Skip to content

Commit

Permalink
UPP refactor phase 2 from Bo Cui (#233)
Browse files Browse the repository at this point in the history 
* 20201123 BoCui:Add "implicit none"/Modernize inequality statements

* sync file CALRAD_WCLOUD_newcrtm.f from EMC_post/develop
  • Loading branch information
@BoCui-NOAA
BoCui-NOAA authored Dec 15, 2020
1 parent 9fa1e08 commit 2c43340
Show file tree
Hide file tree
Showing 105 changed files with 3,060 additions and 3,011 deletions.
26 changes: 13 additions & 13 deletions sorc/ncep_post.fd/AVIATION.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -104,11 +104,11 @@ SUBROUTINE CALLLWS(U,V,H,LLWS)

Z1 = 10.0 + FIS(I,J)*GI !Height of 10m levels geographic height (from sea level)

IF(Z1.LT.H(I,J,LSM)) THEN !First search location of 10m wind level
IF(Z1<H(I,J,LSM)) THEN !First search location of 10m wind level
K1 = LSM + 1 !to see it is in which pressure levels
ELSE
DO LP = LSM,2,-1 !If not found, keep searching upward
IF(Z1.GE.H(I,J,LP).AND.Z1.LT.H(I,J,LP-1)) THEN
IF(Z1>=H(I,J,LP).AND.Z1<H(I,J,LP-1)) THEN
K1 = LP
END IF
END DO
Expand All @@ -118,14 +118,14 @@ SUBROUTINE CALLLWS(U,V,H,LLWS)

DH = 0.0

IF((HZ1+10).GT.609.6) THEN !Then, search 2000ft(609.6m) location
IF((HZ1+10)>609.6) THEN !Then, search 2000ft(609.6m) location
U2= U10(I,J) + (U(I,J,K1-1)-U10(I,J))*599.6/HZ1 !found it between K1-1 and K1, then linear
V2= V10(I,J) + (V(I,J,K1-1)-V10(I,J))*599.6/HZ1 !interpolate to get wind at 2000ft U2,V2
Z2= FIS(I,J)*GI + 609.6
ELSE !otherwise, keep on search upward
DO LP = K1-1,2,-1
DH=DH+(H(I,J,LP-1) - H(I,J,LP))
IF((DH+HZ1+10).gt.609.6) THEN !found the 2000ft level
IF((DH+HZ1+10)>609.6) THEN !found the 2000ft level
Z2=FIS(I,J)*GI+609.6
RT=(Z2-H(I,J,LP))/(H(I,J,LP-1)-H(I,J,LP))
U2=U(I,J,LP)+RT*(U(I,J,LP-1)-U(I,J,LP))
Expand Down Expand Up @@ -398,11 +398,11 @@ SUBROUTINE CALCAT(U,V,H,U_OLD,V_OLD,H_OLD,CAT)
TRBINDX = ABS(VWS)*(DEF + ABS(CVG))
IF(TRBINDX.LE.4.) THEN
IF(TRBINDX<=4.) THEN
CAT(I,J) = 0.0
ELSE IF(TRBINDX.LE.8.) THEN
ELSE IF(TRBINDX<=8.) THEN
CAT(I,J)=1.0
ELSE IF(TRBINDX.LE.12.) THEN
ELSE IF(TRBINDX<=12.) THEN
CAT(I,J)=2.0
ELSE
CAT(I,J)=3.0
Expand Down Expand Up @@ -546,18 +546,18 @@ SUBROUTINE CALFLTCND (CEILING,FLTCND)
CEIL = CEILING(I,J) * 3.2808 !from m -> feet
VISI = VIS(I,J) / 1609.0 !from m -> miles
IF(CEIL.LT.500.0 .OR. VISI.LT.1.0 ) THEN
IF(CEIL<500.0 .OR. VISI<1.0 ) THEN
FLTCND(I,J) = 1.0
ELSE IF( (CEIL.GE.500.AND.CEIL.LT.1000.0) .OR. &
(VISI.GE.1.0.AND.VISI.LT.3.0) ) THEN
ELSE IF( (CEIL>=500.AND.CEIL<1000.0) .OR. &
(VISI>=1.0.AND.VISI<3.0) ) THEN
FLTCND(I,J) = 2.0
ELSE IF( (CEIL.GE.1000.AND.CEIL.LE.3000.0) .OR. &
(VISI.GE.3.0.AND.VISI.LE.5.0) ) THEN
ELSE IF( (CEIL>=1000.AND.CEIL<=3000.0) .OR. &
(VISI>=3.0.AND.VISI<=5.0) ) THEN
FLTCND(I,J) = 3.0
ELSE IF( CEIL.GT.3000.0 .OR. VISI.GT.5.0) THEN
ELSE IF( CEIL>3000.0 .OR. VISI>5.0) THEN
FLTCND(I,J) = 4.0
END IF
Expand Down
2 changes: 1 addition & 1 deletion sorc/ncep_post.fd/AllGETHERV_GSD.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,7 @@ SUBROUTINE AllGETHERV(GRID1)
ibufsend(ij)=GRID1(i,j)
enddo
enddo
if(ij .ne. RECVCOUNTS(me+1)) then
if(ij /= RECVCOUNTS(me+1)) then
write(*,*) 'Error: send account is not equal to receive account',me,ij,RECVCOUNTS(me+1)
endif

Expand Down
28 changes: 14 additions & 14 deletions sorc/ncep_post.fd/BNDLYR.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -224,8 +224,8 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
+PINT(I,J+1,L+1) + PINT(I,J-1,L+1))
DP = PV2-PV1
PMV = 0.5*(PV1+PV2)
IF((PBINT(IW,J,LBND).GE.PMV).AND. &
(PBINT(IW,J,LBND+1).LE.PMV)) THEN
IF((PBINT(IW,J,LBND)>=PMV).AND. &
(PBINT(IW,J,LBND+1)<=PMV)) THEN
PVSUM(I,J,LBND) = PVSUM(I,J,LBND) + DP
UBND(I,J,LBND) = UBND(I,J,LBND) + DP* UH(I,J,L)
VBND(I,J,LBND) = VBND(I,J,LBND) + DP*VH(I,J,L)
Expand All @@ -249,8 +249,8 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
+PINT(IW,J+1,L+1) + PINT(IE,J+1,L+1))
DP = PV2-PV1
PMV = 0.5*(PV1+PV2)
IF((PBINT(IW,J,LBND).GE.PMV).AND. &
(PBINT(IW,J,LBND+1).LE.PMV)) THEN
IF((PBINT(IW,J,LBND)>=PMV).AND. &
(PBINT(IW,J,LBND+1)<=PMV)) THEN
PVSUM(I,J,LBND) = PVSUM(I,J,LBND)+DP
UBND(I,J,LBND) = UBND(I,J,LBND)+UH(I,J,L)*DP
VBND(I,J,LBND) = VBND(I,J,LBND)+VH(I,J,L)*DP
Expand All @@ -268,7 +268,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
DO LBND=1,NBND
DO J=JSTA,JEND
DO I=1,IM
IF(PSUM(I,J,LBND).NE.0.)THEN
IF(PSUM(I,J,LBND)/=0.)THEN
RPSUM = 1./PSUM(I,J,LBND)
LVLBND(I,J,LBND)= LVLBND(I,J,LBND)/NSUM(I,J,LBND)
PBND(I,J,LBND) = (PBINT(I,J,LBND)+PBINT(I,J,LBND+1))*0.5
Expand All @@ -289,7 +289,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
IF(gridtype=='E' .or. gridtype=='B')THEN
DO J=JSTA_M,JEND_M
DO I=2,IM-1
IF(PVSUM(I,J,LBND).NE.0.)THEN
IF(PVSUM(I,J,LBND)/=0.)THEN
RPVSUM = 1./PVSUM(I,J,LBND)
UBND(I,J,LBND) = UBND(I,J,LBND)*RPVSUM
VBND(I,J,LBND) = VBND(I,J,LBND)*RPVSUM
Expand All @@ -307,15 +307,15 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
DO LBND=1,NBND
DO J=JSTA,JEND
DO I=1,IM
IF(PSUM(I,J,LBND).EQ.0.)THEN
IF(PSUM(I,J,LBND)==0.)THEN
L = LM
PMIN = 9999999.
PBND(I,J,LBND) = (PBINT(I,J,LBND)+PBINT(I,J,LBND+1))*0.5
!
DO LL=1,LM
PM = PMID(I,J,LL)
DELP = ABS(PM-PBND(I,J,LBND))
IF(DELP.LT.PMIN)THEN
IF(DELP<PMIN)THEN
PMIN = DELP
L = LL
ENDIF
Expand Down Expand Up @@ -347,11 +347,11 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
! RH, BOUNDS CHECK
!
RHBND(I,J,LBND) = QBND(I,J,LBND)/QSBND(I,J,LBND)
IF (RHBND(I,J,LBND).GT.1.0) THEN
IF (RHBND(I,J,LBND)>1.0) THEN
RHBND(I,J,LBND) = 1.0
QBND(I,J,LBND) = RHBND(I,J,LBND)*QSBND(I,J,LBND)
ENDIF
IF (RHBND(I,J,LBND).LT.0.01) THEN
IF (RHBND(I,J,LBND)<0.01) THEN
RHBND(I,J,LBND) = 0.01
QBND(I,J,LBND) = RHBND(I,J,LBND)*QSBND(I,J,LBND)
ENDIF
Expand All @@ -361,7 +361,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
IF(gridtype == 'E')THEN
DO J=JSTA_M,JEND_M
DO I=2,IM-1
IF(PVSUM(I,J,LBND).EQ.0.)THEN
IF(PVSUM(I,J,LBND)==0.)THEN
LV = LM
PMINV = 9999999.
IE = I+MOD(J,2)
Expand All @@ -375,7 +375,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
PINT(IW,J,LL+1) + PINT(IE,J,LL+1) + &
PINT(I,J+1,LL+1) + PINT(I,J-1,LL+1))
DELPV = ABS(PMV-PBND(I,J,LBND))
IF(DELPV.LT.PMINV)THEN
IF(DELPV<PMINV)THEN
PMINV = DELPV
LV = LL
ENDIF
Expand All @@ -391,7 +391,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
ELSE IF(gridtype=='B')THEN
DO J=JSTA_M,JEND_M
DO I=2,IM-1
IF(PVSUM(I,J,LBND).EQ.0.)THEN
IF(PVSUM(I,J,LBND)==0.)THEN
LV=LM
PMINV=9999999.
IE=I+1
Expand All @@ -405,7 +405,7 @@ SUBROUTINE BNDLYR(PBND,TBND,QBND,RHBND,UBND,VBND, &
PINT(IW,J,LL+1)+PINT(IE,J,LL+1)+ &
PINT(IW,J+1,LL+1)+PINT(IE,J+1,LL+1))
DELPV=ABS(PMV-PBND(I,J,LBND))
IF(DELPV.LT.PMINV)THEN
IF(DELPV<PMINV)THEN
PMINV=DELPV
LV=LL
ENDIF
Expand Down
4 changes: 2 additions & 2 deletions sorc/ncep_post.fd/CALCAPE.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -224,7 +224,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
!--------------TRIAL MAXIMUM BUOYANCY LEVEL VARIABLES-------------------
DO KB=1,LM
!hc IF (ITYPE.EQ.2.AND.KB.GT.1) cycle
!hc IF (ITYPE==2.AND.KB>1) cycle
IF (ITYPE == 1 .OR. (ITYPE == 2 .AND. KB == 1)) THEN
!$omp parallel do private(i,j,apebtk,apespk,bqk,bqs00k,bqs10k,iq,ittbk, &
Expand All @@ -235,7 +235,7 @@ SUBROUTINE CALCAPE(ITYPE,DPBND,P1D,T1D,Q1D,L1D,CAPE, &
PSFCK = PMID(I,J,NINT(LMH(I,J)))
PKL = PMID(I,J,KB)
!hc IF (ITYPE.EQ.1.AND.(PKL.LT.PSFCK-DPBND.OR.PKL.GT.PSFCK)) cycle
!hc IF (ITYPE==1.AND.(PKL<PSFCK-DPBND.OR.PKL>PSFCK)) cycle
IF (ITYPE ==2 .OR. &
(ITYPE == 1 .AND. (PKL >= PSFCK-DPBND .AND. PKL <= PSFCK)))THEN
IF (ITYPE == 1) THEN
Expand Down
8 changes: 4 additions & 4 deletions sorc/ncep_post.fd/CALCAPE2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -311,7 +311,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!--------------TRIAL MAXIMUM BUOYANCY LEVEL VARIABLES-------------------
DO KB=1,LM
!hc IF (ITYPE.EQ.2.AND.KB.GT.1) cycle
!hc IF (ITYPE==2.AND.KB>1) cycle
IF (ITYPE == 1 .OR. (ITYPE == 2 .AND. KB == 1)) THEN
!$omp parallel do private(i,j,apebtk,apespk,bqk,bqs00k,bqs10k,iq,ittbk, &
Expand All @@ -322,7 +322,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
PSFCK = PMID(I,J,NINT(LMH(I,J)))
PKL = PMID(I,J,KB)
!hc IF (ITYPE.EQ.1.AND.(PKL.LT.PSFCK-DPBND.OR.PKL.GT.PSFCK)) cycle
!hc IF (ITYPE==1.AND.(PKL<PSFCK-DPBND.OR.PKL>PSFCK)) cycle
IF (ITYPE ==2 .OR. &
(ITYPE == 1 .AND. (PKL >= PSFCK-DPBND .AND. PKL <= PSFCK)))THEN
IF (ITYPE == 1) THEN
Expand Down Expand Up @@ -565,7 +565,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
ENDIF
! LFC
IF (ITYPE .NE. 1) THEN
IF (ITYPE /= 1) THEN
PRESK2 = PMID(I,J,L+1)
ESATP2 = min(FPVSNEW(TPAR(I,J,L+1)),PRESK2)
QSATP2 = EPS*ESATP2/(PRESK2-ESATP2*ONEPS)
Expand Down Expand Up @@ -752,7 +752,7 @@ SUBROUTINE CALCAPE2(ITYPE,DPBND,P1D,T1D,Q1D,L1D, &
!$omp parallel do private(i,j)
DO J=JSTA,JEND
DO I=1,IM
IF(L12(I,J).NE.LM .AND. L17(I,J).NE.LM) THEN
IF(L12(I,J)/=LM .AND. L17(I,J)/=LM) THEN
DGLD(I,J)=ZINT(I,J,L17(I,J))-ZINT(I,J,L12(I,J))
DGLD(I,J)=MAX(DGLD(I,J),0.)
ENDIF
Expand Down
6 changes: 3 additions & 3 deletions sorc/ncep_post.fd/CALDRG.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,7 +97,7 @@ SUBROUTINE CALDRG(DRAGCO)
! COMPUTE A DRAG COEFFICIENT.
!
USTRSQ=USTAR(I,J)*USTAR(I,J)
IF(WSPDSQ .GT. 1.0) DRAGCO(I,J)=USTRSQ/WSPDSQ
IF(WSPDSQ > 1.0) DRAGCO(I,J)=USTRSQ/WSPDSQ

END IF
ENDDO
Expand Down Expand Up @@ -141,7 +141,7 @@ SUBROUTINE CALDRG(DRAGCO)
! COMPUTE A DRAG COEFFICIENT.
!
USTRSQ=USTAR(I,J)*USTAR(I,J)
IF(WSPDSQ .GT. 1.0E-6)DRAGCO(I,J)=USTRSQ/WSPDSQ
IF(WSPDSQ > 1.0E-6)DRAGCO(I,J)=USTRSQ/WSPDSQ
!
END DO
END DO
Expand Down Expand Up @@ -185,7 +185,7 @@ SUBROUTINE CALDRG(DRAGCO)
! COMPUTE A DRAG COEFFICIENT.
!
USTRSQ=USTAR(I,J)*USTAR(I,J)
IF(WSPDSQ .GT. 1.0E-6)DRAGCO(I,J)=USTRSQ/WSPDSQ
IF(WSPDSQ > 1.0E-6)DRAGCO(I,J)=USTRSQ/WSPDSQ
!
END DO
END DO
Expand Down
2 changes: 1 addition & 1 deletion sorc/ncep_post.fd/CALHEL.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -342,7 +342,7 @@ SUBROUTINE CALHEL(DEPTH,UST,VST,HELI,USHR1,VSHR1,USHR6,VSHR6)
VSHR6(I,J) = VMEAN5 - VMEAN1

DENOM = USHR6(I,J)*USHR6(I,J)+VSHR6(I,J)*VSHR6(I,J)
IF (DENOM .NE. 0.0) THEN
IF (DENOM /= 0.0) THEN
UST(I,J) = UMEAN6 + (7.5*VSHR6(I,J)/SQRT(DENOM))
VST(I,J) = VMEAN6 - (7.5*USHR6(I,J)/SQRT(DENOM))
ELSE
Expand Down
2 changes: 1 addition & 1 deletion sorc/ncep_post.fd/CALHEL2.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -354,7 +354,7 @@ SUBROUTINE CALHEL2(LLOW,LUPP,DEPTH,UST,VST,HELI,CANGLE)
VSHR6(I,J) = VMEAN5 - VMEAN1

DENOM = USHR6(I,J)*USHR6(I,J)+VSHR6(I,J)*VSHR6(I,J)
IF (DENOM .NE. 0.0) THEN
IF (DENOM /= 0.0) THEN
UST(I,J) = UMEAN6 + (7.5*VSHR6(I,J)/SQRT(DENOM))
VST(I,J) = VMEAN6 - (7.5*USHR6(I,J)/SQRT(DENOM))
ELSE
Expand Down
4 changes: 2 additions & 2 deletions sorc/ncep_post.fd/CALMCVG.f
View file
Original file line number Diff line number Diff line change
Expand Up @@ -95,8 +95,8 @@ SUBROUTINE CALMCVG(Q1D,U1D,V1D,QCNVG)
!$omp parallel do private(i,j,qudx,qvdy,r2dx,r2dy)
DO J=JSTA_M,JEND_M
DO I=2,IM-1
IF(VWND(I,J+1).LT.SPVAL.AND.VWND(I,J-1).LT.SPVAL.AND. &
UWND(I+1,J).LT.SPVAL.AND.UWND(I-1,J).LT.SPVAL) THEN
IF(VWND(I,J+1)<SPVAL.AND.VWND(I,J-1)<SPVAL.AND. &
UWND(I+1,J)<SPVAL.AND.UWND(I-1,J)<SPVAL) THEN
R2DX = 1./(2.*DX(I,J)) !MEB DX?
R2DY = 1./(2.*DY(I,J)) !MEB DY?
QUDX = (Q1D(I+1,J)*UWND(I+1,J)-Q1D(I-1,J)*UWND(I-1,J))*R2DX
Expand Down
Loading

0 comments on commit 2c43340

Please sign in to comment.