teshsuite/smpi/mpich3-test/f90/datatype/get_elem_u.f90

   1 ! -*- Mode: Fortran; -*-
   2 !
   3 !  (C) 2013 by Argonne National Laboratory.
   4 !      See COPYRIGHT in top-level directory.
   5 !
   6
   7 ! Based on a test written by Jim Hoekstra on behalf of Cray, Inc.
   8 ! see ticket #884 https://trac.mpich.org/projects/mpich/ticket/884
   9
  10 PROGRAM get_elem_u
  11
  12   USE mpi
  13   IMPLICIT NONE
  14   INTEGER    RANK, SIZE, IERR, COMM, errs
  15   INTEGER    MAX, I, K, dest
  16   INTEGER   STATUS(MPI_STATUS_SIZE)
  17
  18   INTEGER, PARAMETER :: nb=2
  19   INTEGER :: blklen(nb)=(/1,1/)
  20   INTEGER :: types(nb)=(/MPI_DOUBLE_PRECISION,MPI_CHAR/)
  21   INTEGER(kind=MPI_ADDRESS_KIND) :: disp(nb)=(/0,8/)
  22
  23   INTEGER, PARAMETER :: amax=200
  24   INTEGER :: type1, type2, extent
  25   REAL    :: a(amax)
  26
  27   errs = 0
  28   CALL MPI_Init( ierr )
  29   COMM = MPI_COMM_WORLD
  30   CALL MPI_Comm_rank(COMM,RANK,IERR)
  31   CALL MPI_Comm_size(COMM,SIZE,IERR)
  32   dest=size-1
  33
  34   CALL MPI_Type_create_struct(nb, blklen, disp, types, type1, ierr)
  35   CALL MPI_Type_commit(type1, ierr)
  36   CALL MPI_Type_extent(type1, extent, ierr)
  37
  38   CALL MPI_Type_contiguous(4, Type1, Type2, ierr)
  39   CALL MPI_Type_commit(Type2, ierr)
  40   CALL MPI_Type_extent(Type2, extent, ierr)
  41
  42   DO k=1,17
  43
  44      IF(rank .EQ. 0) THEN
  45
  46         !       send k copies of datatype Type1
  47         CALL MPI_Send(a, k, Type1, dest, 0, comm, ierr)
  48
  49      ELSE IF (rank == dest) THEN
  50
  51         CALL MPI_Recv(a, 200, Type2, 0, 0, comm, status, ierr)
  52         CALL MPI_Get_elements(status, Type2, i, ierr)
  53         IF (i .NE. 2*k) THEN
  54            errs = errs+1
  55            PRINT *, "k=",k,"  MPI_Get_elements returns", i, ", but it should be", 2*k
  56         END IF
  57
  58      ELSE
  59         !       thix rank does not particupate
  60      END IF
  61   enddo
  62
  63   CALL MPI_Type_free(type1, ierr)
  64   CALL MPI_Type_free(type2, ierr)
  65
  66   CALL MPI_Finalize( ierr )
  67
  68   IF(rank .EQ. 0 .AND. errs .EQ. 0) THEN
  69      PRINT *, " No Errors"
  70   END IF
  71
  72 END PROGRAM get_elem_u