add fortran 90 tests

[simgrid.git] / teshsuite / smpi / mpich3-test / f90 / datatype / get_elem_u.f90

diff --git a/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_u.f90 b/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_u.f90
new file mode 100644 (file)
index 0000000..aa9f8fe
--- /dev/null
+++ b/teshsuite/smpi/mpich3-test/f90/datatype/get_elem_u.f90
@@ -0,0 +1,72 @@
+! -*- Mode: Fortran; -*- 
+!
+!  (C) 2013 by Argonne National Laboratory.
+!      See COPYRIGHT in top-level directory.
+!
+
+! Based on a test written by Jim Hoekstra on behalf of Cray, Inc.
+! see ticket #884 https://trac.mpich.org/projects/mpich/ticket/884
+
+PROGRAM get_elem_u
+
+  USE mpi 
+  IMPLICIT NONE 
+  INTEGER    RANK, SIZE, IERR, COMM, errs 
+  INTEGER    MAX, I, K, dest
+  INTEGER   STATUS(MPI_STATUS_SIZE)
+
+  INTEGER, PARAMETER :: nb=2
+  INTEGER :: blklen(nb)=(/1,1/)
+  INTEGER :: types(nb)=(/MPI_DOUBLE_PRECISION,MPI_CHAR/)
+  INTEGER(kind=MPI_ADDRESS_KIND) :: disp(nb)=(/0,8/)
+
+  INTEGER, PARAMETER :: amax=200
+  INTEGER :: type1, type2, extent
+  REAL    :: a(amax)
+
+  errs = 0 
+  CALL MPI_Init( ierr ) 
+  COMM = MPI_COMM_WORLD 
+  CALL MPI_Comm_rank(COMM,RANK,IERR) 
+  CALL MPI_Comm_size(COMM,SIZE,IERR) 
+  dest=size-1
+
+  CALL MPI_Type_create_struct(nb, blklen, disp, types, type1, ierr)
+  CALL MPI_Type_commit(type1, ierr)
+  CALL MPI_Type_extent(type1, extent, ierr)
+
+  CALL MPI_Type_contiguous(4, Type1, Type2, ierr) 
+  CALL MPI_Type_commit(Type2, ierr) 
+  CALL MPI_Type_extent(Type2, extent, ierr)
+
+  DO k=1,17
+
+     IF(rank .EQ. 0) THEN 
+
+        !       send k copies of datatype Type1
+        CALL MPI_Send(a, k, Type1, dest, 0, comm, ierr) 
+
+     ELSE IF (rank == dest) THEN
+
+        CALL MPI_Recv(a, 200, Type2, 0, 0, comm, status, ierr) 
+        CALL MPI_Get_elements(status, Type2, i, ierr)
+        IF (i .NE. 2*k) THEN
+           errs = errs+1
+           PRINT *, "k=",k,"  MPI_Get_elements returns", i, ", but it should be", 2*k
+        END IF
+
+     ELSE
+        !       thix rank does not particupate
+     END IF
+  enddo
+
+  CALL MPI_Type_free(type1, ierr)
+  CALL MPI_Type_free(type2, ierr)
+
+  CALL MPI_Finalize( ierr )
+
+  IF(rank .EQ. 0 .AND. errs .EQ. 0) THEN
+     PRINT *, " No Errors"
+  END IF
+
+END PROGRAM get_elem_u