teshsuite/smpi/mpich3-test/f77/ext/c2f2cf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2003 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6       program main
   7       implicit none
   8       include 'mpif.h'
   9       integer errs, toterrs, ierr
  10       integer wrank, wsize
  11       integer wgroup, info, req
  12       integer fsize, frank
  13       integer comm, group, type, op, errh, result
  14       integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest,
  15      $     c2ferrhandler, c2fop
  16       character value*100
  17       logical   flag
  18       errs = 0
  19
  20       call mpi_init( ierr )
  21
  22 C
  23 C Test passing a Fortran MPI object to C
  24       call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
  25       errs = errs + c2fcomm( MPI_COMM_WORLD )
  26       call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr )
  27       errs = errs + c2fgroup( wgroup )
  28       call mpi_group_free( wgroup, ierr )
  29
  30       call mpi_info_create( info, ierr )
  31       call mpi_info_set( info, "host", "myname", ierr )
  32       call mpi_info_set( info, "wdir", "/rdir/foo", ierr )
  33       errs = errs + c2finfo( info )
  34       call mpi_info_free( info, ierr )
  35
  36       errs = errs + c2ftype( MPI_INTEGER )
  37
  38       call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG,
  39      $     MPI_COMM_WORLD, req, ierr )
  40       call mpi_cancel( req, ierr )
  41       errs = errs + c2frequest( req )
  42       call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
  43
  44       errs = errs + c2ferrhandler( MPI_ERRORS_RETURN )
  45
  46       errs = errs + c2fop( MPI_SUM )
  47
  48 C
  49 C Test using a C routine to provide the Fortran handle
  50       call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
  51       call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
  52
  53       call f2ccomm( comm )
  54       call mpi_comm_size( comm, fsize, ierr )
  55       call mpi_comm_rank( comm, frank, ierr )
  56       if (fsize.ne.wsize .or. frank.ne.wrank) then
  57          errs = errs + 1
  58          print *, "Comm(fortran) has wrong size or rank"
  59       endif
  60
  61       call f2cgroup( group )
  62       call mpi_group_size( group, fsize, ierr )
  63       call mpi_group_rank( group, frank, ierr )
  64       if (fsize.ne.wsize .or. frank.ne.wrank) then
  65          errs = errs + 1
  66          print *, "Group(fortran) has wrong size or rank"
  67       endif
  68       call mpi_group_free( group, ierr )
  69
  70       call f2ctype( type )
  71       if (type .ne. MPI_INTEGER) then
  72          errs = errs + 1
  73          print *, "Datatype(fortran) is not MPI_INT"
  74       endif
  75
  76       call f2cinfo( info )
  77       call mpi_info_get( info, "host", 100, value, flag, ierr )
  78       if (.not. flag) then
  79          errs = errs + 1
  80          print *, "Info test for host returned false"
  81       else if (value .ne. "myname") then
  82          errs = errs + 1
  83          print *, "Info test for host returned ", value
  84       endif
  85       call mpi_info_get( info, "wdir", 100, value, flag, ierr )
  86       if (.not. flag) then
  87          errs = errs + 1
  88          print *, "Info test for wdir returned false"
  89       else if (value .ne. "/rdir/foo") then
  90          errs = errs + 1
  91          print *, "Info test for wdir returned ", value
  92       endif
  93       call mpi_info_free( info, ierr )
  94
  95       call f2cop( op )
  96       if (op .ne. MPI_SUM) then
  97           errs = errs + 1
  98           print *, "Fortran MPI_SUM not MPI_SUM in C"
  99       endif
 100
 101       call f2cerrhandler( errh )
 102       if (errh .ne. MPI_ERRORS_RETURN) then
 103           errs = errs + 1
 104           print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C"
 105       endif
 106 C
 107 C Summarize the errors
 108 C
 109       call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
 110      $     MPI_COMM_WORLD, ierr )
 111       if (wrank .eq. 0) then
 112          if (toterrs .eq. 0) then
 113             print *, ' No Errors'
 114          else
 115             print *, ' Found ', toterrs, ' errors'
 116          endif
 117       endif
 118
 119       call mpi_finalize( ierr )
 120       end
 121