teshsuite/smpi/mpich3-test/f77/init/baseenvf.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 ierr, provided, errs, rank, size
  10        integer iv, isubv, qprovided
  11        logical flag
  12
  13        errs = 0
  14        flag = .true.
  15        call mpi_finalized( flag, ierr )
  16        if (flag) then
  17           errs = errs + 1
  18           print *, 'Returned true for finalized before init'
  19        endif
  20        flag = .true.
  21        call mpi_initialized( flag, ierr )
  22        if (flag) then
  23           errs = errs + 1
  24           print *, 'Return true for initialized before init'
  25        endif
  26
  27        provided = -1
  28        call mpi_init_thread( MPI_THREAD_MULTIPLE, provided, ierr )
  29
  30        if (provided .ne. MPI_THREAD_MULTIPLE .and.
  31      &     provided .ne. MPI_THREAD_SERIALIZED .and.
  32      &     provided .ne. MPI_THREAD_FUNNELED .and.
  33      &     provided .ne. MPI_THREAD_SINGLE) then
  34           errs = errs + 1
  35           print *, ' Unrecognized value for provided = ', provided
  36        endif
  37
  38        iv    = -1
  39        isubv = -1
  40        call mpi_get_version( iv, isubv, ierr )
  41        if (iv .ne. MPI_VERSION .or. isubv .ne. MPI_SUBVERSION) then
  42           errs = errs + 1
  43           print *, 'Version in mpif.h and get_version do not agree'
  44           print *, 'Version in mpif.h is ', MPI_VERSION, '.',
  45      &              MPI_SUBVERSION
  46           print *, 'Version in get_version is ', iv, '.', isubv
  47        endif
  48        if (iv .lt. 1 .or. iv .gt. 3) then
  49           errs = errs + 1
  50           print *, 'Version of MPI is invalid (=', iv, ')'
  51        endif
  52        if (isubv.lt.0 .or. isubv.gt.2) then
  53           errs = errs + 1
  54           print *, 'Subversion of MPI is invalid (=', isubv, ')'
  55        endif
  56
  57        call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
  58        call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
  59
  60        flag = .false.
  61        call mpi_is_thread_main( flag, ierr )
  62        if (.not.flag) then
  63           errs = errs + 1
  64           print *, 'is_thread_main returned false for main thread'
  65        endif
  66
  67        call mpi_query_thread( qprovided, ierr )
  68        if (qprovided .ne. provided) then
  69           errs = errs + 1
  70           print *,'query thread and init thread disagree on'//
  71      &           ' thread level'
  72        endif
  73
  74        call mpi_finalize( ierr )
  75        flag = .false.
  76        call mpi_finalized( flag, ierr )
  77        if (.not. flag) then
  78           errs = errs + 1
  79           print *, 'finalized returned false after finalize'
  80        endif
  81
  82        if (rank .eq. 0) then
  83           if (errs .eq. 0) then
  84              print *, ' No Errors'
  85           else
  86              print *, ' Found ', errs, ' errors'
  87           endif
  88        endif
  89
  90        end