pkg/gmredi/gmredi_calc_psi_bolus.F

f42e64b3e7 Jean*0001 #include "GMREDI_OPTIONS.h"
14e0496834 Jean*0002 #ifdef ALLOW_AUTODIFF
                0003 # include "AUTODIFF_OPTIONS.h"
                0004 #endif
ee8a6f4ffb Jean*0005 #ifdef ALLOW_CTRL
                0006 # include "CTRL_OPTIONS.h"
                0007 #endif
472f570611 Jean*0008 #if ( defined GM_READ_K3D_GM   || defined GM_VISBECK_VARIABLE_K \
                0009       || defined ALLOW_GM_LEITH_QG || defined GM_BATES_K3D )
                0010 # define GM_USE_K3D_GM
                0011 #endif
f42e64b3e7 Jean*0012
f6de204bec Jean*0013 CBOP
d1eb4480d0 Jean*0014 C     !ROUTINE: GMREDI_CALC_PSI_BOLUS
f6de204bec Jean*0015 C     !INTERFACE:
d1eb4480d0 Jean*0016       SUBROUTINE GMREDI_CALC_PSI_BOLUS(
f42e64b3e7 Jean*0017      I             bi, bj, iMin, iMax, jMin, jMax,
472f570611 Jean*0018      I             sigmaX, sigmaY, sigmaR, locK3dGM,
c1c6d46ee2 Jean*0019      I             ldd97_LrhoW, ldd97_LrhoS,
f42e64b3e7 Jean*0020      I             myThid )
f6de204bec Jean*0021
                0022 C     !DESCRIPTION: \bv
                0023 C     *==========================================================*
d1eb4480d0 Jean*0024 C     | SUBROUTINE GMREDI_CALC_PSI_BOLUS
f6de204bec Jean*0025 C     | o Calculate stream-functions for GM bolus velocity
                0026 C     *==========================================================*
                0027 C     \ev
                0028
                0029 C     !USES:
f42e64b3e7 Jean*0030       IMPLICIT NONE
                0031
                0032 C     == Global variables ==
                0033 #include "SIZE.h"
                0034 #include "GRID.h"
                0035 #include "DYNVARS.h"
                0036 #include "EEPARAMS.h"
                0037 #include "PARAMS.h"
                0038 #include "GMREDI.h"
43af9695da Gael*0039 #include "FFIELDS.h"
ee8a6f4ffb Jean*0040 #ifdef ALLOW_CTRL
                0041 # include "CTRL_FIELDS.h"
                0042 #endif
2092dbb101 Patr*0043 #ifdef ALLOW_AUTODIFF_TAMC
5b172de0d2 Jean*0044 # include "tamc.h"
2092dbb101 Patr*0045 #endif /* ALLOW_AUTODIFF_TAMC */
                0046
f6de204bec Jean*0047 C     !INPUT/OUTPUT PARAMETERS:
ee8a6f4ffb Jean*0048       _RL sigmaX(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr)
                0049       _RL sigmaY(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr)
                0050       _RL sigmaR(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr)
472f570611 Jean*0051 #ifdef GM_USE_K3D_GM
                0052       _RL locK3dGM(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr)
                0053 #else
                0054       _RL locK3dGM(1)
                0055 #endif
ee8a6f4ffb Jean*0056       _RL ldd97_LrhoW(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0057       _RL ldd97_LrhoS(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
f42e64b3e7 Jean*0058       INTEGER bi,bj,iMin,iMax,jMin,jMax
                0059       INTEGER myThid
f6de204bec Jean*0060 CEOP
f42e64b3e7 Jean*0061
                0062 #ifdef ALLOW_GMREDI
                0063 #ifdef GM_BOLUS_ADVEC
                0064
f6de204bec Jean*0065 C     !LOCAL VARIABLES:
f42e64b3e7 Jean*0066       INTEGER i,j,k, km1
7c50f07931 Mart*0067 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0068 C     tkey :: tape key (depends on tiles)
                0069 C     kkey :: tape key (depends on levels and tiles)
                0070       INTEGER tkey, kkey
7c50f07931 Mart*0071 #endif
5b172de0d2 Jean*0072       _RL halfSign
                0073       _RL rDepth, half_K
ee8a6f4ffb Jean*0074       _RL SlopeX(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0075       _RL SlopeY(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0076       _RL dSigmaDrW(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0077       _RL dSigmaDrS(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0078       _RL taperX(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0079       _RL taperY(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
f42e64b3e7 Jean*0080
                0081 C-    Initialization : <= done in S/R gmredi_init
                0082
2092dbb101 Patr*0083 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0084       tkey = bi + (bj-1)*nSx + (ikey_dynamics-1)*nSx*nSy
2092dbb101 Patr*0085 #endif /* ALLOW_AUTODIFF_TAMC */
                0086
f42e64b3e7 Jean*0087       IF (GM_AdvForm) THEN
5b172de0d2 Jean*0088 C     change sign of vertical Sigma gradient to match stratification sign
                0089        halfSign = halfRL*gravitySign
                0090
f42e64b3e7 Jean*0091        DO k=2,Nr
8233d0ceb9 Jean*0092         km1 = k-1
2092dbb101 Patr*0093
14e0496834 Jean*0094 #ifdef ALLOW_AUTODIFF
8233d0ceb9 Jean*0095         DO j=1-OLy,sNy+OLy
                0096          DO i=1-OLx,sNx+OLx
                0097           SlopeX(i,j)       = 0. _d 0
                0098           SlopeY(i,j)       = 0. _d 0
                0099           dSigmaDrW(i,j)    = 0. _d 0
                0100           dSigmaDrS(i,j)    = 0. _d 0
                0101          ENDDO
2092dbb101 Patr*0102         ENDDO
                0103 #endif
f42e64b3e7 Jean*0104
                0105 C      Gradient of Sigma below U and V points
8233d0ceb9 Jean*0106         DO j=1-OLy,sNy+OLy
                0107          DO i=1-OLx+1,sNx+OLx
5b172de0d2 Jean*0108           SlopeX(i,j) = ( sigmaX(i,j,km1)+sigmaX(i,j,k) )*halfRL
8233d0ceb9 Jean*0109      &                   *maskW(i,j,km1,bi,bj)*maskW(i,j,k,bi,bj)
5b172de0d2 Jean*0110           dSigmaDrW(i,j) = ( sigmaR(i-1,j,k)+sigmaR(i,j,k) )*halfSign
8233d0ceb9 Jean*0111      &                   *maskW(i,j,km1,bi,bj)*maskW(i,j,k,bi,bj)
                0112          ENDDO
c1c6d46ee2 Jean*0113         ENDDO
8233d0ceb9 Jean*0114         DO j=1-OLy+1,sNy+OLy
                0115          DO i=1-OLx,sNx+OLx
5b172de0d2 Jean*0116           SlopeY(i,j) = ( sigmaY(i,j,km1)+sigmaY(i,j,k) )*halfRL
8233d0ceb9 Jean*0117      &                   *maskS(i,j,km1,bi,bj)*maskS(i,j,k,bi,bj)
5b172de0d2 Jean*0118           dSigmaDrS(i,j) = ( sigmaR(i,j-1,k)+sigmaR(i,j,k) )*halfSign
8233d0ceb9 Jean*0119      &                   *maskS(i,j,km1,bi,bj)*maskS(i,j,k,bi,bj)
                0120          ENDDO
c1c6d46ee2 Jean*0121         ENDDO
f42e64b3e7 Jean*0122
5b172de0d2 Jean*0123 C      set "rDepth" (= depth from the surface, in rUnit) for 'ldd97' tapering
                0124         IF ( usingZcoords ) THEN
                0125          rDepth = rF(1) - rF(k)
                0126         ELSE
                0127          rDepth = rF(k) - rF(Nr+1)
                0128         ENDIF
c1c6d46ee2 Jean*0129 C      Calculate slopes , taper and/or clip
8233d0ceb9 Jean*0130         CALL GMREDI_SLOPE_PSI(
                0131      O              taperX, taperY,
                0132      U              SlopeX, SlopeY,
                0133      U              dSigmaDrW, dSigmaDrS,
5b172de0d2 Jean*0134      I              ldd97_LrhoW, ldd97_LrhoS, rDepth, k,
8233d0ceb9 Jean*0135      I              bi, bj, myThid )
f42e64b3e7 Jean*0136
2092dbb101 Patr*0137 #ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0138         kkey = k + (tkey-1)*Nr
2092dbb101 Patr*0139 CADJ STORE SlopeX(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0140 CADJ STORE SlopeY(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0141 CADJ STORE taperX(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0142 CADJ STORE taperY(:,:)       = comlev1_bibj_k, key=kkey, byte=isbyte
                0143 #endif /* ALLOW_AUTODIFF_TAMC */
                0144
f6de204bec Jean*0145 C-  Compute the 2 stream-function Components ( GM bolus vel.)
8233d0ceb9 Jean*0146 C   Note: since SlopeX,Y have been masked, no needs to mask again GM_PsiX,Y
                0147         half_K = GM_background_K
f6de204bec Jean*0148      &         *(GM_bolFac1d(km1)+GM_bolFac1d(k))*op25
8233d0ceb9 Jean*0149         DO j=1-OLy,sNy+OLy
                0150          DO i=1-OLx+1,sNx+OLx
c1c6d46ee2 Jean*0151           GM_PsiX(i,j,k,bi,bj) = SlopeX(i,j)*taperX(i,j)
472f570611 Jean*0152 #ifdef GM_USE_K3D_GM
94a8024bbe Jean*0153      &     *( op25
472f570611 Jean*0154      &        *( locK3dGM(i-1,j,km1)+locK3dGM(i,j,km1)
                0155      &         + locK3dGM(i-1,j,k)+locK3dGM(i,j,k) )
f6de204bec Jean*0156 #else
                0157      &     *( half_K
                0158      &          *(GM_bolFac2d(i-1,j,bi,bj)+GM_bolFac2d(i,j,bi,bj))
5116830959 Patr*0159 #endif
a4576c7cde Juli*0160 #ifdef GM_GEOM_VARIABLE_K
                0161      &      + op5*(GEOM_K3d(i-1,j,k,bi,bj)+GEOM_K3d(i,j,k,bi,bj))
                0162 #endif
8233d0ceb9 Jean*0163      &      )
                0164 c    &       *maskW(i,j,km1,bi,bj)*maskW(i,j,k,bi,bj)
43af9695da Gael*0165 #ifdef ALLOW_EDDYPSI
                0166      &     +eddyPsiX(i,j,k,bi,bj)*maskW(i,j,k,bi,bj)
                0167 #endif
8233d0ceb9 Jean*0168          ENDDO
c1c6d46ee2 Jean*0169         ENDDO
8233d0ceb9 Jean*0170         DO j=1-OLy+1,sNy+OLy
                0171          DO i=1-OLx,sNx+OLx
                0172           GM_PsiY(i,j,k,bi,bj) = SlopeY(i,j)*taperY(i,j)
472f570611 Jean*0173 #ifdef GM_USE_K3D_GM
94a8024bbe Jean*0174      &     *( op25
472f570611 Jean*0175      &        *( locK3dGM(i,j-1,km1)+locK3dGM(i,j,km1)
                0176      &         + locK3dGM(i,j-1,k)+locK3dGM(i,j,k) )
f6de204bec Jean*0177 #else
                0178      &     *( half_K
                0179      &          *(GM_bolFac2d(i,j-1,bi,bj)+GM_bolFac2d(i,j,bi,bj))
5116830959 Patr*0180 #endif
a4576c7cde Juli*0181 #ifdef GM_GEOM_VARIABLE_K
                0182      &      + op5*(GEOM_K3d(i,j-1,k,bi,bj)+GEOM_K3d(i,j,k,bi,bj))
                0183 #endif
8233d0ceb9 Jean*0184      &      )
                0185 c    &       *maskS(i,j,km1,bi,bj)*maskS(i,j,k,bi,bj)
43af9695da Gael*0186 #ifdef ALLOW_EDDYPSI
                0187      &     +eddyPsiY(i,j,k,bi,bj)*maskS(i,j,k,bi,bj)
                0188 #endif
8233d0ceb9 Jean*0189          ENDDO
c1c6d46ee2 Jean*0190         ENDDO
f42e64b3e7 Jean*0191
c1c6d46ee2 Jean*0192 C----- end of loop on level k
f42e64b3e7 Jean*0193        ENDDO
c1c6d46ee2 Jean*0194
8233d0ceb9 Jean*0195 C     end if GM_AdvForm block
f42e64b3e7 Jean*0196       ENDIF
                0197 #endif /* GM_BOLUS_ADVEC */
                0198 #endif /* ALLOW_GMREDI */
                0199
                0200       RETURN
                0201       END