59 SUBROUTINE fdlvl(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD)
63 use vrbls3d,
only: zmid, t, q, pmid, icing_gfip, uh, vh
64 use vrbls2d,
only: fis
66 use params_mod,
only: gi, g
67 use ctlblk_mod,
only: jsta, jend, spval, jsta_2l, jend_2u, lm, jsta_m, &
68 jend_m, htfd, nfd, im, jm, nbin_du, &
69 modelname, ista, iend, ista_2l, iend_2u, ista_m, iend_m
70 use gridspec_mod,
only: gridtype
79 integer,
intent(in) :: ITYPE(NFD)
81 real,
dimension(ISTA:IEND,JSTA:JEND,NFD),
intent(out) :: TFD,QFD,UFD,VFD,PFD,ICINGFD
83 INTEGER LVL(NFD),LHL(NFD)
84 INTEGER IVE(JM),IVW(JM)
85 REAL DZABV(NFD), DZABH(NFD)
88 integer I,J,JVS,JVN,IE,IW,JN,JS,JNT,L,LLMH,IFD,N
89 integer ISTART,ISTOP,JSTART,JSTOP
90 real htt,htsfc,httuv,dz,rdz,delt,delq,delu,delv,z1,z2,htabv,htabh,htsfcv
110 icingfd(i,j,ifd) = spval
115 IF(gridtype ==
'E')
THEN
124 IF(gridtype /=
'A')
THEN
125 CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
127 CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
143 IF (itype(ifd)==1)
THEN
151 llmh = nint(lmh(i,j))
162 IF(gridtype ==
'E')
THEN
167 httuv = 0.25*(zmid(iw,j,l) &
168 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
169 ELSE IF(gridtype==
'B')
THEN
174 httuv = 0.25*(zmid(iw,j,l) &
175 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
180 IF (.NOT. doneh .AND. htt>htfd(ifd))
THEN
182 dzabh(ifd) = htt-htfd(ifd)
185 IF(htsfc > htfd(ifd))
THEN
195 IF (.NOT. donev .AND. httuv>htfd(ifd))
THEN
197 dzabv(ifd) = httuv-htfd(ifd)
200 IF(htsfc>htfd(ifd))
THEN
210 IF(doneh .AND. donev)
exit
220 dz = zmid(i,j,l)-zmid(i,j,l+1)
222 delt = t(i,j,l)-t(i,j,l+1)
223 delq = q(i,j,l)-q(i,j,l+1)
224 tfd(i,j,ifd) = t(i,j,l) - delt*rdz*dzabh(ifd)
225 qfd(i,j,ifd) = q(i,j,l) - delq*rdz*dzabh(ifd)
226 pfd(i,j,ifd) = pmid(i,j,l) - (pmid(i,j,l)-pmid(i,j,l+1))*rdz*dzabh(ifd)
227 icingfd(i,j,ifd) = icing_gfip(i,j,l) - &
228 (icing_gfip(i,j,l)-icing_gfip(i,j,l+1))*rdz*dzabh(ifd)
229 ELSEIF (l == lm)
THEN
230 tfd(i,j,ifd) = t(i,j,l)
231 qfd(i,j,ifd) = q(i,j,l)
232 pfd(i,j,ifd) = pmid(i,j,l)
233 icingfd(i,j,ifd) = icing_gfip(i,j,l)
238 IF(gridtype ==
'E')
THEN
243 z1 = 0.25*(zmid(iw,j,l) &
244 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
245 z2 = 0.25*(zmid(iw,j,l+1) &
246 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
249 ELSE IF(gridtype==
'B')
THEN
254 z1 = 0.25*(zmid(iw,j,l) &
255 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
256 z2 = 0.25*(zmid(iw,j,l+1) &
257 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
260 dz = zmid(i,j,l)-zmid(i,j,l+1)
263 delu = uh(i,j,l) - uh(i,j,l+1)
264 delv = vh(i,j,l) - vh(i,j,l+1)
265 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
266 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
268 ufd(i,j,ifd)=uh(i,j,l)
269 vfd(i,j,ifd)=vh(i,j,l)
289 IF(gridtype ==
'E')
THEN
294 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))*(0.25/g)
295 ELSE IF(gridtype ==
'B')
THEN
300 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))*(0.25/g)
302 llmh = nint(lmh(i,j))
312 htabh = zmid(i,j,l)-htsfc
314 IF(gridtype==
'E')
THEN
315 htabv = 0.25*(zmid(iw,j,l) &
316 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))-htsfcv
317 ELSE IF(gridtype==
'B')
THEN
318 htabv = 0.25*(zmid(iw,j,l) &
319 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))-htsfcv
324 IF (.NOT. doneh .AND. htabh>htfd(ifd))
THEN
326 dzabh(ifd) = htabh-htfd(ifd)
332 IF (.NOT. donev .AND. htabv>htfd(ifd))
THEN
334 dzabv(ifd) = htabv-htfd(ifd)
339 IF(doneh .AND. donev)
exit
349 dz = zmid(i,j,l)-zmid(i,j,l+1)
351 delt = t(i,j,l)-t(i,j,l+1)
352 delq = q(i,j,l)-q(i,j,l+1)
353 tfd(i,j,ifd) = t(i,j,l) - delt*rdz*dzabh(ifd)
354 qfd(i,j,ifd) = q(i,j,l) - delq*rdz*dzabh(ifd)
355 pfd(i,j,ifd) = pmid(i,j,l) - (pmid(i,j,l)-pmid(i,j,l+1))*rdz*dzabh(ifd)
356 icingfd(i,j,ifd) = icing_gfip(i,j,l) - &
357 (icing_gfip(i,j,l)-icing_gfip(i,j,l+1))*rdz*dzabh(ifd)
359 tfd(i,j,ifd) = t(i,j,l)
360 qfd(i,j,ifd) = q(i,j,l)
361 pfd(i,j,ifd) = pmid(i,j,l)
362 icingfd(i,j,ifd) = icing_gfip(i,j,l)
367 IF(gridtype ==
'E')
THEN
372 z1 = 0.25*(zmid(iw,j,l) &
373 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
374 z2 = 0.25*(zmid(iw,j,l+1) &
375 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
377 ELSE IF(gridtype==
'B')
THEN
382 z1 = 0.25*(zmid(iw,j,l) &
383 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
384 z2 = 0.25*(zmid(iw,j,l+1) &
385 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
388 dz = zmid(i,j,l)-zmid(i,j,l+1)
391 delu = uh(i,j,l)-uh(i,j,l+1)
392 delv = vh(i,j,l)-vh(i,j,l+1)
393 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
394 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
396 ufd(i,j,ifd) = uh(i,j,l)
397 vfd(i,j,ifd) = vh(i,j,l)
410 !krf: need ncar and nmm wrf cores in this check as well?
411 IF(modelname==
'RAPR' .OR. modelname==
'NCAR' .OR. modelname==
'NMM')
THEN
415 if(qfd(i,j,ifd) < 1.0e-8) qfd(i,j,ifd)=0.0
470 use vrbls3d,
only: zmid, pmid, uh, vh
471 use vrbls2d,
only: fis
473 use params_mod,
only: gi, g
474 use ctlblk_mod,
only: jsta, jend, spval, jsta_2l, jend_2u, lm, jsta_m, &
475 jend_m, im, jm, modelname, &
476 ista, iend, ista_2l, iend_2u, ista_m, iend_m
477 use gridspec_mod,
only: gridtype
483 integer,
intent(in) :: ITYPE(NFD)
484 integer,
intent(in) :: NFD
485 real,
intent(in) :: HTFD(NFD)
486 real,
dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFD),
intent(out) :: UFD,VFD
489 INTEGER IVE(JM),IVW(JM)
492 integer I,J,JVS,JVN,IE,IW,JN,JS,L,LLMH,IFD,N
493 integer ISTART,ISTOP,JSTART,JSTOP
494 real htt,htsfc,httuv,dz,rdz,delu,delv,z1,z2,htabv,htabh,htsfcv
511 IF(gridtype ==
'E')
THEN
520 IF(gridtype /=
'A')
THEN
521 CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
523 CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
539 IF (itype(ifd) == 1)
THEN
547 llmh = nint(lmh(i,j))
554 IF(gridtype ==
'E')
THEN
559 httuv = 0.25*(zmid(iw,j,l) &
560 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
561 ELSE IF(gridtype==
'B')
THEN
566 httuv = 0.25*(zmid(iw,j,l) &
567 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
572 IF (httuv > htfd(ifd))
THEN
574 dzabv(ifd) = httuv-htfd(ifd)
576 IF(htsfc > htfd(ifd))
THEN
591 IF(gridtype ==
'E')
THEN
596 z1 = 0.25*(zmid(iw,j,l) &
597 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
598 z2 = 0.25*(zmid(iw,j,l+1) &
599 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
602 ELSE IF(gridtype==
'B')
THEN
607 z1 = 0.25*(zmid(iw,j,l) &
608 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
609 z2 = 0.25*(zmid(iw,j,l+1) &
610 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
613 dz = zmid(i,j,l)-zmid(i,j,l+1)
616 delu = uh(i,j,l) - uh(i,j,l+1)
617 delv = vh(i,j,l) - vh(i,j,l+1)
618 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
619 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
620 ELSEIF (l == lm)
THEN
621 ufd(i,j,ifd)=uh(i,j,l)
622 vfd(i,j,ifd)=vh(i,j,l)
624 ufd(i,j,ifd)=uh(i,j,lm)
625 vfd(i,j,ifd)=vh(i,j,lm)
642 IF(gridtype ==
'E')
THEN
647 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))*(0.25/g)
648 ELSE IF(gridtype ==
'B')
THEN
653 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))*(0.25/g)
655 llmh = nint(lmh(i,j))
661 htabh = zmid(i,j,l)-htsfc
662 IF(gridtype==
'E')
THEN
663 htabv = 0.25*(zmid(iw,j,l) &
664 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))-htsfcv
665 ELSE IF(gridtype==
'B')
THEN
666 htabv = 0.25*(zmid(iw,j,l) &
667 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))-htsfcv
672 IF (htabv > htfd(ifd))
THEN
674 dzabv(ifd) = htabv-htfd(ifd)
684 IF(gridtype ==
'E')
THEN
689 z1 = 0.25*(zmid(iw,j,l) &
690 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
691 z2 = 0.25*(zmid(iw,j,l+1) &
692 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
694 ELSE IF(gridtype==
'B')
THEN
699 z1 = 0.25*(zmid(iw,j,l) &
700 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
701 z2 = 0.25*(zmid(iw,j,l+1) &
702 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
705 dz = zmid(i,j,l)-zmid(i,j,l+1)
708 delu = uh(i,j,l)-uh(i,j,l+1)
709 delv = vh(i,j,l)-vh(i,j,l+1)
710 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
711 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
713 ufd(i,j,ifd) = uh(i,j,l)
714 vfd(i,j,ifd) = vh(i,j,l)
799 use vrbls3d,
only: t,q,zmid,pmid,pint,zint
800 use vrbls2d,
only: fis
802 use params_mod,
only: gi, g, gamma,pq0, a2, a3, a4, rhmin,rgamog
803 use ctlblk_mod,
only: jsta, jend, spval, jsta_2l, jend_2u, lm, jsta_m, &
804 jend_m, im, jm,global,modelname, &
805 ista, iend, ista_2l, iend_2u, ista_m, iend_m
806 use gridspec_mod,
only: gridtype
807 use physcons_post,
only: con_fvirt, con_rog, con_eps, con_epsm1
808 use upp_physics,
only: fpvsnew
816 real,
parameter:: zshul=75.,tvshul=290.66
818 integer,
intent(in) :: ITYPE(NFD)
819 integer,
intent(in) :: NFD
820 real,
intent(in) :: PTFD(NFD)
821 real,
intent(in) :: HTFD(NFD)
822 integer,
intent(in) :: NIN
823 real,
intent(in) :: QIN(ISTA:IEND,JSTA:JEND,LM,NIN)
824 character,
intent(in) :: QTYPE(NIN)
825 real,
intent(out) :: QFD(ISTA:IEND,JSTA:JEND,NFD,NIN)
831 integer I,J,L,LLMH,IFD,N
832 integer ISTART,ISTOP,JSTART,JSTOP
833 real htt,htsfc,dz,rdz,delq,htabh
835 real :: tvu,tvd,gammas,part,ES,QSAT,RHL,PL,ZL,TL,QL
836 real :: TVRL,TVRBLO,TBLO,QBLO
848 qfd(i,j,ifd,n) = spval
854 IF(gridtype /=
'A')
THEN
871 IF (itype(ifd) == 1)
THEN
879 llmh = nint(lmh(i,j))
887 IF (htt > htfd(ifd))
THEN
889 dzabh(ifd) = htt-htfd(ifd)
891 IF(htsfc > htfd(ifd))
THEN
907 dz = zmid(i,j,l)-zmid(i,j,l+1)
910 if(qin(i,j,l,n)<spval)
then
911 qfd(i,j,ifd,n)=qin(i,j,l+1,n)
912 elseif(qin(i,j,l+1,n)<spval)
then
913 qfd(i,j,ifd,n)=qin(i,j,l,n)
915 qfd(i,j,ifd,n) = qin(i,j,l,n) - &
916 (qin(i,j,l,n)-qin(i,j,l+1,n))*rdz*dzabh(ifd)
919 ELSEIF (l == lm)
THEN
921 qfd(i,j,ifd,n) = qin(i,j,l,n)
926 IF(modelname ==
'GFS')
THEN
927 if(qtype(n) ==
"T" .or. qtype(n) ==
"Q")
then
928 tvu = t(i,j,lm) * (1.+con_fvirt*q(i,j,lm))
929 if(zmid(i,j,lm) > zshul)
then
930 tvd = tvu + gamma*zmid(i,j,lm)
931 if(tvd > tvshul)
then
932 if(tvu > tvshul)
then
933 tvd = tvshul - 5.e-3*(tvu-tvshul)*(tvu-tvshul)
938 gammas = (tvu-tvd)/zmid(i,j,lm)
942 part = con_rog*(log(ptfd(ifd))-log(pmid(i,j,lm)))
943 part = zmid(i,j,lm) - tvu*part/(1.+0.5*gammas*part)
944 part = t(i,j,lm) - gamma*(part-zmid(i,j,lm))
946 if(qtype(n) ==
"T") qfd(i,j,ifd,n) = part
948 if(qtype(n) ==
"Q")
then
952 es = min(fpvsnew(t(i,j,lm)), pmid(i,j,lm))
953 qsat = con_eps*es/(pmid(i,j,lm)+con_epsm1*es)
956 es = min(fpvsnew(part), ptfd(ifd))
957 qsat = con_eps*es/(ptfd(ifd)+con_epsm1*es)
959 qfd(i,j,ifd,n) = rhl*qsat
964 if(qtype(n) ==
"T" .or. qtype(n) ==
"Q")
then
967 tl = 0.5*(t(i,j,lm-2)+t(i,j,lm-1))
968 ql = 0.5*(q(i,j,lm-2)+q(i,j,lm-1))
970 qsat = pq0/pl*exp(a2*(tl-a3)/(tl-a4))
983 tvrl = tl*(1.+0.608*ql)
984 tvrblo = tvrl*(ptfd(ifd)/pl)**rgamog
985 tblo = tvrblo/(1.+0.608*ql)
987 qsat = pq0/ptfd(ifd)*exp(a2*(tblo-a3)/(tblo-a4))
988 if(qtype(n) ==
"T") qfd(i,j,ifd,n) = tblo
990 if(qtype(n) ==
"Q") qfd(i,j,ifd,n) = max(1.e-12,qblo)
994 if(qtype(n) ==
"K") qfd(i,j,ifd,n)= max(0.0,0.5*(qin(i,j,lm,n)+qin(i,j,lm-1,n)))
1016 llmh = nint(lmh(i,j))
1022 htabh = zmid(i,j,l)-htsfc
1024 IF ( htabh > htfd(ifd))
THEN
1026 dzabh(ifd) = htabh-htfd(ifd)
1036 dz = zmid(i,j,l)-zmid(i,j,l+1)
1039 if(qin(i,j,l,n)<spval)
then
1040 qfd(i,j,ifd,n)=qin(i,j,l+1,n)
1041 elseif(qin(i,j,l+1,n)<spval)
then
1042 qfd(i,j,ifd,n)=qin(i,j,l,n)
1044 qfd(i,j,ifd,n) = qin(i,j,l,n) - &
1045 (qin(i,j,l,n)-qin(i,j,l+1,n))*rdz*dzabh(ifd)
1050 qfd(i,j,ifd,n) = qin(i,j,l,n)