pkg/mom_vecinv/mom_vi_u_vertshear.F

cec2469d72 Alis*0001 #include "MOM_VECINV_OPTIONS.h"
aea29c8517 Alis*0002
31fb0e0e6d Jean*0003 CBOP
                0004 C     !ROUTINE: MOM_VI_U_VERTSHEAR
                0005
                0006 C     !INTERFACE:
aea29c8517 Alis*0007       SUBROUTINE MOM_VI_U_VERTSHEAR(
31fb0e0e6d Jean*0008      I        bi, bj, k, deepFacA,
                0009      I        uFld, wFld,
aea29c8517 Alis*0010      U        uShearTerm,
31fb0e0e6d Jean*0011      I        myThid )
                0012
                0013 C     !DESCRIPTION:
cf9761f7d1 Jean*0014 C     *==========================================================*
                0015 C     | S/R MOM_U_VERTSHEAR
                0016 C     *==========================================================*
aea29c8517 Alis*0017
31fb0e0e6d Jean*0018 C     !USES:
                0019       IMPLICIT NONE
aea29c8517 Alis*0020 C     == Global variables ==
                0021 #include "SIZE.h"
                0022 #include "EEPARAMS.h"
                0023 #include "GRID.h"
                0024 #include "PARAMS.h"
                0025
31fb0e0e6d Jean*0026 C     !INPUT/OUTPUT PARAMETERS:
                0027 C  deepFacA             :: deep-model grid factor at level center
                0028       INTEGER bi, bj, k
                0029       _RL deepFacA(Nr)
aea29c8517 Alis*0030       _RL uFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0031       _RL wFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy)
                0032       _RL uShearTerm(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0033       INTEGER myThid
                0034
31fb0e0e6d Jean*0035 C     !LOCAL VARIABLES:
                0036       INTEGER i, j, kp1, km1
                0037       _RL mask_Kp1, mask_Km1, wBarXm, wBarXp
                0038       _RL uZm, uZp, recip_drDeepRho
                0039       LOGICAL rAdvAreaWeight
                0040 c     _RL umask_Kp1,umask_K,umask_Km1
                0041 c1    _RL wBarXZ,uZbarZ
                0042 CEOP
aea29c8517 Alis*0043
b8082fc644 Jean*0044       rAdvAreaWeight =.TRUE.
                0045 C-    Area-weighted average either in KE or in vert. advection:
                0046       IF ( selectKEscheme.EQ.1 .OR. selectKEscheme.EQ.3 )
                0047      &  rAdvAreaWeight =.FALSE.
                0048
31fb0e0e6d Jean*0049       kp1 = MIN(k+1,Nr)
                0050       mask_Kp1 = oneRL
                0051       IF (k.EQ.Nr) mask_Kp1 = zeroRL
                0052       km1 = MAX(k-1,1)
                0053       mask_Km1 = oneRL
                0054       IF (k.EQ.1) mask_Km1 = zeroRL
                0055
                0056       recip_drDeepRho = recip_drF(k)/deepFacA(k)
                0057      &                * recip_deepFac2C(k)*recip_rhoFacC(k)
aea29c8517 Alis*0058
31fb0e0e6d Jean*0059       DO j=1-OLy,sNy+OLy
                0060        DO i=2-OLx,sNx+OLx
aea29c8517 Alis*0061
627b8cb06f Jean*0062 c       umask_K=_maskW(i,j,k,bi,bj)
aea29c8517 Alis*0063
                0064 C barZ( barX( W ) )
                0065 c       wBarXm=0.5*(wFld(I,J,K,bi,bj)+wFld(I-1,J,K,bi,bj))
                0066 c       wBarXp=0.5*(wFld(I,J,Kp1,bi,bj)+wFld(I-1,J,Kp1,bi,bj))
                0067 c    &         *mask_Kp1
                0068
cf9761f7d1 Jean*0069        IF ( rAdvAreaWeight ) THEN
31fb0e0e6d Jean*0070 C     Transport at interface k : Area weighted average
                0071         wBarXm = halfRL*(
                0072      &     wFld(i,j,k,bi,bj)*rA(i,j,bi,bj)*maskC(i,j,km1,bi,bj)
                0073      &   + wFld(i-1,j,k,bi,bj)*rA(i-1,j,bi,bj)*maskC(i-1,j,km1,bi,bj)
                0074      &                  )*mask_Km1*deepFac2F(k)*rhoFacF(k)
                0075      &                   *recip_rAw(i,j,bi,bj)
                0076
                0077 C     Transport at interface k+1 (here wFld is already masked)
                0078         wBarXp = halfRL*(
                0079      &     wFld(i,j,kp1,bi,bj)*rA(i,j,bi,bj)
                0080      &   + wFld(i-1,j,kp1,bi,bj)*rA(i-1,j,bi,bj)
                0081      &                  )*mask_Kp1*deepFac2F(kp1)*rhoFacF(kp1)
                0082      &                   *recip_rAw(i,j,bi,bj)
cf9761f7d1 Jean*0083        ELSE
31fb0e0e6d Jean*0084 C     Transport at interface k : simple average
                0085         wBarXm = halfRL*(
                0086      &     wFld(i,j,k,bi,bj)*maskC(i,j,km1,bi,bj)
                0087      &   + wFld(i-1,j,k,bi,bj)*maskC(i-1,j,km1,bi,bj)
                0088      &                  )*mask_Km1*deepFac2F(k)*rhoFacF(k)
                0089
                0090 C     Transport at interface k+1 (here wFld is already masked)
                0091         wBarXp = halfRL*(
                0092      &     wFld(i,j,kp1,bi,bj)
                0093      &   + wFld(i-1,j,kp1,bi,bj)
                0094      &                  )*mask_Kp1*deepFac2F(kp1)*rhoFacF(kp1)
cf9761f7d1 Jean*0095        ENDIF
aea29c8517 Alis*0096
31fb0e0e6d Jean*0097 C-    delta_Z( U*deepFac )  @ interface k
23571d7948 Jean*0098 c       umask_Km1=mask_Km1*maskW(i,j,Km1,bi,bj)
31fb0e0e6d Jean*0099         uZm = ( uFld(i,j, k ,bi,bj)*deepFacA( k )
                0100      &        - uFld(i,j,km1,bi,bj)*deepFacA(km1)*mask_Km1 )*rkSign
aea29c8517 Alis*0101 c2   &      *recip_dRC(K)
23571d7948 Jean*0102 c       IF (freeslip1) uZm=uZm*umask_Km1
                0103 c       IF (noslip1.AND.umask_Km1.EQ.0.) uZm=uZm*2.
aea29c8517 Alis*0104
31fb0e0e6d Jean*0105 C-    delta_Z( U*deepFac )  @ interface k+1
23571d7948 Jean*0106 c       umask_Kp1=mask_Kp1*maskW(i,j,Kp1,bi,bj)
31fb0e0e6d Jean*0107         uZp = ( uFld(i,j,kp1,bi,bj)*deepFacA(kp1)*mask_Kp1
                0108      &        - uFld(i,j, k ,bi,bj)*deepFacA( k ) )*rkSign
aea29c8517 Alis*0109 c2   &      *recip_dRC(Kp1)
23571d7948 Jean*0110 c       IF (freeslipK) uZp=uZp*umask_Kp1
                0111 c       IF (noslipK.AND.umask_Kp1.EQ.0.) uZp=uZp*2.
aea29c8517 Alis*0112
                0113 c1      IF (upwindShear) THEN
                0114 c1       wBarXZ=0.5*( wBarXm + wBarXp )
                0115 c1       IF (wBarXZ.GT.0.) THEN
                0116 c1        uZbarZ=uZp
                0117 c1       ELSE
                0118 c1        uZbarZ=uZm
                0119 c1       ENDIF
                0120 c1      ELSE
                0121 c1       uZbarZ=0.5*(uZm+uZp)
                0122 c1      ENDIF
                0123 c1      uShearTerm(I,J)=-wBarXZ*uZbarZ*_maskW(I,J,K,bi,bj)
                0124
                0125 c2      uShearTerm(I,J)=-0.5*(wBarXp*uZp+wBarXm*uZm)
                0126 c2   &                  *_maskW(I,J,K,bi,bj)
3bb7e60d5f Jean*0127         IF (upwindShear) THEN
31fb0e0e6d Jean*0128          uShearTerm(i,j) = -halfRL*
                0129      &                  (    (     wBarXp *uZp +     wBarXm *uZm )
                0130      &                     + ( ABS(wBarXp)*uZp - ABS(wBarXm)*uZm )
                0131      &                  )*_recip_hFacW(i,j,k,bi,bj)*recip_drDeepRho
3bb7e60d5f Jean*0132         ELSE
31fb0e0e6d Jean*0133          uShearTerm(i,j) = -halfRL*( wBarXp*uZp + wBarXm*uZm )
                0134      &                   *_recip_hFacW(i,j,k,bi,bj)*recip_drDeepRho
3bb7e60d5f Jean*0135         ENDIF
aea29c8517 Alis*0136        ENDDO
                0137       ENDDO
                0138
                0139       RETURN
                0140       END