/[MITgcm]/MITgcm/pkg/obcs/obcs_check.F
ViewVC logotype

Diff of /MITgcm/pkg/obcs/obcs_check.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.11 by dimitri, Thu Oct 11 19:14:09 2007 UTC revision 1.12 by mlosch, Thu Apr 24 08:22:06 2008 UTC
# Line 6  C $Name$ Line 6  C $Name$
6        SUBROUTINE OBCS_CHECK( myThid )        SUBROUTINE OBCS_CHECK( myThid )
7  C     /==========================================================\  C     /==========================================================\
8  C     | SUBROUTINE OBCS_CHECK                                    |  C     | SUBROUTINE OBCS_CHECK                                    |
9  C     | o Check dependances with other packages                  |  C     | o Check dependences with other packages                  |
10  C     |==========================================================|  C     |==========================================================|
11  C     \==========================================================/  C     \==========================================================/
12        IMPLICIT NONE        IMPLICIT NONE
# Line 137  C     msgBuf      - Informational/error Line 137  C     msgBuf      - Informational/error
137  #endif /* ALLOW_OBCS */  #endif /* ALLOW_OBCS */
138        RETURN        RETURN
139        END        END
140    
141          SUBROUTINE OBCS_CHECK_TOPOGRAPHY( myThid )
142    C     /==========================================================\
143    C     | SUBROUTINE OBCS_CHECK_TOPOGRAPHY                         |
144    C     | o Check for non-zero normal gradient across open         |
145    C     |   boundaries                                             |
146    C     | o fix them if required and print a message               |
147    C     |==========================================================|
148    C     \==========================================================/
149          IMPLICIT NONE
150    
151    C     === Global variables ===
152    #include "SIZE.h"
153    #include "EEPARAMS.h"
154    #include "PARAMS.h"
155    #include "GRID.h"
156    #include "OBCS.h"
157    
158    C     === Routine arguments ===
159    C     myThid -  Number of this instances
160          INTEGER myThid
161    
162    #ifdef ALLOW_OBCS
163    C     === Local variables ===
164    C     msgBuf      - Informational/error meesage buffer
165          CHARACTER*(MAX_LEN_MBUF) msgBuf
166          INTEGER bi, bj, I, J, K, ichanged
167    
168          IF ( OBCSfixTopo ) THEN
169    C--   Modify topography to ensure that outward d(topography)/dn >= 0,
170    C     topography at open boundary points must be equal or shallower than
171    C     topography one grid-point inward from open boundary
172          ichanged = 0
173          DO bj = myByLo(myThid), myByHi(myThid)
174           DO bi = myBxLo(myThid), myBxHi(myThid)
175    
176            DO K=1,Nr
177    #ifdef ALLOW_OBCS_NORTH
178             DO I=1,sNx
179              J=OB_Jn(I,bi,bj)
180              IF ( J .NE. 0 .AND.
181         &         ( R_low(I,J,bi,bj) .LT. R_low(I,J-1,bi,bj) ) ) THEN
182               ichanged = ichanged + 1
183               R_low(I,J,bi,bj) = R_low(I,J-1,bi,bj)
184               WRITE(msgBuf,'(2A,(1X,4I6))')
185         &          'S/R OBCS_CHECK_TOPOGRAPHY: fixed topography at ',
186         &          '(i,j,bi,bj) = ',  I, J, bi, bj
187               CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
188         &          SQUEEZE_RIGHT, myThid)
189              ENDIF
190             ENDDO
191    #endif
192    #ifdef ALLOW_OBCS_SOUTH
193             DO I=1,sNx
194              J=OB_Js(I,bi,bj)
195              IF ( J .NE. 0 .AND.
196         &         ( R_low(I,J,bi,bj) .LT. R_low(I,J+1,bi,bj) ) ) THEN
197               ichanged = ichanged + 1
198               R_low(I,J,bi,bj) = R_low(I,J+1,bi,bj)
199               WRITE(msgBuf,'(2A,(1X,4I6))')
200         &          'S/R OBCS_CHECK_TOPOGRAPHY: fixed topography at ',
201         &          '(i,j,bi,bj) = ',  I, J, bi, bj
202               CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
203         &          SQUEEZE_RIGHT, myThid)
204              ENDIF
205             ENDDO
206    #endif
207    #ifdef ALLOW_OBCS_EAST
208             DO J=1,sNy
209              I = OB_Ie(J,bi,bj)
210              IF ( I .NE. 0 .AND.
211         &         ( R_low(I,J,bi,bj) .LT. R_low(I-1,J,bi,bj) ) ) THEN
212               ichanged = ichanged + 1
213               R_low(I,J,bi,bj) = R_low(I-1,J,bi,bj)
214               WRITE(msgBuf,'(2A,(1X,4I6))')
215         &          'S/R OBCS_CHECK_TOPOGRAPHY: fixed topography at ',
216         &          '(i,j,bi,bj) = ',  I, J, bi, bj
217               CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
218         &          SQUEEZE_RIGHT, myThid)
219              ENDIF
220             ENDDO
221    #endif
222    C Western boundary
223    #ifdef ALLOW_OBCS_WEST
224             DO J=1,sNy
225              I = OB_Iw(J,bi,bj)
226              IF ( I .NE. 0 .AND.
227         &         ( R_low(I,J,bi,bj) .LT. R_low(I+1,J,bi,bj) ) ) THEN
228               ichanged = ichanged + 1
229               R_low(I,J,bi,bj) = R_low(I+1,J,bi,bj)
230               WRITE(msgBuf,'(2A,(1X,4I6))')
231         &          'S/R OBCS_CHECK_TOPOGRAPHY: fixed topography at ',
232         &          '(i,j,bi,bj) = ',  I, J, bi, bj
233               CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
234         &          SQUEEZE_RIGHT, myThid)
235              ENDIF
236             ENDDO
237    #endif
238            ENDDO
239            
240           ENDDO
241          ENDDO      
242    C--   some diagnostics to stdout
243          IF ( ichanged .GT. 0 ) THEN
244           WRITE(msgBuf,'(A,I7,A,A)')
245         &      'OBCS message: corrected ', ichanged,
246         &      ' instances of problematic topography gradients',
247         &      ' normal to open boundaries'
248           CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
249         &      SQUEEZE_RIGHT, myThid)
250          ENDIF
251    C     endif (OBCSfixTopo)
252          ENDIF
253    #endif /* ALLOW_OBCS */
254          
255          RETURN
256          END
Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12
  ViewVC Help
Powered by ViewVC 1.1.22