UPP (upp-srw-2.2.0)
Loading...
Searching...
No Matches
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