diff --git a/parm/post_avblflds.xml b/parm/post_avblflds.xml
index b9c1f051d..e3b8cb98e 100755
--- a/parm/post_avblflds.xml
+++ b/parm/post_avblflds.xml
@@ -7740,7 +7740,6 @@
level_free_convection
6.0
-
994
OZCON_ON_HYBRID_LVL
@@ -7756,6 +7755,5 @@
hybrid_lvl
7.0
-
diff --git a/sorc/ncep_post.fd/ALLOCATE_ALL.f b/sorc/ncep_post.fd/ALLOCATE_ALL.f
index 593851af4..14ef0c17f 100644
--- a/sorc/ncep_post.fd/ALLOCATE_ALL.f
+++ b/sorc/ncep_post.fd/ALLOCATE_ALL.f
@@ -683,6 +683,7 @@ SUBROUTINE ALLOCATE_ALL()
allocate(z500(im,jsta_2l:jend_2u))
allocate(z700(im,jsta_2l:jend_2u))
allocate(teql(im,jsta_2l:jend_2u))
+ allocate(ieql(im,jsta_2l:jend_2u))
allocate(cfracl(im,jsta_2l:jend_2u))
allocate(cfracm(im,jsta_2l:jend_2u))
allocate(cfrach(im,jsta_2l:jend_2u))
@@ -708,6 +709,7 @@ SUBROUTINE ALLOCATE_ALL()
t700(i,j)=spval
z700(i,j)=spval
teql(i,j)=spval
+ ieql(i,j)=0
cfracl(i,j)=spval
cfracm(i,j)=spval
cfrach(i,j)=spval
diff --git a/sorc/ncep_post.fd/DEALLOCATE.f b/sorc/ncep_post.fd/DEALLOCATE.f
index fd3eef1be..aba65050a 100644
--- a/sorc/ncep_post.fd/DEALLOCATE.f
+++ b/sorc/ncep_post.fd/DEALLOCATE.f
@@ -237,6 +237,7 @@ SUBROUTINE DE_ALLOCATE
deallocate(z500)
deallocate(z700)
deallocate(teql)
+ deallocate(ieql)
deallocate(cfracl)
deallocate(cfracm)
deallocate(cfrach)
diff --git a/sorc/ncep_post.fd/INITPOST.F b/sorc/ncep_post.fd/INITPOST.F
index 8a8991bc8..87cd31af5 100644
--- a/sorc/ncep_post.fd/INITPOST.F
+++ b/sorc/ncep_post.fd/INITPOST.F
@@ -1781,7 +1781,7 @@ SUBROUTINE INITPOST
IM,1,JM,1,IM,JS,JE,1)
do j = jsta_2l, jend_2u
do i = 1, im
- IF(SUBMODELNAME == 'RTMA')THEN !use 1st level of unstaggered U for U10
+ IF(SUBMODELNAME == 'RTMA' .and. MODELNAME == 'RAPR')THEN !use 1st level of unstaggered U for U10
U10 ( i, j ) = uh ( i, j, lm )
ELSE
U10 ( i, j ) = dummy( i, j )
@@ -1793,7 +1793,7 @@ SUBROUTINE INITPOST
IM,1,JM,1,IM,JS,JE,1)
do j = jsta_2l, jend_2u
do i = 1, im
- IF( SUBMODELNAME == 'RTMA')THEN!use 1st level of unstaggered V for V10
+ IF( SUBMODELNAME == 'RTMA' .and. MODELNAME == 'RAPR')THEN!use 1st level of unstaggered V for V10
V10 ( i, j ) = vh ( i, j, lm )
ELSE
V10 ( i, j ) = dummy( i, j )
diff --git a/sorc/ncep_post.fd/MISCLN.f b/sorc/ncep_post.fd/MISCLN.f
index 3538cd00e..c333ad586 100644
--- a/sorc/ncep_post.fd/MISCLN.f
+++ b/sorc/ncep_post.fd/MISCLN.f
@@ -45,6 +45,9 @@
!! 20-11-10 J Meng - USE UPP_PHYSICS MODULE
!! 21-03-25 E Colon - 3D-RTMA-specific SPC fields added as output
!! 21-04-01 J Meng - computation on defined points only
+!! 21-09-01 E Colon - Correction to the effective layer top and
+!! bottoma calculation which is only employed
+!! for RTMA usage.
!!
!! USAGE: CALL MISCLN
!! INPUT ARGUMENT LIST:
@@ -86,7 +89,7 @@ SUBROUTINE MISCLN
use vrbls3d, only: pmid, uh, vh, t, zmid, zint, pint, alpint, q, omga
use vrbls3d, only: catedr,mwt,gtg
use vrbls2d, only: pblh, cprate, fis, T500, T700, Z500, Z700,&
- teql
+ teql,ieql
use masks, only: lmh
use params_mod, only: d00, d50, h99999, h100, h1, h1m12, pq0, a2, a3, a4, &
rhmin, rgamog, tfrz, small, g
@@ -114,6 +117,7 @@ SUBROUTINE MISCLN
real,PARAMETER :: D2000=2000
real,PARAMETER :: HCONST=42000000.
real,PARAMETER :: K2C=273.16
+ REAL,PARAMETER :: DM9999=-9999.0
!
! DECLARE VARIABLES.
@@ -129,7 +133,8 @@ SUBROUTINE MISCLN
RH1D, EGRID1, EGRID2, EGRID3, EGRID4, &
EGRID5, EGRID6, EGRID7, EGRID8, &
MLCAPE,MLCIN,MLLCL,MUCAPE,MUCIN,MUMIXR, &
- FREEZELVL,MUQ1D,SLCL
+ FREEZELVL,MUQ1D,SLCL,THE,MAXTHE
+ integer,dimension(im,jsta:jend) :: MAXTHEPOS
real, dimension(:,:,:),allocatable :: OMGBND, PWTBND, QCNVBND, &
PBND, TBND, QBND, &
UBND, VBND, RHBND, &
@@ -155,7 +160,7 @@ SUBROUTINE MISCLN
ESRH
!
integer I,J,jj,L,ITYPE,ISVALUE,LBND,ILVL,IFD,ITYPEFDLVL(NFD), &
- iget1, iget2, iget3, LLMH
+ iget1, iget2, iget3, LLMH,imax,jmax,lmax
real DPBND,PKL1,PKU1,FAC1,FAC2,PL,TL,QL,QSAT,RHL,TVRL,TVRBLO, &
ES1,ES2,QS1,QS2,RH1,RH2,ZSF,DEPTH(2),work1,work2,work3, &
SCINtmp,MUCAPEtmp,MUCINtmp,MLLCLtmp,ESHRtmp,MLCAPEtmp,STP,&
@@ -169,11 +174,33 @@ SUBROUTINE MISCLN
integer ISTART,ISTOP,JSTART,JSTOP,MIDCAL
real dummy(IM,jsta:jend)
integer idummy(IM,jsta:jend)
+! NEW VARIABLES USED FOR EFFECTIVE LAYER
+ INTEGER,dimension(:,:),allocatable :: EL_BASE, EL_TOPS
+ LOGICAL,dimension(:,:),allocatable :: FOUND_BASE, FOUND_TOPS
+ INTEGER,dimension(:,:),allocatable :: L_THETAE_MAX
+ INTEGER,dimension(:,:),allocatable :: CAPE9, CINS9
+ CHARACTER(LEN=5) :: IM_CH, JSTA_CH, JEND_CH, ME_CH
+ CHARACTER(LEN=60) :: EFFL_FNAME
+ CHARACTER(LEN=60) :: EFFL_FNAME2
+ INTEGER :: IREC, IUNIT
+ INTEGER :: IREC2, IUNIT2
+ LOGICAL :: debugprint
+ INTEGER :: LLL
+ INTEGER :: LLCL_PAR, LEQL_PAR
+ REAL :: LMASK, PSFC, CAPE_PAR, CINS_PAR, LPAR0
+ REAL, DIMENSION(4) :: PARCEL0
+ REAL, DIMENSION(:), ALLOCATABLE :: TPAR_B, TPAR_T
+ REAL, DIMENSION(:), ALLOCATABLE :: TPAR_TMP
+ REAL, DIMENSION(:), ALLOCATABLE :: P_AMB, T_AMB, Q_AMB, ZINT_AMB
+ REAL, DIMENSION(:,:,:), ALLOCATABLE :: TPAR_BASE, TPAR_TOPS
!
!****************************************************************************
! START MISCLN HERE.
!
+ debugprint = .FALSE.
+
+
allocate(USHR1(IM,jsta_2l:jend_2u),VSHR1(IM,jsta_2l:jend_2u), &
USHR6(IM,jsta_2l:jend_2u),VSHR6(IM,jsta_2l:jend_2u))
allocate(UST(IM,jsta_2l:jend_2u),VST(IM,jsta_2l:jend_2u), &
@@ -1401,7 +1428,9 @@ SUBROUTINE MISCLN
DO J=JSTA,JEND
DO I=1,IM
GRID1(I,J)=Z1D(I,J)
- IF (SUBMODELNAME == 'RTMA') FREEZELVL(I,J)=GRID1(I,J)
+ IF (SUBMODELNAME == 'RTMA') THEN
+ FREEZELVL(I,J)=GRID1(I,J)
+ ENDIF
ENDDO
ENDDO
CALL BOUND (GRID1,D00,H99999)
@@ -1490,7 +1519,7 @@ SUBROUTINE MISCLN
END IF
! HIGHEST FREEZING LEVEL RELATIVE HUMIDITY
- IF (IGET(350)>0)THEN
+ IF (IGET(350)>0)THEN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
@@ -1563,7 +1592,7 @@ SUBROUTINE MISCLN
END IF
! HIGHEST -10C ISOTHERM RELATIVE HUMIDITY
- IF (IGET(777)>0)THEN
+ IF (IGET(777)>0)THEN
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
@@ -2115,7 +2144,6 @@ SUBROUTINE MISCLN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
-
IF (EGRID1(I,J) > EGRID2(I,J)) THEN
EGRID2(I,J) = EGRID1(I,J)
LB2(I,J) = LVLBND(I,J,LBND)
@@ -2237,7 +2265,7 @@ SUBROUTINE MISCLN
endif
ENDIF
IF (IGET(110)>0) THEN
- GRID1=spval
+ GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
@@ -2793,8 +2821,8 @@ SUBROUTINE MISCLN
!
! SIGMA 0.85000-1.00000 MOISTURE CONVERGENCE.
IF (IGET(103)>0) THEN
+ GRID1=spval
! CONVERT TO DIVERGENCE FOR GRIB
- GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
@@ -2911,7 +2939,7 @@ SUBROUTINE MISCLN
/ LOG(PMID(I,J,LM)/PMID(I,J,LM-1))
IF (MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') THEN
- EGRID1(I,J) = LOG(PMID(I,J,LM)/EGRID2(I,J)) &
+ EGRID1(I,J) = LOG(PMID(I,J,LM)/EGRID2(I,J)) &
/ max(1.e-6,LOG(PMID(I,J,LM)/PMID(I,J,LM-1)))
EGRID1(I,J) =max(-10.0,min(EGRID1(I,J), 10.0))
IF ( ABS(PMID(I,J,LM)-PMID(I,J,LM-1)) < 0.5 ) THEN
@@ -2987,7 +3015,7 @@ SUBROUTINE MISCLN
QS2 = CON_EPS*ES2/(PMID(I,J,LM-1)+CON_EPSM1*ES2)
RH2 = Q(I,J,LM-1)/QS2
GRID1(I,J) = (RH1+(RH2-RH1)*EGRID1(I,J))*100.
- ENDIF
+ ENDIF
ENDDO
ENDDO
CALL BOUND(GRID1,D00,H100)
@@ -3059,7 +3087,7 @@ SUBROUTINE MISCLN
DO J=JSTA,JEND
DO I=1,IM
IF(OMGA(I,J,LM)0) THEN
+ IF (IGET(582)>0) THEN
! dong add missing value for cape
GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
- IF(T1D(I,J) < spval) THEN
- GRID1(I,J) = EGRID1(I,J)
- IF (SUBMODELNAME == 'RTMA') MLCAPE(I,J)=GRID1(I,J)
- ENDIF
+ IF(T1D(I,J) < spval) THEN
+ GRID1(I,J) = EGRID1(I,J)
+ IF (SUBMODELNAME == 'RTMA')MLCAPE(I,J)=GRID1(I,J)
+ ENDIF
ENDDO
ENDDO
CALL BOUND(GRID1,D00,H99999)
@@ -3162,10 +3186,10 @@ SUBROUTINE MISCLN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
- IF(T1D(I,J) < spval) THEN
- GRID1(I,J) = - GRID1(I,J)
- IF (SUBMODELNAME == 'RTMA') MLCIN(I,J) = GRID1(I,J)
- ENDIF
+ IF(T1D(I,J) < spval) THEN
+ GRID1(I,J) = - GRID1(I,J)
+ IF (SUBMODELNAME == 'RTMA') MLCIN(I,J)=GRID1(I,J)
+ ENDIF
ENDDO
ENDDO
!
@@ -3259,10 +3283,10 @@ SUBROUTINE MISCLN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
- IF(T1D(I,J) < spval) THEN
- GRID1(I,J) = EGRID1(I,J)
- IF (SUBMODELNAME == 'RTMA') MUCAPE(I,J) = GRID1(I,J)
- ENDIF
+ IF(T1D(I,J) < spval) THEN
+ GRID1(I,J) = EGRID1(I,J)
+ IF (SUBMODELNAME == 'RTMA') MUCAPE(I,J)=GRID1(I,J)
+ ENDIF
ENDDO
ENDDO
CALL BOUND(GRID1,D00,H99999)
@@ -3298,7 +3322,7 @@ SUBROUTINE MISCLN
DO I=1,IM
IF(T1D(I,J) < spval) THEN
GRID1(I,J) = - GRID1(I,J)
- IF (SUBMODELNAME == 'RTMA') THEN
+ IF (SUBMODELNAME == 'RTMA')THEN
MUCAPE(I,J) = GRID1(I,J)
MUQ1D(I,J) = Q1D(I,J)
ENDIF
@@ -3342,7 +3366,6 @@ SUBROUTINE MISCLN
enddo
endif
ENDIF
-
!Equilibrium Temperature
IF (IGET(982)>0) THEN
DO J=JSTA,JEND
@@ -3394,7 +3417,7 @@ SUBROUTINE MISCLN
! GENERAL THUNDER PARAMETER ??? 458 ???
IF (IGET(444)>0) THEN
- GRID1 = spval
+ GRID1 = spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
@@ -3422,11 +3445,122 @@ SUBROUTINE MISCLN
endif
ENDIF
ENDIF
+
+
+ IF (SUBMODELNAME == 'RTMA')THEN
+
+!
+! --- Effective (inflow) Layer (EL)
+!
+
+ ALLOCATE(EL_BASE(IM,JSTA_2L:JEND_2U))
+ ALLOCATE(EL_TOPS(IM,JSTA_2L:JEND_2U))
+ ALLOCATE(FOUND_BASE(IM,JSTA_2L:JEND_2U))
+ ALLOCATE(FOUND_TOPS(IM,JSTA_2L:JEND_2U))
+!$omp parallel do private(i,j)
+ DO J=JSTA,JEND
+ DO I=1,IM
+ EL_BASE(I,J) = LM
+ EL_TOPS(I,J) = LM
+ FOUND_BASE(I,J) = .FALSE.
+ FOUND_TOPS(I,J) = .FALSE.
+ ENDDO
+ ENDDO
+
+!
+
+ ITYPE = 2
+ DPBND = 0.
+
+ DO L = LM, 1, -1
+
+! SET AIR PARCELS FOR LEVEL L
+!$omp parallel do private(i,j)
+ DO J=JSTA,JEND
+ DO I=1,IM
+ EGRID1(I,J) = -H99999
+ EGRID2(I,J) = -H99999
+ IDUMMY(I,J) = 0
+ P1D(I,J) = PMID(I,J,L)
+ T1D(I,J) = T(I,J,L)
+ Q1D(I,J) = Q(I,J,L)
+ ENDDO
+ ENDDO
+
+!--- CALCULATE CAPE/CIN FOR ALL AIR PARCELS on LEVEL L
+ IF (debugprint) WRITE(1000+ME,'(A,I3)') &
+ ' CALCULATING CAPE/CINS ON LEVEL:',L
+ CALL CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,IDUMMY,EGRID1, &
+ EGRID2,EGRID3,EGRID4,EGRID5)
+
+!--- CHECK CAPE/CIN OF EACH AIR PARCELS WITH EL CRITERIA
+!$omp parallel do private(i,j)
+ DO J=JSTA,JEND
+ DO I=1,IM
+ IF ( .NOT. FOUND_BASE(I,J) ) THEN
+ IF ( EGRID1(I,J) >= 100. .AND. EGRID2(I,J) >= -250. ) THEN
+ EL_BASE(I,J) = L
+ FOUND_BASE(I,J) = .TRUE.
+ ELSE
+ EL_BASE(I,J) = LM
+ FOUND_BASE(I,J) = .FALSE.
+ END IF
+ ELSE
+ IF ( .NOT. FOUND_TOPS(I,J) ) THEN
+ IF ( EGRID1(I,J) < 100. .OR. EGRID2(I,J) < -250. ) THEN
+ EL_TOPS(I,J) = L + 1
+ FOUND_TOPS(I,J) = .TRUE.
+ ELSE
+ EL_TOPS(I,J) = LM
+ FOUND_TOPS(I,J) = .FALSE.
+ END IF
+ END IF
+ END IF
+ ENDDO
+ ENDDO
+
+ END DO ! L
+
+
+ IF (ALLOCATED(FOUND_BASE)) DEALLOCATE(FOUND_BASE)
+ IF (ALLOCATED(FOUND_TOPS)) DEALLOCATE(FOUND_TOPS)
+
+ IF (debugprint) THEN
+ WRITE(IM_CH,'(I5.5)') IM
+ WRITE(JSTA_CH,'(I5.5)') JSTA
+ WRITE(JEND_CH,'(I5.5)') JEND
+ EFFL_FNAME="EFFL_NEW_"//IM_CH//"_"//JSTA_CH//"_"//JEND_CH &
+ //".dat"
+ EFFL_FNAME2="EFFL_NEW_LVLS_"//IM_CH//"_"//JSTA_CH//"_"//JEND_CH &
+ //".dat"
+ IUNIT=10000+JSTA
+ IUNIT2=20000+JSTA
+ IREC=0
+ IREC2=0
+ OPEN(IUNIT,FILE=TRIM(ADJUSTL(EFFL_FNAME)),FORM='FORMATTED')
+
+
+ DO J=JSTA,JEND
+ DO I=1,IM
+ IREC = IREC + 1
+ IREC2 = IREC2 + 1
+ WRITE(IUNIT,'(1x,I6,2x,I6,2(2x,I6,2x,F12.3))') I, J, &
+ EL_BASE(I,J),PMID(I,J,EL_BASE(I,J)), &
+ EL_TOPS(I,J),PMID(I,J,EL_TOPS(I,J))
+ END DO
+ ENDDO
+ CLOSE(IUNIT)
+ ENDIF
+
+ IF(ALLOCATED(TPAR_BASE)) DEALLOCATE(TPAR_BASE)
+ IF(ALLOCATED(TPAR_TOPS)) DEALLOCATE(TPAR_TOPS)
+
+ ENDIF
!
! EXPAND HRRR CAPE/CIN RELATED VARIABLES
!
! CAPE AND CINS 0-3KM, FOLLOW ML PROCEDURE WITH HEIGHT 0-3KM
-
+!
FIELD1=.FALSE.
FIELD2=.FALSE.
!
@@ -3444,8 +3578,12 @@ SUBROUTINE MISCLN
FIELD2=.TRUE.
ENDIF
!
+! IF(FIELD1)ITYPE=2
+! IF(FIELD2)ITYPE=2
+
IF(FIELD1.OR.FIELD2)THEN
ITYPE = 2
+
!
!$omp parallel do private(i,j)
DO J=JSTA,JEND
@@ -3469,12 +3607,12 @@ SUBROUTINE MISCLN
Q1D(I,J) = (QBND(I,J,1) + QBND(I,J,2) + QBND(I,J,3))/3
ENDDO
ENDDO
-!
+
DPBND = 0.
CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,LB2, &
EGRID1,EGRID2,EGRID3,EGRID4,EGRID5, &
EGRID6,EGRID7,EGRID8)
-!
+
! CAPE1, CINS2, LFC3, ESRHL4,ESRHH5,
! DCAPE6,DGLD7, ESP8)
!
@@ -3538,7 +3676,7 @@ SUBROUTINE MISCLN
! LFC HEIGHT
IF (IGET(952)>0) THEN
- GRID1=spval
+ GRID1=spval
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
@@ -3560,6 +3698,7 @@ SUBROUTINE MISCLN
endif
ENDIF !952
+
! EFFECTIVE STORM RELATIVE HELICITY AND STORM MOTION.
allocate(UST(IM,jsta_2l:jend_2u),VST(IM,jsta_2l:jend_2u), &
@@ -3578,13 +3717,47 @@ SUBROUTINE MISCLN
IF (iget1 > 0 .OR. IGET(162) > 0 .OR. IGET(953) > 0) THEN
DEPTH(1) = 3000.0
DEPTH(2) = 1000.0
+ IF (SUBMODELNAME == 'RTMA') THEN
+!--- IF USSING EL BASE & TOP COMPUTED BY NEW SCHEME FOR THE
+!RELATED VARIABLES
!$omp parallel do private(i,j)
- DO J=JSTA,JEND
- DO I=1,IM
- LLOW(I,J) = INT(EGRID4(I,J))
- LUPP(I,J) = INT(EGRID5(I,J))
+ DO J=JSTA,JEND
+ DO I=1,IM
+ LLOW(I,J) = EL_BASE(I,J)
+ LUPP(I,J) = EL_TOPS(I,J)
+ ENDDO
ENDDO
- ENDDO
+ ELSE
+!$omp parallel do private(i,j)
+ DO J=JSTA,JEND
+ DO I=1,IM
+ LLOW(I,J) = INT(EGRID4(I,J))
+ LUPP(I,J) = INT(EGRID5(I,J))
+ ENDDO
+ ENDDO
+ ENDIF
+!--- OUTPUT EL BASE & TOP COMPUTED BY OLD SCHEME
+ IF (debugprint) THEN
+ WRITE(IM_CH,'(I5.5)') IM
+ WRITE(JSTA_CH,'(I5.5)') JSTA
+ WRITE(JEND_CH,'(I5.5)') JEND
+ EFFL_FNAME="EFFL_OLD_"//IM_CH//"_"//JSTA_CH//"_"//JEND_CH &
+ //".dat"
+ IUNIT=10000+JSTA
+ IREC=0
+ OPEN(IUNIT,FILE=TRIM(ADJUSTL(EFFL_FNAME)),FORM='FORMATTED')
+ DO J=JSTA,JEND
+ DO I=1,IM
+ IREC = IREC + 1
+! WRITE(IUNIT,'(1x,I6,2x,I6,2x,I6,2x,I6)')I,J,LLOW(I,J),LUPP(I,J)
+ WRITE(IUNIT,'(1x,I6,2x,I6,2(2x,I6,2x,F12.3))') I, J, &
+ LLOW(I,J),PMID(I,J,LLOW(I,J)), &
+ LUPP(I,J),PMID(I,J,LUPP(I,J))
+ END DO
+ ENDDO
+ CLOSE(IUNIT)
+ ENDIF
+
! CALL CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6)
CALL CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE)
@@ -3613,6 +3786,7 @@ SUBROUTINE MISCLN
ENDIF !953
+
IF (SUBMODELNAME == 'RTMA') THEN !Start RTMA block
!EL field allocation
@@ -3622,6 +3796,40 @@ SUBROUTINE MISCLN
allocate(EFFUST(IM,jsta_2l:jend_2u),EFFVST(IM,jsta_2l:jend_2u),&
ESRH(IM,jsta_2l:jend_2u))
+!
+ DO J=JSTA,JEND
+ DO I=1,IM
+ MAXTHE(I,J)=-H99999
+ THE(I,J)=-H99999
+ MAXTHEPOS(I,J)=0
+ MUQ1D(I,J) = 0.
+ ENDDO
+ ENDDO
+ DO L=LM,1,-1
+
+ DO J=JSTA,JEND
+ DO I=1,IM
+ EGRID1(I,J) = -H99999
+ P1D(I,J)=PMID(I,J,L)
+ T1D(I,J)=T(I,J,L)
+ Q1D(I,J)=Q(I,J,L)
+ ENDDO
+ ENDDO
+ CALL CALTHTE(P1D,T1D,Q1D,EGRID1)
+ DO J=JSTA,JEND
+ DO I=1,IM
+ THE(I,J)=EGRID1(I,J)
+ IF(THE(I,J)>=MAXTHE(I,J))THEN
+ MAXTHE(I,J)=THE(I,J)
+ MAXTHEPOS(I,J)=L
+ MUQ1D(I,J) = Q(I,J,L) ! save the Q of air parcel with max theta-e (MU Parcel)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDDO
+
+!
!get surface height
IF(gridtype == 'E')THEN
JVN = 1
@@ -3724,15 +3932,14 @@ SUBROUTINE MISCLN
GRID1=spval
DO J=JSTA,JEND
DO I=1,IM
- IF(LLOW(I,J)0) THEN
GRID1(I,J)=STP
@@ -3934,7 +4141,7 @@ SUBROUTINE MISCLN
!Fixed Layer Tornado Parameter
IF (IGET(990)>0) THEN
- DO J=JSTA,JEND
+ DO J=JSTA,JEND
DO I=1,IM
LLMH = NINT(LMH(I,J))
P1D(I,J) = PMID(I,J,LLMH)
@@ -4077,6 +4284,7 @@ SUBROUTINE MISCLN
CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,LB2, &
EGRID1,EGRID2,EGRID3,EGRID4,EGRID5, &
EGRID6,EGRID7,EGRID8)
+
GRID1=spval
DO J=JSTA,JEND
DO I=1,IM
@@ -4126,9 +4334,6 @@ SUBROUTINE MISCLN
GRID1=spval
DO J=JSTA,JEND
DO I=1,IM
- IF(T700(I,J) < spval .and. T500(I,J) < spval .and.&
- Z700(I,J) < spval .and. Z500(I,J) < spval .and.&
- MUCAPE(I,J) < spval .and. MUQ1D(I,J) < spval .and. FSHR(I,J) < spval) THEN
LAPSE=-((T700(I,J)-T500(I,J))/((Z700(I,J)-Z500(I,J))))
SHIP=(MUCAPE(I,J)*D1000*MUQ1D(I,J)*LAPSE*(T500(I,J)-K2C)*FSHR(I,J))/HCONST
IF (MUCAPE(I,J)<1300.)THEN
@@ -4141,7 +4346,6 @@ SUBROUTINE MISCLN
SHIP=SHIP*(FREEZELVL(I,J)/2400.)
ENDIF
GRID1(I,J)=SHIP
- ENDIF
ENDDO
ENDDO
if(grib=='grib2') then
@@ -4168,7 +4372,7 @@ SUBROUTINE MISCLN
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
- IF(T1D(I,J) < spval ) GRID1(I,J) = CANGLE(I,J)
+ IF(T1D(I,J) < spval ) GRID1(I,J) = CANGLE(I,J)
! IF(EGRID1(I,J)<100. .OR. EGRID2(I,J)>-250.) THEN
! GRID1(I,J) = 0.
! ENDIF
@@ -4240,21 +4444,21 @@ SUBROUTINE MISCLN
! Downdraft CAPE
- ITYPE = 1
- ! DO J=JSTA,JEND
- ! DO I=1,IM
- ! LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + &
- ! LVLBND(I,J,3))/3
- ! P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3
- ! T1D(I,J) = (TBND(I,J,1) + TBND(I,J,2) + TBND(I,J,3))/3
- ! Q1D(I,J) = (QBND(I,J,1) + QBND(I,J,2) + QBND(I,J,3))/3
- ! ENDDO
- ! ENDDO
-
- DPBND = 400.E2
- ! CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,LB2, &
- ! EGRID1,EGRID2,EGRID3,EGRID4,EGRID5, &
- ! EGRID6,EGRID7,EGRID8)
+! ITYPE = 1
+! DO J=JSTA,JEND
+! DO I=1,IM
+! LB2(I,J) = (LVLBND(I,J,1) + LVLBND(I,J,2) + &
+! LVLBND(I,J,3))/3
+! P1D(I,J) = (PBND(I,J,1) + PBND(I,J,2) + PBND(I,J,3))/3
+! T1D(I,J) = (TBND(I,J,1) + TBND(I,J,2) + TBND(I,J,3))/3
+! Q1D(I,J) = (QBND(I,J,1) + QBND(I,J,2) + QBND(I,J,3))/3
+! ENDDO
+! ENDDO
+
+! DPBND = 400.E2
+! CALL CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,LB2, &
+! EGRID1,EGRID2,EGRID3,EGRID4,EGRID5, &
+! EGRID6,EGRID7,EGRID8)
IF (IGET(954)>0) THEN
GRID1 = spval
diff --git a/sorc/ncep_post.fd/TTBLEX.f b/sorc/ncep_post.fd/TTBLEX.f
index 09bd3423b..21748a6f4 100644
--- a/sorc/ncep_post.fd/TTBLEX.f
+++ b/sorc/ncep_post.fd/TTBLEX.f
@@ -112,5 +112,8 @@ SUBROUTINE TTBLEX(TREF,TTBL,ITB,JTB,KARR,PMIDL &
ENDDO
!
RETURN
- END
+ END SUBROUTINE TTBLEX
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+!
+!-------------------------------------------------------------------------------------
+!
diff --git a/sorc/ncep_post.fd/UPP_PHYSICS.f b/sorc/ncep_post.fd/UPP_PHYSICS.f
index 3f44dd0c0..60a54dee5 100644
--- a/sorc/ncep_post.fd/UPP_PHYSICS.f
+++ b/sorc/ncep_post.fd/UPP_PHYSICS.f
@@ -51,7 +51,7 @@ module upp_physics
!
SUBROUTINE CALRH(P1,T1,Q1,RH)
- use ctlblk_mod, only: im, jsta, jend, MODELNAME
+ use ctlblk_mod, only: im, jsta, jend, MODELNAME
implicit none
REAL,dimension(IM,jsta:jend),intent(in) :: P1,T1
@@ -137,7 +137,7 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH)
!
DO J=JSTA,JEND
DO I=1,IM
- IF (T1(I,J) < SPVAL) THEN
+ IF (T1(I,J) < spval) THEN
IF (ABS(P1(I,J)) >= 1) THEN
QC = PQ0/P1(I,J)*EXP(A2*(T1(I,J)-A3)/(T1(I,J)-A4))
!
@@ -156,7 +156,7 @@ SUBROUTINE CALRH_NAM(P1,T1,Q1,RH)
!
ENDIF
ELSE
- RH(I,J) = SPVAL
+ RH(I,J) = spval
ENDIF
ENDDO
ENDDO
@@ -245,7 +245,7 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH)
!$omp parallel do private(i,j,es,qc)
DO J=JSTA,JEND
DO I=1,IM
- IF (T1(I,J) < SPVAL .AND. P1(I,J) < SPVAL.AND.Q1(I,J)/=SPVAL) THEN
+ IF (T1(I,J) < spval .AND. P1(I,J) < spval.AND.Q1(I,J)/=spval) THEN
! IF (ABS(P1(I,J)) > 1.0) THEN
! IF (P1(I,J) > 1.0) THEN
IF (P1(I,J) >= 1.0) THEN
@@ -269,7 +269,7 @@ SUBROUTINE CALRH_GFS(P1,T1,Q1,RH)
ENDIF
ELSE
- RH(I,J) = SPVAL
+ RH(I,J) = spval
ENDIF
ENDDO
ENDDO
@@ -295,7 +295,7 @@ SUBROUTINE CALRH_GSD(P1,T1,Q1,RHB)
DO J=JSTA,JEND
DO I=1,IM
- IF (T1(I,J) < SPVAL .AND. P1(I,J) < SPVAL .AND. Q1(I,J) < SPVAL) THEN
+ IF (T1(I,J) < spval .AND. P1(I,J) < spval .AND. Q1(I,J) < spval) THEN
! - compute relative humidity
Tx=T1(I,J)-273.15
POL = 0.99999683 + TX*(-0.90826951E-02 + &
@@ -309,7 +309,7 @@ SUBROUTINE CALRH_GSD(P1,T1,Q1,RHB)
E = P1(I,J)/100.*Q1(I,J)/(0.62197+Q1(I,J)*0.37803)
RHB(I,J) = MIN(1.,E/ES)
ELSE
- RHB(I,J) = SPVAL
+ RHB(I,J) = spval
ENDIF
ENDDO
ENDDO
@@ -344,8 +344,8 @@ SUBROUTINE CALRH_PW(RHPW)
k=lm-l+1
DO J=JSTA,JEND
DO I=1,IM
- if(t(i,j,k)