examples/smpi/NAS/BT/copy_faces.f

   1 c---------------------------------------------------------------------
   2 c---------------------------------------------------------------------
   3
   4       subroutine copy_faces
   5
   6 c---------------------------------------------------------------------
   7 c---------------------------------------------------------------------
   8
   9 c---------------------------------------------------------------------
  10 c
  11 c This function copies the face values of a variable defined on a set
  12 c of cells to the overlap locations of the adjacent sets of cells.
  13 c Because a set of cells interfaces in each direction with exactly one
  14 c other set, we only need to fill six different buffers. We could try to
  15 c overlap communication with computation, by computing
  16 c some internal values while communicating boundary values, but this
  17 c adds so much overhead that it's not clearly useful.
  18 c---------------------------------------------------------------------
  19
  20       include 'header.h'
  21       include 'mpinpb.h'
  22
  23       integer i, j, k, c, m, requests(0:11), p0, p1,
  24      >     p2, p3, p4, p5, b_size(0:5), ss(0:5),
  25      >     sr(0:5), error, statuses(MPI_STATUS_SIZE, 0:11)
  26
  27 c---------------------------------------------------------------------
  28 c     exit immediately if there are no faces to be copied
  29 c---------------------------------------------------------------------
  30       if (no_nodes .eq. 1) then
  31          call compute_rhs
  32          return
  33       endif
  34
  35       ss(0) = start_send_east
  36       ss(1) = start_send_west
  37       ss(2) = start_send_north
  38       ss(3) = start_send_south
  39       ss(4) = start_send_top
  40       ss(5) = start_send_bottom
  41
  42       sr(0) = start_recv_east
  43       sr(1) = start_recv_west
  44       sr(2) = start_recv_north
  45       sr(3) = start_recv_south
  46       sr(4) = start_recv_top
  47       sr(5) = start_recv_bottom
  48
  49       b_size(0) = east_size
  50       b_size(1) = west_size
  51       b_size(2) = north_size
  52       b_size(3) = south_size
  53       b_size(4) = top_size
  54       b_size(5) = bottom_size
  55
  56 c---------------------------------------------------------------------
  57 c     because the difference stencil for the diagonalized scheme is
  58 c     orthogonal, we do not have to perform the staged copying of faces,
  59 c     but can send all face information simultaneously to the neighboring
  60 c     cells in all directions
  61 c---------------------------------------------------------------------
  62       p0 = 0
  63       p1 = 0
  64       p2 = 0
  65       p3 = 0
  66       p4 = 0
  67       p5 = 0
  68
  69       do  c = 1, ncells
  70
  71 c---------------------------------------------------------------------
  72 c     fill the buffer to be sent to eastern neighbors (i-dir)
  73 c---------------------------------------------------------------------
  74          if (cell_coord(1,c) .ne. ncells) then
  75             do   k = 0, cell_size(3,c)-1
  76                do   j = 0, cell_size(2,c)-1
  77                   do   i = cell_size(1,c)-2, cell_size(1,c)-1
  78                      do   m = 1, 5
  79                         out_buffer(ss(0)+p0) = u(m,i,j,k,c)
  80                         p0 = p0 + 1
  81                      end do
  82                   end do
  83                end do
  84             end do
  85          endif
  86
  87 c---------------------------------------------------------------------
  88 c     fill the buffer to be sent to western neighbors
  89 c---------------------------------------------------------------------
  90          if (cell_coord(1,c) .ne. 1) then
  91             do   k = 0, cell_size(3,c)-1
  92                do   j = 0, cell_size(2,c)-1
  93                   do   i = 0, 1
  94                      do   m = 1, 5
  95                         out_buffer(ss(1)+p1) = u(m,i,j,k,c)
  96                         p1 = p1 + 1
  97                      end do
  98                   end do
  99                end do
 100             end do
 101
 102          endif
 103
 104 c---------------------------------------------------------------------
 105 c     fill the buffer to be sent to northern neighbors (j_dir)
 106 c---------------------------------------------------------------------
 107          if (cell_coord(2,c) .ne. ncells) then
 108             do   k = 0, cell_size(3,c)-1
 109                do   j = cell_size(2,c)-2, cell_size(2,c)-1
 110                   do   i = 0, cell_size(1,c)-1
 111                      do   m = 1, 5
 112                         out_buffer(ss(2)+p2) = u(m,i,j,k,c)
 113                         p2 = p2 + 1
 114                      end do
 115                   end do
 116                end do
 117             end do
 118          endif
 119
 120 c---------------------------------------------------------------------
 121 c     fill the buffer to be sent to southern neighbors
 122 c---------------------------------------------------------------------
 123          if (cell_coord(2,c).ne. 1) then
 124             do   k = 0, cell_size(3,c)-1
 125                do   j = 0, 1
 126                   do   i = 0, cell_size(1,c)-1
 127                      do   m = 1, 5
 128                         out_buffer(ss(3)+p3) = u(m,i,j,k,c)
 129                         p3 = p3 + 1
 130                      end do
 131                   end do
 132                end do
 133             end do
 134          endif
 135
 136 c---------------------------------------------------------------------
 137 c     fill the buffer to be sent to top neighbors (k-dir)
 138 c---------------------------------------------------------------------
 139          if (cell_coord(3,c) .ne. ncells) then
 140             do   k = cell_size(3,c)-2, cell_size(3,c)-1
 141                do   j = 0, cell_size(2,c)-1
 142                   do   i = 0, cell_size(1,c)-1
 143                      do   m = 1, 5
 144                         out_buffer(ss(4)+p4) = u(m,i,j,k,c)
 145                         p4 = p4 + 1
 146                      end do
 147                   end do
 148                end do
 149             end do
 150          endif
 151
 152 c---------------------------------------------------------------------
 153 c     fill the buffer to be sent to bottom neighbors
 154 c---------------------------------------------------------------------
 155          if (cell_coord(3,c).ne. 1) then
 156             do    k=0, 1
 157                do   j = 0, cell_size(2,c)-1
 158                   do   i = 0, cell_size(1,c)-1
 159                      do   m = 1, 5
 160                         out_buffer(ss(5)+p5) = u(m,i,j,k,c)
 161                         p5 = p5 + 1
 162                      end do
 163                   end do
 164                end do
 165             end do
 166          endif
 167
 168 c---------------------------------------------------------------------
 169 c     cell loop
 170 c---------------------------------------------------------------------
 171       end do
 172
 173       call mpi_irecv(in_buffer(sr(0)), b_size(0),
 174      >     dp_type, successor(1), WEST,
 175      >     comm_rhs, requests(0), error)
 176       call mpi_irecv(in_buffer(sr(1)), b_size(1),
 177      >     dp_type, predecessor(1), EAST,
 178      >     comm_rhs, requests(1), error)
 179       call mpi_irecv(in_buffer(sr(2)), b_size(2),
 180      >     dp_type, successor(2), SOUTH,
 181      >     comm_rhs, requests(2), error)
 182       call mpi_irecv(in_buffer(sr(3)), b_size(3),
 183      >     dp_type, predecessor(2), NORTH,
 184      >     comm_rhs, requests(3), error)
 185       call mpi_irecv(in_buffer(sr(4)), b_size(4),
 186      >     dp_type, successor(3), BOTTOM,
 187      >     comm_rhs, requests(4), error)
 188       call mpi_irecv(in_buffer(sr(5)), b_size(5),
 189      >     dp_type, predecessor(3), TOP,
 190      >     comm_rhs, requests(5), error)
 191
 192       call mpi_isend(out_buffer(ss(0)), b_size(0),
 193      >     dp_type, successor(1),   EAST,
 194      >     comm_rhs, requests(6), error)
 195       call mpi_isend(out_buffer(ss(1)), b_size(1),
 196      >     dp_type, predecessor(1), WEST,
 197      >     comm_rhs, requests(7), error)
 198       call mpi_isend(out_buffer(ss(2)), b_size(2),
 199      >     dp_type,successor(2),   NORTH,
 200      >     comm_rhs, requests(8), error)
 201       call mpi_isend(out_buffer(ss(3)), b_size(3),
 202      >     dp_type,predecessor(2), SOUTH,
 203      >     comm_rhs, requests(9), error)
 204       call mpi_isend(out_buffer(ss(4)), b_size(4),
 205      >     dp_type,successor(3),   TOP,
 206      >     comm_rhs,   requests(10), error)
 207       call mpi_isend(out_buffer(ss(5)), b_size(5),
 208      >     dp_type,predecessor(3), BOTTOM,
 209      >     comm_rhs,requests(11), error)
 210
 211
 212       call mpi_waitall(12, requests, statuses, error)
 213
 214 c---------------------------------------------------------------------
 215 c     unpack the data that has just been received;
 216 c---------------------------------------------------------------------
 217       p0 = 0
 218       p1 = 0
 219       p2 = 0
 220       p3 = 0
 221       p4 = 0
 222       p5 = 0
 223
 224       do   c = 1, ncells
 225
 226          if (cell_coord(1,c) .ne. 1) then
 227             do   k = 0, cell_size(3,c)-1
 228                do   j = 0, cell_size(2,c)-1
 229                   do   i = -2, -1
 230                      do   m = 1, 5
 231                         u(m,i,j,k,c) = in_buffer(sr(1)+p0)
 232                         p0 = p0 + 1
 233                      end do
 234                   end do
 235                end do
 236             end do
 237          endif
 238
 239          if (cell_coord(1,c) .ne. ncells) then
 240             do  k = 0, cell_size(3,c)-1
 241                do  j = 0, cell_size(2,c)-1
 242                   do  i = cell_size(1,c), cell_size(1,c)+1
 243                      do   m = 1, 5
 244                         u(m,i,j,k,c) = in_buffer(sr(0)+p1)
 245                         p1 = p1 + 1
 246                      end do
 247                   end do
 248                end do
 249             end do
 250          end if
 251
 252          if (cell_coord(2,c) .ne. 1) then
 253             do  k = 0, cell_size(3,c)-1
 254                do   j = -2, -1
 255                   do  i = 0, cell_size(1,c)-1
 256                      do   m = 1, 5
 257                         u(m,i,j,k,c) = in_buffer(sr(3)+p2)
 258                         p2 = p2 + 1
 259                      end do
 260                   end do
 261                end do
 262             end do
 263
 264          endif
 265
 266          if (cell_coord(2,c) .ne. ncells) then
 267             do  k = 0, cell_size(3,c)-1
 268                do   j = cell_size(2,c), cell_size(2,c)+1
 269                   do  i = 0, cell_size(1,c)-1
 270                      do   m = 1, 5
 271                         u(m,i,j,k,c) = in_buffer(sr(2)+p3)
 272                         p3 = p3 + 1
 273                      end do
 274                   end do
 275                end do
 276             end do
 277          endif
 278
 279          if (cell_coord(3,c) .ne. 1) then
 280             do  k = -2, -1
 281                do  j = 0, cell_size(2,c)-1
 282                   do  i = 0, cell_size(1,c)-1
 283                      do   m = 1, 5
 284                         u(m,i,j,k,c) = in_buffer(sr(5)+p4)
 285                         p4 = p4 + 1
 286                      end do
 287                   end do
 288                end do
 289             end do
 290          endif
 291
 292          if (cell_coord(3,c) .ne. ncells) then
 293             do  k = cell_size(3,c), cell_size(3,c)+1
 294                do  j = 0, cell_size(2,c)-1
 295                   do  i = 0, cell_size(1,c)-1
 296                      do   m = 1, 5
 297                         u(m,i,j,k,c) = in_buffer(sr(4)+p5)
 298                         p5 = p5 + 1
 299                      end do
 300                   end do
 301                end do
 302             end do
 303          endif
 304
 305 c---------------------------------------------------------------------
 306 c     cells loop
 307 c---------------------------------------------------------------------
 308       end do
 309
 310 c---------------------------------------------------------------------
 311 c     do the rest of the rhs that uses the copied face values
 312 c---------------------------------------------------------------------
 313       call compute_rhs
 314
 315       return
 316       end