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