pkg/exch2/exch2_check_depths.F

C $Header: /u/gcmpack/MITgcm/pkg/exch2/exch2_check_depths.F,v 1.5 2009/05/26 19:00:09 jmc Exp $
C $Name:  $

#include "PACKAGES_CONFIG.h"
#include "CPP_OPTIONS.h"
#include "W2_OPTIONS.h"

CBOP
C     !ROUTINE: EXCH2_CHECK_DEPTHS

C     !INTERFACE:
      SUBROUTINE EXCH2_CHECK_DEPTHS( rLow, rHigh, myThid )

C     !DESCRIPTION: \bc
C     *==========================================================*
C     | SUBROUTINE EXCH2_CHECK_DEPTHS
C     | o Check that disconnected tile edges (when using blank
C     |   tiles) correspond to a closed (= zero depth) boundary.
C     | Note: no check if using OBCs
C     *==========================================================*
C     \ev

C     !USES:
      IMPLICIT NONE
C     === Global variables ===
#include "SIZE.h"
#include "EEPARAMS.h"
c#include "EESUPPORT.h"
#include "W2_EXCH2_SIZE.h"
#include "W2_EXCH2_TOPOLOGY.h"
#ifdef ALLOW_OBCS
# include "PARAMS.h"
#endif

C     !INPUT/OUTPUT PARAMETERS:
C     === Routine arguments ===
C     rLow    :: Lower  "r" boundary
C     rHigh   :: Higher "r" boundary
C     myThid :: my Thread Id number
      _RS     rLow (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
      _RS     rHigh(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
      INTEGER myThid
CEOP

C     == Local variables ==
      _RS     tmpFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
      CHARACTER*(MAX_LEN_MBUF) msgBuf
      INTEGER bi, bj, tId
      INTEGER i, j, n
      INTEGER errN, errS, errE, errW
      LOGICAL errFlag

#ifdef ALLOW_OBCS
C-    For now, do nothing if OBCs is used
      IF ( useOBCs ) RETURN
#endif

      errFlag = .FALSE.
      DO bj = myByLo(myThid), myByHi(myThid)
       DO bi = myBxLo(myThid), myBxHi(myThid)

C-    Fill E,W & N,S edges with total depth from the interior
         i = sNx+1
         DO j=1,sNy
           tmpFld(0,j) = rHigh( 1 ,j,bi,bj) - rLow( 1 ,j,bi,bj)
           tmpFld(i,j) = rHigh(sNx,j,bi,bj) - rLow(sNx,j,bi,bj)
         ENDDO
         j = sNy+1
         DO i=1,sNx
           tmpFld(i,0) = rHigh(i, 1 ,bi,bj) - rLow(i, 1 ,bi,bj)
           tmpFld(i,j) = rHigh(i,sNy,bi,bj) - rLow(i,sNy,bi,bj)
         ENDDO

C-    Reset to zero if connected
         tId = W2_myTileList(bi,bj)
         DO n= 1,exch2_nNeighbours(tId)
          DO j=exch2_jLo(n,tId),exch2_jHi(n,tId)
           DO i=exch2_iLo(n,tId),exch2_iHi(n,tId)
            tmpFld(i,j) = 0.
           ENDDO
          ENDDO
         ENDDO

C- North:
         errN = 0
         j = sNy+1
         DO i=1,sNx
           IF ( tmpFld(i,j).GT.0. ) errN = errN + 1
         ENDDO
C- South:
         errS = 0
         j = 0
         DO i=1,sNx
           IF ( tmpFld(i,j).GT.0. ) errS = errS + 1
         ENDDO
C- East :
         errE = 0
         i = sNx+1
         DO j=1,sNy
           IF ( tmpFld(i,j).GT.0. ) errE = errE + 1
         ENDDO
C- West :
         errW = 0
         i = 0
         DO j=1,sNy
           IF ( tmpFld(i,j).GT.0. ) errW = errW + 1
         ENDDO

         IF ( errN+errS+errW+errE .GE. 1 ) THEN
          WRITE(msgBuf,'(2A,I6,A,2(I4,A))')
     &        '** WARNINGS ** EXCH2_CHECK_DEPTHS: ',
     &        'tile #', tId, ' (bi,bj=', bi, ',', bj, ' ):'
          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                        SQUEEZE_RIGHT, myThid )
          IF ( errN.GE.1 ) THEN
           WRITE(msgBuf,'(A,I5,A)') ' N.Edge has', errN,
     &        ' unconnected points with non-zero depth.'
           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                         SQUEEZE_RIGHT, myThid )
          ENDIF
          IF ( errS.GE.1 ) THEN
           WRITE(msgBuf,'(A,I5,A)') ' S.Edge has', errS,
     &        ' unconnected points with non-zero depth.'
           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                         SQUEEZE_RIGHT, myThid )
          ENDIF
          IF ( errE.GE.1 ) THEN
           WRITE(msgBuf,'(A,I5,A)') ' E.Edge has', errE,
     &        ' unconnected points with non-zero depth.'
           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                         SQUEEZE_RIGHT, myThid )
          ENDIF
          IF ( errW.GE.1 ) THEN
           WRITE(msgBuf,'(A,I5,A)') ' W.Edge has', errW,
     &        ' unconnected points with non-zero depth.'
           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                         SQUEEZE_RIGHT, myThid )
          ENDIF
          WRITE( msgBuf,'(A)') 'S/R EXCH2_CHECK_DEPTHS: Fatal Error'
          errFlag = .TRUE.
         ENDIF

       ENDDO
      ENDDO

#ifdef USE_ERROR_STOP
c     CALL STOP_IF_ERROR( errFlag, msgBuf, myThid )
#else  /* USE_ERROR_STOP */
c     IF ( errFlag ) STOP 'ABNORMAL END: S/R EXCH2_CHECK_DEPTHS'
#endif /* USE_ERROR_STOP */
      IF ( errFlag ) THEN
          WRITE( msgBuf,'(2A)') '** WARNINGS ** EXCH2_CHECK_DEPTHS:',
     &        ' some algorithm implementation might not be'
          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                        SQUEEZE_RIGHT, myThid )
          WRITE( msgBuf,'(2A)') '** WARNINGS ** EXCH2_CHECK_DEPTHS:',
     &        ' safe with non-zero depth next to blank-tile'
          CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
     &                        SQUEEZE_RIGHT, myThid )
      ENDIF

      RETURN
      END
1	jmc	1.6	C $Header: /u/gcmpack/MITgcm/pkg/exch2/exch2_check_depths.F,v 1.5 2009/05/26 19:00:09 jmc Exp $
2	jmc	1.1	C $Name: $
3
4	jmc	1.3	#include "PACKAGES_CONFIG.h"
5	jmc	1.1	#include "CPP_OPTIONS.h"
6			#include "W2_OPTIONS.h"
7
8			CBOP
9			C !ROUTINE: EXCH2_CHECK_DEPTHS
10
11			C !INTERFACE:
12			SUBROUTINE EXCH2_CHECK_DEPTHS( rLow, rHigh, myThid )
13
14			C !DESCRIPTION: \bc
15			C ==========================================================
16			C \| SUBROUTINE EXCH2_CHECK_DEPTHS
17			C \| o Check that disconnected tile edges (when using blank
18			C \| tiles) correspond to a closed (= zero depth) boundary.
19			C \| Note: no check if using OBCs
20			C ==========================================================
21			C \ev
22
23			C !USES:
24			IMPLICIT NONE
25			C === Global variables ===
26			#include "SIZE.h"
27			#include "EEPARAMS.h"
28			c#include "EESUPPORT.h"
29	jmc	1.4	#include "W2_EXCH2_SIZE.h"
30	jmc	1.1	#include "W2_EXCH2_TOPOLOGY.h"
31	jmc	1.3	#ifdef ALLOW_OBCS
32			# include "PARAMS.h"
33			#endif
34	jmc	1.1
35			C !INPUT/OUTPUT PARAMETERS:
36			C === Routine arguments ===
37			C rLow :: Lower "r" boundary
38			C rHigh :: Higher "r" boundary
39			C myThid :: my Thread Id number
40			_RS rLow (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
41			_RS rHigh(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
42			INTEGER myThid
43			CEOP
44
45			C == Local variables ==
46			_RS tmpFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
47			CHARACTER*(MAX_LEN_MBUF) msgBuf
48			INTEGER bi, bj, tId
49			INTEGER i, j, n
50			INTEGER errN, errS, errE, errW
51			LOGICAL errFlag
52
53	jmc	1.3	#ifdef ALLOW_OBCS
54	jmc	1.1	C- For now, do nothing if OBCs is used
55			IF ( useOBCs ) RETURN
56	jmc	1.3	#endif
57	jmc	1.1
58			errFlag = .FALSE.
59			DO bj = myByLo(myThid), myByHi(myThid)
60			DO bi = myBxLo(myThid), myBxHi(myThid)
61
62			C- Fill E,W & N,S edges with total depth from the interior
63			i = sNx+1
64			DO j=1,sNy
65			tmpFld(0,j) = rHigh( 1 ,j,bi,bj) - rLow( 1 ,j,bi,bj)
66			tmpFld(i,j) = rHigh(sNx,j,bi,bj) - rLow(sNx,j,bi,bj)
67			ENDDO
68			j = sNy+1
69			DO i=1,sNx
70			tmpFld(i,0) = rHigh(i, 1 ,bi,bj) - rLow(i, 1 ,bi,bj)
71			tmpFld(i,j) = rHigh(i,sNy,bi,bj) - rLow(i,sNy,bi,bj)
72			ENDDO
73
74			C- Reset to zero if connected
75	jmc	1.6	tId = W2_myTileList(bi,bj)
76	jmc	1.1	DO n= 1,exch2_nNeighbours(tId)
77			DO j=exch2_jLo(n,tId),exch2_jHi(n,tId)
78			DO i=exch2_iLo(n,tId),exch2_iHi(n,tId)
79			tmpFld(i,j) = 0.
80			ENDDO
81			ENDDO
82			ENDDO
83
84			C- North:
85			errN = 0
86			j = sNy+1
87			DO i=1,sNx
88			IF ( tmpFld(i,j).GT.0. ) errN = errN + 1
89			ENDDO
90			C- South:
91			errS = 0
92			j = 0
93			DO i=1,sNx
94			IF ( tmpFld(i,j).GT.0. ) errS = errS + 1
95			ENDDO
96			C- East :
97			errE = 0
98			i = sNx+1
99			DO j=1,sNy
100			IF ( tmpFld(i,j).GT.0. ) errE = errE + 1
101			ENDDO
102			C- West :
103			errW = 0
104			i = 0
105			DO j=1,sNy
106			IF ( tmpFld(i,j).GT.0. ) errW = errW + 1
107			ENDDO
108
109			IF ( errN+errS+errW+errE .GE. 1 ) THEN
110	jmc	1.5	WRITE(msgBuf,'(2A,I6,A,2(I4,A))')
111			& ' WARNINGS EXCH2_CHECK_DEPTHS: ',
112			& 'tile #', tId, ' (bi,bj=', bi, ',', bj, ' ):'
113			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
114			& SQUEEZE_RIGHT, myThid )
115	jmc	1.1	IF ( errN.GE.1 ) THEN
116			WRITE(msgBuf,'(A,I5,A)') ' N.Edge has', errN,
117			& ' unconnected points with non-zero depth.'
118	jmc	1.5	CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
119			& SQUEEZE_RIGHT, myThid )
120	jmc	1.1	ENDIF
121			IF ( errS.GE.1 ) THEN
122			WRITE(msgBuf,'(A,I5,A)') ' S.Edge has', errS,
123			& ' unconnected points with non-zero depth.'
124	jmc	1.5	CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
125			& SQUEEZE_RIGHT, myThid )
126	jmc	1.1	ENDIF
127			IF ( errE.GE.1 ) THEN
128			WRITE(msgBuf,'(A,I5,A)') ' E.Edge has', errE,
129			& ' unconnected points with non-zero depth.'
130	jmc	1.5	CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
131			& SQUEEZE_RIGHT, myThid )
132	jmc	1.1	ENDIF
133			IF ( errW.GE.1 ) THEN
134			WRITE(msgBuf,'(A,I5,A)') ' W.Edge has', errW,
135			& ' unconnected points with non-zero depth.'
136	jmc	1.5	CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
137			& SQUEEZE_RIGHT, myThid )
138	jmc	1.1	ENDIF
139	jmc	1.5	WRITE( msgBuf,'(A)') 'S/R EXCH2_CHECK_DEPTHS: Fatal Error'
140	jmc	1.1	errFlag = .TRUE.
141			ENDIF
142
143			ENDDO
144			ENDDO
145
146	jmc	1.2	#ifdef USE_ERROR_STOP
147	jmc	1.5	c CALL STOP_IF_ERROR( errFlag, msgBuf, myThid )
148	jmc	1.2	#else /* USE_ERROR_STOP */
149	jmc	1.5	c IF ( errFlag ) STOP 'ABNORMAL END: S/R EXCH2_CHECK_DEPTHS'
150	jmc	1.2	#endif /* USE_ERROR_STOP */
151	jmc	1.5	IF ( errFlag ) THEN
152			WRITE( msgBuf,'(2A)') ' WARNINGS EXCH2_CHECK_DEPTHS:',
153			& ' some algorithm implementation might not be'
154			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
155			& SQUEEZE_RIGHT, myThid )
156			WRITE( msgBuf,'(2A)') ' WARNINGS EXCH2_CHECK_DEPTHS:',
157			& ' safe with non-zero depth next to blank-tile'
158			CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
159			& SQUEEZE_RIGHT, myThid )
160			ENDIF
161	jmc	1.1
162			RETURN
163			END