eesupp/src/bar_check.F

bf7adc9faf Jean*0001 #include "CPP_EEOPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: BAR_CHECK
                0005
                0006 C     !INTERFACE:
                0007       SUBROUTINE BAR_CHECK( barrierId, myThid )
                0008
                0009 C     !DESCRIPTION:
                0010 C     *=====================================================================*
                0011 C     | SUBROUTINE BAR\_CHECK
                0012 C     | o Check threads synchronization in the barrier calling sequence
                0013 C     *=====================================================================*
                0014 C     | o Apply double BARRIER and check that all threads get the same
                0015 C     |   barrierId.
                0016 C     *=====================================================================*
                0017
                0018 C     !USES:
                0019       IMPLICIT NONE
                0020 C     == Global variables ==
                0021 #include "SIZE.h"
                0022 #include "EEPARAMS.h"
                0023 C     == Local common block ==
                0024       INTEGER barStatus(nSx,nSy)
                0025       COMMON / BAR_CHECH_SYNCHRO / barStatus
                0026
                0027 C     !INPUT/OUTPUT PARAMETERS:
                0028 C     == Routine arguments ==
                0029 C     barrierId :: barrier identificator of this instance of BAR_CHECK
                0030 C     myThid    :: Thread number of this instance of BAR_CHECK
                0031       INTEGER barrierId
                0032       INTEGER myThid
                0033
                0034 C     !LOCAL VARIABLES:
                0035 C     == Local variables ==
                0036 C     bi,bj  :: tile indices
                0037 C     msgBuf :: Informational/error meesage buffer
                0038       INTEGER bi,bj
                0039       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0040       LOGICAL flag
                0041 CEOP
                0042
                0043       IF ( barrierId .NE. 0 ) THEN
                0044 C-    Only do checking when barrierId is non-zero
                0045
                0046 C-    Set barStatus to barrierId :
                0047        DO bj = myByLo(myThid), myByHi(myThid)
                0048         DO bi = myBxLo(myThid), myBxHi(myThid)
                0049           barStatus(bi,bj) = barrierId
                0050         ENDDO
                0051        ENDDO
                0052 C-    Synchro
                0053        _BARRIER
                0054 C-    Check that all threads have the same barStatus
                0055        flag = .FALSE.
                0056        DO bj = 1,nSy
                0057         DO bi = 1,nSx
                0058           flag = flag .OR. (barStatus(bi,bj).NE.barrierId)
                0059         ENDDO
                0060        ENDDO
                0061        IF ( flag ) THEN
                0062          WRITE(msgBuf,'(A,I4,A,I8)') 'BAR_CHECK: thread', myThid,
                0063      &        ' out of Sync when reaching barrierId=', barrierId
ccd6efaf81 Jean*0064          CALL PRINT_ERROR( msgBuf, myThid )
                0065 #ifndef DISABLE_WRITE_TO_UNIT_ZERO
bf7adc9faf Jean*0066          WRITE(0,*) myThid, barrierId, 'barStatus=', barStatus
ccd6efaf81 Jean*0067 #endif
                0068          STOP 'ABNORMAL END: S/R BAR_CHECK: OUT OF SYNC'
bf7adc9faf Jean*0069        ENDIF
                0070
                0071       ENDIF
                0072
                0073 C-    Synchro
                0074       _BARRIER
                0075
                0076       RETURN
                0077       END