From 62b92216416f5cc42c8564d7dbe32aa1790549cb Mon Sep 17 00:00:00 2001 From: Steve Goldhaber Date: Mon, 25 Sep 2017 22:12:52 -0600 Subject: [PATCH] Imported mpi-serial changes from MCSclimate/mpi-serial --- src/externals/mct/mpi-serial/Makefile | 3 + src/externals/mct/mpi-serial/mpi.c | 14 + src/externals/mct/mpi-serial/mpif.h | 8 + src/externals/mct/mpi-serial/tests/ftest.F90 | 37 ++- .../mct/mpi-serial/tests/ftest_old.F90 | 248 +++++++++--------- src/externals/mct/mpi-serial/type.c | 1 + 6 files changed, 184 insertions(+), 127 deletions(-) diff --git a/src/externals/mct/mpi-serial/Makefile b/src/externals/mct/mpi-serial/Makefile index 7122f7423f4..0b1ca1db6c2 100644 --- a/src/externals/mct/mpi-serial/Makefile +++ b/src/externals/mct/mpi-serial/Makefile @@ -88,3 +88,6 @@ install: lib $(INSTALL) lib$(MODULE).a -m 644 $(libdir) $(INSTALL) mpi.h -m 644 $(includedir) $(INSTALL) mpif.h -m 644 $(includedir) + + + diff --git a/src/externals/mct/mpi-serial/mpi.c b/src/externals/mct/mpi-serial/mpi.c index d6f58adbce1..0353f477f81 100644 --- a/src/externals/mct/mpi-serial/mpi.c +++ b/src/externals/mct/mpi-serial/mpi.c @@ -323,7 +323,21 @@ int MPI_Get_library_version(char *version, int *resultlen) return(MPI_SUCCESS); } +/**********/ +void FC_FUNC( mpi_get_version, MPI_GET_VERSION )(int *mpi_vers, int *mpi_subvers, int *ierror) +{ + MPI_Get_Version(mpi_vers, mpi_subvers); + + *ierror=MPI_SUCCESS; +} + +int MPI_Get_Version(int *mpi_vers, int *mpi_subvers) +{ + *mpi_vers = 1; + *mpi_subvers = 0; + return (MPI_SUCCESS); +} /**********/ diff --git a/src/externals/mct/mpi-serial/mpif.h b/src/externals/mct/mpi-serial/mpif.h index b4537b5d4a2..678ad9e9fdd 100644 --- a/src/externals/mct/mpi-serial/mpif.h +++ b/src/externals/mct/mpi-serial/mpif.h @@ -325,3 +325,11 @@ parameter (MPI_BOTTOM=0) INTEGER MPI_MAX_LIBRARY_VERSION_STRING PARAMETER (MPI_MAX_LIBRARY_VERSION_STRING=80) + + ! + ! MPI Version + ! + INTEGER MPI_VERSION + PARAMETER (MPI_VERSION=1) + INTEGER MPI_SUBVERSION + PARAMETER (MPI_SUBVERSION=0) diff --git a/src/externals/mct/mpi-serial/tests/ftest.F90 b/src/externals/mct/mpi-serial/tests/ftest.F90 index b292b8b73cd..ef8681a35d1 100644 --- a/src/externals/mct/mpi-serial/tests/ftest.F90 +++ b/src/externals/mct/mpi-serial/tests/ftest.F90 @@ -7,8 +7,8 @@ program test implicit none integer ierr integer ec - character*(MPI_MAX_LIBRARY_VERSION_STRING) version - integer vlen + character*(MPI_MAX_LIBRARY_VERSION_STRING) version + integer vlen ec = 0 #ifdef TEST_INTERNAL @@ -17,8 +17,8 @@ program test call mpi_init(ierr) - call MPI_GET_LIBRARY_VERSION(version,vlen,ierr) - print *,"MPI Version '",version,"' len=",vlen + call MPI_GET_LIBRARY_VERSION(version,vlen,ierr) + print *,"MPI Version '",version,"' len=",vlen call test_contiguous(ec) call test_vector(ec) @@ -31,6 +31,7 @@ program test call test_multiple(ec) call test_multiple_indexed(ec) call test_collectives(ec) + call test_mpi_version(ec) call mpi_finalize(ierr) if (ec .eq. 0) then @@ -678,3 +679,31 @@ subroutine test_collectives(ec) end do end subroutine +!!!!!!!!!!!!!!!!!!!!!!!! +! Test MPI_VERSION +!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_mpi_version(ec) + use mpi + integer ec + integer ierr + integer mpiv + integer mpisv + + print *, "Testing MPI_Get_Version" + + call mpi_get_version(mpiv, mpisv, ierr) + if (ierr /= MPI_SUCCESS) then + print *, "MPI_get_VERSION ierr not zero (",ierr,")" + ec = ec + 1 + else + if (mpiv /= MPI_VERSION) then + print *, "MPI_VERSION mismatch, should be ",MPI_VERSION,", found ",mpiv + ec = ec + 1 + end if + if (mpisv /= MPI_SUBVERSION) then + print *, "MPI_SUBVERSION mismatch, should be ",MPI_SUBVERSION,", found ",mpisv + ec = ec + 1 + end if + end if + end subroutine test_mpi_version diff --git a/src/externals/mct/mpi-serial/tests/ftest_old.F90 b/src/externals/mct/mpi-serial/tests/ftest_old.F90 index 1a35d2ef3ad..938d4472a94 100644 --- a/src/externals/mct/mpi-serial/tests/ftest_old.F90 +++ b/src/externals/mct/mpi-serial/tests/ftest_old.F90 @@ -1,163 +1,165 @@ -program test - implicit none - include "mpif.h" - integer ier + program test + implicit none + include "mpif.h" - integer sreq(10), sreq2(10), rreq(10), rreq2(10) - integer sbuf(10), sbuf2(10), rbuf(10), rbuf2(10) - integer tag - integer status(MPI_STATUS_SIZE,10) - integer i - integer comm2; - logical flag; - character pname(MPI_MAX_PROCESSOR_NAME) - integer pnamesize + integer ier - integer temp,position - integer errcount + integer sreq(10), sreq2(10), rreq(10), rreq2(10) + integer sbuf(10), sbuf2(10), rbuf(10), rbuf2(10) + integer tag + integer status(MPI_STATUS_SIZE,10) + integer i + integer comm2; + logical flag; + character pname(MPI_MAX_PROCESSOR_NAME) + integer pnamesize - errcount = 0 + integer temp,position + integer errcount - print *, 'Time=',mpi_wtime() + errcount = 0 - call mpi_initialized(flag,ier) - print *, 'MPI is initialized=',flag + print *, 'Time=',mpi_wtime() - call mpi_init(ier) + call mpi_initialized(flag,ier) + print *, 'MPI is initialized=',flag - call mpi_get_processor_name(pname,pnamesize,ier) - print *, 'proc name: "',pname(1:pnamesize),'" size:',pnamesize + call mpi_init(ier) + call mpi_get_processor_name(pname,pnamesize,ier) + print *, 'proc name: "',pname(1:pnamesize),'" size:',pnamesize - call mpi_comm_dup(MPI_COMM_WORLD,comm2,ier) - call mpi_initialized(flag,ier) - print *, 'MPI is initialized=',flag + call mpi_comm_dup(MPI_COMM_WORLD,comm2,ier) + call mpi_initialized(flag,ier) + print *, 'MPI is initialized=',flag - do i=1,5 - tag= 100+i - print *, 'Post receive tag ',tag - call mpi_irecv( rbuf(i),1,MPI_INTEGER,0,tag, & - MPI_COMM_WORLD,rreq(i),ier) + do i=1,5 + tag= 100+i + print *, 'Post receive tag ',tag - end do - do i=1,5 - ! tag=1100+i - ! print *, 'Post receive tag ',tag + call mpi_irecv( rbuf(i),1,MPI_INTEGER,0,tag, & + MPI_COMM_WORLD,rreq(i),ier) - call mpi_irecv( rbuf2(i),1,MPI_INTEGER, & - MPI_ANY_SOURCE, MPI_ANY_TAG, & - comm2,rreq2(i),ier) + end do + do i=1,5 +! tag=1100+i +! print *, 'Post receive tag ',tag - end do + call mpi_irecv( rbuf2(i),1,MPI_INTEGER, & + MPI_ANY_SOURCE, MPI_ANY_TAG, & + comm2,rreq2(i),ier) + end do - do i=1,5 - sbuf(i)=10*i - tag=100+i - print *, 'Send ',sbuf(i),' tag ',tag - call mpi_isend( sbuf(i),1,MPI_INTEGER,0,tag, & - MPI_COMM_WORLD,sreq(i),ier) - end do + do i=1,5 + sbuf(i)=10*i + tag=100+i + print *, 'Send ',sbuf(i),' tag ',tag + call mpi_isend( sbuf(i),1,MPI_INTEGER,0,tag, & + MPI_COMM_WORLD,sreq(i),ier) + end do - do i=1,5 - sbuf2(i)=1000+10*i - tag=1100+i - print *, 'Send ',sbuf2(i),' tag ',tag - call mpi_isend( sbuf2(i),1,MPI_INTEGER,0,tag, & - comm2,sreq2(i),ier) - end do + do i=1,5 + sbuf2(i)=1000+10*i + tag=1100+i + print *, 'Send ',sbuf2(i),' tag ',tag - do i=1,5 - if (sbuf(i) .ne. rbuf(i)) then - errcount = errcount+1 - print *, 'error on Send2' - print *, 'found ',sbuf2(i),' should be ',rbuf2(i) - end if - end do + call mpi_isend( sbuf2(i),1,MPI_INTEGER,0,tag, & + comm2,sreq2(i),ier) + end do - do i=1,5 - if (sbuf2(i) .ne. rbuf2(i)) then - errcount = errcount+1 - print *, 'error on Send2' - print *, 'found ',sbuf2(i),' should be ',rbuf2(i) - end if - end do + do i=1,5 + if (sbuf(i) .ne. rbuf(i)) then + errcount = errcount+1 + print *, 'error on Send2' + print *, 'found ',sbuf2(i),' should be ',rbuf2(i) + end if + end do - print *, 'Time=',mpi_wtime() - call mpi_waitall(5,sreq,status,ier) - print *,'sends on MPI_COMM_WORLD done' + do i=1,5 + if (sbuf2(i) .ne. rbuf2(i)) then + errcount = errcount+1 + print *, 'error on Send2' + print *, 'found ',sbuf2(i),' should be ',rbuf2(i) + end if + end do - call mpi_waitall(5,rreq,status,ier) - print *,'recvs on MPI_COMM_WORLD done' + print *, 'Time=',mpi_wtime() + call mpi_waitall(5,sreq,status,ier) + print *,'sends on MPI_COMM_WORLD done' - do i=1,5 - print *, 'Status source=',status(MPI_SOURCE,i), & - ' tag=',status(MPI_TAG,i) - end do + call mpi_waitall(5,rreq,status,ier) + print *,'recvs on MPI_COMM_WORLD done' + + do i=1,5 + print *, 'Status source=',status(MPI_SOURCE,i), & + ' tag=',status(MPI_TAG,i) + end do - call mpi_waitall(5,sreq2,status,ier) - print *,'sends on comm2 done' + call mpi_waitall(5,sreq2,status,ier) + print *,'sends on comm2 done' - call mpi_waitall(5,rreq2,status,ier) - print *,'recvs on comm2 done' + call mpi_waitall(5,rreq2,status,ier) + print *,'recvs on comm2 done' - do i=1,5 - print *, 'Status source=',status(MPI_SOURCE,i), & - ' tag=',status(MPI_TAG,i) - end do + do i=1,5 + print *, 'Status source=',status(MPI_SOURCE,i), & + ' tag=',status(MPI_TAG,i) + end do - ! pack/unpack +! pack/unpack - position=0 - do i=1,5 - temp=100+i - call mpi_pack(temp,1,MPI_INTEGER,sbuf,20,position,MPI_COMM_WORLD,ier) - end do + position=0 + do i=1,5 + temp=100+i + call mpi_pack(temp,1,MPI_INTEGER,sbuf,20,position,MPI_COMM_WORLD,ier) + end do - call mpi_isend(sbuf,position,MPI_PACKED,0,0,MPI_COMM_WORLD,sreq(1),ier) - call mpi_irecv(rbuf,position,MPI_PACKED,0,0,MPI_COMM_WORLD,rreq(1),ier) - call mpi_waitall(1,rreq,status,ier) + call mpi_isend(sbuf,position,MPI_PACKED,0,0,MPI_COMM_WORLD,sreq(1),ier) + call mpi_irecv(rbuf,position,MPI_PACKED,0,0,MPI_COMM_WORLD,rreq(1),ier) + call mpi_waitall(1,rreq,status,ier) - print *,"Pack/send/unpack:" + print *,"Pack/send/unpack:" - position=0 - do i=1,5 - call mpi_unpack( rbuf,20,position,temp,1,MPI_INTEGER, & - MPI_COMM_WORLD) - print *,temp - end do + position=0 + do i=1,5 + call mpi_unpack( rbuf,20,position,temp,1,MPI_INTEGER, & + MPI_COMM_WORLD) + print *,temp + end do + + do i=1,5 + if (rbuf(i) .ne. sbuf(i)) then + errcount = errcount + 1 + print *,"Error for pack/send/unpack" + print *,"found ",rbuf(i)," should be ",sbuf(i) + end if + end do +! + + + call mpi_finalize(ier) + + do i=1,5 + print *, 'Time=',mpi_wtime() + call sleep(1) + end do + + if (errcount .gt. 0) then + print *,errcount," errors" + else + print *,"No errors" + end if + + end - do i=1,5 - if (rbuf(i) .ne. sbuf(i)) then - errcount = errcount + 1 - print *,"Error for pack/send/unpack" - print *,"found ",rbuf(i)," should be ",sbuf(i) - end if - end do - ! - - - call mpi_finalize(ier) - - do i=1,5 - print *, 'Time=',mpi_wtime() - call sleep(1) - end do - - if (errcount .gt. 0) then - print *,errcount," errors" - else - print *,"No errors" - end if - -end program test diff --git a/src/externals/mct/mpi-serial/type.c b/src/externals/mct/mpi-serial/type.c index ac3b8400e63..8dd93f27414 100644 --- a/src/externals/mct/mpi-serial/type.c +++ b/src/externals/mct/mpi-serial/type.c @@ -843,3 +843,4 @@ int Pprint_typemap(Datatype type) return MPI_SUCCESS; } #endif //TEST_INTERNAL +