UPP  11.0.0
 All Data Structures Files Functions Variables Pages
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
404 420 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
ctlblk_mod
Definition: CTLBLK.f:1
fdlvl_uv
subroutine fdlvl_uv(ITYPE, NFD, HTFD, UFD, VFD)
Computes FD level for u,v.
Definition: FDLVL.f:453
masks
Definition: MASKS_mod.f:1
physcons_post
Definition: physcons.f:1
params_mod
Definition: params.F:1
fdlvl_mass
subroutine fdlvl_mass(ITYPE, NFD, PTFD, HTFD, NIN, QIN, QTYPE, QFD)
Computes FD level for mass variables.
Definition: FDLVL.f:784
upp_physics::fpvsnew
elemental real function, public fpvsnew(t)
Definition: UPP_PHYSICS.f:378
upp_physics
Definition: UPP_PHYSICS.f:40