Logo AND Algorithmique Numérique Distribuée

Public GIT Repository
175592572db8b5233fe3735ba17c8be95fc6d5ce
[simgrid.git] / 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