Back to home page

MITgcm
 
 

    

File indexing completed on 2024-11-07 06:11:08 UTC

view on githubraw file Latest commit 9f85ea26 on 2024-11-06 14:50:55 UTC
9c7e07a4e1 Jean*0001 #include "GRDCHK_OPTIONS.h"
a7eff9e819 Jean*0002 #ifdef ALLOW_CTRL
                0003 # include "CTRL_OPTIONS.h"
                0004 #endif
f81d465bd0 Patr*0005 
9f85ea262e Mart*0006 CBOP
                0007 C     !ROUTINE: GRDCHK_GET_POSITION
                0008 C     !INTERFACE:
                0009       SUBROUTINE GRDCHK_GET_POSITION( myThid )
f81d465bd0 Patr*0010 
9f85ea262e Mart*0011 C     !DESCRIPTION:
                0012 C     o Get the location of a given component of the control vector for
                0013 C       the current process.
                0014 C
                0015 C     started: Christian Eckert eckert@mit.edu 04-Apr-2000
                0016 C     continued: heimbach@mit.edu: 13-Jun-2001
f81d465bd0 Patr*0017 
9f85ea262e Mart*0018 C     !USES:
                0019       IMPLICIT NONE
f81d465bd0 Patr*0020 
                0021 #include "EEPARAMS.h"
                0022 #include "SIZE.h"
                0023 #include "GRID.h"
e6556bc77a Mart*0024 #ifdef ALLOW_SHELFICE
                0025 # include "SHELFICE.h"
9c7e07a4e1 Jean*0026 #endif
c732bd258e Patr*0027 #ifdef ALLOW_OBCS
                0028 # include "OBCS_GRID.h"
                0029 #endif
5cf4364659 Mart*0030 #include "CTRL_SIZE.h"
4d72283393 Mart*0031 #include "CTRL.h"
444da61630 Mart*0032 #ifdef ALLOW_OBCS_CONTROL
                0033 C     CTRL_OBCS.h must be included before GRDCHK.h
                0034 # include "CTRL_OBCS.h"
                0035 #endif
                0036 #include "GRDCHK.h"
f81d465bd0 Patr*0037 
9f85ea262e Mart*0038 C     !INPUT/OUTPUT PARAMETERS:
                0039       INTEGER myThid
f81d465bd0 Patr*0040 
9f5240b52a Jean*0041 #ifdef ALLOW_GRDCHK
9f85ea262e Mart*0042 C     !LOCAL VARIABLES:
                0043       INTEGER icvrec
                0044       INTEGER jtile
                0045       INTEGER itile
                0046       INTEGER layer
                0047       INTEGER obcspos
                0048       INTEGER itilepos
                0049       INTEGER jtilepos
                0050       INTEGER itest
                0051       INTEGER ierr
                0052       INTEGER bi,bj
                0053       INTEGER i,j,k
                0054       INTEGER iobcs
                0055       INTEGER iwrk, jwrk, kwrk
                0056       INTEGER irec, irecwrk
                0057       INTEGER icomptest
                0058       INTEGER nobcsmax
                0059       INTEGER pastit
f81d465bd0 Patr*0060       _RL wetlocal
9f85ea262e Mart*0061 CEOP
f81d465bd0 Patr*0062 
9f85ea262e Mart*0063 C     local copies of COMMON block variable (GRDCHK.h)
                0064       itile    = iLocTile
                0065       jtile    = jLocTile
e4b263335d Patr*0066       itilepos = iGloPos
                0067       jtilepos = jGloPos
f81d465bd0 Patr*0068       layer    = kGloPos
                0069       obcspos  = obcsglo
                0070       icvrec   = recglo
                0071 
9f85ea262e Mart*0072       _BEGIN_MASTER( myThid )
e4b263335d Patr*0073 
9f85ea262e Mart*0074 C--   determine proc. number from following assumptions <= done in
                0075 C     grdchk_readparms
ef53b829d7 Jean*0076 
9f85ea262e Mart*0077       IF ( myProcId .EQ. grdchkwhichproc ) THEN
f81d465bd0 Patr*0078 
9f85ea262e Mart*0079 C     initialise parameters
                0080        ierr      = -5
                0081        pastit    = -1
                0082        wetlocal  = 0
f81d465bd0 Patr*0083 
9f85ea262e Mart*0084        itest     = 0
                0085        icomptest = 0
                0086        irecwrk   = 1
                0087        kwrk      = 1
                0088        jwrk      = 1
                0089        iwrk      = 1
f81d465bd0 Patr*0090 
9f85ea262e Mart*0091 C--   set max loop index for obcs multiplicities
                0092        IF ( ncvargrd(grdchkvarindex) .EQ. 'm' ) THEN
444da61630 Mart*0093 #ifdef ALLOW_OBCS_CONTROL
9f85ea262e Mart*0094         nobcsmax = nobcs
444da61630 Mart*0095 #else
9f85ea262e Mart*0096         PRINT *, 'S/R grdchk_get_position: Ooops!'
444da61630 Mart*0097 #endif
9f85ea262e Mart*0098        ELSE
                0099         nobcsmax = 1
                0100        ENDIF
                0101 
                0102 C--   Start to loop over records.
                0103        DO irec = irecwrk, ncvarrecs(grdchkvarindex)
                0104         iobcs = MOD((irec-1),nobcsmax) + 1
                0105         bi = itile
                0106         bj = jtile
                0107         DO k = kwrk, ncvarnrmax(grdchkvarindex)
e4b263335d Patr*0108 cph(
9f85ea262e Mart*0109 cph-print               PRINT *, 'ph-grd get_pos irec, bj, bi, k ',
ef53b829d7 Jean*0110 cph-print     &              irec, bj, bi, k
e4b263335d Patr*0111 cph)
9f85ea262e Mart*0112          IF ( ierr .ne. 0 ) THEN
                0113           DO j = jwrk, ncvarymax(grdchkvarindex)
                0114            DO i = iwrk, ncvarxmax(grdchkvarindex)
                0115             IF (ierr .NE. 0) THEN
                0116              IF ( ncvargrd(grdchkvarindex) .EQ. 'c' ) THEN
                0117               IF ( maskC(i,j,k,bi,bj) .GT. 0.) THEN
                0118                icomptest = icomptest + 1
                0119               ENDIF
                0120               wetlocal = maskC(i,j,k,bi,bj)
                0121              ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 's' ) THEN
                0122               IF ( _maskS(i,j,k,bi,bj) .GT. 0.) THEN
                0123                icomptest = icomptest + 1
                0124               ENDIF
                0125               wetlocal = _maskS(i,j,k,bi,bj)
                0126              ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 'w' ) THEN
                0127               IF ( _maskW(i,j,k,bi,bj) .GT. 0.) THEN
                0128                icomptest = icomptest + 1
                0129               ENDIF
                0130               wetlocal = _maskW(i,j,k,bi,bj)
6b47d550f4 Mart*0131 #ifdef ALLOW_SHELFICE
9f85ea262e Mart*0132 C--   Ice shelf mask.
                0133              ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 'i' ) THEN
                0134               IF ( maskSHI(i,j,k,bi,bj) .GT. 0.) THEN
                0135                icomptest = icomptest + 1
                0136               ENDIF
                0137               wetlocal = maskSHI(i,j,k,bi,bj)
6b47d550f4 Mart*0138 #endif /* ALLOW_SHELFICE */
5cf4364659 Mart*0139 #ifdef ALLOW_OBCS_CONTROL
9f85ea262e Mart*0140              ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 'm' ) THEN
                0141               IF ( ncvarfname(grdchkvarindex)
                0142      &             .EQ. xx_obcsn_file ) THEN
f81d465bd0 Patr*0143 #ifdef ALLOW_OBCSN_CONTROL
9f85ea262e Mart*0144                IF (grdchk_maskxz(i,k,bi,bj,iobcs) .GT. 0.
                0145      &              .AND. j .EQ. OB_Jn(i,bi,bj) ) THEN
                0146                 icomptest = icomptest + 1
                0147                ENDIF
                0148                wetlocal = grdchk_maskxz(i,k,bi,bj,iobcs)
f81d465bd0 Patr*0149 #endif
9f85ea262e Mart*0150               ELSEIF ( ncvarfname(grdchkvarindex)
                0151      &                    .EQ. xx_obcss_file ) THEN
f81d465bd0 Patr*0152 #ifdef ALLOW_OBCSS_CONTROL
9f85ea262e Mart*0153                IF (grdchk_maskxz(i,k,bi,bj,iobcs) .GT. 0.
                0154      &              .AND. j .EQ. OB_Js(i,bi,bj) ) THEN
                0155                 icomptest = icomptest + 1
                0156                ENDIF
                0157                wetlocal = grdchk_maskxz(i,k,bi,bj,iobcs)
f81d465bd0 Patr*0158 #endif
9f85ea262e Mart*0159               ELSEIF ( ncvarfname(grdchkvarindex)
                0160      &              .EQ. xx_obcse_file ) THEN
5cf4364659 Mart*0161 #ifdef ALLOW_OBCSE_CONTROL
9f85ea262e Mart*0162                IF (grdchk_maskyz(j,k,bi,bj,iobcs) .GT. 0.
                0163      &              .AND. i .EQ. OB_Ie(j,bi,bj) ) THEN
                0164                 icomptest = icomptest + 1
                0165                ENDIF
                0166                wetlocal = grdchk_maskyz(j,k,bi,bj,iobcs)
f81d465bd0 Patr*0167 #endif
9f85ea262e Mart*0168               ELSEIF ( ncvarfname(grdchkvarindex)
                0169      &              .EQ. xx_obcsw_file ) THEN
5cf4364659 Mart*0170 #ifdef ALLOW_OBCSW_CONTROL
9f85ea262e Mart*0171                IF ( grdchk_maskyz(j,k,bi,bj,iobcs) .GT. 0.
                0172      &              .AND. i .EQ. OB_Iw(j,bi,bj) ) THEN
                0173                 icomptest = icomptest + 1
                0174                ENDIF
                0175                wetlocal = grdchk_maskyz(j,k,bi,bj,iobcs)
f81d465bd0 Patr*0176 #endif
9f85ea262e Mart*0177               ENDIF
5cf4364659 Mart*0178 #endif /* ALLOW_OBCS_CONTROL */
9f85ea262e Mart*0179              ENDIF
                0180 
                0181              IF ( i     .EQ. itilepos .AND.
                0182      &            j     .EQ. jtilepos .AND.
                0183      &            k     .EQ. layer .AND.
                0184      &            bi    .EQ. itile .AND.
                0185      &            bj    .EQ. jtile .AND.
                0186      &            iobcs .EQ. obcspos .AND.
                0187      &            irec  .EQ. icvrec ) THEN
                0188               pastit = 0
                0189               IF ( wetlocal .NE.0 ) THEN
                0190                nbeg = icomptest
                0191                nend = nbeg + nend
                0192                ierr     = 0
                0193                WRITE(standardMessageUnit,'(a,6I5)')
                0194      &              ' grad-res exact position met: '
                0195                WRITE(standardMessageUnit,'(a,7I5)')
                0196      &              ' grad-res ', grdchkwhichproc,
                0197      &              nbeg, itilepos, jtilepos, layer,
                0198      &              itile, jtile
                0199                GOTO 1234
                0200               ENDIF
                0201              ELSEIF ( pastit .EQ. 0 .AND. wetlocal .NE.0 ) THEN
                0202               nbeg = icomptest
                0203               nend = nbeg + nend
                0204               ierr     = 0
                0205               WRITE(standardMessageUnit,'(a,6I5)')
                0206      &             ' grad-res closest next position: '
                0207               WRITE(standardMessageUnit,'(a,7I5)')
                0208      &             ' grad-res ', grdchkwhichproc,
                0209      &             nbeg, itilepos, jtilepos, layer,
                0210      &             itile, jtile
                0211               GOTO 1234
                0212              ENDIF
                0213 
                0214             ENDIF
                0215            ENDDO
                0216            iwrk = 1
                0217           ENDDO
                0218           jwrk = 1
                0219          ELSEIF (ierr .NE. 0) THEN
                0220           itest     = itest + nwettile(bi,bj,k,iobcs)
                0221           iwrk      = 1
                0222           jwrk      = 1
                0223          ENDIF
                0224 
                0225 C--   End of loop over k
                0226         ENDDO
                0227 
                0228 C--   End of loop over irec records.
                0229        ENDDO
                0230 
                0231 C--   End of if myProcId statement
                0232       ENDIF
                0233 
                0234  1234 CONTINUE
                0235 
                0236       _END_MASTER( myThid )
f81d465bd0 Patr*0237 
                0238       _BARRIER
                0239 
                0240 #endif /* ALLOW_GRDCHK */
                0241 
9f85ea262e Mart*0242       RETURN
                0243       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!