teshsuite/smpi/mpich3-test/f77/datatype/typecntsf.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 errs, ierr
  10        integer ntype1, ntype2
  11 C
  12 C This is a very simple test that just tests that the contents/envelope
  13 C routines can be called.  This should be upgraded to test the new
  14 C MPI-2 datatype routines (which use address-sized integers)
  15 C
  16
  17        errs = 0
  18        call mtest_init( ierr )
  19
  20        call explore( MPI_INTEGER, MPI_COMBINER_NAMED, errs )
  21        call explore( MPI_BYTE, MPI_COMBINER_NAMED, errs )
  22        call mpi_type_vector( 10, 1, 30, MPI_DOUBLE_PRECISION, ntype1,
  23      &                       ierr )
  24        call explore( ntype1, MPI_COMBINER_VECTOR, errs )
  25        call mpi_type_dup( ntype1, ntype2, ierr )
  26        call explore( ntype2, MPI_COMBINER_DUP, errs )
  27        call mpi_type_free( ntype2, ierr )
  28        call mpi_type_free( ntype1, ierr )
  29
  30 C
  31        call mtest_finalize( errs )
  32        call mpi_finalize( ierr )
  33        end
  34 C
  35        subroutine explore( dtype, mycomb, errs )
  36        implicit none
  37        include 'mpif.h'
  38        integer dtype, mycomb, errs
  39        integer ierr
  40        integer nints, nadds, ntype, combiner
  41        integer max_nints, max_dtypes, max_asizev
  42        parameter (max_nints = 10, max_dtypes = 10, max_asizev=10)
  43        integer intv(max_nints), dtypesv(max_dtypes)
  44        include 'typeaints.h'
  45 C
  46        call mpi_type_get_envelope( dtype, nints, nadds, ntype,
  47      &                             combiner, ierr )
  48 C
  49        if (combiner .ne. MPI_COMBINER_NAMED) then
  50           call mpi_type_get_contents( dtype,
  51      &         max_nints, max_asizev, max_dtypes,
  52      &         intv, aintv, dtypesv, ierr )
  53 C
  54 C              dtypesv of constructed types must be free'd now
  55 C
  56           if (combiner .eq. MPI_COMBINER_DUP) then
  57              call mpi_type_free( dtypesv(1), ierr )
  58           endif
  59        endif
  60        if (combiner .ne. mycomb) then
  61           errs = errs + 1
  62           print *, ' Expected combiner ', mycomb, ' but got ',
  63      &             combiner
  64        endif
  65 C
  66 C List all combiner types to check that they are defined in mpif.h
  67        if (combiner .eq. MPI_COMBINER_NAMED) then
  68        else if (combiner .eq. MPI_COMBINER_DUP) then
  69        else if (combiner .eq. MPI_COMBINER_CONTIGUOUS) then
  70        else if (combiner .eq. MPI_COMBINER_VECTOR) then
  71        else if (combiner .eq. MPI_COMBINER_HVECTOR_INTEGER) then
  72        else if (combiner .eq. MPI_COMBINER_HVECTOR) then
  73        else if (combiner .eq. MPI_COMBINER_INDEXED) then
  74        else if (combiner .eq. MPI_COMBINER_HINDEXED_INTEGER) then
  75        else if (combiner .eq. MPI_COMBINER_HINDEXED) then
  76        else if (combiner .eq. MPI_COMBINER_INDEXED_BLOCK) then
  77        else if (combiner .eq. MPI_COMBINER_STRUCT_INTEGER) then
  78        else if (combiner .eq. MPI_COMBINER_STRUCT) then
  79        else if (combiner .eq. MPI_COMBINER_SUBARRAY) then
  80        else if (combiner .eq. MPI_COMBINER_DARRAY) then
  81        else if (combiner .eq. MPI_COMBINER_F90_REAL) then
  82        else if (combiner .eq. MPI_COMBINER_F90_COMPLEX) then
  83        else if (combiner .eq. MPI_COMBINER_F90_INTEGER) then
  84        else if (combiner .eq. MPI_COMBINER_RESIZED) then
  85        else
  86           errs = errs + 1
  87           print *, ' Unknown combiner ', combiner
  88        endif
  89
  90        return
  91        end