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