teshsuite/smpi/mpich3-test/f77/datatype/allctypesf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2004 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6       program main
   7       include 'mpif.h'
   8       integer atype, ierr
   9 C
  10       call mtest_init(ierr)
  11       call mpi_comm_set_errhandler( MPI_COMM_WORLD, MPI_ERRORS_RETURN,
  12      *                              ierr )
  13 C
  14 C     Check that all Ctypes are available in Fortran (MPI 2.1, p 483, line 46)
  15 C
  16        call checkdtype( MPI_CHAR, "MPI_CHAR", ierr )
  17        call checkdtype( MPI_SIGNED_CHAR, "MPI_SIGNED_CHAR", ierr )
  18        call checkdtype( MPI_UNSIGNED_CHAR, "MPI_UNSIGNED_CHAR", ierr )
  19        call checkdtype( MPI_BYTE, "MPI_BYTE", ierr )
  20        call checkdtype( MPI_WCHAR, "MPI_WCHAR", ierr )
  21        call checkdtype( MPI_SHORT, "MPI_SHORT", ierr )
  22        call checkdtype( MPI_UNSIGNED_SHORT, "MPI_UNSIGNED_SHORT", ierr )
  23        call checkdtype( MPI_INT, "MPI_INT", ierr )
  24        call checkdtype( MPI_UNSIGNED, "MPI_UNSIGNED", ierr )
  25        call checkdtype( MPI_LONG, "MPI_LONG", ierr )
  26        call checkdtype( MPI_UNSIGNED_LONG, "MPI_UNSIGNED_LONG", ierr )
  27        call checkdtype( MPI_FLOAT, "MPI_FLOAT", ierr )
  28        call checkdtype( MPI_DOUBLE, "MPI_DOUBLE", ierr )
  29        if (MPI_LONG_DOUBLE .ne. MPI_DATATYPE_NULL) then
  30          call checkdtype( MPI_LONG_DOUBLE, "MPI_LONG_DOUBLE", ierr )
  31        endif
  32        if (MPI_LONG_LONG_INT .ne. MPI_DATATYPE_NULL) then
  33          call checkdtype2( MPI_LONG_LONG_INT, "MPI_LONG_LONG_INT",
  34      *                     "MPI_LONG_LONG", ierr )
  35        endif
  36        if (MPI_UNSIGNED_LONG_LONG .ne. MPI_DATATYPE_NULL) then
  37          call checkdtype( MPI_UNSIGNED_LONG_LONG,
  38      *                    "MPI_UNSIGNED_LONG_LONG", ierr )
  39        endif
  40        if (MPI_LONG_LONG .ne. MPI_DATATYPE_NULL) then
  41          call checkdtype2( MPI_LONG_LONG, "MPI_LONG_LONG",
  42      *                     "MPI_LONG_LONG_INT", ierr )
  43        endif
  44        call checkdtype( MPI_PACKED, "MPI_PACKED", ierr )
  45        call checkdtype( MPI_LB, "MPI_LB", ierr )
  46        call checkdtype( MPI_UB, "MPI_UB", ierr )
  47        call checkdtype( MPI_FLOAT_INT, "MPI_FLOAT_INT", ierr )
  48        call checkdtype( MPI_DOUBLE_INT, "MPI_DOUBLE_INT", ierr )
  49        call checkdtype( MPI_LONG_INT, "MPI_LONG_INT", ierr )
  50        call checkdtype( MPI_SHORT_INT, "MPI_SHORT_INT", ierr )
  51        call checkdtype( MPI_2INT, "MPI_2INT", ierr )
  52        if (MPI_LONG_DOUBLE_INT .ne. MPI_DATATYPE_NULL) then
  53          call checkdtype( MPI_LONG_DOUBLE_INT, "MPI_LONG_DOUBLE_INT",
  54      *                    ierr)
  55        endif
  56 C
  57 C     Check that all Ctypes are available in Fortran (MPI 2.2)
  58 C     Note that because of implicit declarations in Fortran, this
  59 C     code should compile even with pre MPI 2.2 implementations.
  60 C
  61        if (MPI_VERSION .gt. 2 .or. (MPI_VERSION .eq. 2 .and.
  62      *      MPI_SUBVERSION .ge. 2)) then
  63           call checkdtype( MPI_INT8_T, "MPI_INT8_T", ierr )
  64           call checkdtype( MPI_INT16_T, "MPI_INT16_T", ierr )
  65           call checkdtype( MPI_INT32_T, "MPI_INT32_T", ierr )
  66           call checkdtype( MPI_INT64_T, "MPI_INT64_T", ierr )
  67           call checkdtype( MPI_UINT8_T, "MPI_UINT8_T", ierr )
  68           call checkdtype( MPI_UINT16_T, "MPI_UINT16_T", ierr )
  69           call checkdtype( MPI_UINT32_T, "MPI_UINT32_T", ierr )
  70           call checkdtype( MPI_UINT64_T, "MPI_UINT64_T", ierr )
  71 C other C99 types
  72           call checkdtype( MPI_C_BOOL, "MPI_C_BOOL", ierr )
  73           call checkdtype( MPI_C_FLOAT_COMPLEX, "MPI_C_FLOAT_COMPLEX",
  74      *                     ierr)
  75           call checkdtype2( MPI_C_COMPLEX, "MPI_C_COMPLEX",
  76      *                      "MPI_C_FLOAT_COMPLEX", ierr )
  77           call checkdtype( MPI_C_DOUBLE_COMPLEX, "MPI_C_DOUBLE_COMPLEX",
  78      *                     ierr )
  79           if (MPI_C_LONG_DOUBLE_COMPLEX .ne. MPI_DATATYPE_NULL) then
  80             call checkdtype( MPI_C_LONG_DOUBLE_COMPLEX,
  81      *                       "MPI_C_LONG_DOUBLE_COMPLEX", ierr )
  82           endif
  83 C address/offset types
  84           call checkdtype( MPI_AINT, "MPI_AINT", ierr )
  85           call checkdtype( MPI_OFFSET, "MPI_OFFSET", ierr )
  86        endif
  87 C
  88        call mtest_finalize( ierr )
  89        call MPI_Finalize( ierr )
  90        end
  91 C
  92 C Check name of datatype
  93       subroutine CheckDtype( intype, name, ierr )
  94       include 'mpif.h'
  95       integer intype, ierr
  96       character *(*) name
  97       integer ir, rlen
  98       character *(MPI_MAX_OBJECT_NAME) outname
  99 C
 100       outname = ""
 101       call MPI_TYPE_GET_NAME( intype, outname, rlen, ir )
 102       if (ir .ne. MPI_SUCCESS) then
 103          print *, " Datatype ", name, " not available in Fortran"
 104          ierr = ierr + 1
 105       else
 106          if (outname .ne. name) then
 107             print *, " For datatype ", name, " found name ",
 108      *           outname(1:rlen)
 109             ierr = ierr + 1
 110          endif
 111       endif
 112
 113       return
 114       end
 115 C
 116 C Check name of datatype (allows alias)
 117       subroutine CheckDtype2( intype, name, name2, ierr )
 118       include 'mpif.h'
 119       integer intype, ierr
 120       character *(*) name, name2
 121       integer ir, rlen
 122       character *(MPI_MAX_OBJECT_NAME) outname
 123 C
 124       outname = ""
 125       call MPI_TYPE_GET_NAME( intype, outname, rlen, ir )
 126       if (ir .ne. MPI_SUCCESS) then
 127          print *, " Datatype ", name, " not available in Fortran"
 128          ierr = ierr + 1
 129       else
 130          if (outname .ne. name .and. outname .ne. name2) then
 131             print *, " For datatype ", name, " found name ",
 132      *           outname(1:rlen)
 133             ierr = ierr + 1
 134          endif
 135       endif
 136
 137       return
 138       end