model/src/update_sigma.F

a2a20dcddc Jean*0001 #include "PACKAGES_CONFIG.h"
                0002 #include "CPP_OPTIONS.h"
02d90fb24c Jean*0003 c#ifdef ALLOW_AUTODIFF
                0004 c# include "AUTODIFF_OPTIONS.h"
                0005 c#endif
a2a20dcddc Jean*0006
                0007 CBOP
                0008 C     !ROUTINE: UPDATE_SIGMA
                0009 C     !INTERFACE:
                0010       SUBROUTINE UPDATE_SIGMA( etaHc, myTime, myIter, myThid )
                0011 C     !DESCRIPTION: \bv
                0012 C     *==========================================================*
                0013 C     | SUBROUTINE UPDATE_SIGMA
                0014 C     | o Update the thickness fractions (hFacC,W,S)
                0015 C     |   according to the surface r-position = Non-Linear FrSurf
                0016 C     *==========================================================*
                0017 C     \ev
                0018
                0019 C     !USES:
                0020       IMPLICIT NONE
                0021 C     == Global variables
                0022 #include "SIZE.h"
                0023 #include "EEPARAMS.h"
                0024 #include "PARAMS.h"
                0025 c #include "DYNVARS.h"
                0026 #include "GRID.h"
                0027 #include "SURFACE.h"
02d90fb24c Jean*0028 c#ifdef ALLOW_AUTODIFF_TAMC
                0029 c# include "tamc.h"
                0030 c#endif
a2a20dcddc Jean*0031
                0032 C     !INPUT/OUTPUT PARAMETERS:
                0033 C     == Routine arguments ==
                0034 C     etaHc  :: surface r-anomaly at grid cell center
                0035 C     myTime :: Current time in simulation
                0036 C     myIter :: Current iteration number in simulation
                0037 C     myThid :: my Thread Id. number
                0038       _RL etaHc(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0039       _RL myTime
                0040       INTEGER myIter
                0041       INTEGER myThid
                0042
                0043 #ifdef NONLIN_FRSURF
                0044 c#ifndef DISABLE_SIGMA_CODE
                0045 C     !LOCAL VARIABLES:
                0046 C     Local variables
                0047 C     bi, bj     :: tile indices
                0048 C     i, j, k    :: Loop counters
                0049 C     rEmpty     :: empty column r-position
                0050 C     rFullDepth :: maximum depth of a full column
                0051 C     tmpFld     :: Temporary array used to compute & write Total Depth
                0052 C     msgBuf     :: Informational/error message buffer
                0053       INTEGER bi, bj
                0054       INTEGER i, j, k
                0055       _RL rFullDepth
                0056       _RL tmpFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0057 c     _RL hFactmp
                0058 c     CHARACTER*(MAX_LEN_MBUF) msgBuf
                0059 CEOP
                0060
                0061       rFullDepth = rF(1)-rF(Nr+1)
                0062
                0063       DO bj=myByLo(myThid), myByHi(myThid)
                0064        DO bi=myBxLo(myThid), myBxHi(myThid)
                0065
                0066 c#ifdef ALLOW_AUTODIFF_TAMC
edb6656069 Mart*0067 c        tkey = bi + (bj-1)*nSx + (ikey_dynamics-1)*nSx*nSy
a2a20dcddc Jean*0068 c#endif /* ALLOW_AUTODIFF_TAMC */
                0069
                0070 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0071
                0072 c#ifdef ALLOW_OBCS
                0073 cC-- Apply OBC to rStar_Factor_W,S before updating hFacW,S
                0074 c       IF (useOBCS) THEN
                0075 c        CALL OBCS_APPLY_R_STAR(
                0076 c    I                    bi, bj,
                0077 c    U                    rStarFacC, rStarFacW, rStarFacS,
                0078 c    I                    myTime, myIter, myThid )
                0079 c       ENDIF
                0080 c#endif /* ALLOW_OBCS */
                0081
                0082 C-- Update the fractional thickness hFacC (& "recip_hFac") :
02d90fb24c Jean*0083         DO j=1-OLy,sNy+OLy
                0084          DO i=1-OLx,sNx+OLx
a2a20dcddc Jean*0085           IF ( kSurfC(i,j,bi,bj).LE.Nr ) THEN
                0086            tmpFld(i,j) = etaHc(i,j,bi,bj)
                0087      &                 + ( Ro_surf(i,j,bi,bj)-R_low(i,j,bi,bj) )
                0088           ELSE
                0089            tmpFld(i,j) = rFullDepth
                0090           ENDIF
                0091          ENDDO
                0092         ENDDO
                0093         DO k=1,Nr
02d90fb24c Jean*0094          DO j=1-OLy,sNy+OLy
                0095           DO i=1-OLx,sNx+OLx
a2a20dcddc Jean*0096             hFacC(i,j,k,bi,bj) = maskC(i,j,k,bi,bj)
                0097      &                         *( dAHybSigF(k)*rFullDepth
                0098      &                           +dBHybSigF(k)*tmpFld(i,j)
                0099      &                          )*recip_drF(k)
                0100             recip_hFacC(i,j,k,bi,bj) = maskC(i,j,k,bi,bj)*drF(k)
                0101      &                         /( dAHybSigF(k)*rFullDepth
                0102      &                           +dBHybSigF(k)*tmpFld(i,j)
                0103      &                          )
                0104           ENDDO
                0105          ENDDO
                0106         ENDDO
                0107
                0108 C-- Update the fractional thickness hFacW (& "recip_hFac") :
02d90fb24c Jean*0109         DO j=1-OLy,sNy+OLy
                0110          DO i=1-OLx,sNx+OLx
a2a20dcddc Jean*0111           IF ( kSurfW(i,j,bi,bj).LE.Nr ) THEN
                0112            tmpFld(i,j) = etaHw(i,j,bi,bj)
                0113      &                 + ( rSurfW(i,j,bi,bj)-rLowW(i,j,bi,bj) )
                0114           ELSE
                0115            tmpFld(i,j) = rFullDepth
                0116           ENDIF
                0117          ENDDO
                0118         ENDDO
                0119         DO k=1,Nr
02d90fb24c Jean*0120          DO j=1-OLy,sNy+OLy
                0121           DO i=1-OLx,sNx+OLx
a2a20dcddc Jean*0122             hFacW(i,j,k,bi,bj) = maskW(i,j,k,bi,bj)
                0123      &                         *( dAHybSigF(k)*rFullDepth
                0124      &                           +dBHybSigF(k)*tmpFld(i,j)
                0125      &                          )*recip_drF(k)
                0126             recip_hFacW(i,j,k,bi,bj) = maskW(i,j,k,bi,bj)*drF(k)
                0127      &                         /( dAHybSigF(k)*rFullDepth
                0128      &                           +dBHybSigF(k)*tmpFld(i,j)
                0129      &                          )
                0130           ENDDO
                0131          ENDDO
                0132         ENDDO
                0133
                0134 C-- Update the fractional thickness hFacS (& "recip_hFac") :
02d90fb24c Jean*0135         DO j=1-OLy,sNy+OLy
                0136          DO i=1-OLx,sNx+OLx
a2a20dcddc Jean*0137           IF ( kSurfS(i,j,bi,bj).LE.Nr ) THEN
                0138            tmpFld(i,j) = etaHs(i,j,bi,bj)
                0139      &                 + ( rSurfS(i,j,bi,bj)-rLowS(i,j,bi,bj) )
                0140           ELSE
                0141            tmpFld(i,j) = rFullDepth
                0142           ENDIF
                0143          ENDDO
                0144         ENDDO
                0145         DO k=1,Nr
02d90fb24c Jean*0146          DO j=1-OLy,sNy+OLy
                0147           DO i=1-OLx,sNx+OLx
a2a20dcddc Jean*0148             hFacS(i,j,k,bi,bj) = maskS(i,j,k,bi,bj)
                0149      &                         *( dAHybSigF(k)*rFullDepth
                0150      &                           +dBHybSigF(k)*tmpFld(i,j)
                0151      &                          )*recip_drF(k)
                0152             recip_hFacS(i,j,k,bi,bj) = maskS(i,j,k,bi,bj)*drF(k)
                0153      &                         /( dAHybSigF(k)*rFullDepth
                0154      &                           +dBHybSigF(k)*tmpFld(i,j)
                0155      &                          )
                0156           ENDDO
                0157          ENDDO
                0158         ENDDO
                0159
                0160 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0161
                0162 C- end bi,bj loop
                0163        ENDDO
                0164       ENDDO
                0165
                0166 c     _EXCH_XYZ_RS( hFacC, myThid )
                0167 c     _EXCH_XYZ_RS( recip_hFacC, myThid )
                0168 c     CALL EXCH_UV_XYZ_RS(hFacW,hFacS,.FALSE.,myThid)
                0169 c     CALL EXCH_UV_XYZ_RS(recip_hFacW,recip_hFacS,.FALSE.,myThid)
                0170
                0171 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0172 c#endif /* ndef DISABLE_SIGMA_CODE */
                0173 #endif /* NONLIN_FRSURF */
                0174
                0175       RETURN
                0176       END