cartcrf90.f90

fortran并行计算包

! This file created from test/mpi/f77/topo/cartcrf.f with f77tof90
! -*- Mode: Fortran; -*- 
!
!  (C) 2004 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
! Test various combinations of periodic and non-periodic Cartesian 
! communicators
!
      program main
      use mpi
      integer errs, ierr
      integer ndims, nperiods, i, size
      integer comm, source, dest, newcomm
      integer maxdims
      parameter (maxdims=7)
      logical periods(maxdims), outperiods(maxdims)
      integer dims(maxdims), outdims(maxdims)
      integer outcoords(maxdims)

      errs = 0
      call mtest_init( ierr )

!
!     For upto 6 dimensions, test with periodicity in 0 through all
!     dimensions.  The test is computed by both:
!         get info about the created communicator
!         apply cart shift
!     Note that a dimension can have size one, so that these tests
!     can work with small numbers (even 1) of processes
!
      comm = MPI_COMM_WORLD
      call mpi_comm_size( comm, size, ierr )
      do ndims = 1, 6
         do nperiods = 0, ndims
            do i=1,ndims
               periods(i) = .false.
               dims(i)    = 0
            enddo
            do i=1,nperiods
               periods(i) = .true.
            enddo

            call mpi_dims_create( size, ndims, dims, ierr )
            call mpi_cart_create( comm, ndims, dims, periods, .false., &
      &           newcomm, ierr )

            if (newcomm .ne. MPI_COMM_NULL) then
               call mpi_cart_get( newcomm, maxdims, outdims, outperiods, &
      &              outcoords, ierr )
!               print *, 'Coords = '
               do i=1, ndims
!                  print *, i, '(', outcoords(i), ')'
                  if (periods(i) .neqv. outperiods(i)) then
                     errs = errs + 1
                     print *, ' Wrong value for periods ', i
                     print *, ' ndims = ', ndims
                  endif
               enddo

               do i=1, ndims
                  call mpi_cart_shift( newcomm, i-1, 1, source, dest, &
      &                 ierr )
                  if (outcoords(i) .eq. outdims(i)-1) then
                     if (periods(i)) then
                        if (dest .eq. MPI_PROC_NULL) then
                           errs = errs + 1
                           print *, 'Expected rank, got proc_null'
                        endif
                     else
                        if (dest .ne. MPI_PROC_NULL) then
                           errs = errs + 1
                           print *, 'Expected procnull, got ', dest
                        endif
                     endif
                  endif
                  
                  call mpi_cart_shift( newcomm, i-1, -1, source, dest, &
      &                 ierr )
                  if (outcoords(i) .eq. 0) then
                     if (periods(i)) then
                        if (dest .eq. MPI_PROC_NULL) then
                           errs = errs + 1
                           print *, 'Expected rank, got proc_null'
                        endif
                     else
                        if (dest .ne. MPI_PROC_NULL) then
                           errs = errs + 1
                           print *, 'Expected procnull, got ', dest
                        endif
                     endif
                  endif
               enddo
               call mpi_comm_free( newcomm, ierr )
            endif
            
         enddo
      enddo
      
      call mtest_finalize( errs )
      call mpi_finalize( ierr )
      end