teshsuite/smpi/mpich-test/topol/cartf.f

   1 c
   2 c     From Craig Douglas, modified by Bill Gropp (based on code in Using
   3 c     MPI).
   4 c     This code tests some topology routines and sendrecv with some
   5 c     MPI_PROC_NULL source/destinations.  It should be run with 4
   6 c     processes
   7 c
   8         program main
   9         include 'mpif.h'
  10         integer maxn
  11         parameter (maxn = 35)
  12         double precision  a(maxn,maxn)
  13         integer nx, ny
  14         integer myid, newid, numprocs, comm2d, ierr, stride
  15         integer nbrleft, nbrright, nbrtop, nbrbottom
  16         integer sx, ex, sy, ey
  17         integer dims(2), coords(2)
  18         integer nerrs, toterrs
  19         logical periods(2)
  20         logical verbose
  21         data periods/2*.false./
  22         data verbose/.false./
  23 c
  24         call MPI_INIT( ierr )
  25         call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
  26         call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
  27 c        print *, "Process ", myid, " of ", numprocs, " is alive"
  28         if (numprocs .ne. 4) then
  29            print *, "This test requires exactly four processes"
  30            call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
  31         endif
  32         nx = 8
  33         ny = 4
  34         dims(1) = 0
  35         dims(2) = 0
  36         call MPI_DIMS_CREATE( numprocs, 2, dims, ierr )
  37         call MPI_CART_CREATE( MPI_COMM_WORLD, 2, dims, periods, .true.,
  38      *                      comm2d, ierr )
  39         call MPI_COMM_RANK( comm2d, newid, ierr )
  40         if (verbose) then
  41            print *, "Process ", myid, " of ", numprocs, " is now ",
  42      $          newid
  43         endif
  44         myid = newid
  45         call MPI_Cart_shift( comm2d, 0,  1, nbrleft,   nbrright, ierr )
  46         call MPI_Cart_shift( comm2d, 1,  1, nbrbottom, nbrtop,   ierr )
  47         if (verbose) then
  48             print *, "Process ", myid, " has nbrs", nbrleft, nbrright,
  49      &            nbrtop, nbrbottom
  50         endif
  51         call MPI_Cart_get( comm2d, 2, dims, periods, coords, ierr )
  52         call MPE_DECOMP1D( nx, dims(1), coords(1), sx, ex )
  53         call MPE_DECOMP1D( ny, dims(2), coords(2), sy, ey )
  54 c
  55 c       Fortran allows print to include * and , in the output!
  56 c       So, we use an explicit Format
  57         if ( myid .eq. 0 )
  58      &    print 10, dims(1), dims(2)
  59  10     format( " Dims: ", i4, i4 )
  60         if (verbose) then
  61            print *, "Process ", myid, " has coords of ", coords
  62            print *, "Process ", myid, " has sx,ex/sy,ey ", sx,
  63      $          ex, sy, ey
  64         endif
  65         call MPI_TYPE_VECTOR( ey-sy+3, 1, ex-sx+3,
  66      $                        MPI_DOUBLE_PRECISION, stride, ierr )
  67         call MPI_TYPE_COMMIT( stride, ierr )
  68         call setupv( myid, a, sx, ex, sy, ey )
  69         call MPI_BARRIER( MPI_COMM_WORLD, ierr )
  70 c
  71         call exchng2( myid, a, sx, ex, sy, ey, comm2d, stride,
  72      $                nbrleft, nbrright, nbrtop, nbrbottom )
  73 c
  74 c     Check results
  75 c
  76         call checkval( a, sx, ex, sy, ey, nx, ny, nerrs )
  77 c
  78         call mpi_allreduce( nerrs, toterrs, 1, MPI_INTEGER, MPI_SUM,
  79      $       MPI_COMM_WORLD, ierr )
  80         if (myid .eq. 0) then
  81            print *, " Total errors = ", toterrs
  82         endif
  83         call MPI_TYPE_FREE( stride, ierr )
  84         call MPI_COMM_FREE( comm2d, ierr )
  85 c        call prv( -1, -1, -1, a, sx, ex, sy, ey )
  86         call MPI_FINALIZE(ierr)
  87         end
  88         subroutine MPE_DECOMP1D( n, numprocs, myid, s, e )
  89         integer n, numprocs, myid, s, e
  90         integer nlocal
  91         integer deficit
  92 c
  93         nlocal  = n / numprocs
  94         s       = myid * nlocal + 1
  95         deficit = mod(n,numprocs)
  96         s       = s + min(myid,deficit)
  97         if (myid .lt. deficit) then
  98             nlocal = nlocal + 1
  99         endif
 100         e = s + nlocal - 1
 101         if (e .gt. n .or. myid .eq. numprocs-1) e = n
 102         return
 103         end
 104         subroutine exchng2( myid, v, sx, ex, sy, ey,
 105      $                      comm2d, stride,
 106      $                      nbrleft, nbrright, nbrtop, nbrbottom  )
 107         include "mpif.h"
 108         integer myid, sx, ex, sy, ey, stride
 109         double precision v(sx-1:ex+1,sy-1:ey+1)
 110         integer nbrleft, nbrright, nbrtop, nbrbottom, comm2d
 111         integer status(MPI_STATUS_SIZE), ierr, nx
 112 c
 113         nx = ex - sx + 1
 114 c  These are just like the 1-d versions, except for less data
 115 c        call prv( myid, -1, -1, v, sx, ex, sy, ey )
 116         call MPI_SENDRECV( v(sx,ey),  nx, MPI_DOUBLE_PRECISION,
 117      $                    nbrtop, 0,
 118      $                    v(sx,sy-1), nx, MPI_DOUBLE_PRECISION,
 119      $                    nbrbottom, 0, comm2d, status, ierr )
 120 c        call prv( myid, nbrtop, nbrbottom, v, sx, ex, sy, ey )
 121         call MPI_SENDRECV( v(sx,sy),  nx, MPI_DOUBLE_PRECISION,
 122      $                    nbrbottom, 1,
 123      $                    v(sx,ey+1), nx, MPI_DOUBLE_PRECISION,
 124      $                    nbrtop, 1, comm2d, status, ierr )
 125 c        call prv( myid, nbrbottom, nbrtop, v, sx, ex, sy, ey )
 126 c This uses the "strided" datatype
 127 c       v(ex,sy-1) = -100 - myid
 128         call MPI_SENDRECV( v(ex,sy-1),  1, stride, nbrright,  2,
 129      $                     v(sx-1,sy-1), 1, stride, nbrleft,  2,
 130      $                     comm2d, status, ierr )
 131 c        call prv( myid, nbrright, nbrleft, v, sx, ex, sy, ey )
 132 c       v(sx,sy-1) = -200 - myid
 133         call MPI_SENDRECV( v(sx,sy-1),  1, stride, nbrleft,   3,
 134      $                     v(ex+1,sy-1), 1, stride, nbrright, 3,
 135      $                     comm2d, status, ierr )
 136 c        call prv( myid, nbrleft, nbrright, v, sx, ex, sy, ey )
 137         return
 138         end
 139         subroutine prv( myid, n1, n2, v, sx, ex, sy, ey )
 140 c***********************************************************************
 141 c
 142 c       Print a matrix of numbers.
 143 c
 144 c***********************************************************************
 145         integer myid, n1, n2, sx, ex, sy, ey
 146         double precision  v(sx-1:ex+1,sy-1:ey+1)
 147         integer count, i, j
 148         save count
 149         character*5 fname
 150         data count  / 0 /
 151         if ( myid .lt. 0 ) then
 152             close( 11 )
 153             return
 154         endif
 155         write (fname,'(''foo.'',i1)') myid
 156         if ( count .eq. 0 )
 157      &      open( 11, file=fname, status='UNKNOWN' )
 158         write (11,*) '----------------------------------------'
 159         if ( count .eq. 0 ) then
 160             write (11,*) 'sx ', sx
 161             write (11,*) 'ex ', ex
 162             write (11,*) 'sy ', sy
 163             write (11,*) 'ey ', ey
 164             write (11,*) '----------------------------------------'
 165         endif
 166         count = count + 1
 167         write (11,*) 'count,n1,n2: ', count, n1, n2
 168         do j = ey+1,sy-1,-1
 169             write (11,1) j, (v(i,j), i = sx-1,ex+1)
 170         enddo
 171         return
 172  1      Format( i3, 20f7.0 )
 173 c1      Format( i3, 1p, 20d10.1 )
 174         end
 175         subroutine setupv( myid, v, sx, ex, sy, ey )
 176         integer myid, sx, ex, sy, ey
 177         double precision  v(sx-1:ex+1,sy-1:ey+1)
 178         integer i, j, k
 179 c        write (*,*) 'setupv: ', myid, sx, ex, sy, ey
 180         do j = sy,ey
 181             k = j * 1000.0
 182             do i = sx,ex
 183                 v(i,j)    = i + k
 184                 v(i,sy-1) = 0
 185                 v(i,ey+1) = 0
 186             enddo
 187             v(sx-1,j) = 0
 188             v(ex+1,j) = 0
 189         enddo
 190         return
 191         end
 192 c***********************************************************************
 193       subroutine checkval( a, sx, ex, sy, ey, nx, ny, errs )
 194       integer sx, ex, sy, ey, nx, ny
 195       double precision a(sx-1:ex+1,sy-1:ey+1)
 196       integer i, j, k
 197       integer errs
 198 c
 199 c     Check interior
 200 c
 201       errs = 0
 202       do 10 j=sy,ey
 203          k = j * 1000
 204          do 10 i=sx,ex
 205             if (a(i,j) .ne. i + k ) then
 206                errs = errs + 1
 207                print *, "error at (", i, ",", j, ") = ", a(i,j)
 208             endif
 209  10   continue
 210 c
 211 c     Check the boundaries
 212 c
 213       i = sx - 1
 214       if (sx .eq. 1) then
 215          do 20 j=sy,ey
 216             if (a(i,j) .ne. 0.0) then
 217                errs = errs + 1
 218                print *, "error at (", i, ",", j, ") = ", a(i,j)
 219             endif
 220  20      continue
 221       else
 222          do 30 j=sy,ey
 223             if (a(i,j) .ne. i + j * 1000) then
 224                errs = errs + 1
 225                print *, "error at (", i, ",", j, ") = ", a(i,j)
 226             endif
 227  30      continue
 228       endif
 229       i = ex + 1
 230       if (ex .eq. nx) then
 231          do 40 j=sy,ey
 232             if (a(i,j) .ne. 0.0) then
 233                errs = errs + 1
 234                print *, "error at (", i, ",", j, ") = ", a(i,j)
 235             endif
 236  40      continue
 237       else
 238          do 50 j=sy,ey
 239             if (a(i,j) .ne. i + j * 1000) then
 240                errs = errs + 1
 241                print *, "error at (", i, ",", j, ") = ", a(i,j)
 242             endif
 243  50      continue
 244       endif
 245       j = sy - 1
 246       if (sy .eq. 1) then
 247          do 60 i=sx,ex
 248             if (a(i,j) .ne. 0.0) then
 249                errs = errs + 1
 250                print *, "error at (", i, ",", j, ") = ", a(i,j)
 251             endif
 252  60      continue
 253       else
 254          do 70 i=sx,ex
 255             if (a(i,j) .ne. i + j * 1000) then
 256                errs = errs + 1
 257                print *, "error at (", i, ",", j, ") = ", a(i,j)
 258             endif
 259  70      continue
 260       endif
 261       j = ey + 1
 262       if (ey .eq. ny) then
 263          do 80 i=sx,ex
 264             if (a(i,j) .ne. 0.0) then
 265                errs = errs + 1
 266                print *, "error at (", i, ",", j, ") = ", a(i,j)
 267             endif
 268  80      continue
 269       else
 270          do 90 i=sx,ex
 271             if (a(i,j) .ne. i + j * 1000) then
 272                errs = errs + 1
 273                print *, "error at (", i, ",", j, ") = ", a(i,j)
 274             endif
 275  90      continue
 276       endif
 277       return
 278       end