pkg/mom_vecinv/mom_vi_u_vertshear.F

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