UPP (develop)
Loading...
Searching...
No Matches
CALPW.f
Go to the documentation of this file.
1
43!-----------------------------------------------------------------------
50!-----------------------------------------------------------------------
51 SUBROUTINE calpw(PW,IDECID)
52
53!
54 use vrbls3d, only: q, qqw, qqi, qqr, qqs, cwm, qqg, t, rswtt, &
55 train, tcucn, mcvg, pmid, o3, ext, pint, rlwtt, &
56 taod5503d,sca, asy
57 use vrbls4d, only: smoke, fv3dust, coarsepm
58 use masks, only: htm
59 use params_mod, only: tfrz, gi
60 use ctlblk_mod, only: lm, jsta, jend, im, spval, ista, iend
61 use upp_physics, only: fpvsnew
62!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
63 implicit none
64!
65!
66! SET DENSITY OF WATER AT 1 ATMOSPHERE PRESSURE, 0C.
67! UNITS ARE KG/M**3.
68 real,PARAMETER :: RHOWAT=1.e3
69 real,parameter:: con_rd =2.8705e+2 ! gas constant air (J/kg/K)
70 real,parameter:: con_rv =4.6150e+2 ! gas constant H2O
71 real,parameter:: con_eps =con_rd/con_rv
72 real,parameter:: con_epsm1 =con_rd/con_rv-1
73!
74! DECLARE VARIABLES.
75!
76 integer,intent(in) :: IDECID
77 real,dimension(ista:iend,jsta:jend),intent(inout) :: PW
78 INTEGER LLMH,I,J,L
79 REAL ALPM,DZ,PM,PWSUM,RHOAIR,DP,ES
80 REAL QDUM(ista:iend,jsta:jend), PWS(ista:iend,jsta:jend),QS(ista:iend,jsta:jend)
81!
82!***************************************************************
83! START CALPW HERE.
84!
85! INITIALIZE PW TO 0.
86!
87!$omp parallel do private(i,j)
88 DO j=jsta,jend
89 DO i=ista,iend
90 pw(i,j) = 0.
91 pws(i,j) = 0.
92 ENDDO
93 ENDDO
94!
95! OUTER LOOP OVER VERTICAL DIMENSION.
96! INNER LOOP OVER HORIZONTAL GRID.
97!
98!!$omp parallel do private(i,j,l,es,dp)
99 DO l = 1,lm
100 IF (idecid <= 1) THEN
101!$omp parallel do private(i,j)
102 DO j=jsta,jend
103 DO i=ista,iend
104 qdum(i,j) = q(i,j,l)
105 ENDDO
106 ENDDO
107 ELSE IF (idecid == 2) THEN
108!$omp parallel do private(i,j)
109 DO j=jsta,jend
110 DO i=ista,iend
111 qdum(i,j) = qqw(i,j,l)
112 ENDDO
113 ENDDO
114 ELSE IF (idecid == 3) THEN
115!$omp parallel do private(i,j)
116 DO j=jsta,jend
117 DO i=ista,iend
118 qdum(i,j) = qqi(i,j,l)
119 ENDDO
120 ENDDO
121 ELSE IF (idecid == 4) THEN
122!$omp parallel do private(i,j)
123 DO j=jsta,jend
124 DO i=ista,iend
125 qdum(i,j) = qqr(i,j,l)
126 ENDDO
127 ENDDO
128 ELSE IF (idecid == 5) THEN
129!$omp parallel do private(i,j)
130 DO j=jsta,jend
131 DO i=ista,iend
132 qdum(i,j) = qqs(i,j,l)
133 ENDDO
134 ENDDO
135 ELSE IF (idecid == 6) THEN
136!$omp parallel do private(i,j)
137 DO j=jsta,jend
138 DO i=ista,iend
139 qdum(i,j) = cwm(i,j,l)
140 ENDDO
141 ENDDO
142! SRD
143 ELSE IF (idecid == 16) THEN
144!$omp parallel do private(i,j)
145 DO j=jsta,jend
146 DO i=ista,iend
147 qdum(i,j) = qqg(i,j,l)
148 ENDDO
149 ENDDO
150! SRD
151 ELSE IF (idecid == 7) THEN
152!-- Total supercooled liquid
153!$omp parallel do private(i,j)
154 DO j=jsta,jend
155 DO i=ista,iend
156 IF (t(i,j,l) >= tfrz) THEN
157 qdum(i,j) = 0.
158 ELSE
159 qdum(i,j) = qqw(i,j,l) + qqr(i,j,l)
160 ENDIF
161 ENDDO
162 ENDDO
163 ELSE IF (idecid == 8) THEN
164!-- Total melting ice
165!$omp parallel do private(i,j)
166 DO j=jsta,jend
167 DO i=ista,iend
168 IF (t(i,j,l) <= tfrz) THEN
169 qdum(i,j) = 0.
170 ELSE
171 qdum(i,j) = qqi(i,j,l) + qqs(i,j,l)
172 ENDIF
173 ENDDO
174 ENDDO
175 ELSE IF (idecid == 9) THEN
176! SHORT WAVE T TENDENCY
177!$omp parallel do private(i,j)
178 DO j=jsta,jend
179 DO i=ista,iend
180 qdum(i,j) = rswtt(i,j,l)
181 ENDDO
182 ENDDO
183 ELSE IF (idecid == 10) THEN
184! LONG WAVE T TENDENCY
185!$omp parallel do private(i,j)
186 DO j=jsta,jend
187 DO i=ista,iend
188 qdum(i,j) = rlwtt(i,j,l)
189 ENDDO
190 ENDDO
191 ELSE IF (idecid == 11) THEN
192! LATENT HEATING FROM GRID SCALE RAIN/EVAP
193!$omp parallel do private(i,j)
194 DO j=jsta,jend
195 DO i=ista,iend
196 qdum(i,j) = train(i,j,l)
197 ENDDO
198 ENDDO
199 ELSE IF (idecid == 12) THEN
200! LATENT HEATING FROM CONVECTION
201!$omp parallel do private(i,j)
202 DO j=jsta,jend
203 DO i=ista,iend
204 qdum(i,j) = tcucn(i,j,l)
205 ENDDO
206 ENDDO
207 ELSE IF (idecid == 13) THEN
208! MOISTURE CONVERGENCE
209!$omp parallel do private(i,j)
210 DO j=jsta,jend
211 DO i=ista,iend
212 qdum(i,j) = mcvg(i,j,l)
213 ENDDO
214 ENDDO
215! RH
216 ELSE IF (idecid == 14) THEN
217!$omp parallel do private(i,j,es)
218 DO j=jsta,jend
219 DO i=ista,iend
220 qdum(i,j) = q(i,j,l)
221 es = min(fpvsnew(t(i,j,l)),pmid(i,j,l))
222 qs(i,j) = con_eps*es/(pmid(i,j,l)+con_epsm1*es)
223 ENDDO
224 END DO
225! OZONE
226 ELSE IF (idecid == 15) THEN
227!$omp parallel do private(i,j)
228 DO j=jsta,jend
229 DO i=ista,iend
230 qdum(i,j) = o3(i,j,l)
231 ENDDO
232 END DO
233
234! AEROSOL EXTINCTION (GOCART)
235 ELSE IF (idecid == 17) THEN
236!$omp parallel do private(i,j)
237 DO j=jsta,jend
238 DO i=ista,iend
239 qdum(i,j) = ext(i,j,l)
240 ENDDO
241 END DO
242!
243! E. James - 8 Dec 2017
244! FIRE SMOKE (tracer_1a FROM HRRR-SMOKE)
245 ELSE IF (idecid == 18) THEN
246!$omp parallel do private(i,j)
247 DO j=jsta,jend
248 DO i=ista,iend
249 qdum(i,j) = smoke(i,j,l,1)/(1e9)
250 ENDDO
251 END DO
252!
253! E. James - 8 Dec 2017
254! HRRR-SMOKE AOD
255 ELSE IF (idecid == 19) THEN
256!$omp parallel do private(i,j)
257 DO j=jsta,jend
258 DO i=ista,iend
259 qdum(i,j) = taod5503d(i,j,l)
260 ENDDO
261 END DO
262!LZhang -July 2019
263! SCATTERING AEROSOL OPTICAL THICKNESS (GOCART V2)
264 ELSE IF (idecid == 20) THEN
265!$omp parallel do private(i,j)
266 DO j=jsta,jend
267 DO i=ista,iend
268 qdum(i,j) = sca(i,j,l)
269 ENDDO
270 END DO
271
272! ASYMMETRY PARAMETER (GOCART V2)
273 ELSE IF (idecid == 21) THEN
274!$omp parallel do private(i,j)
275 DO j=jsta,jend
276 DO i=ista,iend
277 qdum(i,j) = asy(i,j,l)
278 ENDDO
279 END DO
280
281! E. James - 14 Sep 2022
282! DUST (from RRFS)
283 ELSE IF (idecid == 22) THEN
284!$omp parallel do private(i,j)
285 DO j=jsta,jend
286 DO i=ista,iend
287 qdum(i,j) = fv3dust(i,j,l,1)/(1e9)
288 ENDDO
289 END DO
290
291! E. James - 23 Feb 2023
292! COARSEPM (from RRFS)
293 ELSE IF (idecid == 23) THEN
294!$omp parallel do private(i,j)
295 DO j=jsta,jend
296 DO i=ista,iend
297 qdum(i,j) = coarsepm(i,j,l,1)/(1e9)
298 ENDDO
299 END DO
300 ENDIF
301!
302!$omp parallel do private(i,j,dp)
303 DO j=jsta,jend
304 DO i=ista,iend
305 if(pint(i,j,l+1) <spval .and. qdum(i,j) < spval) then
306 dp = pint(i,j,l+1) - pint(i,j,l)
307 IF (idecid == 19) THEN
308 pw(i,j) = pw(i,j) + qdum(i,j)
309 ELSE
310 pw(i,j) = pw(i,j) + qdum(i,j)*max(dp,0.)*gi*htm(i,j,l)
311 ENDIF
312 IF (idecid == 14) pws(i,j) = pws(i,j) + qs(i,j)*dp*gi*htm(i,j,l)
313 else
314 pw(i,j) = spval
315 pws(i,j) = spval
316 endif
317 ENDDO
318 ENDDO
319 ENDDO ! l loop
320
321
322 IF (idecid == 14)THEN
323!$omp parallel do private(i,j)
324 DO j=jsta,jend
325 DO i=ista,iend
326 if( pw(i,j)<spval) then
327 pw(i,j) = max(0.,pw(i,j)/pws(i,j)*100.)
328 endif
329 ENDDO
330 ENDDO
331 END IF
332! convert ozone from kg/m2 to dobson units, which give the depth of the
333! ozone layer in 1e-5 m if brought to natural temperature and pressure.
334
335 IF (idecid == 15) then
336!$omp parallel do private(i,j)
337 DO j=jsta,jend
338 DO i=ista,iend
339 if( pw(i,j)<spval) then
340 pw(i,j) = pw(i,j) / 2.14e-5
341 endif
342 ENDDO
343 ENDDO
344 endif
345!
346! END OF ROUTINE.
347!
348 RETURN
349 END
calpw
subroutine calpw(pw, idecid)
CALPW() Subroutine that computes precipitable water.
Definition CALPW.f:52