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