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