pkg/layers/layers_fill.F

cf336ab6c5 Ryan*0001 #include "LAYERS_OPTIONS.h"
f0f170d54b Mart*0002 C--  File layers_fill.F:
cf336ab6c5 Ryan*0003 C--   Contents
50d8304171 Ryan*0004 C--   o LAYERS_FILL
                0005 C--   o LAYERS_FILL_FIELD
f0f170d54b Mart*0006 C--   o LAYERS_CUMULATE
4008d662b9 Jean*0007
cf336ab6c5 Ryan*0008 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0009 CBOP
50d8304171 Ryan*0010
                0011       SUBROUTINE LAYERS_FILL(
                0012      I               df, trIdentity, fluxid,
cf336ab6c5 Ryan*0013      I               kLev, nLevs, bibjFlg, biArg, bjArg, myThid )
50d8304171 Ryan*0014 C     !DESCRIPTION: \bv
                0015 C     *==========================================================*
                0016 C     | SUBROUTINE LAYERS_FILL
f0f170d54b Mart*0017 C     | - Wrapper routine to increment the layers thermodynamics
                0018 C     |   diagnostics arrays with a RL field
                0019 C     | - only active when LAYERS_THERMODYNAMICS is defined
50d8304171 Ryan*0020 C     *==========================================================*
                0021        IMPLICIT NONE
cf336ab6c5 Ryan*0022 #include "SIZE.h"
                0023 #include "EEPARAMS.h"
                0024 #include "PARAMS.h"
                0025 #include "GRID.h"
                0026 #include "LAYERS_SIZE.h"
                0027 #include "LAYERS.h"
                0028 C***********************************************************************
                0029 C   This is designed to look and work exactly like the a regular
                0030 C   diagnostics_fill call.
                0031 C***********************************************************************
4008d662b9 Jean*0032 C     surfflux  :: The surface temperature flux, the same as what is filled into
cf336ab6c5 Ryan*0033 C                   the TFLUX and SFLUX diagnostics
                0034 C     trIdentity:: Index to let us know what tracer it is (1 for T, 2 for S)
                0035 C     kLev      :: Integer flag for vertical levels:
                0036 C                  > 0 (any integer): WHICH single level to increment in qdiag.
                0037 C                  0,-1 to increment "nLevs" levels in qdiag,
                0038 C                  0 : fill-in in the same order as the input array
                0039 C                  -1: fill-in in reverse order.
                0040 C     nLevs     :: indicates Number of levels of the input field array
                0041 C                  (whether to fill-in all the levels (kLev<1) or just one (kLev>0))
                0042 C     bibjFlg   :: Integer flag to indicate instructions for bi bj loop
                0043 C                  0 indicates that the bi-bj loop must be done here
                0044 C                  1 indicates that the bi-bj loop is done OUTSIDE
                0045 C                  2 indicates that the bi-bj loop is done OUTSIDE
                0046 C                     AND that we have been sent a local array (with overlap regions)
                0047 C                  3 indicates that the bi-bj loop is done OUTSIDE
                0048 C                     AND that we have been sent a local array
                0049 C                     AND that the array has no overlap region (interior only)
                0050 C                  NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter
                0051 C     biArg     :: X-direction tile number - used for bibjFlg=1-3
                0052 C     bjArg     :: Y-direction tile number - used for bibjFlg=1-3
                0053
50d8304171 Ryan*0054 C       _RL df(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0055        _RL df(*)
cf336ab6c5 Ryan*0056        INTEGER trIdentity, kLev, nLevs, bibjFlg, biArg, bjArg
                0057        INTEGER myThid
50d8304171 Ryan*0058        CHARACTER*(3) fluxid
cf336ab6c5 Ryan*0059
                0060 #ifdef LAYERS_THERMODYNAMICS
                0061
                0062 C !LOCAL VARIABLES: ====================================================
                0063 C i,j              :: loop indices
                0064 C msgBuf           :: error message buffer
                0065        CHARACTER*(MAX_LEN_MBUF) msgBuf
                0066
50d8304171 Ryan*0067        IF ((trIdentity.EQ.1).OR.(trIdentity.EQ.2)) THEN
4008d662b9 Jean*0068
50d8304171 Ryan*0069        IF (fluxid.EQ.'SUR') THEN
                0070          CALL LAYERS_FILL_FIELD(df, trIdentity, 1, layers_surfflux,'M',
                0071      &           klev, nLevs, bibjFlg, biArg, bjArg, myThid)
f0f170d54b Mart*0072        ELSEIF (fluxid.EQ.'DFX') THEN
50d8304171 Ryan*0073          CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_dfx,'U',
                0074      &           kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
f0f170d54b Mart*0075        ELSEIF (fluxid.EQ.'DFY') THEN
50d8304171 Ryan*0076          CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_dfy,'V',
                0077      &           kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
f0f170d54b Mart*0078        ELSEIF (fluxid.EQ.'DFR') THEN
50d8304171 Ryan*0079          CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_dfr,'M',
                0080      &           kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
f0f170d54b Mart*0081        ELSEIF (fluxid.EQ.'AFX') THEN
50d8304171 Ryan*0082          CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_afx,'U',
                0083      &           kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
f0f170d54b Mart*0084        ELSEIF (fluxid.EQ.'AFY') THEN
50d8304171 Ryan*0085          CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_afy,'V',
                0086      &           kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
f0f170d54b Mart*0087        ELSEIF (fluxid.EQ.'AFR') THEN
50d8304171 Ryan*0088          CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_afr,'M',
6088c626b1 Jean*0089      &           kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
f0f170d54b Mart*0090        ELSEIF (fluxid.EQ.'TOT') THEN
50d8304171 Ryan*0091          CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_tottend,'M',
                0092      &           kLev, nLevs, bibjFlg, biArg, bjArg, myThid)
cf336ab6c5 Ryan*0093        ELSE
50d8304171 Ryan*0094          WRITE(msgBuf,'(2A)')
                0095      &          'S/R LAYERS_FILL: ',
                0096      &          'invalid flux ID'
                0097          CALL PRINT_ERROR( msgBuf, myThid )
                0098          STOP 'ABNORMAL END: S/R LAYERS_FILL'
cf336ab6c5 Ryan*0099        ENDIF
6088c626b1 Jean*0100
50d8304171 Ryan*0101        ELSE
6088c626b1 Jean*0102 C  ---- Cannot throw an error for different trIdentity
50d8304171 Ryan*0103 C       because subroutine also gets called for ptracers.
                0104 C       Just have to do nothing
6088c626b1 Jean*0105
50d8304171 Ryan*0106 C         WRITE(msgBuf,'(5A,I2)')
                0107 C     &          'S/R LAYERS_FILL: ',
                0108 C     &          'only works on THETA (1) or SALT (2)',
                0109 C     &          'fluxid=', fluxid, 'trId=',
                0110 C     &          trIdentity
                0111 C         CALL PRINT_ERROR( msgBuf, myThid )
6088c626b1 Jean*0112 C         STOP 'ABNORMAL END: S/R LAYERS_FILL'
50d8304171 Ryan*0113        ENDIF
6088c626b1 Jean*0114
cf336ab6c5 Ryan*0115       RETURN
                0116       END
50d8304171 Ryan*0117 C end of S/R LAYERS_FILL
4008d662b9 Jean*0118
f0f170d54b Mart*0119 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0120
50d8304171 Ryan*0121       SUBROUTINE LAYERS_FILL_FIELD(
                0122      I               df, trIdentity, myNr,
                0123      U               layers_saved_flux,
                0124      I               fldType,
cf336ab6c5 Ryan*0125      I               kLev, nLevs, bibjFlg, biArg, bjArg, myThid )
50d8304171 Ryan*0126
cf336ab6c5 Ryan*0127        IMPLICIT NONE
                0128 #include "SIZE.h"
                0129 #include "EEPARAMS.h"
                0130 #include "PARAMS.h"
                0131 #include "GRID.h"
                0132 #include "LAYERS_SIZE.h"
                0133 #include "LAYERS.h"
                0134
50d8304171 Ryan*0135        INTEGER trIdentity, myNr, kLev, nLevs, bibjFlg, biArg, bjArg
                0136        CHARACTER fldType
                0137        _RL layers_saved_flux(1-OLx:sNx+OLx,1-OLy:sNy+OLy,
                0138      &                       myNr,2,nSx,nSy)
                0139 C       _RL df(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0140        _RL df(*)
cf336ab6c5 Ryan*0141        INTEGER myThid
                0142
                0143 C !LOCAL VARIABLES: ====================================================
                0144 C i,j              :: loop indices
                0145 C msgBuf           :: error message buffer
50d8304171 Ryan*0146       INTEGER sizI1,sizI2,sizJ1,sizJ2
                0147       INTEGER sizTx,sizTy
                0148       INTEGER iRun, jRun, k, bi, bj
                0149       INTEGER kFirst, kLast
                0150       INTEGER kd, kd0, ksgn
                0151 C       CHARACTER*(MAX_LEN_MBUF) msgBuf
6088c626b1 Jean*0152
50d8304171 Ryan*0153 C-      select range for 1rst & 2nd indices to accumulate
                0154 C         depending on variable location on C-grid,
                0155       IF ( fldType.EQ.'U' ) THEN
                0156        iRun = sNx+1
                0157        jRun = sNy
                0158       ELSEIF ( fldType.EQ.'V' ) THEN
                0159        iRun = sNx
                0160        jRun = sNy+1
                0161       ELSE
                0162        iRun = sNx
                0163        jRun = sNy
                0164       ENDIF
                0165 C-      Dimension of the input array:
                0166       IF (abs(bibjFlg).EQ.3) THEN
                0167         sizI1 = 1
                0168         sizI2 = sNx
                0169         sizJ1 = 1
                0170         sizJ2 = sNy
                0171         iRun = sNx
                0172         jRun = sNy
                0173       ELSE
                0174         sizI1 = 1-OLx
                0175         sizI2 = sNx+OLx
                0176         sizJ1 = 1-OLy
                0177         sizJ2 = sNy+OLy
                0178       ENDIF
                0179       IF (abs(bibjFlg).GE.2) THEN
                0180         sizTx = 1
                0181         sizTy = 1
                0182       ELSE
                0183         sizTx = nSx
                0184         sizTy = nSy
                0185       ENDIF
6088c626b1 Jean*0186
50d8304171 Ryan*0187 C-      Which part of inpFld to add : k = 3rd index,
                0188 C         and do the loop >> do k=kFirst,kLast <<
                0189       IF (kLev.LE.0) THEN
                0190         kFirst = 1
                0191         kLast  = nLevs
                0192       ELSEIF ( nLevs.EQ.1 ) THEN
                0193         kFirst = 1
                0194         kLast  = 1
                0195       ELSEIF ( kLev.LE.nLevs ) THEN
                0196         kFirst = kLev
                0197         kLast  = kLev
                0198       ELSE
                0199         STOP 'ABNORMAL END in LAYERS_SAVE: kLev > nLevs >0'
                0200       ENDIF
                0201 C-      Which part of qdiag to update: kd = 3rd index,
                0202 C         and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn <<
                0203       IF ( kLev.EQ.-1 ) THEN
                0204         ksgn = -1
                0205         kd0 = 1 + nLevs
                0206       ELSEIF ( kLev.EQ.0 ) THEN
                0207         ksgn = 1
                0208         kd0 = 0
                0209       ELSE
                0210         ksgn = 0
6088c626b1 Jean*0211         kd0 = kLev
50d8304171 Ryan*0212       ENDIF
4008d662b9 Jean*0213
50d8304171 Ryan*0214       IF ( bibjFlg.EQ.0 ) THEN
                0215
                0216        DO bj=myByLo(myThid), myByHi(myThid)
                0217         DO bi=myBxLo(myThid), myBxHi(myThid)
                0218          DO k = kFirst,kLast
                0219           kd = kd0 + ksgn*k
                0220           CALL LAYERS_CUMULATE(
                0221      U      layers_saved_flux(1-OLx,1-OLy,kd,trIdentity,bi,bj),
                0222      I      df,
                0223      I      sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
                0224      I      iRun,jRun,k,bi,bj,
                0225      I      myThid)
cf336ab6c5 Ryan*0226          ENDDO
                0227         ENDDO
50d8304171 Ryan*0228        ENDDO
                0229       ELSE
                0230         bi = MIN(biArg,sizTx)
                0231         bj = MIN(bjArg,sizTy)
                0232         DO k = kFirst,kLast
                0233           kd = kd0 + ksgn*k
                0234           CALL LAYERS_CUMULATE(
                0235      U      layers_saved_flux(1-OLx,1-OLy,kd,trIdentity,biArg,bjArg),
                0236      I      df,
                0237      I      sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy,
                0238      I      iRun,jRun,k,bi,bj,
                0239      I      myThid)
                0240         ENDDO
cf336ab6c5 Ryan*0241       ENDIF
50d8304171 Ryan*0242
                0243 C        IF (bibjFlg.EQ.2) THEN
                0244 C C --   called INSIDE the bi-bj loop, with overlap present
                0245 C         DO k = kstart,kend
                0246 C          DO j = 1-OLy,sNy+OLy
                0247 C           DO i = 1-OLx,sNx+OLx
                0248 C            layers_saved_flux(i,j,k,trIdentity,biArg,bjArg) =
                0249 C      &       layers_saved_flux(i,j,k,trIdentity,biArg,bjArg) +
                0250 C      &        df(i,j,1,1)
                0251 C           ENDDO
                0252 C          ENDDO
                0253 C         ENDDO
f0f170d54b Mart*0254 C        ELSEIF (bibjFlg.EQ.0) THEN
50d8304171 Ryan*0255 C C --   the bi-bj loop must be done here
                0256 C         DO bj=myByLo(myThid), myByHi(myThid)
                0257 C          DO bi=myBxLo(myThid), myBxHi(myThid)
                0258 C           DO k = kstart,kend
                0259 C            DO j = 1-OLy,sNy+OLy
                0260 C             DO i = 1-OLx,sNx+OLx
                0261 C               layers_saved_flux(i,j,k,trIdentity,bi,bj) =
                0262 C      &          layers_saved_flux(i,j,k,trIdentity,bi,bj) +
                0263 C      &          df(i,j,bi,bj)
                0264 C             ENDDO
                0265 C            ENDDO
                0266 C           ENDDO
                0267 C          ENDDO
                0268 C         ENDDO
                0269 C        ELSE
                0270 C            WRITE(msgBuf,'(2A)')
                0271 C      &          'S/R LAYERS_FILL_FIELD: ',
                0272 C      &          'got unexpected bibjFlg'
                0273 C            CALL PRINT_ERROR( msgBuf, myThid )
                0274 C            STOP 'ABNORMAL END: S/R LAYERS_FILL_FIELD'
6088c626b1 Jean*0275 C        ENDIF
50d8304171 Ryan*0276
cf336ab6c5 Ryan*0277       RETURN
                0278       END
50d8304171 Ryan*0279 C end of S/R LAYERS_FILL_FIELD
cf336ab6c5 Ryan*0280
f0f170d54b Mart*0281 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0282
50d8304171 Ryan*0283       SUBROUTINE LAYERS_CUMULATE(
                0284      U                  cumFld,
                0285      I                  inpFld,
                0286      I                  sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy,
                0287      I                  iRun,jRun,k,bi,bj,
                0288      I                  myThid )
cf336ab6c5 Ryan*0289
50d8304171 Ryan*0290 C     !DESCRIPTION:
                0291 C     Update array cumFld
                0292 C     by adding content of input field array inpFld
                0293 C     over the range [1:iRun],[1:jRun]
cf336ab6c5 Ryan*0294
50d8304171 Ryan*0295 C     !USES:
                0296       IMPLICIT NONE
cf336ab6c5 Ryan*0297
50d8304171 Ryan*0298 #include "EEPARAMS.h"
                0299 #include "SIZE.h"
cf336ab6c5 Ryan*0300
50d8304171 Ryan*0301 C     !INPUT/OUTPUT PARAMETERS:
                0302 C     == Routine Arguments ==
                0303 C     cumFld      :: cumulative array (updated)
                0304 C     inpFld      :: input field array to add to cumFld
                0305 C     sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max)
                0306 C     sizJ1,sizJ2 :: size of inpFld array: 2nd  index range (min,max)
                0307 C     sizK        :: size of inpFld array: 3rd  dimension
                0308 C     sizTx,sizTy :: size of inpFld array: tile dimensions
                0309 C     iRun,jRun   :: range of 1rst & 2nd index
                0310 C     k,bi,bj     :: level and tile indices of inFld array to add to cumFld array
                0311 C     myThid      :: my Thread Id number
                0312       _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0313       INTEGER sizI1,sizI2,sizJ1,sizJ2
                0314       INTEGER sizK,sizTx,sizTy
                0315       _RL inpFld(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy)
                0316       INTEGER iRun, jRun, k, bi, bj
                0317       INTEGER myThid
                0318 CEOP
4008d662b9 Jean*0319
50d8304171 Ryan*0320 C     !LOCAL VARIABLES:
                0321 C     i,j    :: loop indices
                0322       INTEGER i, j
                0323 C      _RL     tmpFact
cf336ab6c5 Ryan*0324
50d8304171 Ryan*0325 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
cf336ab6c5 Ryan*0326
50d8304171 Ryan*0327       DO j = 1,jRun
                0328        DO i = 1,iRun
                0329         cumFld(i,j) = cumFld(i,j) + inpFld(i,j,k,bi,bj)
                0330        ENDDO
                0331       ENDDO
cf336ab6c5 Ryan*0332
f0f170d54b Mart*0333 #endif /* LAYERS_THERMODYNAMICS */
                0334
cf336ab6c5 Ryan*0335       RETURN
                0336       END