UPP  001
 All Data Structures Files Functions Pages
CALPBL.f
Go to the documentation of this file.
1 
15  SUBROUTINE calpbl(PBLRI)
16 
17 !
18  use vrbls3d, only: pmid, q, t, uh, vh, zmid
19  use vrbls2d, only: fis
20  use masks, only: vtm
21  use params_mod, only: h10e5, capa, d608, h1, g, gi
22  use ctlblk_mod, only: lm, im, jsta, jend, spval, jsta_m, jsta_2l, jend_2u, jend_m
23  use gridspec_mod, only: gridtype
24 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
25  implicit none
26 !
27 ! DECLARE VARIABLES.
28 !
29  real,dimension(IM,jsta_2l:jend_2u),intent(inout) :: pblri
30 
31  REAL, ALLOCATABLE :: thv(:,:,:)
32  INTEGER ifrstlev(im,jsta_2l:jend_2u),icalpbl(im,jsta_2l:jend_2u) &
33  ,lvlp(im,jsta_2l:jend_2u)
34  REAL rif(im,jsta_2l:jend_2u) &
35  ,ribp(im,jsta_2l:jend_2u),ubot1(im,jsta_2l:jend_2u) &
36  ,vbot1(im,jsta_2l:jend_2u),zbot1(im,jsta_2l:jend_2u) &
37  ,thvbot1(im,jsta_2l:jend_2u)
38  integer i,j,l,ie,iw
39  real ape,betta,ricr,ustarr,wmin,uhkl,ulkl,vhkl,vlkl,wndsl,wndslp, &
40  ubot,vbot,vtop,utop,thvtop,ztop,wdl2,rib
41 !
42 !*************************************************************************
43 ! START CALRCHB HERE.
44 !
45  ALLOCATE ( thv(im,jsta_2l:jend_2u,lm) )
46 
47 ! INITIALIZE ARRAYS.
48 !
49 !$omp parallel do private(i,j)
50  DO j=jsta,jend
51  DO i=1,im
52  pblri(i,j) = spval
53  ENDDO
54  ENDDO
55 !
56 ! COMPUTE VIRTUAL POTENTIAL TEMPERATURE.
57 !
58 !$omp parallel do private(i,j,l,ape)
59  DO l=lm,1,-1
60  DO j=jsta,jend
61  DO i=1,im
62  if( pmid(i,j,l)<spval) then
63  ape = (h10e5/pmid(i,j,l))**capa
64  thv(i,j,l) = (q(i,j,l)*d608+h1)*t(i,j,l)*ape
65  endif
66  ENDDO
67  ENDDO
68  ENDDO
69 !
70 ! COMPUTE BULK RICHARDSON NUMBER AS CODED IN GFS MODEL
71 ! AND RAOBS FOR VERIFICATION
72 !
73 !!$omp parallel do
74 !!$omp& private(uhkl,ulkl,vhkl,vlkl,rib,ubot,utop,vbot,vtop,
75 !!$omp& betta,ricr,ustarr,wmin,tvhtop,ztop,
76 !!$omp& wndsl,wndslp,betta,ricr,ustarr,wmin
77 !!$omp& ,IFRSTLEV
78 !!$omp& ,ICALPBL
79 !!$omp& ,LVLP
80 !!$omp& ,RIF
81 !!$omp& ,RIBP
82 !!$omp& ,UBOT1
83 !!$omp& ,VBOT1
84 !!$omp& ,ZBOT1
85 !!$omp& ,THVBOT1)
86 
87 !$omp parallel do private(i,j)
88  DO j=jsta_m,jend_m
89  DO i=2,im-1
90  ifrstlev(i,j) = 0
91  lvlp(i,j) = lm
92  icalpbl(i,j) = 0
93  ENDDO
94  ENDDO
95 
96  DO l = lm,2,-1
97 
98  betta = 100.
99  ricr = 0.25
100  ustarr = 0.1
101  wmin = 0.01
102 !
103  if(gridtype /= 'A') THEN
104  call exch(vtm(1,jsta_2l,l))
105  call exch(uh(1,jsta_2l,l))
106  call exch(vh(1,jsta_2l,l))
107  call exch(vtm(1,jsta_2l,l-1))
108  call exch(uh(1,jsta_2l,l-1))
109  call exch(vh(1,jsta_2l,l-1))
110  end if
111 
112  DO j=jsta_m,jend_m
113  DO i=2,im-1
114 !
115  if( pmid(i,j,l)<spval) then
116 
117  rif(i,j) = 0.
118  IF(ifrstlev(i,j) == 0) THEN
119  ribp(i,j) = rif(i,j)
120  ENDIF
121 
122  IF(gridtype == 'A') THEN
123  ubot = uh(i,j,l)
124  utop = uh(i,j,l-1)
125  vbot = vh(i,j,l)
126  vtop = vh(i,j,l-1)
127  ELSE IF(gridtype == 'E') THEN
128  ie = i+mod(j+1,2)
129  iw = i+mod(j+1,2)-1
130 !
131 ! WE NEED (U,V) WINDS AT A MASS POINT. FOUR POINT
132 ! AVERAGE (U,V) WINDS TO MASS POINT. NORMALIZE FOUR
133 ! POINT AVERAGE BY THE ACTUAL NUMBER OF (U,V) WINDS
134 ! USED IN THE AVERAGING. VTM=1 IF WIND POINT IS
135 ! ABOVE GROUND. VTM=0 IF BELOW GROUND.
136 !
137  wndsl = vtm(i,j-1,l)+vtm(iw,j,l)+vtm(ie,j,l)+vtm(i,j+1,l)
138  wndslp = vtm(i,j-1,l-1)+vtm(iw,j,l-1)+ &
139  vtm(ie,j,l-1)+vtm(i,j+1,l-1)
140  IF(wndsl == 0. .OR. wndslp == 0.) cycle
141  ubot = (uh(i,j-1,l)+uh(iw,j,l)+uh(ie,j,l)+uh(i,j+1,l))/wndsl
142  utop = (uh(i,j-1,l-1)+uh(iw,j,l-1)+uh(ie,j,l-1)+ &
143  uh(i,j+1,l-1))/wndslp
144  vbot = (vh(i,j-1,l)+vh(iw,j,l)+vh(ie,j,l)+vh(i,j+1,l))/wndsl
145  vtop = (vh(i,j-1,l-1)+vh(iw,j,l-1)+vh(ie,j,l-1)+ &
146  vh(i,j+1,l-1))/wndslp
147  ELSE IF(gridtype == 'B')THEN
148  ie=i
149  iw=i-1
150  ubot = (uh(iw,j-1,l)+uh(iw,j,l)+uh(ie,j-1,l)+uh(i,j,l))*0.25
151  utop = (uh(iw,j-1,l-1)+uh(iw,j,l-1)+uh(ie,j-1,l-1)+ &
152  uh(i,j,l-1))*0.25
153  vbot = (vh(iw,j-1,l)+vh(iw,j,l)+vh(ie,j-1,l)+vh(i,j,l))*0.25
154  vtop = (vh(iw,j-1,l-1)+vh(iw,j,l-1)+vh(ie,j-1,l-1)+ &
155  vh(i,j,l-1))*0.25
156  END IF
157 
158  IF(ifrstlev(i,j) == 0) THEN
159  ubot1(i,j) = ubot
160  vbot1(i,j) = vbot
161  zbot1(i,j) = zmid(i,j,l)
162  thvbot1(i,j) = thv(i,j,l)
163  ifrstlev(i,j) = 1
164  ENDIF
165 
166  thvtop = thv(i,j,l-1)
167  ztop = zmid(i,j,l-1)
168 
169 !
170 ! COMPUTE BULK RICHARDSON NUMBER.
171 !
172 ! FOLLOWING VOGELEZANG AND HOLTSLAG (1996):
173 
174  wdl2 = (utop-ubot1(i,j))**2 + (vtop-vbot1(i,j))**2 + wmin**2
175  rib = (g/thvbot1(i,j))*(thvtop-thvbot1(i,j))* &
176  (ztop-zbot1(i,j))/(wdl2+betta*(ustarr**2))
177 !
178 ! COMPUTE PBL HEIGHT
179 !
180 ! --------------------------------------------------------------------
181 ! IF BULK RICHARDSON NUMBER (RIB) EXCEEDS THE CRITICAL RICHARDSON
182 ! NUMBER (RICR), DETERMINE ABL HEIGHT USING LINEAR INTERPOLATION
183 ! BETWEEN HEIGHTS, AND PREVIOUS (RIBP) AND CURRENT (RIB) BULK
184 ! RICHARDSON NUMBERS. L IS BOUNDARY-LAYER TOP LEVEL NUMBER.
185 ! --------------------------------------------------------------------
186  IF (rib>=ricr.AND.icalpbl(i,j)==0) THEN
187  pblri(i,j) = zmid(i,j,l)+(zmid(i,j,l-1)-zmid(i,j,l))* &
188  (ricr-ribp(i,j))/(rib-ribp(i,j))
189  icalpbl(i,j) = 1
190 
191 !-------- Extract surface height -----------------------------------
192 
193  pblri(i,j) = pblri(i,j)-fis(i,j)*gi
194 
195  ENDIF
196 
197  ribp(i,j) = rib
198  lvlp(i,j) = l-1
199 !
200  10 CONTINUE
201 
202  endif !spval
203 
204  ENDDO
205  ENDDO
206  ENDDO
207 !
208  DEALLOCATE (thv)
209 ! END OF ROUTINE.
210 !
211  RETURN
212  END
213 
masks
Definition: MASKS_mod.f:1
params_mod
Definition: params.F:1