UPP  11.0.0
 All Data Structures Files Functions Variables Pages
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
ctlblk_mod
Definition: CTLBLK.f:1
masks
Definition: MASKS_mod.f:1
params_mod
Definition: params.F:1
upp_physics::fpvsnew
elemental real function, public fpvsnew(t)
Definition: UPP_PHYSICS.f:378
upp_physics
Definition: UPP_PHYSICS.f:40