! -*- Mode: Fortran; -*-

!

!  (C) 2014 by Argonne National Laboratory.

!      See COPYRIGHT in top-level directory.

!

        subroutine MTest_Init( ierr )

        use mpi_f08

        integer ierr

        logical flag

        logical dbgflag

        integer wrank

        common /mtest/ dbgflag, wrank

        call MPI_Initialized( flag, ierr )

        if (.not. flag) then

           call MPI_Init( ierr )

        endif

        dbgflag = .false.

        call MPI_Comm_rank( MPI_COMM_WORLD, wrank, ierr )

        end

!

        subroutine MTest_Finalize( errs )

        use mpi

        integer errs

        integer rank, toterrs, ierr

        call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )

        call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,  &

      &        MPI_COMM_WORLD, ierr )

        if (rank .eq. 0) then

           if (toterrs .gt. 0) then

                print *, " Found ", toterrs, " errors"

           else

                print *, " No Errors"

           endif

        endif

        call MPI_Finalize( ierr )

        end

!

! A simple get intracomm for now

        logical function MTestGetIntracomm( comm, min_size, qsmaller )

        use mpi_f08

        integer ierr

        integer min_size, size, rank

        TYPE(MPI_Comm) comm

        logical qsmaller

        integer myindex

        save myindex

        data myindex /0/

        comm = MPI_COMM_NULL

        if (myindex .eq. 0) then

           comm = MPI_COMM_WORLD

        else if (myindex .eq. 1) then

           call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )

        else if (myindex .eq. 2) then

           call mpi_comm_size( MPI_COMM_WORLD, size, ierr )

           call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )

           call mpi_comm_split( MPI_COMM_WORLD, 0, size - rank, comm,  &

      &                                 ierr )

        else

           if (min_size .eq. 1 .and. myindex .eq. 3) then

              comm = MPI_COMM_SELF

           endif

        endif

        myindex = mod( myindex, 4 ) + 1

        MTestGetIntracomm = comm /= MPI_COMM_NULL

        end

!

        subroutine MTestFreeComm( comm )

        use mpi_f08

        integer ierr

        TYPE(MPI_Comm) comm

        if (comm .ne. MPI_COMM_WORLD .and. &

      &      comm .ne. MPI_COMM_SELF  .and. &

      &      comm .ne. MPI_COMM_NULL) then

           call mpi_comm_free( comm, ierr )

        endif

        end

!

        subroutine MTestPrintError( errcode )

        use mpi_f08

        integer errcode

        integer errclass, slen, ierr

        character*(MPI_MAX_ERROR_STRING) string

        call MPI_Error_class( errcode, errclass, ierr )

        call MPI_Error_string( errcode, string, slen, ierr )

        print *, "Error class ", errclass, "(", string(1:slen), ")"

        end

!

        subroutine MTestPrintErrorMsg( msg, errcode )

        use mpi_f08

        character*(*) msg

        integer errcode

        integer errclass, slen, ierr

        character*(MPI_MAX_ERROR_STRING) string

        call MPI_Error_class( errcode, errclass, ierr )

        call MPI_Error_string( errcode, string, slen, ierr )

        print *, msg, ": Error class ", errclass, " &

      &       (", string(1:slen), ")"

        end

        subroutine MTestSpawnPossible( can_spawn, errs )

        use mpi

        integer can_spawn

        integer errs

        integer(kind=MPI_ADDRESS_KIND) val

        integer ierror

        logical flag

        integer comm_size

        call mpi_comm_get_attr( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, val, &

      &                          flag, ierror )

        if ( ierror .ne. MPI_SUCCESS ) then

!       MPI_UNIVERSE_SIZE keyval missing from MPI_COMM_WORLD attributes

            can_spawn = -1

            errs = errs + 1

        else

            if ( flag ) then

                comm_size = -1

                call mpi_comm_size( MPI_COMM_WORLD, comm_size, ierror )

                if ( ierror .ne. MPI_SUCCESS ) then

!       MPI_COMM_SIZE failed for MPI_COMM_WORLD

                    can_spawn = -1

                    errs = errs + 1

                    return

                endif

                if ( val .le. comm_size ) then

!       no additional processes can be spawned

                    can_spawn = 0

                else

                    can_spawn = 1

                endif

            else

!       No attribute associated with key MPI_UNIVERSE_SIZE of MPI_COMM_WORLD

                can_spawn = -1

            endif

        endif

        end