Back to home page

MITgcm
 
 

    

File indexing completed on 2024-03-02 06:10:37 UTC

view on githubraw file Latest commit 5cf43646 on 2024-03-01 18:50:49 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
                0077       INTEGER i,j,k
                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)
b6a9ed93ee Jean*0101       IF ( icomp .GT. 0 ) THEN
                0102        IF ( icomp .LE. ncvarcomp ) THEN
                0103 C--     A valid component of the control variable has been selected.
                0104         IF ( ichknum .EQ. 1 ) THEN
                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
                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
e4b263335d Patr*0175                icomploc = icomp
31a64ac75a Patr*0176                icvrec = irec
2091ce7ee7 Patr*0177                itile  = bi
                0178                jtile  = bj
e4b263335d Patr*0179 cph(
                0180 cph-print               print *, 'ph-grd irec, bj, bi, k ', irec, bj, bi, k
                0181 cpj)
b6a9ed93ee Jean*0182                DO j = jwrk, ncvarymax(grdchkvarindex)
                0183                 DO i = iwrk, ncvarxmax(grdchkvarindex)
                0184                  IF (ierr .NE. 0) THEN
                0185                   IF ( ncvargrd(grdchkvarindex) .EQ. 'c' ) THEN
                0186                      IF ( maskC(i,j,k,bi,bj) .GT. 0.) THEN
2091ce7ee7 Patr*0187                         icomptest = icomptest + 1
0f4da31a07 Patr*0188                         itmp = i
                0189                         jtmp = j
b6a9ed93ee Jean*0190                      ENDIF
                0191                   ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 's' ) THEN
                0192                      IF ( _maskS(i,j,k,bi,bj) .GT. 0.) THEN
2091ce7ee7 Patr*0193                         icomptest = icomptest + 1
0f4da31a07 Patr*0194                         itmp = i
                0195                         jtmp = j
b6a9ed93ee Jean*0196                      ENDIF
                0197                   ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 'w' ) THEN
                0198                      IF ( _maskW(i,j,k,bi,bj) .GT. 0.) THEN
2091ce7ee7 Patr*0199                         icomptest = icomptest + 1
0f4da31a07 Patr*0200                         itmp = i
                0201                         jtmp = j
b6a9ed93ee Jean*0202                      ENDIF
                0203 #ifdef ALLOW_SHELFICE
                0204                   ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 'i' ) THEN
                0205                      IF ( maskSHI(i,j,k,bi,bj) .GT. 0.) THEN
e6556bc77a Mart*0206                         icomptest = icomptest + 1
                0207                         itmp = i
                0208                         jtmp = j
b6a9ed93ee Jean*0209                      ENDIF
6b47d550f4 Mart*0210 #endif /* ALLOW_SHELFICE */
5cf4364659 Mart*0211 #ifdef ALLOW_OBCS_CONTROL
b6a9ed93ee Jean*0212                   ELSEIF ( ncvargrd(grdchkvarindex) .EQ. 'm' ) THEN
5cf4364659 Mart*0213                      IF ( ncvarfname(grdchkvarindex)
                0214      &                  .EQ.xx_obcsn_file ) THEN
7109a141b2 Patr*0215 #ifdef ALLOW_OBCSN_CONTROL
b6a9ed93ee Jean*0216                         IF ( grdchk_maskxz(i,k,bi,bj,iobcs) .GT. 0.
                0217      &                       .AND. j.EQ. OB_Jn(i,bi,bj) ) THEN
7109a141b2 Patr*0218                            icomptest = icomptest + 1
0f4da31a07 Patr*0219                            itmp = i
b6a9ed93ee Jean*0220                            jtmp = OB_Jn(i,bi,bj)
                0221                         ENDIF
7109a141b2 Patr*0222 #endif
5cf4364659 Mart*0223                      ELSEIF ( ncvarfname(grdchkvarindex)
                0224      &                       .EQ.xx_obcss_file ) THEN
7109a141b2 Patr*0225 #ifdef ALLOW_OBCSS_CONTROL
b6a9ed93ee Jean*0226                         IF ( grdchk_maskxz(i,k,bi,bj,iobcs) .GT. 0.
                0227      &                       .AND. j.EQ. OB_Js(i,bi,bj) ) THEN
7109a141b2 Patr*0228                            icomptest = icomptest + 1
0f4da31a07 Patr*0229                            itmp = i
b6a9ed93ee Jean*0230                            jtmp = OB_Js(i,bi,bj)
                0231                         ENDIF
7109a141b2 Patr*0232 #endif
5cf4364659 Mart*0233                      ELSEIF ( ncvarfname(grdchkvarindex)
                0234      &                       .EQ.xx_obcse_file ) THEN
                0235 #ifdef ALLOW_OBCSE_CONTROL
b6a9ed93ee Jean*0236                         IF ( grdchk_maskyz(j,k,bi,bj,iobcs) .GT. 0.
5cf4364659 Mart*0237      &                       .AND. i.EQ. OB_Ie(j,bi,bj) ) THEN
7109a141b2 Patr*0238                            icomptest = icomptest + 1
5cf4364659 Mart*0239                            itmp = OB_Ie(j,bi,bj)
0f4da31a07 Patr*0240                            jtmp = j
b6a9ed93ee Jean*0241                         ENDIF
7109a141b2 Patr*0242 #endif
5cf4364659 Mart*0243                      ELSEIF ( ncvarfname(grdchkvarindex)
                0244      &                       .EQ.xx_obcsw_file ) THEN
                0245 #ifdef ALLOW_OBCSW_CONTROL
b6a9ed93ee Jean*0246                         IF ( grdchk_maskyz(j,k,bi,bj,iobcs) .GT. 0.
5cf4364659 Mart*0247      &                       .AND. i.EQ. OB_Iw(j,bi,bj) ) THEN
7109a141b2 Patr*0248                            icomptest = icomptest + 1
5cf4364659 Mart*0249                            itmp = OB_Iw(j,bi,bj)
0f4da31a07 Patr*0250                            jtmp = j
b6a9ed93ee Jean*0251                         ENDIF
7109a141b2 Patr*0252 #endif
b6a9ed93ee Jean*0253                      ENDIF
5cf4364659 Mart*0254 #endif /* ALLOW_OBCS_CONTROL */
b6a9ed93ee Jean*0255                   ENDIF
e4b263335d Patr*0256 cph(
                0257 cph-print                  print *, 'ph-grd icomp, icomptest, icomploc, i, j ',
ef53b829d7 Jean*0258 cph-print     &                 icomp, icomptest, icomploc, i, j
e4b263335d Patr*0259 cpj)
b6a9ed93ee Jean*0260                   IF ( icomploc .EQ. icomptest ) THEN
0f4da31a07 Patr*0261                      itilepos = itmp
                0262                      jtilepos = jtmp
2091ce7ee7 Patr*0263                      layer    = k
7109a141b2 Patr*0264                      obcspos  = iobcs
2091ce7ee7 Patr*0265                      ierr     = 0
c732bd258e Patr*0266 cph                     itest    = iwetsum(bi,bj,k)
0f4da31a07 Patr*0267 cph(
                0268                      print *, 'ph-grd -->hit<-- ', itmp,jtmp,k,iobcs
                0269                      goto 1234
                0270 cph)
b6a9ed93ee Jean*0271                   ENDIF
                0272                  ENDIF
                0273                 ENDDO
2091ce7ee7 Patr*0274                 iwrk = 1
b6a9ed93ee Jean*0275                ENDDO
2091ce7ee7 Patr*0276                jwrk = 1
b6a9ed93ee Jean*0277              ELSEIF (ierr .NE. 0) THEN
                0278                IF (icomptest .EQ. icomp-1) THEN
0f4da31a07 Patr*0279                  icomptest = icomptest
b6a9ed93ee Jean*0280                ELSE
0f4da31a07 Patr*0281                  icomptest = icomptest + nwettile(bi,bj,k,iobcs)
b6a9ed93ee Jean*0282                ENDIF
e4b263335d Patr*0283 cph(
                0284 cph-print               print *, 'ph-grd after loop icomptest, icomploc, k ',
                0285 cph-print     &              icomptest, icomploc, k
                0286 cph)
b6a9ed93ee Jean*0287                iwrk      = 1
                0288                jwrk      = 1
                0289              ENDIF
                0290 
                0291 C--   End of loop over k
                0292            ENDDO
                0293            kwrk = 1
                0294 C--   End of loop over bi
232d1fe37e Jean*0295 c         enddo
b6a9ed93ee Jean*0296 c         biwrk = 1
                0297 C--   End of loop over bj
                0298 c        enddo
                0299 c        bjwrk = 1
                0300 C--   End of loop over iobcs
                0301 c        enddo
                0302 c        iobcswrk = 1
                0303 C--   End of loop over irec records.
                0304         ENDDO
                0305 
                0306        ELSE
                0307 C--   else icomp > ncvarcomp
                0308          IF ( icomp .GT. maxncvarcomps ) THEN
                0309 C--        Such a component does not exist.
                0310            ierr     = -4
                0311            icvrec   = -1
                0312            jtile    = -1
                0313            itile    = -1
                0314            layer    = -1
                0315            obcspos  = -1
                0316            jtilepos = -1
                0317            itilepos = -1
                0318          ELSE
                0319 C--        The component is a land point.
                0320            ierr     = -3
                0321            icvrec   = -1
                0322            jtile    = -1
                0323            itile    = -1
                0324            layer    = -1
                0325            obcspos  = -1
                0326            jtilepos = -1
                0327            itilepos = -1
                0328          ENDIF
                0329 C--   End if/else block icomp =< ncvarcomp
                0330        ENDIF
                0331       ELSE
                0332 C--   else not( icomp > 0 )
                0333          IF ( icomp .LT. 0 ) THEN
                0334 C--         Such a component does not exist.
2091ce7ee7 Patr*0335             ierr     = -2
                0336             icvrec   = -1
                0337             jtile    = -1
                0338             itile    = -1
                0339             layer    = -1
7109a141b2 Patr*0340             obcspos  = -1
2091ce7ee7 Patr*0341             jtilepos = -1
                0342             itilepos = -1
b6a9ed93ee Jean*0343          ELSE
                0344 C--         Component zero.
2091ce7ee7 Patr*0345             ierr     = -1
                0346             icvrec   = -1
                0347             jtile    = -1
                0348             itile    = -1
                0349             layer    = -1
7109a141b2 Patr*0350             obcspos  = -1
2091ce7ee7 Patr*0351             jtilepos = -1
                0352             itilepos = -1
b6a9ed93ee Jean*0353          ENDIF
                0354 C--   End if/else block icomp > 0
                0355       ENDIF
2091ce7ee7 Patr*0356 
b6a9ed93ee Jean*0357  1234 CONTINUE
0f4da31a07 Patr*0358 
b6a9ed93ee Jean*0359       _END_MASTER( myThid )
2091ce7ee7 Patr*0360 
                0361       _BARRIER
                0362 
edd57506ae Patr*0363 #endif /* ALLOW_GRDCHK */
2091ce7ee7 Patr*0364 
b6a9ed93ee Jean*0365       RETURN
                0366       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!