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