UPP v11.0.0
Loading...
Searching...
No Matches
FDLVL.f
Go to the documentation of this file.
1
44 SUBROUTINE fdlvl(ITYPE,TFD,QFD,UFD,VFD,PFD,ICINGFD,AERFD)
45
46!
47!
48 use vrbls4d, only: dust
49 use vrbls3d, only: zmid, t, q, pmid, icing_gfip, uh, vh
50 use vrbls2d, only: fis
51 use masks, only: lmh
52 use params_mod, only: gi, g
53 use ctlblk_mod, only: jsta, jend, spval, jsta_2l, jend_2u, lm, jsta_m, &
54 jend_m, htfd, nfd, im, jm, nbin_du, gocart_on, &
55 modelname, ista, iend, ista_2l, iend_2u, ista_m, iend_m
56 use gridspec_mod, only: gridtype
57!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
58 implicit none
59!
60! SET NUMBER OF FD LEVELS.
61!jw integer,intent(in) :: NFD ! coming from calling subroutine
62!
63! DECLARE VARIABLES
64!
65 integer,intent(in) :: ITYPE(NFD)
66!jw real,intent(in) :: HTFD(NFD)
67 real,dimension(ISTA:IEND,JSTA:JEND,NFD),intent(out) :: TFD,QFD,UFD,VFD,PFD,ICINGFD
68 real,dimension(ISTA:IEND,JSTA:JEND,NFD,NBIN_DU),intent(out) :: AERFD
69!
70 INTEGER LVL(NFD),LHL(NFD)
71 INTEGER IVE(JM),IVW(JM)
72 REAL DZABV(NFD), DZABH(NFD)
73 LOGICAL DONEH, DONEV
74!jw
75 integer I,J,JVS,JVN,IE,IW,JN,JS,JNT,L,LLMH,IFD,N
76 integer ISTART,ISTOP,JSTART,JSTOP
77 real htt,htsfc,httuv,dz,rdz,delt,delq,delu,delv,z1,z2,htabv,htabh,htsfcv
78!
79! SET FD LEVEL HEIGHTS IN METERS.
80! DATA HTFD / 30.E0,50.E0,80.E0,100.E0,305.E0,457.E0,610.E0,914.E0,1524.E0, &
81! 1829.E0,2134.E0,2743.E0,3658.E0,4572.E0,6000.E0/
82!
83!****************************************************************
84! START FDLVL HERE
85!
86! INITIALIZE ARRAYS.
87!
88!$omp parallel do
89 DO ifd = 1,nfd
90 DO j=jsta,jend
91 DO i=ista,iend
92 tfd(i,j,ifd) = spval
93 qfd(i,j,ifd) = spval
94 ufd(i,j,ifd) = spval
95 vfd(i,j,ifd) = spval
96 pfd(i,j,ifd) = spval
97 icingfd(i,j,ifd) = spval
98 ENDDO
99 ENDDO
100 ENDDO
101 if (gocart_on) then
102 DO n = 1, nbin_du
103 DO ifd = 1,nfd
104 DO j=jsta,jend
105 DO i=ista,iend
106 aerfd(i,j,ifd,n) = spval
107 ENDDO
108 ENDDO
109 ENDDO
110 ENDDO
111 endif
112
113 IF(gridtype == 'E') THEN
114 jvn = 1
115 jvs = -1
116 do j=jsta,jend
117 ive(j) = mod(j,2)
118 ivw(j) = ive(j)-1
119 enddo
120 END IF
121
122 IF(gridtype /= 'A')THEN
123 CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
124 DO l=1,lm
125 CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
126 END DO
127 istart = ista_m
128 istop = iend_m
129 jstart = jsta_m
130 jstop = jend_m
131 ELSE
132 istart = ista
133 istop = iend
134 jstart = jsta
135 jstop = jend
136 END IF
137 DO ifd = 1, nfd
138!
139! MSL FD LEVELS
140!
141 IF (itype(ifd)==1) THEN
142! write(6,*) 'computing above MSL'
143!
144! LOOP OVER HORIZONTAL GRID.
145!
146 DO j=jstart,jstop
147 DO i=istart,istop
148 htsfc = fis(i,j)*gi
149 llmh = nint(lmh(i,j))
150! IFD = 1
151!
152! LOCATE VERTICAL INDICES OF T,Q,U,V, LEVEL JUST
153! ABOVE EACH FD LEVEL.
154!
155! DO 22 IFD = 1, NFD
156 doneh=.false.
157 donev=.false.
158 DO l = lm,1,-1
159 htt = zmid(i,j,l)
160 IF(gridtype == 'E') THEN
161 ie = i+ive(j)
162 iw = i+ivw(j)
163 jn = j+jvn
164 js = j+jvs
165 httuv = 0.25*(zmid(iw,j,l) &
166 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
167 ELSE IF(gridtype=='B')THEN
168 ie = i+1
169 iw = i
170 jn = j+1
171 js = j
172 httuv = 0.25*(zmid(iw,j,l) &
173 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
174 ELSE
175 httuv = htt
176 END IF
177
178 IF (.NOT. doneh .AND. htt>htfd(ifd)) THEN
179 lhl(ifd) = l
180 dzabh(ifd) = htt-htfd(ifd)
181 doneh = .true.
182! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
183 IF(htsfc > htfd(ifd)) THEN
184!mp
185 lhl(ifd) = lm+1 ! CHUANG: changed to lm+1
186!mp
187 ENDIF
188! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
189! IFD = IFD + 1
190! IF (IFD>NFD) GOTO 30
191 END IF
192
193 IF (.NOT. donev .AND. httuv>htfd(ifd)) THEN
194 lvl(ifd) = l
195 dzabv(ifd) = httuv-htfd(ifd)
196 donev=.true.
197! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
198 IF(htsfc>htfd(ifd)) THEN
199!mp
200 lvl(ifd)=lm+1 ! CHUANG: changed to lm+1
201!mp
202 ENDIF
203! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
204! IFD = IFD + 1
205! IF (IFD>NFD) GOTO 30
206 ENDIF
207
208 IF(doneh .AND. donev) exit
209 enddo ! end of l loop
210! 22 CONTINUE
211!
212! COMPUTE T, Q, U, AND V AT FD LEVELS.
213!
214! DO 40 IFD = 1,NFD
215
216 l = lhl(ifd)
217 IF (l < lm) THEN
218 dz = zmid(i,j,l)-zmid(i,j,l+1)
219 rdz = 1./dz
220 delt = t(i,j,l)-t(i,j,l+1)
221 delq = q(i,j,l)-q(i,j,l+1)
222 tfd(i,j,ifd) = t(i,j,l) - delt*rdz*dzabh(ifd)
223 qfd(i,j,ifd) = q(i,j,l) - delq*rdz*dzabh(ifd)
224 pfd(i,j,ifd) = pmid(i,j,l) - (pmid(i,j,l)-pmid(i,j,l+1))*rdz*dzabh(ifd)
225 icingfd(i,j,ifd) = icing_gfip(i,j,l) - &
226 (icing_gfip(i,j,l)-icing_gfip(i,j,l+1))*rdz*dzabh(ifd)
227 if (gocart_on) then
228 DO n = 1, nbin_du
229 aerfd(i,j,ifd,n) = dust(i,j,l,n) - &
230 (dust(i,j,l,n)-dust(i,j,l+1,n))*rdz*dzabh(ifd)
231 ENDDO
232 endif
233 ELSEIF (l == lm) THEN
234 tfd(i,j,ifd) = t(i,j,l)
235 qfd(i,j,ifd) = q(i,j,l)
236 pfd(i,j,ifd) = pmid(i,j,l)
237 icingfd(i,j,ifd) = icing_gfip(i,j,l)
238 if (gocart_on) then
239 DO n = 1, nbin_du
240 aerfd(i,j,ifd,n) = dust(i,j,l,n)
241 ENDDO
242 endif
243 ENDIF
244
245 l = lvl(ifd)
246 IF (l < lm) THEN
247 IF(gridtype == 'E')THEN
248 ie = i+ive(j)
249 iw = i+ivw(j)
250 jn = j+jvn
251 js = j+jvs
252 z1 = 0.25*(zmid(iw,j,l) &
253 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
254 z2 = 0.25*(zmid(iw,j,l+1) &
255 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
256 dz = z1-z2
257
258 ELSE IF(gridtype=='B')THEN
259 ie =i+1
260 iw = i
261 jn = j+1
262 js = j
263 z1 = 0.25*(zmid(iw,j,l) &
264 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
265 z2 = 0.25*(zmid(iw,j,l+1) &
266 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
267 dz = z1-z2
268 ELSE
269 dz = zmid(i,j,l)-zmid(i,j,l+1)
270 END IF
271 rdz = 1./dz
272 delu = uh(i,j,l) - uh(i,j,l+1)
273 delv = vh(i,j,l) - vh(i,j,l+1)
274 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
275 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
276 ELSEIF (l==lm) THEN
277 ufd(i,j,ifd)=uh(i,j,l)
278 vfd(i,j,ifd)=vh(i,j,l)
279 ENDIF
280! 40 CONTINUE
281!
282! COMPUTE FD LEVEL T, Q, U, AND V AT NEXT K.
283!
284 enddo ! end of i loop
285 enddo ! end of j loop
286! END OF MSL FD LEVELS
287 ELSE
288! write(6,*) 'computing above AGL'
289!
290! AGL FD LEVELS
291!
292!
293! LOOP OVER HORIZONTAL GRID.
294!
295 DO j=jstart,jstop
296 DO i=istart,istop
297 htsfc = fis(i,j)*gi
298 IF(gridtype == 'E') THEN
299 ie = i+ive(j)
300 iw = i+ivw(j)
301 jn = j+jvn
302 js = j+jvs
303 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))*(0.25/g)
304 ELSE IF(gridtype == 'B')THEN
305 ie = i+1
306 iw = i
307 jn = j+1
308 js = j
309 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))*(0.25/g)
310 END IF
311 llmh = nint(lmh(i,j))
312! IFD = 1
313!
314! LOCATE VERTICAL INDICES OF T,U,V, LEVEL JUST
315! ABOVE EACH FD LEVEL.
316!
317! DO 222 IFD = 1, NFD
318 doneh=.false.
319 donev=.false.
320 DO l = llmh,1,-1
321 htabh = zmid(i,j,l)-htsfc
322! if(i==245.and.j==813)print*,'Debug FDL HTABH= ',htabh,zmid(i,j,l),htsfc
323 IF(gridtype=='E')THEN
324 htabv = 0.25*(zmid(iw,j,l) &
325 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))-htsfcv
326 ELSE IF(gridtype=='B')THEN
327 htabv = 0.25*(zmid(iw,j,l) &
328 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))-htsfcv
329 ELSE
330 htabv = htabh
331 END IF
332
333 IF (.NOT. doneh .AND. htabh>htfd(ifd)) THEN
334 lhl(ifd) = l
335 dzabh(ifd) = htabh-htfd(ifd)
336 doneh=.true.
337! IFD = IFD + 1
338! IF (IFD>NFD) GOTO 230
339 ENDIF
340
341 IF (.NOT. donev .AND. htabv>htfd(ifd)) THEN
342 lvl(ifd) = l
343 dzabv(ifd) = htabv-htfd(ifd)
344 donev = .true.
345! IFD = IFD + 1
346! IF (IFD>NFD) GOTO 230
347 ENDIF
348 IF(doneh .AND. donev) exit
349 enddo ! end of l loop
350!
351! COMPUTE T, Q, U, AND V AT FD LEVELS.
352!
353! 222 CONTINUE
354!
355! DO 240 IFD = 1,NFD
356 l = lhl(ifd)
357 IF (l<lm) THEN
358 dz = zmid(i,j,l)-zmid(i,j,l+1)
359 rdz = 1./dz
360 delt = t(i,j,l)-t(i,j,l+1)
361 delq = q(i,j,l)-q(i,j,l+1)
362 tfd(i,j,ifd) = t(i,j,l) - delt*rdz*dzabh(ifd)
363 qfd(i,j,ifd) = q(i,j,l) - delq*rdz*dzabh(ifd)
364 pfd(i,j,ifd) = pmid(i,j,l) - (pmid(i,j,l)-pmid(i,j,l+1))*rdz*dzabh(ifd)
365 icingfd(i,j,ifd) = icing_gfip(i,j,l) - &
366 (icing_gfip(i,j,l)-icing_gfip(i,j,l+1))*rdz*dzabh(ifd)
367 if (gocart_on) then
368 DO n = 1, nbin_du
369 aerfd(i,j,ifd,n) = dust(i,j,l,n) - &
370 (dust(i,j,l,n)-dust(i,j,l+1,n))*rdz*dzabh(ifd)
371 ENDDO
372 endif
373 ELSE
374 tfd(i,j,ifd) = t(i,j,l)
375 qfd(i,j,ifd) = q(i,j,l)
376 pfd(i,j,ifd) = pmid(i,j,l)
377 icingfd(i,j,ifd) = icing_gfip(i,j,l)
378 if (gocart_on) then
379 DO n = 1, nbin_du
380 aerfd(i,j,ifd,n) = dust(i,j,l,n)
381 ENDDO
382 endif
383 ENDIF
384
385 l = lvl(ifd)
386 IF (l < lm) THEN
387 IF(gridtype == 'E')THEN
388 ie = i+ive(j)
389 iw = i+ivw(j)
390 jn = j+jvn
391 js = j+jvs
392 z1 = 0.25*(zmid(iw,j,l) &
393 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
394 z2 = 0.25*(zmid(iw,j,l+1) &
395 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
396 dz = z1-z2
397 ELSE IF(gridtype=='B')THEN
398 ie = i+1
399 iw = i
400 jn = j+1
401 js = j
402 z1 = 0.25*(zmid(iw,j,l) &
403 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
404 z2 = 0.25*(zmid(iw,j,l+1) &
405 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
406 dz = z1-z2
407 ELSE
408 dz = zmid(i,j,l)-zmid(i,j,l+1)
409 END IF
410 rdz = 1./dz
411 delu = uh(i,j,l)-uh(i,j,l+1)
412 delv = vh(i,j,l)-vh(i,j,l+1)
413 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
414 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
415 ELSE
416 ufd(i,j,ifd) = uh(i,j,l)
417 vfd(i,j,ifd) = vh(i,j,l)
418 ENDIF
419! 240 CONTINUE
420!
421! COMPUTE FD LEVEL T, U, AND V AT NEXT K.
422!
423 enddo ! end of i loop
424 enddo ! end of j loop
425! END OF AGL FD LEVELS
426 ENDIF
427 enddo ! end of IFD loop
428
429! safety check to avoid tiny QFD values
430 !krf: need ncar and nmm wrf cores in this check as well?
431 IF(modelname=='RAPR' .OR. modelname=='NCAR' .OR. modelname=='NMM') THEN !
432 DO 420 ifd = 1,nfd
433 DO j=jsta,jend
434 DO i=ista,iend
435 if(qfd(i,j,ifd) < 1.0e-8) qfd(i,j,ifd)=0.0
436 ENDDO
437 ENDDO
438420 CONTINUE
439 endif
440!
441! END OF ROUTINE.
442!
443 RETURN
444 END
445
487 SUBROUTINE fdlvl_uv(ITYPE,NFD,HTFD,UFD,VFD)
488!
489!
490 use vrbls3d, only: zmid, pmid, uh, vh
491 use vrbls2d, only: fis
492 use masks, only: lmh
493 use params_mod, only: gi, g
494 use ctlblk_mod, only: jsta, jend, spval, jsta_2l, jend_2u, lm, jsta_m, &
495 jend_m, im, jm, modelname, &
496 ista, iend, ista_2l, iend_2u, ista_m, iend_m
497 use gridspec_mod, only: gridtype
498!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
499 implicit none
500!
501! DECLARE VARIABLES
502!
503 integer,intent(in) :: ITYPE(NFD)
504 integer,intent(in) :: NFD ! coming from calling subroutine
505 real,intent(in) :: HTFD(NFD)
506 real,dimension(ISTA_2L:IEND_2U,JSTA_2L:JEND_2U,NFD),intent(out) :: UFD,VFD
507!
508 INTEGER LVL(NFD)
509 INTEGER IVE(JM),IVW(JM)
510 REAL DZABV(NFD)
511!jw
512 integer I,J,JVS,JVN,IE,IW,JN,JS,L,LLMH,IFD,N
513 integer ISTART,ISTOP,JSTART,JSTOP
514 real htt,htsfc,httuv,dz,rdz,delu,delv,z1,z2,htabv,htabh,htsfcv
515!
516!****************************************************************
517! START FDLVL_UV HERE
518!
519! INITIALIZE ARRAYS.
520!
521!$omp parallel do
522 DO ifd = 1,nfd
523 DO j=jsta,jend
524 DO i=ista,iend
525 ufd(i,j,ifd) = spval
526 vfd(i,j,ifd) = spval
527 ENDDO
528 ENDDO
529 ENDDO
530
531 IF(gridtype == 'E') THEN
532 jvn = 1
533 jvs = -1
534 do j=jsta,jend
535 ive(j) = mod(j,2)
536 ivw(j) = ive(j)-1
537 enddo
538 END IF
539
540 IF(gridtype /= 'A')THEN
541 CALL exch(fis(ista_2l:iend_2u,jsta_2l:jend_2u))
542 DO l=1,lm
543 CALL exch(zmid(ista_2l:iend_2u,jsta_2l:jend_2u,l))
544 END DO
545 istart = ista_m
546 istop = iend_m
547 jstart = jsta_m
548 jstop = jend_m
549 ELSE
550 istart = ista
551 istop = iend
552 jstart = jsta
553 jstop = jend
554 END IF
555 DO ifd = 1, nfd
556!
557! MSL FD LEVELS
558!
559 IF (itype(ifd) == 1) THEN
560! write(6,*) 'computing above MSL'
561!
562! LOOP OVER HORIZONTAL GRID.
563!
564 DO j=jstart,jstop
565 DO i=istart,istop
566 htsfc = fis(i,j)*gi
567 llmh = nint(lmh(i,j))
568!
569! LOCATE VERTICAL INDICES OF U,V, LEVEL JUST
570! ABOVE EACH FD LEVEL.
571!
572 DO l = lm,1,-1
573 htt = zmid(i,j,l)
574 IF(gridtype == 'E') THEN
575 ie = i+ive(j)
576 iw = i+ivw(j)
577 jn = j+jvn
578 js = j+jvs
579 httuv = 0.25*(zmid(iw,j,l) &
580 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
581 ELSE IF(gridtype=='B')THEN
582 ie = i+1
583 iw = i
584 jn = j+1
585 js = j
586 httuv = 0.25*(zmid(iw,j,l) &
587 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
588 ELSE
589 httuv = htt
590 END IF
591
592 IF (httuv > htfd(ifd)) THEN
593 lvl(ifd) = l
594 dzabv(ifd) = httuv-htfd(ifd)
595! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
596 IF(htsfc > htfd(ifd)) THEN
597!mp
598 lvl(ifd)=lm+1 ! CHUANG: changed to lm+1
599!mp
600 ENDIF
601! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
602
603 exit
604 ENDIF
605 enddo ! end of l loop
606!
607! COMPUTE U V AT FD LEVELS.
608!
609 l = lvl(ifd)
610 IF (l < lm) THEN
611 IF(gridtype == 'E')THEN
612 ie = i+ive(j)
613 iw = i+ivw(j)
614 jn = j+jvn
615 js = j+jvs
616 z1 = 0.25*(zmid(iw,j,l) &
617 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
618 z2 = 0.25*(zmid(iw,j,l+1) &
619 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
620 dz = z1-z2
621
622 ELSE IF(gridtype=='B')THEN
623 ie =i+1
624 iw = i
625 jn = j+1
626 js = j
627 z1 = 0.25*(zmid(iw,j,l) &
628 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
629 z2 = 0.25*(zmid(iw,j,l+1) &
630 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
631 dz = z1-z2
632 ELSE
633 dz = zmid(i,j,l)-zmid(i,j,l+1)
634 END IF
635 rdz = 1./dz
636 delu = uh(i,j,l) - uh(i,j,l+1)
637 delv = vh(i,j,l) - vh(i,j,l+1)
638 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
639 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
640 ELSEIF (l == lm) THEN
641 ufd(i,j,ifd)=uh(i,j,l)
642 vfd(i,j,ifd)=vh(i,j,l)
643 ELSE ! Underground
644 ufd(i,j,ifd)=uh(i,j,lm)
645 vfd(i,j,ifd)=vh(i,j,lm)
646 ENDIF
647!
648 enddo ! end of i loop
649 enddo ! end of j loop
650! END OF MSL FD LEVELS
651 ELSE
652! write(6,*) 'computing above AGL'
653!
654! AGL FD LEVELS
655!
656!
657! LOOP OVER HORIZONTAL GRID.
658!
659 DO j=jstart,jstop
660 DO i=istart,istop
661 htsfc = fis(i,j)*gi
662 IF(gridtype == 'E') THEN
663 ie = i+ive(j)
664 iw = i+ivw(j)
665 jn = j+jvn
666 js = j+jvs
667 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(i,js))*(0.25/g)
668 ELSE IF(gridtype == 'B')THEN
669 ie = i+1
670 iw = i
671 jn = j+1
672 js = j
673 htsfcv = (fis(iw,j)+fis(ie,j)+fis(i,jn)+fis(ie,jn))*(0.25/g)
674 END IF
675 llmh = nint(lmh(i,j))
676!
677! LOCATE VERTICAL INDICES OF U,V, LEVEL JUST
678! ABOVE EACH FD LEVEL.
679!
680 DO l = llmh,1,-1
681 htabh = zmid(i,j,l)-htsfc
682 IF(gridtype=='E')THEN
683 htabv = 0.25*(zmid(iw,j,l) &
684 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))-htsfcv
685 ELSE IF(gridtype=='B')THEN
686 htabv = 0.25*(zmid(iw,j,l) &
687 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))-htsfcv
688 ELSE
689 htabv = htabh
690 END IF
691
692 IF (htabv > htfd(ifd)) THEN
693 lvl(ifd) = l
694 dzabv(ifd) = htabv-htfd(ifd)
695! IFD = IFD + 1
696 exit
697 ENDIF
698 enddo ! end of l loop
699!
700! COMPUTE U V AT FD LEVELS.
701!
702 l = lvl(ifd)
703 IF (l < lm) THEN
704 IF(gridtype == 'E')THEN
705 ie = i+ive(j)
706 iw = i+ivw(j)
707 jn = j+jvn
708 js = j+jvs
709 z1 = 0.25*(zmid(iw,j,l) &
710 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(i,js,l))
711 z2 = 0.25*(zmid(iw,j,l+1) &
712 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(i,js,l+1))
713 dz = z1-z2
714 ELSE IF(gridtype=='B')THEN
715 ie = i+1
716 iw = i
717 jn = j+1
718 js = j
719 z1 = 0.25*(zmid(iw,j,l) &
720 + zmid(ie,j,l)+zmid(i,jn,l)+zmid(ie,jn,l))
721 z2 = 0.25*(zmid(iw,j,l+1) &
722 + zmid(ie,j,l+1)+zmid(i,jn,l+1)+zmid(ie,jn,l+1))
723 dz = z1-z2
724 ELSE
725 dz = zmid(i,j,l)-zmid(i,j,l+1)
726 END IF
727 rdz = 1./dz
728 delu = uh(i,j,l)-uh(i,j,l+1)
729 delv = vh(i,j,l)-vh(i,j,l+1)
730 ufd(i,j,ifd) = uh(i,j,l) - delu*rdz*dzabv(ifd)
731 vfd(i,j,ifd) = vh(i,j,l) - delv*rdz*dzabv(ifd)
732 ELSE
733 ufd(i,j,ifd) = uh(i,j,l)
734 vfd(i,j,ifd) = vh(i,j,l)
735 ENDIF
736!
737! COMPUTE FD LEVEL T, U, AND V AT NEXT K.
738!
739 enddo ! end of i loop
740 enddo ! end of j loop
741! END OF AGL FD LEVELS
742 ENDIF
743 enddo ! end of IFD loop
744
745 RETURN
746 END
747
817 SUBROUTINE fdlvl_mass(ITYPE,NFD,PTFD,HTFD,NIN,QIN,QTYPE,QFD)
818 use vrbls3d, only: t,q,zmid,pmid,pint,zint
819 use vrbls2d, only: fis
820 use masks, only: lmh
821 use params_mod, only: gi, g, gamma,pq0, a2, a3, a4, rhmin,rgamog
822 use ctlblk_mod, only: jsta, jend, spval, jsta_2l, jend_2u, lm, jsta_m, &
823 jend_m, im, jm,global,modelname, &
824 ista, iend, ista_2l, iend_2u, ista_m, iend_m
825 use gridspec_mod, only: gridtype
826 use physcons_post,only: con_fvirt, con_rog, con_eps, con_epsm1
827 use upp_physics, only: fpvsnew
828!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
829 implicit none
830!
831! SET NUMBER OF FD LEVELS.
832!
833! DECLARE VARIABLES
834!
835 real,parameter:: zshul=75.,tvshul=290.66
836
837 integer,intent(in) :: ITYPE(NFD)
838 integer,intent(in) :: NFD ! coming from calling subroutine
839 real, intent(in) :: PTFD(NFD)
840 real,intent(in) :: HTFD(NFD)
841 integer,intent(in) :: NIN
842 real,intent(in) :: QIN(ISTA:IEND,JSTA:JEND,LM,NIN)
843 character, intent(in) :: QTYPE(NIN)
844 real,intent(out) :: QFD(ISTA:IEND,JSTA:JEND,NFD,NIN)
845
846!
847 INTEGER LHL(NFD)
848 REAL DZABH(NFD)
849!jw
850 integer I,J,L,LLMH,IFD,N
851 integer ISTART,ISTOP,JSTART,JSTOP
852 real htt,htsfc,dz,rdz,delq,htabh
853
854 real :: tvu,tvd,gammas,part,ES,QSAT,RHL,PL,ZL,TL,QL
855 real :: TVRL,TVRBLO,TBLO,QBLO
856!
857!****************************************************************
858! START FDLVL_MASS HERE
859!
860! INITIALIZE ARRAYS.
861!
862!$omp parallel do
863 DO n=1,nin
864 DO ifd = 1,nfd
865 DO j=jsta,jend
866 DO i=ista,iend
867 qfd(i,j,ifd,n) = spval
868 ENDDO
869 ENDDO
870 ENDDO
871 ENDDO
872
873 IF(gridtype /= 'A')THEN
874 istart = ista_m
875 istop = iend_m
876 jstart = jsta_m
877 jstop = jend_m
878 ELSE
879 istart = ista
880 istop = iend
881 jstart = jsta
882 jstop = jend
883 END IF
884
885 DO ifd = 1, nfd
886
887!
888! MSL FD LEVELS
889!
890 IF (itype(ifd) == 1) THEN
891! write(6,*) 'computing above MSL'
892!
893! LOOP OVER HORIZONTAL GRID.
894!
895 DO j=jstart,jstop
896 DO i=istart,istop
897 htsfc = fis(i,j)*gi
898 llmh = nint(lmh(i,j))
899!
900! LOCATE VERTICAL INDICES OF Q, LEVEL JUST
901! ABOVE EACH FD LEVEL.
902!
903 DO l = lm,1,-1
904 htt = zmid(i,j,l)
905
906 IF (htt > htfd(ifd)) THEN
907 lhl(ifd) = l
908 dzabh(ifd) = htt-htfd(ifd)
909! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
910 IF(htsfc > htfd(ifd)) THEN
911!mp
912 lhl(ifd) = lm+1 ! CHUANG: changed to lm+1
913!mp
914 ENDIF
915! THIS SHOULD SET BELOW GROUND VALUES TO SPVAL
916
917 exit
918 END IF
919
920 ENDDO ! end of L loop
921!
922! COMPUTE Q AT FD LEVELS.
923!
924 l = lhl(ifd)
925 IF (l < lm) THEN
926 dz = zmid(i,j,l)-zmid(i,j,l+1)
927 rdz = 1./dz
928 DO n = 1, nin
929 if(qin(i,j,l,n)<spval) then
930 qfd(i,j,ifd,n)=qin(i,j,l+1,n)
931 elseif(qin(i,j,l+1,n)<spval) then
932 qfd(i,j,ifd,n)=qin(i,j,l,n)
933 else
934 qfd(i,j,ifd,n) = qin(i,j,l,n) - &
935 (qin(i,j,l,n)-qin(i,j,l+1,n))*rdz*dzabh(ifd)
936 endif
937 ENDDO
938 ELSEIF (l == lm) THEN
939 DO n = 1, nin
940 qfd(i,j,ifd,n) = qin(i,j,l,n)
941 ENDDO
942 ELSE ! Underground
943 DO n = 1, nin
944 ! Deduce T and Q differently by different models
945 IF(modelname == 'GFS')THEN ! GFS deduce T using Shuell
946 if(qtype(n) == "T" .or. qtype(n) == "Q") then
947 tvu = t(i,j,lm) * (1.+con_fvirt*q(i,j,lm))
948 if(zmid(i,j,lm) > zshul) then
949 tvd = tvu + gamma*zmid(i,j,lm)
950 if(tvd > tvshul) then
951 if(tvu > tvshul) then
952 tvd = tvshul - 5.e-3*(tvu-tvshul)*(tvu-tvshul)
953 else
954 tvd = tvshul
955 endif
956 endif
957 gammas = (tvu-tvd)/zmid(i,j,lm)
958 else
959 gammas = 0.
960 endif
961 part = con_rog*(log(ptfd(ifd))-log(pmid(i,j,lm)))
962 part = zmid(i,j,lm) - tvu*part/(1.+0.5*gammas*part)
963 part = t(i,j,lm) - gamma*(part-zmid(i,j,lm))
964
965 if(qtype(n) == "T") qfd(i,j,ifd,n) = part
966
967 if(qtype(n) == "Q") then
968
969! Compute RH at lowest model layer because Iredell and Chuang decided to compute
970! underground GFS Q to maintain RH
971 es = min(fpvsnew(t(i,j,lm)), pmid(i,j,lm))
972 qsat = con_eps*es/(pmid(i,j,lm)+con_epsm1*es)
973 rhl = q(i,j,lm)/qsat
974! compute saturation water vapor at isobaric level
975 es = min(fpvsnew(part), ptfd(ifd))
976 qsat = con_eps*es/(ptfd(ifd)+con_epsm1*es)
977! Q at isobaric level is computed by maintaining constant RH
978 qfd(i,j,ifd,n) = rhl*qsat
979 endif
980 endif
981
982 ELSE
983 if(qtype(n) == "T" .or. qtype(n) == "Q") then
984 pl = pint(i,j,lm-1)
985 zl = zint(i,j,lm-1)
986 tl = 0.5*(t(i,j,lm-2)+t(i,j,lm-1))
987 ql = 0.5*(q(i,j,lm-2)+q(i,j,lm-1))
988
989 qsat = pq0/pl*exp(a2*(tl-a3)/(tl-a4))
990 rhl = ql/qsat
991!
992 IF(rhl > 1.)THEN
993 rhl = 1.
994 ql = rhl*qsat
995 ENDIF
996!
997 IF(rhl < rhmin)THEN
998 rhl = rhmin
999 ql = rhl*qsat
1000 ENDIF
1001!
1002 tvrl = tl*(1.+0.608*ql)
1003 tvrblo = tvrl*(ptfd(ifd)/pl)**rgamog
1004 tblo = tvrblo/(1.+0.608*ql)
1005
1006 qsat = pq0/ptfd(ifd)*exp(a2*(tblo-a3)/(tblo-a4))
1007 if(qtype(n) == "T") qfd(i,j,ifd,n) = tblo
1008 qblo = rhl*qsat
1009 if(qtype(n) == "Q") qfd(i,j,ifd,n) = max(1.e-12,qblo)
1010 endif
1011 END IF ! endif loop for deducing T and Q differently for GFS
1012
1013 if(qtype(n) == "W") qfd(i,j,ifd,n)=qin(i,j,lm,n) ! W OMGA
1014 if(qtype(n) == "K") qfd(i,j,ifd,n)= max(0.0,0.5*(qin(i,j,lm,n)+qin(i,j,lm-1,n))) ! TKE
1015 if(qtype(n) == "C") qfd(i,j,ifd,n)=0.0 ! Hydrometeor fields
1016 END DO
1017
1018 ENDIF ! Underground
1019
1020!
1021! COMPUTE FD LEVEL Q AT NEXT K.
1022!
1023 enddo ! end of i loop
1024 enddo ! end of j loop
1025! END OF MSL FD LEVELS
1026 ELSE
1027! write(6,*) 'computing above AGL'
1028!
1029! AGL FD LEVELS
1030!
1031!
1032! LOOP OVER HORIZONTAL GRID.
1033!
1034 DO j=jstart,jstop
1035 DO i=istart,istop
1036 htsfc = fis(i,j)*gi
1037 llmh = nint(lmh(i,j))
1038!
1039! LOCATE VERTICAL INDICES OF Q, LEVEL JUST
1040! ABOVE EACH FD LEVEL.
1041!
1042 DO l = llmh,1,-1
1043 htabh = zmid(i,j,l)-htsfc
1044
1045 IF ( htabh > htfd(ifd)) THEN
1046 lhl(ifd) = l
1047 dzabh(ifd) = htabh-htfd(ifd)
1048
1049 exit
1050 ENDIF
1051 enddo ! end of l loop
1052!
1053! COMPUTE Q AT FD LEVELS.
1054!
1055 l = lhl(ifd)
1056 IF (l < lm) THEN
1057 dz = zmid(i,j,l)-zmid(i,j,l+1)
1058 rdz = 1./dz
1059 DO n = 1, nin
1060 if(qin(i,j,l,n)<spval) then
1061 qfd(i,j,ifd,n)=qin(i,j,l+1,n)
1062 elseif(qin(i,j,l+1,n)<spval) then
1063 qfd(i,j,ifd,n)=qin(i,j,l,n)
1064 else
1065 qfd(i,j,ifd,n) = qin(i,j,l,n) - &
1066 (qin(i,j,l,n)-qin(i,j,l+1,n))*rdz*dzabh(ifd)
1067 endif
1068 ENDDO
1069 ELSE
1070 DO n = 1, nin
1071 qfd(i,j,ifd,n) = qin(i,j,l,n)
1072 ENDDO
1073 ENDIF
1074
1075!
1076! COMPUTE FD LEVEL Q AT NEXT K.
1077!
1078 enddo ! end of i loop
1079 enddo ! end of j loop
1080! END OF AGL FD LEVELS
1081 ENDIF
1082 enddo ! end of IFD loop
1083
1084!
1085! END OF ROUTINE.
1086!
1087 RETURN
1088 END
fdlvl_uv
subroutine fdlvl_uv(itype, nfd, htfd, ufd, vfd)
Computes FD level for u,v.
Definition FDLVL.f:488
fdlvl_mass
subroutine fdlvl_mass(itype, nfd, ptfd, htfd, nin, qin, qtype, qfd)
Computes FD level for mass variables.
Definition FDLVL.f:818
upp_physics
calcape() computes CAPE/CINS and other storm related variables.
Definition UPP_PHYSICS.f:27
upp_physics::fpvsnew
elemental real function, public fpvsnew(t)
Definition UPP_PHYSICS.f:346