commnamef90.f90

mpi并行计算的c++代码 可用vc或gcc编译通过 可以用来搭建并行计算试验环境

! This file created from test/mpi/f77/comm/commnamef.f with f77tof90
! -*- Mode: Fortran; -*- 
!
!  (C) 2003 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
      program main
      use mpi
      integer errs, ierr
      integer comm(4), i, rlen, ln
      character*(MPI_MAX_OBJECT_NAME) inname(4), cname
      logical MTestGetIntracomm

      errs = 0
      call mtest_init( ierr )
      
! Test the predefined communicators
      do ln=1,MPI_MAX_OBJECT_NAME
         cname(ln:ln) = 'X'
      enddo
      call mpi_comm_get_name( MPI_COMM_WORLD, cname, rlen, ierr )
      do ln=MPI_MAX_OBJECT_NAME,1,-1
         if (cname(ln:ln) .ne. ' ') then
            if (ln .ne. rlen) then
               errs = errs + 1
               print *, 'result len ', rlen,' not equal to actual len ', &
      &              ln
            endif
            goto 110
         endif
      enddo
      if (cname(1:rlen) .ne. 'MPI_COMM_WORLD') then
         errs = errs + 1
         print *, 'Did not get MPI_COMM_WORLD for world'
      endif
 110  continue
!
      do ln=1,MPI_MAX_OBJECT_NAME
         cname(ln:ln) = 'X'
      enddo
      call mpi_comm_get_name( MPI_COMM_SELF, cname, rlen, ierr )
      do ln=MPI_MAX_OBJECT_NAME,1,-1
         if (cname(ln:ln) .ne. ' ') then
            if (ln .ne. rlen) then
               errs = errs + 1
               print *, 'result len ', rlen,' not equal to actual len ', &
      &              ln
            endif
            goto 120
         endif
      enddo
      if (cname(1:rlen) .ne. 'MPI_COMM_SELF') then
         errs = errs + 1
         print *, 'Did not get MPI_COMM_SELF for world'
      endif
 120  continue
!
      do i = 1, 4
         if (MTestGetIntracomm( comm(i), 1, .true. )) then
            ncomm = i
            write( inname(i), '(a,i1)') 'myname',i
            call mpi_comm_set_name( comm(i), inname(i), ierr )
         else
            goto 130
         endif
      enddo
 130   continue
!
!     Now test them all
      do i=1, ncomm
         call mpi_comm_get_name( comm(i), cname, rlen, ierr )
         if (inname(i) .ne. cname) then
            errs = errs + 1
            print *, ' Expected ', inname(i), ' got ', cname
         endif
         call MTestFreeComm( comm(i) )
      enddo
!      
      call mtest_finalize( errs )
      call mpi_finalize( ierr )
      end