pkg/fizhi/fizhi_tendency_apply.F

a456aa407c Andr*0001 #include "FIZHI_OPTIONS.h"
beaae9fcda Jean*0002       SUBROUTINE fizhi_tendency_apply_u(
73b1dccda0 Jean*0003      U                        gU_arr,
                0004      I                        iMin,iMax,jMin,jMax, kLev, bi, bj,
                0005      I                        myTime, myIter, myThid )
e337e4ca8c Andr*0006 C=======================================================================
                0007 C Routine: fizhi_tendency_apply_u
                0008 C     Interpolate tendencies from physics grid to dynamics grid and
                0009 C     add fizhi tendency terms to U tendency.
73b1dccda0 Jean*0010 C
                0011 C INPUT:
e337e4ca8c Andr*0012 C     iMin - Working range of tile for applying forcing.
                0013 C     iMax
                0014 C     jMin
                0015 C     jMax
                0016 C     kLev
                0017 C
                0018 C Notes: Routine works for one level at a time
                0019 C        Assumes that U and V tendencies are already on C-Grid
                0020 C=======================================================================
beaae9fcda Jean*0021       IMPLICIT NONE
e337e4ca8c Andr*0022
                0023 #include "SIZE.h"
                0024 #include "GRID.h"
                0025 #include "EEPARAMS.h"
                0026 #include "DYNVARS.h"
                0027 #include "fizhi_SIZE.h"
f4a0368053 Andr*0028 #include "fizhi_land_SIZE.h"
e337e4ca8c Andr*0029 #include "fizhi_coms.h"
                0030
73b1dccda0 Jean*0031       _RL     gU_arr(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0032       INTEGER iMin, iMax, jMin, jMax
                0033       INTEGER kLev, bi, bj
                0034       _RL     myTime
                0035       INTEGER myIter
                0036       INTEGER myThid
e337e4ca8c Andr*0037
73b1dccda0 Jean*0038       _RL rayleighdrag
                0039       _RL tmpdiag(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
beaae9fcda Jean*0040       INTEGER i, j
3f756368dc Andr*0041 #ifdef ALLOW_DIAGNOSTICS
beaae9fcda Jean*0042       LOGICAL  DIAGNOSTICS_IS_ON
                0043       EXTERNAL DIAGNOSTICS_IS_ON
3f756368dc Andr*0044 #endif
e337e4ca8c Andr*0045
beaae9fcda Jean*0046       IF ( klev.EQ.Nr .OR. rC(klev).LT.1000. ) THEN
689620ef36 Andr*0047        rayleighdrag = 1./(31.*86400.*2.)
beaae9fcda Jean*0048       ELSE
689620ef36 Andr*0049        rayleighdrag = 0.
beaae9fcda Jean*0050       ENDIF
689620ef36 Andr*0051
beaae9fcda Jean*0052       DO j=jMin,jMax
                0053        DO i=iMin,iMax
                0054         gU_arr(i,j) = gU_arr(i,j)
                0055      &              + maskW(i,j,kLev,bi,bj)
                0056      &               *( guphy(i,j,kLev,bi,bj)
                0057      &                - rayleighdrag*uVel(i,j,kLev,bi,bj) )
                0058        ENDDO
                0059       ENDDO
e337e4ca8c Andr*0060
beaae9fcda Jean*0061       IF ( DIAGNOSTICS_IS_ON('DIABUDYN',myThid) ) THEN
                0062        DO j=jMin,jMax
                0063        DO i=iMin,iMax
                0064         tmpdiag(i,j) = maskW(i,j,kLev,bi,bj)
                0065      &               *( guphy(i,j,kLev,bi,bj)
                0066      &                - rayleighdrag*uVel(i,j,kLev,bi,bj) )
                0067      &               * 86400
                0068        ENDDO
                0069        ENDDO
                0070        CALL DIAGNOSTICS_FILL(tmpdiag,'DIABUDYN',kLev,1,2,bi,bj,myThid)
                0071       ENDIF
3f756368dc Andr*0072
beaae9fcda Jean*0073       IF ( DIAGNOSTICS_IS_ON('RFU     ',myThid) ) THEN
                0074        DO j=jMin,jMax
                0075        DO i=iMin,iMax
73b1dccda0 Jean*0076         tmpdiag(i,j) = -1. _d 0 * rayleighdrag *
beaae9fcda Jean*0077      &       maskW(i,j,kLev,bi,bj)*uVel(i,j,kLev,bi,bj) * 86400
                0078        ENDDO
                0079        ENDDO
                0080        CALL DIAGNOSTICS_FILL(tmpdiag,'RFU     ',kLev,1,2,bi,bj,myThid)
                0081       ENDIF
3f756368dc Andr*0082
beaae9fcda Jean*0083       RETURN
                0084       END
                0085       SUBROUTINE fizhi_tendency_apply_v(
73b1dccda0 Jean*0086      U                        gV_arr,
                0087      I                        iMin,iMax,jMin,jMax, kLev, bi, bj,
                0088      I                        myTime, myIter, myThid )
e337e4ca8c Andr*0089 C=======================================================================
                0090 C Routine: fizhi_tendency_apply_v
                0091 C     Interpolate tendencies from physics grid to dynamics grid and
                0092 C     add fizhi tendency terms to V tendency.
73b1dccda0 Jean*0093 C
                0094 C INPUT:
e337e4ca8c Andr*0095 C     iMin - Working range of tile for applying forcing.
                0096 C     iMax
                0097 C     jMin
                0098 C     jMax
                0099 C     kLev
                0100 C
                0101 C Notes: Routine works for one level at a time
                0102 C        Assumes that U and V tendencies are already on C-Grid
                0103 C=======================================================================
beaae9fcda Jean*0104       IMPLICIT NONE
e337e4ca8c Andr*0105
                0106 #include "SIZE.h"
                0107 #include "GRID.h"
                0108 #include "EEPARAMS.h"
                0109 #include "DYNVARS.h"
                0110 #include "fizhi_SIZE.h"
f4a0368053 Andr*0111 #include "fizhi_land_SIZE.h"
e337e4ca8c Andr*0112 #include "fizhi_coms.h"
                0113
73b1dccda0 Jean*0114       _RL     gV_arr(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0115       INTEGER iMin, iMax, jMin, jMax
                0116       INTEGER kLev, bi, bj
                0117       _RL     myTime
                0118       INTEGER myIter
                0119       INTEGER myThid
e337e4ca8c Andr*0120
73b1dccda0 Jean*0121       _RL rayleighdrag
                0122       _RL tmpdiag(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
beaae9fcda Jean*0123       INTEGER i, j
3f756368dc Andr*0124 #ifdef ALLOW_DIAGNOSTICS
beaae9fcda Jean*0125       LOGICAL  DIAGNOSTICS_IS_ON
                0126       EXTERNAL DIAGNOSTICS_IS_ON
3f756368dc Andr*0127 #endif
e337e4ca8c Andr*0128
beaae9fcda Jean*0129       IF ( klev.EQ.Nr .OR. rC(klev).LT.1000. ) THEN
689620ef36 Andr*0130        rayleighdrag = 1./(31.*86400.*2.)
beaae9fcda Jean*0131       ELSE
689620ef36 Andr*0132        rayleighdrag = 0.
beaae9fcda Jean*0133       ENDIF
689620ef36 Andr*0134
beaae9fcda Jean*0135       DO j=jMin,jMax
                0136        DO i=iMin,iMax
                0137         gV_arr(i,j) = gV_arr(i,j)
                0138      &              + maskS(i,j,kLev,bi,bj)
                0139      &               *( gvphy(i,j,kLev,bi,bj)
                0140      &                - rayleighdrag*vVel(i,j,kLev,bi,bj) )
                0141        ENDDO
                0142       ENDDO
e337e4ca8c Andr*0143
beaae9fcda Jean*0144       IF ( DIAGNOSTICS_IS_ON('DIABVDYN',myThid) ) THEN
                0145        DO j=jMin,jMax
                0146        DO i=iMin,iMax
                0147         tmpdiag(i,j) = maskS(i,j,kLev,bi,bj)
                0148      &               *( gvphy(i,j,kLev,bi,bj)
                0149      &                - rayleighdrag*vVel(i,j,kLev,bi,bj) )
                0150      &               * 86400
                0151        ENDDO
                0152        ENDDO
                0153        CALL DIAGNOSTICS_FILL(tmpdiag,'DIABVDYN',kLev,1,2,bi,bj,myThid)
                0154       ENDIF
3f756368dc Andr*0155
beaae9fcda Jean*0156       IF ( DIAGNOSTICS_IS_ON('RFV     ',myThid) ) THEN
                0157        DO j=jMin,jMax
                0158        DO i=iMin,iMax
73b1dccda0 Jean*0159         tmpdiag(i,j) = -1. _d 0 * rayleighdrag *
beaae9fcda Jean*0160      &       maskS(i,j,kLev,bi,bj)*vVel(i,j,kLev,bi,bj) * 86400
                0161        ENDDO
                0162        ENDDO
                0163        CALL DIAGNOSTICS_FILL(tmpdiag,'RFV     ',kLev,1,2,bi,bj,myThid)
                0164       ENDIF
3f756368dc Andr*0165
beaae9fcda Jean*0166       RETURN
                0167       END
                0168       SUBROUTINE fizhi_tendency_apply_t(
73b1dccda0 Jean*0169      U                        gT_arr,
                0170      I                        iMin,iMax,jMin,jMax, kLev, bi, bj,
                0171      I                        myTime, myIter, myThid )
e337e4ca8c Andr*0172 C=======================================================================
                0173 C Routine: fizhi_tendency_apply_t
                0174 C     Interpolate tendencies from physics grid to dynamics grid and
                0175 C     add fizhi tendency terms to T (theta) tendency.
73b1dccda0 Jean*0176 C
                0177 C INPUT:
e337e4ca8c Andr*0178 C     iMin - Working range of tile for applying forcing.
                0179 C     iMax
                0180 C     jMin
                0181 C     jMax
                0182 C     kLev
                0183 C
                0184 C Notes: Routine works for one level at a time
                0185 C=======================================================================
beaae9fcda Jean*0186       IMPLICIT NONE
e337e4ca8c Andr*0187
                0188 #include "SIZE.h"
                0189 #include "GRID.h"
                0190 #include "EEPARAMS.h"
                0191 #include "DYNVARS.h"
                0192 #include "fizhi_SIZE.h"
f4a0368053 Andr*0193 #include "fizhi_land_SIZE.h"
e337e4ca8c Andr*0194 #include "fizhi_coms.h"
                0195
73b1dccda0 Jean*0196       _RL     gT_arr(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0197       INTEGER iMin, iMax, jMin, jMax
                0198       INTEGER kLev, bi, bj
                0199       _RL     myTime
                0200       INTEGER myIter
                0201       INTEGER myThid
e337e4ca8c Andr*0202
73b1dccda0 Jean*0203       _RL rayleighdrag,getcon,cp,kappa,pNrkappa
                0204       _RL tmpdiag(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
beaae9fcda Jean*0205       INTEGER i, j
3f756368dc Andr*0206 #ifdef ALLOW_DIAGNOSTICS
beaae9fcda Jean*0207       LOGICAL  DIAGNOSTICS_IS_ON
                0208       EXTERNAL DIAGNOSTICS_IS_ON
3f756368dc Andr*0209 #endif
e337e4ca8c Andr*0210
beaae9fcda Jean*0211       IF ( klev.EQ.Nr .OR. rC(klev).LT.1000. ) THEN
689620ef36 Andr*0212        cp = getcon('CP')
                0213        kappa = getcon('KAPPA')
73b1dccda0 Jean*0214        pNrkappa = (rC(klev)/100000.)**kappa
689620ef36 Andr*0215        rayleighdrag = 1./((31.*86400.*2.)*(pNrkappa*cp))
beaae9fcda Jean*0216       ELSE
689620ef36 Andr*0217        rayleighdrag = 0.
beaae9fcda Jean*0218       ENDIF
689620ef36 Andr*0219
beaae9fcda Jean*0220       DO j=jMin,jMax
                0221        DO i=iMin,iMax
                0222         gT_arr(i,j) = gT_arr(i,j)
                0223      &    + ( maskC(i,j,kLev,bi,bj)*gthphy(i,j,kLev,bi,bj)
                0224      &      + rayleighdrag * 0.5
                0225      &        *( maskW(i,j,kLev,bi,bj)
                0226      &              *uVel(i,j,kLev,bi,bj)*uVel(i,j,kLev,bi,bj)
                0227      &         + maskW(i+1,j,kLev,bi,bj)
                0228      &              *uVel(i+1,j,kLev,bi,bj)*uVel(i+1,j,kLev,bi,bj)
                0229      &         + maskS(i,j,kLev,bi,bj)
                0230      &              *vVel(i,j,kLev,bi,bj)*vVel(i,j,kLev,bi,bj)
                0231      &         + maskS(i,j+1,kLev,bi,bj)
                0232      &              *vVel(i,j+1,kLev,bi,bj)*vVel(i,j+1,kLev,bi,bj)
                0233      &         ) )
                0234        ENDDO
                0235       ENDDO
e337e4ca8c Andr*0236
beaae9fcda Jean*0237       IF ( DIAGNOSTICS_IS_ON('DIABTDYN',myThid) ) THEN
                0238        DO j=jMin,jMax
                0239        DO i=iMin,iMax
                0240         tmpdiag(i,j) =
                0241      &      ( maskC(i,j,kLev,bi,bj)*gthphy(i,j,kLev,bi,bj)
                0242      &      + rayleighdrag * 0.5
                0243      &        *( maskW(i,j,kLev,bi,bj)
                0244      &              *uVel(i,j,kLev,bi,bj)*uVel(i,j,kLev,bi,bj)
                0245      &         + maskW(i+1,j,kLev,bi,bj)
                0246      &              *uVel(i+1,j,kLev,bi,bj)*uVel(i+1,j,kLev,bi,bj)
                0247      &         + maskS(i,j,kLev,bi,bj)
                0248      &              *vVel(i,j,kLev,bi,bj)*vVel(i,j,kLev,bi,bj)
                0249      &         + maskS(i,j+1,kLev,bi,bj)
                0250      &              *vVel(i,j+1,kLev,bi,bj)*vVel(i,j+1,kLev,bi,bj)
                0251      &         ) ) * 86400
                0252        ENDDO
                0253        ENDDO
                0254        CALL DIAGNOSTICS_FILL(tmpdiag,'DIABTDYN',kLev,1,2,bi,bj,myThid)
                0255       ENDIF
3f756368dc Andr*0256
beaae9fcda Jean*0257       IF ( DIAGNOSTICS_IS_ON('RFT     ',myThid) ) THEN
                0258        DO j=jMin,jMax
                0259        DO i=iMin,iMax
                0260         tmpdiag(i,j) = ( rayleighdrag * 0.5
                0261      &        *( maskW(i,j,kLev,bi,bj)
                0262      &              *uVel(i,j,kLev,bi,bj)*uVel(i,j,kLev,bi,bj)
                0263      &         + maskW(i+1,j,kLev,bi,bj)
                0264      &              *uVel(i+1,j,kLev,bi,bj)*uVel(i+1,j,kLev,bi,bj)
                0265      &         + maskS(i,j,kLev,bi,bj)
                0266      &              *vVel(i,j,kLev,bi,bj)*vVel(i,j,kLev,bi,bj)
                0267      &         + maskS(i,j+1,kLev,bi,bj)
                0268      &              *vVel(i,j+1,kLev,bi,bj)*vVel(i,j+1,kLev,bi,bj)
                0269      &         ) ) * 86400
                0270        ENDDO
                0271        ENDDO
                0272        CALL DIAGNOSTICS_FILL(tmpdiag,'RFT     ',kLev,1,2,bi,bj,myThid)
                0273       ENDIF
3f756368dc Andr*0274
beaae9fcda Jean*0275       RETURN
                0276       END
                0277       SUBROUTINE fizhi_tendency_apply_s(
73b1dccda0 Jean*0278      U                        gS_arr,
                0279      I                        iMin,iMax,jMin,jMax, kLev, bi, bj,
                0280      I                        myTime, myIter, myThid )
e337e4ca8c Andr*0281 C=======================================================================
                0282 C Routine: fizhi_tendency_apply_s
                0283 C     Interpolate tendencies from physics grid to dynamics grid and
                0284 C     add fizhi tendency terms to S tendency.
73b1dccda0 Jean*0285 C
                0286 C INPUT:
e337e4ca8c Andr*0287 C     iMin - Working range of tile for applying forcing.
                0288 C     iMax
                0289 C     jMin
                0290 C     jMax
                0291 C     kLev
                0292 C
                0293 C Notes: Routine works for one level at a time
                0294 C=======================================================================
beaae9fcda Jean*0295       IMPLICIT NONE
e337e4ca8c Andr*0296
                0297 #include "SIZE.h"
                0298 #include "GRID.h"
                0299 #include "EEPARAMS.h"
                0300 #include "DYNVARS.h"
                0301 #include "fizhi_SIZE.h"
f4a0368053 Andr*0302 #include "fizhi_land_SIZE.h"
e337e4ca8c Andr*0303 #include "fizhi_coms.h"
                0304
73b1dccda0 Jean*0305       _RL     gS_arr(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0306       INTEGER iMin, iMax, jMin, jMax
                0307       INTEGER kLev, bi, bj
                0308       _RL     myTime
                0309       INTEGER myIter
                0310       INTEGER myThid
e337e4ca8c Andr*0311
73b1dccda0 Jean*0312       _RL tmpdiag(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
beaae9fcda Jean*0313       INTEGER i, j
3f756368dc Andr*0314 #ifdef ALLOW_DIAGNOSTICS
beaae9fcda Jean*0315       LOGICAL  DIAGNOSTICS_IS_ON
                0316       EXTERNAL DIAGNOSTICS_IS_ON
3f756368dc Andr*0317 #endif
e337e4ca8c Andr*0318
beaae9fcda Jean*0319       DO j=jMin,jMax
                0320        DO i=iMin,iMax
                0321         gS_arr(i,j) = gS_arr(i,j)
                0322      &    + maskC(i,j,kLev,bi,bj)*gsphy(i,j,kLev,bi,bj)
                0323        ENDDO
                0324       ENDDO
e337e4ca8c Andr*0325
beaae9fcda Jean*0326       IF ( DIAGNOSTICS_IS_ON('DIABQDYN',myThid) ) THEN
                0327        DO j=jMin,jMax
                0328        DO i=iMin,iMax
3f756368dc Andr*0329         tmpdiag(i,j) = ( maskC(i,j,kLev,bi,bj) * gsphy(i,j,kLev,bi,bj) )
beaae9fcda Jean*0330      &    * 86400
                0331        ENDDO
                0332        ENDDO
                0333        CALL DIAGNOSTICS_FILL(tmpdiag,'DIABQDYN',kLev,1,2,bi,bj,myThid)
                0334       ENDIF
3f756368dc Andr*0335
beaae9fcda Jean*0336       RETURN
                0337       END