From 159681ea6f4a5e2973a2ab965158c05f6b181472 Mon Sep 17 00:00:00 2001
From: ESCOBAR Juan <escj@nuwa>
Date: Mon, 14 Mar 2022 19:38:25 +0100
Subject: [PATCH] Juan 14/03/2022:ZSOLVER/mode_mppdb.f90,add
MPPDB_CHECK0D_REAL_MG & some mppdb_barrier
---
src/ZSOLVER/mode_mppdb.f90 | 284 ++++++++++++++++++++++++++++++++++---
1 file changed, 262 insertions(+), 22 deletions(-)
diff --git a/src/ZSOLVER/mode_mppdb.f90 b/src/ZSOLVER/mode_mppdb.f90
index 185fb4acb..3d28a437d 100644
--- a/src/ZSOLVER/mode_mppdb.f90
+++ b/src/ZSOLVER/mode_mppdb.f90
@@ -94,6 +94,16 @@ MODULE MODE_MPPDB
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
@@ -386,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)
@@ -563,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
!
@@ -750,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
!
@@ -939,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
!
@@ -1220,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
!
@@ -1560,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()
@@ -1605,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
@@ -1715,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
@@ -2283,7 +2311,7 @@ END MODULE MODE_MPPDB
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_CHECK3D_REAL_MG(PTAB,MESSAGE,PPRECISION)
+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
@@ -2356,8 +2384,10 @@ END 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_CHECK3D_REAL_MG','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_CHECK3D_REAL_MG','only works with 1 process on each side'//MSG)
+ END IF
+ CALL MPPDB_BARRIER()
RETURN
END IF
!
@@ -2493,3 +2523,213 @@ END MODULE MODE_MPPDB
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
--
GitLab