pkg/exch2/exch2_check_depths.F

ca9dfa26c1 Jean*0001 #include "PACKAGES_CONFIG.h"
e31f23dc17 Jean*0002 #include "CPP_OPTIONS.h"
                0003 #include "W2_OPTIONS.h"
                0004
                0005 CBOP
                0006 C     !ROUTINE: EXCH2_CHECK_DEPTHS
                0007
                0008 C     !INTERFACE:
                0009       SUBROUTINE EXCH2_CHECK_DEPTHS( rLow, rHigh, myThid )
                0010
                0011 C     !DESCRIPTION: \bc
                0012 C     *==========================================================*
                0013 C     | SUBROUTINE EXCH2_CHECK_DEPTHS
                0014 C     | o Check that disconnected tile edges (when using blank
                0015 C     |   tiles) correspond to a closed (= zero depth) boundary.
                0016 C     | Note: no check if using OBCs
                0017 C     *==========================================================*
                0018 C     \ev
                0019
                0020 C     !USES:
                0021       IMPLICIT NONE
                0022 C     === Global variables ===
                0023 #include "SIZE.h"
                0024 #include "EEPARAMS.h"
                0025 c#include "EESUPPORT.h"
90219e5912 Jean*0026 #include "W2_EXCH2_SIZE.h"
e31f23dc17 Jean*0027 #include "W2_EXCH2_TOPOLOGY.h"
ca9dfa26c1 Jean*0028 #ifdef ALLOW_OBCS
                0029 # include "PARAMS.h"
                0030 #endif
e31f23dc17 Jean*0031
                0032 C     !INPUT/OUTPUT PARAMETERS:
                0033 C     === Routine arguments ===
                0034 C     rLow    :: Lower  "r" boundary
                0035 C     rHigh   :: Higher "r" boundary
4f747a7822 Jean*0036 C     myThid  :: my Thread Id number
e31f23dc17 Jean*0037       _RS     rLow (1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0038       _RS     rHigh(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0039       INTEGER myThid
                0040 CEOP
                0041
                0042 C     == Local variables ==
                0043       _RS     tmpFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0044       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0045       INTEGER bi, bj, tId
                0046       INTEGER i, j, n
                0047       INTEGER errN, errS, errE, errW
                0048       LOGICAL errFlag
                0049
ca9dfa26c1 Jean*0050 #ifdef ALLOW_OBCS
e31f23dc17 Jean*0051 C-    For now, do nothing if OBCs is used
                0052       IF ( useOBCs ) RETURN
ca9dfa26c1 Jean*0053 #endif
e31f23dc17 Jean*0054
                0055       errFlag = .FALSE.
                0056       DO bj = myByLo(myThid), myByHi(myThid)
                0057        DO bi = myBxLo(myThid), myBxHi(myThid)
                0058
                0059 C-    Fill E,W & N,S edges with total depth from the interior
                0060          i = sNx+1
                0061          DO j=1,sNy
                0062            tmpFld(0,j) = rHigh( 1 ,j,bi,bj) - rLow( 1 ,j,bi,bj)
                0063            tmpFld(i,j) = rHigh(sNx,j,bi,bj) - rLow(sNx,j,bi,bj)
                0064          ENDDO
                0065          j = sNy+1
                0066          DO i=1,sNx
                0067            tmpFld(i,0) = rHigh(i, 1 ,bi,bj) - rLow(i, 1 ,bi,bj)
                0068            tmpFld(i,j) = rHigh(i,sNy,bi,bj) - rLow(i,sNy,bi,bj)
                0069          ENDDO
                0070
                0071 C-    Reset to zero if connected
8adbfea2f8 Jean*0072          tId = W2_myTileList(bi,bj)
e31f23dc17 Jean*0073          DO n= 1,exch2_nNeighbours(tId)
                0074           DO j=exch2_jLo(n,tId),exch2_jHi(n,tId)
                0075            DO i=exch2_iLo(n,tId),exch2_iHi(n,tId)
                0076             tmpFld(i,j) = 0.
                0077            ENDDO
                0078           ENDDO
                0079          ENDDO
                0080
                0081 C- North:
                0082          errN = 0
                0083          j = sNy+1
                0084          DO i=1,sNx
                0085            IF ( tmpFld(i,j).GT.0. ) errN = errN + 1
                0086          ENDDO
                0087 C- South:
                0088          errS = 0
                0089          j = 0
                0090          DO i=1,sNx
                0091            IF ( tmpFld(i,j).GT.0. ) errS = errS + 1
                0092          ENDDO
                0093 C- East :
                0094          errE = 0
                0095          i = sNx+1
                0096          DO j=1,sNy
                0097            IF ( tmpFld(i,j).GT.0. ) errE = errE + 1
                0098          ENDDO
                0099 C- West :
                0100          errW = 0
                0101          i = 0
                0102          DO j=1,sNy
                0103            IF ( tmpFld(i,j).GT.0. ) errW = errW + 1
                0104          ENDDO
                0105
                0106          IF ( errN+errS+errW+errE .GE. 1 ) THEN
b9dadda204 Mart*0107           WRITE(msgBuf,'(2A,I8,A,2(I4,A))')
4f747a7822 Jean*0108      &        '** WARNING ** EXCH2_CHECK_DEPTHS: ',
f1521734b9 Jean*0109      &        'tile #', tId, ' (bi,bj=', bi, ',', bj, ' ):'
                0110           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0111      &                        SQUEEZE_RIGHT, myThid )
e31f23dc17 Jean*0112           IF ( errN.GE.1 ) THEN
                0113            WRITE(msgBuf,'(A,I5,A)') ' N.Edge has', errN,
                0114      &        ' unconnected points with non-zero depth.'
f1521734b9 Jean*0115            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0116      &                         SQUEEZE_RIGHT, myThid )
e31f23dc17 Jean*0117           ENDIF
                0118           IF ( errS.GE.1 ) THEN
                0119            WRITE(msgBuf,'(A,I5,A)') ' S.Edge has', errS,
                0120      &        ' unconnected points with non-zero depth.'
f1521734b9 Jean*0121            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0122      &                         SQUEEZE_RIGHT, myThid )
e31f23dc17 Jean*0123           ENDIF
                0124           IF ( errE.GE.1 ) THEN
                0125            WRITE(msgBuf,'(A,I5,A)') ' E.Edge has', errE,
                0126      &        ' unconnected points with non-zero depth.'
f1521734b9 Jean*0127            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0128      &                         SQUEEZE_RIGHT, myThid )
e31f23dc17 Jean*0129           ENDIF
                0130           IF ( errW.GE.1 ) THEN
                0131            WRITE(msgBuf,'(A,I5,A)') ' W.Edge has', errW,
                0132      &        ' unconnected points with non-zero depth.'
f1521734b9 Jean*0133            CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0134      &                         SQUEEZE_RIGHT, myThid )
e31f23dc17 Jean*0135           ENDIF
                0136           WRITE( msgBuf,'(A)') 'S/R EXCH2_CHECK_DEPTHS: Fatal Error'
f1521734b9 Jean*0137           errFlag = .TRUE.
e31f23dc17 Jean*0138          ENDIF
                0139
                0140        ENDDO
                0141       ENDDO
                0142
d3fbaa6766 Jean*0143 #ifdef USE_ERROR_STOP
f1521734b9 Jean*0144 c     CALL STOP_IF_ERROR( errFlag, msgBuf, myThid )
d3fbaa6766 Jean*0145 #else  /* USE_ERROR_STOP */
f1521734b9 Jean*0146 c     IF ( errFlag ) STOP 'ABNORMAL END: S/R EXCH2_CHECK_DEPTHS'
d3fbaa6766 Jean*0147 #endif /* USE_ERROR_STOP */
f1521734b9 Jean*0148       IF ( errFlag ) THEN
4f747a7822 Jean*0149           WRITE( msgBuf,'(2A)') '** WARNING ** EXCH2_CHECK_DEPTHS:',
f1521734b9 Jean*0150      &        ' some algorithm implementation might not be'
                0151           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0152      &                        SQUEEZE_RIGHT, myThid )
4f747a7822 Jean*0153           WRITE( msgBuf,'(2A)') '** WARNING ** EXCH2_CHECK_DEPTHS:',
f1521734b9 Jean*0154      &        ' safe with non-zero depth next to blank-tile'
                0155           CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
                0156      &                        SQUEEZE_RIGHT, myThid )
                0157       ENDIF
e31f23dc17 Jean*0158
                0159       RETURN
                0160       END