ROMS
Loading...
Searching...
No Matches
ad_nesting.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE ad_nesting_mod
3
4#if defined NESTING && defined ADJOINT
5!
6!git $Id$
7!================================================== Hernan G. Arango ===
8! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore !
9! Licensed under a MIT/X style license !
10! See License_ROMS.md !
11!=======================================================================
12! !
13! This module contains several routines to process the connectivity !
14! between nested grids. It process the contact region points between !
15! data donor and data receiver grids. !
16! !
17! The locations of the linear interpolation weights in the donor !
18! grid with respect the receiver grid contact region at contact !
19! point x(Irg,Jrg,Krg) are: !
20! !
21! 8___________7 (Idg+1,Jdg+1,Kdg) !
22! /. /| !
23! / . / | !
24! (Idg,Jdg+1,Kdg) 5/___________/6 | !
25! | . | | !
26! | . x | | !
27! | 4.........|..|3 (Idg+1,Jdg+1,Kdg-1) !
28! | . | / !
29! |. | / !
30! |___________|/ !
31! (Idg,Jdg,Kdg-1) 1 2 !
32! !
33! Suffix: dg = donor grid !
34! rg = receiver grid !
35! !
36! Routines: !
37! ======== !
38! !
39! ad_nesting Public interface to time-stepping kernel !
40! !
41! ad_get_composite Composite grid, extracts contact points donor !
42! data !
43! ad_get_refine Refinement grid, extracts contact points donor !
44! data !
45! ad_put_composite Composite grid, fills contact points (spatial !
46! interpolation) !
47! ad_put_refine Refinement grid, fills contact points (spatial !
48! and temporal interpolation) !
49! !
50! ad_bry_fluxes Extracts horizontat advective fluxes the contact !
51! boundary of donor and receiver grids !
52# ifdef NESTING_DEBUG
53! ad_check_massflux If refinement, checks mass fluxes between coarse !
54! and fine grids for volume conservation. It is !
55! use only for debugging and diagnostics. !
56# endif
57! ad_correct_tracer Corrects coarse grid tracer at the refinement !
58! grid boundary with the refined accumulated !
59! fluxes !
60! ad_fine2coarse Replace coarse grid state variables with the !
61! averaged fine grid values (two-way nesting) !
62! !
63! ad_get_contact2d Gets 2D field donor grid cell holding contact !
64! point !
65! ad_get_contact3d Gets 3D field donor grid cell holding contact !
66! point !
67! ad_get_persisted2d Gets 2D field persisted values on contact points !
68! ad_put_contact2d Sets 2D field contact points, spatial !
69! interpolation !
70! ad_put_contact3d Sets 3D field contact points, spatial !
71! interpolation !
72! !
73! ad_put_refine2d Interpolates (space-time) 2D state variables !
74! ad_put_refine3d Interpolates (space-time) 3D state variables !
75! !
76! ad_z_weights Sets donor grid vertical indices (cell holding !
77! contact point) and vertical interpolation !
78! weights !
79! !
80! WARNINGS: !
81! ======== !
82! !
83! All the routines contained in this module are inside of a parallel !
84! region, except the main driver routine "nesting", which is called !
85! serially several times from main2d or main3d to perform different !
86! tasks. Notice that the calls to private "get_***" and "put_***" !
87! routines need to be in separated parallel loops because of serial !
88! with partitions and shared-memory rules. Furthermore, the donor !
89! and receiver grids may have different tile partitions. There is no !
90! I/O management inside the nesting routines. !
91! !
92! The connectivity between donor and receiver grids can be complex. !
93! The horizontal mapping between grids is static and done outside of !
94! ROMS. Only the time-dependent vertical interpolation weights are !
95! computed here. The contact region points I- and J-cell indices !
96! between donor and receiver grids, and the horizontal interpolation !
97! weights are read from the input nesting connectivity NetCDF file. !
98! It makes the nesting efficient and greatly simplifies parallelism. !
99! !
100!=======================================================================
101!
102 implicit none
103!
104 PUBLIC :: ad_nesting
105 PUBLIC :: ad_bry_fluxes
106# ifdef NESTING_DEBUG
107 PRIVATE :: ad_check_massflux
108# endif
109# ifdef SOLVE3D
110 PRIVATE :: ad_correct_tracer
111 PRIVATE :: ad_correct_tracer_tile
112# endif
113 PRIVATE :: ad_fine2coarse
114 PRIVATE :: ad_fine2coarse2d
115# ifdef SOLVE3D
116 PRIVATE :: ad_fine2coarse3d
117# endif
118 PRIVATE :: ad_get_contact2d
119# ifdef SOLVE3D
120 PRIVATE :: ad_get_contact3d
121# endif
122 PRIVATE :: ad_get_composite
123 PRIVATE :: ad_get_persisted2d
124 PRIVATE :: ad_get_refine
125 PRIVATE :: ad_put_composite
126 PRIVATE :: ad_put_refine
127 PRIVATE :: ad_put_refine2d
128# ifdef SOLVE3D
129 PRIVATE :: ad_put_refine3d
130 PRIVATE :: ad_z_weights
131# endif
132!
133 CONTAINS
134!
135 SUBROUTINE ad_nesting (ng, model, isection)
136!
137!=======================================================================
138! !
139! This routine process the contact region points between composite !
140! grids. In composite grids, it is possible to have more than one !
141! contact region. !
142! !
143! On Input: !
144! !
145! ng Data receiver grid number (integer) !
146! model Calling model identifier (integer) !
147! isection Governing equations time-stepping section in !
148! main2d or main3d indicating which state !
149! variables to process (integer) !
150! !
151!=======================================================================
152!
153 USE mod_param
154 USE mod_parallel
155 USE mod_ncparam
156 USE mod_nesting
157 USE mod_scalars
158!
159# ifdef SOLVE3D
160 USE set_depth_mod, ONLY : set_depth
161# endif
162 USE ad_set_depth_mod, ONLY : ad_set_depth
163 USE nesting_mod, ONLY : get_metrics
164 USE nesting_mod, ONLY : mask_hweights
165 USE nesting_mod, ONLY : z_weights
166 USE strings_mod, ONLY : founderror
167!
168! Imported variable declarations.
169!
170 integer, intent(in) :: ng, model, isection
171!
172! Local variable declarations.
173!
174 logical :: lputfsur
175 integer :: subs, tile, thread
176 integer :: ngc
177!
178 character (len=*), parameter :: myfile = &
179 & __FILE__
180
181# ifdef SOLVE3D
182!
183!-----------------------------------------------------------------------
184! Process vertical indices and interpolation weigths associated with
185! depth. Currently, vertical weights are used in composite grids
186! because their grids are not coincident. They are not needed in
187! refinement grids because the donor and receiver grids have the same
188! number of vertical levels and matching bathymetry. However, in
189! the future, it is possible to have configurations that require
190! vertical weights in refinement. The switch "get_Vweights" controls
191! if such weights are computed or not. If false, it will accelerate
192! computations because of less distributed-memory communications.
193!-----------------------------------------------------------------------
194!
195 IF ((isection.eq.nzwgt).and.get_vweights) THEN
196 DO tile=last_tile(ng),first_tile(ng),-1
197 CALL z_weights (ng, model, tile)
198 END DO
199!$OMP BARRIER
200 RETURN
201 END IF
202# endif
203
204# if defined MASKING || defined WET_DRY
205!
206!-----------------------------------------------------------------------
207! If Land/Sea masking, scale horizontal interpolation weights to
208! account for land contact points. If wetting and drying, the scaling
209! is done at every time-step because masking is time dependent.
210!-----------------------------------------------------------------------
211!
212 IF (isection.eq.nmask) THEN
213 DO tile=last_tile(ng),first_tile(ng),-1
214 CALL mask_hweights (ng, model, tile)
215 END DO
216!$OMP BARRIER
217 RETURN
218 END IF
219# endif
220!
221!-----------------------------------------------------------------------
222! If refinement grid, process contact points.
223!-----------------------------------------------------------------------
224!
225 IF (refinedgrid(ng)) THEN
226!
227! Extract grid spacing metrics (on_u and om_v) and load then to
228! REFINE(:) structure. These metrics are needed to impose mass
229! flux at the finer grid physical boundaries. It need to be done
230! separately because parallelism partions between all nested grid.
231!
232 IF (isection.eq.ndxdy) THEN
233 DO tile=first_tile(ng),last_tile(ng),+1
234 CALL get_metrics (ng, model, tile)
235 END DO
236!$OMP BARRIER
237!
238! Extract and store donor grid data at contact points.
239!
240 ELSE IF (isection.eq.ngetd) THEN
241 DO tile=first_tile(ng),last_tile(ng),+1
242!^ CALL tl_get_refine (ng, model, tile)
243!^
244 CALL ad_get_refine (ng, model, tile)
245 END DO
246!$OMP BARRIER
247!
248! Fill refinement grid contact points variables by interpolating
249! (space, time) from extracted donor grid data. The free-surface
250! needs to be processed first and in a separate parallel region
251! because of shared-memory applications.
252!
253 ELSE IF (isection.eq.nputd) THEN
254!$OMP BARRIER
255!
256 lputfsur=.false.
257 DO tile=first_tile(ng),last_tile(ng),+1
258!^ CALL tl_put_refine (ng, model, tile, LputFsur)
259!^
260 CALL ad_put_refine (ng, model, tile, lputfsur)
261 END DO
262!$OMP BARRIER
263 lputfsur=.true.
264 DO tile=first_tile(ng),last_tile(ng),+1
265!^ CALL tl_put_refine (ng, model, tile, LputFsur)
266!^
267 CALL ad_put_refine (ng, model, tile, lputfsur)
268 END DO
269
270# ifdef NESTING_DEBUG
271!
272! If refinement, check mass flux conservation between coarser and
273! finer grids. DIAGNOSTIC ONLY.
274!
275 ELSE IF (isection.eq.nmflx) THEN
276 DO tile=first_tile(ng),last_tile(ng),+1
277!^ CALL tl_check_massflux (ng, model, tile)
278!^
279 CALL ad_check_massflux (ng, model, tile)
280 END DO
281# endif
282
283# ifndef ONE_WAY
284!
285! Fine to coarse coupling: two-way nesting.
286!
287 ELSE IF (isection.eq.n2way) THEN
288
289 ngc=coarserdonor(ng) ! coarse grid number
290# ifdef SOLVE3D
291!$OMP BARRIER
292!
293! Replace coarse grid 3D state variables with the averaged fine grid
294! values (two-way coupling).
295!
296 DO tile=last_tile(ngc),first_tile(ngc),-1
297!^ CALL tl_fine2coarse (ng, model, r3dvar, tile)
298!^
299 CALL ad_fine2coarse (ng, model, r3dvar, tile)
300 END DO
301!$OMP BARRIER
302 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
303!
304! Update coarse grid depth variables. We have a new coarse grid
305! adjusted free-surface, Zt_avg1.
306!
307 DO tile=first_tile(ngc),last_tile(ngc),+1
308!^ CALL tl_set_depth (ngc, tile, model)
309!^
310 CALL ad_set_depth (ngc, tile, model)
311 END DO
312# endif
313!
314! Replace coarse grid 2D state variables with the averaged fine grid
315! values (two-way coupling).
316!
317 DO tile=last_tile(ngc),first_tile(ngc),-1
318!^ CALL fine2coarse (ng, model, r2dvar, tile)
319!^
320 CALL ad_fine2coarse (ng, model, r2dvar, tile)
321 END DO
322!$OMP BARRIER
323 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
324
325# if defined SOLVE3D && !defined NO_CORRECT_TRACER
326!
327! Correct coarse grid tracer values at the refinement grid, ng,
328! boundary with the refined accumulated fluxes (Hz*u*T/n, Hz*v*T/m).
329!
330 DO tile=first_tile(ngc),last_tile(ngc),+1
331!^ CALL tl_correct_tracer (ngc, ng, model, tile)
332!^
333 CALL ad_correct_tracer (ngc, ng, model, tile)
334 END DO
335!$OMP BARRIER
336# endif
337# else
338!
339! Fine to coarse coupling (two-way nesting) is not activated!
340!
341 ELSE IF (isection.eq.n2way) THEN
342# endif
343 END IF
344
345 ELSE
346!
347!-----------------------------------------------------------------------
348! Otherwise, process contact points in composite grid.
349!-----------------------------------------------------------------------
350!
351
352!$OMP BARRIER
353!
354! Fill composite grid contact points variables by interpolating from
355! extracted donor grid data.
356!
357 DO tile=last_tile(ng),first_tile(ng),-1
358!^ CALL tl_put_composite (ng, model, isection, tile)
359!^
360 CALL ad_put_composite (ng, model, isection, tile)
361 END DO
362!$OMP BARRIER
363
364!
365! Get composite grid contact points data from donor grid. It extracts
366! the donor grid cell data necessary to interpolate state variables
367! at each contact point.
368!
369 DO tile=first_tile(ng),last_tile(ng),+1
370!^ CALL tl_get_composite (ng, model, isection, tile)
371!^
372 CALL ad_get_composite (ng, model, isection, tile)
373 END DO
374
375 END IF
376
377# ifdef SOLVE3D
378!
379!-----------------------------------------------------------------------
380! Process vertical indices and interpolation weigths associated with
381! depth.
382!-----------------------------------------------------------------------
383!
384 IF (isection.eq.nzwgt) THEN
385 DO tile=last_tile(ng),first_tile(ng),-1
386!^ CALL tl_z_weights (ng, model, tile)
387!^
388 CALL ad_z_weights (ng, model, tile)
389 END DO
390!$OMP BARRIER
391 RETURN
392 END IF
393# endif
394
395 RETURN
396 END SUBROUTINE ad_nesting
397!
398 SUBROUTINE ad_get_composite (ng, model, isection, tile)
399!
400!=======================================================================
401! !
402! This routine gets the donor grid data required to process the !
403! contact points of the current composite grid. It extracts the !
404! donor cell points containing each contact point. In composite !
405! grids, it is possible to have more than one contact region. !
406! !
407! The interpolation of composite grid contact points from donor !
408! grid data is carried out in a different parallel region using !
409! 'put_composite'. !
410! !
411! On Input: !
412! !
413! ng Composite grid number (integer) !
414! model Calling model identifier (integer) !
415! isection Governing equations time-stepping section in !
416! main2d or main3d indicating which state !
417! variables to process (integer) !
418! tile Domain tile partition (integer) !
419! !
420! On Output: (mod_nesting) !
421! !
422! COMPOSITE Updated contact points structure. !
423! !
424!=======================================================================
425!
426 USE mod_param
427 USE mod_coupling
428 USE mod_forces
429 USE mod_grid
430 USE mod_ncparam
431 USE mod_nesting
432 USE mod_ocean
433 USE mod_scalars
434 USE mod_stepping
435 USE nesting_mod, ONLY : get_contact2d
436# ifdef SOLVE3D
437 USE nesting_mod, ONLY : get_contact3d
438# endif
439
440!
441! Imported variable declarations.
442!
443 integer, intent(in) :: ng, model, isection, tile
444!
445! Local variable declarations.
446!
447 integer :: cr, dg, rg, nrec, rec
448# ifdef SOLVE3D
449 integer :: itrc
450# endif
451 integer :: lbi, ubi, lbj, ubj
452 integer :: tindex
453!
454!-----------------------------------------------------------------------
455! Get donor grid data needed to process composite grid contact points.
456! Only process those variables associated with the governing equation
457! time-stepping section.
458!-----------------------------------------------------------------------
459!
460 DO cr=1,ncontact
461!
462! Get data donor and data receiver grid numbers.
463!
464 dg=rcontact(cr)%donor_grid
465 rg=rcontact(cr)%receiver_grid
466!
467! Process only contact region data for requested nested grid "ng".
468!
469 IF (rg.eq.ng) THEN
470!
471! Set donor grid lower and upper array indices.
472!
473 lbi=bounds(dg)%LBi(tile)
474 ubi=bounds(dg)%UBi(tile)
475 lbj=bounds(dg)%LBj(tile)
476 ubj=bounds(dg)%UBj(tile)
477!
478! Process bottom stress (bustr, bvstr).
479!
480 IF (isection.eq.nbstr) THEN
481!^ CALL get_contact2d (dg, model, tile, &
482!^ & u2dvar, Vname(1,idUbms), &
483!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
484!^ & LBi, UBi, LBj, UBj, &
485!^ & FORCES(dg) % tl_bustr, &
486!^ & COMPOSITE(cr) % tl_bustr)
487!^
488 CALL ad_get_contact2d (dg, model, tile, &
489 & u2dvar, vname(1,idubms), &
490 & cr, ucontact(cr)%Npoints, ucontact, &
491 & lbi, ubi, lbj, ubj, &
492 & forces(dg) % ad_bustr, &
493 & composite(cr) % ad_bustr)
494
495!^ CALL get_contact2d (dg, model, tile, &
496!^ & v2dvar, Vname(1,idVbms), &
497!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
498!^ & LBi, UBi, LBj, UBj, &
499!^ & FORCES(dg) % tl_bvstr, &
500!^ & COMPOSITE(cr) % tl_bvstr)
501!^
502 CALL ad_get_contact2d (dg, model, tile, &
503 & v2dvar, vname(1,idvbms), &
504 & cr, vcontact(cr)%Npoints, vcontact, &
505 & lbi, ubi, lbj, ubj, &
506 & forces(dg) % ad_bvstr, &
507 & composite(cr) % ad_bvstr)
508 END IF
509!
510! Process free-surface (zeta) at the appropriate time index.
511!
512 IF ((isection.eq.nfsic).or. &
513 & (isection.eq.nzeta).or. &
514 & (isection.eq.n2dps).or. &
515 & (isection.eq.n2dcs)) THEN
516 IF (isection.eq.nzeta) THEN
517 nrec=2 ! process time records 1 and 2
518 ELSE
519 nrec=1 ! process knew record
520 END IF
521 DO rec=1,nrec
522 IF (isection.eq.nzeta) THEN
523 tindex=rec
524 ELSE
525 tindex=knew(dg)
526 END IF
527!^ CALL get_contact2d (dg, model, tile, &
528!^ & r2dvar, Vname(1,idFsur), &
529!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
530!^ & LBi, UBi, LBj, UBj, &
531!^ & OCEAN(dg) % tl_zeta(:,:,Tindex), &
532!^ & COMPOSITE(cr) % tl_zeta(:,:,rec))
533!^
534 CALL ad_get_contact2d (dg, model, tile, &
535 & r2dvar, vname(1,idfsur), &
536 & cr, rcontact(cr)%Npoints, rcontact,&
537 & lbi, ubi, lbj, ubj, &
538 & ocean(dg) % ad_zeta(:,:,tindex), &
539 & composite(cr) % ad_zeta(:,:,rec))
540 END DO
541 END IF
542!
543! Process free-surface equation rigth-hand-side (rzeta) term.
544!
545 IF (isection.eq.n2dps) THEN
546 tindex=1
547!^ CALL get_contact2d (dg, model, tile, &
548!^ & r2dvar, Vname(1,idRzet), &
549!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
550!^ & LBi, UBi, LBj, UBj, &
551!^ & OCEAN(dg) % tl_rzeta(:,:,Tindex), &
552!^ & COMPOSITE(cr) % tl_rzeta)
553!^
554 CALL ad_get_contact2d (dg, model, tile, &
555 & r2dvar, vname(1,idrzet), &
556 & cr, rcontact(cr)%Npoints, rcontact, &
557 & lbi, ubi, lbj, ubj, &
558 & ocean(dg) % ad_rzeta(:,:,tindex), &
559 & composite(cr) % ad_rzeta)
560 END IF
561!
562! Process 2D momentum components (ubar,vbar) at the appropriate time
563! index.
564!
565 IF ((isection.eq.n2dic).or. &
566 & (isection.eq.n2dps).or. &
567 & (isection.eq.n2dcs).or. &
568 & (isection.eq.n3duv)) THEN
569 IF (isection.eq.n3duv) THEN
570 nrec=2 ! process time records 1 and 2
571 ELSE
572 nrec=1 ! process knew record
573 END IF
574 DO rec=1,nrec
575 IF (isection.eq.n3duv) THEN
576 tindex=rec
577 ELSE
578 tindex=knew(dg)
579 END IF
580!^ CALL get_contact2d (dg, model, tile, &
581!^ & u2dvar, Vname(1,idUbar), &
582!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
583!^ & LBi, UBi, LBj, UBj, &
584!^ & OCEAN(dg) % tl_ubar(:,:,Tindex), &
585!^ & COMPOSITE(cr) % tl_ubar(:,:,rec))
586!^
587 CALL ad_get_contact2d (dg, model, tile, &
588 & u2dvar, vname(1,idubar), &
589 & cr, ucontact(cr)%Npoints, ucontact,&
590 & lbi, ubi, lbj, ubj, &
591 & ocean(dg) % ad_ubar(:,:,tindex), &
592 & composite(cr) % ad_ubar(:,:,rec))
593
594!^ CALL get_contact2d (dg, model, tile, &
595!^ & v2dvar, Vname(1,idVbar), &
596!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
597!^ & LBi, UBi, LBj, UBj, &
598!^ & OCEAN(dg) % tl_vbar(:,:,Tindex), &
599!^ & COMPOSITE(cr) % tl_vbar(:,:,rec))
600!^
601 CALL ad_get_contact2d (dg, model, tile, &
602 & v2dvar, vname(1,idvbar), &
603 & cr, vcontact(cr)%Npoints, vcontact,&
604 & lbi, ubi, lbj, ubj, &
605 & ocean(dg) % ad_vbar(:,:,tindex), &
606 & composite(cr) % ad_vbar(:,:,rec))
607 END DO
608 END IF
609
610# ifdef SOLVE3D
611!
612! Process time averaged free-surface (Zt_avg1) and 2D momentum fluxes
613! (DU_avg1, DV_avg1).
614!
615 IF (isection.eq.n2dfx) THEN
616!^ CALL get_contact2d (dg, model, tile, &
617!^ & r2dvar, 'Zt_avg1', &
618!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
619!^ & LBi, UBi, LBj, UBj, &
620!^ & COUPLING(dg) % tl_Zt_avg1, &
621!^ & COMPOSITE(cr) % tl_Zt_avg1)
622!^
623 CALL ad_get_contact2d (dg, model, tile, &
624 & r2dvar, 'Zt_avg1', &
625 & cr, rcontact(cr)%Npoints, rcontact, &
626 & lbi, ubi, lbj, ubj, &
627 & coupling(dg) % ad_Zt_avg1, &
628 & composite(cr) % ad_Zt_avg1)
629!
630! Do we need to get DU_avg1 and DV_avg1 here? YES.
631!
632 CALL get_contact2d (dg, model, tile, &
633 & u2dvar, 'DU_avg1', &
634 & cr, ucontact(cr)%Npoints, ucontact, &
635 & lbi, ubi, lbj, ubj, &
636 & coupling(dg) % DU_avg1, &
637 & composite(cr) % DU_avg1)
638 CALL get_contact2d (dg, model, tile, &
639 & v2dvar, 'DV_avg1', &
640 & cr, vcontact(cr)%Npoints, vcontact, &
641 & lbi, ubi, lbj, ubj, &
642 & coupling(dg) % DV_avg1, &
643 & composite(cr) % DV_avg1)
644
645!^ CALL get_contact2d (dg, model, tile, &
646!^ & u2dvar, 'DU_avg1', &
647!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
648!^ & LBi, UBi, LBj, UBj, &
649!^ & COUPLING(dg) % tl_DU_avg1, &
650!^ & COMPOSITE(cr) % tl_DU_avg1)
651!^
652 CALL ad_get_contact2d (dg, model, tile, &
653 & u2dvar, 'DU_avg1', &
654 & cr, ucontact(cr)%Npoints, ucontact, &
655 & lbi, ubi, lbj, ubj, &
656 & coupling(dg) % ad_DU_avg1, &
657 & composite(cr) % ad_DU_avg1)
658
659!^ CALL get_contact2d (dg, model, tile, &
660!^ & v2dvar, 'DV_avg1', &
661!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
662!^ & LBi, UBi, LBj, UBj, &
663!^ & COUPLING(dg) % tl_DV_avg1, &
664!^ & COMPOSITE(cr) % tl_DV_avg1)
665!^
666 CALL ad_get_contact2d (dg, model, tile, &
667 & v2dvar, 'DV_avg1', &
668 & cr, vcontact(cr)%Npoints, vcontact, &
669 & lbi, ubi, lbj, ubj, &
670 & coupling(dg) % ad_DV_avg1, &
671 & composite(cr) % ad_DV_avg1)
672 END IF
673
674# if !defined TS_FIXED
675!
676! Process tracer variables (t) at the appropriate time index.
677!
678 IF ((isection.eq.ntvic).or. &
679 & (isection.eq.nrhst).or. &
680 & (isection.eq.n3dtv)) THEN
681 DO itrc=1,nt(ng)
682 IF (isection.eq.nrhst) THEN
683 tindex=3
684 ELSE
685 tindex=nnew(dg)
686 END IF
687!^ CALL get_contact3d (dg, model, tile, &
688!^ & r3dvar, Vname(1,idTvar(itrc)), &
689!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
690!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
691!^ & OCEAN(dg) % tl_t(:,:,:,Tindex,itrc), &
692!^ & COMPOSITE(cr) % tl_t(:,:,:,itrc))
693!^
694 CALL ad_get_contact3d (dg, model, tile, &
695 & r3dvar, vname(1,idtvar(itrc)), &
696 & cr, rcontact(cr)%Npoints, rcontact,&
697 & lbi, ubi, lbj, ubj, 1, n(dg), &
698 & ocean(dg) % ad_t(:,:,:,tindex, &
699 & itrc), &
700 & composite(cr) % ad_t(:,:,:,itrc))
701 END DO
702 END IF
703# endif
704!
705! Process 3D momentum (u, v) at the appropriate time-index.
706!
707 IF ((isection.eq.n3dic).or. &
708 & (isection.eq.n3duv)) THEN
709 tindex=nnew(dg)
710!^ CALL get_contact3d (dg, model, tile, &
711!^ & u3dvar, Vname(1,idUvel), &
712!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
713!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
714!^ & OCEAN(dg) % tl_u(:,:,:,Tindex), &
715!^ & COMPOSITE(cr) % tl_u)
716!^
717 CALL ad_get_contact3d (dg, model, tile, &
718 & u3dvar, vname(1,iduvel), &
719 & cr, ucontact(cr)%Npoints, ucontact, &
720 & lbi, ubi, lbj, ubj, 1, n(dg), &
721 & ocean(dg) % ad_u(:,:,:,tindex), &
722 & composite(cr) % ad_u)
723!^ CALL get_contact3d (dg, model, tile, &
724!^ & v3dvar, Vname(1,idVvel), &
725!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
726!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
727!^ & OCEAN(dg) % tl_v(:,:,:,Tindex), &
728!^ & COMPOSITE(cr) % tl_v)
729!^
730 CALL ad_get_contact3d (dg, model, tile, &
731 & v3dvar, vname(1,idvvel), &
732 & cr, vcontact(cr)%Npoints, vcontact, &
733 & lbi, ubi, lbj, ubj, 1, n(dg), &
734 & ocean(dg) % ad_v(:,:,:,tindex), &
735 & composite(cr) % ad_v)
736 END IF
737!
738! Process 3D momentum fluxes (Huon, Hvom).
739!
740 IF (isection.eq.n3duv) THEN
741!^ CALL get_contact3d (dg, model, tile, &
742!^ & u3dvar, 'Huon', &
743!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
744!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
745!^ & GRID(dg) % tl_Huon, &
746!^ & COMPOSITE(cr) % tl_Huon)
747!^
748 CALL ad_get_contact3d (dg, model, tile, &
749 & u3dvar, 'Huon', &
750 & cr, ucontact(cr)%Npoints, ucontact, &
751 & lbi, ubi, lbj, ubj, 1, n(dg), &
752 & grid(dg) % ad_Huon, &
753 & composite(cr) % ad_Huon)
754!^ CALL get_contact3d (dg, model, tile, &
755!^ & v3dvar, 'Hvom', &
756!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
757!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
758!^ & GRID(dg) % tl_Hvom, &
759!^ & COMPOSITE(cr) % tl_Hvom)
760!^
761 CALL ad_get_contact3d (dg, model, tile, &
762 & v3dvar, 'Hvom', &
763 & cr, vcontact(cr)%Npoints, vcontact, &
764 & lbi, ubi, lbj, ubj, 1, n(dg), &
765 & grid(dg) % ad_Hvom, &
766 & composite(cr) % ad_Hvom)
767 END IF
768# endif
769
770 END IF
771 END DO
772
773 RETURN
774 END SUBROUTINE ad_get_composite
775!
776 SUBROUTINE ad_get_refine (ng, model, tile)
777!
778!=======================================================================
779! !
780! This routine gets the donor grid data required to process the !
781! contact points of the current refinement grid. It extracts !
782! the donor cell points containing each contact point. !
783! !
784! The extracted data is stored in two-time rolling records which !
785! are needed for the space and time interpolation in 'put_refine'. !
786! !
787! Except for initialization, this routine is called at the bottom !
788! of the donor grid time step so all the values are updated for the !
789! time(dg)+dt(dg). That is, in 2D applications it is called after !
790! "step2d" corrector step and in 3D applications it is called after !
791! "step3d_t". This is done to have the coarser grid snapshots at !
792! time(dg) and time(dg)+dt(dg) to bound the interpolation of the !
793! finer grid contact points. !
794! !
795! On Input: !
796! !
797! ng Refinement grid number (integer) !
798! model Calling model identifier (integer) !
799! tile Domain tile partition (integer) !
800! !
801! On Output: (mod_nesting) !
802! !
803! REFINED Updated contact points structure. !
804! !
805!=======================================================================
806!
807 USE mod_param
808 USE mod_parallel
809 USE mod_coupling
810 USE mod_ncparam
811 USE mod_nesting
812 USE mod_ocean
813 USE mod_scalars
814 USE mod_stepping
815
816 USE nesting_mod, ONLY : get_persisted2d
817!
818! Imported variable declarations.
819!
820 integer, intent(in) :: ng, model, tile
821!
822! Local variable declarations.
823!
824# ifdef NESTING_DEBUG
825 logical, save :: first = .true.
826# endif
827 integer :: tindex2d, cr, dg, ir, rg, told, tnew
828# ifdef SOLVE3D
829 integer :: tindex3d, itrc
830# endif
831 integer :: lbi, ubi, lbj, ubj
832!
833!-----------------------------------------------------------------------
834! Get donor grid data needed to process refinement grid contact points.
835! The extracted contact point data is stored in two time records to
836! facilitate the space-time interpolation elsewhere.
837!-----------------------------------------------------------------------
838!
839 DO cr=1,ncontact
840!
841! Get data donor and data receiver grid numbers.
842!
843 dg=rcontact(cr)%donor_grid
844 rg=rcontact(cr)%receiver_grid
845!
846! Process only contact region data for requested nested grid "ng".
847!
848 IF ((dg.eq.coarserdonor(rg)).and.(dg.eq.ng)) THEN
849!
850! Set donor grid lower and upper array indices.
851!
852 lbi=bounds(dg)%LBi(tile)
853 ubi=bounds(dg)%UBi(tile)
854 lbj=bounds(dg)%LBj(tile)
855 ubj=bounds(dg)%UBj(tile)
856!
857! Update rolling time indices. The contact data is stored in two time
858! levels. We need a special case for ROMS initialization in "main2d"
859! or "main3d" after the processing "ini_fields". Notice that a dt(dg)
860! is added because this routine is called after the end of the time
861! step.
862!
863! tnew=3-RollingIndex(cr)
864 tnew=rollingindex(cr)
865!
866! Set donor grid time index to process. In 3D applications, the 2D
867! record index to use can be either 1 or 2 since both ubar(:,:,1:2)
868! and vbar(:,:,1:2) are set to its time-averaged values in "step3d_uv".
869! That is, we can use Tindex2d=kstp(dg) or Tindex2d=knew(dg). However,
870! in 2D applications we need to use Tindex2d=knew(dg).
871!
872 tindex2d=knew(dg)
873# ifdef SOLVE3D
874 tindex3d=nnew(dg)
875# endif
876
877# ifdef NESTING_DEBUG
878!
879! If debugging, write information into Fortran unit 102 to check the
880! logic of processing donor grid data.
881!
882 IF (domain(ng)%SouthWest_Test(tile)) THEN
883 IF (master) THEN
884 IF (first) THEN
885 first=.false.
886 WRITE (102,10)
887 END IF
888 WRITE (102,20) ng, cr, dg, rg, iic(dg), iic(rg), &
889 & 3-tnew, tnew, tindex2d, tindex3d, &
890 & int(time(rg)), &
891 & int(rollingtime(3-tnew,cr)), &
892 & int(time(ng)), &
893 & int(rollingtime(tnew,cr))
894 10 FORMAT (2x,'ng',2x,'cr',2x,'dg',2x,'rg',5x,'iic',5x,'iic',&
895 & 2x,'told',2x,'tnew',2x,'Tindex',2x,'Tindex', &
896 & 9x,'time',8x,'time',8x,'time',8x,'time',/, &
897 & 20x,'(dg)',4x,'(rg)',18x,'2D',6x,'3D',9x,'(rg)', &
898 & 8x,'told',8x,'(ng)',8x,'tnew',/)
899 20 FORMAT (4(1x,i3),2(1x,i7),2(2x,i4),2(4x,i4),1x,4(2x,i10))
900 FLUSH (102)
901 END IF
902 END IF
903# endif
904!
905! Extract free-surface.
906!
907# ifdef SOLVE3D
908!^ CALL get_contact2d (dg, model, tile, &
909!^ & r2dvar, 'Zt_avg1', &
910!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
911!^ & LBi, UBi, LBj, UBj, &
912!^ & COUPLING(dg) % tl_Zt_avg1, &
913!^ & REFINED(cr) % tl_zeta(:,:,tnew))
914!^
915 CALL ad_get_contact2d (dg, model, tile, &
916 & r2dvar, 'Zt_avg1', &
917 & cr, rcontact(cr)%Npoints, rcontact, &
918 & lbi, ubi, lbj, ubj, &
919 & coupling(dg) % ad_Zt_avg1, &
920 & refined(cr) % ad_zeta(:,:,tnew))
921# else
922!^ CALL get_contact2d (dg, model, tile, &
923!^ & r2dvar, 'zeta', &
924!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
925!^ & LBi, UBi, LBj, UBj, &
926!^ & OCEAN(dg) % tl_zeta(:,:,Tindex2d), &
927!^ & REFINED(cr) % tl_zeta(:,:,tnew))
928!^
929 CALL ad_get_contact2d (dg, model, tile, &
930 & r2dvar, 'zeta', &
931 & cr, rcontact(cr)%Npoints, rcontact, &
932 & lbi, ubi, lbj, ubj, &
933 & ocean(dg) % ad_zeta(:,:,tindex2d), &
934 & refined(cr) % ad_zeta(:,:,tnew))
935# endif
936!
937! Extract 2D momentum components (ubar, vbar).
938!
939!^ CALL get_contact2d (dg, model, tile, &
940!^ & u2dvar, Vname(1,idUbar), &
941!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
942!^ & LBi, UBi, LBj, UBj, &
943!^ & OCEAN(dg) % tl_ubar(:,:,Tindex2d), &
944!^ & REFINED(cr) % tl_ubar(:,:,tnew))
945!^
946 CALL ad_get_contact2d (dg, model, tile, &
947 & u2dvar, vname(1,idubar), &
948 & cr, ucontact(cr)%Npoints, ucontact, &
949 & lbi, ubi, lbj, ubj, &
950 & ocean(dg) % ad_ubar(:,:,tindex2d), &
951 & refined(cr) % ad_ubar(:,:,tnew))
952
953
954!^ CALL get_contact2d (dg, model, tile, &
955!^ & v2dvar, Vname(1,idVbar), &
956!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
957!^ & LBi, UBi, LBj, UBj, &
958!^ & OCEAN(dg) % tl_vbar(:,:,Tindex2d), &
959!^ & REFINED(cr) % tl_vbar(:,:,tnew))
960!^
961 CALL ad_get_contact2d (dg, model, tile, &
962 & v2dvar, vname(1,idvbar), &
963 & cr, vcontact(cr)%Npoints, vcontact, &
964 & lbi, ubi, lbj, ubj, &
965 & ocean(dg) % ad_vbar(:,:,tindex2d), &
966 & refined(cr) % ad_vbar(:,:,tnew))
967
968# ifdef SOLVE3D
969!
970! Extract time-averaged fluxes (DU_avg2, DV_avg2). We will use latter
971! only the values at the finer grid physical boundary to impose mass
972! flux conservation in routine "put_refine2d".
973!
974 CALL get_persisted2d (dg, rg, model, tile, &
975 & u2dvar, 'DU_avg2', &
976 & cr, ucontact(cr)%Npoints, ucontact, &
977 & lbi, ubi, lbj, ubj, &
978 & coupling(dg) % DU_avg2, &
979 & refined(cr) % DU_avg2(:,:,tnew))
980!^ CALL get_persisted2d (dg, rg, model, tile, &
981!^ & u2dvar, 'DU_avg2', &
982!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
983!^ & LBi, UBi, LBj, UBj, &
984!^ & COUPLING(dg) % tl_DU_avg2, &
985!^ & REFINED(cr) % tl_DU_avg2(:,:,tnew))
986!^
987 CALL ad_get_persisted2d (dg, rg, model, tile, &
988 & u2dvar, 'DU_avg2', &
989 & cr, ucontact(cr)%Npoints, ucontact, &
990 & lbi, ubi, lbj, ubj, &
991 & coupling(dg) % ad_DU_avg2, &
992 & refined(cr) % ad_DU_avg2(:,:,tnew))
993
994 CALL get_persisted2d (dg, rg, model, tile, &
995 & v2dvar, 'DV_avg2', &
996 & cr, vcontact(cr)%Npoints, vcontact, &
997 & lbi, ubi, lbj, ubj, &
998 & coupling(dg) % DV_avg2, &
999 & refined(cr) % DV_avg2(:,:,tnew))
1000
1001!^ CALL get_persisted2d (dg, rg, model, tile, &
1002!^ & v2dvar, 'DV_avg2', &
1003!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
1004!^ & LBi, UBi, LBj, UBj, &
1005!^ & COUPLING(dg) % tl_DV_avg2, &
1006!^ & REFINED(cr) % tl_DV_avg2(:,:,tnew))
1007!^
1008 CALL ad_get_persisted2d (dg, rg, model, tile, &
1009 & v2dvar, 'DV_avg2', &
1010 & cr, vcontact(cr)%Npoints, vcontact, &
1011 & lbi, ubi, lbj, ubj, &
1012 & coupling(dg) % ad_DV_avg2, &
1013 & refined(cr) % ad_DV_avg2(:,:,tnew))
1014!
1015! Tracer-type variables.
1016!
1017 DO itrc=1,nt(dg)
1018!^ CALL get_contact3d (dg, model, tile, &
1019!^ & r3dvar, Vname(1,idTvar(itrc)), &
1020!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
1021!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
1022!^ & OCEAN(dg) % tl_t(:,:,:,Tindex3d,itrc), &
1023!^ & REFINED(cr) % tl_t(:,:,:,tnew,itrc))
1024!^
1025 CALL ad_get_contact3d (dg, model, tile, &
1026 & r3dvar, vname(1,idtvar(itrc)), &
1027 & cr, rcontact(cr)%Npoints, rcontact, &
1028 & lbi, ubi, lbj, ubj, 1, n(dg), &
1029 & ocean(dg) % ad_t(:,:,:,tindex3d, &
1030 & itrc), &
1031 & refined(cr) % ad_t(:,:,:,tnew,itrc))
1032 END DO
1033!
1034! Extract 3D momentum components (u, v).
1035!
1036!^ CALL get_contact3d (dg, model, tile, &
1037!^ & u3dvar, Vname(1,idUvel), &
1038!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
1039!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
1040!^ & OCEAN(dg) % tl_u(:,:,:,Tindex3d), &
1041!^ & REFINED(cr) % tl_u(:,:,:,tnew))
1042!^
1043 CALL ad_get_contact3d (dg, model, tile, &
1044 & u3dvar, vname(1,iduvel), &
1045 & cr, ucontact(cr)%Npoints, ucontact, &
1046 & lbi, ubi, lbj, ubj, 1, n(dg), &
1047 & ocean(dg) % ad_u(:,:,:,tindex3d), &
1048 & refined(cr) % ad_u(:,:,:,tnew))
1049
1050!^ CALL get_contact3d (dg, model, tile, &
1051!^ & v3dvar, Vname(1,idVvel), &
1052!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
1053!^ & LBi, UBi, LBj, UBj, 1, N(dg), &
1054!^ & OCEAN(dg) % tl_v(:,:,:,Tindex3d), &
1055!^ & REFINED(cr) % tl_v(:,:,:,tnew))
1056!^
1057 CALL ad_get_contact3d (dg, model, tile, &
1058 & v3dvar, vname(1,idvvel), &
1059 & cr, vcontact(cr)%Npoints, vcontact, &
1060 & lbi, ubi, lbj, ubj, 1, n(dg), &
1061 & ocean(dg) % ad_v(:,:,:,tindex3d), &
1062 & refined(cr) % ad_v(:,:,:,tnew))
1063# endif
1064 END IF
1065 END DO
1066
1067 RETURN
1068 END SUBROUTINE ad_get_refine
1069!
1070 SUBROUTINE ad_put_composite (ng, model, isection, tile)
1071!
1072!=======================================================================
1073! !
1074! This routine interpolates composite grid contact points from donor !
1075! grid data extracted in routine 'get_composite'. !
1076! !
1077! On Input: !
1078! !
1079! ng Composite grid number (integer) !
1080! model Calling model identifier (integer) !
1081! isection Governing equations time-stepping section in !
1082! main2d or main3d indicating which state !
1083! variables to process (integer) !
1084! tile Domain tile partition (integer) !
1085! !
1086!=======================================================================
1087!
1088 USE mod_param
1089 USE mod_coupling
1090 USE mod_forces
1091 USE mod_grid
1092 USE mod_ncparam
1093 USE mod_nesting
1094 USE mod_ocean
1095 USE mod_scalars
1096 USE mod_stepping
1097
1098# ifdef DISTRIBUTE
1099!
1100 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
1101# ifdef SOLVE3D
1102 USE mp_exchange_mod, ONLY : ad_mp_exchange3d, ad_mp_exchange4d
1103# endif
1104# endif
1105!
1106! Imported variable declarations.
1107!
1108 integer, intent(in) :: ng, model, isection, tile
1109!
1110! Local variable declarations.
1111!
1112 integer :: dg, rg, cr, nrec, rec
1113# ifdef SOLVE3D
1114 integer :: itrc
1115# endif
1116 integer :: lbi, ubi, lbj, ubj
1117 integer :: tindex
1118!
1119!-----------------------------------------------------------------------
1120! Interpolate composite grid contact points from donor grid data.
1121! Only process those variables associated with the governing equation
1122! time-stepping section.
1123!-----------------------------------------------------------------------
1124!
1125 cr_loop : DO cr=1,ncontact
1126!
1127! Get data donor and data receiver grid numbers.
1128!
1129 dg=rcontact(cr)%donor_grid
1130 rg=rcontact(cr)%receiver_grid
1131!
1132! Process only contact region data for requested nested grid "ng".
1133!
1134 IF (rg.eq.ng) THEN
1135!
1136! Set receiver grid lower and upper array indices.
1137!
1138 lbi=bounds(rg)%LBi(tile)
1139 ubi=bounds(rg)%UBi(tile)
1140 lbj=bounds(rg)%LBj(tile)
1141 ubj=bounds(rg)%UBj(tile)
1142!
1143! Process bottom stress (bustr, bvstr).
1144!
1145 IF (isection.eq.nbstr) THEN
1146# ifdef DISTRIBUTE
1147!^ CALL mp_exchange2d (rg, tile, model, 2, &
1148!^ & LBi, UBi, LBj, UBj, &
1149!^ & NghostPoints, &
1150!^ & EWperiodic(rg), NSperiodic(rg), &
1151!^ & FORCES(rg) % tl_bustr, &
1152!^ & FORCES(rg) % tl_bvstr)
1153!^
1154 CALL ad_mp_exchange2d (rg, tile, model, 2, &
1155 & lbi, ubi, lbj, ubj, &
1156 & nghostpoints, &
1157 & ewperiodic(rg), nsperiodic(rg), &
1158 & forces(rg) % ad_bustr, &
1159 & forces(rg) % ad_bvstr)
1160# endif
1161!^ CALL put_contact2d (rg, model, tile, &
1162!^ & u2dvar, Vname(1,idUbms), &
1163!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
1164!^ & LBi, UBi, LBj, UBj, &
1165# ifdef MASKING
1166!^ & GRID(rg) % umask, &
1167# endif
1168!^ & COMPOSITE(cr) % tl_bustr, &
1169!^ & FORCES(rg) % tl_bustr)
1170!^
1171 CALL ad_put_contact2d (rg, model, tile, &
1172 & u2dvar, vname(1,idubms), &
1173 & cr, ucontact(cr)%Npoints, ucontact, &
1174 & lbi, ubi, lbj, ubj, &
1175# ifdef MASKING
1176 & grid(rg) % umask, &
1177# endif
1178 & composite(cr) % ad_bustr, &
1179 & forces(rg) % ad_bustr)
1180!^ CALL put_contact2d (rg, model, tile, &
1181!^ & v2dvar, Vname(1,idVbms), &
1182!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
1183!^ & LBi, UBi, LBj, UBj, &
1184# ifdef MASKING
1185!^ & GRID(rg) % vmask, &
1186# endif
1187!^ & COMPOSITE(cr) % tl_bvstr, &
1188!^ & FORCES(rg) % tl_bvstr)
1189!^
1190 CALL ad_put_contact2d (rg, model, tile, &
1191 & v2dvar, vname(1,idvbms), &
1192 & cr, vcontact(cr)%Npoints, vcontact, &
1193 & lbi, ubi, lbj, ubj, &
1194# ifdef MASKING
1195 & grid(rg) % vmask, &
1196# endif
1197 & composite(cr) % ad_bvstr, &
1198 & forces(rg) % ad_bvstr)
1199 END IF
1200!
1201! Process free-surface (zeta) at the appropriate time index.
1202!
1203 IF ((isection.eq.nfsic).or. &
1204 & (isection.eq.nzeta).or. &
1205 & (isection.eq.n2dps).or. &
1206 & (isection.eq.n2dcs)) THEN
1207 IF (isection.eq.nzeta) THEN
1208 nrec=2 ! process time records 1 and 2
1209 ELSE
1210 nrec=1 ! process knew record
1211 END IF
1212 DO rec=1,nrec
1213 IF (isection.eq.nzeta) THEN
1214 tindex=rec
1215 ELSE
1216 tindex=knew(rg)
1217 END IF
1218# ifdef DISTRIBUTE
1219!^ CALL mp_exchange2d (rg, tile, model, 1, &
1220!^ & LBi, UBi, LBj, UBj, &
1221!^ & NghostPoints, &
1222!^ & EWperiodic(rg), NSperiodic(rg), &
1223!^ & OCEAN(rg) % tl_zeta(:,:,Tindex))
1224!^
1225 CALL ad_mp_exchange2d (rg, tile, model, 1, &
1226 & lbi, ubi, lbj, ubj, &
1227 & nghostpoints, &
1228 & ewperiodic(rg), nsperiodic(rg), &
1229 & ocean(rg) % ad_zeta(:,:,tindex))
1230# endif
1231!^ CALL put_contact2d (rg, model, tile, &
1232!^ & r2dvar, Vname(1,idFsur), &
1233!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
1234!^ & LBi, UBi, LBj, UBj, &
1235# ifdef MASKING
1236!^ & GRID(rg) % rmask, &
1237# endif
1238!^ & COMPOSITE(cr) % tl_zeta(:,:,rec), &
1239!^ & OCEAN(rg) % tl_zeta(:,:,Tindex))
1240!^
1241 CALL ad_put_contact2d (rg, model, tile, &
1242 & r2dvar, vname(1,idfsur), &
1243 & cr, rcontact(cr)%Npoints, rcontact,&
1244 & lbi, ubi, lbj, ubj, &
1245# ifdef MASKING
1246 & grid(rg) % rmask, &
1247# endif
1248 & composite(cr) % ad_zeta(:,:,rec), &
1249 & ocean(rg) % ad_zeta(:,:,tindex))
1250 END DO
1251 END IF
1252!
1253! Process free-surface equation rigth-hand-side (rzeta) term.
1254!
1255 IF (isection.eq.n2dps) THEN
1256 tindex=1
1257# ifdef DISTRIBUTE
1258!^ CALL mp_exchange2d (rg, tile, model, 1, &
1259!^ & LBi, UBi, LBj, UBj, &
1260!^ & NghostPoints, &
1261!^ & EWperiodic(rg), NSperiodic(rg), &
1262!^ & OCEAN(rg) % tl_rzeta(:,:,Tindex))
1263!^
1264 CALL ad_mp_exchange2d (rg, tile, model, 1, &
1265 & lbi, ubi, lbj, ubj, &
1266 & nghostpoints, &
1267 & ewperiodic(rg), nsperiodic(rg), &
1268 & ocean(rg) % ad_rzeta(:,:,tindex))
1269# endif
1270!^ CALL put_contact2d (rg, model, tile, &
1271!^ & r2dvar, Vname(1,idRzet), &
1272!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
1273!^ & LBi, UBi, LBj, UBj, &
1274# ifdef MASKING
1275!^ & GRID(rg) % rmask, &
1276# endif
1277!^ & COMPOSITE(cr) % tl_rzeta, &
1278!^ & OCEAN(rg) % tl_rzeta(:,:,Tindex))
1279!^
1280 CALL ad_put_contact2d (rg, model, tile, &
1281 & r2dvar, vname(1,idrzet), &
1282 & cr, rcontact(cr)%Npoints, rcontact, &
1283 & lbi, ubi, lbj, ubj, &
1284# ifdef MASKING
1285 & grid(rg) % rmask, &
1286# endif
1287 & composite(cr) % ad_rzeta, &
1288 & ocean(rg) % ad_rzeta(:,:,tindex))
1289 END IF
1290!
1291! Process 2D momentum components (ubar,vbar) at the appropriate time
1292! index.
1293!
1294 IF ((isection.eq.n2dic).or. &
1295 & (isection.eq.n2dps).or. &
1296 & (isection.eq.n2dcs).or. &
1297 & (isection.eq.n3duv)) THEN
1298 IF (isection.eq.n3duv) THEN
1299 nrec=2 ! process time records 1 and 2
1300 ELSE
1301 nrec=1 ! process knew record
1302 END IF
1303 DO rec=1,nrec
1304 IF (isection.eq.n3duv) THEN
1305 tindex=rec
1306 ELSE
1307 tindex=knew(rg)
1308 END IF
1309# ifdef DISTRIBUTE
1310!^ CALL mp_exchange2d (rg, tile, model, 2, &
1311!^ & LBi, UBi, LBj, UBj, &
1312!^ & NghostPoints, &
1313!^ & EWperiodic(rg), NSperiodic(rg), &
1314!^ & OCEAN(rg) % tl_ubar(:,:,Tindex), &
1315!^ & OCEAN(rg) % tl_vbar(:,:,Tindex))
1316!^
1317 CALL ad_mp_exchange2d (rg, tile, model, 2, &
1318 & lbi, ubi, lbj, ubj, &
1319 & nghostpoints, &
1320 & ewperiodic(rg), nsperiodic(rg), &
1321 & ocean(rg) % ad_ubar(:,:,tindex), &
1322 & ocean(rg) % ad_vbar(:,:,tindex))
1323# endif
1324!^ CALL put_contact2d (rg, model, tile, &
1325!^ & u2dvar, Vname(1,idUbar), &
1326!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
1327!^ & LBi, UBi, LBj, UBj, &
1328# ifdef MASKING
1329!^ & GRID(rg) % umask, &
1330# endif
1331!^ & COMPOSITE(cr) % tl_ubar(:,:,rec), &
1332!^ & OCEAN(rg) % tl_ubar(:,:,Tindex))
1333!^
1334 CALL ad_put_contact2d (rg, model, tile, &
1335 & u2dvar, vname(1,idubar), &
1336 & cr, ucontact(cr)%Npoints, ucontact,&
1337 & lbi, ubi, lbj, ubj, &
1338# ifdef MASKING
1339 & grid(rg) % umask, &
1340# endif
1341 & composite(cr) % ad_ubar(:,:,rec), &
1342 & ocean(rg) % ad_ubar(:,:,tindex))
1343!^ CALL put_contact2d (rg, model, tile, &
1344!^ & v2dvar, Vname(1,idVbar), &
1345!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
1346!^ & LBi, UBi, LBj, UBj, &
1347# ifdef MASKING
1348!^ & GRID(rg) % vmask, &
1349# endif
1350!^ & COMPOSITE(cr) % tl_vbar(:,:,rec), &
1351!^ & OCEAN(rg) % tl_vbar(:,:,Tindex))
1352!^
1353 CALL ad_put_contact2d (rg, model, tile, &
1354 & v2dvar, vname(1,idvbar), &
1355 & cr, vcontact(cr)%Npoints, vcontact,&
1356 & lbi, ubi, lbj, ubj, &
1357# ifdef MASKING
1358 & grid(rg) % vmask, &
1359# endif
1360 & composite(cr) % ad_vbar(:,:,rec), &
1361 & ocean(rg) % ad_vbar(:,:,tindex))
1362 END DO
1363 END IF
1364
1365# ifdef SOLVE3D
1366!
1367! Process time averaged free-surface (Zt_avg1) and 2D momentum fluxes
1368! (DU_avg1, DV_avg1).
1369!
1370 IF (isection.eq.n2dfx) THEN
1371# ifdef DISTRIBUTE
1372!^ CALL mp_exchange2d (rg, tile, model, 3, &
1373!^ & LBi, UBi, LBj, UBj, &
1374!^ & NghostPoints, &
1375!^ & EWperiodic(rg), NSperiodic(rg), &
1376!^ & COUPLING(rg) % tl_Zt_avg1, &
1377!^ & COUPLING(rg) % tl_DU_avg1, &
1378!^ & COUPLING(rg) % tl_DV_avg1)
1379!^
1380 CALL ad_mp_exchange2d (rg, tile, model, 3, &
1381 & lbi, ubi, lbj, ubj, &
1382 & nghostpoints, &
1383 & ewperiodic(rg), nsperiodic(rg), &
1384 & coupling(rg) % ad_Zt_avg1, &
1385 & coupling(rg) % ad_DU_avg1, &
1386 & coupling(rg) % ad_DV_avg1)
1387# endif
1388!^ CALL put_contact2d (rg, model, tile, &
1389!^ & r2dvar, 'Zt_avg1', &
1390!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
1391!^ & LBi, UBi, LBj, UBj, &
1392# ifdef MASKING
1393!^ & GRID(rg) % rmask, &
1394# endif
1395!^ & COMPOSITE(cr) % tl_Zt_avg1, &
1396!^ & COUPLING(rg) % tl_Zt_avg1)a
1397!^
1398 CALL ad_put_contact2d (rg, model, tile, &
1399 & r2dvar, 'Zt_avg1', &
1400 & cr, rcontact(cr)%Npoints, rcontact, &
1401 & lbi, ubi, lbj, ubj, &
1402# ifdef MASKING
1403 & grid(rg) % rmask, &
1404# endif
1405 & composite(cr) % ad_Zt_avg1, &
1406 & coupling(rg) % ad_Zt_avg1)
1407!^ CALL put_contact2d (rg, model, tile, &
1408!^ & u2dvar, Vname(1,idUfx1), &
1409!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
1410!^ & LBi, UBi, LBj, UBj, &
1411# ifdef MASKING
1412!^ & GRID(rg) % umask, &
1413# endif
1414!^ & COMPOSITE(cr) % tl_DU_avg1, &
1415!^ & COUPLING(rg) % tl_DU_avg1)
1416!^
1417 CALL ad_put_contact2d (rg, model, tile, &
1418 & u2dvar, vname(1,idufx1), &
1419 & cr, ucontact(cr)%Npoints, ucontact, &
1420 & lbi, ubi, lbj, ubj, &
1421# ifdef MASKING
1422 & grid(rg) % umask, &
1423# endif
1424 & composite(cr) % ad_DU_avg1, &
1425 & coupling(rg) % ad_DU_avg1)
1426!^ CALL put_contact2d (rg, model, tile, &
1427!^ & v2dvar, Vname(1,idVfx1), &
1428!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
1429!^ & LBi, UBi, LBj, UBj, &
1430# ifdef MASKING
1431!^ & GRID(rg) % vmask, &
1432# endif
1433!^ & COMPOSITE(cr) % tl_DV_avg1, &
1434!^ & COUPLING(rg) % tl_DV_avg1)
1435!^
1436 CALL ad_put_contact2d (rg, model, tile, &
1437 & v2dvar, vname(1,idvfx1), &
1438 & cr, vcontact(cr)%Npoints, vcontact, &
1439 & lbi, ubi, lbj, ubj, &
1440# ifdef MASKING
1441 & grid(rg) % vmask, &
1442# endif
1443 & composite(cr) % ad_DV_avg1, &
1444 & coupling(rg) % ad_DV_avg1)
1445 END IF
1446
1447# if !defined TS_FIXED
1448!
1449! Process tracer variables (t) at the appropriate time index.
1450!
1451 IF ((isection.eq.ntvic).or. &
1452 & (isection.eq.nrhst).or. &
1453 & (isection.eq.n3dtv)) THEN
1454 DO itrc=1,nt(ng)
1455 IF (isection.eq.nrhst) THEN
1456 tindex=3
1457 ELSE
1458 tindex=nnew(rg)
1459 END IF
1460# ifdef DISTRIBUTE
1461!^ CALL mp_exchange4d (rg, tile, model, 1, &
1462!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1463!^ & 1, NT(rg), &
1464!^ & NghostPoints, &
1465!^ & EWperiodic(rg), NSperiodic(rg), &
1466!^ & OCEAN(rg) % tl_t(:,:,:,Tindex,:))
1467!^
1468 CALL ad_mp_exchange4d (rg, tile, model, 1, &
1469 & lbi, ubi, lbj, ubj, 1, n(rg), &
1470 & 1, nt(rg), &
1471 & nghostpoints, &
1472 & ewperiodic(rg), nsperiodic(rg), &
1473 & ocean(rg) % ad_t(:,:,:,tindex,:))
1474# endif
1475!^ CALL tl_put_contact3d (rg, model, tile, &
1476!^ & r3dvar, Vname(1,idTvar(itrc)), &
1477!^ & cr, Rcontact(cr)%Npoints, Rcontact,&
1478!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1479# ifdef MASKING
1480!^ & GRID(rg) % rmask, &
1481# endif
1482!^ & COMPOSITE(cr) % t(:,:,:,itrc), &
1483!^ & COMPOSITE(cr) % tl_t(:,:,:,itrc), &
1484!^ & OCEAN(rg) % tl_t(:,:,:,Tindex, &
1485!^ & itrc))
1486!^
1487 CALL ad_put_contact3d (rg, model, tile, &
1488 & r3dvar, vname(1,idtvar(itrc)), &
1489 & cr, rcontact(cr)%Npoints, rcontact,&
1490 & lbi, ubi, lbj, ubj, 1, n(rg), &
1491# ifdef MASKING
1492 & grid(rg) % rmask, &
1493# endif
1494 & composite(cr) % t(:,:,:,itrc), &
1495 & composite(cr) % ad_t(:,:,:,itrc), &
1496 & ocean(rg) % ad_t(:,:,:,tindex, &
1497 & itrc))
1498 END DO
1499 END IF
1500# endif
1501!
1502! Process 3D momentum (u, v) at the appropriate time-index.
1503!
1504 IF ((isection.eq.n3dic).or. &
1505 & (isection.eq.n3duv)) THEN
1506 tindex=nnew(rg)
1507# ifdef DISTRIBUTE
1508!^ CALL mp_exchange3d (rg, tile, model, 2, &
1509!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1510!^ & NghostPoints, &
1511!^ & EWperiodic(rg), NSperiodic(rg), &
1512!^ & OCEAN(rg) % tl_u(:,:,:,Tindex), &
1513!^ & OCEAN(rg) % tl_v(:,:,:,Tindex))
1514!^
1515 CALL ad_mp_exchange3d (rg, tile, model, 2, &
1516 & lbi, ubi, lbj, ubj, 1, n(rg), &
1517 & nghostpoints, &
1518 & ewperiodic(rg), nsperiodic(rg), &
1519 & ocean(rg) % ad_u(:,:,:,tindex), &
1520 & ocean(rg) % ad_v(:,:,:,tindex))
1521# endif
1522!^ CALL tl_put_contact3d (rg, model, tile, &
1523!^ & u3dvar, Vname(1,idUvel), &
1524!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
1525!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1526# ifdef MASKING
1527!^ & GRID(rg) % umask, &
1528# endif
1529!^ & COMPOSITE(cr) % u, &
1530!^ & COMPOSITE(cr) % tl_u, &
1531!^ & OCEAN(rg) % tl_u(:,:,:,Tindex))
1532!^
1533 CALL ad_put_contact3d (rg, model, tile, &
1534 & u3dvar, vname(1,iduvel), &
1535 & cr, ucontact(cr)%Npoints, ucontact, &
1536 & lbi, ubi, lbj, ubj, 1, n(rg), &
1537# ifdef MASKING
1538 & grid(rg) % umask, &
1539# endif
1540 & composite(cr) % u, &
1541 & composite(cr) % ad_u, &
1542 & ocean(rg) % ad_u(:,:,:,tindex))
1543!^ CALL tl_put_contact3d (rg, model, tile, &
1544!^ & v3dvar, Vname(1,idVvel), &
1545!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
1546!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1547# ifdef MASKING
1548!^ & GRID(rg) % vmask, &
1549# endif
1550!^ & COMPOSITE(cr) % v, &
1551!^ & COMPOSITE(cr) % tl_v, &
1552!^ & OCEAN(rg) % tl_v(:,:,:,Tindex))
1553!^
1554 CALL ad_put_contact3d (rg, model, tile, &
1555 & v3dvar, vname(1,idvvel), &
1556 & cr, vcontact(cr)%Npoints, vcontact, &
1557 & lbi, ubi, lbj, ubj, 1, n(rg), &
1558# ifdef MASKING
1559 & grid(rg) % vmask, &
1560# endif
1561 & composite(cr) % v, &
1562 & composite(cr) % ad_v, &
1563 & ocean(rg) % ad_v(:,:,:,tindex))
1564 END IF
1565!
1566! Process 3D momentum fluxes (Huon, Hvom).
1567!
1568 IF (isection.eq.n3duv) THEN
1569# ifdef DISTRIBUTE
1570!^ CALL mp_exchange3d (rg, tile, model, 2, &
1571!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1572!^ & NghostPoints, &
1573!^ & EWperiodic(rg), NSperiodic(rg), &
1574!^ & GRID(rg) % tl_Huon, &
1575!^ & GRID(rg) % tl_Hvom)
1576!^
1577 CALL ad_mp_exchange3d (rg, tile, model, 2, &
1578 & lbi, ubi, lbj, ubj, 1, n(rg), &
1579 & nghostpoints, &
1580 & ewperiodic(rg), nsperiodic(rg), &
1581 & grid(rg) % ad_Huon, &
1582 & grid(rg) % ad_Hvom)
1583# endif
1584!^ CALL tl_put_contact3d (rg, model, tile, &
1585!^ & u3dvar, 'Huon', &
1586!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
1587!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1588# ifdef MASKING
1589!^ & GRID(rg) % umask, &
1590# endif
1591!^ & COMPOSITE(cr) % Huon, &
1592!^ & COMPOSITE(cr) % tl_Huon, &
1593!^ & GRID(rg) % tl_Huon)
1594!^
1595 CALL ad_put_contact3d (rg, model, tile, &
1596 & u3dvar, 'Huon', &
1597 & cr, ucontact(cr)%Npoints, ucontact, &
1598 & lbi, ubi, lbj, ubj, 1, n(rg), &
1599# ifdef MASKING
1600 & grid(rg) % umask, &
1601# endif
1602 & composite(cr) % Huon, &
1603 & composite(cr) % ad_Huon, &
1604 & grid(rg) % ad_Huon)
1605!^ CALL tl_put_contact3d (rg, model, tile, &
1606!^ & v3dvar, 'Hvom', &
1607!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
1608!^ & LBi, UBi, LBj, UBj, 1, N(rg), &
1609# ifdef MASKING
1610!^ & GRID(rg) % vmask, &
1611# endif
1612!^ & COMPOSITE(cr) % Hvom, &
1613!^ & COMPOSITE(cr) % tl_Hvom, &
1614!^ & GRID(rg) % tl_Hvom)
1615!^
1616 CALL ad_put_contact3d (rg, model, tile, &
1617 & v3dvar, 'Hvom', &
1618 & cr, vcontact(cr)%Npoints, vcontact, &
1619 & lbi, ubi, lbj, ubj, 1, n(rg), &
1620# ifdef MASKING
1621 & grid(rg) % vmask, &
1622# endif
1623 & composite(cr) % Hvom, &
1624 & composite(cr) % ad_Hvom, &
1625 & grid(rg) % ad_Hvom)
1626 END IF
1627# endif
1628
1629 END IF
1630 END DO cr_loop
1631
1632 RETURN
1633 END SUBROUTINE ad_put_composite
1634!
1635 SUBROUTINE ad_put_refine (ng, model, tile, LputFsur)
1636!
1637!=======================================================================
1638! !
1639! This routine interpolates refinement grid contact points from donor !
1640! grid data extracted in routine 'get_refine'. Notice that because of !
1641! shared-memory parallelism, the free-surface is processed first and !
1642! in a different parallel region.
1643! !
1644! On Input: !
1645! !
1646! ng Refinement grid number (integer) !
1647! model Calling model identifier (integer) !
1648! tile Domain tile partition (integer) !
1649! LputFsur Switch to process or not free-surface (logical) !
1650! !
1651!=======================================================================
1652!
1653 USE mod_param
1654 USE mod_coupling
1655 USE mod_forces
1656 USE mod_grid
1657 USE mod_ncparam
1658 USE mod_nesting
1659 USE mod_ocean
1660 USE mod_scalars
1661 USE mod_stepping
1662!
1663! Imported variable declarations.
1664!
1665 logical, intent(in) :: lputfsur
1666 integer, intent(in) :: ng, model, tile
1667!
1668! Local variable declarations.
1669!
1670 integer :: dg, rg, cr, nrec, rec, tnew, told
1671# ifdef SOLVE3D
1672 integer :: itrc
1673# endif
1674 integer :: lbi, ubi, lbj, ubj
1675 integer :: tindex
1676!
1677!-----------------------------------------------------------------------
1678! Interpolate refinement grid contact points from donor grid data
1679! (space-time interpolation)
1680!-----------------------------------------------------------------------
1681!
1682 DO cr=1,ncontact
1683!
1684! Get data donor and data receiver grid numbers.
1685!
1686 dg=rcontact(cr)%donor_grid
1687 rg=rcontact(cr)%receiver_grid
1688!
1689! Process only contact region data for requested nested grid "ng", if
1690! donor grid is coarser than receiver grid. That is, we are only
1691! processing external contact points areas.
1692!
1693 IF ((rg.eq.ng).and.(dxmax(dg).gt.dxmax(rg))) THEN
1694!
1695! Update adjoint rolling time indices. The contact data is stored in
1696! two time levels.
1697!
1698 IF (.not.lputfsur) THEN
1699 IF (time(dg).eq.time(rg)) THEN
1700 rollingindex(cr)=3-rollingindex(cr)
1701 END IF
1702 tnew=rollingindex(cr)
1703 told=3-tnew
1704! told=RollingIndex(cr)
1705! tnew=3-told
1706! IF (time(dg).eq.time(rg)) THEN
1707! RollingIndex(cr)=3-RollingIndex(cr)
1708! END IF
1709 rollingtime(tnew,cr)=time(dg)+dt(dg)
1710 rollingtime(told,cr)=time(dg)
1711 END IF
1712!
1713! Set receiver grid lower and upper array indices.
1714!
1715 lbi=bounds(rg)%LBi(tile)
1716 ubi=bounds(rg)%UBi(tile)
1717 lbj=bounds(rg)%LBj(tile)
1718 ubj=bounds(rg)%UBj(tile)
1719!
1720! Fill free-surface separatelly.
1721!
1722 IF (lputfsur) THEN
1723!^ CALL tl_put_refine2d (ng, dg, cr, model, tile, LputFsur, &
1724!^ & LBi, UBi, LBj, UBj)
1725!^
1726 CALL ad_put_refine2d (ng, dg, cr, model, tile, lputfsur, &
1727 & lbi, ubi, lbj, ubj)
1728 ELSE
1729# ifdef SOLVE3D
1730!
1731! Fill 3D state variables contact points.
1732!
1733!^ CALL tl_put_refine3d (ng, dg, cr, model, tile, &
1734!^ & LBi, UBi, LBj, UBj)
1735!^
1736 CALL ad_put_refine3d (ng, dg, cr, model, tile, &
1737 & lbi, ubi, lbj, ubj)
1738# endif
1739!
1740! Fill other 2D state variables (like momentum) contact points.
1741!
1742!^ CALL tl_put_refine2d (ng, dg, cr, model, tile, LputFsur, &
1743!^ & LBi, UBi, LBj, UBj)
1744!^
1745 CALL ad_put_refine2d (ng, dg, cr, model, tile, lputfsur, &
1746 & lbi, ubi, lbj, ubj)
1747 END IF
1748 END IF
1749 END DO
1750
1751 RETURN
1752 END SUBROUTINE ad_put_refine
1753
1754# ifdef SOLVE3D
1755!
1756 SUBROUTINE ad_correct_tracer (ng, ngf, model, tile)
1757!
1758!=======================================================================
1759! !
1760! This routine corrects the tracer values in the coarser grid at the !
1761! location of the finer grid physical domain perimeter by comparing !
1762! vertically accumulated horizontal tracer flux (Hz*u*T/n, Hz*v*T/m) !
1763! in two-way nesting refinement: !
1764! !
1765! coarse grid, t(:,jb,:,nstp,:) = t(:,jb,:,nstp,:) - FacJ (west, !
1766! east) !
1767! t(ib,:,:,nstp,:) = t(ib,:,:,nstp,:) - FacI (south, !
1768! north) !
1769! where !
1770! !
1771! FacJ = (TFF(jb,itrc) - TFC(jb,itrc)) * !
1772! pm(:,jb) * pn(:,jb) / D(:,jb) !
1773! !
1774! TFF(ib,itrc) = SUM[SUM[Tflux(ib,k,itrc)]] finer !
1775! grid !
1776! for k=1:N, 1:RefineScale flux !
1777! !
1778! TFC(ib,itrc) = SUM[Tflux(ib,k,itrc)] coarser !
1779! grid !
1780! for k=1:N flux !
1781! !
1782! Similarly, for the southern and northern tracer fluxes. !
1783! !
1784! !
1785! On Input: !
1786! !
1787! ngc Coarser grid number (integer) !
1788! ngf Finer grid number (integer) !
1789! model Calling model identifier (integer) !
1790! tile Domain tile partition (integer) !
1791! !
1792! On Output: (mod_ocean) !
1793! !
1794! t Updated coarse grid tracer values at finer grid !
1795! perimeter !
1796! !
1797!=======================================================================
1798!
1799 USE mod_param
1800!
1801! Imported variable declarations.
1802!
1803 integer, intent(in) :: ng, ngf, model, tile
1804!
1805! Local variable declarations.
1806!
1807# include "tile.h"
1808!
1809 CALL ad_correct_tracer_tile (ng, ngf, model, tile, &
1810 & lbi, ubi, lbj, ubj, &
1811 & imins, imaxs, jmins, jmaxs)
1812 RETURN
1813!
1814 END SUBROUTINE ad_correct_tracer
1815!
1816!***********************************************************************
1817 SUBROUTINE ad_correct_tracer_tile (ngc, ngf, model, tile, &
1818 & LBi, UBi, LBj, UBj, &
1819 & IminS, ImaxS, JminS, JmaxS)
1820!***********************************************************************
1821!
1822 USE mod_param
1823 USE mod_clima
1824 USE mod_grid
1825 USE mod_ocean
1826 USE mod_nesting
1827 USE mod_scalars
1828 USE mod_stepping
1829
1830# ifdef DISTRIBUTE
1831!
1832 USE mp_exchange_mod, ONLY : ad_mp_exchange4d
1833# endif
1834!
1835! Imported variable declarations.
1836!
1837 integer, intent(in) :: ngc, ngf, model, tile
1838 integer, intent(in) :: lbi, ubi, lbj, ubj
1839 integer, intent(in) :: imins, imaxs, jmins, jmaxs
1840!
1841! Local variable declarations.
1842!
1843 integer :: iedge, ibc, ibc_min, ibc_max, ibf, io
1844 integer :: jedge, jbc, jbc_min, jbc_max, jbf, jo
1845 integer :: istr, iend, jstr, jend
1846 integer :: istrm2, iendp2, jstrm2, jendp2
1847 integer :: tindex, i, ic, isum, itrc, j, jsum, k, half
1848 integer :: cr, dg, dgcr, rg, rgcr
1849
1850 real(r8) :: tfc, tff, tvalue, cff
1851 real(r8) :: ad_tfc, ad_tff, ad_tvalue, ad_cff, adfac
1852
1853 real(r8) :: dinv(imins:imaxs,jmins:jmaxs)
1854 real(r8) :: ad_dinv(imins:imaxs,jmins:jmaxs)
1855
1856!
1857! Clear adjoint constants.
1858!
1859 ad_tfc=0.0_r8
1860 ad_tff=0.0_r8
1861 ad_tvalue=0.0_r8
1862 ad_cff=0.0_r8
1863 ad_dinv=0.0_r8
1864
1865# ifdef DISTRIBUTE
1866!
1867!-----------------------------------------------------------------------
1868! Exchange boundary data.
1869!-----------------------------------------------------------------------
1870!
1871!^ CALL mp_exchange4d (ngc, tile, model, 1, &
1872!^ & LBi, UBi, LBj, UBj, 1, N(ngc), &
1873!^ & 1, NT(ngc), &
1874!^ & NghostPoints, &
1875!^ & EWperiodic(ngc), NSperiodic(ngc), &
1876!^ & OCEAN(ngc)%tl_t(:,:,:,Tindex,:))
1877!^
1878 CALL ad_mp_exchange4d (ngc, tile, model, 1, &
1879 & lbi, ubi, lbj, ubj, 1, n(ngc), &
1880 & 1, nt(ngc), &
1881 & nghostpoints, &
1882 & ewperiodic(ngc), nsperiodic(ngc), &
1883 & ocean(ngc)%ad_t(:,:,:,tindex,:))
1884# endif
1885!
1886!-----------------------------------------------------------------------
1887! Correct coarser grid tracer values at finer grid perimeter.
1888!-----------------------------------------------------------------------
1889!
1890! Determine contact regions where coarse grid is the donor and coarse
1891! grid is the receiver..
1892!
1893 DO cr=1,ncontact
1894 dg=donor_grid(cr)
1895 rg=receiver_grid(cr)
1896 IF ((ngc.eq.dg).and.(ngf.eq.rg)) THEN
1897 dgcr=cr ! coarse is donor
1898 ELSE IF ((ngc.eq.rg).and.(ngf.eq.dg)) THEN
1899 rgcr=cr ! coarse is receiver
1900 END IF
1901 END DO
1902!
1903! Set tile starting and ending indices for coarser grid.
1904!
1905 istr =bounds(ngc)%Istr (tile)
1906 iend =bounds(ngc)%Iend (tile)
1907 jstr =bounds(ngc)%Jstr (tile)
1908 jend =bounds(ngc)%Jend (tile)
1909!
1910 istrm2=bounds(ngc)%Istrm2(tile)
1911 iendp2=bounds(ngc)%Iendp2(tile)
1912 jstrm2=bounds(ngc)%Jstrm2(tile)
1913 jendp2=bounds(ngc)%Jendp2(tile)
1914
1915!
1916! Compute coarser grid inverse water colunm thickness.
1917!
1918 DO j=jstrm2,jendp2
1919 DO i=istrm2,iendp2
1920 cff=grid(ngc)%Hz(i,j,1)
1921 DO k=2,n(rg)
1922 cff=cff+grid(ngc)%Hz(i,j,k)
1923 END DO
1924 dinv(i,j)=1.0_r8/cff
1925 END DO
1926 END DO
1927
1928!
1929! Set finer grid center (half) and offset indices (Io and Jo) for
1930! coarser grid (I,J) coordinates.
1931!
1932 half=(refinescale(ngf)-1)/2
1933 io=half+1
1934 jo=half+1
1935!
1936! Set coarse grid tracer index to correct. Since the exchange of data
1937! is done at the bottom of main3d, we need to use the newest time
1938! index, I think.
1939!
1940 tindex=nstp(ngc) ! HGA: Why this index is stable?
1941!! Tindex=nnew(ngc) ! Gets a lot of noise at boundary
1942
1943!
1944!=======================================================================
1945! Compute vertically integrated horizontal advective tracer flux for
1946! coarser at the finer grid physical boundary. Then, correct coarser
1947! grid tracer values at that boundary.
1948!=======================================================================
1949!
1950! Initialize tracer counter index. The "tclm" array is only allocated
1951! to the NTCLM fields that need to be processed. This is done to
1952! reduce memory.
1953!
1954 ic=0
1955!
1956 t_loop : DO itrc=1,nt(ngc)
1957 ic=ic+1
1958!
1959!-----------------------------------------------------------------------
1960! Adjoint Finer grid northern boundary.
1961!-----------------------------------------------------------------------
1962!
1963 jbc=j_top(ngf)
1964 ibc_min=i_left(ngf)
1965 ibc_max=i_right(ngf)-1 ! interior points, no top
1966! right corner
1967 DO ibc=istr,iend
1968 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
1969 & ((jstr.le.jbc).and.(jbc.le.jend))) THEN
1970!
1971! Sum vertically coarse grid horizontal advective tracer flux,
1972! Hz*v*T/m, from last time-step.
1973!
1974 tfc=0.0_r8
1975 DO k=1,n(ngc)
1976 tfc=tfc+bry_contact(inorth,rgcr)%Tflux(ibc,k,itrc)
1977 END DO
1978!
1979! Sum vertically and horizontally finer grid advective tracer flux.
1980! This is a vertical and horizontal I-integral because "RefineScale"
1981! sub-divisions are done in the finer grid in each single coarse grid
1982! at the I-edge.
1983!
1984 tff=0.0_r8
1985 iedge=io+(ibc-ibc_min)*refinescale(ngf)
1986 DO isum=-half,half
1987 ibf=iedge+isum
1988 DO k=1,n(ngf)
1989 tff=tff+bry_contact(inorth,dgcr)%Tflux(ibf,k,itrc)
1990 END DO
1991 END DO
1992!
1993! Zeroth order correction to fine grid time integral.
1994!
1995 tff=tff*dt(ngc)/dt(ngf)
1996!
1997 cff=grid(ngc)%pm(ibc,jbc)* &
1998 & grid(ngc)%pn(ibc,jbc)* &
1999 & dinv(ibc,jbc)
2000 DO k=1,n(ngc)
2001!^ OCEAN(ngc)%tl_t(Ibc,Jbc,k,Tindex,itrc)=tl_Tvalue
2002!^
2003 ad_tvalue=ad_tvalue+ &
2004 & ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)
2005 ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)=0.0_r8
2006# ifdef MASKING
2007!^ tl_Tvalue=tl_Tvalue*GRID(ngc)%rmask(Ibc,Jbc)
2008!^
2009 ad_tvalue=ad_tvalue*grid(ngc)%rmask(ibc,jbc)
2010
2011# endif
2012 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
2013!^ tl_Tvalue=tl_Tvalue- &
2014!^ & dt(ngc)*CLIMA(ngc)%Tnudgcof(Ibc,Jbc,k,itrc)* &
2015!^ & tl_Tvalue
2016!^
2017 ad_tvalue=ad_tvalue* &
2018 & (1.0_r8-dt(ngc)* &
2019 & clima(ngc)%Tnudgcof(ibc,jbc,k,itrc))
2020 END IF
2021!^ tl_Tvalue=(0.5_r8- &
2022!^ & SIGN(0.5_r8, &
2023!^ & -(OCEAN(ngc)%t(Ibc,Jbc,k,Tindex,itrc)- &
2024!^ & cff*(TFF-TFC))))* &
2025!^ & (OCEAN(ngc)%tl_t(Ibc,Jbc,k,Tindex,itrc)- &
2026!^ & tl_cff*(TFF-TFC)-cff*(tl_TFF-tl_TFC))
2027!^
2028 adfac=(0.5_r8- &
2029 & sign(0.5_r8, &
2030 & -(ocean(ngc)%t(ibc,jbc,k,tindex,itrc)- &
2031 & cff*(tff-tfc))))*ad_tvalue
2032 ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)= &
2033 & ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)+adfac
2034 ad_cff=ad_cff-(tff-tfc)*adfac
2035 ad_tff=ad_tff-cff*adfac
2036 ad_tfc=ad_tfc+cff*adfac
2037 ad_tvalue=0.0_r8
2038 END DO
2039!
2040! Correct coarse grid tracer at the finer grid northern boundary.
2041!
2042!^ tl_cff=GRID(ngc)%pm(Ibc,Jbc)* &
2043!^ & GRID(ngc)%pn(Ibc,Jbc)* &
2044!^ & tl_Dinv(Ibc,Jbc)
2045!^
2046 ad_dinv(ibc,jbc)=ad_dinv(ibc,jbc)+ &
2047 & grid(ngc)%pm(ibc,jbc)* &
2048 & grid(ngc)%pn(ibc,jbc)*ad_cff
2049 ad_cff=0.0_r8
2050!
2051! Zeroth order correction to fine grid time integral.
2052!
2053!^ tl_TFF=tl_TFF*dt(ngc)/dt(ngf)
2054!^
2055 ad_tff=ad_tff*dt(ngc)/dt(ngf)
2056!
2057! Sum vertically and horizontally finer grid advective tracer flux.
2058! This is a vertical and horizontal I-integral because "RefineScale"
2059! sub-divisions are done in the finer grid in each single coarse grid
2060! at the I-edge.
2061!
2062 iedge=io+(ibc-ibc_min)*refinescale(ngf)
2063 DO isum=-half,half
2064 ibf=iedge+isum
2065 DO k=1,n(ngf)
2066!^ tl_TFF=tl_TFF+ &
2067!^ & BRY_CONTACT(inorth,dgcr)%tl_Tflux(Ibf,k,itrc)
2068!^
2069 bry_contact(inorth,dgcr)%ad_Tflux(ibf,k,itrc)= &
2070 & bry_contact(inorth,dgcr)%ad_Tflux(ibf,k,itrc)+ad_tff
2071 END DO
2072 END DO
2073!^ tl_TFF=0.0_r8
2074!^
2075 ad_tff=0.0_r8
2076!
2077! Sum vertically coarse grid horizontal advective tracer flux,
2078! Hz*v*T/m, from last time-step.
2079!
2080 DO k=1,n(ngc)
2081!^ tl_TFC=tl_TFC+ &
2082!^ & BRY_CONTACT(inorth,rgcr)%tl_Tflux(Ibc,k,itrc)
2083!^
2084 bry_contact(inorth,rgcr)%ad_Tflux(ibc,k,itrc)= &
2085 & bry_contact(inorth,rgcr)%ad_Tflux(ibc,k,itrc)+ad_tfc
2086 END DO
2087!^ tl_TFC=0.0_r8
2088!^
2089 ad_tfc=0.0_r8
2090 END IF
2091 END DO
2092
2093!
2094!-----------------------------------------------------------------------
2095! Adjoint Finer grid southern boundary.
2096!-----------------------------------------------------------------------
2097!
2098 jbc=j_bottom(ngf)
2099 ibc_min=i_left(ngf)
2100 ibc_max=i_right(ngf)-1 ! interior points, no bottom
2101! right corner
2102! right corner
2103 DO ibc=istr,iend
2104 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
2105 & ((jstr.le.jbc-1).and.(jbc-1.le.jend))) THEN
2106!
2107! Sum vertically coarse grid horizontal advective tracer flux,
2108! Hz*v*T/m, from last time-step.
2109!
2110 tfc=0.0_r8
2111 DO k=1,n(ngc)
2112 tfc=tfc+bry_contact(isouth,rgcr)%Tflux(ibc,k,itrc)
2113 END DO
2114!
2115! Sum vertically and horizontally finer grid advective tracer flux.
2116! This is a vertical and horizontal I-integral because "RefineScale"
2117! sub-divisions are done in the finer grid in each single coarse grid
2118! at the I-edge.
2119!
2120 tff=0.0_r8
2121 iedge=io+(ibc-ibc_min)*refinescale(ngf)
2122 DO isum=-half,half
2123 ibf=iedge+isum
2124 DO k=1,n(ngf)
2125 tff=tff+bry_contact(isouth,dgcr)%Tflux(ibf,k,itrc)
2126 END DO
2127 END DO
2128!
2129! Zeroth order correction to fine grid time integral (RIL, 2016).
2130!
2131 tff=tff*dt(ngc)/dt(ngf)
2132
2133 cff=grid(ngc)%pm(ibc,jbc-1)* &
2134 & grid(ngc)%pn(ibc,jbc-1)* &
2135 & dinv(ibc,jbc-1)
2136
2137 DO k=1,n(ngc)
2138!^ OCEAN(ngc)%tl_t(Ibc,Jbc-1,k,Tindex,itrc)=tl_Tvalue
2139!^
2140 ad_tvalue=ad_tvalue+ &
2141 & ocean(ngc)%ad_t(ibc,jbc-1,k,tindex,itrc)
2142 ocean(ngc)%ad_t(ibc,jbc-1,k,tindex,itrc)=0.0_r8
2143# ifdef MASKING
2144!^ tl_Tvalue=tl_Tvalue*GRID(ngc)%rmask(Ibc,Jbc-1)
2145!^
2146 ad_tvalue=ad_tvalue*grid(ngc)%rmask(ibc,jbc-1)
2147# endif
2148 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
2149!^ tl_Tvalue=tl_Tvalue- &
2150!^ & dt(ngc)* &
2151!^ & CLIMA(ngc)%Tnudgcof(Ibc,Jbc-1,k,itrc)* &
2152!^ & tl_Tvalue
2153!^
2154 ad_tvalue=ad_tvalue* &
2155 & (1.0_r8-dt(ngc)* &
2156 & clima(ngc)%Tnudgcof(ibc,jbc-1,k,itrc))
2157 END IF
2158!^ tl_Tvalue=(0.5_r8- &
2159!^ & SIGN(0.5_r8, &
2160!^ & -(OCEAN(ngc)%t(Ibc,Jbc-1,k,Tindex,itrc)- &
2161!^ & cff*(TFF-TFC))))* &
2162!^ & (OCEAN(ngc)%tl_t(Ibc,Jbc-1,k,Tindex,itrc)- &
2163!^ & tl_cff*(TFF-TFC)-cff*(tl_TFF-tl_TFC))
2164!^
2165 adfac=(0.5_r8- &
2166 & sign(0.5_r8, &
2167 & -(ocean(ngc)%t(ibc,jbc-1,k,tindex,itrc)- &
2168 & cff*(tff-tfc))))*ad_tvalue
2169 ocean(ngc)%ad_t(ibc,jbc-1,k,tindex,itrc)= &
2170 & ocean(ngc)%ad_t(ibc,jbc-1,k,tindex,itrc)+adfac
2171 ad_cff=ad_cff-(tff-tfc)*adfac
2172 ad_tff=ad_tff-cff*adfac
2173 ad_tfc=ad_tfc+cff*adfac
2174 ad_tvalue=0.0_r8
2175 END DO
2176!
2177! Correct coarse grid tracer at the finer grid southern boundary.
2178!
2179!^ tl_cff=GRID(ngc)%pm(Ibc,Jbc-1)* &
2180!^ & GRID(ngc)%pn(Ibc,Jbc-1)* &
2181!^ & tl_Dinv(Ibc,Jbc-1)
2182!^
2183 ad_dinv(ibc,jbc-1)=ad_dinv(ibc,jbc-1)+ &
2184 & grid(ngc)%pm(ibc,jbc-1)* &
2185 & grid(ngc)%pn(ibc,jbc-1)*ad_cff
2186 ad_cff=0.0_r8
2187!
2188! Zeroth order correction to fine grid time integral (RIL, 2016).
2189!
2190!^ tl_TFF=tl_TFF*dt(ngc)/dt(ngf)
2191!^
2192 ad_tff=ad_tff*dt(ngc)/dt(ngf)
2193!
2194! Sum vertically and horizontally finer grid advective tracer flux.
2195! This is a vertical and horizontal I-integral because "RefineScale"
2196! sub-divisions are done in the finer grid in each single coarse grid
2197! at the I-edge.
2198!
2199 iedge=io+(ibc-ibc_min)*refinescale(ngf)
2200 DO isum=-half,half
2201 ibf=iedge+isum
2202 DO k=1,n(ngf)
2203!^ tl_TFF=tl_TFF+ &
2204!^ & BRY_CONTACT(isouth,dgcr)%tl_Tflux(Ibf,k,itrc)
2205!^
2206 bry_contact(isouth,dgcr)%ad_Tflux(ibf,k,itrc)= &
2207 & bry_contact(isouth,dgcr)%ad_Tflux(ibf,k,itrc)+ad_tff
2208 END DO
2209 END DO
2210!^ tl_TFF=0.0_r8
2211!^
2212 ad_tff=0.0_r8
2213!
2214! Sum vertically coarse grid horizontal advective tracer flux,
2215! Hz*v*T/m, from last time-step.
2216!
2217 DO k=1,n(ngc)
2218!^ tl_TFC=tl_TFC+ &
2219!^ & BRY_CONTACT(isouth,rgcr)%tl_Tflux(Ibc,k,itrc)
2220!^
2221 bry_contact(isouth,rgcr)%ad_Tflux(ibc,k,itrc)= &
2222 & bry_contact(isouth,rgcr)%ad_Tflux(ibc,k,itrc)+ad_tfc
2223 END DO
2224!^ tl_TFC=0.0_r8
2225!^
2226 ad_tfc=0.0_r8
2227 END IF
2228 END DO
2229!
2230!-----------------------------------------------------------------------
2231! Finer grid eastern boundary.
2232!-----------------------------------------------------------------------
2233!
2234 ibc=i_right(ngf)
2235 jbc_min=j_bottom(ngf)
2236 jbc_max=j_top(ngf)-1 ! interior points, no top
2237! right corner
2238 DO jbc=jstr,jend
2239 IF (((istr.le.ibc).and.(ibc.le.iend)).and. &
2240 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
2241!
2242! Sum vertically coarse grid horizontal advective tracer flux,
2243! Hz*u*T/n, from last time-step.
2244!
2245 tfc=0.0_r8
2246 DO k=1,n(ngc)
2247 tfc=tfc+bry_contact(ieast,rgcr)%Tflux(jbc,k,itrc)
2248 END DO
2249!
2250! Sum vertically and horizontally finer grid advective tracer flux.
2251! This is a vertical and horizontal J-integral because "RefineScale"
2252! sub-divisions are done in the finer grid in each single coarse grid
2253! at the J-edge.
2254!
2255 tff=0.0_r8
2256 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
2257 DO jsum=-half,half
2258 jbf=jedge+jsum
2259 DO k=1,n(ngf)
2260 tff=tff+bry_contact(ieast,dgcr)%Tflux(jbf,k,itrc)
2261 END DO
2262 END DO
2263!
2264! Zeroth order correction to fine grid time integral (RIL, 2016).
2265!
2266 tff=tff*dt(ngc)/dt(ngf)
2267!
2268! Correct coarse grid tracer at the finer grid eastern boundary.
2269!
2270 cff=grid(ngc)%pm(ibc,jbc)* &
2271 & grid(ngc)%pn(ibc,jbc)* &
2272 & dinv(ibc,jbc)
2273 DO k=1,n(ngc)
2274!^ OCEAN(ngc)%tl_t(Ibc,Jbc,k,Tindex,itrc)=tl_Tvalue
2275!^
2276 ad_tvalue=ad_tvalue+ &
2277 & ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)
2278 ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)=0.0_r8
2279# ifdef MASKING
2280!^ tl_Tvalue=tl_Tvalue*GRID(ngc)%rmask(Ibc,Jbc)
2281!^
2282 ad_tvalue=ad_tvalue*grid(ngc)%rmask(ibc,jbc)
2283# endif
2284 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
2285!^ tl_Tvalue=tl_Tvalue- &
2286!^ & dt(ngc)* &
2287!^ & CLIMA(ngc)%Tnudgcof(Ibc,Jbc,k,itrc)* &
2288!^ & tl_Tvalue
2289!^
2290 ad_tvalue=ad_tvalue* &
2291 & (1.0_r8-dt(ngc)* &
2292 & clima(ngc)%Tnudgcof(ibc,jbc,k,itrc))
2293 END IF
2294!^ tl_Tvalue=(0.5_r8- &
2295!^ & SIGN(0.5_r8, &
2296!^ & -(OCEAN(ngc)%t(Ibc,Jbc,k,Tindex,itrc)- &
2297!^ & cff*(TFF-TFC))))* &
2298!^ & (OCEAN(ngc)%tl_t(Ibc,Jbc,k,Tindex,itrc)- &
2299!^ & tl_cff*(TFF-TFC)-cff*(tl_TFF-tl_TFC))
2300!^
2301 adfac=(0.5_r8- &
2302 & sign(0.5_r8, &
2303 & -(ocean(ngc)%t(ibc,jbc,k,tindex,itrc)- &
2304 & cff*(tff-tfc))))*ad_tvalue
2305 ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)= &
2306 & ocean(ngc)%ad_t(ibc,jbc,k,tindex,itrc)+adfac
2307 ad_cff=ad_cff-(tff-tfc)*adfac
2308 ad_tff=ad_tff-cff*adfac
2309 ad_tfc=ad_tfc+cff*adfac
2310 ad_tvalue=0.0_r8
2311 END DO
2312!
2313! Correct coarse grid tracer at the finer grid eastern boundary.
2314!
2315!^ tl_cff=GRID(ngc)%pm(Ibc,Jbc)* &
2316!^ & GRID(ngc)%pn(Ibc,Jbc)* &
2317!^ & tl_Dinv(Ibc,Jbc)
2318!^
2319 ad_dinv(ibc,jbc)=ad_dinv(ibc,jbc)+ &
2320 & grid(ngc)%pm(ibc,jbc)* &
2321 & grid(ngc)%pn(ibc,jbc)*ad_cff
2322 ad_cff=0.0_r8
2323!
2324! Zeroth order correction to fine grid time integral (RIL, 2016).
2325!
2326!^ tl_TFF=tl_TFF*dt(ngc)/dt(ngf)
2327!^
2328 ad_tff=ad_tff*dt(ngc)/dt(ngf)
2329!
2330! Sum vertically and horizontally finer grid advective tracer flux.
2331! This is a vertical and horizontal J-integral because "RefineScale"
2332! sub-divisions are done in the finer grid in each single coarse grid
2333! at the J-edge.
2334!
2335 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
2336 DO jsum=-half,half
2337 jbf=jedge+jsum
2338 DO k=1,n(ngf)
2339!^ tl_TFF=tl_TFF+ &
2340!^ & BRY_CONTACT(ieast,dgcr)%tl_Tflux(Jbf,k,itrc)
2341!^
2342 bry_contact(ieast,dgcr)%ad_Tflux(jbf,k,itrc)= &
2343 & bry_contact(ieast,dgcr)%ad_Tflux(jbf,k,itrc)+ad_tff
2344 END DO
2345 END DO
2346!^ tl_TFF=0.0_r8
2347!^
2348 ad_tff=0.0_r8
2349!
2350! Sum vertically coarse grid horizontal advective tracer flux,
2351! Hz*u*T/n, from last time-step.
2352!
2353 DO k=1,n(ngc)
2354!^ tl_TFC=tl_TFC+ &
2355!^ & BRY_CONTACT(ieast,rgcr)%tl_Tflux(Jbc,k,itrc)
2356!^
2357 bry_contact(ieast,rgcr)%ad_Tflux(jbc,k,itrc)= &
2358 & bry_contact(ieast,rgcr)%ad_Tflux(jbc,k,itrc)+ad_tfc
2359 END DO
2360!^ tl_TFC=0.0_r8
2361!^
2362 ad_tfc=0.0_r8
2363 END IF
2364 END DO
2365!
2366!-----------------------------------------------------------------------
2367! Finer grid western boundary.
2368!-----------------------------------------------------------------------
2369!
2370 ibc=i_left(ngf)
2371 jbc_min=j_bottom(ngf)
2372 jbc_max=j_top(ngf)-1 ! interior points, no top
2373! left corner
2374 DO jbc=jstr,jend
2375 IF (((istr.le.ibc-1).and.(ibc-1.le.iend)).and. &
2376 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
2377!
2378! Sum vertically coarse grid horizontal advective tracer flux,
2379! Hz*u*T/n, from last time-step.
2380!
2381 tfc=0.0_r8
2382 DO k=1,n(ngc)
2383 tfc=tfc+bry_contact(iwest,rgcr)%Tflux(jbc,k,itrc)
2384 END DO
2385!
2386! Sum vertically and horizontally finer grid advective tracer flux.
2387! This is a vertical and horizontal J-integral because "RefineScale"
2388! sub-divisions are done in the finer grid in each single coarse grid
2389! at the J-edge.
2390!
2391 tff=0.0_r8
2392 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
2393 DO jsum=-half,half
2394 jbf=jedge+jsum
2395 DO k=1,n(ngf)
2396 tff=tff+bry_contact(iwest,dgcr)%Tflux(jbf,k,itrc)
2397 END DO
2398 END DO
2399!
2400! Zeroth order correction to fine grid time integral (RIL, 2016).
2401!
2402 tff=tff*dt(ngc)/dt(ngf)
2403!
2404! Correct coarse grid tracer at the finer grid western boundary.
2405!
2406 cff=grid(ngc)%pm(ibc-1,jbc)* &
2407 & grid(ngc)%pn(ibc-1,jbc)* &
2408 & dinv(ibc-1,jbc)
2409 DO k=1,n(ngc)
2410!^ OCEAN(ngc)%tl_t(Ibc-1,Jbc,k,Tindex,itrc)=tl_Tvalue
2411!^
2412 ad_tvalue=ad_tvalue+ &
2413 & ocean(ngc)%ad_t(ibc-1,jbc,k,tindex,itrc)
2414 ocean(ngc)%ad_t(ibc-1,jbc,k,tindex,itrc)=0.0_r8
2415# ifdef MASKING
2416!^ tl_Tvalue=tl_Tvalue*GRID(ngc)%rmask(Ibc-1,Jbc)
2417!^
2418 ad_tvalue=ad_tvalue*grid(ngc)%rmask(ibc-1,jbc)
2419# endif
2420 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
2421!^ tl_Tvalue=tl_Tvalue- &
2422!^ & dt(ngc)* &
2423!^ & CLIMA(ngc)%Tnudgcof(Ibc-1,Jbc,k,itrc)* &
2424!^ & tl_Tvalue
2425!^
2426 ad_tvalue=ad_tvalue* &
2427 & (1.0_r8-dt(ngc)* &
2428 & clima(ngc)%Tnudgcof(ibc-1,jbc,k,itrc))
2429 END IF
2430!^ tl_Tvalue=(0.5_r8- &
2431!^ & SIGN(0.5_r8, &
2432!^ & -(OCEAN(ngc)%t(Ibc-1,Jbc,k,Tindex,itrc)- &
2433!^ & cff*(TFF-TFC))))* &
2434!^ & (OCEAN(ngc)%tl_t(Ibc-1,Jbc,k,Tindex,itrc)- &
2435!^ & tl_cff*(TFF-TFC)-cff*(tl_TFF-tl_TFC))
2436!^
2437 adfac=(0.5_r8- &
2438 & sign(0.5_r8, &
2439 & -(ocean(ngc)%t(ibc-1,jbc,k,tindex,itrc)- &
2440 & cff*(tff-tfc))))*ad_tvalue
2441 ocean(ngc)%ad_t(ibc-1,jbc,k,tindex,itrc)= &
2442 & ocean(ngc)%ad_t(ibc-1,jbc,k,tindex,itrc)+adfac
2443 ad_cff=ad_cff-(tff-tfc)*adfac
2444 ad_tff=ad_tff-cff*adfac
2445 ad_tfc=ad_tfc+cff*adfac
2446 ad_tvalue=0.0_r8
2447 END DO
2448!
2449! Correct coarse grid tracer at the finer grid western boundary.
2450!
2451!^ tl_cff=GRID(ngc)%pm(Ibc-1,Jbc)* &
2452!^ & GRID(ngc)%pn(Ibc-1,Jbc)* &
2453!^ & tl_Dinv(Ibc-1,Jbc)
2454!^
2455 ad_dinv(ibc-1,jbc)=ad_dinv(ibc-1,jbc)+ &
2456 & grid(ngc)%pm(ibc-1,jbc)* &
2457 & grid(ngc)%pn(ibc-1,jbc)*ad_cff
2458 ad_cff=0.0_r8
2459!
2460! Zeroth order correction to fine grid time integral (RIL, 2016).
2461!
2462!^ tl_TFF=tl_TFF*dt(ngc)/dt(ngf)
2463!^
2464 ad_tff=ad_tff*dt(ngc)/dt(ngf)
2465!
2466! Sum vertically and horizontally finer grid advective tracer flux.
2467! This is a vertical and horizontal J-integral because "RefineScale"
2468! sub-divisions are done in the finer grid in each single coarse grid
2469! at the J-edge.
2470!
2471 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
2472 DO jsum=-half,half
2473 jbf=jedge+jsum
2474 DO k=1,n(ngf)
2475!^ tl_TFF=tl_TFF+ &
2476!^ & BRY_CONTACT(iwest,dgcr)%tl_Tflux(Jbf,k,itrc)
2477!^
2478 bry_contact(iwest,dgcr)%ad_Tflux(jbf,k,itrc)= &
2479 & bry_contact(iwest,dgcr)%ad_Tflux(jbf,k,itrc)+ad_tff
2480 END DO
2481 END DO
2482!^ tl_TFF=0.0_r8
2483!^
2484 ad_tff=0.0_r8
2485!
2486! Sum vertically coarse grid horizontal advective tracer flux,
2487! Hz*u*T/n, from last time-step.
2488!
2489 DO k=1,n(ngc)
2490!^ tl_TFC=tl_TFC+ &
2491!^ & BRY_CONTACT(iwest,rgcr)%tl_Tflux(Jbc,k,itrc)
2492!^
2493 bry_contact(iwest,rgcr)%ad_Tflux(jbc,k,itrc)= &
2494 & bry_contact(iwest,rgcr)%ad_Tflux(jbc,k,itrc)+ad_tfc
2495 END DO
2496!^ tl_TFC=0.0_r8
2497!^
2498 ad_tfc=0.0_r8
2499 END IF
2500 END DO
2501
2502 END DO t_loop
2503!
2504! Compute coarser grid inverse water colunm thickness.
2505!
2506 DO j=jstrm2,jendp2
2507 DO i=istrm2,iendp2
2508 cff=grid(ngc)%Hz(i,j,1)
2509 DO k=2,n(rg)
2510 cff=cff+grid(ngc)%Hz(i,j,k)
2511 END DO
2512 dinv(i,j)=1.0_r8/cff
2513!^ tl_Dinv(i,j)=-tl_cff*Dinv(i,j)/cff
2514!^
2515 ad_cff=ad_cff-ad_dinv(i,j)*dinv(i,j)/cff
2516 ad_dinv(i,j)=0.0_r8
2517 DO k=2,n(rg)
2518!^ tl_cff=tl_cff+GRID(ngc)%tl_Hz(i,j,k)
2519!^
2520 grid(ngc)%ad_Hz(i,j,k)=grid(ngc)%ad_Hz(i,j,k)+ad_cff
2521 END DO
2522!^ tl_cff=GRID(ngc)%tl_Hz(i,j,1)
2523!^
2524 grid(ngc)%ad_Hz(i,j,1)=grid(ngc)%ad_Hz(i,j,1)+ad_cff
2525 ad_cff=0.0_r8
2526 END DO
2527 END DO
2528
2529 RETURN
2530 END SUBROUTINE ad_correct_tracer_tile
2531# endif
2532!
2533 SUBROUTINE ad_fine2coarse (ng, model, vtype, tile)
2534!
2535!=======================================================================
2536! !
2537! This routine replaces interior coarse grid data with the refined !
2538! averaged values: two-way nesting. !
2539! !
2540! On Input: !
2541! !
2542! ng Refinement grid number (integer) !
2543! model Calling model identifier (integer) !
2544! vtype State variables to process (integer): !
2545! vtype = r2dvar 2D state variables !
2546! vtype = r3dvar 3D state variables !
2547! tile Domain tile partition (integer) !
2548! !
2549! On Output: (mod_coupling, mod_ocean) !
2550! !
2551! Updated state variable with average refined grid !
2552! solution !
2553! !
2554!=======================================================================
2555!
2556 USE mod_param
2557 USE mod_parallel
2558 USE mod_coupling
2559 USE mod_forces
2560 USE mod_grid
2561 USE mod_iounits
2562 USE mod_ncparam
2563 USE mod_nesting
2564 USE mod_ocean
2565 USE mod_scalars
2566 USE mod_stepping
2567!
2568 USE ad_exchange_2d_mod
2569# ifdef SOLVE3D
2570 USE ad_exchange_3d_mod
2571# endif
2572# ifdef DISTRIBUTE
2573 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
2574# ifdef SOLVE3D
2575 USE mp_exchange_mod, ONLY : ad_mp_exchange3d, ad_mp_exchange4d
2576# endif
2577# endif
2578 USE strings_mod, ONLY : founderror
2579!
2580! Imported variable declarations.
2581!
2582 integer, intent(in) :: ng, model, vtype, tile
2583!
2584! Local variable declarations.
2585!
2586 logical :: areaavg
2587 integer :: lbid, ubid, lbjd, ubjd
2588 integer :: lbir, ubir, lbjr, ubjr
2589 integer :: dindex2d, rindex2d
2590# ifdef SOLVE3D
2591 integer :: dindex3d, rindex3d
2592# endif
2593 integer :: cr, dg, k, rg, nrec, rec
2594# ifdef SOLVE3D
2595 integer :: itrc
2596# endif
2597!
2598 character (len=*), parameter :: myfile = &
2599 & __FILE__//", ad_fine2coarse"
2600!
2601!-----------------------------------------------------------------------
2602! Average interior fine grid state variable data to the coarse grid
2603! location. Then, replace coarse grid values with averaged data.
2604!-----------------------------------------------------------------------
2605!
2606 DO cr=1,ncontact
2607!
2608! Get data donor and data receiver grid numbers.
2609!
2610 dg=rcontact(cr)%donor_grid
2611 rg=rcontact(cr)%receiver_grid
2612!
2613! Process contact region if the current refinement grid "ng" is the
2614! donor grid. The coarse grid "rg" is the receiver grid and the
2615! contact structure has all the information necessary for fine to
2616! coarse coupling. The donor grid size is always smaller than the
2617! receiver coarser grid.
2618!
2619 IF ((ng.eq.dg).and.(dxmax(dg).lt.dxmax(rg))) THEN
2620!
2621! Set donor and receiver grids lower and upper array indices.
2622!
2623 lbid=bounds(dg)%LBi(tile)
2624 ubid=bounds(dg)%UBi(tile)
2625 lbjd=bounds(dg)%LBj(tile)
2626 ubjd=bounds(dg)%UBj(tile)
2627!
2628 lbir=bounds(rg)%LBi(tile)
2629 ubir=bounds(rg)%UBi(tile)
2630 lbjr=bounds(rg)%LBj(tile)
2631 ubjr=bounds(rg)%UBj(tile)
2632!
2633! Report.
2634!
2635 IF (domain(ng)%SouthWest_Test(tile)) THEN
2636 IF (master.and.(vtype.eq.r2dvar)) THEN
2637 WRITE (stdout,10) dg, rg, cr
2638 10 FORMAT (6x,'AD_FINE2COARSE - exchanging data between ', &
2639 & 'grids: dg = ',i2.2,' and rg = ',i2.2, &
2640 & ' at cr = ',i2.2)
2641 END IF
2642 END IF
2643!
2644! Set state variable indices to process for donor and receiver grids.
2645! Since the exchange of data is done at the bottom of main2d/main3d,
2646! we need to use the newest time indices.
2647!
2648 dindex2d=knew(dg) ! Donor 2D variables index
2649 rindex2d=knew(rg) ! Receiver 3D variables index
2650# ifdef SOLVE3D
2651 dindex3d=nnew(dg) ! Donor 3D variables index
2652 rindex3d=nnew(rg) ! Receiver 3D variables index
2653# endif
2654!
2655!-----------------------------------------------------------------------
2656! Exchange boundary data.
2657!-----------------------------------------------------------------------
2658!
2659 IF (ewperiodic(rg).or.nsperiodic(rg)) THEN
2660 IF (vtype.eq.r2dvar) THEN
2661# ifdef SOLVE3D
2662!^ CALL exchange_r2d_tile (rg, tile, &
2663!^ & LBiR, UBiR, LBjR, UBjR, &
2664!^ & COUPLING(rg)%tl_Zt_avg1)
2665!^
2666 CALL ad_exchange_r2d_tile (rg, tile, &
2667 & lbir, ubir, lbjr, ubjr, &
2668 & coupling(rg)%ad_Zt_avg1)
2669 DO k=1,2
2670!^ CALL exchange_u2d_tile (rg, tile, &
2671!^ & LBiR, UBiR, LBjR, UBjR, &
2672!^ & OCEAN(rg)%tl_ubar(:,:,k))
2673!^
2674 CALL ad_exchange_u2d_tile (rg, tile, &
2675 & lbir, ubir, lbjr, ubjr, &
2676 & ocean(rg)%ad_ubar(:,:,k))
2677!^ CALL exchange_v2d_tile (rg, tile, &
2678!^ & LBiR, UBiR, LBjR, UBjR, &
2679!^ & OCEAN(rg)%tl_vbar(:,:,k))
2680!^
2681 CALL ad_exchange_v2d_tile (rg, tile, &
2682 & lbir, ubir, lbjr, ubjr, &
2683 & ocean(rg)%ad_vbar(:,:,k))
2684 END DO
2685# else
2686!^ CALL exchange_r2d_tile (rg, tile, &
2687!^ & LBiR, UBiR, LBjR, UBjR, &
2688!^ & OCEAN(rg)%tl_zeta(:,:,Rindex2d))
2689!^
2690 CALL ad_exchange_r2d_tile (rg, tile, &
2691 & lbir, ubir, lbjr, ubjr, &
2692 & ocean(rg)%ad_zeta(:,:, &
2693 & rindex2d))
2694!^ CALL exchange_u2d_tile (rg, tile, &
2695!^ & LBiR, UBiR, LBjR, UBjR, &
2696!^ & OCEAN(rg)%tl_ubar(:,:,Rindex2d))
2697!^
2698 CALL ad_exchange_u2d_tile (rg, tile, &
2699 & lbir, ubir, lbjr, ubjr, &
2700 & ocean(rg)%ad_ubar(:,:, &
2701 & rindex2d))
2702!^ CALL exchange_v2d_tile (rg, tile, &
2703!^ & LBiR, UBiR, LBjR, UBjR, &
2704!^ & OCEAN(rg)%tl_vbar(:,:,Rindex2d))
2705!^
2706 CALL ad_exchange_v2d_tile (rg, tile, &
2707 & lbir, ubir, lbjr, ubjr, &
2708 & ocean(rg)%ad_vbar(:,:, &
2709 & rindex2d))
2710# endif
2711# ifdef SOLVE3D
2712 ELSE IF (vtype.eq.r3dvar) THEN
2713!^ CALL exchange_u3d_tile (rg, tile, &
2714!^ & LBiR, UBiR, LBjR, UBjR, 1, N(rg), &
2715!^ & OCEAN(rg)%tl_u(:,:,:,Rindex3d))
2716!^
2717 CALL ad_exchange_u3d_tile (rg, tile, &
2718 & lbir, ubir, lbjr, ubjr, &
2719 & 1, n(rg), &
2720 & ocean(rg)%ad_u(:,:,:,rindex3d))
2721!^ CALL exchange_v3d_tile (rg, tile, &
2722!^ & LBiR, UBiR, LBjR, UBjR, 1, N(rg), &
2723!^ & OCEAN(rg)%tl_v(:,:,:,Rindex3d))
2724!^
2725 CALL ad_exchange_v3d_tile (rg, tile, &
2726 & lbir, ubir, lbjr, ubjr, &
2727 & 1, n(rg), &
2728 & ocean(rg)%ad_v(:,:,:,rindex3d))
2729 DO itrc=1,nt(rg)
2730!^ CALL exchange_r3d_tile (rg, tile, &
2731!^ & LBiR, UBiR, LBjR, UBjR, &
2732!^ & 1, N(rg), &
2733!^ & OCEAN(rg)%tl_t(:,:,:,Rindex3d, &
2734!^ & itrc))
2735!^
2736 CALL ad_exchange_r3d_tile (rg, tile, &
2737 & lbir, ubir, lbjr, ubjr, &
2738 & 1, n(rg), &
2739 & ocean(rg)%ad_t(:,:,:, &
2740 & rindex3d, &
2741 & itrc))
2742 END DO
2743# endif
2744 END IF
2745 END IF
2746
2747# ifdef DISTRIBUTE
2748!
2749 IF (vtype.eq.r2dvar) THEN
2750# ifdef SOLVE3D
2751!^ CALL mp_exchange2d (rg, tile, model, 1, &
2752!^ & LBiR, UBiR, LBjR, UBjR, &
2753!^ & NghostPoints, &
2754!^ & EWperiodic(rg), NSperiodic(rg), &
2755!^ & COUPLING(rg)%tl_Zt_avg1)
2756!^
2757 CALL ad_mp_exchange2d (rg, tile, model, 1, &
2758 & lbir, ubir, lbjr, ubjr, &
2759 & nghostpoints, &
2760 & ewperiodic(rg), nsperiodic(rg), &
2761 & coupling(rg)%ad_Zt_avg1)
2762!^ CALL mp_exchange2d (rg, tile, model, 4, &
2763!^ & LBiR, UBiR, LBjR, UBjR, &
2764!^ & NghostPoints, &
2765!^ & EWperiodic(rg), NSperiodic(rg), &
2766!^ & OCEAN(rg)%tl_ubar(:,:,1), &
2767!^ & OCEAN(rg)%tl_vbar(:,:,1), &
2768!^ & OCEAN(rg)%tl_ubar(:,:,2), &
2769!^ & OCEAN(rg)%tl_vbar(:,:,2))
2770!^
2771 CALL ad_mp_exchange2d (rg, tile, model, 4, &
2772 & lbir, ubir, lbjr, ubjr, &
2773 & nghostpoints, &
2774 & ewperiodic(rg), nsperiodic(rg), &
2775 & ocean(rg)%ad_ubar(:,:,1), &
2776 & ocean(rg)%ad_vbar(:,:,1), &
2777 & ocean(rg)%ad_ubar(:,:,2), &
2778 & ocean(rg)%ad_vbar(:,:,2))
2779# else
2780!^ CALL mp_exchange2d (rg, tile, model, 3, &
2781!^ & LBiR, UBiR, LBjR, UBjR, &
2782!^ & NghostPoints, &
2783!^ & EWperiodic(rg), NSperiodic(rg), &
2784!^ & OCEAN(rg)%tl_zeta(:,:,Rindex2d), &
2785!^ & OCEAN(rg)%tl_ubar(:,:,Rindex2d), &
2786!^ & OCEAN(rg)%tl_vbar(:,:,Rindex2d))
2787!^
2788 CALL ad_mp_exchange2d (rg, tile, model, 3, &
2789 & lbir, ubir, lbjr, ubjr, &
2790 & nghostpoints, &
2791 & ewperiodic(rg), nsperiodic(rg), &
2792 & ocean(rg)%ad_zeta(:,:,rindex2d), &
2793 & ocean(rg)%ad_ubar(:,:,rindex2d), &
2794 & ocean(rg)%ad_vbar(:,:,rindex2d))
2795# endif
2796# ifdef SOLVE3D
2797 ELSE IF (vtype.eq.r3dvar) THEN
2798!^ CALL mp_exchange3d (rg, tile, model, 2, &
2799!^ & LBiR, UBiR, LBjR, UBjR, 1, N(rg), &
2800!^ & NghostPoints, &
2801!^ & EWperiodic(rg), NSperiodic(rg), &
2802!^ & OCEAN(rg)%tl_u(:,:,:,Rindex3d), &
2803!^ & OCEAN(rg)%tl_v(:,:,:,Rindex3d))
2804!^
2805 CALL ad_mp_exchange3d (rg, tile, model, 2, &
2806 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
2807 & nghostpoints, &
2808 & ewperiodic(rg), nsperiodic(rg), &
2809 & ocean(rg)%ad_u(:,:,:,rindex3d), &
2810 & ocean(rg)%ad_v(:,:,:,rindex3d))
2811!^ CALL mp_exchange4d (rg, tile, model, 1, &
2812!^ & LBiR, UBiR, LBjR, UBjR, 1, N(rg), &
2813!^ & 1, NT(rg), &
2814!^ & NghostPoints, &
2815!^ & EWperiodic(rg), NSperiodic(rg), &
2816!^ & OCEAN(rg)%tl_t(:,:,:,Rindex3d,:))
2817!^
2818 CALL ad_mp_exchange4d (rg, tile, model, 1, &
2819 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
2820 & 1, nt(rg), &
2821 & nghostpoints, &
2822 & ewperiodic(rg), nsperiodic(rg), &
2823 & ocean(rg)%ad_t(:,:,:,rindex3d,:))
2824# endif
2825 END IF
2826# endif
2827!
2828!-----------------------------------------------------------------------
2829! Process 2D state variables.
2830!-----------------------------------------------------------------------
2831!
2832 IF (vtype.eq.r2dvar) THEN
2833!
2834! Free-surface.
2835!
2836 areaavg=.false.
2837# ifdef SOLVE3D
2838!^ CALL fine2coarse2d (rg, dg, model, tile, &
2839!^ & r2dvar, 'Zt_avg1', &
2840!^ & AreaAvg, RefineScale(dg), &
2841!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
2842!^ & LBiD, UBiD, LBjD, UBjD, &
2843!^ & LBiR, UBiR, LBjR, UBjR, &
2844!^ & GRID(dg)%om_r, &
2845!^ & GRID(dg)%on_r, &
2846!^ & GRID(rg)%pm, &
2847!^ & GRID(rg)%pn, &
2848# ifdef MASKING
2849!^ & GRID(dg)%rmask_full, &
2850!^ & GRID(rg)%rmask, &
2851# endif
2852!^ & COUPLING(dg)%tl_Zt_avg1, &
2853!^ & COUPLING(rg)%tl_Zt_avg1)
2854!^
2855 CALL ad_fine2coarse2d (rg, dg, model, tile, &
2856 & r2dvar, 'Zt_avg1', &
2857 & areaavg, refinescale(dg), &
2858 & cr, rcontact(cr)%Npoints, rcontact, &
2859 & lbid, ubid, lbjd, ubjd, &
2860 & lbir, ubir, lbjr, ubjr, &
2861 & grid(dg)%om_r, &
2862 & grid(dg)%on_r, &
2863 & grid(rg)%pm, &
2864 & grid(rg)%pn, &
2865# ifdef MASKING
2866 & grid(dg)%rmask_full, &
2867 & grid(rg)%rmask, &
2868# endif
2869 & coupling(dg)%ad_Zt_avg1, &
2870 & coupling(rg)%ad_Zt_avg1)
2871# else
2872!^ CALL fine2coarse2d (rg, dg, model, tile, &
2873!^ & r2dvar, Vname(1,idFsur), &
2874!^ & AreaAvg, RefineScale(dg), &
2875!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
2876!^ & LBiD, UBiD, LBjD, UBjD, &
2877!^ & LBiR, UBiR, LBjR, UBjR, &
2878!^ & GRID(dg)%om_r, &
2879!^ & GRID(dg)%on_r, &
2880!^ & GRID(rg)%pm, &
2881!^ & GRID(rg)%pn, &
2882# ifdef MASKING
2883!^ & GRID(dg)%rmask, &
2884!^ & GRID(rg)%rmask, &
2885# endif
2886!^ & OCEAN(dg)%tl_zeta(:,:,Dindex2d), &
2887!^ & OCEAN(rg)%tl_zeta(:,:,Rindex2d))
2888!^
2889 CALL ad_fine2coarse2d (rg, dg, model, tile, &
2890 & r2dvar, vname(1,idfsur), &
2891 & areaavg, refinescale(dg), &
2892 & cr, rcontact(cr)%Npoints, rcontact, &
2893 & lbid, ubid, lbjd, ubjd, &
2894 & lbir, ubir, lbjr, ubjr, &
2895 & grid(dg)%om_r, &
2896 & grid(dg)%on_r, &
2897 & grid(rg)%pm, &
2898 & grid(rg)%pn, &
2899# ifdef MASKING
2900 & grid(dg)%rmask, &
2901 & grid(rg)%rmask, &
2902# endif
2903 & ocean(dg)%ad_zeta(:,:,dindex2d), &
2904 & ocean(rg)%ad_zeta(:,:,rindex2d))
2905# endif
2906 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2907!
2908! Process 2D momentum components (ubar,vbar).
2909!
2910 areaavg=.false.
2911!^ CALL fine2coarse2d (rg, dg, model, tile, &
2912!^ & u2dvar, Vname(1,idUbar), &
2913!^ & AreaAvg, RefineScale(dg), &
2914!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
2915!^ & LBiD, UBiD, LBjD, UBjD, &
2916!^ & LBiR, UBiR, LBjR, UBjR, &
2917!^ & GRID(dg)%om_u, &
2918!^ & GRID(dg)%on_u, &
2919!^ & GRID(rg)%pm, &
2920!^ & GRID(rg)%pn, &
2921# ifdef MASKING
2922!^ & GRID(dg)%umask_full, &
2923!^ & GRID(rg)%umask_full, &
2924# endif
2925!^ & OCEAN(dg)%tl_ubar(:,:,Dindex2d), &
2926# ifdef SOLVE3D
2927!^ & OCEAN(rg)%tl_ubar(:,:,1), &
2928!^ & OCEAN(rg)%tl_ubar(:,:,2))
2929# else
2930!^ & OCEAN(rg)%tl_ubar(:,:,Rindex2d))
2931# endif
2932!^
2933 CALL ad_fine2coarse2d (rg, dg, model, tile, &
2934 & u2dvar, vname(1,idubar), &
2935 & areaavg, refinescale(dg), &
2936 & cr, ucontact(cr)%Npoints, ucontact, &
2937 & lbid, ubid, lbjd, ubjd, &
2938 & lbir, ubir, lbjr, ubjr, &
2939 & grid(dg)%om_u, &
2940 & grid(dg)%on_u, &
2941 & grid(rg)%pm, &
2942 & grid(rg)%pn, &
2943# ifdef MASKING
2944 & grid(dg)%umask_full, &
2945 & grid(rg)%umask_full, &
2946# endif
2947 & ocean(dg)%ad_ubar(:,:,dindex2d), &
2948# ifdef SOLVE3D
2949 & ocean(rg)%ad_ubar(:,:,1), &
2950 & ocean(rg)%ad_ubar(:,:,2))
2951# else
2952 & ocean(rg)%ad_ubar(:,:,rindex2d))
2953# endif
2954 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2955!
2956!^ CALL fine2coarse2d (rg, dg, model, tile, &
2957!^ & v2dvar, Vname(1,idVbar), &
2958!^ & AreaAvg, RefineScale(dg), &
2959!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
2960!^ & LBiD, UBiD, LBjD, UBjD, &
2961!^ & LBiR, UBiR, LBjR, UBjR, &
2962!^ & GRID(dg)%om_v, &
2963!^ & GRID(dg)%on_v, &
2964!^ & GRID(rg)%pm, &
2965!^ & GRID(rg)%pn, &
2966# ifdef MASKING
2967!^ & GRID(dg)%vmask_full, &
2968!^ & GRID(rg)%vmask_full, &
2969# endif
2970!^ & OCEAN(dg)%tl_vbar(:,:,Dindex2d), &
2971# ifdef SOLVE3D
2972!^ & OCEAN(rg)%tl_vbar(:,:,1), &
2973!^ & OCEAN(rg)%tl_vbar(:,:,2))
2974# else
2975!^ & OCEAN(rg)%tl_vbar(:,:,Rindex2d))
2976# endif
2977!^
2978 CALL ad_fine2coarse2d (rg, dg, model, tile, &
2979 & v2dvar, vname(1,idvbar), &
2980 & areaavg, refinescale(dg), &
2981 & cr, vcontact(cr)%Npoints, vcontact, &
2982 & lbid, ubid, lbjd, ubjd, &
2983 & lbir, ubir, lbjr, ubjr, &
2984 & grid(dg)%om_v, &
2985 & grid(dg)%on_v, &
2986 & grid(rg)%pm, &
2987 & grid(rg)%pn, &
2988# ifdef MASKING
2989 & grid(dg)%vmask_full, &
2990 & grid(rg)%vmask_full, &
2991# endif
2992 & ocean(dg)%ad_vbar(:,:,dindex2d), &
2993# ifdef SOLVE3D
2994 & ocean(rg)%ad_vbar(:,:,1), &
2995 & ocean(rg)%ad_vbar(:,:,2))
2996# else
2997 & ocean(rg)%ad_vbar(:,:,rindex2d))
2998# endif
2999 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3000
3001# ifdef SOLVE3D
3002!
3003!-----------------------------------------------------------------------
3004! Process 3D state variables.
3005!-----------------------------------------------------------------------
3006!
3007 ELSE IF (vtype.eq.r3dvar) THEN
3008!
3009! Tracer type-variables.
3010!
3011 areaavg=.false.
3012 DO itrc=1,nt(rg)
3013!^ CALL fine2coarse3d (rg, dg, model, tile, &
3014!^ & r3dvar, Vname(1,idTvar(itrc)), &
3015!^ & AreaAvg, RefineScale(dg), &
3016!^ & cr, Rcontact(cr)%Npoints, Rcontact, &
3017!^ & LBiD, UBiD, LBjD, UBjD, 1, N(dg), &
3018!^ & LBiR, UBiR, LBjR, UBjR, 1, N(rg), &
3019!^ & GRID(dg)%om_r, &
3020!^ & GRID(dg)%on_r, &
3021!^ & GRID(rg)%pm, &
3022!^ & GRID(rg)%pn, &
3023# ifdef MASKING
3024!^ & GRID(dg)%rmask, &
3025!^ & GRID(rg)%rmask, &
3026# endif
3027!^ & OCEAN(dg)%tl_t(:,:,:,Dindex3d,itrc), &
3028!^ & OCEAN(rg)%tl_t(:,:,:,Rindex3d,itrc))
3029!^
3030 CALL ad_fine2coarse3d (rg, dg, model, tile, &
3031 & r3dvar, vname(1,idtvar(itrc)), &
3032 & areaavg, refinescale(dg), &
3033 & cr, rcontact(cr)%Npoints, rcontact,&
3034 & lbid, ubid, lbjd, ubjd, 1, n(dg), &
3035 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3036 & grid(dg)%om_r, &
3037 & grid(dg)%on_r, &
3038 & grid(rg)%pm, &
3039 & grid(rg)%pn, &
3040# ifdef MASKING
3041 & grid(dg)%rmask, &
3042 & grid(rg)%rmask, &
3043# endif
3044 & ocean(dg)%ad_t(:,:,:,dindex3d, &
3045 & itrc), &
3046 & ocean(rg)%ad_t(:,:,:,rindex3d, &
3047 & itrc))
3048 IF (founderror(exit_flag, noerror, &
3049 & __line__, myfile)) RETURN
3050 END DO
3051!
3052! Process 3D momentum components (u, v).
3053!
3054 areaavg=.false.
3055!^ CALL fine2coarse3d (rg, dg, model, tile, &
3056!^ & u3dvar, Vname(1,idUvel), &
3057!^ & AreaAvg, RefineScale(dg), &
3058!^ & cr, Ucontact(cr)%Npoints, Ucontact, &
3059!^ & LBiD, UBiD, LBjD, UBjD, 1, N(dg), &
3060!^ & LBiR, UBiR, LBjR, UBjR, 1, N(rg), &
3061!^ & GRID(dg)%om_u, &
3062!^ & GRID(dg)%on_u, &
3063!^ & GRID(rg)%pm, &
3064!^ & GRID(rg)%pn, &
3065# ifdef MASKING
3066!^ & GRID(dg)%umask_full, &
3067!^ & GRID(rg)%umask_full, &
3068# endif
3069!^ & OCEAN(dg)%tl_u(:,:,:,Dindex3d), &
3070!^ & OCEAN(rg)%tl_u(:,:,:,Rindex3d))
3071!^
3072 CALL ad_fine2coarse3d (rg, dg, model, tile, &
3073 & u3dvar, vname(1,iduvel), &
3074 & areaavg, refinescale(dg), &
3075 & cr, ucontact(cr)%Npoints, ucontact, &
3076 & lbid, ubid, lbjd, ubjd, 1, n(dg), &
3077 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3078 & grid(dg)%om_u, &
3079 & grid(dg)%on_u, &
3080 & grid(rg)%pm, &
3081 & grid(rg)%pn, &
3082# ifdef MASKING
3083 & grid(dg)%umask_full, &
3084 & grid(rg)%umask_full, &
3085# endif
3086 & ocean(dg)%ad_u(:,:,:,dindex3d), &
3087 & ocean(rg)%ad_u(:,:,:,rindex3d))
3088 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3089!
3090!^ CALL fine2coarse3d (rg, dg, model, tile, &
3091!^ & v3dvar, Vname(1,idVvel), &
3092!^ & AreaAvg, RefineScale(dg), &
3093!^ & cr, Vcontact(cr)%Npoints, Vcontact, &
3094!^ & LBiD, UBiD, LBjD, UBjD, 1, N(dg), &
3095!^ & LBiR, UBiR, LBjR, UBjR, 1, N(rg), &
3096!^ & GRID(dg)%om_v, &
3097!^ & GRID(dg)%on_v, &
3098!^ & GRID(rg)%pm, &
3099!^ & GRID(rg)%pn, &
3100# ifdef MASKING
3101!^ & GRID(dg)%vmask_full, &
3102!^ & GRID(rg)%vmask_full, &
3103# endif
3104!^ & OCEAN(dg)%tl_v(:,:,:,Dindex3d), &
3105!^ & OCEAN(rg)%tl_v(:,:,:,Rindex3d))
3106!^
3107 CALL ad_fine2coarse3d (rg, dg, model, tile, &
3108 & v3dvar, vname(1,idvvel), &
3109 & areaavg, refinescale(dg), &
3110 & cr, vcontact(cr)%Npoints, vcontact, &
3111 & lbid, ubid, lbjd, ubjd, 1, n(dg), &
3112 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3113 & grid(dg)%om_v, &
3114 & grid(dg)%on_v, &
3115 & grid(rg)%pm, &
3116 & grid(rg)%pn, &
3117# ifdef MASKING
3118 & grid(dg)%vmask_full, &
3119 & grid(rg)%vmask_full, &
3120# endif
3121 & ocean(dg)%ad_v(:,:,:,dindex3d), &
3122 & ocean(rg)%ad_v(:,:,:,rindex3d))
3123 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3124# endif
3125 END IF
3126!
3127 END IF
3128 END DO
3129
3130 RETURN
3131 END SUBROUTINE ad_fine2coarse
3132!
3133 SUBROUTINE ad_put_refine2d (ng, dg, cr, model, tile, LputFsur, &
3134 & LBi, UBi, LBj, UBj)
3135!
3136!=======================================================================
3137! !
3138! This routine interpolates (space, time) refinement grid 2D state !
3139! variables contact points using data from the donor grid. Notice !
3140! that because of shared-memory parallelism, the free-surface is !
3141! processed first and in a different parallel region. !
3142! !
3143! On Input: !
3144! !
3145! ng Refinement (receiver) grid number (integer) !
3146! dg Donor grid number (integer) !
3147! cr Contact region number to process (integer) !
3148! model Calling model identifier (integer) !
3149! tile Domain tile partition (integer) !
3150! LputFsur Switch to process or not free-surface (logical) !
3151! LBi Receiver grid, I-dimension Lower bound (integer) !
3152! UBi Receiver grid, I-dimension Upper bound (integer) !
3153! LBj Receiver grid, J-dimension Lower bound (integer) !
3154! UBj Receiver grid, J-dimension Upper bound (integer) !
3155! !
3156! On Output: OCEAN(ng) structure !
3157! !
3158! zeta Updated free-surface !
3159! ubar Updated 2D momentum in the XI-direction !
3160! vbar Updated 2D momentum in the ETA-direction !
3161! !
3162!=======================================================================
3163!
3164 USE mod_param
3165 USE mod_parallel
3166 USE mod_coupling
3167 USE mod_grid
3168 USE mod_nesting
3169 USE mod_ocean
3170 USE mod_scalars
3171 USE mod_stepping
3172 USE mod_iounits
3173
3174# ifdef DISTRIBUTE
3175!
3176 USE distribute_mod, ONLY : mp_assemble
3177 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
3178# endif
3179 USE strings_mod, ONLY : founderror
3180!
3181! Imported variable declarations.
3182!
3183 logical, intent(in) :: lputfsur
3184 integer, intent(in) :: ng, dg, cr, model, tile
3185 integer, intent(in) :: lbi, ubi, lbj, ubj
3186!
3187! Local variable declarations.
3188!
3189 logical :: uboundary, vboundary
3190
3191# ifdef DISTRIBUTE
3192 integer :: ilb, iub, jlb, jub, nptssn, nptswe, my_tile
3193# endif
3194 integer :: nsub, i, irec, j, m, tnew, told, ii
3195 integer :: idg, jdg
3196
3197# ifdef DISTRIBUTE
3198 real(r8), parameter :: spv = 0.0_r8
3199# endif
3200 real(dp) :: wnew, wold, secscale, fac
3201 real(r8) :: cff, cff1, my_value
3202 real(r8) :: ad_cff, adfac, adfac1, adfac2, ad_my_value
3203!
3204 character (len=*), parameter :: myfile = &
3205 & __FILE__//", ad_put_refine2d"
3206
3207# include "set_bounds.h"
3208!
3209!-----------------------------------------------------------------------
3210! Interpolate (space, time) refinement grid contact points for 2D state
3211! variables from donor grid.
3212!-----------------------------------------------------------------------
3213!
3214! Clear adjoint constants.
3215!
3216 ad_cff=0.0_r8
3217 adfac=0.0_r8
3218 adfac1=0.0_r8
3219 adfac2=0.0_r8
3220 ad_my_value=0.0_r8
3221
3222# ifdef DISTRIBUTE
3223!
3224! Set global size of boundary edges.
3225!
3226 IF (.not.lputfsur) THEN
3227 my_tile=-1
3228 ilb=bounds(ng)%LBi(my_tile)
3229 iub=bounds(ng)%UBi(my_tile)
3230 jlb=bounds(ng)%LBj(my_tile)
3231 jub=bounds(ng)%UBj(my_tile)
3232 nptswe=jub-jlb+1
3233 nptssn=iub-ilb+1
3234
3235# ifdef NESTING_DEBUG
3236!
3237! If distributed-memory, initialize arrays used to check mass flux
3238! conservation with special value (zero) to facilitate the global
3239! reduction when collecting data between all nodes.
3240!
3241 bry_contact(iwest ,cr)%Mflux=spv
3242 bry_contact(ieast ,cr)%Mflux=spv
3243 bry_contact(isouth,cr)%Mflux=spv
3244 bry_contact(inorth,cr)%Mflux=spv
3245# endif
3246 END IF
3247# endif
3248!
3249! Set time snapshot indices for the donor grid data.
3250!
3251 told=3-rollingindex(cr)
3252 tnew=rollingindex(cr)
3253!
3254! Set linear time interpolation weights. Fractional seconds are
3255! rounded to the nearest milliseconds integer towards zero in the
3256! time interpolation weights.
3257!
3258 secscale=1000.0_dp ! seconds to milliseconds
3259!
3260 wold=anint((rollingtime(tnew,cr)-time(ng))*secscale,dp)
3261 wnew=anint((time(ng)-rollingtime(told,cr))*secscale,dp)
3262 fac=1.0_dp/(wold+wnew)
3263 wold=fac*wold
3264 wnew=fac*wnew
3265!
3266! IF (((Wold*Wnew).lt.0.0_dp).or.((Wold+Wnew).le.0.0_dp)) THEN
3267 IF (domain(ng)%SouthWest_Test(tile)) THEN
3268 IF (master) THEN
3269 WRITE (stdout,10) cr, dg, ng, &
3270 & iic(dg), told, tnew, &
3271 & iic(ng), wold, wnew, &
3272 & int(time(ng)), &
3273 & int(rollingtime(told,cr)), &
3274 & int(rollingtime(tnew,cr))
3275 END IF
3276! exit_flag=8
3277 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3278 END IF
3279! END IF
3280
3281# ifdef DISTRIBUTE
3282!
3283!-----------------------------------------------------------------------
3284! Exchange tile information.
3285!-----------------------------------------------------------------------
3286!
3287! Free-surface.
3288!
3289 IF (lputfsur) THEN
3290!^ CALL mp_exchange2d (ng, tile, model, &
3291# ifdef SOLVE3D
3292!^ & 4, &
3293# else
3294!^ & 3, &
3295# endif
3296!^ & LBi, UBi, LBj, UBj, &
3297!^ & NghostPoints, &
3298!^ & EWperiodic(ng), NSperiodic(ng), &
3299# ifdef SOLVE3D
3300!^ & COUPLING(ng)%tl_Zt_avg1, &
3301# endif
3302!^ & OCEAN(ng)%tl_zeta(:,:,1), &
3303!^ & OCEAN(ng)%tl_zeta(:,:,2), &
3304!^ & OCEAN(ng)%tl_zeta(:,:,3))
3305!^
3306 CALL ad_mp_exchange2d (ng, tile, model, &
3307# ifdef SOLVE3D
3308 & 4, &
3309# else
3310 & 3, &
3311# endif
3312 & lbi, ubi, lbj, ubj, &
3313 & nghostpoints, &
3314 & ewperiodic(ng), nsperiodic(ng), &
3315# ifdef SOLVE3D
3316 & coupling(ng)%ad_Zt_avg1, &
3317# endif
3318 & ocean(ng)%ad_zeta(:,:,1), &
3319 & ocean(ng)%ad_zeta(:,:,2), &
3320 & ocean(ng)%ad_zeta(:,:,3))
3321!
3322! 2D momentum.
3323!
3324 ELSE
3325
3326# ifdef NESTING_DEBUG
3327!
3328! No action required for the adjoint of mp_assemble (AMM).
3329!
3330!^ CALL mp_assemble (ng, model, NptsSN, spv, &
3331!^ & BRY_CONTACT(inorth,cr)%tl_Mflux(ILB:))
3332!^
3333!! CALL ad_mp_assemble (ng, model, NptsSN, spv, &
3334!! & BRY_CONTACT(inorth,cr)%ad_Mflux(ILB:))
3335!^ CALL mp_assemble (ng, model, NptsSN, spv, &
3336!^ & BRY_CONTACT(isouth,cr)%tl_Mflux(ILB:))
3337!^
3338!! CALL ad_mp_assemble (ng, model, NptsSN, spv, &
3339!! & BRY_CONTACT(isouth,cr)%ad_Mflux(ILB:))
3340!^ CALL mp_assemble (ng, model, NptsWE, spv, &
3341!^ & BRY_CONTACT(ieast ,cr)%tl_Mflux(JLB:))
3342!! CALL ad_mp_assemble (ng, model, NptsWE, spv, &
3343!! & BRY_CONTACT(ieast ,cr)%ad_Mflux(JLB:))
3344!^ CALL mp_assemble (ng, model, NptsWE, spv, &
3345!^ & BRY_CONTACT(iwest ,cr)%tl_Mflux(JLB:))
3346!^
3347!! CALL ad_mp_assemble (ng, model, NptsWE, spv, &
3348!! & BRY_CONTACT(iwest ,cr)%ad_Mflux(JLB:))
3349# endif
3350
3351!^ CALL mp_exchange2d (ng, tile, model, 3, &
3352!^ & LBi, UBi, LBj, UBj, &
3353!^ & NghostPoints, &
3354!^ & EWperiodic(ng), NSperiodic(ng), &
3355!^ & OCEAN(ng)%tl_vbar(:,:,1), &
3356!^ & OCEAN(ng)%tl_vbar(:,:,2), &
3357!^ & OCEAN(ng)%tl_vbar(:,:,3))
3358!^
3359 CALL ad_mp_exchange2d (ng, tile, model, 3, &
3360 & lbi, ubi, lbj, ubj, &
3361 & nghostpoints, &
3362 & ewperiodic(ng), nsperiodic(ng), &
3363 & ocean(ng)%ad_vbar(:,:,1), &
3364 & ocean(ng)%ad_vbar(:,:,2), &
3365 & ocean(ng)%ad_vbar(:,:,3))
3366
3367!^ CALL mp_exchange2d (ng, tile, model, 3, &
3368!^ & LBi, UBi, LBj, UBj, &
3369!^ & NghostPoints, &
3370!^ & EWperiodic(ng), NSperiodic(ng), &
3371!^ & OCEAN(ng)%tl_ubar(:,:,1), &
3372!^ & OCEAN(ng)%tl_ubar(:,:,2), &
3373!^ & OCEAN(ng)%tl_ubar(:,:,3))
3374!^
3375 CALL ad_mp_exchange2d (ng, tile, model, 3, &
3376 & lbi, ubi, lbj, ubj, &
3377 & nghostpoints, &
3378 & ewperiodic(ng), nsperiodic(ng), &
3379 & ocean(ng)%ad_ubar(:,:,1), &
3380 & ocean(ng)%ad_ubar(:,:,2), &
3381 & ocean(ng)%ad_ubar(:,:,3))
3382
3383 END IF
3384# endif
3385
3386 free_surface : IF (lputfsur) THEN
3387 DO m=1,rcontact(cr)%Npoints
3388 i=rcontact(cr)%Irg(m)
3389 j=rcontact(cr)%Jrg(m)
3390 IF (((istrt.le.i).and.(i.le.iendt)).and. &
3391 & ((jstrt.le.j).and.(j.le.jendt))) THEN
3392# ifdef SOLVE3D
3393!^ COUPLING(ng)%tl_Zt_avg1(i,j)=tl_my_value
3394!^
3395 ad_my_value=ad_my_value+ &
3396 & coupling(ng)%ad_Zt_avg1(i,j)
3397 coupling(ng)%ad_Zt_avg1(i,j)=0.0_r8
3398# endif
3399!^ OCEAN(ng)%tl_zeta(i,j,1)=tl_my_value
3400!^
3401 ad_my_value=ad_my_value+ &
3402 & ocean(ng)%ad_zeta(i,j,1)
3403 ocean(ng)%ad_zeta(i,j,1)=0.0_r8
3404!^ OCEAN(ng)%tl_zeta(i,j,2)=tl_my_value
3405!^
3406 ad_my_value=ad_my_value+ &
3407 & ocean(ng)%ad_zeta(i,j,2)
3408 ocean(ng)%ad_zeta(i,j,2)=0.0_r8
3409!^ OCEAN(ng)%tl_zeta(i,j,3)=tl_my_value
3410!^
3411 ad_my_value=ad_my_value+ &
3412 & ocean(ng)%ad_zeta(i,j,3)
3413 ocean(ng)%ad_zeta(i,j,3)=0.0_r8
3414# ifdef WET_DRY
3415 IF (my_value.le.(dcrit(ng)-grid(ng)%h(i,j))) THEN
3416!^ tl_my_value=-GRID(ng)%tl_h(i,j)
3417!^
3418 grid(ng)%ad_h(i,j)=grid(ng)%ad_h(i,j)-ad_my_value
3419 ad_my_value=0.0_r8
3420 END IF
3421# endif
3422# ifdef MASKING
3423!^ tl_my_value=tl_my_value*GRID(ng)%rmask(i,j)
3424!^
3425 ad_my_value=ad_my_value*grid(ng)%rmask(i,j)
3426# endif
3427!^ tl_my_value=Wold* &
3428!^ & (Rcontact(cr)%Lweight(1,m)* &
3429!^ & REFINED(cr)%tl_zeta(1,m,told)+ &
3430!^ & Rcontact(cr)%Lweight(2,m)* &
3431!^ & REFINED(cr)%tl_zeta(2,m,told)+ &
3432!^ & Rcontact(cr)%Lweight(3,m)* &
3433!^ & REFINED(cr)%tl_zeta(3,m,told)+ &
3434!^ & Rcontact(cr)%Lweight(4,m)* &
3435!^ & REFINED(cr)%tl_zeta(4,m,told))+ &
3436!^ & Wnew* &
3437!^ (Rcontact(cr)%Lweight(1,m)* &
3438!^ & REFINED(cr)%tl_zeta(1,m,tnew)+ &
3439!^ & Rcontact(cr)%Lweight(2,m)* &
3440!^ & REFINED(cr)%tl_zeta(2,m,tnew)+ &
3441!^ & Rcontact(cr)%Lweight(3,m)* &
3442!^ & REFINED(cr)%tl_zeta(3,m,tnew)+ &
3443!^ & Rcontact(cr)%Lweight(4,m)* &
3444!^ & REFINED(cr)%tl_zeta(4,m,tnew))
3445!^
3446 DO ii=1,4
3447 adfac1=wold*rcontact(cr)%Lweight(ii,m)*ad_my_value
3448 adfac2=wnew*rcontact(cr)%Lweight(ii,m)*ad_my_value
3449 refined(cr)%ad_zeta(ii,m,told)= &
3450 & refined(cr)%ad_zeta(ii,m,told)+adfac1
3451 refined(cr)%ad_zeta(ii,m,tnew)= &
3452 & refined(cr)%ad_zeta(ii,m,tnew)+adfac2
3453 END DO
3454 ad_my_value=0.0_r8
3455 END IF
3456 END DO
3457 ELSE
3458
3459# ifdef SOLVE3D
3460!
3461!-----------------------------------------------------------------------
3462! Impose mass flux at the finer grid physical boundaries. This is only
3463! done for indx1(ng) time record.
3464!
3465! Western/Eastern boundary:
3466!
3467! ubar(Ibry,:,indx1) = DU_avg2(Ibry,:) * pn(Ibry,:) / D(Ibry,:)
3468!
3469! Southern/Northern boundary:
3470!
3471! vbar(:,Jbry,indx1) = DV_avg2(:,Jbry) * pm(:,Jbry) / D(:,Jbry)
3472!
3473! We use the latest coarse grid mass flux REFINED(cr)%DU_avg(1,:,tnew)
3474! with a linear variation (cff1) to ensure that the sum of the refined
3475! grid fluxes equals the coarse grid flux.
3476!-----------------------------------------------------------------------
3477!
3478! Northern edge.
3479!
3480 IF (domain(ng)%Northern_Edge(tile)) THEN
3481 DO i=istr,iend
3482 m=bry_contact(inorth,cr)%C2Bindex(i)
3483 idg=vcontact(cr)%Idg(m) ! for debugging
3484 jdg=vcontact(cr)%Jdg(m) ! purposes
3485 cff=0.5_r8*grid(ng)%om_v(i,jend+1)* &
3486 & (grid(ng)%h(i,jend+1)+ &
3487 & ocean(ng)%zeta(i,jend+1,indx1(ng))+ &
3488 & grid(ng)%h(i,jend )+ &
3489 & ocean(ng)%zeta(i,jend ,indx1(ng)))
3490 cff1=grid(ng)%om_v(i,jend+1)/refined(cr)%om_v(m)
3491# ifdef TIME_INTERP_FLUX
3492 my_value=cff1*(wold*refined(cr)%DV_avg2(1,m,told)+ &
3493 & wnew*refined(cr)%DV_avg2(1,m,tnew))/cff
3494# else
3495 my_value=cff1*refined(cr)%DV_avg2(1,m,tnew)/cff
3496# endif
3497# ifdef MASKING
3498 my_value=my_value*grid(ng)%vmask(i,jend+1)
3499# endif
3500# ifdef WET_DRY
3501 my_value=my_value*grid(ng)%vmask_wet(i,jend+1)
3502# endif
3503!^ OCEAN(ng)%tl_vbar(i,Jend+1,indx1(ng))=tl_my_value
3504!^
3505 ad_my_value=ad_my_value+ &
3506 & ocean(ng)%ad_vbar(i,jend+1,indx1(ng))
3507 ocean(ng)%ad_vbar(i,jend+1,indx1(ng))=0.0_r8
3508# ifdef NESTING_DEBUG
3509!^ BRY_CONTACT(inorth,cr)%tl_Mflux(i)=tl_cff*my_value+ &
3510!^ & cff*tl_my_value
3511!^
3512 ad_cff=ad_cff+ &
3513 & my_value*bry_contact(inorth,cr)%ad_Mflux(i)
3514 ad_my_value=ad_my_value+ &
3515 & cff*bry_contact(inorth,cr)%ad_Mflux(i)
3516 bry_contact(inorth,cr)%ad_Mflux(i)=0.0_r8
3517# endif
3518# ifdef WET_DRY
3519!^ tl_my_value=tl_my_value*GRID(ng)%vmask_wet(i,Jend+1)
3520!^
3521 ad_my_value=ad_my_value*grid(ng)%vmask_wet(i,jend+1)
3522# endif
3523# ifdef MASKING
3524!^ tl_my_value=tl_my_value*GRID(ng)%vmask(i,Jend+1)
3525!^
3526 ad_my_value=ad_my_value*grid(ng)%vmask(i,jend+1)
3527# endif
3528# ifdef TIME_INTERP_FLUX
3529 my_value=cff1*(wold*refined(cr)%DV_avg2(1,m,told)+ &
3530 & wnew*refined(cr)%DV_avg2(1,m,tnew))/cff
3531!^ tl_my_value=cff1* &
3532!^ & (Wold*REFINED(cr)%tl_DV_avg2(1,m,told)+ &
3533!^ & Wnew*REFINED(cr)%tl_DV_avg2(1,m,tnew))/cff- &
3534!^ & tl_cff*my_value/cff
3535!^
3536 adfac=ad_my_value/cff
3537 adfac1=cff1*adfac
3538 refined(cr)%ad_DV_avg2(1,m,told)= &
3539 & refined(cr)%ad_DV_avg2(1,m,told)+wold*adfac1
3540 refined(cr)%ad_DV_avg2(1,m,tnew)= &
3541 & refined(cr)%ad_DV_avg2(1,m,tnew)+wnew*adfac1
3542 ad_cff=ad_cff- &
3543 & my_value*adfac
3544 ad_my_value=0.0_r8
3545# else
3546 my_value=cff1*refined(cr)%DV_avg2(1,m,tnew)/cff
3547!^ tl_my_value=cff1*REFINED(cr)%tl_DV_avg2(1,m,tnew)/cff- &
3548!^ & tl_cff*my_value/cff
3549!^
3550 adfac=ad_my_value/cff
3551 refined(cr)%ad_DV_avg2(1,m,tnew)= &
3552 & refined(cr)%ad_DV_avg2(1,m,tnew)+cff1*adfac
3553 ad_cff=ad_cff- &
3554 & my_value*adfac
3555 ad_my_value=0.0_r8
3556# endif
3557!^ tl_cff=0.5_r8*GRID(ng)%om_v(i,Jend+1)* &
3558!^ & (GRID(ng)%tl_h(i,Jend+1)+ &
3559!^ & OCEAN(ng)%tl_zeta(i,Jend+1,indx1(ng))+ &
3560!^ & GRID(ng)%tl_h(i,Jend )+ &
3561!^ & OCEAN(ng)%tl_zeta(i,Jend ,indx1(ng)))
3562!^
3563 adfac=0.5_r8*grid(ng)%om_v(i,jend+1)*ad_cff
3564 grid(ng)%ad_h(i,jend )=grid(ng)%ad_h(i,jend )+adfac
3565 grid(ng)%ad_h(i,jend+1)=grid(ng)%ad_h(i,jend+1)+adfac
3566 ocean(ng)%ad_zeta(i,jend ,indx1(ng))= &
3567 & ocean(ng)%ad_zeta(i,jend ,indx1(ng))+adfac
3568 ocean(ng)%ad_zeta(i,jend+1,indx1(ng))= &
3569 & ocean(ng)%ad_zeta(i,jend+1,indx1(ng))+adfac
3570 ad_cff=0.0_r8
3571 END DO
3572 END IF
3573!
3574! Southern edge.
3575!
3576 IF (domain(ng)%Southern_Edge(tile)) THEN
3577 DO i=istr,iend
3578 m=bry_contact(isouth,cr)%C2Bindex(i)
3579 idg=vcontact(cr)%Idg(m) ! for debugging
3580 jdg=vcontact(cr)%Jdg(m) ! purposes
3581 cff=0.5_r8*grid(ng)%om_v(i,jstr)* &
3582 & (grid(ng)%h(i,jstr-1)+ &
3583 & ocean(ng)%zeta(i,jstr-1,indx1(ng))+ &
3584 & grid(ng)%h(i,jstr )+ &
3585 & ocean(ng)%zeta(i,jstr ,indx1(ng)))
3586# ifdef TIME_INTERP_FLUX
3587 my_value=cff1*(wold*refined(cr)%DV_avg2(1,m,told)+ &
3588 & wnew*refined(cr)%DV_avg2(1,m,tnew))/cff
3589# else
3590 my_value=cff1*refined(cr)%DV_avg2(1,m,tnew)/cff
3591# endif
3592# ifdef MASKING
3593 my_value=my_value*grid(ng)%vmask(i,jstr)
3594# endif
3595# ifdef WET_DRY
3596 my_value=my_value*grid(ng)%vmask_wet(i,jstr)
3597# endif
3598!^ OCEAN(ng)%tl_vbar(i,Jstr,indx1(ng))=tl_my_value
3599!^
3600 ad_my_value=ad_my_value+ &
3601 & ocean(ng)%ad_vbar(i,jstr,indx1(ng))
3602 ocean(ng)%ad_vbar(i,jstr,indx1(ng))=0.0_r8
3603# ifdef NESTING_DEBUG
3604!^ BRY_CONTACT(isouth,cr)%tl_Mflux(i)=tl_cff*my_value+ &
3605!^ & cff*tl_my_value
3606!^
3607 ad_my_value=ad_my_value+ &
3608 & cff*bry_contact(isouth,cr)%ad_Mflux(i)
3609 ad_cff=ad_cff+ &
3610 & my_value*bry_contact(isouth,cr)%ad_Mflux(i)
3611 bry_contact(isouth,cr)%ad_Mflux(i)=0.0_r8
3612# endif
3613# ifdef WET_DRY
3614!^ tl_my_value=tl_my_value*GRID(ng)%vmask_wet(i,Jstr)
3615!^
3616 ad_my_value=ad_my_value*grid(ng)%vmask_wet(i,jstr)
3617# endif
3618# ifdef MASKING
3619!^ tl_my_value=tl_my_value*GRID(ng)%vmask(i,Jstr)
3620!^
3621 ad_my_value=ad_my_value*grid(ng)%vmask(i,jstr)
3622# endif
3623# ifdef TIME_INTERP_FLUX
3624 my_value=cff1*(wold*refined(cr)%DV_avg2(1,m,told)+ &
3625 & wnew*refined(cr)%DV_avg2(1,m,tnew))/cff
3626!^ tl_my_value=cff1* &
3627!^ & (Wold*REFINED(cr)%tl_DV_avg2(1,m,told)+ &
3628!^ & Wnew*REFINED(cr)%tl_DV_avg2(1,m,tnew))/cff- &
3629!^ & tl_cff*my_value/cff
3630!^
3631 adfac=ad_my_value/cff
3632 adfac1=cff1*adfac
3633 refined(cr)%ad_DV_avg2(1,m,told)= &
3634 & refined(cr)%ad_DV_avg2(1,m,told)+wold*adfac1
3635 refined(cr)%tl_DV_avg2(1,m,tnew)= &
3636 & refined(cr)%ad_DV_avg2(1,m,tnew)+wnew*adfac1
3637 ad_cff=ad_cff- &
3638 & my_value*adfac
3639 ad_my_value=0.0_r8
3640# else
3641 my_value=cff1*refined(cr)%DV_avg2(1,m,tnew)/cff
3642!^ tl_my_value=cff1*REFINED(cr)%tl_DV_avg2(1,m,tnew)/cff- &
3643!^ & tl_cff*my_value/cff
3644!^
3645 adfac=ad_my_value/cff
3646 refined(cr)%ad_DV_avg2(1,m,tnew)= &
3647 & refined(cr)%ad_DV_avg2(1,m,tnew)+cff1*adfac
3648 ad_cff=ad_cff- &
3649 & my_value*adfac
3650 ad_my_value=0.0_r8
3651# endif
3652!^ tl_cff=0.5_r8*GRID(ng)%om_v(i,Jstr)* &
3653!^ & (GRID(ng)%tl_h(i,Jstr-1)+ &
3654!^ & OCEAN(ng)%tl_zeta(i,Jstr-1,indx1(ng))+ &
3655!^ & GRID(ng)%tl_h(i,Jstr )+ &
3656!^ & OCEAN(ng)%tl_zeta(i,Jstr ,indx1(ng)))
3657!^
3658 adfac=0.5_r8*grid(ng)%om_v(i,jstr)*ad_cff
3659 grid(ng)%ad_h(i,jstr-1)=grid(ng)%ad_h(i,jstr-1)+adfac
3660 grid(ng)%ad_h(i,jstr )=grid(ng)%ad_h(i,jstr )+adfac
3661 ocean(ng)%ad_zeta(i,jstr-1,indx1(ng))= &
3662 & ocean(ng)%ad_zeta(i,jstr-1,indx1(ng))+adfac
3663 ocean(ng)%ad_zeta(i,jstr ,indx1(ng))= &
3664 & ocean(ng)%ad_zeta(i,jstr ,indx1(ng))+adfac
3665 ad_cff=0.0_r8
3666 END DO
3667 END IF
3668!
3669! Eastern edge.
3670!
3671 IF (domain(ng)%Eastern_Edge(tile)) THEN
3672 DO j=jstr,jend
3673 m=bry_contact(ieast,cr)%C2Bindex(j)
3674 idg=ucontact(cr)%Idg(m) ! for debugging
3675 jdg=ucontact(cr)%Jdg(m) ! purposes
3676 cff=0.5_r8*grid(ng)%on_u(iend+1,j)* &
3677 & (grid(ng)%h(iend+1,j)+ &
3678 & ocean(ng)%zeta(iend+1,j,indx1(ng))+ &
3679 & grid(ng)%h(iend ,j)+ &
3680 & ocean(ng)%zeta(iend ,j,indx1(ng)))
3681 cff1=grid(ng)%on_u(iend+1,j)/refined(cr)%on_u(m)
3682# ifdef TIME_INTERP_FLUX
3683 my_value=cff1*(wold*refined(cr)%DU_avg2(1,m,told)+ &
3684 & wnew*refined(cr)%DU_avg2(1,m,tnew))/cff
3685# else
3686 my_value=cff1*refined(cr)%DU_avg2(1,m,tnew)/cff
3687# endif
3688# ifdef MASKING
3689 my_value=my_value*grid(ng)%umask(iend+1,j)
3690# endif
3691# ifdef WET_DRY
3692 my_value=my_value*grid(ng)%umask_wet(iend+1,j)
3693# endif
3694!^ OCEAN(ng)%tl_ubar(Iend+1,j,indx1(ng))=tl_my_value
3695!^
3696 ad_my_value=ad_my_value+ &
3697 & ocean(ng)%ad_ubar(iend+1,j,indx1(ng))
3698 ocean(ng)%ad_ubar(iend+1,j,indx1(ng))=0.0_r8
3699# ifdef NESTING_DEBUG
3700!^ BRY_CONTACT(ieast,cr)%tl_Mflux(j)=tl_cff*my_value+ &
3701!^ & cff*tl_my_value
3702!^
3703 ad_my_value=ad_my_value+ &
3704 & cff*bry_contact(ieast,cr)%ad_Mflux(j)
3705 ad_cff=ad_cff+ &
3706 & my_value*bry_contact(ieast,cr)%ad_Mflux(j)
3707 bry_contact(ieast,cr)%ad_Mflux(j)=0.0_r8
3708# endif
3709# ifdef WET_DRY
3710!^ tl_my_value=tl_my_value*GRID(ng)%umask_wet(Iend+1,j)
3711!^
3712 ad_my_value=ad_my_value*grid(ng)%umask_wet(iend+1,j)
3713# endif
3714# ifdef MASKING
3715!^ tl_my_value=tl_my_value*GRID(ng)%umask(Iend+1,j)
3716!^
3717 ad_my_value=ad_my_value*grid(ng)%umask(iend+1,j)
3718# endif
3719# ifdef TIME_INTERP_FLUX
3720 my_value=cff1*(wold*refined(cr)%DU_avg2(1,m,told)+ &
3721 & wnew*refined(cr)%DU_avg2(1,m,tnew))/cff
3722!^ tl_my_value=cff1* &
3723!^ & (Wold*REFINED(cr)%tl_DU_avg2(1,m,told)+ &
3724!^ & Wnew*REFINED(cr)%tl_DU_avg2(1,m,tnew))/cff- &
3725!^ & tl_cff*my_value/cff
3726!^
3727 adfac=ad_my_value/cff
3728 adfac1=cff1*adfac
3729 refined(cr)%ad_DU_avg2(1,m,told)= &
3730 & refined(cr)%ad_DU_avg2(1,m,told)+wold*adfac1
3731 refined(cr)%ad_DU_avg2(1,m,tnew)= &
3732 & refined(cr)%ad_DU_avg2(1,m,tnew)+wnew*adfac1
3733 ad_cff=ad_cff- &
3734 & my_value*adfac
3735 ad_my_value=0.0_r8
3736# else
3737 my_value=cff1*refined(cr)%DU_avg2(1,m,tnew)/cff
3738!^ tl_my_value=cff1*REFINED(cr)%tl_DU_avg2(1,m,tnew)/cff- &
3739!^ & tl_cff*my_value/cff
3740!^
3741 adfac=ad_my_value/cff
3742 refined(cr)%ad_DU_avg2(1,m,tnew)= &
3743 & refined(cr)%ad_DU_avg2(1,m,tnew)+cff1*adfac
3744 ad_cff=ad_cff- &
3745 & my_value*adfac
3746 ad_my_value=0.0_r8
3747# endif
3748!^ tl_cff=0.5_r8*GRID(ng)%on_u(Iend+1,j)* &
3749!^ & (GRID(ng)%tl_h(Iend+1,j)+ &
3750!^ & OCEAN(ng)%tl_zeta(Iend+1,j,indx1(ng))+ &
3751!^ & GRID(ng)%tl_h(Iend ,j)+ &
3752!^ & OCEAN(ng)%tl_zeta(Iend ,j,indx1(ng)))
3753!^
3754 adfac=0.5_r8*grid(ng)%on_u(iend+1,j)*ad_cff
3755 grid(ng)%ad_h(iend ,j)=grid(ng)%ad_h(iend ,j)+adfac
3756 grid(ng)%ad_h(iend+1,j)=grid(ng)%ad_h(iend+1,j)+adfac
3757 ocean(ng)%ad_zeta(iend ,j,indx1(ng))= &
3758 & ocean(ng)%ad_zeta(iend ,j,indx1(ng))+adfac
3759 ocean(ng)%ad_zeta(iend+1,j,indx1(ng))= &
3760 & ocean(ng)%ad_zeta(iend+1,j,indx1(ng))+adfac
3761 ad_cff=0.0_r8
3762 END DO
3763 END IF
3764!
3765! Western edge.
3766!
3767 IF (domain(ng)%Western_Edge(tile)) THEN
3768 DO j=jstr,jend
3769 m=bry_contact(iwest,cr)%C2Bindex(j)
3770 idg=ucontact(cr)%Idg(m) ! for debugging
3771 jdg=ucontact(cr)%Jdg(m) ! purposes
3772 cff=0.5_r8*grid(ng)%on_u(istr,j)* &
3773 (grid(ng)%h(istr-1,j)+ &
3774 & ocean(ng)%zeta(istr-1,j,indx1(ng))+ &
3775 & grid(ng)%h(istr ,j)+ &
3776 & ocean(ng)%zeta(istr ,j,indx1(ng)))
3777 cff1=grid(ng)%on_u(istr,j)/refined(cr)%on_u(m)
3778# ifdef TIME_INTERP_FLUX
3779 my_value=cff1*(wold*refined(cr)%DU_avg2(1,m,told)+ &
3780 & wnew*refined(cr)%DU_avg2(1,m,tnew))/cff
3781# else
3782 my_value=cff1*refined(cr)%DU_avg2(1,m,tnew)/cff
3783# endif
3784# ifdef MASKING
3785 my_value=my_value*grid(ng)%umask(istr,j)
3786# endif
3787# ifdef WET_DRY
3788 my_value=my_value*grid(ng)%umask_wet(istr,j)
3789# endif
3790!^ OCEAN(ng)%tl_ubar(Istr,j,indx1(ng))=tl_my_value
3791!^
3792 ad_my_value=ad_my_value+ &
3793 & ocean(ng)%ad_ubar(istr,j,indx1(ng))
3794 ocean(ng)%ad_ubar(istr,j,indx1(ng))=0.0_r8
3795# ifdef NESTING_DEBUG
3796!^ BRY_CONTACT(iwest,cr)%tl_Mflux(j)=cff*tl_my_value+ &
3797!^ & tl_cff*my_value
3798!^
3799 ad_my_value=ad_my_value+ &
3800 & cff*bry_contact(iwest,cr)%ad_Mflux(j)
3801 ad_cff=ad_cff+ &
3802 & my_value*bry_contact(iwest,cr)%ad_Mflux(j)
3803 bry_contact(iwest,cr)%ad_Mflux(j)=0.0_r8
3804# endif
3805# ifdef WET_DRY
3806!^ tl_my_value=tl_my_value*GRID(ng)%umask_wet(Istr,j)
3807!^
3808 ad_my_value=ad_my_value*grid(ng)%umask_wet(istr,j)
3809# endif
3810# ifdef MASKING
3811!^ tl_my_value=tl_my_value*GRID(ng)%umask(Istr,j)
3812!^
3813 ad_my_value=ad_my_value*grid(ng)%umask(istr,j)
3814# endif
3815# ifdef TIME_INTERP_FLUX
3816 my_value=cff1*(wold*refined(cr)%DU_avg2(1,m,told)+ &
3817 & wnew*refined(cr)%DU_avg2(1,m,tnew))/cff
3818!^ tl_my_value=cff1* &
3819!^ & (Wold*REFINED(cr)%tl_DU_avg2(1,m,told)+ &
3820!^ & Wnew*REFINED(cr)%tl_DU_avg2(1,m,tnew))/cff- &
3821!^ & tl_cff*my_value/cff
3822!^
3823 adfac=ad_my_value/cff
3824 adfac1=cff1*adfac
3825 refined(cr)%ad_DU_avg2(1,m,told)= &
3826 & refined(cr)%ad_DU_avg2(1,m,told)+wold*adfac1
3827 refined(cr)%ad_DU_avg2(1,m,tnew)= &
3828 & refined(cr)%ad_DU_avg2(1,m,tnew)+wnew*adfac1
3829 ad_cff=ad_cff-my_value*adfac
3830 ad_my_value=0.0_r8
3831# else
3832 my_value=cff1*refined(cr)%DU_avg2(1,m,tnew)/cff
3833!^ tl_my_value=cff1*REFINED(cr)%tl_DU_avg2(1,m,tnew)/cff- &
3834!^ & tl_cff*my_value/cff
3835!^
3836 adfac=ad_my_value/cff
3837 refined(cr)%ad_DU_avg2(1,m,tnew)= &
3838 & refined(cr)%ad_DU_avg2(1,m,tnew)+cff1*adfac
3839 ad_cff=ad_cff- &
3840 & my_value*adfac
3841 ad_my_value=0.0_r8
3842# endif
3843!^ tl_cff=0.5_r8*GRID(ng)%on_u(Istr,j)* &
3844!^ & (GRID(ng)%tl_h(Istr-1,j)+ &
3845!^ & OCEAN(ng)%tl_zeta(Istr-1,j,indx1(ng))+ &
3846!^ & GRID(ng)%tl_h(Istr ,j)+ &
3847!^ & OCEAN(ng)%tl_zeta(Istr ,j,indx1(ng)))
3848!^
3849 adfac=0.5_r8*grid(ng)%on_u(istr,j)*ad_cff
3850 grid(ng)%ad_h(istr-1,j)=grid(ng)%ad_h(istr-1,j)+adfac
3851 grid(ng)%ad_h(istr ,j)=grid(ng)%ad_h(istr ,j)+adfac
3852 ocean(ng)%ad_zeta(istr-1,j,indx1(ng))= &
3853 & ocean(ng)%ad_zeta(istr-1,j,indx1(ng))+adfac
3854 ocean(ng)%ad_zeta(istr ,j,indx1(ng))= &
3855 & ocean(ng)%ad_zeta(istr ,j,indx1(ng))+adfac
3856 ad_cff=0.0_r8
3857 END DO
3858 END IF
3859# endif
3860!
3861! 2D momentum in the ETA-direction.
3862# ifdef SOLVE3D
3863!
3864! Notice that contact points at the domain southern and northern
3865! boundaries are avoided for indx1(ng) time record. They are be
3866! assigned in the mass flux computations below. This exception is
3867! done for adjoint correctness.
3868# endif
3869!
3870 DO m=1,vcontact(cr)%Npoints
3871 i=vcontact(cr)%Irg(m)
3872 j=vcontact(cr)%Jrg(m)
3873 IF (((istrt.le.i).and.(i.le.iendt)).and. &
3874 & ((jstrp.le.j).and.(j.le.jendt))) THEN
3875 DO irec=1,3
3876# ifdef SOLVE3D
3877 vboundary=(m.eq.bry_contact(isouth,cr)%C2Bindex(i)).or. &
3878 & (m.eq.bry_contact(inorth,cr)%C2Bindex(i))
3879 IF(.not.(vboundary.and.(irec.eq.indx1(ng)))) THEN
3880!^ OCEAN(ng)%tl_vbar(i,j,irec)=tl_my_value
3881!^
3882 ad_my_value=ad_my_value+ &
3883 & ocean(ng)%ad_vbar(i,j,irec)
3884 ocean(ng)%ad_vbar(i,j,irec)=0.0_r8
3885!! ELSE ! for debugging
3886!! OCEAN(ng)%vbar(i,j,irec)=0.0_r8 ! purposes
3887 END IF
3888# else
3889!^ OCEAN(ng)%tl_vbar(i,j,irec)=tl_my_value
3890!^
3891 ad_my_value=ad_my_value+ &
3892 & ocean(ng)%ad_vbar(i,j,irec)
3893 ocean(ng)%ad_vbar(i,j,irec)=0.0_r8
3894# endif
3895 END DO
3896# ifdef WET_DRY
3897!^ tl_my_value=tl_my_value*GRID(ng)%vmask_wet(i,j)
3898!^
3899 ad_my_value=ad_my_value*grid(ng)%vmask_wet(i,j)
3900# endif
3901# ifdef MASKING
3902!^ tl_my_value=tl_my_value*GRID(ng)%vmask(i,j)
3903!^
3904 ad_my_value=ad_my_value*grid(ng)%vmask(i,j)
3905# endif
3906!^ tl_my_value=Wold* &
3907!^ & (Vcontact(cr)%Lweight(1,m)* &
3908!^ & REFINED(cr)%tl_vbar(1,m,told)+ &
3909!^ & Vcontact(cr)%Lweight(2,m)* &
3910!^ & REFINED(cr)%tl_vbar(2,m,told)+ &
3911!^ & Vcontact(cr)%Lweight(3,m)* &
3912!^ & REFINED(cr)%tl_vbar(3,m,told)+ &
3913!^ & Vcontact(cr)%Lweight(4,m)* &
3914!^ & REFINED(cr)%tl_vbar(4,m,told))+ &
3915!^ & Wnew* &
3916!^ & (Vcontact(cr)%Lweight(1,m)* &
3917!^ & REFINED(cr)%tl_vbar(1,m,tnew)+ &
3918!^ & Vcontact(cr)%Lweight(2,m)* &
3919!^ & REFINED(cr)%tl_vbar(2,m,tnew)+ &
3920!^ & Vcontact(cr)%Lweight(3,m)* &
3921!^ & REFINED(cr)%tl_vbar(3,m,tnew)+ &
3922!^ & Vcontact(cr)%Lweight(4,m)* &
3923!^ & REFINED(cr)%tl_vbar(4,m,tnew))
3924!^
3925 DO ii=1,4
3926 adfac1=wold*vcontact(cr)%Lweight(ii,m)*ad_my_value
3927 adfac2=wnew*vcontact(cr)%Lweight(ii,m)*ad_my_value
3928 refined(cr)%ad_vbar(ii,m,told)= &
3929 & refined(cr)%ad_vbar(ii,m,told)+adfac1
3930 refined(cr)%ad_vbar(ii,m,tnew)= &
3931 & refined(cr)%ad_vbar(ii,m,tnew)+adfac2
3932 END DO
3933 ad_my_value=0.0_r8
3934 END IF
3935 END DO
3936!
3937! 2D momentum in the XI-direction.
3938# ifdef SOLVE3D
3939!
3940! Notice that contact points at the domain western and eastern
3941! boundaries are avoided for indx1(ng) time record. They are be
3942! assigned in the mass flux computations below. This exception is
3943! done for adjoint correctness.
3944# endif
3945!
3946 DO m=1,ucontact(cr)%Npoints
3947 i=ucontact(cr)%Irg(m)
3948 j=ucontact(cr)%Jrg(m)
3949 IF (((istrp.le.i).and.(i.le.iendt)).and. &
3950 & ((jstrt.le.j).and.(j.le.jendt))) THEN
3951 DO irec=1,3
3952# ifdef SOLVE3D
3953 uboundary=(m.eq.bry_contact(iwest,cr)%C2Bindex(j)).or. &
3954 & (m.eq.bry_contact(ieast,cr)%C2Bindex(j))
3955 IF(.not.(uboundary.and.(irec.eq.indx1(ng)))) THEN
3956!^ OCEAN(ng)%tl_ubar(i,j,irec)=tl_my_value
3957!^
3958 ad_my_value=ad_my_value+ &
3959 & ocean(ng)%ad_ubar(i,j,irec)
3960 ocean(ng)%ad_ubar(i,j,irec)=0.0_r8
3961!! ELSE ! for debugging
3962!! OCEAN(ng)%ubar(i,j,irec)=0.0_r8 ! purposes
3963 END IF
3964# else
3965!^ OCEAN(ng)%tl_ubar(i,j,irec)=tl_my_value
3966!^
3967 ad_my_value=ad_my_value+ &
3968 & ocean(ng)%ad_ubar(i,j,irec)
3969 ocean(ng)%ad_ubar(i,j,irec)=0.0_r8
3970# endif
3971 END DO
3972# ifdef WET_DRY
3973!^ tl_my_value=tl_my_value*GRID(ng)%umask_wet(i,j)
3974!^
3975 ad_my_value=ad_my_value*grid(ng)%umask_wet(i,j)
3976# endif
3977# ifdef MASKING
3978!^ tl_my_value=tl_my_value*GRID(ng)%umask(i,j)
3979!^
3980 ad_my_value=ad_my_value*grid(ng)%umask(i,j)
3981# endif
3982!^ tl_my_value=Wold* &
3983!^ & (Ucontact(cr)%Lweight(1,m)* &
3984!^ & REFINED(cr)%tl_ubar(1,m,told)+ &
3985!^ & Ucontact(cr)%Lweight(2,m)* &
3986!^ & REFINED(cr)%tl_ubar(2,m,told)+ &
3987!^ & Ucontact(cr)%Lweight(3,m)* &
3988!^ & REFINED(cr)%tl_ubar(3,m,told)+ &
3989!^ & Ucontact(cr)%Lweight(4,m)* &
3990!^ & REFINED(cr)%tl_ubar(4,m,told)) &
3991!^ & Wnew* &
3992!^ & (Ucontact(cr)%Lweight(1,m)* &
3993!^ & REFINED(cr)%tl_ubar(1,m,tnew)+ &
3994!^ & Ucontact(cr)%Lweight(2,m)* &
3995!^ & REFINED(cr)%tl_ubar(2,m,tnew)+ &
3996!^ & Ucontact(cr)%Lweight(3,m)* &
3997!^ & REFINED(cr)%tl_ubar(3,m,tnew)+ &
3998!^ & Ucontact(cr)%Lweight(4,m)* &
3999!^ & REFINED(cr)%tl_ubar(4,m,tnew))
4000!^
4001 DO ii=1,4
4002 adfac1=wold*ucontact(cr)%Lweight(ii,m)*ad_my_value
4003 adfac2=wnew*ucontact(cr)%Lweight(ii,m)*ad_my_value
4004 refined(cr)%ad_ubar(ii,m,told)= &
4005 & refined(cr)%ad_ubar(ii,m,told)+adfac1
4006 refined(cr)%ad_ubar(ii,m,tnew)= &
4007 & refined(cr)%ad_ubar(ii,m,tnew)+adfac2
4008 END DO
4009 ad_my_value=0.0_r8
4010 END IF
4011 END DO
4012
4013 END IF free_surface
4014!
4015 10 FORMAT (/,'AD_PUT_REFINE2D - unbounded contact points temporal: ',&
4016 & ' interpolation:', &
4017 & /,2x, 'cr = ',i2.2, &
4018 & 8x,'dg = ',i2.2, &
4019 & 8x,'ng = ',i2.2, &
4020 & /,2x, 'iic(dg) = ',i7.7, &
4021 & 3x,'told = ',i1, &
4022 & 9x,'tnew = ',i1, &
4023 & /,2x, 'iic(ng) = ',i7.7, &
4024 & 3x,'Wold = ',f8.5, &
4025 & 2x,'Wnew = ',f8.5, &
4026 & /,2x, 'time(ng) = ',i10, &
4027 & 3x,'time(told) = ',i10, &
4028 & 3x,'time(tnew) = ',i10)
4029
4030 RETURN
4031 END SUBROUTINE ad_put_refine2d
4032
4033# ifdef SOLVE3D
4034!
4035 SUBROUTINE ad_put_refine3d (ng, dg, cr, model, tile, &
4036 & LBi, UBi, LBj, UBj)
4037!
4038!=======================================================================
4039! !
4040! This routine interpolates (space, time) refinement grid 3D state !
4041! variables contact points using data from the donor grid. !
4042! !
4043! On Input: !
4044! !
4045! ng Refinement (receiver) grid number (integer) !
4046! dg Donor grid number (integer) !
4047! cr Contact region number to process (integer) !
4048! model Calling model identifier (integer) !
4049! tile Domain tile partition (integer) !
4050! LBi Receiver grid, I-dimension Lower bound (integer) !
4051! UBi Receiver grid, I-dimension Upper bound (integer) !
4052! LBj Receiver grid, J-dimension Lower bound (integer) !
4053! UBj Receiver grid, J-dimension Upper bound (integer) !
4054! !
4055! On Output: OCEAN(ng) structure !
4056! !
4057! t Updated tracer-type variables !
4058! u Updated 3D momentum in the XI-direction !
4059! v Updated 3D momentum in the ETA-direction !
4060! !
4061!=======================================================================
4062!
4063 USE mod_param
4064 USE mod_parallel
4065 USE mod_grid
4066 USE mod_nesting
4067 USE mod_ocean
4068 USE mod_scalars
4069 USE mod_stepping
4070 USE mod_iounits
4071!
4072# ifdef DISTRIBUTE
4073 USE mp_exchange_mod, ONLY : ad_mp_exchange3d, ad_mp_exchange4d
4074# endif
4075 USE strings_mod, ONLY : founderror
4076!
4077! Imported variable declarations.
4078!
4079 integer, intent(in) :: ng, dg, cr, model, tile
4080 integer, intent(in) :: lbi, ubi, lbj, ubj
4081!
4082! Local variable declarations.
4083!
4084# ifdef NESTING_DEBUG
4085 logical, save :: first = .true.
4086# endif
4087 integer :: i, itrc, j, k, m, tnew, told, ii
4088
4089 real(dp) :: wnew, wold, secscale, fac
4090 real(r8) :: my_value, ad_my_value, adfac1, adfac2
4091!
4092 character (len=*), parameter :: myfile = &
4093 & __FILE__//", ad_put_refine3d"
4094
4095# include "set_bounds.h"
4096!
4097! Clear adjoint constants.
4098!
4099 ad_my_value=0.0_r8
4100 adfac1=0.0_r8
4101 adfac2=0.0_r8
4102!
4103!-----------------------------------------------------------------------
4104! Interpolate (space, time) refinement grid contact points for 2D state
4105! variables from donor grid.
4106!-----------------------------------------------------------------------
4107!
4108! Set time snapshot indices for the donor grid data.
4109!
4110 told=3-rollingindex(cr)
4111 tnew=rollingindex(cr)
4112!
4113! Set linear time interpolation weights. Fractional seconds are
4114! rounded to the nearest milliseconds integer towards zero in the
4115! time interpolation weights.
4116!
4117 secscale=1000.0_dp ! seconds to milliseconds
4118!
4119 wold=anint((rollingtime(tnew,cr)-time(ng))*secscale,dp)
4120 wnew=anint((time(ng)-rollingtime(told,cr))*secscale,dp)
4121 fac=1.0_dp/(wold+wnew)
4122 wold=fac*wold
4123 wnew=fac*wnew
4124!
4125! IF (((Wold*Wnew).lt.0.0_dp).or.((Wold+Wnew).le.0.0_dp)) THEN
4126 IF (domain(ng)%SouthWest_Test(tile)) THEN
4127 IF (master) THEN
4128 WRITE (stdout,10) cr, dg, ng, &
4129 & iic(dg), told, tnew, &
4130 & iic(ng), wold, wnew, &
4131 & int(time(ng)), &
4132 & int(rollingtime(told,cr)), &
4133 & int(rollingtime(tnew,cr))
4134 END IF
4135! exit_flag=8
4136 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4137 END IF
4138! END IF
4139
4140# ifdef NESTING_DEBUG
4141!
4142! If debugging, write information into Fortran unit 202 to check the
4143! logic of interpolating from donor grid data.
4144!
4145 IF (domain(ng)%SouthWest_Test(tile)) THEN
4146 IF (master) THEN
4147 IF (first) THEN
4148 first=.false.
4149 WRITE (202,20)
4150 END IF
4151 WRITE (202,30) cr, dg, ng, iic(dg), iic(ng), told, tnew, &
4152 & int(time(dg)), &
4153 & int(rollingtime(told,cr)), &
4154 & int(time(ng)), &
4155 & int(rollingtime(tnew,cr)), &
4156 & wold, wnew
4157 20 FORMAT (3x,'cr',3x,'dg',3x,'ng',4x,'iic',4x,'iic',2x,'told', &
4158 & 2x,'tnew',7x,'time',7x,'time',7x,'time',7x,'time', &
4159 & 7x,'Wold',7x,'Wnew',/,18x,'(dg)',3x,'(ng)', &
4160 & 19x,'(dg)',7x,'told',7x,'(ng)',7x,'tnew',/)
4161 30 FORMAT (3i5,2i7,2i6,4(2x,i9),2f11.4)
4162 FLUSH (202)
4163 END IF
4164 END IF
4165# endif
4166
4167# ifdef DISTRIBUTE
4168!
4169!-----------------------------------------------------------------------
4170! Exchange tile information.
4171!-----------------------------------------------------------------------
4172!
4173!^ CALL mp_exchange3d (ng, tile, model, 4, &
4174!^ & LBi, UBi, LBj, UBj, 1, N(ng), &
4175!^ & NghostPoints, &
4176!^ & EWperiodic(ng), NSperiodic(ng), &
4177!^ & OCEAN(ng)%tl_u(:,:,:,1), &
4178!^ & OCEAN(ng)%tl_u(:,:,:,2), &
4179!^ & OCEAN(ng)%tl_v(:,:,:,1), &
4180!^ & OCEAN(ng)%tl_v(:,:,:,2))
4181!^
4182 CALL ad_mp_exchange3d (ng, tile, model, 4, &
4183 & lbi, ubi, lbj, ubj, 1, n(ng), &
4184 & nghostpoints, &
4185 & ewperiodic(ng), nsperiodic(ng), &
4186 & ocean(ng)%ad_u(:,:,:,1), &
4187 & ocean(ng)%ad_u(:,:,:,2), &
4188 & ocean(ng)%ad_v(:,:,:,1), &
4189 & ocean(ng)%ad_v(:,:,:,2))
4190!^ CALL mp_exchange3d (ng, tile, model, 4, &
4191!^ & LBi, UBi, LBj, UBj, 1, N(ng), &
4192!^ & NghostPoints, &
4193!^ & EWperiodic(ng), NSperiodic(ng), &
4194!^ & OCEAN(ng)%tl_u(:,:,:,1), &
4195!^ & OCEAN(ng)%tl_u(:,:,:,2), &
4196!^ & OCEAN(ng)%tl_v(:,:,:,1), &
4197!^ & OCEAN(ng)%tl_v(:,:,:,2))
4198!^
4199 CALL ad_mp_exchange4d (ng, tile, model, 3, &
4200 & lbi, ubi, lbj, ubj, 1, n(ng), 1, nt(ng), &
4201 & nghostpoints, &
4202 & ewperiodic(ng), nsperiodic(ng), &
4203 & ocean(ng)%ad_t(:,:,:,1,:), &
4204 & ocean(ng)%ad_t(:,:,:,2,:), &
4205 & ocean(ng)%ad_t(:,:,:,3,:))
4206# endif
4207!
4208! 3D momentum in the XI-direction.
4209!
4210 DO m=1,ucontact(cr)%Npoints
4211 i=ucontact(cr)%Irg(m)
4212 j=ucontact(cr)%Jrg(m)
4213 IF (((istrp.le.i).and.(i.le.iendt)).and. &
4214 & ((jstrt.le.j).and.(j.le.jendt))) THEN
4215 DO k=1,n(ng)
4216!^ OCEAN(ng)%tl_u(i,j,k,1)=tl_my_value
4217!^
4218 ad_my_value=ad_my_value+ocean(ng)%ad_u(i,j,k,1)
4219 ocean(ng)%ad_u(i,j,k,1)=0.0_r8
4220!^ OCEAN(ng)%tl_u(i,j,k,2)=tl_my_value
4221!^
4222 ad_my_value=ad_my_value+ocean(ng)%ad_u(i,j,k,2)
4223 ocean(ng)%ad_u(i,j,k,2)=0.0_r8
4224# ifdef MASKING
4225!^ tl_my_value=tl_my_value*GRID(ng)%umask(i,j)
4226!^
4227 ad_my_value=ad_my_value*grid(ng)%umask(i,j)
4228# endif
4229!^ tl_my_value=Wold* &
4230!^ & (Ucontact(cr)%Lweight(1,m)* &
4231!^ & REFINED(cr)%tl_u(1,k,m,told)+ &
4232!^ & Ucontact(cr)%Lweight(2,m)* &
4233!^ & REFINED(cr)%tl_u(2,k,m,told)+ &
4234!^ & Ucontact(cr)%Lweight(3,m)* &
4235!^ & REFINED(cr)%tl_u(3,k,m,told)+ &
4236!^ & Ucontact(cr)%Lweight(4,m)* &
4237!^ & REFINED(cr)%tl_u(4,k,m,told))+ &
4238!^ & Wnew* &
4239!^ & (Ucontact(cr)%Lweight(1,m)* &
4240!^ & REFINED(cr)%tl_u(1,k,m,tnew)+ &
4241!^ & Ucontact(cr)%Lweight(2,m)* &
4242!^ & REFINED(cr)%tl_u(2,k,m,tnew)+ &
4243!^ & Ucontact(cr)%Lweight(3,m)* &
4244!^ & REFINED(cr)%tl_u(3,k,m,tnew)+ &
4245!^ & Ucontact(cr)%Lweight(4,m)* &
4246!^ & REFINED(cr)%tl_u(4,k,m,tnew))
4247 DO ii=1,4
4248 adfac1=wold*ucontact(cr)%Lweight(ii,m)*ad_my_value
4249 adfac2=wnew*ucontact(cr)%Lweight(ii,m)*ad_my_value
4250 refined(cr)%ad_u(ii,k,m,told)= &
4251 & refined(cr)%ad_u(ii,k,m,told)+adfac1
4252 refined(cr)%ad_u(ii,k,m,tnew)= &
4253 & refined(cr)%ad_u(ii,k,m,tnew)+adfac2
4254 END DO
4255 ad_my_value=0.0_r8
4256 END DO
4257 END IF
4258 END DO
4259!
4260! 3D momentum in the ETA-direction.
4261!
4262 DO m=1,vcontact(cr)%Npoints
4263 i=vcontact(cr)%Irg(m)
4264 j=vcontact(cr)%Jrg(m)
4265 IF (((istrt.le.i).and.(i.le.iendt)).and. &
4266 & ((jstrp.le.j).and.(j.le.jendt))) THEN
4267 DO k=1,n(ng)
4268!^ OCEAN(ng)%tl_v(i,j,k,1)=tl_my_value
4269!^
4270 ad_my_value=ad_my_value+ocean(ng)%ad_v(i,j,k,1)
4271 ocean(ng)%ad_v(i,j,k,1)=0.0_r8
4272!^ OCEAN(ng)%tl_v(i,j,k,2)=tl_my_value
4273!^
4274 ad_my_value=ad_my_value+ocean(ng)%ad_v(i,j,k,2)
4275 ocean(ng)%ad_v(i,j,k,2)=0.0_r8
4276# ifdef MASKING
4277!^ tl_my_value=tl_my_value*GRID(ng)%vmask(i,j)
4278!^
4279 ad_my_value=ad_my_value*grid(ng)%vmask(i,j)
4280# endif
4281!^ tl_my_value=Wold* &
4282!^ & (Vcontact(cr)%Lweight(1,m)* &
4283!^ & REFINED(cr)%tl_v(1,k,m,told)+ &
4284!^ & Vcontact(cr)%Lweight(2,m)* &
4285!^ & REFINED(cr)%tl_v(2,k,m,told)+ &
4286!^ & Vcontact(cr)%Lweight(3,m)* &
4287!^ & REFINED(cr)%tl_v(3,k,m,told)+ &
4288!^ & Vcontact(cr)%Lweight(4,m)* &
4289!^ & REFINED(cr)%tl_v(4,k,m,told))+ &
4290!^ & Wnew* &
4291!^ & (Vcontact(cr)%Lweight(1,m)* &
4292!^ & REFINED(cr)%tl_v(1,k,m,tnew)+ &
4293!^ & Vcontact(cr)%Lweight(2,m)* &
4294!^ & REFINED(cr)%tl_v(2,k,m,tnew)+ &
4295!^ & Vcontact(cr)%Lweight(3,m)* &
4296!^ & REFINED(cr)%tl_v(3,k,m,tnew)+ &
4297!^ & Vcontact(cr)%Lweight(4,m)* &
4298!^ & REFINED(cr)%tl_v(4,k,m,tnew))
4299!^
4300 DO ii=1,4
4301 adfac1=wold*vcontact(cr)%Lweight(ii,m)*ad_my_value
4302 adfac2=wnew*vcontact(cr)%Lweight(ii,m)*ad_my_value
4303 refined(cr)%ad_v(ii,k,m,told)= &
4304 & refined(cr)%ad_v(ii,k,m,told)+adfac1
4305 refined(cr)%ad_v(ii,k,m,tnew)= &
4306 & refined(cr)%ad_v(ii,k,m,tnew)+adfac2
4307 END DO
4308 ad_my_value=0.0_r8
4309 END DO
4310 END IF
4311 END DO
4312!
4313! Tracer-type variables.
4314!
4315 DO m=1,rcontact(cr)%Npoints
4316 i=rcontact(cr)%Irg(m)
4317 j=rcontact(cr)%Jrg(m)
4318 IF (((istrt.le.i).and.(i.le.iendt)).and. &
4319 & ((jstrt.le.j).and.(j.le.jendt))) THEN
4320 DO itrc=1,nt(ng)
4321 DO k=1,n(ng)
4322!^ OCEAN(ng)%tl_t(i,j,k,1,itrc)=tl_my_value
4323!^
4324 ad_my_value=ad_my_value+ocean(ng)%ad_t(i,j,k,1,itrc)
4325 ocean(ng)%ad_t(i,j,k,1,itrc)=0.0_r8
4326!^ OCEAN(ng)%tl_t(i,j,k,2,itrc)=tl_my_value
4327!^
4328 ad_my_value=ad_my_value+ocean(ng)%ad_t(i,j,k,2,itrc)
4329 ocean(ng)%ad_t(i,j,k,2,itrc)=0.0_r8
4330!^ OCEAN(ng)%tl_t(i,j,k,3,itrc)=tl_my_value
4331!^a
4332 ad_my_value=ad_my_value+ocean(ng)%ad_t(i,j,k,3,itrc)
4333 ocean(ng)%ad_t(i,j,k,3,itrc)=0.0_r8
4334# ifdef MASKING
4335!^ tl_my_value=tl_my_value*GRID(ng)%rmask(i,j)
4336 ad_my_value=ad_my_value*grid(ng)%rmask(i,j)
4337# endif
4338!^ tl_my_value=Wold* &
4339!^ & (Rcontact(cr)%Lweight(1,m)* &
4340!^ & REFINED(cr)%tl_t(1,k,m,told,itrc)+ &
4341!^ & Rcontact(cr)%Lweight(2,m)* &
4342!^ & REFINED(cr)%tl_t(2,k,m,told,itrc)+ &
4343!^ & Rcontact(cr)%Lweight(3,m)* &
4344!^ & REFINED(cr)%tl_t(3,k,m,told,itrc)+ &
4345!^ & Rcontact(cr)%Lweight(4,m)* &
4346!^ & REFINED(cr)%tl_t(4,k,m,told,itrc))+ &
4347!^ & Wnew* &
4348!^ & (Rcontact(cr)%Lweight(1,m)* &
4349!^ & REFINED(cr)%tl_t(1,k,m,tnew,itrc)+ &
4350!^ & Rcontact(cr)%Lweight(2,m)* &
4351!^ & REFINED(cr)%tl_t(2,k,m,tnew,itrc)+ &
4352!^ & Rcontact(cr)%Lweight(3,m)* &
4353!^ & REFINED(cr)%tl_t(3,k,m,tnew,itrc)+ &
4354!^ & Rcontact(cr)%Lweight(4,m)* &
4355!^ & REFINED(cr)%tl_t(4,k,m,tnew,itrc))
4356!^
4357 DO ii=1,4
4358 adfac1=wold*rcontact(cr)%Lweight(ii,m)*ad_my_value
4359 adfac2=wnew*rcontact(cr)%Lweight(ii,m)*ad_my_value
4360 refined(cr)%ad_t(ii,k,m,told,itrc)= &
4361 & refined(cr)%ad_t(ii,k,m,told,itrc)+adfac1
4362 refined(cr)%ad_t(ii,k,m,tnew,itrc)= &
4363 & refined(cr)%ad_t(ii,k,m,tnew,itrc)+adfac2
4364 END DO
4365 ad_my_value=0.0_r8
4366 END DO
4367 END DO
4368 END IF
4369 END DO
4370!
4371 10 FORMAT (/,'AD_PUT_REFINE3D - unbounded contact points temporal: ',&
4372 & ' interpolation:', &
4373 & /,2x, 'cr = ',i2.2, &
4374 & 8x,'dg = ',i2.2, &
4375 & 8x,'ng = ',i2.2, &
4376 & /,2x, 'iic(dg) = ',i7.7, &
4377 & 3x,'told = ',i1, &
4378 & 9x,'tnew = ',i1, &
4379 & /,2x, 'iic(ng) = ',i7.7, &
4380 & 3x,'Wold = ',f8.5, &
4381 & 2x,'Wnew = ',f8.5, &
4382 & /,2x, 'time(ng) = ',i10, &
4383 & 3x,'time(told) = ',i10, &
4384 & 3x,'time(tnew) = ',i10)
4385
4386 RETURN
4387 END SUBROUTINE ad_put_refine3d
4388# endif
4389
4390# ifdef SOLVE3D
4391!
4392 SUBROUTINE ad_z_weights (ng, model, tile)
4393!
4394!=======================================================================
4395! !
4396! This routine determines the vertical indices and interpolation !
4397! weights associated with depth, which are needed to process 3D !
4398! fields in the contact region. !
4399! !
4400! On Input: !
4401! !
4402! model Calling model identifier (integer) !
4403! tile Domain partition for composite grid ng (integer) !
4404! !
4405! On Output: Updated T_NGC type structures in mod_param: !
4406! !
4407! Rcontact Updated values for Kdg(:,:) and Vweigths (:,:,:) !
4408! Ucontact Updated values for Kdg(:,:) and Vweigths (:,:,:) !
4409! Vcontact Updated values for Kdg(:,:) and Vweigths (:,:,:) !
4410! !
4411!=======================================================================
4412!
4413 USE mod_param
4414 USE mod_grid
4415 USE mod_nesting
4416 USE mod_scalars
4417!
4418# ifdef DISTRIBUTE
4419 USE distribute_mod, ONLY : mp_assemble
4420# endif
4421 USE strings_mod, ONLY : founderror
4422!
4423! Imported variable declarations.
4424!
4425 integer, intent(in) :: ng, model, tile
4426!
4427! Local variable declarations.
4428!
4429 integer :: cr, dg, rg, i, j, k, m, ii
4430 integer :: idg, jdg, kdg, imind, imaxd, jmind, jmaxd
4431 integer :: irg, jrg, krg, iminr, imaxr, jminr, jmaxr
4432 integer :: idgm1, idgp1, jdgm1, jdgp1
4433 integer :: npoints
4434# ifdef DISTRIBUTE
4435 integer :: nkpts, nwpts, nzpts
4436
4437 integer, parameter :: ispv = 0
4438# endif
4439 real(r8), parameter :: spv = 0.0_r8
4440
4441 real(r8) :: zbot, zr, ztop, dz, r1, r2
4442 real(r8) :: ad_zbot, ad_zr, ad_ztop, ad_dz, ad_r1, ad_r2
4443 real(r8) :: adfac, adfac1
4444
4445 real(r8), allocatable :: zd(:,:,:)
4446 real(r8), allocatable :: ad_zd(:,:,:)
4447!
4448 character (len=*), parameter :: myfile = &
4449 & __FILE__//", ad_z_weights"
4450!
4451!=======================================================================
4452! Adjoint compute vertical indices and weights for each contact region.
4453!=======================================================================
4454!
4455!
4456! Clear adjoint constants.
4457!
4458 ad_zbot=0.0_r8
4459 ad_zr=0.0_r8
4460 ad_ztop=0.0_r8
4461 ad_dz=0.0_r8
4462 ad_r1=0.0_r8
4463 ad_r2=0.0_r8
4464 adfac=0.0_r8
4465!
4466! Compute vertical indices and weights.
4467!
4468 DO cr=1,ncontact
4469!
4470! Get donor and receiver grid numbers.
4471!
4472 dg=rcontact(cr)%donor_grid
4473 rg=rcontact(cr)%receiver_grid
4474!
4475! Process only contact region data for requested nested grid "ng".
4476!
4477 IF (rg.eq.ng) THEN
4478
4479# ifdef DISTRIBUTE
4480!
4481! Exchange data between all parallel nodes. No action required for the
4482! adjoint of mp_assemble (AMM).
4483!
4484 nkpts=n(rg)*npoints
4485 nwpts=2*nkpts
4486 nzpts=4*nkpts
4487!
4488!^ CALL mp_assemble (rg, model, Nkpts, ispv, Vcontact(cr)%Kdg)
4489!^
4490!! CALL ad_mp_assemble (rg, model, Nkpts, ispv, &
4491!! Vcontact(cr)%Kdg)
4492!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
4493
4494!! CALL mp_assemble (rg, model, Nwpts, spv, &
4495!! & Vcontact(cr)%Vweight)
4496!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
4497
4498!! CALL ad_mp_assemble (rg, model, Nwpts, spv, &
4499!! & Vcontact(cr)%ad_Vweight)
4500!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
4501# endif
4502!
4503!-----------------------------------------------------------------------
4504! Process variables in structure Vcontact(cr).
4505!-----------------------------------------------------------------------
4506!
4507! Get number of contact points to process.
4508!
4509 npoints=vcontact(cr)%Npoints
4510!
4511! Set starting and ending tile indices for the donor and receiver
4512! grids.
4513!
4514 imind=bounds(dg) % IstrT(tile)
4515 imaxd=bounds(dg) % IendT(tile)
4516 jmind=bounds(dg) % JstrP(tile)
4517 jmaxd=bounds(dg) % JendT(tile)
4518!
4519 iminr=bounds(rg) % IstrT(tile)
4520 imaxr=bounds(rg) % IendT(tile)
4521 jminr=bounds(rg) % JstrP(tile)
4522 jmaxr=bounds(rg) % JendT(tile)
4523
4524# ifdef DISTRIBUTE
4525!
4526! If distributed-memory, initialize with special value (zero) to
4527! facilitate the global reduction when collecting data between all
4528! nodes.
4529!
4530 nkpts=n(rg)*npoints
4531 nwpts=2*nkpts
4532 nzpts=4*nkpts
4533
4534 vcontact(cr)%Kdg(1:n(rg),1:npoints)=ispv
4535 vcontact(cr)%Vweight(1:2,1:n(rg),1:npoints)=spv
4536# endif
4537
4538 v_contact : IF (.not.vcontact(cr)%interpolate.and. &
4539 & vcontact(cr)%coincident) THEN
4540 DO krg=1,n(rg)
4541 DO m=1,npoints
4542 irg=vcontact(cr)%Irg(m)
4543 jrg=vcontact(cr)%Jrg(m)
4544 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
4545 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
4546!^ Vcontact(cr)%Kdg(Krg,m)=Krg
4547!^ Vcontact(cr)%Vweight(1,Krg,m)=1.0_r8
4548!^ Vcontact(cr)%Vweight(2,Krg,m)=0.0_r8
4549
4550!^ Vcontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
4551!^
4552 vcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
4553!^ Vcontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
4554!^
4555 vcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
4556 END IF
4557 END DO
4558 END DO
4559!
4560! Otherwise, vertically interpolate because donor and receiver grids
4561! are not coincident.
4562!
4563
4564 ELSE
4565!
4566! Allocate and initialize local working arrays.
4567!
4568 IF (.not.allocated(zd)) THEN
4569 allocate (zd(4,n(dg),npoints))
4570 END IF
4571 zd=spv
4572 IF (.not.allocated(ad_zd)) THEN
4573 allocate (ad_zd(4,n(dg),npoints))
4574 END IF
4575 ad_zd=0.0_r8
4576!
4577! Extract donor grid depths for each cell containing the receiver grid
4578! contact point.
4579!
4580 DO kdg=1,n(dg)
4581 DO m=1,npoints
4582 idg=vcontact(cr)%Idg(m)
4583 idgp1=min(idg+1, bounds(dg)%UBi(-1))
4584 jdg=vcontact(cr)%Jdg(m)
4585 jdgm1=max(jdg-1, bounds(dg)%LBj(-1))
4586 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
4587 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
4588 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
4589 zd(1,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdgm1,kdg)+ &
4590 & grid(dg)%z_r(idg ,jdg ,kdg))
4591 zd(2,kdg,m)=0.5_r8*(grid(dg)%z_r(idgp1,jdgm1,kdg)+ &
4592 & grid(dg)%z_r(idgp1,jdg ,kdg))
4593 zd(3,kdg,m)=0.5_r8*(grid(dg)%z_r(idgp1,jdg ,kdg)+ &
4594 & grid(dg)%z_r(idgp1,jdgp1,kdg))
4595 zd(4,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdg ,kdg)+ &
4596 & grid(dg)%z_r(idg ,jdgp1,kdg))
4597 END IF
4598 END DO
4599 END DO
4600
4601# ifdef DISTRIBUTE
4602!
4603! Exchange data between all parallel nodes.
4604!
4605 CALL mp_assemble (dg, model, nzpts, spv, zd)
4606 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4607# endif
4608!
4609!
4610! Determine donor grid vertical indices (Kdg) and weights (Vweight)
4611! needed for the interpolation of data at the receiver grid contact
4612! points.
4613!
4614 DO krg=1,n(rg)
4615 DO m=1,npoints
4616 irg=vcontact(cr)%Irg(m)
4617 jrg=vcontact(cr)%Jrg(m)
4618 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
4619 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
4620 ztop=vcontact(cr)%Lweight(1,m)*zd(1,n(dg),m)+ &
4621 & vcontact(cr)%Lweight(2,m)*zd(2,n(dg),m)+ &
4622 & vcontact(cr)%Lweight(3,m)*zd(3,n(dg),m)+ &
4623 & vcontact(cr)%Lweight(4,m)*zd(4,n(dg),m)
4624 zbot=vcontact(cr)%Lweight(1,m)*zd(1,1 ,m)+ &
4625 & vcontact(cr)%Lweight(2,m)*zd(2,1 ,m)+ &
4626 & vcontact(cr)%Lweight(3,m)*zd(3,1 ,m)+ &
4627 & vcontact(cr)%Lweight(4,m)*zd(4,1 ,m)
4628 zr=0.5_r8*(grid(rg)%z_r(irg,jrg ,krg)+ &
4629 & grid(rg)%z_r(irg,jrg-1,krg))
4630 IF (zr.ge.ztop) THEN ! If shallower, use top
4631!^ Vcontact(cr)%Kdg(Krg,m)=N(dg)! donor grid cell value
4632!^ Vcontact(cr)%Vweight(1,Krg,m)=0.0_r8
4633!^ Vcontact(cr)%Vweight(2,Krg,m)=1.0_r8
4634
4635!^ Vcontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
4636!^
4637 vcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
4638!^ Vcontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
4639!^
4640 vcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
4641 ELSE IF (zbot.ge.zr) THEN ! If deeper, use bottom
4642!^ Vcontact(cr)%Kdg(Krg,m)=1 ! donor grid cell value
4643!^ Vcontact(cr)%Vweight(1,Krg,m)=0.0_r8
4644!^ Vcontact(cr)%Vweight(2,Krg,m)=1.0_r8
4645
4646!^ Vcontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
4647!^
4648 vcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
4649!^ Vcontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
4650!^
4651 vcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
4652 ELSE ! bounded, interpolate
4653 DO kdg=n(dg),2,-1
4654 ztop=vcontact(cr)%Lweight(1,m)*zd(1,kdg ,m)+ &
4655 & vcontact(cr)%Lweight(2,m)*zd(2,kdg ,m)+ &
4656 & vcontact(cr)%Lweight(3,m)*zd(3,kdg ,m)+ &
4657 & vcontact(cr)%Lweight(4,m)*zd(4,kdg ,m)
4658 zbot=vcontact(cr)%Lweight(1,m)*zd(1,kdg-1,m)+ &
4659 & vcontact(cr)%Lweight(2,m)*zd(2,kdg-1,m)+ &
4660 & vcontact(cr)%Lweight(3,m)*zd(3,kdg-1,m)+ &
4661 & vcontact(cr)%Lweight(4,m)*zd(4,kdg-1,m)
4662 IF ((ztop.gt.zr).and.(zr.ge.zbot)) THEN
4663 dz=ztop-zbot
4664 r2=(zr-zbot)/dz
4665 r1=1.0_r8-r2
4666!^ Vcontact(cr)%Kdg(Krg,m)=Kdg
4667!^ Vcontact(cr)%Vweight(1,Krg,m)=r1
4668!^ Vcontact(cr)%Vweight(2,Krg,m)=r2
4669
4670!^ Vcontact(cr)%tl_Vweight(1,Krg,m)=tl_r1
4671!^
4672 ad_r1=ad_r1+vcontact(cr)%ad_Vweight(1,krg,m)
4673 vcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
4674!^ Vcontact(cr)%tl_Vweight(2,Krg,m)=tl_r2
4675!^
4676 ad_r2=ad_r2+vcontact(cr)%ad_Vweight(2,krg,m)
4677 vcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
4678!^ tl_r1=-tl_r2
4679!^
4680 ad_r2=ad_r2-ad_r1
4681 ad_r1=0.0_r8
4682!^ tl_r2=(tl_Zr-tl_Zbot)/dz-tl_dz*r2/dz
4683!^
4684 adfac=ad_r2/dz
4685 ad_zr=ad_zr+adfac
4686 ad_zbot=ad_zbot-adfac
4687 ad_dz=ad_dz-r2*adfac
4688 ad_r2=0.0_r8
4689
4690!^ tl_dz=tl_Ztop-tl_Zbot
4691!^
4692 ad_ztop=ad_ztop+ad_dz
4693 ad_zbot=ad_zbot-ad_dz
4694 ad_dz=0.0_r8
4695 END IF
4696!^ tl_Zbot=Vcontact(cr)%Lweight(1,m)* &
4697!^ & tl_Zd(1,Kdg-1,m)+ &
4698!^ & Vcontact(cr)%Lweight(2,m)* &
4699!^ & tl_Zd(2,Kdg-1,m)+ &
4700!^ & Vcontact(cr)%Lweight(3,m)* &
4701!^ & tl_Zd(3,Kdg-1,m)+ &
4702!^ & Vcontact(cr)%Lweight(4,m)* &
4703!^ & tl_Zd(4,Kdg-1,m)
4704!^
4705 DO ii=1,4
4706 adfac=vcontact(cr)%Lweight(ii,m)*ad_zbot
4707 ad_zd(ii,kdg-1,m)=ad_zd(ii,kdg-1,m)+adfac
4708 END DO
4709 ad_zbot=0.0_r8
4710!^ tl_Ztop=Vcontact(cr)%Lweight(1,m)* &
4711!^ & tl_Zd(1,Kdg ,m)+ &
4712!^ & Vcontact(cr)%Lweight(2,m)* &
4713!^ & tl_Zd(2,Kdg ,m)+ &
4714!^ & Vcontact(cr)%Lweight(3,m)* &
4715!^ & tl_Zd(3,Kdg ,m)+ &
4716!^ & Vcontact(cr)%Lweight(4,m)*
4717!^ & tl_Zd(4,Kdg ,m)
4718!^
4719 DO ii=1,4
4720 adfac=vcontact(cr)%Lweight(ii,m)*ad_ztop
4721 ad_zd(ii,kdg ,m)=ad_zd(ii,kdg ,m)+adfac
4722 END DO
4723 ad_ztop=0.0_r8
4724 END DO
4725 END IF
4726!^ tl_Zr=0.5_r8* &
4727!^ (GRID(rg)%tl_z_r(Irg,Jrg ,Krg)+ &
4728!^ & GRID(rg)%tl_z_r(Irg,Jrg-1,Krg))
4729!^
4730 grid(rg)%ad_z_r(irg,jrg ,krg)= &
4731 & grid(rg)%ad_z_r(irg,jrg ,krg)+0.5_r8*ad_zr
4732 grid(rg)%ad_z_r(irg,jrg-1,krg)= &
4733 & grid(rg)%ad_z_r(irg,jrg-1,krg)+0.5_r8*ad_zr
4734 ad_zr=0.0_r8
4735!^ tl_Zbot=Vcontact(cr)%Lweight(1,m)*tl_Zd(1,1 ,m)+ &
4736!^ & Vcontact(cr)%Lweight(2,m)*tl_Zd(2,1 ,m)+ &
4737!^ & Vcontact(cr)%Lweight(3,m)*tl_Zd(3,1 ,m)+ &
4738!^ & Vcontact(cr)%Lweight(4,m)*tl_Zd(4,1 ,m)
4739!^
4740 DO ii=1,4
4741 adfac=vcontact(cr)%Lweight(ii,m)*ad_zbot
4742 ad_zd(ii,1 ,m)=ad_zd(ii,1 ,m)+adfac
4743 END DO
4744 ad_zbot=0.0_r8
4745!^ tl_Ztop=Vcontact(cr)%Lweight(1,m)*tl_Zd(1,N(dg),m)+ &
4746!^ & Vcontact(cr)%Lweight(2,m)*tl_Zd(2,N(dg),m)+ &
4747!^ & Vcontact(cr)%Lweight(3,m)*tl_Zd(3,N(dg),m)+ &
4748!^ & Vcontact(cr)%Lweight(4,m)*tl_Zd(4,N(dg),m)
4749!^
4750 DO ii=1,4
4751 adfac=vcontact(cr)%Lweight(ii,m)*ad_ztop
4752 ad_zd(ii,n(dg),m)=ad_zd(ii,n(dg),m)+adfac
4753 END DO
4754 ad_ztop=0.0_r8
4755 END IF
4756 END DO
4757 END DO
4758
4759# ifdef DISTRIBUTE
4760!
4761! Exchange data between all parallel nodes. No action required for the
4762! adjoint of mp_assemble (AMM).
4763!
4764!^ CALL mp_assemble (dg, model, Nzpts, spv, Zd)
4765!^
4766!! CALL ad_mp_assemble (dg, model, Nzpts, spv, ad_Zd)
4767!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
4768# endif
4769!
4770! Extract donor grid depths for each cell containing the receiver grid
4771! contact point.
4772!
4773 DO kdg=1,n(dg)
4774 DO m=1,npoints
4775 idg=vcontact(cr)%Idg(m)
4776 idgp1=min(idg+1, bounds(dg)%UBi(-1))
4777 jdg=vcontact(cr)%Jdg(m)
4778 jdgm1=max(jdg-1, bounds(dg)%LBj(-1))
4779 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
4780 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
4781 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
4782 adfac=0.5_r8*ad_zd(1,kdg,m)
4783!^ tl_Zd(1,Kdg,m)=0.5_r8* &
4784!^ & (GRID(dg)%tl_z_r(Idg ,Jdgm1,Kdg)+ &
4785!^ & GRID(dg)%tl_z_r(Idg ,Jdg ,Kdg))
4786!^
4787 grid(dg)%ad_z_r(idg ,jdgm1,kdg)= &
4788 & grid(dg)%ad_z_r(idg ,jdgm1,kdg)+adfac
4789 grid(dg)%ad_z_r(idg ,jdg ,kdg)= &
4790 & grid(dg)%ad_z_r(idg ,jdg ,kdg)+adfac
4791 ad_zd(1,kdg,m)=0.0
4792!^ tl_Zd(2,Kdg,m)=0.5_r8* &
4793!^ & (GRID(dg)%tl_z_r(Idgp1,Jdgm1,Kdg)+ &
4794!^ & GRID(dg)%tl_z_r(Idgp1,Jdg ,Kdg))
4795!^
4796 adfac=0.5_r8*ad_zd(2,kdg,m)
4797 grid(dg)%ad_z_r(idgp1,jdgm1,kdg)= &
4798 & grid(dg)%ad_z_r(idgp1,jdgm1,kdg)+adfac
4799 grid(dg)%ad_z_r(idgp1,jdg ,kdg)= &
4800 & grid(dg)%ad_z_r(idgp1,jdg ,kdg)+adfac
4801 ad_zd(2,kdg,m)=0.0_r8
4802!^ tl_Zd(3,Kdg,m)=0.5_r8* &
4803!^ & (GRID(dg)%tl_z_r(Idgp1,Jdg ,Kdg)+ &
4804!^ & GRID(dg)%tl_z_r(Idgp1,Jdgp1,Kdg))
4805!^
4806 adfac=0.5_r8*ad_zd(3,kdg,m)
4807 grid(dg)%ad_z_r(idgp1,jdg ,kdg)= &
4808 & grid(dg)%ad_z_r(idgp1,jdg ,kdg)+adfac
4809 grid(dg)%ad_z_r(idgp1,jdgp1,kdg)= &
4810 & grid(dg)%ad_z_r(idgp1,jdgp1,kdg)+adfac
4811 ad_zd(3,kdg,m)=0.0_r8
4812!^ tl_Zd(4,Kdg,m)=0.5_r8* &
4813!^ & (GRID(dg)%tl_z_r(Idg ,Jdg ,Kdg)+ &
4814!^ & GRID(dg)%tl_z_r(Idg ,Jdgp1,Kdg))
4815!^
4816 adfac=0.5_r8*ad_zd(4,kdg,m)
4817 grid(dg)%ad_z_r(idg ,jdg ,kdg)= &
4818 & grid(dg)%ad_z_r(idg ,jdg ,kdg)+adfac
4819 grid(dg)%ad_z_r(idg ,jdgp1,kdg)= &
4820 & grid(dg)%ad_z_r(idg ,jdgp1,kdg)+adfac
4821 ad_zd(4,kdg,m)=0.0_r8
4822 END IF
4823 END DO
4824 END DO
4825 END IF v_contact
4826
4827# ifdef DISTRIBUTE
4828!
4829! If distributed-memory, initialize with special value (zero) to
4830! facilitate the global reduction when collecting data between all
4831! nodes.
4832!
4833!^ Vcontact(cr)%tl_Vweight(1:2,1:N(rg),1:Npoints)=0.0_r8
4834!^
4835 vcontact(cr)%ad_Vweight(1:2,1:n(rg),1:npoints)=0.0_r8
4836# endif
4837!
4838! Deallocate local work arrays.
4839!
4840 IF (allocated(zd)) THEN
4841 deallocate (zd)
4842 END IF
4843 IF (allocated(ad_zd)) THEN
4844 deallocate (ad_zd)
4845 END IF
4846
4847# ifdef DISTRIBUTE
4848!
4849! Exchange data between all parallel nodes. No action required for the
4850! adjoint of mp_assemble (AMM).
4851!
4852!^ CALL mp_assemble (rg, model, Nwpts, spv, &
4853!^ & Ucontact(cr)%Vweight)
4854!^
4855!! CALL ad_mp_assemble (rg, model, Nwpts, spv, &
4856!! & Ucontact(cr)%ad_Vweight)
4857!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
4858# endif
4859!
4860!-----------------------------------------------------------------------
4861! Process variables in structure Ucontact(cr).
4862!-----------------------------------------------------------------------
4863!
4864! Get number of contact points to process.
4865!
4866 npoints=ucontact(cr)%Npoints
4867!
4868! Set starting and ending tile indices for the donor and receiver
4869! grids.
4870!
4871 imind=bounds(dg) % IstrP(tile)
4872 imaxd=bounds(dg) % IendT(tile)
4873 jmind=bounds(dg) % JstrT(tile)
4874 jmaxd=bounds(dg) % JendT(tile)
4875!
4876 iminr=bounds(rg) % IstrP(tile)
4877 imaxr=bounds(rg) % IendT(tile)
4878 jminr=bounds(rg) % JstrT(tile)
4879 jmaxr=bounds(rg) % JendT(tile)
4880
4881# ifdef DISTRIBUTE
4882!
4883! If distributed-memory, initialize with special value (zero) to
4884! facilitate the global reduction when collecting data between all
4885! nodes.
4886!
4887 nkpts=n(rg)*npoints
4888 nwpts=2*nkpts
4889 nzpts=4*nkpts
4890
4891 ucontact(cr)%Kdg(1:n(rg),1:npoints)=ispv
4892 ucontact(cr)%Vweight(1:2,1:n(rg),1:npoints)=spv
4893# endif
4894!
4895! If coincident grids and requested, avoid vertical interpolation.
4896!
4897 u_contact : IF (.not.ucontact(cr)%interpolate.and. &
4898 & ucontact(cr)%coincident) THEN
4899 DO krg=1,n(rg)
4900 DO m=1,npoints
4901 irg=ucontact(cr)%Irg(m)
4902 jrg=ucontact(cr)%Jrg(m)
4903 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
4904 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
4905!^ Ucontact(cr)%Kdg(Krg,m)=Krg
4906!^ Ucontact(cr)%Vweight(1,Krg,m)=1.0_r8
4907!^ Ucontact(cr)%Vweight(2,Krg,m)=0.0_r8
4908
4909!^ Ucontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
4910!^
4911 ucontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
4912!^ Ucontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
4913!^
4914 ucontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
4915 END IF
4916 END DO
4917 END DO
4918!
4919! Otherwise, vertically interpolate because donor and receiver grids
4920! are not coincident.
4921!
4922 ELSE
4923!
4924! Allocate and initialize local working arrays.
4925!
4926 IF (.not.allocated(zd)) THEN
4927 allocate (zd(4,n(dg),npoints))
4928 END IF
4929 zd=spv
4930 IF (.not.allocated(ad_zd)) THEN
4931 allocate (ad_zd(4,n(dg),npoints))
4932 END IF
4933 ad_zd=0.0_r8
4934!
4935! Extract donor grid depths for each cell containing the receiver grid
4936! contact point. Notice that indices i-1, i+1 and j-1, j+1 are bounded
4937! the minimum/maximum possible values in contact points at the edge of
4938! the contact region. In such cases, the interpolation weights
4939! Lweight(1,m)=1 and Lweight(2:3,m)=0. This is done to avoid out of
4940! range errors. We need to take care of this in the adjoint code.
4941!
4942 DO kdg=1,n(dg)
4943 DO m=1,npoints
4944 idg =ucontact(cr)%Idg(m)
4945 idgm1=max(idg-1, bounds(dg)%LBi(-1))
4946 idgp1=min(idg+1, bounds(dg)%UBi(-1))
4947 jdg =ucontact(cr)%Jdg(m)
4948 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
4949 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
4950 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
4951 zd(1,kdg,m)=0.5_r8*(grid(dg)%z_r(idgm1,jdg ,kdg)+ &
4952 & grid(dg)%z_r(idg ,jdg ,kdg))
4953 zd(2,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdg ,kdg)+ &
4954 & grid(dg)%z_r(idgp1,jdg ,kdg))
4955 zd(3,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdgp1,kdg)+ &
4956 & grid(dg)%z_r(idgp1,jdgp1,kdg))
4957 zd(4,kdg,m)=0.5_r8*(grid(dg)%z_r(idgm1,jdgp1,kdg)+ &
4958 & grid(dg)%z_r(idg ,jdgp1,kdg))
4959 END IF
4960 END DO
4961 END DO
4962
4963# ifdef DISTRIBUTE
4964!
4965! Exchange data between all parallel nodes.
4966!
4967 CALL mp_assemble (dg, model, nzpts, spv, zd)
4968 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4969# endif
4970!
4971! Determine donor grid vertical indices (Kdg) and weights (Vweight)
4972! needed for the interpolation of data at the receiver grid contact
4973! points.
4974!
4975 DO krg=1,n(rg)
4976 DO m=1,npoints
4977 irg=ucontact(cr)%Irg(m)
4978 jrg=ucontact(cr)%Jrg(m)
4979 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
4980 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
4981 ztop=ucontact(cr)%Lweight(1,m)*zd(1,n(dg),m)+ &
4982 & ucontact(cr)%Lweight(2,m)*zd(2,n(dg),m)+ &
4983 & ucontact(cr)%Lweight(3,m)*zd(3,n(dg),m)+ &
4984 & ucontact(cr)%Lweight(4,m)*zd(4,n(dg),m)
4985 zbot=ucontact(cr)%Lweight(1,m)*zd(1,1 ,m)+ &
4986 & ucontact(cr)%Lweight(2,m)*zd(2,1 ,m)+ &
4987 & ucontact(cr)%Lweight(3,m)*zd(3,1 ,m)+ &
4988 & ucontact(cr)%Lweight(4,m)*zd(4,1 ,m)
4989 zr=0.5_r8*(grid(rg)%z_r(irg ,jrg,krg)+ &
4990 & grid(rg)%z_r(irg-1,jrg,krg))
4991 IF (zr.ge.ztop) THEN ! If shallower, use top
4992!^ Ucontact(cr)%Kdg(Krg,m)=N(dg)! donor grid cell value
4993!^ Ucontact(cr)%Vweight(1,Krg,m)=0.0_r8
4994!^ Ucontact(cr)%Vweight(2,Krg,m)=1.0_r8
4995
4996!^ Ucontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
4997!^
4998 ucontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
4999!^ Ucontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
5000!^
5001 ucontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
5002 ELSE IF (zbot.ge.zr) THEN ! If deeper, use bottom
5003!^ Ucontact(cr)%Kdg(Krg,m)=1 ! donor grid cell value
5004!^ Ucontact(cr)%Vweight(1,Krg,m)=0.0_r8
5005!^ Ucontact(cr)%Vweight(2,Krg,m)=1.0_r8
5006
5007!^ Ucontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
5008!^
5009 ucontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
5010!^ Ucontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
5011!^
5012 ucontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
5013 ELSE ! bounded, interpolate
5014 DO kdg=n(dg),2,-1
5015 ztop=ucontact(cr)%Lweight(1,m)*zd(1,kdg ,m)+ &
5016 & ucontact(cr)%Lweight(2,m)*zd(2,kdg ,m)+ &
5017 & ucontact(cr)%Lweight(3,m)*zd(3,kdg ,m)+ &
5018 & ucontact(cr)%Lweight(4,m)*zd(4,kdg ,m)
5019 zbot=ucontact(cr)%Lweight(1,m)*zd(1,kdg-1,m)+ &
5020 & ucontact(cr)%Lweight(2,m)*zd(2,kdg-1,m)+ &
5021 & ucontact(cr)%Lweight(3,m)*zd(3,kdg-1,m)+ &
5022 & ucontact(cr)%Lweight(4,m)*zd(4,kdg-1,m)
5023 IF ((ztop.gt.zr).and.(zr.ge.zbot)) THEN
5024 dz=ztop-zbot
5025 r2=(zr-zbot)/dz
5026 r1=1.0_r8-r2
5027!^ Ucontact(cr)%Kdg(Krg,m)=Kdg
5028!^ Ucontact(cr)%Vweight(1,Krg,m)=r1
5029!^ Ucontact(cr)%Vweight(2,Krg,m)=r2
5030
5031!^ Ucontact(cr)%tl_Vweight(1,Krg,m)=tl_r1
5032!^
5033 ad_r1=ad_r1+ucontact(cr)%ad_Vweight(1,krg,m)
5034 ucontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
5035!^ Ucontact(cr)%tl_Vweight(2,Krg,m)=tl_r2
5036!^
5037 ad_r2=ad_r2+ucontact(cr)%ad_Vweight(2,krg,m)
5038 ucontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
5039!^ tl_r1=-tl_r2
5040!^
5041 ad_r2=ad_r2-ad_r1
5042 ad_r1=0.0_r8
5043!^ tl_r2=(tl_Zr-tl_Zbot)/dz-tl_dz*r2/dz
5044!^
5045 adfac=ad_r2/dz
5046 ad_zr=ad_zr+adfac
5047 ad_zbot=ad_zbot-adfac
5048 ad_dz=ad_dz-r2*adfac
5049 ad_r2=0.0_r8
5050!^ tl_dz=tl_Ztop-tl_Zbot
5051!^
5052 ad_ztop=ad_ztop+ad_dz
5053 ad_zbot=ad_zbot-ad_dz
5054 ad_dz=0.0_r8
5055 END IF
5056!^ tl_Zbot=Ucontact(cr)%Lweight(1,m)* &
5057!^ & tl_Zd(1,Kdg-1,m)+ &
5058!^ & Ucontact(cr)%Lweight(2,m)* &
5059!^ & tl_Zd(2,Kdg-1,m)+ &
5060!^ & Ucontact(cr)%Lweight(3,m)* &
5061!^ & tl_Zd(3,Kdg-1,m)+ &
5062!^ & Ucontact(cr)%Lweight(4,m)*
5063!^ & tl_Zd(4,Kdg-1,m)
5064!^
5065 DO ii=1,4
5066 adfac=ucontact(cr)%Lweight(ii,m)*ad_zbot
5067 ad_zd(ii,kdg-1,m)=ad_zd(ii,kdg-1,m)+adfac
5068 END DO
5069 ad_zbot=0.0_r8
5070!^ tl_Ztop=Ucontact(cr)%Lweight(1,m)* &
5071!^ & tl_Zd(1,Kdg ,m)+ &
5072!^ & Ucontact(cr)%Lweight(2,m)* &
5073!^ & tl_Zd(2,Kdg ,m)+ &
5074!^ & Ucontact(cr)%Lweight(3,m)* &
5075!^ & tl_Zd(3,Kdg ,m)+ &
5076!^ & Ucontact(cr)%Lweight(4,m)*
5077!^ & tl_Zd(4,Kdg ,m)
5078 DO ii=1,4
5079 adfac=ucontact(cr)%Lweight(ii,m)*ad_ztop
5080 ad_zd(ii,kdg ,m)=ad_zd(ii,kdg ,m)+adfac
5081 END DO
5082 ad_ztop=0.0_r8
5083 END DO
5084 END IF
5085!^ tl_Zr=0.5_r8*(GRID(rg)%tl_z_r(Irg ,Jrg,Krg)+ &
5086!^ & GRID(rg)%tl_z_r(Irg-1,Jrg,Krg))
5087!^
5088 adfac=0.5_r8*ad_zr
5089 grid(rg)%ad_z_r(irg ,jrg,krg)= &
5090 & grid(rg)%ad_z_r(irg ,jrg,krg)+adfac
5091 grid(rg)%ad_z_r(irg-1,jrg,krg)= &
5092 & grid(rg)%ad_z_r(irg-1,jrg,krg)+adfac
5093 ad_zr=0.0_r8
5094!^ tl_Zbot=Ucontact(cr)%Lweight(1,m)*tl_Zd(1,1 ,m)+ &
5095!^ & Ucontact(cr)%Lweight(2,m)*tl_Zd(2,1 ,m)+ &
5096!^ & Ucontact(cr)%Lweight(3,m)*tl_Zd(3,1 ,m)+ &
5097!^ & Ucontact(cr)%Lweight(4,m)*tl_Zd(4,1 ,m)
5098!^
5099 DO ii=1,4
5100 adfac=ucontact(cr)%Lweight(ii,m)*ad_zbot
5101 ad_zd(ii,1 ,m)=ad_zd(ii,1 ,m)+adfac
5102 END DO
5103 ad_zbot=0.0_r8
5104!^ tl_Ztop=Ucontact(cr)%Lweight(1,m)*tl_Zd(1,N(dg),m)+ &
5105!^ & Ucontact(cr)%Lweight(2,m)*tl_Zd(2,N(dg),m)+ &
5106!^ & Ucontact(cr)%Lweight(3,m)*tl_Zd(3,N(dg),m)+ &
5107!^ & Ucontact(cr)%Lweight(4,m)*tl_Zd(4,N(dg),m)
5108!^
5109 DO ii=1,4
5110 adfac=ucontact(cr)%Lweight(ii,m)*ad_ztop
5111 ad_zd(ii,n(dg),m)=ad_zd(ii,n(dg),m)+adfac
5112 END DO
5113 ad_ztop=0.0_r8
5114 END IF
5115 END DO
5116 END DO
5117
5118# ifdef DISTRIBUTE
5119!
5120! Exchange data between all parallel nodes. No action required for the
5121! adjoint of mp_assemble (AMM)
5122!
5123!^ CALL mp_assemble (dg, model, Nzpts, spv, ad_Zd)
5124!^
5125!! CALL ad_mp_assemble (dg, model, Nzpts, spv, ad_Zd)
5126!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
5127# endif
5128!
5129 DO kdg=1,n(dg)
5130 DO m=1,npoints
5131 idg =ucontact(cr)%Idg(m)
5132 idgm1=max(idg-1, bounds(dg)%LBi(-1))
5133 idgp1=min(idg+1, bounds(dg)%UBi(-1))
5134 jdg =ucontact(cr)%Jdg(m)
5135 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
5136 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
5137 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
5138!^ tl_Zd(1,Kdg,m)=0.5_r8* &
5139!^ & (GRID(dg)%tl_z_r(Idgm1,Jdg ,Kdg)+ &
5140!^ & GRID(dg)%tl_z_r(Idg ,Jdg ,Kdg))
5141!^
5142 adfac=0.5_r8*ad_zd(1,kdg,m)
5143 grid(dg)%ad_z_r(idgm1,jdg ,kdg)= &
5144 & grid(dg)%ad_z_r(idgm1,jdg ,kdg)+adfac
5145 grid(dg)%ad_z_r(idg ,jdg ,kdg)= &
5146 & grid(dg)%ad_z_r(idg ,jdg ,kdg)+adfac
5147 ad_zd(1,kdg,m)=0.0_r8
5148!^ tl_Zd(2,Kdg,m)=0.5_r8* &
5149!^ & (GRID(dg)%tl_z_r(Idg ,Jdg ,Kdg)+ &
5150!^ & GRID(dg)%tl_z_r(Idgp1,Jdg ,Kdg))
5151!^
5152 adfac=0.5_r8*ad_zd(2,kdg,m)
5153 grid(dg)%ad_z_r(idg ,jdg ,kdg)= &
5154 & grid(dg)%ad_z_r(idg ,jdg ,kdg)+adfac
5155 grid(dg)%ad_z_r(idgp1,jdg ,kdg)= &
5156 & grid(dg)%ad_z_r(idgp1,jdg ,kdg)+adfac
5157 ad_zd(2,kdg,m)=0.0_r8
5158!^ tl_Zd(3,Kdg,m)=0.5_r8* &
5159!^ & (GRID(dg)%tl_z_r(Idg ,Jdgp1,Kdg)+ &
5160!^ & GRID(dg)%tl_z_r(Idgp1,Jdgp1,Kdg))
5161!^
5162 adfac=0.5_r8*ad_zd(3,kdg,m)
5163 grid(dg)%ad_z_r(idg ,jdgp1,kdg)= &
5164 & grid(dg)%ad_z_r(idg ,jdgp1,kdg)+adfac
5165 grid(dg)%ad_z_r(idgp1,jdgp1,kdg)= &
5166 & grid(dg)%ad_z_r(idgp1,jdgp1,kdg)+adfac
5167 ad_zd(3,kdg,m)=0.0_r8
5168!^ tl_Zd(4,Kdg,m)=0.5_r8* &
5169!^ & (GRID(dg)%tl_z_r(Idgm1,Jdgp1,Kdg)+ &
5170!^ & GRID(dg)%tl_z_r(Idg ,Jdgp1,Kdg))
5171!^
5172 adfac=0.5_r8*ad_zd(4,kdg,m)
5173 grid(dg)%ad_z_r(idgm1,jdgp1,kdg)= &
5174 & grid(dg)%ad_z_r(idgm1,jdgp1,kdg)+adfac
5175 grid(dg)%ad_z_r(idg ,jdgp1,kdg)= &
5176 & grid(dg)%ad_z_r(idg ,jdgp1,kdg)+adfac
5177 ad_zd(4,kdg,m)=0.0_r8
5178 END IF
5179 END DO
5180 END DO
5181 END IF u_contact
5182
5183# ifdef DISTRIBUTE
5184!
5185! If distributed-memory, initialize with special value (zero) to
5186! facilitate the global reduction when collecting data between all
5187! nodes.
5188!
5189!^ Ucontact(cr)%tl_Vweight(1:2,1:N(rg),1:Npoints)=0.0_r8
5190!^
5191 ucontact(cr)%ad_Vweight(1:2,1:n(rg),1:npoints)=0.0_r8
5192# endif
5193!
5194! Deallocate local work arrays.
5195!
5196 IF (allocated(zd)) THEN
5197 deallocate (zd)
5198 END IF
5199 IF (allocated(ad_zd)) THEN
5200 deallocate (ad_zd)
5201 END IF
5202
5203# ifdef DISTRIBUTE
5204!
5205! Exchange data between all parallel nodes. No action required for
5206! the adjoint of mp_assemble.
5207!
5208 npoints=rcontact(cr)%Npoints
5209 nkpts=n(rg)*npoints
5210 nwpts=2*nkpts
5211 nzpts=4*nkpts
5212
5213!^ CALL _mp_assemble (rg, model, Nwpts, spv, &
5214!^ & Rcontact(cr)Vweight)
5215!^
5216!! CALL ad_mp_assemble (rg, model, Nwpts, spv, &
5217!! & Rcontact(cr)%ad_Vweight)
5218!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
5219# endif
5220!
5221!-----------------------------------------------------------------------
5222! Process variables in structure Rcontact(cr).
5223!-----------------------------------------------------------------------
5224!
5225! Get number of contact points to process.
5226!
5227 npoints=rcontact(cr)%Npoints
5228!
5229! Set starting and ending tile indices for the donor and receiver
5230! grids.
5231!
5232 imind=bounds(dg) % IstrT(tile)
5233 imaxd=bounds(dg) % IendT(tile)
5234 jmind=bounds(dg) % JstrT(tile)
5235 jmaxd=bounds(dg) % JendT(tile)
5236!
5237 iminr=bounds(rg) % IstrT(tile)
5238 imaxr=bounds(rg) % IendT(tile)
5239 jminr=bounds(rg) % JstrT(tile)
5240 jmaxr=bounds(rg) % JendT(tile)
5241
5242# ifdef DISTRIBUTE
5243!
5244! If distributed-memory, initialize with special value (zero) to
5245! facilitate the global reduction when collecting data between all
5246! nodes.
5247!
5248 nkpts=n(rg)*npoints
5249 nwpts=2*nkpts
5250 nzpts=4*nkpts
5251
5252 rcontact(cr)%Kdg(1:n(rg),1:npoints)=ispv
5253 rcontact(cr)%Vweight(1:2,1:n(rg),1:npoints)=spv
5254# endif
5255!
5256! If coincident grids and requested, avoid vertical interpolation.
5257!
5258 r_contact : IF (.not.rcontact(cr)%interpolate.and. &
5259 & rcontact(cr)%coincident) THEN
5260 DO krg=1,n(rg)
5261 DO m=1,npoints
5262 irg=rcontact(cr)%Irg(m)
5263 jrg=rcontact(cr)%Jrg(m)
5264 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
5265 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
5266!^ Rcontact(cr)%Kdg(Krg,m)=Krg
5267!^ Rcontact(cr)%Vweight(1,Krg,m)=1.0_r8
5268!^ Rcontact(cr)%Vweight(2,Krg,m)=0.0_r8
5269
5270!^ Rcontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
5271!^
5272 rcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
5273!^ Rcontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
5274!^
5275 rcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
5276 END IF
5277 END DO
5278 END DO
5279!
5280! Otherwise, vertically interpolate because donor and receiver grids
5281! are not coincident.
5282!
5283 ELSE
5284!
5285! Allocate and initialize local working arrays.
5286!
5287 IF (.not.allocated(zd)) THEN
5288 allocate ( zd(4,n(dg),npoints) )
5289 END IF
5290 zd=spv
5291 IF (.not.allocated(ad_zd)) THEN
5292 allocate ( ad_zd(4,n(dg),npoints) )
5293 END IF
5294 ad_zd=0.0_r8
5295!
5296! Extract donor grid depths for each cell containing the receiver grid
5297! contact point. Notice that indices i+1 and j+1 are bounded to the
5298! maximum possible values in contact points at the edge of the contact
5299! region. In such cases, Lweight(1,m)=1 and Lweight(2:3,m)=0. This is
5300! done to avoid out of range errors. We need to take care of this in
5301! the adjoint code.
5302!
5303 DO kdg=1,n(dg)
5304 DO m=1,npoints
5305 idg =rcontact(cr)%Idg(m)
5306 idgp1=min(idg+1, bounds(dg)%UBi(-1))
5307 jdg =rcontact(cr)%Jdg(m)
5308 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
5309 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
5310 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
5311 zd(1,kdg,m)=grid(dg)%z_r(idg ,jdg ,kdg)
5312 zd(2,kdg,m)=grid(dg)%z_r(idgp1,jdg ,kdg)
5313 zd(3,kdg,m)=grid(dg)%z_r(idgp1,jdgp1,kdg)
5314 zd(4,kdg,m)=grid(dg)%z_r(idg ,jdgp1,kdg)
5315 END IF
5316 END DO
5317 END DO
5318
5319# ifdef DISTRIBUTE
5320!
5321! Exchange data between all parallel nodes.
5322!
5323 CALL mp_assemble (dg, model, nzpts, spv, zd)
5324 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5325# endif
5326!
5327! Determine donor grid vertical indices (Kdg) and weights (Vweight)
5328! needed for the interpolation of data at the receiver grid contact
5329! points.
5330!
5331 DO krg=1,n(rg)
5332 DO m=1,npoints
5333 irg=rcontact(cr)%Irg(m)
5334 jrg=rcontact(cr)%Jrg(m)
5335 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
5336 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
5337 ztop=rcontact(cr)%Lweight(1,m)*zd(1,n(dg),m)+ &
5338 & rcontact(cr)%Lweight(2,m)*zd(2,n(dg),m)+ &
5339 & rcontact(cr)%Lweight(3,m)*zd(3,n(dg),m)+ &
5340 & rcontact(cr)%Lweight(4,m)*zd(4,n(dg),m)
5341 zbot=rcontact(cr)%Lweight(1,m)*zd(1,1 ,m)+ &
5342 & rcontact(cr)%Lweight(2,m)*zd(2,1 ,m)+ &
5343 & rcontact(cr)%Lweight(3,m)*zd(3,1 ,m)+ &
5344 & rcontact(cr)%Lweight(4,m)*zd(4,1 ,m)
5345 zr=grid(rg)%z_r(irg,jrg,krg)
5346 IF (zr.ge.ztop) THEN ! If shallower, use top
5347!^ Rcontact(cr)%Kdg(Krg,m)=N(dg)! donor grid cell value
5348!^ Rcontact(cr)%Vweight(1,Krg,m)=0.0_r8
5349!^ Rcontact(cr)%Vweight(2,Krg,m)=1.0_r8
5350
5351!^ Rcontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
5352!^
5353 rcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
5354!^ Rcontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
5355!^
5356 rcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
5357 ELSE IF (zbot.ge.zr) THEN ! If deeper, use bottom
5358!^ Rcontact(cr)%Kdg(Krg,m)=1 ! donor grid cell value
5359!^ Rcontact(cr)%Vweight(1,Krg,m)=0.0_r8
5360!^ Rcontact(cr)%Vweight(2,Krg,m)=1.0_r8
5361
5362!^ Rcontact(cr)%tl_Vweight(1,Krg,m)=0.0_r8
5363!^
5364 rcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
5365!^ Rcontact(cr)%tl_Vweight(2,Krg,m)=0.0_r8
5366!^
5367 rcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
5368 ELSE ! bounded, interpolate
5369 DO kdg=n(dg),2,-1
5370 ztop=rcontact(cr)%Lweight(1,m)*zd(1,kdg ,m)+ &
5371 & rcontact(cr)%Lweight(2,m)*zd(2,kdg ,m)+ &
5372 & rcontact(cr)%Lweight(3,m)*zd(3,kdg ,m)+ &
5373 & rcontact(cr)%Lweight(4,m)*zd(4,kdg ,m)
5374 zbot=rcontact(cr)%Lweight(1,m)*zd(1,kdg-1,m)+ &
5375 & rcontact(cr)%Lweight(2,m)*zd(2,kdg-1,m)+ &
5376 & rcontact(cr)%Lweight(3,m)*zd(3,kdg-1,m)+ &
5377 & rcontact(cr)%Lweight(4,m)*zd(4,kdg-1,m)
5378 IF ((ztop.gt.zr).and.(zr.ge.zbot)) THEN
5379 dz=ztop-zbot
5380 r2=(zr-zbot)/dz
5381 r1=1.0_r8-r2
5382!^ Rcontact(cr)%Kdg(Krg,m)=Kdg
5383!^ Rcontact(cr)%Vweight(1,Krg,m)=r1
5384!^ Rcontact(cr)%Vweight(2,Krg,m)=r2
5385
5386!^ Rcontact(cr)%tl_Vweight(1,Krg,m)=tl_r1
5387!^
5388 ad_r1=ad_r1+rcontact(cr)%ad_Vweight(1,krg,m)
5389 rcontact(cr)%ad_Vweight(1,krg,m)=0.0_r8
5390!^ Rcontact(cr)%tl_Vweight(2,Krg,m)=tl_r2
5391!^
5392 ad_r2=ad_r2+rcontact(cr)%ad_Vweight(2,krg,m)
5393 rcontact(cr)%ad_Vweight(2,krg,m)=0.0_r8
5394!^ tl_r1=-tl_r2
5395!^
5396 ad_r2=ad_r2-ad_r1
5397 ad_r1=0.0_r8
5398!^ tl_r2=(tl_Zr-tl_Zbot)/dz-tl_dz*r2/dz
5399!^
5400 adfac=ad_r1/dz
5401 ad_zr=ad_zr+adfac
5402 ad_zbot=ad_zbot-adfac
5403 ad_dz=ad_dz-r2*adfac
5404 ad_r2=0.0_r8
5405!^ tl_dz=tl_Ztop-tl_Zbot
5406!^
5407 ad_ztop=ad_ztop+ad_dz
5408 ad_zbot=ad_zbot-ad_dz
5409 ad_dz=0.0_r8
5410 END IF
5411!^ tl_Zbot=Rcontact(cr)%Lweight(1,m)* &
5412!^ & tl_Zd(1,Kdg-1,m)+ &
5413!^ & Rcontact(cr)%Lweight(2,m)* &
5414!^ & tl_Zd(2,Kdg-1,m)+ &
5415!^ & Rcontact(cr)%Lweight(3,m)* &
5416!^ & tl_Zd(3,Kdg-1,m)+ &
5417!^ & Rcontact(cr)%Lweight(4,m)* &
5418!^ & tl_Zd(4,Kdg-1,m)
5419!^
5420 DO ii=1,4
5421 adfac=rcontact(cr)%Lweight(ii,m)*ad_zbot
5422 ad_zd(ii,kdg-1,m)=ad_zd(ii,kdg-1,m)+adfac
5423 END DO
5424 ad_zbot=0.0_r8
5425!^ tl_Ztop=Rcontact(cr)%Lweight(1,m)* &
5426!^ & tl_Zd(1,Kdg ,m)+ &
5427!^ & Rcontact(cr)%Lweight(2,m)* &
5428!^ & tl_Zd(2,Kdg ,m)+ &
5429!^ & Rcontact(cr)%Lweight(3,m)* &
5430!^ & tl_Zd(3,Kdg ,m)+ &
5431!^ & Rcontact(cr)%Lweight(4,m)*
5432!^ & tl_Zd(4,Kdg ,m)
5433!^
5434 DO ii=1,4
5435 adfac=rcontact(cr)%Lweight(ii,m)*ad_ztop
5436 ad_zd(ii,kdg ,m)=ad_zd(ii,kdg ,m)+adfac
5437 END DO
5438 ad_ztop=0.0_r8
5439 END DO
5440 END IF
5441!^ tl_Zr=GRID(rg)%tl_z_r(Irg,Jrg,Krg)
5442!^
5443 grid(rg)%ad_z_r(irg,jrg,krg)= &
5444 & grid(rg)%ad_z_r(irg,jrg,krg)+ad_zr
5445 ad_zr=0.0_r8
5446!^ tl_Ztop=Rcontact(cr)%Lweight(1,m)*tl_Zd(1,N(dg),m)+ &
5447!^ & Rcontact(cr)%Lweight(2,m)*tl_Zd(2,N(dg),m)+ &
5448!^ & Rcontact(cr)%Lweight(3,m)*tl_Zd(3,N(dg),m)+ &
5449!^ & Rcontact(cr)%Lweight(4,m)*tl_Zd(4,N(dg),m)
5450!^
5451 DO ii=1,4
5452 adfac=rcontact(cr)%Lweight(ii,m)*ad_ztop
5453 ad_zd(ii,n(dg),m)=ad_zd(ii,n(dg),m)+adfac
5454 END DO
5455 ad_ztop=0.0_r8
5456!^ tl_Zbot=Rcontact(cr)%Lweight(1,m)*tl_Zd(1,1 ,m)+ &
5457!^ & Rcontact(cr)%Lweight(2,m)*tl_Zd(2,1 ,m)+ &
5458!^ & Rcontact(cr)%Lweight(3,m)*tl_Zd(3,1 ,m)+ &
5459!^ & Rcontact(cr)%Lweight(4,m)*tl_Zd(4,1 ,m)
5460!^
5461 DO ii=1,4
5462 adfac=rcontact(cr)%Lweight(ii,m)*ad_zbot
5463 ad_zd(ii,1 ,m)=ad_zd(ii,1 ,m)+adfac
5464 END DO
5465 ad_zbot=0.0_r8
5466 END IF
5467 END DO
5468 END DO
5469
5470# ifdef DISTRIBUTE
5471!
5472! Exchange data between all parallel nodes. No action required for the
5473! adjoint of mp_assemble (AMM).
5474!
5475!^ CALL ad_mp_assemble (dg, model, Nzpts, spv, Zd)
5476!^
5477!! CALL ad_mp_assemble (dg, model, Nzpts, spv, ad_Zd)
5478!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
5479# endif
5480!
5481 DO kdg=1,n(dg)
5482 DO m=1,npoints
5483 idg =rcontact(cr)%Idg(m)
5484 idgp1=min(idg+1, bounds(dg)%UBi(-1))
5485 jdg =rcontact(cr)%Jdg(m)
5486 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
5487 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
5488 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
5489!^ tl_Zd(1,Kdg,m)=GRID(dg)%tl_z_r(Idg ,Jdg ,Kdg)
5490!^
5491 grid(dg)%ad_z_r(idg ,jdg ,kdg)= &
5492 & grid(dg)%ad_z_r(idg ,jdg ,kdg)+ &
5493 & ad_zd(1,kdg,m)
5494 ad_zd(1,kdg,m)=0.0_r8
5495!^ tl_Zd(2,Kdg,m)=GRID(dg)%tl_z_r(Idgp1,Jdg ,Kdg)
5496!^
5497 grid(dg)%ad_z_r(idgp1,jdg ,kdg)= &
5498 & grid(dg)%ad_z_r(idgp1,jdg ,kdg)+ &
5499 & ad_zd(2,kdg,m)
5500 ad_zd(2,kdg,m)=0.0_r8
5501!^ tl_Zd(3,Kdg,m)=GRID(dg)%tl_z_r(Idgp1,Jdgp1,Kdg)
5502!^
5503 grid(dg)%ad_z_r(idgp1,jdgp1,kdg)= &
5504 & grid(dg)%ad_z_r(idgp1,jdgp1,kdg)+ &
5505 & ad_zd(3,kdg,m)
5506 ad_zd(3,kdg,m)=0.0_r8
5507!^ tl_Zd(4,Kdg,m)=GRID(dg)%tl_z_r(Idg ,Jdgp1,Kdg)
5508!^
5509 grid(dg)%ad_z_r(idg ,jdgp1,kdg)= &
5510 & grid(dg)%ad_z_r(idg ,jdgp1,kdg)+ &
5511 & ad_zd(4,kdg,m)
5512 ad_zd(4,kdg,m)=0.0_r8
5513 END IF
5514 END DO
5515 END DO
5516 END IF r_contact
5517
5518# ifdef DISTRIBUTE
5519!
5520! If distributed-memory, initialize with special value (zero) to
5521! facilitate the global reduction when collecting data between all
5522! nodes.
5523!
5524!^ Rcontact(cr)%tl_Vweight(1:2,1:N(rg),1:Npoints)=0.0_r8
5525!^
5526 rcontact(cr)%ad_Vweight(1:2,1:n(rg),1:npoints)=0.0_r8
5527# endif
5528!
5529! Deallocate local work arrays.
5530!
5531 IF (allocated(zd)) THEN
5532 deallocate (zd)
5533 END IF
5534 IF (allocated(ad_zd)) THEN
5535 deallocate (ad_zd)
5536 END IF
5537
5538 END IF
5539
5540 END DO
5541
5542 RETURN
5543
5544 END SUBROUTINE ad_z_weights
5545# endif
5546
5547# ifdef SOLVE3D
5548!
5549 SUBROUTINE ad_put_contact3d (rg, model, tile, &
5550 & gtype, svname, &
5551 & cr, Npoints, contact, &
5552 & LBi, UBi, LBj, UBj, LBk, UBk, &
5553# ifdef MASKING
5554 & Amask, &
5555# endif
5556 & Ac, ad_Ac, ad_Ar)
5557!
5558!=======================================================================
5559! !
5560! This routine uses extracted donor grid data (Ac) to spatially !
5561! interpolate a 3D state variable at the receiver grid contact !
5562! points. If the donor and receiver grids are concident, the !
5563! Lweight(1,:) is unity and Lweight(2:4,:) are zero. !
5564! !
5565! On Input: !
5566! !
5567! rg Receiver grid number (integer) !
5568! model Calling model identifier (integer) !
5569! tile Domain tile partition (integer) !
5570! gtype C-grid variable type (integer) !
5571! svname State variable name (string) !
5572! cr Contact region number to process (integer) !
5573! Npoints Number of points in the contact region (integer) !
5574! contact Contact region information variables (T_NGC structure)!
5575! LBi Receiver grid, I-dimension Lower bound (integer) !
5576! UBi Receiver grid, I-dimension Upper bound (integer) !
5577! LBj Receiver grid, J-dimension Lower bound (integer) !
5578! UBj Receiver grid, J-dimension Upper bound (integer) !
5579! LBk Receiver grid, K-dimension Lower bound (integer) !
5580! UBk Receiver grid, K-dimension Upper bound (integer) !
5581# ifdef MASKING
5582! Amask Receiver grid land/sea masking !
5583# endif
5584! Ac Contact point data extracted from donor grid !
5585! !
5586! On Output: !
5587! !
5588! Ar Updated receiver grid 3D state array !
5589! !
5590!=======================================================================
5591!
5592 USE mod_param
5593 USE mod_ncparam
5594 USE mod_nesting
5595!
5596! Imported variable declarations.
5597!
5598 integer, intent(in) :: rg, model, tile
5599 integer, intent(in) :: gtype, cr, Npoints
5600 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
5601!
5602 character(len=*), intent(in) :: svname
5603!
5604 TYPE (T_NGC), intent(inout) :: contact(:)
5605!
5606# ifdef ASSUMED_SHAPE
5607 real(r8), intent(in) :: Ac(:,:,:)
5608 real(r8), intent(inout) :: ad_Ac(:,:,:)
5609# ifdef MASKING
5610 real(r8), intent(in) :: Amask(LBi:,LBj:)
5611# endif
5612 real(r8), intent(inout) :: ad_Ar(LBi:,LBj:,LBk:)
5613# else
5614 real(r8), intent(in) :: Ac(Npoints,LBk:UBk,4)
5615 real(r8), intent(inout) :: ad_Ac(Npoints,LBk:UBk,4)
5616# ifdef MASKING
5617 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
5618# endif
5619 real(r8), intent(inout) :: ad_Ar(LBi:UBi,LBj:UBj,LBk:UBk)
5620# endif
5621!
5622! Local variable declarations.
5623!
5624 integer :: i, j, k, kdg, kdgm1, m, ii
5625 integer :: Istr, Iend, Jstr, Jend, Kmin
5626
5627 real(r8), dimension(8) :: cff
5628 real(r8), dimension(8) :: ad_cff
5629!
5630! Clear adjoint constants.
5631!
5632 DO ii=1,8
5633 ad_cff(ii)=0.0_r8
5634 END DO
5635!
5636!
5637!-----------------------------------------------------------------------
5638! Interpolate 3D data from donor grid to receiver grid contact points.
5639!-----------------------------------------------------------------------
5640!
5641! Set starting and ending tile indices for the receiver grid.
5642!
5643 SELECT CASE (gtype)
5644 CASE (r3dvar)
5645 istr=bounds(rg) % IstrT(tile)
5646 iend=bounds(rg) % IendT(tile)
5647 jstr=bounds(rg) % JstrT(tile)
5648 jend=bounds(rg) % JendT(tile)
5649 kmin=1
5650 CASE (u3dvar)
5651 istr=bounds(rg) % IstrP(tile)
5652 iend=bounds(rg) % IendT(tile)
5653 jstr=bounds(rg) % JstrT(tile)
5654 jend=bounds(rg) % JendT(tile)
5655 kmin=1
5656 CASE (v3dvar)
5657 istr=bounds(rg) % IstrT(tile)
5658 iend=bounds(rg) % IendT(tile)
5659 jstr=bounds(rg) % JstrP(tile)
5660 jend=bounds(rg) % JendT(tile)
5661 kmin=1
5662 CASE (w3dvar)
5663 istr=bounds(rg) % IstrT(tile)
5664 iend=bounds(rg) % IendT(tile)
5665 jstr=bounds(rg) % JstrT(tile)
5666 jend=bounds(rg) % JendT(tile)
5667 kmin=0
5668 END SELECT
5669!
5670! Interpolate.
5671!
5672 DO k=lbk,ubk
5673 DO m=1,npoints
5674 i=contact(cr)%Irg(m)
5675 j=contact(cr)%Jrg(m)
5676 kdg=contact(cr)%Kdg(k,m)
5677 kdgm1=max(kdg-1,kmin)
5678 IF (((istr.le.i).and.(i.le.iend)).and. &
5679 & ((jstr.le.j).and.(j.le.jend))) THEN
5680 cff(1)=contact(cr)%Lweight(1,m)*contact(cr)%Vweight(1,k,m)
5681 cff(2)=contact(cr)%Lweight(2,m)*contact(cr)%Vweight(1,k,m)
5682 cff(3)=contact(cr)%Lweight(3,m)*contact(cr)%Vweight(1,k,m)
5683 cff(4)=contact(cr)%Lweight(4,m)*contact(cr)%Vweight(1,k,m)
5684 cff(5)=contact(cr)%Lweight(1,m)*contact(cr)%Vweight(2,k,m)
5685 cff(6)=contact(cr)%Lweight(2,m)*contact(cr)%Vweight(2,k,m)
5686 cff(7)=contact(cr)%Lweight(3,m)*contact(cr)%Vweight(2,k,m)
5687 cff(8)=contact(cr)%Lweight(4,m)*contact(cr)%Vweight(2,k,m)
5688!
5689# ifdef MASKING
5690!^ tl_Ar(i,j,k)=tl_Ar(i,j,k)*Amask(i,j)
5691!^
5692 ad_ar(i,j,k)=ad_ar(i,j,k)*amask(i,j)
5693# endif
5694!^ tl_Ar(i,j,k)=tl_cff(1)*Ac(1,kdgm1,m)+ &
5695!^ & cff(1)*tl_Ac(1,kdgm1,m)+ &
5696!^ & tl_cff(2)*Ac(2,kdgm1,m)+ &
5697!^ & cff(2)*tl_Ac(2,kdgm1,m)+ &
5698!^ & tl_cff(3)*Ac(3,kdgm1,m)+ &
5699!^ & cff(3)*tl_Ac(3,kdgm1,m)+ &
5700!^ & tl_cff(4)*Ac(4,kdgm1,m)+ &
5701!^ & cff(4)*tl_Ac(4,kdgm1,m)+ &
5702!^ & tl_cff(5)*Ac(1,kdg ,m)+ &
5703!^ & cff(5)*tl_Ac(1,kdg ,m)+ &
5704!^ & tl_cff(6)*Ac(2,kdg ,m)+ &
5705!^ & cff(6)*tl_Ac(2,kdg ,m)+ &
5706!^ & tl_cff(7)*Ac(3,kdg ,m)+ &
5707!^ & cff(7)*tl_Ac(3,kdg ,m)+ &
5708!^ & tl_cff(8)*Ac(4,kdg ,m)+ &
5709!^ & cff(8)*tl_Ac(4,kdg ,m)
5710!^
5711 ad_cff(1)=ad_cff(1)+ac(1,kdgm1,m)*ad_ar(i,j,k)
5712 ad_cff(2)=ad_cff(2)+ac(2,kdgm1,m)*ad_ar(i,j,k)
5713 ad_cff(3)=ad_cff(3)+ac(3,kdgm1,m)*ad_ar(i,j,k)
5714 ad_cff(4)=ad_cff(4)+ac(4,kdgm1,m)*ad_ar(i,j,k)
5715 ad_cff(5)=ad_cff(5)+ac(1,kdg ,m)*ad_ar(i,j,k)
5716 ad_cff(6)=ad_cff(6)+ac(2,kdg ,m)*ad_ar(i,j,k)
5717 ad_cff(7)=ad_cff(7)+ac(3,kdg ,m)*ad_ar(i,j,k)
5718 ad_cff(8)=ad_cff(8)+ac(4,kdg ,m)*ad_ar(i,j,k)
5719
5720 ad_ac(1,kdgm1,m)=ad_ac(1,kdgm1,m)+cff(1)*ad_ar(i,j,k)
5721 ad_ac(2,kdgm1,m)=ad_ac(2,kdgm1,m)+cff(2)*ad_ar(i,j,k)
5722 ad_ac(3,kdgm1,m)=ad_ac(3,kdgm1,m)+cff(3)*ad_ar(i,j,k)
5723 ad_ac(4,kdgm1,m)=ad_ac(4,kdgm1,m)+cff(4)*ad_ar(i,j,k)
5724 ad_ac(1,kdg ,m)=ad_ac(1,kdg ,m)+cff(5)*ad_ar(i,j,k)
5725 ad_ac(2,kdg ,m)=ad_ac(2,kdg ,m)+cff(6)*ad_ar(i,j,k)
5726 ad_ac(3,kdg ,m)=ad_ac(3,kdg ,m)+cff(7)*ad_ar(i,j,k)
5727 ad_ac(4,kdg ,m)=ad_ac(4,kdg ,m)+cff(8)*ad_ar(i,j,k)
5728
5729 ad_ar(i,j,k)=0.0_r8
5730
5731!^ tl_cff(1)=contact(cr)%Lweight(1,m)* &
5732!^ & contact(cr)%tl_Vweight(1,k,m)
5733!^ tl_cff(2)=contact(cr)%Lweight(2,m)* &
5734!^ & contact(cr)%tl_Vweight(1,k,m)
5735!^ tl_cff(3)=contact(cr)%Lweight(3,m)* &
5736!^ & contact(cr)%tl_Vweight(1,k,m)
5737!^ tl_cff(4)=contact(cr)%Lweight(4,m)* &
5738!^ & contact(cr)%tl_Vweight(1,k,m)
5739!^ tl_cff(5)=contact(cr)%Lweight(1,m)* &
5740!^ & contact(cr)%tl_Vweight(2,k,m)
5741!^ tl_cff(6)=contact(cr)%Lweight(2,m)* &
5742!^ & contact(cr)%tl_Vweight(2,k,m)
5743!^ tl_cff(7)=contact(cr)%Lweight(3,m)* &
5744!^ & contact(cr)%tl_Vweight(2,k,m)
5745!^ tl_cff(8)=contact(cr)%Lweight(4,m)* &
5746!^ & contact(cr)%tl_Vweight(2,k,m)
5747!^
5748 contact(cr)%ad_Vweight(1,k,m)= &
5749 & contact(cr)%ad_Vweight(1,k,m)+ &
5750 & contact(cr)%Lweight(1,m)*ad_cff(1)+ &
5751 & contact(cr)%Lweight(2,m)*ad_cff(2)+ &
5752 & contact(cr)%Lweight(3,m)*ad_cff(3)+ &
5753 & contact(cr)%Lweight(4,m)*ad_cff(4)
5754 ad_cff(1)=0.0_r8
5755 ad_cff(2)=0.0_r8
5756 ad_cff(3)=0.0_r8
5757 ad_cff(4)=0.0_r8
5758
5759 contact(cr)%ad_Vweight(2,k,m)= &
5760 contact(cr)%ad_Vweight(2,k,m)+ &
5761 & contact(cr)%Lweight(1,m)*ad_cff(5)+ &
5762 & contact(cr)%Lweight(2,m)*ad_cff(6)+ &
5763 & contact(cr)%Lweight(3,m)*ad_cff(7)+ &
5764 & contact(cr)%Lweight(4,m)*ad_cff(8)
5765 ad_cff(5)=0.0_r8
5766 ad_cff(6)=0.0_r8
5767 ad_cff(7)=0.0_r8
5768 ad_cff(8)=0.0_r8
5769 END IF
5770 END DO
5771 END DO
5772
5773 RETURN
5774 END SUBROUTINE ad_put_contact3d
5775# endif
5776!
5777 SUBROUTINE ad_put_contact2d (rg, model, tile, &
5778 & gtype, svname, &
5779 & cr, Npoints, contact, &
5780 & LBi, UBi, LBj, UBj, &
5781# ifdef MASKING
5782 & Amask, &
5783# endif
5784 & Ac, Ar)
5785!
5786!=======================================================================
5787! !
5788! This routine uses extracted donor grid data (Ac) to spatially !
5789! interpolate a 2D state variable at the receiver grid contact !
5790! points. If the donor and receiver grids are coincident, the !
5791! Lweight(1,:) is unity and Lweight(2:4,:) are zero. !
5792! !
5793! On Input: !
5794! !
5795! rg Receiver grid number (integer) !
5796! model Calling model identifier (integer) !
5797! tile Domain tile partition (integer) !
5798! gtype C-grid variable type (integer) !
5799! svname State variable name (string) !
5800! cr Contact region number to process (integer) !
5801! Npoints Number of points in the contact region (integer) !
5802! contact Contact region information variables (T_NGC structure)!
5803! LBi Receiver grid, I-dimension Lower bound (integer) !
5804! UBi Receiver grid, I-dimension Upper bound (integer) !
5805! LBj Receiver grid, J-dimension Lower bound (integer) !
5806! UBj Receiver grid, J-dimension Upper bound (integer) !
5807# ifdef MASKING
5808! Amask Receiver grid land/sea masking !
5809# endif
5810! Ac Contact point data extracted from donor grid !
5811! !
5812! On Output: !
5813! !
5814! Ar Updated receiver grid 2D state array !
5815! !
5816!=======================================================================
5817!
5818 USE mod_param
5819 USE mod_ncparam
5820 USE mod_nesting
5821!
5822! Imported variable declarations.
5823!
5824 integer, intent(in) :: rg, model, tile
5825 integer, intent(in) :: gtype, cr, Npoints
5826 integer, intent(in) :: LBi, UBi, LBj, UBj
5827!
5828 character(len=*), intent(in) :: svname
5829!
5830 TYPE (T_NGC), intent(in) :: contact(:)
5831!
5832# ifdef ASSUMED_SHAPE
5833 real(r8), intent(inout) :: Ac(:,:)
5834# ifdef MASKING
5835 real(r8), intent(in) :: Amask(LBi:,LBj:)
5836# endif
5837 real(r8), intent(inout) :: Ar(LBi:,LBj:)
5838# else
5839 real(r8), intent(inout) :: Ac(4,Npoints)
5840# ifdef MASKING
5841 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
5842# endif
5843 real(r8), intent(inout) :: Ar(LBi:UBi,LBj:UBj)
5844# endif
5845!
5846! Local variable declarations.
5847!
5848 integer :: i, j, m, ii
5849 integer :: Istr, Iend, Jstr, Jend
5850!
5851!-----------------------------------------------------------------------
5852! Interpolate 2D data from donor grid to receiver grid contact points.
5853!-----------------------------------------------------------------------
5854!
5855! Set starting and ending tile indices for the receiver grid.
5856!
5857 SELECT CASE (gtype)
5858 CASE (r2dvar)
5859 istr=bounds(rg) % IstrT(tile)
5860 iend=bounds(rg) % IendT(tile)
5861 jstr=bounds(rg) % JstrT(tile)
5862 jend=bounds(rg) % JendT(tile)
5863 CASE (u2dvar)
5864 istr=bounds(rg) % IstrP(tile)
5865 iend=bounds(rg) % IendT(tile)
5866 jstr=bounds(rg) % JstrT(tile)
5867 jend=bounds(rg) % JendT(tile)
5868 CASE (v2dvar)
5869 istr=bounds(rg) % IstrT(tile)
5870 iend=bounds(rg) % IendT(tile)
5871 jstr=bounds(rg) % JstrP(tile)
5872 jend=bounds(rg) % JendT(tile)
5873 END SELECT
5874!
5875! Interpolate.
5876!
5877 DO m=1,npoints
5878 i=contact(cr)%Irg(m)
5879 j=contact(cr)%Jrg(m)
5880 IF (((istr.le.i).and.(i.le.iend)).and. &
5881 & ((jstr.le.j).and.(j.le.jend))) THEN
5882# ifdef MASKING
5883 ar(i,j)=ar(i,j)*amask(i,j)
5884# endif
5885!^ Ar(i,j)=contact(cr)%Lweight(1,m)*Ac(1,m)+ &
5886!^ & contact(cr)%Lweight(2,m)*Ac(2,m)+ &
5887!^ & contact(cr)%Lweight(3,m)*Ac(3,m)+ &
5888!^ & contact(cr)%Lweight(4,m)*Ac(4,m)
5889!^
5890 DO ii=1,4
5891 ac(ii,m)=ac(ii,m)+contact(cr)%Lweight(ii,m)*ar(i,j)
5892 END DO
5893 ar(i,j)=0.0_r8
5894 END IF
5895 END DO
5896
5897 RETURN
5898 END SUBROUTINE ad_put_contact2d
5899!
5900 SUBROUTINE ad_fine2coarse2d (ng, dg, model, tile, &
5901 & gtype, svname, &
5902 & AreaAvg, Rscale, &
5903 & cr, Npoints, contact, &
5904 & LBiF, UBiF, LBjF, UBjF, &
5905 & LBiC, UBiC, LBjC, UBjC, &
5906# ifdef DISTRIBUTE
5907 & Adx, Ady, &
5908# else
5909 & dxF, dyF, &
5910# endif
5911 & pmC, pnC, &
5912# ifdef MASKING
5913# ifdef DISTRIBUTE
5914 & Amsk, &
5915# else
5916 & Fmsk, &
5917# endif
5918 & Cmsk, &
5919# endif
5920# ifdef DISTRIBUTE
5921 & A, &
5922# else
5923 & F, &
5924# endif
5925 & C1, C2)
5926!
5927!=======================================================================
5928! !
5929! This routine replaces the coarse grid data inside the refinement !
5930! grid interior for a 2D state variable with its refined averaged !
5931! values: two-way nesting. !
5932! !
5933! On Input: !
5934! !
5935! ng Coarser grid number (integer) !
5936! dg Finer grid number (integer) !
5937! model Calling model identifier (integer) !
5938! tile Domain tile partition (integer) !
5939! gtype C-grid variable type (integer) !
5940! svname State variable name (string) !
5941! AreaAvg Switch for area averaging (logical) !
5942! Rscale Refinement grid scale (integer) !
5943! cr Contact region number to process (integer) !
5944! Npoints Number of points in the contact zone (integer) !
5945! contact Contact zone information variables (T_NGC structure) !
5946! LBiF Finer grid, I-dimension Lower bound (integer) !
5947! UBiF Finer grid, I-dimension Upper bound (integer) !
5948! LBjF Finer grid, J-dimension Lower bound (integer) !
5949! UBjF Finer grid, J-dimension Upper bound (integer) !
5950! LBiC Coarser grid, I-dimension Lower bound (integer) !
5951! UBiC Coarser grid, I-dimension Upper bound (integer) !
5952! LBjC Coarser grid, J-dimension Lower bound (integer) !
5953! UBjC Coarser grid, J-dimension Upper bound (integer) !
5954# ifdef DISTRIBUTE
5955! Adx Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
5956! Ady Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
5957# else
5958! dxF Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
5959! dyF Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
5960# endif
5961! pmC Coarser grid, inverse X-grid spacing (1/dx) at RHO !
5962! pnC Coarser grid, inverse Y-grid spacing (1/dy) at RHO !
5963# ifdef MASKING
5964# ifdef DISTRIBUTE
5965! Amsk Finer grid land/sea masking (2D array) !
5966# else
5967! Fmsk Finer grid land/sea masking (2D array) !
5968# endif
5969! Cmsk Coarser grid land/sea masking (2D array) !
5970# endif
5971# ifdef DISTRIBUTE
5972! A Finer grid 2D data !
5973# else
5974! F Finer grid 2D data !
5975# endif
5976! C1 Coarser grid 2D data, record 1 !
5977! C2 Coarser grid 2D data, record 2 (OPTIONAL) !
5978! !
5979! On Output: (mod_nesting) !
5980! !
5981! C1 Updated Coarser grid 2D data, record 1 !
5982! C2 Uodated Coarser grid 2D data, record 2 (OPTIONAL) !
5983! !
5984!=======================================================================
5985!
5986 USE mod_param
5987 USE mod_ncparam
5988 USE mod_nesting
5989 USE mod_scalars
5990
5991# ifdef DISTRIBUTE
5992!
5993 USE distribute_mod, ONLY : mp_aggregate2d
5994# endif
5995 USE strings_mod, ONLY : founderror
5996!
5997! Imported variable declarations.
5998!
5999 logical, intent(in) :: areaavg
6000 integer, intent(in) :: ng, dg, model, tile
6001 integer, intent(in) :: gtype, cr, npoints, rscale
6002 integer, intent(in) :: lbif, ubif, lbjf, ubjf
6003 integer, intent(in) :: lbic, ubic, lbjc, ubjc
6004!
6005 character(len=*), intent(in) :: svname
6006!
6007 TYPE (t_ngc), intent(in) :: contact(:)
6008!
6009# ifdef ASSUMED_SHAPE
6010 real(r8), intent(in) :: pmc(lbic:,lbjc:)
6011 real(r8), intent(in) :: pnc(lbic:,lbjc:)
6012# ifdef MASKING
6013 real(r8), intent(in) :: cmsk(lbic:,lbjc:)
6014# ifdef DISTRIBUTE
6015 real(r8), intent(in) :: amsk(lbif:,lbjf:)
6016# else
6017 real(r8), intent(in) :: fmsk(lbif:,lbjf:)
6018# endif
6019# endif
6020# ifdef DISTRIBUTE
6021 real(r8), intent(inout) :: a(lbif:,lbjf:)
6022 real(r8), intent(in) :: adx(lbif:,lbjf:)
6023 real(r8), intent(in) :: ady(lbif:,lbjf:)
6024# else
6025 real(r8), intent(inout) :: f(lbif:,lbjf:)
6026 real(r8), intent(in) :: dxf(lbif:,lbjf:)
6027 real(r8), intent(in) :: dyf(lbif:,lbjf:)
6028# endif
6029 real(r8), intent(inout) :: c1(lbic:,lbjc:)
6030 real(r8), intent(inout), optional :: c2(lbic:,lbjc:)
6031# else
6032 real(r8), intent(in) :: pmc(lbic:ubic,lbjc:ubjc)
6033 real(r8), intent(in) :: pnc(lbic:ubic,lbjc:ubjc)
6034# ifdef MASKING
6035 real(r8), intent(in) :: cmsk(lbic:ubic,lbjc:ubjc)
6036# ifdef DISTRIBUTE
6037 real(r8), intent(in) :: amsk(lbif:ubif,lbjf:ubjf)
6038# else
6039 real(r8), intent(in) :: fmsk(lbif:ubif,lbjf:ubjf)
6040# endif
6041# endif
6042# ifdef DISTRIBUTE
6043 real(r8), intent(inout) :: a(lbif:ubif,lbjf:ubjf)
6044 real(r8), intent(in) :: adx(lbif:ubif,lbjf:ubjf)
6045 real(r8), intent(in) :: adx(lbif:ubif,lbjf:ubjf)
6046# else
6047 real(r8), intent(inout) :: f(lbif:ubif,lbjf:ubjf)
6048 real(r8), intent(in) :: dxf(lbif:ubif,lbjf:ubjf)
6049 real(r8), intent(in) :: dyf(lbif:ubif,lbjf:ubjf)
6050# endif
6051 real(r8), intent(inout) :: c1(lbic:ubic,lbjc:ubjc)
6052 real(r8), intent(inout), optional :: c2(lbic:ubic,lbjc:ubjc)
6053# endif
6054!
6055! Local variable declarations.
6056!
6057 integer :: iadd, ic, jadd, jc, half, i, j, m
6058# ifdef DISTRIBUTE
6059 integer :: lbi, ubi, lbj, ubj
6060# endif
6061
6062 real(r8) :: areac_inv, my_area, my_areasum, ratio
6063 real(r8) :: my_avg, my_count, my_sum
6064
6065# ifdef DISTRIBUTE
6066 real(r8), allocatable :: f(:,:)
6067 real(r8), allocatable :: dxf(:,:)
6068 real(r8), allocatable :: dyf(:,:)
6069# ifdef MASKING
6070 real(r8), allocatable :: fmsk(:,:)
6071# endif
6072# endif
6073!
6074 character (len=*), parameter :: myfile = &
6075 & __FILE__//", ad_fine2coarse2d"
6076
6077# include "set_bounds.h"
6078!
6079!-----------------------------------------------------------------------
6080! Average interior fine grid state variable data to the coarse grid
6081! location. Then, replace coarse grid values with averaged data.
6082!-----------------------------------------------------------------------
6083!
6084! Clear constants.
6085!
6086 my_avg=0.0_r8
6087 my_sum=0.0_r8
6088 my_count=0.0_r8
6089 my_area=0.0_r8
6090 my_areasum=0.0_r8
6091
6092# ifdef DISTRIBUTE
6093!
6094! Allocate global work array(s).
6095!
6096 lbi=bounds(dg)%LBi(-1)
6097 ubi=bounds(dg)%UBi(-1)
6098 lbj=bounds(dg)%LBj(-1)
6099 ubj=bounds(dg)%UBj(-1)
6100 IF (.not.allocated(f)) THEN
6101 allocate ( f(lbi:ubi,lbj:ubj) )
6102 END IF
6103 IF (areaavg) THEN
6104 IF (.not.allocated(dxf)) THEN
6105 allocate ( dxf(lbi:ubi,lbj:ubj) )
6106 END IF
6107 IF (.not.allocated(dyf)) THEN
6108 allocate ( dyf(lbi:ubi,lbj:ubj) )
6109 END IF
6110 END IF
6111# ifdef MASKING
6112 IF (.not.allocated(fmsk)) THEN
6113 allocate ( fmsk(lbi:ubi,lbj:ubj) )
6114 END IF
6115# endif
6116!
6117! Gather finer grid data from all nodes in the group to build a global
6118! array.
6119!
6120 IF (areaavg) THEN
6121 CALL mp_aggregate2d (dg, model, gtype, &
6122 & lbif, ubif, lbjf, ubjf, &
6123 & lbi, ubi, lbj, ubj, &
6124 & adx, dxf)
6125 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6126!
6127 CALL mp_aggregate2d (dg, model, gtype, &
6128 & lbif, ubif, lbjf, ubjf, &
6129 & lbi, ubi, lbj, ubj, &
6130 & ady, dyf)
6131 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6132 END IF
6133# ifdef MASKING
6134!
6135 CALL mp_aggregate2d (dg, model, gtype, &
6136 & lbif, ubif, lbjf, ubjf, &
6137 & lbi, ubi, lbj, ubj, &
6138 & amsk, fmsk)
6139 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6140# endif
6141# endif
6142
6143!
6144! Average finer grid data to coarse grid according to the refinement
6145! ratio.
6146!
6147 half=(rscale-1)/2
6148 IF (areaavg) THEN ! area averaging
6149 DO m=1,npoints
6150 i=contact(cr)%Idg(m)
6151 j=contact(cr)%Jdg(m)
6152 ic=contact(cr)%Irg(m)
6153 jc=contact(cr)%Jrg(m)
6154 IF (((istr.le.ic).and.(ic.le.iend)).and. &
6155 & ((jstr.le.jc).and.(jc.le.jend))) THEN
6156 my_count=0.0_r8
6157# ifdef MASKING
6158 DO jadd=-half,half
6159 DO iadd=-half,half
6160 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
6161 END DO
6162 END DO
6163# endif
6164 SELECT CASE (gtype) ! coarse grid inverse area
6165 CASE (r2dvar)
6166 areac_inv=pmc(ic,jc)*pnc(ic,jc)
6167 CASE (u2dvar)
6168 areac_inv=0.25_r8*(pmc(ic-1,jc)+pmc(ic,jc))* &
6169 & (pnc(ic-1,jc)+pnc(ic,jc))
6170 CASE (v2dvar)
6171 areac_inv=0.25_r8*(pmc(ic,jc-1)+pmc(ic,jc))* &
6172 & (pnc(ic,jc-1)+pnc(ic,jc))
6173 CASE DEFAULT
6174 areac_inv=pmc(ic,jc)*pnc(ic,jc)
6175 END SELECT
6176 IF (PRESENT(c2)) THEN
6177!^ C2(Ic,Jc)=my_avg
6178 my_avg=my_avg+c2(ic,jc)
6179 c2(ic,jc)=0.0_r8
6180 END IF
6181!^ C1(Ic,Jc)=my_avg
6182 my_avg=my_avg+c1(ic,jc)
6183 c1(ic,jc)=0.0_r8
6184# ifdef MASKING
6185 my_avg=my_avg*cmsk(ic,jc)
6186 IF (my_count.gt.0.0_r8) THEN
6187 my_avg=my_avg*rscale*rscale/my_count
6188 END IF
6189# endif
6190!^ my_avg=my_sum*areaC_inv
6191
6192 my_sum=my_sum+areac_inv*my_avg
6193 my_avg=0.0_r8
6194
6195!! ratio=my_areasum*areaC_inv ! for debugging purposes
6196
6197
6198 DO jadd=-half,half
6199 DO iadd=-half,half
6200 my_area=dxf(i+iadd,j+jadd)*dyf(i+iadd,j+jadd)
6201 my_areasum=my_areasum+my_area
6202# ifdef MASKING
6203!^ my_sum=my_sum+ &
6204!^ & F(i+Iadd,j+Jadd)*my_area* &
6205!^ & MIN(1.0_r8,Fmsk(i+Iadd,j+Jadd))
6206 f(i+iadd,j+jadd)=f(i+iadd,j+jadd)+my_area* &
6207 & min(1.0_r8,fmsk(i+iadd,j+jadd))*my_sum
6208# else
6209!^ my_sum=my_sum+ &
6210!^ & F(i+Iadd,j+Jadd)*my_area
6211 f(i+iadd,j+jadd)=f(i+iadd,j+jadd)+my_area*my_sum
6212# endif
6213 END DO
6214 END DO
6215 my_sum=0.0_r8
6216 my_areasum=0.0_r8
6217 END IF
6218 END DO
6219 ELSE ! simple averaging
6220 DO m=1,npoints
6221 i=contact(cr)%Idg(m)
6222 j=contact(cr)%Jdg(m)
6223 ic=contact(cr)%Irg(m)
6224 jc=contact(cr)%Jrg(m)
6225 IF (((istr.le.ic).and.(ic.le.iend)).and. &
6226 & ((jstr.le.jc).and.(jc.le.jend))) THEN
6227!
6228! Compute my_count first.
6229!
6230 my_count=0.0_r8
6231 DO jadd=-half,half
6232 DO iadd=-half,half
6233# ifdef MASKING
6234 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
6235# else
6236 my_count=my_count+1.0_r8
6237# endif
6238 END DO
6239 END DO
6240 IF (PRESENT(c2)) THEN
6241!^ C2(Ic,Jc)=my_avg
6242 my_avg=my_avg+c2(ic,jc)
6243 c2(ic,jc)=0.0_r8
6244 END IF
6245 my_avg=my_avg+c1(ic,jc)
6246 c1(ic,jc)=0.0_r8
6247# ifdef MASKING
6248 my_avg=my_avg*cmsk(ic,jc)
6249# endif
6250 IF (my_count.gt.0.0_r8) THEN
6251!^ my_avg=my_sum/my_count
6252 my_sum=my_sum+my_avg/my_count
6253 my_avg=0.0_r8
6254 END IF
6255 DO jadd=-half,half
6256 DO iadd=-half,half
6257# ifdef MASKING
6258!^ my_sum=my_sum+ &
6259!^ & F(i+Iadd,j+Jadd)*Fmsk(i+Iadd,j+Jadd)
6260 f(i+iadd,j+jadd)=f(i+iadd,j+jadd)+fmsk(i+iadd,j+jadd)* &
6261 & my_sum
6262# else
6263!^ my_sum=my_sum+ &
6264!^ & F(i+Iadd,j+Jadd)
6265 f(i+iadd,j+jadd)=f(i+iadd,j+jadd)+my_sum
6266# endif
6267 END DO
6268 END DO
6269 my_sum=0.0_r8
6270 END IF
6271 END DO
6272 END IF
6273
6274# ifdef DISTRIBUTE
6275
6276!AMM
6277!
6278! This next loop represents the adjoint of mp_aggregate2d.
6279!
6280 DO j=lbjf,ubjf
6281 DO i=lbif,ubif
6282 a(i,j)=a(i,j)+f(i,j)
6283 f(i,j)=0.0_r8
6284 END DO
6285 END DO
6286!
6287!AMM
6288!
6289
6290!
6291! Deallocate work array.
6292!
6293 IF (allocated(f)) THEN
6294 deallocate (f)
6295 END IF
6296 IF (areaavg) THEN
6297 IF (allocated(dxf)) THEN
6298 deallocate (dxf)
6299 END IF
6300 IF (allocated(dyf)) THEN
6301 deallocate (dyf)
6302 END IF
6303 END IF
6304# ifdef MASKING
6305 IF (allocated(fmsk)) THEN
6306 deallocate (fmsk)
6307 END IF
6308# endif
6309# endif
6310
6311 RETURN
6312 END SUBROUTINE ad_fine2coarse2d
6313!
6314# ifdef SOLVE3D
6315 SUBROUTINE ad_fine2coarse3d (ng, dg, model, tile, &
6316 & gtype, svname, &
6317 & AreaAvg, Rscale, &
6318 & cr, Npoints, contact, &
6319 & LBiF, UBiF, LBjF, UBjF, LBkF, UBkF, &
6320 & LBiC, UBiC, LBjC, UBjC, LBkC, UBkC, &
6321# ifdef DISTRIBUTE
6322 & Adx, Ady, &
6323# else
6324 & dxF, dyF, &
6325# endif
6326 & pmC, pnC, &
6327# ifdef MASKING
6328# ifdef DISTRIBUTE
6329 & Amsk, &
6330# else
6331 & Fmsk, &
6332# endif
6333 & Cmsk, &
6334# endif
6335# ifdef DISTRIBUTE
6336 & A, &
6337# else
6338 & F, &
6339# endif
6340 & C)
6341!
6342!=======================================================================
6343! !
6344! This routine replaces the coarse grid data inside the refinement !
6345! grid interior for a 3D state variable with its refined averaged !
6346! values: two-way nesting. !
6347! !
6348! On Input: !
6349! !
6350! ng Coarser grid number (integer) !
6351! dg Finer grid number (integer) !
6352! model Calling model identifier (integer) !
6353! tile Domain tile partition (integer) !
6354! gtype C-grid variable type (integer) !
6355! svname State variable name (string) !
6356! AreaAvg Switch for area averaging (logical) !
6357! Rscale Refinement grid scale (integer) !
6358! cr Contact region number to process (integer) !
6359! Npoints Number of points in the contact zone (integer) !
6360! contact Contact zone information variables (T_NGC structure) !
6361! LBiF Finer grid, I-dimension Lower bound (integer) !
6362! UBiF Finer grid, I-dimension Upper bound (integer) !
6363! LBjF Finer grid, J-dimension Lower bound (integer) !
6364! UBjF Finer grid, J-dimension Upper bound (integer) !
6365! LBkF Finer grid, K-dimension Lower bound (integer) !
6366! UBkF Finer grid, K-dimension Upper bound (integer) !
6367! LBiC Coarser grid, I-dimension Lower bound (integer) !
6368! UBiC Coarser grid, I-dimension Upper bound (integer) !
6369! LBjC Coarser grid, J-dimension Lower bound (integer) !
6370! UBjC Coarser grid, J-dimension Upper bound (integer) !
6371! LBkC Coarser grid, K-dimension Lower bound (integer) !
6372! UBkC Coarser grid, K-dimension Upper bound (integer) !
6373# ifdef DISTRIBUTE
6374! Adx Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
6375! Ady Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
6376# else
6377! dxF Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
6378! dyF Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
6379# endif
6380! pmC Coarser grid, inverse X-grid spacing (1/dx) at RHO !
6381! pnC Coarser grid, inverse Y-grid spacing (1/dy) at RHO !
6382# ifdef MASKING
6383# ifdef DISTRIBUTE
6384! Amsk Finer grid land/sea masking (2D array) !
6385# else
6386! Fmsk Finer grid land/sea masking (2D array) !
6387# endif
6388! Cmsk Coarser grid land/sea masking (2D array) !
6389# endif
6390# ifdef DISTRIBUTE
6391! A Finer grid 2D data !
6392# else
6393! F Finer grid 2D data !
6394# endif
6395! C Coarser grid 3D data !
6396! !
6397! On Output: (mod_nesting) !
6398! !
6399! C Updated Coarser grid 3D data !
6400! !
6401!=======================================================================
6402!
6403 USE mod_param
6404 USE mod_ncparam
6405 USE mod_nesting
6406 USE mod_scalars
6407!
6408# ifdef DISTRIBUTE
6409 USE distribute_mod, ONLY : mp_aggregate2d
6410 USE distribute_mod, ONLY : mp_aggregate3d
6411# endif
6412 USE strings_mod, ONLY : founderror
6413!
6414! Imported variable declarations.
6415!
6416 logical, intent(in) :: areaavg
6417 integer, intent(in) :: ng, dg, model, tile
6418 integer, intent(in) :: gtype, cr, npoints, rscale
6419 integer, intent(in) :: lbif, ubif, lbjf, ubjf, lbkf, ubkf
6420 integer, intent(in) :: lbic, ubic, lbjc, ubjc, lbkc, ubkc
6421!
6422 character(len=*), intent(in) :: svname
6423!
6424 TYPE (t_ngc), intent(in) :: contact(:)
6425!
6426# ifdef ASSUMED_SHAPE
6427 real(r8), intent(in) :: pmc(lbic:,lbjc:)
6428 real(r8), intent(in) :: pnc(lbic:,lbjc:)
6429# ifdef MASKING
6430 real(r8), intent(in) :: cmsk(lbic:,lbjc:)
6431# ifdef DISTRIBUTE
6432 real(r8), intent(in) :: amsk(lbif:,lbjf:)
6433# else
6434 real(r8), intent(in) :: fmsk(lbif:,lbjf:)
6435# endif
6436# endif
6437# ifdef DISTRIBUTE
6438 real(r8), intent(inout) :: a(lbif:,lbjf:,lbkf:)
6439 real(r8), intent(in) :: adx(lbif:,lbjf:)
6440 real(r8), intent(in) :: ady(lbif:,lbjf:)
6441# else
6442 real(r8), intent(inout) :: f(lbif:,lbjf:,lbkf:)
6443 real(r8), intent(in) :: dxf(lbif:,lbjf:)
6444 real(r8), intent(in) :: dyf(lbif:,lbjf:)
6445# endif
6446 real(r8), intent(inout) :: c(lbic:,lbjc:,lbkc:)
6447# else
6448 real(r8), intent(in) :: pmc(lbic:ubic,lbjc:ubjc)
6449 real(r8), intent(in) :: pnc(lbic:ubic,lbjc:ubjc)
6450# ifdef MASKING
6451 real(r8), intent(in) :: cmsk(lbic:ubic,lbjc:ubjc)
6452# ifdef DISTRIBUTE
6453 real(r8), intent(in) :: amsk(lbif:ubif,lbjf:ubjf)
6454# else
6455 real(r8), intent(in) :: fmsk(lbif:ubif,lbjf:ubjf)
6456# endif
6457# endif
6458# ifdef DISTRIBUTE
6459 real(r8), intent(inout) :: a(lbif:ubif,lbjf:ubjf,lbkf:ubkf)
6460 real(r8), intent(in) :: adx(lbif:ubif,lbjf:ubjf)
6461 real(r8), intent(in) :: adx(lbif:ubif,lbjf:ubjf)
6462# else
6463 real(r8), intent(inout) :: f(lbif:ubif,lbjf:ubjf,lbkf:ubkf)
6464 real(r8), intent(in) :: dxf(lbif:ubif,lbjf:ubjf)
6465 real(r8), intent(in) :: dyf(lbif:ubif,lbjf:ubjf)
6466# endif
6467 real(r8), intent(inout) :: c(lbic:ubic,lbjc:ubjc,lbkc:ubkc)
6468# endif
6469!
6470! Local variable declarations.
6471!
6472 integer :: iadd, ic, jadd, jc, half, i, j, k, m
6473# ifdef DISTRIBUTE
6474 integer :: lbi, ubi, lbj, ubj
6475# endif
6476
6477 real(r8) :: areac_inv, my_area, my_areasum, ratio
6478 real(r8) :: my_avg, my_count, my_sum
6479
6480# ifdef DISTRIBUTE
6481 real(r8), allocatable :: f(:,:,:)
6482 real(r8), allocatable :: dxf(:,:)
6483 real(r8), allocatable :: dyf(:,:)
6484# ifdef MASKING
6485 real(r8), allocatable :: fmsk(:,:)
6486# endif
6487# endif
6488!
6489 character (len=*), parameter :: myfile = &
6490 & __FILE__//", ad_fine2coarse3d"
6491
6492# include "set_bounds.h"
6493!
6494! Clear constants.
6495!
6496 my_area=0.0_r8
6497 my_areasum=0.0_r8
6498 my_avg=0.0_r8
6499 my_count=0.0_r8
6500 my_sum=0.0_r8
6501!
6502!-----------------------------------------------------------------------
6503! Average interior fine grid state variable data to the coarse grid
6504! location. Then, replace coarse grid values with averaged data.
6505!-----------------------------------------------------------------------
6506
6507# ifdef DISTRIBUTE
6508!
6509! Allocate global work array(s).
6510!
6511 lbi=bounds(dg)%LBi(-1)
6512 ubi=bounds(dg)%UBi(-1)
6513 lbj=bounds(dg)%LBj(-1)
6514 ubj=bounds(dg)%UBj(-1)
6515 IF (.not.allocated(f)) THEN
6516 allocate ( f(lbi:ubi,lbj:ubj,lbkf:ubkf) )
6517 END IF
6518 IF (areaavg) THEN
6519 IF (.not.allocated(dxf)) THEN
6520 allocate ( dxf(lbi:ubi,lbj:ubj) )
6521 END IF
6522 IF (.not.allocated(dyf)) THEN
6523 allocate ( dyf(lbi:ubi,lbj:ubj) )
6524 END IF
6525 END IF
6526# ifdef MASKING
6527 IF (.not.allocated(fmsk)) THEN
6528 allocate ( fmsk(lbi:ubi,lbj:ubj) )
6529 END IF
6530# endif
6531!
6532! Gather finer grid data from all nodes in the group to build a global
6533! array.
6534!
6535 IF (areaavg) THEN
6536 CALL mp_aggregate2d (dg, model, gtype, &
6537 & lbif, ubif, lbjf, ubjf, &
6538 & lbi, ubi, lbj, ubj, &
6539 & adx, dxf)
6540 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6541!
6542 CALL mp_aggregate2d (dg, model, gtype, &
6543 & lbif, ubif, lbjf, ubjf, &
6544 & lbi, ubi, lbj, ubj, &
6545 & ady, dyf)
6546 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6547 END IF
6548# ifdef MASKING
6549!
6550 CALL mp_aggregate2d (dg, model, gtype, &
6551 & lbif, ubif, lbjf, ubjf, &
6552 & lbi, ubi, lbj, ubj, &
6553 & amsk, fmsk)
6554 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6555# endif
6556# endif
6557!
6558! Average finer grid data to coarse grid according to the refinement
6559! ratio.
6560!
6561 half=(rscale-1)/2
6562 IF (areaavg) THEN ! area averaging
6563 DO k=lbkc,ubkc
6564 DO m=1,npoints
6565 i=contact(cr)%Idg(m)
6566 j=contact(cr)%Jdg(m)
6567 ic=contact(cr)%Irg(m)
6568 jc=contact(cr)%Jrg(m)
6569 IF (((istr.le.ic).and.(ic.le.iend)).and. &
6570 & ((jstr.le.jc).and.(jc.le.jend))) THEN
6571!
6572! Compute my_count first.
6573!
6574 my_count=0.0_r8
6575# ifdef MASKING
6576 DO jadd=-half,half
6577 DO iadd=-half,half
6578 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
6579 END DO
6580 END DO
6581# endif
6582 SELECT CASE (gtype) ! coarse grid inverse area
6583 CASE (r3dvar)
6584 areac_inv=pmc(ic,jc)*pnc(ic,jc)
6585 CASE (u3dvar)
6586 areac_inv=0.25_r8*(pmc(ic-1,jc)+pmc(ic,jc))* &
6587 & (pnc(ic-1,jc)+pnc(ic,jc))
6588 CASE (v3dvar)
6589 areac_inv=0.25_r8*(pmc(ic,jc-1)+pmc(ic,jc))* &
6590 & (pnc(ic,jc-1)+pnc(ic,jc))
6591 CASE DEFAULT
6592 areac_inv=pmc(ic,jc)*pnc(ic,jc)
6593 END SELECT
6594!
6595!^ C(Ic,Jc,k)=my_avg
6596!^
6597 my_avg=my_avg+c(ic,jc,k)
6598 c(ic,jc,k)=0.0_r8
6599# ifdef MASKING
6600 my_avg=my_avg*cmsk(ic,jc)
6601 IF (my_count.gt.0.0_r8) THEN
6602 my_avg=my_avg*rscale*rscale/my_count
6603 END IF
6604# endif
6605!^ my_avg=my_sum*areaC_inv
6606
6607 my_sum=my_sum+areac_inv*my_avg
6608 my_avg=0.0_r8
6609
6610!^ ratio=my_areasum*areaC_inv ! for debugging purposes
6611!^
6612 DO jadd=-half,half
6613 DO iadd=-half,half
6614 my_area=dxf(i+iadd,j+jadd)*dyf(i+iadd,j+jadd)
6615 my_areasum=my_areasum+my_area
6616# ifdef MASKING
6617!^ my_sum=my_sum+ &
6618!^ & F(i+Iadd,j+Jadd,k)*my_area* &
6619!^ & MIN(1.0_r8,Fmsk(i+Iadd,j+Jadd))
6620!^
6621 f(i+iadd,j+jadd,k)=f(i+iadd,j+jadd,k)+ &
6622 & my_area* &
6623 & min(1.0_r8,fmsk(i+iadd,j+jadd))* &
6624 & my_sum
6625# else
6626!^ my_sum=my_sum+ &
6627!^ & F(i+Iadd,j+Jadd,k)*my_area
6628!^
6629 f(i+iadd,j+jadd,k)=f(i+iadd,j+jadd,k)+ &
6630 & my_area*my_sum
6631# endif
6632 END DO
6633 END DO
6634 my_count=0.0_r8
6635 my_sum=0.0_r8
6636 my_areasum=0.0_r8
6637 END IF
6638 END DO
6639 END DO
6640 ELSE ! simple averaging
6641 DO k=lbkc,ubkc
6642 DO m=1,npoints
6643 i=contact(cr)%Idg(m)
6644 j=contact(cr)%Jdg(m)
6645 ic=contact(cr)%Irg(m)
6646 jc=contact(cr)%Jrg(m)
6647 IF (((istr.le.ic).and.(ic.le.iend)).and. &
6648 & ((jstr.le.jc).and.(jc.le.jend))) THEN
6649!
6650! Compute my_count first.
6651!
6652 my_count=0.0_r8
6653 DO jadd=-half,half
6654 DO iadd=-half,half
6655# ifdef MASKING
6656 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
6657# else
6658 my_count=my_count+1.0_r8
6659# endif
6660 END DO
6661 END DO
6662!
6663!^ C(Ic,Jc,k)=my_avg
6664!^
6665 my_avg=my_avg+c(ic,jc,k)
6666 c(ic,jc,k)=0.0_r8
6667# ifdef MASKING
6668 my_avg=my_avg*cmsk(ic,jc)
6669# endif
6670 IF (my_count.gt.0.0_r8) THEN
6671!^ my_avg=my_sum/my_count
6672!^
6673 my_sum=my_sum+my_avg/my_count
6674 my_avg=0.0_r8
6675 END IF
6676
6677 DO jadd=-half,half
6678 DO iadd=-half,half
6679# ifdef MASKING
6680!^ my_sum=my_sum+ &
6681!^ & F(i+Iadd,j+Jadd,k)*Fmsk(i+Iadd,j+Jadd)
6682!^
6683 f(i+iadd,j+jadd,k)=f(i+iadd,j+jadd,k)+ &
6684 & fmsk(i+iadd,j+jadd)*my_sum
6685# else
6686!^ my_sum=my_sum+ &
6687!^ & F(i+Iadd,j+Jadd,k)
6688!^
6689 f(i+iadd,j+jadd,k)=f(i+iadd,j+jadd,k)+my_sum
6690# endif
6691 END DO
6692 END DO
6693 my_count=0.0_r8
6694 my_avg=0.0_r8
6695 my_sum=0.0_r8
6696 END IF
6697 END DO
6698 END DO
6699 END IF
6700
6701# ifdef DISTRIBUTE
6702!
6703! The following loop represents the adjoint of mp_aggregate3d (AMM).
6704!
6705 DO k=lbkf,ubkf
6706 DO j=lbjf,ubjf
6707 DO i=lbif,ubif
6708 a(i,j,k)=a(i,j,k)+f(i,j,k)
6709 f(i,j,k)=0.0_r8
6710 END DO
6711 END DO
6712 END DO
6713!
6714! Deallocate work array.
6715!
6716 IF (allocated(f)) THEN
6717 deallocate (f)
6718 END IF
6719 IF (areaavg) THEN
6720 IF (allocated(dxf)) THEN
6721 deallocate (dxf)
6722 END IF
6723 IF (allocated(dyf)) THEN
6724 deallocate (dyf)
6725 END IF
6726 END IF
6727# ifdef MASKING
6728 IF (allocated(fmsk)) THEN
6729 deallocate (fmsk)
6730 END IF
6731# endif
6732# endif
6733
6734 RETURN
6735 END SUBROUTINE ad_fine2coarse3d
6736# endif
6737!
6738 SUBROUTINE ad_get_contact2d (dg, model, tile, &
6739 & gtype, svname, &
6740 & cr, Npoints, contact, &
6741 & LBi, UBi, LBj, UBj, &
6742 & Ad, Ac)
6743!
6744!=======================================================================
6745! !
6746! This routine gets the donor grid data (Ac) necessary to process !
6747! the contact points for a 2D state variable (Ad). It extracts the !
6748! donor cell points containing each contact point, Ac(1:4,:). !
6749! !
6750! On Input: !
6751! !
6752! dg Donor grid number (integer) !
6753! model Calling model identifier (integer) !
6754! tile Domain tile partition (integer) !
6755! gtype C-grid variable type (integer) !
6756! svname State variable name (string) !
6757! cr Contact region number to process (integer) !
6758! Npoints Number of points in the contact region (integer) !
6759! contact Contact region information variables (T_NGC structure)!
6760! LBi Donor grid, I-dimension Lower bound (integer) !
6761! UBi Donor grid, I-dimension Upper bound (integer) !
6762! LBj Donor grid, J-dimension Lower bound (integer) !
6763! UBj Donor grid, J-dimension Upper bound (integer) !
6764! Ad Donor grid data (2D array) !
6765! !
6766! On Input: !
6767! !
6768! Ac 2D state variable contact point data !
6769! !
6770!=======================================================================
6771!
6772 USE mod_param
6773 USE mod_ncparam
6774 USE mod_nesting
6775
6776# ifdef DISTRIBUTE
6777!
6778! USE distribute_mod, ONLY : ad_mp_assemble
6779# endif
6780!
6781! Imported variable declarations.
6782!
6783 integer, intent(in) :: dg, model, tile
6784 integer, intent(in) :: gtype, cr, npoints
6785 integer, intent(in) :: lbi, ubi, lbj, ubj
6786!
6787 character(len=*), intent(in) :: svname
6788!
6789 TYPE (t_ngc), intent(in) :: contact(:)
6790!
6791# ifdef ASSUMED_SHAPE
6792 real(r8), intent(inout) :: ad(lbi:,lbj:)
6793 real(r8), intent(inout) :: ac(:,:)
6794# else
6795 real(r8), intent(inout) :: ad(lbi:ubi,lbj:ubj)
6796 real(r8), intent(inout) :: ac(npoints,4)
6797# endif
6798!
6799! Local variable declarations.
6800!
6801 integer :: i, ip1, j, jp1, m
6802 integer :: imin, imax, jmin, jmax
6803 integer :: istr, iend, jstr, jend
6804# ifdef DISTRIBUTE
6805 integer :: npts
6806# endif
6807
6808 real(r8), parameter :: aspv = 0.0_r8
6809!
6810!-----------------------------------------------------------------------
6811! Initialize.
6812!-----------------------------------------------------------------------
6813!
6814! Set starting and ending tile indices for the donor grids.
6815!
6816 SELECT CASE (gtype)
6817 CASE (r2dvar)
6818 imin=bounds(dg) % IstrT(-1) ! full RHO-grid range
6819 imax=bounds(dg) % IendT(-1)
6820 jmin=bounds(dg) % JstrT(-1)
6821 jmax=bounds(dg) % JendT(-1)
6822!
6823 istr=bounds(dg) % IstrT(tile) ! domain partition range
6824 iend=bounds(dg) % IendT(tile)
6825 jstr=bounds(dg) % JstrT(tile)
6826 jend=bounds(dg) % JendT(tile)
6827 CASE (u2dvar)
6828 imin=bounds(dg) % IstrP(-1) ! full U-grid range
6829 imax=bounds(dg) % IendT(-1)
6830 jmin=bounds(dg) % JstrT(-1)
6831 jmax=bounds(dg) % JendT(-1)
6832!
6833 istr=bounds(dg) % IstrP(tile) ! domain partition range
6834 iend=bounds(dg) % IendT(tile)
6835 jstr=bounds(dg) % JstrT(tile)
6836 jend=bounds(dg) % JendT(tile)
6837 CASE (v2dvar)
6838 imin=bounds(dg) % IstrT(-1) ! full V-grid range
6839 imax=bounds(dg) % IendT(-1)
6840 jmin=bounds(dg) % JstrP(-1)
6841 jmax=bounds(dg) % JendT(-1)
6842!
6843 istr=bounds(dg) % IstrT(tile) ! domain partition range
6844 iend=bounds(dg) % IendT(tile)
6845 jstr=bounds(dg) % JstrP(tile)
6846 jend=bounds(dg) % JendT(tile)
6847 END SELECT
6848!
6849!-----------------------------------------------------------------------
6850! Adjoint of extract donor grid data at contact points.
6851!-----------------------------------------------------------------------
6852
6853# ifdef DISTRIBUTE
6854!
6855! Gather and broadcast data from all nodes. No action required for the
6856! adjoint of mp_assemble (AMM).
6857!
6858!! Npts=4*Npoints
6859!^ CALL mp_assemble (dg, model, Npts, Aspv, Ac)
6860!^
6861!! CALL ad_mp_assemble (dg, model, Npts, Aspv, Ac)
6862# endif
6863!
6864! Notice that the indices i+1 and j+1 are bounded the maximum values
6865! of the grid. This implies that contact point lies on the grid
6866! boundary.
6867!
6868 DO m=1,npoints
6869 i=contact(cr)%Idg(m)
6870 j=contact(cr)%Jdg(m)
6871 ip1=min(i+1,imax)
6872 jp1=min(j+1,jmax)
6873 IF (((istr.le.i).and.(i.le.iend)).and. &
6874 & ((jstr.le.j).and.(j.le.jend))) THEN
6875!^ Ac(1,m)=Ad(i ,j )
6876!^
6877 ad(i ,j )=ad(i ,j )+ac(1,m)
6878 ac(1,m)=0.0_r8
6879!^ Ac(2,m)=Ad(ip1,j )
6880!^
6881 ad(ip1,j )=ad(ip1,j )+ac(2,m)
6882 ac(2,m)=0.0_r8
6883!^ Ac(3,m)=Ad(ip1,jp1)
6884!^
6885 ad(ip1,jp1)=ad(ip1,jp1)+ac(3,m)
6886 ac(3,m)=0.0_r8
6887!^ Ac(4,m)=Ad(i ,jp1)
6888!^
6889 ad(i ,jp1)=ad(i ,jp1)+ac(4,m)
6890 ac(4,m)=0.0_r8
6891 END IF
6892 END DO
6893
6894# ifdef DISTRIBUTE
6895!
6896! Adjoint of initialize contact points array to special value to
6897! facilitate distribute-memory data collection from all nodes.
6898!
6899 DO m=1,npoints
6900 ac(1,m)=0.0_r8
6901 ac(2,m)=0.0_r8
6902 ac(3,m)=0.0_r8
6903 ac(4,m)=0.0_r8
6904 END DO
6905# endif
6906
6907 RETURN
6908 END SUBROUTINE ad_get_contact2d
6909
6910# ifdef SOLVE3D
6911!
6912 SUBROUTINE ad_get_contact3d (dg, model, tile, &
6913 & gtype, svname, &
6914 & cr, Npoints, contact, &
6915 & LBi, UBi, LBj, UBj, LBk, UBk, &
6916 & Ad, Ac)
6917!
6918!=======================================================================
6919! !
6920! This routine gets the donor grid data (Ac) necessary to process !
6921! the contact points for a 3D state variable (Ad). It extracts the !
6922! donor cell points containing each contact point, Ac(1:4,k,:). !
6923! !
6924! On Input: !
6925! !
6926! dg Donor grid number (integer) !
6927! model Calling model identifier (integer) !
6928! tile Domain tile partition (integer) !
6929! gtype C-grid variable type (integer) !
6930! svname State variable name (string) !
6931! cr Contact region number to process (integer) !
6932! Npoints Number of points in the contact region (integer) !
6933! contact Contact region information variables (T_NGC structure)!
6934! LBi Donor grid, I-dimension Lower bound (integer) !
6935! UBi Donor grid, I-dimension Upper bound (integer) !
6936! LBj Donor grid, J-dimension Lower bound (integer) !
6937! UBj Donor grid, J-dimension Upper bound (integer) !
6938! Ad Donor grid data (3D array) !
6939! !
6940! On Input: !
6941! !
6942! Ac 3D state variable contact point data !
6943! !
6944!=======================================================================
6945!
6946 USE mod_param
6947 USE mod_ncparam
6948 USE mod_nesting
6949!
6950# ifdef DISTRIBUTE
6951!! USE distribute_mod, ONLY : ad_mp_assemble
6952# endif
6953 USE strings_mod, ONLY : founderror
6954!
6955! Imported variable declarations.
6956!
6957 integer, intent(in) :: dg, model, tile
6958 integer, intent(in) :: gtype, cr, npoints
6959 integer, intent(in) :: lbi, ubi, lbj, ubj, lbk, ubk
6960!
6961 character(len=*), intent(in) :: svname
6962!
6963 TYPE (t_ngc), intent(in) :: contact(:)
6964!
6965# ifdef ASSUMED_SHAPE
6966 real(r8), intent(inout) :: ad(lbi:,lbj:,lbk:)
6967 real(r8), intent(inout) :: ac(:,lbk:,:)
6968# else
6969 real(r8), intent(inout) :: ad(lbi:ubi,lbj:ubj,lbk:ubk)
6970 real(r8), intent(inout) :: ac(4,lbk:ubk,npoints)
6971# endif
6972!
6973! Local variable declarations.
6974!
6975 integer :: i, ip1, j, jp1, k, m
6976 integer :: imin, imax, jmin, jmax
6977 integer :: istr, iend, jstr, jend
6978# ifdef DISTRIBUTE
6979 integer :: npts
6980# endif
6981!
6982 real(r8), parameter :: aspv = 0.0_r8
6983!
6984 character (len=*), parameter :: myfile = &
6985 & __FILE__//", ad_get_contact3d"
6986!
6987!-----------------------------------------------------------------------
6988! Initialize.
6989!-----------------------------------------------------------------------
6990!
6991! Set starting and ending tile indices for the donor grid.
6992!
6993 SELECT CASE (gtype)
6994 CASE (r3dvar)
6995 imin=bounds(dg) % IstrT(-1) ! full RHO-grid range
6996 imax=bounds(dg) % IendT(-1)
6997 jmin=bounds(dg) % JstrT(-1)
6998 jmax=bounds(dg) % JendT(-1)
6999!
7000 istr=bounds(dg) % IstrT(tile) ! domain partition range
7001 iend=bounds(dg) % IendT(tile)
7002 jstr=bounds(dg) % JstrT(tile)
7003 jend=bounds(dg) % JendT(tile)
7004 CASE (u3dvar)
7005 imin=bounds(dg) % IstrP(-1) ! full U-grid range
7006 imax=bounds(dg) % IendT(-1)
7007 jmin=bounds(dg) % JstrT(-1)
7008 jmax=bounds(dg) % JendT(-1)
7009!
7010 istr=bounds(dg) % IstrP(tile) ! domain partition range
7011 iend=bounds(dg) % IendT(tile)
7012 jstr=bounds(dg) % JstrT(tile)
7013 jend=bounds(dg) % JendT(tile)
7014 CASE (v3dvar)
7015 imin=bounds(dg) % IstrT(-1) ! full V-grid range
7016 imax=bounds(dg) % IendT(-1)
7017 jmin=bounds(dg) % JstrP(-1)
7018 jmax=bounds(dg) % JendT(-1)
7019!
7020 istr=bounds(dg) % IstrT(tile) ! domain partition range
7021 iend=bounds(dg) % IendT(tile)
7022 jstr=bounds(dg) % JstrP(tile)
7023 jend=bounds(dg) % JendT(tile)
7024 END SELECT
7025!
7026!-----------------------------------------------------------------------
7027! Adjoint of extract donor grid data at contact points.
7028!-----------------------------------------------------------------------
7029
7030# ifdef DISTRIBUTE
7031!
7032! Gather and broadcast data from all nodes. No action required for
7033! the adjoint of mp_assemble.
7034!
7035!! Npts=4*(UBk-LBk+1)*Npoints
7036!^ CALL mp_assemble (dg, model, Npts, Aspv, Ac(:,LBk:,:))
7037!^
7038!! CALL ad_mp_assemble (dg, model, Npts, Aspv, Ac(:,LBk:,:))
7039!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
7040# endif
7041!
7042! Notice that the indices i+1 and j+1 are bounded the maximum values
7043! of the grid. This implies that contact point lies on the grid
7044! boundary.
7045!
7046 DO k=lbk,ubk
7047 DO m=1,npoints
7048 i=contact(cr)%Idg(m)
7049 j=contact(cr)%Jdg(m)
7050 ip1=min(i+1,imax)
7051 jp1=min(j+1,jmax)
7052 IF (((istr.le.i).and.(i.le.iend)).and. &
7053 & ((jstr.le.j).and.(j.le.jend))) THEN
7054!^ Ac(1,k,m)=Ad(i ,j ,k)
7055!^
7056 ad(i ,j ,k)=ad(i ,j ,k)+ac(1,k,m)
7057 ac(1,k,m)=0.0_r8
7058!^ Ac(2,k,m)=Ad(ip1,j ,k)
7059!^
7060 ad(ip1,j ,k)=ad(ip1,j ,k)+ac(2,k,m)
7061 ac(2,k,m)=0.0_r8
7062!^ Ac(3,k,m)=Ad(ip1,jp1,k)
7063!^
7064 ad(ip1,jp1,k)=ad(ip1,jp1,k)+ac(3,k,m)
7065 ac(3,k,m)=0.0_r8
7066!^ Ac(4,k,m)=Ad(i ,jp1,k)
7067!^
7068 ad(i ,jp1,k)=ad(i ,jp1,k)+ac(4,k,m)
7069 ac(4,k,m)=0.0_r8
7070 END IF
7071 END DO
7072 END DO
7073
7074# ifdef DISTRIBUTE
7075!
7076! Adjoint of initialize contact points array to special value to
7077! facilitate distribute-memory data collection from all nodes.
7078!
7079 DO k=lbk,ubk
7080 DO m=1,npoints
7081 ac(1,k,m)=0.0_r8
7082 ac(2,k,m)=0.0_r8
7083 ac(3,k,m)=0.0_r8
7084 ac(4,k,m)=0.0_r8
7085 END DO
7086 END DO
7087# endif
7088!
7089 RETURN
7090 END SUBROUTINE ad_get_contact3d
7091# endif
7092!
7093 SUBROUTINE ad_get_persisted2d (dg, rg, model, tile, &
7094 & gtype, svname, &
7095 & cr, Npoints, contact, &
7096 & LBi, UBi, LBj, UBj, &
7097 & Ad, Ac)
7098!
7099!=======================================================================
7100! !
7101! This routine gets the donor grid data (Ac) necessary to process !
7102! the contact points for a 2D flux variable (Ad). It extracts the !
7103! donor cell points containing each contact point, Ac(1:4,:). !
7104! !
7105! This routine is different that 'get_contact2d'. It is used in !
7106! refinement to impose the appropriate coarser grid flux to insure !
7107! volume and mass conservation. The value of the coarse grid cell !
7108! is presisted over the refined grid points along its physical !
7109! boundary. This will facilitate that the sum of all the refined !
7110! grid point is the same as that of the coarse grid containing such !
7111! points. The spatial interpolation as set in 'get_contact2d' will !
7112! not conserve volume and mass. !
7113! !
7114! On Input: !
7115! !
7116! dg Donor grid number (integer) !
7117! rg Receiver grid number (integer) !
7118! model Calling model identifier (integer) !
7119! tile Domain tile partition (integer) !
7120! gtype C-grid variable type (integer) !
7121! svname State variable name (string) !
7122! cr Contact region number to process (integer) !
7123! Npoints Number of points in the contact region (integer) !
7124! contact Contact region information variables (T_NGC structure)!
7125! LBi Donor grid, I-dimension Lower bound (integer) !
7126! UBi Donor grid, I-dimension Upper bound (integer) !
7127! LBj Donor grid, J-dimension Lower bound (integer) !
7128! UBj Donor grid, J-dimension Upper bound (integer) !
7129! Ad Donor grid data (2D array) !
7130! !
7131! On Input: !
7132! !
7133! Ac 2D flux variable contact point data !
7134! !
7135!=======================================================================
7136!
7137 USE mod_param
7138 USE mod_ncparam
7139 USE mod_nesting
7140 USE mod_scalars
7141!
7142# ifdef DISTRIBUTE
7143!! USE distribute_mod, ONLY : ad_mp_assemble
7144# endif
7145 USE strings_mod, ONLY : founderror
7146!
7147! Imported variable declarations.
7148!
7149 integer, intent(in) :: dg, rg, model, tile
7150 integer, intent(in) :: gtype, cr, npoints
7151 integer, intent(in) :: lbi, ubi, lbj, ubj
7152!
7153 character(len=*), intent(in) :: svname
7154!
7155 TYPE (t_ngc), intent(in) :: contact(:)
7156!
7157# ifdef ASSUMED_SHAPE
7158 real(r8), intent(inout) :: ad(lbi:,lbj:)
7159 real(r8), intent(inout) :: ac(:,:)
7160# else
7161 real(r8), intent(inout) :: ad(lbi:ubi,lbj:ubj)
7162 real(r8), intent(inout) :: ac(npoints,4)
7163# endif
7164!
7165! Local variable declarations.
7166!
7167 integer :: idg, ip1, irg, jdg, jp1, jrg, ii
7168 integer :: imin, imax, jmin, jmax
7169 integer :: istr, iend, jstr, jend
7170 integer :: i, i_add, j, j_add, m, m_add
7171# ifdef DISTRIBUTE
7172 integer :: npts
7173# endif
7174!
7175 real(r8), parameter :: aspv = 0.0_r8
7176 real(r8):: rscale
7177!
7178 character (len=*), parameter :: myfile = &
7179 & __FILE__//", ad_get_persisted2d"
7180!
7181!-----------------------------------------------------------------------
7182! Initialize.
7183!-----------------------------------------------------------------------
7184!
7185! Set starting and ending tile indices for the donor grids.
7186!
7187 SELECT CASE (gtype)
7188 CASE (r2dvar)
7189 imin=bounds(dg) % IstrT(-1) ! full RHO-grid range
7190 imax=bounds(dg) % IendT(-1)
7191 jmin=bounds(dg) % JstrT(-1)
7192 jmax=bounds(dg) % JendT(-1)
7193!
7194 istr=bounds(dg) % IstrT(tile) ! domain partition range
7195 iend=bounds(dg) % IendT(tile)
7196 jstr=bounds(dg) % JstrT(tile)
7197 jend=bounds(dg) % JendT(tile)
7198!
7199 m_add=nstrr(cr)-1
7200 CASE (u2dvar)
7201 imin=bounds(dg) % IstrP(-1) ! full U-grid range
7202 imax=bounds(dg) % IendT(-1)
7203 jmin=bounds(dg) % JstrT(-1)
7204 jmax=bounds(dg) % JendT(-1)
7205!
7206 istr=bounds(dg) % IstrP(tile) ! domain partition range
7207 iend=bounds(dg) % IendT(tile)
7208 jstr=bounds(dg) % JstrT(tile)
7209 jend=bounds(dg) % JendT(tile)
7210!
7211 m_add=nstru(cr)-1
7212 CASE (v2dvar)
7213 imin=bounds(dg) % IstrT(-1) ! full V-grid range
7214 imax=bounds(dg) % IendT(-1)
7215 jmin=bounds(dg) % JstrP(-1)
7216 jmax=bounds(dg) % JendT(-1)
7217!
7218 istr=bounds(dg) % IstrT(tile) ! domain partition range
7219 iend=bounds(dg) % IendT(tile)
7220 jstr=bounds(dg) % JstrP(tile)
7221 jend=bounds(dg) % JendT(tile)
7222!
7223 m_add=nstrv(cr)-1
7224 END SELECT
7225!
7226!-----------------------------------------------------------------------
7227! Adjoint of extract donor grid data at contact points.
7228!-----------------------------------------------------------------------
7229!
7230# ifdef DISTRIBUTE
7231!
7232! Gather and broadcast data from all nodes. No action required for the
7233! adjoint of mp_assemble (AMM).
7234!
7235!^ CALL mp_assemble (dg, model, Npts, Aspv, Ac)
7236!^
7237!! CALL ad_mp_assemble (dg, model, Npts, Aspv, Ac)
7238!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
7239# endif
7240!
7241! Notice that the indices i+1 and j+1 are bounded the maximum values
7242! of the grid. This implies that contact point lies on the grid
7243! boundary.
7244!
7245 rscale=1.0_r8/real(refinescale(rg))
7246 DO m=1,npoints
7247 idg=contact(cr)%Idg(m)
7248 jdg=contact(cr)%Jdg(m)
7249 irg=contact(cr)%Irg(m)
7250 jrg=contact(cr)%Jrg(m)
7251 ip1=min(idg+1,imax)
7252 jp1=min(jdg+1,jmax)
7253 IF (((istr.le.idg).and.(idg.le.iend)).and. &
7254 & ((jstr.le.jdg).and.(jdg.le.jend))) THEN
7255 IF (on_boundary(m+m_add).gt.0) THEN
7256 IF ((on_boundary(m+m_add).eq.1).or. &
7257 & (on_boundary(m+m_add).eq.3)) THEN ! western and
7258 j_add=int(real(jrg-1,r8)*rscale) ! eastern edges
7259 j=j_bottom(rg)+j_add
7260!^ Ac(1,m)=Ad(Idg,j)
7261!^ Ac(2,m)=Ad(Idg,j)
7262!^ Ac(3,m)=Ad(Idg,j)
7263!^ Ac(4,m)=Ad(Idg,j)
7264!^
7265 DO ii=1,4
7266 ad(idg,j)=ad(idg,j)+ac(ii,m)
7267 ac(ii,m)=0.0_r8
7268 END DO
7269 ELSE IF ((on_boundary(m+m_add).eq.2).or. &
7270 & (on_boundary(m+m_add).eq.4)) THEN ! southern and
7271 i_add=int(real(irg-1,r8)*rscale) ! northern edges
7272 i=i_left(rg)+i_add
7273!^ Ac(1,m)=Ad(i,Jdg)
7274!^ Ac(2,m)=Ad(i,Jdg)
7275!^ Ac(3,m)=Ad(i,Jdg)
7276!^ Ac(4,m)=Ad(i,Jdg)
7277!^
7278 DO ii=1,4
7279 ad(i,jdg)=ad(i,jdg)+ac(ii,m)
7280 ac(ii,m)=0.0_r8
7281 END DO
7282 END IF
7283!
7284! Contact point is not at physical boundary, just set values for spatial
7285! interpolation (not used).
7286!
7287 ELSE
7288!^ Ac(1,m)=Ad(Idg,Jdg)
7289!^ Ac(2,m)=Ad(Ip1,Jdg)
7290!^ Ac(3,m)=Ad(Ip1,Jp1)
7291!^ Ac(4,m)=Ad(Idg,Jp1)
7292!^
7293 ad(idg,jdg)=ad(idg,jdg)+ac(1,m)
7294 ac(1,m)=0.0_r8
7295 ad(ip1,jdg)=ad(ip1,jdg)+ac(2,m)
7296 ac(2,m)=0.0_r8
7297 ad(ip1,jp1)=ad(ip1,jp1)+ac(3,m)
7298 ac(3,m)=0.0_r8
7299 ad(idg,jp1)=ad(idg,jp1)+ac(4,m)
7300 ac(4,m)=0.0_r8
7301 END IF
7302 END IF
7303 END DO
7304
7305# ifdef DISTRIBUTE
7306!
7307! Initialize contact points array to special value to facilite
7308! distribute-memory data collection from all nodes.
7309!
7310 DO m=1,npoints
7311 ac(1,m)=0.0_r8
7312 ac(2,m)=0.0_r8
7313 ac(3,m)=0.0_r8
7314 ac(4,m)=0.0_r8
7315 END DO
7316# endif
7317!
7318 RETURN
7319 END SUBROUTINE ad_get_persisted2d
7320!
7321 SUBROUTINE ad_bry_fluxes (dg, rg, cr, model, tile, &
7322 & IminS, ImaxS, JminS, JmaxS, &
7323 & ILB, IUB, JLB, JUB, &
7324 & scale, FX, FE, &
7325 & F_west, F_east, F_south, F_north)
7326!
7327!=======================================================================
7328! !
7329! This routine extracts tracer horizontal advective fluxes (Hz*u*T/n, !
7330! Hz*v*T/m) at the grid contact boundary (physical domain perimeter). !
7331! The data source is either the coarse or finer grid. These fluxes !
7332! are used for in two-way nesting. b !
7333! !
7334! On Input: !
7335! !
7336! dg Donor grid number (integer) !
7337! rg Receiver grid number (integer) !
7338! cr Contact region number to process (integer) !
7339! model Calling model identifier (integer) !
7340! tile Domain tile partition (integer) !
7341! scale Advective flux scale (floating-point) !
7342! IminS Advective flux, I-dimension Lower bound (integer) !
7343! ImaxS Advective flux, I-dimension Upper bound (integer) !
7344! JminS Advective flux, J-dimension Lower bound (integer) !
7345! JmaxS Advective flux, J-dimension Upper bound (integer) !
7346! ILB Western/Eastern boundary flux Lower bound (integer) !
7347! IUB Western/Eastern boundary flux Upper bound (integer) !
7348! JLB Southern/Northern boundary flux Lower bound (integer) !
7349! JUB Southern/Northern boundary flux Lower bound (integer) !
7350! FX Horizontal advetive flux in the XI-direction (array) !
7351! FE Horizontal advetive flux in the ETA-direction (array) !
7352! !
7353! On Output: !
7354! !
7355! F_west Western boundary advective flux (1D array) !
7356! F_east Eastern boundary advective flux (1D array) !
7357! F_south Southern boundary advective flux (1D array) !
7358! F_north Northerb boundary advective flux (1D array) !
7359! !
7360!=======================================================================
7361!
7362 USE mod_param
7363 USE mod_parallel
7364 USE mod_nesting
7365 USE mod_scalars
7366!
7367# ifdef DISTRIBUTE
7368!! USE distribute_mod, ONLY : ad_mp_assemble
7369# endif
7370 USE strings_mod, ONLY : founderror
7371!
7372! Imported variable declarations.
7373!
7374 integer, intent(in) :: dg, rg, cr, model, tile
7375 integer, intent(in) :: imins, imaxs, jmins, jmaxs
7376 integer, intent(in) :: ilb, iub, jlb, jub
7377
7378 real(r8), intent(in) :: scale
7379!
7380# ifdef ASSUMED_SHAPE
7381 real(r8), intent(inout) :: fx(imins:,jmins:)
7382 real(r8), intent(inout) :: fe(imins:,jmins:)
7383
7384 real(r8), intent(inout) :: f_west (jlb:)
7385 real(r8), intent(inout) :: f_east (jlb:)
7386 real(r8), intent(inout) :: f_south(ilb:)
7387 real(r8), intent(inout) :: f_north(ilb:)
7388# else
7389 real(r8), intent(inout) :: fx(imins:imaxs,jmins:jmaxs)
7390 real(r8), intent(inout) :: fe(imins:imaxs,jmins:jmaxs)
7391
7392 real(r8), intent(inout) :: f_west (jlb:jub)
7393 real(r8), intent(inout) :: f_east (jlb:jub)
7394 real(r8), intent(inout) :: f_south(ilb:iub)
7395 real(r8), intent(inout) :: f_north(ilb:iub)
7396# endif
7397!
7398! Local variable declarations.
7399!
7400 integer :: istr, iend, jstr, jend
7401 integer :: ib_east, ib_west, jb_north, jb_south
7402 integer :: i, j, m
7403
7404# ifdef DISTRIBUTE
7405 integer :: nptswe, nptssn
7406
7407 real(r8), parameter :: fspv = 0.0_r8
7408# endif
7409!
7410 character (len=*), parameter :: myfile = &
7411 & __FILE__//", ad_bry_fluxes"
7412
7413# ifdef DISTRIBUTE
7414!
7415!-----------------------------------------------------------------------
7416! Gather and broadcast data from all nodes.
7417!-----------------------------------------------------------------------
7418!
7419! No action required for the adjoint of mp_assemble (AMM).
7420!
7421!^ CALL mp_assemble (dg, model, NptsWE, Fspv, F_west (JLB:))
7422!^
7423!! CALL ad_mp_assemble (dg, model, NptsWE, Fspv, F_west (JLB:))
7424!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
7425
7426!^ CALL mp_assemble (dg, model, NptsWE, Fspv, F_east (JLB:))
7427!^
7428!! CALL ad_mp_assemble (dg, model, NptsWE, Fspv, F_east (JLB:))
7429!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
7430
7431!^ CALL mp_assemble (dg, model, NptsSN, Fspv, F_south(ILB:))
7432!^
7433!! CALL ad_mp_assemble (dg, model, NptsSN, Fspv, F_south(ILB:))
7434!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
7435
7436!^ CALL mp_assemble (dg, model, NptsSN, Fspv, F_north(ILB:))
7437!^
7438!! CALL ad_mp_assemble (dg, model, NptsSN, Fspv, F_north(ILB:))
7439!! IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN
7440# endif
7441
7442!
7443!-----------------------------------------------------------------------
7444! Initialize local variables.
7445!-----------------------------------------------------------------------
7446!
7447! Set tile starting and ending indices.
7448!
7449 istr=bounds(rg)%Istr(tile)
7450 iend=bounds(rg)%Iend(tile)
7451 jstr=bounds(rg)%Jstr(tile)
7452 jend=bounds(rg)%Jend(tile)
7453
7454!
7455!-----------------------------------------------------------------------
7456! If "rg" is the finer grid, extract advective tracer flux at its
7457! physical domain boundaries (grid perimeter).
7458!-----------------------------------------------------------------------
7459!
7460! Receiver finer grid number is greater than donor coaser grid number
7461! because of refinement nesting layers.
7462!
7463 IF (rg.gt.dg) THEN
7464!
7465! Northern boundary.
7466!
7467 IF (domain(dg)%Northern_Edge(tile)) THEN
7468 DO i=istr,iend
7469!^ F_north(i)=FE(i,Jend+1)*scale
7470!^
7471 fe(i,jend+1)=fe(i,jend+1)+scale*f_north(i)
7472 f_north(i)=0.0_r8
7473 END DO
7474 END IF
7475!
7476! Southern boundary.
7477!
7478 IF (domain(dg)%Southern_Edge(tile)) THEN
7479 DO i=istr,iend
7480!^ F_south(i)=FE(i,Jstr)*scale
7481!^
7482 fe(i,jstr)=fe(i,jstr)+scale*f_south(i)
7483 f_south(i)=0.0_r8
7484 END DO
7485 END IF
7486!
7487! Eastern boundary.
7488!
7489 IF (domain(dg)%Eastern_Edge(tile)) THEN
7490 DO j=jstr,jend
7491!^ F_east(j)=FX(Iend+1,j)*scale
7492!^
7493 fx(iend+1,j)=fx(iend+1,j)+scale*f_east(j)
7494 f_east(j)=0.0_r8
7495 END DO
7496 END IF
7497!
7498! Western boundary.
7499!
7500 IF (domain(dg)%Western_Edge(tile)) THEN
7501 DO j=jstr,jend
7502!^ F_west(j)=FX(Istr,j)*scale
7503!^
7504 fx(istr,j)=fx(istr,j)+scale*f_west(j)
7505 f_west(j)=0.0_r8
7506 END DO
7507 END IF
7508!
7509!-----------------------------------------------------------------------
7510! If "rg" is the coarser grid, extract coarser grid advective tracer
7511! flux at the location of the finer grid physical domain boundaries
7512! (grid perimeter).
7513!-----------------------------------------------------------------------
7514!
7515! Receiver coarser grid number is smaller than donor finer grid number
7516! because of refinement nesting layers.
7517!
7518 ELSE IF (rg.lt.dg) THEN
7519!
7520! Southern/Northern boundaries.
7521!
7522 jb_south=j_bottom(dg)
7523 jb_north=j_top(dg)
7524 DO i=istr,iend
7525 IF ((jstr.le.jb_south).and.(jb_south.le.jend)) THEN
7526!^ F_south(i)=FE(i,Jb_south)*scale
7527!^
7528 fe(i,jb_south)=fe(i,jb_south)+scale*f_south(i)
7529 f_south(i)=0.0_r8
7530 END IF
7531!
7532 IF ((jstr.le.jb_north).and.(jb_north.le.jend)) THEN
7533!^ F_north(i)=FE(i,Jb_north)*scale
7534!^
7535 fe(i,jb_north)=fe(i,jb_north)+scale*f_north(i)
7536 f_north(i)=0.0_r8
7537 END IF
7538 END DO
7539!
7540! Western/Eastern boundaries.
7541!
7542 ib_west=i_left(dg)
7543 ib_east=i_right(dg)
7544 DO j=jstr,jend
7545 IF ((istr.le.ib_west).and.(ib_west.le.iend)) THEN
7546!^ F_west(j)=FX(Ib_west,j)*scale
7547!^
7548 fx(ib_west,j)=fx(ib_west,j)+scale*f_west(j)
7549 f_west(j)=0.0_r8
7550 END IF
7551!
7552 IF ((istr.le.ib_east).and.(ib_east.le.iend)) THEN
7553!^ F_east(j)=FX(Ib_east,j)*scale
7554!^
7555 fx(ib_east,j)=fx(ib_east,j)+scale*f_east(j)
7556 f_east(j)=0.0_r8
7557 END IF
7558 END DO
7559 END IF
7560
7561# ifdef DISTRIBUTE
7562!
7563! Initialize arrays to facilitate collective communications.
7564!
7565 nptswe=jub-jlb+1
7566 nptssn=iub-ilb+1
7567!
7568 f_west =0.0_r8
7569 f_east =0.0_r8
7570 f_south=0.0_r8
7571 f_north=0.0_r8
7572# endif
7573
7574 RETURN
7575 END SUBROUTINE ad_bry_fluxes
7576
7577# ifdef NESTING_DEBUG
7578!
7579 SUBROUTINE ad_check_massflux (ngf, model, tile)
7580!
7581!=======================================================================
7582! !
7583! If refinement, this routine check mass fluxes between coarse and !
7584! fine grids for mass and volume conservation. It is only used for !
7585! diagnostic purposes. !
7586! !
7587! On Input: !
7588! !
7589! ngf Finer grid number (integer) !
7590! model Calling model identifier (integer) !
7591! tile Domain tile partition (integer) !
7592! !
7593! On Output: (mod_nesting) !
7594! !
7595! BRY_CONTACT Updated Mflux in structure. !
7596! !
7597!=======================================================================
7598!
7599 USE mod_param
7600 USE mod_parallel
7601 USE mod_nesting
7602 USE mod_scalars
7603
7604# ifdef DISTRIBUTE
7605!
7606 USE distribute_mod, ONLY : mp_assemble
7607# endif
7608!
7609! Imported variable declarations.
7610!
7611 integer, intent(in) :: ngf, model, tile
7612!
7613! Local variable declarations.
7614!
7615# ifdef DISTRIBUTE
7616 integer :: ilb, iub, jlb, jub, nptssn, nptswe, my_tile
7617# endif
7618 integer :: iedge, ibc, ibc_min, ibc_max, ibf, io
7619 integer :: jedge, jbc, jbc_min, jbc_max, jbf, jo
7620 integer :: istr, iend, jstr, jend
7621 integer :: cjcr, cr, dg, half, icr, isum, jsum, m, rg
7622 integer :: tnew, told
7623
7624# ifdef DISTRIBUTE
7625 real(r8), parameter :: spv = 0.0_r8
7626# endif
7627 real(r8) :: eastsum, northsum, southsum, westsum
7628 real(r8) :: ad_eastsum, ad_northsum, ad_southsum, ad_westsum
7629# ifdef NESTING_DEBUG_NOT
7630 real(r8) :: mfratio
7631# endif
7632!
7633! Clear adjoint constants.
7634!
7635 ad_eastsum=0.0_r8
7636 ad_northsum=0.0_r8
7637 ad_southsum=0.0_r8
7638 ad_westsum=0.0_r8
7639!
7640!-----------------------------------------------------------------------
7641! Check mass and volume conservation during refinement between coarse
7642! and fine grids.
7643!-----------------------------------------------------------------------
7644!
7645 DO cr=1,ncontact
7646!
7647! Get data donor and data receiver grid numbers.
7648!
7649 dg=rcontact(cr)%donor_grid
7650 rg=rcontact(cr)%receiver_grid
7651!
7652! Process only contact region data for requested nested finer grid
7653! "ngf". Notice that the donor grid is coarser than receiver grid.
7654!
7655 IF ((rg.eq.ngf).and.(dxmax(dg).gt.dxmax(rg))) THEN
7656!
7657! Set tile starting and ending indices for donor coarser grid.
7658!
7659 istr=bounds(dg)%Istr(tile)
7660 iend=bounds(dg)%Iend(tile)
7661 jstr=bounds(dg)%Jstr(tile)
7662 jend=bounds(dg)%Jend(tile)
7663!
7664! Set time rolling indices and conjugate region where the coarser
7665! donor grid becomes the receiver grid.
7666!
7667 told=3-rollingindex(cr)
7668 tnew=rollingindex(cr)
7669 DO icr=1,ncontact
7670 IF ((rg.eq.rcontact(icr)%donor_grid).and. &
7671 & (dg.eq.rcontact(icr)%receiver_grid)) THEN
7672 cjcr=icr
7673 EXIT
7674 END IF
7675 END DO
7676!
7677! Set finer grid center (half) and offset indices (Io and Jo) for
7678! coarser grid (I,J) coordinates.
7679!
7680 half=(refinescale(ngf)-1)/2
7681 io=half+1
7682 jo=half+1
7683!
7684!-----------------------------------------------------------------------
7685! Average finer grid western boundary mass fluxes and load them to the
7686! BRY_CONTACT structure.
7687!-----------------------------------------------------------------------
7688!
7689 ibc=i_left(ngf)
7690 jbc_min=j_bottom(ngf)
7691 jbc_max=j_top(ngf)-1 ! interior points, no top
7692! left corner
7693# ifdef NESTING_DEBUG_NOT
7694 IF (domain(ngf)%SouthWest_Test(tile)) THEN
7695 IF (master) THEN
7696 WRITE (302,10) 'Western Boundary Mass Fluxes: ', &
7697 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
7698 FLUSH (302)
7699 END IF
7700 END IF
7701!
7702# endif
7703 DO jbc=jstr,jend
7704 IF (((istr.le.ibc).and.(ibc.le.iend)).and. &
7705 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
7706!
7707! Sum finer grid western boundary mass fluxes within coarser grid cell.
7708!
7709 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
7710 DO jsum=-half,half
7711 jbf=jedge+jsum
7712!^ tl_WestSum=tl_WestSum+ &
7713!^ & BRY_CONTACT(iwest,cr)%tl_Mflux(Jbf)
7714!^
7715 bry_contact(iwest,cr)%ad_Mflux(jbf)= &
7716 & bry_contact(iwest,cr)%ad_Mflux(jbf)+ad_westsum
7717 END DO
7718!^ tl_WestSum=0.0_r8
7719!^
7720 ad_westsum=0.0_r8
7721 m=bry_contact(iwest,cr)%C2Bindex(jbf) ! pick last one
7722!
7723! Load coarser grid western boundary mass flux that have been averaged
7724! from finer grid. These values can be compared with the coarser grid
7725! values REFINED(cr)%DU_avg2 to check if the mass flux between coarser
7726! and finer grid is conserved.
7727!
7728!^ BRY_CONTACT(iwest,cjcr)%tl_Mflux(Jbc)=tl_WestSum
7729!^
7730 ad_westsum=ad_westsum+ &
7731 & bry_contact(iwest,cjcr)%ad_Mflux(jbc)
7732 bry_contact(iwest,cjcr)%ad_Mflux(jbc)=0.0_r8
7733
7734# ifdef NESTING_DEBUG_NOT
7735 IF (westsum.ne.0) THEN
7736 mfratio=refined(cr)%DU_avg2(1,m,tnew)/westsum
7737 ELSE
7738 mfratio=1.0_r8
7739 END IF
7740 WRITE (302,30) jbc, refined(cr)%DU_avg2(1,m,tnew), &
7741 & westsum, mfratio
7742 FLUSH (302)
7743# endif
7744 END IF
7745 END DO
7746!
7747!-----------------------------------------------------------------------
7748! Average finer grid eastern boundary mass fluxes and load them to the
7749! BRY_CONTACT structure.
7750!-----------------------------------------------------------------------
7751!
7752 ibc=i_right(ngf)
7753 jbc_min=j_bottom(ngf)
7754 jbc_max=j_top(ngf)-1 ! interior points, no top
7755! right corner
7756# ifdef NESTING_DEBUG_NOT
7757 IF (domain(ngf)%SouthWest_Test(tile)) THEN
7758 IF (master) THEN
7759 WRITE (302,10) 'Eastern Boundary Mass Fluxes: ', &
7760 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
7761 FLUSH (302)
7762 END IF
7763 END IF
7764!
7765# endif
7766 DO jbc=jstr,jend
7767 IF (((istr.le.ibc).and.(ibc.le.iend)).and. &
7768 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
7769!
7770! Sum finer grid eastern boundary mass fluxes within coarser grid cell.
7771!
7772 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
7773 DO jsum=-half,half
7774 jbf=jedge+jsum
7775!^ tl_EastSum=tl_EastSum+ &
7776!^ & BRY_CONTACT(ieast,cr)%tl_Mflux(Jbf)
7777!^
7778 bry_contact(ieast,cr)%ad_Mflux(jbf)= &
7779 & bry_contact(ieast,cr)%ad_Mflux(jbf)+ad_eastsum
7780 END DO
7781!^ tl_EastSum=0.0_r8
7782!^
7783 ad_eastsum=0.0_r8
7784 m=bry_contact(ieast,cr)%C2Bindex(jbf) ! pick last one
7785!
7786! Load coarser grid eastern boundary mass flux that have been averaged
7787! from finer grid. These values can be compared with the coarser grid
7788! values REFINED(cr)%DU_avg2 to check if the mass flux between coarser
7789! and finer grid is conserved.
7790!
7791!^ BRY_CONTACT(ieast,cjcr)%tl_Mflux(Jbc)=tl_EastSum
7792!^
7793 ad_eastsum=ad_eastsum+ &
7794 & bry_contact(ieast,cjcr)%ad_Mflux(jbc)
7795 bry_contact(ieast,cjcr)%ad_Mflux(jbc)=0.0_r8
7796
7797# ifdef NESTING_DEBUG_NOT
7798 IF (eastsum.ne.0) THEN
7799 mfratio=refined(cr)%DU_avg2(1,m,tnew)/eastsum
7800 ELSE
7801 mfratio=1.0_r8
7802 END IF
7803 WRITE (302,30) jbc, refined(cr)%DU_avg2(1,m,tnew), &
7804 & eastsum, mfratio
7805 FLUSH (302)
7806# endif
7807 END IF
7808 END DO
7809!
7810!-----------------------------------------------------------------------
7811! Average finer grid southern boundary mass fluxes and load them to the
7812! BRY_CONTACT structure.
7813!-----------------------------------------------------------------------
7814!
7815 jbc=j_bottom(ngf)
7816 ibc_min=i_left(ngf)
7817 ibc_max=i_right(ngf)-1 ! interior points, no bottom
7818! right corner
7819# ifdef NESTING_DEBUG_NOT
7820 IF (domain(ngf)%SouthWest_Test(tile)) THEN
7821 IF (master) THEN
7822 WRITE (302,20) 'Southern Boundary Mass Fluxes: ', &
7823 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
7824 FLUSH (302)
7825 END IF
7826 END IF
7827!
7828# endif
7829 DO ibc=istr,iend
7830 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
7831 & ((jstr.le.jbc).and.(jbc.le.jend))) THEN
7832!
7833! Sum finer grid southern boundary mass fluxes within coarser grid
7834! cell.
7835!
7836 iedge=io+(ibc-ibc_min)*refinescale(ngf)
7837 DO isum=-half,half
7838 ibf=iedge+isum
7839!^ tl_SouthSum=tl_SouthSum+ &
7840!^ & BRY_CONTACT(isouth,cr)%tl_Mflux(Ibf)
7841!^
7842 bry_contact(isouth,cr)%ad_Mflux(ibf)= &
7843 & bry_contact(isouth,cr)%ad_Mflux(ibf)+ad_southsum
7844 END DO
7845!^ tl_SouthSum=0.0_r8
7846!^
7847 ad_southsum=0.0_r8
7848 m=bry_contact(isouth,cr)%C2Bindex(ibf) ! pick last one
7849!
7850! Load coarser grid southern boundary mass flux that have been averaged
7851! from finer grid. These values can be compared with the coarser grid
7852! values REFINED(cr)%DU_avg2 to check if the mass flux between coarser
7853! and finer grid is conserved.
7854!
7855!^ BRY_CONTACT(isouth,cjcr)%tl_Mflux(Ibc)=tl_SouthSum
7856!^
7857 ad_southsum=ad_southsum+ &
7858 & bry_contact(isouth,cjcr)%ad_Mflux(ibc)
7859 bry_contact(isouth,cjcr)%ad_Mflux(ibc)=0.0_r8
7860
7861# ifdef NESTING_DEBUG_NOT
7862 IF (southsum.ne.0) THEN
7863 mfratio=refined(cr)%DV_avg2(1,m,tnew)/southsum
7864 ELSE
7865 mfratio=1.0_r8
7866 END IF
7867 WRITE (302,30) ibc, refined(cr)%DV_avg2(1,m,tnew), &
7868 & southsum, mfratio
7869 FLUSH (302)
7870# endif
7871 END IF
7872 END DO
7873!
7874!-----------------------------------------------------------------------
7875! Average finer grid northern boundary mass fluxes and load them to the
7876! BRY_CONTACT structure.
7877!-----------------------------------------------------------------------
7878!
7879 jbc=j_top(ngf)
7880 ibc_min=i_left(ngf)
7881 ibc_max=i_right(ngf)-1 ! interior points, no top
7882! right corner
7883# ifdef NESTING_DEBUG_NOT
7884 IF (domain(ngf)%SouthWest_Test(tile)) THEN
7885 IF (master) THEN
7886 WRITE (302,20) 'Northern Boundary Mass Fluxes: ', &
7887 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
7888 FLUSH (302)
7889 END IF
7890 END IF
7891!
7892# endif
7893 DO ibc=istr,iend
7894 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
7895 & ((jstr.le.jbc).and.(jbc.le.jend))) THEN
7896!
7897! Sum finer grid northern boundary mass fluxes within coarser grid
7898! cell.
7899!
7900 iedge=io+(ibc-ibc_min)*refinescale(ngf)
7901 DO isum=-half,half
7902 ibf=iedge+isum
7903!^ tl_NorthSum=tl_NorthSum+ &
7904!^ & BRY_CONTACT(inorth,cr)%tl_Mflux(Ibf)
7905!^
7906 bry_contact(inorth,cr)%ad_Mflux(ibf)= &
7907 & bry_contact(inorth,cr)%ad_Mflux(ibf)+ad_northsum
7908 ad_northsum=0.0_r8
7909 END DO
7910!^ tl_NorthSum=0.0_r8
7911!^
7912 ad_northsum=0.0_r8
7913 m=bry_contact(inorth,cr)%C2Bindex(ibf) ! pick last one
7914!
7915! Load coarser grid northern boundary mass flux that have been averaged
7916! from finer grid. These values can be compared with the coarser grid
7917! values REFINED(cr)%DU_avg2 to check if the mass flux between coarser
7918! and finer grid is conserved.
7919!
7920!^ BRY_CONTACT(inorth,cjcr)%tl_Mflux(Ibc)=tl_NorthSum
7921!^
7922 ad_northsum=ad_northsum+ &
7923 & bry_contact(inorth,cjcr)%ad_Mflux(ibc)
7924 bry_contact(inorth,cjcr)%ad_Mflux(ibc)=0.0_r8
7925
7926# ifdef NESTING_DEBUG_NOT
7927 IF (northsum.ne.0) THEN
7928 mfratio=refined(cr)%DV_avg2(1,m,tnew)/northsum
7929 ELSE
7930 mfratio=1.0_r8
7931 END IF
7932 WRITE (302,30) ibc, refined(cr)%DV_avg2(1,m,tnew), &
7933 & northsum, mfratio
7934# endif
7935 END IF
7936 END DO
7937
7938# ifdef DISTRIBUTE
7939!
7940! Set global size of boundary edges for coarse grid (donor index).
7941!
7942 my_tile=-1
7943 ilb=bounds(dg)%LBi(my_tile)
7944 iub=bounds(dg)%UBi(my_tile)
7945 jlb=bounds(dg)%LBj(my_tile)
7946 jub=bounds(dg)%UBj(my_tile)
7947 nptswe=jub-jlb+1
7948 nptssn=iub-ilb+1
7949!
7950! If distributed-memory, initialize arrays used to check mass flux
7951! conservation with special value (zero) to facilitate the global
7952! reduction when collecting data between all nodes.
7953!
7954 bry_contact(iwest ,cjcr)%ad_Mflux=0.0_r8
7955 bry_contact(ieast ,cjcr)%ad_Mflux=0.0_r8
7956 bry_contact(isouth,cjcr)%ad_Mflux=0.0_r8
7957 bry_contact(inorth,cjcr)%ad_Mflux=0.0_r8
7958# endif
7959# ifdef DISTRIBUTE
7960!
7961! Collect data from all nodes.
7962!
7963!^ CALL mp_assemble (dg, model, NptsWE, spv, &
7964!^ & BRY_CONTACT(iwest ,cjcr)%tl_Mflux(JLB:))
7965!^
7966!^ CALL mp_assemble (dg, model, NptsWE, spv, &
7967!^ & BRY_CONTACT(ieast ,cjcr)%tl_Mflux(JLB:))
7968!^
7969!^ CALL mp_assemble (dg, model, NptsSN, spv, &
7970!^ & BRY_CONTACT(isouth,cjcr)%tl_Mflux(ILB:))
7971!^
7972!^ CALL mp_assemble (dg, model, NptsSN, spv, &
7973!^ & BRY_CONTACT(inorth,cjcr)%tl_Mflux(ILB:))
7974!^
7975# endif
7976 END IF
7977 END DO
7978
7979# ifdef NESTING_DEBUG_NOT
7980!
7981 FLUSH (302)
7982!
7983 10 FORMAT (/,1x,a,/,/,4x,'cr = ',i2.2,4x,'dg = ',i2.2,4x,'rg = ', &
7984 & i2.2,4x,'iif(rg) = ',i3.3,4x,'iic(rg) = ',i10.10,4x, &
7985 & 'time(rg) = ',i10.10,/,/,2x,'Coarse',6x,'Coarse Grid',8x, &
7986 & 'Fine Grid',11x,'Ratio',/,4x,'Jb',9x,'DU_avg2',9x, &
7987 & 'SUM(DU_avg2)',/)
7988 20 FORMAT (/,1x,a,/,/,4x,'cr = ',i2.2,4x,'dg = ',i2.2,4x,'rg = ', &
7989 & i2.2,4x,'iif(rg) = ',i3.3,4x,'iic(rg) = ',i10.10,4x, &
7990 & 'time(rg) = ',i10.10,/,/,2x,'Coarse',6x,'Coarse Grid',8x, &
7991 & 'Fine Grid',11x,'Ratio',/,4x,'Ib',9x,'DV_avg2',9x, &
7992 & 'SUM(DV_avg2)',/)
7993 30 FORMAT (4x,i4.4,3(3x,1p,e15.8))
7994# endif
7995
7996 RETURN
7997 END SUBROUTINE ad_check_massflux
7998# endif
7999#endif
8000 END MODULE ad_nesting_mod
distribute_mod::mp_assemble
Definition distribute.F:67
ad_exchange_2d_mod
Definition ad_exchange_2d.F:2
ad_exchange_2d_mod::ad_exchange_u2d_tile
subroutine ad_exchange_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:816
ad_exchange_2d_mod::ad_exchange_v2d_tile
subroutine ad_exchange_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:1201
ad_exchange_2d_mod::ad_exchange_r2d_tile
subroutine ad_exchange_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:431
ad_exchange_3d_mod
Definition ad_exchange_3d.F:2
ad_exchange_3d_mod::ad_exchange_v3d_tile
subroutine ad_exchange_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:1283
ad_exchange_3d_mod::ad_exchange_r3d_tile
subroutine ad_exchange_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:461
ad_exchange_3d_mod::ad_exchange_u3d_tile
subroutine ad_exchange_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:872
ad_nesting_mod
Definition ad_nesting.F:2
ad_nesting_mod::ad_get_contact2d
subroutine, private ad_get_contact2d(dg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, ad, ac)
Definition ad_nesting.F:6743
ad_nesting_mod::ad_put_contact3d
subroutine ad_put_contact3d(rg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, lbk, ubk, amask, ac, ad_ac, ad_ar)
Definition ad_nesting.F:5557
ad_nesting_mod::ad_fine2coarse3d
subroutine, private ad_fine2coarse3d(ng, dg, model, tile, gtype, svname, areaavg, rscale, cr, npoints, contact, lbif, ubif, lbjf, ubjf, lbkf, ubkf, lbic, ubic, lbjc, ubjc, lbkc, ubkc, adx, ady, pmc, pnc, amsk, cmsk, a, c)
Definition ad_nesting.F:6341
ad_nesting_mod::ad_nesting
subroutine, public ad_nesting(ng, model, isection)
Definition ad_nesting.F:136
ad_nesting_mod::ad_fine2coarse
subroutine, private ad_fine2coarse(ng, model, vtype, tile)
Definition ad_nesting.F:2534
ad_nesting_mod::ad_get_refine
subroutine, private ad_get_refine(ng, model, tile)
Definition ad_nesting.F:777
ad_nesting_mod::ad_get_contact3d
subroutine, private ad_get_contact3d(dg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, lbk, ubk, ad, ac)
Definition ad_nesting.F:6917
ad_nesting_mod::ad_get_persisted2d
subroutine, private ad_get_persisted2d(dg, rg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, ad, ac)
Definition ad_nesting.F:7098
ad_nesting_mod::ad_put_contact2d
subroutine ad_put_contact2d(rg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, amask, ac, ar)
Definition ad_nesting.F:5785
ad_nesting_mod::ad_put_refine2d
subroutine, private ad_put_refine2d(ng, dg, cr, model, tile, lputfsur, lbi, ubi, lbj, ubj)
Definition ad_nesting.F:3135
ad_nesting_mod::ad_correct_tracer
subroutine, private ad_correct_tracer(ng, ngf, model, tile)
Definition ad_nesting.F:1757
ad_nesting_mod::ad_z_weights
subroutine, private ad_z_weights(ng, model, tile)
Definition ad_nesting.F:4393
ad_nesting_mod::ad_check_massflux
subroutine, private ad_check_massflux(ngf, model, tile)
Definition ad_nesting.F:7580
ad_nesting_mod::ad_get_composite
subroutine, private ad_get_composite(ng, model, isection, tile)
Definition ad_nesting.F:399
ad_nesting_mod::ad_fine2coarse2d
subroutine, private ad_fine2coarse2d(ng, dg, model, tile, gtype, svname, areaavg, rscale, cr, npoints, contact, lbif, ubif, lbjf, ubjf, lbic, ubic, lbjc, ubjc, adx, ady, pmc, pnc, amsk, cmsk, a, c1, c2)
Definition ad_nesting.F:5926
ad_nesting_mod::ad_correct_tracer_tile
subroutine, private ad_correct_tracer_tile(ngc, ngf, model, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs)
Definition ad_nesting.F:1820
ad_nesting_mod::ad_bry_fluxes
subroutine, public ad_bry_fluxes(dg, rg, cr, model, tile, imins, imaxs, jmins, jmaxs, ilb, iub, jlb, jub, scale, fx, fe, f_west, f_east, f_south, f_north)
Definition ad_nesting.F:7326
ad_nesting_mod::ad_put_refine
subroutine, private ad_put_refine(ng, model, tile, lputfsur)
Definition ad_nesting.F:1636
ad_nesting_mod::ad_put_refine3d
subroutine, private ad_put_refine3d(ng, dg, cr, model, tile, lbi, ubi, lbj, ubj)
Definition ad_nesting.F:4037
ad_nesting_mod::ad_put_composite
subroutine, private ad_put_composite(ng, model, isection, tile)
Definition ad_nesting.F:1071
ad_set_depth_mod
Definition ad_set_depth.F:2
ad_set_depth_mod::ad_set_depth
subroutine, public ad_set_depth(ng, tile, model)
Definition ad_set_depth.F:36
distribute_mod
Definition distribute.F:3
distribute_mod::mp_aggregate3d
subroutine mp_aggregate3d(ng, model, gtype, lbit, ubit, lbjt, ubjt, lbig, ubig, lbjg, ubjg, lbk, ubk, atiled, aglobal)
Definition distribute.F:8866
distribute_mod::mp_aggregate2d
subroutine mp_aggregate2d(ng, model, gtype, lbit, ubit, lbjt, ubjt, lbig, ubig, lbjg, ubjg, atiled, aglobal)
Definition distribute.F:8665
mod_clima
Definition mod_clima.F:2
mod_clima::clima
type(t_clima), dimension(:), allocatable clima
Definition mod_clima.F:153
mod_coupling
Definition mod_coupling.F:2
mod_coupling::coupling
type(t_coupling), dimension(:), allocatable coupling
Definition mod_coupling.F:102
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_iounits
Definition mod_iounits.F:2
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::idubar
integer idubar
Definition mod_ncparam.F:325
mod_ncparam::idvvel
integer idvvel
Definition mod_ncparam.F:381
mod_ncparam::idfsur
integer idfsur
Definition mod_ncparam.F:206
mod_ncparam::idtvar
integer, dimension(:), allocatable idtvar
Definition mod_ncparam.F:568
mod_ncparam::idvfx1
integer idvfx1
Definition mod_ncparam.F:372
mod_ncparam::idvbms
integer idvbms
Definition mod_ncparam.F:365
mod_ncparam::iduvel
integer iduvel
Definition mod_ncparam.F:343
mod_ncparam::vname
character(len=maxlen), dimension(6, 0:nv) vname
Definition mod_ncparam.F:591
mod_ncparam::idrzet
integer idrzet
Definition mod_ncparam.F:286
mod_ncparam::idufx1
integer idufx1
Definition mod_ncparam.F:337
mod_ncparam::idubms
integer idubms
Definition mod_ncparam.F:330
mod_ncparam::idvbar
integer idvbar
Definition mod_ncparam.F:360
mod_nesting
Definition mod_nesting.F:2
mod_nesting::nrhst
integer, parameter nrhst
Definition mod_nesting.F:87
mod_nesting::ngetd
integer, parameter ngetd
Definition mod_nesting.F:77
mod_nesting::n2dfx
integer, parameter n2dfx
Definition mod_nesting.F:92
mod_nesting::nputd
integer, parameter nputd
Definition mod_nesting.F:79
mod_nesting::nzeta
integer, parameter nzeta
Definition mod_nesting.F:88
mod_nesting::vcontact
type(t_ngc), dimension(:), allocatable vcontact
Definition mod_nesting.F:288
mod_nesting::bry_contact
type(t_bcp), dimension(:,:), allocatable bry_contact
Definition mod_nesting.F:335
mod_nesting::ntvic
integer, parameter ntvic
Definition mod_nesting.F:85
mod_nesting::rollingindex
integer, dimension(:), allocatable rollingindex
Definition mod_nesting.F:178
mod_nesting::nstrv
integer, dimension(:), allocatable nstrv
Definition mod_nesting.F:207
mod_nesting::nzwgt
integer, parameter nzwgt
Definition mod_nesting.F:89
mod_nesting::on_boundary
integer, dimension(:), allocatable on_boundary
Definition mod_nesting.F:210
mod_nesting::ndxdy
integer, parameter ndxdy
Definition mod_nesting.F:76
mod_nesting::i_right
integer, dimension(:), allocatable i_right
Definition mod_nesting.F:194
mod_nesting::nfsic
integer, parameter nfsic
Definition mod_nesting.F:82
mod_nesting::i_left
integer, dimension(:), allocatable i_left
Definition mod_nesting.F:193
mod_nesting::nstru
integer, dimension(:), allocatable nstru
Definition mod_nesting.F:206
mod_nesting::n3dic
integer, parameter n3dic
Definition mod_nesting.F:84
mod_nesting::nmask
integer, parameter nmask
Definition mod_nesting.F:78
mod_nesting::n2way
integer, parameter n2way
Definition mod_nesting.F:80
mod_nesting::receiver_grid
integer, dimension(:), allocatable receiver_grid
Definition mod_nesting.F:173
mod_nesting::coarserdonor
integer, dimension(:), allocatable coarserdonor
Definition mod_nesting.F:138
mod_nesting::n3duv
integer, parameter n3duv
Definition mod_nesting.F:93
mod_nesting::donor_grid
integer, dimension(:), allocatable donor_grid
Definition mod_nesting.F:172
mod_nesting::j_bottom
integer, dimension(:), allocatable j_bottom
Definition mod_nesting.F:195
mod_nesting::n2dps
integer, parameter n2dps
Definition mod_nesting.F:90
mod_nesting::refined
type(t_refined), dimension(:), allocatable refined
Definition mod_nesting.F:437
mod_nesting::j_top
integer, dimension(:), allocatable j_top
Definition mod_nesting.F:196
mod_nesting::composite
type(t_composite), dimension(:), allocatable composite
Definition mod_nesting.F:409
mod_nesting::n2dic
integer, parameter n2dic
Definition mod_nesting.F:83
mod_nesting::n3dtv
integer, parameter n3dtv
Definition mod_nesting.F:94
mod_nesting::rcontact
type(t_ngc), dimension(:), allocatable rcontact
Definition mod_nesting.F:286
mod_nesting::nbstr
integer, parameter nbstr
Definition mod_nesting.F:86
mod_nesting::rollingtime
real(dp), dimension(:,:), allocatable rollingtime
Definition mod_nesting.F:179
mod_nesting::nstrr
integer, dimension(:), allocatable nstrr
Definition mod_nesting.F:205
mod_nesting::get_vweights
logical get_vweights
Definition mod_nesting.F:130
mod_nesting::ucontact
type(t_ngc), dimension(:), allocatable ucontact
Definition mod_nesting.F:287
mod_nesting::nmflx
integer, parameter nmflx
Definition mod_nesting.F:75
mod_nesting::ncontact
integer ncontact
Definition mod_nesting.F:256
mod_nesting::n2dcs
integer, parameter n2dcs
Definition mod_nesting.F:91
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_parallel
Definition mod_parallel.F:2
mod_parallel::first_tile
integer, dimension(:), allocatable first_tile
Definition mod_parallel.F:62
mod_parallel::master
logical master
Definition mod_parallel.F:40
mod_parallel::last_tile
integer, dimension(:), allocatable last_tile
Definition mod_parallel.F:63
mod_param
Definition mod_param.F:2
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::bounds
type(t_bounds), dimension(:), allocatable bounds
Definition mod_param.F:232
mod_param::r3dvar
integer, parameter r3dvar
Definition mod_param.F:721
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::u3dvar
integer, parameter u3dvar
Definition mod_param.F:722
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_param::u2dvar
integer, parameter u2dvar
Definition mod_param.F:718
mod_param::w3dvar
integer, parameter w3dvar
Definition mod_param.F:724
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_param::r2dvar
integer, parameter r2dvar
Definition mod_param.F:717
mod_param::v2dvar
integer, parameter v2dvar
Definition mod_param.F:719
mod_param::v3dvar
integer, parameter v3dvar
Definition mod_param.F:723
mod_scalars
Definition mod_scalars.F:2
mod_scalars::iic
integer, dimension(:), allocatable iic
Definition mod_scalars.F:249
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::dcrit
real(r8), dimension(:), allocatable dcrit
Definition mod_scalars.F:782
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::indx1
integer, dimension(:), allocatable indx1
Definition mod_scalars.F:248
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::dxmax
real(dp), dimension(:), allocatable dxmax
Definition mod_scalars.F:675
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::time
real(dp), dimension(:), allocatable time
Definition mod_scalars.F:262
mod_scalars::refinedgrid
logical, dimension(:), allocatable refinedgrid
Definition mod_scalars.F:494
mod_scalars::ltracerclm
logical, dimension(:,:), allocatable ltracerclm
Definition mod_scalars.F:528
mod_scalars::refinescale
integer, dimension(:), allocatable refinescale
Definition mod_scalars.F:498
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::lnudgetclm
logical, dimension(:,:), allocatable lnudgetclm
Definition mod_scalars.F:535
mod_scalars::iif
integer, dimension(:), allocatable iif
Definition mod_scalars.F:250
mod_scalars::noerror
integer noerror
Definition mod_scalars.F:561
mod_stepping
Definition mod_stepping.F:2
mod_stepping::knew
integer, dimension(:), allocatable knew
Definition mod_stepping.F:64
mod_stepping::nnew
integer, dimension(:), allocatable nnew
Definition mod_stepping.F:69
mod_stepping::nstp
integer, dimension(:), allocatable nstp
Definition mod_stepping.F:71
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::ad_mp_exchange3d
subroutine ad_mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:5451
mp_exchange_mod::ad_mp_exchange4d
subroutine ad_mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c)
Definition mp_exchange.F:7058
mp_exchange_mod::ad_mp_exchange2d
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:4058
nesting_mod
Definition nesting.F:2
nesting_mod::get_persisted2d
subroutine, public get_persisted2d(dg, rg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, ad, ac)
Definition nesting.F:5150
nesting_mod::get_contact3d
subroutine, public get_contact3d(dg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, lbk, ubk, ad, ac)
Definition nesting.F:4988
nesting_mod::z_weights
subroutine, public z_weights(ng, model, tile)
Definition nesting.F:6450
nesting_mod::get_metrics
subroutine, public get_metrics(ng, model, tile)
Definition nesting.F:2245
nesting_mod::get_contact2d
subroutine, public get_contact2d(dg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, ad, ac)
Definition nesting.F:4829
nesting_mod::mask_hweights
subroutine, public mask_hweights(ng, model, tile)
Definition nesting.F:1200
set_depth_mod
Definition set_depth.F:2
set_depth_mod::set_depth
subroutine, public set_depth(ng, tile, model)
Definition set_depth.F:34
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
mod_nesting::t_ngc
Definition mod_nesting.F:258