pkg/down_slope/dwnslp_apply.F

b6bbe8cccf Jean*0001 #include "DWNSLP_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: DWNSLP_APPLY
                0005 C     !INTERFACE:
                0006       SUBROUTINE DWNSLP_APPLY(
                0007      I            trIdentity, bi, bj, kBottom,
                0008      I            tracer,
4bbed03c23 Jean*0009      U            gTracer,
                0010      I            recip_hFac, recip_rA_arg, recip_drF,
                0011      I            deltaTLev, myTime, myIter, myThid )
bb79aa40f5 Jean*0012
b6bbe8cccf Jean*0013 C     !DESCRIPTION: \bv
                0014 C     *==========================================================*
                0015 C     | SUBROUTINE DWNSLP_APPLY
                0016 C     | o Apply the dowsloping-transport to tracer field
                0017 C     *==========================================================*
                0018 C     \ev
                0019
                0020 C     !USES:
                0021       IMPLICIT NONE
                0022
                0023 C     === Global variables ===
                0024 #include "SIZE.h"
                0025 #include "EEPARAMS.h"
                0026 #include "PARAMS.h"
                0027 #include "DWNSLP_SIZE.h"
                0028 #include "DWNSLP_PARAMS.h"
                0029 #include "DWNSLP_VARS.h"
                0030 #ifdef ALLOW_GENERIC_ADVDIFF
                0031 # include "GAD.h"
                0032 #endif
                0033
                0034 C     !INPUT/OUTPUT PARAMETERS:
                0035 C     === Routine arguments ===
                0036 C     trIdentity :: tracer identification number
                0037 C     bi,bj      :: Tile indices
                0038 C     kBottom    :: bottom level
4bbed03c23 Jean*0039 C     tracer     :: tracer field at current time (input)
                0040 C     gTracer    :: tracer tendency to update
a965871e68 Jean*0041 C     recip_hFac :: Reciprocal of cell open-depth factor
                0042 C     recip_rA_arg :: Reciprocal of cell Area
4bbed03c23 Jean*0043 C     recip_drF  :: Reciprocal of cell thickness
                0044 C     deltaTLev  :: tracer time step
b6bbe8cccf Jean*0045 C     myTime     :: Current time in simulation
                0046 C     myIter     :: Current time-step number
                0047 C     myThid     :: my Thread Id. number
                0048       INTEGER trIdentity
                0049       INTEGER bi, bj
4bbed03c23 Jean*0050       INTEGER kBottom ( xySize, nSx, nSy )
                0051       _RL tracer      ( xySize, Nr )
                0052       _RL gTracer     ( xySize, Nr )
                0053       _RS recip_hFac  ( xySize, Nr )
b6bbe8cccf Jean*0054       _RS recip_rA_arg( xySize, nSx, nSy )
4bbed03c23 Jean*0055       _RS recip_drF(Nr)
                0056       _RL deltaTLev(Nr)
b6bbe8cccf Jean*0057       _RL     myTime
                0058       INTEGER myIter, myThid
                0059
                0060 #ifdef ALLOW_DOWN_SLOPE
4bbed03c23 Jean*0061 #ifdef ALLOW_DIAGNOSTICS
                0062 C-    !FUNCTIONS:
                0063       LOGICAL  DIAGNOSTICS_IS_ON
                0064       EXTERNAL DIAGNOSTICS_IS_ON
                0065 #endif /* ALLOW_DIAGNOSTICS */
b6bbe8cccf Jean*0066
                0067 C     !LOCAL VARIABLES:
                0068 C     === Local variables ===
0884a363a5 Jean*0069 C     msgBuf     :: Informational/error message buffer
610bbab848 Jean*0070       INTEGER k
fe1862e69b Mart*0071       INTEGER n,ijd,ijs,kshelf,kDeep
b6bbe8cccf Jean*0072       _RL     gTrLoc(0:Nr)
fe1862e69b Mart*0073       _RL     dTrac(1:Nr)
b6bbe8cccf Jean*0074       INTEGER upward
                0075       LOGICAL onOffFlag
                0076
                0077 #ifdef ALLOW_DIAGNOSTICS
                0078       CHARACTER*8 diagName
                0079       CHARACTER*4 diagSufx
                0080       LOGICAL     doDiagDwnSlpTend
4bbed03c23 Jean*0081       _RL         tmpFac
b6bbe8cccf Jean*0082 #ifdef ALLOW_GENERIC_ADVDIFF
                0083       CHARACTER*4 GAD_DIAG_SUFX
                0084       EXTERNAL    GAD_DIAG_SUFX
                0085 #endif
                0086 #endif /* ALLOW_DIAGNOSTICS */
                0087
                0088 CEOP
                0089
                0090       onOffFlag = .TRUE.
                0091 #ifdef ALLOW_GENERIC_ADVDIFF
                0092       IF ( trIdentity.EQ.GAD_TEMPERATURE ) onOffFlag = temp_useDWNSLP
                0093       IF ( trIdentity.EQ.GAD_SALINITY    ) onOffFlag = salt_useDWNSLP
                0094 #endif
                0095       IF ( onOffFlag ) THEN
                0096 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0097
                0098 c      upward = rkSign*NINT(-gravitySign)
                0099        upward = 1
                0100        IF (usingZCoords) upward = -1
                0101
                0102 #ifdef ALLOW_DIAGNOSTICS
                0103        IF ( useDiagnostics ) THEN
                0104         IF ( trIdentity.GE.1 ) THEN
                0105 C--   Set diagnostic suffix for the current tracer
                0106 #ifdef ALLOW_GENERIC_ADVDIFF
                0107           diagSufx = GAD_DIAG_SUFX( trIdentity, myThid )
                0108 #else
                0109           diagSufx = 'aaaa'
                0110 #endif
                0111           diagName = 'DSLP'//diagSufx
                0112         ELSE
                0113           STOP 'S/R DWNSLP_APPLY: should never reach this point !'
                0114         ENDIF
                0115         doDiagDwnSlpTend = DIAGNOSTICS_IS_ON(diagName,myThid)
                0116        ELSE
                0117         doDiagDwnSlpTend = .FALSE.
                0118        ENDIF
4bbed03c23 Jean*0119        IF ( doDiagDwnSlpTend ) THEN
                0120          tmpFac = -1. _d 0
                0121          CALL DIAGNOSTICS_SCALE_FILL( gTracer, tmpFac, 1, diagName,
                0122      &                                0, Nr, -2, bi, bj, myThid )
                0123        ENDIF
b6bbe8cccf Jean*0124 #endif /* ALLOW_DIAGNOSTICS */
                0125
fe1862e69b Mart*0126 #ifndef TARGET_NEC_SX
bb79aa40f5 Jean*0127        IF ( DWNSLP_ioUnit.GT.0 ) THEN
                0128         _BEGIN_MASTER(myThid)
b6bbe8cccf Jean*0129         WRITE(DWNSLP_ioUnit,'(A,I8,3I4)')
                0130      &   ' DWNSLP_APPLY: iter, iTr, bi,bj=', myIter,trIdentity, bi,bj
                0131         WRITE(DWNSLP_ioUnit,'(2A)') '  bi  bj     n    ijDp    ijSh',
                0132      &   ' kDp   Tr_Dp         Gt_Dp         Tr_Sh         Gt_Sh'
bb79aa40f5 Jean*0133         _END_MASTER(myThid)
b6bbe8cccf Jean*0134        ENDIF
fe1862e69b Mart*0135 #endif
b6bbe8cccf Jean*0136
                0137        DO n=1,DWNSLP_NbSite(bi,bj)
                0138         IF (DWNSLP_deepK(n,bi,bj).NE.0) THEN
                0139
0884a363a5 Jean*0140 C- detect density gradient along the slope => Downsloping flow
b6bbe8cccf Jean*0141          ijd = DWNSLP_ijDeep(n,bi,bj)
                0142          ijs = ijd + DWNSLP_shVsD(n,bi,bj)
                0143
                0144          kshelf = kBottom(ijs,bi,bj)
fe1862e69b Mart*0145          kDeep = DWNSLP_deepK(n,bi,bj)
                0146 C- precomute vertical tracer differences to help TAF
                0147          DO k=kshelf,kDeep+upward,-upward
                0148           dTrac(k) = tracer(ijd,k-upward)-tracer(ijd,k)
                0149          ENDDO
                0150          dTrac(kDeep) = tracer(ijs,kshelf)-tracer(ijd,kDeep)
0884a363a5 Jean*0151 C- downsloping flow (in) & upward return flow :
fe1862e69b Mart*0152          DO k=kshelf,kDeep,-upward
b6bbe8cccf Jean*0153           gTrLoc(k) = DWNSLP_Transp(n,bi,bj)
fe1862e69b Mart*0154      &       * dTrac(k)
a965871e68 Jean*0155      &       *recip_drF(k)*recip_hFac(ijd,k)
b6bbe8cccf Jean*0156      &       *recip_rA_arg(ijd,bi,bj)
4bbed03c23 Jean*0157           gTracer(ijd,k) = gTracer(ijd,k) + gTrLoc(k)
b6bbe8cccf Jean*0158          ENDDO
0884a363a5 Jean*0159 C- downsloping flow (out) & return flow to the shelf
fe1862e69b Mart*0160          k = kshelf
                0161          gTrLoc(0) = DWNSLP_Transp(n,bi,bj)
                0162      &       * ( tracer(ijd,k)-tracer(ijs,k) )
a965871e68 Jean*0163      &       *recip_drF(k)*recip_hFac(ijs,k)
b6bbe8cccf Jean*0164      &       *recip_rA_arg(ijs,bi,bj)
fe1862e69b Mart*0165          gTracer(ijs,k) = gTracer(ijs,k) + gTrLoc(0)
b6bbe8cccf Jean*0166
fe1862e69b Mart*0167 #ifndef TARGET_NEC_SX
                0168 C-    skip within do-loop write statement when compiling on a vector computer
bb79aa40f5 Jean*0169          IF ( DWNSLP_ioUnit.GT.0 ) THEN
                0170           _BEGIN_MASTER(myThid)
fe1862e69b Mart*0171           k = kDeep
b6bbe8cccf Jean*0172           WRITE(DWNSLP_ioUnit,'(2I4,I6,2I8,I4,1P4E14.6)')
                0173      &      bi,bj,n,ijd,ijs,k,
fe1862e69b Mart*0174      &      tracer(ijd,k), deltaTLev(k)*gTrLoc(k),
                0175      &      tracer(ijs,kshelf), deltaTLev(k)*gTrLoc(0)
bb79aa40f5 Jean*0176           _END_MASTER(myThid)
b6bbe8cccf Jean*0177          ENDIF
fe1862e69b Mart*0178 #endif
b6bbe8cccf Jean*0179         ENDIF
                0180        ENDDO
fe1862e69b Mart*0181 #ifndef TARGET_NEC_SX
bb79aa40f5 Jean*0182        IF ( DWNSLP_ioUnit.GT.0 ) THEN
                0183          _BEGIN_MASTER(myThid)
                0184          WRITE(DWNSLP_ioUnit,*)
                0185          _END_MASTER(myThid)
                0186        ENDIF
fe1862e69b Mart*0187 #endif
b6bbe8cccf Jean*0188
                0189 #ifdef ALLOW_DIAGNOSTICS
                0190        IF ( doDiagDwnSlpTend )
                0191      &  CALL DIAGNOSTICS_FILL( gTracer, diagName, 0,Nr,2,bi,bj,myThid )
                0192 #endif /* ALLOW_DIAGNOSTICS */
                0193
                0194 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0195 C--   end if on-off-flag
                0196       ENDIF
                0197
                0198 #endif /* ALLOW_DOWN_SLOPE */
                0199
                0200       RETURN
                0201       END