teshsuite/smpi/mpich3-test/f77/info/infotest2f.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, errs
  10       integer i1, i2
  11       integer nkeys, i, j, sumindex, vlen, ln, valuelen
  12       logical found, flag
  13       character*(MPI_MAX_INFO_KEY) keys(6)
  14       character*(MPI_MAX_INFO_VAL) values(6)
  15       character*(MPI_MAX_INFO_KEY) mykey
  16       character*(MPI_MAX_INFO_VAL) myvalue
  17 C
  18       data keys/"Key1", "key2", "KeY3", "A Key With Blanks","See Below",
  19      &          "last"/
  20       data values/"value 1", "value 2", "VaLue 3", "key=valu:3","false",
  21      &            "no test"/
  22 C
  23       errs = 0
  24
  25       call mtest_init( ierr )
  26
  27 C Note that the MPI standard requires that leading an trailing blanks
  28 C are stripped from keys and values (Section 4.10, The Info Object)
  29 C
  30 C First, create and initialize an info
  31       call mpi_info_create( i1, ierr )
  32       call mpi_info_set( i1, keys(1), values(1), ierr )
  33       call mpi_info_set( i1, keys(2), values(2), ierr )
  34       call mpi_info_set( i1, keys(3), values(3), ierr )
  35       call mpi_info_set( i1, keys(4), values(4), ierr )
  36       call mpi_info_set( i1, " See Below", values(5), ierr )
  37       call mpi_info_set( i1, keys(6), " no test ", ierr )
  38 C
  39       call mpi_info_get_nkeys( i1, nkeys, ierr )
  40       if (nkeys .ne. 6) then
  41          print *, ' Number of keys should be 6, is ', nkeys
  42       endif
  43       sumindex = 0
  44       do i=1, nkeys
  45 C        keys are number from 0 to n-1, even in Fortran (Section 4.10)
  46          call mpi_info_get_nthkey( i1, i-1, mykey, ierr )
  47          found = .false.
  48          do j=1, 6
  49             if (mykey .eq. keys(j)) then
  50                found = .true.
  51                sumindex = sumindex + j
  52                call mpi_info_get_valuelen( i1, mykey, vlen, flag, ierr )
  53                if (.not.flag) then
  54                   errs = errs + 1
  55                   print *, ' no value for key', mykey
  56                else
  57                   call mpi_info_get( i1, mykey, MPI_MAX_INFO_VAL,
  58      &                               myvalue, flag, ierr )
  59                   if (myvalue .ne. values(j)) then
  60                      errs = errs + 1
  61                      print *, ' Value for ', mykey, ' not expected'
  62                   else
  63                      do ln=MPI_MAX_INFO_VAL,1,-1
  64                         if (myvalue(ln:ln) .ne. ' ') then
  65                            if (vlen .ne. ln) then
  66                               errs = errs + 1
  67                               print *, ' length is ', ln,
  68      &                          ' but valuelen gave ',  vlen,
  69      &                          ' for key ', mykey
  70                            endif
  71                            goto 100
  72                         endif
  73                      enddo
  74  100                 continue
  75                   endif
  76                endif
  77             endif
  78          enddo
  79          if (.not.found) then
  80             print *, i, 'th key ', mykey, ' not in list'
  81          endif
  82       enddo
  83       if (sumindex .ne. 21) then
  84          errs = errs + 1
  85          print *, ' Not all keys found'
  86       endif
  87 C
  88 C delete 2, then dup, then delete 2 more
  89       call mpi_info_delete( i1, keys(1), ierr )
  90       call mpi_info_delete( i1, keys(2), ierr )
  91       call mpi_info_dup( i1, i2, ierr )
  92       call mpi_info_delete( i1, keys(3), ierr )
  93 C
  94 C check the contents of i2
  95 C valuelen does not signal an error for unknown keys; instead, sets
  96 C flag to false
  97       do i=1,2
  98          flag = .true.
  99          call mpi_info_get_valuelen( i2, keys(i), valuelen, flag, ierr )
 100          if (flag) then
 101             errs = errs + 1
 102             print *, ' Found unexpected key ', keys(i)
 103          endif
 104          myvalue = 'A test'
 105          call mpi_info_get( i2, keys(i), MPI_MAX_INFO_VAL,
 106      &                      myvalue, flag, ierr )
 107          if (flag) then
 108             errs = errs + 1
 109             print *, ' Found unexpected key in MPI_Info_get ', keys(i)
 110          else
 111             if (myvalue .ne. 'A test') then
 112                errs = errs + 1
 113                print *, ' Returned value overwritten, is now ', myvalue
 114             endif
 115          endif
 116
 117       enddo
 118       do i=3,6
 119          myvalue = ' '
 120          call mpi_info_get( i2, keys(i), MPI_MAX_INFO_VAL,
 121      &                      myvalue, flag, ierr )
 122          if (.not. flag) then
 123              errs = errs + 1
 124              print *, ' Did not find key ', keys(i)
 125          else
 126             if (myvalue .ne. values(i)) then
 127                errs = errs + 1
 128                print *, ' Found wrong value (', myvalue, ') for key ',
 129      &                  keys(i)
 130             endif
 131          endif
 132       enddo
 133 C
 134 C     Free info
 135       call mpi_info_free( i1, ierr )
 136       call mpi_info_free( i2, ierr )
 137
 138       call mtest_finalize( errs )
 139       call mpi_finalize( ierr )
 140
 141       end