From 490349d44b5543935aa4db26b75ccd3711a2f658 Mon Sep 17 00:00:00 2001
From: Juan ESCOBAR <juan.escobar@aero.obs-mip.fr>
Date: Fri, 8 Jul 2022 16:12:06 +0200
Subject: [PATCH] Juan 08/07/2022:ZSOLVER/mode_mppdb.f90, move to master
LIB/SURCOUCHE/src/mode_mppdb.f90
---
src/ZSOLVER/mode_mppdb.f90 | 2735 ------------------------------------
1 file changed, 2735 deletions(-)
delete mode 100644 src/ZSOLVER/mode_mppdb.f90
diff --git a/src/ZSOLVER/mode_mppdb.f90 b/src/ZSOLVER/mode_mppdb.f90
deleted file mode 100644
index 3d28a437d..000000000
--- a/src/ZSOLVER/mode_mppdb.f90
+++ /dev/null
@@ -1,2735 +0,0 @@
-!MNH_LIC Copyright 2011-2019 CNRS, Meteo-France and Universite Paul Sabatier
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
-!MNH_LIC for details. version 1.
-!-----------------------------------------------------------------
-!
-#define _COLOR_OUTPUT
-!
-MODULE MODE_MPPDB
-!
-! Modifications:
-!! J.Escobar 23/10/2012: correct CHECK_LB & format print output
-!! M.Moge 05/02/2015: MPPDB_CHECK_SURFEX2D and MPPDB_CHECK_SURFEX3D + bug fix in MPPDB_CHECK2D and MPPDB_CHECK3D (call MPI_AllReduce at the beginning)
-! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
-! G.Delautier : 23/06/2016 : surfex v8
-! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
-! P.Wautelet : 25/07/2018: added MPPDB_CHECK1D_LOG, MPPDB_CHECK1D and MPPDB_CHECK3D_LOG
-! P.Wautelet : 12/1/2018: support any array size for MPPDB_CHECK2D + check array size + modified outpout (for simpler grep) + use PRINT_MSG
-! Philippe Wautelet: 10/01/2019: use NEWUNIT argument of OPEN
-! Philippe Wautelet: 22/01/2019: use standard FLUSH statement instead of non standard intrinsics
-! Philippe Wautelet: 22/01/2019: use sleep_c subroutine instead of non-standard call system
-! 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
-
- use MODE_TOOLS_ll, only: GET_GLOBALDIMS_ll, GET_INDICE_ll
- use mode_msg
-
- use modi_tools_c
-
- IMPLICIT NONE
-
- INTEGER, PARAMETER :: NMAXPAS = 2
- INTEGER, PARAMETER :: NMAXMSGLEN = 256
- INTEGER, PARAMETER :: NTAG = 12345
-
- INTEGER ,PARAMETER :: NSLEEP=30 !Sleep duration to wait for (in seconds)
- INTEGER ,PARAMETER :: chlg=256
- CHARACTER(LEN=chlg),PARAMETER :: MPPDB_CONF = "mppdb.nam"
-
- LOGICAL :: MPPDB_INITIALIZED = .FALSE.
- LOGICAL :: MPPDB_DEBUG = .FALSE.
-
- CHARACTER(LEN=chlg) :: MPPDB_EXEC = "PREP_REAL_CASE"
- CHARACTER(LEN=chlg) :: MPPDB_HOST = "localhost"
- CHARACTER(LEN=chlg) :: MPPDB_WDIR = "."
- INTEGER :: MPPDB_NBSON = 1
-
- INTEGER :: MPPDB_INTER_COMM,MPPDB_INTRA_COMM
- INTEGER :: MPPDB_IRANK_WORLD,MPPDB_IRANK_INTRA
- INTEGER :: MPPDB_NBPROC_WORLD,MPPDB_NBPROC_INTRA
-
- LOGICAL :: MPPDB_FATHER_WORLD = .FALSE.
-
- REAL :: PRECISION = 1e-8 * 0.0 !PW: TODO: remove this variable
- REAL :: XPRECISION = 1e-8 * 0.0
- LOGICAL :: MPPDB_CHECK_LB = .FALSE.
- LOGICAL :: MPPDB_CHECK_LB_CORNERS = .FALSE.
-
- INTERFACE MPPDB_CHECK
- MODULE PROCEDURE MPPDB_CHECK1D_INT,MPPDB_CHECK1D_LOG, MPPDB_CHECK1D_REAL, &
- MPPDB_CHECK2D_REAL, &
- MPPDB_CHECK3D_LOG, MPPDB_CHECK3D_REAL, &
- Mppdb_check4d_real
- END INTERFACE
-
- INTERFACE MPPDB_CHECK1D
- MODULE PROCEDURE MPPDB_CHECK1D_REAL
- END INTERFACE
- LOGICAL :: MPPDB_ACTIVED = .FALSE.
-
- INTERFACE MPPDB_CHECK2D
- MODULE PROCEDURE MPPDB_CHECK2D_REAL
- END INTERFACE
-
- INTERFACE MPPDB_CHECK3D
- MODULE PROCEDURE MPPDB_CHECK3D_REAL
- END INTERFACE
-
- interface mppdb_check4d
- 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
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_INIT()
-#ifdef MNH_SP4
- !pas de mpi_spawn sur IBM-SP ni MPI_ARGV_NULL etc ...
- RETURN
-#else
- USE MODD_MPIF
- !JUANZ
- USE MODE_MNH_WORLD , ONLY : INIT_NMNH_COMM_WORLD
- USE MODD_VAR_ll , ONLY : NMNH_COMM_WORLD
- !JUANZ
-
- IMPLICIT NONE
-
-
- INTEGER :: IUNIT
- INTEGER :: IERR
-! INTEGER :: NBPROC_WORLD,NBPROC_INTRA
-
- LOGICAL :: GISINIT
- LOGICAL :: drapeau
-
- INTEGER :: INFO_SPAWN
- INTEGER :: RANK_FATHER = 0
- INTEGER,ALLOCATABLE :: info_error(:)
- CHARACTER(LEN=40) :: chaine
- LOGICAL :: isset
-
-
-
- NAMELIST /NAM_MPPDB/ MPPDB_DEBUG,MPPDB_EXEC,MPPDB_HOST,MPPDB_NBSON,MPPDB_WDIR,MPPDB_CHECK_LB,MPPDB_CHECK_LB_CORNERS
-
- !NMNH_COMM_WORLD = MPI_COMM_WORLD
-
- ! If already initialized, nothing to do
- IF (MPPDB_INITIALIZED) RETURN
- !
- MPPDB_INITIALIZED = .TRUE.
- MPPDB_ACTIVED = .TRUE.
- !
- ! Init MPI
- !
- CALL MPI_INITIALIZED(GISINIT, ierr)
- IF (.NOT. GISINIT) THEN
- !CALL MPI_INIT(ierr)
- CALL INIT_NMNH_COMM_WORLD(ierr)
- END IF
- !
- ! Get me rank in the my world
- !
- CALL MPI_COMM_RANK(NMNH_COMM_WORLD, MPPDB_IRANK_WORLD , ierr)
- CALL MPI_COMM_SIZE(NMNH_COMM_WORLD, MPPDB_NBPROC_WORLD, ierr)
- !
- !... Have I a father ?
- !
- CALL MPI_COMM_GET_PARENT(MPPDB_INTER_COMM, ierr)
- IF (MPPDB_INTER_COMM == MPI_COMM_NULL) THEN
- !
- ! NO Father !
- MPPDB_FATHER_WORLD = .TRUE.
- CALL MPI_BARRIER(NMNH_COMM_WORLD,ierr)
- !
- ! if no config file , inactive MPPDB routines
- !
- OPEN(newunit=IUNIT,file=MPPDB_CONF,STATUS='OLD',iostat=IERR)
- IF (IERR.NE.0 ) THEN
- ! PRINT*,"IOSTAT=",IERR
- !
- !no config file => exit from MPPDB not actived
- !
- MPPDB_INITIALIZED = .FALSE.
- RETURN
- END IF
- !
- ! read the parameter
- !
- READ(unit=IUNIT,NML=NAM_MPPDB)
- CLOSE(unit=IUNIT)
- IF ( .NOT. MPPDB_DEBUG ) THEN
- ! why don't when MMPDB to work
- MPPDB_INITIALIZED = .FALSE.
- RETURN
- ENDIF
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !-------------------------------------------------------------------------!
- ! !
- ! NO Father & rank=0 <=> I'm the root Father so Init all and Clone !
- ! !
- !-------------------------------------------------------------------------!
- IF (MPPDB_DEBUG) THEN
- WRITE(*,NML=NAM_MPPDB)
- ENDIF
- !
- ! Create the info contecte for the son
- !
- ! host
- !
- CALL MPI_INFO_CREATE (INFO_SPAWN , ierr)
- !CALL MPI_INFO_SET (INFO_SPAWN , "host", MPPDB_HOST , 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", 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' )
-
- !
- ELSE
- ! other father only do nothing but participate
- INFO_SPAWN = MPI_INFO_NULL
- !
- END IF ! IF (MPPDB_IRANK_WORLD.EQ.0)
- !
- ! clone the son
- !
- ALLOCATE(info_error(MPPDB_NBSON))
- CALL MPI_BARRIER(NMNH_COMM_WORLD,ierr)
- !
- CALL MPI_COMM_SPAWN(MPPDB_EXEC, MPI_ARGV_NULL,MPPDB_NBSON,INFO_SPAWN, &
- RANK_FATHER, NMNH_COMM_WORLD,MPPDB_INTER_COMM ,info_error, ierr)
- !
- CALL MPI_BARRIER(NMNH_COMM_WORLD,ierr)
- !
- DEALLOCATE(info_error)
- !
- ! merge the communicator
- !
- drapeau=.FALSE.
- CALL MPI_INTERCOMM_MERGE(MPPDB_INTER_COMM, drapeau, MPPDB_INTRA_COMM, ierr)
- !
- !... Numbre of processus in MPPDB_INTRA_COMM.
- CALL MPI_COMM_SIZE(MPPDB_INTRA_COMM, mppdb_nbproc_intra, ierr)
- !
- !... My rank in MPPDB_INTRA_COMM
- CALL MPI_COMM_RANK(MPPDB_INTRA_COMM, mppdb_irank_intra, ierr)
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- ! I'm the first father
- IF (MPPDB_DEBUG) print*,"MPPDB_INIT :: FIRST FATHER mppdb_irank_intra=", mppdb_irank_intra &
- ,"mppdb_nbproc_intra=",mppdb_nbproc_intra
- flush(unit=OUTPUT_UNIT)
- endif
- !
- ! Wait the sons
- !
- CALL MPI_BARRIER ( MPPDB_INTRA_COMM , ierr )
- ! WAIT FOR TOTALVIEW IF NEEDED
- call sleep_c(NSLEEP)
- !
- ELSE ! (MPPDB_INTER_COMM <> MPI_COMM_NULL)
- !-------------------------------------------------------------------------!
- ! !
- ! I've a father <=> I'm a son !
- ! !
- !-------------------------------------------------------------------------!
- !
- CALL MPI_BARRIER(NMNH_COMM_WORLD,ierr)
- !
- ! merge the communicator
- !
- drapeau=.TRUE.
- CALL MPI_INTERCOMM_MERGE(MPPDB_INTER_COMM, drapeau, MPPDB_INTRA_COMM, ierr)
- !
- !... Numbre of processus in MPPDB_INTRA_COMM.
- CALL MPI_COMM_SIZE(MPPDB_INTRA_COMM, mppdb_nbproc_intra, ierr)
- !
- !... My rang in MPPDB_INTRA_COMM
- CALL MPI_COMM_RANK(MPPDB_INTRA_COMM, mppdb_irank_intra, ierr)
- !
- !
- ! Wait the FATHER's
- !
- CALL MPI_BARRIER ( MPPDB_INTRA_COMM , ierr )
- !
- ! WAIT FOR TOTALVIEW IF NEEDED
- call sleep_c(NSLEEP)
- !
- MPPDB_DEBUG = .TRUE.
- IF (MPPDB_DEBUG) write(200,*) "MPPDB_INIT :: FIRST SON mppdb_irank_intra=", mppdb_irank_intra &
- ,"MPPDB_IRANK_WORLD=",MPPDB_IRANK_WORLD
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- ! I'm the first son
- MPPDB_DEBUG = .TRUE.
- IF (MPPDB_DEBUG) print*,"MPPDB_INIT :: FIRSTSON mppdb_irank_intra=", mppdb_irank_intra
- END IF
- END IF ! IF (MPPDB_INTER_COMM == MPI_COMM_NULL)
-
- CALL MPI_BARRIER ( MPPDB_INTRA_COMM , ierr )
-
-#endif
- END SUBROUTINE MPPDB_INIT
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_START_DEBUG()
- IMPLICIT NONE
- MPPDB_ACTIVED = .TRUE.
- END SUBROUTINE MPPDB_START_DEBUG
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_STOP_DEBUG()
- IMPLICIT NONE
- MPPDB_ACTIVED = .FALSE.
- END SUBROUTINE MPPDB_STOP_DEBUG
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_GET_ACTIVED(OACTIVE)
- IMPLICIT NONE
- LOGICAL , INTENT(OUT) :: OACTIVE
- OACTIVE = MPPDB_ACTIVED
- END SUBROUTINE MPPDB_GET_ACTIVED
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_SET_ACTIVED(OACTIVE)
- IMPLICIT NONE
- LOGICAL , INTENT(IN) :: OACTIVE
- MPPDB_ACTIVED = OACTIVE
- END SUBROUTINE MPPDB_SET_ACTIVED
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_BARRIER()
-#ifdef MNH_SP4
- !pas de mpi_spawn sur IBM-SP ni MPI_ARGV_NULL etc ...
- RETURN
-#else
- IMPLICIT NONE
- INTEGER :: IERR
- !
- ! synchronize all father & sons
- !
- IF (( .NOT. MPPDB_INITIALIZED ) .OR. ( .NOT. MPPDB_ACTIVED )) RETURN
- !
- CALL MPI_BARRIER(MPPDB_INTRA_COMM,IERR)
- !
-#endif
- END SUBROUTINE MPPDB_BARRIER
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_CHECK1D_INT(KTAB,MESSAGE)
- !
- USE MODD_MPIF, ONLY: MPI_CHARACTER, MPI_STATUS_IGNORE, MPI_SUM, MPI_MAX
- use modd_precision, only: MNHINT_MPI
- !
- USE MODE_DEVICE
- !
- IMPLICIT NONE
- !
- INTEGER,DIMENSION(:),INTENT(IN) :: KTAB
- CHARACTER(LEN=*), INTENT(IN) :: MESSAGE
- !
- 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
- INTEGER,DIMENSION(NMAXPAS) :: INUMDIFF
- LOGICAL :: G_KTAB_ON_DEVICE
- LOGICAL,DIMENSION(NMAXPAS) :: OK
- INTEGER,DIMENSION(SIZE(KTAB,1)) :: ITAB, ITAB_SON
- !
-#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
- !get the global size of KTAB
- CALL MPI_ALLREDUCE(SIZE(KTAB), IGLBSIZEPTAB, 1, MNHINT_MPI, MPI_SUM, MPPDB_INTER_COMM, IINFO_ll)
- IF ( IGLBSIZEPTAB == 0 ) RETURN
- !
- 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_CHECK1D_INT','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_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)
- !
- NPAS = 1
- IF (G_KTAB_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_CHECK1D_INT','NPAS_ll reduced')
- END IF
- !
- DO IPAS=1,NPAS_ll
- IF ((IPAS.EQ.2) .AND. G_KTAB_ON_DEVICE ) ITAB = KTAB ! 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(ITAB), 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(ITAB)==ISIZEOTHER) THEN
- CALL MPI_RECV(ITAB_SON,SIZE(ITAB_SON),MNHINT_MPI,I_FIRST_SON, &
- NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
- INUMDIFF(IPAS) = COUNT( ITAB(:)/=ITAB_SON(:) )
- IF ( INUMDIFF(IPAS)>0 ) THEN
- OK(IPAS) = .FALSE.
- ELSE
- OK(IPAS) = .TRUE.
- END IF
- END IF
- END IF
- ELSE
- I_FIRST_FATHER = 0
- CALL MPI_SENDRECV(SIZE(ITAB),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(ITAB)==ISIZEOTHER) THEN
- CALL MPI_SEND(ITAB,SIZE(ITAB),MNHINT_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(ITAB)==ISIZEOTHER) THEN
- IF (NPAS_ll == 1) THEN
-#ifdef _COLOR_OUTPUT
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- achar(27)//'[32mMPPDB_CHECK1D :: OK'//achar(27)//'[0m ','',YMSG, INUMDIFF(1),SIZE(KTAB)
- ELSE
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- achar(27)//'[31mMPPDB_CHECK1D :: KO'//achar(27)//'[0m ','',YMSG, INUMDIFF(1),SIZE(KTAB)
- END IF
-#else
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- 'MPPDB_CHECK1D :: OK','',YMSG, INUMDIFF(1),SIZE(KTAB)
- ELSE
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- 'MPPDB_CHECK1D :: KO','',YMSG, INUMDIFF(1),SIZE(KTAB)
- 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=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[32mMPPDB_CHECK1D :: OK on host, OK on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[31mMPPDB_CHECK1D :: KO on host, KO on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- ELSE IF ( .NOT.OK(1) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[33mMPPDB_CHECK1D :: OK on host, KO on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- ELSE IF ( .NOT.OK(2) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[33mMPPDB_CHECK1D :: KO on host, OK on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- END IF
-#else
- IF ( OK(1) .AND. OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: OK on host, OK on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: KO on host, KO on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- ELSE IF ( .NOT.OK(1) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: OK on host, KO on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- ELSE IF ( .NOT.OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: KO on host, OK on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(KTAB)
- END IF
-#endif
- flush(unit=OUTPUT_UNIT)
- ELSE
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_INT','NPAS_ll>2 not (yet) implemented')
- END IF
- ELSE
-#ifdef _COLOR_OUTPUT
- WRITE (*,'( A,I10,I10,A40 )') achar(27)//'[31mMPPDB_CHECK1D :: KO: array sizes different on 2 sides'//achar(27)//'[0m ',&
- SIZE(ITAB),ISIZEOTHER,YMSG
-#else
- WRITE (*,'( A,I10,I10,A40 )') 'MPPDB_CHECK1D :: KO: array sizes different on 2 sides',SIZE(ITAB),ISIZEOTHER,YMSG
-#endif
- END IF
- END IF
-#endif
- END SUBROUTINE MPPDB_CHECK1D_INT
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_CHECK1D_LOG(OTAB,MESSAGE)
- !
- USE MODD_MPIF, ONLY: MPI_CHARACTER, MPI_STATUS_IGNORE, MPI_SUM, MPI_MAX
- use modd_precision, only: MNHINT_MPI, MNHLOG_MPI
- !
- USE MODE_DEVICE
- !
- IMPLICIT NONE
- !
- LOGICAL,DIMENSION(:),INTENT(IN) :: OTAB
- CHARACTER(LEN=*), INTENT(IN) :: MESSAGE
- !
- 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
- INTEGER,DIMENSION(NMAXPAS) :: INUMDIFF
- LOGICAL :: G_OTAB_ON_DEVICE
- LOGICAL,DIMENSION(NMAXPAS) :: OK
- LOGICAL, DIMENSION(SIZE(OTAB,1)) :: GTAB, GTAB_SON
- !
-#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
- !get the global size of OTAB
- CALL MPI_ALLREDUCE(SIZE(OTAB), IGLBSIZEPTAB, 1, MNHINT_MPI, MPI_SUM, MPPDB_INTER_COMM, IINFO_ll)
- IF ( IGLBSIZEPTAB == 0 ) RETURN
- !
- 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_CHECK1D_LOG','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_CHECK1D_LOG','only works with 1 process on each side'//MSG)
- END IF
- CALL MPPDB_BARRIER()
- RETURN
- END IF
- !
- CALL GET_FROM_DEVICE(OTAB,GTAB,G_OTAB_ON_DEVICE)
- !
- NPAS = 1
- IF (G_OTAB_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_CHECK1D_LOG','NPAS_ll reduced')
- END IF
- !
- DO IPAS=1,NPAS_ll
- IF ((IPAS.EQ.2) .AND. G_OTAB_ON_DEVICE ) GTAB = OTAB ! 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(GTAB),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(GTAB)==ISIZEOTHER) THEN
- CALL MPI_RECV(GTAB_SON,SIZE(GTAB_SON),MNHLOG_MPI,I_FIRST_SON, &
- NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
- INUMDIFF(IPAS) = COUNT( GTAB(:).NEQV.GTAB_SON(:) )
- IF ( INUMDIFF(IPAS)>0 ) THEN
- OK(IPAS) = .FALSE.
- ELSE
- OK(IPAS) = .TRUE.
- END IF
- END IF
- END IF
- ELSE
- I_FIRST_FATHER = 0
- CALL MPI_SENDRECV(SIZE(GTAB),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(GTAB)==ISIZEOTHER) THEN
- CALL MPI_SEND(GTAB,SIZE(GTAB),MNHLOG_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(GTAB)==ISIZEOTHER) THEN
- IF (NPAS_ll == 1) THEN
-#ifdef _COLOR_OUTPUT
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- achar(27)//'[32mMPPDB_CHECK1D :: OK'//achar(27)//'[0m ','',YMSG, INUMDIFF(1),SIZE(OTAB)
- ELSE
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- achar(27)//'[31mMPPDB_CHECK1D :: KO'//achar(27)//'[0m ','',YMSG, INUMDIFF(1),SIZE(OTAB)
- END IF
-#else
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- 'MPPDB_CHECK1D :: OK','',YMSG, INUMDIFF(1),SIZE(OTAB)
- ELSE
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- 'MPPDB_CHECK1D :: KO','',YMSG, INUMDIFF(1),SIZE(OTAB)
- 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=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[32mMPPDB_CHECK1D :: OK on host, OK on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[31mMPPDB_CHECK1D :: KO on host, KO on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(1) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[33mMPPDB_CHECK1D :: OK on host, KO on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(2) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[33mMPPDB_CHECK1D :: KO on host, OK on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- END IF
-#else
- IF ( OK(1) .AND. OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: OK on host, OK on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: KO on host, KO on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(1) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: OK on host, KO on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK1D :: KO on host, OK on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- END IF
-#endif
- flush(unit=OUTPUT_UNIT)
- ELSE
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK1D_LOG','NPAS_ll>2 not (yet) implemented')
- END IF
- ELSE
-#ifdef _COLOR_OUTPUT
- WRITE (*,'( A,I10,I10,A40 )') achar(27)//'[31mMPPDB_CHECK1D :: KO: array sizes different on 2 sides'//achar(27)//'[0m ',&
- SIZE(GTAB),ISIZEOTHER,YMSG
-#else
- WRITE (*,'( A,I10,I10,A40 )') 'MPPDB_CHECK1D :: KO: array sizes different on 2 sides',SIZE(GTAB),ISIZEOTHER,YMSG
-#endif
- END IF
- END IF
-#endif
- END SUBROUTINE MPPDB_CHECK1D_LOG
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- SUBROUTINE MPPDB_CHECK1D_REAL(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
- !
- 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)) :: ZTAB, ZTAB_SON, ZTAB_DIFF
- !
-#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
- !
- 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_CHECK1D_REAL','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_CHECK1D_REAL','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_CHECK1D_REAL','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 = ABS ( ZTAB - ZTAB_SON )
- MAX_VAL(IPAS) = MAXVAL( ABS (ZTAB_SON) )
- MAX_DIFF(IPAS) = MAXVAL( ZTAB_DIFF)
- !
- 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_CHECK1D :: 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_CHECK1D :: KO'//achar(27)//'[0m ','',YMSG, MAX_DIFF(1),MAX_VAL(1)
- END IF
-#else
- IF ( OK(1) ) THEN
- write(*, '(" MPPDB_CHECK1D :: OK MPPDB_CHECK1D =",A40," Error=",e15.8," MAXVAL=",e15.8)' ) &
- MESSAGE,MAX_DIFF(1),MAX_VAL(1)
- ELSE
- write(*, '(" MPPDB_CHECK1D :: KO MPPDB_CHECK1D =",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_CHECK1D :: 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_CHECK1D :: 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_CHECK1D :: 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_CHECK1D :: 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_CHECK1D :: 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_CHECK1D :: 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_CHECK1D :: 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_CHECK1D :: 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_CHECK1D_REAL','NPAS_ll>2 not (yet) implemented')
- END IF
- ELSE
-#ifdef _COLOR_OUTPUT
- WRITE (*,'( A,I10,I10,A40 )') achar(27)//'[31mMPPDB_CHECK1D :: KO: array sizes different on 2 sides'//achar(27)//'[0m ',&
- SIZE(ZTAB),ISIZEOTHER,YMSG
-#else
- WRITE (*,'( A,I10,I10,A40 )') 'MPPDB_CHECK1D :: KO: array sizes different on 2 sides',SIZE(ZTAB),ISIZEOTHER,YMSG
-#endif
- END IF
- END IF
-#endif
- END SUBROUTINE MPPDB_CHECK1D_REAL
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_CHECK3D_LOG(OTAB,MESSAGE)
- !
- USE MODD_PARAMETERS_ll, ONLY: JPHEXT
- USE MODD_MPIF, ONLY: MPI_CHARACTER, MPI_STATUS_IGNORE, MPI_SUM, MPI_MAX
- use modd_precision, only: MNHINT_MPI, MNHLOG_MPI
- !
- USE MODE_DEVICE
- USE MODE_GATHER_ll
- !
- IMPLICIT NONE
- !
- LOGICAL, DIMENSION(:,:,:),INTENT(IN) :: OTAB
- CHARACTER(len=*), INTENT(IN) :: MESSAGE
- !
- CHARACTER(len=40) :: YMSG
- CHARACTER(len=NMAXMSGLEN) :: MSG
- CHARACTER(len=NMAXMSGLEN),DIMENSION(:),ALLOCATABLE :: ALLMSG
- INTEGER :: IIMAX_ll,IJMAX_ll
- INTEGER :: IIU_ll,IJU_ll,IKU_ll
- INTEGER :: IINFO_ll
- INTEGER :: I_FIRST_SON
- INTEGER :: I_FIRST_FATHER
- INTEGER :: IPAS,NPAS,NPAS_ll
- INTEGER :: IIB_ll,IIE_ll,IJB_ll,IJE_ll
- INTEGER :: IGLBSIZEOTAB
- INTEGER :: IIU_SON_ll,IJU_SON_ll,IKU_SON_ll
- INTEGER :: IIB_SON_ll,IIE_SON_ll,IJB_SON_ll,IJE_SON_ll
- INTEGER :: IHEXT_SON_ll , IDIFF_HEXT
- INTEGER :: JI,JJ,JK
- INTEGER,DIMENSION(NMAXPAS) :: INUMDIFF
- INTEGER,DIMENSION(3,NMAXPAS) :: IFIRSTERROR
- LOGICAL :: G_OTAB_ON_DEVICE, GISXYSIZE_GLOB
- LOGICAL,DIMENSION(NMAXPAS) :: OK
- LOGICAL,DIMENSION(SIZE(OTAB,1),SIZE(OTAB,2),SIZE(OTAB,3)) :: GTAB
- LOGICAL, DIMENSION(:,:,:),ALLOCATABLE,TARGET :: TAB_ll,TAB_SON_ll
- !
-#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
- !get the global size of OTAB
- CALL MPI_ALLREDUCE(SIZE(OTAB), IGLBSIZEOTAB, 1, MNHINT_MPI, MPI_SUM, MPPDB_INTER_COMM, IINFO_ll)
- IF ( IGLBSIZEOTAB == 0 ) RETURN
- !
- CALL CHECK_ISXYSIZE(SIZE(OTAB,1),SIZE(OTAB,2),GISXYSIZE_GLOB)
- !
- !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) 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
- !
- 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_LOG','message not similar on all processes (' &
- //TRIM(ALLMSG(IPAS))//' vs '//TRIM(MSG)//')')
- END DO
- DEALLOCATE(ALLMSG)
- !
- CALL GET_FROM_DEVICE(OTAB,GTAB,G_OTAB_ON_DEVICE)
- !
- NPAS = 1
- IF (G_OTAB_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_LOG','NPAS_ll reduced')
- END IF
- !
- IFIRSTERROR(:,:) = -1
- !
- DO IPAS=1,NPAS_ll
- IF ((IPAS.EQ.2) .AND. G_OTAB_ON_DEVICE ) GTAB = OTAB ! the 2 time test the value on host
- !
- IF(MPPDB_FATHER_WORLD) THEN
- !
- ! Reconstruct the whole OTAB in TAB_ll
- !
- CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
- IIU_ll = IIMAX_ll+2*JPHEXT
- IJU_ll = IJMAX_ll+2*JPHEXT
- IKU_ll = SIZE(OTAB,3)
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll))
- CALL GATHERALL_FIELD_ll('XY',GTAB,TAB_ll,IINFO_ll)
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! I'm the first FATHER => receive the correct global ARRAY from first son
- !
- !
- ! the first son , is the next processus after this 'world' so
- !
- I_FIRST_SON = MPPDB_NBPROC_WORLD
- !
- ! receive JPHEXT from son if different
- !
- CALL MPI_RECV(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_SON, &
- NTAG, MPPDB_INTRA_COMM,MPI_STATUS_IGNORE, IINFO_ll)
- !
- IIU_SON_ll = IIMAX_ll+2*IHEXT_SON_ll
- IJU_SON_ll = IJMAX_ll+2*IHEXT_SON_ll
- IKU_SON_ll = SIZE(OTAB,3)
- !
- IF (.NOT. ALLOCATED(TAB_SON_ll)) ALLOCATE(TAB_SON_ll(IIU_SON_ll,IJU_SON_ll,IKU_SON_ll))
- !
- CALL MPI_RECV(TAB_SON_ll,SIZE(TAB_SON_ll),MNHLOG_MPI,I_FIRST_SON, &
- NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
- !
- TAB_ll = TAB_ll.NEQV.TAB_SON_ll
- !
- ! Set corners values to zero if we want to check the halos without the corners
- IF ( MPPDB_CHECK_LB .AND. .NOT.MPPDB_CHECK_LB_CORNERS ) THEN
- TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = .FALSE.
- TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = .FALSE.
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = .FALSE.
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = .FALSE.
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll) = .FALSE.
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll) = .FALSE.
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = .FALSE.
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = .FALSE.
- END IF
- !
- IF (MPPDB_CHECK_LB) THEN
- IDIFF_HEXT = MIN(JPHEXT,IHEXT_SON_ll)
- ELSE
- IDIFF_HEXT = 0
- END IF
- IIB_ll = 1 + JPHEXT ; IJB_ll = 1 + JPHEXT
- IIE_ll = IIU_ll-JPHEXT ; IJE_ll = IJU_ll-JPHEXT
- !
- IIB_SON_ll = 1 + IHEXT_SON_ll ; IJB_SON_ll = 1 + IHEXT_SON_ll
- IIE_SON_ll = IIU_SON_ll-IHEXT_SON_ll ; IJE_SON_ll = IJU_SON_ll-IHEXT_SON_ll
- !
- INUMDIFF(IPAS) = COUNT( TAB_ll(IIB_SON_ll-IDIFF_HEXT:IIE_SON_ll+IDIFF_HEXT, &
- IJB_SON_ll-IDIFF_HEXT:IJE_SON_ll+IDIFF_HEXT,1:IKU_SON_ll))
- IF ( INUMDIFF(IPAS) > 0 ) THEN
- OK(IPAS) = .FALSE.
- DO JK = 1,SIZE(TAB_ll,3)
- DO JJ = 1,SIZE(TAB_ll,2)
- DO JI = 1,SIZE(TAB_ll,1)
- IF (TAB_ll(JI,JJ,JK)) THEN
- IFIRSTERROR(1,IPAS)=JI
- IFIRSTERROR(2,IPAS)=JJ
- IFIRSTERROR(3,IPAS)=JK
- GOTO 100
- END IF
- END DO
- END DO
- END DO
-100 CONTINUE
- ELSE
- OK(IPAS) = .TRUE.
- END IF
- !
- DEALLOCATE(TAB_ll,TAB_SON_ll)
- !
- END IF
- ELSE
- !
- ! Reconstruct the all OTAB in TAB_ll
- !
- CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
- IIU_ll = IIMAX_ll+2*JPHEXT
- IJU_ll = IJMAX_ll+2*JPHEXT
- IKU_ll = SIZE(OTAB,3)
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll))
- CALL GATHERALL_FIELD_ll('XY',GTAB,TAB_ll,IINFO_ll)
- !
- ! SON WORLD
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! first son --> send the good array to the first father
- !
- I_FIRST_FATHER = 0
- IHEXT_SON_ll = JPHEXT
- CALL MPI_SEND(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_FATHER, &
- NTAG, MPPDB_INTRA_COMM, IINFO_ll)
- !
- CALL MPI_SEND(TAB_ll,SIZE(TAB_ll),MNHLOG_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 (NPAS_ll == 1) THEN
-#ifdef _COLOR_OUTPUT
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- achar(27)//'[32mMPPDB_CHECK3D :: OK'//achar(27)//'[0m ','',YMSG, INUMDIFF(1),SIZE(OTAB)
- ELSE
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- achar(27)//'[31mMPPDB_CHECK3D :: KO'//achar(27)//'[0m ','',YMSG, INUMDIFF(1),SIZE(OTAB)
- END IF
-#else
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- 'MPPDB_CHECK3D :: OK','',YMSG, INUMDIFF(1),SIZE(OTAB)
- ELSE
- write(*, '( A29,A22,A40," Errors/#elts: ",I12,"/",I12 )' ) &
- 'MPPDB_CHECK3D :: KO','',YMSG, INUMDIFF(1),SIZE(OTAB)
- 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=",I12," device=",I12," (#elts=",I12,")" )' ) &
- achar(27)//'[32mMPPDB_CHECK3D :: OK on host, OK on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,") POS: host=",I4,I4,I4," device=",I4,I4,I4 )')&
- achar(27)//'[31mMPPDB_CHECK3D :: KO on host, KO on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB), &
- IFIRSTERROR(1,2),IFIRSTERROR(2,2),IFIRSTERROR(3,2),IFIRSTERROR(1,1),IFIRSTERROR(2,1),IFIRSTERROR(3,1)
- ELSE IF ( .NOT.OK(1) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,") POS: host=",I4,I4,I4," device=",I4,I4,I4 )')&
- achar(27)//'[33mMPPDB_CHECK3D :: OK on host, KO on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB), &
- IFIRSTERROR(1,2),IFIRSTERROR(2,2),IFIRSTERROR(3,2),IFIRSTERROR(1,1),IFIRSTERROR(2,1),IFIRSTERROR(3,1)
- ELSE IF ( .NOT.OK(2) ) THEN
- write(*, '( A51,A40," Errors: host=",I12," device=",I12," (#elts=",I12,") POS: host=",I4,I4,I4," device=",I4,I4,I4 )')&
- achar(27)//'[33mMPPDB_CHECK3D :: KO on host, OK on device'//achar(27)//'[0m ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB), &
- IFIRSTERROR(1,2),IFIRSTERROR(2,2),IFIRSTERROR(3,2),IFIRSTERROR(1,1),IFIRSTERROR(2,1),IFIRSTERROR(3,1)
- END IF
-#else
- IF ( OK(1) .AND. OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,")" )' ) &
- 'MPPDB_CHECK3D :: OK on host, OK on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB)
- ELSE IF ( .NOT.OK(1) .AND. .NOT.OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,") POS: host=",I4,I4,I4," device=",I4,I4,I4 )')&
- 'MPPDB_CHECK3D :: KO on host, KO on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB), &
- IFIRSTERROR(1,2),IFIRSTERROR(2,2),IFIRSTERROR(3,2),IFIRSTERROR(1,1),IFIRSTERROR(2,1),IFIRSTERROR(3,1)
- ELSE IF ( .NOT.OK(1) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,") POS: host=",I4,I4,I4," device=",I4,I4,I4 )')&
- 'MPPDB_CHECK3D :: OK on host, KO on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB), &
- IFIRSTERROR(1,2),IFIRSTERROR(2,2),IFIRSTERROR(3,2),IFIRSTERROR(1,1),IFIRSTERROR(2,1),IFIRSTERROR(3,1)
- ELSE IF ( .NOT.OK(2) ) THEN
- write(*, '( A42,A40," Errors: host=",I12," device=",I12," (#elts=",I12,") POS: host=",I4,I4,I4," device=",I4,I4,I4 )')&
- 'MPPDB_CHECK3D :: KO on host, OK on device ',YMSG, &
- INUMDIFF(2),INUMDIFF(1),SIZE(OTAB), &
- IFIRSTERROR(1,2),IFIRSTERROR(2,2),IFIRSTERROR(3,2),IFIRSTERROR(1,1),IFIRSTERROR(2,1),IFIRSTERROR(3,1)
- END IF
-#endif
- flush(unit=OUTPUT_UNIT)
- ELSE
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_LOG','NPAS_ll>2 not (yet) implemented')
- END IF
- END IF
-#endif
- END SUBROUTINE MPPDB_CHECK3D_LOG
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_CHECK3D_REAL(PTAB,MESSAGE,PPRECISION)
- !
- USE MODD_MPIF, ONLY: MPI_CHARACTER, MPI_STATUS_IGNORE, MPI_SUM, MPI_MAX
- USE MODD_PARAMETERS_ll, ONLY: JPHEXT
- use modd_precision, only: MNHINT_MPI, MNHREAL_MPI
- !
- USE MODE_DEVICE
- USE MODE_GATHER_ll
- !
- 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 :: IIMAX_ll,IJMAX_ll
- INTEGER :: IIU_ll,IJU_ll,IKU_ll
- INTEGER :: IINFO_ll
- INTEGER :: I_FIRST_SON
- INTEGER :: I_FIRST_FATHER
- INTEGER :: IIB_ll,IIE_ll,IJB_ll,IJE_ll
- INTEGER :: IGLBSIZEPTAB
- INTEGER :: IIU_SON_ll,IJU_SON_ll,IKU_SON_ll
- INTEGER :: IIB_SON_ll,IIE_SON_ll,IJB_SON_ll,IJE_SON_ll
- INTEGER :: IHEXT_SON_ll , IDIFF_HEXT
- INTEGER :: IPAS,NPAS,NPAS_ll
- LOGICAL :: G_PTAB_ON_DEVICE, GISXYSIZE_GLOB
- 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
- REAL,DIMENSION(:,:,:,:),ALLOCATABLE,TARGET :: TAB_ll
- REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: TAB_SON_ll
-
-#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
- !
- CALL CHECK_ISXYSIZE(SIZE(PTAB,1),SIZE(PTAB,2),GISXYSIZE_GLOB)
- !
- !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) 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
- !
- 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','message not similar on all processes (' &
- //TRIM(ALLMSG(IPAS))//' vs '//TRIM(MSG)//')')
- END DO
- DEALLOCATE(ALLMSG)
-
- 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)
-
- MAX_DIFF(:) = 0.0
-
- IF (NPAS_ll>NMAXPAS) THEN
- NPAS_ll = NMAXPAS
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK3D_REAL','NPAS_ll reduced')
- END IF
-
- 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
- !
- ! Reconstruct the whole PTAB in TAB_ll
- !
- CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
- IIU_ll = IIMAX_ll+2*JPHEXT
- IJU_ll = IJMAX_ll+2*JPHEXT
- IKU_ll = SIZE(PTAB,3)
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll,NPAS_ll))
- CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll(:,:,:,IPAS),IINFO_ll)
-
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! I'm the first FATHER => receive the correct global ARRAY from first son
- !
- !
- ! the first son , is the next processus after this 'world' so
- !
- I_FIRST_SON = MPPDB_NBPROC_WORLD
- !
- ! receive JPHEXT from son if different
- !
- CALL MPI_RECV(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_SON, &
- NTAG, MPPDB_INTRA_COMM,MPI_STATUS_IGNORE, IINFO_ll)
-
- !IHEXT_SON_ll = JPHEXT
-
- IIU_SON_ll = IIMAX_ll+2*IHEXT_SON_ll
- IJU_SON_ll = IJMAX_ll+2*IHEXT_SON_ll
- IKU_SON_ll = SIZE(PTAB,3)
-
- IF (.NOT. ALLOCATED(TAB_SON_ll)) ALLOCATE(TAB_SON_ll(IIU_SON_ll,IJU_SON_ll,IKU_SON_ll))
- !
- CALL MPI_RECV(TAB_SON_ll,SIZE(TAB_SON_ll),MNHREAL_MPI,I_FIRST_SON, &
- NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
- !
- TAB_ll(:,:,:,IPAS) = ABS ( TAB_ll(:,:,:,IPAS) - TAB_SON_ll(:,:,:) )
- !
- ! Set corners values to zero if we want to check the halos without the corners
- IF ( MPPDB_CHECK_LB .AND. .NOT.MPPDB_CHECK_LB_CORNERS ) THEN
- TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
- TAB_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll,IPAS) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll,IPAS) = 0d0
- TAB_SON_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_SON_ll(1:JPHEXT, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_SON_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
- TAB_SON_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT, 1:IKU_ll) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll, 1:IKU_ll) = 0d0
- END IF
- !
- IF (MPPDB_CHECK_LB) THEN
- IDIFF_HEXT = MIN(JPHEXT,IHEXT_SON_ll)
- ELSE
- IDIFF_HEXT = 0
- END IF
- IIB_ll = 1 + JPHEXT ; IJB_ll = 1 + JPHEXT
- IIE_ll = IIU_ll-JPHEXT ; IJE_ll = IJU_ll-JPHEXT
-
- IIB_SON_ll = 1 + IHEXT_SON_ll ; IJB_SON_ll = 1 + IHEXT_SON_ll
- IIE_SON_ll = IIU_SON_ll-IHEXT_SON_ll ; IJE_SON_ll = IJU_SON_ll-IHEXT_SON_ll
-
- MAX_VAL(IPAS) = MAXVAL( ABS (TAB_SON_ll(IIB_SON_ll-IDIFF_HEXT:IIE_SON_ll+IDIFF_HEXT,&
- IJB_SON_ll-IDIFF_HEXT:IJE_SON_ll+IDIFF_HEXT,1:IKU_SON_ll) ) )
- MAX_DIFF(IPAS) = MAXVAL( TAB_ll(IIB_ll-IDIFF_HEXT:IIE_ll+IDIFF_HEXT,IJB_ll-IDIFF_HEXT:IJE_ll+IDIFF_HEXT,1:IKU_ll,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.
- !write(*, '(" MPPDB_CHECK3D :: KO MPPDB_CHECK3D =",A40," Error=",e15.8," MAXVAL=",e15.8," PTAB_ON_DEVICE=",l1," IPAS=",I1)' ) MESSAGE,MAX_DIFF(IPAS),MAX_VAL(IPAS),G_PTAB_ON_DEVICE,IPAS
- ELSE
- OK(IPAS) = .TRUE.
- !write(*, '(" MPPDB_CHECK3D :: OK MPPDB_CHECK3D =",A40," Error=",e15.8," MAXVAL=",e15.8," PTAB_ON_DEVICE=",l1," IPAS=",I1)' ) MESSAGE,MAX_DIFF(IPAS),MAX_VAL(IPAS),G_PTAB_ON_DEVICE,IPAS
- END IF
- !flush(unit=OUTPUT_UNIT)
- !
- !DEALLOCATE(TAB_ll,TAB_SON_ll)
- !
- END IF
- ELSE
- !
- ! Reconstruct the all PTAB in TAB_ll
- !
- CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
- IIU_ll = IIMAX_ll+2*JPHEXT
- IJU_ll = IJMAX_ll+2*JPHEXT
- IKU_ll = SIZE(PTAB,3)
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll,IKU_ll,NPAS_ll))
- CALL GATHERALL_FIELD_ll('XY',ZTAB,TAB_ll(:,:,:,IPAS),IINFO_ll)
- !
- ! SON WORLD
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! first son --> send the good array to the first father
- !
- I_FIRST_FATHER = 0
- IHEXT_SON_ll = JPHEXT
- CALL MPI_BSEND(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_FATHER, &
- NTAG, MPPDB_INTRA_COMM, IINFO_ll)
-
- CALL MPI_BSEND(TAB_ll(:,:,:,IPAS),SIZE(TAB_ll(:,:,:,IPAS)),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 (NPAS_ll == 1) THEN
-#ifdef _COLOR_OUTPUT
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Error: ",e15.8," MAXVAL= ",e15.8 )' ) &
- achar(27)//'[32mMPPDB_CHECK3D :: 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_CHECK3D :: KO'//achar(27)//'[0m ','',YMSG, MAX_DIFF(1),MAX_VAL(1)
- END IF
-#else
- IF ( OK(1) ) THEN
- write(*, '(" MPPDB_CHECK3D :: OK MPPDB_CHECK3D =",A40," Error=",e15.8," MAXVAL=",e15.8)' ) MESSAGE,MAX_DIFF(1),MAX_VAL(1)
- ELSE
- write(*, '(" MPPDB_CHECK3D :: KO MPPDB_CHECK3D =",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_CHECK3D :: 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_CHECK3D :: 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_CHECK3D :: 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_CHECK3D :: 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_CHECK3D :: 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_CHECK3D :: 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_CHECK3D :: 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_CHECK3D :: 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_CHECK3D_REAL','NPAS_ll>2 not (yet) implemented')
- END IF
- DEALLOCATE(TAB_ll,TAB_SON_ll)
- END IF
-#endif
- END SUBROUTINE MPPDB_CHECK3D_REAL
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_CHECK3DM(MESSAGE,PPRECISION &
- ,PTAB1,PTAB2,PTAB3,PTAB4,PTAB5,PTAB6,PTAB7,PTAB8,PTAB9,PTAB10 &
- ,PTAB11,PTAB12,PTAB13,PTAB14,PTAB15,PTAB16,PTAB17,PTAB18,PTAB19,PTAB20 &
- )
-
- IMPLICIT NONE
-
- CHARACTER(len=*), INTENT(IN) :: MESSAGE
- REAL, OPTIONAL, INTENT(IN) :: PPRECISION
- REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PTAB1,PTAB2,PTAB3,PTAB4,PTAB5,PTAB6,PTAB7,PTAB8,PTAB9,PTAB10
- REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PTAB11,PTAB12,PTAB13,PTAB14,PTAB15,PTAB16,PTAB17,PTAB18,PTAB19,PTAB20
-
- IF (PRESENT(PTAB1)) CALL MPPDB_CHECK3D(PTAB1,MESSAGE//"::PTAB1",PPRECISION)
- IF (PRESENT(PTAB2)) CALL MPPDB_CHECK3D(PTAB2,MESSAGE//"::PTAB2",PPRECISION)
- IF (PRESENT(PTAB3)) CALL MPPDB_CHECK3D(PTAB3,MESSAGE//"::PTAB3",PPRECISION)
- IF (PRESENT(PTAB4)) CALL MPPDB_CHECK3D(PTAB4,MESSAGE//"::PTAB4",PPRECISION)
- IF (PRESENT(PTAB5)) CALL MPPDB_CHECK3D(PTAB5,MESSAGE//"::PTAB5",PPRECISION)
- IF (PRESENT(PTAB6)) CALL MPPDB_CHECK3D(PTAB6,MESSAGE//"::PTAB6",PPRECISION)
- IF (PRESENT(PTAB7)) CALL MPPDB_CHECK3D(PTAB7,MESSAGE//"::PTAB7",PPRECISION)
- IF (PRESENT(PTAB8)) CALL MPPDB_CHECK3D(PTAB8,MESSAGE//"::PTAB8",PPRECISION)
- IF (PRESENT(PTAB9)) CALL MPPDB_CHECK3D(PTAB9,MESSAGE//"::PTAB9",PPRECISION)
- IF (PRESENT(PTAB10)) CALL MPPDB_CHECK3D(PTAB10,MESSAGE//"::PTAB10",PPRECISION)
- IF (PRESENT(PTAB11)) CALL MPPDB_CHECK3D(PTAB11,MESSAGE//"::PTAB11",PPRECISION)
- IF (PRESENT(PTAB12)) CALL MPPDB_CHECK3D(PTAB12,MESSAGE//"::PTAB12",PPRECISION)
- IF (PRESENT(PTAB13)) CALL MPPDB_CHECK3D(PTAB13,MESSAGE//"::PTAB13",PPRECISION)
- IF (PRESENT(PTAB14)) CALL MPPDB_CHECK3D(PTAB14,MESSAGE//"::PTAB14",PPRECISION)
- IF (PRESENT(PTAB15)) CALL MPPDB_CHECK3D(PTAB15,MESSAGE//"::PTAB15",PPRECISION)
- IF (PRESENT(PTAB16)) CALL MPPDB_CHECK3D(PTAB16,MESSAGE//"::PTAB16",PPRECISION)
- IF (PRESENT(PTAB17)) CALL MPPDB_CHECK3D(PTAB17,MESSAGE//"::PTAB17",PPRECISION)
- IF (PRESENT(PTAB18)) CALL MPPDB_CHECK3D(PTAB18,MESSAGE//"::PTAB18",PPRECISION)
- IF (PRESENT(PTAB19)) CALL MPPDB_CHECK3D(PTAB19,MESSAGE//"::PTAB19",PPRECISION)
- IF (PRESENT(PTAB20)) CALL MPPDB_CHECK3D(PTAB20,MESSAGE//"::PTAB20",PPRECISION)
-
- END SUBROUTINE MPPDB_CHECK3DM
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- subroutine Mppdb_check4d_real(ptab,hmsg,pprecision)
-
- implicit none
-
- real, dimension(:,:,:,:),intent(in) :: ptab
- character(len=*), intent(in) :: hmsg
- real,optional, intent(in) :: pprecision
-
- character(len=3) :: yidx
- integer :: ji
-
- do ji = 1, size(ptab,4)
- write( yidx, '( I3.3 )' ) ji
- call Mppdb_check3d_real( ptab(:,:,:,ji), hmsg//'(:,:,:,'//yidx//')', pprecision )
- end do
- end subroutine Mppdb_check4d_real
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_CHECK2D_REAL(PTAB,MESSAGE,PPRECISION)
- !
- USE MODD_MPIF, ONLY: MPI_CHARACTER, MPI_STATUS_IGNORE, MPI_LAND, MPI_SUM, MPI_MAX
- USE MODD_PARAMETERS_ll, ONLY: JPHEXT
- use modd_precision, only: MNHINT_MPI, MNHREAL_MPI
- !
- USE MODE_DEVICE
- USE MODE_GATHER_ll
- USE MODE_TOOLS_ll, ONLY: GET_DIM_EXT_ll
- !
- 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 :: IIMAX_ll,IJMAX_ll
- INTEGER :: IIU_ll,IJU_ll
- INTEGER :: IINFO_ll
- INTEGER :: I_FIRST_SON
- INTEGER :: I_FIRST_FATHER
- INTEGER :: IIB_ll,IIE_ll,IJB_ll,IJE_ll
- INTEGER :: IGLBSIZEPTAB
- INTEGER :: IIU_SON_ll,IJU_SON_ll
- INTEGER :: IIB_SON_ll,IIE_SON_ll,IJB_SON_ll,IJE_SON_ll
- INTEGER :: IHEXT_SON_ll , IDIFF_HEXT
- INTEGER :: IPAS,NPAS,NPAS_ll
- LOGICAL :: G_PTAB_ON_DEVICE
- LOGICAL :: GISXYSIZE_GLOB
- LOGICAL,DIMENSION(NMAXPAS) :: OK
- REAL :: ZDIV
- REAL :: ZPRECISION
- REAL,DIMENSION(NMAXPAS) :: MAX_DIFF, MAX_VAL
- REAL,DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2)) :: ZTAB
- REAL,DIMENSION(:,:),ALLOCATABLE,TARGET :: TAB_ll,TAB_SON_ll
-
-#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
- !
- CALL CHECK_ISXYSIZE(SIZE(PTAB,1),SIZE(PTAB,2),GISXYSIZE_GLOB)
- !
- !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) 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()
-
- 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_CHECK2D_REAL','message not similar on all processes (' &
- //TRIM(ALLMSG(IPAS))//' vs '//TRIM(MSG)//')')
- END DO
- DEALLOCATE(ALLMSG)
-
- 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)
-
- MAX_DIFF(:) = 0.0
-
- IF (NPAS_ll>NMAXPAS) THEN
- NPAS_ll = NMAXPAS
- CALL PRINT_MSG(NVERB_WARNING,'GEN','MPPDB_CHECK2D_REAL','NPAS_ll reduced')
- END IF
-
- 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
- !
- ! Reconstruct the whole PTAB in TAB_ll
- !
- IF (GISXYSIZE_GLOB) THEN
- CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
- IIU_ll = IIMAX_ll+2*JPHEXT
- IJU_ll = IJMAX_ll+2*JPHEXT
- 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) 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
- IJMAX_ll = IJU_ll
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll))
- TAB_ll(:,:) = ZTAB(:,:)
- END IF
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! I'm the first FATHER => receive the correct global ARRAY from first son
- !
- !
- ! the first son , is the next processus after this 'world' so
- !
- I_FIRST_SON = MPPDB_NBPROC_WORLD
- !
- ! receive JPHEXT from son if different
- !
- IF (GISXYSIZE_GLOB) THEN
- CALL MPI_RECV(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_SON, &
- NTAG, MPPDB_INTRA_COMM,MPI_STATUS_IGNORE, IINFO_ll)
-
- !IHEXT_SON_ll = JPHEXT
-
- IIU_SON_ll = IIMAX_ll+2*IHEXT_SON_ll
- IJU_SON_ll = IJMAX_ll+2*IHEXT_SON_ll
- ELSE
- IIU_SON_ll = IIMAX_ll
- IJU_SON_ll = IJMAX_ll
- END IF
-
- IF (.NOT. ALLOCATED(TAB_SON_ll)) ALLOCATE(TAB_SON_ll(IIU_SON_ll,IJU_SON_ll))
- !
- CALL MPI_RECV(TAB_SON_ll,SIZE(TAB_SON_ll),MNHREAL_MPI,I_FIRST_SON, &
- NTAG,MPPDB_INTRA_COMM,MPI_STATUS_IGNORE,IINFO_ll)
- !
- TAB_ll = ABS ( TAB_ll - TAB_SON_ll )
- !
- ! Set corners values to zero if we want to check the halos without the corners
- IF ( GISXYSIZE_GLOB .AND. MPPDB_CHECK_LB .AND. .NOT.MPPDB_CHECK_LB_CORNERS ) THEN
- TAB_ll(1:JPHEXT, 1:JPHEXT ) = 0d0
- TAB_ll(1:JPHEXT, 1:JPHEXT ) = 0d0
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll) = 0d0
- TAB_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT ) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT ) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll) = 0d0
- TAB_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll) = 0d0
- TAB_SON_ll(1:JPHEXT, 1:JPHEXT ) = 0d0
- TAB_SON_ll(1:JPHEXT, 1:JPHEXT ) = 0d0
- TAB_SON_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll) = 0d0
- TAB_SON_ll(1:JPHEXT, IJU_ll-JPHEXT:IJU_ll) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT ) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, 1:JPHEXT ) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll) = 0d0
- TAB_SON_ll(IIU_ll-JPHEXT:IIU_ll, IJU_ll-JPHEXT:IJU_ll) = 0d0
- END IF
- !
- IF (MPPDB_CHECK_LB .AND. GISXYSIZE_GLOB) THEN
- IDIFF_HEXT = MIN(JPHEXT,IHEXT_SON_ll)
- ELSE
- IDIFF_HEXT = 0
- END IF
- !
- IF (GISXYSIZE_GLOB) THEN
- IIB_ll = 1 + JPHEXT ; IJB_ll = 1 + JPHEXT
- IIE_ll = IIU_ll-JPHEXT ; IJE_ll = IJU_ll-JPHEXT
- !
- IIB_SON_ll = 1 + IHEXT_SON_ll ; IJB_SON_ll = 1 + IHEXT_SON_ll
- IIE_SON_ll = IIU_SON_ll-IHEXT_SON_ll ; IJE_SON_ll = IJU_SON_ll-IHEXT_SON_ll
- ELSE
- IIB_ll = 1 ; IJB_ll = 1
- IIE_ll = IIU_ll ; IJE_ll = IJU_ll
- !
- IIB_SON_ll = 1 ; IJB_SON_ll = 1
- IIE_SON_ll = IIU_SON_ll ; IJE_SON_ll = IJU_SON_ll
- END IF
-
- MAX_VAL(IPAS) = MAXVAL( ABS (TAB_SON_ll(IIB_SON_ll-IDIFF_HEXT:IIE_SON_ll+IDIFF_HEXT,&
- IJB_SON_ll-IDIFF_HEXT:IJE_SON_ll+IDIFF_HEXT) ) )
- MAX_DIFF(IPAS) = MAXVAL( TAB_ll(IIB_ll-IDIFF_HEXT:IIE_ll+IDIFF_HEXT,IJB_ll-IDIFF_HEXT:IJE_ll+IDIFF_HEXT))
- !
- 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
- !
- !DEALLOCATE(TAB_ll,TAB_SON_ll)
- !
- END IF
- ELSE
- !
- ! Reconstruct the all PTAB in TAB_ll
- !
- IF (GISXYSIZE_GLOB) THEN
- CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
- IIU_ll = IIMAX_ll+2*JPHEXT
- IJU_ll = IJMAX_ll+2*JPHEXT
- 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) 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
- IJMAX_ll = IJU_ll
- IF (.NOT. ALLOCATED(TAB_ll)) ALLOCATE(TAB_ll(IIU_ll,IJU_ll))
- TAB_ll(:,:) = ZTAB(:,:)
- END IF
- !
- ! SON WORLD
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! first son --> send the good array to the first father
- !
- I_FIRST_FATHER = 0
- IF (GISXYSIZE_GLOB) THEN
- IHEXT_SON_ll = JPHEXT
- CALL MPI_BSEND(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_FATHER, &
- NTAG, MPPDB_INTRA_COMM, IINFO_ll)
- END IF
-
- CALL MPI_BSEND(TAB_ll,SIZE(TAB_ll),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 (NPAS_ll == 1) THEN
-#ifdef _COLOR_OUTPUT
- IF ( OK(1) ) THEN
- write(*, '( A29,A22,A40," Error: ",e15.8," MAXVAL= ",e15.8 )' ) &
- achar(27)//'[32mMPPDB_CHECK2D :: 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_CHECK2D :: KO'//achar(27)//'[0m ','',YMSG, MAX_DIFF(1),MAX_VAL(1)
- END IF
-#else
- IF ( OK(1) ) THEN
- write(*, '(" MPPDB_CHECK2D :: OK MPPDB_CHECK2D =",A40," Error=",e15.8," MAXVAL=",e15.8)' ) MESSAGE,MAX_DIFF(1),MAX_VAL(1)
- ELSE
- write(*, '(" MPPDB_CHECK2D :: KO MPPDB_CHECK2D =",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_CHECK2D :: 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_CHECK2D :: 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_CHECK2D :: 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_CHECK2D :: 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_CHECK2D :: 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_CHECK2D :: 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_CHECK2D :: 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_CHECK2D :: 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_CHECK2D_REAL','NPAS_ll>2 not (yet) implemented')
- END IF
- DEALLOCATE(TAB_ll,TAB_SON_ll)
- END IF
-#endif
- END SUBROUTINE MPPDB_CHECK2D_REAL
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_CHECKLB(PLB,MESSAGE,PPRECISION,HLBTYPE,KRIM)
-
- USE MODD_PARAMETERS_ll, ONLY : JPHEXT
- USE MODD_VAR_ll , ONLY : NMNH_COMM_WORLD
- USE MODD_IO , ONLY : ISP,ISNPROC,GSMONOPROC,LPACK,L2D
- USE MODD_MPIF , ONLY : MPI_STATUS_IGNORE, MPI_SUM
-
- USE MODE_DISTRIB_LB
- USE MODE_TOOLS_ll, ONLY : GET_GLOBALDIMS_ll
- USE MODE_MODELN_HANDLER, ONLY : GET_CURRENT_MODEL_INDEX
- use modd_precision, only: MNHINT_MPI, MNHREAL_MPI
-
- IMPLICIT NONE
-
- REAL, DIMENSION(:,:,:) , TARGET :: PLB
- CHARACTER(len=*) :: MESSAGE
- REAL :: PPRECISION
- CHARACTER(LEN=*), INTENT(IN) ::HLBTYPE! 'LBX','LBXU','LBY' or 'LBYV'
- INTEGER, INTENT(IN) ::KRIM ! size of the LB area
-
- !
- ! local var
- !
- REAL,ALLOCATABLE, DIMENSION(:,:,:) :: TAB_ll,TAB_SON_ll,TAB_SAVE_ll
- REAL,DIMENSION(:,:,:),ALLOCATABLE,TARGET :: Z3D
- REAL,DIMENSION(:,:,:), POINTER :: TX3DP
- INTEGER :: IIMAX_ll,IJMAX_ll
- INTEGER :: IIU,IJU,IIU_ll,IJU_ll,IKU_ll
- INTEGER :: IINFO_ll
-
- INTEGER :: I_FIRST_SON
- INTEGER :: I_FIRST_FATHER
- REAL :: MAX_DIFF , MAX_VAL
- INTEGER :: IIB_ll,IIE_ll,IJB_ll,IJE_ll
- INTEGER :: JI
- INTEGER :: IIB,IIE,IJB,IJE
-
- INTEGER :: IIU_SON_ll,IJU_SON_ll,IKU_SON_ll
- INTEGER :: IIB_SON_ll,IIE_SON_ll,IJB_SON_ll,IJE_SON_ll
- INTEGER :: IHEXT_SON_ll , IDIFF_HEXT , IRIM_ll , IRIM_SON_ll
- INTEGER :: IMI , IGLBSIZEPTAB
-
-#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
- !get the global size of PLB
- CALL MPI_ALLREDUCE(SIZE(PLB), IGLBSIZEPTAB, 1,MNHINT_MPI, MPI_SUM, MPPDB_INTER_COMM, IINFO_ll)
- IF ( IGLBSIZEPTAB == 0 ) RETURN
- !
- CALL MPPDB_BARRIER()
- !
- IF(MPPDB_FATHER_WORLD) THEN
- !
- ! Reconstruct the all PLB in TAB_ll
- !
- CALL GET_GLOBALDIMS_ll (IIMAX_ll,IJMAX_ll)
- IIU_ll = IIMAX_ll+2*JPHEXT
- IJU_ll = IJMAX_ll+2*JPHEXT
- IKU_ll = SIZE(PLB,3)
- IRIM_ll = MAX(1,KRIM)
-
- IF (HLBTYPE == 'LBX' ) THEN
- IIU_ll = JPHEXT*2
- ELSE IF ( HLBTYPE == 'LBXU') THEN
- IIU_ll = (IRIM_ll+JPHEXT)*2
- ELSE IF ( HLBTYPE == 'LBY') THEN
- IJU_ll = JPHEXT*2
- ELSE IF ( HLBTYPE == 'LBYV') THEN
- IJU_ll = (IRIM_ll+JPHEXT)*2
- END IF
-
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- ! I/O proc case
- ALLOCATE(Z3D(IIU_ll,IJU_ll,SIZE(PLB,3)))
- DO JI = 1,ISNPROC
- CALL GET_DISTRIB_LB(HLBTYPE,JI,'FM','WRITE',IRIM_ll,IIB,IIE,IJB,IJE)
- IF (IIB /= 0) THEN
- TX3DP=>Z3D(IIB:IIE,IJB:IJE,:)
- IF (ISP /= JI) THEN
- CALL MPI_RECV(TX3DP,SIZE(TX3DP),MNHREAL_MPI,JI-1 &
- ,99,NMNH_COMM_WORLD,MPI_STATUS_IGNORE,IINFO_ll)
- ELSE
- CALL GET_DISTRIB_LB(HLBTYPE,JI,'LOC','WRITE',IRIM_ll,IIB,IIE,IJB,IJE)
- TX3DP = PLB(IIB:IIE,IJB:IJE,:)
- END IF
- END IF
- END DO
-
- TX3DP=>Z3D
-
- ELSE
- ! Other processors
- CALL GET_DISTRIB_LB(HLBTYPE,ISP,'LOC','WRITE',IRIM_ll,IIB,IIE,IJB,IJE)
- IF (IIB /= 0) THEN
- TX3DP=>PLB(IIB:IIE,IJB:IJE,:)
- CALL MPI_BSEND(TX3DP,SIZE(TX3DP),MNHREAL_MPI,0,99,NMNH_COMM_WORLD,IINFO_ll)
- END IF
- END IF
-
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! I'm the first FATHER => receive the correct global ARRAY from first son
- !
- !
- ! the first son , is the next processus after this 'world' so
- !
- I_FIRST_SON = MPPDB_NBPROC_WORLD
- !
- ! receive JPHEXT from son if different
- !
- CALL MPI_RECV(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_SON, &
- NTAG, MPPDB_INTRA_COMM,MPI_STATUS_IGNORE, IINFO_ll)
-
- IIU_SON_ll = IIMAX_ll+2*IHEXT_SON_ll
- IJU_SON_ll = IJMAX_ll+2*IHEXT_SON_ll
- IKU_SON_ll = SIZE(PLB,3)
- IRIM_SON_ll = MAX(1,KRIM)
- !
- IF (HLBTYPE == 'LBX' ) THEN
- IIU_SON_ll = IHEXT_SON_ll*2
- ELSE IF ( HLBTYPE == 'LBXU') THEN
- IIU_SON_ll = (IRIM_SON_ll+IHEXT_SON_ll)*2
- ELSE IF ( HLBTYPE == 'LBY') THEN
- IJU_SON_ll = IHEXT_SON_ll*2
- ELSE IF ( HLBTYPE == 'LBYV') THEN
- IJU_SON_ll = (IRIM_SON_ll+IHEXT_SON_ll)*2
- END IF
- !
- ALLOCATE(TAB_SON_ll(IIU_SON_ll,IJU_SON_ll,IKU_SON_ll))
- !
- CALL MPI_RECV(TAB_SON_ll,SIZE(TAB_SON_ll),MNHREAL_MPI,I_FIRST_SON, &
- NTAG, MPPDB_INTRA_COMM,MPI_STATUS_IGNORE, IINFO_ll)
- !
- IDIFF_HEXT = MIN(JPHEXT,IHEXT_SON_ll)
- !
- ALLOCATE(TAB_SAVE_ll(SIZE(Z3D,1),SIZE(Z3D,2),SIZE(Z3D,3)))
- !
- IF (HLBTYPE == 'LBX' .OR. HLBTYPE == 'LBXU') THEN
-
- ELSE
- END IF
- IIB_ll = 1 + JPHEXT ; IJB_ll = 1 + JPHEXT
- IIE_ll = IIU_ll-JPHEXT ; IJE_ll = IJU_ll-JPHEXT
-
- IIB_SON_ll = 1 + IHEXT_SON_ll ; IJB_SON_ll = 1 + IHEXT_SON_ll
- IIE_SON_ll = IIU_SON_ll-IHEXT_SON_ll ; IJE_SON_ll = IJU_SON_ll-IHEXT_SON_ll
- !
- TAB_SAVE_ll = Z3D
- Z3D = 0.0
- Z3D(IIB_ll-IDIFF_HEXT:IIE_ll+IDIFF_HEXT,IJB_ll-IDIFF_HEXT:IJE_ll+IDIFF_HEXT,1:IKU_ll) &
- = ABS ( TAB_SAVE_ll(IIB_ll-IDIFF_HEXT:IIE_ll+IDIFF_HEXT,IJB_ll-IDIFF_HEXT:IJE_ll+IDIFF_HEXT,1:IKU_ll) &
- - TAB_SON_ll(IIB_SON_ll-IDIFF_HEXT:IIE_SON_ll+IDIFF_HEXT,IJB_SON_ll-IDIFF_HEXT:IJE_SON_ll+IDIFF_HEXT &
- ,1:IKU_SON_ll) )
- !
- MAX_VAL = MAXVAL( ABS (TAB_SON_ll(IIB_SON_ll-IDIFF_HEXT:IIE_SON_ll+IDIFF_HEXT,&
- IJB_SON_ll-IDIFF_HEXT:IJE_SON_ll+IDIFF_HEXT,1:IKU_SON_ll) ) )
- IF ( MAX_VAL .EQ. 0.0 ) MAX_VAL = 1.0
- !
- IMI = GET_CURRENT_MODEL_INDEX()
- MAX_DIFF=MAXVAL(Z3D(IIB_ll-IDIFF_HEXT:IIE_ll+IDIFF_HEXT,IJB_ll-IDIFF_HEXT:IJE_ll+IDIFF_HEXT,1:IKU_ll)/MAX_VAL)
- !
- IF (MAX_DIFF > PPRECISION ) THEN
- print*," MPPDB_CHECKLB :: KO MPPDB_CHECKLB =", MESSAGE ," Error=",MAX_DIFF , MAX_VAL, IMI
- ELSE
- print*," MPPDB_CHECKLB :: OK MPPDB_CHECKLB =", MESSAGE ," Error=",MAX_DIFF , MAX_VAL, IMI
- END IF
- flush(unit=OUTPUT_UNIT)
- !
- DEALLOCATE(TAB_SON_ll)
- !
- END IF
- ELSE
- !
- ! SON WORLD
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- !
- ! first son --> send the good array to the first father
- !
- I_FIRST_FATHER = 0
- IHEXT_SON_ll = JPHEXT
- CALL MPI_BSEND(IHEXT_SON_ll,1,MNHINT_MPI,I_FIRST_FATHER, &
- NTAG, MPPDB_INTRA_COMM, IINFO_ll)
- CALL MPI_BSEND(PLB,SIZE(PLB),MNHREAL_MPI,I_FIRST_FATHER, &
- NTAG, MPPDB_INTRA_COMM, IINFO_ll)
- END IF
- END IF
-
- CALL MPPDB_BARRIER()
-#endif
- END SUBROUTINE MPPDB_CHECKLB
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_CHECK_SURFEX2D(PTAB,MESSAGE,PPRECISION,KLUOUT,HTYPE,KIU,KJU)
-
- USE MODD_PARAMETERS, ONLY : JPHEXT
- USE MODI_GET_1D_MASK
- USE MODI_UNPACK_SAME_RANK
- USE MODI_GET_SURF_MASK_n
- USE MODD_IO_SURF_MNH, ONLY : NHALO
- USE MODD_MNH_SURFEX_n
-
- IMPLICIT NONE
-
- REAL, DIMENSION(:), INTENT(IN) :: PTAB
- CHARACTER(len=*), INTENT(IN) :: MESSAGE
- REAL, INTENT(IN) :: PPRECISION
- CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: HTYPE ! 'WATER', 'NATURE', 'TOWN', 'SEA', 'FULL' (default is 'FULL')
- INTEGER, INTENT(IN) :: KLUOUT ! output listing logical unit
- INTEGER, INTENT(IN),OPTIONAL :: KIU ! size of local subdomain in X direction, useful in case where GET_INDICE_ll does not give the sire of the desired model (e.g. in pgd2)
- INTEGER, INTENT(IN),OPTIONAL :: KJU ! size of local subdomain in Y direction
- !
- ! local var
- !
- REAL,ALLOCATABLE, DIMENSION(:) :: PTAB_UNPACKED
- REAL,ALLOCATABLE, DIMENSION(:,:) :: ZFIELD2D
- INTEGER :: IIU,IJU
- INTEGER :: KXOR, KYOR, KXEND, KYEND ! origin and end of the local physical subdomain
- INTEGER :: II,IJ
- INTEGER, ALLOCATABLE, DIMENSION(:) :: KMASK
- INTEGER :: KSIZE
- INTEGER :: KSIZE_FULL
- !
- IF ( ( .NOT. MPPDB_INITIALIZED ) .OR. ( .NOT. MPPDB_ACTIVED ) ) RETURN
- !
-! IF ( SIZE(PTAB) == 0 ) THEN
-! ALLOCATE(ZFIELD2D(0,0))
-! RETURN
- !
- ! Get the dimensions of the subdomain
- !
- IF ( PRESENT(KIU) .AND. PRESENT(KJU) ) THEN
- IIU = KIU+2*JPHEXT
- IJU = KJU+2*JPHEXT
- KSIZE_FULL = KIU*KJU
- ELSE
- CALL GET_INDICE_ll( KXOR, KYOR, KXEND, KYEND )
- IIU = KXEND-KXOR+1+2*JPHEXT
- IJU = KYEND-KYOR+1+2*JPHEXT
- KSIZE_FULL = (KXEND-KXOR+1)*(KYEND-KYOR+1)
- IF ( PRESENT(HTYPE) .AND. KSIZE_FULL /= SIZE(YSURF_CUR%U%XCOVER,1) .AND. NHALO /= JPHEXT ) THEN
- !IIU = KXEND-KXOR+1+2*JPHEXT+2*NHALO
- !IJU = KYEND-KYOR+1+2*JPHEXT+2*NHALO
- KSIZE_FULL = (KXEND-KXOR+1+2*NHALO) * (KYEND-KYOR+1+2*NHALO)
- ENDIF
- ENDIF
- !
- ! Unpack PTAB
- !
- IF(PRESENT(HTYPE)) THEN
- KSIZE = SIZE( PTAB, 1 )
- ALLOCATE( KMASK(KSIZE) )
- ALLOCATE( PTAB_UNPACKED(KSIZE_FULL) )
- CALL GET_SURF_MASK_n(YSURF_CUR%DTCO,YSURF_CUR%U,HTYPE,KSIZE,KMASK,KSIZE_FULL,KLUOUT)
- CALL UNPACK_SAME_RANK( KMASK, PTAB, PTAB_UNPACKED )
- ELSE
- KSIZE = KSIZE_FULL
- ALLOCATE( PTAB_UNPACKED(KSIZE) )
- PTAB_UNPACKED(:) = PTAB(:)
- ENDIF
- !
- ! Redimension PTAB into a 2D field
- !
- ALLOCATE(ZFIELD2D(IIU,IJU))
- ZFIELD2D = 0.
- DO IJ=1+JPHEXT,IJU-JPHEXT
- DO II=1+JPHEXT,IIU-JPHEXT
- IF(PRESENT(HTYPE)) THEN
- ZFIELD2D(II,IJ) = PTAB_UNPACKED((IJ-JPHEXT-1+NHALO)*(KXEND-KXOR+1+2*NHALO)+II-JPHEXT+NHALO)
- ELSE
- ZFIELD2D(II,IJ) = PTAB_UNPACKED((IJ-JPHEXT-1)*(KXEND-KXOR+1)+II-JPHEXT)
- END IF
- ENDDO
- ENDDO
- !
- ! Call MPPDB_CHECK2D on ZFIELD3D
- !
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- write(6,*) ' MPPDB_CHECK_SURFEX2D :'
- ENDIF
- CALL MPPDB_CHECK2D(ZFIELD2D,MESSAGE,PPRECISION)
-
- IF (ALLOCATED(KMASK)) DEALLOCATE( KMASK )
- IF (ALLOCATED(PTAB_UNPACKED)) DEALLOCATE( PTAB_UNPACKED )
- IF (ALLOCATED(ZFIELD2D)) DEALLOCATE( ZFIELD2D )
- !
- END SUBROUTINE MPPDB_CHECK_SURFEX2D
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- SUBROUTINE MPPDB_CHECK_SURFEX3D(PTAB,MESSAGE,PPRECISION,KLUOUT,HTYPE,KZSIZE)
-
- USE MODD_PARAMETERS, ONLY : JPHEXT
- USE MODI_GET_1D_MASK
- USE MODI_UNPACK_SAME_RANK
- USE MODI_GET_SURF_MASK_n
- USE MODD_IO_SURF_MNH, ONLY : NHALO
- USE MODD_CONFZ , ONLY : MPI_BUFFER_SIZE
- USE MODD_MPIF, ONLY: MPI_STATUS_IGNORE, MPI_MAX, MPI_SUM
- USE MODD_MNH_SURFEX_n
- use modd_precision, only: MNHINT_MPI
-!
- IMPLICIT NONE
-!
- REAL, DIMENSION(:,:) :: PTAB
- CHARACTER(len=*) :: MESSAGE
- REAL :: PPRECISION
- CHARACTER(LEN=*), INTENT(IN),OPTIONAL :: HTYPE ! 'WATER', 'NATURE', 'TOWN', 'SEA', 'FULL' (default is 'FULL')
- INTEGER, INTENT(IN) :: KLUOUT ! output listing logical unit
- INTEGER, INTENT(IN),OPTIONAL :: KZSIZE ! size of Z-dimension. Necessary if PTAB is of size 0 on one process
- !
- ! local var
- !
- REAL,ALLOCATABLE, DIMENSION(:,:) :: PTAB_UNPACKED
- REAL,ALLOCATABLE, DIMENSION(:,:,:) :: ZFIELD3D
- INTEGER :: IIU,IJU,IKU
- INTEGER :: KXOR, KYOR, KXEND, KYEND ! origin and end of the local physical subdomain
- INTEGER :: II,IJ,IK
- INTEGER, ALLOCATABLE, DIMENSION(:) :: KMASK
- INTEGER :: KSIZE
- INTEGER :: KSIZEBUF
- INTEGER :: KSIZE_FULL
- INTEGER :: IGLBSIZEPTAB
- INTEGER :: INBSLICES
- INTEGER :: IINFO_ll
- INTEGER :: IKSIZE_ll
- !
- IF ( ( .NOT. MPPDB_INITIALIZED ) .OR. ( .NOT. MPPDB_ACTIVED ) ) RETURN
- CALL MPI_ALLREDUCE(SIZE(PTAB), IGLBSIZEPTAB, 1,MNHINT_MPI, MPI_SUM, MPPDB_INTRA_COMM, IINFO_ll)
- IF ( IGLBSIZEPTAB == 0 ) RETURN
- CALL MPI_ALLREDUCE(SIZE(PTAB,2),IKSIZE_ll, 1, MNHINT_MPI, MPI_MAX, MPPDB_INTRA_COMM, IINFO_ll)
- !
- IF ( SIZE(PTAB) == 0 ) THEN !if the local size of the field is 0, we need to define ZFIELD3D filled with default value 1e20
- CALL GET_INDICE_ll( KXOR, KYOR, KXEND, KYEND )
- IIU = KXEND-KXOR+1+2*JPHEXT
- IJU = KYEND-KYOR+1+2*JPHEXT
- IKU = IKSIZE_ll
- ALLOCATE(ZFIELD3D(IIU,IJU,IKU))
- ZFIELD3D = 1.E20
- ELSE
- !
- ! Get the dimensions of the subdomain
- !
- CALL GET_INDICE_ll( KXOR, KYOR, KXEND, KYEND )
- IIU = KXEND-KXOR+1+2*JPHEXT
- IJU = KYEND-KYOR+1+2*JPHEXT
- IKU = SIZE(PTAB,2)
- KSIZE_FULL = (KXEND-KXOR+1)*(KYEND-KYOR+1)
- IF ( PRESENT(HTYPE) .AND. KSIZE_FULL /= SIZE(YSURF_CUR%U%XCOVER,1) .AND. NHALO /= JPHEXT ) THEN
- KSIZE_FULL = (KXEND-KXOR+1+2*NHALO) * (KYEND-KYOR+1+2*NHALO)
- ENDIF
- !
- ! Unpack PTAB
- !
- IF(PRESENT(HTYPE)) THEN
- KSIZE = SIZE( PTAB, 1 )
- ALLOCATE( KMASK(KSIZE) )
- ALLOCATE( PTAB_UNPACKED(KSIZE_FULL,IKU) )
- CALL GET_SURF_MASK_n(YSURF_CUR%DTCO,YSURF_CUR%U,HTYPE,KSIZE,KMASK,KSIZE_FULL,KLUOUT)
- DO II=1,IKU
- CALL UNPACK_SAME_RANK( KMASK, PTAB(:,II), PTAB_UNPACKED(:,II) )
- ENDDO
- ELSE
- KSIZE = KSIZE_FULL
- ALLOCATE( PTAB_UNPACKED(KSIZE,IKU) )
- PTAB_UNPACKED(:,:) = PTAB(:,:)
- ENDIF
- !
- ! Redimension PTAB into a 2D field
- !
- ALLOCATE(ZFIELD3D(IIU,IJU,IKU))
- ZFIELD3D = 0.
- DO IJ=1+JPHEXT,IJU-JPHEXT
- DO II=1+JPHEXT,IIU-JPHEXT
- !ZFIELD3D(II,IJ,:) = PTAB_UNPACKED((IJ-JPHEXT-1)*(KXEND-KXOR+1)+II-JPHEXT,:)
- ZFIELD3D(II,IJ,:) = PTAB_UNPACKED((IJ-JPHEXT-1+NHALO)*(KXEND-KXOR+1+2*NHALO)+II-JPHEXT+NHALO,:)
- ENDDO
- ENDDO
- ENDIF
- !
- ! Call MPPDB_CHECK3D on ZFIELD3D
- !
- ! pour eviter de communiquer des tableaux trop grands qui ne passent pas en memoire,
- ! on "decoupe" le champ en morceaux de taille inferieure a MPI_BUFFER_SIZE*1000000/8
- !ATTENTION : en fait ça ne suffit pas, il faut prendre une limite plus petite
- !je choisi arbitrairement 52*102*102 comme limite a la taille globale du champ
-! IF ( SIZE(ZFIELD3D) > MPI_BUFFER_SIZE*1000000/8 ) THEN
-! KSIZEBUF = SIZE(ZFIELD3D,3)*8/MPI_BUFFER_SIZE*1000000
-! IF ( SIZE(ZFIELD3D) > 52*102*102 ) THEN
- IF ( IGLBSIZEPTAB > MPI_BUFFER_SIZE*1000000/16 ) THEN
- INBSLICES = IGLBSIZEPTAB/(MPI_BUFFER_SIZE*1000000/16)
- IF (SIZE(ZFIELD3D,3) >= INBSLICES ) THEN
- KSIZEBUF = SIZE(ZFIELD3D,3)/INBSLICES
- ELSE
- write(6,*) ' MPPDB_CHECK_SURFEX3D : field \"',MESSAGE,'\" is too large to be checked with MPPDB. No checking was done...'
- ENDIF
-! IF ( IGLBSIZEPTAB > 52*102*102 ) THEN
-! INBSLICES = 52
-! IF (SIZE(ZFIELD3D,3) >=52 ) THEN
-! KSIZEBUF = SIZE(ZFIELD3D,3)/52
-! ELSE
-! KSIZEBUF=1
-! ENDIF
- DO IK=1,INBSLICES
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- IF ( KSIZEBUF*INBSLICES==SIZE(ZFIELD3D,3) ) THEN
- write(6,*) ' MPPDB_CHECK_SURFEX3D part ',IK,'/',INBSLICES,' :'
- ELSE
- write(6,*) ' MPPDB_CHECK_SURFEX3D part ',IK,'/',INBSLICES+1,' :'
- ENDIF
- ENDIF
- CALL MPPDB_CHECK3D(ZFIELD3D(:,:,(IK-1)*KSIZEBUF+1:IK*KSIZEBUF),MESSAGE,PPRECISION)
- ENDDO
- IF ( KSIZEBUF*INBSLICES==SIZE(ZFIELD3D,3) ) THEN
- ELSE
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- write(6,*) ' MPPDB_CHECK_SURFEX3D part ',IK,'/',INBSLICES+1,' :'
- ENDIF
- CALL MPPDB_CHECK3D(ZFIELD3D(:,:,KSIZEBUF*INBSLICES+1:),MESSAGE,PPRECISION)
- ENDIF
- ELSE
- IF (MPPDB_IRANK_WORLD.EQ.0) THEN
- write(6,*) ' MPPDB_CHECK_SURFEX3D :'
- ENDIF
- CALL MPPDB_CHECK3D(ZFIELD3D,MESSAGE,PPRECISION)
- ENDIF
- IF (ALLOCATED(KMASK)) DEALLOCATE( KMASK )
- IF (ALLOCATED(PTAB_UNPACKED)) DEALLOCATE( PTAB_UNPACKED )
- IF (ALLOCATED(ZFIELD3D)) DEALLOCATE( ZFIELD3D )
- !
- END SUBROUTINE MPPDB_CHECK_SURFEX3D
- !
- !
- SUBROUTINE CHECK_ISXYSIZE(KX,KY,OISXYSIZE_GLOB)
- !
- USE MODD_MPIF, ONLY: MPI_LAND
- use modd_precision, only: MNHLOG_MPI
- USE MODE_TOOLS_ll, ONLY: GET_DIM_EXT_ll
- !
- IMPLICIT NONE
- !
- INTEGER,INTENT(IN) :: KX,KY
- LOGICAL,INTENT(OUT) :: OISXYSIZE_GLOB
- !
- INTEGER :: IIU, IJU, IINFO_ll
- LOGICAL :: GISXYSIZE
- !
- CALL GET_DIM_EXT_ll('B',IIU,IJU)
- !Determine if the array has the same size as the mesh
- IF ( KX==IIU .AND. KY==IJU ) THEN
- GISXYSIZE = .TRUE.
- ELSE
- GISXYSIZE = .FALSE.
- END IF
- !
- CALL MPI_ALLREDUCE(GISXYSIZE,OISXYSIZE_GLOB,1,MNHLOG_MPI,MPI_LAND,MPPDB_INTER_COMM,IINFO_ll)
- !
- 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
--
GitLab