pkg/obcs/obcs_check_depths.F

614077ca71 Jean*0001 #include "OBCS_OPTIONS.h"
                0002
                0003       SUBROUTINE OBCS_CHECK_DEPTHS( myThid )
                0004 C     *==========================================================*
7ab2af4f8a Jean*0005 C     | SUBROUTINE OBCS_CHECK_DEPTHS
                0006 C     | o Check for non-zero normal gradient across open
                0007 C     |   boundaries
                0008 C     | o fix them if required and print a message
614077ca71 Jean*0009 C     *==========================================================*
                0010 C     *==========================================================*
                0011       IMPLICIT NONE
                0012
                0013 C     === Global variables ===
                0014 #include "SIZE.h"
                0015 #include "EEPARAMS.h"
                0016 #include "PARAMS.h"
                0017 #include "GRID.h"
9b4f2a04e2 Jean*0018 #include "OBCS_PARAMS.h"
                0019 #include "OBCS_GRID.h"
614077ca71 Jean*0020
                0021 C     === Routine arguments ===
7ab2af4f8a Jean*0022 C     myThid    :: my Thread Id number
614077ca71 Jean*0023       INTEGER myThid
                0024
                0025 #ifdef ALLOW_OBCS
                0026 C     === Local variables ===
7ab2af4f8a Jean*0027 C     msgBuf    :: Informational/error message buffer
614077ca71 Jean*0028       CHARACTER*(MAX_LEN_MBUF) msgBuf
268338d16f Jean*0029       INTEGER bi, bj, i, j, ichanged
614077ca71 Jean*0030
                0031       IF ( OBCSfixTopo ) THEN
                0032 C--   Modify topography to ensure that outward d(topography)/dn >= 0,
                0033 C     topography at open boundary points must be equal or shallower than
                0034 C     topography one grid-point inward from open boundary
                0035       ichanged = 0
                0036       DO bj = myByLo(myThid), myByHi(myThid)
                0037        DO bi = myBxLo(myThid), myBxHi(myThid)
                0038
                0039 #ifdef ALLOW_OBCS_NORTH
268338d16f Jean*0040         DO i=1,sNx
                0041          j = OB_Jn(i,bi,bj)
                0042          IF ( j.NE.OB_indexNone ) THEN
                0043           IF ( R_low(i,j,bi,bj) .LT. R_low(i,j-1,bi,bj) ) THEN
614077ca71 Jean*0044            ichanged = ichanged + 1
268338d16f Jean*0045            R_low(i,j,bi,bj) = R_low(i,j-1,bi,bj)
faeac5b8f9 Jean*0046            WRITE(msgBuf,'(2A,2I6,2I4)')
                0047      &          'OBCS_CHECK_DEPTHS: fixed topography at ',
268338d16f Jean*0048      &          '(i,j,bi,bj)=',  i, j, bi, bj
614077ca71 Jean*0049            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0050      &          SQUEEZE_RIGHT, myThid)
                0051           ENDIF
268338d16f Jean*0052          ENDIF
                0053         ENDDO
614077ca71 Jean*0054 #endif
                0055 #ifdef ALLOW_OBCS_SOUTH
268338d16f Jean*0056         DO i=1,sNx
                0057          j = OB_Js(i,bi,bj)
                0058          IF ( j.NE.OB_indexNone ) THEN
                0059           IF ( R_low(i,j,bi,bj) .LT. R_low(i,j+1,bi,bj) ) THEN
614077ca71 Jean*0060            ichanged = ichanged + 1
268338d16f Jean*0061            R_low(i,j,bi,bj) = R_low(i,j+1,bi,bj)
faeac5b8f9 Jean*0062            WRITE(msgBuf,'(2A,2I6,2I4)')
                0063      &          'OBCS_CHECK_DEPTHS: fixed topography at ',
268338d16f Jean*0064      &          '(i,j,bi,bj)=',  i, j, bi, bj
614077ca71 Jean*0065            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0066      &          SQUEEZE_RIGHT, myThid)
                0067           ENDIF
268338d16f Jean*0068          ENDIF
                0069         ENDDO
614077ca71 Jean*0070 #endif
                0071 #ifdef ALLOW_OBCS_EAST
268338d16f Jean*0072         DO j=1,sNy
                0073          i = OB_Ie(j,bi,bj)
                0074          IF ( i.NE.OB_indexNone ) THEN
                0075           IF ( R_low(i,j,bi,bj) .LT. R_low(i-1,j,bi,bj) ) THEN
614077ca71 Jean*0076            ichanged = ichanged + 1
268338d16f Jean*0077            R_low(i,j,bi,bj) = R_low(i-1,j,bi,bj)
faeac5b8f9 Jean*0078            WRITE(msgBuf,'(2A,2I6,2I4)')
                0079      &          'OBCS_CHECK_DEPTHS: fixed topography at ',
268338d16f Jean*0080      &          '(i,j,bi,bj)=',  i, j, bi, bj
614077ca71 Jean*0081            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0082      &          SQUEEZE_RIGHT, myThid)
                0083           ENDIF
268338d16f Jean*0084          ENDIF
                0085         ENDDO
614077ca71 Jean*0086 #endif
                0087 C Western boundary
                0088 #ifdef ALLOW_OBCS_WEST
268338d16f Jean*0089         DO j=1,sNy
                0090          i = OB_Iw(j,bi,bj)
                0091          IF ( i.NE.OB_indexNone ) THEN
                0092           IF ( R_low(i,j,bi,bj) .LT. R_low(i+1,j,bi,bj) ) THEN
614077ca71 Jean*0093            ichanged = ichanged + 1
268338d16f Jean*0094            R_low(i,j,bi,bj) = R_low(i+1,j,bi,bj)
faeac5b8f9 Jean*0095            WRITE(msgBuf,'(2A,2I6,2I4)')
                0096      &          'OBCS_CHECK_DEPTHS: fixed topography at ',
268338d16f Jean*0097      &          '(i,j,bi,bj)=',  i, j, bi, bj
614077ca71 Jean*0098            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0099      &          SQUEEZE_RIGHT, myThid)
                0100           ENDIF
268338d16f Jean*0101          ENDIF
614077ca71 Jean*0102         ENDDO
268338d16f Jean*0103 #endif
614077ca71 Jean*0104
                0105        ENDDO
                0106       ENDDO
                0107 C--   some diagnostics to stdout
7ab2af4f8a Jean*0108       CALL GLOBAL_SUM_INT( ichanged, myThid )
614077ca71 Jean*0109       IF ( ichanged .GT. 0 ) THEN
faeac5b8f9 Jean*0110        _BEGIN_MASTER(myThid)
                0111        WRITE(msgBuf,'(2A,I7,A)') 'OBCS_CHECK_DEPTHS: ',
                0112      &   'Topography gradients normal to open boundaries:'
614077ca71 Jean*0113        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
faeac5b8f9 Jean*0114      &                     SQUEEZE_RIGHT, myThid )
                0115        WRITE(msgBuf,'(2A,I7,A)') 'OBCS_CHECK_DEPTHS: ',
                0116      &   '==> corrected ', ichanged,' problematic grid-points'
                0117 c      WRITE(msgBuf,'(A,I7,A,A)')
                0118 c    &      'OBCS message: corrected ', ichanged,
                0119 c    &      ' instances of problematic topography gradients',
                0120 c    &      ' normal to open boundaries'
                0121        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0122      &                     SQUEEZE_RIGHT, myThid )
                0123        _END_MASTER(myThid)
614077ca71 Jean*0124       ENDIF
7ab2af4f8a Jean*0125
614077ca71 Jean*0126 C     endif (OBCSfixTopo)
                0127       ENDIF
                0128 #endif /* ALLOW_OBCS */
                0129
                0130       RETURN
                0131       END