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