teshsuite/smpi/mpich3-test/f90/datatype/get_elem_d.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_d
  11
  12   use mpi
  13 !  implicit none
  14
  15   integer, parameter :: verbose=0
  16   integer, parameter :: cmax=100,dmax=100,imax=60
  17   integer, parameter :: nb=2
  18   integer :: comm,rank,size,dest,ierror,errs=0
  19   integer :: status(MPI_STATUS_SIZE)
  20   integer :: i,ii,count,ka,j,jj,k,kj,krat,tag=100
  21   integer :: blklen(nb)=(/2,2/)
  22   integer :: types(nb)=(/MPI_DOUBLE_PRECISION,MPI_INTEGER/)
  23   integer(kind=MPI_ADDRESS_KIND) :: disp(nb)
  24   integer :: newtype,ntlen,ians(0:23),ians0(0:3),ians1(20),ians2(20)
  25   double precision :: dbuff(dmax), a
  26   integer :: ibuff(imax)
  27   character :: cbuff(cmax)='X'
  28
  29   call MPI_Init(ierror)
  30   comm=MPI_COMM_WORLD
  31   call MPI_Comm_size(comm, size, ierror)
  32   dest=size-1
  33   call MPI_Comm_rank(comm, rank, ierror)
  34   call MPI_Sizeof (j, kj, ierror)
  35   call MPI_Sizeof (a, ka, ierror)
  36   ntlen=2*ka+2*kj
  37   krat=ntlen/kj
  38   disp=(/0,2*ka/)
  39
  40   !  calculate answers for expected i values for Get_elements with derived type
  41   ians0(0)=ka
  42   ians0(1)=2*ka
  43   ians0(2)=2*ka+kj
  44   ians0(3)=2*ka+2*kj
  45   ii=0
  46   do i=1,24
  47      if (i .eq. ians0(ii)) ii=ii+1
  48      ians1(i)=ii
  49   enddo
  50   if (rank == 0 .and. verbose > 0) print *, (ians1(k),k=1,24)
  51   jj=0
  52   do j=0,19,4
  53      ians(j)=jj+ka/kj
  54      ians(j+1)=jj+2*(ka/kj)
  55      ians(j+2)=jj+2*(ka/kj)+1
  56      ians(j+3)=jj+2*(ka/kj)+2
  57      if (rank == 0 .and. verbose > 0) print *, (ians(k),k=j,j+3)
  58      jj=jj+ntlen/kj
  59   enddo
  60   ii=0
  61   do i=1,20
  62      if (i .eq. ians(ii)) ii=ii+1
  63      ians2(i)=ii
  64   enddo
  65   if (rank == 0 .and. verbose > 0) print *, (ians2(k),k=1,20)
  66
  67   if (verbose > 0) print *, MPI_UNDEFINED
  68
  69   call MPI_Type_create_struct(nb, blklen, disp, types, newtype, ierror)
  70   call MPI_Type_commit(newtype, ierror)
  71
  72   do i=1,24
  73      if (rank == 0) then
  74         call MPI_Send(cbuff, i, MPI_BYTE, dest, 100, comm, ierror)
  75
  76      else if (rank == dest) then
  77
  78         !     first receive
  79         call MPI_Recv(dbuff, dmax, newtype, 0, 100, comm, status, ierror)
  80         !       check on MPI_Get_elements
  81         call MPI_Get_elements(status, newtype, count, ierror)
  82         if (count .ne. ians1(i)) then
  83            errs=errs+1
  84            write (*,fmt="(i2,'  R1 Get_elements  count=',i3,&
  85                 &'  but should be ',i3)") i,count,ians1(i)
  86         endif
  87
  88      else
  89         !     other ranks do not participate
  90      endif
  91   enddo
  92
  93   do i=1,20
  94      if (rank == 0) then
  95         call MPI_Send(ibuff, i, MPI_INTEGER, dest, 100, comm, ierror)
  96
  97      else if (rank == dest) then
  98
  99         !     second receive
 100         call MPI_Recv(dbuff, dmax, newtype, 0, 100, comm, status, ierror)
 101         !       check on MPI_Get_elements
 102         call MPI_Get_elements(status, newtype, count, ierror)
 103         if (count .ne. ians2(i)) then
 104            errs=errs+1
 105            write (*,fmt="(i2,'  R2 Get_elements  count=',i3,&
 106                 &'  but should be ',i3)") i,count,ians2(i)
 107         endif
 108      else
 109         !     other ranks do not participate
 110      endif
 111   enddo
 112
 113   if (rank .eq. dest) then
 114      if (errs .eq. 0) then
 115         write (*,*) " No Errors"
 116      else
 117         print *, 'errs=',errs
 118      endif
 119   endif
 120
 121   call MPI_Type_free(newtype, ierror)
 122   call MPI_Finalize(ierror)
 123
 124 end program get_elem_d