teshsuite/smpi/mpich3-test/f77/attr/baseattr2f.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C
   4 C (C) 2001 by Argonne National Laboratory.
   5 C     See COPYRIGHT in top-level directory.
   6 C
   7         program main
   8         implicit none
   9         include 'mpif.h'
  10         integer ierr, errs
  11         logical flag
  12         integer value, commsize, commrank
  13
  14         errs = 0
  15         call mpi_init( ierr )
  16
  17         call mpi_comm_size( MPI_COMM_WORLD, commsize, ierr )
  18         call mpi_comm_rank( MPI_COMM_WORLD, commrank, ierr )
  19
  20         call mpi_attr_get( MPI_COMM_WORLD, MPI_TAG_UB, value, flag, ierr
  21      $       )
  22         if (.not. flag) then
  23            errs = errs + 1
  24            print *, "Could not get TAG_UB"
  25         else
  26            if (value .lt. 32767) then
  27               errs = errs + 1
  28               print *, "Got too-small value (", value, ") for TAG_UB"
  29            endif
  30         endif
  31
  32         call mpi_attr_get( MPI_COMM_WORLD, MPI_HOST, value, flag, ierr )
  33         if (.not. flag) then
  34            errs = errs + 1
  35            print *, "Could not get HOST"
  36         else
  37            if ((value .lt. 0 .or. value .ge. commsize) .and. value .ne.
  38      $          MPI_PROC_NULL) then
  39               errs = errs + 1
  40               print *, "Got invalid value ", value, " for HOST"
  41            endif
  42         endif
  43
  44         call mpi_attr_get( MPI_COMM_WORLD, MPI_IO, value, flag, ierr )
  45         if (.not. flag) then
  46            errs = errs + 1
  47            print *, "Could not get IO"
  48         else
  49            if ((value .lt. 0 .or. value .ge. commsize) .and. value .ne.
  50      $          MPI_ANY_SOURCE .and. value .ne. MPI_PROC_NULL) then
  51               errs = errs + 1
  52               print *, "Got invalid value ", value, " for IO"
  53            endif
  54         endif
  55
  56         call mpi_attr_get( MPI_COMM_WORLD, MPI_WTIME_IS_GLOBAL, value,
  57      $       flag, ierr )
  58         if (flag) then
  59 C          Wtime need not be set
  60            if (value .lt.  0 .or. value .gt. 1) then
  61               errs = errs + 1
  62               print *, "Invalid value for WTIME_IS_GLOBAL (got ", value,
  63      $             ")"
  64            endif
  65         endif
  66
  67         call mpi_attr_get( MPI_COMM_WORLD, MPI_APPNUM, value, flag, ierr
  68      $       )
  69 C     appnum need not be set
  70         if (flag) then
  71            if (value .lt. 0) then
  72               errs = errs + 1
  73               print *, "MPI_APPNUM is defined as ", value,
  74      $             " but must be nonnegative"
  75            endif
  76         endif
  77
  78         call mpi_attr_get( MPI_COMM_WORLD, MPI_UNIVERSE_SIZE, value,
  79      $       flag, ierr )
  80 C     MPI_UNIVERSE_SIZE need not be set
  81         if (flag) then
  82            if (value .lt. commsize) then
  83               errs = errs + 1
  84               print *, "MPI_UNIVERSE_SIZE = ", value,
  85      $             ", less than comm world (", commsize, ")"
  86            endif
  87         endif
  88
  89         call mpi_attr_get( MPI_COMM_WORLD, MPI_LASTUSEDCODE, value, flag
  90      $       , ierr )
  91 C Last used code must be defined and >= MPI_ERR_LASTCODE
  92         if (flag) then
  93            if (value .lt. MPI_ERR_LASTCODE) then
  94             errs = errs + 1
  95             print *, "MPI_LASTUSEDCODE points to an integer (",
  96      $           MPI_ERR_LASTCODE, ") smaller than MPI_ERR_LASTCODE (",
  97      $           value, ")"
  98             endif
  99          else
 100             errs = errs + 1
 101             print *, "MPI_LASTUSECODE is not defined"
 102          endif
 103
 104 C     Check for errors
 105       if (errs .eq. 0) then
 106          print *, " No Errors"
 107       else
 108          print *, " Found ", errs, " errors"
 109       endif
 110
 111       call MPI_Finalize( ierr )
 112
 113       end