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