c2f2cf90.f90

fortran并行计算包

! This file created from test/mpi/f77/ext/c2f2cf.f with f77tof90
! -*- Mode: Fortran; -*- 
!
!  (C) 2003 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
      program main
      use mpi
      integer errs, toterrs, ierr
      integer wrank, wsize
      integer wgroup, info, req
      integer fsize, frank
      integer comm, group, type, op, errh, result
      integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest, &
      &     c2ferrhandler, c2fop
      character value*100
      logical   flag
      errs = 0

      call mpi_init( ierr )

!
! Test passing a Fortran MPI object to C
      call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
      errs = errs + c2fcomm( MPI_COMM_WORLD )
      call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr )
      errs = errs + c2fgroup( wgroup )
      call mpi_group_free( wgroup, ierr )

      call mpi_info_create( info, ierr )
      call mpi_info_set( info, "host", "myname", ierr )
      call mpi_info_set( info, "wdir", "/rdir/foo", ierr )
      errs = errs + c2finfo( info )
      call mpi_info_free( info, ierr )

      errs = errs + c2ftype( MPI_INTEGER )

      call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG, &
      &     MPI_COMM_WORLD, req, ierr )
      call mpi_cancel( req, ierr )
      errs = errs + c2frequest( req )
      call mpi_wait( req, MPI_STATUS_IGNORE, ierr )

      errs = errs + c2ferrhandler( MPI_ERRORS_RETURN )

      errs = errs + c2fop( MPI_SUM )

!
! Test using a C routine to provide the Fortran handle
      call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
      call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )

      call f2ccomm( comm )
      call mpi_comm_size( comm, fsize, ierr )
      call mpi_comm_rank( comm, frank, ierr )
      if (fsize.ne.wsize .or. frank.ne.wrank) then
         errs = errs + 1
         print *, "Comm(fortran) has wrong size or rank"
      endif
      
      call f2cgroup( group )
      call mpi_group_size( group, fsize, ierr )
      call mpi_group_rank( group, frank, ierr )
      if (fsize.ne.wsize .or. frank.ne.wrank) then
         errs = errs + 1
         print *, "Group(fortran) has wrong size or rank"
      endif
      call mpi_group_free( group, ierr )

      call f2ctype( type )
      if (type .ne. MPI_INTEGER) then
         errs = errs + 1
         print *, "Datatype(fortran) is not MPI_INT"
      endif
      
      call f2cinfo( info )
      call mpi_info_get( info, "host", 100, value, flag, ierr )
      if (.not. flag) then
         errs = errs + 1
         print *, "Info test for host returned false"
      else if (value .ne. "myname") then
         errs = errs + 1
         print *, "Info test for host returned ", value
      endif
      call mpi_info_get( info, "wdir", 100, value, flag, ierr )
      if (.not. flag) then
         errs = errs + 1
         print *, "Info test for wdir returned false"
      else if (value .ne. "/rdir/foo") then
         errs = errs + 1
         print *, "Info test for wdir returned ", value
      endif
      call mpi_info_free( info, ierr )

      call f2cop( op )
      if (op .ne. MPI_SUM) then
          errs = errs + 1
          print *, "Fortran MPI_SUM not MPI_SUM in C"
      endif

      call f2cerrhandler( errh )
      if (errh .ne. MPI_ERRORS_RETURN) then
          errs = errs + 1
          print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C"
      endif
!
! Summarize the errors
!
      call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
      &     MPI_COMM_WORLD, ierr )
      if (wrank .eq. 0) then
         if (toterrs .eq. 0) then
            print *, ' No Errors'
         else
            print *, ' Found ', toterrs, ' errors'
         endif
      endif

      call mpi_finalize( ierr )
      stop
      end