teshsuite/smpi/mpich3-test/f77/topo/cartcrf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2004 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6 C Test various combinations of periodic and non-periodic Cartesian
   7 C communicators
   8 C
   9       program main
  10       implicit none
  11       include 'mpif.h'
  12       integer errs, ierr
  13       integer ndims, nperiods, i, size
  14       integer comm, source, dest, newcomm
  15       integer maxdims
  16       parameter (maxdims=7)
  17       logical periods(maxdims), outperiods(maxdims)
  18       integer dims(maxdims), outdims(maxdims)
  19       integer outcoords(maxdims)
  20
  21       errs = 0
  22       call mtest_init( ierr )
  23
  24 C
  25 C     For up to 6 dimensions, test with periodicity in 0 through all
  26 C     dimensions.  The test is computed by both:
  27 C         get info about the created communicator
  28 C         apply cart shift
  29 C     Note that a dimension can have size one, so that these tests
  30 C     can work with small numbers (even 1) of processes
  31 C
  32       comm = MPI_COMM_WORLD
  33       call mpi_comm_size( comm, size, ierr )
  34       do ndims = 1, 6
  35          do nperiods = 0, ndims
  36             do i=1,ndims
  37                periods(i) = .false.
  38                dims(i)    = 0
  39             enddo
  40             do i=1,nperiods
  41                periods(i) = .true.
  42             enddo
  43
  44             call mpi_dims_create( size, ndims, dims, ierr )
  45             call mpi_cart_create( comm, ndims, dims, periods, .false.,
  46      $           newcomm, ierr )
  47
  48             if (newcomm .ne. MPI_COMM_NULL) then
  49                call mpi_cart_get( newcomm, maxdims, outdims, outperiods,
  50      $              outcoords, ierr )
  51 C               print *, 'Coords = '
  52                do i=1, ndims
  53 C                  print *, i, '(', outcoords(i), ')'
  54                   if (periods(i) .neqv. outperiods(i)) then
  55                      errs = errs + 1
  56                      print *, ' Wrong value for periods ', i
  57                      print *, ' ndims = ', ndims
  58                   endif
  59                enddo
  60
  61                do i=1, ndims
  62                   call mpi_cart_shift( newcomm, i-1, 1, source, dest,
  63      $                 ierr )
  64                   if (outcoords(i) .eq. outdims(i)-1) then
  65                      if (periods(i)) then
  66                         if (dest .eq. MPI_PROC_NULL) then
  67                            errs = errs + 1
  68                            print *, 'Expected rank, got proc_null'
  69                         endif
  70                      else
  71                         if (dest .ne. MPI_PROC_NULL) then
  72                            errs = errs + 1
  73                            print *, 'Expected procnull, got ', dest
  74                         endif
  75                      endif
  76                   endif
  77
  78                   call mpi_cart_shift( newcomm, i-1, -1, source, dest,
  79      $                 ierr )
  80                   if (outcoords(i) .eq. 0) then
  81                      if (periods(i)) then
  82                         if (dest .eq. MPI_PROC_NULL) then
  83                            errs = errs + 1
  84                            print *, 'Expected rank, got proc_null'
  85                         endif
  86                      else
  87                         if (dest .ne. MPI_PROC_NULL) then
  88                            errs = errs + 1
  89                            print *, 'Expected procnull, got ', dest
  90                         endif
  91                      endif
  92                   endif
  93                enddo
  94                call mpi_comm_free( newcomm, ierr )
  95             endif
  96
  97          enddo
  98       enddo
  99
 100       call mtest_finalize( errs )
 101       call mpi_finalize( ierr )
 102       end