module module_mp_SBM_BreakUp private public Spont_Rain_BreakUp,Spontanous_Init,BreakUp_Snow,KR_SNOW_MIN,KR_SNOW_MAX INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 INTEGER,PARAMETER :: JBreak_Spontanous = 28, & I_Break_Method = 1 DOUBLE PRECISION,PARAMETER :: COL = 0.23105 INTEGER,PARAMETER :: KR_SNOW_MAX = 35 INTEGER,PARAMETER :: KR_SNOW_MIN = 34 DOUBLE PRECISION,PARAMETER :: BREAK_SNOW_KRMAX_0 = 0.02D0 DOUBLE PRECISION,PARAMETER :: BREAK_SNOW_KRMAX_1 = 0.012D0 contains subroutine Spontanous_Init(DTwrf, XL, DROPRADII, Prob, Gain_Var_New, NND, NKR, & ikr_spon_break) implicit none integer,intent(in):: NKR real(kind=r4size),intent(in) :: DTwrf,XL(:),DROPRADII(:) real(kind=r8size),intent(out) :: Prob(:), Gain_Var_New(:,:), NND(:,:) real(kind=r8size) :: diameter(nkr), ratio_new, q_m, gain_var(nkr,nkr), dtime_spon_break, & DROPRADII_dp(nkr),XL_dp(nkr) integer :: kr,i,j, ikr_spon_break real(kind=r8size),parameter :: gamma = 0.453d0 character*256 :: wrf_err_message DROPRADII_dp = DROPRADII XL_dp = XL diameter(:) = DROPRADII_dp(:)*2.0d0*10.0d0 DO KR=1,NKR ikr_spon_break=kr IF (DROPRADII(kr)>=0.3) exit END DO WRITE( wrf_err_message , * ) 'IKR_Spon_Break=',ikr_spon_break CALL wrf_message ( TRIM ( wrf_err_message ) ) if (i_break_method==1) then DO KR=1,NKR prob(kr)=2.94d-7*dexp(34.0d0*DROPRADII(kr)) ENDDO else if (i_break_method==2) then DO KR=1,NKR prob(kr)=0.155d-3*dexp(1.466d0*10.0d0*DROPRADII(kr)) ENDDO endif DO j=ikr_spon_break,nkr DO i=1,j-1 gain_var(j,i)=(145.37d0/xl_dp(i))*(dropradii_dp(i)/dropradii_dp(j))*dexp(-7.0d0*dropradii_dp(i)/dropradii_dp(j)) nnd(j,i)=gamma*dexp(-gamma*diameter(i))/(1-dexp(-gamma*diameter(j))) END DO END DO q_m = 0.0 DO i=1,ikr_spon_break-1 q_m = q_m + gain_var(ikr_spon_break,i)*xl_dp(i)**2; END DO ratio_new = q_m/xl_dp(ikr_spon_break) DO j=ikr_spon_break,nkr DO i=1,j-1 gain_var_new(j,i) = gain_var(j,i)/ratio_new END DO END DO RETURN End Subroutine Spontanous_Init SUBROUTINE Spont_Rain_BreakUp (DTwrf, FF1R, XL, Prob, Gain_Var_New, NND, NKR, ikr_spon_break) implicit none integer,intent(in) :: NKR, IKR_Spon_Break real(kind=r8size),intent(INOUT) :: FF1R(:) real(kind=r8size),intent(IN) ::XL(:),Prob(:),Gain_Var_New(:,:),NND(:,:) real(kind=r4size),intent(in) :: DTwrf real(kind=r8size) :: dm, deg01, tmp_1, tmp_2, tmp_3 real(kind=r8size),dimension(nkr) :: dropconc_bf, dropconc_af, drops_break, psi1, dropradii integer :: kr,i,imax,j real(kind=r4size) :: start_time, end_time, dtime_spon_break dtime_spon_break = DTwrf DEG01 = 1.0/3.0 DO KR=1,NKR DROPRADII(KR)=(3.*XL(KR)/4./3.141593/1.)**DEG01 ENDDO if(SUM(FF1R) <= nkr*1.D-30) return imax=nkr do i=nkr,1,-1 imax=i if (FF1R(i) > 0.0D0) exit enddo if (imax 273.15)then FL(kmax) = 1.0d0 RF(kmax) = 0.0d0 else FL(kmax) = 0.0d0 RF(kmax) = 1.0d0 endif ELSE if(TIN > 273.15)then RF(KMAX) = 0.0 FL(KMAX) = FLW_MAX/F(KMAX) else FL(KMAX) = 0.0 RF(KMAX) = FRM_MAX/F(KMAX)/(1.0D0-FL(KMAX)) endif END IF DO K=KMAX+1,NKR F(K)=0.0D0 if(TIN > 273.15)then RF(K) = 0.0D0 FL(K) = 1.0D0 else RF(K) = 1.0D0 FL(K) = 0.0D0 endif ENDDO G(KMAX)=3.0D0*F(KMAX)*A DO K=KMAX-1,KMIN-1,-1 G(K)=F(K)*3.0D0*X(K)*X(K) GLW(K)=G(K)*FL(K) GRM(K)=G(K)*(1.0D0-FL(K))*RF(K) ENDDO DO K=KMAX,KMIN,-1 DEL_GLW(K) = G(K)*BREAK_SNOW(K)*FL(K) GLW(K-1) = GLW(K-1)+DEL_GLW(K) DEL_GRM(K) = G(K)*(1.0D0-FL(K))*RF(K)*BREAK_SNOW(K) GRM(K-1) = GRM(K-1)+DEL_GRM(K) G(K-1) = G(K-1)+G(K)*BREAK_SNOW(K) F(K-1) = G(K-1)/3.0D0/X(K-1)/X(K-1) if (G(k-1) < 1.0d-20) then if(TIN > 273.15)then FL(k-1) = 1.0d0 RF(k-1) = 0.0d0 else FL(k-1) = 0.0d0 RF(k-1) = 1.0d0 endif else if(TIN > 273.15)then FL(k-1) = GLW(k-1)/G(k-1) RF(K-1) = 0.0 else FL(K-1) = 0.0 RF(k-1) = GRM(k-1)/G(k-1)/(1.0D0-FL(k-1)) endif endif G(K) = G(K)*(1.0D0-BREAK_SNOW(K)) F(K) = G(K)/3.0D0/X(K)/X(K) END DO RETURN END SUBROUTINE BreakUp_Snow end module module_mp_SBM_BreakUp module module_mp_SBM_Collision private public coll_xyy_lwf, coll_xyx_lwf, coll_xxx_lwf, & coll_xyz_lwf, coll_xxy_lwf, & modkrn_KS, coll_breakup_KS, courant_bott_KS INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 integer,parameter :: kp_flux_max = 44 real(kind=r8size), parameter :: G_LIM = 1.0D-16 integer,parameter :: kr_sgs_max = 20 contains subroutine coll_xyy_lwf (gx,gy,flx,fly,ckxy,x,y, & c,ima,prdkrn,nkr,indc) implicit none integer,intent(in) :: nkr real(kind=r8size),intent(inout) :: gy(:),gx(:),fly(:),flx(:) real(kind=r8size),intent(in) :: ckxy(:,:),x(:),y(:),c(:,:) integer,intent(in) :: ima(:,:) real(kind=r8size),intent(in) :: prdkrn real(kind=r8size) :: gmin,ckxy_ji,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w,gk,gk_w,& fl_gk,fl_gsk,flux,x1,flux_w,gy_k_w,gy_kp_old,gy_kp_w integer :: j,jx0,jx1,i,iy0,iy1,jmin,indc,k,kp gmin = 1.0d-60 do j=1,nkr-1 jx0=j if(gx(j).gt.gmin) goto 2000 enddo 2000 continue if(jx0.eq.nkr-1) return do j=nkr-1,jx0,-1 jx1=j if(gx(j).gt.gmin) goto 2010 enddo 2010 continue do i=1,nkr-1 iy0=i if(gy(i).gt.gmin) goto 2001 enddo 2001 continue if(iy0.eq.nkr-1) return do i=nkr-1,iy0,-1 iy1=i if(gy(i).gt.gmin) goto 2011 enddo 2011 continue do i = iy0,iy1 if(gy(i).le.gmin) goto 2020 jmin = i if(jmin.eq.nkr-1) return if(i.lt.jx0) jmin=jx0-indc do j=jmin+indc,jx1 if(gx(j).le.gmin) goto 2021 k=ima(i,j) kp=k+1 ckxy_ji=ckxy(j,i) x01=ckxy_ji*gy(i)*gx(j)*prdkrn x02=dmin1(x01,gy(i)*x(j)) x03=dmin1(x02,gx(j)*y(i)) gsi=x03/x(j) gsj=x03/y(i) gsk=gsi+gsj if(gsk.le.gmin) goto 2021 gsi_w=gsi*fly(i) gsj_w=gsj*flx(j) gsk_w=gsi_w+gsj_w gsk_w=dmin1(gsk_w,gsk) gy(i)=gy(i)-gsi gy(i)=dmax1(gy(i),0.0d0) gx(j)=gx(j)-gsj gx(j)=dmax1(gx(j),0.0d0) gk=gy(k)+gsk if(gk.le.gmin) goto 2021 gk_w=gy(k)*fly(k)+gsk_w gk_w=dmin1(gk_w,gk) fl_gk=gk_w/gk fl_gsk=gsk_w/gsk flux=0.d0 x1=dlog(gy(kp)/gk+1.d-15) flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j)))) flux=dmin1(flux,gsk) flux=dmin1(flux,gk) if(kp.gt.kp_flux_max) flux=0.5d0*flux flux_w=flux*fl_gsk flux_w=dmin1(flux_w,gsk_w) flux_w=dmin1(flux_w,gk_w) gy(k)=gk-flux gy(k)=dmax1(gy(k),gmin) gy_k_w=gk*fl_gk-flux_w gy_k_w=dmin1(gy_k_w,gy(k)) gy_k_w=dmax1(gy_k_w,0.0d0) fly(k)=gy_k_w/gy(k) gy_kp_old=gy(kp) gy(kp)=gy(kp)+flux gy(kp)=dmax1(gy(kp),gmin) gy_kp_w=gy_kp_old*fly(kp)+flux_w gy_kp_w=dmin1(gy_kp_w,gy(kp)) fly(kp)=gy_kp_w/gy(kp) if(fly(k).gt.1.0d0.and.fly(k).le.1.0001d0) & fly(k)=1.0d0 if(fly(kp).gt.1.0d0.and.fly(kp).le.1.0001d0) & fly(kp)=1.0d0 if(fly(k).gt.1.0001d0.or.fly(kp).gt.1.0001d0 & .or.fly(k).lt.0.0d0.or.fly(kp).lt.0.0d0) then print*, 'in subroutine coll_xyy_lwf' if(fly(k).gt.1.0001d0) print*, 'fly(k).gt.1.0001d0' if(fly(kp).gt.1.0001d0) print*, 'fly(kp).gt.1.0001d0' if(fly(k).lt.0.0d0) print*, 'fly(k).lt.0.0d0' if(fly(kp).lt.0.0d0) print*, 'fly(kp).lt.0.0d0' print*, 'i,j,k,kp' print*, i,j,k,kp print*, 'jx0,jx1,iy0,iy1' print*, jx0,jx1,iy0,iy1 print*, 'ckxy(j,i),x01,x02,x03' print 204, ckxy(j,i),x01,x02,x03 print*, 'gsi,gsj,gsk' print 203, gsi,gsj,gsk print*, 'gsi_w,gsj_w,gsk_w' print 203, gsi_w,gsj_w,gsk_w print*, 'gk,gk_w' print 202, gk,gk_w print*, 'fl_gk,fl_gsk' print 202, fl_gk,fl_gsk print*, 'x1,c(i,j)' print 202, x1,c(i,j) print*, 'flux' print 201, flux print*, 'flux_w' print 201, flux_w print*, 'gy_k_w' print 201, gy_k_w print*, 'gy_kp_w' print 201, gy_kp_w if(fly(k).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xyy_lwf, fly(k) < 0' if(fly(kp).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xyy_lwf, fly(kp) < 0' if(fly(k).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xyy_lwf, fly(k) > 1.0001' if(fly(kp).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xyy_lwf, fly(kp) > 1.0001' call wrf_error_fatal3("",610,& "in coal_bott coll_xyy_lwf, model stop") endif 2021 continue enddo 2020 continue enddo 201 format(1x,d13.5) 202 format(1x,2d13.5) 203 format(1x,3d13.5) 204 format(1x,4d13.5) return end subroutine coll_xyy_lwf subroutine coll_xxx_lwf(g,fl,ckxx,x,c,ima,prdkrn,nkr) implicit none integer,intent(in) :: nkr real(kind=r8size),intent(inout) :: g(:),fl(:) real(kind=r8size),intent(in) :: ckxx(:,:),x(:), c(:,:) integer,intent(in) :: ima(:,:) real(kind=r8size),intent(in) :: prdkrn real(kind=r8size):: gmin,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w,gk, & gk_w,fl_gk,fl_gsk,flux,x1,flux_w,g_k_w,g_kp_old,g_kp_w integer :: i,ix0,ix1,j,k,kp gmin=g_lim*1.0d3 do i=1,nkr-1 ix0=i if(g(i).gt.gmin) goto 2000 enddo 2000 continue if(ix0.eq.nkr-1) return do i=nkr-1,1,-1 ix1=i if(g(i).gt.gmin) goto 2010 enddo 2010 continue do i=ix0,ix1 if(g(i).le.gmin) goto 2020 do j=i,ix1 if(g(j).le.gmin) goto 2021 k=ima(i,j) kp=k+1 x01=ckxx(i,j)*g(i)*g(j)*prdkrn x02=dmin1(x01,g(i)*x(j)) if(j.ne.k) x03=dmin1(x02,g(j)*x(i)) if(j.eq.k) x03=x02 gsi=x03/x(j) gsj=x03/x(i) gsk=gsi+gsj if(gsk.le.gmin) goto 2021 gsi_w=gsi*fl(i) gsj_w=gsj*fl(j) gsk_w=gsi_w+gsj_w gsk_w=dmin1(gsk_w,gsk) g(i)=g(i)-gsi g(i)=dmax1(g(i),0.0d0) g(j)=g(j)-gsj if(j.ne.k) g(j)=dmax1(g(j),0.0d0) gk=g(k)+gsk if(g(j).lt.0.d0.and.gk.le.gmin) then g(j)=0.d0 g(k)=g(k)+gsi goto 2021 endif if(gk.le.gmin) goto 2021 gk_w=g(k)*fl(k)+gsk_w gk_w=dmin1(gk_w,gk) fl_gk=gk_w/gk fl_gsk=gsk_w/gsk flux=0.d0 x1=dlog(g(kp)/gk+1.d-15) flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j)))) flux=dmin1(flux,gsk) flux=dmin1(flux,gk) if(kp.gt.kp_flux_max) flux=0.5d0*flux flux_w=flux*fl_gsk flux_w=dmin1(flux_w,gsk_w) flux_w=dmin1(flux_w,gk_w) g(k)=gk-flux g(k)=dmax1(g(k),gmin) g_k_w=gk_w-flux_w g_k_w=dmin1(g_k_w,g(k)) g_k_w=dmax1(g_k_w,0.0d0) fl(k)=g_k_w/g(k) g_kp_old=g(kp) g(kp)=g(kp)+flux g(kp)=dmax1(g(kp),gmin) g_kp_w=g_kp_old*fl(kp)+flux_w g_kp_w=dmin1(g_kp_w,g(kp)) fl(kp)=g_kp_w/g(kp) if(fl(k).gt.1.0d0.and.fl(k).le.1.0001d0) & fl(k)=1.0d0 if(fl(kp).gt.1.0d0.and.fl(kp).le.1.0001d0) & fl(kp)=1.0d0 if(fl(k).gt.1.0001d0.or.fl(kp).gt.1.0001d0 & .or.fl(k).lt.0.0d0.or.fl(kp).lt.0.0d0) then print*, 'in subroutine coll_xxx_lwf' print*, 'snow - snow = snow' if(fl(k).gt.1.0001d0) print*, 'fl(k).gt.1.0001d0' if(fl(kp).gt.1.0001d0) print*, 'fl(kp).gt.1.0001d0' if(fl(k).lt.0.0d0) print*, 'fl(k).lt.0.0d0' if(fl(kp).lt.0.0d0) print*, 'fl(kp).lt.0.0d0' print*, 'i,j,k,kp' print*, i,j,k,kp print*, 'ix0,ix1' print*, ix0,ix1 print*, 'ckxx(i,j),x01,x02,x03' print 204, ckxx(i,j),x01,x02,x03 print*, 'gsi,gsj,gsk' print 203, gsi,gsj,gsk print*, 'gsi_w,gsj_w,gsk_w' print 203, gsi_w,gsj_w,gsk_w print*, 'gk,gk_w' print 202, gk,gk_w print*, 'fl_gk,fl_gsk' print 202, fl_gk,fl_gsk print*, 'x1,c(i,j)' print 202, x1,c(i,j) print*, 'flux' print 201, flux print*, 'flux_w' print 201, flux_w print*, 'g_k_w' print 201, g_k_w print *, 'g_kp_w' print 201, g_kp_w if(fl(k).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xxx_lwf, fl(k) < 0' if(fl(kp).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xxx_lwf, fl(kp) < 0' if(fl(k).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xxx_lwf, fl(k) > 1.0001' if(fl(kp).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xxx_lwf, fl(kp) > 1.0001' call wrf_error_fatal3("",790,& "in coal_bott sub. coll_xxx_lwf, model stop") endif 2021 continue enddo 2020 continue enddo 201 format(1x,d13.5) 202 format(1x,2d13.5) 203 format(1x,3d13.5) 204 format(1x,4d13.5) return end subroutine coll_xxx_lwf subroutine coll_xyx_lwf (gx,gy,flx,fly,ckxy,x,y, & c,ima,prdkrn,nkr,indc,dm_rime) implicit none integer,intent(in) :: nkr real(kind=r8size),intent(inout) :: gy(:),gx(:),fly(:),flx(:),dm_rime(:) real(kind=r8size),intent(in) :: ckxy(:,:),x(:),y(:),c(:,:),prdkrn integer,intent(in) :: ima(:,:) real(kind=r8size) :: gmin,x01,x02,x03,gsi,gsj,gsk,gk,flux,x1,gsi_w,gsj_w,gsk_w, & gk_w,fl_gk,fl_gsk,flux_w,gx_k_w,gx_kp_old,gx_kp_w,frac_split integer :: j, jx0, jx1, i, iy0, iy1, jmin, indc, k, kp gmin=g_lim*1.0d3 do j=1,nkr-1 jx0=j if(gx(j).gt.gmin) goto 2000 end do 2000 continue if(jx0.eq.nkr-1) return do j=nkr-1,jx0,-1 jx1=j if(gx(j).gt.gmin) goto 2010 end do 2010 continue do i=1,nkr-1 iy0=i if(gy(i).gt.gmin) goto 2001 end do 2001 continue if(iy0.eq.nkr-1) return do i=nkr-1,iy0,-1 iy1=i if(gy(i).gt.gmin) goto 2011 end do 2011 continue do i = 1,nkr dm_rime(i)=0.0 end do do i=iy0,iy1 if(gy(i).le.gmin) goto 2020 jmin=i if(jmin.eq.nkr-1) return if(i.lt.jx0) jmin=jx0-indc do j=jmin+indc,jx1 if(gx(j).le.gmin) goto 2021 k=ima(i,j) kp=k+1 x01=ckxy(j,i)*gy(i)*gx(j)*prdkrn x02=dmin1(x01,gy(i)*x(j)) if(j.ne.k) x03=dmin1(x02,gx(j)*y(i)) if(j.eq.k) x03=x02 gsi=x03/x(j) gsj=x03/y(i) gsk=gsi+gsj if(gsk.le.gmin) goto 2021 gsi_w=gsi*fly(i) gsj_w=gsj*flx(j) gsk_w=gsi_w+gsj_w gsk_w=dmin1(gsk_w,gsk) gy(i)=gy(i)-gsi gy(i)=dmax1(gy(i),0.0d0) gx(j)=gx(j)-gsj if(j.ne.k) gx(j)=dmax1(gx(j),0.0d0) gk=gx(k)+gsk if(gk.le.gmin) goto 2021 gk_w=gx(k)*flx(k)+gsk_w gk_w=dmin1(gk_w,gk) fl_gk=gk_w/gk fl_gsk=gsk_w/gsk flux=0.d0 x1=dlog(gx(kp)/gk+1.d-15) flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j)))) flux=dmin1(flux,gsk) flux=dmin1(flux,gk) if(kp.gt.kp_flux_max) flux=0.5d0*flux flux_w=flux*fl_gsk flux_w=dmin1(flux_w,gsk_w) flux_w=dmin1(flux_w,gk_w) frac_split = flux/gsk if(frac_split < 0.) frac_split = 0. if(frac_split > 1.) frac_split = 1. dm_rime(k)=dm_rime(k)+gsi*(1.-frac_split) dm_rime(kp)=dm_rime(kp)+gsi*frac_split gx(k)=gk-flux gx(k)=dmax1(gx(k),gmin) gx_k_w=gk_w-flux_w gx_k_w=dmin1(gx_k_w,gx(k)) gx_k_w=dmax1(gx_k_w,0.0d0) flx(k)=gx_k_w/gx(k) gx_kp_old=gx(kp) gx(kp)=gx(kp)+flux gx(kp)=dmax1(gx(kp),gmin) gx_kp_w=gx_kp_old*flx(kp)+flux_w gx_kp_w=dmin1(gx_kp_w,gx(kp)) flx(kp)=gx_kp_w/gx(kp) if(flx(k).gt.1.0d0.and.flx(k).le.1.0001d0) & flx(k)=1.0d0 if(flx(kp).gt.1.0d0.and.flx(kp).le.1.0001d0) & flx(kp)=1.0d0 if(flx(k).gt.1.0001d0.or.flx(kp).gt.1.0001d0 & .or.flx(k).lt.0.0d0.or.flx(kp).lt.0.0d0) then print*, 'in subroutine coll_xyx_lwf' if(flx(k).gt.1.0001d0) & print*, 'flx(k).gt.1.0001d0' if(flx(kp).gt.1.0001d0) & print*, 'flx(kp).gt.1.0001d0' if(flx(k).lt.0.0d0) print*, 'flx(k).lt.0.0d0' if(flx(kp).lt.0.0d0) print*, 'flx(kp).lt.0.0d0' print*, 'i,j,k,kp' print*, i,j,k,kp print*, 'jx0,jx1,iy0,iy1' print*, jx0,jx1,iy0,iy1 print*, 'gx_kp_old' print 201, gx_kp_old print*, 'ckxy(j,i),x01,x02,x03' print 204, ckxy(j,i),x01,x02,x03 print*, 'gsi,gsj,gsk' print 203, gsi,gsj,gsk print*, 'gsi_w,gsj_w,gsk_w' print 203, gsi_w,gsj_w,gsk_w print*, 'gk,gk_w' print 202, gk,gk_w print*, 'fl_gk,fl_gsk' print 202, fl_gk,fl_gsk print*, 'x1,c(i,j)' print 202, x1,c(i,j) print*, 'flux' print 201, flux print*, 'flux_w' print 201, flux_w print*, 'gx_k_w' print 201, gx_k_w print*, 'gx_kp_w' print 201, gx_kp_w if(flx(k).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xyx_lwf, flx(k) < 0' if(flx(kp).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xyx_lwf, flx(kp) < 0' if(flx(k).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xyx_lwf, flx(k) > 1.0001' if(flx(kp).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xyx_lwf, flx(kp) > 1.0001' call wrf_error_fatal3("",993,& "fatal error in module_mp_fast_sbm in coll_xyx_lwf (stop 2022), model stop") stop 2022 endif 2021 continue enddo 2020 continue enddo 201 format(1x,d13.5) 202 format(1x,2d13.5) 203 format(1x,3d13.5) 204 format(1x,4d13.5) return end subroutine coll_xyx_lwf subroutine coll_xyz_lwf(gx,gy,gz,flx,fly,flz,ckxy,x,y, & c,ima,prdkrn,nkr,indc) implicit none integer,intent(in) :: nkr real(kind=r8size),intent(inout) :: gx(:),gy(:),gz(:),flx(:),fly(:),flz(:) real(kind=r8size),intent(in) :: ckxy(:,:),x(:),y(:),c(:,:) integer,intent(in) :: ima(:,:) real(kind=r8size),intent(in) :: prdkrn real(kind=r8size) :: gmin,ckxy_ji,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w,gk, & gk_w,fl_gk,fl_gsk,flux,x1,flux_w,gz_k_w,gz_kp_old,gz_kp_w integer :: j,jx0,jx1,i,iy0,iy1,jmin,indc,k,kp gmin = 1.0d-60 do j=1,nkr-1 jx0=j if(gx(j).gt.gmin) goto 2000 enddo 2000 continue if(jx0.eq.nkr-1) return do j=nkr-1,jx0,-1 jx1=j if(gx(j).gt.gmin) goto 2010 enddo 2010 continue do i=1,nkr-1 iy0=i if(gy(i).gt.gmin) goto 2001 enddo 2001 continue if(iy0.eq.nkr-1) return do i=nkr-1,iy0,-1 iy1=i if(gy(i).gt.gmin) goto 2011 enddo 2011 continue do i=iy0,iy1 if(gy(i).le.gmin) goto 2020 jmin=i if(jmin.eq.nkr-1) return if(i.lt.jx0) jmin=jx0-indc do j=jmin+indc,jx1 if(gx(j).le.gmin) goto 2021 k=ima(i,j) kp=k+1 ckxy_ji=ckxy(j,i) x01=ckxy_ji*gy(i)*gx(j)*prdkrn x02=dmin1(x01,gy(i)*x(j)) x03=dmin1(x02,gx(j)*y(i)) gsi=x03/x(j) gsj=x03/y(i) gsk=gsi+gsj if(gsk.le.gmin) goto 2021 gsi_w=gsi*fly(i) gsj_w=gsj*flx(j) gsk_w=gsi_w+gsj_w gsk_w=dmin1(gsk_w,gsk) gy(i)=gy(i)-gsi gy(i)=dmax1(gy(i),0.0d0) gx(j)=gx(j)-gsj gx(j)=dmax1(gx(j),0.0d0) gk=gz(k)+gsk if(gk.le.gmin) goto 2021 gk_w=gz(k)*flz(k)+gsk_w gk_w=dmin1(gk_w,gk) fl_gk=gk_w/gk fl_gsk=gsk_w/gsk flux=0.d0 x1=dlog(gz(kp)/gk+1.d-15) flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j)))) flux=dmin1(flux,gsk) flux=dmin1(flux,gk) if(kp.gt.kp_flux_max) flux=0.5d0*flux flux_w=flux*fl_gsk flux_w=dmin1(flux_w,gsk_w) flux_w=dmin1(flux_w,gk_w) gz(k)=gk-flux gz(k)=dmax1(gz(k),gmin) gz_k_w=gk*fl_gk-flux_w gz_k_w=dmin1(gz_k_w,gz(k)) gz_k_w=dmax1(gz_k_w,0.0d0) flz(k)=gz_k_w/gz(k) gz_kp_old=gz(kp) gz(kp)=gz(kp)+flux gz(kp)=dmax1(gz(kp),gmin) gz_kp_w=gz_kp_old*flz(kp)+flux_w gz_kp_w=dmin1(gz_kp_w,gz(kp)) flz(kp)=gz_kp_w/gz(kp) if(flz(k).gt.1.0d0.and.flz(k).le.1.0001d0) & flz(k)=1.0d0 if(flz(kp).gt.1.0d0.and.flz(kp).le.1.0001d0) & flz(kp)=1.0d0 if(flz(k).gt.1.0001d0.or.flz(kp).gt.1.0001d0 & .or.flz(k).lt.0.0d0.or.flz(kp).lt.0.0d0) then print*, 'in subroutine coll_xyz_lwf' if(flz(k).gt.1.0001d0) print*, 'flz(k).gt.1.0001d0' if(flz(kp).gt.1.0001d0) print*, 'flz(kp).gt.1.0001d0' if(flz(k).lt.0.0d0) print*, 'flz(k).lt.0.0d0' if(flz(kp).lt.0.0d0) print*, 'flz(kp).lt.0.0d0' print*, 'i,j,k,kp' print*, i,j,k,kp print*, 'jx0,jx1,iy0,iy1' print*, jx0,jx1,iy0,iy1 print*, 'gz_kp_old' print 201, gz_kp_old print*, 'x01,x02,x03' print 203, x01,x02,x03 print*, 'gsi,gsj,gsk' print 203, gsi,gsj,gsk print*, 'gsi_w,gsj_w,gsk_w' print 203, gsi_w,gsj_w,gsk_w print*, 'gk,gk_w' print 202, gk,gk_w print*, 'fl_gk,fl_gsk' print 202, fl_gk,fl_gsk print*, 'x1,c(i,j)' print 202, x1,c(i,j) print*, 'flux' print 201, flux print*, 'flux_w' print 201, flux_w print*, 'gz_k_w' print 201, gz_k_w print*, 'gz_kp_w' print 204, gz_kp_w if(flz(k).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xyz_lwf, flz(k) < 0' if(flz(kp).lt.0.0d0) print*, & 'stop 2022: in subroutine coll_xyz_lwf, flz(kp) < 0' if(flz(k).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xyz_lwf, flz(k) > 1.0001' if(flz(kp).gt.1.0001d0) print*, & 'stop 2022: in sub. coll_xyz_lwf, flz(kp) > 1.0001' call wrf_error_fatal3("",1201,& "fatal error: in sub. coll_xyz_lwf,model stop") endif 2021 continue enddo 2020 continue enddo 201 format(1x,d13.5) 202 format(1x,2d13.5) 203 format(1x,3d13.5) 204 format(1x,4d13.5) return end subroutine coll_xyz_lwf subroutine coll_xxy_lwf(gx,gy,flx,fly,ckxx,x, & c,ima,prdkrn,nkr) implicit none integer,intent(in) :: nkr real(kind=r8size),intent(inout):: gx(nkr),gy(nkr),flx(nkr),fly(nkr) real(kind=r8size),intent(in) :: x(nkr),ckxx(nkr,nkr),c(nkr,nkr) real(kind=r8size),intent(in) :: prdkrn integer,intent(in) :: ima(nkr,nkr) real(kind=r8size) :: gmin,ckxx_ij,x01,x02,x03,gsi,gsj,gsk,gsi_w,gsj_w,gsk_w, & gk,gk_w,flux,flux_w,fl_gk,fl_gsk,x1,gy_k_w,gy_kp_w, & gy_kp_old integer::i,ix0,ix1,j,k,kp gmin = 1.0d-60 do i=1,nkr-1 ix0=i if(gx(i).gt.gmin) goto 2000 enddo 2000 continue if(ix0.eq.nkr-1) return do i=nkr-1,ix0,-1 ix1=i if(gx(i).gt.gmin) goto 2010 enddo 2010 continue do i=ix0,ix1 if(gx(i).le.gmin) goto 2020 do j=i,ix1 if(gx(j).le.gmin) goto 2021 k=ima(i,j) kp=k+1 ckxx_ij = ckxx(i,j) x01=ckxx_ij*gx(i)*gx(j)*prdkrn x02=dmin1(x01,gx(i)*x(j)) x03=dmin1(x02,gx(j)*x(i)) gsi=x03/x(j) gsj=x03/x(i) gsk=gsi+gsj if(gsk.le.gmin) goto 2021 gsi_w=gsi*flx(i) gsj_w=gsj*flx(j) gsk_w=gsi_w+gsj_w gsk_w=dmin1(gsk_w,gsk) gx(i)=gx(i)-gsi gx(i)=dmax1(gx(i),0.0d0) gx(j)=gx(j)-gsj gx(j)=dmax1(gx(j),0.0d0) gk=gy(k)+gsk if(gk.le.gmin) goto 2021 gk_w=gy(k)*fly(k)+gsk_w gk_w=dmin1(gk_w,gk) fl_gk=gk_w/gk fl_gsk=gsk_w/gsk flux=0.d0 x1=dlog(gy(kp)/gk+1.d-15) flux=gsk/x1*(dexp(0.5d0*x1)-dexp(x1*(0.5d0-c(i,j)))) flux=dmin1(flux,gsk) flux=dmin1(flux,gk) if(kp.gt.kp_flux_max) flux=0.5d0*flux flux_w=flux*fl_gsk flux_w=dmin1(flux_w,gk_w) flux_w=dmin1(flux_w,gsk_w) flux_w=dmax1(flux_w,0.0d0) gy(k)=gk-flux gy_k_w=gk*fl_gk-flux_w gy_k_w=dmin1(gy_k_w,gy(k)) gy_k_w=dmax1(gy_k_w,0.0d0) if (gy(k)/=0.0) then fly(k)=gy_k_w/gy(k) else fly(k)=0.0d0 endif gy_kp_old=gy(kp) gy(kp)=gy(kp)+flux gy_kp_w=gy_kp_old*fly(kp)+flux_w gy_kp_w=dmin1(gy_kp_w,gy(kp)) if (gy(kp)/=0.0) then fly(kp)=gy_kp_w/gy(kp) else fly(kp)=0.0d0 endif 2021 continue if(fly(k).gt.1.0d0.and.fly(k).le.1.0001d0) & fly(k)=1.0d0 if(fly(kp).gt.1.0d0.and.fly(kp).le.1.0001d0) & fly(kp)=1.0d0 end do 2020 continue end do return end subroutine coll_xxy_lwf SUBROUTINE INTERPOL_SE (NH, H_TAB, X_TAB, H, X) implicit none integer :: NH real(kind=r4size) :: H_TAB(NH), X_TAB(NH) real(kind=r8size) :: H, X integer :: I, J IF(H > H_TAB(1)) THEN X = X_TAB(1) RETURN ENDIF IF(H < H_TAB(NH)) THEN X = X_TAB(NH) RETURN ENDIF DO I = 2,NH IF(H > H_TAB(I)) THEN J = I-1 X = X_TAB(J)+(X_TAB(I)-X_TAB(J))/ & (H_TAB(I)-H_TAB(J))*(H-H_TAB(J)) RETURN ENDIF ENDDO RETURN END SUBROUTINE INTERPOL_SE subroutine modkrn_KS (tt,qq,pp,rho,factor_t,ttcoal,ICase,Icondition, & Iin,Jin,Kin) implicit none real(kind=r8size),intent(in) :: tt, pp real(kind=r8size),intent(inout) :: qq real(kind=r4size),intent(in) :: ttcoal, rho real(kind=r8size),intent(out) :: factor_t integer :: ICase, Iin, Jin, Kin, Icondition real(kind=r8size) :: satq2, temp, epsf, tc, ttt1, ttt, qs2, qq1, dele, tc_min, & tc_max, factor_max, factor_min, f, t, a, b, c, p, d real(kind=r8size) :: at, bt, ct, dt real(kind=r8size) :: AA,BB,CC,DD,Es,Ew,AA1_MY,BB1_MY real(kind=r4size) :: tt_r, T_tab(7), SE_tab(7) satq2(t,p) = 3.80d3*(10**(9.76421d0-2667.1d0/t))/p temp(a,b,c,d,t) = d*t*t*t+c*t*t+b*t+a tc = tt - 273.15 if (tc > 0.0) return SELECT CASE (ICase) CASE(1) data at, bt, ct, dt /0.88333d0, 0.0931878d0, 0.0034793d0, 4.5185186d-05/ if(qq.le.0.0) qq = 1.0e-15 epsf = 0.5d0 tc = tt - 273.15 ttt1 =temp(at,bt,ct,dt,tc) ttt =ttt1 qs2 =satq2(tt,pp) qq1 =qq*(0.622d0+0.378d0*qs2)/(0.622d0+0.378d0*qq)/qs2 dele =ttt*qq1 if(tc.ge.-6.0d0) then factor_t = dele if(factor_t.lt.epsf) factor_t = epsf if(factor_t.gt.1.0d0) factor_t = 1.0d0 endif if (Icondition == 0) then if(tc.ge.-12.5d0 .and. tc.lt.-6.0d0) factor_t = 0.5D0 if(tc.ge.-17.0d0 .and. tc.lt.-12.5d0) factor_t = 1.0 if(tc.ge.-20.0d0 .and. tc.lt.-17.0d0) factor_t = 0.4d0 else if(tc.ge.-12.5d0 .and. tc.lt.-6.0d0) factor_t = 0.3D0 if(tc.ge.-17.0d0 .and. tc.lt.-12.5d0) factor_t = 0.1d0 if(tc.ge.-20.0d0 .and. tc.lt.-17.0d0) factor_t = 0.05d0 endif if(tc.lt.-20.0d0) then tc_min = ttcoal-273.15d0 tc_max = -20.0d0 if(Icondition == 0)then factor_max = 0.4d0 factor_min = 0.0d0 else factor_max = 0.05d0 factor_min = 0.0d0 endif f = factor_min + (tc-tc_min)*(factor_max-factor_min)/ & (tc_max-tc_min) factor_t = f endif if(tc.lt.-40.0d0) then factor_t = 0.0d0 endif if (factor_t > 1.0) factor_t = 1.0 if(tc.ge.0.0d0) then factor_t = 1.0d0 endif CASE(11) T_tab = [0.0, -0.813, -5.26, -10.13, -14.63, -20.02, -40.0 ] SE_tab = [10.0**(-0.693), 10.0**(-0.72), 10.0**(-0.877), 10.0**(-1.050), 10.0**(-1.212), 10.0**(-1.401), 10.0**(-2.082) ] CALL INTERPOL_SE (size(SE_tab), T_TAB, SE_TAB, TC, factor_t) if(tc < -40.0d0) then factor_t = 0.0d0 endif if (factor_t > 1.0) factor_t = 1.0 if(tc > 0.0d0) then factor_t = 1.0d0 endif END SELECT return end subroutine modkrn_KS subroutine coll_breakup_KS (gt_mg, xt_mg, jmax, dt, jbreak, & PKIJ, QKJ, NKRinput, NKR) implicit none integer,intent(in) :: jmax, jbreak, NKRInput, NKR real(kind=r8size),intent(in) :: xt_mg(:), dt real(kind=r4size),intent(in) :: pkij(:,:,:),qkj(:,:) real(kind=r8size),intent(inout) :: gt_mg(:) integer,parameter :: ia=1, ja=1, ka=1 integer :: ie, je, ke, nkrdiff, jdiff, k, i, j real(kind=r8size),parameter :: eps = 1.0d-20 real(kind=r8size) :: gt(jmax), xt(jmax+1), ft(jmax), fa(jmax), dg(jmax), df(jmax), dbreak(jbreak) & ,amweight(jbreak), gain, aloss ie=jbreak je=jbreak ke=jbreak nkrdiff = nkrinput-nkr do j=1,jmax xt(j)=xt_mg(j) gt(j)=gt_mg(j) ft(j)=gt(j)/xt(j)/xt(j) enddo jdiff=jmax-jbreak fa = 0.0 do k=1,ke-nkrdiff fa(k)=ft(k+jdiff+nkrdiff) enddo xt(jmax+1)=xt(jmax)*2.0d0 amweight = 0.0 dbreak = 0.0 do k=1,ke-nkrdiff gain=0.0d0 do i=1,ie-nkrdiff do j=1,i gain=gain+fa(i)*fa(j)*pkij(k,i,j) enddo enddo aloss=0.0d0 do j=1,je-nkrdiff aloss=aloss+fa(j)*qkj(k,j) enddo j=jmax-jbreak+k+nkrdiff amweight(k)=2.0/(xt(j+1)**2.0-xt(j)**2.0) dbreak(k)=amweight(k)*(gain-fa(k)*aloss) if(dbreak(k) .ne. dbreak(k)) then print*,dbreak(k),amweight(k),gain,fa(k),aloss print*,"-" print*,dbreak print*,"-" print*,amweight print*,"-" print*,j,jmax,jbreak,k,nkrdiff print*,"-" print*,fa print*,"-" print*,xt print*,"-" print*,gt call wrf_error_fatal3("",1573,& " inside coll_breakup, NaN, model stop") endif enddo df = 0.0d0 do j=1,jdiff+nkrdiff df(j)=0.0d0 enddo do j=1,ke-nkrdiff df(j+jdiff)=dbreak(j) enddo do j=1,jmax dg(j)=df(j)*xt(j)*xt(j) enddo do j=1,jmax gt(j)=gt(j)+dg(j)*dt enddo gt_mg = gt return end subroutine coll_breakup_KS subroutine courant_bott_KS(xl, nkr, chucm, ima, scal) implicit none integer,intent(in) :: nkr real,intent(in) :: xl(:) real(kind=r8size),intent(inout) :: chucm(:,:) integer,intent(inout) :: ima(:,:) real(kind=r8size),intent(in) :: scal integer :: k, kk, j, i real(kind=r8size) :: x0, xl_mg(nkr), dlnr xl_mg(1:nkr) = xl(1:nkr)*1.0D3 dlnr=dlog(2.0d0)/(3.0d0*scal) do i = 1,nkr do j = i,nkr x0 = xl_mg(i) + xl_mg(j) do k = j,nkr kk = k if(k == 1) goto 1000 if(xl_mg(k) >= x0 .and. xl_mg(k-1) < x0) then chucm(i,j) = dlog(x0/xl_mg(k-1))/(3.d0*dlnr) if(chucm(i,j) > 1.0d0-1.d-08) then chucm(i,j) = 0.0d0 kk = kk + 1 endif ima(i,j) = min(nkr-1,kk-1) goto 2000 endif 1000 continue enddo 2000 continue chucm(j,i) = chucm(i,j) ima(j,i) = ima(i,j) enddo enddo return end subroutine courant_bott_KS end module module_mp_SBM_Collision module module_mp_SBM_Auxiliary private public :: POLYSVP, JERRATE_KS, JERTIMESC_KS, JERSUPSAT_KS, & JERDFUN_KS, JERDFUN_NEW_KS, Relaxation_Time INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 INTEGER,PARAMETER :: ISIGN_KO_1 = 0, ISIGN_KO_2 = 0, ISIGN_3POINT = 1, & IDebug_Print_DebugModule = 1 DOUBLE PRECISION,PARAMETER::COEFF_REMAPING = 0.0066667D0 DOUBLE PRECISION,PARAMETER::VENTPL_MAX = 5.0D0 DOUBLE PRECISION,PARAMETER::RW_PW_MIN = 1.0D-10 DOUBLE PRECISION,PARAMETER::RI_PI_MIN = 1.0D-10 DOUBLE PRECISION,PARAMETER::RW_PW_RI_PI_MIN = 1.0D-10 DOUBLE PRECISION,PARAMETER::RATIO_ICEW_MIN = 1.0D-4 contains double precision FUNCTION POLYSVP (TT,ITYPE) implicit none real,intent(in) :: TT integer,intent(in) :: ITYPE real(4),parameter :: C1 = -9.09718E0, C2 = -3.56654E0, C3 = 0.876793E0, C4 = 0.78583503E0, & AA1_MY = 2.53E12, BB1_MY = 5.42E3, AA2_MY = 3.41E13, BB2_MY = 6.13E3 real(4) :: ES1N, ES2N method_select: SELECT CASE(ITYPE) Case(0) ES1N = AA1_MY*EXP(-BB1_MY/TT) POLYSVP = ES1N Case(1) ES2N = AA2_MY*EXP(-BB2_MY/TT) POLYSVP = ES2N END SELECT method_select return end function POLYSVP SUBROUTINE JERRATE_KS (xlS, & TP,PP, & Vxl,RIEC,RO1BL, & B11_MY, & ID,IN,fl1,NKR,ICEMAX) IMPLICIT NONE INTEGER,INTENT(IN) :: ID, IN, NKR, ICEMAX REAL(KIND=r4size),INTENT(IN) :: RO1BL(NKR,ID),RIEC(NKR,ID),FL1(NKR) REAL(KIND=r4size),INTENT(INOUT) :: B11_MY(NKR,ID) REAL(KIND=r8size),INTENT(IN) :: PP, TP, xlS(NKR,ID),Vxl(NKR,ID) INTEGER :: KR, nskin(nkr), ICE REAL(KIND=r4size) :: VENTPLM(NKR), FD1(NKR,ICEMAX),FK1(NKR,ICEMAX), xl_MY1(NKR,ICEMAX), & AL1_MY(2),ESAT1(2), TPreal REAL(KIND=r8size) :: PZERO, TZERO, CONST, D_MY, COEFF_VISCOUS, SHMIDT_NUMBER, & A, B, RVT, SHMIDT_NUMBER03, XLS_KR_ICE, RO1BL_KR_ICE, VXL_KR_ICE, REINOLDS_NUMBER, & RESHM, VENTPL, CONSTL, DETL REAL(KIND=r4size) :: deg01,deg03 REAL(KIND=r8size),parameter:: RV_MY=461.5D4, CF_MY=2.4D3, D_MYIN=0.211D0 PZERO=1.013D6 TZERO=273.15D0 do kr=1,nkr if (in==2 .and. fl1(kr)==0.0 .or. in==6 .or. in==3 .and. tp<273.15) then nskin(kr) = 2 else nskin(kr) = 1 endif enddo AL1_MY(1)=2.5D10 AL1_MY(2)=2.834D10 DEG01=1.0/3.0 DEG03=1.0/3.0 CONST=12.566372D0 D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94D0 COEFF_VISCOUS=0.13D0 SHMIDT_NUMBER=COEFF_VISCOUS/D_MY A=2.0D0*(3.0D0/4.0D0/3.141593D0)**DEG01 B=A/COEFF_VISCOUS RVT=RV_MY*TP TPreal = TP ESAT1(1) = POLYSVP(TPreal,0) ESAT1(2) = POLYSVP(TPreal,1) DO KR=1,NKR VENTPLM(KR)=0.0D0 ENDDO SHMIDT_NUMBER03=SHMIDT_NUMBER**DEG03 DO ICE=1,ID DO KR=1,NKR xlS_KR_ICE=xlS(KR,ICE) RO1BL_KR_ICE=RO1BL(KR,ICE) Vxl_KR_ICE=Vxl(KR,ICE) REINOLDS_NUMBER= & B*Vxl_KR_ICE*(xlS_KR_ICE/RO1BL_KR_ICE)**DEG03 RESHM=DSQRT(REINOLDS_NUMBER)*SHMIDT_NUMBER03 IF(REINOLDS_NUMBER<2.5D0) THEN VENTPL=1.0D0+0.108D0*RESHM*RESHM VENTPLM(KR)=VENTPL ELSE VENTPL=0.78D0+0.308D0*RESHM VENTPLM(KR)=VENTPL ENDIF ENDDO DO KR=1,NKR VENTPL=VENTPLM(KR) IF(VENTPL>VENTPL_MAX) THEN VENTPL=VENTPL_MAX VENTPLM(KR)=VENTPL ENDIF CONSTL=CONST*RIEC(KR,ICE) FD1(KR,ICE)=RVT/D_MY/ESAT1(nskin(kr)) FK1(KR,ICE)=(AL1_MY(nskin(kr))/RVT-1.0D0)*AL1_MY(nskin(kr))/CF_MY/TP xl_MY1(KR,ICE)=VENTPL*CONSTL DETL=FK1(KR,ICE)+FD1(KR,ICE) B11_MY(KR,ICE)=xl_MY1(KR,ICE)/DETL ENDDO ENDDO RETURN END SUBROUTINE JERRATE_KS SUBROUTINE JERTIMESC_KS (FI1,X1,SFN11, & B11_MY,CF,ID,NKR,ICEMAX,COL) IMPLICIT NONE INTEGER,INTENT(IN) :: ID,NKR,ICEMAX REAL(KIND=r4size),INTENT(in) :: B11_MY(NKR,ID), FI1(NKR,ID), COL, CF REAL(KIND=r8size),INTENT(in) :: X1(NKR,ID) REAL(KIND=r4size),INTENT(out) :: SFN11(ID) INTEGER :: ICE, KR REAL(KIND=r4size) :: SFN11S, FK, DELM, FUN, B11 DO ICE=1,ID SFN11S=0.0D0 SFN11(ICE)=CF*SFN11S DO KR=1,NKR FK=FI1(KR,ICE) DELM=X1(KR,ICE)*3.0D0*COL FUN=FK*DELM B11=B11_MY(KR,ICE) SFN11S=SFN11S+FUN*B11 ENDDO SFN11(ICE)=CF*SFN11S ENDDO RETURN END SUBROUTINE JERTIMESC_KS SUBROUTINE JERSUPSAT_KS (DEL1,DEL2,DEL1N,DEL2N, & RW,PW,RI,PI, & DT,DEL1INT,DEL2INT,DYN1,DYN2, & ISYM1,ISYM2,ISYM3,ISYM4,ISYM5) IMPLICIT NONE INTEGER,INTENT(INOUT) :: ISYM1, ISYM2(:), ISYM3, ISYM4, ISYM5 REAL(KIND=r4size),INTENT(IN) :: DT, DYN1, DYN2 REAL(KIND=r8size),INTENT(IN) :: DEL1, DEL2 REAL(KIND=r8size),INTENT(INOUT) :: DEL1N,DEL2N,DEL1INT,DEL2INT,RW, PW, RI, PI INTEGER :: I, ISYMICE, IRW, IPW, IRI, IPI REAL(KIND=r8size) :: X, EXPM1, DETER, EXPR, EXPP, A, ALFA, BETA, GAMA, G31, G32, G2, EXPB, EXPG, & C11, C21, C12, C22, A1DEL1N, A2DEL1N, A3DEL1N, A4DEL1N, A1DEL1INT, A2DEL1INT, & A3DEL1INT, A4DEL1INT, A1DEL2N, A2DEL2N, A3DEL2N , A4DEL2N, A1DEL2INT, A2DEL2INT, & A3DEL2INT, A4DEL2INT, A5DEL2INT EXPM1(x)=x+x*x/2.0D0+x*x*x/6.0D0+x*x*x*x/24.0D0+ & x*x*x*x*x/120.0D0 ISYMICE = sum(ISYM2) + ISYM3 + ISYM4 + ISYM5 IRW = 1 IPW = 1 IRI = 1 IPI = 1 IF(max(RW,PW,RI,PI)<=RW_PW_RI_PI_MIN) THEN RW = 0.0 IRW = 0 PW = 0.0 IPW = 0 RI = 0.0 IRI = 0 PI = 0.0 IPI = 0 ISYM1 = 0 ISYMICE = 0 ELSE IF(DMAX1(RW,PW)>RW_PW_MIN) THEN IF(RW < RW_PW_MIN*RW_PW_MIN) THEN RW = 1.0D-20 IRW = 0 ENDIF IF(PW < RW_PW_MIN*RW_PW_MIN)THEN PW = 1.0D-20 IPW = 0 ENDIF IF(DMAX1(PI/PW,RI/RW)<=RATIO_ICEW_MIN) THEN RI = 0.0 IRI = 0 PI = 0.0 IPI = 0 ISYMICE = 0 ENDIF IF(DMIN1(PI/PW,RI/RW)>1.0D0/RATIO_ICEW_MIN) THEN RW = 0.0 IRW = 0 PW = 0.0 IPW = 0 ISYM1 = 0 ENDIF ELSE RW = 0.0 IRW = 0 PW = 0.0 IPW = 0 ISYM1 = 0 ENDIF ENDIF IF(ISYMICE == 0)THEN ISYM2 = 0 ISYM3 = 0 ISYM4 = 0 ISYM5 = 0 ENDIF DETER=RW*PI-PW*RI IF(IRW == 0 .AND. IRI == 0) THEN DEL1N=DEL1+DYN1*DT DEL2N=DEL2+DYN2*DT DEL1INT=DEL1*DT+DYN1*DT*DT/2.0D0 DEL2INT=DEL2*DT+DYN2*DT*DT/2.0D0 GOTO 100 ENDIF IF(IRI == 0) THEN EXPR=EXP(-RW*DT) IF(ABS(RW*DT)>1.0E-6) THEN DEL1N=DEL1*EXPR+(DYN1/RW)*(1.0D0-EXPR) DEL2N=PW*DEL1*EXPR/RW-PW*DYN1*DT/RW- & PW*DYN1*EXPR/(RW*RW)+DYN2*DT+ & DEL2-PW*DEL1/RW+PW*DYN1/(RW*RW) DEL1INT=-DEL1*EXPR/RW+DYN1*DT/RW+ & DYN1*EXPR/(RW*RW)+DEL1/RW-DYN1/(RW*RW) DEL2INT=PW*DEL1*EXPR/(-RW*RW)-PW*DYN1*DT*DT/(2.0D0*RW)+ & PW*DYN1*EXPR/(RW*RW*RW)+DYN2*DT*DT/2.0D0+ & DEL2*DT-PW*DEL1*DT/RW+PW*DYN1*DT/(RW*RW)+ & PW*DEL1/(RW*RW)-PW*DYN1/(RW*RW*RW) GOTO 100 ELSE EXPR=EXPM1(-RW*DT) DEL1N=DEL1+DEL1*EXPR+(DYN1/RW)*(0.0D0-EXPR) DEL2N=PW*DEL1*EXPR/RW-PW*DYN1*DT/RW- & PW*DYN1*EXPR/(RW*RW)+DYN2*DT+DEL2 DEL1INT=-DEL1*EXPR/RW+DYN1*DT/RW+DYN1*EXPR/(RW*RW) DEL2INT=PW*DEL1*EXPR/(-RW*RW)-PW*DYN1*DT*DT/(2.0D0*RW)+ & PW*DYN1*EXPR/(RW*RW*RW)+DYN2*DT*DT/2.0D0+ & DEL2*DT-PW*DEL1*DT/RW+PW*DYN1*DT/(RW*RW) GOTO 100 ENDIF ENDIF IF(IRW == 0) THEN EXPP=EXP(-PI*DT) IF(ABS(PI*DT)>1.0E-6) THEN DEL2N = DEL2*EXPP+(DYN2/PI)*(1.0D0-EXPP) DEL2INT = -DEL2*EXPP/PI+DYN2*DT/PI+ & DYN2*EXPP/(PI*PI)+DEL2/PI-DYN2/(PI*PI) DEL1N = +RI*DEL2*EXPP/PI-RI*DYN2*DT/PI- & RI*DYN2*EXPP/(PI*PI)+DYN1*DT+ & DEL1-RI*DEL2/PI+RI*DYN2/(PI*PI) DEL1INT = -RI*DEL2*EXPP/(PI*PI)-RI*DYN2*DT*DT/(2.0D0*PI)+ & RI*DYN2*EXPP/(PI*PI*PI)+DYN1*DT*DT/2.0D0+ & DEL1*DT-RI*DEL2*DT/PI+RI*DYN2*DT/(PI*PI)+ & RI*DEL2/(PI*PI)-RI*DYN2/(PI*PI*PI) GOTO 100 ELSE EXPP=EXPM1(-PI*DT) DEL2N=DEL2+DEL2*EXPP-EXPP*DYN2/PI DEL2INT=-DEL2*EXPP/PI+DYN2*DT/PI+DYN2*EXPP/(PI*PI) DEL1N=+RI*DEL2*EXPP/PI-RI*DYN2*DT/PI- & RI*DYN2*EXPP/(PI*PI)+DYN1*DT+DEL1 DEL1INT=-RI*DEL2*EXPP/(PI*PI)-RI*DYN2*DT*DT/(2.0D0*PI)+ & RI*DYN2*EXPP/(PI*PI*PI)+DYN1*DT*DT/2.0D0+ & DEL1*DT-RI*DEL2*DT/PI+RI*DYN2*DT/(PI*PI) GOTO 100 ENDIF ENDIF IF(IRW == 1 .AND. IRI == 1) THEN A=(RW-PI)*(RW-PI)+4.0E0*PW*RI IF(A < 0.0) THEN PRINT*, 'IN SUBROUTINE JERSUPSAT: A < 0' PRINT*, 'DETER' PRINT 201, DETER PRINT*, 'RW,PW,RI,PI' PRINT 204, RW,PW,RI,PI PRINT*, 'DT,DYN1,DYN2' PRINT 203, DT,DYN1,DYN2 PRINT*, 'DEL1,DEL2' PRINT 202, DEL1,DEL2 PRINT*, 'STOP 1905:A < 0' call wrf_error_fatal3("",2148,& "fatal error: STOP 1905:A < 0, model stop") ENDIF ALFA=DSQRT((RW-PI)*(RW-PI)+4.0D0*PW*RI) BETA=0.5D0*(ALFA+RW+PI) GAMA=0.5D0*(ALFA-RW-PI) G31=PI*DYN1-RI*DYN2 G32=-PW*DYN1+RW*DYN2 G2=RW*PI-RI*PW IF (G2 < 1.0d-20) G2 = 1.0004d-11*1.0003d-11-1.0002d-11*1.0001e-11 EXPB=DEXP(-BETA*DT) EXPG=DEXP(GAMA*DT) IF(DABS(GAMA*DT)>1.0E-6) THEN C11=(BETA*DEL1-RW*DEL1-RI*DEL2-BETA*G31/G2+DYN1)/ALFA C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA C12=(BETA*DEL2-PW*DEL1-PI*DEL2-BETA*G32/G2+DYN2)/ALFA C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA DEL1N=C11*EXPG+C21*EXPB+G31/G2 DEL1INT=C11*EXPG/GAMA-C21*EXPB/BETA+(C21/BETA-C11/GAMA) & +G31*DT/G2 DEL2N=C12*EXPG+C22*EXPB+G32/G2 DEL2INT=C12*EXPG/GAMA-C22*EXPB/BETA+(C22/BETA-C12/GAMA) & +G32*DT/G2 GOTO 100 ELSE IF(ABS(RI/RW)>1.0E-12) THEN IF(ABS(RW/RI)>1.0E-12) THEN ALFA=DSQRT((RW-PI)*(RW-PI)+4.0D0*PW*RI) BETA=0.5D0*(ALFA+RW+PI) GAMA=0.5D0*(ALFA-RW-PI) IF (GAMA < 0.5*2.0d-10) GAMA=0.5D0*(2.002d-10-2.001d-10) EXPG=EXPM1(GAMA*DT) EXPB=DEXP(-BETA*DT) C11=(BETA*DEL1-RW*DEL1-RI*DEL2+DYN1)/ALFA C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA C12=(BETA*DEL2-PW*DEL1-PI*DEL2+DYN2)/ALFA C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA A1DEL1N=C11 A2DEL1N=C11*EXPG A3DEL1N=C21*EXPB A4DEL1N=G31/G2*(GAMA/ALFA+(GAMA/ALFA-1.0D0)*EXPG) DEL1N=A1DEL1N+A2DEL1N+A3DEL1N+A4DEL1N A1DEL1INT=C11*EXPG/GAMA A2DEL1INT=-C21*EXPB/BETA A3DEL1INT=C21/BETA A4DEL1INT=G31/G2*DT*(GAMA/ALFA) DEL1INT=A1DEL1INT+A2DEL1INT+A3DEL1INT+A4DEL1INT A1DEL2N=C12 A2DEL2N=C12*EXPG A3DEL2N=C22*EXPB A4DEL2N=G32/G2*(GAMA/ALFA+ & (GAMA/ALFA-1.0D0)* & (GAMA*DT+GAMA*GAMA*DT*DT/2.0D0)) DEL2N=A1DEL2N+A2DEL2N+A3DEL2N+A4DEL2N A1DEL2INT=C12*EXPG/GAMA A2DEL2INT=-C22*EXPB/BETA A3DEL2INT=C22/BETA A4DEL2INT=G32/G2*DT*(GAMA/ALFA) A5DEL2INT=G32/G2*(GAMA/ALFA-1.0D0)* & (GAMA*DT*DT/2.0D0) DEL2INT=A1DEL2INT+A2DEL2INT+A3DEL2INT+A4DEL2INT+ & A5DEL2INT ELSE X=-2.0D0*RW*PI+RW*RW+4.0D0*PW*RI ALFA=PI*(1+(X/PI)/2.0D0-(X/PI)*(X/PI)/8.0D0) BETA=PI+(X/PI)/4.0D0-(X/PI)*(X/PI)/16.0D0+RW/2.0D0 GAMA=(X/PI)/4.0D0-(X/PI)*(X/PI)/16.0D0-RW/2.0D0 EXPG=EXPM1(GAMA*DT) EXPB=DEXP(-BETA*DT) C11=(BETA*DEL1-RW*DEL1-RI*DEL2+DYN1)/ALFA C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA C12=(BETA*DEL2-PW*DEL1-PI*DEL2+DYN2)/ALFA C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA DEL1N=C11+C11*EXPG+C21*EXPB+ & G31/G2*(GAMA/ALFA+(GAMA/ALFA-1)*EXPG) DEL1INT=C11*EXPG/GAMA-C21*EXPB/BETA+(C21/BETA)+ & G31/G2*DT*(GAMA/ALFA) DEL2N=C12+C12*EXPG+C22*EXPB+G32/G2*(GAMA/ALFA+ & (GAMA/ALFA-1.0D0)* & (GAMA*DT+GAMA*GAMA*DT*DT/2.0D0)) DEL2INT=C12*EXPG/GAMA-C22*EXPB/BETA+ & (C22/BETA)+G32/G2*DT*(GAMA/ALFA)+ & G32/G2*(GAMA/ALFA-1.0D0)*(GAMA*DT*DT/2.0D0) ENDIF ELSE X=-2.0D0*RW*PI+PI*PI+4.0D0*PW*RI ALFA=RW*(1.0D0+(X/RW)/2.0D0-(X/RW)*(X/RW)/8.0D0) BETA=RW+(X/RW)/4.0D0-(X/RW)*(X/RW)/16.0D0+PI/2.0D0 GAMA=(X/RW)/4.0D0-(X/RW)*(X/RW)/16.0D0-PI/2.0D0 EXPG=EXPM1(GAMA*DT) EXPB=DEXP(-BETA*DT) C11=(BETA*DEL1-RW*DEL1-RI*DEL2+DYN1)/ALFA C21=(GAMA*DEL1+RW*DEL1+RI*DEL2-GAMA*G31/G2-DYN1)/ALFA C12=(BETA*DEL2-PW*DEL1-PI*DEL2+DYN2)/ALFA C22=(GAMA*DEL2+PW*DEL1+PI*DEL2-GAMA*G32/G2-DYN2)/ALFA DEL1N=C11+C11*EXPG+C21*EXPB+ & G31/G2*(GAMA/ALFA+(GAMA/ALFA-1.0D0)*EXPG) DEL1INT=C11*EXPG/GAMA-C21*EXPB/BETA+(C21/BETA)+ & G31/G2*DT*(GAMA/ALFA) DEL2N=C12+C12*EXPG+C22*EXPB+G32/G2* & (GAMA/ALFA+ & (GAMA/ALFA-1.0D0)*(GAMA*DT+GAMA*GAMA*DT*DT/2.0D0)) DEL2INT=C12*EXPG/GAMA-C22*EXPB/BETA+C22/BETA+ & G32/G2*DT*(GAMA/ALFA)+ & G32/G2*(GAMA/ALFA-1.0D0)*(GAMA*DT*DT/2.0D0) ENDIF ENDIF ENDIF 100 CONTINUE 201 FORMAT(1X,D13.5) 202 FORMAT(1X,2D13.5) 203 FORMAT(1X,3D13.5) 204 FORMAT(1X,4D13.5) RETURN END SUBROUTINE JERSUPSAT_KS SUBROUTINE JERDFUN_KS (xi,xiN,B21_MY, & FI2,PSI2,fl2,DEL2N, & ISYM2,IND,ITYPE,TPN,IDROP, & FR_LIM,FRH_LIM,ICEMAX,NKR,COL,Ihydro,Iin,Jin,Kin,Itimestep) IMPLICIT NONE INTEGER,INTENT(IN) :: ISYM2, IND, ITYPE, NKR, ICEMAX, Ihydro, Iin, Jin ,Kin, Itimestep INTEGER,INTENT(INOUT) :: IDROP REAL(kind=R4SIZE),INTENT(IN) :: B21_MY(:), FI2(:), FR_LIM(:), FRH_LIM(:), & DEL2N, COL REAL(kind=R8SIZE),INTENT(IN) :: TPN, xi(:) REAL(kind=R8SIZE),INTENT(INOUT) :: xiN(:) REAL(kind=R4SIZE),INTENT(INOUT) :: PSI2(:), FL2(:) INTEGER :: ITYP, KR, NR, ICE, K, IDSD_Negative REAL(kind=R8SIZE) :: FL2_NEW(NKR), FI2R(NKR), PSI2R(NKR), C, DEGREE1, DEGREE2, DEGREE3, D, RATEXI, & B, A, xiR(NKR),xiNR(NKR), FR_LIM_KR C = 2.0D0/3.0D0 DEGREE1 = 1.0D0/3.0D0 DEGREE2 = C DEGREE3 = 3.0D0/2.0D0 IF(IND > 1) THEN ITYP = ITYPE ELSE ITYP = 1 ENDIF DO KR=1,NKR PSI2R(KR) = FI2(KR) FI2R(KR) = FI2(KR) ENDDO NR=NKR IF(ISYM2 == 1) THEN IF(IND==1 .AND. ITYPE==1) THEN DO KR=1,NKR D=xi(KR)**DEGREE1 RATExi=C*DEL2N*B21_MY(KR)/D B=xi(KR)**DEGREE2 A=B+RATExi IF(A<0.0D0) THEN xiN(KR)=1.0D-50 ELSE xiN(KR)=A**DEGREE3 ENDIF ENDDO ELSE DO KR=1,NKR RATExi = DEL2N*B21_MY(KR) xiN(KR) = xi(KR) + RATExi ENDDO ENDIF DO KR=1,NKR xiR(KR) = xi(KR) xiNR(KR) = xiN(KR) FI2R(KR) = FI2(KR) END DO IDSD_Negative = 0 CALL JERNEWF_KS & (NR,xiR,FI2R,PSI2R,xiNR,ISIGN_3POINT,TPN,IDROP,NKR,COL,IDSD_Negative,Ihydro,Iin,Jin,Kin,Itimestep) IF(IDSD_Negative == 1)THEN IF(ISIGN_KO_1 == 1) THEN ENDIF ENDIF DO KR=1,NKR IF(ITYPE==5) THEN FR_LIM_KR=FRH_LIM(KR) ELSE FR_LIM_KR=FR_LIM(KR) ENDIF IF(PSI2R(KR)<0.0D0) THEN PRINT*, 'STOP 1506 : PSI2R(KR)<0.0D0, in JERDFUN_KS' call wrf_error_fatal3("",2411,& "fatal error in PSI2R(KR)<0.0D0, in JERDFUN_KS, model stop") ENDIF PSI2(KR) = PSI2R(KR) ENDDO ENDIF 201 FORMAT(1X,D13.5) 304 FORMAT(1X,I2,2X,4D13.5) RETURN END SUBROUTINE JERDFUN_KS SUBROUTINE JERNEWF_KS & (NRX,RR,FI,PSI,RN,I3POINT,TPN,IDROP,NKR,COL,IDSD_Negative,Ihydro, & Iin,Jin,Kin,Itimestep) IMPLICIT NONE INTEGER,INTENT(IN) :: NRX, I3POINT, NKR, Ihydro, Iin, Jin, Kin, Itimestep INTEGER,INTENT(INOUT) :: IDROP, IDSD_Negative real(kind=R8SIZE),INTENT(IN) :: TPN real(kind=R4SIZE),INTENT(IN) :: COL real(kind=R8SIZE),INTENT(INOUT) :: PSI(:), RN(:), FI(:), RR(:) INTEGER :: KMAX, KR, I, K , NRXP, ISIGN_DIFFUSIONAL_GROWTH, NRX1, & I3POINT_CONDEVAP, IEvap real(kind=R8SIZE) :: RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, GN1,GN2, & GN3,GN1P,GMAT,GMAT2, & CDROP(NRX),DELTA_CDROP(NRX),RRS(NRX+1),PSINEW(NRX+1), & PSI_IM,PSI_I,PSI_IP, AOLDCON, ANEWCON, AOLDMASS, ANEWMASS INTEGER,PARAMETER :: KRDROP_REMAPING_MIN = 6, KRDROP_REMAPING_MAX = 12 NRXP = NRX + 1 NRX1 = NKR DO I=1,NRX IF(RN(I) < 0.0D0) THEN RN(I) = 1.0D-50 FI(I) = 0.0D0 ENDIF ENDDO DO K=1,NRX RRS(K)=RR(K) ENDDO I3POINT_CONDEVAP = I3POINT IEvap = 0 IF(RN(1) < RRS(1)) THEN I3POINT_CONDEVAP = 0 IDROP = 0 NRX1 = NRX IEvap = 1 ENDIF IF(IDROP == 0) I3POINT_CONDEVAP = 0 DO K=1,NRX PSI(K)=0.0D0 CDROP(K)=0.0D0 DELTA_CDROP(K)=0.0D0 PSINEW(K)=0.0D0 ENDDO RRS(NRXP)=RRS(NRX)*1024.0D0 PSINEW(NRXP) = 0.0D0 ISIGN_DIFFUSIONAL_GROWTH = 0 DO K=1,NRX IF(RN(K).NE.RR(K)) THEN ISIGN_DIFFUSIONAL_GROWTH = 1 GOTO 2000 ENDIF ENDDO 2000 CONTINUE IF(ISIGN_DIFFUSIONAL_GROWTH == 1) THEN DO K=1,NRX1 IF(FI(K) > 0.0) THEN IF(DABS(RN(K)-RR(K)) < 1.0D-16) THEN PSINEW(K) = FI(K)*RR(K) CYCLE ENDIF I = 1 DO WHILE (.NOT.(RRS(I) <= RN(K) .AND. RRS(I+1) >= RN(K)) & .AND.I.LT.NRX1) I = I + 1 ENDDO IF(RN(K).LT.RRS(1)) THEN RNTMP=RN(K) RRTMP=0.0D0 RRP=RRS(1) GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP) PSINEW(1)=PSINEW(1)+FI(K)*RR(K)*GMAT2 ELSE RNTMP=RN(K) RRTMP=RRS(I) RRP=RRS(I+1) GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP) GMAT=(RRP-RNTMP)/(RRP-RRTMP) PSINEW(I)=PSINEW(I)+FI(K)*RR(K)*GMAT PSINEW(I+1)=PSINEW(I+1)+FI(K)*RR(K)*GMAT2 ENDIF ENDIF 3000 CONTINUE ENDDO DO KR=1,NRX1 PSI(KR)=PSINEW(KR) ENDDO DO KR=NRX1+1,NRX PSI(KR)=FI(KR) ENDDO IF(I3POINT_CONDEVAP == 1) THEN DO K=1,NRX1-1 IF(FI(K) > 0.0) THEN IF(DABS(RN(K)-RR(K)).LT.1.0D-16) THEN PSI(K) = FI(K)*RR(K) GOTO 3001 ENDIF IF(RRS(2).LT.RN(K)) THEN I = 2 DO WHILE & (.NOT.(RRS(I) <= RN(K) .AND. RRS(I+1) >= RN(K)) & .AND.I.LT.NRX1-1) I = I + 1 ENDDO RNTMP=RN(K) RRTMP=RRS(I) RRP=RRS(I+1) RRM=RRS(I-1) RNTMP2=RN(K+1) RRTMP2=RRS(I+1) RRP2=RRS(I+2) RRM2=RRS(I) GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ & (RRTMP-RRM) GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ & (RRP2-RRM2)/(RRTMP2-RRM2) GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ & (RRTMP-RRM) GMAT=(RRP-RNTMP)/(RRP-RRTMP) GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ & (RRP-RRTMP) GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP) PSI_IM = PSI(I-1)+GN1*FI(K)*RR(K) PSI_I = PSI(I)+GN1P*FI(K+1)*RR(K+1)+& (GN2-GMAT)*FI(K)*RR(K) PSI_IP = PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K) IF(PSI_IM > 0.0D0) THEN IF(PSI_IP > 0.0D0) THEN IF(I > 2) THEN IF(PSI_IM > PSI(I-2) .AND. PSI_IM < PSI_I & .AND. PSI(I-2) < PSI(I) .OR. PSI(I-2) >= PSI(I)) THEN PSI(I-1) = PSI_IM PSI(I) = PSI(I) + FI(K)*RR(K)*(GN2-GMAT) PSI(I+1) = PSI_IP ENDIF ENDIF ELSE EXIT ENDIF ELSE EXIT ENDIF ENDIF ENDIF 3001 CONTINUE ENDDO ENDIF DO K=1,NRX1 PSI(K)=PSI(K)/RR(K) ENDDO DO K=NRX1+1,NRX PSI(K)=FI(K) ENDDO IF(IDROP == 1) THEN DO K=KRDROP_REMAPING_MIN,KRDROP_REMAPING_MAX CDROP(K)=3.0D0*COL*PSI(K)*RR(K) ENDDO DO K=KRDROP_REMAPING_MAX,KRDROP_REMAPING_MIN,-1 KMAX=K IF(PSI(K).GT.0.0D0) GOTO 2011 ENDDO 2011 CONTINUE DO K=KMAX-1,KRDROP_REMAPING_MIN,-1 IF(CDROP(K).GT.0.0D0) THEN DELTA_CDROP(K)=CDROP(K+1)/CDROP(K) IF(DELTA_CDROP(K).LT.COEFF_REMAPING) THEN CDROP(K)=CDROP(K)+CDROP(K+1) CDROP(K+1)=0.0D0 ENDIF ENDIF ENDDO DO K=KRDROP_REMAPING_MIN,KMAX PSI(K)=CDROP(K)/(3.0D0*COL*RR(K)) ENDDO ENDIF ELSE DO K=1,NRX PSI(K)=FI(K) ENDDO ENDIF DO KR=1,NRX IF(PSI(KR) < 0.0) THEN IDSD_Negative = 1 print*, "IDSD_Negative=",IDSD_Negative,"kr",kr PRINT*, 'IN SUBROUTINE JERNEWF' PRINT*, 'PSI(KR)<0' PRINT*, 'BEFORE EXIT' PRINT*, 'ISIGN_DIFFUSIONAL_GROWTH' PRINT*, ISIGN_DIFFUSIONAL_GROWTH PRINT*, 'I3POINT_CONDEVAP' PRINT*, I3POINT_CONDEVAP PRINT*, 'K,RR(K),RN(K),K=1,NRX' PRINT*, (K,RR(K),RN(K),K=1,NRX) PRINT*, 'K,RR(K),RN(K),FI(K),PSI(K),K=1,NRX' PRINT 304, (K,RR(K),RN(K),FI(K),PSI(K),K=1,NRX) PRINT*, IDROP,Ihydro,Iin,Jin,Kin,Itimestep call wrf_error_fatal3("",2734,& "fatal error in SUBROUTINE JERNEWF PSI(KR)<0, < min, model stop") ENDIF ENDDO 304 FORMAT(1X,I2,2X,4D13.5) RETURN END SUBROUTINE JERNEWF_KS SUBROUTINE JERDFUN_NEW_KS & (xi,xiN,B21_MY, & FI2,PSI2, & TPN,IDROP,FR_LIM,NKR,COL,Ihydro,Iin,Jin,Kin,Itimestep) IMPLICIT NONE INTEGER,INTENT(INOUT) :: IDROP, NKR INTEGER,INTENT(IN) :: Ihydro,Iin,Jin,Kin,Itimestep REAL(kind=R4SIZE),intent(IN) :: FI2(:), B21_MY(:), FR_LIM(:), COL REAL(kind=R8SIZE), INTENT(IN) :: TPN, xi(:) REAL(kind=R4SIZE),INTENT(INOUT) :: PSI2(:) REAL(kind=R8SIZE),INTENT(INOUT) :: xiN(:) INTEGER :: NR, KR, IDSD_Negative REAL(kind=R8SIZE) :: C, DEGREE1, DEGREE2, DEGREE3, D, RATEXI, B, A, & xiR(NKR),FI2R(NKR),PSI2R(NKR),xiNR(NKR) C=2.0D0/3.0D0 DEGREE1=C/2.0D0 DEGREE2=C DEGREE3=3.0D0/2.0D0 NR=NKR xiR = xi FI2R = FI2 PSI2R = PSI2 xiNR = xiN DO KR=1,NKR D = xiR(KR)**DEGREE1 RATExi = C*B21_MY(KR)/D B = xiR(KR)**DEGREE2 A = B+RATExi IF(A<0.0D0) THEN xiNR(KR) = 1.0D-50 ELSE xiNR(KR) = A**DEGREE3 ENDIF ENDDO IDSD_Negative = 0 CALL JERNEWF_KS & (NR,xiR,FI2R,PSI2R,xiNR,ISIGN_3POINT,TPN,IDROP,NKR,COL,IDSD_Negative,Ihydro,Iin,Jin,Kin,Itimestep) IF(IDSD_Negative == 1)THEN IF(ISIGN_KO_2 == 1) THEN ENDIF ENDIF PSI2 = PSI2R 201 FORMAT(1X,D13.5) RETURN END SUBROUTINE JERDFUN_NEW_KS SUBROUTINE Relaxation_Time(TPS,QPS,PP,ROR,DEL1S,DEL2S, & R1,VR1,FF1in,RLEC,RO1BL, & R2,VR2,FF2in,RIEC,RO2BL, & R3,VR3,FF3in,RSEC,RO3BL, & R4,VR4,FF4in,RGEC,RO4BL, & R5,VR5,FF5in,RHEC,RO5BL, & NKR,ICEMAX,COL,DTdyn,NCOND,DTCOND) implicit none integer,intent(in) :: NKR,ICEMAX integer,intent(out) :: NCOND real(kind=R4SIZE),intent(in) :: R1(:),FF1in(:),RLEC(:),RO1BL(:), & R2(:,:),FF2in(:,:),RIEC(:,:),RO2BL(:,:), & R3(NKR),FF3in(:),RSEC(:),RO3BL(:), & R4(NKR),FF4in(:),RGEC(:),RO4BL(:), & R5(NKR),FF5in(:),RHEC(:),RO5BL(:), & ROR,COL,DTdyn,VR1(:),VR2(:,:),VR3(:),VR4(:),VR5(:) real(kind=R8SIZE),intent(in) :: TPS,QPS,PP,DEL1S,DEL2S real(kind=R4SIZE),intent(out) :: DTCOND integer :: ISYM1, ISYM2(ICEMAX), ISYM3, ISYM4, ISYM5, ISYM_SUM, ICM real(kind=R8SIZE),parameter :: AA1_MY = 2.53D12, BB1_MY = 5.42D3, AA2_MY = 3.41D13, & BB2_MY = 6.13E3, AL1 = 2500.0, AL2 = 2834.0 real(kind=R8SIZE),parameter :: TAU_Min = 0.1 real(kind=R8SIZE) :: OPER2, AR1, TAU_RELAX, B5L, B5I, & R1D(NKR), R2D(NKR,ICEMAX), R3D(NKR), R4D(NKR), R5D(NKR), & VR1_d(nkr),VR2_d(nkr,icemax),VR3_d(nkr),VR4_d(nkr),VR5_d(nkr) real(kind=R4SIZE) :: B11_MY(NKR), B21_MY(NKR,ICEMAX), B31_MY(NKR), & B41_MY(NKR), B51_MY(NKR), FL1(NKR), FL3(NKR), FL4(NKR), FL5(NKR), & SFNDUMMY(3), SFN11, SFNI1(ICEMAX), SFNII1, SFN21, SFN31, SFN41, SFN51, SFNI, SFNL, B8L, B8I, RI, PW, & DOPL, DOPI, TAU_w, TAU_i, phi, RW, PI OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1 VR1_d = VR1 VR2_d = VR2 VR3_d = VR3 VR4_d = VR4 VR5_d = VR5 ISYM1 = 0 ISYM2 = 0 ISYM3 = 0 ISYM4 = 0 ISYM5 = 0 IF(sum(FF1in) > 0.0) ISYM1 = 1 IF(sum(FF2in(:,1)) > 1.0D-10) ISYM2(1) = 1 IF(sum(FF2in(:,2)) > 1.0D-10) ISYM2(2) = 1 IF(sum(FF2in(:,3)) > 1.0D-10) ISYM2(3) = 1 IF(sum(FF3in) > 1.0D-10) ISYM3 = 1 IF(sum(FF4in) > 1.0D-10) ISYM4 = 1 IF(sum(FF5in) > 1.0D-10) ISYM5 = 1 ISYM_SUM = ISYM1 + sum(ISYM2) + ISYM3 + ISYM4 + ISYM5 IF(ISYM_SUM == 0)THEN TAU_RELAX = DTdyn NCOND = nint(DTdyn/TAU_RELAX) DTCOND = TAU_RELAX RETURN ENDIF R1D = R1 R2D = R2 R3D = R3 R4D = R4 R5D = R5 B8L=1./ROR B8I=1./ROR ICM = ICEMAX SFN11 = 0.0 SFNI1 = 0.0 SFN31 = 0.0 SFN41 = 0.0 SFN51 = 0.0 B11_MY = 0.0 B21_MY = 0.0 B31_MY = 0.0 B41_MY = 0.0 B51_MY = 0.0 IF(ISYM1 == 1)THEN FL1 = 0.0 CALL JERRATE_KS(R1D,TPS,PP,VR1_d,RLEC,RO1BL,B11_MY,1,1,fl1,NKR,ICEMAX) sfndummy(1) = SFN11 CALL JERTIMESC_KS(FF1in,R1D,SFNDUMMY,B11_MY,B8I,1,NKR,ICEMAX,COL) SFN11 = sfndummy(1) ENDIF IF(ISYM3 == 1) THEN FL3 = 0.0 CALL JERRATE_KS (R3D,TPS,PP,VR3_d,RSEC,RO3BL,B31_MY,1,3,fl3,NKR,ICEMAX) sfndummy(1) = SFN31 CALL JERTIMESC_KS(FF3in,R3D,SFNDUMMY,B31_MY,B8I,1,NKR,ICEMAX,COL) SFN31 = sfndummy(1) ENDIF IF(ISYM4 == 1) THEN FL4 = 0.0 CALL JERRATE_KS(R4D,TPS,PP,VR4_d,RGEC,RO4BL,B41_MY,1,2,fl4,NKR,ICEMAX) sfndummy(1) = SFN41 CALL JERTIMESC_KS(FF4in,R4D,SFNDUMMY,B41_MY,B8I,1,NKR,ICEMAX,COL) SFN41 = sfndummy(1) ENDIF IF(ISYM5 == 1) THEN FL5 = 0.0 CALL JERRATE_KS(R5D,TPS,PP,VR5_d,RHEC,RO5BL,B51_MY,1,2,fl5,NKR,ICEMAX) sfndummy(1) = SFN51 CALL JERTIMESC_KS(FF5in,R5D,SFNDUMMY,B51_MY,B8I,1,NKR,ICEMAX,COL) SFN51 = sfndummy(1) ENDIF SFNII1 = 0.0 SFN21 = 0.0 SFNL = 0.0 SFNI = 0.0 RI = 0.0 PW = 0.0 SFNII1 = SFNI1(1)+SFNI1(2)+SFNI1(3) SFN21 = SFNII1 + SFN31 + SFN41 + SFN51 SFNL = SFN11 SFNI = SFN21 B5L=BB1_MY/TPS/TPS B5I=BB2_MY/TPS/TPS DOPL=1.+ DEL1S DOPI=1.+ DEL2S RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI TAU_w = DTdyn TAU_i = DTdyn phi = (1.0 + DEL2S)/(1.0 + DEL1S) if(PW > 0.0 .or. PI > 0.0) TAU_w = (PW + phi*PI)**(-1.0) if(RW > 0.0 .or. RI > 0.0) TAU_i = phi/(RW + RI*phi) TAU_RELAX = DTdyn IF(PW > 0.0 .or. RI > 0.0) TAU_RELAX = (PW + RI)**(-1.0)/3.0 IF(PW > 0.0 .and. RI > 0.0) TAU_RELAX = min(TAU_w,TAU_i)/3.0 if(TAU_RELAX > DTdyn) TAU_RELAX = DTdyn/3.0 if(TAU_RELAX < TAU_Min) TAU_RELAX = TAU_Min IF(PW <= 0.0 .and. RI <= 0.0) TAU_RELAX = DTdyn NCOND = ceiling(DTdyn/TAU_RELAX) DTCOND = TAU_RELAX RETURN END SUBROUTINE Relaxation_Time end module module_mp_SBM_Auxiliary module module_mp_SBM_Nucleation USE module_mp_SBM_Auxiliary,ONLY:POLYSVP private public JERNUCL01_KS, LogNormal_modes_Aerosol INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 INTEGER,PARAMETER :: Use_cloud_base_nuc = 1 real(kind=r8size),PARAMETER::T_NUCL_DROP_MIN = -80.0D0 real(kind=r8size),PARAMETER::T_NUCL_ICE_MIN = -37.0D0 INTEGER,PARAMETER :: ice_nucl_method = 0 INTEGER,PARAMETER :: ISIGN_TQ_ICENUCL = 1 DOUBLE PRECISION,PARAMETER::DELSUPICE_MAX = 59.0D0 contains SUBROUTINE JERNUCL01_KS(PSI1_r, PSI2_r, FCCNR_r, & XL_r, XI_r, TT, QQ, & ROR_r, PP_r, & SUP1, SUP2, & COL_r, & SUP2_OLD_r, DSUPICE_XYZ_r, & RCCN_r, DROPRADII_r, NKR, NKR_aerosol, ICEMAX, ICEPROCS, & Win_r, Is_This_CloudBase, RO_SOLUTE, IONS, MWAERO, & Iin, Jin, Kin) implicit none integer,intent(in) :: Kin, Jin, Iin, NKR, NKR_aerosol, ICEMAX, ICEPROCS, Is_This_CloudBase,IONS real(kind=r4size),intent(in) :: XL_r(:), XI_r(:,:), ROR_r, PP_r, COL_r, Win_r, & SUP2_OLD_r, DSUPICE_XYZ_r, RCCN_r(:), DROPRADII_r(:) real(kind=r4size),intent(in) :: MWAERO, RO_SOLUTE real(kind=r4size),intent(inout) :: PSI1_r(:),PSI2_r(:,:),FCCNR_r(:) real(kind=r8size),intent(inout) :: TT, QQ, SUP1,SUP2 integer :: KR, ICE, K real(kind=r8size) :: DROPCONCN(NKR), ARG_1, COL3, RORI, TPN, QPN, TPC, AR1, AR2, OPER3, & SUM_ICE, DEL2N, FI2(NKR,ICEMAX), TFREEZ_OLD, DTFREEZXZ, RMASSIAA_NUCL, RMASSIBB_NUCL, & FI2_K, xi_K, FI2R2, DELMASSICE_NUCL, ES1N, ES2N, EW1N real(kind=r8size),parameter :: AL2 = 2834.0D0 real(kind=r8size) :: PSI1(NKR),PSI2(NKR,ICEMAX),FCCNR(NKR_aerosol),ROR,XL(NKR),XI(NKR,ICEMAX),PP,COL, & SUP2_OLD,DSUPICE_XYZ,Win, RCCN(NKR_aerosol),DROPRADII(NKR) real(kind=r4size) :: TPNreal OPER3(AR1,AR2) = AR1*AR2/(0.622D0+0.378D0*AR1) PSI1 = PSI1_r PSI2 = PSI2_r FCCNR = FCCNR_r XL = XL_r XI = XI_r ROR = ROR_r PP = PP_r COL = COL_r SUP2_OLD = SUP2_OLD_r DSUPICE_XYZ = DSUPICE_XYZ_r RCCN = RCCN_r DROPRADII = DROPRADII_r Win = Win_r COL3 = 3.0D0*COL RORI = 1.0D0/ROR TPN = TT QPN = QQ TPC = TT - 273.15D0 IF(SUP1>0.0D0 .AND. TPC>T_NUCL_DROP_MIN) THEN if(sum(FCCNR) > 0.0)then DROPCONCN = 0.0D0 CALL WATER_NUCLEATION (COL, NKR_aerosol, PSI1, FCCNR, xl, TT, QQ, ROR, SUP1, DROPCONCN, & PP, Is_This_CloudBase, Win, RO_SOLUTE, RCCN, IONS,MWAERO) endif IF(TPC <= -38.0D0) THEN SUM_ICE = 0.0D0 DO KR=1,NKR PSI2(KR,2) = PSI2(KR,2) + PSI1(KR) SUM_ICE = SUM_ICE + COL3*xl(KR)*xl(KR)*PSI1(KR) PSI1(KR) = 0.0D0 END DO ARG_1 = 334.0D0*SUM_ICE*RORI TT = TT + ARG_1 ENDIF ENDIF DEL2N = 100.0D0*SUP2 TPC = TT-273.15D0 IF(TPC < 0.0D0 .AND. TPC >= T_NUCL_ICE_MIN .AND. DEL2N > 0.0D0) THEN DO KR=1,NKR DO ICE=1,ICEMAX FI2(KR,ICE)=PSI2(KR,ICE) ENDDO ENDDO if(ice_nucl_method == 0) then CALL ICE_NUCL (PSI2,xi,SUP2,TT,DSUPICE_XYZ,SUP2_OLD,ICEMAX,NKR,COL) endif IF(ISIGN_TQ_ICENUCL == 1) THEN RMASSIAA_NUCL=0.0D0 RMASSIBB_NUCL=0.0D0 DO K=1,NKR DO ICE=1,ICEMAX FI2_K=FI2(K,ICE) xi_K=xi(K,ICE) FI2R2=FI2_K*xi_K*xi_K RMASSIBB_NUCL=RMASSIBB_NUCL+FI2R2 ENDDO ENDDO RMASSIBB_NUCL = RMASSIBB_NUCL*COL3*RORI IF(RMASSIBB_NUCL < 0.0D0) RMASSIBB_NUCL = 0.0D0 DO K=1,NKR DO ICE=1,ICEMAX FI2_K=PSI2(K,ICE) xi_K=xi(K,ICE) FI2R2=FI2_K*xi_K*xi_K RMASSIAA_NUCL=RMASSIAA_NUCL+FI2R2 ENDDO ENDDO RMASSIAA_NUCL = RMASSIAA_NUCL*COL3*RORI IF(RMASSIAA_NUCL < 0.0D0) RMASSIAA_NUCL=0.0D0 DELMASSICE_NUCL = RMASSIAA_NUCL-RMASSIBB_NUCL QPN = QQ-DELMASSICE_NUCL QQ = QPN TPN = TT + AL2*DELMASSICE_NUCL TT = TPN TPNreal = TPN ES1N = POLYSVP(TPNreal,0) ES2N = POLYSVP(TPNreal,1) EW1N = OPER3(QPN,PP) SUP1 = EW1N/ES1N-1.0D0 SUP2 = EW1N/ES2N-1.0D0 ENDIF ENDIF PSI1_r = PSI1 PSI2_r = PSI2 FCCNR_r = FCCNR RETURN END SUBROUTINE JERNUCL01_KS SUBROUTINE WATER_NUCLEATION (COL, NKR, PSI1, FCCNR, xl, TT, QQ, ROR, SUP1, & DROPCONCN, PP, Is_This_CloudBase, Win, RO_SOLUTE, & RCCN, IONS, MWAERO) implicit none integer,intent(in) :: Is_This_CloudBase, NKR, IONS real(kind=r8size),intent(in) :: xl(:), ROR, PP, Win, RCCN(:), COL real(kind=r8size),intent(inout) :: FCCNR(:), PSI1(:), DROPCONCN(:), QQ, TT, SUP1 real(kind=r4size),intent(in) :: RO_SOLUTE, MWAERO integer :: IMAX, I, NCRITI, KR real(kind=r8size) :: DX,AR2,RCRITI,DEG01,RORI,CCNCONC(NKR),AKOE,BKOE, AR1, OPER3, RCCN_MINIMUM, & DLN1, DLN2, RMASSL_NUCL, ES1N, EW1N real(kind=r8size),parameter :: AL1 = 2500.0D0 real(kind=r4size) :: TTreal OPER3(AR1,AR2)=AR1*AR2/(0.622D0+0.378D0*AR1) DROPCONCN(:) = 0.0D0 DEG01 = 1.0D0/3.0D0 RORI=1.0/ROR IMAX = NKR DO I=IMAX,1,-1 IF(FCCNR(I) > 0.0D0) THEN IMAX = I exit ENDIF ENDDO NCRITI=0 do while (IMAX>=NCRITI) CCNCONC = 0.0 AKOE=3.3D-05/TT BKOE = ions*4.3/mwaero BKOE=BKOE*(4.0D0/3.0D0)*3.141593D0*RO_SOLUTE if(Use_cloud_base_nuc == 1) then if(Is_This_CloudBase == 1) then CALL Cloud_Base_Super (FCCNR, RCCN, TT, PP, Win, NKR, RCRITI, RO_SOLUTE, IONS, MWAERO, COL) else RCRITI = (AKOE/3.0D0)*(4.0D0/BKOE/SUP1/SUP1)**DEG01 endif else RCRITI=(AKOE/3.0D0)*(4.0D0/BKOE/SUP1/SUP1)**DEG01 endif IF(RCRITI >= RCCN(IMAX)) EXIT NCRITI = IMAX do while (RCRITI<=RCCN(NCRITI) .and. NCRITI>1) NCRITI=NCRITI-1 enddo RCCN_MINIMUM = RCCN(1)/10000.0D0 IF (NCRITI==IMAX-1) then if (NCRITI>1) then DLN1=DLOG(RCRITI)-DLOG(RCCN(IMAX-1)) DLN2=COL-DLN1 CCNCONC(IMAX)=DLN2*FCCNR(IMAX) FCCNR(IMAX)=FCCNR(IMAX)*DLN1/COL else DLN1=DLOG(RCRITI)-DLOG(RCCN_MINIMUM) DLN2=DLOG(RCCN(1))-DLOG(RCRITI) CCNCONC(IMAX)=DLN2*FCCNR(IMAX) FCCNR(IMAX)=FCCNR(IMAX)*DLN1/(DLN1+DLN2) endif else CCNCONC(IMAX) = COL*FCCNR(IMAX) FCCNR(IMAX)=0.0D0 endif RMASSL_NUCL=0.0D0 if (IMAX <= NKR-7) then DROPCONCN(1) = DROPCONCN(1)+CCNCONC(IMAX) RMASSL_NUCL = RMASSL_NUCL+CCNCONC(IMAX)*XL(1)*XL(1) else DROPCONCN(8-(NKR-IMAX)) = DROPCONCN(8-(NKR-IMAX))+CCNCONC(IMAX) RMASSL_NUCL = RMASSL_NUCL + CCNCONC(IMAX)*XL(8-(NKR-IMAX))*XL(8-(NKR-IMAX)) endif RMASSL_NUCL = RMASSL_NUCL*COL*3.0*RORI IMAX = IMAX-1 end do IF(sum(DROPCONCN) > 0.0)THEN DO KR = 1,8 DX = 3.0D0*COL*xl(KR) PSI1(KR) = PSI1(KR)+DROPCONCN(KR)/DX ENDDO ENDIF RETURN END SUBROUTINE WATER_NUCLEATION SUBROUTINE ICE_NUCL (PSI2,xi,SUP2,TT,DSUPICE_XYZ,SUP2_OLD,ICEMAX,NKR,COL) implicit none integer,intent(in) :: NKR, ICEMAX real(kind=r8size),intent(in) :: xi(:,:), DSUPICE_XYZ, COL real(kind=r8size),intent(inout) :: PSI2(:,:),TT,SUP2,SUP2_OLD integer :: KR,ICE,ITYPE real(kind=r8size) :: FI2(NKR,ICEMAX), CONCI_BFNUCL(ICEMAX), CONCI_AFNUCL(ICEMAX) real(kind=r8size),parameter :: A1 = -0.639D0, B1 = 0.1296D0, A2 = -2.8D0, B2 = 0.262D0, & TEMP1 = -5.0D0, TEMP2 = -2.0D0, TEMP3 = -20.0D0 real(kind=r8size),PARAMETER::C1_MEY = 1.0D-3 real(kind=r8size),PARAMETER::C2_MEY = 0.0D0 INTEGER,PARAMETER :: NRGI = 2 real(kind=r8size) :: C1,C2,TPC,DEL2N,DEL2NN,HELEK1,HELEK2,FF1BN,FACT,DSUP2N,DELTACD,DELTAF, & ADDF,DELCONCI_AFNUCL,TPCC,DX C1=C1_MEY C2=C2_MEY DO KR=1,NKR DO ICE=1,ICEMAX FI2(KR,ICE)=PSI2(KR,ICE) ENDDO ENDDO DO ICE=1,ICEMAX CONCI_BFNUCL(ICE)=0.0D0 DO KR=1,NKR CONCI_BFNUCL(ICE)=CONCI_BFNUCL(ICE)+ & 3.0D0*COL*PSI2(KR,ICE)*xi(KR,ICE) ENDDO ENDDO TPC = TT-273.15D0 ITYPE=0 IF((TPC>-4.0D0).OR.(TPC<=-8.1D0.AND.TPC>-12.7D0).OR. & (TPC<=-17.8D0.AND.TPC>-22.4D0)) THEN ITYPE=2 ELSE IF((TPC<=-4.0D0.AND.TPC>-8.1D0) & .OR.(TPC<=-22.4D0)) THEN ITYPE=1 ELSE ITYPE=3 ENDIF ENDIF ICE=ITYPE IF (TPC < TEMP1) THEN DEL2N = 100.0D0*SUP2 DEL2NN = DEL2N IF( DEL2N > DELSUPICE_MAX) DEL2NN = DELSUPICE_MAX HELEK1 = C1*DEXP(A1+B1*DEL2NN) ELSE HELEK1 = 0.0D0 ENDIF IF(TPC < TEMP2) THEN TPCC = TPC IF(TPCC < TEMP3) TPCC = TEMP3 HELEK2 = C2*DEXP(A2-B2*TPCC) ELSE HELEK2 = 0.0D0 ENDIF FF1BN = HELEK1+HELEK2 FACT=1.0D0 DSUP2N = (SUP2-SUP2_OLD+DSUPICE_XYZ)*100.0D0 SUP2_OLD = SUP2 IF(DSUP2N > DELSUPICE_MAX) DSUP2N = DELSUPICE_MAX DELTACD = FF1BN*B1*DSUP2N IF(DELTACD>=FF1BN) DELTACD=FF1BN IF(DELTACD>0.0D0) THEN DELTAF=DELTACD*FACT if(CONCI_BFNUCL(ICE)<=helek1) then DO KR=1,NRGI-1 DX=3.0D0*xi(KR,ICE)*COL ADDF=DELTAF/DX PSI2(KR,ICE)=PSI2(KR,ICE)+ADDF ENDDO endif ENDIF DO ICE=1,ICEMAX CONCI_AFNUCL(ICE)=0.0D0 DO KR=1,NKR CONCI_AFNUCL(ICE)=CONCI_AFNUCL(ICE)+ & 3.0D0*COL*PSI2(KR,ICE)*xi(KR,ICE) END DO DELCONCI_AFNUCL=DABS(CONCI_AFNUCL(ICE)-CONCI_BFNUCL(ICE)) IF(DELCONCI_AFNUCL>10.0D0) THEN PRINT*, 'IN SUBROUTINE ICE_NUCL, AFTER NUCLEATION' PRINT*, 'BECAUSE DELCONCI_AFNUCL > 10/cm^3' PRINT*, 'CONCI_BFNUCL(ICE),CONCI_AFNUCL(ICE)' PRINT 202, CONCI_BFNUCL(ICE),CONCI_AFNUCL(ICE) PRINT*, 'DELTACD,DSUP2N,FF1BN,B1,DSUPICEXZ,SUP2' PRINT 206, DELTACD,DSUP2N,FF1BN,B1,DSUPICE_XYZ,SUP2 PRINT*, 'KR, FI2(KR,ICE), PSI2(KR,ICE), KR=1,NKR' PRINT 302, (KR, FI2(KR,ICE), PSI2(KR,ICE), KR=1,NKR) PRINT*, 'STOP 099 : DELCONCI_AFNUCL(ICE) > 10/cm^3' STOP 099 ENDIF END DO 202 FORMAT(1X,2D13.5) 206 FORMAT(1X,6D13.5) 302 FORMAT(1X,I2,2X,2D13.5) RETURN END SUBROUTINE ICE_NUCL SUBROUTINE Cloud_Base_Super (FCCNR, RCCN, TT, PP, Wbase, NKR, RCRITI, RO_SOLUTE, IONS, MWAERO, & COL) implicit none integer,intent(in) :: NKR, IONS real(kind=r8size),intent(in) :: TT, PP, Wbase, RCCN(:), COL real(kind=r8size),intent(inout) :: FCCNR(:), RCRITI real(kind=r4size),intent(in) :: MWAERO, RO_SOLUTE integer :: NR, NN, KR real(kind=r8size) :: PL(NKR), supmax(NKR), AKOE, BKOE, C3, PR, CCNCONACT, DL1, DL2, & TPC CALL supmax_COEFF(AKOE,BKOE,C3,PP,TT,RO_SOLUTE,IONS,MWAERO) PR = C3*wbase**(0.75D0) SupMax = 999.0 PL = 0.0 NN = -1 DO NR=2,NKR supmax(NR)=DSQRT((4.0D0*AKOE**3.0D0)/(27.0D0*RCCN(NR)**3.0D0*BKOE)) CCNCONACT=0.0D0 DO KR=NR,NKR CCNCONACT = CCNCONACT + COL*FCCNR(KR) ENDDO PL(NR)=supmax(NR)*(DSQRT(CCNCONACT)) IF(PL(NR).LE.PR) THEN NN = NR EXIT ENDIF END DO if (nn == -1) then print*,"PR, Wbase [cm/s], C3",PR,wbase,C3 print*,"PL",PL CALL wrf_error_fatal3("",3533,& 'NN is not defined in cloud base routine, model stop' ) endif DL1 = dabs(PL(NN-1)-PR) DL2 = dabs(PL(NN)-PR) RCRITI = RCCN(NN-1)*dexp(COL*DL1/(DL1+DL2)) RETURN END SUBROUTINE Cloud_Base_Super SUBROUTINE supmax_COEFF (AKOE,BKOE,C3,PP,TT,RO_SOLUTE,IONS,MWAERO) implicit none integer,intent(in) :: IONS real(kind=r8size) ,intent(in) :: PP, TT real(kind=r8size) ,intent(out) :: AKOE, BKOE, C3 real,intent(in) :: MWAERO, RO_SOLUTE real(kind=r8size) ,parameter :: RV_MY = 461.5D4, CP = 1005.0D4, G = 9.8D2, RD_MY = 287.0D4, & PI = 3.141593D0 real(kind=r8size) :: PZERO,TZERO,ALW1,SW,RO_W,HC,EW,RO_V,DV,RO_A,FL,FR,F,TPC,QV,A1,A2, & C1,C2,DEG01,DEG02 TPC = TT-273.15d0 PZERO=1.01325D6 TZERO=273.15D0 ALW1 = -6.143419998D-2*tpc**(3.0D0)+1.58927D0*tpc**(2.0D0) & -2.36418D3*tpc+2.50079D6 ALW1 = ALW1*10.0D3 IF(tpc.LT.-5.5D0) THEN Sw = 5.285D-11*tpc**(6.0D0)+6.283D-9*tpc**(5.0D0)+ & 2.933D-7*tpc**(4.0D0)+6.511D-6*tpc**(3.0D0)+ & 6.818D-5*tpc**(2.0D0)+1.15D-4*tpc+7.593D-2 ELSE Sw = -1.55D-4*tpc+7.566165D-2 ENDIF Sw = Sw*10.0D2 IF (tpc.LT.0.0D0) THEN RO_W= -7.497D-9*tpc**(6.0D0)-3.6449D-7*tpc**(5.0D0) & -6.9987D-6*tpc**(4.0D0)+1.518D-4*tpc**(3.0D0) & -8.486D-3*tpc**(2.0D0)+6.69D-2*tpc+9.9986D2 ELSE RO_W=(-3.932952D-10*tpc**(5.0D0)+1.497562D-7*tpc**(4.0D0) & -5.544846D-5*tpc**(3.0D0)-7.92221D-3*tpc**(2.0D0)+ & 1.8224944D1*tpc+9.998396D2)/(1.0D0+1.8159725D-2*tpc) ENDIF RO_W=RO_W*1.0D-3 HC=7.1128D-5*tpc+2.380696D-2 HC=HC*10.0D4 ew = 6.38780966D-9*tpc**(6.0D0)+2.03886313D-6*tpc**(5.0D0)+ & 3.02246994D-4*tpc**(4.0D0)+2.65027242D-2*tpc**(3.0D0)+ & 1.43053301D0*tpc**(2.0D0)+4.43986062D1*tpc+6.1117675D2 ew=ew*10.0D0 AKOE=2.0D0*Sw/(RV_MY*RO_W*(tpc+TZERO)) BKOE = ions*4.3/mwaero BKOE=BKOE*(4.0D0/3.0D0)*pi*RO_SOLUTE RO_V = ew/(RV_MY*(tpc+TZERO)) DV = 0.211D0*(PZERO/PP)*((tpc+TZERO)/TZERO)**(1.94D0) RO_A=PZERO/((tpc+TZERO)*RD_MY) FL=(RO_W*ALW1**(2.0D0))/(HC*RV_MY*(tpc+TZERO)**(2.0D0)) FR = RO_W*RV_MY*(tpc+TZERO)/(ew*DV) F = FL + FR QV=RO_V/RO_A A1=(G*ALW1/(CP*RV_MY*(tpc+TZERO)**(2.0D0)))-(G/(RD_MY*(tpc+TZERO))) A2=(1.0D0/QV)+(ALW1**(2.0D0))/(CP*RV_MY*(tpc+TZERO)**(2.0D0)) C1=1.058D0 C2=1.904D0 DEG01=1.0D0/3.0D0 DEG02=1.0D0/6.0D0 C3=C1*(F*A1/3.0D0)**(0.75D0)*DSQRT(3.0D0*RO_A/(4.0D0*pi*RO_W*A2)) RETURN END SUBROUTINE SupMax_COEFF SUBROUTINE LogNormal_modes_Aerosol(FCCNR_CON,FCCNR_MAR,NKR_local,COL,XL,XCCN,RCCN,RO_SOLUTE,Scale_Fa,IType) implicit none integer,intent(in) :: NKR_local, Itype real(kind=r4size) ,intent(in) :: XL(:), COL, RO_SOLUTE, Scale_Fa real(kind=r8size) ,intent(out) :: FCCNR_CON(:), FCCNR_MAR(:) real(kind=r4size) ,intent(out) :: XCCN(:),RCCN(:) integer :: mode_num, KR integer,parameter :: modemax = 3 real(kind=r8size) :: ccncon1, ccncon2, ccncon3, radius_mean1, radius_mean2, radius_mean3, & sig1, sig2, sig3, & ccncon(modemax), sig(modemax), radius_mean(modemax) real(kind=r8size) :: CONCCCNIN, FCCNR_tmp(NKR_local), DEG01, X0DROP, & XOCCN, X0, R0, RCCN_MICRON, S_KR, S(NKR_local), X0CCN, ROCCN(NKR_local), & RO_SOLUTE_Ammon, RO_SOLUTE_NaCl,arg11,arg12,arg13,arg21,arg22,arg23, & arg31,arg32,arg33,dNbydlogR_norm1,dNbydlogR_norm2,dNbydlogR_norm3 real(kind=r8size) ,PARAMETER :: RCCN_MAX = 0.4D-4 real(kind=r8size) ,PARAMETER :: RCCN_MIN = 0.003D-4 real(kind=r8size) ,PARAMETER :: RCCN_MIN_3LN = 0.00048D-4 real(kind=r8size) ,PARAMETER :: PI = 3.14159265D0 DEG01 = 1.0D0/3.0D0 X0DROP = XL(2) X0CCN = X0DROP/(2.0**(NKR_local)) DO KR = NKR_local,1,-1 ROCCN(KR) = RO_SOLUTE X0 = X0CCN*2.0D0**(KR) R0 = (3.0D0*X0/4.0D0/3.141593D0/ROCCN(KR))**DEG01 XCCN(KR) = X0 RCCN(KR) = R0 ENDDO IF(IType == 1) THEN ccncon1 = 340.000 radius_mean1 = 0.00500D-04 sig1 = 1.60000 ccncon2 = 60.0000 radius_mean2 = 0.03500D-04 sig2 = 2.00000 ccncon3 = 3.10000 radius_mean3 = 0.31000D-04 sig3 = 2.70000 ELSE IF(IType == 2) THEN ccncon1 = 1000.000 radius_mean1 = 0.00800D-04 sig1 = 1.60000 ccncon2 = 800.0000 radius_mean2 = 0.03400D-04 sig2 = 2.10000 ccncon3 = 0.72000 radius_mean3 = 0.46000D-04 sig3 = 2.20000 ENDIF FCCNR_tmp = 0.0 CONCCCNIN = 0.0 arg11 = ccncon1/(sqrt(2.0D0*pi)*log(sig1)) arg21 = ccncon2/(sqrt(2.0D0*pi)*log(sig2)) arg31 = ccncon3/(sqrt(2.0D0*pi)*log(sig3)) dNbydlogR_norm1 = 0.0 dNbydlogR_norm2 = 0.0 dNbydlogR_norm3 = 0.0 do kr = NKR_local,1,-1 if(RCCN(kr) > RCCN_MIN_3LN .and. RCCN(kr) < RCCN_MAX)then arg12 = (log(RCCN(kr)/radius_mean1))**2.0 arg13 = 2.0D0*((log(sig1))**2.0); dNbydlogR_norm1 = arg11*exp(-arg12/arg13)*(log(2.0)/3.0) arg22 = (log(RCCN(kr)/radius_mean2))**2.0 arg23 = 2.0D0*((log(sig2))**2.0) dNbydlogR_norm2 = dNbydlogR_norm1 + arg21*exp(-arg22/arg23)*(log(2.0)/3.0) arg32 = (log(RCCN(kr)/radius_mean3))**2.0 arg33 = 2.0D0*((log(sig3))**2.0) dNbydlogR_norm3 = dNbydlogR_norm2 + arg31*exp(-arg32/arg33)*(log(2.0)/3.0); FCCNR_tmp(kr) = dNbydlogR_norm3/col endif enddo CONCCCNIN = col*sum(FCCNR_tmp(:)) print*,'CONCCCNIN',CONCCCNIN if(IType == 1) FCCNR_MAR = Scale_Fa*FCCNR_tmp if(IType == 2) FCCNR_CON = Scale_Fa*FCCNR_tmp RETURN END SUBROUTINE LogNormal_modes_Aerosol end module module_mp_SBM_Nucleation MODULE module_mp_fast_sbm USE module_mp_SBM_polar_radar,ONLY:polar_hucm USE module_mp_SBM_BreakUp,ONLY:Spont_Rain_BreakUp,BreakUp_Snow,KR_SNOW_MIN,KR_SNOW_MAX USE module_mp_SBM_Nucleation,ONLY:JERNUCL01_KS, LogNormal_modes_Aerosol USE module_mp_SBM_Auxiliary,ONLY:JERRATE_KS,JERTIMESC_KS,JERSUPSAT_KS, & JERDFUN_KS,JERDFUN_NEW_KS,POLYSVP,Relaxation_Time USE scatt_tables,ONLY:faf1,fbf1,fab1,fbb1, & faf3,fbf3,fab3,fbb3, & faf4,fbf4,fab4,fbb4, & faf5,fbf5,fab5,fbb5, & LOAD_TABLES, & temps_water,temps_fd,temps_crystals, & temps_snow,temps_graupel,temps_hail, & fws_fd,fws_crystals,fws_snow, & fws_graupel,fws_hail, & usetables, & twolayer_hail,twolayer_graupel,twolayer_fd,twolayer_snow,rpquada,usequad PRIVATE PUBLIC FAST_SBM,FAST_HUCMINIT INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8 INTEGER, PARAMETER, PRIVATE:: R16SIZE = 16 INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4 INTEGER, PRIVATE,PARAMETER :: p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,& p_ff6i33=100,p_ff8i01=101,p_ff8i43=143 INTEGER, PRIVATE,PARAMETER :: r_p_ff1i01=2, r_p_ff1i06=07,r_p_ff2i01=08,r_p_ff2i06=13,r_p_ff3i01=14,& r_p_ff3i06=19,r_p_ff4i01=20,r_p_ff4i06=25,r_p_ff5i01=26,r_p_ff5i06=31,r_p_ff6i01=32,r_p_ff6i06=37,& r_p_ff7i01=38,r_p_ff7i06=43,r_p_ff8i01=44,r_p_ff8i06=49,r_p_ff9i01=50,r_p_ff9i06=55 INTEGER,PARAMETER :: IBREAKUP = 1 INTEGER,PARAMETER :: Snow_BreakUp_On = 1 INTEGER,PARAMETER :: Spont_Rain_BreakUp_On = 1 LOGICAL,PARAMETER :: CONSERV = .TRUE. INTEGER,PARAMETER :: JIWEN_FAN_MELT = 1 LOGICAL,PARAMETER :: IPolar_HUCM = .TRUE. INTEGER,PARAMETER :: hail_opt = 1 INTEGER,PARAMETER :: ILogNormal_modes_Aerosol = 1 REAL,PARAMETER :: DX_BOUND = 1433 REAL(kind=r8size), PARAMETER :: SCAL = 1.d0 INTEGER,PARAMETER :: ICEPROCS = 1 INTEGER,PARAMETER :: ICETURB = 0, LIQTURB = 0 INTEGER,PARAMETER :: icempl=1,ICEMAX=3,NCD=33,NHYDR=5,NHYDRO=7 & ,K0_LL=8,KRMIN_LL=1,KRMAX_LL=19,L0_LL=6 & ,IEPS_400=1,IEPS_800=0,IEPS_1600=0 & ,K0L_GL=16,K0G_GL=16 & ,KRMINL_GL=1,KRMAXL_GL=24 & ,KRMING_GL=1,KRMAXG_GL=33 & ,KRDROP=15,KRBREAK=17,KRICE=18 & ,NKR=33,JMAX=33,NRG=2,JBREAK=18,BR_MAX=33,KRMIN_BREAKUP=31,NKR_aerosol=43 REAL(kind=r4size) :: dt_coll REAL,PARAMETER :: C1_MEY=0.00033,C2_MEY=0.0,COL=0.23105, & p1=1000000.0,p2=750000.0,p3=500000.0, & ALCR = 0.5, & ALCR_G = 100.0 INTEGER :: NCOND, NCOLL INTEGER,PARAMETER :: kr_icempl=9 REAL(kind=r4size) :: & RADXX(NKR,NHYDR-1),MASSXX(NKR,NHYDR-1),DENXX(NKR,NHYDR-1) & ,MASSXXO(NKR,NHYDRO),DENXXO(NKR,NHYDRO),VRI(NKR) & ,XX(nkr),ROCCN(nkr),FCCNR_MIX(NKR),FCCNR(NKR) REAL(kind=r8size),DIMENSION (NKR) :: FF1R_D,XL_D,VR1_D & ,FF3R_D,XS_D,VR3_D,VTS_D,FLIQFR_SD,RO3BL_D & ,FF4R_D,XG_D,VR4_D,VTG_D,FLIQFR_GD,RO4BL_D & ,FF5R_D,XH_D,VR5_D,VTH_D,FLIQFR_HD,RO5BL_D & ,XS_MELT_D,XG_MELT_D,XH_MELT_D,VR_TEST,FRIMFR_SD,RF3R REAL(kind=r8size),DIMENSION (nkr,icemax) :: XI_MELT_D & ,FF2R_D,XI_D,VR2_D,VTC_D,FLIQFR_ID,RO2BL_D REAL(kind=r8size) :: T_NEW_D,rhocgs_D,pcgs_D,DT_D,qv_old_D,qv_d REAL(kind=r4size),private :: C2,C3,C4 REAL(kind=r8size),private :: & xl_mg(nkr),xs_mg(nkr),xg_mg(nkr),xh_mg(nkr) & ,xi1_mg(nkr),xi2_mg(nkr),xi3_mg(nkr) REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:):: & bin_mass,tab_colum,tab_dendr,tab_snow,bin_log REAL (KIND=R4SIZE), ALLOCATABLE, DIMENSION(:) :: & RLEC,RSEC,RGEC,RHEC,XL,XS,XG,XH,VR1,VR3,VR4,VR5 REAL (KIND=R4SIZE), ALLOCATABLE, DIMENSION(:,:):: & RIEC,XI,VR2 REAL (KIND=R4SIZE), ALLOCATABLE :: & COEFIN(:),SLIC(:,:),TLIC(:,:), & YWLL_1000MB(:,:),YWLL_750MB(:,:),YWLL_500MB(:,:) REAL (KIND=R4SIZE), ALLOCATABLE :: & YWLI_300MB(:,:,:),YWLI_500MB(:,:,:),YWLI_750MB(:,:,:), & YWLG_300MB(:,:),YWLG_500MB(:,:),YWLG_750MB(:,:),YWLG(:,:), & YWLH_300MB(:,:),YWLH_500MB(:,:),YWLH_750MB(:,:), & YWLS_300MB(:,:),YWLS_500MB(:,:),YWLS_750MB(:,:), & YWII_300MB(:,:,:,:),YWII_500MB(:,:,:,:),YWII_750MB(:,:,:,:), & YWII_300MB_tmp(:,:,:,:),YWII_500MB_tmp(:,:,:,:),YWII_750MB_tmp(:,:,:,:), & YWIS_300MB(:,:,:),YWIS_500MB(:,:,:),YWIS_750MB(:,:,:), & YWSG_300MB(:,:),YWSG_500MB(:,:),YWSG_750MB(:,:), & YWSS_300MB(:,:),YWSS_500MB(:,:),YWSS_750MB(:,:) REAL (KIND=R4SIZE), ALLOCATABLE :: & RO1BL(:), RO2BL(:,:), RO3BL(:), RO4BL(:), RO5BL(:), & RADXXO(:,:) INTEGER,ALLOCATABLE :: ima(:,:) REAL (KIND=R8SIZE), ALLOCATABLE :: chucm(:,:) REAL (KIND=R8SIZE), ALLOCATABLE :: BRKWEIGHT(:),ECOALMASSM(:,:), Prob(:),Gain_Var_New(:,:),NND(:,:) REAL (KIND=R4SIZE), ALLOCATABLE :: DROPRADII(:),PKIJ(:,:,:),QKJ(:,:) INTEGER :: ikr_spon_break REAL (KIND=R8SIZE), ALLOCATABLE :: cwll(:,:), & cwli_1(:,:),cwli_2(:,:),cwli_3(:,:), & cwil_1(:,:),cwil_2(:,:),cwil_3(:,:), & cwlg(:,:),cwlh(:,:),cwls(:,:), & cwgl(:,:),cwhl(:,:),cwsl(:,:), & cwii_1_1(:,:),cwii_1_2(:,:),cwii_1_3(:,:), & cwii_2_1(:,:),cwii_2_2(:,:),cwii_2_3(:,:), & cwii_3_1(:,:),cwii_3_2(:,:),cwii_3_3(:,:), & cwis_1(:,:),cwis_2(:,:),cwis_3(:,:), & cwsi_1(:,:),cwsi_2(:,:),cwsi_3(:,:), & cwig_1(:,:),cwig_2(:,:),cwig_3(:,:), & cwih_1(:,:),cwih_2(:,:),cwih_3(:,:), & cwsg(:,:),cwss(:,:) REAL(kind=r8size),ALLOCATABLE :: FCCNR_MAR(:),FCCNR_CON(:) REAL(kind=r4size),ALLOCATABLE :: Scale_CCN_Factor,XCCN(:),RCCN(:),FCCN(:) INTEGER :: icloud real(kind=r4size),parameter :: mwaero = 115.0 integer,parameter :: ions = 3 real(kind=r4size),parameter :: RO_SOLUTE = 1.79 REAL (KIND=R4SIZE) :: FR_LIM(NKR), FRH_LIM(NKR) CONTAINS SUBROUTINE FAST_SBM (w,u,v,th_old, & & chem_new,n_chem, & & itimestep,DT,DX,DY, & & dz8w,rho_phy,p_phy,pi_phy,th_phy, & & xland,domain_id,ivgtyp,xlat,xlong, & & QV,QC,QR,QI,QS,QG,QV_OLD, & & QNC,QNR,QNI,QNS,QNG,QNA, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, & & diagflag, & & sbmradar,num_sbmradar, & & sbm_diagnostics, & & RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,SR) IMPLICIT NONE INTEGER :: KR,IKL,ICE INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE & & ,ITIMESTEP,N_CHEM,NUM_SBMRADAR,domain_id & & ,sbm_diagnostics REAL, INTENT(IN) :: DT,DX,DY REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(IN ) :: & U, & V, & W REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem),INTENT(INOUT) :: chem_new REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_sbmradar),INTENT(INOUT) :: sbmradar REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(INOUT) :: & qv, & qv_old, & th_old, & qc, & qr, & qi, & qs, & qg, & qnc, & qnr, & qni, & qns, & qng, & qna REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: XLAND LOGICAL, OPTIONAL, INTENT(IN) :: diagflag INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN):: IVGTYP REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT, XLONG REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & & dz8w,p_phy,pi_phy,rho_phy REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme):: & & th_phy REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme), OPTIONAL :: & & RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,SR REAL (KIND=R4SIZE), DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1):: & t_new,t_old,zcgs,rhocgs,pcgs INTEGER :: I,J,K,KFLIP INTEGER :: KRFREEZ REAL (KIND=R4SIZE),PARAMETER :: Z0IN=2.0E5,ZMIN=2.0E5 REAL (KIND=R4SIZE) :: EPSF2D, & & TAUR1,TAUR2,EPS_R1,EPS_R2,ANC1IN, & & PEPL,PEPI,PERL,PERI,ANC1,ANC2,PARSP, & & AFREEZMY,BFREEZMY,BFREEZMAX, & & TCRIT,TTCOAL, & & EPSF1,EPSF3,EPSF4, & & SUP2_OLD, DSUPICEXZ,TFREEZ_OLD,DTFREEZXZ, & & AA1_MY,BB1_MY,AA2_MY,BB2_MY, & & DTIME,DTCOND,DTNEW,DTCOLL, & & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN & & /2.53,5.42,3.41E1,6.13/ DATA AA1_MY,BB1_MY,AA2_MY,BB2_MY/2.53E12,5.42E3,3.41E13,6.13E3/ DATA KRFREEZ,BFREEZMAX,ANC1,ANC2,PARSP,PEPL,PEPI,PERL,PERI, & & TAUR1,TAUR2,EPS_R1,EPS_R2,TTCOAL,AFREEZMY,& & BFREEZMY,EPSF1,EPSF3,EPSF4,TCRIT/21,& & 0.6600E00, & & 1.0000E02,1.0000E02,0.9000E02, & & 0.6000E00,0.6000E00,1.0000E-03,1.0000E-03, & & 0.5000E00,0.8000E00,0.1500E09,0.1500E09, & & 2.3315E02,0.3333E-04,0.6600E00, & & 0.1000E-02,0.1000E-05,0.1000E-05, & & 2.7015E02/ REAL (KIND=R4SIZE),DIMENSION (nkr) :: FF1IN,FF3IN,FF4IN,FF5IN,& & FF1R,FF3R,FF4R,FF5R,FLIQFR_S,FRIMFR_S,FLIQFR_G,FLIQFR_H, & & FF1R_NEW,FF3R_NEW,FF4R_NEW,FF5R_NEW REAL (KIND=R4SIZE),DIMENSION (nkr) :: FL3R,FL4R,FL5R,FL3R_NEW,FL4R_NEW,FL5R_NEW REAL (KIND=R4SIZE),DIMENSION (nkr,icemax) :: FF2IN,FF2R,FLIQFR_I REAL (KIND=R4SIZE) :: XI_MELT(NKR,ICEMAX),XS_MELT(NKR),XG_MELT(NKR),XH_MELT(NKR) REAL (KIND=R8SIZE) :: DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN REAL (KIND=R8SIZE) :: DELSUP1,DELSUP2,DELDIV1,DELDIV2 REAL (KIND=R8SIZE) :: TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ REAL (KIND=R8SIZE) :: DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD,DEL_T,DEL_Q REAL (KIND=R4SIZE) :: DEL_BB,DEL_BBN,DEL_BBR, TTA_r REAL (KIND=R4SIZE) :: FACTZ,CONCCCN_XZ,CONCDROP REAL (KIND=R4SIZE) :: SUPICE(KTE),AR1,AR2, & & DERIVT_X,DERIVT_Y,DERIVT_Z,DERIVS_X,DERIVS_Y,DERIVS_Z, & & ES2NPLSX,ES2NPLSY,EW1NPLSX,EW1NPLSY,UX,VX, & & DEL2INPLSX,DEL2INPLSY,DZZ(KTE) INTEGER KRR,I_START,I_END,J_START,J_END REAL (KIND=R4SIZE) :: DTFREEZ_XYZ(ITE,KTE,JTE),DSUPICE_XYZ(ITE,KTE,JTE) REAL (KIND=R4SIZE) :: DXHUCM,DYHUCM REAL (KIND=R4SIZE) :: FMAX1,FMAX2(ICEMAX),FMAX3,FMAX4,FMAX5 INTEGER ISYM1,ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5 INTEGER DIFFU REAL (KIND=R4SIZE) :: DELTAW REAL (KIND=R4SIZE) :: zcgs_z(kts:kte),pcgs_z(kts:kte),rhocgs_z(kts:kte),ffx_z(kts:kte,nkr) REAL (KIND=R4SIZE) :: z_full REAL (KIND=R4SIZE) :: VRX(kts:kte,NKR) REAL (KIND=R4SIZE) :: VR1_Z(NKR,KTS:KTE), FACTOR_P, VR1_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE) REAL (KIND=R4SIZE) :: VR2_ZC(NKR,KTS:KTE), VR2_Z(NKR,ICEMAX) REAL (KIND=R4SIZE) :: VR2_ZP(NKR,KTS:KTE) REAL (KIND=R4SIZE) :: VR2_ZD(NKR,KTS:KTE) REAL (KIND=R4SIZE) :: VR3_Z(NKR,KTS:KTE), VR3_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE) REAL (KIND=R4SIZE) :: VR4_Z(NKR,KTS:KTE), VR4_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE) REAL (KIND=R4SIZE) :: VR5_Z(NKR,KTS:KTE), VR5_Z3D(NKR,ITS:ITE,KTS:KTE,JTS:JTE) REAL (KIND=R4SIZE) :: BulkDen_Snow(NKR,ITS:ITE,KTS:KTE,JTS:JTE) REAL (KIND=R4SIZE), PARAMETER :: RON=8.E6, GON=5.E7,PI=3.14159265359 REAL (KIND=R4SIZE) :: EFF_N,EFF_D REAL (KIND=R4SIZE) :: EFF_NI(its:ite,kts:kte,jts:jte),eff_di(its:ite,kts:kte,jts:jte) REAL (KIND=R4SIZE) :: EFF_NQIC,eff_DQIC REAL (KIND=R4SIZE) :: EFF_NQIP,eff_DQIP REAL (KIND=R4SIZE) :: EFF_NQID,eff_DQID REAL (KIND=R4SIZE) :: lambda,chi0,xi1,xi2,xi3,xi4,xi5,r_e,chi_3,f1,f2,volume,surface_area,xi6,ft,chi_e,ft_bin REAL (KIND=R4SIZE), DIMENSION(kts:kte):: & qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d REAL (KIND=R4SIZE), DIMENSION(kts:kte):: dBZ REAL (KIND=R4SIZE) :: nzero,son,nzero_less parameter (son=2.E7) REAL (KIND=R4SIZE) :: raddumb(nkr),massdumb(nkr) REAL (KIND=R4SIZE) :: hydrosum integer imax,kmax,jmax REAL (KIND=R4SIZE) :: gmax,tmax,qmax,divmax,rainmax,qnmax,inmax,knmax,hydro,difmax, tdif, tt_old, w_stag, w_stag_my, qq_old,teten,es integer print_int parameter (print_int=300) integer t_print,i_print,j_print,k_print REAL (KIND=R8SIZE), DIMENSION(kts:kte):: zmks_1d REAL (KIND=R8SIZE) :: dx_dbl, dy_dbl INTEGER,DIMENSION (nkr) :: melt_snow,melt_graupel,melt_hail,melt_ice INTEGER ihucm_flag REAL (KIND=R4SIZE) :: NSNOW_ADD INTEGER,PARAMETER :: n_radar = 10 integer :: ijk, Mod_Flag REAL (KIND=R8SIZE),PARAMETER :: wavelength = 11.0D0 INTEGER :: IWL REAL (KIND=R4SIZE) :: DIST_SING REAL (KIND=R8SIZE) :: BKDEN_Snow(NKR) REAL (KIND=R8SIZE) :: DISTANCE,FL1_FD(NKR),BULK(NKR), BulkDens_Snow(NKR) REAL (KIND=R8SIZE) :: FF1_FD(NKR),FFL_FD(NKR),OUT1(n_radar),OUT2(n_radar),OUT3(n_radar),OUT4(n_radar),OUT5(n_radar), & OUT6(n_radar),OUT7(n_radar),OUT8(n_radar),OUT9(n_radar), FL1R_FD(NKR) REAL (KIND=R8SIZE) :: rate_shed_per_grau_grampersec(NKR), rate_shed_per_hail_grampersec(NKR), rhoair_max integer :: count_H, count_G, count_S_l, count_S_r REAL (KIND=R8SIZE) :: RMin_G integer :: KR_GRAUP_MAX_BLAHAK, KR_G_TO_H REAL (KIND=R8SIZE) :: SUP_WATER, ES1N_KS, ES1N_dummy, ES2N_dummy logical :: K_found integer :: KZ_Cloud_Base(its:ite,jts:jte), IS_THIS_CLOUDBASE,KR_Small_Ice REAL (KIND=R4SIZE) :: qna0(its:ite,kts:kte,jts:jte), fr_hom, w_stagm, CollEff_out, FACT REAL (KIND=R4SIZE) :: FACTZ_new(KMS:KME,NKR), TT_r INTEGER :: NZ,NZZ,II,JJ XS_d = XS if (itimestep.eq.1)then if (iceprocs.eq.1) call wrf_message(" FAST SBM: ICE PROCESES ACTIVE ") if (iceprocs.eq.0) call wrf_message(" FAST SBM: LIQUID PROCESES ONLY") end if NCOND = 3 NCOLL = 1 DTCOND = DT/REAL(NCOND) DTCOLL = DT/REAL(NCOLL) dt_coll = DTCOLL DEL_BB=BB2_MY-BB1_MY DEL_BBN=BB2_MYN-BB1_MYN DEL_BBR=BB1_MYN/DEL_BBN if (conserv)then DO j = jts,jte DO i = its,ite DO k = kts,kte rhocgs(I,K,J)=rho_phy(I,K,J)*0.001 KRR=0 DO KR=p_ff1i01,p_ff1i33 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KRR)/XL(KRR)/3.0 END DO KRR=0 DO KR=p_ff5i01,p_ff5i33 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3.0 END DO KRR=0 DO KR=p_ff8i01,p_ff8i43 KRR=KRR+1 chem_new(I,K,J,KR) = chem_new(I,K,J,KR)*RHOCGS(I,K,J)/1000.0 END DO if(hail_opt == 1) then KRR=0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XH(KRR)/XH(KRR)/3.0 END DO else KRR=0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3.0 END DO endif END DO END DO END DO end if DXHUCM=100.*DX DYHUCM=100.*DY I_START=MAX(1,ITS-1) J_START=MAX(1,JTS-1) I_END=MIN(IDE-1,ITE+1) J_END=MIN(JDE-1,JTE+1) DO j = j_start,j_end DO i = i_start,i_end z_full=0. DO k = kts,kte pcgs(I,K,J)=P_PHY(I,K,J)*10. rhocgs(I,K,J)=rho_phy(I,K,J)*0.001 zcgs(I,K,J)=z_full+0.5*dz8w(I,K,J)*100 z_full=z_full+dz8w(i,k,j)*100. ENDDO ENDDO ENDDO if (itimestep == 1)then FACTZ_new = 0.0 DO j = jts,jte DO i = its,ite DO k = kts,kte rhoair_max = rhocgs(i,1,j) if(ILogNormal_modes_Aerosol == 1)then IF (zcgs(I,K,J) .LE. ZMIN)THEN FACTZ = 1.0 ELSE FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN) END IF KRR = 0 DO KR = p_ff8i01,p_ff8i43 KRR = KRR + 1 if (xland(i,j) == 1)then chem_new(I,K,J,KR) = (FCCNR_CON(KRR)/rhoair_max)*rhocgs(i,k,j) else chem_new(I,K,J,KR) = (FCCNR_MAR(KRR)/rhoair_max)*rhocgs(i,k,j) endif END DO endif end do end do end do end if if (itimestep > 1 .and. domain_id == 1)then DO j = jts,jte DO k = kts,kte DO i = its,ite rhoair_max = rhocgs(i,1,j) if (i <= 5 .or. i >= IDE-5 .OR. & & j <= 5 .or. j >= JDE-5)THEN if(ILogNormal_modes_Aerosol == 1)then IF (zcgs(I,K,J).LE.ZMIN) THEN FACTZ = 1.0 ELSE FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN) END IF KRR = 0 DO kr = p_ff8i01,p_ff8i43 KRR = KRR + 1 if (xland(i,j) == 1)then chem_new(I,K,J,KR) = (FCCNR_CON(KRR)/rhoair_max)*rhocgs(i,k,j) else chem_new(I,K,J,KR) = (FCCNR_MAR(KRR)/rhoair_max)*rhocgs(i,k,j) endif END DO endif end if end do end do end do end if if (itimestep == 1)then DO j = j_start,j_end DO k = kts,kte DO i = i_start,i_end th_old(i,k,j)=th_phy(i,k,j) qv_old(i,k,j)=qv(i,k,j) END DO END DO END DO end if DO j = j_start,j_end DO k = kts,kte DO i = i_start,i_end t_new(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j) END DO END DO END DO IF(ICEPROCS == 1)THEN KZ_Cloud_Base = 0 DO j = jts,jte DO i = its,ite K_found = .FALSE. DO k = kts,kte ES1N = AA1_MY*EXP(-BB1_MY/T_NEW(I,K,J)) EW1N = QV(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV(I,K,J)) SUP_WATER = EW1N/ES1N - 1.0 if(k.lt.kte)then w_stag_my = 50.*(w(i,k,j)+w(i,k+1,j)) else w_stag_my = 100*w(i,k,j) end if if(SUP_WATER > 0.0D0 .and. w_stag_my > 0.1*1.0D2 .and. K_found .eqv. .FALSE. .and. K > 2 .and. zcgs(I,K,J) < 3.0*1.0D5)then KZ_Cloud_Base(I,J) = K K_found = .TRUE. endif IF(K.EQ.KTE)THEN DZZ(K)=(zcgs(I,K,J)-zcgs(I,K-1,J)) ELSE IF(K.EQ.1)THEN DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K,J)) ELSE DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K-1,J)) END IF ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J)) EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J)) SUPICE(K)=EW1N/ES2N-1. IF(SUPICE(K).GT.0.5) SUPICE(K)=.5 END DO DO k = kts,kte IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15) THEN if (k.lt.kte)then w_stag=50.*(w(i,k,j)+w(i,k+1,j)) else w_stag=100*w(i,k,j) end if IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1)) VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1)) ELSE UX=U(I,K,J)*100. VX=V(I,K,J)*100. END IF IF(K.EQ.1) DERIVT_Z=(T_OLD(I,K+1,J)-T_OLD(I,K,J))/DZZ(K) IF(K.EQ.KTE) DERIVT_Z=(T_OLD(I,K,J)-T_OLD(I,K-1,J))/DZZ(K) IF(K.GT.1.AND.K.LT.KTE) DERIVT_Z= & (T_OLD(I,K+1,J)-T_OLD(I,K-1,J))/DZZ(K) IF (I.EQ.1)THEN DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I,K,J))/(DXHUCM) ELSE IF (I.EQ.IDE-1)THEN DERIVT_X=(T_OLD(I,K,J)-T_OLD(I-1,K,J))/(DXHUCM) ELSE DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I-1,K,J))/(2.*DXHUCM) END IF IF (J.EQ.1)THEN DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J))/(DYHUCM) ELSE IF (J.EQ.JDE-1)THEN DERIVT_Y=(T_OLD(I,K,J)-T_OLD(I,K,J-1))/(DYHUCM) ELSE DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J-1))/(2.*DYHUCM) END IF DTFREEZ_XYZ(I,K,J) = DT*(VX*DERIVT_Y+ & UX*DERIVT_X+w_stag*DERIVT_Z) ELSE DTFREEZ_XYZ(I,K,J)=0. ENDIF IF(SUPICE(K).GE.0.02.AND.T_OLD(I,K,J).LT.268.15) THEN IF (I.LT.IDE-1)THEN ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I+1,K,J)) EW1NPLSX=QV_OLD(I+1,K,J)*pcgs(I+1,K,J)/ & (0.622+0.378*QV_OLD(I+1,K,J)) ELSE ES2NPLSX = AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J)) EW1NPLSX = QV_OLD(I,K,J)*pcgs(I,K,J)/ & (0.622+0.378*QV_OLD(I,K,J)) END IF IF (ES2NPLSX.EQ.0)THEN DEL2INPLSX=0.5 ELSE DEL2INPLSX=EW1NPLSX/ES2NPLSX-1. END IF IF(DEL2INPLSX.GT.0.5) DEL2INPLSX=.5 IF (I.GT.1)THEN ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I-1,K,J)) EW1N=QV_OLD(I-1,K,J)*pcgs(I-1,K,J)/(0.622+0.378*QV_OLD(I-1,K,J)) ELSE ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J)) EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J)) END IF DEL2IN=EW1N/ES2N-1. IF(DEL2IN.GT.0.5) DEL2IN=.5 IF (I.GT.1.AND.I.LT.IDE-1)THEN DERIVS_X=(DEL2INPLSX-DEL2IN)/(2.*DXHUCM) ELSE DERIVS_X=(DEL2INPLSX-DEL2IN)/(DXHUCM) END IF IF (J.LT.JDE-1)THEN ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J+1)) EW1NPLSY=QV_OLD(I,K,J+1)*pcgs(I,K,J+1)/(0.622+0.378*QV_OLD(I,K,J+1)) ELSE ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J)) EW1NPLSY=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J)) END IF DEL2INPLSY=EW1NPLSY/ES2NPLSY-1. IF(DEL2INPLSY.GT.0.5) DEL2INPLSY=.5 IF (J.GT.1)THEN ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J-1)) EW1N=QV_OLD(I,K,J-1)*pcgs(I,K,J-1)/(0.622+0.378*QV_OLD(I,K,J-1)) ELSE ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J)) EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J)) END IF DEL2IN=EW1N/ES2N-1. IF(DEL2IN.GT.0.5) DEL2IN=.5 IF (J.GT.1.AND.J.LT.JDE-1)THEN DERIVS_Y=(DEL2INPLSY-DEL2IN)/(2.*DYHUCM) ELSE DERIVS_Y=(DEL2INPLSY-DEL2IN)/(DYHUCM) END IF IF (K.EQ.1)DERIVS_Z=(SUPICE(K+1)-SUPICE(K))/DZZ(K) IF (K.EQ.KTE)DERIVS_Z=(SUPICE(K)-SUPICE(K-1))/DZZ(K) IF(K.GT.1.and.K.LT.KTE) DERIVS_Z=(SUPICE(K+1)-SUPICE(K-1))/DZZ(K) IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1)) VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1)) ELSE UX=U(I,K,J)*100. VX=V(I,K,J)*100. END IF DSUPICE_XYZ(I,K,J)=(UX*DERIVS_X+VX*DERIVS_Y+ & w_stag*DERIVS_Z)*DTCOND ELSE DSUPICE_XYZ(I,K,J)=0.0 END IF END DO END DO END DO ENDIF do j = jts,jte do k = kts,kte do i = its,ite FACTOR_P = DSQRT(1.0D6/PCGS(I,K,J)) VR2_ZC(1:nkr,K) = VR2(1:nkr,1)*FACTOR_P VR2_ZP(1:nkr,K) = VR2(1:nkr,2)*FACTOR_P VR2_ZD(1:nkr,K) = VR2(1:nkr,3)*FACTOR_P VR1_Z(1:nkr,K) = VR1(1:nkr)*FACTOR_P VR3_Z(1:nkr,K) = VR3(1:nkr)*FACTOR_P VR4_Z(1:nkr,K) = VR4(1:nkr)*FACTOR_P VR5_Z(1:nkr,k) = VR5(1:nkr)*FACTOR_P VR1_Z3D(1:nkr,I,K,J) = VR1(1:nkr)*FACTOR_P VR3_Z3D(1:nkr,I,K,J) = VR3(1:nkr)*FACTOR_P VR4_Z3D(1:nkr,I,K,J) = VR4(1:nkr)*FACTOR_P VR5_Z3D(1:nkr,I,K,J) = VR5(1:nkr)*FACTOR_P KRR = 0 DO kr = p_ff1i01,p_ff1i33 KRR = KRR + 1 FF1R(KRR) = chem_new(I,K,J,KR) IF (FF1R(KRR) < 0.0)FF1R(KRR) = 0.0 END DO KRR = 0 DO kr=p_ff8i01,p_ff8i43 KRR = KRR + 1 FCCN(KRR) = chem_new(I,K,J,KR) if (fccn(krr) < 0.0)fccn(krr) = 0.0 END DO FF2R(:,1) = 0.0 FF2R(:,2) = 0.0 FF2R(:,3) = 0.0 KRR=0 DO kr=p_ff5i01,p_ff5i33 KRR=KRR+1 FF3R(KRR)=chem_new(I,K,J,KR) if (ff3r(krr) < 0.0)ff3r(krr) = 0.0 END DO if(hail_opt == 1)then KRR=0 DO kr=p_ff6i01,p_ff6i33 KRR=KRR+1 FF5R(KRR) = chem_new(I,K,J,KR) if (ff5r(krr) < 0.0)ff5r(krr) = 0.0 FF4R(KRR) = 0.0 ENDDO else KRR=0 DO kr=p_ff6i01,p_ff6i33 KRR=KRR+1 FF4R(KRR) = chem_new(I,K,J,KR) if (ff4r(krr) < 0.0)ff4r(krr) = 0.0 FF5R(KRR) = 0.0 ENDDO endif IF (T_OLD(I,K,J).GT.193.15)THEN TT=T_OLD(I,K,J) QQ=QV_OLD(I,K,J) IF(QQ.LE.0.0) QQ = 1.D-10 PP=pcgs(I,K,J) TTA=T_NEW(I,K,J) QQA=QV(I,K,J) IF (QQA.LE.0) call wrf_message("WARNING: FAST SBM, QQA < 0") IF (QQA.LE.0) print*,'I,J,K,Told,Tnew,QQA = ',I,J,K,TT,TTA,QQA IF (QQA.LE.0) QQA = 1.0D-10 ES1N = AA1_MY*DEXP(-BB1_MY/TT) ES2N = AA2_MY*DEXP(-BB2_MY/TT) EW1N=QQ*PP/(0.622+0.378*QQ) DIV1=EW1N/ES1N DEL1IN=EW1N/ES1N-1. DIV2=EW1N/ES2N DEL2IN=EW1N/ES2N-1. ES1N=AA1_MY*DEXP(-BB1_MY/TTA) ES2N=AA2_MY*DEXP(-BB2_MY/TTA) EW1N=QQA*PP/(0.622+0.378*QQA) DIV3=EW1N/ES1N DEL1AD=EW1N/ES1N-1. DIV4=EW1N/ES2N DEL2AD=EW1N/ES2N-1. SUP2_OLD=DEL2IN IF(del1ad > 0.0 .or. del2ad > 0.0 .or. (sum(FF1R)+sum(FF3R)+sum(FF4R)+sum(FF5R)) > 1.0e-20)THEN DEL_T = (TTA - TT) / NCOND DEL_Q = (QQA - QQ) / NCOND DIFFU=1 IF (DIV1.EQ.DIV3) DIFFU = 0 IF (DIV2.EQ.DIV4) DIFFU = 0 DTNEW = 0.0 DO IKL=1,NCOND DTCOND = min(DT-DTNEW,DTCOND) DTNEW = DTNEW + DTCOND IF (DIFFU.NE.0)THEN IF (DIFFU.NE.0)THEN TT = TT + DEL_T QQ = QQ + DEL_Q ES1N = AA1_MY*DEXP(-BB1_MY/TT) ES2N = AA2_MY*DEXP(-BB2_MY/TT) EW1N = QQ*PP/(0.622+0.378*QQ) DIV1 = EW1N/ES1N DEL1IN = EW1N/ES1N-1.0 DIV2 = EW1N/ES2N DEL2IN = EW1N/ES2N-1.0 END IF IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN DIFFU=0 END IF IF (DIFFU == 1)THEN IF(DEL1IN > 0.0 .OR. DEL2IN > 0.0)THEN DO KR=1,NKR FF1IN(KR)=FF1R(KR) DO ICE=1,ICEMAX FF2IN(KR,ICE)=FF2R(KR,ICE) ENDDO ENDDO Is_This_CloudBase = 0 IF(KZ_Cloud_Base(I,J) == K .and. col*sum(FF1IN*XL) < 5.0) Is_This_CloudBase = 1 if (k.lt.kte)then w_stag_my = 50.*(w(i,k,j)+w(i,k+1,j)) else w_stag_my = 100*w(i,k,j) end if CALL JERNUCL01_KS(FF1IN,FF2IN,FCCN & ,XL,XI,TT,QQ & ,rhocgs(I,K,J),pcgs(I,K,J) & ,DEL1IN,DEL2IN & ,COL & ,SUP2_OLD,DSUPICE_XYZ(I,K,J) & ,RCCN,DROPRADII,NKR,NKR_aerosol,ICEMAX,ICEPROCS & ,W_Stag_My,Is_This_CloudBase,RO_SOLUTE,IONS,MWAERO & ,I,J,K) DO KR=1,NKR FF1R(KR)=FF1IN(KR) DO ICE=1,ICEMAX FF3R(KR) = FF3R(KR) + FF2IN(KR,ICE) FF2IN(KR,ICE) = 0.0 FF2R(KR,ICE) = 0.0 END DO END DO END IF FMAX1=0. FMAX2=0. FMAX3=0. FMAX4=0. FMAX5=0. DO KR=1,NKR FF1IN(KR)=FF1R(KR) FMAX1=AMAX1(FF1R(KR),FMAX1) FF3IN(KR)=FF3R(KR) FMAX3=AMAX1(FF3R(KR),FMAX3) FF4IN(KR)=FF4R(KR) FMAX4=AMAX1(FF4R(KR),FMAX4) FF5IN(KR)=FF5R(KR) FMAX5=AMAX1(FF5R(KR),FMAX5) DO ICE=1,ICEMAX FF2IN(KR,ICE)=FF2R(KR,ICE) FMAX2(ICE)=AMAX1(FF2R(KR,ICE),FMAX2(ICE)) END DO END DO ISYM1=0 ISYM2=0 ISYM3=0 ISYM4=0 ISYM5=0 IF(FMAX1 > 0)ISYM1 = 1 IF (ICEPROCS == 1)THEN IF(FMAX2(1) > 1.E-10)ISYM2(1) = 1 IF(FMAX2(2) > 1.E-10)ISYM2(2) = 1 IF(FMAX2(3) > 1.E-10)ISYM2(3) = 1 IF(FMAX3 > 1.E-10)ISYM3 = 1 IF(FMAX4 > 1.E-10)ISYM4 = 1 IF(FMAX5 > 1.E-10)ISYM5 = 1 END IF IF(ISYM1==1 .AND. ((TT-273.15)>-0.187 .OR.(sum(ISYM2)==0 .AND. & ISYM3==0 .AND. ISYM4==0 .AND. ISYM5==0)))THEN CALL ONECOND1(TT,QQ,PP,rhocgs(I,K,J) & ,VR1_Z(:,K),pcgs(I,K,J) & ,DEL1IN,DEL2IN,DIV1,DIV2 & ,FF1R,FF1IN,XL,RLEC,RO1BL & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & ,C1_MEY,C2_MEY & ,COL,DTCOND,ICEMAX,NKR,ISYM1 & ,ISYM2,ISYM3,ISYM4,ISYM5,I,J,K,W(i,k,j),DX,Itimestep) ELSE IF(ISYM1==0 .AND. (TT-273.15)<-0.187 .AND. & (sum(ISYM2)>1 .OR. ISYM3==1 .OR. ISYM4==1 .OR. ISYM5==1))THEN VR2_Z(:,1) = VR2_ZC(:,K) VR2_Z(:,2) = VR2_ZP(:,K) VR2_Z(:,3) = VR2_ZD(:,K) CALL ONECOND2(TT,QQ,PP,rhocgs(I,K,J) & ,VR2_Z,VR3_Z(:,K),VR4_Z(:,K),VR5_Z(:,K),pcgs(I,K,J) & ,DEL1IN,DEL2IN,DIV1,DIV2 & ,FF2R,FF2IN,XI,RIEC,RO2BL & ,FF3R,FF3IN,XS,RSEC,RO3BL & ,FF4R,FF4IN,XG,RGEC,RO4BL & ,FF5R,FF5IN,XH,RHEC,RO5BL & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & ,C1_MEY,C2_MEY & ,COL,DTCOND,ICEMAX,NKR & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5,I,J,K,W(i,k,j),DX,Itimestep) ELSE IF(ISYM1==1 .AND. (TT-273.15)<-0.187 .AND. & (sum(ISYM2)>1 .OR. ISYM3==1 .OR. ISYM4==1 .OR. ISYM5==1))THEN IF (TT > 233.15)THEN VR2_Z(:,1) = VR2_ZC(:,K) VR2_Z(:,2) = VR2_ZP(:,K) VR2_Z(:,3) = VR2_ZD(:,K) CALL ONECOND3(TT,QQ,PP,rhocgs(I,K,J) & ,VR1_Z(:,K),VR2_Z,VR3_Z(:,K),VR4_Z(:,K),VR5_Z(:,K),pcgs(I,K,J) & ,DEL1IN,DEL2IN,DIV1,DIV2 & ,FF1R,FF1IN,XL,RLEC,RO1BL & ,FF2R,FF2IN,XI,RIEC,RO2BL & ,FF3R,FF3IN,XS,RSEC,RO3BL & ,FF4R,FF4IN,XG,RGEC,RO4BL & ,FF5R,FF5IN,XH,RHEC,RO5BL & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & ,C1_MEY,C2_MEY & ,COL,DTCOND,ICEMAX,NKR & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5,I,J,K,W(i,k,j),DX,Itimestep) ENDIF END IF END IF END IF END DO DO IKL = 1,NCOLL IF ( TT >= 233.15 ) THEN FLIQFR_SD = 0.0 FLIQFR_GD = 0.0 FLIQFR_HD = 0.0 FRIMFR_SD = 0.0 CALL COAL_BOTT_NEW (FF1R,FF2R,FF3R, & FF4R,FF5R,TT,QQ,PP, & rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL, & FLIQFR_SD,FLIQFR_GD,FLIQFR_HD,FRIMFR_SD, & DEL1IN, DEL2IN, & I,J,K,Itimestep,CollEff_out) END IF END DO T_new(i,k,j) = tt qv(i,k,j) = qq ENDIF END IF IF(T_NEW(i,k,j) < 273.15 .and. ICEPROCS == 1)THEN CALL FREEZ & (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, & T_NEW(I,K,J),DT,rhocgs(I,K,J), & COL,AFREEZMY,BFREEZMY,BFREEZMAX, & KRFREEZ,ICEMAX,NKR) ENDIF IF (JIWEN_FAN_MELT == 1 .and. T_NEW(i,k,j) > 273.15 .and. ICEPROCS == 1) THEN CALL J_W_MELT(FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, & T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR) END IF DO KR=1,NKR DO ICE=1,ICEMAX FF3R(KR)=FF3R(KR) + FF2R(KR,ICE) FF2R(KR,ICE) = 0.0 END DO if(hail_opt == 1)then FF5R(KR) = FF5R(KR) + FF4R(KR) FF4R(KR) = 0.0 else FF4R(KR) = FF4R(KR) + FF5R(KR) FF5R(KR) = 0.0 endif END DO IF (Spont_Rain_BreakUp_On == 1 .AND. (SUM(FF1R) > 43.0*1.0D-30) )THEN FF1R_D(:) = FF1R(:) XL_D(:) = XL(:) CALL Spont_Rain_BreakUp (DT ,FF1R_D, XL_D, Prob, Gain_Var_New, NND, NKR, ikr_spon_break) FF1R(:) = FF1R_D(:) END IF IF (Snow_BreakUp_On == 1 .and. ICEPROCS == 1 .and. sum(FF3R(KR_SNOW_MIN:NKR))> (NKR-KR_SNOW_MIN)*1.0D-30)THEN DO KR=1,NKR FF3R_D(KR) = FF3R(KR) END DO IF (KR_SNOW_MAX <= NKR) CALL BreakUp_Snow (TT_r,FF3R_D,FLIQFR_SD,xs_d,FRIMFR_SD,NKR) DO KR=1,NKR FF3R(KR) = FF3R_D(KR) END DO END IF th_phy(i,k,j) = t_new(i,k,j)/pi_phy(i,k,j) KRR = 0 DO kr = p_ff1i01,p_ff1i33 KRR = KRR+1 chem_new(I,K,J,KR) = FF1R(KRR) END DO KRR = 0 DO kr=p_ff8i01,p_ff8i43 KRR=KRR+1 chem_new(I,K,J,KR)=FCCN(KRR) END DO IF (ICEPROCS == 1)THEN KRR = 0 DO kr=p_ff5i01,p_ff5i33 KRR=KRR+1 chem_new(I,K,J,KR)=FF3R(KRR) END DO if(hail_opt == 1)then KRR = 0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 chem_new(I,K,J,KR) = FF5R(KRR) END DO else KRR = 0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 chem_new(I,K,J,KR) = FF4R(KRR) END DO endif END IF END DO END DO END DO do j = jts,jte do i = its,ite do k = kts,kte rhocgs_z(k)=rhocgs(i,k,j) pcgs_z(k)=pcgs(i,k,j) zcgs_z(k)=zcgs(i,k,j) vrx(k,:)=vr1_z3D(:,i,k,j) krr=0 do kr=p_ff1i01,p_ff1i33 krr=krr+1 ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j) end do end do call FALFLUXHUCM_Z(ffx_z,VRX,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr) do k = kts,kte krr=0 do kr=p_ff1i01,p_ff1i33 krr=krr+1 chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j) end do end do if(iceprocs == 1)then do k = kts,kte rhocgs_z(k)=rhocgs(i,k,j) pcgs_z(k)=pcgs(i,k,j) zcgs_z(k)=zcgs(i,k,j) vrx(k,:)=vr3_z3D(:,i,k,j) krr=0 do kr=p_ff5i01,p_ff5i33 krr=krr+1 ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j) end do end do call FALFLUXHUCM_Z(ffx_z,VRX,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr) do k = kts,kte krr=0 do kr=p_ff5i01,p_ff5i33 krr=krr+1 chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j) end do end do do k = kts,kte rhocgs_z(k)=rhocgs(i,k,j) pcgs_z(k)=pcgs(i,k,j) zcgs_z(k)=zcgs(i,k,j) if(hail_opt == 1)then vrx(k,:) = vr5_z3D(:,i,k,j) else vrx(k,:) = vr4_z3D(:,i,k,j) endif krr=0 do kr=p_ff6i01,p_ff6i33 krr=krr+1 ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j) end do end do call FALFLUXHUCM_Z(ffx_z,VRX,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr) do k = kts,kte krr=0 do kr=p_ff6i01,p_ff6i33 krr=krr+1 chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j) end do end do end if end do end do gmax=0 qmax=0 imax=0 kmax=0 qnmax=0 inmax=0 knmax=0 DO j = jts,jte DO k = kts,kte DO i = its,ite QC(I,K,J) = 0.0 QR(I,K,J) = 0.0 QI(I,K,J) = 0.0 QS(I,K,J) = 0.0 QG(I,K,J) = 0.0 QNC(I,K,J) = 0.0 QNR(I,K,J) = 0.0 QNI(I,K,J) = 0.0 QNS(I,K,J) = 0.0 QNG(I,K,J) = 0.0 QNA(I,K,J) = 0.0 tt = th_phy(i,k,j)*pi_phy(i,k,j) KRR = 0 DO KR = p_ff1i01,p_ff1i33 KRR=KRR+1 IF (KRR < KRDROP)THEN QC(I,K,J) = QC(I,K,J) & + (1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3 QNC(I,K,J) = QNC(I,K,J) & + COL*chem_new(I,K,J,KR)*XL(KRR)*3.0/rhocgs(I,K,J)*1000.0 ELSE QR(I,K,J) = QR(I,K,J) & + (1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3.0 QNR(I,K,J) = QNR(I,K,J) & + COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000.0 END IF END DO KRR=0 IF (ICEPROCS == 1)THEN KRR=0 DO KR=p_ff5i01,p_ff5i33 KRR=KRR+1 if (KRR <= KRICE)THEN QI(I,K,J) = QI(I,K,J) & +(1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3.0 QNI(I,K,J) = QNI(I,K,J) & + COL*chem_new(I,K,J,KR)*XS(KRR)*3.0/rhocgs(I,K,J)*1000.0 else QS(I,K,J) = QS(I,K,J) & + (1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3.0 QNS(I,K,J) = QNS(I,K,J) & + COL*chem_new(I,K,J,KR)*XS(KRR)*3.0/rhocgs(I,K,J)*1000.0 endif END DO KRR=0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 if(hail_opt == 1)then QG(I,K,J)=QG(I,K,J) & +(1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XH(KRR)*XH(KRR)*3.0 QNG(I,K,J)=QNG(I,K,J) & +COL*chem_new(I,K,J,KR)*XH(KRR)*3.0/rhocgs(I,K,J)*1000.0 else QG(I,K,J)=QG(I,K,J) & +(1.0/RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3.0 QNG(I,K,J)=QNG(I,K,J) & +COL*chem_new(I,K,J,KR)*XG(KRR)*3.0/rhocgs(I,K,J)*1000.0 endif END DO END IF KRR = 0 DO KR = p_ff8i01,p_ff8i43 KRR = KRR + 1 QNA(I,K,J) = QNA(I,K,J) & + COL*chem_new(I,K,J,KR)/rhocgs(I,K,J)*1000.0 END DO END DO END DO END DO 998 format(' ',10(f10.1,1x)) DO j = jts,jte DO i = its,ite RAINNCV(I,J) = 0.0 SNOWNCV(I,J) = 0.0 GRAUPELNCV(I,J) = 0.0 krr=0 DO KR=p_ff1i01,p_ff1i33 krr=krr+1 DELTAW = VR1_Z(KRR,1) RAINNC(I,J) = RAINNC(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XL(KRR)*XL(KRR) RAINNCV(I,J) = RAINNCV(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XL(KRR)*XL(KRR) END DO KRR=0 DO KR=p_ff5i01,p_ff5i33 KRR=KRR+1 DELTAW = VR3_Z(KRR,1) RAINNC(I,J)=RAINNC(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XS(KRR)*XS(KRR) RAINNCV(I,J)=RAINNCV(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XS(KRR)*XS(KRR) SNOWNC(I,J) = SNOWNC(I,J) & + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XS(KRR)*XS(KRR) SNOWNCV(I,J) = SNOWNCV(I,J) & + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XS(KRR)*XS(KRR) END DO KRR=0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 if(hail_opt == 1)then DELTAW = VR5_Z(KRR,1) RAINNC(I,J) = RAINNC(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XH(KRR)*XH(KRR) RAINNCV(I,J) = RAINNCV(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XH(KRR)*XH(KRR) GRAUPELNC(I,J) = GRAUPELNC(I,J) & + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XH(KRR)*XH(KRR) GRAUPELNCV(I,J) = GRAUPELNCV(I,J) & + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XH(KRR)*XH(KRR) else DELTAW = VR4_Z(KRR,1) RAINNC(I,J) = RAINNC(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XG(KRR)*XG(KRR) RAINNCV(I,J) = RAINNCV(I,J) & +10.0*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XG(KRR)*XG(KRR) GRAUPELNC(I,J) = GRAUPELNC(I,J) & + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XG(KRR)*XG(KRR) GRAUPELNCV(I,J) = GRAUPELNCV(I,J) & + 10*(3./RO1BL(KRR))*COL*DT*DELTAW* & chem_new(I,1,J,KR)*XG(KRR)*XG(KRR) endif END DO if ( PRESENT (diagflag) ) then if( diagflag .and. IPolar_HUCM .and. (sbm_diagnostics==1) ) then dx_dbl = dx dy_dbl = dy do k = kts,kte zmks_1d(k) = zcgs(i,k,j)*0.01 end do DIST_SING = ((i-ide/2)**2+(j-jde/2)**2)**(0.5) DISTANCE = 1.D5 do k=kts,kte FF2R_d = 0.0 FLIQFR_SD = 0.0 FLIQFR_GD = 0.0 FLIQFR_HD = 0.0 FF1_FD = 0.0 FL1_FD = 0.0 BKDEN_Snow(:) = RO3BL(:) RO2BL_D(:,:) = RO2BL(:,:) RO2BL_D(:,:) = RO2BL(:,:) KRR=0 do kr = p_ff1i01,p_ff1i33 KRR=KRR+1 FF1R_D(KRR) = (1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3.0 if (FF1R_D(KRR) < 1.0D-20) FF1R_D(KRR) = 0.0 end do if (ICEPROCS == 1)then KRR=0 do kr=p_ff5i01,p_ff5i33 KRR=KRR+1 FF3R_D(KRR)=(1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3.0 FF3R (KRR) = chem_new(I,K,J,KR) if (ff3r_D(krr) < 1.0D-20) ff3r_D(krr) = 0.0 end do KRR=0 if(hail_opt == 0)then do kr = p_ff6i01,p_ff6i33 KRR=KRR+1 FF4R_D(KRR) = (1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3.0 FF4R(KRR) = chem_new(I,K,J,KR) if (FF4R_D(KRR) < 1.0D-20) FF4R_D(KRR)= 0.0 FF5R_d(KRR) = 0.0 end do else do kr=p_ff6i01,p_ff6i33 KRR=KRR+1 FF5R_D(KRR)=(1./RHOCGS(I,K,J))*chem_new(I,K,J,KR)*XH(KRR)*XH(KRR)*3.0 FF5R(KRR)=chem_new(I,K,J,KR) if (ff5r_d(krr) < 1.0D-20) ff5r_d(krr)=0.0 FF4R_d(KRR) = 0.0 end do endif end if rhocgs_d = rhocgs(I,K,J) T_NEW_D = T_NEW(I,K,J) IWL = 1 ICLOUD = 0 CALL polar_hucm & (FF1R_D, FF2R_D, FF3R_D, FF4R_D, FF5R_D, FF1_FD, & FLIQFR_SD, FLIQFR_GD, FLIQFR_HD, FL1_FD, & BKDEN_Snow, T_NEW_D, rhocgs_D, wavelength, iwl, & distance, dx_dbl, dy_dbl, zmks_1d, & out1, out2, out3, out4, out5, out6, out7, out8, out9, & bin_mass, tab_colum, tab_dendr, tab_snow, bin_log, & ijk, i, j, k, kts, kte, NKR, ICEMAX, icloud, itimestep, & faf1,fbf1,fab1,fbb1, & faf3,fbf3,fab3,fbb3, & faf4,fbf4,fab4,fbb4, & faf5,fbf5,fab5,fbb5, & temps_water,temps_fd,temps_crystals, & temps_snow,temps_graupel,temps_hail, & fws_fd,fws_crystals,fws_snow, & fws_graupel,fws_hail,usetables) KRR=0 DO KR=r_p_ff1i01,r_p_ff1i06 KRR=KRR+1 sbmradar(I,K,J,KR) = out1(KRR) END DO KRR=0 DO KR=r_p_ff2i01,r_p_ff2i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out2(KRR) END DO KRR=0 DO KR=r_p_ff3i01,r_p_ff3i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out3(KRR) END DO KRR=0 DO KR=r_p_ff4i01,r_p_ff4i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out4(KRR) END DO KRR=0 DO KR=r_p_ff5i01,r_p_ff5i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out5(KRR) END DO KRR=0 DO KR=r_p_ff6i01,r_p_ff6i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out6(KRR) END DO KRR=0 DO KR=r_p_ff7i01,r_p_ff7i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out7(KRR) END DO KRR=0 DO KR=r_p_ff8i01,r_p_ff8i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out8(KRR) END DO KRR=0 DO KR=r_p_ff9i01,r_p_ff9i06 KRR=KRR+1 sbmradar(I,K,J,KR)=out9(KRR) END DO end do endif endif END DO END DO do j=jts,jte do k=kts,kte do i=its,ite th_old(i,k,j)=th_phy(i,k,j) qv_old(i,k,j)=qv(i,k,j) end do end do end do if (conserv)then DO j = jts,jte DO i = its,ite DO k = kts,kte rhocgs(I,K,J)=rho_phy(I,K,J)*0.001 krr=0 DO KR=p_ff1i01,p_ff1i33 krr=krr+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XL(KRR)*XL(KRR)*3.0 if (qc(i,k,j)+qr(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.0 END DO KRR=0 DO KR=p_ff5i01,p_ff5i33 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XS(KRR)*XS(KRR)*3.0 if (qs(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.0 END DO KRR=0 DO KR=p_ff8i01,p_ff8i43 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*1000.0 END DO if(hail_opt == 1)then KRR=0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XH(KRR)*XH(KRR)*3.0 if (qg(i,k,j) < 1.e-13) chem_new(I,K,J,KR) = 0.0 END DO else KRR=0 DO KR=p_ff6i01,p_ff6i33 KRR=KRR+1 chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XG(KRR)*XG(KRR)*3.0 if (qg(i,k,j) < 1.e-13) chem_new(I,K,J,KR) = 0.0 END DO endif END DO END DO END DO END IF RETURN END SUBROUTINE FAST_SBM SUBROUTINE FALFLUXHUCM_Z(chem_new,VR1,RHOCGS,PCGS,ZCGS,DT, & kts,kte,nkr) IMPLICIT NONE integer,intent(in) :: kts,kte,nkr real(kind=r4size),intent(inout) :: chem_new(:,:) real(kind=r4size),intent(in) :: rhocgs(:),pcgs(:),zcgs(:),VR1(:,:),DT integer :: I,J,K,KR real(kind=r4size) :: TFALL,DTFALL,VFALL(KTE),DWFLUX(KTE) integer :: IFALL,N,NSUB DO KR=1,NKR IFALL=0 DO k = kts,kte IF(chem_new(K,KR).GE.1.E-20)IFALL=1 END DO IF (IFALL.EQ.1)THEN TFALL=1.E10 DO K=kts,kte VFALL(K) = VR1(K,KR) TFALL=AMIN1(TFALL,ZCGS(K)/(VFALL(K)+1.E-20)) END DO IF(TFALL.GE.1.E10)STOP NSUB=(INT(2.0*DT/TFALL)+1) DTFALL=DT/NSUB DO N=1,NSUB DO K=KTS,KTE-1 DWFLUX(K)=-(RHOCGS(K)*VFALL(K)*chem_new(k,kr)- & RHOCGS(K+1)* & VFALL(K+1)*chem_new(K+1,KR))/(RHOCGS(K)*(ZCGS(K+1)- & ZCGS(K))) END DO DWFLUX(KTE)=-(RHOCGS(KTE)*VFALL(KTE)* & & chem_new(kte,kr))/(RHOCGS(KTE)*(ZCGS(KTE)-ZCGS(KTE-1))) DO K=kts,kte chem_new(k,kr)=chem_new(k,kr)+DWFLUX(K)*DTFALL END DO END DO END IF END DO RETURN END SUBROUTINE FALFLUXHUCM_Z SUBROUTINE FAST_HUCMINIT(DT) USE module_mp_SBM_BreakUp,ONLY:Spontanous_Init USE module_mp_SBM_Collision,ONLY:courant_bott_KS USE module_domain USE module_dm IMPLICIT NONE real(kind=r4size),intent(in) :: DT LOGICAL , EXTERNAL :: wrf_dm_on_monitor LOGICAL :: opened CHARACTER*80 errmess integer :: I,J,KR,IType,HUJISBM_UNIT1 real(kind=r4size) :: dlnr,ax,deg01,CONCCCNIN,CONTCCNIN character(len=256),parameter :: dir_43 = "SBM_input_43", dir_33 = "SBM_input_33" character(len=256) :: input_dir,Fname if(nkr == 33) input_dir = trim(dir_33) if(nkr == 43) input_dir = trim(dir_43) call wrf_message(" FAST SBM: INITIALIZING WRF_HUJISBM ") call wrf_message(" FAST SBM: ****** WRF_HUJISBM ******* ") if (.NOT. ALLOCATED(bin_mass)) ALLOCATE(bin_mass(nkr)) if (.NOT. ALLOCATED(tab_colum)) ALLOCATE(tab_colum(nkr)) if (.NOT. ALLOCATED(tab_dendr)) ALLOCATE(tab_dendr(nkr)) if (.NOT. ALLOCATED(tab_snow)) ALLOCATE(tab_snow(nkr)) if (.NOT. ALLOCATED(bin_log)) ALLOCATE(bin_log(nkr)) dlnr=dlog(2.d0)/(3.d0) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 20,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2060 ENDIF ENDDO 2060 CONTINUE ENDIF CALL wrf_dm_bcast_bytes( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5418,& 'module_mp_FAST-SBM: Table-1 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table, model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_FAST-SBM : Table-1 -- opening "BLKD_SDC.dat" on unit',hujisbm_unit1 CALL wrf_debug(150, errmess) OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/BLKD_SDC.dat",FORM="FORMATTED",STATUS="OLD",ERR=2070) DO kr=1,NKR READ(hujisbm_unit1,*) bin_mass(kr),tab_colum(kr),tab_dendr(kr),tab_snow(kr) bin_log(kr) = log10(bin_mass(kr)) ENDDO ENDIF CALL wrf_dm_bcast_bytes(bin_mass, size(bin_mass)*R8SIZE) CALL wrf_dm_bcast_bytes(tab_colum, size(tab_colum)*R8SIZE) CALL wrf_dm_bcast_bytes(tab_dendr, size(tab_dendr)*R8SIZE) CALL wrf_dm_bcast_bytes(tab_snow, size(tab_snow)*R8SIZE) CALL wrf_dm_bcast_bytes(bin_log, size(bin_log)*R8SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-1' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(RLEC)) ALLOCATE(RLEC(nkr)) if (.NOT. ALLOCATED(RIEC)) ALLOCATE(RIEC(nkr,icemax)) if (.NOT. ALLOCATED(RSEC)) ALLOCATE(RSEC(nkr)) if (.NOT. ALLOCATED(RGEC)) ALLOCATE(RGEC(nkr)) if (.NOT. ALLOCATED(RHEC)) ALLOCATE(RHEC(nkr)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2061 ENDIF ENDDO 2061 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5466,& 'module_mp_FAST-SBM: Table-2 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_FAST-SBM : Table-2 -- opening capacity.asc on unit',hujisbm_unit1 CALL wrf_debug(150, errmess) OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/capacity33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070) 900 FORMAT(6E13.5) READ(hujisbm_unit1,900) RLEC,RIEC,RSEC,RGEC,RHEC END IF CALL wrf_dm_bcast_bytes(RLEC, size(RLEC)*R4SIZE) CALL wrf_dm_bcast_bytes(RIEC, size(RIEC)*R4SIZE) CALL wrf_dm_bcast_bytes(RSEC, size(RSEC)*R4SIZE) CALL wrf_dm_bcast_bytes(RGEC, size(RGEC)*R4SIZE) CALL wrf_dm_bcast_bytes(RHEC, size(RHEC)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-2' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(XL)) ALLOCATE(XL(nkr)) if (.NOT. ALLOCATED(XI)) ALLOCATE(XI(nkr,icemax)) if (.NOT. ALLOCATED(XS)) ALLOCATE(XS(nkr)) if (.NOT. ALLOCATED(XG)) ALLOCATE(XG(nkr)) if (.NOT. ALLOCATED(XH)) ALLOCATE(XH(nkr)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2062 ENDIF ENDDO 2062 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1, 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5513,& 'module_mp_FAST_SBM: Table-3 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-3 -- opening masses.asc on unit ',hujisbm_unit1 CALL wrf_debug(150, errmess) OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/masses33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) XL,XI,XS,XG,XH CLOSE(hujisbm_unit1) ENDIF CALL wrf_dm_bcast_bytes(XL, size(XL)*R4SIZE) CALL wrf_dm_bcast_bytes(XI, size(XI)*R4SIZE) CALL wrf_dm_bcast_bytes(XS, size(XS)*R4SIZE) CALL wrf_dm_bcast_bytes(XG, size(XG)*R4SIZE) CALL wrf_dm_bcast_bytes(XH, size(XH)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-3' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(VR1)) ALLOCATE(VR1(nkr)) if (.NOT. ALLOCATED(VR2)) ALLOCATE(VR2(nkr,icemax)) if (.NOT. ALLOCATED(VR3)) ALLOCATE(VR3(nkr)) if (.NOT. ALLOCATED(VR4)) ALLOCATE(VR4(nkr)) if (.NOT. ALLOCATED(VR5)) ALLOCATE(VR5(nkr)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2063 ENDIF ENDDO 2063 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5559,& 'module_mp_FAST_SBM: Table-4 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-4 -- opening termvels.asc on unit ',hujisbm_unit1 CALL wrf_debug(150, errmess) OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/termvels33_corrected.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) VR1,VR2,VR3,VR4,VR5 CLOSE(hujisbm_unit1) ENDIF CALL wrf_dm_bcast_bytes(VR1, size(VR1)*R4SIZE) CALL wrf_dm_bcast_bytes(VR2, size(VR2)*R4SIZE) CALL wrf_dm_bcast_bytes(VR3, size(VR3)*R4SIZE) CALL wrf_dm_bcast_bytes(VR4, size(VR4)*R4SIZE) CALL wrf_dm_bcast_bytes(VR5, size(VR5)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-4' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(SLIC)) ALLOCATE(SLIC(nkr,6)) if (.NOT. ALLOCATED(TLIC)) ALLOCATE(TLIC(nkr,2)) if (.NOT. ALLOCATED(COEFIN)) ALLOCATE(COEFIN(nkr)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2065 ENDIF ENDDO hujisbm_unit1 = -1 2065 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5606,& 'module_mp_FAST_SBM: Table-5 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-5 -- opening constants.asc on unit ',hujisbm_unit1 CALL wrf_debug(150, errmess) OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/constants33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) SLIC,TLIC,COEFIN CLOSE(hujisbm_unit1) END IF CALL wrf_dm_bcast_bytes(SLIC, size(SLIC)*R4SIZE) CALL wrf_dm_bcast_bytes(TLIC, size(TLIC)*R4SIZE) CALL wrf_dm_bcast_bytes(COEFIN, size(COEFIN)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-5' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(YWLL_1000MB)) ALLOCATE(YWLL_1000MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLL_750MB)) ALLOCATE(YWLL_750MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLL_500MB)) ALLOCATE(YWLL_500MB(nkr,nkr)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2066 ENDIF ENDDO hujisbm_unit1 = -1 2066 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5649,& 'module_mp_FAST_SBM: Table-6 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-6 -- opening kernels_z.asc on unit ',hujisbm_unit1 CALL wrf_debug(150, errmess) Fname = trim(input_dir)//'/kernLL_z33.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWLL_1000MB,YWLL_750MB,YWLL_500MB CLOSE(hujisbm_unit1) END IF DO I=1,NKR DO J=1,NKR IF(I > 33 .OR. J > 33) THEN YWLL_1000MB(I,J) = 0.0 YWLL_750MB(I,J) = 0.0 YWLL_500MB(I,J) = 0.0 ENDIF ENDDO ENDDO CALL wrf_dm_bcast_bytes(YWLL_1000MB, size(YWLL_1000MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLL_750MB, size(YWLL_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLL_500MB, size(YWLL_500MB)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-6' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(YWLI_300MB)) ALLOCATE(YWLI_300MB(nkr,nkr,icemax)) if (.NOT. ALLOCATED(YWLI_500MB)) ALLOCATE(YWLI_500MB(nkr,nkr,icemax)) if (.NOT. ALLOCATED(YWLI_750MB)) ALLOCATE(YWLI_750MB(nkr,nkr,icemax)) if (.NOT. ALLOCATED(YWLG_300MB)) ALLOCATE(YWLG_300MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLG_500MB)) ALLOCATE(YWLG_500MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLG_750MB)) ALLOCATE(YWLG_750MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLH_300MB)) ALLOCATE(YWLH_300MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLH_500MB)) ALLOCATE(YWLH_500MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLH_750MB)) ALLOCATE(YWLH_750MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLS_300MB)) ALLOCATE(YWLS_300MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLS_500MB)) ALLOCATE(YWLS_500MB(nkr,nkr)) if (.NOT. ALLOCATED(YWLS_750MB)) ALLOCATE(YWLS_750MB(nkr,nkr)) if (.NOT. ALLOCATED(YWII_300MB)) ALLOCATE(YWII_300MB(nkr,nkr,icemax,icemax)) if (.NOT. ALLOCATED(YWII_500MB)) ALLOCATE(YWII_500MB(nkr,nkr,icemax,icemax)) if (.NOT. ALLOCATED(YWII_750MB)) ALLOCATE(YWII_750MB(nkr,nkr,icemax,icemax)) if (.NOT. ALLOCATED(YWIS_300MB)) ALLOCATE(YWIS_300MB(nkr,nkr,icemax)) if (.NOT. ALLOCATED(YWIS_500MB)) ALLOCATE(YWIS_500MB(nkr,nkr,icemax)) if (.NOT. ALLOCATED(YWIS_750MB)) ALLOCATE(YWIS_750MB(nkr,nkr,icemax)) if (.NOT. ALLOCATED(YWSG_300MB)) ALLOCATE(YWSG_300MB(nkr,nkr)) if (.NOT. ALLOCATED(YWSG_500MB)) ALLOCATE(YWSG_500MB(nkr,nkr)) if (.NOT. ALLOCATED(YWSG_750MB)) ALLOCATE(YWSG_750MB(nkr,nkr)) if (.NOT. ALLOCATED(YWSS_300MB)) ALLOCATE(YWSS_300MB(nkr,nkr)) if (.NOT. ALLOCATED(YWSS_500MB)) ALLOCATE(YWSS_500MB(nkr,nkR)) if (.NOT. ALLOCATED(YWSS_750MB)) ALLOCATE(YWSS_750MB(nkr,nkr)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2067 ENDIF ENDDO 2067 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5739,& 'module_mp_FAST_SBM: Table-7 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : Table-7 -- opening kernels33.asc on unit',hujisbm_unit1 CALL wrf_debug(150, errmess) Fname = trim(input_dir)//'/ckli_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWLI_300MB,YWLI_500MB,YWLI_750MB CLOSE(hujisbm_unit1) Fname = trim(input_dir)//'/cklg_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWLG_300MB,YWLG_500MB,YWLG_750MB CLOSE(hujisbm_unit1) Fname = trim(input_dir)//'/cklh_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWLH_300MB,YWLH_500MB,YWLH_750MB CLOSE(hujisbm_unit1) Fname = trim(input_dir)//'/ckls_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWLS_300MB,YWLS_500MB,YWLS_750MB CLOSE(hujisbm_unit1) Fname = trim(input_dir)//'/ckii_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWII_300MB,YWII_500MB,YWII_750MB CLOSE(hujisbm_unit1) Fname = trim(input_dir)//'/ckis_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWIS_300MB,YWIS_500MB,YWIS_750MB CLOSE(hujisbm_unit1) Fname = trim(input_dir)//'/cksg_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWSG_300MB,YWSG_500MB,YWSG_750MB CLOSE(hujisbm_unit1) Fname = trim(input_dir)//'/ckss_33_300mb_500mb_750mb.asc' OPEN(UNIT=hujisbm_unit1,FILE=Fname,FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) YWSS_300MB,YWSS_500MB,YWSS_750MB CLOSE(hujisbm_unit1) END IF CALL wrf_dm_bcast_bytes(YWLI_300MB, size(YWLI_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLI_500MB, size(YWLI_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLI_750MB, size(YWLI_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLG_300MB, size(YWLG_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLG_500MB, size(YWLG_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLG_750MB, size(YWLG_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLH_300MB, size(YWLH_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLH_500MB, size(YWLH_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLH_750MB, size(YWLH_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLS_300MB, size(YWLS_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLS_500MB, size(YWLS_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWLS_750MB, size(YWLS_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWII_300MB, size(YWII_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWII_500MB, size(YWII_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWII_750MB, size(YWII_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWIS_300MB, size(YWIS_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWIS_500MB, size(YWIS_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWIS_750MB, size(YWIS_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWSG_300MB, size(YWSG_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWSG_500MB, size(YWSG_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWSG_750MB, size(YWSG_750MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWSS_300MB, size(YWSS_300MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWSS_500MB, size(YWSS_500MB)*R4SIZE) CALL wrf_dm_bcast_bytes(YWSS_750MB, size(YWSS_750MB)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-7' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(RO1BL)) ALLOCATE(RO1BL(nkr)) if (.NOT. ALLOCATED(RO2BL)) ALLOCATE(RO2BL(nkr,icemax)) if (.NOT. ALLOCATED(RO3BL)) ALLOCATE(RO3BL(nkr)) if (.NOT. ALLOCATED(RO4BL)) ALLOCATE(RO4BL(nkr)) if (.NOT. ALLOCATED(RO5BL)) ALLOCATE(RO5BL(nkr)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2068 ENDIF ENDDO 2068 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5938,& 'module_mp_FAST_SBM: Table-8 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : Table-8 -- opening bulkdens.asc on unit ',hujisbm_unit1 CALL wrf_debug(150, errmess) OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/bulkdens33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,900) RO1BL,RO2BL,RO3BL,RO4BL,RO5BL CLOSE(hujisbm_unit1) END IF CALL wrf_dm_bcast_bytes(RO1BL, size(RO1BL)*R4SIZE) CALL wrf_dm_bcast_bytes(RO2BL, size(RO2BL)*R4SIZE) CALL wrf_dm_bcast_bytes(RO3BL, size(RO3BL)*R4SIZE) CALL wrf_dm_bcast_bytes(RO4BL, size(RO4BL)*R4SIZE) CALL wrf_dm_bcast_bytes(RO5BL, size(RO5BL)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-8' CALL wrf_debug(000, errmess) if (.NOT. ALLOCATED(RADXXO)) ALLOCATE(RADXXO(nkr,nhydro)) hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 31,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2069 ENDIF ENDDO 2069 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",5977,& 'module_mp_FAST_SBM: Table-9 -- FAST_SBM_INIT: '// & 'Can not find unused fortran unit to read in lookup table,model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN WRITE(errmess, '(A,I2)') 'module_mp_FAST_SBM : Table-9 -- opening bulkradii.asc on unit',hujisbm_unit1 CALL wrf_debug(150, errmess) OPEN(UNIT=hujisbm_unit1,FILE=trim(input_dir)//"/bulkradii33.asc",FORM="FORMATTED",STATUS="OLD",ERR=2070) READ(hujisbm_unit1,*) RADXXO CLOSE(hujisbm_unit1) END IF CALL wrf_dm_bcast_bytes(RADXXO, size(RADXXO)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading Table-9' CALL wrf_debug(000, errmess) CALL LOAD_TABLES(NKR) CALL wrf_dm_bcast_bytes(FAF1, size(FAF1)*R16SIZE) CALL wrf_dm_bcast_bytes(FBF1, size(FBF1)*R16SIZE) CALL wrf_dm_bcast_bytes(FAB1, size(FAB1)*R16SIZE) CALL wrf_dm_bcast_bytes(FBB1, size(FBB1)*R16SIZE) CALL wrf_dm_bcast_bytes(FAF3, size(FAF3)*R16SIZE) CALL wrf_dm_bcast_bytes(FBF3, size(FBF3)*R16SIZE) CALL wrf_dm_bcast_bytes(FAB3, size(FAB3)*R16SIZE) CALL wrf_dm_bcast_bytes(FBB3, size(FBB3)*R16SIZE) CALL wrf_dm_bcast_bytes(FAF4, size(FAF4)*R16SIZE) CALL wrf_dm_bcast_bytes(FBF4, size(FBF4)*R16SIZE) CALL wrf_dm_bcast_bytes(FAB4, size(FAB4)*R16SIZE) CALL wrf_dm_bcast_bytes(FBB4, size(FBB4)*R16SIZE) CALL wrf_dm_bcast_bytes(FAF5, size(FAF5)*R16SIZE) CALL wrf_dm_bcast_bytes(FBF5, size(FBF5)*R16SIZE) CALL wrf_dm_bcast_bytes(FAB5, size(FAB5)*R16SIZE) CALL wrf_dm_bcast_bytes(FBB5, size(FBB5)*R16SIZE) CALL wrf_dm_bcast_integer ( usetables , size ( usetables ) * 4 ) WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : succesfull reading Table-10' call wrf_message(errmess) ax=2.d0**(1.0) do i=1,nkr xl_mg(i) = xl(i)*1.e3 xs_mg(i) = xs(i)*1.e3 xg_mg(i) = xg(i)*1.e3 xh_mg(i) = xh(i)*1.e3 xi1_mg(i) = xi(i,1)*1.e3 xi2_mg(i) = xi(i,2)*1.e3 xi3_mg(i) = xi(i,3)*1.e3 enddo if (.NOT. ALLOCATED(IMA)) ALLOCATE(IMA(nkr,nkr)) if (.NOT. ALLOCATED(CHUCM)) ALLOCATE(CHUCM(nkr,nkr)) chucm = 0.0d0 ima = 0 CALL courant_bott_KS(xl, nkr, chucm, ima, scal) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading "courant_bott_KS" ' CALL wrf_debug(000, errmess) DEG01=1./3. CONCCCNIN=0. CONTCCNIN=0. if (.NOT. ALLOCATED(DROPRADII)) ALLOCATE(DROPRADII(NKR)) DO KR=1,NKR DROPRADII(KR)=(3.0*XL(KR)/4.0/3.141593/1.0)**DEG01 ENDDO if (.NOT. ALLOCATED(FCCNR_MAR)) ALLOCATE(FCCNR_MAR(NKR_aerosol)) if (.NOT. ALLOCATED(FCCNR_CON)) ALLOCATE(FCCNR_CON(NKR_aerosol)) if (.NOT. ALLOCATED(XCCN)) ALLOCATE(XCCN(NKR_aerosol)) if (.NOT. ALLOCATED(RCCN)) ALLOCATE(RCCN(NKR_aerosol)) if (.NOT. ALLOCATED(Scale_CCN_Factor)) ALLOCATE(Scale_CCN_Factor) if (.NOT. ALLOCATED(FCCN)) ALLOCATE(FCCN(NKR_aerosol)) IF(ILogNormal_modes_Aerosol == 1)THEN FCCNR_CON = 0.0 FCCNR_MAR = 0.0 Scale_CCN_Factor = 1.0 XCCN = 0.0 RCCN = 0.0 CALL LogNormal_modes_Aerosol(FCCNR_CON,FCCNR_MAR,NKR_aerosol,COL,XL,XCCN,RCCN,RO_SOLUTE,Scale_CCN_Factor,1) CALL LogNormal_modes_Aerosol(FCCNR_CON,FCCNR_MAR,NKR_aerosol,COL,XL,XCCN,RCCN,RO_SOLUTE,Scale_CCN_Factor,2) WRITE(errmess, '(A,I2)') 'module_mp_WRFsbm : succesfull reading "LogNormal_modes_Aerosol" ' CALL wrf_debug(000, errmess) ENDIF if (.NOT. ALLOCATED(PKIJ)) ALLOCATE(PKIJ(JBREAK,JBREAK,JBREAK)) if (.NOT. ALLOCATED(QKJ)) ALLOCATE(QKJ(JBREAK,JBREAK)) if (.NOT. ALLOCATED(ECOALMASSM)) ALLOCATE(ECOALMASSM(NKR,NKR)) if (.NOT. ALLOCATED(BRKWEIGHT)) ALLOCATE(BRKWEIGHT(JBREAK)) PKIJ = 0.0e0 QKJ = 0.0e0 ECOALMASSM = 0.0d0 BRKWEIGHT = 0.0d0 CALL BREAKINIT_KS(PKIJ,QKJ,ECOALMASSM,BRKWEIGHT,XL,DROPRADII,BR_MAX,JBREAK,JMAX,NKR,VR1) CALL wrf_dm_bcast_bytes(PKIJ, size(PKIJ)*R4SIZE) CALL wrf_dm_bcast_bytes(QKJ, size(QKJ)*R4SIZE) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading BREAKINIT_KS" ' CALL wrf_debug(000, errmess) 100 FORMAT(10I4) 101 FORMAT(3X,F7.5,E13.5) 102 FORMAT(4E12.4) 105 FORMAT(A48) 106 FORMAT(A80) 123 FORMAT(3E12.4,3I4) 200 FORMAT(6E13.5) 201 FORMAT(6D13.5) 300 FORMAT(8E14.6) 301 FORMAT(3X,F8.3,3X,E13.5) 302 FORMAT(5E13.5) if (.NOT. ALLOCATED(cwll)) ALLOCATE(cwll(nkr,nkr)) if (.NOT. ALLOCATED(cwli_1)) ALLOCATE(cwli_1(nkr,nkr)) if (.NOT. ALLOCATED(cwli_2)) ALLOCATE(cwli_2(nkr,nkr)) if (.NOT. ALLOCATED(cwli_3)) ALLOCATE(cwli_3(nkr,nkr)) if (.NOT. ALLOCATED(cwil_1)) ALLOCATE(cwil_1(nkr,nkr)) if (.NOT. ALLOCATED(cwil_2)) ALLOCATE(cwil_2(nkr,nkr)) if (.NOT. ALLOCATED(cwil_3)) ALLOCATE(cwil_3(nkr,nkr)) if (.NOT. ALLOCATED(cwlg)) ALLOCATE(cwlg(nkr,nkr)) if (.NOT. ALLOCATED(cwlh)) ALLOCATE(cwlh(nkr,nkr)) if (.NOT. ALLOCATED(cwls)) ALLOCATE(cwls(nkr,nkr)) if (.NOT. ALLOCATED(cwgl)) ALLOCATE(cwgl(nkr,nkr)) if (.NOT. ALLOCATED(cwhl)) ALLOCATE(cwhl(nkr,nkr)) if (.NOT. ALLOCATED(cwsl)) ALLOCATE(cwsl(nkr,nkr)) if (.NOT. ALLOCATED(cwii_1_1)) ALLOCATE(cwii_1_1(nkr,nkr)) if (.NOT. ALLOCATED(cwii_1_2)) ALLOCATE(cwii_1_2(nkr,nkr)) if (.NOT. ALLOCATED(cwii_1_3)) ALLOCATE(cwii_1_3(nkr,nkr)) if (.NOT. ALLOCATED(cwii_2_1)) ALLOCATE(cwii_2_1(nkr,nkr)) if (.NOT. ALLOCATED(cwii_2_2)) ALLOCATE(cwii_2_2(nkr,nkr)) if (.NOT. ALLOCATED(cwii_2_3)) ALLOCATE(cwii_2_3(nkr,nkr)) if (.NOT. ALLOCATED(cwii_3_1)) ALLOCATE(cwii_3_1(nkr,nkr)) if (.NOT. ALLOCATED(cwii_3_2)) ALLOCATE(cwii_3_2(nkr,nkr)) if (.NOT. ALLOCATED(cwii_3_3)) ALLOCATE(cwii_3_3(nkr,nkr)) if (.NOT. ALLOCATED(cwis_1)) ALLOCATE(cwis_1(nkr,nkr)) if (.NOT. ALLOCATED(cwis_2)) ALLOCATE(cwis_2(nkr,nkr)) if (.NOT. ALLOCATED(cwis_3)) ALLOCATE(cwis_3(nkr,nkr)) if (.NOT. ALLOCATED(cwsi_1)) ALLOCATE(cwsi_1(nkr,nkr)) if (.NOT. ALLOCATED(cwsi_2)) ALLOCATE(cwsi_2(nkr,nkr)) if (.NOT. ALLOCATED(cwsi_3)) ALLOCATE(cwsi_3(nkr,nkr)) if (.NOT. ALLOCATED(cwig_1)) ALLOCATE(cwig_1(nkr,nkr)) if (.NOT. ALLOCATED(cwig_2)) ALLOCATE(cwig_2(nkr,nkr)) if (.NOT. ALLOCATED(cwig_3)) ALLOCATE(cwig_3(nkr,nkr)) if (.NOT. ALLOCATED(cwih_1)) ALLOCATE(cwih_1(nkr,nkr)) if (.NOT. ALLOCATED(cwih_2)) ALLOCATE(cwih_2(nkr,nkr)) if (.NOT. ALLOCATED(cwih_3)) ALLOCATE(cwih_3(nkr,nkr)) if (.NOT. ALLOCATED(cwsg)) ALLOCATE(cwsg(nkr,nkr)) if (.NOT. ALLOCATED(cwss)) ALLOCATE(cwss(nkr,nkr)) cwll(:,:) = 0.0e0 cwli_1(:,:) = 0.0e0 ; cwli_2(:,:) = 0.0e0 ; cwli_3(:,:) = 0.0e0 cwil_1(:,:) = 0.0e0 ; cwil_2(:,:) = 0.0e0 ; cwil_3(:,:) = 0.0e0 cwlg(:,:) = 0.0e0 ; cwlh(:,:) = 0.0e0 ; cwls(:,:) = 0.0e0 cwgl(:,:) = 0.0e0 ; cwhl(:,:) = 0.0e0 ; cwsl(:,:) = 0.0e0 cwii_1_1(:,:) = 0.0e0 ; cwii_1_2(:,:) = 0.0e0 ; cwii_1_3(:,:) = 0.0e0 cwii_2_1(:,:) = 0.0e0 ; cwii_2_2(:,:) = 0.0e0 ; cwii_2_3(:,:) = 0.0e0 cwii_3_1(:,:) = 0.0e0 ; cwii_3_2(:,:) = 0.0e0 ; cwii_3_3(:,:) = 0.0e0 cwis_1(:,:) = 0.0e0 ; cwis_2(:,:) = 0.0e0 ; cwis_3(:,:) = 0.0e0 cwsi_1(:,:) = 0.0e0 ; cwsi_2(:,:) = 0.0e0 ; cwsi_3(:,:) = 0.0e0 cwig_1(:,:) = 0.0e0 ; cwig_2(:,:) = 0.0e0 ; cwig_3(:,:) = 0.0e0 cwih_1(:,:) = 0.0e0 ; cwih_2(:,:) = 0.0e0 ; cwih_3(:,:) = 0.0e0 cwsg(:,:) = 0.0e0 ; cwss(:,:) = 0.0e0 call Kernals_KS(dt,nkr,7.6E6) if (.NOT. ALLOCATED( Prob)) ALLOCATE( Prob(NKR)) if (.NOT. ALLOCATED(Gain_Var_New)) ALLOCATE(Gain_Var_New(NKR,NKR)) if (.NOT. ALLOCATED(NND)) ALLOCATE(NND(NKR,NKR)) Prob = 0.0 Gain_Var_New = 0.0 NND = 0.0 call Spontanous_Init(dt, XL, DROPRADII, Prob, Gain_Var_New, NND, NKR, ikr_spon_break) WRITE(errmess, '(A,I2)') 'FAST_SBM_INIT : succesfull reading "Spontanous_Init" ' CALL wrf_debug(000, errmess) return 2070 continue WRITE( errmess , '(A,I4)' ) & 'module_mp_FAST_SBM_INIT: error opening hujisbm_DATA on unit,model stop ' & &, hujisbm_unit1 CALL wrf_error_fatal3("",6184,& errmess) END SUBROUTINE FAST_HUCMINIT subroutine Kernals_KS(dtime_coal,nkr,p_z) implicit none integer :: nkr real(kind=r4size),intent(in) :: dtime_coal,p_z integer :: i,j real(kind=r4size),parameter :: p1=1.0e6,p2=0.75e6,p3=0.50e6,p4=0.3e6 real(kind=r4size) :: dlnr, scal, dtimelnr, pdm, p_1, p_2, p_3, ckern_1, ckern_2, & ckern_3 scal = 1.0 dlnr = dlog(2.0d0)/(3.0d0*scal) dtimelnr = dtime_coal*dlnr p_1=p1 p_2=p2 p_3=p3 do i=1,nkr do j=1,nkr ckern_1 = YWLL_1000mb(i,j) ckern_2 = YWLL_750mb(i,j) ckern_3 = YWLL_500mb(i,j) cwll(i,j) = ckern_z(p_z,p_1,p_2,p_3,ckern_1,ckern_2,ckern_3)*dtime_coal*dlnr end do end do DO I=1,NKR DO J=1,NKR CWLL(I,J) = ECOALMASSM(I,J)*CWLL(I,J) END DO END DO p_1=p2 p_2=p3 p_3=p4 if(p_z >= p_1) then do j=1,nkr do i=1,nkr cwli_1(i,j) = ywli_750mb(i,j,1)*dtimelnr cwli_2(i,j) = ywli_750mb(i,j,2)*dtimelnr cwli_3(i,j) = ywli_750mb(i,j,3)*dtimelnr cwlg(i,j) = ywlg_750mb(i,j)*dtimelnr cwlh(i,j) = ywlh_750mb(i,j)*dtimelnr cwls(i,j) = ywls_750mb(i,j)*dtimelnr cwii_1_1(i,j) = ywii_750mb(i,j,1,1)*dtimelnr cwii_1_2(i,j) = ywii_750mb(i,j,1,2)*dtimelnr cwii_1_3(i,j) = ywii_750mb(i,j,1,3)*dtimelnr cwii_2_1(i,j) = ywii_750mb(i,j,2,1)*dtimelnr cwii_2_2(i,j) = ywii_750mb(i,j,2,2)*dtimelnr cwii_2_3(i,j) = ywii_750mb(i,j,2,3)*dtimelnr cwii_3_1(i,j) = ywii_750mb(i,j,3,1)*dtimelnr cwii_3_2(i,j) = ywii_750mb(i,j,3,2)*dtimelnr cwii_3_3(i,j) = ywii_750mb(i,j,3,3)*dtimelnr cwis_1(i,j) = ywis_750mb(i,j,1)*dtimelnr cwis_2(i,j) = ywis_750mb(i,j,2)*dtimelnr cwis_3(i,j) = ywis_750mb(i,j,3)*dtimelnr cwsg(i,j) = ywsg_750mb(i,j)*dtimelnr cwss(i,j) = ywss_750mb(i,j)*dtimelnr end do end do endif if (p_z <= p_3) then do j=1,nkr do i=1,nkr cwli_1(i,j) = ywli_300mb(i,j,1)*dtimelnr cwli_2(i,j) = ywli_300mb(i,j,2)*dtimelnr cwli_3(i,j) = ywli_300mb(i,j,3)*dtimelnr cwlg(i,j) = ywlg_300mb(i,j)*dtimelnr cwlh(i,j) = ywlh_300mb(i,j)*dtimelnr cwls(i,j) = ywls_300mb(i,j)*dtimelnr cwii_1_1(i,j) = ywii_300mb(i,j,1,1)*dtimelnr cwii_1_2(i,j) = ywii_300mb(i,j,1,2)*dtimelnr cwii_1_3(i,j) = ywii_300mb(i,j,1,3)*dtimelnr cwii_2_1(i,j) = ywii_300mb(i,j,2,1)*dtimelnr cwii_2_2(i,j) = ywii_300mb(i,j,2,2)*dtimelnr cwii_2_3(i,j) = ywii_300mb(i,j,2,3)*dtimelnr cwii_3_1(i,j) = ywii_300mb(i,j,3,1)*dtimelnr cwii_3_2(i,j) = ywii_300mb(i,j,3,2)*dtimelnr cwii_3_3(i,j) = ywii_300mb(i,j,3,3)*dtimelnr cwis_1(i,j) = ywis_300mb(i,j,1)*dtimelnr cwis_2(i,j) = ywis_300mb(i,j,2)*dtimelnr cwis_3(i,j) = ywis_300mb(i,j,3)*dtimelnr cwsg(i,j) = ywsg_300mb(i,j)*dtimelnr cwss(i,j) = ywss_300mb(i,j)*dtimelnr end do end do endif if (p_z < p_1 .and. p_z >= p_2) then pdm = (p_z-p_2)/(p_1-p_2) do j=1,nkr do i=1,nkr ckern_1=ywli_750mb(i,j,1) ckern_2=ywli_500mb(i,j,1) cwli_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywli_750mb(i,j,2) ckern_2=ywli_500mb(i,j,2) cwli_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywli_750mb(i,j,3) ckern_2=ywli_500mb(i,j,3) cwli_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywlg_750mb(i,j) ckern_2=ywlg_500mb(i,j) cwlg(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywlh_750mb(i,j) ckern_2=ywlh_500mb(i,j) cwlh(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywls_750mb(i,j) ckern_2=ywls_500mb(i,j) cwls(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,1,1) ckern_2=ywii_500mb(i,j,1,1) cwii_1_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,1,2) ckern_2=ywii_500mb(i,j,1,2) cwii_1_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,1,3) ckern_2=ywii_500mb(i,j,1,3) cwii_1_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,2,1) ckern_2=ywii_500mb(i,j,2,1) cwii_2_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,2,2) ckern_2=ywii_500mb(i,j,2,2) cwii_2_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,2,3) ckern_2=ywii_500mb(i,j,2,3) cwii_2_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,3,1) ckern_2=ywii_500mb(i,j,3,1) cwii_3_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,3,2) ckern_2=ywii_500mb(i,j,3,2) cwii_3_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywii_750mb(i,j,3,3) ckern_2=ywii_500mb(i,j,3,3) cwii_3_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywis_750mb(i,j,1) ckern_2=ywis_500mb(i,j,1) cwis_1(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywis_750mb(i,j,2) ckern_2=ywis_500mb(i,j,2) cwis_2(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywis_750mb(i,j,3) ckern_2=ywis_500mb(i,j,3) cwis_3(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywsg_750mb(i,j) ckern_2=ywsg_500mb(i,j) cwsg(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr ckern_1=ywss_750mb(i,j) ckern_2=ywss_500mb(i,j) cwss(i,j)=(ckern_2+(ckern_1-ckern_2)*pdm)*dtimelnr end do end do endif if (p_z < p_2 .and. p_z > p_3) then pdm = (p_z-p_3)/(p_2-p_3) do j=1,nkr do i=1,nkr ckern_2=ywli_500mb(i,j,1) ckern_3=ywli_300mb(i,j,1) cwli_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywli_500mb(i,j,2) ckern_3=ywli_300mb(i,j,2) cwli_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywli_500mb(i,j,3) ckern_3=ywli_300mb(i,j,3) cwli_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywlg_500mb(i,j) ckern_3=ywlg_300mb(i,j) cwlg(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywlh_500mb(i,j) ckern_3=ywlh_300mb(i,j) cwlh(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywls_500mb(i,j) ckern_3=ywls_300mb(i,j) cwls(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,1,1) ckern_3=ywii_300mb(i,j,1,1) cwii_1_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,1,2) ckern_3=ywii_300mb(i,j,1,2) cwii_1_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,1,3) ckern_3=ywii_300mb(i,j,1,3) cwii_1_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,2,1) ckern_3=ywii_300mb(i,j,2,1) cwii_2_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,2,2) ckern_3=ywii_300mb(i,j,2,2) cwii_2_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,2,3) ckern_3=ywii_300mb(i,j,2,3) cwii_2_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,3,1) ckern_3=ywii_300mb(i,j,3,1) cwii_3_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,3,2) ckern_3=ywii_300mb(i,j,3,2) cwii_3_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywii_500mb(i,j,3,3) ckern_3=ywii_300mb(i,j,3,3) cwii_3_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywis_500mb(i,j,1) ckern_3=ywis_300mb(i,j,1) cwis_1(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywis_500mb(i,j,2) ckern_3=ywis_300mb(i,j,2) cwis_2(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywis_500mb(i,j,3) ckern_3=ywis_300mb(i,j,3) cwis_3(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywsg_500mb(i,j) ckern_3=ywsg_300mb(i,j) cwsg(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr ckern_2=ywss_500mb(i,j) ckern_3=ywss_300mb(i,j) cwss(i,j)=(ckern_3+(ckern_2-ckern_3)*pdm)*dtimelnr end do end do endif do i=1,nkr do j=1,nkr cwil_1(i,j)=cwli_1(j,i) cwil_2(i,j)=cwli_2(j,i) cwil_3(i,j)=cwli_3(j,i) cwgl(i,j)=cwlg(j,i) cwhl(i,j)=cwlh(j,i) cwsl(i,j)=cwls(j,i) cwsi_1(i,j)=cwis_1(j,i) cwsi_2(i,j)=cwis_2(j,i) cwsi_3(i,j)=cwis_3(j,i) end do end do return end subroutine Kernals_KS real function ckern_z (p_z,p_1,p_2,p_3,ckern_1,ckern_2,ckern_3) implicit none real(kind=r4size),intent(in) :: p_z,p_1,p_2,p_3,ckern_1, & ckern_2,ckern_3 if(p_z>=p_1) ckern_z = ckern_1 if(p_z<=p_3) ckern_z = ckern_3 if(p_z=p_2) ckern_z = ckern_2 + (ckern_1-ckern_2)*(p_z-p_2)/(p_1-p_2) if(p_zp_3) ckern_z = ckern_3 + (ckern_2-ckern_3)*(p_z-p_3)/(p_2-p_3) return end function ckern_z SUBROUTINE FREEZ(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH, & TIN,DT,RO,COL,AFREEZMY,BFREEZMY, & BFREEZMAX,KRFREEZ,ICEMAX,NKR) IMPLICIT NONE INTEGER KR,ICE,ICE_TYPE REAL COL,AFREEZMY,BFREEZMY,BFREEZMAX INTEGER KRFREEZ,ICEMAX,NKR REAL DT,RO,YKK,PF,PF_1,DEL_T,TT_DROP,ARG_1,YK2,DF1,BF,ARG_M, & TT_DROP_AFTER_FREEZ,CFREEZ,SUM_ICE,TIN,TTIN,AF,FF_MAX,F1_MAX, & F2_MAX,F3_MAX,F4_MAX,F5_MAX REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX) & ,XI(NKR,ICEMAX),FF3(NKR),XS(NKR),FF4(NKR) & ,XG(NKR),FF5(NKR),XH(NKR) TTIN=TIN DEL_T =TTIN-273.15 ICE_TYPE=2 F1_MAX=0. F2_MAX=0. F3_MAX=0. F4_MAX=0. F5_MAX=0. DO KR=1,NKR F1_MAX=AMAX1(F1_MAX,FF1(KR)) F3_MAX=AMAX1(F3_MAX,FF3(KR)) F4_MAX=AMAX1(F4_MAX,FF4(KR)) F5_MAX=AMAX1(F5_MAX,FF5(KR)) DO ICE=1,ICEMAX F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE)) ENDDO FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX) ENDDO IF(DEL_T.LT.0.AND.F1_MAX.NE.0) THEN SUM_ICE=0. AF = AFREEZMY CFREEZ =(BFREEZMAX-BFREEZMY)/XL(NKR) DO KR =1,NKR ARG_M =XL(KR) BF =BFREEZMY+CFREEZ*ARG_M PF_1 =AF*EXP(-BF*DEL_T) PF =ARG_M*PF_1 YKK =EXP(-PF*DT) DF1 =FF1(KR)*(1.-YKK) YK2 =DF1 FF1(KR)=FF1(KR)*YKK IF(KR.LE.KRFREEZ) THEN FF2(KR,ICE_TYPE)=FF2(KR,ICE_TYPE)+YK2 ELSE FF5(KR) =FF5(KR)+YK2 ENDIF SUM_ICE=SUM_ICE+YK2*3.*XL(KR)*XL(KR)*COL ENDDO ARG_1 =333.*SUM_ICE/RO TT_DROP_AFTER_FREEZ=TTIN+ARG_1 TIN =TT_DROP_AFTER_FREEZ ENDIF RETURN END SUBROUTINE FREEZ SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH & ,TIN,DT,RO,COL,ICEMAX,NKR) IMPLICIT NONE integer,intent(in) :: NKR,ICEMAX real(kind=R4size),intent(in) :: DT,COL,RO real(kind=R4size),intent(inout) :: FF1(:),XL(:),FF2(:,:),XI(:,:),FF3(:),XS(:),FF4(:),XG(:), & FF5(:),XH(:),Tin integer :: KR,ICE,ICE_TYPE real(kind=R4size) :: ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DF1,DN,DN0, & A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, & DEL_T,meltrate,gamma gamma=4.4 DEL_T = TIN-273.15 ICE_TYPE = 2 F1_MAX=0. F2_MAX=0. F3_MAX=0. F4_MAX=0. F5_MAX=0. DO KR=1,NKR F1_MAX=AMAX1(F1_MAX,FF1(KR)) F3_MAX=AMAX1(F3_MAX,FF3(KR)) F4_MAX=AMAX1(F4_MAX,FF4(KR)) F5_MAX=AMAX1(F5_MAX,FF5(KR)) DO ICE=1,ICEMAX F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE)) END DO FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX) END DO SUM_ICE=0. IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN DO KR = 1,NKR ARG_M = 0.0 DO ICE = 1,ICEMAX IF (ICE ==1) THEN IF (KR .le. 10) THEN ARG_M = ARG_M+FF2(KR,ICE) FF2(KR,ICE) = 0.0 ELSE IF (KR .gt. 10 .and. KR .lt. 18) THEN meltrate = 0.5/50. ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) ELSE meltrate = 0.683/120. ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) ENDIF ENDIF IF (ICE ==2 .or. ICE ==3) THEN IF (kr .le. 12) THEN ARG_M = ARG_M+FF2(KR,ICE) FF2(KR,ICE)=0. ELSE IF (kr .gt. 12 .and. kr .lt. 20) THEN meltrate = 0.5/50. ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) ELSE meltrate = 0.683/120. ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt) FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt) ENDIF ENDIF END DO IF (kr .le. 14) THEN ARG_M = ARG_M + FF3(KR) FF3(KR) = 0.0 ELSE IF (kr .gt. 14 .and. kr .lt. 22) THEN meltrate = 0.5/50. ARG_M=ARG_M+FF3(KR)*(meltrate*dt) FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt) ELSE meltrate = 0.683/120. ARG_M=ARG_M+FF3(KR)*(meltrate*dt) FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt) ENDIF IF (kr .le. 13) then ARG_M = ARG_M+FF4(KR)+FF5(KR) FF4(KR)=0. FF5(KR)=0. ELSE IF (kr .gt. 13 .and. kr .lt. 23) THEN meltrate = 0.5/50. ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt) FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt) FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt) ELSE meltrate = 0.683/120. ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt) FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt) FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt) ENDIF FF1(KR) = FF1(KR) + ARG_M SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL END DO ARG_1=333.*SUM_ICE/RO TIN = TIN - ARG_1 ENDIF RETURN END SUBROUTINE J_W_MELT SUBROUTINE ONECOND1 & & (TT,QQ,PP,ROR & & ,VR1,PSINGLE & & ,DEL1N,DEL2N,DIV1,DIV2 & & ,FF1,PSI1,R1,RLEC,RO1BL & & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & & ,C1_MEY,C2_MEY & & ,COL,DTCOND,ICEMAX,NKR,ISYM1 & ,ISYM2,ISYM3,ISYM4,ISYM5,Iin,Jin,Kin,W_in,DX_in,Itimestep) IMPLICIT NONE INTEGER NKR,ICEMAX, ISYM1, ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5, Iin, Jin, Kin, & sea_spray_no_temp_change_per_grid, Itimestep REAL COL,VR1(NKR),PSINGLE & & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & & ,DTCOND, W_in,DX_in REAL C1_MEY,C2_MEY INTEGER I_ABERGERON,I_BERGERON, & & KR,ICE,ITIME,KCOND,NR,NRM, & & KLIMIT, & & KM,KLIMITL REAL AL1,AL2,D,GAM,POD, & & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, & & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, & & TPC1, TPC2, TPC3, TPC4, TPC5, & & EPSDEL, EPSDEL2,DT0L, DT0I,& & ROR, & & CWHUCM,B6,B8L,B8I, & & DEL1,DEL2,DEL1S,DEL2S, & & TIMENEW,TIMEREV,SFN11,SFN12, & & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,RW,RI,QW,PW, & & PI,QI,DEL1N0,DEL2N0,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, & & DEL_R1,DT0L0,DT0I0, & & DTNEWL0, & & DTNEWL2 REAL DT_WATER_COND,DT_WATER_EVAP INTEGER K REAL FF1_OLD(NKR),SUPINTW(NKR) DOUBLE PRECISION DSUPINTW(NKR),DD1N,DB11_MY,DAL1,DAL2 DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD & & ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K & & ,R1_K,R2_K,R3_K,R4_K,R5_K & & ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 & & ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB & & ,ES1N,ES2N,EW1N,ARGEXP & & ,TT,QQ,PP & & ,DEL1N,DEL2N,DIV1,DIV2 & & ,OPER2,OPER3,AR1,AR2 DOUBLE PRECISION DELMASSL1 REAL R1(NKR) & & ,RLEC(NKR),RO1BL(NKR) & & ,FI1(NKR),FF1(NKR),PSI1(NKR) & & ,B11_MY(NKR),B12_MY(NKR) REAL DTIMEO(NKR),DTIMEL(NKR) & & ,TIMESTEPD(NKR) REAL :: FL1(NKR), sfndummy(3), R1N(NKR) INTEGER :: IDROP DOUBLE PRECISION :: R1D(NKR),R1ND(NKR) OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1 OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1) DATA AL1 /2500./, AL2 /2834./, D /0.211/ & & ,GAM /1.E-4/, POD /10./ DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY & & /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/ DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN & & /2.53,5.42,3.41E1,6.13/ DATA TPC1, TPC2, TPC3, TPC4, TPC5 & & /-4.0,-8.1,-12.7,-17.8,-22.4/ DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/ DATA DT0L, DT0I /1.E20,1.E20/ DOUBLE PRECISION :: DEL1_d , DEL2_d, RW_d , PW_d, RI_d, PI_d, D1N_d, D2N_d, & VR1_d(NKR) sfndummy = 0.0 B12_MY = 0.0 B11_MY = 0.0 I_ABERGERON=0 I_BERGERON=0 COL3=3.0*COL ITIME=0 KCOND=0 DT_WATER_COND=0.4 DT_WATER_EVAP=0.4 ITIME=0 KCOND=0 DT0LREF=0.2 DTLREF=0.4 NR=NKR NRM=NKR-1 DT=DTCOND DTT=DTCOND XRAD=0. CWHUCM=0. XRAD=0. B6=CWHUCM*GAM-XRAD B8L=1./ROR B8I=1./ROR RORI=1./ROR DO KR=1,NKR FF1_OLD(KR)=FF1(KR) SUPINTW(KR)=0.0 DSUPINTW(KR)=0.0 ENDDO TPN=TT QPN=QQ DO KR=1,NKR FI1(KR)=FF1(KR) END DO TIMENEW=0. ITIME=0 TOLD = TPN QOLD = QPN R1D = R1 R1ND = R1D SFNL = 0.0 SFN11 = 0.0 56 ITIME = ITIME+1 TIMEREV = DT-TIMENEW TIMEREV = DT-TIMENEW DEL1 = DEL1N DEL2 = DEL2N DEL1S = DEL1N DEL2S = DEL2N TPS = TPN QPS = QPN IF(ISYM1 == 1)THEN FL1 = 0.0 VR1_d = VR1 CALL JERRATE_KS & (R1D,TPS,PP,VR1_d,RLEC,RO1BL,B11_MY,1,1,fl1,NKR,ICEMAX) sfndummy(1)=SFN11 CALL JERTIMESC_KS(FI1,R1D,SFNDUMMY,B11_MY,B8L,1,NKR,ICEMAX,COL) SFN11 = sfndummy(1) ENDIF SFN12 = 0.0 SFNL = SFN11 + SFN12 SFNI = 0. B5L=BB1_MY/TPS/TPS B5I=BB2_MY/TPS/TPS B7L=B5L*B6 B7I=B5I*B6 DOPL=1.+DEL1S DOPI=1.+DEL2S RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI QW=B7L*DOPL PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI QI=B7I*DOPI IF(RW.NE.RW .or. PW.NE.PW)THEN print*, 'NaN In ONECOND1' call wrf_error_fatal3("",6892,& "fatal error in ONECOND1 (RW or PW are NaN), model stop") ENDIF KCOND=10 IF(DEL1N >= 0.0D0) KCOND=11 IF(KCOND == 11) THEN DTNEWL = DT DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL IF (DTT < 0.0) call wrf_error_fatal3("",6906,& "fatal error in ONECOND1-DEL1N>0:(DTT<0), model stop") DEL1_d = DEL1 DEL2_d = DEL2 RW_d = RW PW_d = PW RI_d = RI PI_d = PI CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, & RW_d,PW_d,RI_d,PI_d, & DTT,D1N_d,D2N_d,0.0,0.0, & ISYM1,ISYM2,ISYM3,ISYM4,ISYM5) DEL1 = DEL1_d DEL2 = DEL2_d RW = RW_d PW = PW_d RI = RI_d PI = PI_d D1N = D1N_d D2N = D2N_d IF(ISYM1 == 1)THEN IDROP = ISYM1 CALL JERDFUN_KS(R1D, R1ND, B11_MY, FI1, PSI1, fl1, D1N, & ISYM1, 1, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 1, Iin, Jin ,Kin, Itimestep) ENDIF IF((DEL1.GT.0.AND.DEL1N.LT.0) & &.AND.ABS(DEL1N).GT.EPSDEL) THEN call wrf_error_fatal3("",6937,& "fatal error in ONECOND1-1 (DEL1.GT.0.AND.DEL1N.LT.0), model stop") ENDIF ELSE DTIMEO = DT DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL IF (DTT < 0.0) call wrf_error_fatal3("",6952,& "fatal error in ONECOND1-DEL1N<0:(DTT<0), model stop") DEL1_d = DEL1 DEL2_d = DEL2 RW_d = RW PW_d = PW RI_d = RI PI_d = PI CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, & RW_d,PW_d,RI_d,PI_d, & DTT,D1N_d,D2N_d,0.0,0.0, & ISYM1,ISYM2,ISYM3,ISYM4,ISYM5) DEL1 = DEL1_d DEL2 = DEL2_d RW = RW_d PW = PW_d RI = RI_d PI = PI_d D1N = D1N_d D2N = D2N_d IF(ISYM1 == 1)THEN IDROP = ISYM1 CALL JERDFUN_KS(R1D, R1ND, B11_MY, & FI1, PSI1, fl1, D1N, & ISYM1, 1, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 1, Iin, Jin ,Kin, Itimestep) ENDIF IF((DEL1.LT.0.AND.DEL1N.GT.0) & .AND.ABS(DEL1N).GT.EPSDEL) THEN call wrf_error_fatal3("",6983,& "fatal error in ONECOND1-2 (DEL1.LT.0.AND.DEL1N.GT.0), model stop") ENDIF ENDIF RMASSLBB=0. RMASSLAA=0. DO K=1,NKR FI1_K = FI1(K) R1_K = R1(K) FI1R1 = FI1_K*R1_K*R1_K RMASSLBB = RMASSLBB+FI1R1 ENDDO RMASSLBB = RMASSLBB*COL3*RORI IF(RMASSLBB.LE.0.) RMASSLBB=0. DO K=1,NKR FI1_K=PSI1(K) R1_K=R1(K) FI1R1=FI1_K*R1_K*R1_K RMASSLAA=RMASSLAA+FI1R1 END DO RMASSLAA=RMASSLAA*COL3*RORI IF(RMASSLAA.LE.0.) RMASSLAA=0. DELMASSL1 = RMASSLAA - RMASSLBB QPN = QPS - DELMASSL1 DAL1 = AL1 TPN = TPS + DAL1*DELMASSL1 IF(ABS(DAL1*DELMASSL1) > 3.0 )THEN print*,"ONECOND1-in(start)" print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in print*,"DELMASSL1",DELMASSL1,"DT",DTT print*,"DEL1N,DEL2N,DEL1,DEL2,D1N,D2N,RW,PW,RI,PI,DT" print*,DEL1N,DEL2N,DEL1,DEL2,D1N,D2N,RW,PW,RI,PI,DTT print*,"TPS",TPS,"QPS",QPS print*,'FI1 before',FI1,'PSI1 after',PSI1 print*,"ONECOND1-in(end)" call wrf_error_fatal3("",7026,& "fatal error in ONECOND1-in (ABS(DAL1*DELMASSL1) > 3.0), model stop") ENDIF IF(ISYM1 == 1) THEN DO KR=1,NKR SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N DD1N=D1N DB11_MY=B11_MY(KR) DSUPINTW(KR)=DSUPINTW(KR)+DB11_MY*DD1N ENDDO ENDIF IF(TIMENEW.LT.DT) GOTO 56 57 CONTINUE IF(ISYM1 == 1) THEN CALL JERDFUN_NEW_KS (R1D,R1ND,SUPINTW, & FF1_OLD,PSI1, & TPN,IDROP,FR_LIM, NKR, COL,1,Iin,Jin,Kin,Itimestep) ENDIF RMASSLAA=0.0 RMASSLBB=0.0 DO K=1,NKR FI1_K=FF1_OLD(K) R1_K=R1(K) FI1R1=FI1_K*R1_K*R1_K RMASSLBB=RMASSLBB+FI1R1 ENDDO RMASSLBB=RMASSLBB*COL3*RORI IF(RMASSLBB.LT.0.0) RMASSLBB=0.0 DO K=1,NKR FI1_K=PSI1(K) R1_K=R1(K) FI1R1=FI1_K*R1_K*R1_K RMASSLAA=RMASSLAA+FI1R1 ENDDO RMASSLAA=RMASSLAA*COL3*RORI IF(RMASSLAA.LT.0.0) RMASSLAA=0.0 DELMASSL1 = RMASSLAA-RMASSLBB QPN = QOLD - DELMASSL1 DAL1 = AL1 TPN = TOLD + DAL1*DELMASSL1 IF(ABS(DAL1*DELMASSL1) > 5.0 )THEN print*,"ONECOND1-out (start)" print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in print*,"DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DT" print*,DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DTT print*,"I=",Iin,"J=",Jin,"Kin",Kin print*,"TPS=",TPS,"QPS=",QPS,"delmassl1",delmassl1 print*,"DAL1=",DAL1 print*,RMASSLBB,RMASSLAA print*,"FI1",FI1 print*,"PSI1",PSI1 print*,"ONECOND1-out (end)" IF(ABS(DAL1*DELMASSL1) > 5.0 )THEN call wrf_error_fatal3("",7089,& "fatal error in ONECOND1-out (ABS(DAL1*DELMASSL1) > 5.0), model stop") ENDIF ENDIF TT=TPN QQ=QPN DO KR=1,NKR FF1(KR)=PSI1(KR) ENDDO RETURN END SUBROUTINE ONECOND1 SUBROUTINE ONECOND2 & & (TT,QQ,PP,ROR & & ,VR2,VR3,VR4,VR5,PSINGLE & & ,DEL1N,DEL2N,DIV1,DIV2 & & ,FF2,PSI2,R2,RIEC,RO2BL & & ,FF3,PSI3,R3,RSEC,RO3BL & & ,FF4,PSI4,R4,RGEC,RO4BL & & ,FF5,PSI5,R5,RHEC,RO5BL & & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & & ,C1_MEY,C2_MEY & & ,COL,DTCOND,ICEMAX,NKR & & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5, & Iin,Jin,Kin,W_in,DX_in,Itimestep) IMPLICIT NONE INTEGER NKR,ICEMAX,ISYM1, Iin, Jin, Kin, Itimestep REAL COL,VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) & & ,VR5(NKR),PSINGLE & & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & & ,DTCOND,W_in,DX_in REAL C1_MEY,C2_MEY INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON, & & KR,ICE,ITIME,ICM,KCOND,NR,NRM,INUC, & & ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5,KP,KLIMIT, & & KM,ITER,KLIMITL,KLIMITG,KLIMITH,KLIMITI_1,KLIMITI_2,KLIMITI_3, & & NCRITI REAL AL1,AL2,D,GAM,POD, & & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, & & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, & & TPC1, TPC2, TPC3, TPC4, TPC5, & & EPSDEL, DT0L, DT0I, & & ROR, & & DEL1NUC,DEL2NUC, & & CWHUCM,B6,B8L,B8I,RMASSGL,RMASSGI, & & DEL1,DEL2,DEL1S,DEL2S, & & TIMENEW,TIMEREV,SFN11,SFN12, & & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,OPERQ,RW,RI,QW,PW, & & PI,QI,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, & & DEL_R1,DT0L0,DT0I0,SFN31,SFN32,SFN52, & & SFNII1,SFN21,SFN22,DTNEWI3,DTNEWI4,DTNEWI5,DTNEWI2_1, & & DTNEWI2_2,DTNEWI1,DEL_R2,DEL_R4,DEL_R5,SFN41,SFN42, & & SNF51,DTNEWI2_3,DTNEWI2,DTNEWI_1,DTNEWI_2, & & DTNEWL0,DTNEWG1,DTNEWH1,DTNEWI_3, & & DTNEWL2,SFN51,SFNII2,DEL_R3,DTNEWI REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, & & DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON INTEGER K DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2 DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD & & ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K & & ,R1_K,R2_K,R3_K,R4_K,R5_K & & ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 & & ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB & & ,ES1N,ES2N,EW1N,ARGEXP & & ,TT,QQ,PP & & ,DEL1N,DEL2N,DIV1,DIV2 & & ,OPER2,OPER3,AR1,AR2 DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1 CHARACTER*70 CPRINT REAL R2(NKR,ICEMAX) & & ,RIEC(NKR,ICEMAX) & & ,RO2BL(NKR,ICEMAX) & & ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) & & ,FF2(NKR,ICEMAX) & & ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) REAL R3(NKR) & & ,RSEC(NKR),RO3BL(NKR) & & ,FI3(NKR),FF3(NKR),PSI3(NKR) & & ,B31_MY(NKR),B32_MY(NKR) REAL R4(NKR) & & ,RGEC(NKR),RO4BL(NKR) & & ,FI4(NKR),FF4(NKR),PSI4(NKR) & & ,B41_MY(NKR),B42_MY(NKR) REAL R5(NKR) & & ,RHEC(NKR),RO5BL(NKR) & & ,FI5(NKR),FF5(NKR),PSI5(NKR) & & ,B51_MY(NKR),B52_MY(NKR) REAL DTIMEG(NKR),DTIMEH(NKR) REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) & & ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) & & ,SFNI1(ICEMAX),SFNI2(ICEMAX) & & ,TIMESTEPD(NKR) & & ,FI1REF(NKR),PSI1REF(NKR) & & ,FI2REF(NKR,ICEMAX),PSI2REF(NKR,ICEMAX)& & ,FCCNRREF(NKR) REAL :: FL1(NKR), sfndummy(3), FL3(NKR), FL4(NKR), FL5(NKR), & R2N(NKR,ICEMAX), R3N(NKR), R4N(NKR), R5N(NKR) INTEGER :: IDROP, ISYMICE DOUBLE PRECISION :: R2D(NKR,ICEMAX),R3D(NKR), R4D(NKR), R5D(NKR), & R2ND(NKR,ICEMAX),R3ND(NKR), R4ND(NKR), R5ND(NKR), & VR2_d(NKR,ICEMAX), VR3_d(NKR), VR4_d(NKR), VR5_d(NKR) OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1 OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1) DATA AL1 /2500./, AL2 /2834./, D /0.211/ & & ,GAM /1.E-4/, POD /10./ DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY & & /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/ DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN & & /2.53,5.42,3.41E1,6.13/ DATA TPC1, TPC2, TPC3, TPC4, TPC5 & & /-4.0,-8.1,-12.7,-17.8,-22.4/ DATA EPSDEL/0.1E-03/ DATA DT0L, DT0I /1.E20,1.E20/ DOUBLE PRECISION :: DEL1_d, DEL2_d, RW_d, PW_d, RI_d, PI_d, D1N_d, D2N_d B22_MY = 0.0 B32_MY = 0.0 B42_MY = 0.0 B52_MY = 0.0 B21_MY = 0.0 B31_MY = 0.0 B41_MY = 0.0 B51_MY = 0.0 SFNDUMMY = 0.0 R2D = R2 R3D = R3 R4D = R4 R5D = R5 R2ND = R2D R3ND = R3D R4ND = R4D R5ND = R5D SFNI1 = 0.0 SFN31 = 0.0 SFN41 = 0.0 SFN51 = 0.0 I_MIXCOND=0 I_MIXEVAP=0 I_ABERGERON=0 I_BERGERON=0 COL3=3.0*COL ICM=ICEMAX ITIME=0 KCOND=0 DT_WATER_COND=0.4 DT_WATER_EVAP=0.4 DT_ICE_COND=0.4 DT_ICE_EVAP=0.4 DT_MIX_COND=0.4 DT_MIX_EVAP=0.4 DT_MIX_BERGERON=0.4 DT_MIX_ANTIBERGERON=0.4 ICM=ICEMAX ITIME=0 KCOND=0 DT0LREF=0.2 DTLREF=0.4 NR=NKR NRM=NKR-1 DT=DTCOND DTT=DTCOND XRAD=0. CWHUCM=0. XRAD=0. B6=CWHUCM*GAM-XRAD B8L=1./ROR B8I=1./ROR RORI=1./ROR TPN=TT QPN=QQ DO ICE=1,ICEMAX SFNI1(ICE)=0. SFNI2(ICE)=0. DEL2D(ICE)=0. ENDDO TIMENEW = 0. ITIME = 0 46 ITIME = ITIME + 1 TIMEREV=DT-TIMENEW DEL1=DEL1N DEL2=DEL2N DEL1S=DEL1N DEL2S=DEL2N DEL2D(1)=DEL2N DEL2D(2)=DEL2N DEL2D(3)=DEL2N TPS=TPN QPS=QPN DO KR=1,NKR FI3(KR)=PSI3(KR) FI4(KR)=PSI4(KR) FI5(KR)=PSI5(KR) DO ICE=1,ICEMAX FI2(KR,ICE)=PSI2(KR,ICE) ENDDO ENDDO IF(sum(ISYM2) > 0) THEN FL1 = 0.0 VR2_d = VR2 CALL JERRATE_KS (R2D,TPS,PP,VR2_d,RIEC,RO2BL,B21_MY,3,2,fl1,NKR,ICEMAX) CALL JERTIMESC_KS (FI2,R2D,SFNI1,B21_MY,B8I,ICM,NKR,ICEMAX,COL) ENDIF IF(ISYM3 == 1) THEN FL3 = 0.0 VR3_d = VR3 CALL JERRATE_KS (R3D,TPS,PP,VR3_d,RSEC,RO3BL,B31_MY,1,3,fl3,NKR,ICEMAX) sfndummy(1) = SFN31 CALL JERTIMESC_KS(FI3,R3D,SFNDUMMY,B31_MY,B8I,1,NKR,ICEMAX,COL) SFN31 = sfndummy(1) ENDIF IF(ISYM4 == 1) THEN FL4 = 0.0 VR4_d = VR4 CALL JERRATE_KS(R4D,TPS,PP,VR4_d,RGEC,RO4BL,B41_MY,1,2,fl4,NKR,ICEMAX) sfndummy(1) = SFN41 CALL JERTIMESC_KS(FI4,R4D,SFNDUMMY,B41_MY,B8I,1,NKR,ICEMAX,COL) SFN41 = sfndummy(1) ENDIF IF(ISYM5 == 1) THEN FL5 = 0.0 VR5_d = VR5 CALL JERRATE_KS(R5D,TPS,PP,VR5_d,RHEC,RO5BL,B51_MY,1,2,fl5,NKR,ICEMAX) sfndummy(1) = SFN51 CALL JERTIMESC_KS(FI5,R5D,SFNDUMMY,B51_MY,B8I,1,NKR,ICEMAX,COL) SFN51 = sfndummy(1) ENDIF SFNII1 = SFNI1(1) + SFNI1(2) + SFNI1(3) SFN21 = SFNII1 + SFN31 + SFN41 + SFN51 SFNL = 0.0 SFN22 = 0.0 SFNI = SFN21 + SFN22 B5L=BB1_MY/TPS/TPS B5I=BB2_MY/TPS/TPS B7L=B5L*B6 B7I=B5I*B6 DOPL=1.+DEL1S DOPI=1.+DEL2S OPERQ=OPER2(QPS) RW=(OPERQ+B5L*AL1)*DOPL*SFNL QW=B7L*DOPL PW=(OPERQ+B5I*AL1)*DOPI*SFNL RI=(OPERQ+B5L*AL2)*DOPL*SFNI PI=(OPERQ+B5I*AL2)*DOPI*SFNI QI=B7I*DOPI KCOND=20 IF(DEL2N > 0.0) KCOND=21 IF(RW.NE.RW .or. PW.NE.PW)THEN print*, 'NaN In ONECOND2' call wrf_error_fatal3("",7399,& "fatal error in ONECOND2 (RW or PW are NaN), model stop") ENDIF IF(KCOND == 21) THEN DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL IF (DTT < 0.0) call wrf_error_fatal3("",7411,& "fatal error in ONECOND2-DEL2N>0:(DTT<0), model stop") DEL1_d = DEL1 DEL2_d = DEL2 RW_d = RW PW_d = PW RI_d = RI PI_d = PI CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, & RW_d,PW_d,RI_d,PI_d, & DTT,D1N_d,D2N_d,0.0,0.0, & ISYM1,ISYM2,ISYM3,ISYM4,ISYM5) DEL1 = DEL1_d DEL2 = DEL2_d RW = RW_d PW = PW_d RI = RI_d PI = PI_d D1N = D1N_d D2N = D2N_d IF(sum(ISYM2) > 0)THEN IDROP = 0 FL1 = 0.0 IF(ISYM2(1) == 1) THEN CALL JERDFUN_KS(R2D(:,1), R2ND(:,1), B21_MY(:,1), & FI2(:,1), PSI2(:,1), fl1, D2N, & ISYM2(1), ICM, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 21, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM2(2) == 1) THEN CALL JERDFUN_KS(R2D(:,2), R2ND(:,2), B21_MY(:,2), & FI2(:,2), PSI2(:,2), fl1, D2N, & ISYM2(2), ICM, 2, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 22, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM2(3) == 1) THEN CALL JERDFUN_KS(R2D(:,3), R2ND(:,3), B21_MY(:,3), & FI2(:,3), PSI2(:,3), fl1, D2N, & ISYM2(3), ICM, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 23, Iin, Jin ,Kin, Itimestep) ENDIF ENDIF IF(ISYM3 == 1) THEN IDROP = 0 FL3 = 0.0 CALL JERDFUN_KS(R3D, R3ND, B31_MY, & FI3, PSI3, fl3, D2N, & ISYM3, 1, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 3, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM4 == 1) THEN IDROP = 0 FL4 = 0.0 CALL JERDFUN_KS(R4D, R4ND, B41_MY, & FI4, PSI4, fl4, D2N, & ISYM4, 1, 4, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 4, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM5 == 1) THEN IDROP = 0 FL5 = 0.0 CALL JERDFUN_KS(R5D, R5ND, B51_MY, & FI5, PSI5, fl5, D2N, & ISYM5, 1, 5, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 5, Iin, Jin ,Kin, Itimestep) ENDIF IF((DEL2.GT.0.AND.DEL2N.LT.0) & .AND.ABS(DEL2N).GT.EPSDEL) THEN call wrf_error_fatal3("",7484,& "fatal error in module_mp_fast_sbm (DEL2.GT.0.AND.DEL2N.LT.0), model stop") ENDIF ELSE DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL IF (DTT < 0.0) call wrf_error_fatal3("",7496,& "fatal error in ONECOND2-DEL2N<0:(DTT<0), model stop") DEL1_d = DEL1 DEL2_d = DEL2 RW_d = RW PW_d = PW RI_d = RI PI_d = PI CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, & RW_d,PW_d,RI_d,PI_d, & DTT,D1N_d,D2N_d,0.0,0.0, & ISYM1,ISYM2,ISYM3,ISYM4,ISYM5) DEL1 = DEL1_d DEL2 = DEL2_d RW = RW_d PW = PW_d RI = RI_d PI = PI_d D1N = D1N_d D2N = D2N_d IF(sum(ISYM2) > 0) THEN IDROP = 0 FL1 = 0.0 IF(ISYM2(1)==1)THEN CALL JERDFUN_KS(R2D(:,1), R2ND(:,1), B21_MY(:,1), & FI2(:,1), PSI2(:,1), fl1, D2N, & ISYM2(1), ICM, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 21, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM2(2)==1)THEN CALL JERDFUN_KS(R2D(:,2), R2ND(:,2), B21_MY(:,2), & FI2(:,2), PSI2(:,2), fl1, D2N, & ISYM2(2), ICM, 2, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 22, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM2(3)==1)THEN CALL JERDFUN_KS(R2D(:,3), R2ND(:,3), B21_MY(:,3), & FI2(:,3), PSI2(:,3), fl1, D2N, & ISYM2(3), ICM, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 23, Iin, Jin ,Kin, Itimestep) ENDIF ENDIF IF(ISYM3 == 1) THEN IDROP = 0 FL3 = 0.0 CALL JERDFUN_KS(R3D, R3ND, B31_MY, & FI3, PSI3, fl3, D2N, & ISYM3, 1, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 3, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM4 == 1) THEN IDROP = 0 FL4 = 0.0 CALL JERDFUN_KS(R4D, R4ND, B41_MY, & FI4, PSI4, fl4, D2N, & ISYM4, 1, 4, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 4, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM5 == 1) THEN IDROP = 0 FL5 = 0.0 CALL JERDFUN_KS(R5D, R5ND, B51_MY, & FI5, PSI5, fl5, D2N, & ISYM5, 1, 5, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 5, Iin, Jin ,Kin, Itimestep) ENDIF IF((DEL2.LT.0.AND.DEL2N.GT.0) & .AND.ABS(DEL2N).GT.EPSDEL) THEN call wrf_error_fatal3("",7572,& "fatal error in module_mp_fast_sbm (DEL2.LT.0.AND.DEL2N.GT.0), model stop") ENDIF ENDIF RMASSIBB=0.0 RMASSIAA=0.0 DO K=1,NKR DO ICE = 1,ICEMAX FI2_K = FI2(K,ICE) R2_K = R2(K,ICE) FI2R2 = FI2_K*R2_K*R2_K RMASSIBB = RMASSIBB + FI2R2 ENDDO FI3_K=FI3(K) FI4_K=FI4(K) FI5_K=FI5(K) R3_K=R3(K) R4_K=R4(K) R5_K=R5(K) FI3R3=FI3_K*R3_K*R3_K FI4R4=FI4_K*R4_K*R4_K FI5R5=FI5_K*R5_K*R5_K RMASSIBB=RMASSIBB+FI3R3 RMASSIBB=RMASSIBB+FI4R4 RMASSIBB=RMASSIBB+FI5R5 ENDDO RMASSIBB=RMASSIBB*COL3*RORI IF(RMASSIBB.LT.0.0) RMASSIBB=0.0 DO K=1,NKR DO ICE =1,ICEMAX FI2_K=PSI2(K,ICE) R2_K=R2(K,ICE) FI2R2=FI2_K*R2_K*R2_K RMASSIAA=RMASSIAA+FI2R2 ENDDO FI3_K = PSI3(K) FI4_K = PSI4(K) FI5_K = PSI5(K) R3_K=R3(K) R4_K=R4(K) R5_K=R5(K) FI3R3=FI3_K*R3_K*R3_K FI4R4=FI4_K*R4_K*R4_K FI5R5=FI5_K*R5_K*R5_K RMASSIAA=RMASSIAA+FI3R3 RMASSIAA=RMASSIAA+FI4R4 RMASSIAA=RMASSIAA+FI5R5 ENDDO RMASSIAA = RMASSIAA*COL3*RORI IF(RMASSIAA.LT.0.0) RMASSIAA=0.0 DELMASSI1 = RMASSIAA-RMASSIBB QPN = QPS-DELMASSI1 DAL2 = AL2 TPN = TPS+DAL2*DELMASSI1 IF(ABS(DAL2*DELMASSI1) > 5.0 )THEN print*,"ONECOND2-out (start)" print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in print*,"DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DT" print*,DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DTT print*,"TPS=",TPS,"QPS=",QPS,"delmassi1",delmassi1 print*,"DAL1=",DAL2 print*,RMASSIBB,RMASSIAA print*,"FI2_1",FI2(:,1) print*,"FI2_2",FI2(:,2) print*,"FI2_3",FI2(:,3) print*,"FI3",FI3 print*,"FI4",FI4 print*,"FI5",FI5 print*,"PSI2_1",PSI2(:,1) print*,"PSI2_2",PSI2(:,2) print*,"PSI2_3",PSI2(:,3) print*,"PSI3",PSI3 print*,"PSI4",PSI4 print*,"PSI5",PSI5 print*,"ONECOND2-out (end)" IF(ABS(DAL2*DELMASSI1) > 5.0 )THEN call wrf_error_fatal3("",7657,& "fatal error in ONECOND2-out (ABS(DAL2*DELMASSI1) > 5.0), model stop") ENDIF ENDIF IF(TIMENEW.LT.DT) GOTO 46 TT=TPN QQ=QPN DO KR=1,NKR DO ICE=1,ICEMAX FF2(KR,ICE)=PSI2(KR,ICE) ENDDO FF3(KR)=PSI3(KR) FF4(KR)=PSI4(KR) FF5(KR)=PSI5(KR) ENDDO RETURN END SUBROUTINE ONECOND2 SUBROUTINE ONECOND3 & & (TT,QQ,PP,ROR & & ,VR1,VR2,VR3,VR4,VR5,PSINGLE & & ,DEL1N,DEL2N,DIV1,DIV2 & & ,FF1,PSI1,R1,RLEC,RO1BL & & ,FF2,PSI2,R2,RIEC,RO2BL & & ,FF3,PSI3,R3,RSEC,RO3BL & & ,FF4,PSI4,R4,RGEC,RO4BL & & ,FF5,PSI5,R5,RHEC,RO5BL & & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & & ,C1_MEY,C2_MEY & & ,COL,DTCOND,ICEMAX,NKR & & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5, & Iin,Jin,Kin,W_in,DX_in, Itimestep) IMPLICIT NONE INTEGER ICEMAX,NKR,KR,ITIME,ICE,KCOND,K & & ,ISYM1,ISYM2(ICEMAX),ISYM3,ISYM4,ISYM5, Kin, Iin, Jin, Itimestep INTEGER KLIMITL,KLIMITG,KLIMITH,KLIMITI_1, & & KLIMITI_2,KLIMITI_3 INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON REAL ROR,VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) & & ,VR5(NKR),PSINGLE & & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY & & ,C1_MEY,C2_MEY & & ,COL,DTCOND,W_in,DX_in REAL R1(NKR)& & ,RLEC(NKR),RO1BL(NKR) & & ,FI1(NKR),FF1(NKR),PSI1(NKR) & & ,B11_MY(NKR),B12_MY(NKR) REAL R2(NKR,ICEMAX) & & ,RIEC(NKR,ICEMAX) & & ,RO2BL(NKR,ICEMAX) & & ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) & & ,FF2(NKR,ICEMAX) & & ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) & & ,RATE2(NKR,ICEMAX),DEL_R2M(NKR,ICEMAX) REAL R3(NKR) & & ,RSEC(NKR),RO3BL(NKR) & & ,FI3(NKR),FF3(NKR),PSI3(NKR) & & ,B31_MY(NKR),B32_MY(NKR) & & ,DEL_R3M(NKR) REAL R4(NKR) & & ,RGEC(NKR),RO4BL(NKR) & & ,FI4(NKR),FF4(NKR),PSI4(NKR) & & ,B41_MY(NKR),B42_MY(NKR) & & ,DEL_R4M(NKR) REAL R5(NKR) & & ,RHEC(NKR),RO5BL(NKR) & & ,FI5(NKR),FF5(NKR),PSI5(NKR) & & ,B51_MY(NKR),B52_MY(NKR) & & ,DEL_R5M(NKR) DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2 DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD & & ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K & & ,R1_K,R2_K,R3_K,R4_K,R5_K & & ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 & & ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB & & ,ES1N,ES2N,EW1N,ARGEXP & & ,TT,QQ,PP,DEL1N0,DEL2N0 & & ,DEL1N,DEL2N,DIV1,DIV2 & & ,OPER2,OPER3,AR1,AR2 DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1 REAL A1_MYN, BB1_MYN, A2_MYN, BB2_MYN DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN & & /2.53,5.42,3.41E1,6.13/ REAL B8L,B8I,SFN11,SFN12,SFNL,SFNI REAL B5L,B5I,B7L,B7I,B6,DOPL,DEL1S,DEL2S,DOPI,RW,QW,PW, & & RI,PI,QI,SFNI1(ICEMAX),SFNI2(ICEMAX),AL1,AL2 REAL D1N,D2N,DT0L, DT0I,D1N0,D2N0 REAL SFN21,SFN22,SFNII1,SFNII2,SFN31,SFN32,SFN41,SFN42,SFN51, & & SFN52 REAL DEL1,DEL2 REAL TIMEREV,DT,DTT,TIMENEW REAL DTIMEG(NKR),DTIMEH(NKR),totccn_before,totccn_after REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) & & ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, & & DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON REAL DTNEWL0,DTNEWL1,DTNEWI1,DTNEWI2_1,DTNEWI2_2,DTNEWI2_3, & & DTNEWI2,DTNEWI_1,DTNEWI_2,DTNEWI3,DTNEWI4,DTNEWI5, & & DTNEWL,DTNEWL2,DTNEWG1,DTNEWH1 REAL TIMESTEPD(NKR) DATA AL1 /2500./, AL2 /2834./ REAL EPSDEL,EPSDEL2 DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/ REAL :: FL1(NKR), FL2(NKR,ICEMAX), FL3(NKR), FL4(NKR), FL5(NKR), SFNDUMMY(3), & R1N(NKR), R2N(NKR,ICEMAX), R3N(NKR), R4N(NKR), R5N(NKR) INTEGER :: IDROP, ICM, ISYMICE DOUBLE PRECISION :: R1D(NKR),R2D(NKR,ICEMAX),R3D(NKR), R4D(NKR), R5D(NKR), & R1ND(NKR),R2ND(NKR,ICEMAX),R3ND(NKR), R4ND(NKR), R5ND(NKR) DATA DT0L, DT0I /1.E20,1.E20/ DOUBLE PRECISION :: DEL1_d, DEL2_d , RW_d, PW_d , RI_d , PI_d , D1N_d, D2N_d, & VR1_d(NKR), VR2_d(NKR,ICEMAX), VR3_d(NKR), VR4_d(NKR), VR5_d(NKR), & TTinput,QQinput,DEL1Ninput,DEL2Ninput OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1 OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1) TTinput = TT QQinput = QQ DEL1Ninput = DEL1N DEL2Ninput = DEL2N B12_MY = 0.0 B22_MY = 0.0 B32_MY = 0.0 B42_MY = 0.0 B52_MY = 0.0 B21_MY = 0.0 B31_MY = 0.0 B41_MY = 0.0 B51_MY = 0.0 ICM = ICEMAX R1D = R1 R2D = R2 R3D = R3 R4D = R4 R5D = R5 R1ND = R1D R2ND = R2D R3ND = R3D R4ND = R4D R5ND = R5D VR1_d = VR1 VR2_d = VR2 VR3_d = VR3 VR4_d = VR4 VR5_d = VR5 SFN11 = 0.0 SFNI1 = 0.0 SFN31 = 0.0 SFN41 = 0.0 SFN51 = 0.0 DT_WATER_COND=0.4 DT_WATER_EVAP=0.4 DT_ICE_COND=0.4 DT_ICE_EVAP=0.4 DT_MIX_COND=0.4 DT_MIX_EVAP=0.4 DT_MIX_BERGERON=0.4 DT_MIX_ANTIBERGERON=0.4 I_MIXCOND=0 I_MIXEVAP=0 I_ABERGERON=0 I_BERGERON=0 ITIME = 0 TIMENEW = 0.0 DT = DTCOND DTT = DTCOND B6=0. B8L=1./ROR B8I=1./ROR RORI=1.D0/ROR COL3=3.D0*COL TPN=TT QPN=QQ 16 ITIME = ITIME + 1 IF((TPN-273.15).GE.-0.187) GO TO 17 TIMEREV = DT - TIMENEW DEL1 = DEL1N DEL2 = DEL2N DEL1S = DEL1N DEL2S = DEL2N DEL2D(1) = DEL2N DEL2D(2) = DEL2N DEL2D(3) = DEL2N TPS = TPN QPS = QPN DO KR = 1,NKR FI1(KR) = PSI1(KR) FI3(KR) = PSI3(KR) FI4(KR) = PSI4(KR) FI5(KR) = PSI5(KR) DO ICE = 1,ICEMAX FI2(KR,ICE) = PSI2(KR,ICE) ENDDO ENDDO IF(ISYM1 == 1)THEN FL1 = 0.0 CALL JERRATE_KS & (R1D,TPS,PP,VR1_d,RLEC,RO1BL,B11_MY,1,1,fl1,NKR,ICEMAX) sfndummy(1) = SFN11 CALL JERTIMESC_KS(FI1,R1D,SFNDUMMY,B11_MY,B8L,1,NKR,ICEMAX,COL) SFN11 = sfndummy(1) ENDIF IF(sum(ISYM2) > 0) THEN FL1 = 0.0 CALL JERRATE_KS (R2D,TPS,PP,VR2_d,RIEC,RO2BL,B21_MY,3,2,fl1,NKR,ICEMAX) CALL JERTIMESC_KS (FI2,R2D,SFNI1,B21_MY,B8I,ICM,NKR,ICEMAX,COL) ENDIF IF(ISYM3 == 1) THEN FL3 = 0.0 CALL JERRATE_KS (R3D,TPS,PP,VR3_d,RSEC,RO3BL,B31_MY,1,3,fl3,NKR,ICEMAX) sfndummy(1) = SFN31 CALL JERTIMESC_KS(FI3,R3D,SFNDUMMY,B31_MY,B8I,1,NKR,ICEMAX,COL) SFN31 = sfndummy(1) ENDIF IF(ISYM4 == 1) THEN FL4 = 0.0 CALL JERRATE_KS(R4D,TPS,PP,VR4_d,RGEC,RO4BL,B41_MY,1,2,fl4,NKR,ICEMAX) sfndummy(1) = SFN41 CALL JERTIMESC_KS(FI4,R4D,SFNDUMMY,B41_MY,B8I,1,NKR,ICEMAX,COL) SFN41 = sfndummy(1) ENDIF IF(ISYM5 == 1) THEN FL5 = 0.0 CALL JERRATE_KS(R5D,TPS,PP,VR5_d,RHEC,RO5BL,B51_MY,1,2,fl5,NKR,ICEMAX) sfndummy(1) = SFN51 CALL JERTIMESC_KS(FI5,R5D,SFNDUMMY,B51_MY,B8I,1,NKR,ICEMAX,COL) SFN51 = sfndummy(1) ENDIF SFNII1 = SFNI1(1) + SFNI1(2) + SFNI1(3) SFN21 = SFNII1 + SFN31 + SFN41 + SFN51 SFN12 = 0.0 SFNL = SFN11 + SFN12 SFN22 = 0.0 SFNI = SFN21 + SFN22 B5L=BB1_MY/TPS/TPS B5I=BB2_MY/TPS/TPS B7L=B5L*B6 B7I=B5I*B6 DOPL=1.+DEL1S DOPI=1.+DEL2S RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL QW=B7L*DOPL PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI QI=B7I*DOPI IF(RW.NE.RW .or. PW.NE.PW)THEN print*, 'NaN In ONECOND3' call wrf_error_fatal3("",7957,& "fatal error in ONECOND3 (RW or PW are NaN), model stop") ENDIF KCOND=50 IF(DEL1N .LT. 0.0 .AND. DEL2N .LT. 0.0) KCOND=30 IF(DEL1N .GT. 0.0 .AND. DEL2N .GT. 0.0) KCOND=31 IF(DEL1N .LT. 0.0 .AND. DEL2N .GT. 0.0) KCOND=32 IF(KCOND == 50) THEN DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL PRINT*, "Anti-Bregeron Regime, No DIFFU" PRINT*, DEL1, DEL2, TT, QQ, Kin GO TO 17 ENDIF IF(KCOND == 31) THEN DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL ENDIF IF(KCOND == 30) THEN DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL ENDIF IF(KCOND == 32) THEN DTNEWL = DT DTNEWL = AMIN1(DTNEWL,TIMEREV) TIMENEW = TIMENEW + DTNEWL DTT = DTNEWL ENDIF IF (DTT < 0.0) call wrf_error_fatal3("",8014,& "fatal error in ONECOND3:(DTT<0), model stop") DEL1_d = DEL1 DEL2_d = DEL2 RW_d = RW PW_d = PW RI_d = RI PI_d = PI CALL JERSUPSAT_KS(DEL1_d,DEL2_d,DEL1N,DEL2N, & RW_d,PW_d,RI_d,PI_d, & DTT,D1N_d,D2N_d,0.0,0.0, & ISYM1,ISYM2,ISYM3,ISYM4,ISYM5) DEL1 = DEL1_d DEL2 = DEL2_d RW = RW_d PW = PW_d RI = RI_d PI = PI_d D1N = D1N_d D2N = D2N_d IF(ISYM1 == 1) THEN IDROP = ISYM1 FL1 = 0.0 CALL JERDFUN_KS(R1D, R1ND, B11_MY, & FI1, PSI1, fl1, D1N, & ISYM1, 1, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 1, Iin, Jin ,Kin, Itimestep) ENDIF IF(sum(ISYM2) > 0) THEN IDROP = 0 FL1 = 0.0 IF(ISYM2(1)==1)THEN CALL JERDFUN_KS(R2D(:,1), R2ND(:,1), B21_MY(:,1), & FI2(:,1), PSI2(:,1), fl1, D2N, & ISYM2(1), ICM, 1, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 21, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM2(2)==1)THEN CALL JERDFUN_KS(R2D(:,2), R2ND(:,2), B21_MY(:,2), & FI2(:,2), PSI2(:,2), fl1, D2N, & ISYM2(2), ICM, 2, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 22, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM2(3)==1)THEN CALL JERDFUN_KS(R2D(:,3), R2ND(:,3), B21_MY(:,3), & FI2(:,3), PSI2(:,3), fl1, D2N, & ISYM2(3), ICM, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 23, Iin, Jin ,Kin, Itimestep) ENDIF ENDIF IF(ISYM3 == 1) THEN IDROP = 0 FL3 = 0.0 CALL JERDFUN_KS(R3D, R3ND, B31_MY, & FI3, PSI3, fl3, D2N, & ISYM3, 1, 3, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 3, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM4 == 1) THEN IDROP = 0 FL4 = 0.0 CALL JERDFUN_KS(R4D, R4ND, B41_MY, & FI4, PSI4, fl4, D2N, & ISYM4, 1, 4, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 4, Iin, Jin ,Kin, Itimestep) ENDIF IF(ISYM5 == 1) THEN IDROP = 0 FL5 = 0.0 CALL JERDFUN_KS(R5D, R5ND, B51_MY, & FI5, PSI5, fl5, D2N, & ISYM5, 1, 5, TPN, IDROP, FR_LIM, FRH_LIM, ICEMAX, NKR, COL, 5, Iin, Jin ,Kin, Itimestep) ENDIF RMASSLBB=0.D0 RMASSIBB=0.D0 RMASSLAA=0.D0 RMASSIAA=0.D0 DO K=1,NKR FI1_K=FI1(K) R1_K=R1(K) FI1R1=FI1_K*R1_K*R1_K RMASSLBB=RMASSLBB+FI1R1 DO ICE =1,ICEMAX FI2_K=FI2(K,ICE) R2_K=R2(K,ICE) FI2R2=FI2_K*R2_K*R2_K RMASSIBB=RMASSIBB+FI2R2 ENDDO FI3_K=FI3(K) FI4_K=FI4(K) FI5_K=FI5(K) R3_K=R3(K) R4_K=R4(K) R5_K=R5(K) FI3R3=FI3_K*R3_K*R3_K FI4R4=FI4_K*R4_K*R4_K FI5R5=FI5_K*R5_K*R5_K RMASSIBB=RMASSIBB+FI3R3 RMASSIBB=RMASSIBB+FI4R4 RMASSIBB=RMASSIBB+FI5R5 ENDDO RMASSIBB=RMASSIBB*COL3*RORI IF(RMASSIBB.LT.0.0) RMASSIBB=0.0 RMASSLBB=RMASSLBB*COL3*RORI IF(RMASSLBB.LT.0.0) RMASSLBB=0.0 DO K=1,NKR FI1_K=PSI1(K) R1_K=R1(K) FI1R1=FI1_K*R1_K*R1_K RMASSLAA=RMASSLAA+FI1R1 DO ICE =1,ICEMAX FI2(K,ICE)=PSI2(K,ICE) FI2_K=FI2(K,ICE) R2_K=R2(K,ICE) FI2R2=FI2_K*R2_K*R2_K RMASSIAA=RMASSIAA+FI2R2 ENDDO FI3_K=PSI3(K) FI4_K=PSI4(K) FI5_K=PSI5(K) R3_K=R3(K) R4_K=R4(K) R5_K=R5(K) FI3R3=FI3_K*R3_K*R3_K FI4R4=FI4_K*R4_K*R4_K FI5R5=FI5_K*R5_K*R5_K RMASSIAA=RMASSIAA+FI3R3 RMASSIAA=RMASSIAA+FI4R4 RMASSIAA=RMASSIAA+FI5R5 ENDDO RMASSIAA=RMASSIAA*COL3*RORI IF(RMASSIAA.LE.0.0) RMASSIAA=0.0 RMASSLAA=RMASSLAA*COL3*RORI IF(RMASSLAA.LT.0.0) RMASSLAA=0.0 DELMASSL1=RMASSLAA-RMASSLBB DELMASSI1=RMASSIAA-RMASSIBB DELTAQ1=DELMASSL1+DELMASSI1 QPN=QPS-DELTAQ1 DAL1=AL1 DAL2=AL2 TPN = TPS + DAL1*DELMASSL1+DAL2*DELMASSI1 IF(ABS(DAL1*DELMASSL1+DAL2*DELMASSI1) > 5.0 )THEN print*,"ONECOND3-input-start" print*,"TTinput",TTinput,"QQinput",QQinput,"PP",PP print*,'DEL1Ninput',DEL1Ninput,'DEL2Ninput',DEL2Ninput print*,"ROR",ROR,'VR1',VR1,'PSINGLE',PSINGLE print*,'DIV1',DIV1,'DIV2',DIV2 print*,'R1',R1,'RLEC',RLEC,'RO1BL',RO1BL print*,'const',AA1_MY,BB1_MY,AA2_MY,BB2_MY print*,'const',C1_MEY,C2_MEY,COL print*,'DTCOND',DTCOND,'ICEMAX',ICEMAX,'NKR',NKR print*,'ISYM1',ISYM1,'ISYM2',ISYM2,'ISYM3',ISYM3,'ISYM4',ISYM4,'ISYM5',ISYM5 print*,Iin,Jin,Kin,W_in,DX_in print*,"ONECOND3-input-end" print*,"ONECOND3-out (start)" print*,"I=",Iin,"J=",Jin,"Kin",Kin,"W",w_in,"DX",dx_in print*,"DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DT" print*,DEL1N,DEL2N,D1N,D2N,RW,PW,RI,PI,DTT print*,"TPS=",TPS,"TPN=",TPN,"QPS=",QPS,"delmassl1",delmassl1,"delmassi1",delmassi1 print*,"DAL2=",DAL2,"DAL1=",DAL1 print*,RMASSLAA,RMASSLBB print*,RMASSIAA,RMASSIBB print*,"FI1",FI1 print*,"FI3",FI3 print*,"FI4",FI4 print*,"FI5",FI5 print*,"PSI1",PSI1 print*,"R1D",R1D,"R1ND",R1ND print*,"PSI3",PSI3 print*,"R3D",R3D,"R3ND",R3ND print*,"PSI4",PSI4 print*,"R4D",R4D,"R4ND",R4ND print*,"PSI5",PSI5 print*,"R5D",R5D,"R5ND",R5ND print*,"ONECOND3-out (end)" IF(ABS(DAL1*DELMASSL1+DAL2*DELMASSI1) > 5.0 )THEN call wrf_error_fatal3("",8205,& "fatal error in ONECOND3-out (ABS(DAL1*DELMASSL1+DAL2*DELMASSI1) > 5.0), model stop") ENDIF ENDIF IF(TIMENEW < DT) GOTO 16 17 CONTINUE TT=TPN QQ=QPN DO KR=1,NKR FF1(KR)=PSI1(KR) DO ICE=1,ICEMAX FF2(KR,ICE)=PSI2(KR,ICE) ENDDO FF3(KR)=PSI3(KR) FF4(KR)=PSI4(KR) FF5(KR)=PSI5(KR) ENDDO RETURN END SUBROUTINE ONECOND3 SUBROUTINE COAL_BOTT_NEW(FF1R,FF2R,FF3R, & FF4R,FF5R,TT,QQ,PP,RHO,dt_coll,TCRIT,TTCOAL,& FLIQFR_S,FLIQFR_G,FLIQFR_H,FRIMFR_S, & DEL1in, DEL2in, & Iin,Jin,Kin,itimestep,CollEff) use module_mp_SBM_Collision,only:coll_xyy_lwf,coll_xyx_lwf,coll_xxx_lwf, & coll_xyz_lwf, modkrn_KS, coll_breakup_KS, & coll_xxy_lwf implicit none integer,intent(in) :: Iin,Jin,Kin,itimestep real(kind=r4size),intent(in) :: tcrit,ttcoal,dt_coll real(kind=r4size),intent(inout) :: ff1r(:),ff2r(:,:),ff3r(:),ff4r(:), & ff5r(:),colleff real(kind=r8size),intent(inout) :: fliqfr_s(:),fliqfr_g(:),fliqfr_h(:), & frimfr_s(:),del1in,del2in,tt,qq real(kind=r8size),intent(in) :: pp integer :: KR,ICE,icol_drop,icol_snow,icol_graupel,icol_hail, & icol_column,icol_plate,icol_dendrite,icol_drop_brk real(kind=r8size) :: g1(nkr),g2(nkr,icemax),g3(nkr),g4(nkr),g5(nkr), & gdumb(JMAX),gdumb_bf_breakup(JMAX),xl_dumb(JMAX), & g_orig(nkr),g2_1(nkr),g2_2(nkr),g2_3(nkr) real(kind=r4size) :: cont_fin_drop,dconc,conc_icempl,deldrop,t_new, & delt_new,cont_fin_ice,conc_old,conc_new,cont_init_ice, & cont_init_drop,ALWC,T_new_real,PP_r,rho,ES1N,ES2N,EW1N real(kind=r4size),parameter :: tt_no_coll=273.16 integer :: I,J,IT,NDIV real(kind=r8size) :: break_drop_bef,break_drop_aft,dtbreakup,break_drop_per, & prdkrn,fl1(nkr),rf1(nkr),rf3(nkr),fl3(nkr), & fl4(nkr),fl5(nkr),fl2_1(nkr),fl2_2(nkr),fl2_3(nkr), & rf2(nkr),rf4(nkr),rf5(nkr),conc_drop_old, conc_drop_new, & dconc_drop, dm_rime(nkr), conc_plate_icempl, & col3, cont_coll_drop real(kind=r8size),parameter :: prdkrn1 = 1.0d0 real(kind=r4size),parameter :: prdkrn1_r = 1.0 integer,parameter :: icempl = 1 real(kind=r8size),parameter :: t_ice_mpl = 270.15D0 real(kind=r8size),PARAMETER :: g_lim = 1.0D-19*1.0D3,AA1_MY = 2.53E12, & BB1_MY = 5.42E3, AA2_MY = 3.41E13 ,BB2_MY = 6.13E3 icol_drop_brk=0 icol_drop=0 icol_snow=0 icol_graupel=0 icol_hail=0 icol_column=0 icol_plate=0 icol_dendrite=0 t_new = tt PP_r = PP call Kernals_KS(dt_coll,nkr,PP_r) CALL MODKRN_KS(TT,QQ,PP,RHO,PRDKRN,TTCOAL,11,1,Iin,Jin,Kin) CollEff = PRDKRN DO KR=1,NKR G1(KR)=FF1R(KR)*3.*XL(KR)*XL(KR)*1.E3 G2(KR,1)=FF2R(KR,1)*3*xi(KR,1)*XI(KR,1)*1.e3 G2(KR,2)=FF2R(KR,2)*3.*xi(KR,2)*XI(KR,2)*1.e3 G2(KR,3)=FF2R(KR,3)*3.*xi(KR,3)*XI(KR,3)*1.e3 G3(KR)=FF3R(KR)*3.*xs(kr)*xs(kr)*1.e3 G4(KR)=FF4R(KR)*3.*xg(kr)*xg(kr)*1.e3 G5(KR)=FF5R(KR)*3.*xh(kr)*xh(kr)*1.e3 g2_1(kr)=g2(KR,1) g2_2(KR)=g2(KR,2) g2_3(KR)=g2(KR,3) if(kr .gt. KRMIN_BREAKUP .and. g1(kr) > g_lim) icol_drop_brk = 1 IF (IBREAKUP.NE.1) icol_drop_brk = 0 if(g1(kr).gt.g_lim) icol_drop=1 if(g2_1(kr).gt.g_lim) icol_column = 1 if(g2_2(kr).gt.g_lim) icol_plate = 1 if(g2_3(kr).gt.g_lim) icol_dendrite = 1 if(g3(kr).gt.g_lim) icol_snow = 1 if(g4(kr).gt.g_lim) icol_graupel = 1 if(g5(kr).gt.g_lim) icol_hail = 1 END DO fl1 = 1.0 fl3(:) = FLIQFR_S(:) fl4(:) = FLIQFR_G(:) fl5(:) = FLIQFR_H(:) rf1 = 1.0 rf3(:) = FRIMFR_S(:) rf4(:) = 0.0 rf5(:) = 0.0 cont_init_drop = 0.0 cont_init_ice = 0.0 cont_init_drop = sum(g1(1:nkr)) cont_init_ice = sum(g3(1:nkr)) + sum(g4(1:nkr)) + sum(g5(1:nkr)) do ice=1,icemax cont_init_ice = cont_init_ice + sum(g2(1:nkr,ice)) enddo cont_init_drop=col*cont_init_drop*1.e-3 cont_init_ice=col*cont_init_ice*1.e-3 alwc=cont_init_drop*1.e6 if (icol_drop.eq.1)then fl1 = 1.0 call coll_xxx_lwf (G1,fl1,CWLL,XL_MG,CHUCM,IMA,1.d0,NKR) if(icol_drop_brk == 1)then ndiv = 1 10 continue do it = 1,ndiv dtbreakup = dt_coll/ndiv if (it == 1)then do kr=1,JMAX gdumb(kr)= g1(kr)*1.D-3 gdumb_bf_breakup(kr) = g1(kr)*1.D-3 xl_dumb(kr)=xl_mg(KR)*1.D-3 end do break_drop_bef=0.d0 do kr=1,JMAX break_drop_bef = break_drop_bef+g1(kr)*1.D-3 end do end if call coll_breakup_KS(gdumb, xl_dumb, JMAX, dtbreakup, JBREAK, PKIJ, QKJ, NKR, NKR) end do do KR=1,NKR FF1R(KR) = (1.0d3*GDUMB(KR))/(3.0*XL(KR)*XL(KR)*1.E3) if(FF1R(KR) < 0.0)then if(ndiv < 8)then ndiv = 2*ndiv go to 10 else go to 11 endif endif if(FF1R(kr) .ne. FF1R(kr)) then print*,kr,GDUMB(kr),GDUMB_BF_BREAKUP(kr),XL(kr) print*,IT,NDIV, DTBREAKUP print*,GDUMB print*,GDUMB_BF_BREAKUP call wrf_error_fatal3("",8381,& "in coal_bott af-coll_breakup - FF1R NaN, model stop") endif enddo break_drop_aft=0.0d0 do kr=1,JMAX break_drop_aft=break_drop_aft+gdumb(kr) end do break_drop_per=break_drop_aft/break_drop_bef if (break_drop_per > 1.001)then ndiv=ndiv*2 GO TO 10 else do kr=1,JMAX g1(kr) = gdumb(kr)*1.D3 end do end if end if end if 11 continue if(tt <= 273.15)then if(icol_drop == 1)then if (icol_snow == 1)then rf1 = 1.0 rf5 = 0.0 rf4 = 0.0 if(hail_opt == 1)then call coll_xyz_lwf(g1,g3,g5,rf1,rf3,rf5,cwls,xl_mg,xs_mg, & chucm,ima,prdkrn1,nkr,0) else call coll_xyz_lwf(g1,g3,g4,rf1,rf3,rf4,cwls,xl_mg,xs_mg, & chucm,ima,prdkrn1,nkr,0) endif rf1 = 1.0 rf5 = 0.0 rf4 = 0.0 if(alwc < alcr) then call coll_xyx_lwf(g3,g1,rf3,rf1,cwsl,xs_mg,xl_mg, & chucm,ima,prdkrn1,nkr,1,dm_rime) else if(hail_opt == 1)then call coll_xyz_lwf(g3,g1,g5,rf3,rf1,rf5,cwsl,xs_mg,xl_mg, & chucm,ima,prdkrn1,nkr,1) else call coll_xyz_lwf(g3,g1,g4,rf3,rf1,rf4,cwsl,xs_mg,xl_mg, & chucm,ima,prdkrn1,nkr,1) endif endif end if if (icol_graupel == 1) then if(alwc < alcr_g) then rf1 = 1.0 rf4 = 0.0 call coll_xyy_lwf(g1,g4,rf1,rf4,cwlg,xl_mg,xg_mg, & chucm,ima,prdkrn1,nkr,0) conc_old = 0.0 conc_new = 0.0 do kr = kr_icempl,nkr conc_old = conc_old+col*g1(kr)/xl_mg(kr) end do rf1 = 1.0 rf4 = 0.0 call coll_xyx_lwf(g4,g1,rf4,rf1,cwgl,xg_mg,xl_mg, & chucm,ima,prdkrn1,nkr,1,dm_rime) else rf1 = 1.0 rf5 = 0.0 rf4 = 0.0 call coll_xyz_lwf(g1,g4,g5,rf1,rf4,rf5,cwlg,xl_mg,xg_mg, & chucm,ima,prdkrn1,nkr,1) conc_old = 0.0 conc_new = 0.0 do kr = kr_icempl,nkr conc_old = conc_old+col*g1(kr)/xl_mg(kr) enddo rf1 = 1.0 rf5 = 0.0 rf4 = 0.0 call coll_xyz_lwf(g4,g1,g5,rf4,rf1,rf5,cwgl,xg_mg,xl_mg, & chucm,ima,prdkrn1,nkr,1) end if endif if(icol_hail == 1) then rf1 = 1.0 rf5 = 0.0 call coll_xyy_lwf(g1,g5,rf1,rf5,cwlh,xl_mg,xh_mg, & chucm,ima,prdkrn1,nkr,0) conc_old = 0.0 conc_new = 0.0 do kr = kr_icempl,nkr conc_old = conc_old+col*g1(kr)/xl_mg(kr) enddo rf1 = 1.0 rf5 = 0.0 call coll_xyx_lwf(g5,g1,rf5,rf1,cwhl,xh_mg,xl_mg, & chucm,ima,prdkrn1,nkr,1,dm_rime) endif if((icol_graupel == 1 .or. icol_hail == 1) .and. icempl == 1) then if(tt .ge. 265.15 .and. tt .le. tcrit) then do kr = kr_icempl,nkr conc_new=conc_new+col*g1(kr)/xl_mg(kr) enddo dconc = conc_old-conc_new if(tt .le. 268.15) then conc_icempl=dconc*4.e-3*(265.15-tt)/(265.15-268.15) endif if(tt .gt. 268.15) then conc_icempl=dconc*4.e-3*(tcrit-tt)/(tcrit-268.15) endif g3(1)=g3(1)+conc_icempl*xs_mg(1)/col endif endif endif if(icol_snow == 1) then call coll_xxx_lwf(g3,rf3,cwss,xs_mg,chucm,ima,prdkrn,nkr) endif endif cont_fin_drop=0. cont_fin_ice=0. do kr=1,nkr g2(kr,1)=g2_1(kr) g2(kr,2)=g2_2(kr) g2(kr,3)=g2_3(kr) cont_fin_drop=cont_fin_drop+g1(kr) cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)+g5(kr) do ice=1,icemax cont_fin_ice=cont_fin_ice+g2(kr,ice) enddo enddo cont_fin_drop=col*cont_fin_drop*1.e-3 cont_fin_ice=col*cont_fin_ice*1.e-3 deldrop=cont_init_drop-cont_fin_drop if(t_new <= 273.15) then if(deldrop > 0.0) then t_new = t_new + 320.*deldrop/rho ES1N = POLYSVP(t_new,0) ES2N = POLYSVP(t_new,1) EW1N = QQ*PP/(0.622+0.378*QQ) DEL1in = EW1N/ES1N - 1.0 DEL2in = EW1N/ES2N - 1.0 else if(abs(deldrop).gt.cont_init_drop*0.05) then call wrf_error_fatal3("",8567,& "fatal error in module_mp_fast_sbm (abs(deldrop).gt.cont_init_drop), model stop") endif endif endif 61 continue DO KR=1,NKR FF1R(KR)=G1(KR)/(3.*XL(KR)*XL(KR)*1.E3) if((FF1R(kr) .ne. FF1R(kr)) .or. FF1R(kr) < 0.0)then print*,"G1",G1 call wrf_error_fatal3("",8579,& "stop at end coal_bott - FF1R NaN or FF1R < 0.0, model stop") endif FF3R(KR)=G3(KR)/(3.*xs(kr)*xs(kr)*1.e3) if((FF3R(kr) .ne. FF3R(kr)) .or. FF3R(kr) < 0.0)then call wrf_error_fatal3("",8584,& "stop at end coal_bott - FF3R NaN or FF3R < 0.0, model stop") endif if(hail_opt == 0)then FF4R(KR)=G4(KR)/(3.*xg(kr)*xg(kr)*1.e3) if((FF4R(kr) .ne. FF4R(kr)) .or. FF4R(kr) < 0.0) then call wrf_error_fatal3("",8590,& "stop at end coal_bott - FF4R NaN or FF4R < 0.0, model stop") end if else FF5R(KR)=G5(KR)/(3.*xh(kr)*xh(kr)*1.e3) if((FF5R(kr) .ne. FF5R(kr)) .or. FF5R(kr) < 0.0) then call wrf_error_fatal3("",8596,& "stop at end coal_bott - FF5R NaN or FF5R < 0.0, model stop") endif endif END DO 15 CONTINUE FLIQFR_S(:) = fl3(:) FLIQFR_G(:) = fl4(:) FLIQFR_H(:) = fl5(:) FRIMFR_S(:) = rf3(:) if (abs(tt-t_new).gt.5.0) then call wrf_error_fatal3("",8609,& "fatal error in module_mp_FAST_sbm Del_T 5 K, model stop") endif tt = t_new RETURN END SUBROUTINE COAL_BOTT_NEW SUBROUTINE BREAKINIT_KS(PKIJ,QKJ,ECOALMASSM,BRKWEIGHT,XL_r,DROPRADII,BR_MAX,JBREAK,JMAX,NKR,VR1) USE module_domain USE module_dm IMPLICIT NONE integer,intent(in) :: br_max, JBREAK, NKR, JMAX real(kind=r8size),intent(inout) :: ECOALMASSM(:,:),BRKWEIGHT(:) real,intent(in) :: XL_r(:), DROPRADII(:), VR1(:) real(kind=r4size),intent(inout) :: PKIJ(:,:,:),QKJ(:,:) INTEGER :: hujisbm_unit1 LOGICAL, PARAMETER :: PRINT_diag=.FALSE. LOGICAL :: opened LOGICAL , EXTERNAL :: wrf_dm_on_monitor CHARACTER*80 errmess DOUBLE PRECISION :: XL_d(NKR), DROPRADII_d(NKR), VR1_d(NKR) INTEGER :: IE,JE,KE INTEGER,PARAMETER :: AP = 1 INTEGER :: I,J,K,JDIFF REAL :: RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK) REAL :: PI,D0,HLP DOUBLE PRECISION :: M(0:JBREAK),ALM REAL :: DBREAK(JBREAK),GAIN,LOSS INTEGER :: IP,KP,JP,KQ,JQ REAL :: XTJ CHARACTER*256 FILENAME_P,FILENAME_Q, file_p, file_q xl_d = xl_r IE = JBREAK JE = JBREAK KE = JBREAK if(nkr == 43) file_p = 'SBM_input_43/'//'coeff_p43.dat' if(nkr == 43) file_q = 'SBM_input_43/'//'coeff_q43.dat' if(nkr == 33) file_p = 'SBM_input_33/'//'coeff_p_new_33.dat' if(nkr == 33) file_q = 'SBM_input_33/'//'coeff_q_new_33.dat' hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 20,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2061 ENDIF ENDDO 2061 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",8688,& 'Can not find unused fortran unit to read in BREAKINIT_KS lookup table, model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN OPEN(UNIT=hujisbm_unit1,FILE=trim(file_p), & FORM="FORMATTED",STATUS="OLD",ERR=2070) DO K=1,KE DO I=1,IE DO J=1,I READ(hujisbm_unit1,'(3I6,1E16.8)') KP,IP,JP,PKIJ(KP,IP,JP) ENDDO ENDDO ENDDO CLOSE(hujisbm_unit1) END IF hujisbm_unit1 = -1 IF ( wrf_dm_on_monitor() ) THEN DO i = 20,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN hujisbm_unit1 = i GOTO 2062 ENDIF ENDDO 2062 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , 4 ) IF ( hujisbm_unit1 < 0 ) THEN CALL wrf_error_fatal3("",8722,& 'Can not find unused fortran unit to read in BREAKINIT_KS lookup table, model stop' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN OPEN(UNIT=hujisbm_unit1,FILE=trim(file_q), & FORM="FORMATTED",STATUS="OLD",ERR=2070) DO K=1,KE DO J=1,JE READ(hujisbm_unit1,'(2I6,1E16.8)') KQ,JQ,QKJ(KQ,JQ) ENDDO ENDDO CLOSE(hujisbm_unit1) END IF DROPRADII_d = DROPRADII vr1_d = vr1 DO J=1,NKR DO I=1,NKR ECOALMASSM(I,J)=ECOALMASS(xl_d(I), xl_d(J), DROPRADII_d, vr1_d, NKR) ENDDO ENDDO DO J=25,31 ECOALMASSM(NKR,J)=0.1D-29 ENDDO RETURN 2070 continue WRITE( errmess , '(A,I4)' ) & 'module_FAST_SBM: error opening hujisbm_DATA on unit, model stop' & , hujisbm_unit1 CALL wrf_error_fatal3("",8755,& errmess) END SUBROUTINE BREAKINIT_KS double precision FUNCTION ecoalmass(x1, x2, DROPRADII, VR1_BREAKUP, NKR) implicit none integer,intent(in) :: NKR real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR), x1, x2 real(kind=r8size),PARAMETER :: zero=0.0d0,one=1.0d0,eps=1.0d-10 real(kind=r8size) :: rho, PI, akPI, Deta, Dksi rho=1.0d0 PI=3.1415927d0 akPI=6.0d0/PI Deta = (akPI*x1/rho)**(1.0d0/3.0d0) Dksi = (akPI*x2/rho)**(1.0d0/3.0d0) ecoalmass = ecoaldiam(Deta, Dksi, DROPRADII, VR1_BREAKUP, NKR) RETURN END FUNCTION ecoalmass double precision FUNCTION ecoaldiam(Deta,Dksi,DROPRADII,VR1_BREAKUP,NKR) implicit none integer,intent(in) :: NKR real(kind=r8size),intent(in) :: DROPRADII(nkr), VR1_BREAKUP(nkr),Deta,Dksi real(kind=r8size) :: Dgr, Dkl, Rgr, RKl, q, qmin, qmax, e, x, e1, e2, sin1, cos1 real(kind=r8size),PARAMETER :: zero=0.0d0,one=1.0d0,eps=1.0d-30,PI=3.1415927d0 Dgr=dmax1(Deta,Dksi) Dkl=dmin1(Deta,Dksi) Rgr=0.5d0*Dgr Rkl=0.5d0*Dkl q=0.5d0*(Rkl+Rgr) qmin=250.0d-4 qmax=500.0d-4 if(Dkl<100.0d-4) then e=1.0d0 elseif (q=qmin.and.q=qmax) then e=ecoalLowList(Dgr, Dkl, DROPRADII, VR1_BREAKUP, NKR) else e=0.999d0 endif ecoaldiam=dmax1(dmin1(one,e),eps) RETURN END FUNCTION ecoaldiam double precision FUNCTION ecoalLowList(Dgr,Dkl,DROPRADII,VR1_BREAKUP,NKR) implicit none integer,intent(in) :: NKR real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR) real(kind=r8size),intent(inout) :: Dgr, Dkl real(kind=r8size) :: sigma, aka, akb, dSTSc, ST, Sc, ET, CKE, qq0, qq1, qq2, Ecl, W1, W2, DC real(kind=r8size),PARAMETER :: epsi=1.d-20 sigma=72.8d0 aka=0.778d0 akb=2.61d-4 CALL collenergy(Dgr,Dkl,CKE,ST,Sc,W1,W2,Dc,DROPRADII,VR1_BREAKUP,NKR) dSTSc=ST-Sc ET=CKE+dSTSc IF(ET<50.0d0) THEN qq0=1.0d0+(Dkl/Dgr) qq1=aka/qq0**2 qq2=akb*sigma*(ET**2)/(Sc+epsi) Ecl=qq1*dexp(-qq2) ELSE Ecl=0.0d0 ENDIF ecoalLowList=Ecl RETURN END FUNCTION ecoalLowList double precision FUNCTION ecoalOchs(D_l,D_s,DROPRADII, VR1_BREAKUP,NKR) implicit none integer,intent(in) :: NKR real(kind=r8size),intent(in) :: DROPRADII(NKR), VR1_BREAKUP(NKR), D_l, D_s real(kind=r8size) :: PI, sigma, R_s, R_l, p, vTl, vTs, dv, Weber_number, pa1, pa2, pa3, g, x, e real(kind=r8size),PARAMETER :: epsf=1.d-30 , FPMIN=1.d-30 PI=3.1415927d0 sigma=72.8d0 R_s=0.5d0*D_s R_l=0.5d0*D_l p=R_s/R_l vTl=vTBeard(D_l,DROPRADII, VR1_BREAKUP,NKR) vTs=vTBeard(D_s,DROPRADII, VR1_BREAKUP,NKR) dv=dabs(vTl-vTs) if(dv DROPRADII(NKR)) vTBeard=VR1_BREAKUP(NKR) DO KR=1,NKR-1 IF(aa>DROPRADII(KR).and.aa<=DROPRADII(KR+1)) then vTBeard=VR1_BREAKUP(KR+1) ENDIF ENDDO RETURN END FUNCTION vTBeard END MODULE module_mp_fast_sbm