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