interp_fcn.F
References to this file elsewhere.
1 !WRF:MEDIATION_LAYER:INTERPOLATIONFUNCTION
2 !
3
4 #define MM5_SINT
5 !#define DUMBCOPY
6
7 #if ( NMM_CORE == 1 )
8 !=======================================================================================
9 ! E grid interpolation for mass with addition of terrain adjustments. First routine
10 ! pertains to initial conditions and the next one corresponds to boundary conditions
11 ! This is gopal's doing
12 !=======================================================================================
13
14 SUBROUTINE interp_mass_nmm (cfld, & ! CD field
15 cids, cide, ckds, ckde, cjds, cjde, &
16 cims, cime, ckms, ckme, cjms, cjme, &
17 cits, cite, ckts, ckte, cjts, cjte, &
18 nfld, & ! ND field
19 nids, nide, nkds, nkde, njds, njde, &
20 nims, nime, nkms, nkme, njms, njme, &
21 nits, nite, nkts, nkte, njts, njte, &
22 shw, & ! stencil half width for interp
23 imask, & ! interpolation mask
24 xstag, ystag, & ! staggering of field
25 ipos, jpos, & ! Position of lower left of nest in CD
26 nri, nrj, & ! nest ratios
27 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
28 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
29 CBWGT4, HBWGT4, & ! dummys for weights
30 CZ3d, Z3d, & ! Z3d interpolated from CZ3d
31 CFIS,FIS, & ! CFIS dummy on fine domain
32 CSM,SM, & ! CSM is dummy
33 CPDTOP,PDTOP, &
34 CPTOP,PTOP, &
35 CPSTD,PSTD, &
36 CKZMAX,KZMAX )
37
38 USE MODULE_MODEL_CONSTANTS
39 USE module_timing
40 IMPLICIT NONE
41
42 LOGICAL,INTENT(IN) :: xstag, ystag
43 INTEGER,INTENT(IN) :: ckzmax,kzmax
44 INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
45 cims, cime, ckms, ckme, cjms, cjme, &
46 cits, cite, ckts, ckte, cjts, cjte, &
47 nids, nide, nkds, nkde, njds, njde, &
48 nims, nime, nkms, nkme, njms, njme, &
49 nits, nite, nkts, nkte, njts, njte, &
50 shw,ipos,jpos,nri,nrj
51
52 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
53
54 ! parent domain
55
56 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
57 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3
58 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM
59 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
60 REAL,DIMENSION(cims:cime,1:KZMAX,cjms:cjme ),INTENT(IN) :: CZ3d
61 REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD
62 REAL,INTENT(IN) :: CPDTOP,CPTOP
63
64 ! nested domain
65
66 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH
67 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3
68 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4
69 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM
70 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: NFLD
71 REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD
72 REAL,DIMENSION(nims:nime,1:KZMAX,njms:njme ),INTENT(OUT) :: Z3d
73 REAL,INTENT(IN) :: PDTOP,PTOP
74
75 ! local
76
77 INTEGER,PARAMETER :: JTB=134
78 REAL, PARAMETER :: LAPSR=6.5E-3,GI=1./G, D608=0.608
79 REAL, PARAMETER :: COEF3=R_D*GI*LAPSR
80 INTEGER :: I,J,K,IDUM
81 REAL :: dlnpdz,tvout,pmo
82 REAL,DIMENSION(nims:nime,njms:njme) :: ZS,DUM2d
83 REAL,DIMENSION(JTB) :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
84 !-----------------------------------------------------------------------------------------------------
85 !
86 !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
87 !
88 DO J=NJTS,MIN(NJTE,NJDE-1)
89 DO I=NITS,MIN(NITE,NIDE-1)
90 IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) &
91 CALL wrf_error_fatal ('mass points:check domain bounds along x' )
92 IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) &
93 CALL wrf_error_fatal ('mass points:check domain bounds along y' )
94 ENDDO
95 ENDDO
96
97 IF(KZMAX .GT. (JTB-10)) &
98 CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
99
100 ! WRITE(21,*)'------------- MED NEST INITIAL 1 ----------------'
101 ! DO J=NJTS,MIN(NJTE,NJDE-1)
102 ! DO I=NITS,MIN(NITE,NIDE-1)
103 ! WRITE(21,*)I,J,IMASK(I,J),NFLD(I,1,J)
104 ! ENDDO
105 ! ENDDO
106 ! WRITE(21,*)
107
108 !
109 !*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ALSO CHECK IF SM IS LAND (SM=0) OVER TOPO
110 !*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES!
111 !
112
113 DO J=NJTS,MIN(NJTE,NJDE-1)
114 DO I=NITS,MIN(NITE,NIDE-1)
115 ZS(I,J)=FIS(I,J)/G
116 ENDDO
117 ENDDO
118
119 !
120 !*** Interpolate GPMs DERIVED FROM STANDARD ATMOSPHERIC LAPSE RATE FROM THE PARENT TO
121 !*** THE NESTED DOMAIN
122 !
123 !*** INDEX CONVENTIONS
124 !*** HBWGT4
125 !*** 4
126 !***
127 !***
128 !***
129 !*** h
130 !*** 1 2
131 !*** HBWGT1 HBWGT2
132 !***
133 !***
134 !*** 3
135 !*** HBWGT3
136
137 Z3d=0.0
138 DO J=NJTS,MIN(NJTE,NJDE-1)
139 DO K=NKTS,KZMAX ! Please note that we are still in isobaric surfaces
140 DO I=NITS,MIN(NITE,NIDE-1)
141 !
142 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
143 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
144 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
145 + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) &
146 + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1)
147 ELSE
148 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
149 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
150 + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) &
151 + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1)
152
153 ENDIF
154 !
155 ENDDO
156 ENDDO
157 ENDDO
158
159 ! RECONSTRUCT PDs ON THE BASIS OF TOPOGRAPHY AND THE INTERPOLATED HEIGHTS
160
161 DO J=NJTS,MIN(NJTE,NJDE-1)
162 DO I=NITS,MIN(NITE,NIDE-1)
163 !
164 IF (ZS(I,J) .LT. Z3d(I,1,J)) THEN
165 dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j))
166 dum2d(i,j) = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j)))
167 dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP
168 IF(J==10)WRITE(0,*)I,J,K,ZS(I,J),Z3d(I,K,J),Z3d(I,K+1,J),dum2d(i,j),PDTOP,PTOP
169 ELSE ! target level bounded by input levels
170 DO K =NKTS,KZMAX-1 ! still in the isobaric surfaces
171 IF(ZS(I,J) .GE. Z3d(I,K,J) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN
172 dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j))
173 dum2d(i,j) = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j)))
174 dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP
175 ! IF(I==1)WRITE(0,*)I,J,K,ZS(I,J),Z3d(I,K,J),Z3d(I,K+1,J),dum2d(i,j),PDTOP,PTOP
176 ENDIF
177 ENDDO
178 ENDIF
179 IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN
180 WRITE(0,*)'I=',I,'J=',J,'K=',KZMAX,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J)
181 CALL wrf_error_fatal3 ( "interp_fcn.b" , 176 , "MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
182 ENDIF
183 !
184 ENDDO
185 ENDDO
186
187 DO J=NJTS,MIN(NJTE,NJDE-1)
188 DO K=NKDS,NKDE ! NKTE is 1, nevertheless let us pretend religious
189 DO I=NITS,MIN(NITE,NIDE-1)
190 IF(IMASK(I,J) .NE. 1)THEN
191 NFLD(I,K,J)= dum2d(i,j) ! PD defined in the nested domain
192 ENDIF
193 ENDDO
194 ENDDO
195 ENDDO
196
197 !
198 END SUBROUTINE interp_mass_nmm
199 !
200 !--------------------------------------------------------------------------------------
201
202 SUBROUTINE nmm_bdymass_hinterp ( cfld, & ! CD field
203 cids, cide, ckds, ckde, cjds, cjde, &
204 cims, cime, ckms, ckme, cjms, cjme, &
205 cits, cite, ckts, ckte, cjts, cjte, &
206 nfld, & ! ND field
207 nids, nide, nkds, nkde, njds, njde, &
208 nims, nime, nkms, nkme, njms, njme, &
209 nits, nite, nkts, nkte, njts, njte, &
210 shw, & ! stencil half width
211 imask, & ! interpolation mask
212 xstag, ystag, & ! staggering of field
213 ipos, jpos, & ! Position of lower left of nest in CD
214 nri, nrj, & ! nest ratios
215 cbdy, nbdy, &
216 cbdy_t, nbdy_t, &
217 cdt, ndt, &
218 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
219 CTEMP_BT,NTEMP_BT, & ! later on
220 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
221 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
222 CBWGT4, HBWGT4, & ! dummys
223 CZ3d, Z3d, & ! Z3d dummy on nested domain
224 CFIS,FIS, & ! CFIS dummy on fine domain
225 CSM,SM, & ! CSM is dummy
226 CPDTOP,PDTOP, &
227 CPTOP,PTOP, &
228 CPSTD,PSTD, &
229 CKZMAX,KZMAX )
230
231
232 USE module_configure
233 USE module_wrf_error
234
235 IMPLICIT NONE
236
237
238 INTEGER, INTENT(IN) :: ckzmax,kzmax
239 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
240 cims, cime, ckms, ckme, cjms, cjme, &
241 cits, cite, ckts, ckte, cjts, cjte, &
242 nids, nide, nkds, nkde, njds, njde, &
243 nims, nime, nkms, nkme, njms, njme, &
244 nits, nite, nkts, nkte, njts, njte, &
245 shw, &
246 ipos, jpos, &
247 nri, nrj
248
249
250 REAL, INTENT(INOUT) :: cdt, ndt
251
252 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt
253 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt
254 LOGICAL, INTENT(IN) :: xstag, ystag
255 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t
256
257 ! parent domain
258
259 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
260 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
261 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3
262 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM
263 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
264 REAL,DIMENSION(cims:cime,1:KZMAX,cjms:cjme ), INTENT(IN) :: CZ3d
265 REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD
266 REAL,INTENT(IN) :: CPDTOP,CPTOP
267
268 ! nested domain
269
270 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH
271 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3
272 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4
273 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM
274 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: NFLD
275 REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD
276 REAL,DIMENSION(nims:nime,1:KZMAX,njms:njme ),INTENT(OUT) :: Z3d
277 REAL,INTENT(IN) :: PDTOP,PTOP
278
279 ! Local
280
281 INTEGER :: nijds, nijde, spec_bdy_width,i,j,k
282 REAL :: dlnpdz,dum2d
283 REAL,DIMENSION(nims:nime,njms:njme) :: zs
284
285 nijds = min(nids, njds)
286 nijde = max(nide, njde)
287 CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
288
289
290 CALL nmm_bdymass_interp1( cfld, & ! CD field
291 cids, cide, ckds, ckde, cjds, cjde, &
292 cims, cime, ckms, ckme, cjms, cjme, &
293 cits, cite, ckts, ckte, cjts, cjte, &
294 nfld, & ! ND field
295 nijds, nijde , spec_bdy_width , &
296 nids, nide, nkds, nkde, njds, njde, &
297 nims, nime, nkms, nkme, njms, njme, &
298 nits, nite, nkts, nkte, njts, njte, &
299 shw, imask, &
300 xstag, ystag, & ! staggering of field
301 ipos, jpos, & ! Position of lower left of nest in CD
302 nri, nrj, &
303 cdt, ndt, &
304 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
305 CTEMP_BT,NTEMP_BT, & ! later on
306 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
307 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
308 CBWGT4, HBWGT4, & ! dummys
309 CZ3d, Z3d, & ! Z3d dummy on nested domain
310 CFIS,FIS, & ! CFIS dummy on fine domain
311 CSM,SM, & ! CSM is dummy
312 CPDTOP,PDTOP, &
313 CPTOP,PTOP, &
314 CPSTD,PSTD, &
315 CKZMAX,KZMAX )
316
317 RETURN
318
319 END SUBROUTINE nmm_bdymass_hinterp
320 !
321 !---------------------------------------------------------------------
322 !
323 SUBROUTINE nmm_bdymass_interp1( cfld, & ! CD field
324 cids, cide, ckds, ckde, cjds, cjde, &
325 cims, cime, ckms, ckme, cjms, cjme, &
326 cits, cite, ckts, ckte, cjts, cjte, &
327 nfld, & ! ND field
328 nijds, nijde, spec_bdy_width , &
329 nids, nide, nkds, nkde, njds, njde, &
330 nims, nime, nkms, nkme, njms, njme, &
331 nits, nite, nkts, nkte, njts, njte, &
332 shw1, &
333 imask, & ! interpolation mask
334 xstag, ystag, & ! staggering of field
335 ipos, jpos, & ! lower left of nest in CD
336 nri, nrj, &
337 cdt, ndt, &
338 CTEMP_B,NTEMP_B, & ! to be removed
339 CTEMP_BT,NTEMP_BT, & ! later on
340 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! SW grid locs and weights
341 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones
342 CBWGT4, HBWGT4, & ! are just dummys
343 CZ3d, Z3d, & ! Z3d dummy on nested domain
344 CFIS,FIS, & ! CFIS dummy on fine domain
345 CSM,SM, & ! CSM is dummy
346 CPDTOP,PDTOP, &
347 CPTOP,PTOP, &
348 CPSTD,PSTD, &
349 CKZMAX,KZMAX )
350
351 USE MODULE_MODEL_CONSTANTS
352 use module_state_description
353 IMPLICIT NONE
354
355 INTEGER, INTENT(IN) :: ckzmax,kzmax
356 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
357 cims, cime, ckms, ckme, cjms, cjme, &
358 cits, cite, ckts, ckte, cjts, cjte, &
359 nids, nide, nkds, nkde, njds, njde, &
360 nims, nime, nkms, nkme, njms, njme, &
361 nits, nite, nkts, nkte, njts, njte, &
362 shw1, ipos, jpos, nri, nrj
363
364 INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width
365 LOGICAL, INTENT(IN) :: xstag, ystag
366
367 REAL, INTENT(INOUT) :: cdt, ndt
368 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt
369 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt
370
371 ! parent domain
372
373 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
374 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
375 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3
376 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM
377 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
378 REAL,DIMENSION(cims:cime,1:KZMAX,cjms:cjme ),INTENT(IN) :: CZ3d
379 REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD
380 REAL,INTENT(IN) :: CPDTOP,CPTOP
381
382 ! nested domain
383
384 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH
385 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3
386 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4
387 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM
388 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(INOUT) :: NFLD
389 REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD
390 REAL,DIMENSION(nims:nime,1:KZMAX,njms:njme ),INTENT(OUT) :: Z3d
391 REAL,INTENT(IN) :: PDTOP,PTOP
392
393 ! local
394
395 INTEGER,PARAMETER :: JTB=134
396 INTEGER :: i,j,k,ii,jj
397 REAL :: dlnpdz,dum2d
398 REAL, DIMENSION (nims:nime,njms:njme) :: zs
399 REAL, DIMENSION (nims:nime,njms:njme) :: CWK1,CWK2,CWK3,CWK4
400
401 !
402 !*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ASLO CHECK IF SM IS LAND (SM=0) OVER TOPO
403 !*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES!
404 !
405
406 DO J=NJTS,MIN(NJTE,NJDE-1)
407 DO I=NITS,MIN(NITE,NIDE-1)
408 ZS(I,J)=FIS(I,J)/G
409 ENDDO
410 ENDDO
411
412 ! X start boundary
413
414 NMM_XS: IF(NITS .EQ. NIDS)THEN
415 ! WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
416 I = NIDS
417
418 DO J = NJTS,MIN(NJTE,NJDE-1)
419 DO K=NKTS,KZMAX
420 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
421 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
422 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
423 + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) &
424 + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1)
425 ELSE
426 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
427 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
428 + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) &
429 + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1)
430 !
431 ! IF(J==13 .AND. K==1)WRITE(0,*)IIH(I,J),IIH(I,J)+1,JJH(I,J)-1,JJH(I,J),JJH(I,J)+1
432 ! IF(J==13 .AND. K==1)WRITE(0,*)HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J), &
433 ! CZ3d(IIH(I,J), K, JJH(I,J) ), &
434 ! CZ3d(IIH(I,J)+1,K, JJH(I,J) ), &
435 ! CZ3d(IIH(I,J), K, JJH(I,J)-1), &
436 ! CZ3d(IIH(I,J), K, JJH(I,J)+1)
437 !
438 ENDIF
439 END DO
440 END DO
441
442 DO J = NJTS,MIN(NJTE,NJDE-1)
443 IF(MOD(J,2) .NE. 0)THEN
444 IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed
445 dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j))
446 dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j)))
447 CWK1(I,J) = dum2d -PDTOP -PTOP
448 ! WRITE(0,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK1(I,J)
449 ELSE ! target level bounded by input levels
450 DO K =NKTS,KZMAX-1
451 IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN
452 dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j))
453 dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j)))
454 CWK1(I,J) = dum2d -PDTOP -PTOP
455 ! WRITE(0,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK1(I,J)
456 ENDIF
457 ENDDO
458 ENDIF
459 IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN
460 WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J)
461 CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
462 ENDIF
463 ELSE
464 CWK1(I,J)=0.
465 ENDIF
466 ENDDO
467
468 DO J = NJTS,MIN(NJTE,NJDE-1)
469 DO K = NKDS,NKDE
470 ntemp_b(i,k,j) = CWK1(I,J)
471 ntemp_bt(i,k,j) = 0.0
472 ! bdy(J,K,I,P_XSB) = CWK1(I,J) ! This will not work for NMM since
473 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
474 END DO
475 END DO
476 ENDIF NMM_XS
477
478 ! X end boundary
479
480 NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
481 ! WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
482 I = NIDE-1
483 II = NIDE - I
484
485 DO J=NJTS,MIN(NJTE,NJDE-1)
486 DO K=NKTS,KZMAX
487 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
488 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
489 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
490 + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) &
491 + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1)
492
493 ! IF(J==151)WRITE(0,*)'CRASH1',K,HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J)
494 ! IF(J==151)WRITE(0,*)'CRASH2',K,Z3d(I,K,J),CZ3d(IIH(I,J), K, JJH(I,J) ), &
495 ! CZ3d(IIH(I,J)+1,K, JJH(I,J) ), &
496 ! CZ3d(IIH(I,J), K, JJH(I,J)-1), &
497 ! CZ3d(IIH(I,J), K, JJH(I,J)+1)
498 ELSE
499 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
500 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
501 + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) &
502 + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1)
503
504 ! IF(J==151)WRITE(0,*)'CRASH3',K,HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J)
505 ! IF(J==151)WRITE(0,*)'CRASH4',K,Z3d(I,K,J),CZ3d(IIH(I,J), K, JJH(I,J) ), &
506 ! CZ3d(IIH(I,J)+1,K, JJH(I,J) ), CZ3d(IIH(I,J)+1,K, JJH(I,J)-1), &
507 ! CZ3d(IIH(I,J)+1,K, JJH(I,J)+1)
508
509 ENDIF
510 ENDDO
511 ENDDO
512
513 DO J = NJTS,MIN(NJTE,NJDE-1)
514 IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of nested domain
515 IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed
516 dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j))
517 dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j)))
518 CWK2(I,J) = dum2d -PDTOP -PTOP
519 ! WRITE(0,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK2(I,J)
520 ELSE ! target level bounded by input levels
521 DO K =NKTS,KZMAX-1
522 IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN
523 dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j))
524 dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j)))
525 CWK2(I,J) = dum2d -PDTOP -PTOP
526 ! WRITE(0,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK2(I,J)
527 ENDIF
528 ENDDO
529 ENDIF
530 IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN
531 WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J)
532 CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
533 ENDIF
534 ELSE
535 CWK2(I,J) = 0.0
536 ENDIF
537 ENDDO
538
539 DO J = NJTS,MIN(NJTE,NJDE-1)
540 DO K = NKDS,NKDE
541 ntemp_b(i,k,j) = CWK2(I,J)
542 ntemp_bt(i,k,j) = 0.0
543 ! bdy(J,K,II,P_XEB) = CWK2(I,J) ! This will not work for NMM since
544 ! bdy_t(J,K,II,P_XEB)= 0.0 ! NMM core requires BC halo exchanges
545 END DO
546 END DO
547 ENDIF NMM_XE
548
549 ! Y start boundary
550
551 NMM_YS: IF(NJTS .EQ. NJDS)THEN
552 ! WRITE(20,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
553 J = NJDS
554 DO K=NKTS,KZMAX
555 DO I = NITS,MIN(NITE,NIDE-1)
556 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
557 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
558 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
559 + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) &
560 + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1)
561 ELSE
562 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
563 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
564 + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) &
565 + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1)
566 ENDIF
567 END DO
568 END DO
569
570 DO I = NITS,MIN(NITE,NIDE-1)
571 IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed
572 dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j))
573 dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j)))
574 CWK3(I,J) = dum2d -PDTOP -PTOP
575 ! WRITE(20,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK3(I,J)
576 ELSE ! target level bounded by input levels
577 DO K =NKTS,KZMAX-1
578 IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN
579 dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j))
580 dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j)))
581 CWK3(I,J) = dum2d -PDTOP -PTOP
582 ! WRITE(20,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK3(I,J)
583 ENDIF
584 ENDDO
585 ENDIF
586 IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN
587 WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J)
588 CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
589 ENDIF
590 ENDDO
591
592 DO K = NKDS, NKDE
593 DO I = NITS,MIN(NITE,NIDE-1)
594 ntemp_b(i,k,j) = CWK3(I,J)
595 ntemp_bt(i,k,j) = 0.0
596 ! bdy(I,K,J,P_YSB) = CWK3(I,J) ! This will not work for the NMM core
597 ! bdy_t(I,K,J,P_YSB) = 0.0 ! since NMM core requires BC halo exchanges
598 END DO
599 END DO
600 END IF NMM_YS
601
602 ! Y end boundary
603
604 NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
605 ! WRITE(20,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
606 J = NJDE-1
607 JJ = NJDE - J
608 DO K=NKTS,KZMAX
609 DO I = NITS,MIN(NITE,NIDE-1)
610 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
611 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
612 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
613 + HBWGT3(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)-1) &
614 + HBWGT4(I,J)*CZ3d(IIH(I,J), K, JJH(I,J)+1)
615 ELSE
616 Z3d(I,K,J) = HBWGT1(I,J)*CZ3d(IIH(I,J), K, JJH(I,J) ) &
617 + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J) ) &
618 + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)-1) &
619 + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,K, JJH(I,J)+1)
620 ENDIF
621 END DO
622 END DO
623
624 DO I = NITS,MIN(NITE,NIDE-1)
625 IF (ZS(I,J) .LT. Z3d(I,2,J)) THEN ! level 2 has to be changed
626 dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,1,j)-Z3d(i,2,j))
627 dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,1,j)))
628 CWK4(I,J) = dum2d -PDTOP -PTOP
629 ! WRITE(20,*)I,J,ZS(I,J),Z3d(i,1,j),Z3d(i,2,j),CWK4(I,J)
630 ELSE ! target level bounded by input levels
631 DO K =NKTS,KZMAX-1
632 IF(ZS(I,J) .GE. Z3d(i,K,j) .AND. ZS(I,J) .LT. Z3d(i,K+1,j))THEN
633 dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(i,K,j)-Z3d(i,K+1,j))
634 dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(i,K,j)))
635 CWK4(I,J) = dum2d -PDTOP -PTOP
636 ! WRITE(20,*)I,J,ZS(I,J),Z3d(i,K,j),Z3d(i,K+1,j),CWK4(I,J)
637 ENDIF
638 ENDDO
639 ENDIF
640 IF(ZS(I,J) .GE. Z3d(I,KZMAX,J))THEN
641 WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,KZMAX,J)
642 CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
643 ENDIF
644 ENDDO
645
646 DO K = NKDS,NKDE
647 DO I = NITS,MIN(NITE,NIDE-1)
648 ntemp_b(i,k,j) = CWK4(I,J)
649 ntemp_bt(i,k,j) = 0.0
650 ! bdy(I,K,JJ,P_YEB) = CWK4(I,J) ! This will not work for the NMM core
651 ! bdy_t(I,K,JJ,P_YEB) = 0.0 ! since NMM core requires BC halo exchanges
652 END DO
653 END DO
654 END IF NMM_YE
655
656 RETURN
657
658 END SUBROUTINE nmm_bdymass_interp1
659 !
660 !==========================================================================================
661 ! E grid vertical interpolation: Heights (Z3d) originally obtained on the mother domains
662 ! on isobaric levels are first horizontally interpolated in interp_mass_nmm on to the
663 ! the nested domain. Now heights on isobaric surfaces must be interpolated on to the
664 ! new hybrid surfaces that include the high resolution topography. After obtaining
665 ! heights in the modified hybrid surfaces, we use the hyposmetric equation to recover
666 ! the temperature fields. The following routine returns the temperature fields in the
667 ! nested domain. First routine pertains to initial conditions and the next one
668 ! corresponds to boundary conditions.
669 !=======================================================================================
670 !
671 SUBROUTINE interp_p2hyb_nmm (cfld, & ! CD field
672 cids,cide,ckds,ckde,cjds,cjde, &
673 cims,cime,ckms,ckme,cjms,cjme, &
674 cits,cite,ckts,ckte,cjts,cjte, &
675 nfld, & ! ND field
676 nids,nide,nkds,nkde,njds,njde, &
677 nims,nime,nkms,nkme,njms,njme, &
678 nits,nite,nkts,nkte,njts,njte, &
679 shw, & ! stencil half width for interp
680 imask, & ! interpolation mask
681 xstag,ystag, & ! staggering of field
682 ipos,jpos, & ! Position of lower left of nest in CD
683 nri,nrj, & ! nest ratios
684 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
685 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
686 CBWGT4, HBWGT4, & ! dummys for weights
687 CZ3d,Z3d, & ! Z3d interpolated from CZ3d
688 CQ,Q, & ! CQ not used
689 CFIS,FIS, & ! CFIS dummy on fine domain
690 CPD,PD, &
691 CPSTD,PSTD, &
692 CPDTOP,PDTOP, &
693 CPTOP,PTOP, &
694 CETA1,ETA1,CETA2,ETA2, &
695 CDETA1,DETA1,CDETA2,DETA2 )
696
697 USE MODULE_MODEL_CONSTANTS
698 USE module_timing
699 IMPLICIT NONE
700
701 LOGICAL,INTENT(IN) :: xstag, ystag
702 INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
703 cims, cime, ckms, ckme, cjms, cjme, &
704 cits, cite, ckts, ckte, cjts, cjte, &
705 nids, nide, nkds, nkde, njds, njde, &
706 nims, nime, nkms, nkme, njms, njme, &
707 nits, nite, nkts, nkte, njts, njte, &
708 shw,ipos,jpos,nri,nrj
709
710 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
711
712 ! parent domain
713
714 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
715 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2
716 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4
717
718 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
719 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CZ3d,CQ
720 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFIS,CPD
721 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD
722 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2
723 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CDETA1,CDETA2
724 REAL, INTENT(IN) :: CPDTOP,CPTOP
725
726 ! nested domain
727
728 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH
729 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2
730 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4
731
732 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD ! This is T, here
733 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(IN) :: Z3d,Q
734 REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: FIS,PD
735 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD
736 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2
737 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: DETA1,DETA2
738 REAL,INTENT(IN) :: PDTOP,PTOP
739
740 ! local
741
742 INTEGER,PARAMETER :: JTB=134
743 REAL, PARAMETER :: LAPSR=6.5E-3,GI=1./G, D608=0.608
744 REAL, PARAMETER :: TRG=2.0*R_D*GI,COEF3=R_D*GI*LAPSR
745 INTEGER :: I,J,K
746 REAL :: TVOUT,PMO
747 REAL,DIMENSION(nims:nime,njms:njme) :: ZS
748 REAL,DIMENSION(JTB) :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
749 ! REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme) :: TOUT
750 !-----------------------------------------------------------------------------------------------------
751 !
752 !
753 ! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION
754 !
755 IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) &
756 CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
757
758
759 ! WRITE(22,*)'------------- MED NEST INITIAL 2 ----------------'
760 ! DO J=NJTS,MIN(NJTE,NJDE-1)
761 ! DO I=NITS,MIN(NITE,NIDE-1)
762 ! WRITE(22,*)I,J,IMASK(I,J),NFLD(I,1,J)
763 ! ENDDO
764 ! ENDDO
765 ! WRITE(22,*)
766
767 !
768 ! direct horizontal interpolation may work in the absence of terrain especially at
769 ! the boundaries
770 !
771 ! DO J=NJTS,MIN(NJTE,NJDE-1)
772 ! DO K=NKDS,NKDE
773 ! DO I=NITS,MIN(NITE,NIDE-1)
774 ! IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
775 ! NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
776 ! + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
777 ! + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
778 ! + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
779 ! ELSE
780 ! NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
781 ! + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
782 ! + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
783 ! + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
784 ! ENDIF
785 ! ENDDO
786 ! ENDDO
787 ! ENDDO
788
789 !
790 ! Interpolate Z3d to the new pressure levels, determine Temperature in the nested domain
791 ! from hydrostatic equation. This is important for terrain adjustments in nested domains
792 !
793
794 DO J=NJTS,MIN(NJTE,NJDE-1)
795 DO I=NITS,MIN(NITE,NIDE-1)
796 IF(IMASK(I,J) .NE. 1)THEN
797 ZS(I,J)=FIS(I,J)*GI
798 ENDIF
799 ENDDO
800 ENDDO
801
802 DO J=NJTS,MIN(NJTE,NJDE-1)
803 DO I=NITS,MIN(NITE,NIDE-1)
804 IF(IMASK(I,J) .NE. 1)THEN
805 !
806 ! clean local array before use of spline
807
808 ZIN=0.;PIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0.
809 !
810 DO K=NKDS,NKDE ! inputs at standard interface levels
811 PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop;redefined later
812 ZIN(K) = Z3d(I,NKDE-K+1,J)
813 ENDDO
814 !
815 Y2(1 )=0.
816 Y2(NKDE)=0.
817 !
818 DO K=NKDS,NKDE ! target points in model interface levels (pint)
819 PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
820 ENDDO
821 !
822 IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb
823 PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target
824 ZIN(NKDE) = ZS(I,J)
825 ENDIF
826
827 CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate
828
829 DO K=NKDS,NKDE-1
830 PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
831 TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG
832 NFLD(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature in the nested domain
833 ! IF(I==2 .and. J==3)WRITE(0,*)K,PIN(K),Z3d(I,K,J),PIO(K),ZOUT(K),TVOUT,Q(I,K,J),NFLD(I,K,J)
834 ENDDO
835 !
836 ENDIF
837 ENDDO
838 ENDDO
839
840 !
841 END SUBROUTINE interp_p2hyb_nmm
842 !
843 !===================================================================================================
844 !
845 SUBROUTINE nmm_bdy_p2hyb (cfld, & ! CD field
846 cids,cide,ckds,ckde,cjds,cjde, &
847 cims,cime,ckms,ckme,cjms,cjme, &
848 cits,cite,ckts,ckte,cjts,cjte, &
849 nfld, & ! ND field
850 nids,nide,nkds,nkde,njds,njde, &
851 nims,nime,nkms,nkme,njms,njme, &
852 nits,nite,nkts,nkte,njts,njte, &
853 shw, & ! stencil half width for interp
854 imask, & ! interpolation mask
855 xstag,ystag, & ! staggering of field
856 ipos,jpos, & ! Position of lower left of nest in CD
857 nri,nrj, & ! nest ratios
858 cbdy, nbdy, &
859 cbdy_t, nbdy_t, &
860 cdt, ndt, &
861 CTEMP_B,NTEMP_B, & ! to be removed
862 CTEMP_BT,NTEMP_BT, &
863 CZ3d,Z3d, & ! Z3d interpolated from CZ3d
864 CQ,Q, & ! CQ not used
865 CFIS,FIS, & ! CFIS dummy on fine domain
866 CPD,PD, &
867 CPSTD,PSTD, &
868 CPDTOP,PDTOP, &
869 CPTOP,PTOP, &
870 CETA1,ETA1,CETA2,ETA2, &
871 CDETA1,DETA1,CDETA2,DETA2 )
872
873 USE MODULE_MODEL_CONSTANTS
874 USE module_timing
875 IMPLICIT NONE
876
877 LOGICAL,INTENT(IN) :: xstag, ystag
878 REAL, INTENT(INOUT) :: cdt, ndt
879 INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
880 cims, cime, ckms, ckme, cjms, cjme, &
881 cits, cite, ckts, ckte, cjts, cjte, &
882 nids, nide, nkds, nkde, njds, njde, &
883 nims, nime, nkms, nkme, njms, njme, &
884 nits, nite, nkts, nkte, njts, njte, &
885 shw,ipos,jpos,nri,nrj
886 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt
887 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt
888
889 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
890 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t
891
892 ! parent domain
893
894 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
895 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CZ3d,CQ
896 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CFIS,CPD
897 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD
898 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2
899 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CDETA1,CDETA2
900 REAL, INTENT(IN) :: CPDTOP,CPTOP
901
902 ! nested domain
903
904 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD ! This is T, here
905 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(IN) :: Z3d,Q
906 REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: FIS,PD
907 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD
908 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2
909 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: DETA1,DETA2
910 REAL,INTENT(IN) :: PDTOP,PTOP
911
912 ! local
913
914 INTEGER,PARAMETER :: JTB=134
915 REAL, PARAMETER :: LAPSR=6.5E-3,GI=1./G, D608=0.608
916 REAL, PARAMETER :: TRG=2.0*R_D*GI,COEF3=R_D*GI*LAPSR
917 INTEGER :: I,J,K,II,JJ
918 REAL :: TVOUT,PMO
919 REAL,DIMENSION(nims:nime,njms:njme) :: ZS
920 REAL,DIMENSION(JTB) :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
921 REAL, DIMENSION (nims:nime,nkms:nkme,njms:njme) :: CWK1,CWK2,CWK3,CWK4
922 !-----------------------------------------------------------------------------------------------------
923 !
924
925 !
926 ! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION
927 !
928 IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) &
929 CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
930
931 DO J=NJTS,MIN(NJTE,NJDE-1)
932 DO I=NITS,MIN(NITE,NIDE-1)
933 ZS(I,J)=FIS(I,J)*GI
934 ENDDO
935 ENDDO
936
937
938 ! X start boundary
939
940 NMM_XS: IF(NITS .EQ. NIDS)THEN
941 ! WRITE(0,*)'ENTERING X1 START BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1)
942 I = NIDS
943 DO J=NJTS,MIN(NJTE,NJDE-1)
944 IF(MOD(J,2) .NE. 0)THEN
945 ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline
946 !
947 DO K=NKTS,NKDE ! inputs at standard interface levels
948 PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop; redifined later
949 ZIN(K) = Z3d(I,NKDE-K+1,J)
950 ENDDO
951 !
952 Y2(1 )=0.
953 Y2(NKDE)=0.
954 !
955 DO K=NKDS,NKDE ! target points in model interface levels (pint)
956 PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
957 ENDDO
958 !
959 IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb
960 PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target
961 ZIN(NKDE) = ZS(I,J)
962 ENDIF
963
964 CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate
965
966 DO K=NKDS,NKDE-1
967 PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
968 TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG
969 CWK1(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain
970 ENDDO
971
972 ELSE
973 DO K=NKDS,NKDE-1
974 CWK1(I,K,J)=0.0
975 ENDDO
976 ENDIF
977 ENDDO
978
979 DO J = NJTS,MIN(NJTE,NJDE-1)
980 DO K = NKDS,NKDE-1
981 ntemp_b(i,k,j) = CWK1(I,K,J)
982 ntemp_bt(i,k,j) = 0.0
983 ! bdy(J,K,I,P_XSB) = CWK1(I,K,J) ! This will not work for NMM since
984 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
985 END DO
986 END DO
987
988 ENDIF NMM_XS
989
990
991 ! X end boundary
992
993
994 NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
995 ! WRITE(0,*)'ENTERING X END BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1)
996 I = NIDE-1
997 II = NIDE - I
998 DO J=NJTS,MIN(NJTE,NJDE-1)
999 IF(MOD(J,2) .NE. 0)THEN
1000 ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline
1001 !
1002 DO K=NKTS,NKDE ! inputs at standard interface levels;redifined later
1003 PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop
1004 ZIN(K) = Z3d(I,NKDE-K+1,J)
1005 ENDDO
1006 !
1007 Y2(1 )=0.
1008 Y2(NKDE)=0.
1009 !
1010 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1011 PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1012 ENDDO
1013 !
1014 IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb
1015 PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target
1016 ZIN(NKDE) = ZS(I,J)
1017 ENDIF
1018
1019 CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate
1020
1021 DO K=NKDS,NKDE-1
1022 PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
1023 TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG
1024 CWK2(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain
1025 ENDDO
1026
1027 ELSE
1028 DO K=NKDS,NKDE-1
1029 CWK2(I,K,J)=0.0
1030 ENDDO
1031 ENDIF
1032 ENDDO
1033
1034 DO J = NJTS,MIN(NJTE,NJDE-1)
1035 DO K = NKDS,NKDE-1
1036 ntemp_b(i,k,j) = CWK2(I,K,J)
1037 ntemp_bt(i,k,j) = 0.0
1038 ! bdy(J,K,I,P_XSB) = CWK2(I,K,J) ! This will not work for NMM since
1039 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
1040 ! if(k==1)WRITE(0,*)J,ntemp_b(i,k,j)
1041 END DO
1042 END DO
1043
1044 ENDIF NMM_XE
1045
1046 ! Y start boundary
1047
1048 NMM_YS: IF(NJTS .EQ. NJDS)THEN
1049 ! WRITE(0,*)'ENTERING Y START BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1)
1050 J = NJDS
1051 DO I=NITS,MIN(NITE,NIDE-1)
1052 ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline
1053 !
1054 DO K=NKDS,NKDE ! inputs at standard interface levels;redifined later
1055 PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop
1056 ZIN(K) = Z3d(I,NKDE-K+1,J)
1057 ENDDO
1058 !
1059 Y2(1 )=0.
1060 Y2(NKDE)=0.
1061 !
1062 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1063 PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1064 ENDDO
1065 !
1066 IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb
1067 PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target
1068 ZIN(NKDE) = ZS(I,J)
1069 ENDIF
1070
1071 CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate
1072
1073 DO K=NKDS,NKDE-1
1074 PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
1075 TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG
1076 CWK3(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain
1077 ENDDO
1078
1079 ENDDO
1080
1081 DO K = NKDS,NKDE-1
1082 DO I = NITS,MIN(NITE,NIDE-1)
1083 ntemp_b(i,k,j) = CWK3(I,K,J)
1084 ntemp_bt(i,k,j) = 0.0
1085 ! bdy(J,K,I,P_XSB) = CWK3(I,K,J) ! This will not work for NMM since
1086 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
1087 ! if(k==1)WRITE(0,*)I,ntemp_b(i,k,j)
1088 END DO
1089 END DO
1090
1091 ENDIF NMM_YS
1092
1093 ! Y end boundary
1094
1095 NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
1096 ! WRITE(0,*)'ENTERING Y END BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1)
1097 J = NJDE-1
1098 JJ = NJDE - J
1099 DO I=NITS,MIN(NITE,NIDE-1)
1100 ZIN=0.;Y2=0;PIO=0.;ZOUT=0.;DUM1=0.;DUM2=0. ! clean local array before use of spline
1101 !
1102 DO K=NKDS,NKDE ! inputs at standard interface levels;redifined later
1103 PIN(K) = PSTD(NKDE-K+1) ! please don't remove this from IJ loop
1104 ZIN(K) = Z3d(I,NKDE-K+1,J)
1105 ENDDO
1106 !
1107 Y2(1 )=0.
1108 Y2(NKDE)=0.
1109 !
1110 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1111 PIO(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1112 ENDDO
1113 !
1114 IF(PIO(1) .GE. PSTD(1))THEN ! if lower boundary is higher than 1000. mb
1115 PIN(NKDE) = PIO(1) ! re-set lower boundary to be consistent with target
1116 ZIN(NKDE) = ZS(I,J)
1117 ENDIF
1118
1119 CALL SPLINE2(I,J,JTB,NKDE,PIN,ZIN,Y2,NKDE,PIO,ZOUT,DUM1,DUM2) ! interpolate
1120
1121 DO K=NKDS,NKDE-1
1122 PMO = (PIO(K+1)+PIO(K))/(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
1123 TVOUT = (ZOUT(K+1)-ZOUT(K))*PMO/TRG
1124 CWK4(I,K,J)= TVOUT/(1.0+Q(I,K,J)*P608) ! temperature defined in the nested domain
1125 ENDDO
1126
1127 ENDDO
1128
1129 DO K = NKDS,NKDE-1
1130 DO I = NITS,MIN(NITE,NIDE-1)
1131 ntemp_b(i,k,j) = CWK4(I,K,J)
1132 ntemp_bt(i,k,j) = 0.0
1133 ! bdy(J,K,I,P_XSB) = CWK4(I,K,J) ! This will not work for NMM since
1134 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
1135 ! if(k==1)WRITE(0,*)I,ntemp_b(i,k,j)
1136 END DO
1137 END DO
1138
1139 ENDIF NMM_YE
1140 !
1141 END SUBROUTINE nmm_bdy_p2hyb
1142
1143 !=======================================================================================
1144 !
1145 ! ADDED FOR INCLUDING MOISTURE AND THERMODYNAMIC ENERGY BALANCE
1146 !
1147 !=======================================================================================
1148
1149 SUBROUTINE interp_scalar_nmm (cfld, & ! CD field
1150 cids,cide,ckds,ckde,cjds,cjde, &
1151 cims,cime,ckms,ckme,cjms,cjme, &
1152 cits,cite,ckts,ckte,cjts,cjte, &
1153 nfld, & ! ND field
1154 nids,nide,nkds,nkde,njds,njde, &
1155 nims,nime,nkms,nkme,njms,njme, &
1156 nits,nite,nkts,nkte,njts,njte, &
1157 shw, & ! stencil half width for interp
1158 imask, & ! interpolation mask
1159 xstag,ystag, & ! staggering of field
1160 ipos,jpos, & ! Position of lower left of nest in CD
1161 nri,nrj, & ! nest ratios
1162 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
1163 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
1164 CBWGT4, HBWGT4, & ! dummys for weights
1165 CC3d,C3d, &
1166 CPD,PD, &
1167 CPSTD,PSTD, &
1168 CPDTOP,PDTOP, &
1169 CPTOP,PTOP, &
1170 CETA1,ETA1,CETA2,ETA2 )
1171
1172 USE MODULE_MODEL_CONSTANTS
1173 USE module_timing
1174 IMPLICIT NONE
1175
1176 LOGICAL,INTENT(IN) :: xstag, ystag
1177 INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
1178 cims, cime, ckms, ckme, cjms, cjme, &
1179 cits, cite, ckts, ckte, cjts, cjte, &
1180 nids, nide, nkds, nkde, njds, njde, &
1181 nims, nime, nkms, nkme, njms, njme, &
1182 nits, nite, nkts, nkte, njts, njte, &
1183 shw,ipos,jpos,nri,nrj
1184
1185 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
1186
1187 ! parent domain
1188
1189 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
1190 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2
1191 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4
1192
1193 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
1194 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CC3d ! scalar input on constant pressure levels
1195 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD
1196 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CPD
1197 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2
1198 REAL, INTENT(IN) :: CPDTOP,CPTOP
1199
1200 ! nested domain
1201
1202 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH
1203 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2
1204 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4
1205
1206 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD ! This is scalar on hybrid levels
1207 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: C3d ! Scalar on constant pressure levels
1208 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD
1209 REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: PD
1210 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2
1211 REAL,INTENT(IN) :: PDTOP,PTOP
1212
1213 ! local
1214
1215 INTEGER,PARAMETER :: JTB=134
1216 INTEGER :: I,J,K
1217 REAL,DIMENSION(JTB) :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2
1218
1219 !-----------------------------------------------------------------------------------------------------
1220 !
1221 !
1222 ! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE OR LINEAR INTERPOLATION
1223 !
1224 IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) &
1225 CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
1226
1227 !
1228 ! FIRST, HORIZONTALLY INTERPOLATE MOISTURE NOW AVAILABLE ON CONSTANT PRESSURE SURFACE (LEVELS) FROM THE
1229 ! PARENT TO THE NESTED DOMAIN
1230 !
1231 !*** INDEX CONVENTIONS
1232 !*** HBWGT4
1233 !*** 4
1234 !***
1235 !***
1236 !***
1237 !*** h
1238 !*** 1 2
1239 !*** HBWGT1 HBWGT2
1240 !***
1241 !***
1242 !*** 3
1243 !*** HBWGT3
1244
1245 C3d=0.0
1246 DO J=NJTS,MIN(NJTE,NJDE-1)
1247 DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces
1248 DO I=NITS,MIN(NITE,NIDE-1)
1249 IF(IMASK(I,J) .NE. 1)THEN
1250 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
1251 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1252 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1253 + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) &
1254 + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1)
1255
1256 ELSE
1257 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1258 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1259 + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) &
1260 + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1)
1261
1262 ENDIF
1263 ENDIF
1264 ENDDO
1265 ENDDO
1266 ENDDO
1267
1268 !
1269 ! RECOVER THE SCALARS FROM CONSTANT PRESSURE SURFACES (LEVELS) ON TO HYBRID SURFACES
1270 !
1271 DO J=NJTS,MIN(NJTE,NJDE-1)
1272 DO I=NITS,MIN(NITE,NIDE-1)
1273 IF(IMASK(I,J) .NE. 1)THEN
1274 !
1275 ! clean local array before use of spline or linear interpolation
1276
1277 CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0.
1278 !
1279 DO K=NKDS+1,NKDE ! inputs at standard levels
1280 PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
1281 CIN(K-1) = C3d(I,NKDE-K+1,J)
1282 ENDDO
1283 !
1284 Y2(1 )=0.
1285 Y2(NKDE-1)=0.
1286 !
1287 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1288 PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1289 ENDDO
1290
1291 DO K=NKDS,NKDE-1 ! target points in model levels
1292 PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
1293 ENDDO
1294 !
1295
1296 IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary
1297 PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all
1298 WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
1299 WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
1300 ENDIF
1301
1302 CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate
1303
1304 DO K=1,NKDE-1
1305 NFLD(I,K,J)= COUT(K) ! scalar in the nested domain
1306 ENDDO
1307
1308 ! IF(I==1 .AND. J==1)THEN
1309 ! WRITE(0,*)
1310 ! WRITE(0,*)'IPOS=',IPOS,'JPOS=',JPOS
1311 ! DO K=NKTS,NKDE-1
1312 ! WRITE(0,*)'T and Q AFTER BALANCING',K,CFLD(IPOS,K,JPOS),NFLD(I,K,J), &
1313 ! CFLD(IPOS,K,JPOS)-NFLD(I,K,J)
1314 ! ENDDO
1315 ! ENDIF
1316 !
1317 ENDIF
1318 ENDDO
1319 ENDDO
1320
1321 END SUBROUTINE interp_scalar_nmm
1322 !
1323 !===========================================================================================
1324 !
1325 SUBROUTINE nmm_bdy_scalar (cfld, & ! CD field
1326 cids,cide,ckds,ckde,cjds,cjde, &
1327 cims,cime,ckms,ckme,cjms,cjme, &
1328 cits,cite,ckts,ckte,cjts,cjte, &
1329 nfld, & ! ND field
1330 nids,nide,nkds,nkde,njds,njde, &
1331 nims,nime,nkms,nkme,njms,njme, &
1332 nits,nite,nkts,nkte,njts,njte, &
1333 shw, & ! stencil half width for interp
1334 imask, & ! interpolation mask
1335 xstag,ystag, & ! staggering of field
1336 ipos,jpos, & ! Position of lower left of nest in CD
1337 nri,nrj, & ! nest ratios
1338 cbdy, nbdy, &
1339 cbdy_t, nbdy_t, &
1340 cdt, ndt, &
1341 CTEMP_B,NTEMP_B, & ! to be removed
1342 CTEMP_BT,NTEMP_BT, &
1343 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
1344 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
1345 CBWGT4, HBWGT4, & ! dummys for weights
1346 CC3d,C3d, &
1347 CPD,PD, &
1348 CPSTD,PSTD, &
1349 CPDTOP,PDTOP, &
1350 CPTOP,PTOP, &
1351 CETA1,ETA1,CETA2,ETA2 )
1352 USE MODULE_MODEL_CONSTANTS
1353 USE module_timing
1354 IMPLICIT NONE
1355
1356 LOGICAL,INTENT(IN) :: xstag, ystag
1357 REAL, INTENT(INOUT) :: cdt, ndt
1358 INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
1359 cims, cime, ckms, ckme, cjms, cjme, &
1360 cits, cite, ckts, ckte, cjts, cjte, &
1361 nids, nide, nkds, nkde, njds, njde, &
1362 nims, nime, nkms, nkme, njms, njme, &
1363 nits, nite, nkts, nkte, njts, njte, &
1364 shw,ipos,jpos,nri,nrj
1365 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: ctemp_b,ctemp_bt
1366 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(OUT) :: ntemp_b,ntemp_bt
1367 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t
1368
1369 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK
1370
1371 ! parent domain
1372
1373 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
1374 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2
1375 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4
1376 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CFLD
1377 REAL,DIMENSION(cims:cime,ckms:ckme,cjms:cjme), INTENT(IN) :: CC3d ! scalar input on constant pressure levels
1378 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD
1379 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CPD
1380 REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2
1381 REAL, INTENT(IN) :: CPDTOP,CPTOP
1382
1383 ! nested domain
1384
1385 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH
1386 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2
1387 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4
1388 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: NFLD
1389 REAL,DIMENSION(nims:nime,nkms:nkme,njms:njme), INTENT(OUT):: C3d !Scalar on constant pressure levels
1390 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD
1391 REAL,DIMENSION(nims:nime,njms:njme ), INTENT(IN) :: PD
1392 REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2
1393 REAL,INTENT(IN) :: PDTOP,PTOP
1394
1395 ! local
1396
1397 INTEGER,PARAMETER :: JTB=134
1398 INTEGER :: I,J,K,II,JJ
1399 REAL,DIMENSION(JTB) :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2
1400 REAL, DIMENSION (nims:nime,nkms:nkme,njms:njme) :: CWK1,CWK2,CWK3,CWK4
1401 !-----------------------------------------------------------------------------------------------------
1402 !
1403 !
1404 ! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION
1405 !
1406 IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) &
1407 CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm')
1408
1409 ! X start boundary
1410
1411 NMM_XS: IF(NITS .EQ. NIDS)THEN
1412 ! WRITE(0,*)'ENTERING X1 START BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1)
1413 I = NIDS
1414 DO J = NJTS,MIN(NJTE,NJDE-1)
1415 DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces
1416 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
1417 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1418 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1419 + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) &
1420 + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1)
1421 ELSE
1422 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1423 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1424 + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) &
1425 + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1)
1426 ENDIF
1427 ENDDO
1428 ENDDO
1429 !
1430 DO J=NJTS,MIN(NJTE,NJDE-1)
1431 IF(MOD(J,2) .NE. 0)THEN
1432 CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
1433 DO K=NKDS+1,NKDE ! inputs at standard levels
1434 PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
1435 CIN(K-1) = C3d(I,NKDE-K+1,J)
1436 ENDDO
1437 Y2(1 )=0.
1438 Y2(NKDE-1)=0.
1439 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1440 PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1441 ENDDO
1442 DO K=NKDS,NKDE-1 ! target points in model levels
1443 PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
1444 ENDDO
1445 IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary
1446 PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all
1447 WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
1448 WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
1449 ENDIF
1450
1451 CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate
1452
1453 DO K=1,NKDE-1
1454 CWK1(I,K,J)= COUT(K) ! scalar in the nested domain
1455 ENDDO
1456 ELSE
1457 DO K=NKDS,NKDE-1
1458 CWK1(I,K,J)=0.0
1459 ENDDO
1460 ENDIF
1461 ENDDO
1462
1463 DO J = NJTS,MIN(NJTE,NJDE-1)
1464 DO K = NKDS,NKDE-1
1465 ntemp_b(i,k,j) = CWK1(I,K,J)
1466 ntemp_bt(i,k,j) = 0.0
1467 ! bdy(J,K,I,P_XSB) = CWK1(I,K,J) ! This will not work for NMM since
1468 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
1469 END DO
1470 END DO
1471
1472 ENDIF NMM_XS
1473
1474
1475 ! X end boundary
1476
1477 NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
1478 ! WRITE(0,*)'ENTERING X END BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1)
1479 I = NIDE-1
1480 DO J = NJTS,MIN(NJTE,NJDE-1)
1481 DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces
1482 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
1483 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1484 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1485 + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) &
1486 + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1)
1487 ELSE
1488 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1489 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1490 + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) &
1491 + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1)
1492
1493 ENDIF
1494 ENDDO
1495 ENDDO
1496
1497 DO J=NJTS,MIN(NJTE,NJDE-1)
1498 IF(MOD(J,2) .NE. 0)THEN
1499 CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
1500 DO K=NKDS+1,NKDE ! inputs at standard levels
1501 PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
1502 CIN(K-1) = C3d(I,NKDE-K+1,J)
1503 ENDDO
1504 Y2(1 )=0.
1505 Y2(NKDE-1)=0.
1506 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1507 PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1508 ENDDO
1509 DO K=NKDS,NKDE-1 ! target points in model levels
1510 PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
1511 ENDDO
1512 IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary
1513 PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all
1514 WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
1515 WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
1516 ENDIF
1517
1518 CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate
1519
1520 DO K=1,NKDE-1
1521 CWK2(I,K,J)= COUT(K) ! scalar in the nested domain
1522 ENDDO
1523 ELSE
1524 DO K=NKDS,NKDE-1
1525 CWK2(I,K,J)=0.0
1526 ENDDO
1527 ENDIF
1528 ENDDO
1529
1530 DO J = NJTS,MIN(NJTE,NJDE-1)
1531 DO K = NKDS,MIN(NKTE,NKDE-1)
1532 ntemp_b(i,k,j) = CWK2(I,K,J)
1533 ntemp_bt(i,k,j) = 0.0
1534 ! bdy(J,K,I,P_XSB) = CWK2(I,K,J) ! This will not work for NMM since
1535 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
1536 ! if(k==1)WRITE(0,*)J,ntemp_b(i,k,j)
1537 END DO
1538 END DO
1539
1540 ENDIF NMM_XE
1541
1542 ! Y start boundary
1543
1544 NMM_YS: IF(NJTS .EQ. NJDS)THEN
1545 ! WRITE(0,*)'ENTERING Y START BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1)
1546 J = NJDS
1547 DO K=NKDS,NKDE-1
1548 DO I = NITS,MIN(NITE,NIDE-1)
1549 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
1550 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1551 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1552 + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) &
1553 + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1)
1554 ELSE
1555 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1556 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1557 + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) &
1558 + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1)
1559
1560 ENDIF
1561 ENDDO
1562 ENDDO
1563 !
1564 DO I=NITS,MIN(NITE,NIDE-1)
1565 CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
1566 DO K=NKDS+1,NKDE ! inputs at standard levels
1567 PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
1568 CIN(K-1) = C3d(I,NKDE-K+1,J)
1569 ENDDO
1570 Y2(1 )=0.
1571 Y2(NKDE-1)=0.
1572 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1573 PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1574 ENDDO
1575 DO K=NKDS,NKDE-1 ! target points in model levels
1576 PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
1577 ENDDO
1578 IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary
1579 PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all
1580 WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
1581 WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
1582 ENDIF
1583
1584 CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate
1585
1586 DO K=1,NKDE-1
1587 CWK3(I,K,J)= COUT(K) ! scalar in the nested domain
1588 ENDDO
1589 ENDDO
1590
1591 DO K = NKDS,NKDE-1
1592 DO I = NITS,MIN(NITE,NIDE-1)
1593 ntemp_b(i,k,j) = CWK3(I,K,J)
1594 ntemp_bt(i,k,j) = 0.0
1595 ! bdy(J,K,I,P_XSB) = CWK3(I,K,J) ! This will not work for NMM since
1596 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
1597 ENDDO
1598 ENDDO
1599
1600
1601 ENDIF NMM_YS
1602
1603 ! Y end boundary
1604
1605 NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
1606 ! WRITE(0,*)'ENTERING Y END BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1)
1607 J = NJDE-1
1608 DO K=NKDS,NKDE-1
1609 DO I = NITS,MIN(NITE,NIDE-1)
1610 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
1611 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1612 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1613 + HBWGT3(I,J)*CC3d(IIH(I,J), K, JJH(I,J)-1) &
1614 + HBWGT4(I,J)*CC3d(IIH(I,J), K, JJH(I,J)+1)
1615 ELSE
1616 C3d(I,K,J) = HBWGT1(I,J)*CC3d(IIH(I,J), K, JJH(I,J) ) &
1617 + HBWGT2(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J) ) &
1618 + HBWGT3(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)-1) &
1619 + HBWGT4(I,J)*CC3d(IIH(I,J)+1,K, JJH(I,J)+1)
1620
1621 ENDIF
1622 ENDDO
1623 ENDDO
1624
1625 DO I=NITS,MIN(NITE,NIDE-1)
1626 CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array
1627 DO K=NKDS+1,NKDE ! inputs at standard levels
1628 PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5)
1629 CIN(K-1) = C3d(I,NKDE-K+1,J)
1630 ENDDO
1631 Y2(1 )=0.
1632 Y2(NKDE-1)=0.
1633 DO K=NKDS,NKDE ! target points in model interface levels (pint)
1634 PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP
1635 ENDDO
1636 DO K=NKDS,NKDE-1 ! target points in model levels
1637 PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5)
1638 ENDDO
1639 IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary
1640 PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all
1641 WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
1642 WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
1643 ENDIF
1644
1645 CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate
1646
1647 DO K=1,NKDE-1
1648 CWK4(I,K,J)= COUT(K) ! scalar in the nested domain
1649 ENDDO
1650 ENDDO
1651
1652 DO K = NKDS,NKDE-1
1653 DO I = NITS,MIN(NITE,NIDE-1)
1654 ntemp_b(i,k,j) = CWK4(I,K,J)
1655 ntemp_bt(i,k,j) = 0.0
1656 ! bdy(J,K,I,P_XSB) = CWK4(I,K,J) ! This will not work for NMM since
1657 ! bdy_t(J,K,I,P_XSB) = 0.0 ! NMM requires BC halo exchanges
1658 ! if(k==1)WRITE(0,*)I,ntemp_b(i,k,j)
1659 END DO
1660 END DO
1661
1662 ENDIF NMM_YE
1663
1664 !
1665 END SUBROUTINE nmm_bdy_scalar
1666 !
1667 !
1668 !=======================================================================================
1669 SUBROUTINE SPLINE2(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q)
1670 !
1671 ! ******************************************************************
1672 ! * *
1673 ! * THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE *
1674 ! * PROGRAMED FOR A SMALL SCALAR MACHINE. *
1675 ! * *
1676 ! * PROGRAMER Z. JANJIC *
1677 ! * *
1678 ! * NOLD - NUMBER OF GIVEN VALUES OF THE FUNCTION. MUST BE GE 3. *
1679 ! * XOLD - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE *
1680 ! * FUNCTION ARE GIVEN. MUST BE IN ASCENDING ORDER. *
1681 ! * YOLD - THE GIVEN VALUES OF THE FUNCTION AT THE POINTS XOLD. *
1682 ! * Y2 - THE SECOND DERIVATIVES AT THE POINTS XOLD. IF NATURAL *
1683 ! * SPLINE IS FITTED Y2(1)=0. AND Y2(NOLD)=0. MUST BE *
1684 ! * SPECIFIED. *
1685 ! * NNEW - NUMBER OF VALUES OF THE FUNCTION TO BE CALCULATED. *
1686 ! * XNEW - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE *
1687 ! * FUNCTION ARE CALCULATED. XNEW(K) MUST BE GE XOLD(1) *
1688 ! * AND LE XOLD(NOLD). *
1689 ! * YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED. *
1690 ! * P, Q - AUXILIARY VECTORS OF THE LENGTH NOLD-2. *
1691 ! * *
1692 ! ******************************************************************
1693 !---------------------------------------------------------------------
1694 IMPLICIT NONE
1695 !---------------------------------------------------------------------
1696 INTEGER,INTENT(IN) :: I,J,JTBX,NNEW,NOLD
1697 REAL,DIMENSION(JTBX),INTENT(IN) :: XNEW,XOLD,YOLD
1698 REAL,DIMENSION(JTBX),INTENT(INOUT) :: P,Q,Y2
1699 REAL,DIMENSION(JTBX),INTENT(OUT) :: YNEW
1700 !
1701 INTEGER :: II,JJ,K,K1,K2,KOLD,NOLDM1
1702 REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR &
1703 ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
1704 !---------------------------------------------------------------------
1705
1706 ! debug
1707
1708 II=9999
1709 JJ=9999
1710 IF(I.eq.II.and.J.eq.JJ)THEN
1711 WRITE(0,*)'DEBUG in SPLINE2: I,J',I,J
1712 WRITE(0,*)'DEBUG in SPLINE2:HSO= ',xnew(1:nold)
1713 DO K=1,NOLD
1714 WRITE(0,*)'DEBUG in SPLINE2:L,ZETAI,PINTI= ' &
1715 ,K,YOLD(K),XOLD(K)
1716 ENDDO
1717 ENDIF
1718
1719 !
1720 NOLDM1=NOLD-1
1721 !
1722 DXL=XOLD(2)-XOLD(1)
1723 DXR=XOLD(3)-XOLD(2)
1724 DYDXL=(YOLD(2)-YOLD(1))/DXL
1725 DYDXR=(YOLD(3)-YOLD(2))/DXR
1726 RTDXC=0.5/(DXL+DXR)
1727 !
1728 P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1))
1729 Q(1)=-RTDXC*DXR
1730 !
1731 IF(NOLD.EQ.3)GO TO 150
1732 !---------------------------------------------------------------------
1733 K=3
1734 !
1735 100 DXL=DXR
1736 DYDXL=DYDXR
1737 DXR=XOLD(K+1)-XOLD(K)
1738 DYDXR=(YOLD(K+1)-YOLD(K))/DXR
1739 DXC=DXL+DXR
1740 DEN=1./(DXL*Q(K-2)+DXC+DXC)
1741 !
1742 P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2))
1743 Q(K-1)=-DEN*DXR
1744 !
1745 K=K+1
1746 IF(K.LT.NOLD)GO TO 100
1747 !-----------------------------------------------------------------------
1748 150 K=NOLDM1
1749 !
1750 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1)
1751 !
1752 K=K-1
1753 IF(K.GT.1)GO TO 200
1754 !-----------------------------------------------------------------------
1755 K1=1
1756 !
1757 300 XK=XNEW(K1)
1758 !
1759 DO 400 K2=2,NOLD
1760 !
1761 IF(XOLD(K2).GT.XK)THEN
1762 KOLD=K2-1
1763 GO TO 450
1764 ENDIF
1765 !
1766 400 CONTINUE
1767 !
1768 YNEW(K1)=YOLD(NOLD)
1769 GO TO 600
1770 !
1771 450 IF(K1.EQ.1)GO TO 500
1772 IF(K.EQ.KOLD)GO TO 550
1773 !
1774 500 K=KOLD
1775 !
1776 Y2K=Y2(K)
1777 Y2KP1=Y2(K+1)
1778 DX=XOLD(K+1)-XOLD(K)
1779 RDX=1./DX
1780 !
1781 AK=.1666667*RDX*(Y2KP1-Y2K)
1782 BK=0.5*Y2K
1783 CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K)
1784 !
1785 550 X=XK-XOLD(K)
1786 XSQ=X*X
1787 !
1788 YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K)
1789
1790 ! debug
1791
1792 IF(I.eq.II.and.J.eq.JJ)THEN
1793 WRITE(0,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', K1,XNEW(k1),YNEW(k1)
1794 ENDIF
1795
1796 !
1797 600 K1=K1+1
1798 IF(K1.LE.NNEW)GO TO 300
1799
1800 RETURN
1801
1802 END SUBROUTINE SPLINE2
1803
1804 !=======================================================================================
1805 ! E grid interpolation for H and V points
1806 !=======================================================================================
1807
1808 SUBROUTINE interp_h_nmm (cfld, & ! CD field
1809 cids, cide, ckds, ckde, cjds, cjde, &
1810 cims, cime, ckms, ckme, cjms, cjme, &
1811 cits, cite, ckts, ckte, cjts, cjte, &
1812 nfld, & ! ND field
1813 nids, nide, nkds, nkde, njds, njde, &
1814 nims, nime, nkms, nkme, njms, njme, &
1815 nits, nite, nkts, nkte, njts, njte, &
1816 shw, & ! stencil half width for interp
1817 imask, & ! interpolation mask
1818 xstag, ystag, & ! staggering of field
1819 ipos, jpos, & ! Position of lower left of nest in CD
1820 nri, nrj, & ! nest ratios
1821 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
1822 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
1823 CBWGT4, HBWGT4 ) ! dummys for weights
1824 USE module_timing
1825 IMPLICIT NONE
1826
1827 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
1828 cims, cime, ckms, ckme, cjms, cjme, &
1829 cits, cite, ckts, ckte, cjts, cjte, &
1830 nids, nide, nkds, nkde, njds, njde, &
1831 nims, nime, nkms, nkme, njms, njme, &
1832 nits, nite, nkts, nkte, njts, njte, &
1833 shw, &
1834 ipos, jpos, &
1835 nri, nrj
1836 LOGICAL, INTENT(IN) :: xstag, ystag
1837
1838 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
1839 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
1840 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
1841 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
1842 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
1843 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
1844 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
1845
1846 ! local
1847 INTEGER i,j,k
1848 !
1849 !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
1850 !
1851 DO J=NJTS,MIN(NJTE,NJDE-1)
1852 DO I=NITS,MIN(NITE,NIDE-1)
1853 IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) &
1854 CALL wrf_error_fatal ('hpoints:check domain bounds along x' )
1855 IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) &
1856 CALL wrf_error_fatal ('hpoints:check domain bounds along y' )
1857 ENDDO
1858 ENDDO
1859
1860 ! WRITE(23,*)'------------- MED NEST INITIAL 3 ----------------'
1861 ! DO J=NJTS,MIN(NJTE,NJDE-1)
1862 ! DO I=NITS,MIN(NITE,NIDE-1)
1863 ! WRITE(23,*)I,J,IMASK(I,J),NFLD(I,1,J)
1864 ! ENDDO
1865 ! ENDDO
1866 ! WRITE(23,*)
1867
1868 !
1869 !*** INDEX CONVENTIONS
1870 !*** HBWGT4
1871 !*** 4
1872 !***
1873 !***
1874 !***
1875 !*** h
1876 !*** 1 2
1877 !*** HBWGT1 HBWGT2
1878 !***
1879 !***
1880 !*** 3
1881 !*** HBWGT3
1882
1883 DO J=NJTS,MIN(NJTE,NJDE-1)
1884 DO K=NKDS,NKDE
1885 DO I=NITS,MIN(NITE,NIDE-1)
1886 IF(IMASK(I,J) .NE. 1)THEN
1887 !
1888 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
1889 NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
1890 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
1891 + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
1892 + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
1893 ELSE
1894 NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
1895 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
1896 + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
1897 + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
1898 ENDIF
1899 !
1900 ENDIF
1901 ENDDO
1902 ENDDO
1903 ENDDO
1904
1905 END SUBROUTINE interp_h_nmm
1906 !
1907 SUBROUTINE interp_v_nmm (cfld, & ! CD field
1908 cids, cide, ckds, ckde, cjds, cjde, &
1909 cims, cime, ckms, ckme, cjms, cjme, &
1910 cits, cite, ckts, ckte, cjts, cjte, &
1911 nfld, & ! ND field
1912 nids, nide, nkds, nkde, njds, njde, &
1913 nims, nime, nkms, nkme, njms, njme, &
1914 nits, nite, nkts, nkte, njts, njte, &
1915 shw, & ! stencil half width for interp
1916 imask, & ! interpolation mask
1917 xstag, ystag, & ! staggering of field
1918 ipos, jpos, & ! Position of lower left of nest in CD
1919 nri, nrj, & ! nest ratios
1920 CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights
1921 CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are
1922 CBWGT4, VBWGT4 ) ! dummys
1923 USE module_timing
1924 IMPLICIT NONE
1925
1926 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
1927 cims, cime, ckms, ckme, cjms, cjme, &
1928 cits, cite, ckts, ckte, cjts, cjte, &
1929 nids, nide, nkds, nkde, njds, njde, &
1930 nims, nime, nkms, nkme, njms, njme, &
1931 nits, nite, nkts, nkte, njts, njte, &
1932 shw, &
1933 ipos, jpos, &
1934 nri, nrj
1935 LOGICAL, INTENT(IN) :: xstag, ystag
1936
1937 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
1938 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
1939 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
1940 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
1941 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
1942 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV
1943 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
1944
1945 ! local
1946 INTEGER i,j,k
1947
1948
1949 !
1950 !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
1951 !
1952 DO J=NJTS,MIN(NJTE,NJDE-1)
1953 DO I=NITS,MIN(NITE,NIDE-1)
1954 IF(IIV(i,j).LT.(CIDS-shw) .OR. IIV(i,j).GT.(CIDE+shw)) &
1955 CALL wrf_error_fatal ('vpoints:check domain bounds along x' )
1956 IF(JJV(i,j).LT.(CJDS-shw) .OR. JJV(i,j).GT.(CJDE+shw)) &
1957 CALL wrf_error_fatal ('vpoints:check domain bounds along y' )
1958 ENDDO
1959 ENDDO
1960
1961 ! WRITE(24,*)'------------- MED NEST INITIAL 4 ----------------'
1962 ! DO J=NJTS,MIN(NJTE,NJDE-1)
1963 ! DO I=NITS,MIN(NITE,NIDE-1)
1964 ! WRITE(24,*)I,J,IMASK(I,J),NFLD(I,1,J)
1965 ! ENDDO
1966 ! ENDDO
1967 ! WRITE(24,*)
1968
1969 !
1970 !*** INDEX CONVENTIONS
1971 !*** VBWGT4
1972 !*** 4
1973 !***
1974 !***
1975 !***
1976 !*** h
1977 !*** 1 2
1978 !*** VBWGT1 VBWGT2
1979 !***
1980 !***
1981 !*** 3
1982 !*** VBWGT3
1983
1984
1985 DO J=NJTS,MIN(NJTE,NJDE-1)
1986 DO K=NKDS,NKDE
1987 DO I=NITS,MIN(NITE,NIDE-1)
1988 IF(IMASK(I,J) .NE. 1)THEN
1989 !
1990 IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7
1991 NFLD(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) &
1992 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) &
1993 + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) &
1994 + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1)
1995 ELSE
1996 NFLD(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) &
1997 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) &
1998 + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) &
1999 + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1)
2000 ENDIF
2001 !
2002 ENDIF
2003 ENDDO
2004 ENDDO
2005 ENDDO
2006
2007 END SUBROUTINE interp_v_nmm
2008 !
2009 !=======================================================================================
2010 ! E grid nearest neighbour interpolation for H points
2011 !=======================================================================================
2012 !
2013 SUBROUTINE interp_hnear_nmm (cfld, & ! CD field
2014 cids, cide, ckds, ckde, cjds, cjde, &
2015 cims, cime, ckms, ckme, cjms, cjme, &
2016 cits, cite, ckts, ckte, cjts, cjte, &
2017 nfld, & ! ND field
2018 nids, nide, nkds, nkde, njds, njde, &
2019 nims, nime, nkms, nkme, njms, njme, &
2020 nits, nite, nkts, nkte, njts, njte, &
2021 shw, & ! stencil half width for interp
2022 imask, & ! interpolation mask
2023 xstag, ystag, & ! staggering of field
2024 ipos, jpos, & ! Position of lower left of nest in CD
2025 nri, nrj, & ! nest ratios
2026 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
2027 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
2028 CBWGT4, HBWGT4 ) ! just dummys
2029 USE module_timing
2030 IMPLICIT NONE
2031
2032 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2033 cims, cime, ckms, ckme, cjms, cjme, &
2034 cits, cite, ckts, ckte, cjts, cjte, &
2035 nids, nide, nkds, nkde, njds, njde, &
2036 nims, nime, nkms, nkme, njms, njme, &
2037 nits, nite, nkts, nkte, njts, njte, &
2038 shw, &
2039 ipos, jpos, &
2040 nri, nrj
2041 LOGICAL, INTENT(IN) :: xstag, ystag
2042
2043 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
2044 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
2045 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
2046 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
2047 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2048 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
2049 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
2050
2051 ! local
2052
2053 LOGICAL FLIP
2054 INTEGER i,j,k,n
2055 REAL SUM,AMAXVAL
2056 REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT
2057
2058
2059 ! WRITE(25,*)'------------- MED NEST INITIAL 5 ----------------'
2060 ! DO J=NJTS,MIN(NJTE,NJDE-1)
2061 ! DO I=NITS,MIN(NITE,NIDE-1)
2062 ! WRITE(25,*)I,J,IMASK(I,J),NFLD(I,1,J)
2063 ! ENDDO
2064 ! ENDDO
2065 ! WRITE(25,*)
2066
2067 !
2068 !*** INDEX CONVENTIONS
2069 !*** NBWGT4=0
2070 !*** 4
2071 !***
2072 !***
2073 !***
2074 !*** h
2075 !*** 1 2
2076 !*** NBWGT1=1 NBWGT2=0
2077 !***
2078 !***
2079 !*** 3
2080 !*** NBWGT3=0
2081
2082 DO J=NJTS,MIN(NJTE,NJDE-1)
2083 DO I=NITS,MIN(NITE,NIDE-1)
2084 IF(IMASK(I,J) .NE. 1)THEN
2085 NBWGT(1,I,J)=HBWGT1(I,J)
2086 NBWGT(2,I,J)=HBWGT2(I,J)
2087 NBWGT(3,I,J)=HBWGT3(I,J)
2088 NBWGT(4,I,J)=HBWGT4(I,J)
2089 ENDIF
2090 ENDDO
2091 ENDDO
2092
2093 DO J=NJTS,MIN(NJTE,NJDE-1)
2094 DO I=NITS,MIN(NITE,NIDE-1)
2095 IF(IMASK(I,J) .NE. 1)THEN
2096 !
2097 AMAXVAL=0.
2098 DO N=1,4
2099 AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
2100 ENDDO
2101 !
2102 FLIP=.TRUE.
2103 SUM=0.0
2104 DO N=1,4
2105 IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
2106 NBWGT(N,I,J)=1.0
2107 FLIP=.FALSE.
2108 ELSE
2109 NBWGT(N,I,J)=0.0
2110 ENDIF
2111 SUM=SUM+NBWGT(N,I,J)
2112 IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
2113 ENDDO
2114 !
2115 ENDIF
2116 ENDDO
2117 ENDDO
2118
2119 DO J=NJTS,MIN(NJTE,NJDE-1)
2120 DO K=NKDS,NKDE
2121 DO I=NITS,MIN(NITE,NIDE-1)
2122 IF(IMASK(I,J) .NE. 1)THEN
2123 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
2124 NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2125 + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2126 + NBWGT(3,I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
2127 + NBWGT(4,I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
2128 ELSE
2129 NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2130 + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2131 + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
2132 + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
2133
2134 ENDIF
2135 !
2136 ENDIF
2137 ENDDO
2138 ENDDO
2139 ENDDO
2140
2141 END SUBROUTINE interp_hnear_nmm
2142 !
2143 !=======================================================================================
2144 ! E grid nearest neighbour interpolation for integer H points
2145 !=======================================================================================
2146 !
2147 SUBROUTINE interp_int_hnear_nmm (cfld, & ! CD field; integers
2148 cids, cide, ckds, ckde, cjds, cjde, &
2149 cims, cime, ckms, ckme, cjms, cjme, &
2150 cits, cite, ckts, ckte, cjts, cjte, &
2151 nfld, & ! ND field; integers
2152 nids, nide, nkds, nkde, njds, njde, &
2153 nims, nime, nkms, nkme, njms, njme, &
2154 nits, nite, nkts, nkte, njts, njte, &
2155 shw, & ! stencil half width for interp
2156 imask, & ! interpolation mask
2157 xstag, ystag, & ! staggering of field
2158 ipos, jpos, & ! lower left of nest in CD
2159 nri, nrj, & ! nest ratios
2160 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! s-w grid locs and weights
2161 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
2162 CBWGT4, HBWGT4 ) ! just dummys
2163 USE module_timing
2164 IMPLICIT NONE
2165
2166 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2167 cims, cime, ckms, ckme, cjms, cjme, &
2168 cits, cite, ckts, ckte, cjts, cjte, &
2169 nids, nide, nkds, nkde, njds, njde, &
2170 nims, nime, nkms, nkme, njms, njme, &
2171 nits, nite, nkts, nkte, njts, njte, &
2172 shw, &
2173 ipos, jpos, &
2174 nri, nrj
2175 LOGICAL, INTENT(IN) :: xstag, ystag
2176
2177 INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
2178 INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
2179 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
2180 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
2181 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2182 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
2183 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
2184
2185 ! local
2186
2187 LOGICAL FLIP
2188 INTEGER i,j,k,n
2189 REAL SUM,AMAXVAL
2190 REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT
2191
2192
2193
2194 ! WRITE(26,*)'------------- MED NEST INITIAL 6 ----------------'
2195 ! DO J=NJTS,MIN(NJTE,NJDE-1)
2196 ! DO I=NITS,MIN(NITE,NIDE-1)
2197 ! WRITE(26,*)I,J,IMASK(I,J),NFLD(I,1,J)
2198 ! ENDDO
2199 ! ENDDO
2200 ! WRITE(26,*)
2201
2202 !
2203 !*** INDEX CONVENTIONS
2204 !*** NBWGT4=0
2205 !*** 4
2206 !***
2207 !***
2208 !***
2209 !*** h
2210 !*** 1 2
2211 !*** NBWGT1=1 NBWGT2=0
2212 !***
2213 !***
2214 !*** 3
2215 !*** NBWGT3=0
2216
2217 DO J=NJTS,MIN(NJTE,NJDE-1)
2218 DO I=NITS,MIN(NITE,NIDE-1)
2219 IF(IMASK(I,J) .NE. 1)THEN
2220 NBWGT(1,I,J)=HBWGT1(I,J)
2221 NBWGT(2,I,J)=HBWGT2(I,J)
2222 NBWGT(3,I,J)=HBWGT3(I,J)
2223 NBWGT(4,I,J)=HBWGT4(I,J)
2224 ENDIF
2225 ENDDO
2226 ENDDO
2227
2228 DO J=NJTS,MIN(NJTE,NJDE-1)
2229 DO I=NITS,MIN(NITE,NIDE-1)
2230 IF(IMASK(I,J) .NE. 1)THEN
2231 !
2232 AMAXVAL=0.
2233 DO N=1,4
2234 AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL)
2235 ENDDO
2236 !
2237 FLIP=.TRUE.
2238 SUM=0.0
2239 DO N=1,4
2240 IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN
2241 NBWGT(N,I,J)=1.0
2242 FLIP=.FALSE.
2243 ELSE
2244 NBWGT(N,I,J)=0.0
2245 ENDIF
2246 SUM=SUM+NBWGT(N,I,J)
2247 IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" )
2248 ENDDO
2249 !
2250 ENDIF
2251 ENDDO
2252 ENDDO
2253
2254 DO J=NJTS,MIN(NJTE,NJDE-1)
2255 DO K=NKTS,NKTS
2256 DO I=NITS,MIN(NITE,NIDE-1)
2257 !
2258 IF(IMASK(I,J) .NE. 1)THEN
2259 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
2260 NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2261 + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2262 + NBWGT(3,I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
2263 + NBWGT(4,I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
2264 ELSE
2265 NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2266 + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2267 + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
2268 + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
2269
2270 ENDIF
2271 !
2272 ENDIF
2273 ENDDO
2274 ENDDO
2275 ENDDO
2276
2277 END SUBROUTINE interp_int_hnear_nmm
2278 !
2279 !--------------------------------------------------------------------------------------
2280
2281 SUBROUTINE nmm_bdy_hinterp (cfld, & ! CD field
2282 cids, cide, ckds, ckde, cjds, cjde, &
2283 cims, cime, ckms, ckme, cjms, cjme, &
2284 cits, cite, ckts, ckte, cjts, cjte, &
2285 nfld, & ! ND field
2286 nids, nide, nkds, nkde, njds, njde, &
2287 nims, nime, nkms, nkme, njms, njme, &
2288 nits, nite, nkts, nkte, njts, njte, &
2289 shw, & ! stencil half width
2290 imask, & ! interpolation mask
2291 xstag, ystag, & ! staggering of field
2292 ipos, jpos, & ! Position of lower left of nest in CD
2293 nri, nrj, & ! nest ratios
2294 cbdy, nbdy, &
2295 cbdy_t, nbdy_t, &
2296 cdt, ndt, &
2297 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
2298 CTEMP_BT,NTEMP_BT, & ! later on
2299 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
2300 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
2301 CBWGT4, HBWGT4 ) ! dummys
2302
2303 USE module_configure
2304 USE module_wrf_error
2305
2306 IMPLICIT NONE
2307
2308
2309 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2310 cims, cime, ckms, ckme, cjms, cjme, &
2311 cits, cite, ckts, ckte, cjts, cjte, &
2312 nids, nide, nkds, nkde, njds, njde, &
2313 nims, nime, nkms, nkme, njms, njme, &
2314 nits, nite, nkts, nkte, njts, njte, &
2315 shw, &
2316 ipos, jpos, &
2317 nri, nrj
2318
2319 LOGICAL, INTENT(IN) :: xstag, ystag
2320
2321 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
2322 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
2323 !
2324 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: ctemp_b,ctemp_bt
2325 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: ntemp_b,ntemp_bt
2326 !
2327 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
2328 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t
2329 REAL cdt, ndt
2330 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
2331 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
2332 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2333 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
2334 ! Local
2335
2336 INTEGER nijds, nijde, spec_bdy_width,i,j,k
2337
2338 nijds = min(nids, njds)
2339 nijde = max(nide, njde)
2340 CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
2341
2342
2343 CALL nmm_bdy_interp1( cfld, & ! CD field
2344 cids, cide, ckds, ckde, cjds, cjde, &
2345 cims, cime, ckms, ckme, cjms, cjme, &
2346 cits, cite, ckts, ckte, cjts, cjte, &
2347 nfld, & ! ND field
2348 nijds, nijde , spec_bdy_width , &
2349 nids, nide, nkds, nkde, njds, njde, &
2350 nims, nime, nkms, nkme, njms, njme, &
2351 nits, nite, nkts, nkte, njts, njte, &
2352 shw, imask, &
2353 xstag, ystag, & ! staggering of field
2354 ipos, jpos, & ! Position of lower left of nest in CD
2355 nri, nrj, &
2356 cdt, ndt, &
2357 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
2358 CTEMP_BT,NTEMP_BT, & ! later on
2359 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
2360 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
2361 CBWGT4, HBWGT4 ) ! dummys
2362
2363 RETURN
2364
2365 END SUBROUTINE nmm_bdy_hinterp
2366
2367 !----------------------------------------------------------------------------------------------------
2368 SUBROUTINE nmm_bdy_interp1( cfld, & ! CD field
2369 cids, cide, ckds, ckde, cjds, cjde, &
2370 cims, cime, ckms, ckme, cjms, cjme, &
2371 cits, cite, ckts, ckte, cjts, cjte, &
2372 nfld, & ! ND field
2373 nijds, nijde, spec_bdy_width , &
2374 nids, nide, nkds, nkde, njds, njde, &
2375 nims, nime, nkms, nkme, njms, njme, &
2376 nits, nite, nkts, nkte, njts, njte, &
2377 shw1, &
2378 imask, & ! interpolation mask
2379 xstag, ystag, & ! staggering of field
2380 ipos, jpos, & ! Position of lower left of nest in CD
2381 nri, nrj, &
2382 cdt, ndt, &
2383 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
2384 CTEMP_BT,NTEMP_BT, & ! later on
2385 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
2386 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
2387 CBWGT4, HBWGT4 ) ! dummys
2388
2389 use module_state_description
2390 IMPLICIT NONE
2391
2392 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2393 cims, cime, ckms, ckme, cjms, cjme, &
2394 cits, cite, ckts, ckte, cjts, cjte, &
2395 nids, nide, nkds, nkde, njds, njde, &
2396 nims, nime, nkms, nkme, njms, njme, &
2397 nits, nite, nkts, nkte, njts, njte, &
2398 shw1, & ! ignore
2399 ipos, jpos, &
2400 nri, nrj
2401 INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width
2402 LOGICAL, INTENT(IN) :: xstag, ystag
2403
2404 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
2405 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld
2406 !
2407 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: ctemp_b,ctemp_bt
2408 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: ntemp_b,ntemp_bt
2409 !
2410 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
2411 REAL :: cdt, ndt
2412 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
2413 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
2414 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2415 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
2416
2417 ! local
2418
2419 INTEGER :: i,j,k,ii,jj
2420 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: cwk1,cwk2,cwk3,cwk4
2421
2422 ! X start boundary
2423
2424 NMM_XS: IF(NITS .EQ. NIDS)THEN
2425 ! WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
2426 I = NIDS
2427 DO J = NJTS,MIN(NJTE,NJDE-1)
2428 DO K = NKDS,NKDE
2429 IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of nested domain
2430 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
2431 CWK1(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2432 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2433 + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
2434 + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
2435
2436
2437 ELSE
2438 CWK1(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2439 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2440 + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
2441 + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
2442 ENDIF
2443 ELSE
2444 CWK1(I,K,J) = 0.0 ! even rows at mass points of the nested domain
2445 ENDIF
2446 ntemp_b(i,k,j) = CWK1(I,K,J)
2447 ntemp_bt(i,k,j) = 0.0
2448 ! bdy(J,K,I,P_XSB) = CWK1(I,K,J) ! This will not work for NMM core
2449 ! bdy_t(J,K,I,P_XSB) = 0.0 ! since NMM requires BC halos
2450 END DO
2451 END DO
2452 ENDIF NMM_XS
2453
2454 ! X end boundary
2455
2456 NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
2457 ! WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1)
2458 I = NIDE-1
2459 DO J = NJTS,MIN(NJTE,NJDE-1)
2460 DO K = NKDS,NKDE
2461 IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of the nested domain
2462 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
2463 CWK2(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2464 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2465 + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
2466 + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
2467 ELSE
2468 CWK2(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2469 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2470 + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
2471 + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
2472
2473 ENDIF
2474 ELSE
2475 CWK2(I,K,J) = 0.0 ! even rows at mass points
2476 ENDIF
2477 II = NIDE - I
2478 ntemp_b(i,k,j) = CWK2(I,K,J)
2479 ntemp_bt(i,k,j) = 0.0
2480 ! bdy(J,K,II,P_XEB) = CWK2(I,K,J)
2481 ! bdy_t(J,K,II,P_XEB)= 0.0
2482 END DO
2483 END DO
2484 ENDIF NMM_XE
2485
2486 ! Y start boundary
2487
2488 NMM_YS: IF(NJTS .EQ. NJDS)THEN
2489 ! WRITE(0,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
2490 J = NJDS
2491 DO K = NKDS, NKDE
2492 DO I = NITS,MIN(NITE,NIDE-1)
2493 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
2494 CWK3(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2495 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2496 + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
2497 + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
2498 ELSE
2499 CWK3(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2500 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2501 + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
2502 + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
2503
2504 ENDIF
2505 ntemp_b(i,k,j) = CWK3(I,K,J)
2506 ntemp_bt(i,k,j) = 0.0
2507 ! bdy(I,K,J,P_YSB) = CWK3(I,K,J)
2508 ! bdy_t(I,K,J,P_YSB) = 0.0
2509 END DO
2510 END DO
2511 END IF NMM_YS
2512
2513 ! Y end boundary
2514
2515 NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
2516 ! WRITE(0,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1)
2517 J = NJDE-1
2518 DO K = NKDS,NKDE
2519 DO I = NITS,MIN(NITE,NIDE-1)
2520 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
2521 CWK4(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2522 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2523 + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
2524 + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
2525 ELSE
2526 CWK4(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2527 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2528 + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
2529 + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
2530
2531 ENDIF
2532 JJ = NJDE - J
2533 ntemp_b(i,k,j) = CWK4(I,K,J)
2534 ntemp_bt(i,k,j) = 0.0
2535 ! bdy(I,K,JJ,P_YEB) = CWK4(I,K,J)
2536 ! bdy_t(I,K,JJ,P_YEB) = 0.0
2537 END DO
2538 END DO
2539 END IF NMM_YE
2540
2541 RETURN
2542
2543 END SUBROUTINE nmm_bdy_interp1
2544
2545 !--------------------------------------------------------------------------------------
2546
2547 SUBROUTINE nmm_bdy_vinterp ( cfld, & ! CD field
2548 cids, cide, ckds, ckde, cjds, cjde, &
2549 cims, cime, ckms, ckme, cjms, cjme, &
2550 cits, cite, ckts, ckte, cjts, cjte, &
2551 nfld, & ! ND field
2552 nids, nide, nkds, nkde, njds, njde, &
2553 nims, nime, nkms, nkme, njms, njme, &
2554 nits, nite, nkts, nkte, njts, njte, &
2555 shw, & ! stencil half width
2556 imask, & ! interpolation mask
2557 xstag, ystag, & ! staggering of field
2558 ipos, jpos, & ! Position of lower left of nest in CD
2559 nri, nrj, & ! nest ratios
2560 cbdy, nbdy, &
2561 cbdy_t, nbdy_t, &
2562 cdt, ndt, &
2563 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
2564 CTEMP_BT,NTEMP_BT, & ! later on
2565 CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights
2566 CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are
2567 CBWGT4, VBWGT4 ) ! dummys
2568
2569 USE module_configure
2570 USE module_wrf_error
2571
2572 IMPLICIT NONE
2573
2574
2575 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2576 cims, cime, ckms, ckme, cjms, cjme, &
2577 cits, cite, ckts, ckte, cjts, cjte, &
2578 nids, nide, nkds, nkde, njds, njde, &
2579 nims, nime, nkms, nkme, njms, njme, &
2580 nits, nite, nkts, nkte, njts, njte, &
2581 shw, &
2582 ipos, jpos, &
2583 nri, nrj
2584
2585 LOGICAL, INTENT(IN) :: xstag, ystag
2586
2587 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
2588 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
2589 !
2590 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: ctemp_b,ctemp_bt
2591 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: ntemp_b,ntemp_bt
2592 !
2593 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
2594 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy, cbdy_t, nbdy, nbdy_t
2595 REAL cdt, ndt
2596 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
2597 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
2598 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2599 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV
2600
2601 ! Local
2602
2603 INTEGER nijds, nijde, spec_bdy_width
2604
2605 nijds = min(nids, njds)
2606 nijde = max(nide, njde)
2607 CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
2608
2609 CALL nmm_bdy_interp2( cfld, & ! CD field
2610 cids, cide, ckds, ckde, cjds, cjde, &
2611 cims, cime, ckms, ckme, cjms, cjme, &
2612 cits, cite, ckts, ckte, cjts, cjte, &
2613 nfld, & ! ND field
2614 nijds, nijde , spec_bdy_width , &
2615 nids, nide, nkds, nkde, njds, njde, &
2616 nims, nime, nkms, nkme, njms, njme, &
2617 nits, nite, nkts, nkte, njts, njte, &
2618 shw, imask, &
2619 xstag, ystag, & ! staggering of field
2620 ipos, jpos, & ! Position of lower left of nest in CD
2621 nri, nrj, &
2622 cdt, ndt, &
2623 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
2624 CTEMP_BT,NTEMP_BT, & ! later on
2625 CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights
2626 CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are
2627 CBWGT4, VBWGT4 ) ! dummys
2628 RETURN
2629
2630 END SUBROUTINE nmm_bdy_vinterp
2631
2632 !----------------------------------------------------------------------------------------------------
2633 SUBROUTINE nmm_bdy_interp2( cfld, & ! CD field
2634 cids, cide, ckds, ckde, cjds, cjde, &
2635 cims, cime, ckms, ckme, cjms, cjme, &
2636 cits, cite, ckts, ckte, cjts, cjte, &
2637 nfld, & ! ND field
2638 nijds, nijde, spec_bdy_width , &
2639 nids, nide, nkds, nkde, njds, njde, &
2640 nims, nime, nkms, nkme, njms, njme, &
2641 nits, nite, nkts, nkte, njts, njte, &
2642 shw1, &
2643 imask, & ! interpolation mask
2644 xstag, ystag, & ! staggering of field
2645 ipos, jpos, & ! Position of lower left of nest in CD
2646 nri, nrj, &
2647 cdt, ndt, &
2648 CTEMP_B,NTEMP_B, & ! These temp arrays should be removed
2649 CTEMP_BT,NTEMP_BT, & ! later on
2650 CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights
2651 CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are
2652 CBWGT4, VBWGT4 )
2653
2654 use module_state_description
2655 IMPLICIT NONE
2656
2657 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2658 cims, cime, ckms, ckme, cjms, cjme, &
2659 cits, cite, ckts, ckte, cjts, cjte, &
2660 nids, nide, nkds, nkde, njds, njde, &
2661 nims, nime, nkms, nkme, njms, njme, &
2662 nits, nite, nkts, nkte, njts, njte, &
2663 shw1, & ! ignore
2664 ipos, jpos, &
2665 nri, nrj
2666 INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width
2667 LOGICAL, INTENT(IN) :: xstag, ystag
2668
2669 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
2670 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld
2671 !
2672 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: ctemp_b,ctemp_bt
2673 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: ntemp_b,ntemp_bt
2674 !
2675 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
2676 REAL :: cdt, ndt
2677 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
2678 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
2679 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2680 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV
2681
2682 ! local
2683
2684 INTEGER :: i,j,k,ii,jj
2685 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: cwk1,cwk2,cwk3,cwk4
2686
2687 ! X start boundary
2688
2689 NMM_XS: IF(NITS .EQ. NIDS)THEN
2690 ! WRITE(0,*)'ENTERING X START BOUNDARY AT VELOCITY POINTS',NITS,NIDS,NJTS,MIN(NJTE,NJDE-1)
2691 I = NIDS
2692 DO J = NJTS,MIN(NJTE,NJDE-1)
2693 DO K = NKDS,NKDE
2694 IF(MOD(J,2) .EQ.0)THEN ! 1,3,5,7 of nested domain
2695 IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
2696 CWK1(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) &
2697 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) &
2698 + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) &
2699 + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1)
2700 ELSE
2701 CWK1(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) &
2702 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) &
2703 + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) &
2704 + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1)
2705 ENDIF
2706 ELSE
2707 CWK1(I,K,J) = 0.0 ! odd rows along J, at mass points have zero velocity
2708 ENDIF
2709 ntemp_b(i,k,j) = CWK1(I,K,J)
2710 ntemp_bt(i,k,j) = 0.0
2711 ! bdy(J,K,I,P_XSB) = CWK1(I,K,J)
2712 ! bdy_t(J,K,I,P_XSB) = 0.0
2713 ! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J)
2714 ! IF(k==1)WRITE(0,*)i,j,ntemp_b(i,k,j)
2715 END DO
2716 END DO
2717 ENDIF NMM_XS
2718
2719 ! X end boundary
2720
2721 NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN
2722 ! WRITE(0,*)'ENTERING X END BOUNDARY AT VELOCITY POINTS',NITE-1,NIDE-1,NJTS,MIN(NJTE,NJDE-1)
2723 I = NIDE-1
2724 DO J = NJTS,MIN(NJTE,NJDE-1)
2725 DO K = NKDS,NKDE
2726 IF(MOD(J,2) .EQ.0)THEN ! 1,3,5,7 of the nested domain
2727 IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain
2728 CWK2(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) &
2729 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) &
2730 + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) &
2731 + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1)
2732 ELSE
2733 CWK2(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) &
2734 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) &
2735 + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) &
2736 + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1)
2737 ENDIF
2738 ELSE
2739 CWK2(I,K,J) = 0.0 ! odd rows at mass points
2740 ENDIF
2741 II = NIDE - I
2742 ntemp_b(i,k,j) = CWK2(I,K,J)
2743 ntemp_bt(i,k,j) = 0.0
2744 ! bdy(J,K,II,P_XEB) = CWK2(I,K,J)
2745 ! bdy_t(J,K,II,P_XEB)= 0.0
2746 ! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J)
2747 ! IF(k==1)WRITE(0,*)i,j,ntemp_b(i,k,j)
2748 END DO
2749 END DO
2750 ENDIF NMM_XE
2751
2752 ! Y start boundary
2753
2754 NMM_YS: IF(NJTS .EQ. NJDS)THEN
2755 ! WRITE(0,*)'ENTERING Y START BOUNDARY AT VELOCITY POINTS',NJTS,NJDS,NITS,MIN(NITE,NIDE-1)
2756 J = NJDS
2757 DO K = NKDS, NKDE
2758 DO I = NITS,MIN(NITE,NIDE-2) ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL
2759 IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7
2760 CWK3(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) &
2761 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) &
2762 + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) &
2763 + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1)
2764 ELSE
2765 CWK3(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) &
2766 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) &
2767 + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) &
2768 + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1)
2769 ENDIF
2770 ntemp_b(i,k,j) = CWK3(I,K,J)
2771 ntemp_bt(i,k,j) = 0.0
2772 ! bdy(I,K,J,P_YSB) = CWK3(I,K,J)
2773 ! bdy_t(I,K,J,P_YSB) = 0.0
2774 ! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J)
2775 END DO
2776 END DO
2777 END IF NMM_YS
2778
2779 ! Y end boundary
2780
2781 NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN
2782 ! WRITE(0,*)'ENTERING Y END BOUNDARY AT VELOCITY POINTS',NJTE-1,NJDE-1,NITS,MIN(NITE,NIDE-1)
2783 J = NJDE-1
2784 DO K = NKDS,NKDE
2785 DO I = NITS,MIN(NITE,NIDE-2) ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL
2786 IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7
2787 CWK4(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K, JJV(I,J) ) &
2788 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J) ) &
2789 + VBWGT3(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)-1) &
2790 + VBWGT4(I,J)*CFLD(IIV(I,J)+1,K, JJV(I,J)+1)
2791 ELSE
2792 CWK4(I,K,J) = VBWGT1(I,J)*CFLD(IIV(I,J), K,JJV(I,J) ) &
2793 + VBWGT2(I,J)*CFLD(IIV(I,J)+1,K,JJV(I,J) ) &
2794 + VBWGT3(I,J)*CFLD(IIV(I,J), K,JJV(I,J)-1) &
2795 + VBWGT4(I,J)*CFLD(IIV(I,J), K,JJV(I,J)+1)
2796 ENDIF
2797 JJ = NJDE - J
2798 ntemp_b(i,k,j) = CWK4(I,K,J)
2799 ntemp_bt(i,k,j) = 0.0
2800 ! bdy(I,K,JJ,P_YEB) = CWK4(I,K,J)
2801 ! bdy_t(I,K,JJ,P_YEB) = 0.0
2802 ! IF(k==1)WRITE(0,*)IIV(I,J),JJV(I,J),i,j,VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J)
2803 END DO
2804 END DO
2805 END IF NMM_YE
2806
2807 RETURN
2808
2809 END SUBROUTINE nmm_bdy_interp2
2810
2811 !
2812 !=======================================================================================
2813 ! E grid interpolation: simple copy from parent to mother domain
2814 !=======================================================================================
2815 !
2816 !--------------------------------------------------------------------------------------
2817 !
2818 !
2819 SUBROUTINE nmm_copy ( cfld, & ! CD field
2820 cids, cide, ckds, ckde, cjds, cjde, &
2821 cims, cime, ckms, ckme, cjms, cjme, &
2822 cits, cite, ckts, ckte, cjts, cjte, &
2823 nfld, & ! ND field
2824 nids, nide, nkds, nkde, njds, njde, &
2825 nims, nime, nkms, nkme, njms, njme, &
2826 nits, nite, nkts, nkte, njts, njte, &
2827 shw, & ! stencil half width
2828 imask, & ! interpolation mask
2829 xstag, ystag, & ! staggering of field
2830 ipos, jpos, & ! Position of lower left of nest in CD
2831 nri, nrj, & ! nest ratios
2832 CII, IIH, CJJ, JJH )
2833
2834 USE module_timing
2835 IMPLICIT NONE
2836
2837 LOGICAL, INTENT(IN) :: xstag, ystag
2838 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2839 cims, cime, ckms, ckme, cjms, cjme, &
2840 cits, cite, ckts, ckte, cjts, cjte, &
2841 nids, nide, nkds, nkde, njds, njde, &
2842 nims, nime, nkms, nkme, njms, njme, &
2843 nits, nite, nkts, nkte, njts, njte, &
2844 shw, &
2845 ipos, jpos, &
2846 nri, nrj
2847 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(IN) :: cfld
2848 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld
2849 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
2850 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2851 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
2852
2853 ! local
2854 INTEGER i,j,k
2855
2856
2857 DO J=NJTS,MIN(NJTE,NJDE-1)
2858 DO K=NKTS,NKTE
2859 DO I=NITS,MIN(NITE,NIDE-1)
2860 NFLD(I,K,J) = CFLD(IIH(I,J),K,JJH(I,J))
2861 ENDDO
2862 ENDDO
2863 ENDDO
2864
2865 RETURN
2866
2867 END SUBROUTINE nmm_copy
2868 !
2869 !=======================================================================================
2870 ! E grid interpolation for terrain: In order to be consistent with the quasi-hydrostatic
2871 ! balance at the boundaries, a four point average of the terrain is done at the second
2872 ! and the penaltimate rows and columns around the boundaries.
2873 !=======================================================================================
2874 !
2875 SUBROUTINE interp_topo_nmm (cfld, & ! CD field
2876 cids, cide, ckds, ckde, cjds, cjde, &
2877 cims, cime, ckms, ckme, cjms, cjme, &
2878 cits, cite, ckts, ckte, cjts, cjte, &
2879 nfld, & ! ND field
2880 nids, nide, nkds, nkde, njds, njde, &
2881 nims, nime, nkms, nkme, njms, njme, &
2882 nits, nite, nkts, nkte, njts, njte, &
2883 shw, & ! stencil half width for interp
2884 imask, & ! interpolation mask
2885 xstag, ystag, & ! staggering of field
2886 ipos, jpos, & ! Position of lower left of nest in CD
2887 nri, nrj, & ! nest ratios
2888 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
2889 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
2890 CBWGT4, HBWGT4 ) ! dummys for weights
2891 USE module_timing
2892 IMPLICIT NONE
2893
2894 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2895 cims, cime, ckms, ckme, cjms, cjme, &
2896 cits, cite, ckts, ckte, cjts, cjte, &
2897 nids, nide, nkds, nkde, njds, njde, &
2898 nims, nime, nkms, nkme, njms, njme, &
2899 nits, nite, nkts, nkte, njts, njte, &
2900 shw, &
2901 ipos, jpos, &
2902 nri, nrj
2903 LOGICAL, INTENT(IN) :: xstag, ystag
2904
2905 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
2906 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
2907 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
2908 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
2909 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
2910 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
2911 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
2912
2913 ! local
2914 INTEGER i,j,k
2915 !
2916 !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
2917 !
2918 DO J=NJTS,MIN(NJTE,NJDE-1)
2919 DO I=NITS,MIN(NITE,NIDE-1)
2920 IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) &
2921 CALL wrf_error_fatal ('hpoints:check domain bounds along x' )
2922 IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) &
2923 CALL wrf_error_fatal ('hpoints:check domain bounds along y' )
2924 ENDDO
2925 ENDDO
2926
2927
2928 !
2929 !*** INDEX CONVENTIONS
2930 !*** HBWGT4
2931 !*** 4
2932 !***
2933 !***
2934 !***
2935 !*** h
2936 !*** 1 2
2937 !*** HBWGT1 HBWGT2
2938 !***
2939 !***
2940 !*** 3
2941 !*** HBWGT3
2942
2943 WRITE(0,*)'HALO WEIGHTS: interp_fcn.F','NITS to MIN(NITE,NIDE-1)=',NITS,MIN(NITE,NIDE-1)
2944 WRITE(0,*)'HALO WEIGHTS: interp_fcn.F','NJTS to MIN(NJTE,NJDE-1)=',NJTS,MIN(NJTE,NJDE-1)
2945
2946 DO J=MAX(NJTS-1,NJDS),MIN(NJTE+1,NJDE-1)
2947 DO K=NKDS,NKDE
2948 DO I=MAX(NITS-1,NIDS),MIN(NITE+1,NIDE-1)
2949 IF(IMASK(I,J) .NE. 1)THEN
2950 !
2951 IF(I==1 .AND. K==1)WRITE(0,*)'HALO WEIGHTS: interp_fcn.F', I,J, &
2952 HBWGT1(I,J)+HBWGT2(I,J)+HBWGT3(I,J)+HBWGT4(I,J), &
2953 IIH(I,J),JJH(I,J)
2954
2955 IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7
2956 NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2957 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2958 + HBWGT3(I,J)*CFLD(IIH(I,J), K, JJH(I,J)-1) &
2959 + HBWGT4(I,J)*CFLD(IIH(I,J), K, JJH(I,J)+1)
2960 ELSE
2961 NFLD(I,K,J) = HBWGT1(I,J)*CFLD(IIH(I,J), K, JJH(I,J) ) &
2962 + HBWGT2(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J) ) &
2963 + HBWGT3(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)-1) &
2964 + HBWGT4(I,J)*CFLD(IIH(I,J)+1,K, JJH(I,J)+1)
2965 ENDIF
2966 !
2967 ENDIF
2968 ENDDO
2969 ENDDO
2970 ENDDO
2971
2972
2973 END SUBROUTINE interp_topo_nmm
2974 !
2975 !=======================================================================================
2976 ! E grid test for mass point coincidence
2977 !=======================================================================================
2978 !
2979 SUBROUTINE test_nmm (cfld, & ! CD field
2980 cids, cide, ckds, ckde, cjds, cjde, &
2981 cims, cime, ckms, ckme, cjms, cjme, &
2982 cits, cite, ckts, ckte, cjts, cjte, &
2983 nfld, & ! ND field
2984 nids, nide, nkds, nkde, njds, njde, &
2985 nims, nime, nkms, nkme, njms, njme, &
2986 nits, nite, nkts, nkte, njts, njte, &
2987 shw, & ! stencil half width for interp
2988 imask, & ! interpolation mask
2989 xstag, ystag, & ! staggering of field
2990 ipos, jpos, & ! Position of lower left of nest in CD
2991 nri, nrj, & ! nest ratios
2992 CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights
2993 CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are
2994 CBWGT4, HBWGT4 ) ! dummys for weights
2995 USE module_timing
2996 IMPLICIT NONE
2997
2998 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
2999 cims, cime, ckms, ckme, cjms, cjme, &
3000 cits, cite, ckts, ckte, cjts, cjte, &
3001 nids, nide, nkds, nkde, njds, njde, &
3002 nims, nime, nkms, nkme, njms, njme, &
3003 nits, nite, nkts, nkte, njts, njte, &
3004 shw, &
3005 ipos, jpos, &
3006 nri, nrj
3007 LOGICAL, INTENT(IN) :: xstag, ystag
3008
3009 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
3010 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
3011 REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy
3012 REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
3013 INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy
3014 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH
3015 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
3016
3017 ! local
3018 INTEGER i,j,k
3019 REAL,PARAMETER :: error=0.0001,error1=1.0
3020 REAL :: diff
3021 !
3022 !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
3023 !
3024 DO J=NJTS,MIN(NJTE,NJDE-1)
3025 DO I=NITS,MIN(NITE,NIDE-1)
3026 IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) &
3027 CALL wrf_error_fatal ('hpoints:check domain bounds along x' )
3028 IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) &
3029 CALL wrf_error_fatal ('hpoints:check domain bounds along y' )
3030 ENDDO
3031 ENDDO
3032
3033 !
3034 !*** INDEX CONVENTIONS
3035 !*** HBWGT4
3036 !*** 4
3037 !***
3038 !***
3039 !***
3040 !*** h
3041 !*** 1 2
3042 !*** HBWGT1 HBWGT2
3043 !***
3044 !***
3045 !*** 3
3046 !*** HBWGT3
3047
3048
3049 ! WRITE(0,*)NITS,MIN(NITE,NIDE-1),CITS,CITE
3050 DO J=NJTS,MIN(NJTE,NJDE-1)
3051 DO K=NKDS,NKDE
3052 DO I=NITS,MIN(NITE,NIDE-1)
3053 IF(ABS(1.0-HBWGT1(I,J)) .LE. ERROR)THEN
3054 DIFF=ABS(NFLD(I,K,J)-CFLD(IIH(I,J),K,JJH(I,J)))
3055 IF(DIFF .GT. ERROR)THEN
3056 CALL wrf_debug(1,"dyn_nmm: NON-COINCIDENT, NESTED MASS POINT")
3057 WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,K,J),CFLD(IIH(I,J),K,JJH(I,J)),DIFF
3058 ENDIF
3059 IF(DIFF .GT. ERROR1)THEN
3060 WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,K,J),CFLD(IIH(I,J),K,JJH(I,J)),DIFF
3061 CALL wrf_error_fatal ('dyn_nmm: NON-COINCIDENT, NESTED MASS POINT')
3062 ENDIF
3063 ENDIF
3064 ENDDO
3065 ENDDO
3066 ENDDO
3067
3068 END SUBROUTINE test_nmm
3069
3070 !==================================
3071 ! this is the default function used in nmm feedback at mass points.
3072
3073 SUBROUTINE nmm_feedback ( cfld, & ! CD field
3074 cids, cide, ckds, ckde, cjds, cjde, &
3075 cims, cime, ckms, ckme, cjms, cjme, &
3076 cits, cite, ckts, ckte, cjts, cjte, &
3077 nfld, & ! ND field
3078 nids, nide, nkds, nkde, njds, njde, &
3079 nims, nime, nkms, nkme, njms, njme, &
3080 nits, nite, nkts, nkte, njts, njte, &
3081 shw, & ! stencil half width for interp
3082 imask, & ! interpolation mask
3083 xstag, ystag, & ! staggering of field
3084 ipos, jpos, & ! Position of lower left of nest in CD
3085 nri, nrj, & ! nest ratios
3086 CII, IIH, CJJ, JJH, &
3087 CBWGT1, HBWGT1, CBWGT2, HBWGT2, &
3088 CBWGT3, HBWGT3, CBWGT4, HBWGT4 )
3089 USE module_configure
3090 IMPLICIT NONE
3091
3092
3093 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3094 cims, cime, ckms, ckme, cjms, cjme, &
3095 cits, cite, ckts, ckte, cjts, cjte, &
3096 nids, nide, nkds, nkde, njds, njde, &
3097 nims, nime, nkms, nkme, njms, njme, &
3098 nits, nite, nkts, nkte, njts, njte, &
3099 shw, &
3100 ipos, jpos, &
3101 nri, nrj
3102 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
3103 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH
3104 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4
3105 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
3106 LOGICAL, INTENT(IN) :: xstag, ystag
3107
3108 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
3109 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
3110 INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask
3111
3112 ! Local
3113
3114 INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
3115 INTEGER :: icmin,icmax,jcmin,jcmax
3116 INTEGER :: is, ipoints,jpoints,ijpoints
3117 INTEGER , PARAMETER :: passes = 2
3118 REAL :: AVGH
3119
3120 !=====================================================================================
3121 !
3122
3123 IF(nri .ne. 3 .OR. nrj .ne. 3) &
3124 CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist' )
3125
3126 ! WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR MASS'
3127
3128 CFLD = 9999.0
3129
3130 DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
3131 nj = (cj-jpos)*nrj + 1
3132 if(mod(cj,2) .eq. 0)THEN
3133 is=0 ! even rows for mass points (2,4,6,8)
3134 else
3135 is=1 ! odd rows for mass points (1,3,5,7)
3136 endif
3137 DO ck = ckts, ckte
3138 nk = ck
3139 DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
3140 ni = (ci-ipos)*nri + 2 -is
3141 IF(IS==0)THEN ! (2,4,6,8)
3142 AVGH = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI+1,NK,NJ+1)+ NFLD(NI+1,NK,NJ-1) &
3143 + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) &
3144 + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2)
3145 ELSE
3146 AVGH = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI-1,NK,NJ+1)+ NFLD(NI-1,NK,NJ-1) &
3147 + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) &
3148 + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2)
3149 ENDIF
3150 !dusan CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGH)/13.0
3151 CFLD(CI,CK,CJ) = (NFLD(NI,NK,NJ)+AVGH)/13.0
3152 ENDDO
3153 ENDDO
3154 ENDDO
3155
3156 END SUBROUTINE nmm_feedback
3157
3158 !===========================================================================================
3159
3160 SUBROUTINE nmm_vfeedback ( cfld, & ! CD field
3161 cids, cide, ckds, ckde, cjds, cjde, &
3162 cims, cime, ckms, ckme, cjms, cjme, &
3163 cits, cite, ckts, ckte, cjts, cjte, &
3164 nfld, & ! ND field
3165 nids, nide, nkds, nkde, njds, njde, &
3166 nims, nime, nkms, nkme, njms, njme, &
3167 nits, nite, nkts, nkte, njts, njte, &
3168 shw, & ! stencil half width for interp
3169 imask, & ! interpolation mask
3170 xstag, ystag, & ! staggering of field
3171 ipos, jpos, & ! Position of lower left of nest in CD
3172 nri, nrj, & ! nest ratios
3173 CII, IIV, CJJ, JJV, &
3174 CBWGT1, VBWGT1, CBWGT2, VBWGT2, &
3175 CBWGT3, VBWGT3, CBWGT4, VBWGT4 )
3176 USE module_configure
3177 IMPLICIT NONE
3178
3179
3180 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3181 cims, cime, ckms, ckme, cjms, cjme, &
3182 cits, cite, ckts, ckte, cjts, cjte, &
3183 nids, nide, nkds, nkde, njds, njde, &
3184 nims, nime, nkms, nkme, njms, njme, &
3185 nits, nite, nkts, nkte, njts, njte, &
3186 shw, &
3187 ipos, jpos, &
3188 nri, nrj
3189 INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy
3190 INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIV,JJV
3191 REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4
3192 REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
3193 LOGICAL, INTENT(IN) :: xstag, ystag
3194
3195 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
3196 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
3197 INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask
3198
3199 ! Local
3200
3201 INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
3202 INTEGER :: icmin,icmax,jcmin,jcmax
3203 INTEGER :: is, ipoints,jpoints,ijpoints
3204 INTEGER , PARAMETER :: passes = 2
3205 REAL :: AVGV
3206
3207 !=====================================================================================
3208 !
3209
3210 IF(nri .ne. 3 .OR. nrj .ne. 3) &
3211 CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist')
3212
3213 ! WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR VELOCITY'
3214
3215 CFLD = 9999.0
3216
3217 DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
3218 nj = (cj-jpos)*nrj + 1
3219 if(mod(cj,2) .eq. 0)THEN
3220 is=1 ! even rows for velocity points (2,4,6,8)
3221 else
3222 is=0 ! odd rows for velocity points (1,3,5,7)
3223 endif
3224 DO ck = ckts, ckte
3225 nk = ck
3226 DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
3227 ni = (ci-ipos)*nri + 2 -is
3228 IF(IS==0)THEN ! (1,3,5,7)
3229 AVGV = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI+1,NK,NJ+1)+ NFLD(NI+1,NK,NJ-1) &
3230 + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) &
3231 + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2)
3232 ELSE
3233 AVGV = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI-1,NK,NJ+1)+ NFLD(NI-1,NK,NJ-1) &
3234 + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) &
3235 + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2)
3236 ENDIF
3237 !dusan CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGV)/13.0
3238 CFLD(CI,CK,CJ) = (NFLD(NI,NK,NJ)+AVGV)/13.0
3239 ENDDO
3240 ENDDO
3241 ENDDO
3242
3243 END SUBROUTINE nmm_vfeedback
3244
3245
3246 SUBROUTINE nmm_smoother ( cfld , &
3247 cids, cide, ckds, ckde, cjds, cjde, &
3248 cims, cime, ckms, ckme, cjms, cjme, &
3249 cits, cite, ckts, ckte, cjts, cjte, &
3250 nids, nide, nkds, nkde, njds, njde, &
3251 nims, nime, nkms, nkme, njms, njme, &
3252 nits, nite, nkts, nkte, njts, njte, &
3253 xstag, ystag, &
3254 ipos, jpos, &
3255 nri, nrj &
3256 )
3257
3258 USE module_configure
3259 IMPLICIT NONE
3260
3261 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3262 cims, cime, ckms, ckme, cjms, cjme, &
3263 cits, cite, ckts, ckte, cjts, cjte, &
3264 nids, nide, nkds, nkde, njds, njde, &
3265 nims, nime, nkms, nkme, njms, njme, &
3266 nits, nite, nkts, nkte, njts, njte, &
3267 nri, nrj, &
3268 ipos, jpos
3269 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
3270 LOGICAL, INTENT(IN) :: xstag, ystag
3271
3272
3273 ! Local
3274
3275 INTEGER :: feedback
3276 INTEGER, PARAMETER :: smooth_passes = 5
3277
3278 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew
3279 INTEGER :: ci, cj, ck
3280 INTEGER :: is, npass
3281 REAL :: AVGH
3282
3283 RETURN
3284 ! If there is no feedback, there can be no smoothing.
3285
3286 CALL nl_get_feedback ( 1, feedback )
3287 IF ( feedback == 0 ) RETURN
3288
3289 WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT'
3290
3291 DO npass = 1, smooth_passes
3292
3293 DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
3294 if(mod(cj,2) .eq. 0)THEN
3295 is=0 ! even rows for mass points (2,4,6,8)
3296 else
3297 is=1 ! odd rows for mass points (1,3,5,7)
3298 endif
3299 DO ck = ckts, ckte
3300 DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
3301 IF(IS==0)THEN ! (2,4,6,8)
3302 AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1)
3303 ELSE
3304 AVGH = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1)
3305 ENDIF
3306 CFLDNEW(CI,CK,CJ) = (AVGH + 4*CFLD(CI,CK,CJ)) / 8.0
3307 ENDDO
3308 ENDDO
3309 ENDDO
3310
3311 DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
3312 if(mod(cj,2) .eq. 0)THEN
3313 is=0 ! even rows for mass points (2,4,6,8)
3314 else
3315 is=1 ! odd rows for mass points (1,3,5,7)
3316 endif
3317 DO ck = ckts, ckte
3318 DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
3319 CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ)
3320 ENDDO
3321 ENDDO
3322 ENDDO
3323
3324 ENDDO ! do npass
3325
3326 END SUBROUTINE nmm_smoother
3327
3328
3329 SUBROUTINE nmm_vsmoother ( cfld , &
3330 cids, cide, ckds, ckde, cjds, cjde, &
3331 cims, cime, ckms, ckme, cjms, cjme, &
3332 cits, cite, ckts, ckte, cjts, cjte, &
3333 nids, nide, nkds, nkde, njds, njde, &
3334 nims, nime, nkms, nkme, njms, njme, &
3335 nits, nite, nkts, nkte, njts, njte, &
3336 xstag, ystag, &
3337 ipos, jpos, &
3338 nri, nrj &
3339 )
3340
3341 USE module_configure
3342 IMPLICIT NONE
3343
3344 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3345 cims, cime, ckms, ckme, cjms, cjme, &
3346 cits, cite, ckts, ckte, cjts, cjte, &
3347 nids, nide, nkds, nkde, njds, njde, &
3348 nims, nime, nkms, nkme, njms, njme, &
3349 nits, nite, nkts, nkte, njts, njte, &
3350 nri, nrj, &
3351 ipos, jpos
3352 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
3353 LOGICAL, INTENT(IN) :: xstag, ystag
3354
3355
3356 ! Local
3357
3358 INTEGER :: feedback
3359 INTEGER, PARAMETER :: smooth_passes = 5
3360
3361 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfldnew
3362 INTEGER :: ci, cj, ck
3363 INTEGER :: is, npass
3364 REAL :: AVGV
3365
3366 RETURN
3367 ! If there is no feedback, there can be no smoothing.
3368
3369 CALL nl_get_feedback ( 1, feedback )
3370 IF ( feedback == 0 ) RETURN
3371
3372 WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR VELOCITY'
3373
3374 DO npass = 1, smooth_passes
3375
3376 DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
3377 if(mod(cj,2) .eq. 0)THEN
3378 is=1 ! even rows for mass points (2,4,6,8)
3379 else
3380 is=0 ! odd rows for mass points (1,3,5,7)
3381 endif
3382 DO ck = ckts, ckte
3383 DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
3384 IF(IS==0)THEN ! (2,4,6,8)
3385 AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI+1,CK,CJ+1) + CFLD(CI+1,CK,CJ-1)
3386 ELSE
3387 AVGV = CFLD(CI,CK,CJ+1) + CFLD(CI,CK,CJ-1) + CFLD(CI-1,CK,CJ+1) + CFLD(CI-1,CK,CJ-1)
3388 ENDIF
3389 CFLDNEW(CI,CK,CJ) = (AVGV + 4*CFLD(CI,CK,CJ)) / 8.0
3390 ENDDO
3391 ENDDO
3392 ENDDO
3393
3394 DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs
3395 if(mod(cj,2) .eq. 0)THEN
3396 is=1 ! even rows for mass points (2,4,6,8)
3397 else
3398 is=0 ! odd rows for mass points (1,3,5,7)
3399 endif
3400 DO ck = ckts, ckte
3401 DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs
3402 CFLD(CI,CK,CJ) = CFLDNEW(CI,CK,CJ)
3403 ENDDO
3404 ENDDO
3405 ENDDO
3406
3407 ENDDO
3408
3409 END SUBROUTINE nmm_vsmoother
3410 !======================================================================================
3411 ! End of gopal's doing
3412 !======================================================================================
3413 #endif
3414
3415 SUBROUTINE interp_fcn ( cfld, & ! CD field
3416 cids, cide, ckds, ckde, cjds, cjde, &
3417 cims, cime, ckms, ckme, cjms, cjme, &
3418 cits, cite, ckts, ckte, cjts, cjte, &
3419 nfld, & ! ND field
3420 nids, nide, nkds, nkde, njds, njde, &
3421 nims, nime, nkms, nkme, njms, njme, &
3422 nits, nite, nkts, nkte, njts, njte, &
3423 shw, & ! stencil half width for interp
3424 imask, & ! interpolation mask
3425 xstag, ystag, & ! staggering of field
3426 ipos, jpos, & ! Position of lower left of nest in CD
3427 nri, nrj ) ! nest ratios
3428 USE module_timing
3429 USE module_configure
3430 IMPLICIT NONE
3431
3432
3433 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3434 cims, cime, ckms, ckme, cjms, cjme, &
3435 cits, cite, ckts, ckte, cjts, cjte, &
3436 nids, nide, nkds, nkde, njds, njde, &
3437 nims, nime, nkms, nkme, njms, njme, &
3438 nits, nite, nkts, nkte, njts, njte, &
3439 shw, &
3440 ipos, jpos, &
3441 nri, nrj
3442 LOGICAL, INTENT(IN) :: xstag, ystag
3443
3444 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
3445 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
3446 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
3447
3448 ! Local
3449
3450 !logical first
3451
3452 INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, nioff, njoff
3453 #ifdef MM5_SINT
3454 INTEGER nfx, ior
3455 PARAMETER (ior=2)
3456 INTEGER nf
3457 REAL psca(cims:cime,cjms:cjme,nri*nrj)
3458 LOGICAL icmask( cims:cime, cjms:cjme )
3459 INTEGER i,j,k
3460 #endif
3461
3462 #if (DA_CORE != 1)
3463 ! Iterate over the ND tile and compute the values
3464 ! from the CD tile.
3465
3466 #ifdef MM5_SINT
3467
3468 ioff = 0 ; joff = 0
3469 nioff = 0 ; njoff = 0
3470 IF ( xstag ) THEN
3471 ioff = (nri-1)/2
3472 nioff = nri
3473 ENDIF
3474 IF ( ystag ) THEN
3475 joff = (nrj-1)/2
3476 njoff = nrj
3477 ENDIF
3478
3479 nfx = nri * nrj
3480 !$OMP PARALLEL DO &
3481 !$OMP PRIVATE ( i,j,k,ni,nj,ci,cj,ip,jp,nk,ck,nf,icmask,psca )
3482 DO k = ckts, ckte
3483 icmask = .FALSE.
3484 DO nf = 1,nfx
3485 DO j = cjms,cjme
3486 nj = (j-jpos) * nrj + ( nrj / 2 + 1 ) ! j point on nest
3487 DO i = cims,cime
3488 ni = (i-ipos) * nri + ( nri / 2 + 1 ) ! i point on nest
3489 if ( ni .ge. nits-nioff-1 .and. ni .le. nite+nioff+1 .and. nj .ge. njts-njoff-1 .and. nj .le. njte+njoff+1 ) then
3490 if ( imask(ni,nj) .eq. 1 .or. imask(ni-nioff,nj-njoff) .eq. 1 ) then
3491 icmask( i, j ) = .TRUE.
3492 endif
3493 endif
3494 psca(i,j,nf) = cfld(i,k,j)
3495 ENDDO
3496 ENDDO
3497 ENDDO
3498
3499 ! tile dims in this call to sint are 1-over to account for the fact
3500 ! that the number of cells on the nest local subdomain is not
3501 ! necessarily a multiple of the nest ratio in a given dim.
3502 ! this could be a little less ham-handed.
3503
3504 !call start_timing
3505
3506 CALL sint( psca, &
3507 cims, cime, cjms, cjme, icmask, &
3508 cits-1, cite+1, cjts-1, cjte+1, nrj*nri, xstag, ystag )
3509
3510 !call end_timing( ' sint ' )
3511
3512 DO nj = njts, njte+joff
3513 cj = jpos + (nj-1) / nrj ! j coord of CD point
3514 jp = mod ( nj-1 , nrj ) ! coord of ND w/i CD point
3515 nk = k
3516 ck = nk
3517 DO ni = nits, nite+ioff
3518 ci = ipos + (ni-1) / nri ! i coord of CD point
3519 ip = mod ( ni-1 , nri ) ! coord of ND w/i CD point
3520 if ( imask ( ni, nj ) .eq. 1 .or. imask ( ni-ioff, nj-joff ) .eq. 1 ) then
3521 nfld( ni-ioff, nk, nj-joff ) = psca( ci , cj, ip+1 + (jp)*nri )
3522 endif
3523 ENDDO
3524 ENDDO
3525 ENDDO
3526 !$OMP END PARALLEL DO
3527 #endif
3528
3529 #ifdef DUMBCOPY
3530 !write(0,'(") cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
3531 !write(0,'(") nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
3532 !write(0,'(") cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
3533 !write(0,'(") nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
3534
3535 DO nj = njts, njte
3536 cj = jpos + (nj-1) / nrj ! j coord of CD point
3537 jp = mod ( nj , nrj ) ! coord of ND w/i CD point
3538 DO nk = nkts, nkte
3539 ck = nk
3540 DO ni = nits, nite
3541 ci = ipos + (ni-1) / nri ! j coord of CD point
3542 ip = mod ( ni , nri ) ! coord of ND w/i CD point
3543 ! This is a trivial implementation of the interp_fcn; just copies
3544 ! the values from the CD into the ND
3545 if ( imask ( ni, nj ) .eq. 1 ) then
3546 nfld( ni, nk, nj ) = cfld( ci , ck , cj )
3547 endif
3548 ENDDO
3549 ENDDO
3550 ENDDO
3551 #endif
3552 #endif
3553
3554 RETURN
3555
3556 END SUBROUTINE interp_fcn
3557
3558 !==================================
3559 ! this is the default function used in feedback.
3560
3561 SUBROUTINE copy_fcn ( cfld, & ! CD field
3562 cids, cide, ckds, ckde, cjds, cjde, &
3563 cims, cime, ckms, ckme, cjms, cjme, &
3564 cits, cite, ckts, ckte, cjts, cjte, &
3565 nfld, & ! ND field
3566 nids, nide, nkds, nkde, njds, njde, &
3567 nims, nime, nkms, nkme, njms, njme, &
3568 nits, nite, nkts, nkte, njts, njte, &
3569 shw, & ! stencil half width for interp
3570 imask, & ! interpolation mask
3571 xstag, ystag, & ! staggering of field
3572 ipos, jpos, & ! Position of lower left of nest in CD
3573 nri, nrj ) ! nest ratios
3574 USE module_configure
3575 IMPLICIT NONE
3576
3577
3578 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3579 cims, cime, ckms, ckme, cjms, cjme, &
3580 cits, cite, ckts, ckte, cjts, cjte, &
3581 nids, nide, nkds, nkde, njds, njde, &
3582 nims, nime, nkms, nkme, njms, njme, &
3583 nits, nite, nkts, nkte, njts, njte, &
3584 shw, &
3585 ipos, jpos, &
3586 nri, nrj
3587 LOGICAL, INTENT(IN) :: xstag, ystag
3588
3589 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
3590 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ),INTENT(IN) :: nfld
3591 INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask
3592
3593 ! Local
3594
3595 INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
3596 INTEGER :: icmin,icmax,jcmin,jcmax
3597 INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
3598 INTEGER , PARAMETER :: passes = 2
3599 INTEGER spec_zone
3600
3601 ! Loop over the coarse grid in the area of the fine mesh. Do not
3602 ! process the coarse grid values that are along the lateral BC
3603 ! provided to the fine grid. Since that is in the specified zone
3604 ! for the fine grid, it should not be used in any feedback to the
3605 ! coarse grid as it should not have changed.
3606
3607 ! Due to peculiarities of staggering, it is simpler to handle the feedback
3608 ! for the staggerings based upon whether it is a even ratio (2::1, 4::1, etc.) or
3609 ! an odd staggering ratio (3::1, 5::1, etc.).
3610
3611 ! Though there are separate grid ratios for the i and j directions, this code
3612 ! is not general enough to handle aspect ratios .NE. 1 for the fine grid cell.
3613
3614 ! These are local integer increments in the looping. Basically, istag=1 means
3615 ! that we will assume one less point in the i direction. Note that ci and cj
3616 ! have a maximum value that is decreased by istag and jstag, respectively.
3617
3618 ! Horizontal momentum feedback is along the face, not within the cell. For a
3619 ! 3::1 ratio, temperature would use 9 pts for feedback, while u and v use
3620 ! only 3 points for feedback from the nest to the parent.
3621
3622 CALL nl_get_spec_zone( 1 , spec_zone )
3623 istag = 1 ; jstag = 1
3624 IF ( xstag ) istag = 0
3625 IF ( ystag ) jstag = 0
3626
3627 IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio
3628
3629 IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
3630 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3631 nj = (cj-jpos)*nrj + jstag + 1
3632 DO ck = ckts, ckte
3633 nk = ck
3634 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3635 ni = (ci-ipos)*nri + istag + 1
3636 cfld( ci, ck, cj ) = 0.
3637 DO ijpoints = 1 , nri * nrj
3638 ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
3639 jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
3640 cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
3641 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints )
3642 END DO
3643 ! cfld( ci, ck, cj ) = 1./9. * &
3644 ! ( nfld( ni-1, nk , nj-1) + &
3645 ! nfld( ni , nk , nj-1) + &
3646 ! nfld( ni+1, nk , nj-1) + &
3647 ! nfld( ni-1, nk , nj ) + &
3648 ! nfld( ni , nk , nj ) + &
3649 ! nfld( ni+1, nk , nj ) + &
3650 ! nfld( ni-1, nk , nj+1) + &
3651 ! nfld( ni , nk , nj+1) + &
3652 ! nfld( ni+1, nk , nj+1) )
3653 ENDDO
3654 ENDDO
3655 ENDDO
3656
3657 ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN
3658 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3659 nj = (cj-jpos)*nrj + jstag + 1
3660 DO ck = ckts, ckte
3661 nk = ck
3662 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3663 ni = (ci-ipos)*nri + istag + 1
3664 cfld( ci, ck, cj ) = 0.
3665 DO ijpoints = (nri+1)/2 , (nri+1)/2 + nri*(nri-1) , nri
3666 ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
3667 jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
3668 cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
3669 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints )
3670 END DO
3671 ! cfld( ci, ck, cj ) = 1./3. * &
3672 ! ( nfld( ni , nk , nj-1) + &
3673 ! nfld( ni , nk , nj ) + &
3674 ! nfld( ni , nk , nj+1) )
3675 ENDDO
3676 ENDDO
3677 ENDDO
3678
3679 ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN
3680 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3681 nj = (cj-jpos)*nrj + jstag + 1
3682 DO ck = ckts, ckte
3683 nk = ck
3684 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3685 ni = (ci-ipos)*nri + istag + 1
3686 cfld( ci, ck, cj ) = 0.
3687 DO ijpoints = ( nrj*nrj +1 )/2 - nrj/2 , ( nrj*nrj +1 )/2 - nrj/2 + nrj-1
3688 ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1
3689 jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1
3690 cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
3691 1./REAL( nrj) * nfld( ni+ipoints , nk , nj+jpoints )
3692 END DO
3693 ! cfld( ci, ck, cj ) = 1./3. * &
3694 ! ( nfld( ni-1, nk , nj ) + &
3695 ! nfld( ni , nk , nj ) + &
3696 ! nfld( ni+1, nk , nj ) )
3697 ENDDO
3698 ENDDO
3699 ENDDO
3700
3701 END IF
3702
3703 ! Even refinement ratio
3704
3705 ELSE IF ( MOD(nrj,2) .EQ. 0) THEN
3706 IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
3707
3708 ! This is a simple schematic of the feedback indexing used in the even
3709 ! ratio nests. For simplicity, a 2::1 ratio is depicted. Only the
3710 ! mass variable staggering is shown.
3711 ! Each of
3712 ! the boxes with a "T" and four small "t" represents a coarse grid (CG)
3713 ! cell, that is composed of four (2::1 ratio) fine grid (FG) cells.
3714
3715 ! Shown below is the area of the CG that is in the area of the FG. The
3716 ! first grid point of the depicted CG is the starting location of the nest
3717 ! in the parent domain (ipos,jpos - i_parent_start and j_parent_start from
3718 ! the namelist).
3719
3720 ! For each of the CG points, the feedback loop is over each of the FG points
3721 ! within the CG cell. For a 2::1 ratio, there are four total points (this is
3722 ! the ijpoints loop). The feedback value to the CG is the arithmetic mean of
3723 ! all of the FG values within each CG cell.
3724
3725 ! |-------------||-------------| |-------------||-------------|
3726 ! | t t || t t | | t t || t t |
3727 ! jpos+ | || | | || |
3728 ! (njde-njds)- | T || T | | T || T |
3729 ! jstag | || | | || |
3730 ! | t t || t t | | t t || t t |
3731 ! |-------------||-------------| |-------------||-------------|
3732 ! |-------------||-------------| |-------------||-------------|
3733 ! | t t || t t | | t t || t t |
3734 ! | || | | || |
3735 ! | T || T | | T || T |
3736 ! | || | | || |
3737 ! | t t || t t | | t t || t t |
3738 ! |-------------||-------------| |-------------||-------------|
3739 !
3740 ! ...
3741 ! ...
3742 ! ...
3743 ! ...
3744 ! ...
3745
3746 ! |-------------||-------------| |-------------||-------------|
3747 ! jpoints = 1 | t t || t t | | t t || t t |
3748 ! | || | | || |
3749 ! | T || T | | T || T |
3750 ! | || | | || |
3751 ! jpoints = 0, | t t || t t | | t t || t t |
3752 ! nj=3 |-------------||-------------| |-------------||-------------|
3753 ! |-------------||-------------| |-------------||-------------|
3754 ! jpoints = 1 | t t || t t | | t t || t t |
3755 ! | || | | || |
3756 ! jpos | T || T | ... | T || T |
3757 ! | || | ... | || |
3758 ! jpoints = 0, | t t || t t | ... | t t || t t |
3759 ! nj=1 |-------------||-------------| |-------------||-------------|
3760 ! ^ ^
3761 ! | |
3762 ! | |
3763 ! ipos ipos+
3764 ! ni = 1 3 (nide-nids)/nri
3765 ! ipoints= 0 1 0 1 -istag
3766 !
3767
3768 ! For performance benefits, users can comment out the inner most loop (and cfld=0) and
3769 ! hardcode the loop feedback. For example, it is set up to run a 2::1 ratio
3770 ! if uncommented. This lacks generality, but is likely to gain timing benefits
3771 ! with compilers unable to unroll inner loops that do not have parameterized sizes.
3772
3773 ! The extra +1 ---------/ and the extra -1 ----\ (both for ci and cj)
3774 ! / \ keeps the feedback out of the
3775 ! / \ outer row/col, since that CG data
3776 ! / \ specified the nest boundary originally
3777 ! / \ This
3778 ! / \ is just
3779 ! / \ a sentence to not end a line
3780 ! / \ with a stupid backslash
3781 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3782 nj = (cj-jpos)*nrj + jstag
3783 DO ck = ckts, ckte
3784 nk = ck
3785 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3786 ni = (ci-ipos)*nri + istag
3787 cfld( ci, ck, cj ) = 0.
3788 DO ijpoints = 1 , nri * nrj
3789 ipoints = MOD((ijpoints-1),nri)
3790 jpoints = (ijpoints-1)/nri
3791 cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
3792 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints )
3793 END DO
3794 ! cfld( ci, ck, cj ) = 1./4. * &
3795 ! ( nfld( ni , nk , nj ) + &
3796 ! nfld( ni+1, nk , nj ) + &
3797 ! nfld( ni , nk , nj+1) + &
3798 ! nfld( ni+1, nk , nj+1) )
3799 END DO
3800 END DO
3801 END DO
3802
3803 ! U
3804
3805 ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN
3806 ! |---------------|
3807 ! | |
3808 ! jpoints = 1 u u |
3809 ! | |
3810 ! U |
3811 ! | |
3812 ! jpoints = 0, u u |
3813 ! nj=3 | |
3814 ! |---------------|
3815 ! |---------------|
3816 ! | |
3817 ! jpoints = 1 u u |
3818 ! | |
3819 ! jpos U |
3820 ! | |
3821 ! jpoints = 0, u u |
3822 ! nj=1 | |
3823 ! |---------------|
3824 !
3825 ! ^
3826 ! |
3827 ! |
3828 ! ipos
3829 ! ni = 1 3
3830 ! ipoints= 0 1 0
3831 !
3832
3833 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3834 nj = (cj-jpos)*nrj + 1
3835 DO ck = ckts, ckte
3836 nk = ck
3837 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3838 ni = (ci-ipos)*nri + 1
3839 cfld( ci, ck, cj ) = 0.
3840 DO ijpoints = 1 , nri*nrj , nri
3841 ipoints = MOD((ijpoints-1),nri)
3842 jpoints = (ijpoints-1)/nri
3843 cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
3844 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints )
3845 END DO
3846 ! cfld( ci, ck, cj ) = 1./2. * &
3847 ! ( nfld( ni , nk , nj ) + &
3848 ! nfld( ni , nk , nj+1) )
3849 ENDDO
3850 ENDDO
3851 ENDDO
3852
3853 ! V
3854
3855 ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN
3856 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3857 nj = (cj-jpos)*nrj + 1
3858 DO ck = ckts, ckte
3859 nk = ck
3860 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3861 ni = (ci-ipos)*nri + 1
3862 cfld( ci, ck, cj ) = 0.
3863 DO ijpoints = 1 , nri
3864 ipoints = MOD((ijpoints-1),nri)
3865 jpoints = (ijpoints-1)/nri
3866 cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + &
3867 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints )
3868 END DO
3869 ! cfld( ci, ck, cj ) = 1./2. * &
3870 ! ( nfld( ni , nk , nj ) + &
3871 ! nfld( ni+1, nk , nj ) )
3872 ENDDO
3873 ENDDO
3874 ENDDO
3875 END IF
3876 END IF
3877
3878 RETURN
3879
3880 END SUBROUTINE copy_fcn
3881
3882 !==================================
3883 ! this is the 1pt function used in feedback.
3884
3885 SUBROUTINE copy_fcnm ( cfld, & ! CD field
3886 cids, cide, ckds, ckde, cjds, cjde, &
3887 cims, cime, ckms, ckme, cjms, cjme, &
3888 cits, cite, ckts, ckte, cjts, cjte, &
3889 nfld, & ! ND field
3890 nids, nide, nkds, nkde, njds, njde, &
3891 nims, nime, nkms, nkme, njms, njme, &
3892 nits, nite, nkts, nkte, njts, njte, &
3893 shw, & ! stencil half width for interp
3894 imask, & ! interpolation mask
3895 xstag, ystag, & ! staggering of field
3896 ipos, jpos, & ! Position of lower left of nest in CD
3897 nri, nrj ) ! nest ratios
3898 USE module_configure
3899 USE module_wrf_error
3900 IMPLICIT NONE
3901
3902
3903 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3904 cims, cime, ckms, ckme, cjms, cjme, &
3905 cits, cite, ckts, ckte, cjts, cjte, &
3906 nids, nide, nkds, nkde, njds, njde, &
3907 nims, nime, nkms, nkme, njms, njme, &
3908 nits, nite, nkts, nkte, njts, njte, &
3909 shw, &
3910 ipos, jpos, &
3911 nri, nrj
3912 LOGICAL, INTENT(IN) :: xstag, ystag
3913
3914 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
3915 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
3916 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
3917
3918 ! Local
3919
3920 INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
3921 INTEGER :: icmin,icmax,jcmin,jcmax
3922 INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
3923 INTEGER , PARAMETER :: passes = 2
3924 INTEGER spec_zone
3925
3926 CALL nl_get_spec_zone( 1, spec_zone )
3927 istag = 1 ; jstag = 1
3928 IF ( xstag ) istag = 0
3929 IF ( ystag ) jstag = 0
3930
3931 IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio
3932
3933 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3934 nj = (cj-jpos)*nrj + jstag + 1
3935 DO ck = ckts, ckte
3936 nk = ck
3937 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3938 ni = (ci-ipos)*nri + istag + 1
3939 cfld( ci, ck, cj ) = nfld( ni , nk , nj )
3940 ENDDO
3941 ENDDO
3942 ENDDO
3943
3944 ELSE ! even refinement ratio, pick nearest neighbor on SW corner
3945 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
3946 nj = (cj-jpos)*nrj + 1
3947 DO ck = ckts, ckte
3948 nk = ck
3949 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
3950 ni = (ci-ipos)*nri + 1
3951 ipoints = nri/2 -1
3952 jpoints = nrj/2 -1
3953 cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints )
3954 END DO
3955 END DO
3956 END DO
3957
3958 END IF
3959
3960 RETURN
3961
3962 END SUBROUTINE copy_fcnm
3963
3964 !==================================
3965 ! this is the 1pt function used in feedback for integers
3966
3967 SUBROUTINE copy_fcni ( cfld, & ! CD field
3968 cids, cide, ckds, ckde, cjds, cjde, &
3969 cims, cime, ckms, ckme, cjms, cjme, &
3970 cits, cite, ckts, ckte, cjts, cjte, &
3971 nfld, & ! ND field
3972 nids, nide, nkds, nkde, njds, njde, &
3973 nims, nime, nkms, nkme, njms, njme, &
3974 nits, nite, nkts, nkte, njts, njte, &
3975 shw, & ! stencil half width for interp
3976 imask, & ! interpolation mask
3977 xstag, ystag, & ! staggering of field
3978 ipos, jpos, & ! Position of lower left of nest in CD
3979 nri, nrj ) ! nest ratios
3980 USE module_configure
3981 USE module_wrf_error
3982 IMPLICIT NONE
3983
3984
3985 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
3986 cims, cime, ckms, ckme, cjms, cjme, &
3987 cits, cite, ckts, ckte, cjts, cjte, &
3988 nids, nide, nkds, nkde, njds, njde, &
3989 nims, nime, nkms, nkme, njms, njme, &
3990 nits, nite, nkts, nkte, njts, njte, &
3991 shw, &
3992 ipos, jpos, &
3993 nri, nrj
3994 LOGICAL, INTENT(IN) :: xstag, ystag
3995
3996 INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
3997 INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
3998 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
3999
4000 ! Local
4001
4002 INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
4003 INTEGER :: icmin,icmax,jcmin,jcmax
4004 INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
4005 INTEGER , PARAMETER :: passes = 2
4006 INTEGER spec_zone
4007
4008 CALL nl_get_spec_zone( 1, spec_zone )
4009 istag = 1 ; jstag = 1
4010 IF ( xstag ) istag = 0
4011 IF ( ystag ) jstag = 0
4012
4013 IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio
4014
4015 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
4016 nj = (cj-jpos)*nrj + jstag + 1
4017 DO ck = ckts, ckte
4018 nk = ck
4019 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
4020 ni = (ci-ipos)*nri + istag + 1
4021 cfld( ci, ck, cj ) = nfld( ni , nk , nj )
4022 ENDDO
4023 ENDDO
4024 ENDDO
4025
4026 ELSE ! even refinement ratio
4027 DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte)
4028 nj = (cj-jpos)*nrj + 1
4029 DO ck = ckts, ckte
4030 nk = ck
4031 DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite)
4032 ni = (ci-ipos)*nri + 1
4033 ipoints = nri/2 -1
4034 jpoints = nrj/2 -1
4035 cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints )
4036 END DO
4037 END DO
4038 END DO
4039
4040 END IF
4041
4042 RETURN
4043
4044 END SUBROUTINE copy_fcni
4045
4046 !==================================
4047
4048 SUBROUTINE bdy_interp ( cfld, & ! CD field
4049 cids, cide, ckds, ckde, cjds, cjde, &
4050 cims, cime, ckms, ckme, cjms, cjme, &
4051 cits, cite, ckts, ckte, cjts, cjte, &
4052 nfld, & ! ND field
4053 nids, nide, nkds, nkde, njds, njde, &
4054 nims, nime, nkms, nkme, njms, njme, &
4055 nits, nite, nkts, nkte, njts, njte, &
4056 shw, & ! stencil half width
4057 imask, & ! interpolation mask
4058 xstag, ystag, & ! staggering of field
4059 ipos, jpos, & ! Position of lower left of nest in CD
4060 nri, nrj, & ! nest ratios
4061 cbdy_xs, nbdy_xs, &
4062 cbdy_xe, nbdy_xe, &
4063 cbdy_ys, nbdy_ys, &
4064 cbdy_ye, nbdy_ye, &
4065 cbdy_txs, nbdy_txs, &
4066 cbdy_txe, nbdy_txe, &
4067 cbdy_tys, nbdy_tys, &
4068 cbdy_tye, nbdy_tye, &
4069 cdt, ndt &
4070 ) ! boundary arrays
4071 USE module_configure
4072 IMPLICIT NONE
4073
4074 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
4075 cims, cime, ckms, ckme, cjms, cjme, &
4076 cits, cite, ckts, ckte, cjts, cjte, &
4077 nids, nide, nkds, nkde, njds, njde, &
4078 nims, nime, nkms, nkme, njms, njme, &
4079 nits, nite, nkts, nkte, njts, njte, &
4080 shw, &
4081 ipos, jpos, &
4082 nri, nrj
4083
4084 LOGICAL, INTENT(IN) :: xstag, ystag
4085
4086 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
4087 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
4088 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
4089 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs
4090 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe
4091 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys
4092 REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye
4093 REAL cdt, ndt
4094
4095 ! Local
4096
4097 INTEGER nijds, nijde, spec_bdy_width
4098
4099 nijds = min(nids, njds)
4100 nijde = max(nide, njde)
4101 CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
4102
4103 CALL bdy_interp1( cfld, & ! CD field
4104 cids, cide, ckds, ckde, cjds, cjde, &
4105 cims, cime, ckms, ckme, cjms, cjme, &
4106 cits, cite, ckts, ckte, cjts, cjte, &
4107 nfld, & ! ND field
4108 nijds, nijde , spec_bdy_width , &
4109 nids, nide, nkds, nkde, njds, njde, &
4110 nims, nime, nkms, nkme, njms, njme, &
4111 nits, nite, nkts, nkte, njts, njte, &
4112 shw, imask, &
4113 xstag, ystag, & ! staggering of field
4114 ipos, jpos, & ! Position of lower left of nest in CD
4115 nri, nrj, &
4116 cbdy_xs, nbdy_xs, &
4117 cbdy_xe, nbdy_xe, &
4118 cbdy_ys, nbdy_ys, &
4119 cbdy_ye, nbdy_ye, &
4120 cbdy_txs, nbdy_txs, &
4121 cbdy_txe, nbdy_txe, &
4122 cbdy_tys, nbdy_tys, &
4123 cbdy_tye, nbdy_tye, &
4124 cdt, ndt &
4125 )
4126
4127 RETURN
4128
4129 END SUBROUTINE bdy_interp
4130
4131 SUBROUTINE bdy_interp1( cfld, & ! CD field
4132 cids, cide, ckds, ckde, cjds, cjde, &
4133 cims, cime, ckms, ckme, cjms, cjme, &
4134 cits, cite, ckts, ckte, cjts, cjte, &
4135 nfld, & ! ND field
4136 nijds, nijde, spec_bdy_width , &
4137 nids, nide, nkds, nkde, njds, njde, &
4138 nims, nime, nkms, nkme, njms, njme, &
4139 nits, nite, nkts, nkte, njts, njte, &
4140 shw1, &
4141 imask, & ! interpolation mask
4142 xstag, ystag, & ! staggering of field
4143 ipos, jpos, & ! Position of lower left of nest in CD
4144 nri, nrj, &
4145 cbdy_xs, bdy_xs, &
4146 cbdy_xe, bdy_xe, &
4147 cbdy_ys, bdy_ys, &
4148 cbdy_ye, bdy_ye, &
4149 cbdy_txs, bdy_txs, &
4150 cbdy_txe, bdy_txe, &
4151 cbdy_tys, bdy_tys, &
4152 cbdy_tye, bdy_tye, &
4153 cdt, ndt &
4154 )
4155
4156 USE module_configure
4157 use module_state_description
4158 IMPLICIT NONE
4159
4160 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
4161 cims, cime, ckms, ckme, cjms, cjme, &
4162 cits, cite, ckts, ckte, cjts, cjte, &
4163 nids, nide, nkds, nkde, njds, njde, &
4164 nims, nime, nkms, nkme, njms, njme, &
4165 nits, nite, nkts, nkte, njts, njte, &
4166 shw1, & ! ignore
4167 ipos, jpos, &
4168 nri, nrj
4169 INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width
4170 LOGICAL, INTENT(IN) :: xstag, ystag
4171
4172 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld
4173 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld
4174 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
4175 REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs ! not used
4176 REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe ! not used
4177 REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys ! not used
4178 REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye ! not used
4179 REAL :: cdt, ndt
4180 REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs
4181 REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe
4182 REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys
4183 REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye
4184
4185 ! Local
4186
4187 REAL*8 rdt
4188 INTEGER ci, cj, ck, ni, nj, nk, ni1, nj1, nk1, ip, jp, ioff, joff
4189 #ifdef MM5_SINT
4190 INTEGER nfx, ior
4191 PARAMETER (ior=2)
4192 INTEGER nf
4193 REAL psca1(cims:cime,cjms:cjme,nri*nrj)
4194 REAL psca(cims:cime,cjms:cjme,nri*nrj)
4195 LOGICAL icmask( cims:cime, cjms:cjme )
4196 INTEGER i,j,k
4197 #endif
4198 INTEGER shw
4199 INTEGER spec_zone
4200 INTEGER relax_zone
4201 INTEGER sz
4202 INTEGER n2ci,n
4203 INTEGER n2cj
4204
4205 ! statement functions for converting a nest index to coarse
4206 n2ci(n) = (n+ipos*nri-1)/nri
4207 n2cj(n) = (n+jpos*nrj-1)/nrj
4208
4209 #if (DA_CORE != 1)
4210 rdt = 1.D0/cdt
4211
4212 shw = 0
4213
4214 ioff = 0 ; joff = 0
4215 IF ( xstag ) ioff = (nri-1)/2
4216 IF ( ystag ) joff = (nrj-1)/2
4217
4218 ! Iterate over the ND tile and compute the values
4219 ! from the CD tile.
4220
4221 #ifdef MM5_SINT
4222 CALL nl_get_spec_zone( 1, spec_zone )
4223 CALL nl_get_relax_zone( 1, relax_zone )
4224 sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width)
4225
4226 nfx = nri * nrj
4227
4228 !$OMP PARALLEL DO &
4229 !$OMP PRIVATE ( i,j,k,ni,nj,ni1,nj1,ci,cj,ip,jp,nk,ck,nf,icmask,psca,psca1 )
4230 DO k = ckts, ckte
4231
4232 DO nf = 1,nfx
4233 DO j = cjms,cjme
4234 nj = (j-jpos) * nrj + ( nrj / 2 + 1 ) ! j point on nest
4235 DO i = cims,cime
4236 ni = (i-ipos) * nri + ( nri / 2 + 1 ) ! i point on nest
4237 psca1(i,j,nf) = cfld(i,k,j)
4238 ENDDO
4239 ENDDO
4240 ENDDO
4241 ! hopefully less ham handed but still correct and more efficient
4242 ! sintb ignores icmask so it does not matter that icmask is not set
4243 !
4244 ! SOUTH BDY
4245 IF ( njts .ge. njds .and. njts .le. njds + sz + joff ) THEN
4246 CALL sintb( psca1, psca, &
4247 cims, cime, cjms, cjme, icmask, &
4248 n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njds)), n2cj(MIN(njte,njds+sz+joff)), nrj*nri, xstag, ystag )
4249 ENDIF
4250 ! NORTH BDY
4251 IF ( njte .le. njde .and. njte .ge. njde - sz - joff ) THEN
4252 CALL sintb( psca1, psca, &
4253 cims, cime, cjms, cjme, icmask, &
4254 n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njde-sz-joff)), n2cj(MIN(njte,njde-1+joff)), nrj*nri, xstag, ystag )
4255 ENDIF
4256 ! WEST BDY
4257 IF ( nits .ge. nids .and. nits .le. nids + sz + ioff ) THEN
4258 CALL sintb( psca1, psca, &
4259 cims, cime, cjms, cjme, icmask, &
4260 n2ci(MAX(nits,nids)), n2ci(MIN(nite,nids+sz+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag )
4261 ENDIF
4262 ! EAST BDY
4263 IF ( nite .le. nide .and. nite .ge. nide - sz - ioff ) THEN
4264 CALL sintb( psca1, psca, &
4265 cims, cime, cjms, cjme, icmask, &
4266 n2ci(MAX(nits,nide-sz-ioff)), n2ci(MIN(nite,nide-1+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag )
4267 ENDIF
4268
4269 DO nj1 = MAX(njds,njts-1), MIN(njde+joff,njte+joff+1)
4270 cj = jpos + (nj1-1) / nrj ! j coord of CD point
4271 jp = mod ( nj1-1 , nrj ) ! coord of ND w/i CD point
4272 nk = k
4273 ck = nk
4274 DO ni1 = MAX(nids,nits-1), MIN(nide+ioff,nite+ioff+1)
4275 ci = ipos + (ni1-1) / nri ! j coord of CD point
4276 ip = mod ( ni1-1 , nri ) ! coord of ND w/i CD point
4277
4278 ni = ni1-ioff
4279 nj = nj1-joff
4280
4281 IF ( ( ni.LT.nids) .OR. (nj.LT.njds) ) THEN
4282 CYCLE
4283 END IF
4284
4285 !bdy contains the value at t-dt. psca contains the value at t
4286 !compute dv/dt and store in bdy_t
4287 !afterwards store the new value of v at t into bdy
4288 ! WEST
4289 IF ( ni .ge. nids .and. ni .lt. nids + sz ) THEN
4290 bdy_txs( nj,k,ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
4291 bdy_xs( nj,k,ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
4292 ENDIF
4293
4294 ! SOUTH
4295 IF ( nj .ge. njds .and. nj .lt. njds + sz ) THEN
4296 bdy_tys( ni,k,nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
4297 bdy_ys( ni,k,nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
4298 ENDIF
4299
4300 ! EAST
4301 IF ( xstag ) THEN
4302 IF ( ni .ge. nide - sz + 1 .AND. ni .le. nide ) THEN
4303 bdy_txe( nj,k,nide-ni+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
4304 bdy_xe( nj,k,nide-ni+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
4305 ENDIF
4306 ELSE
4307 IF ( ni .ge. nide - sz .AND. ni .le. nide-1 ) THEN
4308 bdy_txe( nj,k,nide-ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
4309 bdy_xe( nj,k,nide-ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
4310 ENDIF
4311 ENDIF
4312
4313 ! NORTH
4314 IF ( ystag ) THEN
4315 IF ( nj .ge. njde - sz + 1 .AND. nj .le. njde ) THEN
4316 bdy_tye( ni,k,njde-nj+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
4317 bdy_ye( ni,k,njde-nj+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
4318 ENDIF
4319 ELSE
4320 IF ( nj .ge. njde - sz .AND. nj .le. njde-1 ) THEN
4321 bdy_tye(ni,k,njde-nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj))
4322 bdy_ye( ni,k,njde-nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri )
4323 ENDIF
4324 ENDIF
4325
4326 ENDDO
4327 ENDDO
4328 ENDDO
4329 !$OMP END PARALLEL DO
4330 #endif
4331
4332 #ifdef DUMBCOPY
4333 !write(0,'("cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme
4334 !write(0,'("nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme
4335 !write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
4336 !write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
4337
4338 DO nj = njts, njte
4339 cj = jpos + (nj-1) / nrj ! j coord of CD point
4340 jp = mod ( nj , nrj ) ! coord of ND w/i CD point
4341 DO nk = nkts, nkte
4342 ck = nk
4343 DO ni = nits, nite
4344 ci = ipos + (ni-1) / nri ! j coord of CD point
4345 ip = mod ( ni , nri ) ! coord of ND w/i CD point
4346 ! This is a trivial implementation of the interp_fcn; just copies
4347 ! the values from the CD into the ND
4348 nfld( ni, nk, nj ) = cfld( ci , ck , cj )
4349 ENDDO
4350 ENDDO
4351 ENDDO
4352 #endif
4353 #endif
4354
4355 RETURN
4356
4357 END SUBROUTINE bdy_interp1
4358
4359
4360
4361 SUBROUTINE interp_fcni( cfld, & ! CD field
4362 cids, cide, ckds, ckde, cjds, cjde, &
4363 cims, cime, ckms, ckme, cjms, cjme, &
4364 cits, cite, ckts, ckte, cjts, cjte, &
4365 nfld, & ! ND field
4366 nids, nide, nkds, nkde, njds, njde, &
4367 nims, nime, nkms, nkme, njms, njme, &
4368 nits, nite, nkts, nkte, njts, njte, &
4369 shw, & ! stencil half width
4370 imask, & ! interpolation mask
4371 xstag, ystag, & ! staggering of field
4372 ipos, jpos, & ! Position of lower left of nest in CD
4373 nri, nrj ) ! nest ratios
4374 USE module_configure
4375 IMPLICIT NONE
4376
4377
4378 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
4379 cims, cime, ckms, ckme, cjms, cjme, &
4380 cits, cite, ckts, ckte, cjts, cjte, &
4381 nids, nide, nkds, nkde, njds, njde, &
4382 nims, nime, nkms, nkme, njms, njme, &
4383 nits, nite, nkts, nkte, njts, njte, &
4384 shw, &
4385 ipos, jpos, &
4386 nri, nrj
4387 LOGICAL, INTENT(IN) :: xstag, ystag
4388
4389 INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
4390 INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
4391 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
4392
4393 ! Local
4394
4395 INTEGER ci, cj, ck, ni, nj, nk, ip, jp
4396
4397 ! Iterate over the ND tile and compute the values
4398 ! from the CD tile.
4399
4400 !write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
4401 !write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
4402
4403 DO nj = njts, njte
4404 cj = jpos + (nj-1) / nrj ! j coord of CD point
4405 jp = mod ( nj , nrj ) ! coord of ND w/i CD point
4406 DO nk = nkts, nkte
4407 ck = nk
4408 DO ni = nits, nite
4409 ci = ipos + (ni-1) / nri ! j coord of CD point
4410 ip = mod ( ni , nri ) ! coord of ND w/i CD point
4411 ! This is a trivial implementation of the interp_fcn; just copies
4412 ! the values from the CD into the ND
4413 nfld( ni, nk, nj ) = cfld( ci , ck , cj )
4414 ENDDO
4415 ENDDO
4416 ENDDO
4417
4418 RETURN
4419
4420 END SUBROUTINE interp_fcni
4421
4422 SUBROUTINE interp_fcnm( cfld, & ! CD field
4423 cids, cide, ckds, ckde, cjds, cjde, &
4424 cims, cime, ckms, ckme, cjms, cjme, &
4425 cits, cite, ckts, ckte, cjts, cjte, &
4426 nfld, & ! ND field
4427 nids, nide, nkds, nkde, njds, njde, &
4428 nims, nime, nkms, nkme, njms, njme, &
4429 nits, nite, nkts, nkte, njts, njte, &
4430 shw, & ! stencil half width
4431 imask, & ! interpolation mask
4432 xstag, ystag, & ! staggering of field
4433 ipos, jpos, & ! Position of lower left of nest in CD
4434 nri, nrj ) ! nest ratios
4435 USE module_configure
4436 IMPLICIT NONE
4437
4438
4439 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
4440 cims, cime, ckms, ckme, cjms, cjme, &
4441 cits, cite, ckts, ckte, cjts, cjte, &
4442 nids, nide, nkds, nkde, njds, njde, &
4443 nims, nime, nkms, nkme, njms, njme, &
4444 nits, nite, nkts, nkte, njts, njte, &
4445 shw, &
4446 ipos, jpos, &
4447 nri, nrj
4448 LOGICAL, INTENT(IN) :: xstag, ystag
4449
4450 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
4451 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
4452 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
4453
4454 ! Local
4455
4456 INTEGER ci, cj, ck, ni, nj, nk, ip, jp
4457
4458 ! Iterate over the ND tile and compute the values
4459 ! from the CD tile.
4460
4461 !write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte
4462 !write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte
4463
4464 DO nj = njts, njte
4465 cj = jpos + (nj-1) / nrj ! j coord of CD point
4466 jp = mod ( nj , nrj ) ! coord of ND w/i CD point
4467 DO nk = nkts, nkte
4468 ck = nk
4469 DO ni = nits, nite
4470 ci = ipos + (ni-1) / nri ! j coord of CD point
4471 ip = mod ( ni , nri ) ! coord of ND w/i CD point
4472 ! This is a trivial implementation of the interp_fcn; just copies
4473 ! the values from the CD into the ND
4474 nfld( ni, nk, nj ) = cfld( ci , ck , cj )
4475 ENDDO
4476 ENDDO
4477 ENDDO
4478
4479 RETURN
4480
4481 END SUBROUTINE interp_fcnm
4482
4483 SUBROUTINE interp_mask_land_field ( cfld, & ! CD field
4484 cids, cide, ckds, ckde, cjds, cjde, &
4485 cims, cime, ckms, ckme, cjms, cjme, &
4486 cits, cite, ckts, ckte, cjts, cjte, &
4487 nfld, & ! ND field
4488 nids, nide, nkds, nkde, njds, njde, &
4489 nims, nime, nkms, nkme, njms, njme, &
4490 nits, nite, nkts, nkte, njts, njte, &
4491 shw, & ! stencil half width
4492 imask, & ! interpolation mask
4493 xstag, ystag, & ! staggering of field
4494 ipos, jpos, & ! Position of lower left of nest in CD
4495 nri, nrj, & ! nest ratios
4496 clu, nlu )
4497
4498 USE module_configure
4499 USE module_wrf_error
4500
4501 IMPLICIT NONE
4502
4503
4504 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
4505 cims, cime, ckms, ckme, cjms, cjme, &
4506 cits, cite, ckts, ckte, cjts, cjte, &
4507 nids, nide, nkds, nkde, njds, njde, &
4508 nims, nime, nkms, nkme, njms, njme, &
4509 nits, nite, nkts, nkte, njts, njte, &
4510 shw, &
4511 ipos, jpos, &
4512 nri, nrj
4513 LOGICAL, INTENT(IN) :: xstag, ystag
4514
4515 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
4516 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
4517 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
4518
4519 REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
4520 REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
4521
4522 ! Local
4523
4524 INTEGER ci, cj, ck, ni, nj, nk, ip, jp
4525 INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater
4526 REAL :: avg , sum , dx , dy
4527 INTEGER , PARAMETER :: max_search = 5
4528 CHARACTER*120 message
4529
4530 ! Find out what the water value is.
4531
4532 CALL nl_get_iswater(1,iswater)
4533
4534 ! Right now, only mass point locations permitted.
4535
4536 IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
4537
4538 ! Loop over each i,k,j in the nested domain.
4539
4540 DO nj = njts, njte
4541 IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
4542 cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4543 ELSE
4544 cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4545 END IF
4546 DO nk = nkts, nkte
4547 ck = nk
4548 DO ni = nits, nite
4549 IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
4550 ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4551 ELSE
4552 ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4553 END IF
4554
4555
4556
4557
4558 !
4559 ! (ci,cj+1) (ci+1,cj+1)
4560 ! - -------------
4561 ! 1-dy | | |
4562 ! | | |
4563 ! - | * |
4564 ! dy | | (ni,nj) |
4565 ! | | |
4566 ! - -------------
4567 ! (ci,cj) (ci+1,cj)
4568 !
4569 ! |--|--------|
4570 ! dx 1-dx
4571
4572
4573 ! For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0
4574
4575 IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
4576 dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri )
4577 ELSE
4578 dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri )
4579 END IF
4580 IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
4581 dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj )
4582 ELSE
4583 dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj )
4584 END IF
4585
4586 ! This is a "land only" field. If this is a water point, no operations required.
4587
4588 IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) ) THEN
4589 ! noop
4590 ! nfld(ni,nk,nj) = 1.e20
4591 nfld(ni,nk,nj) = -1
4592
4593 ! If this is a nested land point, and the surrounding coarse values are all land points,
4594 ! then this is a simple 4-pt interpolation.
4595
4596 ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. &
4597 ( NINT(clu(ci ,cj )) .NE. iswater ) .AND. &
4598 ( NINT(clu(ci+1,cj )) .NE. iswater ) .AND. &
4599 ( NINT(clu(ci ,cj+1)) .NE. iswater ) .AND. &
4600 ( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN
4601 nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + &
4602 dy * cfld(ci ,ck,cj+1) ) + &
4603 dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + &
4604 dy * cfld(ci+1,ck,cj+1) )
4605
4606 ! If this is a nested land point and there are NO coarse land values surrounding,
4607 ! we temporarily punt.
4608
4609 ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. &
4610 ( NINT(clu(ci ,cj )) .EQ. iswater ) .AND. &
4611 ( NINT(clu(ci+1,cj )) .EQ. iswater ) .AND. &
4612 ( NINT(clu(ci ,cj+1)) .EQ. iswater ) .AND. &
4613 ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN
4614 ! nfld(ni,nk,nj) = -1.e20
4615 nfld(ni,nk,nj) = -1
4616
4617 ! If there are some water points and some land points, take an average.
4618
4619 ELSE IF ( NINT(nlu(ni ,nj )) .NE. iswater ) THEN
4620 icount = 0
4621 sum = 0
4622 IF ( NINT(clu(ci ,cj )) .NE. iswater ) THEN
4623 icount = icount + 1
4624 sum = sum + cfld(ci ,ck,cj )
4625 END IF
4626 IF ( NINT(clu(ci+1,cj )) .NE. iswater ) THEN
4627 icount = icount + 1
4628 sum = sum + cfld(ci+1,ck,cj )
4629 END IF
4630 IF ( NINT(clu(ci ,cj+1)) .NE. iswater ) THEN
4631 icount = icount + 1
4632 sum = sum + cfld(ci ,ck,cj+1)
4633 END IF
4634 IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN
4635 icount = icount + 1
4636 sum = sum + cfld(ci+1,ck,cj+1)
4637 END IF
4638 nfld(ni,nk,nj) = sum / REAL ( icount )
4639 END IF
4640 END DO
4641 END DO
4642 END DO
4643
4644 ! Get an average of the whole domain for problem locations.
4645
4646 sum = 0
4647 icount = 0
4648 DO nj = njts, njte
4649 DO nk = nkts, nkte
4650 DO ni = nits, nite
4651 IF ( ( nfld(ni,nk,nj) .GT. -1.e19 ) .AND. ( nfld(ni,nk,nj) .LT. 1.e19 ) ) THEN
4652 icount = icount + 1
4653 sum = sum + nfld(ni,nk,nj)
4654 END IF
4655 END DO
4656 END DO
4657 END DO
4658 CALL wrf_dm_bcast_real( sum, 1 )
4659 IF ( icount .GT. 0 ) THEN
4660 avg = sum / REAL ( icount )
4661
4662 ! OK, if there were any of those island situations, we try to search a bit broader
4663 ! of an area in the coarse grid.
4664
4665 DO nj = njts, njte
4666 DO nk = nkts, nkte
4667 DO ni = nits, nite
4668 IF ( nfld(ni,nk,nj) .LT. -1.e19 ) THEN
4669 IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
4670 cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4671 ELSE
4672 cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4673 END IF
4674 IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
4675 ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4676 ELSE
4677 ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4678 END IF
4679 ist = MAX (ci-max_search,cits)
4680 ien = MIN (ci+max_search,cite,cide-1)
4681 jst = MAX (cj-max_search,cjts)
4682 jen = MIN (cj+max_search,cjte,cjde-1)
4683 icount = 0
4684 sum = 0
4685 DO jj = jst,jen
4686 DO ii = ist,ien
4687 IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN
4688 icount = icount + 1
4689 sum = sum + cfld(ii,nk,jj)
4690 END IF
4691 END DO
4692 END DO
4693 IF ( icount .GT. 0 ) THEN
4694 nfld(ni,nk,nj) = sum / REAL ( icount )
4695 ELSE
4696 ! CALL wrf_error_fatal ( "horizontal interp error - island" )
4697 write(message,*) 'horizontal interp error - island, using average ', avg
4698 CALL wrf_message ( message )
4699 nfld(ni,nk,nj) = avg
4700 END IF
4701 END IF
4702 END DO
4703 END DO
4704 END DO
4705 ENDIF
4706 ELSE
4707 CALL wrf_error_fatal ( "only unstaggered fields right now" )
4708 END IF
4709
4710 END SUBROUTINE interp_mask_land_field
4711
4712 SUBROUTINE interp_mask_water_field ( cfld, & ! CD field
4713 cids, cide, ckds, ckde, cjds, cjde, &
4714 cims, cime, ckms, ckme, cjms, cjme, &
4715 cits, cite, ckts, ckte, cjts, cjte, &
4716 nfld, & ! ND field
4717 nids, nide, nkds, nkde, njds, njde, &
4718 nims, nime, nkms, nkme, njms, njme, &
4719 nits, nite, nkts, nkte, njts, njte, &
4720 shw, & ! stencil half width
4721 imask, & ! interpolation mask
4722 xstag, ystag, & ! staggering of field
4723 ipos, jpos, & ! Position of lower left of nest in CD
4724 nri, nrj, & ! nest ratios
4725 clu, nlu )
4726
4727 USE module_configure
4728 USE module_wrf_error
4729
4730 IMPLICIT NONE
4731
4732
4733 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
4734 cims, cime, ckms, ckme, cjms, cjme, &
4735 cits, cite, ckts, ckte, cjts, cjte, &
4736 nids, nide, nkds, nkde, njds, njde, &
4737 nims, nime, nkms, nkme, njms, njme, &
4738 nits, nite, nkts, nkte, njts, njte, &
4739 shw, &
4740 ipos, jpos, &
4741 nri, nrj
4742 LOGICAL, INTENT(IN) :: xstag, ystag
4743
4744 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
4745 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
4746 INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
4747
4748 REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
4749 REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
4750
4751 ! Local
4752
4753 INTEGER ci, cj, ck, ni, nj, nk, ip, jp
4754 INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater
4755 REAL :: avg , sum , dx , dy
4756 INTEGER , PARAMETER :: max_search = 5
4757
4758 ! Find out what the water value is.
4759
4760 CALL nl_get_iswater(1,iswater)
4761
4762 ! Right now, only mass point locations permitted.
4763
4764 IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
4765
4766 ! Loop over each i,k,j in the nested domain.
4767
4768 DO nj = njts, njte
4769 IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
4770 cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4771 ELSE
4772 cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4773 END IF
4774 DO nk = nkts, nkte
4775 ck = nk
4776 DO ni = nits, nite
4777 IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
4778 ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4779 ELSE
4780 ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4781 END IF
4782
4783
4784
4785
4786 !
4787 ! (ci,cj+1) (ci+1,cj+1)
4788 ! - -------------
4789 ! 1-dy | | |
4790 ! | | |
4791 ! - | * |
4792 ! dy | | (ni,nj) |
4793 ! | | |
4794 ! - -------------
4795 ! (ci,cj) (ci+1,cj)
4796 !
4797 ! |--|--------|
4798 ! dx 1-dx
4799
4800
4801 ! At ni=2, we are on the coarse grid point, so dx = 0
4802
4803 IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
4804 dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri )
4805 ELSE
4806 dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri )
4807 END IF
4808 IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
4809 dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj )
4810 ELSE
4811 dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj )
4812 END IF
4813
4814 ! This is a "water only" field. If this is a land point, no operations required.
4815
4816 IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) ) THEN
4817 ! noop
4818 ! nfld(ni,nk,nj) = 1.e20
4819 nfld(ni,nk,nj) = -1
4820
4821 ! If this is a nested water point, and the surrounding coarse values are all water points,
4822 ! then this is a simple 4-pt interpolation.
4823
4824 ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) .AND. &
4825 ( NINT(clu(ci ,cj )) .EQ. iswater ) .AND. &
4826 ( NINT(clu(ci+1,cj )) .EQ. iswater ) .AND. &
4827 ( NINT(clu(ci ,cj+1)) .EQ. iswater ) .AND. &
4828 ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN
4829 nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + &
4830 dy * cfld(ci ,ck,cj+1) ) + &
4831 dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + &
4832 dy * cfld(ci+1,ck,cj+1) )
4833
4834 ! If this is a nested water point and there are NO coarse water values surrounding,
4835 ! we temporarily punt.
4836
4837 ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) .AND. &
4838 ( NINT(clu(ci ,cj )) .NE. iswater ) .AND. &
4839 ( NINT(clu(ci+1,cj )) .NE. iswater ) .AND. &
4840 ( NINT(clu(ci ,cj+1)) .NE. iswater ) .AND. &
4841 ( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN
4842 ! nfld(ni,nk,nj) = -1.e20
4843 nfld(ni,nk,nj) = -1
4844
4845 ! If there are some land points and some water points, take an average.
4846
4847 ELSE IF ( NINT(nlu(ni ,nj )) .EQ. iswater ) THEN
4848 icount = 0
4849 sum = 0
4850 IF ( NINT(clu(ci ,cj )) .EQ. iswater ) THEN
4851 icount = icount + 1
4852 sum = sum + cfld(ci ,ck,cj )
4853 END IF
4854 IF ( NINT(clu(ci+1,cj )) .EQ. iswater ) THEN
4855 icount = icount + 1
4856 sum = sum + cfld(ci+1,ck,cj )
4857 END IF
4858 IF ( NINT(clu(ci ,cj+1)) .EQ. iswater ) THEN
4859 icount = icount + 1
4860 sum = sum + cfld(ci ,ck,cj+1)
4861 END IF
4862 IF ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) THEN
4863 icount = icount + 1
4864 sum = sum + cfld(ci+1,ck,cj+1)
4865 END IF
4866 nfld(ni,nk,nj) = sum / REAL ( icount )
4867 END IF
4868 END DO
4869 END DO
4870 END DO
4871
4872 ! Get an average of the whole domain for problem locations.
4873
4874 sum = 0
4875 icount = 0
4876 DO nj = njts, njte
4877 DO nk = nkts, nkte
4878 DO ni = nits, nite
4879 IF ( ( nfld(ni,nk,nj) .GT. -1.e19 ) .AND. ( nfld(ni,nk,nj) .LT. 1.e19 ) ) THEN
4880 icount = icount + 1
4881 sum = sum + nfld(ni,nk,nj)
4882 END IF
4883 END DO
4884 END DO
4885 END DO
4886 avg = sum / REAL ( icount )
4887
4888
4889 ! OK, if there were any of those lake situations, we try to search a bit broader
4890 ! of an area in the coarse grid.
4891
4892 DO nj = njts, njte
4893 DO nk = nkts, nkte
4894 DO ni = nits, nite
4895 IF ( nfld(ni,nk,nj) .LT. -1.e19 ) THEN
4896 IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
4897 cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4898 ELSE
4899 cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
4900 END IF
4901 IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
4902 ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4903 ELSE
4904 ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
4905 END IF
4906 ist = MAX (ci-max_search,cits)
4907 ien = MIN (ci+max_search,cite,cide-1)
4908 jst = MAX (cj-max_search,cjts)
4909 jen = MIN (cj+max_search,cjte,cjde-1)
4910 icount = 0
4911 sum = 0
4912 DO jj = jst,jen
4913 DO ii = ist,ien
4914 IF ( NINT(clu(ii,jj)) .EQ. iswater ) THEN
4915 icount = icount + 1
4916 sum = sum + cfld(ii,nk,jj)
4917 END IF
4918 END DO
4919 END DO
4920 IF ( icount .GT. 0 ) THEN
4921 nfld(ni,nk,nj) = sum / REAL ( icount )
4922 ELSE
4923 ! CALL wrf_error_fatal ( "horizontal interp error - lake" )
4924 print *,'horizontal interp error - lake, using average ',avg
4925 nfld(ni,nk,nj) = avg
4926 END IF
4927 END IF
4928 END DO
4929 END DO
4930 END DO
4931 ELSE
4932 CALL wrf_error_fatal ( "only unstaggered fields right now" )
4933 END IF
4934
4935 END SUBROUTINE interp_mask_water_field
4936
4937 SUBROUTINE none
4938 END SUBROUTINE none
4939
4940 SUBROUTINE smoother ( cfld , &
4941 cids, cide, ckds, ckde, cjds, cjde, &
4942 cims, cime, ckms, ckme, cjms, cjme, &
4943 cits, cite, ckts, ckte, cjts, cjte, &
4944 nids, nide, nkds, nkde, njds, njde, &
4945 nims, nime, nkms, nkme, njms, njme, &
4946 nits, nite, nkts, nkte, njts, njte, &
4947 xstag, ystag, & ! staggering of field
4948 ipos, jpos, & ! Position of lower left of nest in
4949 nri, nrj &
4950 )
4951
4952 USE module_configure
4953 IMPLICIT NONE
4954
4955 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
4956 cims, cime, ckms, ckme, cjms, cjme, &
4957 cits, cite, ckts, ckte, cjts, cjte, &
4958 nids, nide, nkds, nkde, njds, njde, &
4959 nims, nime, nkms, nkme, njms, njme, &
4960 nits, nite, nkts, nkte, njts, njte, &
4961 nri, nrj, &
4962 ipos, jpos
4963 LOGICAL, INTENT(IN) :: xstag, ystag
4964 INTEGER :: smooth_option, feedback , spec_zone
4965
4966 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
4967
4968 ! If there is no feedback, there can be no smoothing.
4969
4970 CALL nl_get_feedback ( 1, feedback )
4971 IF ( feedback == 0 ) RETURN
4972 CALL nl_get_spec_zone ( 1, spec_zone )
4973
4974 ! These are the 2d smoothers used on the fedback data. These filters
4975 ! are run on the coarse grid data (after the nested info has been
4976 ! fedback). Only the area of the nest in the coarse grid is filtered.
4977
4978 CALL nl_get_smooth_option ( 1, smooth_option )
4979
4980 IF ( smooth_option == 0 ) THEN
4981 ! no op
4982 ELSE IF ( smooth_option == 1 ) THEN
4983 CALL sm121 ( cfld , &
4984 cids, cide, ckds, ckde, cjds, cjde, &
4985 cims, cime, ckms, ckme, cjms, cjme, &
4986 cits, cite, ckts, ckte, cjts, cjte, &
4987 xstag, ystag, & ! staggering of field
4988 nids, nide, nkds, nkde, njds, njde, &
4989 nims, nime, nkms, nkme, njms, njme, &
4990 nits, nite, nkts, nkte, njts, njte, &
4991 nri, nrj, &
4992 ipos, jpos & ! Position of lower left of nest in
4993 )
4994 ELSE IF ( smooth_option == 2 ) THEN
4995 CALL smdsm ( cfld , &
4996 cids, cide, ckds, ckde, cjds, cjde, &
4997 cims, cime, ckms, ckme, cjms, cjme, &
4998 cits, cite, ckts, ckte, cjts, cjte, &
4999 xstag, ystag, & ! staggering of field
5000 nids, nide, nkds, nkde, njds, njde, &
5001 nims, nime, nkms, nkme, njms, njme, &
5002 nits, nite, nkts, nkte, njts, njte, &
5003 nri, nrj, &
5004 ipos, jpos & ! Position of lower left of nest in
5005 )
5006 END IF
5007
5008 END SUBROUTINE smoother
5009
5010 SUBROUTINE sm121 ( cfld , &
5011 cids, cide, ckds, ckde, cjds, cjde, &
5012 cims, cime, ckms, ckme, cjms, cjme, &
5013 cits, cite, ckts, ckte, cjts, cjte, &
5014 xstag, ystag, & ! staggering of field
5015 nids, nide, nkds, nkde, njds, njde, &
5016 nims, nime, nkms, nkme, njms, njme, &
5017 nits, nite, nkts, nkte, njts, njte, &
5018 nri, nrj, &
5019 ipos, jpos & ! Position of lower left of nest in
5020 )
5021
5022 USE module_configure
5023 IMPLICIT NONE
5024
5025 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
5026 cims, cime, ckms, ckme, cjms, cjme, &
5027 cits, cite, ckts, ckte, cjts, cjte, &
5028 nids, nide, nkds, nkde, njds, njde, &
5029 nims, nime, nkms, nkme, njms, njme, &
5030 nits, nite, nkts, nkte, njts, njte, &
5031 nri, nrj, &
5032 ipos, jpos
5033 LOGICAL, INTENT(IN) :: xstag, ystag
5034
5035 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
5036 REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew
5037
5038 INTEGER :: i , j , k , loop
5039 INTEGER :: istag,jstag
5040
5041 INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt)
5042
5043 istag = 1 ; jstag = 1
5044 IF ( xstag ) istag = 0
5045 IF ( ystag ) jstag = 0
5046
5047 ! Simple 1-2-1 smoother.
5048
5049 smoothing_passes : DO loop = 1 , smooth_passes
5050
5051 DO k = ckts , ckte
5052
5053 ! Initialize dummy cfldnew
5054
5055 DO i = MAX(ipos,cits-3) , MIN(ipos+(nide-nids)/nri,cite+3)
5056 DO j = MAX(jpos,cjts-3) , MIN(jpos+(njde-njds)/nrj,cjte+3)
5057 cfldnew(i,j) = cfld(i,k,j)
5058 END DO
5059 END DO
5060
5061 ! 1-2-1 smoothing in the j direction first,
5062
5063 DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2)
5064 DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2)
5065 cfldnew(i,j) = 0.25 * ( cfld(i,k,j+1) + 2.*cfld(i,k,j) + cfld(i,k,j-1) )
5066 END DO
5067 END DO
5068
5069 ! then 1-2-1 smoothing in the i direction last
5070
5071 DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2)
5072 DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2)
5073 cfld(i,k,j) = 0.25 * ( cfldnew(i+1,j) + 2.*cfldnew(i,j) + cfldnew(i-1,j) )
5074 END DO
5075 END DO
5076
5077 END DO
5078
5079 END DO smoothing_passes
5080
5081 END SUBROUTINE sm121
5082
5083 SUBROUTINE smdsm ( cfld , &
5084 cids, cide, ckds, ckde, cjds, cjde, &
5085 cims, cime, ckms, ckme, cjms, cjme, &
5086 cits, cite, ckts, ckte, cjts, cjte, &
5087 xstag, ystag, & ! staggering of field
5088 nids, nide, nkds, nkde, njds, njde, &
5089 nims, nime, nkms, nkme, njms, njme, &
5090 nits, nite, nkts, nkte, njts, njte, &
5091 nri, nrj, &
5092 ipos, jpos & ! Position of lower left of nest in
5093 )
5094
5095 USE module_configure
5096 IMPLICIT NONE
5097
5098 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
5099 cims, cime, ckms, ckme, cjms, cjme, &
5100 cits, cite, ckts, ckte, cjts, cjte, &
5101 nids, nide, nkds, nkde, njds, njde, &
5102 nims, nime, nkms, nkme, njms, njme, &
5103 nits, nite, nkts, nkte, njts, njte, &
5104 nri, nrj, &
5105 ipos, jpos
5106 LOGICAL, INTENT(IN) :: xstag, ystag
5107
5108 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
5109 REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew
5110
5111 REAL , DIMENSION ( 2 ) :: xnu
5112 INTEGER :: i , j , k , loop , n
5113 INTEGER :: istag,jstag
5114
5115 INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt)
5116
5117 xnu = (/ 0.50 , -0.52 /)
5118
5119 istag = 1 ; jstag = 1
5120 IF ( xstag ) istag = 0
5121 IF ( ystag ) jstag = 0
5122
5123 ! The odd number passes of this are the "smoother", the even
5124 ! number passes are the "de-smoother" (note the different signs on xnu).
5125
5126 smoothing_passes : DO loop = 1 , smooth_passes * 2
5127
5128 n = 2 - MOD ( loop , 2 )
5129
5130 DO k = ckts , ckte
5131
5132 DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2)
5133 DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2)
5134 cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i,k,j+1) + cfld(i,k,j-1)) * 0.5-cfld(i,k,j))
5135 END DO
5136 END DO
5137
5138 DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2)
5139 DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2)
5140 cfld(i,k,j) = cfldnew(i,j)
5141 END DO
5142 END DO
5143
5144 DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2)
5145 DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2)
5146 cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i+1,k,j) + cfld(i-1,k,j)) * 0.5-cfld(i,k,j))
5147 END DO
5148 END DO
5149
5150 DO j = MAX(jpos+1,cjts-2) , MIN(jpos+(njde-njds)/nrj-1-jstag,cjte+2)
5151 DO i = MAX(ipos+1,cits-2) , MIN(ipos+(nide-nids)/nri-1-istag,cite+2)
5152 cfld(i,k,j) = cfldnew(i,j)
5153 END DO
5154 END DO
5155
5156 END DO
5157
5158 END DO smoothing_passes
5159
5160 END SUBROUTINE smdsm
5161
5162 !==================================
5163 ! this is used to modify a field over the nest so we can see where the nest is
5164
5165 SUBROUTINE mark_domain ( cfld, & ! CD field
5166 cids, cide, ckds, ckde, cjds, cjde, &
5167 cims, cime, ckms, ckme, cjms, cjme, &
5168 cits, cite, ckts, ckte, cjts, cjte, &
5169 nfld, & ! ND field
5170 nids, nide, nkds, nkde, njds, njde, &
5171 nims, nime, nkms, nkme, njms, njme, &
5172 nits, nite, nkts, nkte, njts, njte, &
5173 shw, & ! stencil half width for interp
5174 imask, & ! interpolation mask
5175 xstag, ystag, & ! staggering of field
5176 ipos, jpos, & ! Position of lower left of nest in CD
5177 nri, nrj ) ! nest ratios
5178 USE module_configure
5179 USE module_wrf_error
5180 IMPLICIT NONE
5181
5182
5183 INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, &
5184 cims, cime, ckms, ckme, cjms, cjme, &
5185 cits, cite, ckts, ckte, cjts, cjte, &
5186 nids, nide, nkds, nkde, njds, njde, &
5187 nims, nime, nkms, nkme, njms, njme, &
5188 nits, nite, nkts, nkte, njts, njte, &
5189 shw, &
5190 ipos, jpos, &
5191 nri, nrj
5192 LOGICAL, INTENT(IN) :: xstag, ystag
5193
5194 REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld
5195 REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld
5196 INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask
5197
5198 ! Local
5199
5200 INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa
5201 INTEGER :: icmin,icmax,jcmin,jcmax
5202 INTEGER :: istag,jstag, ipoints,jpoints,ijpoints
5203
5204 istag = 1 ; jstag = 1
5205 IF ( xstag ) istag = 0
5206 IF ( ystag ) jstag = 0
5207
5208 DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-jstag-1,cjte)
5209 nj = (cj-jpos)*nrj + jstag + 1
5210 DO ck = ckts, ckte
5211 nk = ck
5212 DO ci = MAX(ipos+1,cits),MIN(ipos+(nide-nids)/nri-istag-1,cite)
5213 ni = (ci-ipos)*nri + istag + 1
5214 cfld( ci, ck, cj ) = 9021000. !magic number: Beverly Hills * 100.
5215 ENDDO
5216 ENDDO
5217 ENDDO
5218
5219 END SUBROUTINE mark_domain
5220