Back to home page

MITgcm
 
 

    

File indexing completed on 2023-09-03 05:10:26 UTC

view on githubraw file Latest commit 74487008 on 2023-09-03 01:50:18 UTC
f42e64b3e7 Jean*0001 #include "GMREDI_OPTIONS.h"
14e0496834 Jean*0002 #ifdef ALLOW_AUTODIFF
                0003 # include "AUTODIFF_OPTIONS.h"
                0004 #endif
f42e64b3e7 Jean*0005 
5b172de0d2 Jean*0006 CBOP
                0007 C     !ROUTINE: GMREDI_SLOPE_PSI
                0008 C     !INTERFACE:
60e7c881f5 Jean*0009       SUBROUTINE GMREDI_SLOPE_PSI(
f42e64b3e7 Jean*0010      O             taperX, taperY,
c1c6d46ee2 Jean*0011      U             SlopeX, SlopeY,
5b172de0d2 Jean*0012      U             dSigmaDrW, dSigmaDrS,
                0013      I             LrhoW, LrhoS, rDepth, k,
                0014      I             bi, bj, myThid )
                0015 C     !DESCRIPTION: \bv
8233d0ceb9 Jean*0016 C     *==========================================================*
60e7c881f5 Jean*0017 C     | SUBROUTINE GMREDI_SLOPE_PSI                              |
5b172de0d2 Jean*0018 C     | o Calculate slopes for use in GM advective form          |
8233d0ceb9 Jean*0019 C     *==========================================================*
f42e64b3e7 Jean*0020 C     | On entry:                                                |
5b172de0d2 Jean*0021 C     |     dSigmaDrW,S  contains the -d/dz Sigma if Z-coords    |
                0022 C     |                           but  d/dp Sigma if P-coords    |
                0023 C     |     SlopeX/Y     contains X/Y gradients of sigma         |
                0024 C     |     rDepth       depth (> 0) in r-Unit from the surface  |
f42e64b3e7 Jean*0025 C     | On exit:                                                 |
5b172de0d2 Jean*0026 C     |     dSigmaDrW,S  contains the effective dSig/dz          |
                0027 C     |     SlopeX/Y     contains X/Y slopes                     |
                0028 C     |     taperFct     contains tapering funct. value ;        |
                0029 C     |                  = 1 when using no tapering              |
8233d0ceb9 Jean*0030 C     *==========================================================*
5b172de0d2 Jean*0031 C     \ev
                0032 
                0033 C     !USES:
f42e64b3e7 Jean*0034       IMPLICIT NONE
                0035 
                0036 C     == Global variables ==
                0037 #include "SIZE.h"
                0038 #include "EEPARAMS.h"
                0039 #include "GMREDI.h"
                0040 #include "PARAMS.h"
2092dbb101 Patr*0041 #ifdef ALLOW_AUTODIFF_TAMC
5b172de0d2 Jean*0042 # include "tamc.h"
2092dbb101 Patr*0043 #endif /* ALLOW_AUTODIFF_TAMC */
                0044 
5b172de0d2 Jean*0045 C     !INPUT/OUTPUT PARAMETERS:
14e0496834 Jean*0046       _RL taperX(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0047       _RL taperY(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0048       _RL SlopeX(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0049       _RL SlopeY(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0050       _RL dSigmaDrW(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0051       _RL dSigmaDrS(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0052       _RL LrhoW(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0053       _RL LrhoS(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
5b172de0d2 Jean*0054       _RL rDepth
8233d0ceb9 Jean*0055       INTEGER k,bi,bj,myThid
f42e64b3e7 Jean*0056 
                0057 #ifdef ALLOW_GMREDI
2092dbb101 Patr*0058 #ifdef GM_BOLUS_ADVEC
f42e64b3e7 Jean*0059 
5b172de0d2 Jean*0060 C     !LOCAL VARIABLES:
14e0496834 Jean*0061       _RL dSigmaDrLtd(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
5b172de0d2 Jean*0062       _RL f1, Smod, f2, Rnondim
f42e64b3e7 Jean*0063       _RL maxSlopeSqr
c1c6d46ee2 Jean*0064       _RL slopeCutoff
5b172de0d2 Jean*0065       _RL loc_maxSlope, loc_rMaxSlope
f42e64b3e7 Jean*0066       _RL fpi
5b172de0d2 Jean*0067       PARAMETER( fpi = PI )
                0068       INTEGER i, j
0f82b218cd Jean*0069 #ifdef GMREDI_WITH_STABLE_ADJOINT
5b172de0d2 Jean*0070       _RL slopeMaxSpec
0f82b218cd Jean*0071 #endif
7c50f07931 Mart*0072 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0073 C     kkey :: tape key (depends on levels and tiles)
                0074       INTEGER kkey
7c50f07931 Mart*0075 #endif
5b172de0d2 Jean*0076 CEOP
0f82b218cd Jean*0077 
                0078 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
f42e64b3e7 Jean*0079 
c1c6d46ee2 Jean*0080       slopeCutoff = SQRT( GM_slopeSqCutoff )
5b172de0d2 Jean*0081 C-    Note regarding slopeCutoff: current code by-passes the reduction of taper
                0082 C     fct when slope is larger than "slopeCutoff", and this is not very safe !
                0083 C     However, with default GM_Small_Number (=1.E-20) and default value of
                0084 C     GM_slopeSqCutoff (=1.E+48), this is unlikely to occur as it would require
                0085 C     |sigmaX/Y| > 1.e+4
                0086 
                0087       loc_maxSlope  = GM_maxSlope*wUnit2rVel(k)
                0088       loc_rMaxSlope = GM_rMaxSlope*rVel2wUnit(k)
c1c6d46ee2 Jean*0089 
2092dbb101 Patr*0090 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0091       kkey = bi + (bj-1)*nSx + (ikey_dynamics-1)*nSx*nSy
                0092       kkey = k + (kkey-1)*Nr
2092dbb101 Patr*0093 #endif /* ALLOW_AUTODIFF_TAMC */
                0094 
f42e64b3e7 Jean*0095       IF (GM_taper_scheme.EQ.'orig' .OR.
                0096      &    GM_taper_scheme.EQ.'clipping') THEN
                0097 
9cb619cfcd Patr*0098 #ifdef GM_EXCLUDE_CLIPPING
                0099 
                0100         STOP 'Need to compile without "#define GM_EXCLUDE_CLIPPING"'
                0101 
                0102 #else  /* GM_EXCLUDE_CLIPPING */
                0103 
f42e64b3e7 Jean*0104 C-      Original implementation in mitgcmuv
                0105 C       (this turns out to be the same as Cox slope clipping)
                0106 
2092dbb101 Patr*0107 C-- X-comp
                0108 
14e0496834 Jean*0109 #ifdef ALLOW_AUTODIFF
                0110         DO j=1-OLy,sNy+OLy
                0111          DO i=1-OLx+1,sNx+OLx
c1c6d46ee2 Jean*0112           dSigmaDrLtd(i,j) = 0. _d 0
                0113          ENDDO
                0114         ENDDO
14e0496834 Jean*0115 #endif /* ALLOW_AUTODIFF */
2092dbb101 Patr*0116 
f42e64b3e7 Jean*0117 C-      Cox 1987 "Slope clipping"
14e0496834 Jean*0118         DO j=1-OLy,sNy+OLy
                0119          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0120           dSigmaDrLtd(i,j) = GM_Small_Number
                0121      &     + ABS(SlopeX(i,j))*loc_rMaxSlope
2092dbb101 Patr*0122          ENDDO
                0123         ENDDO
                0124 #ifdef ALLOW_AUTODIFF_TAMC
c1c6d46ee2 Jean*0125 CADJ STORE dSigmaDrLtd(:,:)  = comlev1_bibj_k, key=kkey, byte=isbyte
2092dbb101 Patr*0126 CADJ STORE dSigmaDrW(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
                0127 #endif
14e0496834 Jean*0128         DO j=1-OLy,sNy+OLy
                0129          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0130           IF (dSigmaDrW(i,j).LE.dSigmaDrLtd(i,j))
c1c6d46ee2 Jean*0131      &        dSigmaDrW(i,j) = dSigmaDrLtd(i,j)
2092dbb101 Patr*0132          ENDDO
                0133         ENDDO
                0134 #ifdef ALLOW_AUTODIFF_TAMC
                0135 CADJ STORE dSigmaDrW(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
                0136 #endif
14e0496834 Jean*0137         DO j=1-OLy,sNy+OLy
                0138          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0139           SlopeX(i,j) = SlopeX(i,j)/dSigmaDrW(i,j)
07c79baaea Jean*0140           taperX(i,j) = 1. _d 0
2092dbb101 Patr*0141          ENDDO
                0142         ENDDO
f42e64b3e7 Jean*0143 
2092dbb101 Patr*0144 C-- Y-comp
f42e64b3e7 Jean*0145 
14e0496834 Jean*0146 #ifdef ALLOW_AUTODIFF
                0147         DO j=1-OLy+1,sNy+OLy
                0148          DO i=1-OLx,sNx+OLx
c1c6d46ee2 Jean*0149           dSigmaDrLtd(i,j) = 0. _d 0
                0150          ENDDO
                0151         ENDDO
14e0496834 Jean*0152 #endif /* ALLOW_AUTODIFF */
                0153         DO j=1-OLy+1,sNy+OLy
                0154          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0155           dSigmaDrLtd(i,j) = GM_Small_Number
                0156      &     + ABS(SlopeY(i,j))*loc_rMaxSlope
2092dbb101 Patr*0157          ENDDO
                0158         ENDDO
                0159 #ifdef ALLOW_AUTODIFF_TAMC
c1c6d46ee2 Jean*0160 CADJ STORE dSigmaDrLtd(:,:)  = comlev1_bibj_k, key=kkey, byte=isbyte
2092dbb101 Patr*0161 CADJ STORE dSigmaDrS(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
                0162 #endif
14e0496834 Jean*0163         DO j=1-OLy+1,sNy+OLy
                0164          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0165           IF (dSigmaDrS(i,j).LE.dSigmaDrLtd(i,j))
c1c6d46ee2 Jean*0166      &        dSigmaDrS(i,j) = dSigmaDrLtd(i,j)
2092dbb101 Patr*0167          ENDDO
                0168         ENDDO
                0169 #ifdef ALLOW_AUTODIFF_TAMC
                0170 CADJ STORE dSigmaDrS(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
                0171 #endif
14e0496834 Jean*0172         DO j=1-OLy+1,sNy+OLy
                0173          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0174           SlopeY(i,j) = SlopeY(i,j)/dSigmaDrS(i,j)
07c79baaea Jean*0175           taperY(i,j) = 1. _d 0
f42e64b3e7 Jean*0176          ENDDO
                0177         ENDDO
                0178 
9cb619cfcd Patr*0179 #endif /* GM_EXCLUDE_CLIPPING */
                0180 
5755dbe390 Patr*0181       ELSEIF (GM_taper_scheme.EQ.'fm07') THEN
                0182 
                0183         STOP 'GMREDI_SLOPE_PSI: AdvForm not yet implemented for fm07'
                0184 
f42e64b3e7 Jean*0185       ELSE
                0186 
9cb619cfcd Patr*0187 #ifdef GM_EXCLUDE_TAPERING
                0188 
                0189         STOP 'Need to compile without "#define GM_EXCLUDE_TAPERING"'
                0190 
                0191 #else  /* GM_EXCLUDE_TAPERING */
                0192 
2092dbb101 Patr*0193 #ifdef ALLOW_AUTODIFF_TAMC
                0194 CADJ STORE slopeX(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0195 CADJ STORE dSigmaDrW(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
                0196 #endif
                0197 
0f82b218cd Jean*0198 C- Compute the slope, no clipping, but avoid reverse slope in negatively
5b172de0d2 Jean*0199 C                                  stratified (dSigmaDr < 0) region :
14e0496834 Jean*0200         DO j=1-OLy,sNy+OLy
                0201          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0202           IF (dSigmaDrW(i,j).LE.GM_Small_Number)
                0203      &        dSigmaDrW(i,j) = GM_Small_Number
2092dbb101 Patr*0204          ENDDO
                0205         ENDDO
                0206 #ifdef ALLOW_AUTODIFF_TAMC
5b172de0d2 Jean*0207 CADJ STORE dsigmaDrW(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
2092dbb101 Patr*0208 #endif
14e0496834 Jean*0209         DO j=1-OLy,sNy+OLy
                0210          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0211           SlopeX(i,j) = SlopeX(i,j)/dSigmaDrW(i,j)
07c79baaea Jean*0212           taperX(i,j) = 1. _d 0
9cb619cfcd Patr*0213          ENDDO
                0214         ENDDO
                0215 #ifdef ALLOW_AUTODIFF_TAMC
5b172de0d2 Jean*0216 CADJ STORE slopeX(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
9cb619cfcd Patr*0217 #endif
d8ee9652bd Gael*0218         IF (GM_taper_scheme.NE.'stableGmAdjTap') THEN
5b172de0d2 Jean*0219          DO j=1-OLy,sNy+OLy
                0220           DO i=1-OLx+1,sNx+OLx
                0221            IF ( ABS(SlopeX(i,j)) .GE. slopeCutoff ) THEN
c1c6d46ee2 Jean*0222              SlopeX(i,j) = SIGN(slopeCutoff,SlopeX(i,j))
9cb619cfcd Patr*0223              taperX(i,j) = 0. _d 0
5b172de0d2 Jean*0224            ENDIF
                0225           ENDDO
2092dbb101 Patr*0226          ENDDO
d8ee9652bd Gael*0227         ENDIF
f42e64b3e7 Jean*0228 
2092dbb101 Patr*0229 #ifdef ALLOW_AUTODIFF_TAMC
                0230 CADJ STORE slopeY(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0231 CADJ STORE dSigmaDrS(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
                0232 #endif
f42e64b3e7 Jean*0233 
14e0496834 Jean*0234         DO j=1-OLy+1,sNy+OLy
                0235          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0236           IF (dSigmaDrS(i,j).LE.GM_Small_Number)
                0237      &        dSigmaDrS(i,j) = GM_Small_Number
2092dbb101 Patr*0238          ENDDO
                0239         ENDDO
                0240 #ifdef ALLOW_AUTODIFF_TAMC
5b172de0d2 Jean*0241 CADJ STORE dsigmaDrS(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
2092dbb101 Patr*0242 #endif
14e0496834 Jean*0243         DO j=1-OLy+1,sNy+OLy
                0244          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0245           SlopeY(i,j) = SlopeY(i,j)/dSigmaDrS(i,j)
07c79baaea Jean*0246           taperY(i,j) = 1. _d 0
f42e64b3e7 Jean*0247          ENDDO
                0248         ENDDO
9cb619cfcd Patr*0249 #ifdef ALLOW_AUTODIFF_TAMC
5b172de0d2 Jean*0250 CADJ STORE slopeY(:,:)    = comlev1_bibj_k, key=kkey, byte=isbyte
9cb619cfcd Patr*0251 #endif
d8ee9652bd Gael*0252         IF (GM_taper_scheme.NE.'stableGmAdjTap') THEN
5b172de0d2 Jean*0253          DO j=1-OLy+1,sNy+OLy
                0254           DO i=1-OLx,sNx+OLx
                0255            IF ( ABS(SlopeY(i,j)) .GE. slopeCutoff ) THEN
c1c6d46ee2 Jean*0256              SlopeY(i,j) = SIGN(slopeCutoff,SlopeY(i,j))
9cb619cfcd Patr*0257              taperY(i,j) = 0. _d 0
5b172de0d2 Jean*0258            ENDIF
                0259           ENDDO
9cb619cfcd Patr*0260          ENDDO
d8ee9652bd Gael*0261         ENDIF
14e0496834 Jean*0262 
f42e64b3e7 Jean*0263 C- Compute the tapering function for the GM+Redi tensor :
                0264 
2092dbb101 Patr*0265 #ifdef ALLOW_AUTODIFF_TAMC
                0266 CADJ STORE slopeX(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0267 CADJ STORE slopeY(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0268 #endif
                0269 
f42e64b3e7 Jean*0270        IF (GM_taper_scheme.EQ.'linear') THEN
                0271 
                0272 C-      Simplest adiabatic tapering = Smax/Slope (linear)
14e0496834 Jean*0273         DO j=1-OLy,sNy+OLy
                0274          DO i=1-OLx+1,sNx+OLx
c1c6d46ee2 Jean*0275           Smod = ABS(SlopeX(i,j))
5b172de0d2 Jean*0276           IF ( Smod .GT. loc_maxSlope .AND.
                0277      &         Smod .LT. slopeCutoff )
                0278      &      taperX(i,j) = loc_maxSlope/(Smod+GM_Small_Number)
c1c6d46ee2 Jean*0279          ENDDO
                0280         ENDDO
14e0496834 Jean*0281         DO j=1-OLy+1,sNy+OLy
                0282          DO i=1-OLx,sNx+OLx
c1c6d46ee2 Jean*0283           Smod = ABS(SlopeY(i,j))
5b172de0d2 Jean*0284           IF ( Smod .GT. loc_maxSlope .AND.
                0285      &         Smod .LT. slopeCutoff )
                0286      &      taperY(i,j) = loc_maxSlope/(Smod+GM_Small_Number)
f42e64b3e7 Jean*0287          ENDDO
                0288         ENDDO
                0289 
8233d0ceb9 Jean*0290        ELSEIF ( GM_taper_scheme.EQ.'gkw91' .OR.
                0291      &          GM_taper_scheme.EQ.'ac02' ) THEN
f42e64b3e7 Jean*0292 
                0293 C-      Gerdes, Koberle and Willebrand, Clim. Dyn. 1991
5b172de0d2 Jean*0294         maxSlopeSqr = loc_maxSlope*loc_maxSlope
14e0496834 Jean*0295         DO j=1-OLy,sNy+OLy
                0296          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0297           Smod = ABS(SlopeX(i,j))
                0298           IF ( Smod .GT. loc_maxSlope .AND.
                0299      &         Smod .LT. slopeCutoff )
                0300      &      taperX(i,j) = maxSlopeSqr/
9cb619cfcd Patr*0301      &           ( SlopeX(i,j)*SlopeX(i,j) + GM_Small_Number )
c1c6d46ee2 Jean*0302          ENDDO
                0303         ENDDO
14e0496834 Jean*0304         DO j=1-OLy+1,sNy+OLy
                0305          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0306           Smod = ABS(SlopeY(i,j))
                0307           IF ( Smod .GT. loc_maxSlope .AND.
                0308      &         Smod .LT. slopeCutoff )
                0309      &      taperY(i,j) = maxSlopeSqr/
9cb619cfcd Patr*0310      &           ( SlopeY(i,j)*SlopeY(i,j) + GM_Small_Number )
f42e64b3e7 Jean*0311          ENDDO
                0312         ENDDO
                0313 
                0314        ELSEIF (GM_taper_scheme.EQ.'dm95') THEN
                0315 
                0316 C-      Danabasoglu and McWilliams, J. Clim. 1995
14e0496834 Jean*0317         DO j=1-OLy,sNy+OLy
                0318          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0319           Smod = ABS(SlopeX(i,j))*rVel2wUnit(k)
                0320           taperX(i,j) = op5*( oneRL + TANH( (GM_Scrit-Smod)/GM_Sd ))
c1c6d46ee2 Jean*0321          ENDDO
                0322         ENDDO
14e0496834 Jean*0323         DO j=1-OLy+1,sNy+OLy
                0324          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0325           Smod = ABS(SlopeY(i,j))*rVel2wUnit(k)
                0326           taperY(i,j) = op5*( oneRL + TANH( (GM_Scrit-Smod)/GM_Sd ))
f42e64b3e7 Jean*0327          ENDDO
                0328         ENDDO
                0329 
                0330        ELSEIF (GM_taper_scheme.EQ.'ldd97') THEN
                0331 
                0332 C-      Large, Danabasoglu and Doney, JPO 1997
c1c6d46ee2 Jean*0333 
14e0496834 Jean*0334         DO j=1-OLy,sNy+OLy
                0335          DO i=1-OLx+1,sNx+OLx
c1c6d46ee2 Jean*0336           Smod = ABS(SlopeX(i,j))
                0337           IF ( Smod .LT. slopeCutoff ) THEN
5b172de0d2 Jean*0338             f1 = op5*( oneRL
                0339      &               + TANH( (GM_Scrit-Smod*rVel2wUnit(k))/GM_Sd ) )
                0340             IF ( Smod.NE.zeroRL ) THEN
                0341               Rnondim = rDepth/( LrhoW(i,j)*Smod )
07c79baaea Jean*0342             ELSE
5b172de0d2 Jean*0343               Rnondim = 1. _d 0
07c79baaea Jean*0344             ENDIF
5b172de0d2 Jean*0345             IF ( Rnondim.GE.oneRL ) THEN
07c79baaea Jean*0346               f2 = 1. _d 0
                0347             ELSE
5b172de0d2 Jean*0348               f2 = op5*( oneRL + SIN( fpi*(Rnondim-op5) ))
07c79baaea Jean*0349             ENDIF
5b172de0d2 Jean*0350             taperX(i,j) = f1*f2
c1c6d46ee2 Jean*0351           ENDIF
                0352          ENDDO
                0353         ENDDO
                0354 
14e0496834 Jean*0355         DO j=1-OLy+1,sNy+OLy
                0356          DO i=1-OLx,sNx+OLx
c1c6d46ee2 Jean*0357           Smod = ABS(SlopeY(i,j))
                0358           IF ( Smod .LT. slopeCutoff ) THEN
5b172de0d2 Jean*0359             f1 = op5*( oneRL
                0360      &               + TANH( (GM_Scrit-Smod*rVel2wUnit(k))/GM_Sd ) )
                0361             IF ( Smod.NE.zeroRL ) THEN
                0362               Rnondim = rDepth/( LrhoS(i,j)*Smod )
07c79baaea Jean*0363             ELSE
5b172de0d2 Jean*0364               Rnondim = 1. _d 0
07c79baaea Jean*0365             ENDIF
5b172de0d2 Jean*0366             IF ( Rnondim.GE.oneRL ) THEN
07c79baaea Jean*0367               f2 = 1. _d 0
                0368             ELSE
5b172de0d2 Jean*0369               f2 = op5*( oneRL + SIN( fpi*(Rnondim-op5) ))
07c79baaea Jean*0370             ENDIF
5b172de0d2 Jean*0371             taperY(i,j) = f1*f2
c1c6d46ee2 Jean*0372           ENDIF
f42e64b3e7 Jean*0373          ENDDO
                0374         ENDDO
                0375 
d8ee9652bd Gael*0376        ELSEIF (GM_taper_scheme.EQ.'stableGmAdjTap') THEN
9cb619cfcd Patr*0377 
d8ee9652bd Gael*0378 #ifndef GMREDI_WITH_STABLE_ADJOINT
f42e64b3e7 Jean*0379 
d8ee9652bd Gael*0380         STOP 'Need to compile wth "#define GMREDI_WITH_STABLE_ADJOINT"'
bc93e58d13 Gael*0381 
                0382 #else  /* GMREDI_WITH_STABLE_ADJOINT */
                0383 
d8ee9652bd Gael*0384 c special choice for adjoint/optimization of parameters
                0385 c (~ strong clipping, reducing non linearity of psi=f(K))
bc93e58d13 Gael*0386 
                0387         slopeMaxSpec=1. _d -4
                0388 
7448700841 Mart*0389 #ifdef ALLOW_AUTODIFF_TAMC
bc93e58d13 Gael*0390 CADJ STORE slopeX(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0391 CADJ STORE slopeY(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
7448700841 Mart*0392 #endif
14e0496834 Jean*0393         DO j=1-OLy,sNy+OLy
                0394          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0395           Smod = ABS(SlopeX(i,j))
                0396           IF ( Smod .GT. slopeMaxSpec ) THEN
                0397            SlopeX(i,j) = 5.*SlopeX(i,j)*slopeMaxSpec/Smod
                0398           ELSE
                0399            SlopeX(i,j) = 5.*SlopeX(i,j)
                0400           ENDIF
                0401           taperX(i,j) = 1.
bc93e58d13 Gael*0402          ENDDO
                0403         ENDDO
14e0496834 Jean*0404         DO j=1-OLy+1,sNy+OLy
                0405          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0406           Smod = ABS(SlopeY(i,j))
                0407           IF ( Smod .GT. slopeMaxSpec ) THEN
                0408            SlopeY(i,j) = 5.*SlopeY(i,j)*slopeMaxSpec/Smod
                0409           ELSE
                0410            SlopeY(i,j) = 5.*SlopeY(i,j)
                0411           ENDIF
                0412           taperY(i,j) = 1.
bc93e58d13 Gael*0413          ENDDO
                0414         ENDDO
                0415 #endif /* GMREDI_WITH_STABLE_ADJOINT */
                0416 
d8ee9652bd Gael*0417        ELSEIF (GM_taper_scheme.NE.' ') THEN
                0418         STOP 'GMREDI_SLOPE_PSI: Bad GM_taper_scheme'
                0419        ENDIF
                0420 
                0421 #endif /* GM_EXCLUDE_TAPERING */
                0422 
                0423       ENDIF
                0424 
2092dbb101 Patr*0425 #endif /* BOLUS_ADVEC */
f42e64b3e7 Jean*0426 #endif /* ALLOW_GMREDI */
                0427 
                0428       RETURN
                0429       END
[ 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!