C $Header: /u/gcmpack/MITgcm/pkg/layers/layers_save.F,v 1.4 2015/06/10 20:51:17 jmc Exp $ C $Name: $ #include "LAYERS_OPTIONS.h" C-- File layers_save.F: C-- Contents C-- o LAYERS_FILL C-- o LAYERS_FILL_FIELD C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| CBOP SUBROUTINE LAYERS_FILL( I df, trIdentity, fluxid, I kLev, nLevs, bibjFlg, biArg, bjArg, myThid ) C !DESCRIPTION: \bv C *==========================================================* C | SUBROUTINE LAYERS_FILL C | "Remember" the merid. advective flux for use later in layers_thermodynamics C *==========================================================* IMPLICIT NONE #include "SIZE.h" #include "EEPARAMS.h" #include "PARAMS.h" #include "GRID.h" #include "LAYERS_SIZE.h" #include "LAYERS.h" C*********************************************************************** C This is designed to look and work exactly like the a regular C diagnostics_fill call. C*********************************************************************** C surfflux :: The surface temperature flux, the same as what is filled into C the TFLUX and SFLUX diagnostics C trIdentity:: Index to let us know what tracer it is (1 for T, 2 for S) C kLev :: Integer flag for vertical levels: C > 0 (any integer): WHICH single level to increment in qdiag. C 0,-1 to increment "nLevs" levels in qdiag, C 0 : fill-in in the same order as the input array C -1: fill-in in reverse order. C nLevs :: indicates Number of levels of the input field array C (whether to fill-in all the levels (kLev<1) or just one (kLev>0)) C bibjFlg :: Integer flag to indicate instructions for bi bj loop C 0 indicates that the bi-bj loop must be done here C 1 indicates that the bi-bj loop is done OUTSIDE C 2 indicates that the bi-bj loop is done OUTSIDE C AND that we have been sent a local array (with overlap regions) C 3 indicates that the bi-bj loop is done OUTSIDE C AND that we have been sent a local array C AND that the array has no overlap region (interior only) C NOTE - bibjFlg can be NEGATIVE to indicate not to increment counter C biArg :: X-direction tile number - used for bibjFlg=1-3 C bjArg :: Y-direction tile number - used for bibjFlg=1-3 C _RL df(1-OLx:sNx+OLx,1-OLy:sNy+OLy) _RL df(*) INTEGER trIdentity, kLev, nLevs, bibjFlg, biArg, bjArg INTEGER myThid CHARACTER*(3) fluxid #ifdef LAYERS_THERMODYNAMICS C !LOCAL VARIABLES: ==================================================== C i,j :: loop indices C msgBuf :: error message buffer CHARACTER*(MAX_LEN_MBUF) msgBuf IF ((trIdentity.EQ.1).OR.(trIdentity.EQ.2)) THEN IF (fluxid.EQ.'SUR') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, 1, layers_surfflux,'M', & klev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE IF (fluxid.EQ.'DFX') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_dfx,'U', & kLev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE IF (fluxid.EQ.'DFY') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_dfy,'V', & kLev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE IF (fluxid.EQ.'DFR') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_dfr,'M', & kLev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE IF (fluxid.EQ.'AFX') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_afx,'U', & kLev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE IF (fluxid.EQ.'AFY') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_afy,'V', & kLev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE IF (fluxid.EQ.'AFR') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_afr,'M', & kLev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE IF (fluxid.EQ.'TOT') THEN CALL LAYERS_FILL_FIELD(df, trIdentity, Nr, layers_tottend,'M', & kLev, nLevs, bibjFlg, biArg, bjArg, myThid) ELSE WRITE(msgBuf,'(2A)') & 'S/R LAYERS_FILL: ', & 'invalid flux ID' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R LAYERS_FILL' ENDIF ELSE C ---- Cannot throw an error for different trIdentity C because subroutine also gets called for ptracers. C Just have to do nothing C WRITE(msgBuf,'(5A,I2)') C & 'S/R LAYERS_FILL: ', C & 'only works on THETA (1) or SALT (2)', C & 'fluxid=', fluxid, 'trId=', C & trIdentity C CALL PRINT_ERROR( msgBuf, myThid ) C STOP 'ABNORMAL END: S/R LAYERS_FILL' ENDIF #endif /* LAYERS_THERMODYNAMICS */ RETURN END
C end of S/R LAYERS_FILL SUBROUTINE LAYERS_FILL_FIELD( I df, trIdentity, myNr, U layers_saved_flux, I fldType, I kLev, nLevs, bibjFlg, biArg, bjArg, myThid ) IMPLICIT NONE #include "SIZE.h" #include "EEPARAMS.h" #include "PARAMS.h" #include "GRID.h" #include "LAYERS_SIZE.h" #include "LAYERS.h" INTEGER trIdentity, myNr, kLev, nLevs, bibjFlg, biArg, bjArg CHARACTER fldType _RL layers_saved_flux(1-OLx:sNx+OLx,1-OLy:sNy+OLy, & myNr,2,nSx,nSy) C _RL df(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) _RL df(*) INTEGER myThid #ifdef LAYERS_THERMODYNAMICS C !LOCAL VARIABLES: ==================================================== C i,j :: loop indices C msgBuf :: error message buffer INTEGER sizI1,sizI2,sizJ1,sizJ2 INTEGER sizTx,sizTy INTEGER iRun, jRun, k, bi, bj INTEGER kFirst, kLast INTEGER kd, kd0, ksgn C CHARACTER*(MAX_LEN_MBUF) msgBuf C- select range for 1rst & 2nd indices to accumulate C depending on variable location on C-grid, IF ( fldType.EQ.'U' ) THEN iRun = sNx+1 jRun = sNy ELSEIF ( fldType.EQ.'V' ) THEN iRun = sNx jRun = sNy+1 ELSE iRun = sNx jRun = sNy ENDIF C- Dimension of the input array: IF (abs(bibjFlg).EQ.3) THEN sizI1 = 1 sizI2 = sNx sizJ1 = 1 sizJ2 = sNy iRun = sNx jRun = sNy ELSE sizI1 = 1-OLx sizI2 = sNx+OLx sizJ1 = 1-OLy sizJ2 = sNy+OLy ENDIF IF (abs(bibjFlg).GE.2) THEN sizTx = 1 sizTy = 1 ELSE sizTx = nSx sizTy = nSy ENDIF C- Which part of inpFld to add : k = 3rd index, C and do the loop >> do k=kFirst,kLast << IF (kLev.LE.0) THEN kFirst = 1 kLast = nLevs ELSEIF ( nLevs.EQ.1 ) THEN kFirst = 1 kLast = 1 ELSEIF ( kLev.LE.nLevs ) THEN kFirst = kLev kLast = kLev ELSE STOP 'ABNORMAL END in LAYERS_SAVE: kLev > nLevs >0' ENDIF C- Which part of qdiag to update: kd = 3rd index, C and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn << IF ( kLev.EQ.-1 ) THEN ksgn = -1 kd0 = 1 + nLevs ELSEIF ( kLev.EQ.0 ) THEN ksgn = 1 kd0 = 0 ELSE ksgn = 0 kd0 = kLev ENDIF IF ( bibjFlg.EQ.0 ) THEN DO bj=myByLo(myThid), myByHi(myThid) DO bi=myBxLo(myThid), myBxHi(myThid) DO k = kFirst,kLast kd = kd0 + ksgn*k CALL LAYERS_CUMULATE( U layers_saved_flux(1-OLx,1-OLy,kd,trIdentity,bi,bj), I df, I sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy, I iRun,jRun,k,bi,bj, I myThid) ENDDO ENDDO ENDDO ELSE bi = MIN(biArg,sizTx) bj = MIN(bjArg,sizTy) DO k = kFirst,kLast kd = kd0 + ksgn*k CALL LAYERS_CUMULATE( U layers_saved_flux(1-OLx,1-OLy,kd,trIdentity,biArg,bjArg), I df, I sizI1,sizI2,sizJ1,sizJ2,nLevs,sizTx,sizTy, I iRun,jRun,k,bi,bj, I myThid) ENDDO ENDIF C IF (bibjFlg.EQ.2) THEN C C -- called INSIDE the bi-bj loop, with overlap present C DO k = kstart,kend C DO j = 1-OLy,sNy+OLy C DO i = 1-OLx,sNx+OLx C layers_saved_flux(i,j,k,trIdentity,biArg,bjArg) = C & layers_saved_flux(i,j,k,trIdentity,biArg,bjArg) + C & df(i,j,1,1) C ENDDO C ENDDO C ENDDO C ELSE IF (bibjFlg.EQ.0) THEN C C -- the bi-bj loop must be done here C DO bj=myByLo(myThid), myByHi(myThid) C DO bi=myBxLo(myThid), myBxHi(myThid) C DO k = kstart,kend C DO j = 1-OLy,sNy+OLy C DO i = 1-OLx,sNx+OLx C layers_saved_flux(i,j,k,trIdentity,bi,bj) = C & layers_saved_flux(i,j,k,trIdentity,bi,bj) + C & df(i,j,bi,bj) C ENDDO C ENDDO C ENDDO C ENDDO C ENDDO C ELSE C WRITE(msgBuf,'(2A)') C & 'S/R LAYERS_FILL_FIELD: ', C & 'got unexpected bibjFlg' C CALL PRINT_ERROR( msgBuf, myThid ) C STOP 'ABNORMAL END: S/R LAYERS_FILL_FIELD' C ENDIF #endif /* LAYERS_THERMODYNAMICS */ RETURN END
C end of S/R LAYERS_FILL_FIELD SUBROUTINE LAYERS_CUMULATE( U cumFld, I inpFld, I sizI1,sizI2,sizJ1,sizJ2,sizK,sizTx,sizTy, I iRun,jRun,k,bi,bj, I myThid ) C !DESCRIPTION: C Update array cumFld C by adding content of input field array inpFld C over the range [1:iRun],[1:jRun] C !USES: IMPLICIT NONE #include "EEPARAMS.h" #include "SIZE.h" C !INPUT/OUTPUT PARAMETERS: C == Routine Arguments == C cumFld :: cumulative array (updated) C inpFld :: input field array to add to cumFld C sizI1,sizI2 :: size of inpFld array: 1rst index range (min,max) C sizJ1,sizJ2 :: size of inpFld array: 2nd index range (min,max) C sizK :: size of inpFld array: 3rd dimension C sizTx,sizTy :: size of inpFld array: tile dimensions C iRun,jRun :: range of 1rst & 2nd index C k,bi,bj :: level and tile indices of inFld array to add to cumFld array C myThid :: my Thread Id number _RL cumFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy) INTEGER sizI1,sizI2,sizJ1,sizJ2 INTEGER sizK,sizTx,sizTy _RL inpFld(sizI1:sizI2,sizJ1:sizJ2,sizK,sizTx,sizTy) INTEGER iRun, jRun, k, bi, bj INTEGER myThid CEOP C !LOCAL VARIABLES: C i,j :: loop indices INTEGER i, j C _RL tmpFact C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| DO j = 1,jRun DO i = 1,iRun cumFld(i,j) = cumFld(i,j) + inpFld(i,j,k,bi,bj) ENDDO ENDDO RETURN END