UPP (upp-srw-2.2.0)
Loading...
Searching...
No Matches
FRZLVL2.f
Go to the documentation of this file.
1
46!-------------------------------------------------------------------------------
54
55 SUBROUTINE frzlvl2(ISOTHERM,ZFRZ,RHFRZ,PFRZL)
56
57!
58 use vrbls3d, only: pint, t, zmid, pmid, q, zint, alpint
59 use vrbls2d, only: fis, tshltr, pshltr, qz0, qs, qshltr
60 use masks, only: lmh, sm
61 use params_mod, only: gi, d00, capa, d0065, tfrz, pq0, a2, a3, a4, d50
62 use ctlblk_mod, only: jsta, jend, spval, lm, modelname, im, ista, iend
63 use physcons_post, only: con_rd, con_rv, con_eps, con_epsm1
64 use upp_physics, only: fpvsnew
65
66 implicit none
67
68!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
69! implicit none
70!
71! DECLARE VARIABLES.
72!
73 REAL,PARAMETER::PUCAP=300.0e2
74 real,intent(in) :: ISOTHERM
75 REAL,dimension(ista:iend,jsta:jend),intent(out) :: RHFRZ, ZFRZ, PFRZL
76!jw
77 integer I,J,L,LICE,LLMH
78 real HTSFC,PSFC,QSFC,RHSFC,QW,QSAT,DELZ,DELT,DELQ,DELALP,DELZP, &
79 zl,zu,dzabv,qfrz,alpl,alph,alpfrz,pfrz,qsfrz,rhz,dzfr, &
80 tsfc,es
81!
82!*********************************************************************
83! START FRZLVL.
84!
85! LOOP OVER HORIZONTAL GRID.
86!
87
88 DO 20 j=jsta,jend
89 DO 20 i=ista,iend
90 IF(fis(i,j)<spval)THEN
91 htsfc = fis(i,j)*gi
92 llmh = nint(lmh(i,j))
93 rhfrz(i,j) = d00
94 zfrz(i,j) = htsfc
95 psfc = pint(i,j,llmh)
96 pfrzl(i,j) = psfc
97!
98! FIND THE HIGHEST LAYER WHERE THE TEMPERATURE
99! CHANGES FROM ABOVE TO BELOW ISOTHERM.
100!
101! TSFC = (SM(I,J)*THZ0(I,J)+(1.-SM(I,J))*THS(I,J)) &
102! *(PINT(I,J,NINT(LMH(I,J))+1)/P1000)**CAPA
103 IF(tshltr(i,j)/=spval .AND. pshltr(i,j)/=spval)THEN
104 tsfc=tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa
105 ELSE
106! GFS analysis does not have flux file to retrieve TSFC from
107 tsfc=t(i,j,lm)+d0065*(zmid(i,j,lm)-htsfc-2.0)
108 END IF
109 lice=llmh
110! Per AWC's request, put a 300 mb cap for highest isothermal level so that it
111! does not go into stratosphere
112 DO l = llmh-1,1,-1
113 IF (pmid(i,j,l)>=pucap .AND. &
114 (t(i,j,l)<=isotherm.AND.t(i,j,l+1)>isotherm))lice=l
115 ENDDO
116!
117! CHECK IF ISOTHERM LEVEL IS AT THE GROUND.
118!
119 IF (lice==llmh.AND.tsfc<=isotherm) THEN
120 zfrz(i,j) = htsfc+2.0+(tsfc-isotherm)/d0065
121 qsfc = sm(i,j)*qz0(i,j)+(1.-sm(i,j))*qs(i,j)
122 IF(qshltr(i,j)/=spval)THEN
123 psfc=pshltr(i,j)
124 qsfc=qshltr(i,j)
125 ELSE
126 qsfc=q(i,j,lm)
127 psfc=pmid(i,j,lm)
128 END IF
129 pfrzl(i,j) = psfc
130!
131 IF(modelname == 'GFS' .OR. modelname == 'RAPR')THEN
132 es=fpvsnew(tsfc)
133 es=min(es,psfc)
134 qsat=con_eps*es/(psfc+con_epsm1*es)
135 ELSE
136 qsat=pq0/psfc &
137 *exp(a2*(tsfc-a3)/(tsfc-a4))
138 END IF
139!
140 rhsfc = qsfc/qsat
141 rhsfc = amax1(0.01,rhsfc)
142 rhsfc = amin1(rhsfc,1.0)
143 rhfrz(i,j)= rhsfc
144!
145! OTHERWISE, LOCATE THE ISOTHERM LEVEL ALOFT.
146!
147 ELSE IF (lice<llmh) THEN
148 l=lice
149 delz = d50*(zint(i,j,l)-zint(i,j,l+2))
150 zl = d50*(zint(i,j,l+1)+zint(i,j,l+2))
151 delt = t(i,j,l)-t(i,j,l+1)
152 zfrz(i,j) = zl+(isotherm-t(i,j,l+1))/delt*delz
153!
154 dzabv = zfrz(i,j)-zl
155 delq = q(i,j,l)-q(i,j,l+1)
156 qfrz = q(i,j,l+1) + delq/delz*dzabv
157 qfrz = amax1(0.0,qfrz)
158!
159 alpl = alpint(i,j,l+2)
160 alph = alpint(i,j,l)
161 delalp = alph - alpl
162 delzp = zint(i,j,l)-zint(i,j,l+2)
163 dzfr = zfrz(i,j) - zint(i,j,l+2)
164 alpfrz = alpl + delalp/delzp*dzfr
165 pfrz = exp(alpfrz)
166 pfrzl(i,j) = pfrz
167 IF(modelname == 'GFS'.OR.modelname == 'RAPR')THEN
168 es=fpvsnew(isotherm)
169 es=min(es,pfrz)
170 qsfrz=con_eps*es/(pfrz+con_epsm1*es)
171 ELSE
172 qsfrz=pq0/pfrz &
173 *exp(a2*(isotherm-a3)/(isotherm-a4))
174 END IF
175! QSFRZ = PQ0/PFRZ
176!
177 rhz = qfrz/qsfrz
178 rhz = amax1(0.01,rhz)
179 rhz = amin1(rhz,1.0)
180 rhfrz(i,j) = rhz
181!
182 ELSE
183 l=lice
184 zu = zmid(i,j,l)
185 zl = htsfc+2.0
186 delz = zu-zl
187 IF(tshltr(i,j)/=spval .AND. pshltr(i,j)/=spval)THEN
188 tsfc=tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa
189 ELSE
190! GFS analysis does not have flux file to retrieve TSFC from
191 tsfc=t(i,j,lm)+d0065*(zmid(i,j,lm)-htsfc-2.0)
192 END IF
193 delt = t(i,j,l)-tsfc
194 zfrz(i,j) = zl + (isotherm-tsfc)/delt*delz
195!
196 dzabv = zfrz(i,j)-zl
197! GFS does not output QS
198 IF(qshltr(i,j)/=spval)THEN
199 qsfc=qshltr(i,j)
200 ELSE
201 qsfc=q(i,j,lm)
202 END IF
203 delq = q(i,j,l)-qsfc
204 qfrz = qsfc + delq/delz*dzabv
205 qfrz = amax1(0.0,qfrz)
206!
207 alph = alpint(i,j,l)
208 alpl = alog(psfc)
209 delalp = alph-alpl
210 alpfrz = alpl + delalp/delz*dzabv
211 pfrz = exp(alpfrz)
212 pfrzl(i,j) = pfrz
213 IF(modelname == 'GFS'.OR.modelname == 'RAPR')THEN
214 es=fpvsnew(isotherm)
215 es=min(es,pfrz)
216 qsfrz=con_eps*es/(pfrz+con_epsm1*es)
217 ELSE
218 qsfrz=pq0/pfrz &
219 *exp(a2*(isotherm-a3)/(isotherm-a4))
220 END IF
221!
222 rhz = qfrz/qsfrz
223 rhz = amax1(0.01,rhz)
224 rhz = amin1(rhz,1.0)
225 rhfrz(i,j)= rhz
226 ENDIF
227!
228! BOUND ISOTHERM LEVEL RH. ISOTHERM LEVEL HEIGHT IS
229! MEASURED WITH RESPECT TO MEAN SEA LEVEL.
230!
231 rhfrz(i,j) = amax1(0.01,rhfrz(i,j))
232 rhfrz(i,j) = amin1(rhfrz(i,j),1.00)
233 zfrz(i,j) = amax1(0.0,zfrz(i,j))
234 ELSE
235 rhfrz(i,j) = spval
236 zfrz(i,j) = spval
237 ENDIF
238 20 CONTINUE
239!
240! END OF ROUTINE.
241!
242 RETURN
243 END
frzlvl2
subroutine frzlvl2(isotherm, zfrz, rhfrz, pfrzl)
Subroutine that computes FRZING LVL, Z and RH.
Definition FRZLVL2.f:56