pkg/mom_fluxform/mom_calc_rtrans.F

6d54cf9ca1 Ed H*0001 #include "MOM_FLUXFORM_OPTIONS.h"
bd2e80b12f Jean*0002
                0003 CBOP
                0004 C     !ROUTINE: MOM_CALC_RTRANS
eaba2fd266 Jean*0005 C     !INTERFACE:
                0006       SUBROUTINE MOM_CALC_RTRANS(
bd2e80b12f Jean*0007      I                          k, bi, bj,
                0008      O                          rTransU, rTransV,
                0009      I                          myTime, myIter, myThid)
                0010 C     !DESCRIPTION: \bv
                0011 C     *==========================================================*
eaba2fd266 Jean*0012 C     | SUBROUTINE MOM_CALC_RTRANS
                0013 C     | o Calculate vertical transports at interface k
bd2e80b12f Jean*0014 C     |   above U & V points (West & South face)
                0015 C     *==========================================================*
                0016 C     | r coordinate (z or p):
                0017 C     |  is simply half of the 2 vert. Transp at Center location
                0018 C     | r* coordinate: less simple since
                0019 C     |  d.eta/dt / H has to be evaluated locally at U & V points
                0020 C     *==========================================================*
                0021 C     \ev
                0022
                0023 C     !USES:
                0024       IMPLICIT NONE
                0025 C     == GLobal variables ==
                0026 #include "SIZE.h"
                0027 #include "DYNVARS.h"
                0028 #include "EEPARAMS.h"
                0029 #include "PARAMS.h"
                0030 #include "GRID.h"
                0031 #include "SURFACE.h"
aa2d1573fa Patr*0032 #include "MOM_FLUXFORM.h"
bd2e80b12f Jean*0033
                0034 C     !INPUT/OUTPUT PARAMETERS:
                0035 C     == Routine arguments ==
                0036 C     k       :: vertical level
                0037 C     bi,bj   :: tile indices
                0038 C     rTransU :: vertical transport (above U point)
                0039 C     rTransV :: vertical transport (above V point)
                0040 C     myTime  :: current time
                0041 C     myIter  :: current iteration number
eaba2fd266 Jean*0042 C     myThid  :: thread number
                0043
bd2e80b12f Jean*0044       INTEGER k, bi, bj, myIter, myThid
                0045       _RL myTime
                0046       _RL rTransU(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0047       _RL rTransV(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0048
                0049 C     !LOCAL VARIABLES:
                0050 #ifdef NONLIN_FRSURF
                0051 C     == Local variables in common block ==
                0052 C     dWtransC :: vertical transp. difference between r & r* coordinates
                0053 C     dWtransU :: same but above u.point location (West  face)
                0054 C     dWtransV :: same but above v.point location (South face)
aa2d1573fa Patr*0055 cph need this in a header for the adjoint
eaba2fd266 Jean*0056 cph      COMMON /LOCAL_MOM_CALC_RTRANS/
aa2d1573fa Patr*0057 cph     &       dWtransC, dWtransU, dWtransV
eaba2fd266 Jean*0058 cph      _RL dWtransC(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0059 cph      _RL dWtransU(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0060 cph      _RL dWtransV(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
bd2e80b12f Jean*0061 #endif /* NONLIN_FRSURF */
                0062 C     == Local variables ==
                0063 C     I, J :: Loop counters
                0064       INTEGER i,j
                0065 CEOP
                0066
                0067 #ifdef NONLIN_FRSURF
                0068       IF ( k.EQ.Nr+1 .AND.
9669509dca Jean*0069      &     useRealFreshWaterFlux .AND. usingPCoords ) THEN
eaba2fd266 Jean*0070 C note: deep-model not implemented for P-coordinate + realFreshWaterFlux ;
                0071 C       anelastic: always assumes that rhoFacF(1) = 1
bd2e80b12f Jean*0072         DO j=1-OLy+1,sNy+OLy
                0073          DO i=1-OLx+1,sNx+OLx
3da6675e68 Jean*0074           rTransU(i,j) = mass2rUnit*
bd2e80b12f Jean*0075      &      0.5 _d 0*( PmEpR( i ,j,bi,bj)*rA( i ,j,bi,bj)
                0076      &                +PmEpR(i-1,j,bi,bj)*rA(i-1,j,bi,bj) )
3da6675e68 Jean*0077           rTransV(i,j) = mass2rUnit*
bd2e80b12f Jean*0078      &      0.5 _d 0*( PmEpR(i, j ,bi,bj)*rA(i, j ,bi,bj)
                0079      &                +PmEpR(i,j-1,bi,bj)*rA(i,j-1,bi,bj) )
                0080          ENDDO
                0081         ENDDO
                0082       ELSEIF ( k.GT.Nr ) THEN
                0083 #else /* NONLIN_FRSURF */
                0084        IF ( k.GT.Nr ) THEN
                0085 #endif /* NONLIN_FRSURF */
                0086         DO j=1-OLy+1,sNy+OLy
                0087          DO i=1-OLx+1,sNx+OLx
                0088           rTransU(i,j) = 0.
                0089           rTransV(i,j) = 0.
                0090          ENDDO
                0091         ENDDO
                0092       ELSE
                0093 C-    Calculate vertical transports above U & V points (West & South face):
                0094         DO j=1-OLy+1,sNy+OLy
                0095          DO i=1-OLx+1,sNx+OLx
                0096           rTransU(i,j) =
eaba2fd266 Jean*0097      &         0.5 _d 0*( wVel(i-1,j,k,bi,bj)*rA(i-1,j,bi,bj)
                0098      &                   +wVel( i ,j,k,bi,bj)*rA( i ,j,bi,bj)
                0099      &                  )*deepFac2F(k)*rhoFacF(k)
bd2e80b12f Jean*0100           rTransV(i,j) =
eaba2fd266 Jean*0101      &         0.5 _d 0*( wVel(i,j-1,k,bi,bj)*rA(i,j-1,bi,bj)
                0102      &                   +wVel(i, j ,k,bi,bj)*rA(i, j ,bi,bj)
                0103      &                  )*deepFac2F(k)*rhoFacF(k)
bd2e80b12f Jean*0104          ENDDO
                0105         ENDDO
eaba2fd266 Jean*0106       ENDIF
bd2e80b12f Jean*0107
                0108 #ifdef NONLIN_FRSURF
                0109 C---  Modify rTransU & rTransV when using r* coordinate:
eaba2fd266 Jean*0110 C     note: not implemented neither for anelastic nor deep-model.
bd2e80b12f Jean*0111       IF ( select_rStar.NE.0 ) THEN
cdc9f269ae Patr*0112 # ifndef DISABLE_RSTAR_CODE
bd2e80b12f Jean*0113
                0114        IF ( k.EQ.1) THEN
                0115 C-    Initialise dWtrans :
                0116         DO j=1-OLy,sNy+OLy
                0117          DO i=1-OLx,sNx+OLx
                0118           dWtransC(i,j,bi,bj) = rStarDhCDt(i,j,bi,bj)
                0119      &         *(Ro_surf(i,j,bi,bj)-R_low(i,j,bi,bj))
                0120      &         *rA(i,j,bi,bj)
                0121          ENDDO
                0122         ENDDO
                0123         DO j=1-OLy+1,sNy+OLy
                0124          DO i=1-OLx+1,sNx+OLx
eaba2fd266 Jean*0125           dWtransU(i,j,bi,bj) =
bd2e80b12f Jean*0126      &          0.5 _d 0*(dWtransC(i-1,j,bi,bj)+dWtransC(i,j,bi,bj))
                0127           dWtransV(i,j,bi,bj) =
                0128      &          0.5 _d 0*(dWtransC(i,j-1,bi,bj)+dWtransC(i,j,bi,bj))
                0129          ENDDO
                0130         ENDDO
                0131
                0132        ELSEIF (k.LE.Nr) THEN
                0133 C-    Update dWtrans from previous value (interface k-1):
                0134         DO j=1-OLy,sNy+OLy
                0135          DO i=1-OLx,sNx+OLx
                0136           dWtransC(i,j,bi,bj) = dWtransC(i,j,bi,bj)
                0137      &     - rStarDhCDt(i,j,bi,bj)*drF(k-1)*h0FacC(i,j,k-1,bi,bj)
                0138      &                            *rA(i,j,bi,bj)
                0139          ENDDO
                0140         ENDDO
                0141         DO j=1-OLy+1,sNy+OLy
                0142          DO i=1-OLx+1,sNx+OLx
                0143           dWtransU(i,j,bi,bj) = dWtransU(i,j,bi,bj)
                0144      &     - rStarDhWDt(i,j,bi,bj)*drF(k-1)*h0FacW(i,j,k-1,bi,bj)
                0145      &                            *rAw(i,j,bi,bj)
                0146           dWtransV(i,j,bi,bj) = dWtransV(i,j,bi,bj)
                0147      &     - rStarDhSDt(i,j,bi,bj)*drF(k-1)*h0FacS(i,j,k-1,bi,bj)
                0148      &                            *rAs(i,j,bi,bj)
                0149          ENDDO
                0150         ENDDO
                0151 C-    Modify rTransU & rTransV :
                0152         DO j=1-OLy+1,sNy+OLy
                0153          DO i=1-OLx+1,sNx+OLx
                0154           rTransU(i,j) = rTransU(i,j)-dWtransU(i,j,bi,bj)
                0155      &       + (dWtransC(i-1,j,bi,bj)+dWtransC(i,j,bi,bj))*0.5 _d 0
                0156           rTransV(i,j) = rTransV(i,j)-dWtransV(i,j,bi,bj)
                0157      &       + (dWtransC(i,j-1,bi,bj)+dWtransC(i,j,bi,bj))*0.5 _d 0
                0158          ENDDO
                0159         ENDDO
                0160
                0161        ENDIF
                0162
cdc9f269ae Patr*0163 # endif /* DISABLE_RSTAR_CODE */
bd2e80b12f Jean*0164       ENDIF
cdc9f269ae Patr*0165
bd2e80b12f Jean*0166 #endif /* NONLIN_FRSURF */
                0167
                0168       RETURN
                0169       END