examples/smpi/NAS/BT/full_mpiio.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       integer ierr
  14       integer mstatus(MPI_STATUS_SIZE)
  15       integer sizes(4), starts(4), subsizes(4)
  16       integer cell_btype(maxcells), cell_ftype(maxcells)
  17       integer cell_blength(maxcells)
  18       integer info
  19       character*20 cb_nodes, cb_size
  20       integer c, m
  21       integer cell_disp(maxcells)
  22
  23        call mpi_bcast(collbuf_nodes, 1, MPI_INTEGER,
  24      >                root, comm_setup, ierr)
  25
  26        call mpi_bcast(collbuf_size, 1, MPI_INTEGER,
  27      >                root, comm_setup, ierr)
  28
  29        if (collbuf_nodes .eq. 0) then
  30           info = MPI_INFO_NULL
  31        else
  32           write (cb_nodes,*) collbuf_nodes
  33           write (cb_size,*) collbuf_size
  34           call MPI_Info_create(info, ierr)
  35           call MPI_Info_set(info, 'cb_nodes', cb_nodes, ierr)
  36           call MPI_Info_set(info, 'cb_buffer_size', cb_size, ierr)
  37           call MPI_Info_set(info, 'collective_buffering', 'true', ierr)
  38        endif
  39
  40        call MPI_Type_contiguous(5, MPI_DOUBLE_PRECISION,
  41      $                          element, ierr)
  42        call MPI_Type_commit(element, ierr)
  43        call MPI_Type_extent(element, eltext, ierr)
  44
  45        do  c = 1, ncells
  46 c
  47 c Outer array dimensions ar same for every cell
  48 c
  49            sizes(1) = IMAX+4
  50            sizes(2) = JMAX+4
  51            sizes(3) = KMAX+4
  52 c
  53 c 4th dimension is cell number, total of maxcells cells
  54 c
  55            sizes(4) = maxcells
  56 c
  57 c Internal dimensions of cells can differ slightly between cells
  58 c
  59            subsizes(1) = cell_size(1, c)
  60            subsizes(2) = cell_size(2, c)
  61            subsizes(3) = cell_size(3, c)
  62 c
  63 c Cell is 4th dimension, 1 cell per cell type to handle varying
  64 c cell sub-array sizes
  65 c
  66            subsizes(4) = 1
  67
  68 c
  69 c type constructors use 0-based start addresses
  70 c
  71            starts(1) = 2
  72            starts(2) = 2
  73            starts(3) = 2
  74            starts(4) = c-1
  75
  76 c
  77 c Create buftype for a cell
  78 c
  79            call MPI_Type_create_subarray(4, sizes, subsizes,
  80      $          starts, MPI_ORDER_FORTRAN, element,
  81      $          cell_btype(c), ierr)
  82 c
  83 c block length and displacement for joining cells -
  84 c 1 cell buftype per block, cell buftypes have own displacment
  85 c generated from cell number (4th array dimension)
  86 c
  87            cell_blength(c) = 1
  88            cell_disp(c) = 0
  89
  90        enddo
  91 c
  92 c Create combined buftype for all cells
  93 c
  94        call MPI_Type_struct(ncells, cell_blength, cell_disp,
  95      $            cell_btype, combined_btype, ierr)
  96        call MPI_Type_commit(combined_btype, ierr)
  97
  98        do  c = 1, ncells
  99 c
 100 c Entire array size
 101 c
 102            sizes(1) = PROBLEM_SIZE
 103            sizes(2) = PROBLEM_SIZE
 104            sizes(3) = PROBLEM_SIZE
 105
 106 c
 107 c Size of c'th cell
 108 c
 109            subsizes(1) = cell_size(1, c)
 110            subsizes(2) = cell_size(2, c)
 111            subsizes(3) = cell_size(3, c)
 112
 113 c
 114 c Starting point in full array of c'th cell
 115 c
 116            starts(1) = cell_low(1,c)
 117            starts(2) = cell_low(2,c)
 118            starts(3) = cell_low(3,c)
 119
 120            call MPI_Type_create_subarray(3, sizes, subsizes,
 121      $          starts, MPI_ORDER_FORTRAN,
 122      $          element, cell_ftype(c), ierr)
 123            cell_blength(c) = 1
 124            cell_disp(c) = 0
 125        enddo
 126
 127        call MPI_Type_struct(ncells, cell_blength, cell_disp,
 128      $            cell_ftype, combined_ftype, ierr)
 129        call MPI_Type_commit(combined_ftype, ierr)
 130
 131        iseek=0
 132        if (node .eq. root) then
 133           call MPI_File_delete(filenm, MPI_INFO_NULL, ierr)
 134        endif
 135
 136
 137       call MPI_Barrier(comm_solve, ierr)
 138
 139        call MPI_File_open(comm_solve,
 140      $          filenm,
 141      $          MPI_MODE_RDWR+MPI_MODE_CREATE,
 142      $          MPI_INFO_NULL, fp, ierr)
 143
 144        if (ierr .ne. MPI_SUCCESS) then
 145                 print *, 'Error opening file'
 146                 stop
 147        endif
 148
 149         call MPI_File_set_view(fp, iseek, element,
 150      $          combined_ftype, 'native', info, ierr)
 151
 152        if (ierr .ne. MPI_SUCCESS) then
 153                 print *, 'Error setting file view'
 154                 stop
 155        endif
 156
 157       do m = 1, 5
 158          xce_sub(m) = 0.d0
 159       end do
 160
 161       idump_sub = 0
 162
 163
 164       return
 165       end
 166
 167 c---------------------------------------------------------------------
 168 c---------------------------------------------------------------------
 169
 170       subroutine output_timestep
 171
 172 c---------------------------------------------------------------------
 173 c---------------------------------------------------------------------
 174       include 'header.h'
 175       include 'mpinpb.h'
 176
 177       integer mstatus(MPI_STATUS_SIZE)
 178       integer ierr
 179
 180       call MPI_File_write_at_all(fp, iseek, u,
 181      $                           1, combined_btype, mstatus, ierr)
 182       if (ierr .ne. MPI_SUCCESS) then
 183           print *, 'Error writing to file'
 184           stop
 185       endif
 186
 187       call MPI_Type_size(combined_btype, iosize, ierr)
 188       iseek = iseek + iosize/eltext
 189
 190       idump_sub = idump_sub + 1
 191       if (rd_interval .gt. 0) then
 192          if (idump_sub .ge. rd_interval) then
 193
 194             iseek = 0
 195             call acc_sub_norms(idump+1)
 196
 197             iseek = 0
 198             idump_sub = 0
 199          endif
 200       endif
 201
 202       return
 203       end
 204
 205 c---------------------------------------------------------------------
 206 c---------------------------------------------------------------------
 207
 208       subroutine acc_sub_norms(idump_cur)
 209
 210       include 'header.h'
 211       include 'mpinpb.h'
 212
 213       integer idump_cur
 214
 215       integer ii, m, ichunk
 216       integer ierr
 217       integer mstatus(MPI_STATUS_SIZE)
 218       double precision xce_single(5)
 219
 220       ichunk = idump_cur - idump_sub + 1
 221       do ii=0, idump_sub-1
 222
 223         call MPI_File_read_at_all(fp, iseek, u,
 224      $                           1, combined_btype, mstatus, ierr)
 225         if (ierr .ne. MPI_SUCCESS) then
 226            print *, 'Error reading back file'
 227            call MPI_File_close(fp, ierr)
 228            stop
 229         endif
 230
 231         call MPI_Type_size(combined_btype, iosize, ierr)
 232         iseek = iseek + iosize/eltext
 233
 234         if (node .eq. root) print *, 'Reading data set ', ii+ichunk
 235
 236         call error_norm(xce_single)
 237         do m = 1, 5
 238            xce_sub(m) = xce_sub(m) + xce_single(m)
 239         end do
 240       enddo
 241
 242       return
 243       end
 244
 245 c---------------------------------------------------------------------
 246 c---------------------------------------------------------------------
 247
 248       subroutine btio_cleanup
 249
 250 c---------------------------------------------------------------------
 251 c---------------------------------------------------------------------
 252       include 'header.h'
 253       include 'mpinpb.h'
 254
 255       integer ierr
 256
 257       call MPI_File_close(fp, ierr)
 258
 259       return
 260       end
 261
 262 c---------------------------------------------------------------------
 263 c---------------------------------------------------------------------
 264
 265
 266       subroutine accumulate_norms(xce_acc)
 267
 268 c---------------------------------------------------------------------
 269 c---------------------------------------------------------------------
 270
 271       include 'header.h'
 272       include 'mpinpb.h'
 273
 274       double precision xce_acc(5)
 275       integer m, ierr
 276
 277       if (rd_interval .gt. 0) goto 20
 278
 279       call MPI_File_open(comm_solve,
 280      $          filenm,
 281      $          MPI_MODE_RDONLY,
 282      $          MPI_INFO_NULL,
 283      $          fp,
 284      $          ierr)
 285
 286       iseek = 0
 287       call MPI_File_set_view(fp, iseek, element, combined_ftype,
 288      $          'native', MPI_INFO_NULL, ierr)
 289
 290 c     clear the last time step
 291
 292       call clear_timestep
 293
 294 c     read back the time steps and accumulate norms
 295
 296       call acc_sub_norms(idump)
 297
 298       call MPI_File_close(fp, ierr)
 299
 300  20   continue
 301       do m = 1, 5
 302          xce_acc(m) = xce_sub(m) / dble(idump)
 303       end do
 304
 305       return
 306       end
 307