tutorial_tracer_adjsens/code_ad/ptracers_forcing_surf.F

847dcb9bdb Jean*0001 #include "PTRACERS_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: PTRACERS_FORCING_SURF
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE PTRACERS_FORCING_SURF(
3f4989e08f Jean*0008      I                            relaxForcingS,
847dcb9bdb Jean*0009      I                            bi, bj, iMin, iMax, jMin, jMax,
                0010      I                            myTime,myIter,myThid )
                0011
                0012 C !DESCRIPTION:
                0013 C     Precomputes surface forcing term for pkg/ptracers.
                0014 C     Precomputation is needed because of non-local KPP transport term,
                0015 C     routine KPP_TRANSPORT_PTR.
                0016
                0017 C !USES: ===============================================================
                0018       IMPLICIT NONE
                0019 #include "SIZE.h"
                0020 #include "EEPARAMS.h"
                0021 #include "PARAMS.h"
dc109c52c8 Jean*0022 #include "GRID.h"
                0023 #include "SURFACE.h"
3f4989e08f Jean*0024 #include "DYNVARS.h"
847dcb9bdb Jean*0025 #include "FFIELDS.h"
dc109c52c8 Jean*0026 #include "PTRACERS_SIZE.h"
79eb851a84 Jean*0027 #include "PTRACERS_PARAMS.h"
698b6992ee Jean*0028 #include "PTRACERS_START.h"
79eb851a84 Jean*0029 #include "PTRACERS_FIELDS.h"
847dcb9bdb Jean*0030
                0031 C !INPUT PARAMETERS: ===================================================
3f4989e08f Jean*0032 C  relaxForcingS        :: Salt forcing due to surface relaxation
847dcb9bdb Jean*0033 C  bi,bj                :: tile indices
                0034 C  myTime               :: model time
                0035 C  myIter               :: time-step number
                0036 C  myThid               :: thread number
3f4989e08f Jean*0037       _RL relaxForcingS(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
847dcb9bdb Jean*0038       INTEGER bi, bj, iMin, iMax, jMin, jMax
                0039       _RL myTime
                0040       INTEGER myIter
                0041       INTEGER myThid
                0042
                0043 #ifdef ALLOW_PTRACERS
                0044
                0045 C !LOCAL VARIABLES: ====================================================
                0046 C  i,j                  :: loop indices
dc109c52c8 Jean*0047 C  iTrc                 :: tracer index
                0048 C  ks                   :: surface level index
                0049       INTEGER i, j
                0050       INTEGER iTrc, ks
3f4989e08f Jean*0051       _RL add2EmP(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0052       _RL epsil, cutoff, tmpVar
847dcb9bdb Jean*0053 CEOP
                0054
dc109c52c8 Jean*0055       IF ( usingPCoords ) THEN
                0056         ks = Nr
                0057       ELSE
                0058         ks = 1
                0059       ENDIF
                0060
847dcb9bdb Jean*0061 C Example of how to add forcing at the surface
dc109c52c8 Jean*0062       DO iTrc=1,PTRACERS_numInUse
698b6992ee Jean*0063 c       IF ( PTRACERS_StepFwd(iTrc) ) THEN
847dcb9bdb Jean*0064           DO j = jMin, jMax
                0065            DO i = iMin, iMax
698b6992ee Jean*0066              surfaceForcingPTr(i,j,bi,bj,iTrc) = 0. _d 0
                0067      &                        + surfaceForcingS(i,j,bi,bj)
847dcb9bdb Jean*0068            ENDDO
                0069           ENDDO
698b6992ee Jean*0070 c       ENDIF
dc109c52c8 Jean*0071       ENDDO
                0072
3f4989e08f Jean*0073 C--   Option to convert Salt-relaxation into additional EmP contribution
                0074       IF ( PTRACERS_addSrelax2EmP ) THEN
                0075 C-    here we assume that salt_EvPrRn = 0
                0076 C     set cutoff value to prevent too large additional EmP:
                0077 C       current limit is set to 0.1 CFL
                0078         epsil = 1. _d -10
                0079         cutoff = 0.1 _d 0 *drF(ks)/PTRACERS_dTLev(ks)
                0080         IF ( ( (nonlinFreeSurf.GT.0 .OR. usingPCoords)
                0081      &         .AND. useRealFreshWaterFlux )
                0082      &     .OR.convertFW2Salt .EQ. -1. ) THEN
                0083          DO j = jMin, jMax
                0084           DO i = iMin, iMax
                0085             tmpVar = MAX( salt(i,j,ks,bi,bj), epsil )
                0086             add2EmP(i,j) = relaxForcingS(i,j)/tmpVar
                0087             add2EmP(i,j) = rUnit2mass
                0088      &                  *MAX( -cutoff, MIN( add2EmP(i,j), cutoff ) )
                0089           ENDDO
                0090          ENDDO
                0091         ELSE
                0092          DO j = jMin, jMax
                0093           DO i = iMin, iMax
                0094             add2EmP(i,j) = relaxForcingS(i,j)/convertFW2Salt
                0095             add2EmP(i,j) = rUnit2mass
                0096      &                  *MAX( -cutoff, MIN( add2EmP(i,j), cutoff ) )
                0097           ENDDO
                0098          ENDDO
                0099         ENDIF
                0100 #ifdef ALLOW_DIAGNOSTICS
                0101         IF ( useDiagnostics ) THEN
                0102          CALL DIAGNOSTICS_FILL(add2EmP,'Add2EmP ',0,1,2,bi,bj,myThid)
                0103         ENDIF
                0104 #endif /* ALLOW_DIAGNOSTICS */
                0105       ELSE
                0106         DO j = jMin, jMax
                0107           DO i = iMin, iMax
                0108             add2EmP(i,j) = 0. _d 0
                0109           ENDDO
                0110         ENDDO
                0111       ENDIF
                0112 C-- end of "addEmP" setting
                0113
dc109c52c8 Jean*0114       IF ( (nonlinFreeSurf.GT.0 .OR. usingPCoords)
                0115      &     .AND. useRealFreshWaterFlux ) THEN
                0116
                0117        DO iTrc=1,PTRACERS_numInUse
                0118
                0119 c-  NonLin_FrSurf and RealFreshWaterFlux : PmEpR effectively changes
                0120 c   the water column height ; temp., salt, (tracer) flux associated
                0121 c   with this input/output of water is added here to the surface tendency.
                0122 c
698b6992ee Jean*0123          IF ( PTRACERS_StepFwd(iTrc) .AND.
                0124      &        PTRACERS_EvPrRn(iTrc).NE.UNSET_RL ) THEN
dc109c52c8 Jean*0125           DO j = jMin, jMax
                0126            DO i = iMin, iMax
79eb851a84 Jean*0127              surfaceForcingPTr(i,j,bi,bj,iTrc) =
                0128      &          surfaceForcingPTr(i,j,bi,bj,iTrc)
3f4989e08f Jean*0129      &        + ( PmEpR(i,j,bi,bj) - add2EmP(i,j) )
dc109c52c8 Jean*0130      &          *( PTRACERS_EvPrRn(iTrc) - pTracer(i,j,ks,bi,bj,iTrc) )
62fd6ae4e5 Jean*0131      &          *mass2rUnit
dc109c52c8 Jean*0132            ENDDO
                0133           ENDDO
                0134          ENDIF
                0135
847dcb9bdb Jean*0136        ENDDO
79eb851a84 Jean*0137
                0138 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0139       ELSE
847dcb9bdb Jean*0140
79eb851a84 Jean*0141 C--   EmPmR does not really affect the water column height (for tracer budget)
                0142 C     and is converted to a salt tendency.
                0143
                0144        IF (convertFW2Salt .EQ. -1.) THEN
                0145 C-    use local surface tracer field to calculate forcing term:
                0146
                0147         DO iTrc=1,PTRACERS_numInUse
                0148
698b6992ee Jean*0149          IF ( PTRACERS_StepFwd(iTrc) .AND.
                0150      &        PTRACERS_EvPrRn(iTrc).NE.UNSET_RL ) THEN
79eb851a84 Jean*0151 C        account for Rain/Evap tracer content (PTRACERS_EvPrRn) using
                0152 C        local surface tracer
                0153           DO j = jMin, jMax
                0154            DO i = iMin, iMax
                0155             surfaceForcingPTr(i,j,bi,bj,iTrc) =
                0156      &          surfaceForcingPTr(i,j,bi,bj,iTrc)
3f4989e08f Jean*0157      &        + ( EmPmR(i,j,bi,bj) + add2EmP(i,j) )
79eb851a84 Jean*0158      &          *( pTracer(i,j,ks,bi,bj,iTrc) - PTRACERS_EvPrRn(iTrc) )
                0159      &          *mass2rUnit
                0160            ENDDO
                0161           ENDDO
                0162          ENDIF
                0163
                0164         ENDDO
                0165
                0166        ELSE
                0167 C-    use uniform tracer value to calculate forcing term:
                0168
                0169         DO iTrc=1,PTRACERS_numInUse
                0170
698b6992ee Jean*0171          IF ( PTRACERS_StepFwd(iTrc) .AND.
                0172      &        PTRACERS_EvPrRn(iTrc).NE.UNSET_RL ) THEN
79eb851a84 Jean*0173 C     account for Rain/Evap tracer content (PTRACERS_EvPrRn) assuming uniform
                0174 C     surface tracer (=PTRACERS_ref)
                0175           DO j = jMin, jMax
                0176            DO i = iMin, iMax
                0177             surfaceForcingPTr(i,j,bi,bj,iTrc) =
                0178      &          surfaceForcingPTr(i,j,bi,bj,iTrc)
3f4989e08f Jean*0179      &        + ( EmPmR(i,j,bi,bj) + add2EmP(i,j) )
79eb851a84 Jean*0180      &            *( PTRACERS_ref(ks,iTrc) - PTRACERS_EvPrRn(iTrc) )
                0181      &            *mass2rUnit
                0182            ENDDO
                0183           ENDDO
                0184          ENDIF
                0185
                0186         ENDDO
                0187
                0188 C-    end local-surface-tracer / uniform-value distinction
                0189        ENDIF
                0190
                0191       ENDIF
                0192
                0193 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0194
847dcb9bdb Jean*0195 #endif /* ALLOW_PTRACERS */
                0196
                0197       RETURN
                0198       END