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