pkg/compon_communic/mitcplr_all_check.F

be1eeeb849 Jean*0001 CBOP
                0002 C     !INTERFACE:
                0003       SUBROUTINE MITCPLR_ALL_CHECK( errFlag, errMsg )
                0004
                0005 C     !DESCRIPTION:
                0006 C     *==========================================================*
                0007 C     | SUBROUTINE MITCPLR_ALL_CHECK
                0008 C     | o Stop every Processes in World if flag is true
                0009 C     *==========================================================*
                0010 C     | Gather error-flag from all processes in World and
                0011 C     |  stop if one is in error. This assumes that every-one
                0012 C     | (all coupler procs and all components) call this routine
                0013 C     *==========================================================*
                0014
                0015       IMPLICIT NONE
                0016
                0017 C Predefined constants/arrays
                0018 #include "CPLR_SIG.h"
                0019 C MPI variables
                0020 #include "mpif.h"
                0021
                0022 C !INPUT/OUTPUT PARAMETERS:
                0023 C     errFlag :: stop if this logical flag is true
                0024 C     errMsg  :: error message to print in case it stops
                0025       LOGICAL errFlag
                0026       CHARACTER*(*) errMsg
                0027
                0028 C !LOCAL VARIABLES:
                0029 C     msgBuf       :: I/O Buffer
                0030 C     errCount     :: error counter
                0031 c     CHARACTER*(MAX_LEN_MBUF) msgBuf
                0032       INTEGER errCount, errLoc, mpiRC
                0033 CEOP
                0034
                0035 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0036
                0037 C--   Collect error from all Procs
                0038       errLoc = 0
                0039       IF ( errFlag ) THEN
                0040         errLoc = 1
                0041       ENDIF
                0042       CALL MPI_Allreduce( errLoc, errCount, 1, MPI_INTEGER, MPI_SUM,
                0043      &                    MPI_COMM_WORLD, mpiRC )
                0044
                0045       IF ( errCount.GE.1 ) THEN
                0046 C--   Print message
                0047         IF ( errFlag .AND. errMsg.NE.' ' ) THEN
                0048           WRITE(LogUnit,'(2A)') ' *** ERROR *** ', errMsg
                0049         ENDIF
                0050         WRITE(LogUnit,'(A,I8,A)')
                0051      &   'FATAL ERROR for ', errCount, ' Proc(s) ==> Stop here'
                0052 C--   Finishes
                0053 c       CALL ALL_PROC_DIE( myThid )
                0054         CALL MPI_FINALIZE( mpiRC )
                0055         STOP 'ABNORMAL END: S/R MITCPLR_ALL_CHECK'
                0056       ENDIF
                0057
                0058       RETURN
                0059       END