Logo AND Algorithmique Numérique Distribuée

Public GIT Repository
Merge branch 'master' of git+ssh://scm.gforge.inria.fr//gitroot/simgrid/simgrid
[simgrid.git] / teshsuite / smpi / mpich3-test / f77 / util / mtestf.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         subroutine MTest_Init( ierr )
7 C       Place the include first so that we can automatically create a
8 C       Fortran 90 version that uses the mpi module instead.  If
9 C       the module is in a different place, the compiler can complain
10 C       about out-of-order statements
11         implicit none
12         include 'mpif.h'
13         integer ierr
14         logical flag
15         logical dbgflag
16         integer wrank
17         common /mtest/ dbgflag, wrank
18
19         call MPI_Initialized( flag, ierr )
20         if (.not. flag) then
21            call MPI_Init( ierr )
22         endif
23
24         dbgflag = .false.
25         call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr )
26         end
27 C
28         subroutine MTest_Finalize( errs )
29         implicit none
30         include 'mpif.h'
31         integer errs
32         integer rank, toterrs, ierr
33         
34         call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
35
36         call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 
37      *        MPI_COMM_WORLD, ierr ) 
38         
39         if (rank .eq. 0) then
40            if (toterrs .gt. 0) then 
41                 print *, " Found ", toterrs, " errors"
42            else
43                 print *, " No Errors"
44            endif
45         endif
46         end
47 C
48 C A simple get intracomm for now
49         logical function MTestGetIntracomm( comm, min_size, qsmaller )
50         implicit none
51         include 'mpif.h'
52         integer ierr
53         integer comm, min_size, size, rank
54         logical qsmaller
55         integer myindex
56         common /grr/ myindex 
57
58         comm = MPI_COMM_NULL
59         if (myindex .eq. 0) then
60            comm = MPI_COMM_WORLD
61         else if (myindex .eq. 1) then
62            call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
63         else if (myindex .eq. 2) then
64            call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
65            call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
66            call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm, 
67      &                                 ierr )
68         else
69            if (min_size .eq. 1 .and. myindex .eq. 3) then
70               comm = MPI_COMM_SELF
71            endif
72         endif
73         myindex = mod( myindex, 4 ) + 1
74         MTestGetIntracomm = comm .ne. MPI_COMM_NULL
75         qsmaller=.true.
76         end
77 C
78         subroutine MTestFreeComm( comm )
79         implicit none
80         include 'mpif.h'
81         integer comm, ierr
82         if (comm .ne. MPI_COMM_WORLD .and.
83      &      comm .ne. MPI_COMM_SELF  .and.
84      &      comm .ne. MPI_COMM_NULL) then
85            call mpi_comm_free( comm, ierr )
86         endif
87         end
88 C
89         subroutine MTestPrintError( errcode )
90         implicit none
91         include 'mpif.h'
92         integer errcode
93         integer errclass, slen, ierr
94         character*(MPI_MAX_ERROR_STRING) string
95
96         call MPI_Error_class( errcode, errclass, ierr )
97         call MPI_Error_string( errcode, string, slen, ierr )
98         print *, "Error class ", errclass, "(", string(1:slen), ")"
99         end
100 C
101         subroutine MTestPrintErrorMsg( msg, errcode )
102         implicit none
103         include 'mpif.h'
104         character*(*) msg
105         integer errcode
106         integer errclass, slen, ierr
107         character*(MPI_MAX_ERROR_STRING) string
108
109         call MPI_Error_class( errcode, errclass, ierr )
110         call MPI_Error_string( errcode, string, slen, ierr )
111         print *, msg, ": Error class ", errclass, "
112      $       (", string(1:slen), ")" 
113         end