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