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

   1         program main
   2         include 'mpif.h'
   3
   4
   5         integer NUM_DIMS
   6         parameter (NUM_DIMS=2)
   7
   8         integer ierr
   9         integer errors, toterrors
  10         integer comm_temp, comm_cart, new_comm
  11         integer size, rank, i
  12         logical periods(NUM_DIMS)
  13         integer dims(NUM_DIMS)
  14         integer coords(NUM_DIMS)
  15         integer new_coords(NUM_DIMS)
  16         logical remain_dims(NUM_DIMS)
  17         integer newnewrank
  18         logical reorder
  19         integer topo_status
  20         integer ndims
  21         integer new_rank
  22
  23         integer source, dest
  24
  25         errors=0
  26         call MPI_INIT (ierr)
  27
  28         call MPI_COMM_RANK( MPI_COMM_WORLD, rank, ierr)
  29         call MPI_COMM_SIZE (MPI_COMM_WORLD, size, ierr )
  30
  31 c
  32 c    Clear dims array and get dims for topology
  33 c
  34         do 100 i=1,NUM_DIMS
  35                 dims(i)=0
  36                 periods(i)= .false.
  37 100     continue
  38         call MPI_DIMS_CREATE( size, NUM_DIMS, dims, ierr)
  39
  40 c
  41 c     Make a new communicator with a topology
  42 c
  43         reorder = .true.
  44         call MPI_CART_CREATE( MPI_COMM_WORLD, 2, dims, periods,
  45      $          reorder, comm_temp, ierr)
  46         call MPI_COMM_DUP (comm_temp, comm_cart, ierr)
  47
  48 c
  49 c     Determine the status of the new communicator
  50 c
  51         call MPI_TOPO_TEST (comm_cart, topo_status, ierr)
  52         IF (topo_status .ne. MPI_CART) then
  53            print *, "Topo_status is not MPI_CART"
  54            errors=errors+1
  55         ENDIF
  56
  57 c
  58 c     How many dims do we have?
  59 c
  60         call MPI_CARTDIM_GET( comm_cart, ndims, ierr)
  61         if (ndims .ne. NUM_DIMS ) then
  62            print *, "ndims (", ndims, ") is not NUM_DIMS (", NUMDIMS,
  63      $          ")"
  64            errors = errors+1
  65         ENDIF
  66
  67 c
  68 c     Get the topology, does it agree with what we put in?
  69 c
  70         do 500 i=1,NUM_DIMS
  71                 dims(i)=0
  72                 periods(i)=.false.
  73 500     continue
  74         call MPI_CART_GET( comm_cart, NUM_DIMS, dims, periods, coords,
  75      $       ierr)
  76 c
  77 c     Does the mapping from coords to rank work?
  78 c
  79         call MPI_CART_RANK( comm_cart, coords, new_rank, ierr)
  80         if (new_rank .ne. rank ) then
  81            print *, "New_rank = ", new_rank, " is not rank (", rank, ")"
  82            errors=errors+1
  83         endif
  84
  85 c
  86 c     Does the mapping from rank to coords work
  87 c
  88         call MPI_CART_COORDS( comm_cart, rank, NUM_DIMS, new_coords ,
  89      $       ierr)
  90         do 600 i=1,NUM_DIMS
  91                 if (coords(i) .ne. new_coords(i)) then
  92                    print *, "coords(",i,") = ", coords(i), " not = ",
  93      $                  new_coords(i)
  94                    errors=errors + 1
  95                 endif
  96 600     continue
  97
  98 c
  99 c     Let's shift in each dimension and see how it works!
 100 c     Because it's late and I'm tired, I'm not making this
 101 c     automatically test itself.
 102 c
 103         do 700 i=1,NUM_DIMS
 104            call MPI_CART_SHIFT( comm_cart, (i-1), 1, source, dest, ierr)
 105 c           print *, '[', rank, '] shifting 1 in the ', (i-1),
 106 c     $                 ' dimension'
 107 c           print *, '[', rank, ']     source = ', source,
 108 c     $                 ' dest = ', dest
 109
 110 700     continue
 111
 112 c
 113 c     Subdivide
 114 c
 115         remain_dims(1)=.false.
 116         do 800 i=2,NUM_DIMS
 117                 remain_dims(i)=.true.
 118 800     continue
 119         call MPI_CART_SUB( comm_cart, remain_dims, new_comm, ierr)
 120
 121 c
 122 c     Determine the status of the new communicator
 123 c
 124         call MPI_TOPO_TEST( new_comm, topo_status, ierr )
 125         if (topo_status .ne. MPI_CART ) then
 126            print *, "Topo_status of new comm is not MPI_CART"
 127            errors=errors+1
 128         endif
 129
 130 c
 131 c     How many dims do we have?
 132 c
 133         call MPI_CARTDIM_GET( new_comm, ndims, ierr)
 134         if (ndims .ne. NUM_DIMS-1 ) then
 135            print *, "ndims (", ndims, ") is not NUM_DIMS-1"
 136            errors = errors+1
 137         endif
 138
 139 c
 140 c     Get the topology, does it agree with what we put in?
 141 c
 142         do 900 i=1,NUM_DIMS-1
 143                 dims(i)=0
 144                 periods(i)=.false.
 145 900     continue
 146         call MPI_CART_GET( new_comm, ndims, dims, periods, coords, ierr)
 147
 148 c
 149 c     Does the mapping from coords to rank work?
 150 c
 151         call MPI_COMM_RANK( new_comm, newnewrank, ierr)
 152         call MPI_CART_RANK( new_comm, coords, new_rank, ierr)
 153         if (new_rank .ne. newnewrank ) then
 154            print *, "New rank (", new_rank, ") is not newnewrank"
 155            errors=errors+1
 156         endif
 157
 158 c
 159 c     Does the mapping from rank to coords work
 160 c
 161         call MPI_CART_COORDS( new_comm, new_rank, NUM_DIMS-1, new_coords
 162      $       ,  ierr)
 163         do 1000 i=1,NUM_DIMS-1
 164                 if (coords(i) .ne. new_coords(i)) then
 165                    print *, "coords(",i,") = ", coords(i),
 166      $                  " != new_coords (", new_coords(i), ")"
 167                    errors=errors+1
 168                 endif
 169 1000    continue
 170
 171 c
 172 c     We're at the end
 173 c
 174         call MPI_COMM_FREE( new_comm, ierr)
 175         call MPI_COMM_FREE( comm_temp, ierr)
 176         call MPI_COMM_FREE( comm_cart, ierr)
 177
 178 c       call Test_Waitforall_( )
 179
 180         call MPI_ALLREDUCE( errors, toterrors, 1, MPI_INTEGER,
 181      1                      MPI_SUM, MPI_COMM_WORLD, ierr )
 182         if (rank .eq. 0) then
 183            if (toterrors .eq. 0) then
 184               print *, ' No Errors'
 185            else
 186               print *, ' Done with ', toterrors, ' ERRORS!'
 187            endif
 188         endif
 189         call MPI_FINALIZE(ierr)
 190 c          print *, '[', rank, '] done with ', errors, ' ERRORS!'
 191
 192         end