C $Header: /u/gcmpack/MITgcm/eesupp/src/bar_check.F,v 1.2 2006/08/02 02:24:22 jmc Exp $ C $Name: $ #include "CPP_EEOPTIONS.h" CBOP C !ROUTINE: BAR_CHECK C !INTERFACE: SUBROUTINE BAR_CHECK( barrierId, myThid ) C !DESCRIPTION: C *=====================================================================* C | SUBROUTINE BAR\_CHECK C | o Check threads synchronization in the barrier calling sequence C *=====================================================================* C | o Apply double BARRIER and check that all threads get the same C | barrierId. C *=====================================================================* C !USES: IMPLICIT NONE C == Global variables == #include "SIZE.h" #include "EEPARAMS.h" C == Local common block == INTEGER barStatus(nSx,nSy) COMMON / BAR_CHECH_SYNCHRO / barStatus C !INPUT/OUTPUT PARAMETERS: C == Routine arguments == C barrierId :: barrier identificator of this instance of BAR_CHECK C myThid :: Thread number of this instance of BAR_CHECK INTEGER barrierId INTEGER myThid C !LOCAL VARIABLES: C == Local variables == C bi,bj :: tile indices C msgBuf :: Informational/error meesage buffer INTEGER bi,bj CHARACTER*(MAX_LEN_MBUF) msgBuf LOGICAL flag CEOP IF ( barrierId .NE. 0 ) THEN C- Only do checking when barrierId is non-zero C- Set barStatus to barrierId : DO bj = myByLo(myThid), myByHi(myThid) DO bi = myBxLo(myThid), myBxHi(myThid) barStatus(bi,bj) = barrierId ENDDO ENDDO C- Synchro _BARRIER C- Check that all threads have the same barStatus flag = .FALSE. DO bj = 1,nSy DO bi = 1,nSx flag = flag .OR. (barStatus(bi,bj).NE.barrierId) ENDDO ENDDO IF ( flag ) THEN WRITE(msgBuf,'(A,I4,A,I8)') 'BAR_CHECK: thread', myThid, & ' out of Sync when reaching barrierId=', barrierId CALL PRINT_ERROR( msgBuf, myThid ) #ifndef DISABLE_WRITE_TO_UNIT_ZERO WRITE(0,*) myThid, barrierId, 'barStatus=', barStatus #endif STOP 'ABNORMAL END: S/R BAR_CHECK: OUT OF SYNC' ENDIF ENDIF C- Synchro _BARRIER RETURN END