examples/smpi/NAS/BT/fortran_io.f

   1
   2 c---------------------------------------------------------------------
   3 c---------------------------------------------------------------------
   4
   5       subroutine setup_btio
   6
   7 c---------------------------------------------------------------------
   8 c---------------------------------------------------------------------
   9
  10       include 'header.h'
  11       include 'mpinpb.h'
  12
  13       character*(128) newfilenm
  14       integer m, ierr
  15
  16       if (node.eq.root) record_length = 40/fortran_rec_sz
  17       call mpi_bcast(record_length, 1, MPI_INTEGER,
  18      >                root, comm_setup, ierr)
  19
  20       open (unit=99, file=filenm,
  21      $      form='unformatted', access='direct',
  22      $      recl=record_length)
  23
  24       do m = 1, 5
  25          xce_sub(m) = 0.d0
  26       end do
  27
  28       idump_sub = 0
  29
  30       return
  31       end
  32
  33
  34 c---------------------------------------------------------------------
  35 c---------------------------------------------------------------------
  36
  37       subroutine output_timestep
  38
  39 c---------------------------------------------------------------------
  40 c---------------------------------------------------------------------
  41       include 'header.h'
  42       include 'mpinpb.h'
  43
  44       integer ix, jio, kio, cio
  45
  46       do cio=1,ncells
  47           do kio=0, cell_size(3,cio)-1
  48               do jio=0, cell_size(2,cio)-1
  49                   iseek=(cell_low(1,cio) +
  50      $                   PROBLEM_SIZE*((cell_low(2,cio)+jio) +
  51      $                   PROBLEM_SIZE*((cell_low(3,cio)+kio) +
  52      $                   PROBLEM_SIZE*idump_sub)))
  53
  54                   do ix=0,cell_size(1,cio)-1
  55                       write(99, rec=iseek+ix+1)
  56      $                      u(1,ix, jio,kio,cio),
  57      $                      u(2,ix, jio,kio,cio),
  58      $                      u(3,ix, jio,kio,cio),
  59      $                      u(4,ix, jio,kio,cio),
  60      $                      u(5,ix, jio,kio,cio)
  61                   enddo
  62               enddo
  63           enddo
  64       enddo
  65
  66       idump_sub = idump_sub + 1
  67       if (rd_interval .gt. 0) then
  68          if (idump_sub .ge. rd_interval) then
  69
  70             call acc_sub_norms(idump+1)
  71
  72             idump_sub = 0
  73          endif
  74       endif
  75
  76       return
  77       end
  78
  79 c---------------------------------------------------------------------
  80 c---------------------------------------------------------------------
  81
  82       subroutine acc_sub_norms(idump_cur)
  83
  84       include 'header.h'
  85       include 'mpinpb.h'
  86
  87       integer idump_cur
  88
  89       integer ix, jio, kio, cio, ii, m, ichunk
  90       double precision xce_single(5)
  91
  92       ichunk = idump_cur - idump_sub + 1
  93       do ii=0, idump_sub-1
  94         do cio=1,ncells
  95           do kio=0, cell_size(3,cio)-1
  96               do jio=0, cell_size(2,cio)-1
  97                   iseek=(cell_low(1,cio) +
  98      $                   PROBLEM_SIZE*((cell_low(2,cio)+jio) +
  99      $                   PROBLEM_SIZE*((cell_low(3,cio)+kio) +
 100      $                   PROBLEM_SIZE*ii)))
 101
 102
 103                   do ix=0,cell_size(1,cio)-1
 104                       read(99, rec=iseek+ix+1)
 105      $                      u(1,ix, jio,kio,cio),
 106      $                      u(2,ix, jio,kio,cio),
 107      $                      u(3,ix, jio,kio,cio),
 108      $                      u(4,ix, jio,kio,cio),
 109      $                      u(5,ix, jio,kio,cio)
 110                   enddo
 111               enddo
 112           enddo
 113         enddo
 114
 115         if (node .eq. root) print *, 'Reading data set ', ii+ichunk
 116
 117         call error_norm(xce_single)
 118         do m = 1, 5
 119            xce_sub(m) = xce_sub(m) + xce_single(m)
 120         end do
 121       enddo
 122
 123       return
 124       end
 125
 126 c---------------------------------------------------------------------
 127 c---------------------------------------------------------------------
 128
 129       subroutine btio_cleanup
 130
 131 c---------------------------------------------------------------------
 132 c---------------------------------------------------------------------
 133
 134       close(unit=99)
 135
 136       return
 137       end
 138
 139 c---------------------------------------------------------------------
 140 c---------------------------------------------------------------------
 141
 142       subroutine accumulate_norms(xce_acc)
 143
 144 c---------------------------------------------------------------------
 145 c---------------------------------------------------------------------
 146       include 'header.h'
 147       include 'mpinpb.h'
 148
 149       double precision xce_acc(5)
 150       integer m
 151
 152       if (rd_interval .gt. 0) goto 20
 153
 154       open (unit=99, file=filenm,
 155      $      form='unformatted', access='direct',
 156      $      recl=record_length)
 157
 158 c     clear the last time step
 159
 160       call clear_timestep
 161
 162 c     read back the time steps and accumulate norms
 163
 164       call acc_sub_norms(idump)
 165
 166       close(unit=99)
 167
 168  20   continue
 169       do m = 1, 5
 170          xce_acc(m) = xce_sub(m) / dble(idump)
 171       end do
 172
 173       return
 174       end