From 07ce23e2427e4c1561a8bc6896f8879e0aaada89 Mon Sep 17 00:00:00 2001
From: ESCOBAR Juan <escj@nuwa>
Date: Thu, 10 Mar 2022 15:47:24 +0100
Subject: [PATCH] Juan 10/03/2022:ZSOLVER/mode_mppdb.f90, add
MPPDB_CHECK3D_REAL_MG for multigrid check
---
src/ZSOLVER/mode_mppdb.f90 | 226 ++++++++++++++++++++++++++++++++++++-
1 file changed, 225 insertions(+), 1 deletion(-)
diff --git a/src/ZSOLVER/mode_mppdb.f90 b/src/ZSOLVER/mode_mppdb.f90
index 3fb6e1542..185fb4acb 100644
--- a/src/ZSOLVER/mode_mppdb.f90
+++ b/src/ZSOLVER/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 10/10/2022: add MPPDB_CHECK3D_REAL_MG , for MultiGrid check
!-----------------------------------------------------------------
!
use ISO_FORTRAN_ENV, only: OUTPUT_UNIT
@@ -84,6 +85,16 @@ 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
+
CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -875,7 +886,7 @@ MODULE MODE_MPPDB
END IF
#endif
END SUBROUTINE MPPDB_CHECK1D_REAL
-
+
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -2269,3 +2280,216 @@ 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) &
+ CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL_MG','only works with 1 process on each side')
+ 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
--
GitLab