diff --git a/src/LIB/SURCOUCHE/src/mode_mppdb.f90 b/src/LIB/SURCOUCHE/src/mode_mppdb.f90
index 117b66edd2800d782bdf1ea80d33f39ca6d15ba4..df97445234ad2d57e1ca39b3906dd3943e776372 100644
--- a/src/LIB/SURCOUCHE/src/mode_mppdb.f90
+++ b/src/LIB/SURCOUCHE/src/mode_mppdb.f90
@@ -22,6 +22,7 @@ MODULE MODE_MPPDB
! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
! P. Wautelet 26/04/2019: use modd_precision parameters for datatypes of MPI communications
! J. Escobar 09/07/2019: bug, in MPPDB_CHECK_SURFEX3D, recompute IKSIZE_ll for local 0 size array
+! J. Escobar 08/07/2022: add MPPDB_CHECK3D_REAL_MG , for MultiGrid check
!-----------------------------------------------------------------
!
use ISO_FORTRAN_ENV, only: OUTPUT_UNIT
@@ -84,6 +85,26 @@ MODULE MODE_MPPDB
module procedure mppdb_check4d_real
end interface
+ INTERFACE
+ SUBROUTINE MPPDB_CHECK3D_REAL_MG(PTAB,MESSAGE,PPRECISION)
+ IMPLICIT NONE
+ !
+ REAL,DIMENSION(:,:,:),INTENT(IN) :: PTAB
+ CHARACTER(LEN=*), INTENT(IN) :: MESSAGE
+ REAL,OPTIONAL, INTENT(IN) :: PPRECISION
+ END SUBROUTINE MPPDB_CHECK3D_REAL_MG
+ END INTERFACE
+
+ INTERFACE
+ SUBROUTINE MPPDB_CHECK0D_REAL_MG(PTAB,MESSAGE,PPRECISION)
+ IMPLICIT NONE
+ !
+ REAL ,INTENT(IN) :: PTAB
+ CHARACTER(LEN=*), INTENT(IN) :: MESSAGE
+ REAL,OPTIONAL, INTENT(IN) :: PPRECISION
+ END SUBROUTINE MPPDB_CHECK0D_REAL_MG
+ END INTERFACE
+
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -113,7 +134,7 @@ MODULE MODE_MPPDB
INTEGER :: INFO_SPAWN
INTEGER :: RANK_FATHER = 0
INTEGER,ALLOCATABLE :: info_error(:)
- CHARACTER(LEN=chlg) :: chaine
+ CHARACTER(LEN=40) :: chaine
LOGICAL :: isset
@@ -188,14 +209,14 @@ MODULE MODE_MPPDB
!
CALL MPI_INFO_CREATE (INFO_SPAWN , ierr)
!CALL MPI_INFO_SET (INFO_SPAWN , "host", MPPDB_HOST , ierr)
- !CALL MPI_INFO_GET (INFO_SPAWN , "host", chlg, chaine, isset ,ierr)
+ !CALL MPI_INFO_GET (INFO_SPAWN , "host", 40, chaine, isset ,ierr)
!IF (MPPDB_DEBUG) PRINT*,"MPPDB_INIT:: FATHER ::INFO_SPAWN , host=",isset,chaine
!IF (ierr.NE.0) STOP 'MPPDB_INIT :: PB MPI_INFO_SET "host" '
!
! working directory
!
CALL MPI_INFO_SET (INFO_SPAWN , "wdir", MPPDB_WDIR , ierr)
- CALL MPI_INFO_GET (INFO_SPAWN , "wdir", chlg, chaine, isset ,ierr)
+ CALL MPI_INFO_GET (INFO_SPAWN , "wdir", 40, chaine, isset ,ierr)
IF (MPPDB_DEBUG) PRINT*,"MPPDB_INIT:: FATHER :: INFO_SPAWN , wdir=",isset,chaine
if (ierr /= 0 ) call Print_msg( NVERB_FATAL, 'GEN', 'MPPDB_INIT', 'MPI_INFO_SET failed' )
@@ -375,9 +396,11 @@ MODULE MODE_MPPDB
!
!implemented for only 1 process on each side
IF (MPPDB_NBPROC_INTRA>2) THEN
- IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) &
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_INT','only works with 1 process on each side')
- RETURN
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_INT','only works with 1 process on each side'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
+ RETURN
END IF
!
CALL GET_FROM_DEVICE(KTAB,ITAB,G_KTAB_ON_DEVICE)
@@ -552,8 +575,10 @@ MODULE MODE_MPPDB
!
!implemented for only 1 process on each side
IF (MPPDB_NBPROC_INTRA>2) THEN
- IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) &
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_LOG','only works with 1 process on each side')
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_LOG','only works with 1 process on each side'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
RETURN
END IF
!
@@ -739,8 +764,10 @@ MODULE MODE_MPPDB
!
!implemented for only 1 process on each side
IF (MPPDB_NBPROC_INTRA>2) THEN
- IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) &
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_REAL','only works with 1 process on each side')
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_REAL','only works with 1 process on each side::'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
RETURN
END IF
!
@@ -875,7 +902,7 @@ MODULE MODE_MPPDB
END IF
#endif
END SUBROUTINE MPPDB_CHECK1D_REAL
-
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -928,8 +955,10 @@ MODULE MODE_MPPDB
!
!If array is not of the mesh size, this subroutine does not work
IF (.NOT.GISXYSIZE_GLOB) THEN
- IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) &
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_LOG','only works with arrays of mesh size')
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_LOG','only works with arrays of mesh size'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
RETURN
END IF
!
@@ -1209,8 +1238,10 @@ MODULE MODE_MPPDB
!
!If array is not of the mesh size, this subroutine does not work
IF (.NOT.GISXYSIZE_GLOB) THEN
- IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) &
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL','only works with arrays of mesh size')
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL','only works with arrays of mesh size'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
RETURN
END IF
!
@@ -1549,10 +1580,12 @@ MODULE MODE_MPPDB
!
!If array is not of the mesh size, this subroutine works only for 1 process on each side
IF (.NOT.GISXYSIZE_GLOB .AND. MPPDB_NBPROC_INTRA>2) THEN
- IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) &
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK2D_REAL', &
- 'only works with 1 process on each side for arrays not of mesh size')
- RETURN
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK2D_REAL', &
+ 'only works with 1 process on each side for arrays not of mesh size'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
+ RETURN
END IF
!
CALL MPPDB_BARRIER()
@@ -1594,8 +1627,11 @@ MODULE MODE_MPPDB
IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll))
CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll,IINFO_ll)
ELSE
- IF (MPPDB_NBPROC_INTRA>2) CALL PRINT_MSG(NVERB_FATAL,'GEN','MPPDB_CHECK2D_REAL', &
- 'only works with 1 process on each side for arrays not of mesh size')
+ IF (MPPDB_NBPROC_INTRA>2) THEN
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','MPPDB_CHECK2D_REAL', &
+ 'only works with 1 process on each side for arrays not of mesh size'//MSG)
+ STOP
+ END IF
IIU_ll = SIZE(PTAB,1)
IJU_ll = SIZE(PTAB,2)
IIMAX_ll = IIU_ll
@@ -1704,8 +1740,11 @@ MODULE MODE_MPPDB
IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll))
CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll,IINFO_ll)
ELSE
- IF (MPPDB_NBPROC_INTRA>2) CALL PRINT_MSG(NVERB_FATAL,'GEN','MPPDB_CHECK2D_REAL', &
- 'only works with 1 process on each side for arrays not of mesh size')
+ IF (MPPDB_NBPROC_INTRA>2) THEN
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','MPPDB_CHECK2D_REAL', &
+ 'only works with 1 process on each side for arrays not of mesh size'//MSG)
+ STOP
+ END IF
IIU_ll = SIZE(PTAB,1)
IJU_ll = SIZE(PTAB,2)
IIMAX_ll = IIU_ll
@@ -2269,3 +2308,428 @@ MODULE MODE_MPPDB
END SUBROUTINE CHECK_ISXYSIZE
!
END MODULE MODE_MPPDB
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE MPPDB_CHECK3D_REAL_MG(PTAB,MESSAGE,PPRECISION)
+ !
+ USE MODD_MPIF, ONLY: MPI_CHARACTER, MPI_STATUS_IGNORE, MPI_SUM, MPI_MAX
+ use modd_precision, only: MNHINT_MPI, MNHREAL_MPI
+ !
+ USE MODE_DEVICE
+ !
+ USE MODE_MPPDB, ONLY: NMAXMSGLEN,NMAXPAS,NTAG
+ USE MODE_MPPDB, ONLY: mppdb_initialized,mppdb_actived,xprecision
+ USE MODE_MPPDB, ONLY: mppdb_inter_comm,mppdb_nbproc_intra,mppdb_intra_comm
+ USE MODE_MPPDB, ONLY: mppdb_father_world,mppdb_irank_world,mppdb_nbproc_world
+ USE MODE_MPPDB, ONLY: mppdb_barrier
+ USE mode_msg
+ use modi_tools_c
+ use ISO_FORTRAN_ENV, only: OUTPUT_UNIT
+ !
+ IMPLICIT NONE
+ !
+ REAL,DIMENSION(:,:,:),INTENT(IN) :: PTAB
+ CHARACTER(LEN=*), INTENT(IN) :: MESSAGE
+ REAL,OPTIONAL, INTENT(IN) :: PPRECISION
+ !
+ CHARACTER(len=40) :: YMSG
+ CHARACTER(len=NMAXMSGLEN) :: MSG
+ CHARACTER(len=NMAXMSGLEN),DIMENSION(:),ALLOCATABLE :: ALLMSG
+ INTEGER :: IINFO_ll
+ INTEGER :: I_FIRST_FATHER, I_FIRST_SON
+ INTEGER :: IPAS,NPAS,NPAS_ll
+ INTEGER :: IGLBSIZEPTAB
+ INTEGER :: ISIZEOTHER
+ LOGICAL :: G_PTAB_ON_DEVICE
+ LOGICAL,DIMENSION(NMAXPAS) :: OK
+ REAL :: ZDIV
+ REAL :: ZPRECISION
+ REAL,DIMENSION(NMAXPAS) :: MAX_DIFF , MAX_VAL
+ REAL, DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2),SIZE(PTAB,3)) :: ZTAB_SON
+ REAL, DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2),SIZE(PTAB,3),2) :: ZTAB_DIFF
+ !
+ REAL, ALLOCATABLE , DIMENSION(:,:,:) :: ZTAB
+ !
+#ifdef MNH_SP4
+ !pas de mpi_spawn sur IBM-SP ni MPI_ARGV_NULL etc ...
+ RETURN
+#else
+ IF ( ( .NOT. MPPDB_INITIALIZED ) .OR. ( .NOT. MPPDB_ACTIVED ) ) RETURN
+ !
+ IF ( PRESENT(PPRECISION) ) THEN
+ ZPRECISION = PPRECISION
+ ELSE
+ ZPRECISION = XPRECISION
+ END IF
+ !
+ !get the global size of PTAB
+ CALL MPI_ALLREDUCE(SIZE(PTAB), IGLBSIZEPTAB, 1,MNHINT_MPI, MPI_SUM, MPPDB_INTER_COMM, IINFO_ll)
+ IF ( IGLBSIZEPTAB == 0 ) RETURN
+ !
+ ALLOCATE(ZTAB(SIZE(PTAB,1),SIZE(PTAB,2),SIZE(PTAB,3)))
+ !
+ CALL MPPDB_BARRIER()
+ !
+ !
+ ALLOCATE(ALLMSG(MPPDB_NBPROC_INTRA))
+ MSG = MESSAGE
+ CALL MPI_ALLGATHER(MSG,LEN(MSG),MPI_CHARACTER,ALLMSG,LEN(MSG),MPI_CHARACTER,MPPDB_INTRA_COMM,IINFO_ll)
+ DO IPAS = 1, MPPDB_NBPROC_INTRA
+ IF ( ALLMSG(IPAS) /= MSG ) &
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','MPPDB_CHECK3D_REAL_MG','message not similar on all processes (' &
+ //TRIM(ALLMSG(IPAS))//' vs '//TRIM(MSG)//')')
+ END DO
+ DEALLOCATE(ALLMSG)
+ !
+ !implemented for only 1 process on each side
+ IF (MPPDB_NBPROC_INTRA>2) THEN
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL_MG','only works with 1 process on each side'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
+ RETURN
+ END IF
+ !
+ CALL GET_FROM_DEVICE(PTAB,ZTAB,G_PTAB_ON_DEVICE)
+ !
+ NPAS = 1
+ IF (G_PTAB_ON_DEVICE) NPAS=2
+ CALL MPI_ALLREDUCE(NPAS,NPAS_ll,1,MNHINT_MPI,MPI_MAX,MPPDB_INTRA_COMM,IINFO_ll)
+ !
+ IF (NPAS_ll>NMAXPAS) THEN
+ NPAS_ll = NMAXPAS
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL_MG','NPAS_ll reduced')
+ END IF
+ !
+ MAX_DIFF(:) = 0.0
+ !
+ DO IPAS=1,NPAS_ll
+ IF ((IPAS.EQ.2) .AND. G_PTAB_ON_DEVICE ) ZTAB = PTAB ! the 2 time test the value on host
+ !
+ IF(MPPDB_FATHER_WORLD) THEN
+ IF (MPPDB_IRANK_WORLD.EQ.0) THEN
+ I_FIRST_SON = MPPDB_NBPROC_WORLD
+ CALL MPI_SENDRECV(SIZE(ZTAB),1,MNHINT_MPI,I_FIRST_SON,NTAG, &
+ ISIZEOTHER,1,MNHINT_MPI,I_FIRST_SON,NTAG, &
+ MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
+ IF (SIZE(ZTAB)==ISIZEOTHER) THEN
+ CALL MPI_RECV(ZTAB_SON,SIZE(ZTAB_SON),MNHREAL_MPI,I_FIRST_SON, &
+ NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
+ ZTAB_DIFF(:,:,:,IPAS) = ABS ( ZTAB(:,:,:) - ZTAB_SON(:,:,:) )
+ MAX_VAL(IPAS) = MAXVAL( ABS (ZTAB_SON) )
+ MAX_DIFF(IPAS) = MAXVAL( ZTAB_DIFF (:,:,:,IPAS) )
+ !
+ IF ( MAX_VAL(IPAS) .EQ. 0.0 ) THEN
+ ZDIV=1.0
+ ELSE
+ ZDIV=MAX_VAL(IPAS)
+ END IF
+ IF ( MAX_DIFF(IPAS)/ZDIV > ZPRECISION ) THEN
+ OK(IPAS) = .FALSE.
+ ELSE
+ OK(IPAS) = .TRUE.
+ END IF
+ END IF
+ END IF
+ ELSE
+ I_FIRST_FATHER = 0
+ CALL MPI_SENDRECV(SIZE(ZTAB),1,MNHINT_MPI,I_FIRST_FATHER,NTAG, &
+ ISIZEOTHER,1,MNHINT_MPI,I_FIRST_FATHER,NTAG, &
+ MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
+ IF (SIZE(ZTAB)==ISIZEOTHER) THEN
+ CALL MPI_SEND(ZTAB,SIZE(ZTAB),MNHREAL_MPI,I_FIRST_FATHER, &
+ NTAG, MPPDB_INTRA_COMM, IINFO_ll)
+ END IF
+ END IF
+ !
+ CALL MPPDB_BARRIER()
+ !
+ END DO
+ !
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ YMSG=ADJUSTL(MESSAGE)
+ IF (SIZE(ZTAB)==ISIZEOTHER) THEN
+ IF (NPAS_ll == 1) THEN
+#ifdef _COLOR_OUTPUT
+ IF ( OK(1) ) THEN
+ write(*, '( A29,A22,A40," Error: ",e15.8," MAXVAL= ",e15.8 )' ) &
+ achar(27)//'[32mMPPDB_CHECKMG :: OK'//achar(27)//'[0m ','',YMSG, MAX_DIFF(1),MAX_VAL(1)
+ ELSE
+ write(*, '( A29,A22,A40," Error: ",e15.8," MAXVAL= ",e15.8 )' ) &
+ achar(27)//'[31mMPPDB_CHECKMG :: KO'//achar(27)//'[0m ','',YMSG, MAX_DIFF(1),MAX_VAL(1)
+ END IF
+#else
+ IF ( OK(1) ) THEN
+ write(*, '(" MPPDB_CHECKMG :: OK MPPDB_CHECKMG =",A40," Error=",e15.8," MAXVAL=",e15.8)' ) &
+ MESSAGE,MAX_DIFF(1),MAX_VAL(1)
+ ELSE
+ write(*, '(" MPPDB_CHECKMG :: KO MPPDB_CHECKMG =",A40," Error=",e15.8," MAXVAL=",e15.8)' ) &
+ MESSAGE,MAX_DIFF(1),MAX_VAL(1)
+ END IF
+#endif
+ flush(unit=OUTPUT_UNIT)
+ ELSE IF (NPAS_ll == 2) THEN
+#ifdef _COLOR_OUTPUT
+ IF ( OK(1) .AND. OK(2) ) THEN
+ write(*, '( A51,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ achar(27)//'[32mMPPDB_CHECKMG :: OK on host, OK on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
+ write(*, '( A519,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8,"LOC=",3I4.3," ",3I4.3 )' ) &
+ achar(27)//'[31mMPPDB_CHECKMG :: KO on host, KO on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1),&
+ MAXLOC(ZTAB_DIFF(:,:,:,2)),MAXLOC(ZTAB_DIFF(:,:,:,1))
+ ELSE IF ( .NOT.OK(1) ) THEN
+ write(*, '( A51,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ achar(27)//'[33mMPPDB_CHECKMG :: OK on host, KO on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(2) ) THEN
+ write(*, '( A51,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ achar(27)//'[33mMPPDB_CHECKMG :: KO on host, OK on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ END IF
+#else
+ IF ( OK(1) .AND. OK(2) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHECKMG :: OK on host, OK on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHECKMG :: KO on host, KO on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(1) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHECKMG :: OK on host, KO on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(2) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHECKMG :: KO on host, OK on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ END IF
+#endif
+ flush(unit=OUTPUT_UNIT)
+ ELSE
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECKMG','NPAS_ll>2 not (yet) implemented')
+ END IF
+ ELSE
+#ifdef _COLOR_OUTPUT
+ WRITE (*,'( A,I10,I10,A40 )') achar(27)//'[31mMPPDB_CHECKMG :: KO: array sizes different on 2 sides'//achar(27)//'[0m ',&
+ SIZE(ZTAB),ISIZEOTHER,YMSG
+#else
+ WRITE (*,'( A,I10,I10,A40 )') 'MPPDB_CHECKMG :: KO: array sizes different on 2 sides',SIZE(ZTAB),ISIZEOTHER,YMSG
+#endif
+ END IF
+ END IF
+#endif
+ END SUBROUTINE MPPDB_CHECK3D_REAL_MG
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ SUBROUTINE MPPDB_CHECK0D_REAL_MG(PTAB,MESSAGE,PPRECISION)
+ !
+ USE MODD_MPIF, ONLY: MPI_CHARACTER, MPI_STATUS_IGNORE, MPI_SUM, MPI_MAX
+ use modd_precision, only: MNHINT_MPI, MNHREAL_MPI
+ !
+ USE MODE_DEVICE
+ !
+ USE MODE_MPPDB, ONLY: NMAXMSGLEN,NMAXPAS,NTAG
+ USE MODE_MPPDB, ONLY: mppdb_initialized,mppdb_actived,xprecision
+ USE MODE_MPPDB, ONLY: mppdb_inter_comm,mppdb_nbproc_intra,mppdb_intra_comm
+ USE MODE_MPPDB, ONLY: mppdb_father_world,mppdb_irank_world,mppdb_nbproc_world
+ USE MODE_MPPDB, ONLY: mppdb_barrier
+ USE mode_msg
+ use modi_tools_c
+ use ISO_FORTRAN_ENV, only: OUTPUT_UNIT
+ !
+ IMPLICIT NONE
+ !
+ REAL ,INTENT(IN) :: PTAB
+ CHARACTER(LEN=*), INTENT(IN) :: MESSAGE
+ REAL,OPTIONAL, INTENT(IN) :: PPRECISION
+ !
+ ! local variable
+ CHARACTER(len=40) :: YMSG
+ CHARACTER(len=NMAXMSGLEN) :: MSG
+ CHARACTER(len=NMAXMSGLEN),DIMENSION(:),ALLOCATABLE :: ALLMSG
+ INTEGER :: IINFO_ll
+ INTEGER :: I_FIRST_FATHER, I_FIRST_SON
+ INTEGER :: IPAS,NPAS,NPAS_ll
+ INTEGER :: IGLBSIZEPTAB
+ INTEGER :: ISIZEOTHER
+ LOGICAL :: G_PTAB_ON_DEVICE
+ LOGICAL,DIMENSION(NMAXPAS) :: OK
+ REAL :: ZDIV
+ REAL :: ZPRECISION
+ REAL,DIMENSION(NMAXPAS) :: MAX_DIFF , MAX_VAL
+ REAL :: ZTAB_SON
+ REAL, DIMENSION(2) :: ZTAB_DIFF
+ !
+ REAL :: ZTAB
+ !
+#ifdef MNH_SP4
+ !pas de mpi_spawn sur IBM-SP ni MPI_ARGV_NULL etc ...
+ RETURN
+#else
+ IF ( ( .NOT. MPPDB_INITIALIZED ) .OR. ( .NOT. MPPDB_ACTIVED ) ) RETURN
+ !
+ IF ( PRESENT(PPRECISION) ) THEN
+ ZPRECISION = PPRECISION
+ ELSE
+ ZPRECISION = XPRECISION
+ END IF
+ !
+ CALL MPPDB_BARRIER()
+ !
+ !
+ ALLOCATE(ALLMSG(MPPDB_NBPROC_INTRA))
+ MSG = MESSAGE
+ CALL MPI_ALLGATHER(MSG,LEN(MSG),MPI_CHARACTER,ALLMSG,LEN(MSG),MPI_CHARACTER,MPPDB_INTRA_COMM,IINFO_ll)
+ DO IPAS = 1, MPPDB_NBPROC_INTRA
+ IF ( ALLMSG(IPAS) /= MSG ) &
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','MPPDB_CHECK3D_REAL_MG','message not similar on all processes (' &
+ //TRIM(ALLMSG(IPAS))//' vs '//TRIM(MSG)//')')
+ END DO
+ DEALLOCATE(ALLMSG)
+ !
+ !implemented for only 1 process on each side
+!!$ IF (MPPDB_NBPROC_INTRA>2) THEN
+!!$ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+!!$ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL_MG','only works with 1 process on each side'//MSG)
+!!$ END IF
+!!$ CALL MPPDB_BARRIER()
+!!$ RETURN
+!!$ END IF
+!!$ !
+!!$ CALL GET_FROM_DEVICE(PTAB,ZTAB,G_PTAB_ON_DEVICE)
+ !
+ ZTAB = PTAB
+ G_PTAB_ON_DEVICE = .FALSE.
+ NPAS = 1
+ IF (G_PTAB_ON_DEVICE) NPAS=2
+ CALL MPI_ALLREDUCE(NPAS,NPAS_ll,1,MNHINT_MPI,MPI_MAX,MPPDB_INTRA_COMM,IINFO_ll)
+ !
+ IF (NPAS_ll>NMAXPAS) THEN
+ NPAS_ll = NMAXPAS
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL_MG','NPAS_ll reduced')
+ END IF
+ !
+ MAX_DIFF(:) = 0.0
+ !
+ DO IPAS=1,NPAS_ll
+ IF ((IPAS.EQ.2) .AND. G_PTAB_ON_DEVICE ) ZTAB = PTAB ! the 2 time test the value on host
+ !
+ IF(MPPDB_FATHER_WORLD) THEN
+ IF (MPPDB_IRANK_WORLD.EQ.0) THEN
+ I_FIRST_SON = MPPDB_NBPROC_WORLD
+!!$ CALL MPI_SENDRECV(SIZE(ZTAB),1,MNHINT_MPI,I_FIRST_SON,NTAG, &
+!!$ ISIZEOTHER,1,MNHINT_MPI,I_FIRST_SON,NTAG, &
+!!$ MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
+!!$ IF (SIZE(ZTAB)==ISIZEOTHER) THEN
+ CALL MPI_RECV(ZTAB_SON,1,MNHREAL_MPI,I_FIRST_SON, &
+ NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
+ ZTAB_DIFF(IPAS) = ABS ( ZTAB - ZTAB_SON )
+ MAX_VAL(IPAS) = ABS (ZTAB_SON)
+ MAX_DIFF(IPAS) = ZTAB_DIFF(IPAS)
+ !
+ IF ( MAX_VAL(IPAS) .EQ. 0.0 ) THEN
+ ZDIV=1.0
+ ELSE
+ ZDIV=MAX_VAL(IPAS)
+ END IF
+ IF ( MAX_DIFF(IPAS)/ZDIV > ZPRECISION ) THEN
+ OK(IPAS) = .FALSE.
+ ELSE
+ OK(IPAS) = .TRUE.
+ END IF
+!!$ END IF
+ END IF
+ ELSE
+ I_FIRST_FATHER = 0
+!!$ CALL MPI_SENDRECV(SIZE(ZTAB),1,MNHINT_MPI,I_FIRST_FATHER,NTAG, &
+!!$ ISIZEOTHER,1,MNHINT_MPI,I_FIRST_FATHER,NTAG, &
+!!$ MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
+!!$ IF (SIZE(ZTAB)==ISIZEOTHER) THEN
+ CALL MPI_SEND(ZTAB,1,MNHREAL_MPI,I_FIRST_FATHER, &
+ NTAG, MPPDB_INTRA_COMM, IINFO_ll)
+!!$ END IF
+ END IF
+ !
+ CALL MPPDB_BARRIER()
+ !
+ END DO
+ !
+ IF (MPPDB_FATHER_WORLD .AND. MPPDB_IRANK_WORLD.EQ.0) THEN
+ YMSG=ADJUSTL(MESSAGE)
+!!$ IF (SIZE(ZTAB)==ISIZEOTHER) THEN
+ IF (NPAS_ll == 1) THEN
+#ifdef _COLOR_OUTPUT
+ IF ( OK(1) ) THEN
+ write(*, '( A29,A22,A40," Error: ",e15.8," MAXVAL= ",e15.8 )' ) &
+ achar(27)//'[32mMPPDB_CHEC0MG :: OK'//achar(27)//'[0m ','',YMSG, MAX_DIFF(1),MAX_VAL(1)
+ ELSE
+ write(*, '( A29,A22,A40," Error: ",e15.8," MAXVAL= ",e15.8 )' ) &
+ achar(27)//'[31mMPPDB_CHEC0MG :: KO'//achar(27)//'[0m ','',YMSG, MAX_DIFF(1),MAX_VAL(1)
+ END IF
+#else
+ IF ( OK(1) ) THEN
+ write(*, '(" MPPDB_CHEC0MG :: OK MPPDB_CHEC0MG =",A40," Error=",e15.8," MAXVAL=",e15.8)' ) &
+ MESSAGE,MAX_DIFF(1),MAX_VAL(1)
+ ELSE
+ write(*, '(" MPPDB_CHEC0MG :: KO MPPDB_CHEC0MG =",A40," Error=",e15.8," MAXVAL=",e15.8)' ) &
+ MESSAGE,MAX_DIFF(1),MAX_VAL(1)
+ END IF
+#endif
+ flush(unit=OUTPUT_UNIT)
+ ELSE IF (NPAS_ll == 2) THEN
+#ifdef _COLOR_OUTPUT
+ IF ( OK(1) .AND. OK(2) ) THEN
+ write(*, '( A51,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ achar(27)//'[32mMPPDB_CHEC0MG :: OK on host, OK on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
+ write(*, '( A51,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ achar(27)//'[31mMPPDB_CHEC0MG :: KO on host, KO on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(1) ) THEN
+ write(*, '( A51,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ achar(27)//'[33mMPPDB_CHEC0MG :: OK on host, KO on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(2) ) THEN
+ write(*, '( A51,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ achar(27)//'[33mMPPDB_CHEC0MG :: KO on host, OK on device'//achar(27)//'[0m ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ END IF
+#else
+ IF ( OK(1) .AND. OK(2) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHEC0MG :: OK on host, OK on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHEC0MG :: KO on host, KO on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(1) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHEC0MG :: OK on host, KO on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ ELSE IF ( .NOT.OK(2) ) THEN
+ write(*, '( A42,A40," Errors: host=",e15.8," device=",e15.8," MAXVALS=",e15.8,e15.8 )' ) &
+ 'MPPDB_CHEC0MG :: KO on host, OK on device ',YMSG, &
+ MAX_DIFF(2),MAX_DIFF(1),MAX_VAL(2),MAX_VAL(1)
+ END IF
+#endif
+ flush(unit=OUTPUT_UNIT)
+ ELSE
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHEC0MG','NPAS_ll>2 not (yet) implemented')
+ END IF
+!!$ ELSE
+!!$#ifdef _COLOR_OUTPUT
+!!$ WRITE (*,'( A,I10,I10,A40 )') achar(27)//'[31mMPPDB_CHEC0MG :: KO: array sizes different on 2 sides'//achar(27)//'[0m ',&
+!!$ SIZE(ZTAB),ISIZEOTHER,YMSG
+!!$#else
+!!$ WRITE (*,'( A,I10,I10,A40 )') 'MPPDB_CHEC0MG :: KO: array sizes different on 2 sides',SIZE(ZTAB),ISIZEOTHER,YMSG
+!!$#endif
+!!$ END IF
+ END IF
+#endif
+ END SUBROUTINE MPPDB_CHECK0D_REAL_MG