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