examples/smpi/NAS/SP/copy_faces.f

   1
   2 c---------------------------------------------------------------------
   3 c---------------------------------------------------------------------
   4
   5        subroutine copy_faces
   6
   7 c---------------------------------------------------------------------
   8 c---------------------------------------------------------------------
   9
  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
  36        ss(0) = start_send_east
  37        ss(1) = start_send_west
  38        ss(2) = start_send_north
  39        ss(3) = start_send_south
  40        ss(4) = start_send_top
  41        ss(5) = start_send_bottom
  42
  43        sr(0) = start_recv_east
  44        sr(1) = start_recv_west
  45        sr(2) = start_recv_north
  46        sr(3) = start_recv_south
  47        sr(4) = start_recv_top
  48        sr(5) = start_recv_bottom
  49
  50        b_size(0) = east_size
  51        b_size(1) = west_size
  52        b_size(2) = north_size
  53        b_size(3) = south_size
  54        b_size(4) = top_size
  55        b_size(5) = bottom_size
  56
  57 c---------------------------------------------------------------------
  58 c because the difference stencil for the diagonalized scheme is
  59 c orthogonal, we do not have to perform the staged copying of faces,
  60 c but can send all face information simultaneously to the neighboring
  61 c cells in all directions
  62 c---------------------------------------------------------------------
  63        p0 = 0
  64        p1 = 0
  65        p2 = 0
  66        p3 = 0
  67        p4 = 0
  68        p5 = 0
  69
  70        do  c = 1, ncells
  71           do   m = 1, 5
  72
  73 c---------------------------------------------------------------------
  74 c            fill the buffer to be sent to eastern neighbors (i-dir)
  75 c---------------------------------------------------------------------
  76              if (cell_coord(1,c) .ne. ncells) then
  77                 do   k = 0, cell_size(3,c)-1
  78                    do   j = 0, cell_size(2,c)-1
  79                       do   i = cell_size(1,c)-2, cell_size(1,c)-1
  80                          out_buffer(ss(0)+p0) = u(i,j,k,m,c)
  81                          p0 = p0 + 1
  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                          out_buffer(ss(1)+p1) = u(i,j,k,m,c)
  95                          p1 = p1 + 1
  96                       end do
  97                    end do
  98                 end do
  99
 100
 101              endif
 102
 103 c---------------------------------------------------------------------
 104 c            fill the buffer to be sent to northern neighbors (j_dir)
 105 c---------------------------------------------------------------------
 106              if (cell_coord(2,c) .ne. ncells) then
 107                 do   k = 0, cell_size(3,c)-1
 108                    do   j = cell_size(2,c)-2, cell_size(2,c)-1
 109                       do   i = 0, cell_size(1,c)-1
 110                          out_buffer(ss(2)+p2) = u(i,j,k,m,c)
 111                          p2 = p2 + 1
 112                       end do
 113                    end do
 114                 end do
 115              endif
 116
 117 c---------------------------------------------------------------------
 118 c            fill the buffer to be sent to southern neighbors
 119 c---------------------------------------------------------------------
 120              if (cell_coord(2,c).ne. 1) then
 121                 do   k = 0, cell_size(3,c)-1
 122                    do   j = 0, 1
 123                       do   i = 0, cell_size(1,c)-1
 124                          out_buffer(ss(3)+p3) = u(i,j,k,m,c)
 125                          p3 = p3 + 1
 126                       end do
 127                    end do
 128                 end do
 129              endif
 130
 131 c---------------------------------------------------------------------
 132 c            fill the buffer to be sent to top neighbors (k-dir)
 133 c---------------------------------------------------------------------
 134              if (cell_coord(3,c) .ne. ncells) then
 135                 do   k = cell_size(3,c)-2, cell_size(3,c)-1
 136                    do   j = 0, cell_size(2,c)-1
 137                       do   i = 0, cell_size(1,c)-1
 138                          out_buffer(ss(4)+p4) = u(i,j,k,m,c)
 139                          p4 = p4 + 1
 140                       end do
 141                    end do
 142                 end do
 143              endif
 144
 145 c---------------------------------------------------------------------
 146 c            fill the buffer to be sent to bottom neighbors
 147 c---------------------------------------------------------------------
 148              if (cell_coord(3,c).ne. 1) then
 149                  do    k=0, 1
 150                     do   j = 0, cell_size(2,c)-1
 151                        do   i = 0, cell_size(1,c)-1
 152                           out_buffer(ss(5)+p5) = u(i,j,k,m,c)
 153                           p5 = p5 + 1
 154                        end do
 155                     end do
 156                  end do
 157               endif
 158
 159 c---------------------------------------------------------------------
 160 c          m loop
 161 c---------------------------------------------------------------------
 162            end do
 163
 164 c---------------------------------------------------------------------
 165 c       cell loop
 166 c---------------------------------------------------------------------
 167         end do
 168
 169        call mpi_irecv(in_buffer(sr(0)), b_size(0),
 170      >                dp_type, successor(1), WEST,
 171      >                comm_rhs, requests(0), error)
 172        call mpi_irecv(in_buffer(sr(1)), b_size(1),
 173      >                dp_type, predecessor(1), EAST,
 174      >                comm_rhs, requests(1), error)
 175        call mpi_irecv(in_buffer(sr(2)), b_size(2),
 176      >                dp_type, successor(2), SOUTH,
 177      >                comm_rhs, requests(2), error)
 178        call mpi_irecv(in_buffer(sr(3)), b_size(3),
 179      >                dp_type, predecessor(2), NORTH,
 180      >                comm_rhs, requests(3), error)
 181        call mpi_irecv(in_buffer(sr(4)), b_size(4),
 182      >                dp_type, successor(3), BOTTOM,
 183      >                comm_rhs, requests(4), error)
 184        call mpi_irecv(in_buffer(sr(5)), b_size(5),
 185      >                dp_type, predecessor(3), TOP,
 186      >                comm_rhs, requests(5), error)
 187
 188        call mpi_isend(out_buffer(ss(0)), b_size(0),
 189      >                dp_type, successor(1),   EAST,
 190      >                comm_rhs, requests(6), error)
 191        call mpi_isend(out_buffer(ss(1)), b_size(1),
 192      >                dp_type, predecessor(1), WEST,
 193      >                comm_rhs, requests(7), error)
 194        call mpi_isend(out_buffer(ss(2)), b_size(2),
 195      >                dp_type,successor(2),   NORTH,
 196      >                comm_rhs, requests(8), error)
 197        call mpi_isend(out_buffer(ss(3)), b_size(3),
 198      >                dp_type,predecessor(2), SOUTH,
 199      >                comm_rhs, requests(9), error)
 200        call mpi_isend(out_buffer(ss(4)), b_size(4),
 201      >                dp_type,successor(3),   TOP,
 202      >                comm_rhs,   requests(10), error)
 203        call mpi_isend(out_buffer(ss(5)), b_size(5),
 204      >                dp_type,predecessor(3), BOTTOM,
 205      >                comm_rhs,requests(11), error)
 206
 207
 208        call mpi_waitall(12, requests, statuses, error)
 209
 210 c---------------------------------------------------------------------
 211 c unpack the data that has just been received;
 212 c---------------------------------------------------------------------
 213        p0 = 0
 214        p1 = 0
 215        p2 = 0
 216        p3 = 0
 217        p4 = 0
 218        p5 = 0
 219
 220        do   c = 1, ncells
 221           do    m = 1, 5
 222
 223              if (cell_coord(1,c) .ne. 1) then
 224                 do   k = 0, cell_size(3,c)-1
 225                    do   j = 0, cell_size(2,c)-1
 226                       do   i = -2, -1
 227                          u(i,j,k,m,c) = in_buffer(sr(1)+p0)
 228                          p0 = p0 + 1
 229                       end do
 230                    end do
 231                 end do
 232              endif
 233
 234              if (cell_coord(1,c) .ne. ncells) then
 235                 do  k = 0, cell_size(3,c)-1
 236                    do  j = 0, cell_size(2,c)-1
 237                       do  i = cell_size(1,c), cell_size(1,c)+1
 238                          u(i,j,k,m,c) = in_buffer(sr(0)+p1)
 239                          p1 = p1 + 1
 240                       end do
 241                    end do
 242                 end do
 243              end if
 244
 245              if (cell_coord(2,c) .ne. 1) then
 246                 do  k = 0, cell_size(3,c)-1
 247                    do   j = -2, -1
 248                       do  i = 0, cell_size(1,c)-1
 249                          u(i,j,k,m,c) = in_buffer(sr(3)+p2)
 250                          p2 = p2 + 1
 251                       end do
 252                    end do
 253                 end do
 254
 255              endif
 256
 257              if (cell_coord(2,c) .ne. ncells) then
 258                 do  k = 0, cell_size(3,c)-1
 259                    do   j = cell_size(2,c), cell_size(2,c)+1
 260                       do  i = 0, cell_size(1,c)-1
 261                          u(i,j,k,m,c) = in_buffer(sr(2)+p3)
 262                          p3 = p3 + 1
 263                       end do
 264                    end do
 265                 end do
 266              endif
 267
 268              if (cell_coord(3,c) .ne. 1) then
 269                 do  k = -2, -1
 270                    do  j = 0, cell_size(2,c)-1
 271                       do  i = 0, cell_size(1,c)-1
 272                          u(i,j,k,m,c) = in_buffer(sr(5)+p4)
 273                          p4 = p4 + 1
 274                       end do
 275                    end do
 276                 end do
 277              endif
 278
 279              if (cell_coord(3,c) .ne. ncells) then
 280                 do  k = cell_size(3,c), cell_size(3,c)+1
 281                    do  j = 0, cell_size(2,c)-1
 282                       do  i = 0, cell_size(1,c)-1
 283                          u(i,j,k,m,c) = in_buffer(sr(4)+p5)
 284                          p5 = p5 + 1
 285                       end do
 286                    end do
 287                 end do
 288              endif
 289
 290 c---------------------------------------------------------------------
 291 c         m loop
 292 c---------------------------------------------------------------------
 293           end do
 294
 295 c---------------------------------------------------------------------
 296 c      cells loop
 297 c---------------------------------------------------------------------
 298        end do
 299
 300 c---------------------------------------------------------------------
 301 c now that we have all the data, compute the rhs
 302 c---------------------------------------------------------------------
 303        call compute_rhs
 304
 305        return
 306        end