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