X-Git-Url: http://info.iut-bm.univ-fcomte.fr/pub/gitweb/simgrid.git/blobdiff_plain/3f31053637ef02fcd96e3819683103686ce11992..9deda161a84a426d0ea75ec4bd9b8cdc3a4b28fb:/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f

diff --git a/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f b/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f
new file mode 100644
index 0000000000..32e9af4330
--- /dev/null
+++ b/teshsuite/smpi/mpich3-test/f77/datatype/typem2f.f
@@ -0,0 +1,177 @@
+C -*- Mode: Fortran; -*- 
+C
+C  (C) 2003 by Argonne National Laboratory.
+C      See COPYRIGHT in top-level directory.
+C
+      program main
+      implicit none
+      include 'mpif.h'
+      integer errs, ierr, i, intsize
+      integer type1, type2, type3, type4, type5
+      integer max_asizev
+      parameter (max_asizev = 10)
+      include 'typeaints.h'
+      integer blocklens(max_asizev), dtypes(max_asizev)
+      integer displs(max_asizev)
+      integer recvbuf(6*max_asizev)
+      integer sendbuf(max_asizev), status(MPI_STATUS_SIZE)
+      integer rank, size
+
+      errs = 0
+
+      call mtest_init( ierr )
+
+      call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
+      call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
+C
+      call mpi_type_size( MPI_INTEGER, intsize, ierr )
+C
+      aintv(1) = 0
+      aintv(2) = 3 * intsize
+      call mpi_type_create_resized( MPI_INTEGER, aintv(1), aintv(2), 
+     &                              type1, ierr )
+      call mpi_type_commit( type1, ierr )
+      aintv(1) = -1
+      aintv(2) = -1
+      call mpi_type_get_extent( type1, aintv(1), aintv(2), ierr )
+      if (aintv(1) .ne. 0) then
+         errs = errs + 1
+         print *, 'Did not get expected lb'
+      endif
+      if (aintv(2) .ne. 3*intsize) then
+         errs = errs + 1
+         print *, 'Did not get expected extent'
+      endif
+      aintv(1) = -1
+      aintv(2) = -1
+      call mpi_type_get_true_extent( type1, aintv(1), aintv(2), ierr )
+      if (aintv(1) .ne. 0) then
+         errs = errs + 1
+         print *, 'Did not get expected true lb'
+      endif
+      if (aintv(2) .ne. intsize) then
+         errs = errs + 1
+         print *, 'Did not get expected true extent (', aintv(2), ') ',
+     &     ' expected ', intsize
+      endif
+C
+      do i=1,10
+         blocklens(i) = 1
+         aintv(i)    = (i-1) * 3 * intsize
+      enddo
+      call mpi_type_create_hindexed( 10, blocklens, aintv, 
+     &                               MPI_INTEGER, type2, ierr )
+      call mpi_type_commit( type2, ierr )
+C
+      aint = 3 * intsize
+      call mpi_type_create_hvector( 10, 1, aint, MPI_INTEGER, type3, 
+     &                              ierr )
+      call mpi_type_commit( type3, ierr )
+C
+      do i=1,10
+         blocklens(i) = 1
+         dtypes(i)    = MPI_INTEGER
+         aintv(i)    = (i-1) * 3 * intsize
+      enddo
+      call mpi_type_create_struct( 10, blocklens, aintv, dtypes,
+     &                             type4, ierr )
+      call mpi_type_commit( type4, ierr )
+
+      do i=1,10
+         displs(i)    = (i-1) * 3
+      enddo
+      call mpi_type_create_indexed_block( 10, 1, displs, 
+     &                               MPI_INTEGER, type5, ierr )
+      call mpi_type_commit( type5, ierr )
+C
+C Using each time, send and receive using these types
+      do i=1, max_asizev*3
+         recvbuf(i) = -1
+      enddo
+      do i=1, max_asizev
+         sendbuf(i) = i
+      enddo
+      call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, 
+     &                   recvbuf, max_asizev, type1, rank, 0, 
+     &                   MPI_COMM_WORLD, status, ierr )
+      do i=1, max_asizev
+         if (recvbuf(1+(i-1)*3) .ne. i ) then
+            errs = errs + 1
+            print *, 'type1:', i, 'th element = ', recvbuf(1+(i-1)*3)
+         endif
+      enddo
+C
+      do i=1, max_asizev*3
+         recvbuf(i) = -1
+      enddo
+      do i=1, max_asizev
+         sendbuf(i) = i
+      enddo
+      call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, 
+     &                   recvbuf, 1, type2, rank, 0, 
+     &                   MPI_COMM_WORLD, status, ierr )
+      do i=1, max_asizev
+         if (recvbuf(1+(i-1)*3) .ne. i ) then
+            errs = errs + 1
+            print *, 'type2:', i, 'th element = ', recvbuf(1+(i-1)*3)
+         endif
+      enddo
+C
+      do i=1, max_asizev*3
+         recvbuf(i) = -1
+      enddo
+      do i=1, max_asizev
+         sendbuf(i) = i
+      enddo
+      call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, 
+     &                   recvbuf, 1, type3, rank, 0, 
+     &                   MPI_COMM_WORLD, status, ierr )
+      do i=1, max_asizev
+         if (recvbuf(1+(i-1)*3) .ne. i ) then
+            errs = errs + 1
+            print *, 'type3:', i, 'th element = ', recvbuf(1+(i-1)*3)
+         endif
+      enddo
+C
+      do i=1, max_asizev*3
+         recvbuf(i) = -1
+      enddo
+      do i=1, max_asizev
+         sendbuf(i) = i
+      enddo
+      call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, 
+     &                   recvbuf, 1, type4, rank, 0, 
+     &                   MPI_COMM_WORLD, status, ierr )
+      do i=1, max_asizev
+         if (recvbuf(1+(i-1)*3) .ne. i ) then
+            errs = errs + 1
+            print *, 'type4:', i, 'th element = ', recvbuf(1+(i-1)*3)
+         endif
+      enddo
+C
+      do i=1, max_asizev*3
+         recvbuf(i) = -1
+      enddo
+      do i=1, max_asizev
+         sendbuf(i) = i
+      enddo
+      call mpi_sendrecv( sendbuf, max_asizev, MPI_INTEGER, rank, 0, 
+     &                   recvbuf, 1, type5, rank, 0, 
+     &                   MPI_COMM_WORLD, status, ierr )
+      do i=1, max_asizev
+         if (recvbuf(1+(i-1)*3) .ne. i ) then
+            errs = errs + 1
+            print *, 'type5:', i, 'th element = ', recvbuf(1+(i-1)*3)
+         endif
+      enddo
+C
+      call mpi_type_free( type1, ierr )
+      call mpi_type_free( type2, ierr )
+      call mpi_type_free( type3, ierr )
+      call mpi_type_free( type4, ierr )
+      call mpi_type_free( type5, ierr )
+
+      call mtest_finalize( errs )
+      call mpi_finalize( ierr )
+
+      end