!----------------------------------------------------------------------
!
!NCEP_MESO:MODEL_LAYER: NONHYDROSTATIC DYNAMICS ROUTINES
!
!----------------------------------------------------------------------
!
#include "nmm_loop_basemacros.h"
#include "nmm_loop_macros.h"
!
!----------------------------------------------------------------------
!
MODULE MODULE_NONHY_DYNAM 2
!
!----------------------------------------------------------------------
USE MODULE_MODEL_CONSTANTS
! USE MODULE_INDX
!----------------------------------------------------------------------
!
REAL :: CAPA=R_D/CP,RG=1./G,TRG=2.*R_D/G
!
CONTAINS
!
!***********************************************************************
SUBROUTINE EPS(NTSD,DT,HYDRO,DX,DY,FAD & 1
,AETA1,DETA1,DETA2,PDTOP,PT &
,HBM2,HBM3 &
,PDSL,PDSLO,PINT,RTOP,PETDT,PDWDT &
,DWDT,DWDTMN,DWDTMX &
,FNS,FEW,FNE,FSE &
,T,U,V,W,W_TOT,Q,CWM &
,DEF3D,HDAC,BARO &
,WP &
,IHE,IHW,IVE,IVW &
,IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE)
!***********************************************************************
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . .
! SUBPROGRAM: EPS
! PRGRMMR: JANJIC ORG: W/NP22 DATE: 9?-??-??
!
! ABSTRACT:
! EPS COMPUTES THE VERTICAL AND HORIZONTAL ADVECTION OF DZ/DT
!
! PROGRAM HISTORY LOG:
! 9?-??-?? JANJIC - ORIGINATOR
! 00-01-05 BLACK - DISTRIBUTED MEMORY AND THREADS
! 02-02-07 BLACK - CONVERTED TO WRF STRUCTURE
! 04-11-22 BLACK - THREADED
! 05-12-12 BLACK - CONVERTED FROM IKJ TO IJK
!
! USAGE: CALL EPS FROM SUBROUTINE SOLVE_RUNSTREAM
! INPUT ARGUMENT LIST:
!
! OUTPUT ARGUMENT LIST:
!
! OUTPUT FILES:
! NONE
!
! SUBPROGRAMS CALLED:
!
! UNIQUE: NONE
!
! LIBRARY: NONE
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 90
! MACHINE : IBM SP
!$$$
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!-----------------------------------------------------------------------
INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE
!
INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
!
!-----------------------------------------------------------------------
!
INTEGER,INTENT(IN) :: NTSD
!
REAL,INTENT(IN) :: DT,DY,PDTOP,PT,WP
!
REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2,AETA1
!
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DWDTMN,DWDTMX,DX &
,FAD,HBM2,HBM3 &
,PDSL,PDSLO &
,HDAC,BARO
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PETDT,DEF3D
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM &
,FEW,FNE &
,FNS,FSE &
,Q,RTOP &
,U,V
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DWDT &
,PDWDT &
,T
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: PINT,W
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: W_TOT
!
LOGICAL,INTENT(IN) :: HYDRO
!
!-----------------------------------------------------------------------
!
!*** LOCAL VARIABLES
!
!-----------------------------------------------------------------------
!
INTEGER,PARAMETER :: NTSHY=2
!
REAL,PARAMETER :: WGHT=0.35
REAL,PARAMETER :: SLPD=1500.
REAL,PARAMETER :: PI=3.14159
!
INTEGER,DIMENSION(KTS:KTE) :: LA
!
INTEGER :: I,J,K,LMP,LSLTP,L
!
REAL,DIMENSION(KTS:KTE) :: B1,B2,B3,C0,CWM_K,DWDT_K,Q_K,RDPP &
,RTOP_K,T_K,WHY
!
REAL,DIMENSION(ITS:ITE) :: DPTU_I,PNP1_I,PSTRUP_I
!
REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: TTB,WEW,WNE,WNS,WSE
!
REAL,DIMENSION(ITS:ITE,KTS:KTE) :: B1_IK,B2_IK,B3_IK,C0_IK &
,CWM_IK,DWDT_IK,Q_IK &
,RDPP_IK,RTOP_IK,T_IK
!
REAL,DIMENSION(ITS:ITE,KTS:KTE+1) :: CHI_IK,COFF_IK &
,PINT_IK,PSTR_IK,W_IK
!
REAL :: ADDT,DELP,DETAL,DP,DPDE,DPPL,DPSTR,DPTL,DPTU &
,DWDTT,EPSN,FCT,FFC,GDT,GDT2 &
,PNP,PP1,PSTRDN,PSTRUP,RDP,RDPDN,RDPUP,RDT &
,TFC,TMP,TTAL,TTFC,HKNE_IJ,HKSE_IJ,ADVEC,ARG,SLTP,PAVG
!
LOGICAL :: BOT,TOP,DIFFW
!
CHARACTER(LEN=255) :: message
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
IF(NTSD<=NTSHY.OR.HYDRO)THEN
!***
DO J=MYJS_P2,MYJE_P2
DO I=MYIS_P1,MYIE_P1
PINT(I,J,KTE+1)=PT
ENDDO
ENDDO
!
!$omp parallel do &
!$omp& private(i,j,k)
DO K=KTS,KTE
DO J=MYJS_P2,MYJE_P2
DO I=MYIS_P1,MYIE_P1
DWDT(I,J,K)=1.
PDWDT(I,J,K)=1.
ENDDO
ENDDO
ENDDO
!
!$omp parallel do &
!$omp& private(i,j,k)
DO K=KTE,KTS,-1
DO J=MYJS_P2,MYJE_P2
DO I=MYIS_P1,MYIE_P1
PINT(I,J,K)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)+PINT(I,J,K+1)
ENDDO
ENDDO
ENDDO
!***
RETURN
!***
ENDIF
!-----------------------------------------------------------------------
ADDT=DT
RDT=1./ADDT
!-----------------------------------------------------------------------
!
!*** TIME TENDENCY
!
!$omp parallel do &
!$omp& private(i,j,k)
DO K=KTS,KTE
DO J=MYJS_P1,MYJE_P1
DO I=MYIS_P1,MYIE_P1
DWDT(I,J,K)=(W(I,J,K)-DWDT(I,J,K))*HBM2(I,J)*RDT
ENDDO
ENDDO
ENDDO
IF (DT > 0 .and. WP .ge. 0.001) THEN
DIFFW=.TRUE.
ELSE
DIFFW=.FALSE.
ENDIF
IF(DIFFW) THEN
DO K=KTS,KTE
DO J=MYJS_P1,MYJE1_P1
DO I=MYIS_P1,MYIE1_P1
HKNE_IJ=(DEF3D(I,J,K)+DEF3D(I+IHE(J),J+1,K))
HKSE_IJ=(DEF3D(I+IHE(J),J-1,K)+DEF3D(I,J,K))
WNE(I,J)=(W (I+IHE(J),J+1,K)-W (I,J,K))*HKNE_IJ
WSE(I,J)=(W (I+IHE(J),J-1,K)-W (I,J,K))*HKSE_IJ
ENDDO
ENDDO
DO J=MYJS2,MYJE2
DO I=MYIS,MYIE
DWDT(I,J,K)= DWDT(I,J,K) - ( WNE (I,J)-WNE (I+IHW(J),J-1) + &
WSE (I,J)-WSE (I+IHW(J),J+1) ) * &
HDAC(I,J)*HBM2(I,J)*RDT
ENDDO
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!***
!*** VERTICAL ADVECTION
!***
!-----------------------------------------------------------------------
!
DO J=MYJS2,MYJE2
DO I=MYIS,MYIE
TTB(I,J)=0.
ENDDO
ENDDO
!
DO K=KTE,KTS+1,-1
!
!$omp parallel do &
!$omp& private(i,j,ttal)
DO J=MYJS2,MYJE2
DO I=MYIS,MYIE
TTAL=(W(I,J,K-1)-W(I,J,K))*PETDT(I,J,K-1)*0.5
DWDT(I,J,K)=(TTAL+TTB(I,J)) &
/(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)) &
+DWDT(I,J,K)
TTB(I,J)=TTAL
ENDDO
ENDDO
ENDDO
!
!$omp parallel do &
!$omp& private(i,j)
DO J=MYJS2,MYJE2
DO I=MYIS1,MYIE1
TTB(I,J)=(W(I,J,KTS)-W(I,J,KTS+1))*PETDT(I,J,KTS)*0.5
DWDT(I,J,KTS)=TTB(I,J)/(DETA1(KTS)*PDTOP+DETA2(KTS)*PDSLO(I,J)) &
+DWDT(I,J,KTS)
ENDDO
ENDDO
!-----------------------------------------------------------------------
!***
!*** END OF VERTICAL ADVECTION
!***
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!***
!*** HORIZONTAL ADVECTION
!***
!-----------------------------------------------------------------------
!
!$omp parallel do &
!$omp& private(dpde,i,j,k)
!
main_horizontal: DO K=KTS,KTE
!
!-----------------------------------------------------------------------
!*** THE WORKING ARRAYS FOR THE PRIMARY VARIABLES
!-----------------------------------------------------------------------
!
DO J=MYJS1_P3,MYJE1_P3
DO I=MYIS_P3,MYIE_P3
WEW(I,J)=FEW(I,J,K)*(W(I+IVE(J),J,K)-W(I+IVW(J),J,K))
WNS(I,J)=FNS(I,J,K)*(W(I,J+1,K)-W(I,J-1,K))
ENDDO
ENDDO
!
!*** DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
!
DO J=MYJS1_P2,MYJE2_P2
DO I=MYIS_P2,MYIE1_P2
WNE(I,J)=FNE(I,J,K)*(W(I+IHE(J),J+1,K)-W(I,J,K))
ENDDO
ENDDO
!
DO J=MYJS2_P2,MYJE1_P2
DO I=MYIS_P2,MYIE1_P2
WSE(I,J)=FSE(I,J,K)*(W(I+IHE(J),J-1,K)-W(I,J,K))
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!*** ADVECTION OF W
!-----------------------------------------------------------------------
!
DO J=MYJS3,MYJE3
DO I=MYIS2,MYIE2
DPDE=DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)
ADVEC=-(WEW(I+IHW(J),J) +WEW(I+IHE(J),J) &
+WNS(I,J-1) +WNS(I,J+1) &
+WNE(I+IHW(J),J-1) +WNE(I,J) &
+WSE(I,J) +WSE(I+IHW(J),J+1)) &
*FAD(I,J)*2.0*HBM3(I,J)/(DPDE*DT)
DWDT(I,J,K)= ADVEC + DWDT(I,J,K)
ENDDO
ENDDO
ENDDO main_horizontal
!-----------------------------------------------------------------------
!***
!*** END OF HORIZONTAL ADVECTION
!***
!-----------------------------------------------------------------------
IF (WP .ge. 0.001) then
do l=1,KTE
why(l)=-99.
enddo
!
lsltp=0
SLTP=(PT+AETA1(KTE-1)*PDTOP+PT+AETA1(KTE)*PDTOP)*0.5
DO L=KTE,2,-1
PAVG=PT+PDTOP*(AETA1(L)+AETA1(L-1))*0.5
ARG=( PAVG-SLTP )/SLPD
if(arg.gt.1.) exit
why(l)=1.-cos(arg*pi*0.5)**2
lsltp=l
enddo
!
DO l=lsltp,KTE
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
dwdt(i,j,l)=dwdt(i,j,l)*why(l)
ENDDO
ENDDO
ENDDO
!-----------------------------------------------------------------------
!---taking external mode out--------------------------------------------
!-----------------------------------------------------------------------
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
TTB(I,J)=0.
ENDDO
ENDDO
!
DO K=KTS,KTE
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
DPDE=DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)
TTB(I,J)=DPDE*DWDT(I,J,K)+TTB(I,J)
ENDDO
ENDDO
ENDDO
!
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
TTB(I,J)=TTB(I,J)/(PDSLO(I,J)+PDTOP)
ENDDO
ENDDO
!
DO K=KTS,KTE
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
DWDT(I,J,K)=DWDT(I,J,K)-TTB(I,J)
ENDDO
ENDDO
ENDDO
endif
!$omp parallel do &
!$omp& private(dwdtt,i,j,k)
DO K=KTS,KTE
DO J=MYJS,MYJE
DO I=MYIS,MYIE
DWDTT=DWDT(I,J,K)
DWDTT=MAX(DWDTT,DWDTMN(I,J))
DWDTT=MIN(DWDTT,DWDTMX(I,J))
!
DWDT(I,J,K)=(DWDTT*RG+1.)*(1.-WP)+PDWDT(I,J,K)*WP
ENDDO
ENDDO
ENDDO
!-----------------------------------------------------------------------
!---setting dwdt (epsilon at this point) on h points to 1. along bdy ---
!-----------------------------------------------------------------------
IF (WP .ge. 0.001) THEN
do K=KTS,KTE
if (JDS .eq. JTS) then
do J=jts,jts+1
do I=its,ite
DWDT(I,J,K)=1.
enddo
enddo
endif
!
if (JTE .ge. JDE-2) then
do j=jte-1,jte
do i=its,ite
DWDT(I,J,K)=1.
enddo
enddo
endif
!
if(ITS .eq. IDS)then
do j=jts,jte
do i=its,its+1
DWDT(I,J,K)=1.
enddo
enddo
endif
!
if(ITE .ge. IDE-2)then
do j=jts,jte
do i=ite-1,ite
DWDT(I,J,K)=1.
enddo
enddo
endif
enddo
ENDIF
GDT=G*DT
GDT2=GDT*GDT
FFC=-R_D/GDT2
!
!-----------------------------------------------------------------------
!
!$omp parallel do &
!$omp& private(b1_ik,b2_ik,b3_ik,c0_ik,chi_ik,coff_ik,cwm_ik, &
!$omp& delp,dppl,dpstr,dptl,dptu_i,dwdt_ik,fct,i,j,k, &
!$omp& pint_ik,pnp1_i,pp1,pstr_ik,pstrdn,pstrup_i,q_ik, &
!$omp& rdpdn,rdpup,rtop_ik,t_ik,tfc,tmp,ttfc,w_ik)
!
final_update: DO J=MYJS3,MYJE3
!
!-----------------------------------------------------------------------
!*** EXTRACT COLUMNS FROM 3-D ARRAYS
!-----------------------------------------------------------------------
!
DO K=KTS,KTE
DO I=MYIS2,MYIE2
CWM_IK(I,K)=CWM(I,J,K)
DWDT_IK(I,K)=DWDT(I,J,K)
Q_IK(I,K)=Q(I,J,K)
RTOP_IK(I,K)=RTOP(I,J,K)
T_IK(I,K)=T(I,J,K)
ENDDO
ENDDO
!
DO K=KTS,KTE+1
DO I=MYIS2,MYIE2
PINT_IK(I,K)=PINT(I,J,K)
W_IK(I,K)=W(I,J,K)
ENDDO
ENDDO
!
DO I=MYIS2,MYIE2
PSTR_IK(I,KTE+1)=PT
ENDDO
!
!-----------------------------------------------------------------------
!
DO K=KTE,KTS,-1
!
IF(K==KTE)THEN
DO I=MYIS2,MYIE2
DPPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
RDPP_IK(I,K)=1./DPPL
DPSTR=DWDT_IK(I,K)*DPPL
PSTR_IK(I,K)=PT+DPSTR
PP1=PT+DPSTR
PNP1_I(I)=(PP1-PINT_IK(I,K))*WGHT+PINT_IK(I,K)
TFC=Q_IK(I,K)*P608+(1.-CWM_IK(I,K))
TTFC=-CAPA*TFC+1.
COFF_IK(I,K)=T_IK(I,K)*TTFC*TFC*DPPL*FFC &
/((PT+PNP1_I(I))*(PT+PNP1_I(I)))
ENDDO
ELSE
DO I=MYIS2,MYIE2
DPPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
RDPP_ik(I,K)=1./DPPL
DPSTR=DWDT_IK(I,K)*DPPL
PSTR_IK(I,K)=PSTR_IK(I,K+1)+DPSTR
PP1=PNP1_I(I)+DPSTR
PNP=(PP1-PINT_IK(I,K))*WGHT+PINT_IK(I,K)
TFC=Q_IK(I,K)*P608+(1.-CWM_IK(I,K))
TTFC=-CAPA*TFC+1.
COFF_IK(I,K)=T_IK(I,K)*TTFC*TFC*DPPL*FFC &
/((PNP1_I(I)+PNP)*(PNP+PNP1_I(I)))
PNP1_I(I)=PNP
ENDDO
ENDIF
!
ENDDO
!
!-----------------------------------------------------------------------
!
DO I=MYIS2,MYIE2
!!BUG!! PSTRUP_I(I)=-(PSTR_IK(I,KTE)-PINT_IK(I,KTE))*COFF_IK(I,KTE)
PSTRUP_I(I)=-(PSTR_IK(I,KTE+1)+PSTR_IK(I,KTE) &
-PINT_IK(I,KTE+1)-PINT_IK(I,KTE))*COFF_IK(I,KTE)
ENDDO
!
!-----------------------------------------------------------------------
DO K=KTE-1,KTS,-1
!
IF(K==KTE-1)THEN
DO I=MYIS2,MYIE2
RDPDN=RDPP_IK(I,K)
RDPUP=RDPP_IK(I,K+1)
!
PSTRDN=-(PSTR_IK(I,K+1)+PSTR_IK(I,K) &
-PINT_IK(I,K+1)-PINT_IK(I,K)) &
*COFF_IK(I,K)
!
B1_IK(I,K)=COFF_IK(I,K+1)+RDPUP
B2_IK(I,K)=(COFF_IK(I,K+1)+COFF_IK(I,K))-(RDPUP+RDPDN)
B3_IK(I,K)=COFF_IK(I,K)+RDPDN
C0_IK(I,K)=PSTRUP_I(I)+PSTRDN
PSTRUP_I(I)=PSTRDN
ENDDO
ELSE
DO I=MYIS2,MYIE2
RDPDN=RDPP_IK(I,K)
RDPUP=RDPP_IK(I,K+1)
!
PSTRDN=-(PSTR_IK(I,K+1)+PSTR_IK(I,K) &
-PINT_IK(I,K+1)-PINT_IK(I,K)) &
*COFF_IK(I,K)
!
B1_IK(I,K)=COFF_IK(I,K+1)+RDPUP
B2_IK(I,K)=(COFF_IK(I,K+1)+COFF_IK(I,K))-(RDPUP+RDPDN)
B3_IK(I,K)=COFF_IK(I,K)+RDPDN
C0_IK(I,K)=PSTRUP_I(I)+PSTRDN
PSTRUP_I(I)=PSTRDN
ENDDO
ENDIF
!
ENDDO
!
!-----------------------------------------------------------------------
!*** ELIMINATION
!-----------------------------------------------------------------------
!
DO K=KTE-2,KTS,-1
!
IF(K>KTS)THEN
DO I=MYIS2,MYIE2
TMP=-B1_IK(I,K)/B2_IK(I,K+1)
B2_IK(I,K)=B3_IK(I,K+1)*TMP+B2_IK(I,K)
C0_IK(I,K)=C0_IK(I,K+1)*TMP+C0_IK(I,K)
ENDDO
ELSE
DO I=MYIS2,MYIE2
TMP=-B1_IK(I,K)/B2_IK(I,K+1)
B2_IK(I,K)=B3_IK(I,K+1)*TMP &
+(B2_IK(I,KTS)+B3_IK(I,KTS))
C0_IK(I,K)=C0_IK(I,K+1)*TMP+C0_IK(I,K)
ENDDO
ENDIF
!
ENDDO
!
!-----------------------------------------------------------------------
!*** BACK SUBSTITUTION
!-----------------------------------------------------------------------
!
DO K=KTS+1,KTE
!
IF(K==KTS+1)THEN
DO I=MYIS2,MYIE2
CHI_IK(I,K)=C0_IK(I,KTS)/B2_IK(I,KTS)
CHI_IK(I,KTS)=CHI_IK(I,K)
ENDDO
ELSE
DO I=MYIS2,MYIE2
CHI_IK(I,K)=(-B3_IK(I,K-1)*CHI_IK(I,K-1)+C0_IK(I,K-1)) &
/B2_IK(I,K-1)
ENDDO
ENDIF
!
ENDDO
!-----------------------------------------------------------------------
!
FCT=0.5/CP
!
DO K=KTE,KTS,-1
!
IF(K==KTE)THEN
DO I=MYIS2,MYIE2
DPTL=(CHI_IK(I,K)+PSTR_IK(I,K)-PINT_IK(I,K))*HBM3(I,J)
PINT_IK(I,K)=PINT_IK(I,K)+DPTL
T_IK(I,K)=DPTL*RTOP_IK(I,K)*FCT+T_IK(I,K)
DELP=(PINT_IK(I,K)-PINT_IK(I,K+1))*RDPP_IK(I,K)
W_IK(I,K)=((DELP-DWDT_IK(I,K))*GDT+W_IK(I,K))*HBM3(I,J)
DWDT_IK(I,K)=(DELP-1.)*HBM3(I,J)+1.
DPTU_I(I)=DPTL
ENDDO
ELSE
DO I=MYIS2,MYIE2
DPTL=(CHI_IK(I,K)+PSTR_IK(I,K)-PINT_IK(I,K))*HBM3(I,J)
PINT_IK(I,K)=PINT_IK(I,K)+DPTL
T_IK(I,K)=(DPTU_I(I)+DPTL)*RTOP_IK(I,K)*FCT+T_IK(I,K)
DELP=(PINT_IK(I,K)-PINT_IK(I,K+1))*RDPP_IK(I,K)
W_IK(I,K)=((DELP-DWDT_IK(I,K))*GDT+W_IK(I,K))*HBM3(I,J)
DWDT_IK(I,K)=(DELP-1.)*HBM3(I,J)+1.
DPTU_I(I)=DPTL
ENDDO
ENDIF
!
ENDDO
!
!-----------------------------------------------------------------------
DO K=KTS,KTE
DO I=MYIS2,MYIE2
PINT(I,J,K)=PINT_IK(I,K)
T(I,J,K)=T_IK(I,K)
W(I,J,K)=W_IK(I,K)
DWDT(I,J,K)=DWDT_IK(I,K)
ENDDO
ENDDO
!-----------------------------------------------------------------------
!
ENDDO final_update
!
!-----------------------------------------------------------------------
!*** DEFINE OUTPUT W FIELD
!-----------------------------------------------------------------------
!
IF (WP .ge. 0.001) THEN
DO K=KTS,KTE+1
DO J=MYJS,MYJE
DO I=MYIS,MYIE
W_TOT(I,J,K)=W(I,J,K)+BARO(I,J)
ENDDO
ENDDO
ENDDO
ELSE
DO K=KTS,KTE+1
DO J=MYJS,MYJE
DO I=MYIS,MYIE
W_TOT(I,J,K)=W(I,J,K)
ENDDO
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!
END SUBROUTINE EPS
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!***********************************************************************
SUBROUTINE VADZ(NTSD,DT,FIS,SIGMA,DFL,HBM2 & 1
,DETA1,DETA2,PDTOP &
,PINT,PDSL,PDSLO,PETDT &
,RTOP,T,Q,CWM,Z,W,DWDT,PDWDT &
,IHE,IHW,IVE,IVW &
,IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE)
!***********************************************************************
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . .
! SUBPROGRAM: VADZ VERTICAL ADVECTION OF HEIGHT
! PRGRMMR: JANJIC ORG: W/NP22 DATE: 93-11-17
!
! ABSTRACT:
! VADV CALCULATES THE CONTRIBUTION OF THE VERTICAL ADVECTION
! OF HEIGHT IN ORDER TO COMPUTE W=DZ/DT DIAGNOSTICALLY
!
! PROGRAM HISTORY LOG:
! 96-05-?? JANJIC - ORIGINATOR
! 00-01-04 BLACK - DISTRIBUTED MEMORY AND THREADS
! 01-03-26 BLACK - CONVERTED TO WRF STRUCTURE
! 02-02-19 BLACK - CONVERSION UPDATED
! 04-11-22 BLACK - THREADED
! 05-12-12 BLACK - CONVERTED FROM IKJ TO IJK
!
! USAGE: CALL VADZ FROM MAIN PROGRAM
! INPUT ARGUMENT LIST:
!
! OUTPUT ARGUMENT LIST:
!
! OUTPUT FILES:
! NONE
!
! SUBPROGRAMS CALLED:
!
! UNIQUE: NONE
!
! LIBRARY: NONE
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 90
! MACHINE : IBM SP
!$$$
!***********************************************************************
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
#ifdef AS_RECEIVED
LOGICAL,INTENT(IN) :: SIGMA
#else
INTEGER,INTENT(IN) :: SIGMA
#endif
!
INTEGER,INTENT(IN) :: NTSD
!
INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE
!
INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
!
!-----------------------------------------------------------------------
!
REAL,INTENT(IN) :: DT,PDTOP
!
REAL,DIMENSION(KTS:KTE),INTENT(IN) :: DETA1,DETA2
!
REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: DFL
!
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,HBM2,PDSL,PDSLO
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM,Q &
,RTOP,T
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: PDWDT
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DWDT
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: W,Z
!-----------------------------------------------------------------------
!
!*** LOCAL VARIABLES
!
!-----------------------------------------------------------------------
INTEGER :: I,J,K
!
REAL,DIMENSION(IMS:IME,JMS:JME) :: FNE,FSE,TTB
!
REAL :: DZ,RDT,TTAL,ZETA
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
RDT=1./DT
!
DO K=KTS,KTE
DO J=MYJS,MYJE
DO I=MYIS,MYIE
PDWDT(I,J,K)=DWDT(I,J,K)
DWDT(I,J,K)=W(I,J,K)
ENDDO
ENDDO
ENDDO
!
DO J=MYJS,MYJE
DO I=MYIS,MYIE
W(I,J,KTS)=0.
!
#ifdef AS_RECEIVED
IF(SIGMA)THEN
#else
IF(SIGMA==1)THEN
#endif
Z(I,J,KTS)=FIS(I,J)*RG
ELSE
Z(I,J,KTS)=0.
ENDIF
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!$omp parallel do &
!$omp& private(dz,i,j,k,zeta)
!-----------------------------------------------------------------------
!
kloop1 : DO K=KTS,KTE
!
!-----------------------------------------------------------------------
!
DO J=MYJS,MYJE
DO I=MYIS,MYIE
!
ZETA=DFL(K+1)*RG
DZ=(Q(I,J,K)*P608-CWM(I,J,K)+1.)*T(I,J,K) &
/(PINT(I,J,K+1)+PINT(I,J,K)) &
*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))*TRG
Z(I,J,K+1)=Z(I,J,K)+DZ
W(I,J,K+1)=(DZ-RTOP(I,J,K) &
*(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J))*RG) &
*HBM2(I,J) &
+W(I,J,K)
!
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!
ENDDO kloop1
!
!-----------------------------------------------------------------------
!$omp parallel do &
!$omp& private(i,j,k)
!-----------------------------------------------------------------------
DO K=KTS,KTE
!
DO J=MYJS,MYJE
DO I=MYIS,MYIE
Z(I,J,K)=(Z(I,J,K+1)+Z(I,J,K))*0.5
W(I,J,K)=(W(I,J,K+1)+W(I,J,K))*HBM2(I,J)*0.5*RDT
ENDDO
ENDDO
!
ENDDO
!-----------------------------------------------------------------------
!
DO J=MYJS,MYJE
DO I=MYIS,MYIE
TTB(I,J)=0.
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!$omp parallel do &
!$omp& private(i,j,k,ttal)
!-----------------------------------------------------------------------
DO K=KTE,KTS+1,-1
DO J=MYJS2,MYJE2
DO I=MYIS1,MYIE1
TTAL=(Z(I,J,K-1)-Z(I,J,K))*PETDT(I,J,K-1)*0.5
W(I,J,K)=(TTAL+TTB(I,J))/(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)) &
+W(I,J,K)
TTB(I,J)=TTAL
ENDDO
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!$omp parallel do &
!$omp& private(i,j)
!-----------------------------------------------------------------------
DO J=MYJS2,MYJE2
DO I=MYIS1,MYIE1
W(I,J,KTS)=TTB(I,J)/(DETA1(KTS)*PDTOP+DETA2(KTS)*PDSLO(I,J)) &
+W(I,J,KTS)
ENDDO
ENDDO
!-----------------------------------------------------------------------
END SUBROUTINE VADZ
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!***********************************************************************
SUBROUTINE HADZ(NTSD,DT,HYDRO,HBM2,DETA1,DETA2,PDTOP & 1,2
,DX,DY,FAD &
,FEW,FNS,FNE,FSE &
,PDSL,U,V,W,Z,WP,BARO &
,IHE,IHW,IVE,IVW &
,IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE)
!***********************************************************************
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . .
! SUBPROGRAM: HADZ HORIZONTAL ADVECTION OF HEIGHT
! PRGRMMR: JANJIC ORG: W/NP22 DATE: 96-05-??
!
! ABSTRACT:
! HADZ CALCULATES DIAGNOSTICALLY THE CONTRIBUTION OF
! THE HORIZONTAL ADVECTION OF HEIGHT
!
! PROGRAM HISTORY LOG:
! 96-05-?? JANJIC - ORIGINATOR
! 00-01-04 BLACK - DISTRIBUTED MEMORY AND THREADS
! 01-03-26 BLACK - CONVERTED TO WRF STRUCTURE
! 04-11-22 BLACK - THREADED
! 05-12-12 BLACK - CONVERTED FROM IKJ TO IJK
!
! USAGE: CALL HADZ FROM MAIN PROGRAM
! INPUT ARGUMENT LIST:
!
! OUTPUT ARGUMENT LIST:
! NONE
!
! OUTPUT FILES:
!
! SUBPROGRAMS CALLED:
!
! UNIQUE: NONE
!
! LIBRARY: NONE
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 90
! MACHINE : IBM SP
!$$$
!***********************************************************************
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
LOGICAL,INTENT(IN) :: HYDRO
!
INTEGER,INTENT(IN) :: NTSD
!
INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
,IMS,IME,JMS,JME,KMS,KME &
,ITS,ITE,JTS,JTE,KTS,KTE
!
INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
!
!-----------------------------------------------------------------------
!
REAL,INTENT(IN) :: DT,DY,PDTOP,WP
!
REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2
!
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX,FAD,HBM2,PDSL
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: BARO
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: U,V
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: FEW,FNE &
,FNS,FSE
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: Z
!
REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: W
!-----------------------------------------------------------------------
!
!*** LOCAL VARIABLES
!
!-----------------------------------------------------------------------
INTEGER,PARAMETER :: NTSHY=2
!
INTEGER :: I,J,K
!
REAL :: FEWP,FNEP,FNSP,FSEP,UDY,VDX
!
REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DPDE,UNED,USED &
& ,ZEW,ZNE,ZNS,ZSE,TTB
!
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
IF(NTSD+1<=NTSHY.OR.HYDRO)THEN
!$omp parallel do &
!$omp& private(i,j,k)
DO K=KTS,KTE
DO J=MYJS,MYJE
DO I=MYIS,MYIE
W(I,J,K)=0.
ENDDO
ENDDO
ENDDO
!***
RETURN
!***
ENDIF
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!
!*** FIRST ZERO OUT SOME WORKING ARRAYS
!
!$omp parallel do &
!$omp& private(i,j)
DO J=JTS-5,JTE+5
DO I=ITS-5,ITE+5
DPDE(I,J)=0.
UNED(I,J)=0.
D(I,J)=0.
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!$omp parallel do &
!$omp& private(dpde,fewp,fnep,fnsp,fsep,i,j,udy,uned,used,vdx &
!$omp& ,zew,zne,zns,zse)
!-----------------------------------------------------------------------
!
main_integration: DO K=KTS,KTE
!
!-----------------------------------------------------------------------
!
!*** MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
!
!-----------------------------------------------------------------------
!
DO J=MYJS_P3,MYJE_P3
DO I=MYIS_P4,MYIE_P4
DPDE(I,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
ENDDO
ENDDO
!
DO J=MYJS1_P3,MYJE1_P3
DO I=MYIS_P3,MYIE_P3
UDY=U(I,J,K)*DY
VDX=V(I,J,K)*DX(I,J)
!
FEWP=UDY*(DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J))
FNSP=VDX*(DPDE(I,J-1)+DPDE(I,J+1))
!
FEW(I,J,K)=FEWP
FNS(I,J,K)=FNSP
!
ZEW(I,J)=FEWP*(Z(I+IVE(J),J,K)-Z(I+IVW(J),J,K))
ZNS(I,J)=FNSP*(Z(I,J+1,K)-Z(I,J-1,K))
!
UNED(I,J)=UDY+VDX
D(I,J)=UDY-VDX
!
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!
!*** DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
!
!-----------------------------------------------------------------------
DO J=MYJS1_P2,MYJE2_P2
DO I=MYIS_P2,MYIE1_P2
FNEP=(UNED(I+IHE(J),J)+UNED(I,J+1)) &
& *(DPDE(I,J)+DPDE(I+IHE(J),J+1))
FNE(I,J,K)=FNEP
ZNE(I,J)=FNEP*(Z(I+IHE(J),J+1,K)-Z(I,J,K))
ENDDO
ENDDO
!
DO J=MYJS2_P2,MYJE1_P2
DO I=MYIS_P2,MYIE1_P2
FSEP=(USED(I+IHE(J),J)+USED(I,J-1)) &
& *(DPDE(I,J)+DPDE(I+IHE(J),J-1))
FSE(I,J,K)=FSEP
ZSE(I,J)=FSEP*(Z(I+IHE(J),J-1,K)-Z(I,J,K))
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!
!*** ADVECTION OF Z
!
!-----------------------------------------------------------------------
!
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
W(I,J,K)=-(ZEW(I+IHW(J),J) +ZEW(I+IHE(J),J) &
+ZNS(I,J-1) +ZNS(I,J+1) &
+ZNE(I+IHW(J),J-1)+ZNE(I,J) &
+ZSE(I,J) +ZSE(I+IHW(J),J+1)) &
*FAD(I,J)*2.0*HBM2(I,J)/(DPDE(I,J)*DT) &
+W(I,J,K)
ENDDO
ENDDO
ENDDO main_integration
IF (WP .ge. 0.001) then
!-----------------------------------------------------------------------
!---taking external mode out--------------------------------------------
!-----------------------------------------------------------------------
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
BARO(I,J)=0.
ENDDO
ENDDO
!
DO K=KTS,KTE
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
DPDE(I,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
BARO(I,J)=(DPDE(I,J))*W(I,J,K)+BARO(I,J)
ENDDO
ENDDO
ENDDO
!
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
BARO(I,J)=BARO(I,J)/(PDSL(I,J)+PDTOP)
ENDDO
ENDDO
!
DO K=KTS,KTE
DO J=MYJS2_P1,MYJE2_P1
DO I=MYIS1_P1,MYIE1_P1
W(I,J,K)=W(I,J,K)-BARO(I,J)
ENDDO
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!
END SUBROUTINE HADZ
!
!-----------------------------------------------------------------------
!
END MODULE MODULE_NONHY_DYNAM
!
!-----------------------------------------------------------------------