Back to home page

MITgcm
 
 

    

File indexing completed on 2025-11-22 06:08:34 UTC

view on githubraw file Latest commit 61b91e10 on 2025-11-21 15:15:30 UTC
fc8c6425d2 Jean*0001 #include "GRDCHK_OPTIONS.h"
a7eff9e819 Jean*0002 #ifdef ALLOW_CTRL
                0003 # include "CTRL_OPTIONS.h"
                0004 #endif
2091ce7ee7 Patr*0005 
b6a9ed93ee Jean*0006 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0007 CBOP
                0008 C     !ROUTINE: GRDCHK_LOC
2091ce7ee7 Patr*0009 
b6a9ed93ee Jean*0010 C     !INTERFACE:
                0011       SUBROUTINE GRDCHK_LOC(
                0012      I                      icomp,
                0013      I                      ichknum,
                0014      O                      icvrec,
                0015      O                      itile,
                0016      O                      jtile,
                0017      O                      layer,
                0018      O                      obcspos,
                0019      O                      itilepos,
                0020      O                      jtilepos,
                0021      O                      icglom1,
                0022      O                      itest,
                0023      O                      ierr,
                0024      I                      myThid )
2091ce7ee7 Patr*0025 
b6a9ed93ee Jean*0026 C     !DESCRIPTION:
                0027 C     ==================================================================
                0028 C     SUBROUTINE GRDCHK_LOC
                0029 C     ==================================================================
                0030 C     o Get the location of a given component of the control vector for
                0031 C       the current process.
                0032 C     started: Christian Eckert eckert@mit.edu 04-Apr-2000
                0033 C     continued: heimbach@mit.edu: 13-Jun-2001
                0034 C     ==================================================================
2091ce7ee7 Patr*0035 
b6a9ed93ee Jean*0036 C     !USES:
                0037       IMPLICIT NONE
                0038 C     == Global variables ===
2091ce7ee7 Patr*0039 #include "EEPARAMS.h"
                0040 #include "SIZE.h"
                0041 #include "GRID.h"
5cf4364659 Mart*0042 #include "CTRL_SIZE.h"
4d72283393 Mart*0043 #include "CTRL.h"
444da61630 Mart*0044 #ifdef ALLOW_OBCS_CONTROL
                0045 C     CTRL_OBCS.h must be included before GRDCHK.h
                0046 # include "CTRL_OBCS.h"
                0047 #endif
                0048 #include "GRDCHK.h"
0f4da31a07 Patr*0049 #ifdef ALLOW_OBCS
fc8c6425d2 Jean*0050 # include "OBCS_GRID.h"
0f4da31a07 Patr*0051 #endif
e6556bc77a Mart*0052 #ifdef ALLOW_SHELFICE
                0053 # include "SHELFICE.h"
                0054 #endif /* ALLOW_SHELFICE */
2091ce7ee7 Patr*0055 
b6a9ed93ee Jean*0056 C     !INPUT/OUTPUT PARAMETERS:
                0057       INTEGER icomp
                0058       INTEGER ichknum
                0059       INTEGER icvrec
                0060       INTEGER jtile
                0061       INTEGER itile
                0062       INTEGER layer
                0063       INTEGER obcspos
                0064       INTEGER itilepos
                0065       INTEGER jtilepos
                0066       INTEGER itest
                0067       INTEGER ierr
                0068       INTEGER myThid
2091ce7ee7 Patr*0069 
edd57506ae Patr*0070 #ifdef ALLOW_GRDCHK
5cf4364659 Mart*0071 C--   == external ==
                0072       INTEGER  ILNBLNK
                0073       EXTERNAL ILNBLNK
                0074 
b6a9ed93ee Jean*0075 C     !LOCAL VARIABLES:
                0076       INTEGER bi,bj
61b91e10c1 Ivan*0077       INTEGER i,j,k, kk
b6a9ed93ee Jean*0078       INTEGER itmp,jtmp
                0079       INTEGER iobcs
                0080 c     INTEGER biwrk,bjwrk
                0081       INTEGER iwrk, jwrk, kwrk
                0082 c     INTEGER iobcswrk
                0083       INTEGER irec, irecwrk
                0084       INTEGER icglo, icglom1
                0085       INTEGER icomptest
                0086       INTEGER icomploc
                0087       INTEGER nobcsmax
                0088 CEOP
2091ce7ee7 Patr*0089 
b6a9ed93ee Jean*0090       _BEGIN_MASTER( myThid )
2091ce7ee7 Patr*0091 
b6a9ed93ee Jean*0092 C     initialise parameters
e4b263335d Patr*0093       ierr    = -5
                0094       icglom1 = 0
                0095       icomploc= 0
2091ce7ee7 Patr*0096 
c732bd258e Patr*0097 cph(
                0098       print *, 'ph-test icomp, ncvarcomp, ichknum ',
                0099      &     icomp, ncvarcomp, ichknum
                0100 cph)
61b91e10c1 Ivan*0101       IF ( icomp.GT.0 ) THEN
                0102        IF ( icomp.LE.ncvarcomp ) THEN
b6a9ed93ee Jean*0103 C--     A valid component of the control variable has been selected.
61b91e10c1 Ivan*0104         IF ( ichknum.EQ.1 ) THEN
b6a9ed93ee Jean*0105           itest     = 0
                0106           icomptest = 0
                0107           irecwrk   = 1
                0108 c         bjwrk     = 1
                0109 c         biwrk     = 1
                0110           kwrk      = 1
                0111 c         iobcswrk  = 1
                0112           jwrk      = 1
                0113           iwrk      = 1
                0114           icglo     = 0
                0115         ELSE
                0116           itest     = itestmem (ichknum-1)
                0117           icomptest = icompmem (ichknum-1)
                0118           irecwrk   = irecmem  (ichknum-1)
                0119 c         bjwrk     = bjmem    (ichknum-1)
                0120 c         biwrk     = bimem    (ichknum-1)
                0121           kwrk      = klocmem  (ichknum-1)
                0122 c         iobcswrk  = iobcsmem (ichknum-1)
                0123           icglo     = icglomem (ichknum-1)
                0124           jwrk      = jlocmem  (ichknum-1)
                0125           iwrk      = ilocmem  (ichknum-1)
                0126           iwrk      = iwrk + 1
                0127         ENDIF
2091ce7ee7 Patr*0128 
b6a9ed93ee Jean*0129 C--   set max loop index for obcs multiplicities
61b91e10c1 Ivan*0130         IF ( ncvargrd(grdchkvarindex).EQ.'m' ) THEN
444da61630 Mart*0131 #ifdef ALLOW_OBCS_CONTROL
                0132          nobcsmax = nobcs
                0133 #else
                0134          print *, 'S/R grdchk_loc: Ooops!'
                0135 #endif
b6a9ed93ee Jean*0136         ELSE
                0137           nobcsmax = 1
                0138         ENDIF
7109a141b2 Patr*0139 
e4b263335d Patr*0140 cph(
ef53b829d7 Jean*0141 cph-print        print *, 'ph-grd _loc: icomp, ichknum ',
e4b263335d Patr*0142 cph-print     &       icomp, ichknum, ncvarcomp
                0143 cpj)
b6a9ed93ee Jean*0144 C--   Start to loop over records.
                0145         DO irec = irecwrk, ncvarrecs(grdchkvarindex)
                0146 c        do iobcs = iobcswrk, nobcsmax
31a64ac75a Patr*0147          iobcs = MOD((irec-1),nobcsmax) + 1
b6a9ed93ee Jean*0148 c        do bj = bjwrk, nSy
                0149 c         do bi = biwrk, nSx
                0150            bj = jLocTile
                0151            bi = iLocTile
                0152 
                0153            DO k = kwrk, ncvarnrmax(grdchkvarindex)
e4b263335d Patr*0154              icglo   = icglo + nwettile(bi,bj,k,iobcs)
                0155              icglom1 = icglo - nwettile(bi,bj,k,iobcs)
                0156 cph(
c732bd258e Patr*0157         print *, 'ph-grd _loc: bi, bj, icomptest, ichknum ',
                0158      &       bi, bj, icomptest, ichknum
ef53b829d7 Jean*0159 cph-print        print *, 'ph-grd _loc: icglo ',
e4b263335d Patr*0160 cph-print     &       k, icglo, icglom1, iwetsum(bi,bj,k)
                0161 cpj)
b6a9ed93ee Jean*0162              IF ( (ierr .NE. 0) .AND.
                0163      &            (icomp .GT. icglom1 .AND. icomp .LE. icglo) ) THEN
e4b263335d Patr*0164 cph
b6a9ed93ee Jean*0165 cph             if ( (ierr .NE. 0) .AND.
                0166 cph     &            (icomp .GT.
ef53b829d7 Jean*0167 cph     &              (iobcs-1)*iwetsum(bi,bj,nr)+iwetsum(bi,bj,k-1))
b6a9ed93ee Jean*0168 cph     &              .AND.
                0169 cph     &            (icomp .LE.
e4b263335d Patr*0170 cph     &              (iobcs-1)*iwetsum(bi,bj,nr)+iwetsum(bi,bj,k))) then
                0171 cph
b6a9ed93ee Jean*0172                IF ( icomptest .EQ. 0 ) THEN
e4b263335d Patr*0173                   icomptest = icglom1
b6a9ed93ee Jean*0174                ENDIF
61b91e10c1 Ivan*0175 
e4b263335d Patr*0176                icomploc = icomp
31a64ac75a Patr*0177                icvrec = irec
2091ce7ee7 Patr*0178                itile  = bi
                0179                jtile  = bj
e4b263335d Patr*0180 cph(
                0181 cph-print               print *, 'ph-grd irec, bj, bi, k ', irec, bj, bi, k
                0182 cpj)
b6a9ed93ee Jean*0183                DO j = jwrk, ncvarymax(grdchkvarindex)
                0184                 DO i = iwrk, ncvarxmax(grdchkvarindex)
61b91e10c1 Ivan*0185                  IF ( ierr.NE.0 ) THEN
                0186                   IF ( ncvargrd(grdchkvarindex).EQ.'c' ) THEN
                0187                      IF ( maskC(i,j,k,bi,bj).GT.0. ) THEN
2091ce7ee7 Patr*0188                         icomptest = icomptest + 1
0f4da31a07 Patr*0189                         itmp = i
                0190                         jtmp = j
b6a9ed93ee Jean*0191                      ENDIF
61b91e10c1 Ivan*0192                   ELSEIF ( ncvargrd(grdchkvarindex).EQ.'s' ) THEN
                0193                      IF ( _maskS(i,j,k,bi,bj).GT.0. ) THEN
2091ce7ee7 Patr*0194                         icomptest = icomptest + 1
0f4da31a07 Patr*0195                         itmp = i
                0196                         jtmp = j
b6a9ed93ee Jean*0197                      ENDIF
61b91e10c1 Ivan*0198                   ELSEIF ( ncvargrd(grdchkvarindex).EQ.'w' ) THEN
                0199                      IF ( _maskW(i,j,k,bi,bj).GT.0. ) THEN
2091ce7ee7 Patr*0200                         icomptest = icomptest + 1
0f4da31a07 Patr*0201                         itmp = i
                0202                         jtmp = j
b6a9ed93ee Jean*0203                      ENDIF
                0204 #ifdef ALLOW_SHELFICE
61b91e10c1 Ivan*0205                   ELSEIF ( ncvargrd(grdchkvarindex).EQ.'i' ) THEN
                0206                      IF ( maskSHI(i,j,k,bi,bj).GT.0. ) THEN
e6556bc77a Mart*0207                         icomptest = icomptest + 1
                0208                         itmp = i
                0209                         jtmp = j
b6a9ed93ee Jean*0210                      ENDIF
6b47d550f4 Mart*0211 #endif /* ALLOW_SHELFICE */
5cf4364659 Mart*0212 #ifdef ALLOW_OBCS_CONTROL
61b91e10c1 Ivan*0213                   ELSEIF ( ncvargrd(grdchkvarindex).EQ.'m' ) THEN
5cf4364659 Mart*0214                      IF ( ncvarfname(grdchkvarindex)
                0215      &                  .EQ.xx_obcsn_file ) THEN
61b91e10c1 Ivan*0216 # ifdef ALLOW_OBCSN_CONTROL
                0217                         IF ( grdchk_maskxz(i,k,bi,bj,iobcs).GT.0.
                0218      &                       .AND. j.EQ.OB_Jn(i,bi,bj) ) THEN
7109a141b2 Patr*0219                            icomptest = icomptest + 1
0f4da31a07 Patr*0220                            itmp = i
b6a9ed93ee Jean*0221                            jtmp = OB_Jn(i,bi,bj)
                0222                         ENDIF
61b91e10c1 Ivan*0223 # endif
5cf4364659 Mart*0224                      ELSEIF ( ncvarfname(grdchkvarindex)
                0225      &                       .EQ.xx_obcss_file ) THEN
61b91e10c1 Ivan*0226 # ifdef ALLOW_OBCSS_CONTROL
                0227                         IF ( grdchk_maskxz(i,k,bi,bj,iobcs).GT.0.
                0228      &                       .AND. j.EQ.OB_Js(i,bi,bj) ) THEN
7109a141b2 Patr*0229                            icomptest = icomptest + 1
0f4da31a07 Patr*0230                            itmp = i
b6a9ed93ee Jean*0231                            jtmp = OB_Js(i,bi,bj)
                0232                         ENDIF
61b91e10c1 Ivan*0233 # endif
5cf4364659 Mart*0234                      ELSEIF ( ncvarfname(grdchkvarindex)
                0235      &                       .EQ.xx_obcse_file ) THEN
61b91e10c1 Ivan*0236 # ifdef ALLOW_OBCSE_CONTROL
                0237                         IF ( grdchk_maskyz(j,k,bi,bj,iobcs).GT.0.
                0238      &                       .AND. i.EQ.OB_Ie(j,bi,bj) ) THEN
7109a141b2 Patr*0239                            icomptest = icomptest + 1
5cf4364659 Mart*0240                            itmp = OB_Ie(j,bi,bj)
0f4da31a07 Patr*0241                            jtmp = j
b6a9ed93ee Jean*0242                         ENDIF
61b91e10c1 Ivan*0243 # endif
5cf4364659 Mart*0244                      ELSEIF ( ncvarfname(grdchkvarindex)
                0245      &                       .EQ.xx_obcsw_file ) THEN
61b91e10c1 Ivan*0246 # ifdef ALLOW_OBCSW_CONTROL
                0247                         IF ( grdchk_maskyz(j,k,bi,bj,iobcs).GT.0.
                0248      &                       .AND. i.EQ.OB_Iw(j,bi,bj) ) THEN
7109a141b2 Patr*0249                            icomptest = icomptest + 1
5cf4364659 Mart*0250                            itmp = OB_Iw(j,bi,bj)
0f4da31a07 Patr*0251                            jtmp = j
b6a9ed93ee Jean*0252                         ENDIF
61b91e10c1 Ivan*0253 # endif
b6a9ed93ee Jean*0254                      ENDIF
5cf4364659 Mart*0255 #endif /* ALLOW_OBCS_CONTROL */
b6a9ed93ee Jean*0256                   ENDIF
e4b263335d Patr*0257 cph(
                0258 cph-print                  print *, 'ph-grd icomp, icomptest, icomploc, i, j ',
ef53b829d7 Jean*0259 cph-print     &                 icomp, icomptest, icomploc, i, j
e4b263335d Patr*0260 cpj)
b6a9ed93ee Jean*0261                   IF ( icomploc .EQ. icomptest ) THEN
0f4da31a07 Patr*0262                      itilepos = itmp
                0263                      jtilepos = jtmp
2091ce7ee7 Patr*0264                      layer    = k
7109a141b2 Patr*0265                      obcspos  = iobcs
2091ce7ee7 Patr*0266                      ierr     = 0
c732bd258e Patr*0267 cph                     itest    = iwetsum(bi,bj,k)
0f4da31a07 Patr*0268 cph(
                0269                      print *, 'ph-grd -->hit<-- ', itmp,jtmp,k,iobcs
                0270                      goto 1234
                0271 cph)
b6a9ed93ee Jean*0272                   ENDIF
                0273                  ENDIF
61b91e10c1 Ivan*0274 
b6a9ed93ee Jean*0275                 ENDDO
2091ce7ee7 Patr*0276                 iwrk = 1
b6a9ed93ee Jean*0277                ENDDO
2091ce7ee7 Patr*0278                jwrk = 1
61b91e10c1 Ivan*0279 
                0280              ELSEIF ( ierr.NE.0 ) THEN
                0281                IF ( icomptest.EQ.icomp-1 ) THEN
0f4da31a07 Patr*0282                  icomptest = icomptest
b6a9ed93ee Jean*0283                ELSE
61b91e10c1 Ivan*0284 C Start icomptest on next vertical layer
                0285                  icomptest = 0
                0286                  DO kk = 1, k
                0287                    icomptest = icomptest + nwettile(bi,bj,kk,iobcs)
                0288                  ENDDO
b6a9ed93ee Jean*0289                ENDIF
61b91e10c1 Ivan*0290 
b6a9ed93ee Jean*0291                iwrk      = 1
                0292                jwrk      = 1
61b91e10c1 Ivan*0293 
b6a9ed93ee Jean*0294              ENDIF
                0295 
                0296 C--   End of loop over k
                0297            ENDDO
                0298            kwrk = 1
                0299 C--   End of loop over bi
232d1fe37e Jean*0300 c         enddo
b6a9ed93ee Jean*0301 c         biwrk = 1
                0302 C--   End of loop over bj
                0303 c        enddo
                0304 c        bjwrk = 1
                0305 C--   End of loop over iobcs
                0306 c        enddo
                0307 c        iobcswrk = 1
                0308 C--   End of loop over irec records.
                0309         ENDDO
                0310 
                0311        ELSE
                0312 C--   else icomp > ncvarcomp
                0313          IF ( icomp .GT. maxncvarcomps ) THEN
                0314 C--        Such a component does not exist.
                0315            ierr     = -4
                0316            icvrec   = -1
                0317            jtile    = -1
                0318            itile    = -1
                0319            layer    = -1
                0320            obcspos  = -1
                0321            jtilepos = -1
                0322            itilepos = -1
                0323          ELSE
                0324 C--        The component is a land point.
                0325            ierr     = -3
                0326            icvrec   = -1
                0327            jtile    = -1
                0328            itile    = -1
                0329            layer    = -1
                0330            obcspos  = -1
                0331            jtilepos = -1
                0332            itilepos = -1
                0333          ENDIF
                0334 C--   End if/else block icomp =< ncvarcomp
                0335        ENDIF
                0336       ELSE
                0337 C--   else not( icomp > 0 )
                0338          IF ( icomp .LT. 0 ) THEN
                0339 C--         Such a component does not exist.
2091ce7ee7 Patr*0340             ierr     = -2
                0341             icvrec   = -1
                0342             jtile    = -1
                0343             itile    = -1
                0344             layer    = -1
7109a141b2 Patr*0345             obcspos  = -1
2091ce7ee7 Patr*0346             jtilepos = -1
                0347             itilepos = -1
b6a9ed93ee Jean*0348          ELSE
                0349 C--         Component zero.
2091ce7ee7 Patr*0350             ierr     = -1
                0351             icvrec   = -1
                0352             jtile    = -1
                0353             itile    = -1
                0354             layer    = -1
7109a141b2 Patr*0355             obcspos  = -1
2091ce7ee7 Patr*0356             jtilepos = -1
                0357             itilepos = -1
b6a9ed93ee Jean*0358          ENDIF
                0359 C--   End if/else block icomp > 0
                0360       ENDIF
2091ce7ee7 Patr*0361 
b6a9ed93ee Jean*0362  1234 CONTINUE
0f4da31a07 Patr*0363 
b6a9ed93ee Jean*0364       _END_MASTER( myThid )
2091ce7ee7 Patr*0365 
                0366       _BARRIER
                0367 
edd57506ae Patr*0368 #endif /* ALLOW_GRDCHK */
2091ce7ee7 Patr*0369 
b6a9ed93ee Jean*0370       RETURN
                0371       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!