Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:41:46 UTC

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