Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:38:57 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
90d17db25d Jean*0001 #include "DIAG_OPTIONS.h"
                0002 
e129400813 Jean*0003 C--   File diagnostics_fill_field.F:
                0004 C--    Contents:
                0005 C--    o DIAGNOSTICS_FILL_FIELD
a45cd986a8 Jean*0006 C--    o DIAGNOSTICS_HF_CUMUL
fc67859634 Jean*0007 C--    o DIAGNOSTICS_CUMULATE
e129400813 Jean*0008 
                0009 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
90d17db25d Jean*0010 CBOP
                0011 C     !ROUTINE: DIAGNOSTICS_FILL_FIELD
                0012 C     !INTERFACE:
0d32f96e75 Jean*0013       SUBROUTINE DIAGNOSTICS_FILL_FIELD(
fc67859634 Jean*0014      I               inpFldRL, fracFldRL, inpFldRS, fracFldRS,
                0015      I               scaleFact, power, arrType, nLevFrac,
a45cd986a8 Jean*0016      I               ndId, ipointer, kLev, nLevs,
62f9c88755 Jean*0017      I               bibjFlg, biArg, bjArg, myThid )
90d17db25d Jean*0018 
                0019 C     !DESCRIPTION:
                0020 C***********************************************************************
0d32f96e75 Jean*0021 C   Increment the diagnostics array with a 2D/3D field
62f9c88755 Jean*0022 C     using a scaling factor & square option (power=2),
0d32f96e75 Jean*0023 C     and with the option to use a fraction-weight (assumed
                0024 C         to be the counter-mate of the current diagnostics)
90d17db25d Jean*0025 C***********************************************************************
                0026 C     !USES:
                0027       IMPLICIT NONE
                0028 
                0029 C     == Global variables ===
                0030 #include "EEPARAMS.h"
                0031 #include "SIZE.h"
                0032 #include "DIAGNOSTICS_SIZE.h"
                0033 #include "DIAGNOSTICS.h"
                0034 
                0035 C     !INPUT PARAMETERS:
                0036 C***********************************************************************
                0037 C  Arguments Description
                0038 C  ----------------------
fc67859634 Jean*0039 C     inpFldRL  :: Field to increment diagnostics array (arrType=0,1)
                0040 C     fracFldRL :: fraction used for weighted average diagnostics (arrType=0,2)
                0041 C     inpFldRS  :: Field to increment diagnostics array (arrType=2,3)
                0042 C     fracFldRS :: fraction used for weighted average diagnostics (arrType=1,3)
62f9c88755 Jean*0043 C     scaleFact :: scaling factor
                0044 C     power     :: option to fill-in with the field square (power=2)
fc67859634 Jean*0045 C     arrType   :: select which array & fraction (RL/RS) to process:
                0046 C                  0: both RL ; 1: inpRL & fracRS ; 2: inpRS,fracRL ; 3: both RS
a45cd986a8 Jean*0047 C     nLevFrac  :: >0: number of levels of the fraction field ; =0: no fraction
                0048 C               :: used ; =-1: use thickness factor "hFac"
                0049 C     ndId      :: Diagnostics Id number (in available diag list) of diag to process
62f9c88755 Jean*0050 C     ipointer  :: Pointer to the slot in qdiag to fill
                0051 C     kLev      :: Integer flag for vertical levels:
90d17db25d Jean*0052 C                  > 0 (any integer): WHICH single level to increment in qdiag.
                0053 C                  0,-1 to increment "nLevs" levels in qdiag,
3ae5f90260 Jean*0054 C                  0 : fill-in in the same order as the input array
90d17db25d Jean*0055 C                  -1: fill-in in reverse order.
62f9c88755 Jean*0056 C     nLevs     :: indicates Number of levels of the input field array
90d17db25d Jean*0057 C                  (whether to fill-in all the levels (kLev<1) or just one (kLev>0))
62f9c88755 Jean*0058 C     bibjFlg   :: Integer flag to indicate instructions for bi bj loop
90d17db25d Jean*0059 C                  0 indicates that the bi-bj loop must be done here
                0060 C                  1 indicates that the bi-bj loop is done OUTSIDE
                0061 C                  2 indicates that the bi-bj loop is done OUTSIDE
                0062 C                     AND that we have been sent a local array (with overlap regions)
                0063 C                  3 indicates that the bi-bj loop is done OUTSIDE
                0064 C                     AND that we have been sent a local array
                0065 C                     AND that the array has no overlap region (interior only)
3ae5f90260 Jean*0066 C                  NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter
62f9c88755 Jean*0067 C     biArg     :: X-direction tile number - used for bibjFlg=1-3
                0068 C     bjArg     :: Y-direction tile number - used for bibjFlg=1-3
                0069 C     myThid    :: my thread Id number
90d17db25d Jean*0070 C***********************************************************************
                0071 C                  NOTE: User beware! If a local (1 tile only) array
3ae5f90260 Jean*0072 C                        is sent here, bibjFlg MUST NOT be set to 0
90d17db25d Jean*0073 C                        or there will be out of bounds problems!
                0074 C***********************************************************************
fc67859634 Jean*0075       _RL inpFldRL(*)
                0076       _RL fracFldRL(*)
                0077       _RS inpFldRS(*)
                0078       _RS fracFldRS(*)
0d32f96e75 Jean*0079       _RL scaleFact
62f9c88755 Jean*0080       INTEGER power
fc67859634 Jean*0081       INTEGER arrType
                0082       INTEGER nLevFrac
a45cd986a8 Jean*0083       INTEGER ndId, ipointer
3ae5f90260 Jean*0084       INTEGER kLev, nLevs, bibjFlg, biArg, bjArg
90d17db25d Jean*0085       INTEGER myThid
                0086 CEOP
                0087 
                0088 C     !LOCAL VARIABLES:
                0089 C ===============
a45cd986a8 Jean*0090 C     useFract  :: flag to increment (or not) with fraction-weighted inpFld
                0091 C     thickFac  :: if > 0, to increment with thickness-weighted inpFld
0d32f96e75 Jean*0092       LOGICAL useFract
a45cd986a8 Jean*0093       INTEGER sizF, thickFac
90d17db25d Jean*0094       INTEGER sizI1,sizI2,sizJ1,sizJ2
                0095       INTEGER sizTx,sizTy
                0096       INTEGER iRun, jRun, k, bi, bj
                0097       INTEGER kFirst, kLast
a45cd986a8 Jean*0098       INTEGER kd, kd0, ksgn, km, kStore
90d17db25d Jean*0099       CHARACTER*8 parms1
                0100       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0101 
                0102 C If-sequence to see if we are a valid and an active diagnostic
a45cd986a8 Jean*0103 c     IF ( ndId.NE.0 .AND. ipointer.NE.0 ) THEN
90d17db25d Jean*0104 
3ae5f90260 Jean*0105        IF ( bibjFlg.GE.0 .AND. ABS(kLev).LE.1 ) THEN
                0106 C Increment the counter for the diagnostic
                0107         IF ( bibjFlg.EQ.0 ) THEN
                0108          DO bj=myByLo(myThid), myByHi(myThid)
                0109           DO bi=myBxLo(myThid), myBxHi(myThid)
                0110            ndiag(ipointer,bi,bj) = ndiag(ipointer,bi,bj) + 1
                0111           ENDDO
                0112          ENDDO
                0113         ELSE
                0114            bi = MIN(biArg,nSx)
                0115            bj = MIN(bjArg,nSy)
                0116            ndiag(ipointer,bi,bj) = ndiag(ipointer,bi,bj) + 1
                0117         ENDIF
                0118        ENDIF
90d17db25d Jean*0119 
                0120 C-      select range for 1rst & 2nd indices to accumulate
3ae5f90260 Jean*0121 C         depending on variable location on C-grid,
a45cd986a8 Jean*0122         thickFac = 0
                0123         parms1 = gdiag(ndId)(1:8)
90d17db25d Jean*0124         IF ( parms1(2:2).EQ.'M' ) THEN
                0125          iRun = sNx
                0126          jRun = sNy
a45cd986a8 Jean*0127          thickFac = 1
90d17db25d Jean*0128         ELSEIF ( parms1(2:2).EQ.'U' ) THEN
                0129          iRun = sNx+1
                0130          jRun = sNy
a45cd986a8 Jean*0131          thickFac = 2
90d17db25d Jean*0132         ELSEIF ( parms1(2:2).EQ.'V' ) THEN
                0133          iRun = sNx
                0134          jRun = sNy+1
a45cd986a8 Jean*0135          thickFac = 3
90d17db25d Jean*0136         ELSEIF ( parms1(2:2).EQ.'Z' ) THEN
                0137          iRun = sNx+1
                0138          jRun = sNy+1
                0139         ELSE
                0140          iRun = sNx
                0141          jRun = sNy
                0142         ENDIF
                0143 
                0144 C-      Dimension of the input array:
a45cd986a8 Jean*0145         IF (ABS(bibjFlg).EQ.3) THEN
90d17db25d Jean*0146           sizI1 = 1
                0147           sizI2 = sNx
                0148           sizJ1 = 1
                0149           sizJ2 = sNy
                0150           iRun = sNx
                0151           jRun = sNy
                0152         ELSE
                0153           sizI1 = 1-OLx
                0154           sizI2 = sNx+OLx
                0155           sizJ1 = 1-OLy
                0156           sizJ2 = sNy+OLy
                0157         ENDIF
a45cd986a8 Jean*0158         IF (ABS(bibjFlg).GE.2) THEN
90d17db25d Jean*0159          sizTx = 1
                0160          sizTy = 1
                0161         ELSE
                0162          sizTx = nSx
                0163          sizTy = nSy
                0164         ENDIF
                0165 C-      Which part of inpFld to add : k = 3rd index,
                0166 C         and do the loop >> do k=kFirst,kLast <<
                0167         IF (kLev.LE.0) THEN
                0168           kFirst = 1
                0169           kLast  = nLevs
                0170         ELSEIF ( nLevs.EQ.1 ) THEN
                0171           kFirst = 1
                0172           kLast  = 1
                0173         ELSEIF ( kLev.LE.nLevs ) THEN
                0174           kFirst = kLev
                0175           kLast  = kLev
                0176         ELSE
                0177           STOP 'ABNORMAL END in DIAGNOSTICS_FILL_FIELD: kLev > nLevs >0'
                0178         ENDIF
3ae5f90260 Jean*0179 C-      Which part of qdiag to update: kd = 3rd index,
90d17db25d Jean*0180 C         and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn <<
                0181         IF ( kLev.EQ.-1 ) THEN
                0182           ksgn = -1
                0183           kd0 = ipointer + nLevs
                0184         ELSEIF ( kLev.EQ.0 ) THEN
                0185           ksgn = 1
                0186           kd0 = ipointer - 1
                0187         ELSE
                0188           ksgn = 0
                0189           kd0 = ipointer + kLev - 1
                0190         ENDIF
a45cd986a8 Jean*0191 C-      Set thickness and fraction-weight option :
                0192         IF ( nLevFrac.GE.0 ) thickFac = 0
fc67859634 Jean*0193         useFract = nLevFrac.GT.0
0d32f96e75 Jean*0194         IF ( useFract ) THEN
fc67859634 Jean*0195           sizF = nLevFrac
0d32f96e75 Jean*0196         ELSE
                0197           sizF = 1
                0198         ENDIF
90d17db25d Jean*0199 
                0200 C-      Check for consistency with Nb of levels reserved in storage array
                0201         kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1
a45cd986a8 Jean*0202         IF ( kStore.GT.kdiag(ndId) ) THEN
90d17db25d Jean*0203          _BEGIN_MASTER(myThid)
e129400813 Jean*0204           WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_FILL_FIELD: ',
a45cd986a8 Jean*0205      &     'exceed Nb of levels(=',kdiag(ndId),' ) reserved '
90d17db25d Jean*0206           CALL PRINT_ERROR( msgBuf , myThid )
e129400813 Jean*0207           WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_FILL_FIELD: ',
a45cd986a8 Jean*0208      &     'for Diagnostics #', ndId, ' : ', cdiag(ndId)
90d17db25d Jean*0209           CALL PRINT_ERROR( msgBuf , myThid )
                0210           WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL_FIELD ',
                0211      I     'with kLev,nLevs,bibjFlg=', kLev,nLevs,bibjFlg
                0212           CALL PRINT_ERROR( msgBuf , myThid )
                0213           WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL_FIELD: ',
                0214      I     '==> trying to store up to ', kStore, ' levels'
                0215           CALL PRINT_ERROR( msgBuf , myThid )
                0216           STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL_FIELD'
                0217          _END_MASTER(myThid)
                0218         ENDIF
                0219 
3ae5f90260 Jean*0220         IF ( bibjFlg.EQ.0 ) THEN
                0221 
90d17db25d Jean*0222          DO bj=myByLo(myThid), myByHi(myThid)
                0223           DO bi=myBxLo(myThid), myBxHi(myThid)
                0224            DO k = kFirst,kLast
                0225             kd = kd0 + ksgn*k
a45cd986a8 Jean*0226             IF ( thickFac.EQ.0 ) THEN
                0227              CALL DIAGNOSTICS_CUMULATE(
90d17db25d Jean*0228      U                  qdiag(1-OLx,1-OLy,kd,bi,bj),
fc67859634 Jean*0229      I                  inpFldRL, fracFldRL, inpFldRS, fracFldRS,
                0230      I                  scaleFact, power, arrType, useFract, sizF,
90d17db25d Jean*0231      I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
a45cd986a8 Jean*0232      I                  iRun, jRun, k, bi, bj,
                0233      I                  myThid )
                0234             ELSE
                0235              km = kd - ipointer + 1
                0236              CALL DIAGNOSTICS_HF_CUMUL(
                0237      U                  qdiag(1-OLx,1-OLy,kd,bi,bj),
                0238      I                  inpFldRL, inpFldRS,
                0239      I                  scaleFact, power, arrType, thickFac,
                0240      I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
                0241      I                  iRun, jRun, k, km,
                0242      I                  bi, bj, myThid )
                0243             ENDIF
90d17db25d Jean*0244            ENDDO
                0245           ENDDO
                0246          ENDDO
                0247         ELSE
                0248           bi = MIN(biArg,sizTx)
                0249           bj = MIN(bjArg,sizTy)
                0250           DO k = kFirst,kLast
                0251             kd = kd0 + ksgn*k
a45cd986a8 Jean*0252             IF ( thickFac.EQ.0 ) THEN
                0253              CALL DIAGNOSTICS_CUMULATE(
90d17db25d Jean*0254      U                  qdiag(1-OLx,1-OLy,kd,biArg,bjArg),
fc67859634 Jean*0255      I                  inpFldRL, fracFldRL, inpFldRS, fracFldRS,
                0256      I                  scaleFact, power, arrType, useFract, sizF,
90d17db25d Jean*0257      I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
a45cd986a8 Jean*0258      I                  iRun, jRun, k, bi, bj,
                0259      I                  myThid )
                0260             ELSE
                0261              km = kd - ipointer + 1
                0262              CALL DIAGNOSTICS_HF_CUMUL(
                0263      U                  qdiag(1-OLx,1-OLy,kd,biArg,bjArg),
                0264      I                  inpFldRL, inpFldRS,
                0265      I                  scaleFact, power, arrType, thickFac,
                0266      I                  sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
                0267      I                  iRun, jRun, k, km,
                0268      I                  biArg, bjArg, myThid )
                0269             ENDIF
90d17db25d Jean*0270           ENDDO
                0271         ENDIF
                0272 
                0273 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0274 c     ELSE
a45cd986a8 Jean*0275 c     IF (myThid.EQ.1) WRITE(6,1000) cdiag(ndId)
90d17db25d Jean*0276 
                0277 c     ENDIF
                0278 
e129400813 Jean*0279 c1000 format(' ',' Warning: Trying to write to diagnostic ',a8,
                0280 c    &        ' But it is not a valid (or active) name ')
3ae5f90260 Jean*0281       RETURN
90d17db25d Jean*0282       END
                0283 
                0284 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0285 
                0286 CBOP
a45cd986a8 Jean*0287 C     !ROUTINE: DIAGNOSTICS_HF_CUMUL
                0288 C     !INTERFACE:
                0289       SUBROUTINE DIAGNOSTICS_HF_CUMUL(
                0290      U                  cumFld,
                0291      I                  inpFldRL, inpFldRS,
                0292      I                  scaleFact, power, arrType, thickFac,
                0293      I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,
                0294      I                  iRun, jRun, k, km,
                0295      I                  bi, bj, myThid )
                0296 
                0297 C     !DESCRIPTION:
                0298 C     Update array cumFld
                0299 C     by adding content of input field array inpFld
                0300 C     weighted by thickness factor "hFac"
                0301 C     over the range [1:iRun],[1:jRun]
                0302 
                0303 C     !USES:
                0304       IMPLICIT NONE
                0305 
                0306 #include "EEPARAMS.h"
                0307 #include "SIZE.h"
                0308 #include "GRID.h"
                0309 
                0310 C     !INPUT/OUTPUT PARAMETERS:
                0311 C     == Routine Arguments ==
                0312 C     cumFld      :: cumulative array (updated)
                0313 C     inpFldRL    :: input field array to add to cumFld (arrType=0,1)
                0314 C     inpFldRS    :: input field array to add to cumFld (arrType=2,3)
                0315 C     scaleFact   :: scaling factor
                0316 C     power       :: option to fill-in with the field square (power=2)
                0317 C     arrType     :: select which array & fraction (RL/RS) to process:
                0318 C                    0: both RL ; 1: inpRL & fracRS ; 2: inpRS,fracRL ; 3: both RS
                0319 C     thickFac    :: which hFac array to use: 1,2,3 = hFacC,W,S
                0320 C     sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max)
                0321 C     sizJ1,sizJ2 :: size of inpFld array: 2nd  index range (min,max)
                0322 C     sizK        :: size of inpFld array: 3rd  dimension
                0323 C     sizTx,sizTy :: size of inpFld array: tile dimensions
                0324 C     iRun,jRun   :: range of 1rst & 2nd index
                0325 C     k           :: level of inpFld array to add to cumFld array
                0326 C     km          :: level of hFac array to use as weight for inpFld
                0327 C     bi, bj      :: indices of tile to process (cumulate in qdiag)
                0328 C     myThid      :: my Thread Id number
                0329       _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0330       INTEGER sizI1,sizI2,sizJ1,sizJ2
                0331       INTEGER sizK,sizTx,sizTy
                0332       _RL inpFldRL(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
                0333       _RS inpFldRS(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
                0334       _RL scaleFact
                0335       INTEGER power
                0336       INTEGER arrType, thickFac
                0337       INTEGER iRun, jRun, k, km, bi, bj
                0338       INTEGER myThid
                0339 CEOP
                0340 
                0341 C     !LOCAL VARIABLES:
                0342 C     i, j     :: loop indices
                0343 C     ti, tj   :: tile indices of inpFld to process
                0344       INTEGER i, j
                0345       INTEGER ti, tj
                0346       _RL tmpFld(sNx+1,sNy+1)
                0347 
                0348 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0349 
                0350       ti = MIN(bi,sizTx)
                0351       tj = MIN(bj,sizTy)
                0352       IF ( arrType.EQ.0 .OR. arrType.EQ.1 ) THEN
                0353         DO j = 1,jRun
                0354          DO i = 1,iRun
                0355           tmpFld(i,j) = scaleFact*inpFldRL(i,j,k,ti,tj)
                0356          ENDDO
                0357         ENDDO
                0358       ELSEIF ( arrType.EQ.2 .OR. arrType.EQ.3 ) THEN
                0359         DO j = 1,jRun
                0360          DO i = 1,iRun
                0361           tmpFld(i,j) = scaleFact*inpFldRS(i,j,k,ti,tj)
                0362          ENDDO
                0363         ENDDO
                0364       ELSE
                0365         STOP 'DIAGNOSTICS_HF_CUMUL: invalid arrType'
                0366       ENDIF
                0367 
                0368       IF ( power.EQ.2 ) THEN
                0369         DO j = 1,jRun
                0370          DO i = 1,iRun
                0371           tmpFld(i,j) = tmpFld(i,j)*tmpFld(i,j)
                0372          ENDDO
                0373         ENDDO
                0374       ENDIF
                0375 
                0376       IF ( thickFac.EQ.1 ) THEN
                0377         DO j = 1,jRun
                0378          DO i = 1,iRun
                0379           cumFld(i,j) = cumFld(i,j)
                0380      &                + tmpFld(i,j)*hFacC(i,j,km,bi,bj)
                0381          ENDDO
                0382         ENDDO
                0383       ELSEIF ( thickFac.EQ.2 ) THEN
                0384         DO j = 1,jRun
                0385          DO i = 1,iRun
                0386           cumFld(i,j) = cumFld(i,j)
                0387      &                + tmpFld(i,j)*hFacW(i,j,km,bi,bj)
                0388          ENDDO
                0389         ENDDO
                0390       ELSEIF ( thickFac.EQ.3 ) THEN
                0391         DO j = 1,jRun
                0392          DO i = 1,iRun
                0393           cumFld(i,j) = cumFld(i,j)
                0394      &                + tmpFld(i,j)*hFacS(i,j,km,bi,bj)
                0395          ENDDO
                0396         ENDDO
                0397       ELSE
                0398         DO j = 1,jRun
                0399          DO i = 1,iRun
                0400           cumFld(i,j) = cumFld(i,j) + tmpFld(i,j)
                0401          ENDDO
                0402         ENDDO
                0403       ENDIF
                0404 
                0405       RETURN
                0406       END
                0407 
                0408 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0409 
                0410 CBOP
fc67859634 Jean*0411 C     !ROUTINE: DIAGNOSTICS_CUMULATE
90d17db25d Jean*0412 C     !INTERFACE:
fc67859634 Jean*0413       SUBROUTINE DIAGNOSTICS_CUMULATE(
90d17db25d Jean*0414      U                  cumFld,
fc67859634 Jean*0415      I                  inpFldRL, frcFldRL, inpFldRS, frcFldRS,
                0416      I                  scaleFact, power, arrType, useFract, sizF,
90d17db25d Jean*0417      I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,
a45cd986a8 Jean*0418      I                  iRun, jRun, k, bi, bj,
fc67859634 Jean*0419      I                  myThid )
90d17db25d Jean*0420 
                0421 C     !DESCRIPTION:
3ae5f90260 Jean*0422 C     Update array cumFld
90d17db25d Jean*0423 C     by adding content of input field array inpFld
                0424 C     over the range [1:iRun],[1:jRun]
                0425 
                0426 C     !USES:
                0427       IMPLICIT NONE
                0428 
                0429 #include "EEPARAMS.h"
                0430 #include "SIZE.h"
                0431 
                0432 C     !INPUT/OUTPUT PARAMETERS:
                0433 C     == Routine Arguments ==
                0434 C     cumFld      :: cumulative array (updated)
fc67859634 Jean*0435 C     inpFldRL    :: input field array to add to cumFld (arrType=0,1)
                0436 C     frcFldRL    :: fraction used for weighted-average diagnostics (arrType=0,2)
                0437 C     inpFldRS    :: input field array to add to cumFld (arrType=2,3)
                0438 C     frcFldRS    :: fraction used for weighted-average diagnostics (arrType=1,3)
0d32f96e75 Jean*0439 C     scaleFact   :: scaling factor
62f9c88755 Jean*0440 C     power       :: option to fill-in with the field square (power=2)
fc67859634 Jean*0441 C     arrType     :: select which array & fraction (RL/RS) to process:
                0442 C                    0: both RL ; 1: inpRL & fracRS ; 2: inpRS,fracRL ; 3: both RS
0d32f96e75 Jean*0443 C     useFract    :: if True, use fraction-weight
                0444 C     sizF        :: size of frcFld array: 3rd  dimension
90d17db25d Jean*0445 C     sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max)
                0446 C     sizJ1,sizJ2 :: size of inpFld array: 2nd  index range (min,max)
                0447 C     sizK        :: size of inpFld array: 3rd  dimension
                0448 C     sizTx,sizTy :: size of inpFld array: tile dimensions
                0449 C     iRun,jRun   :: range of 1rst & 2nd index
a45cd986a8 Jean*0450 C     k,bi,bj     :: level and tile indices of inpFld array to add to cumFld array
90d17db25d Jean*0451 C     myThid      :: my Thread Id number
                0452       _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0453       INTEGER sizI1,sizI2,sizJ1,sizJ2
0d32f96e75 Jean*0454       INTEGER sizF,sizK,sizTx,sizTy
fc67859634 Jean*0455       _RL inpFldRL(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
                0456       _RL frcFldRL(sizI1:sizI2,sizJ1:sizJ2,sizF,sizTx,sizTy)
                0457       _RS inpFldRS(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
                0458       _RS frcFldRS(sizI1:sizI2,sizJ1:sizJ2,sizF,sizTx,sizTy)
0d32f96e75 Jean*0459       _RL scaleFact
62f9c88755 Jean*0460       INTEGER power
fc67859634 Jean*0461       INTEGER arrType
0d32f96e75 Jean*0462       LOGICAL useFract
90d17db25d Jean*0463       INTEGER iRun, jRun, k, bi, bj
                0464       INTEGER myThid
                0465 CEOP
                0466 
                0467 C     !LOCAL VARIABLES:
                0468 C     i,j    :: loop indices
0d32f96e75 Jean*0469       INTEGER i, j, l
62f9c88755 Jean*0470       _RL     tmpFact
90d17db25d Jean*0471 
0d32f96e75 Jean*0472 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0473 
62f9c88755 Jean*0474       tmpFact = scaleFact
                0475       IF ( power.EQ.2 ) tmpFact = scaleFact*scaleFact
                0476 
                0477       IF ( useFract .AND. power.EQ.2 ) THEN
                0478        l = MIN(k,sizF)
fc67859634 Jean*0479 
                0480        IF ( arrType.EQ.0 ) THEN
                0481         DO j = 1,jRun
                0482          DO i = 1,iRun
                0483           cumFld(i,j) = cumFld(i,j)
                0484      &                + tmpFact*inpFldRL(i,j,k,bi,bj)
                0485      &                         *inpFldRL(i,j,k,bi,bj)
                0486      &                         *frcFldRL(i,j,l,bi,bj)
                0487          ENDDO
                0488         ENDDO
                0489        ELSEIF ( arrType.EQ.1 ) THEN
                0490         DO j = 1,jRun
                0491          DO i = 1,iRun
62f9c88755 Jean*0492           cumFld(i,j) = cumFld(i,j)
fc67859634 Jean*0493      &                + tmpFact*inpFldRL(i,j,k,bi,bj)
                0494      &                         *inpFldRL(i,j,k,bi,bj)
                0495      &                         *frcFldRS(i,j,l,bi,bj)
                0496          ENDDO
62f9c88755 Jean*0497         ENDDO
fc67859634 Jean*0498        ELSEIF ( arrType.EQ.2 ) THEN
                0499         DO j = 1,jRun
                0500          DO i = 1,iRun
                0501           cumFld(i,j) = cumFld(i,j)
                0502      &                + tmpFact*inpFldRS(i,j,k,bi,bj)
                0503      &                         *inpFldRS(i,j,k,bi,bj)
                0504      &                         *frcFldRL(i,j,l,bi,bj)
                0505          ENDDO
                0506         ENDDO
                0507        ELSEIF ( arrType.EQ.3 ) THEN
                0508         DO j = 1,jRun
                0509          DO i = 1,iRun
                0510           cumFld(i,j) = cumFld(i,j)
                0511      &                + tmpFact*inpFldRS(i,j,k,bi,bj)
                0512      &                         *inpFldRS(i,j,k,bi,bj)
                0513      &                         *frcFldRS(i,j,l,bi,bj)
                0514          ENDDO
                0515         ENDDO
                0516        ELSE
                0517         STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
                0518        ENDIF
                0519 
62f9c88755 Jean*0520       ELSEIF ( useFract ) THEN
0d32f96e75 Jean*0521        l = MIN(k,sizF)
fc67859634 Jean*0522 
                0523        IF ( arrType.EQ.0 ) THEN
                0524         DO j = 1,jRun
                0525          DO i = 1,iRun
                0526           cumFld(i,j) = cumFld(i,j)
                0527      &                + tmpFact*inpFldRL(i,j,k,bi,bj)
                0528      &                         *frcFldRL(i,j,l,bi,bj)
                0529          ENDDO
                0530         ENDDO
                0531        ELSEIF ( arrType.EQ.1 ) THEN
                0532         DO j = 1,jRun
                0533          DO i = 1,iRun
62f9c88755 Jean*0534           cumFld(i,j) = cumFld(i,j)
fc67859634 Jean*0535      &                + tmpFact*inpFldRL(i,j,k,bi,bj)
                0536      &                         *frcFldRS(i,j,l,bi,bj)
                0537          ENDDO
62f9c88755 Jean*0538         ENDDO
fc67859634 Jean*0539        ELSEIF ( arrType.EQ.2 ) THEN
                0540         DO j = 1,jRun
                0541          DO i = 1,iRun
                0542           cumFld(i,j) = cumFld(i,j)
                0543      &                + tmpFact*inpFldRS(i,j,k,bi,bj)
                0544      &                         *frcFldRL(i,j,l,bi,bj)
                0545          ENDDO
                0546         ENDDO
                0547        ELSEIF ( arrType.EQ.3 ) THEN
                0548         DO j = 1,jRun
                0549          DO i = 1,iRun
                0550           cumFld(i,j) = cumFld(i,j)
                0551      &                + tmpFact*inpFldRS(i,j,k,bi,bj)
                0552      &                         *frcFldRS(i,j,l,bi,bj)
                0553          ENDDO
                0554         ENDDO
                0555        ELSE
                0556         STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
                0557        ENDIF
                0558 
62f9c88755 Jean*0559       ELSEIF ( power.EQ.2 ) THEN
fc67859634 Jean*0560 
3b15f455ec Jean*0561        IF ( arrType.EQ.0 .OR. arrType.EQ.1 ) THEN
fc67859634 Jean*0562         DO j = 1,jRun
                0563          DO i = 1,iRun
                0564           cumFld(i,j) = cumFld(i,j)
                0565      &                + tmpFact*inpFldRL(i,j,k,bi,bj)
                0566      &                         *inpFldRL(i,j,k,bi,bj)
                0567          ENDDO
                0568         ENDDO
3b15f455ec Jean*0569        ELSEIF ( arrType.EQ.2 .OR. arrType.EQ.3 ) THEN
fc67859634 Jean*0570         DO j = 1,jRun
                0571          DO i = 1,iRun
62f9c88755 Jean*0572           cumFld(i,j) = cumFld(i,j)
fc67859634 Jean*0573      &                + tmpFact*inpFldRS(i,j,k,bi,bj)
                0574      &                         *inpFldRS(i,j,k,bi,bj)
                0575          ENDDO
0d32f96e75 Jean*0576         ENDDO
fc67859634 Jean*0577        ELSE
                0578         STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
                0579        ENDIF
                0580 
0d32f96e75 Jean*0581       ELSE
fc67859634 Jean*0582 
3b15f455ec Jean*0583        IF ( arrType.EQ.0 .OR. arrType.EQ.1 ) THEN
fc67859634 Jean*0584         DO j = 1,jRun
                0585          DO i = 1,iRun
3ae5f90260 Jean*0586 C- jmc: try with fixed ranges, that are known at compiling stage
90d17db25d Jean*0587 C        (might produce a better cash optimisation ?)
fc67859634 Jean*0588 c       DO j = 1,sNy
                0589 c        DO i = 1,sNx
                0590           cumFld(i,j) = cumFld(i,j)
                0591      &                + tmpFact*inpFldRL(i,j,k,bi,bj)
                0592          ENDDO
                0593         ENDDO
3b15f455ec Jean*0594        ELSEIF ( arrType.EQ.2 .OR. arrType.EQ.3 ) THEN
fc67859634 Jean*0595         DO j = 1,jRun
                0596          DO i = 1,iRun
62f9c88755 Jean*0597           cumFld(i,j) = cumFld(i,j)
fc67859634 Jean*0598      &                + tmpFact*inpFldRS(i,j,k,bi,bj)
                0599          ENDDO
0d32f96e75 Jean*0600         ENDDO
fc67859634 Jean*0601        ELSE
                0602         STOP 'DIAGNOSTICS_CUMULATE: invalid arrType'
                0603        ENDIF
                0604 
0d32f96e75 Jean*0605       ENDIF
90d17db25d Jean*0606 
3ae5f90260 Jean*0607       RETURN
90d17db25d Jean*0608       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!