UPP  V11.0.0
 All Data Structures Files Functions Pages
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
438 420 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
masks
Definition: MASKS_mod.f:1
physcons_post
Definition: physcons.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