diff --git a/dyn_em/module_advect_em.F b/dyn_em/module_advect_em.F index ff03d1a695..fc012f3e09 100644 --- a/dyn_em/module_advect_em.F +++ b/dyn_em/module_advect_em.F @@ -4146,8 +4146,8 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & IF( (config_flags%open_ys) .and. (jts == jds) ) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -4162,8 +4162,8 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & IF( (config_flags%open_ye) .and. (jte == jde)) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7297,8 +7297,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%open_ys) .and. (jts == jds) ) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -7313,8 +7313,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%open_ye) .and. (jte == jde)) THEN - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7330,8 +7330,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%polar) .and. (jts == jds) ) THEN ! Assuming rv(i,k,jds) = 0. - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MIN( 0.5*rv(i,k,jts+1), 0. ) tendency(i,k,jts) = tendency(i,k,jts) & - rdy*( & @@ -7347,8 +7347,8 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & IF( (config_flags%polar) .and. (jte == jde)) THEN ! Assuming rv(i,k,jde) = 0. - DO i = i_start, i_end DO k = kts, ktf + DO i = i_start, i_end vb = MAX( 0.5*rv(i,k,jte-1), 0. ) tendency(i,k,j_end) = tendency(i,k,j_end) & - rdy*( & @@ -7412,6 +7412,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7424,6 +7427,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7436,6 +7442,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7485,6 +7494,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=kts+2 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7497,6 +7509,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf-1 dz = 2./(rdzw(k)+rdzw(k-1)) @@ -7509,6 +7524,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & field(i,k-2,j), field(i,k-1,j), & field(i,k ,j), field(i,k+1,j), -vel ) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + ENDDO + + DO i = i_start, i_end k=ktf dz = 2./(rdzw(k)+rdzw(k-1)) diff --git a/dyn_em/module_big_step_utilities_em.F b/dyn_em/module_big_step_utilities_em.F index 50d7972c62..72e827b275 100644 --- a/dyn_em/module_big_step_utilities_em.F +++ b/dyn_em/module_big_step_utilities_em.F @@ -5105,8 +5105,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (config_flags%cu_physics .gt. 0) THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RUCUTEN(I,K,J) =RUCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RVCUTEN(I,K,J) =RVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RTHCUTEN(I,K,J)=RTHCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) @@ -5116,8 +5116,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQVCUTEN(I,K,J)=RQVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5126,8 +5126,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQCCUTEN(I,K,J)=RQCCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5136,8 +5136,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQRCUTEN(I,K,J)=RQRCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5146,8 +5146,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQICUTEN(I,K,J)=RQICUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5156,8 +5156,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQSCUTEN(I,K,J)=RQSCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5169,8 +5169,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (config_flags%shcu_physics .gt. 0) THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RUSHTEN(I,K,J) =RUSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RVSHTEN(I,K,J) =RVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) RTHSHTEN(I,K,J)=RTHSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) @@ -5180,8 +5180,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQVSHTEN(I,K,J)=RQVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5190,8 +5190,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQCSHTEN(I,K,J)=RQCSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5200,8 +5200,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQRSHTEN(I,K,J)=RQRSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5210,8 +5210,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQISHTEN(I,K,J)=RQISHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5220,8 +5220,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQSSHTEN(I,K,J)=RQSSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5230,8 +5230,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end DO K=k_start,k_end + DO I=i_start,i_end RQGSHTEN(I,K,J)=RQGSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5296,8 +5296,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end RQVFTEN(I,K,J)=RQVFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5312,8 +5312,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & ( config_flags%cu_physics == NTIEDTKESCHEME )) THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end RTHFTEN(I,K,J)=RTHFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k)) ENDDO ENDDO @@ -5322,8 +5322,8 @@ SUBROUTINE phy_prep_part2 ( config_flags, & ! If using moist theta, get dry theta tendency for CPSs IF ( config_flags%use_theta_m == 1 ) THEN DO J=j_start,j_end - DO I=i_start,i_end - DO K=k_start,k_end + DO K=k_start,k_end + DO I=i_start,i_end th_phy(i,k,j) = (t_new(i,k,j) + t0) / (1. + (R_v/R_d) * qv(i,k,j)) rthften(i,k,j) = th_phy(i,k,j)/(t_new(i,k,j)+t0) * & (rthften(i,k,j) - (R_v/R_d) * th_phy(i,k,j) * rqvften(i,k,j)) diff --git a/dyn_em/module_em.F b/dyn_em/module_em.F index b71934b641..56df890f90 100644 --- a/dyn_em/module_em.F +++ b/dyn_em/module_em.F @@ -2208,8 +2208,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (config_flags%cu_physics .gt. 0) THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RUCUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RUCUTEN(I,K,J) RVCUTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RVCUTEN(I,K,J) RTHCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RTHCUTEN(I,K,J) @@ -2220,8 +2220,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQCCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQCCUTEN(I,K,J) ENDDO ENDDO @@ -2230,8 +2230,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQRCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQRCUTEN(I,K,J) ENDDO ENDDO @@ -2240,8 +2240,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQICUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQICUTEN(I,K,J) ENDDO ENDDO @@ -2250,8 +2250,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQSCUTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQSCUTEN(I,K,J) ENDDO ENDDO @@ -2265,8 +2265,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (config_flags%shcu_physics .gt. 0) THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RUSHTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RUSHTEN(I,K,J) RVSHTEN(I,K,J) =(c1(k)*mut(I,J)+c2(k))*RVSHTEN(I,K,J) RTHSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RTHSHTEN(I,K,J) @@ -2277,8 +2277,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQCSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQCSHTEN(I,K,J) ENDDO ENDDO @@ -2287,8 +2287,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQRSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQRSHTEN(I,K,J) ENDDO ENDDO @@ -2297,8 +2297,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQISHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQISHTEN(I,K,J) ENDDO ENDDO @@ -2307,8 +2307,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQSSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQSSHTEN(I,K,J) ENDDO ENDDO @@ -2317,8 +2317,8 @@ SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN DO J=jts,jtf - DO I=its,itf DO K=kts,ktf + DO I=its,itf RQGSHTEN(I,K,J)=(c1(k)*mut(I,J)+c2(k))*RQGSHTEN(I,K,J) ENDDO ENDDO diff --git a/phys/module_ra_rrtmg_lw.F b/phys/module_ra_rrtmg_lw.F index eb8023bc40..6b5dc2d342 100644 --- a/phys/module_ra_rrtmg_lw.F +++ b/phys/module_ra_rrtmg_lw.F @@ -2537,6 +2537,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale ! compute alpha + ! todo - need to permute this loop after adding vectorized expf() function do i = 1, ncol alpha(i, 1) = 0._rb do ilev = 2,nlay @@ -3280,6 +3281,7 @@ subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, & icldlyr(lay) = 0 ! Change to band loop? +! todo permute, remove condition, vectorize expf do ig = 1, ngptlw if (cldfmc(ig,lay) .eq. 1._rb) then ib = ngb(ig) diff --git a/phys/module_ra_rrtmg_sw.F b/phys/module_ra_rrtmg_sw.F index c0eb328a4d..1149bf8c28 100644 --- a/phys/module_ra_rrtmg_sw.F +++ b/phys/module_ra_rrtmg_sw.F @@ -1845,6 +1845,7 @@ subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale ! compute alpha + ! permute this loop do i = 1, ncol alpha(i, 1) = 0._rb do ilev = 2,nlay @@ -8597,28 +8598,36 @@ subroutine spcvmc_sw & zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk) ! /\/\/\ Above code only needed for direct beam calculation + enddo - +! to vectorize the following loop + do jk=1, klev ! Delta scaling - clear zf = zgcc(jk) * zgcc(jk) zwf = zomcc(jk) * zf ztauc(jk) = (1.0_rb - zwf) * ztauc(jk) zomcc(jk) = (zomcc(jk) - zwf) / (1.0_rb - zwf) zgcc (jk) = (zgcc(jk) - zf) / (1.0_rb - zf) + enddo ! Total sky optical parameters (cloud properties already delta-scaled) ! Use this code if cloud properties are derived in rrtmg_sw_cldprop if (icpr .ge. 1) then + do jk=1,klev + ikl=klev+1-jk ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw) zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + & ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk) zomco(jk) = zomco(jk) / ztauo(jk) + enddo ! Total sky optical parameters (if cloud properties not delta scaled) ! Use this code if cloud properties are not derived in rrtmg_sw_cldprop elseif (icpr .eq. 0) then + do jk=1,klev + ikl=klev+1-jk ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + ptaucmc(ikl,iw) zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + & ztaur(ikl,iw) * 1.0_rb @@ -8633,10 +8642,10 @@ subroutine spcvmc_sw & ztauo(jk) = (1._rb - zwf) * ztauo(jk) zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf) zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf) + enddo endif ! End of layer loop - enddo ! Clear sky reflectivities call reftra_sw (klev, & @@ -8734,22 +8743,27 @@ subroutine spcvmc_sw & pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw) pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) + enddo ! Accumulate direct fluxes for UV/visible bands if (ibm >= 10 .and. ibm <= 13) then + do jk=1,klev+1 + ikl=klev+2-jk puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw) puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw) puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) + enddo ! Accumulate direct fluxes for near-IR bands else if (ibm == 14 .or. ibm <= 9) then + do jk=1,klev+1 + ikl=klev+2-jk pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw) pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw) pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk) pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk) - endif - enddo + endif ! End loop on jg, g-point interval enddo @@ -9429,8 +9443,8 @@ subroutine rrtmg_sw & ! enddo ! enddo - do i = 1, nlayers - do ib = 1, nbndsw + do ib = 1, nbndsw + do i = 1, nlayers ztaua(i,ib) = 0._rb zasya(i,ib) = 0._rb zomga(i,ib) = 0._rb @@ -9453,8 +9467,8 @@ subroutine rrtmg_sw & ! IAER=10: Direct specification of aerosol optical properties from GCM elseif (iaer.eq.10) then - do i = 1 ,nlayers - do ib = 1 ,nbndsw + do ib = 1 ,nbndsw + do i = 1 ,nlayers ztaua(i,ib) = taua(i,ib) ztauacln(i,ib) = 0.0 zasya(i,ib) = asma(i,ib) @@ -9934,8 +9948,8 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, & ! modify to reverse layer indexing here if necessary. if (iaer .ge. 1) then - do l = 1, nlayers - do ib = 1, nbndsw + do ib = 1, nbndsw + do l = 1, nlayers taua(l,ib) = tauaer(iplon,l,ib) ssaa(l,ib) = ssaaer(iplon,l,ib) asma(l,ib) = asmaer(iplon,l,ib) diff --git a/phys/module_radiation_driver.F b/phys/module_radiation_driver.F index 924c820086..e8e2a2d203 100644 --- a/phys/module_radiation_driver.F +++ b/phys/module_radiation_driver.F @@ -1405,8 +1405,8 @@ SUBROUTINE radiation_driver ( & CALL wrf_debug (1, 'in rad driver; use BL clouds') IF (itimestep .NE. 1) THEN DO j = jts,jte - DO i = its,ite DO k = kts,kte + DO i = its,ite CLDFRA(i,k,j)=CLDFRA_BL(i,k,j) ENDDO ENDDO @@ -1414,8 +1414,8 @@ SUBROUTINE radiation_driver ( & ENDIF DO j = jts,jte - DO i = its,ite DO k = kts,kte + DO i = its,ite IF (qc(i,k,j) < 1.E-6 .AND. CLDFRA_BL(i,k,j) > 0.001) THEN qc(i,k,j)=qc(i,k,j) + QC_BL(i,k,j)*CLDFRA_BL(i,k,j) ENDIF