ROMS
Loading...
Searching...
No Matches
Functions/Subroutines
nesting_mod Module Reference

Functions/Subroutines

subroutine, public nesting (ng, model, isection)
 
subroutine, public 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)
 
subroutine, public check_massflux (ngf, model, tile)
 
subroutine, public fill_contact (rg, model, tile, cr, npoints, contact, gtype, mvname, spvalcheck, lbi, ubi, lbj, ubj, ac, ar)
 
subroutine, public mask_hweights (ng, model, tile)
 
subroutine, private get_composite (ng, model, isection, tile)
 
subroutine, public get_metrics (ng, model, tile)
 
subroutine, private get_refine (ng, model, tile)
 
subroutine, private put_composite (ng, model, isection, tile)
 
subroutine, private put_refine (ng, model, tile, lputfsur)
 
subroutine, private correct_tracer (ng, ngf, model, tile)
 
subroutine, private correct_tracer_tile (ngc, ngf, model, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs)
 
subroutine, private fine2coarse (ng, model, vtype, tile)
 
subroutine, public fine2coarse2d (ng, dg, model, tile, gtype, svname, areaavg, rscale, cr, npoints, contact, lbif, ubif, lbjf, ubjf, lbic, ubic, lbjc, ubjc, adx, ady, pmc, pnc, hhc, amsk, cmsk, a, c1, c2)
 
subroutine, public 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)
 
subroutine, public get_contact2d (dg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, ad, ac)
 
subroutine, public get_contact3d (dg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, lbk, ubk, ad, ac)
 
subroutine, public get_persisted2d (dg, rg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, ad, ac)
 
subroutine put_contact2d (rg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, amask, ac, ar)
 
subroutine put_contact3d (rg, model, tile, gtype, svname, cr, npoints, contact, lbi, ubi, lbj, ubj, lbk, ubk, amask, ac, ar)
 
subroutine, private put_refine2d (ng, dg, cr, model, tile, lputfsur, lbi, ubi, lbj, ubj)
 
subroutine, private put_refine3d (ng, dg, cr, model, tile, lbi, ubi, lbj, ubj)
 
subroutine, public z_weights (ng, model, tile)
 

Function/Subroutine Documentation

◆ bry_fluxes()

subroutine, public nesting_mod::bry_fluxes ( integer, intent(in) dg,
integer, intent(in) rg,
integer, intent(in) cr,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs,
integer, intent(in) ilb,
integer, intent(in) iub,
integer, intent(in) jlb,
integer, intent(in) jub,
real(dp), intent(in) scale,
real(r8), dimension(imins:,jmins:), intent(in) fx,
real(r8), dimension(imins:,jmins:), intent(in) fe,
real(r8), dimension (jlb:), intent(inout) f_west,
real(r8), dimension (jlb:), intent(inout) f_east,
real(r8), dimension(ilb:), intent(inout) f_south,
real(r8), dimension(ilb:), intent(inout) f_north )

Definition at line 376 of file nesting.F.

381!
382!=======================================================================
383! !
384! This routine extracts tracer horizontal advective fluxes (Hz*u*T/n, !
385! Hz*v*T/m) at the grid contact boundary (physical domain perimeter). !
386! The data source is either the coarse or finer grid. These fluxes !
387! are used for in two-way nesting. b !
388! !
389! On Input: !
390! !
391! dg Donor grid number (integer) !
392! rg Receiver grid number (integer) !
393! cr Contact region number to process (integer) !
394! model Calling model identifier (integer) !
395! tile Domain tile partition (integer) !
396! scale Advective flux scale (floating-point) !
397! IminS Advective flux, I-dimension Lower bound (integer) !
398! ImaxS Advective flux, I-dimension Upper bound (integer) !
399! JminS Advective flux, J-dimension Lower bound (integer) !
400! JmaxS Advective flux, J-dimension Upper bound (integer) !
401! ILB Western/Eastern boundary flux Lower bound (integer) !
402! IUB Western/Eastern boundary flux Upper bound (integer) !
403! JLB Southern/Northern boundary flux Lower bound (integer) !
404! JUB Southern/Northern boundary flux Lower bound (integer) !
405! FX Horizontal advetive flux in the XI-direction (array) !
406! FE Horizontal advetive flux in the ETA-direction (array) !
407! !
408! On Output: !
409! !
410! F_west Western boundary advective flux (1D array) !
411! F_east Eastern boundary advective flux (1D array) !
412! F_south Southern boundary advective flux (1D array) !
413! F_north Northerb boundary advective flux (1D array) !
414! !
415!=======================================================================
416!
417 USE mod_param
418 USE mod_parallel
419 USE mod_nesting
420 USE mod_scalars
421!
422# ifdef DISTRIBUTE
423
424 USE distribute_mod, ONLY : mp_assemble
425# endif
426 USE strings_mod, ONLY : founderror
427!
428! Imported variable declarations.
429!
430 integer, intent(in) :: dg, rg, cr, model, tile
431 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
432 integer, intent(in) :: ILB, IUB, JLB, JUB
433
434 real(dp), intent(in) :: scale
435!
436# ifdef ASSUMED_SHAPE
437 real(r8), intent(in) :: FX(IminS:,JminS:)
438 real(r8), intent(in) :: FE(IminS:,JminS:)
439
440 real(r8), intent(inout) :: F_west (JLB:)
441 real(r8), intent(inout) :: F_east (JLB:)
442 real(r8), intent(inout) :: F_south(ILB:)
443 real(r8), intent(inout) :: F_north(ILB:)
444# else
445 real(r8), intent(in) :: FX(IminS:ImaxS,JminS:JmaxS)
446 real(r8), intent(in) :: FE(IminS:ImaxS,JminS:JmaxS)
447
448 real(r8), intent(inout) :: F_west (JLB:JUB)
449 real(r8), intent(inout) :: F_east (JLB:JUB)
450 real(r8), intent(inout) :: F_south(ILB:IUB)
451 real(r8), intent(inout) :: F_north(ILB:IUB)
452# endif
453!
454! Local variable declarations.
455!
456 integer :: Istr, Iend, Jstr, Jend
457 integer :: Ib_east, Ib_west, Jb_north, Jb_south
458 integer :: i, j, m
459
460# ifdef DISTRIBUTE
461 integer :: NptsWE, NptsSN
462# endif
463!
464 real(r8), parameter :: Fspv = 0.0_r8
465!
466 character (len=*), parameter :: MyFile = &
467 & __FILE__//", bry_fluxes"
468!
469!-----------------------------------------------------------------------
470! Initialize local variables.
471!-----------------------------------------------------------------------
472!
473! Set tile starting and ending indices.
474!
475 istr=bounds(rg)%Istr(tile)
476 iend=bounds(rg)%Iend(tile)
477 jstr=bounds(rg)%Jstr(tile)
478 jend=bounds(rg)%Jend(tile)
479
480# ifdef DISTRIBUTE
481!
482! Initialize arrays to facilitate collective communications.
483!
484 nptswe=jub-jlb+1
485 nptssn=iub-ilb+1
486# endif
487!
488!-----------------------------------------------------------------------
489! If "rg" is the finer grid, extract advective tracer flux at its
490! physical domain boundaries (grid perimeter).
491!-----------------------------------------------------------------------
492!
493! Receiver finer grid number is greater than donor coaser grid number
494! because of refinement nesting layers.
495!
496 IF (rg.gt.dg) THEN
497!
498! Reset fluxes to zero for first entry of receiver finer grid.
499!
500 IF (mod(iic(rg)-1,refinesteps(rg)).eq.0) THEN
501 f_west =fspv
502 f_east =fspv
503 f_south=fspv
504 f_north=fspv
505 END IF
506!
507! Western boundary.
508!
509 IF (domain(dg)%Western_Edge(tile)) THEN
510 DO j=jstr,jend
511 f_west(j)=f_west(j)+fx(istr,j)*scale
512 END DO
513 DO j=jlb,jstr-1
514 f_west(j)=fspv
515 END DO
516 DO j=jend+1,jub
517 f_west(j)=fspv
518 END DO
519 ELSE
520 f_west=fspv
521 END IF
522!
523! Eastern boundary.
524!
525 IF (domain(dg)%Eastern_Edge(tile)) THEN
526 DO j=jstr,jend
527 f_east(j)=f_east(j)+fx(iend+1,j)*scale
528 END DO
529 DO j=jlb,jstr-1
530 f_east(j)=fspv
531 END DO
532 DO j=jend+1,jub
533 f_east(j)=fspv
534 END DO
535 ELSE
536 f_east=fspv
537 END IF
538!
539! Southern boundary.
540!
541 IF (domain(dg)%Southern_Edge(tile)) THEN
542 DO i=istr,iend
543 f_south(i)=f_south(i)+fe(i,jstr)*scale
544 END DO
545 DO i=ilb,istr-1
546 f_south(i)=fspv
547 END DO
548 DO i=iend+1,iub
549 f_south(i)=fspv
550 END DO
551 ELSE
552 f_south=fspv
553 END IF
554!
555! Northern boundary.
556!
557 IF (domain(dg)%Northern_Edge(tile)) THEN
558 DO i=istr,iend
559 f_north(i)=f_north(i)+fe(i,jend+1)*scale
560 END DO
561 DO i=ilb,istr-1
562 f_north(i)=fspv
563 END DO
564 DO i=iend+1,iub
565 f_north(i)=fspv
566 END DO
567 ELSE
568 f_north=fspv
569 END IF
570!
571!-----------------------------------------------------------------------
572! If "rg" is the coarser grid, extract coarser grid advective tracer
573! flux at the location of the finer grid physical domain boundaries
574! (grid perimeter).
575!-----------------------------------------------------------------------
576!
577! Receiver coarser grid number is smaller than donor finer grid number
578! because of refinement nesting layers.
579!
580 ELSE IF (rg.lt.dg) THEN
581!
582! Western/Eastern boundaries.
583!
584 f_west =fspv
585 f_east =fspv
586 f_south=fspv
587 f_north=fspv
588!
589 ib_west=i_left(dg)
590 ib_east=i_right(dg)
591 DO j=jstr,jend
592 IF ((istr.le.ib_west).and.(ib_west.le.iend)) THEN
593 f_west(j)=fx(ib_west,j)*scale
594 END IF
595!
596 IF ((istr.le.ib_east).and.(ib_east.le.iend)) THEN
597 f_east(j)=fx(ib_east,j)*scale
598 END IF
599 END DO
600!
601! Southern/Northern boundaries.
602!
603 jb_south=j_bottom(dg)
604 jb_north=j_top(dg)
605 DO i=istr,iend
606 IF ((jstr.le.jb_south).and.(jb_south.le.jend)) THEN
607 f_south(i)=fe(i,jb_south)*scale
608 END IF
609!
610 IF ((jstr.le.jb_north).and.(jb_north.le.jend)) THEN
611 f_north(i)=fe(i,jb_north)*scale
612 END IF
613 END DO
614 END IF
615
616# ifdef DISTRIBUTE
617!
618!-----------------------------------------------------------------------
619! Gather and broadcast data from all nodes.
620!-----------------------------------------------------------------------
621!
622 CALL mp_assemble (dg, model, nptswe, fspv, f_west(jlb:))
623 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
624
625 CALL mp_assemble (dg, model, nptswe, fspv, f_east(jlb:))
626 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
627
628 CALL mp_assemble (dg, model, nptssn, fspv, f_south(ilb:))
629 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
630
631 CALL mp_assemble (dg, model, nptssn, fspv, f_north(ilb:))
632 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
633# endif
634!
635 RETURN
distribute_mod::mp_assemble
Definition distribute.F:67
distribute_mod
Definition distribute.F:3
mod_nesting
Definition mod_nesting.F:2
mod_nesting::refinesteps
integer, dimension(:), allocatable refinesteps
Definition mod_nesting.F:156
mod_nesting::i_right
integer, dimension(:), allocatable i_right
Definition mod_nesting.F:194
mod_nesting::i_left
integer, dimension(:), allocatable i_left
Definition mod_nesting.F:193
mod_nesting::j_bottom
integer, dimension(:), allocatable j_bottom
Definition mod_nesting.F:195
mod_nesting::j_top
integer, dimension(:), allocatable j_top
Definition mod_nesting.F:196
mod_parallel
Definition mod_parallel.F:2
mod_param
Definition mod_param.F:2
mod_param::bounds
type(t_bounds), dimension(:), allocatable bounds
Definition mod_param.F:232
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_scalars
Definition mod_scalars.F:2
mod_scalars::iic
integer, dimension(:), allocatable iic
Definition mod_scalars.F:249
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::noerror
integer noerror
Definition mod_scalars.F:561
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52

References mod_param::bounds, mod_param::domain, mod_scalars::exit_flag, strings_mod::founderror(), mod_nesting::i_left, mod_nesting::i_right, mod_scalars::iic, mod_nesting::j_bottom, mod_nesting::j_top, mod_scalars::noerror, and mod_nesting::refinesteps.

Referenced by step3d_t_mod::step3d_t_tile().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ check_massflux()

subroutine, public nesting_mod::check_massflux ( integer, intent(in) ngf,
integer, intent(in) model,
integer, intent(in) tile )

Definition at line 640 of file nesting.F.

641!
642!=======================================================================
643! !
644! If refinement, this routine check mass fluxes between coarse and !
645! fine grids for mass and volume conservation. It is only used for !
646! diagnostic purposes. !
647! !
648! On Input: !
649! !
650! ngf Finer grid number (integer) !
651! model Calling model identifier (integer) !
652! tile Domain tile partition (integer) !
653! !
654! On Output: (mod_nesting) !
655! !
656! BRY_CONTACT Updated Mflux in structure. !
657! !
658!=======================================================================
659!
660 USE mod_param
661 USE mod_parallel
662 USE mod_nesting
663 USE mod_scalars
664
665# ifdef DISTRIBUTE
666!
667 USE distribute_mod, ONLY : mp_assemble
668# endif
669!
670! Imported variable declarations.
671!
672 integer, intent(in) :: ngf, model, tile
673!
674! Local variable declarations.
675!
676# ifdef DISTRIBUTE
677 integer :: ILB, IUB, JLB, JUB, NptsSN, NptsWE, my_tile
678# endif
679 integer :: Iedge, Ibc, Ibc_min, Ibc_max, Ibf, Io
680 integer :: Jedge, Jbc, Jbc_min, Jbc_max, Jbf, Jo
681 integer :: Istr, Iend, Jstr, Jend
682 integer :: cjcr, cr, dg, half, icr, isum, jsum, m, rg
683 integer :: tnew, told
684
685# ifdef DISTRIBUTE
686 real(r8), parameter :: spv = 0.0_r8
687# endif
688 real(r8) :: EastSum, NorthSum, SouthSum, WestSum
689 real(r8) :: MFratio
690!
691!-----------------------------------------------------------------------
692! Check mass and volume conservation during refinement between coarse
693! and fine grids.
694!-----------------------------------------------------------------------
695!
696 DO cr=1,ncontact
697!
698! Get data donor and data receiver grid numbers.
699!
700 dg=rcontact(cr)%donor_grid
701 rg=rcontact(cr)%receiver_grid
702!
703! Process only contact region data for requested nested finer grid
704! "ngf". Notice that the donor grid is coarser than receiver grid.
705!
706 IF ((rg.eq.ngf).and.(dxmax(dg).gt.dxmax(rg))) THEN
707!
708! Set tile starting and ending indices for donor coarser grid.
709!
710 istr=bounds(dg)%Istr(tile)
711 iend=bounds(dg)%Iend(tile)
712 jstr=bounds(dg)%Jstr(tile)
713 jend=bounds(dg)%Jend(tile)
714!
715! Set time rolling indices and conjugate region where the coarser
716! donor grid becomes the receiver grid.
717!
718 told=3-rollingindex(cr)
719 tnew=rollingindex(cr)
720 DO icr=1,ncontact
721 IF ((rg.eq.rcontact(icr)%donor_grid).and. &
722 & (dg.eq.rcontact(icr)%receiver_grid)) THEN
723 cjcr=icr
724 EXIT
725 END IF
726 END DO
727
728# ifdef DISTRIBUTE
729!
730! Set global size of boundary edges for coarse grid (donor index).
731!
732 my_tile=-1
733 ilb=bounds(dg)%LBi(my_tile)
734 iub=bounds(dg)%UBi(my_tile)
735 jlb=bounds(dg)%LBj(my_tile)
736 jub=bounds(dg)%UBj(my_tile)
737 nptswe=jub-jlb+1
738 nptssn=iub-ilb+1
739!
740! If distributed-memory, initialize arrays used to check mass flux
741! conservation with special value (zero) to facilitate the global
742! reduction when collecting data between all nodes.
743!
744 bry_contact(iwest ,cjcr)%Mflux=spv
745 bry_contact(ieast ,cjcr)%Mflux=spv
746 bry_contact(isouth,cjcr)%Mflux=spv
747 bry_contact(inorth,cjcr)%Mflux=spv
748# endif
749!
750! Set finer grid center (half) and offset indices (Io and Jo) for
751! coarser grid (I,J) coordinates.
752!
753 half=(refinescale(ngf)-1)/2
754 io=half+1
755 jo=half+1
756!
757!-----------------------------------------------------------------------
758! Average finer grid western boundary mass fluxes and load them to the
759! BRY_CONTACT structure.
760!-----------------------------------------------------------------------
761!
762 ibc=i_left(ngf)
763 jbc_min=j_bottom(ngf)
764 jbc_max=j_top(ngf)-1 ! interior points, no top
765! left corner
766 IF (domain(ngf)%SouthWest_Test(tile)) THEN
767 IF (master) THEN
768 WRITE (300,10) 'Western Boundary Mass Fluxes: ', &
769 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
770 FLUSH (300)
771 END IF
772 END IF
773!
774 DO jbc=jstr,jend
775 IF (((istr.le.ibc).and.(ibc.le.iend)).and. &
776 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
777!
778! Sum finer grid western boundary mass fluxes within coarser grid cell.
779!
780 westsum=0.0_r8
781 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
782 DO jsum=-half,half
783 jbf=jedge+jsum
784 westsum=westsum+bry_contact(iwest,cr)%Mflux(jbf)
785 END DO
786 m=bry_contact(iwest,cr)%C2Bindex(jbf) ! pick last one
787!
788! Load coarser grid western boundary mass flux that have been averaged
789! from finer grid. These values can be compared with the coarser grid
790! values REFINED(cr)%U2d_flux to check if the mass flux between coarser
791! and finer grid is conserved.
792!
793 bry_contact(iwest,cjcr)%Mflux(jbc)=westsum
794 IF (westsum.ne.0) THEN
795 mfratio=refined(cr)%U2d_flux(1,m,tnew)/westsum
796 ELSE
797 mfratio=1.0_r8
798 END IF
799 WRITE (300,30) jbc, refined(cr)%U2d_flux(1,m,tnew), &
800 & westsum, mfratio
801 FLUSH (300)
802 END IF
803 END DO
804!
805!-----------------------------------------------------------------------
806! Average finer grid eastern boundary mass fluxes and load them to the
807! BRY_CONTACT structure.
808!-----------------------------------------------------------------------
809!
810 ibc=i_right(ngf)
811 jbc_min=j_bottom(ngf)
812 jbc_max=j_top(ngf)-1 ! interior points, no top
813! right corner
814 IF (domain(ngf)%SouthWest_Test(tile)) THEN
815 IF (master) THEN
816 WRITE (300,10) 'Eastern Boundary Mass Fluxes: ', &
817 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
818 FLUSH (300)
819 END IF
820 END IF
821!
822 DO jbc=jstr,jend
823 IF (((istr.le.ibc).and.(ibc.le.iend)).and. &
824 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
825!
826! Sum finer grid eastern boundary mass fluxes within coarser grid cell.
827!
828 eastsum=0.0_r8
829 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
830 DO jsum=-half,half
831 jbf=jedge+jsum
832 eastsum=eastsum+bry_contact(ieast,cr)%Mflux(jbf)
833 END DO
834 m=bry_contact(ieast,cr)%C2Bindex(jbf) ! pick last one
835!
836! Load coarser grid eastern boundary mass flux that have been averaged
837! from finer grid. These values can be compared with the coarser grid
838! values REFINED(cr)%U2d_flux to check if the mass flux between coarser
839! and finer grid is conserved.
840!
841 bry_contact(ieast,cjcr)%Mflux(jbc)=eastsum
842 IF (eastsum.ne.0) THEN
843 mfratio=refined(cr)%U2d_flux(1,m,tnew)/eastsum
844 ELSE
845 mfratio=1.0_r8
846 END IF
847 WRITE (300,30) jbc, refined(cr)%U2d_flux(1,m,tnew), &
848 & eastsum, mfratio
849 FLUSH (300)
850 END IF
851 END DO
852!
853!-----------------------------------------------------------------------
854! Average finer grid southern boundary mass fluxes and load them to the
855! BRY_CONTACT structure.
856!-----------------------------------------------------------------------
857!
858 jbc=j_bottom(ngf)
859 ibc_min=i_left(ngf)
860 ibc_max=i_right(ngf)-1 ! interior points, no bottom
861! right corner
862 IF (domain(ngf)%SouthWest_Test(tile)) THEN
863 IF (master) THEN
864 WRITE (300,20) 'Southern Boundary Mass Fluxes: ', &
865 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
866 FLUSH (300)
867 END IF
868 END IF
869!
870 DO ibc=istr,iend
871 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
872 & ((jstr.le.jbc).and.(jbc.le.jend))) THEN
873!
874! Sum finer grid southern boundary mass fluxes within coarser grid
875! cell.
876!
877 southsum=0.0_r8
878 iedge=io+(ibc-ibc_min)*refinescale(ngf)
879 DO isum=-half,half
880 ibf=iedge+isum
881 southsum=southsum+bry_contact(isouth,cr)%Mflux(ibf)
882 END DO
883 m=bry_contact(isouth,cr)%C2Bindex(ibf) ! pick last one
884!
885! Load coarser grid southern boundary mass flux that have been averaged
886! from finer grid. These values can be compared with the coarser grid
887! values REFINED(cr)%V2d_flux to check if the mass flux between coarser
888! and finer grid is conserved.
889!
890 bry_contact(isouth,cjcr)%Mflux(ibc)=southsum
891 IF (southsum.ne.0) THEN
892 mfratio=refined(cr)%V2d_flux(1,m,tnew)/southsum
893 ELSE
894 mfratio=1.0_r8
895 END IF
896 WRITE (300,30) ibc, refined(cr)%V2d_flux(1,m,tnew), &
897 & southsum, mfratio
898 FLUSH (300)
899 END IF
900 END DO
901!
902!-----------------------------------------------------------------------
903! Average finer grid northern boundary mass fluxes and load them to the
904! BRY_CONTACT structure.
905!-----------------------------------------------------------------------
906!
907 jbc=j_top(ngf)
908 ibc_min=i_left(ngf)
909 ibc_max=i_right(ngf)-1 ! interior points, no top
910! right corner
911 IF (domain(ngf)%SouthWest_Test(tile)) THEN
912 IF (master) THEN
913 WRITE (300,20) 'Northern Boundary Mass Fluxes: ', &
914 & cr, dg, rg, iif(rg), iic(rg), int(time(rg))
915 FLUSH (300)
916 END IF
917 END IF
918!
919 DO ibc=istr,iend
920 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
921 & ((jstr.le.jbc).and.(jbc.le.jend))) THEN
922!
923! Sum finer grid northern boundary mass fluxes within coarser grid
924! cell.
925!
926 northsum=0.0_r8
927 iedge=io+(ibc-ibc_min)*refinescale(ngf)
928 DO isum=-half,half
929 ibf=iedge+isum
930 northsum=northsum+bry_contact(inorth,cr)%Mflux(ibf)
931 END DO
932 m=bry_contact(inorth,cr)%C2Bindex(ibf) ! pick last one
933!
934! Load coarser grid northern boundary mass flux that have been averaged
935! from finer grid. These values can be compared with the coarser grid
936! values REFINED(cr)%V2d_flux to check if the mass flux between coarser
937! and finer grid is conserved.
938!
939 bry_contact(inorth,cjcr)%Mflux(ibc)=northsum
940 IF (northsum.ne.0) THEN
941 mfratio=refined(cr)%V2d_flux(1,m,tnew)/northsum
942 ELSE
943 mfratio=1.0_r8
944 END IF
945 WRITE (300,30) ibc, refined(cr)%V2d_flux(1,m,tnew), &
946 & northsum, mfratio
947 END IF
948 END DO
949
950# ifdef DISTRIBUTE
951!
952! Collect data from all nodes.
953!
954 CALL mp_assemble (dg, model, nptswe, spv, &
955 & bry_contact(iwest ,cjcr)%Mflux(jlb:))
956 CALL mp_assemble (dg, model, nptswe, spv, &
957 & bry_contact(ieast ,cjcr)%Mflux(jlb:))
958 CALL mp_assemble (dg, model, nptssn, spv, &
959 & bry_contact(isouth,cjcr)%Mflux(ilb:))
960 CALL mp_assemble (dg, model, nptssn, spv, &
961 & bry_contact(inorth,cjcr)%Mflux(ilb:))
962# endif
963 END IF
964 END DO
965!
966 FLUSH (300)
967!
968 10 FORMAT (/,1x,a,/,/,4x,'cr = ',i2.2,4x,'dg = ',i2.2,4x,'rg = ', &
969 & i2.2,4x,'iif(rg) = ',i3.3,4x,'iic(rg) = ',i7.7,4x, &
970 & 'time(rg) = ',i7.7,/,/,2x,'Coarse',6x,'Coarse Grid',8x, &
971 & 'Fine Grid',11x,'Ratio',/,4x,'Jb',9x,'U2d_flux',9x, &
972 & 'SUM(U2d_flux)',/)
973 20 FORMAT (/,1x,a,/,/,4x,'cr = ',i2.2,4x,'dg = ',i2.2,4x,'rg = ', &
974 & i2.2,4x,'iif(rg) = ',i3.3,4x,'iic(rg) = ',i7.7,4x, &
975 & 'time(rg) = ',i7.7,/,/,2x,'Coarse',6x,'Coarse Grid',8x, &
976 & 'Fine Grid',11x,'Ratio',/,4x,'Ib',9x,'V2d_flux',9x, &
977 & 'SUM(V2d_flux)',/)
978 30 FORMAT (4x,i4.4,3(3x,1p,e15.8))
979!
980 RETURN
mod_nesting::bry_contact
type(t_bcp), dimension(:,:), allocatable bry_contact
Definition mod_nesting.F:335
mod_nesting::rollingindex
integer, dimension(:), allocatable rollingindex
Definition mod_nesting.F:178
mod_nesting::refined
type(t_refined), dimension(:), allocatable refined
Definition mod_nesting.F:437
mod_nesting::rcontact
type(t_ngc), dimension(:), allocatable rcontact
Definition mod_nesting.F:286
mod_nesting::ncontact
integer ncontact
Definition mod_nesting.F:256
mod_parallel::master
logical master
Definition mod_parallel.F:40
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
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::refinescale
integer, dimension(:), allocatable refinescale
Definition mod_scalars.F:498
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::iif
integer, dimension(:), allocatable iif
Definition mod_scalars.F:250

References mod_param::bounds, mod_nesting::bry_contact, mod_nesting::coarserdonor, mod_param::domain, mod_scalars::dt, mod_scalars::dxmax, mod_nesting::finerdonor, mod_nesting::i_left, mod_nesting::i_right, mod_param::iadm, mod_scalars::ieast, mod_scalars::iic, mod_scalars::iif, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_nesting::j_bottom, mod_nesting::j_top, mod_parallel::master, mod_nesting::ncontact, mod_nesting::rcontact, mod_nesting::refined, mod_scalars::refinedgrid, mod_scalars::refinescale, mod_nesting::refinesteps, mod_nesting::rollingindex, mod_nesting::telescoping, mod_scalars::time, and mod_nesting::twowayinterval.

Referenced by nesting().

Here is the caller graph for this function:

◆ correct_tracer()

subroutine, private nesting_mod::correct_tracer ( integer, intent(in) ng,
integer, intent(in) ngf,
integer, intent(in) model,
integer, intent(in) tile )
private

Definition at line 3047 of file nesting.F.

3048!
3049!=======================================================================
3050! !
3051! This routine corrects the tracer values in the coarser grid at the !
3052! location of the finer grid physical domain perimeter by comparing !
3053! vertically accumulated horizontal tracer flux (Hz*u*T/n, Hz*v*T/m) !
3054! in two-way nesting refinement: !
3055! !
3056! coarse grid, t(:,jb,:,nstp,:) = t(:,jb,:,nstp,:) - FacJ (west, !
3057! east) !
3058! t(ib,:,:,nstp,:) = t(ib,:,:,nstp,:) - FacI (south, !
3059! north) !
3060! where !
3061! !
3062! FacJ = (TFF(jb,itrc) - TFC(jb,itrc)) * !
3063! pm(:,jb) * pn(:,jb) / D(:,jb) !
3064! !
3065! TFF(ib,itrc) = SUM[SUM[Tflux(ib,k,itrc)]] finer !
3066! grid !
3067! for k=1:N, 1:RefineScale flux !
3068! !
3069! TFC(ib,itrc) = SUM[Tflux(ib,k,itrc)] coarser !
3070! grid !
3071! for k=1:N flux !
3072! !
3073! Similarly, for the southern and northern tracer fluxes. !
3074! !
3075! !
3076! On Input: !
3077! !
3078! ngc Coarser grid number (integer) !
3079! ngf Finer grid number (integer) !
3080! model Calling model identifier (integer) !
3081! tile Domain tile partition (integer) !
3082! !
3083! On Output: (mod_ocean) !
3084! !
3085! t Updated coarse grid tracer values at finer grid !
3086! perimeter !
3087! !
3088!=======================================================================
3089!
3090 USE mod_param
3091!
3092! Imported variable declarations.
3093!
3094 integer, intent(in) :: ng, ngf, model, tile
3095!
3096! Local variable declarations.
3097!
3098# include "tile.h"
3099!
3100 CALL correct_tracer_tile (ng, ngf, model, tile, &
3101 lbi, ubi, lbj, ubj, &
3102 & imins, imaxs, jmins, jmaxs)
3103!
3104 RETURN

References correct_tracer_tile().

Referenced by nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ correct_tracer_tile()

subroutine, private nesting_mod::correct_tracer_tile ( integer, intent(in) ngc,
integer, intent(in) ngf,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) imins,
integer, intent(in) imaxs,
integer, intent(in) jmins,
integer, intent(in) jmaxs )
private

Definition at line 3108 of file nesting.F.

3111!***********************************************************************
3112!
3113 USE mod_param
3114 USE mod_clima
3115 USE mod_grid
3116 USE mod_ocean
3117 USE mod_nesting
3118 USE mod_scalars
3119 USE mod_stepping
3120
3121# ifdef DISTRIBUTE
3122!
3123 USE mp_exchange_mod, ONLY : mp_exchange4d
3124# endif
3125!
3126! Imported variable declarations.
3127!
3128 integer, intent(in) :: ngc, ngf, model, tile
3129 integer, intent(in) :: LBi, UBi, LBj, UBj
3130 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
3131!
3132! Local variable declarations.
3133!
3134 integer :: Iedge, Ibc, Ibc_min, Ibc_max, Ibf, Io
3135 integer :: Jedge, Jbc, Jbc_min, Jbc_max, Jbf, Jo
3136 integer :: Istr, Iend, Jstr, Jend
3137 integer :: Istrm2, Iendp2, Jstrm2, Jendp2
3138 integer :: Tindex, i, ic, isum, itrc, j, jsum, k, half
3139 integer :: cr, dg, dgcr, rg, rgcr
3140
3141 real(r8) :: TFC, TFF, Tvalue, cff
3142
3143 real(r8) :: Dinv(IminS:ImaxS,JminS:JmaxS)
3144!
3145!-----------------------------------------------------------------------
3146! Correct coarser grid tracer values at finer grid perimeter.
3147!-----------------------------------------------------------------------
3148!
3149! Determine contact regions where coarse grid is the donor and coarse
3150! grid is the receiver..
3151!
3152 DO cr=1,ncontact
3153 dg=donor_grid(cr)
3154 rg=receiver_grid(cr)
3155 IF ((ngc.eq.dg).and.(ngf.eq.rg)) THEN
3156 dgcr=cr ! coarse is donor
3157 ELSE IF ((ngc.eq.rg).and.(ngf.eq.dg)) THEN
3158 rgcr=cr ! coarse is receiver
3159 END IF
3160 END DO
3161!
3162! Set tile starting and ending indices for coarser grid.
3163!
3164 istr =bounds(ngc)%Istr (tile)
3165 iend =bounds(ngc)%Iend (tile)
3166 jstr =bounds(ngc)%Jstr (tile)
3167 jend =bounds(ngc)%Jend (tile)
3168!
3169 istrm2=bounds(ngc)%Istrm2(tile)
3170 iendp2=bounds(ngc)%Iendp2(tile)
3171 jstrm2=bounds(ngc)%Jstrm2(tile)
3172 jendp2=bounds(ngc)%Jendp2(tile)
3173!
3174! Compute coarser grid inverse water colunm thickness.
3175!
3176 DO j=jstrm2,jendp2
3177 DO i=istrm2,iendp2
3178 cff=grid(ngc)%Hz(i,j,1)
3179 DO k=2,n(rg)
3180 cff=cff+grid(ngc)%Hz(i,j,k)
3181 END DO
3182 dinv(i,j)=1.0_r8/cff
3183 END DO
3184 END DO
3185!
3186! Set finer grid center (half) and offset indices (Io and Jo) for
3187! coarser grid (I,J) coordinates.
3188!
3189 half=(refinescale(ngf)-1)/2
3190 io=half+1
3191 jo=half+1
3192!
3193! Set coarse grid tracer index to correct. Since the exchange of data
3194! is done at the bottom of main3d, we need to use the newest time
3195! index, I think.
3196!
3197!! Tindex=nstp(ngc) ! HGA: Why this index is stable? newest is nosy
3198 tindex=nnew(ngc)
3199!
3200!=======================================================================
3201! Compute vertically integrated horizontal advective tracer flux for
3202! coarser at the finer grid physical boundary. Then, correct coarser
3203! grid tracer values at that boundary.
3204!=======================================================================
3205!
3206! Initialize tracer counter index. The "tclm" array is only allocated
3207! to the NTCLM fields that need to be processed. This is done to
3208! reduce memory.
3209!
3210 ic=0
3211!
3212 t_loop : DO itrc=1,nt(ngc)
3213 ic=ic+1
3214!
3215!-----------------------------------------------------------------------
3216! Finer grid western boundary.
3217!-----------------------------------------------------------------------
3218!
3219 ibc=i_left(ngf)
3220 jbc_min=j_bottom(ngf)
3221 jbc_max=j_top(ngf)-1 ! interior points, no top
3222! left corner
3223 DO jbc=jstr,jend
3224 IF (((istr.le.ibc-1).and.(ibc-1.le.iend)).and. &
3225 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
3226!
3227! Sum vertically coarse grid horizontal advective tracer flux,
3228! Hz*u*T/n, from last time-step.
3229!
3230 tfc=0.0_r8
3231 DO k=1,n(ngc)
3232 tfc=tfc+bry_contact(iwest,rgcr)%Tflux(jbc,k,itrc)
3233 END DO
3234!
3235! Sum vertically and horizontally finer grid advective tracer flux.
3236! This is a vertical and horizontal J-integral because "RefineScale"
3237! sub-divisions are done in the finer grid in each single coarse grid
3238! at the J-edge.
3239!
3240 tff=0.0_r8
3241 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
3242 DO jsum=-half,half
3243 jbf=jedge+jsum
3244 DO k=1,n(ngf)
3245 tff=tff+bry_contact(iwest,dgcr)%Tflux(jbf,k,itrc)
3246 END DO
3247 END DO
3248!
3249! Zeroth order correction to fine grid time integral (RIL, 2016).
3250! Correct coarse grid tracer at the finer grid western boundary.
3251!
3252 cff=grid(ngc)%pm(ibc-1,jbc)* &
3253 & grid(ngc)%pn(ibc-1,jbc)* &
3254 & dinv(ibc-1,jbc)
3255 DO k=1,n(ngc)
3256 tvalue=max(0.0_r8, &
3257 & ocean(ngc)%t(ibc-1,jbc,k,tindex,itrc)- &
3258 & cff*(tff-tfc))
3259 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
3260 tvalue=tvalue+ &
3261 & dt(ngc)*clima(ngc)%Tnudgcof(ibc-1,jbc,k,itrc)* &
3262 & (clima(ngc)%tclm(ibc-1,jbc,k,ic)-tvalue)
3263 END IF
3264# ifdef MASKING
3265 tvalue=tvalue*grid(ngc)%rmask(ibc-1,jbc)
3266# endif
3267 ocean(ngc)%t(ibc-1,jbc,k,tindex,itrc)=tvalue
3268 END DO
3269 END IF
3270 END DO
3271!
3272!-----------------------------------------------------------------------
3273! Finer grid eastern boundary.
3274!-----------------------------------------------------------------------
3275!
3276 ibc=i_right(ngf)
3277 jbc_min=j_bottom(ngf)
3278 jbc_max=j_top(ngf)-1 ! interior points, no top
3279! right corner
3280 DO jbc=jstr,jend
3281 IF (((istr.le.ibc).and.(ibc.le.iend)).and. &
3282 & ((jbc_min.le.jbc).and.(jbc.le.jbc_max))) THEN
3283!
3284! Sum vertically coarse grid horizontal advective tracer flux,
3285! Hz*u*T/n, from last time-step.
3286!
3287 tfc=0.0_r8
3288 DO k=1,n(ngc)
3289 tfc=tfc+bry_contact(ieast,rgcr)%Tflux(jbc,k,itrc)
3290 END DO
3291!
3292! Sum vertically and horizontally finer grid advective tracer flux.
3293! This is a vertical and horizontal J-integral because "RefineScale"
3294! sub-divisions are done in the finer grid in each single coarse grid
3295! at the J-edge.
3296!
3297 tff=0.0_r8
3298 jedge=jo+(jbc-jbc_min)*refinescale(ngf)
3299 DO jsum=-half,half
3300 jbf=jedge+jsum
3301 DO k=1,n(ngf)
3302 tff=tff+bry_contact(ieast,dgcr)%Tflux(jbf,k,itrc)
3303 END DO
3304 END DO
3305!
3306! Zeroth order correction to fine grid time integral (RIL, 2016).
3307! Correct coarse grid tracer at the finer grid eastern boundary.
3308!
3309 cff=grid(ngc)%pm(ibc,jbc)* &
3310 & grid(ngc)%pn(ibc,jbc)* &
3311 & dinv(ibc,jbc)
3312 DO k=1,n(ngc)
3313 tvalue=max(0.0_r8, &
3314 & ocean(ngc)%t(ibc,jbc,k,tindex,itrc)- &
3315 & cff*(tff-tfc))
3316 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
3317 tvalue=tvalue+ &
3318 & dt(ngc)*clima(ngc)%Tnudgcof(ibc,jbc,k,itrc)* &
3319 & (clima(ngc)%tclm(ibc,jbc,k,ic)-tvalue)
3320 END IF
3321# ifdef MASKING
3322 tvalue=tvalue*grid(ngc)%rmask(ibc,jbc)
3323# endif
3324 ocean(ngc)%t(ibc,jbc,k,tindex,itrc)=tvalue
3325 END DO
3326 END IF
3327 END DO
3328!
3329!-----------------------------------------------------------------------
3330! Finer grid southern boundary.
3331!-----------------------------------------------------------------------
3332!
3333 jbc=j_bottom(ngf)
3334 ibc_min=i_left(ngf)
3335 ibc_max=i_right(ngf)-1 ! interior points, no bottom
3336! right corner
3337 DO ibc=istr,iend
3338 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
3339 & ((jstr.le.jbc-1).and.(jbc-1.le.jend))) THEN
3340!
3341! Sum vertically coarse grid horizontal advective tracer flux,
3342! Hz*v*T/m, from last time-step.
3343!
3344 tfc=0.0_r8
3345 DO k=1,n(ngc)
3346 tfc=tfc+bry_contact(isouth,rgcr)%Tflux(ibc,k,itrc)
3347 END DO
3348!
3349! Sum vertically and horizontally finer grid advective tracer flux.
3350! This is a vertical and horizontal I-integral because "RefineScale"
3351! sub-divisions are done in the finer grid in each single coarse grid
3352! at the I-edge.
3353!
3354 tff=0.0_r8
3355 iedge=io+(ibc-ibc_min)*refinescale(ngf)
3356 DO isum=-half,half
3357 ibf=iedge+isum
3358 DO k=1,n(ngf)
3359 tff=tff+bry_contact(isouth,dgcr)%Tflux(ibf,k,itrc)
3360 END DO
3361 END DO
3362!
3363! Zeroth order correction to fine grid time integral (RIL, 2016).
3364! Correct coarse grid tracer at the finer grid southern boundary.
3365!
3366 cff=grid(ngc)%pm(ibc,jbc-1)* &
3367 & grid(ngc)%pn(ibc,jbc-1)* &
3368 & dinv(ibc,jbc-1)
3369 DO k=1,n(ngc)
3370 tvalue=max(0.0_r8, &
3371 & ocean(ngc)%t(ibc,jbc-1,k,tindex,itrc)- &
3372 & cff*(tff-tfc))
3373 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
3374 tvalue=tvalue+ &
3375 & dt(ngc)*clima(ngc)%Tnudgcof(ibc,jbc-1,k,itrc)* &
3376 & (clima(ngc)%tclm(ibc,jbc-1,k,ic)-tvalue)
3377 END IF
3378# ifdef MASKING
3379 tvalue=tvalue*grid(ngc)%rmask(ibc,jbc-1)
3380# endif
3381 ocean(ngc)%t(ibc,jbc-1,k,tindex,itrc)=tvalue
3382 END DO
3383 END IF
3384 END DO
3385!
3386!-----------------------------------------------------------------------
3387! Finer grid northern boundary.
3388!-----------------------------------------------------------------------
3389!
3390 jbc=j_top(ngf)
3391 ibc_min=i_left(ngf)
3392 ibc_max=i_right(ngf)-1 ! interior points, no top
3393! right corner
3394 DO ibc=istr,iend
3395 IF (((ibc_min.le.ibc).and.(ibc.le.ibc_max)).and. &
3396 & ((jstr.le.jbc).and.(jbc.le.jend))) THEN
3397!
3398! Sum vertically coarse grid horizontal advective tracer flux,
3399! Hz*v*T/m, from last time-step.
3400!
3401 tfc=0.0_r8
3402 DO k=1,n(ngc)
3403 tfc=tfc+bry_contact(inorth,rgcr)%Tflux(ibc,k,itrc)
3404 END DO
3405!
3406! Sum vertically and horizontally finer grid advective tracer flux.
3407! This is a vertical and horizontal I-integral because "RefineScale"
3408! sub-divisions are done in the finer grid in each single coarse grid
3409! at the I-edge.
3410!
3411 tff=0.0_r8
3412 iedge=io+(ibc-ibc_min)*refinescale(ngf)
3413 DO isum=-half,half
3414 ibf=iedge+isum
3415 DO k=1,n(ngf)
3416 tff=tff+bry_contact(inorth,dgcr)%Tflux(ibf,k,itrc)
3417 END DO
3418 END DO
3419!
3420! Zeroth order correction to fine grid time integral.
3421! Correct coarse grid tracer at the finer grid northern boundary.
3422!
3423 cff=grid(ngc)%pm(ibc,jbc)* &
3424 & grid(ngc)%pn(ibc,jbc)* &
3425 & dinv(ibc,jbc)
3426 DO k=1,n(ngc)
3427 tvalue=max(0.0_r8, &
3428 & ocean(ngc)%t(ibc,jbc,k,tindex,itrc)- &
3429 & cff*(tff-tfc))
3430 IF (ltracerclm(itrc,ngc).and.lnudgetclm(itrc,ngc)) THEN
3431 tvalue=tvalue+ &
3432 & dt(ngc)*clima(ngc)%Tnudgcof(ibc,jbc,k,itrc)* &
3433 & (clima(ngc)%tclm(ibc,jbc,k,ic)-tvalue)
3434 END IF
3435# ifdef MASKING
3436 tvalue=tvalue*grid(ngc)%rmask(ibc,jbc)
3437# endif
3438 ocean(ngc)%t(ibc,jbc,k,tindex,itrc)=tvalue
3439 END DO
3440 END IF
3441 END DO
3442 END DO t_loop
3443
3444# ifdef DISTRIBUTE
3445!
3446!-----------------------------------------------------------------------
3447! Exchange boundary data.
3448!-----------------------------------------------------------------------
3449!
3450 CALL mp_exchange4d (ngc, tile, model, 1, &
3451 & lbi, ubi, lbj, ubj, 1, n(ngc), &
3452 & 1, nt(ngc), &
3453 & nghostpoints, &
3454 & ewperiodic(ngc), nsperiodic(ngc), &
3455 & ocean(ngc)%t(:,:,:,tindex,:))
3456# endif
3457!
3458 RETURN
mod_clima
Definition mod_clima.F:2
mod_clima::clima
type(t_clima), dimension(:), allocatable clima
Definition mod_clima.F:153
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_nesting::receiver_grid
integer, dimension(:), allocatable receiver_grid
Definition mod_nesting.F:173
mod_nesting::donor_grid
integer, dimension(:), allocatable donor_grid
Definition mod_nesting.F:172
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::ltracerclm
logical, dimension(:,:), allocatable ltracerclm
Definition mod_scalars.F:528
mod_scalars::lnudgetclm
logical, dimension(:,:), allocatable lnudgetclm
Definition mod_scalars.F:535
mod_stepping
Definition mod_stepping.F:2
mod_stepping::nnew
integer, dimension(:), allocatable nnew
Definition mod_stepping.F:69
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::mp_exchange4d
subroutine mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, a, b, c)
Definition mp_exchange.F:3377

References mod_param::bounds, mod_nesting::bry_contact, mod_clima::clima, mod_nesting::donor_grid, mod_scalars::dt, mod_scalars::ewperiodic, mod_grid::grid, mod_nesting::i_left, mod_nesting::i_right, mod_scalars::ieast, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_nesting::j_bottom, mod_nesting::j_top, mod_scalars::lnudgetclm, mod_scalars::ltracerclm, mp_exchange_mod::mp_exchange4d(), mod_param::n, mod_nesting::ncontact, mod_param::nghostpoints, mod_stepping::nnew, mod_scalars::nsperiodic, mod_param::nt, mod_ocean::ocean, mod_nesting::receiver_grid, and mod_scalars::refinescale.

Referenced by correct_tracer().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ fill_contact()

subroutine, public nesting_mod::fill_contact ( integer, intent(in) rg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) gtype,
character(len=*), intent(in) mvname,
real(dp), intent(in) spvalcheck,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
real(r8), dimension(:), intent(in) ac,
real(r8), dimension(lbi:,lbj:), intent(inout) ar )

Definition at line 1076 of file nesting.F.

1081!
1082!=======================================================================
1083! !
1084! This routine is used during initialization to fill the contact !
1085! points of a specified grid metric array. We need to have metric !
1086! data in all the extended computational points of the grid. No !
1087! attempt is done here to interpolate such values since the are !
1088! read in "set_contact" from input contact points NetCDF file. !
1089! This routine just unpack data into global arrays and check if !
1090! all needed values are filled. !
1091! !
1092! During allocation these special metric grid arrays are initialized !
1093! to "spval" to avoid resetting those values processed already from !
1094! the regular Grid NetCDF file. That is, only those contact points !
1095! outside the physical grid are processed here. This is a good way !
1096! to check if all the extra numerical points have been processed. !
1097! !
1098! On Input: !
1099! !
1100! rg Receiver grid number (integer) !
1101! model Calling model identifier (integer) !
1102! tile Domain tile partition (integer) !
1103! cr Contact region number to process (integer) !
1104! Npoints Number of points in the contact region (integer) !
1105! contact Contact region information variables (T_NGC structure)!
1106! gtype C-grid variable type (integer) !
1107! mvname Metrics variable name (string) !
1108! SpValCheck Special value used to check if the contact point !
1109! needs to be processed. !
1110! LBi Receiver grid, I-dimension Lower bound (integer) !
1111! UBi Receiver grid, I-dimension Upper bound (integer) !
1112! LBj Receiver grid, J-dimension Lower bound (integer) !
1113! UBj Receiver grid, J-dimension Upper bound (integer) !
1114! Ac Metric data at Contact points. !
1115! !
1116! On Output: !
1117! !
1118! Ar Updated metric grid array !
1119! !
1120!=======================================================================
1121!
1122 USE mod_param
1123 USE mod_ncparam
1124 USE mod_nesting
1125!
1126! Imported variable declarations.
1127!
1128 integer, intent(in) :: rg, model, tile
1129 integer, intent(in) :: cr, gtype, Npoints
1130 integer, intent(in) :: LBi, UBi, LBj, UBj
1131!
1132 real(dp), intent(in) :: SpValCheck
1133!
1134 character(len=*), intent(in) :: mvname
1135!
1136 TYPE (T_NGC), intent(in) :: contact(:)
1137!
1138# ifdef ASSUMED_SHAPE
1139 real(r8), intent(in) :: Ac(:)
1140 real(r8), intent(inout) :: Ar(LBi:,LBj:)
1141# else
1142 real(r8), intent(in) :: Ac(Npoints)
1143 real(r8), intent(inout) :: Ar(LBi:UBi,LBj:UBj)
1144# endif
1145!
1146! Local variable declarations.
1147!
1148 integer :: i, j, m
1149 integer :: Istr, Iend, Jstr, Jend
1150!
1151!-----------------------------------------------------------------------
1152! Interpolate 2D data from donor grid to receiver grid contact points.
1153!-----------------------------------------------------------------------
1154!
1155!
1156! Set starting and ending tile indices for the receiver grid.
1157!
1158 SELECT CASE (gtype)
1159 CASE (p2dvar)
1160 istr=bounds(rg) % IstrP(tile)
1161 iend=bounds(rg) % IendP(tile)
1162 jstr=bounds(rg) % JstrP(tile)
1163 jend=bounds(rg) % JendP(tile)
1164 CASE (r2dvar)
1165 istr=bounds(rg) % IstrT(tile)
1166 iend=bounds(rg) % IendT(tile)
1167 jstr=bounds(rg) % JstrT(tile)
1168 jend=bounds(rg) % JendT(tile)
1169 CASE (u2dvar)
1170 istr=bounds(rg) % IstrP(tile)
1171 iend=bounds(rg) % IendT(tile)
1172 jstr=bounds(rg) % JstrT(tile)
1173 jend=bounds(rg) % JendT(tile)
1174 CASE (v2dvar)
1175 istr=bounds(rg) % IstrT(tile)
1176 iend=bounds(rg) % IendT(tile)
1177 jstr=bounds(rg) % JstrP(tile)
1178 jend=bounds(rg) % JendT(tile)
1179 END SELECT
1180!
1181! Interpolate.
1182!
1183 DO m=1,npoints
1184 i=contact(cr)%Irg(m)
1185 j=contact(cr)%Jrg(m)
1186 IF (((istr.le.i).and.(i.le.iend)).and. &
1187 & ((jstr.le.j).and.(j.le.jend))) THEN
1188!! IF (Ar(i,j).gt.SpValCheck) THEN ! Only process contact
1189 ar(i,j)=ac(m) ! points outside in the
1190!! END IF ! regular grid
1191 END IF
1192 END DO
1193!
1194 RETURN
mod_ncparam
Definition mod_ncparam.F:2
mod_param::u2dvar
integer, parameter u2dvar
Definition mod_param.F:718
mod_param::p2dvar
integer, parameter p2dvar
Definition mod_param.F:716
mod_param::r2dvar
integer, parameter r2dvar
Definition mod_param.F:717
mod_param::v2dvar
integer, parameter v2dvar
Definition mod_param.F:719

References mod_param::bounds, mod_param::p2dvar, mod_param::r2dvar, mod_param::u2dvar, and mod_param::v2dvar.

Referenced by get_grid_mod::get_grid_nf90(), and get_grid_mod::get_grid_pio().

Here is the caller graph for this function:

◆ fine2coarse()

subroutine, private nesting_mod::fine2coarse ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) vtype,
integer, intent(in) tile )
private

Definition at line 3462 of file nesting.F.

3463!
3464!=======================================================================
3465! !
3466! This routine replaces interior coarse grid data with the refined !
3467! averaged values: two-way nesting. !
3468! !
3469! On Input: !
3470! !
3471! ng Refinement grid number (integer) !
3472! model Calling model identifier (integer) !
3473! vtype State variables to process (integer): !
3474! vtype = r2dvar 2D state variables !
3475! vtype = r3dvar 3D state variables !
3476! tile Domain tile partition (integer) !
3477! !
3478! On Output: (mod_coupling, mod_ocean) !
3479! !
3480! Updated state variable with average refined grid !
3481! solution !
3482! !
3483!=======================================================================
3484!
3485 USE mod_param
3486 USE mod_parallel
3487 USE mod_coupling
3488 USE mod_forces
3489 USE mod_grid
3490 USE mod_iounits
3491 USE mod_ncparam
3492 USE mod_nesting
3493 USE mod_ocean
3494 USE mod_scalars
3495 USE mod_stepping
3496!
3497 USE exchange_2d_mod
3498# ifdef SOLVE3D
3499 USE exchange_3d_mod
3500# endif
3501# ifdef DISTRIBUTE
3502 USE mp_exchange_mod, ONLY : mp_exchange2d
3503# ifdef SOLVE3D
3504 USE mp_exchange_mod, ONLY : mp_exchange3d, mp_exchange4d
3505# endif
3506# endif
3507 USE strings_mod, ONLY : founderror
3508!
3509! Imported variable declarations.
3510!
3511 integer, intent(in) :: ng, model, vtype, tile
3512!
3513! Local variable declarations.
3514!
3515 logical :: AreaAvg
3516!
3517 integer :: LBiD, UBiD, LBjD, UBjD
3518 integer :: LBiR, UBiR, LBjR, UBjR
3519 integer :: Dindex2d, Rindex2d
3520# ifdef SOLVE3D
3521 integer :: Dindex3d, Rindex3d
3522# endif
3523 integer :: cr, dg, k, rg, nrec, rec
3524# ifdef SOLVE3D
3525 integer :: itrc
3526# endif
3527!
3528 character (len=*), parameter :: MyFile = &
3529 & __FILE__//", fine2coarse"
3530!
3531!-----------------------------------------------------------------------
3532! Average interior fine grid state variable data to the coarse grid
3533! location. Then, replace coarse grid values with averaged data.
3534!-----------------------------------------------------------------------
3535!
3536 DO cr=1,ncontact
3537!
3538! Get data donor and data receiver grid numbers.
3539!
3540 dg=rcontact(cr)%donor_grid
3541 rg=rcontact(cr)%receiver_grid
3542!
3543! Process contact region if the current refinement grid "ng" is the
3544! donor grid. The coarse grid "rg" is the receiver grid and the
3545! contact structure has all the information necessary for fine to
3546! coarse coupling. The donor grid size is always smaller than the
3547! receiver coarser grid.
3548!
3549 IF ((ng.eq.dg).and.(dxmax(dg).lt.dxmax(rg))) THEN
3550!
3551! Set donor and receiver grids lower and upper array indices.
3552!
3553 lbid=bounds(dg)%LBi(tile)
3554 ubid=bounds(dg)%UBi(tile)
3555 lbjd=bounds(dg)%LBj(tile)
3556 ubjd=bounds(dg)%UBj(tile)
3557!
3558 lbir=bounds(rg)%LBi(tile)
3559 ubir=bounds(rg)%UBi(tile)
3560 lbjr=bounds(rg)%LBj(tile)
3561 ubjr=bounds(rg)%UBj(tile)
3562!
3563! Report.
3564!
3565 IF (domain(ng)%SouthWest_Test(tile)) THEN
3566 IF (master.and.(vtype.eq.r2dvar)) THEN
3567 WRITE (stdout,10) dg, rg, cr
3568 10 FORMAT (6x,'FINE2COARSE - exchanging data between grids:',&
3569 & ' dg = ',i2.2,' and rg = ',i2.2,' at cr = ',i2.2)
3570 END IF
3571 END IF
3572!
3573! Set state variable indices to process for donor and receiver grids.
3574! Since the exchange of data is done at the bottom of main2d/main3d,
3575! we need to use the newest time indices.
3576!
3577 dindex2d=knew(dg) ! Donor 2D variables index
3578 rindex2d=knew(rg) ! Receiver 3D variables index
3579# ifdef SOLVE3D
3580 dindex3d=nnew(dg) ! Donor 3D variables index
3581 rindex3d=nnew(rg) ! Receiver 3D variables index
3582# endif
3583!
3584!-----------------------------------------------------------------------
3585! Process 2D state variables.
3586!-----------------------------------------------------------------------
3587!
3588 IF (vtype.eq.r2dvar) THEN
3589!
3590! Free-surface.
3591!
3592 areaavg=.false.
3593# ifdef SOLVE3D
3594 CALL fine2coarse2d (rg, dg, model, tile, &
3595 & r2dvar, 'Zt_avg1', &
3596 & areaavg, refinescale(dg), &
3597 & cr, rcontact(cr)%Npoints, rcontact, &
3598 & lbid, ubid, lbjd, ubjd, &
3599 & lbir, ubir, lbjr, ubjr, &
3600 & grid(dg)%om_r, &
3601 & grid(dg)%on_r, &
3602 & grid(rg)%pm, &
3603 & grid(rg)%pn, &
3604 & grid(rg)%h, &
3605# ifdef MASKING
3606 & grid(dg)%rmask_full, &
3607 & grid(rg)%rmask, &
3608# endif
3609 & coupling(dg)%Zt_avg1, &
3610 & coupling(rg)%Zt_avg1)
3611# else
3612 CALL fine2coarse2d (rg, dg, model, tile, &
3613 & r2dvar, vname(1,idfsur), &
3614 & areaavg, refinescale(dg), &
3615 & cr, rcontact(cr)%Npoints, rcontact, &
3616 & lbid, ubid, lbjd, ubjd, &
3617 & lbir, ubir, lbjr, ubjr, &
3618 & grid(dg)%om_r, &
3619 & grid(dg)%on_r, &
3620 & grid(rg)%pm, &
3621 & grid(rg)%pn, &
3622 & grid(rg)%h, &
3623# ifdef MASKING
3624 & grid(dg)%rmask, &
3625 & grid(rg)%rmask, &
3626# endif
3627 & ocean(dg)%zeta(:,:,dindex2d), &
3628 & ocean(rg)%zeta(:,:,rindex2d))
3629# endif
3630 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3631!
3632! Process 2D momentum components (ubar,vbar).
3633!
3634 areaavg=.false.
3635 CALL fine2coarse2d (rg, dg, model, tile, &
3636 & u2dvar, vname(1,idubar), &
3637 & areaavg, refinescale(dg), &
3638 & cr, ucontact(cr)%Npoints, ucontact, &
3639 & lbid, ubid, lbjd, ubjd, &
3640 & lbir, ubir, lbjr, ubjr, &
3641 & grid(dg)%om_u, &
3642 & grid(dg)%on_u, &
3643 & grid(rg)%pm, &
3644 & grid(rg)%pn, &
3645 & grid(rg)%h, &
3646# ifdef MASKING
3647 & grid(dg)%umask_full, &
3648 & grid(rg)%umask_full, &
3649# endif
3650 & ocean(dg)%ubar(:,:,dindex2d), &
3651# ifdef SOLVE3D
3652 & ocean(rg)%ubar(:,:,1), &
3653 & ocean(rg)%ubar(:,:,2))
3654# else
3655 & ocean(rg)%ubar(:,:,rindex2d))
3656# endif
3657 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3658!
3659 CALL fine2coarse2d (rg, dg, model, tile, &
3660 & v2dvar, vname(1,idvbar), &
3661 & areaavg, refinescale(dg), &
3662 & cr, vcontact(cr)%Npoints, vcontact, &
3663 & lbid, ubid, lbjd, ubjd, &
3664 & lbir, ubir, lbjr, ubjr, &
3665 & grid(dg)%om_v, &
3666 & grid(dg)%on_v, &
3667 & grid(rg)%pm, &
3668 & grid(rg)%pn, &
3669 & grid(rg)%h, &
3670# ifdef MASKING
3671 & grid(dg)%vmask_full, &
3672 & grid(rg)%vmask_full, &
3673# endif
3674 & ocean(dg)%vbar(:,:,dindex2d), &
3675# ifdef SOLVE3D
3676 & ocean(rg)%vbar(:,:,1), &
3677 & ocean(rg)%vbar(:,:,2))
3678# else
3679 & ocean(rg)%vbar(:,:,rindex2d))
3680# endif
3681 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3682
3683# ifdef SOLVE3D
3684!
3685!-----------------------------------------------------------------------
3686! Process 3D state variables.
3687!-----------------------------------------------------------------------
3688!
3689 ELSE IF (vtype.eq.r3dvar) THEN
3690!
3691! Tracer type-variables.
3692!
3693 areaavg=.false.
3694 DO itrc=1,nt(rg)
3695 CALL fine2coarse3d (rg, dg, model, tile, &
3696 & r3dvar, vname(1,idtvar(itrc)), &
3697 & areaavg, refinescale(dg), &
3698 & cr, rcontact(cr)%Npoints, rcontact, &
3699 & lbid, ubid, lbjd, ubjd, 1, n(dg), &
3700 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3701 & grid(dg)%om_r, &
3702 & grid(dg)%on_r, &
3703 & grid(rg)%pm, &
3704 & grid(rg)%pn, &
3705# ifdef MASKING
3706 & grid(dg)%rmask_full, &
3707 & grid(rg)%rmask, &
3708# endif
3709 & ocean(dg)%t(:,:,:,dindex3d,itrc), &
3710 & ocean(rg)%t(:,:,:,rindex3d,itrc))
3711 IF (founderror(exit_flag, noerror, &
3712 & __line__, myfile)) RETURN
3713 END DO
3714!
3715! Process 3D momentum components (u, v).
3716!
3717 areaavg=.false.
3718 CALL fine2coarse3d (rg, dg, model, tile, &
3719 & u3dvar, vname(1,iduvel), &
3720 & areaavg, refinescale(dg), &
3721 & cr, ucontact(cr)%Npoints, ucontact, &
3722 & lbid, ubid, lbjd, ubjd, 1, n(dg), &
3723 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3724 & grid(dg)%om_u, &
3725 & grid(dg)%on_u, &
3726 & grid(rg)%pm, &
3727 & grid(rg)%pn, &
3728# ifdef MASKING
3729 & grid(dg)%umask_full, &
3730 & grid(rg)%umask_full, &
3731# endif
3732 & ocean(dg)%u(:,:,:,dindex3d), &
3733 & ocean(rg)%u(:,:,:,rindex3d))
3734 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3735!
3736 CALL fine2coarse3d (rg, dg, model, tile, &
3737 & v3dvar, vname(1,idvvel), &
3738 & areaavg, refinescale(dg), &
3739 & cr, vcontact(cr)%Npoints, vcontact, &
3740 & lbid, ubid, lbjd, ubjd, 1, n(dg), &
3741 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3742 & grid(dg)%om_v, &
3743 & grid(dg)%on_v, &
3744 & grid(rg)%pm, &
3745 & grid(rg)%pn, &
3746# ifdef MASKING
3747 & grid(dg)%vmask_full, &
3748 & grid(rg)%vmask_full, &
3749# endif
3750 & ocean(dg)%v(:,:,:,dindex3d), &
3751 & ocean(rg)%v(:,:,:,rindex3d))
3752 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3753# endif
3754 END IF
3755!
3756!-----------------------------------------------------------------------
3757! Exchange boundary data.
3758!-----------------------------------------------------------------------
3759!
3760 IF (ewperiodic(rg).or.nsperiodic(rg)) THEN
3761 IF (vtype.eq.r2dvar) THEN
3762# ifdef SOLVE3D
3763 CALL exchange_r2d_tile (rg, tile, &
3764 & lbir, ubir, lbjr, ubjr, &
3765 & coupling(rg)%Zt_avg1)
3766 DO k=1,2
3767 CALL exchange_u2d_tile (rg, tile, &
3768 & lbir, ubir, lbjr, ubjr, &
3769 & ocean(rg)%ubar(:,:,k))
3770 CALL exchange_v2d_tile (rg, tile, &
3771 & lbir, ubir, lbjr, ubjr, &
3772 & ocean(rg)%vbar(:,:,k))
3773 END DO
3774# else
3775 CALL exchange_r2d_tile (rg, tile, &
3776 & lbir, ubir, lbjr, ubjr, &
3777 & ocean(rg)%zeta(:,:,rindex2d))
3778 CALL exchange_u2d_tile (rg, tile, &
3779 & lbir, ubir, lbjr, ubjr, &
3780 & ocean(rg)%ubar(:,:,rindex2d))
3781 CALL exchange_v2d_tile (rg, tile, &
3782 & lbir, ubir, lbjr, ubjr, &
3783 & ocean(rg)%vbar(:,:,rindex2d))
3784
3785# endif
3786# ifdef SOLVE3D
3787 ELSE IF (vtype.eq.r3dvar) THEN
3788 CALL exchange_u3d_tile (rg, tile, &
3789 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3790 & ocean(rg)%u(:,:,:,rindex3d))
3791 CALL exchange_v3d_tile (rg, tile, &
3792 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3793 & ocean(rg)%v(:,:,:,rindex3d))
3794 DO itrc=1,nt(rg)
3795 CALL exchange_r3d_tile (rg, tile, &
3796 & lbir, ubir, lbjr, ubjr, &
3797 & 1, n(rg), &
3798 & ocean(rg)%t(:,:,:,rindex3d,itrc))
3799 END DO
3800# endif
3801 END IF
3802 END IF
3803
3804# ifdef DISTRIBUTE
3805!
3806 IF (vtype.eq.r2dvar) THEN
3807# ifdef SOLVE3D
3808 CALL mp_exchange2d (rg, tile, model, 1, &
3809 & lbir, ubir, lbjr, ubjr, &
3810 & nghostpoints, &
3811 & ewperiodic(rg), nsperiodic(rg), &
3812 & coupling(rg)%Zt_avg1)
3813 CALL mp_exchange2d (rg, tile, model, 4, &
3814 & lbir, ubir, lbjr, ubjr, &
3815 & nghostpoints, &
3816 & ewperiodic(rg), nsperiodic(rg), &
3817 & ocean(rg)%ubar(:,:,1), &
3818 & ocean(rg)%vbar(:,:,1), &
3819 & ocean(rg)%ubar(:,:,2), &
3820 & ocean(rg)%vbar(:,:,2))
3821# else
3822 CALL mp_exchange2d (rg, tile, model, 3, &
3823 & lbir, ubir, lbjr, ubjr, &
3824 & nghostpoints, &
3825 & ewperiodic(rg), nsperiodic(rg), &
3826 & ocean(rg)%zeta(:,:,rindex2d), &
3827 & ocean(rg)%ubar(:,:,rindex2d), &
3828 & ocean(rg)%vbar(:,:,rindex2d))
3829# endif
3830# ifdef SOLVE3D
3831 ELSE IF (vtype.eq.r3dvar) THEN
3832 CALL mp_exchange3d (rg, tile, model, 2, &
3833 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3834 & nghostpoints, &
3835 & ewperiodic(rg), nsperiodic(rg), &
3836 & ocean(rg)%u(:,:,:,rindex3d), &
3837 & ocean(rg)%v(:,:,:,rindex3d))
3838 CALL mp_exchange4d (rg, tile, model, 1, &
3839 & lbir, ubir, lbjr, ubjr, 1, n(rg), &
3840 & 1, nt(rg), &
3841 & nghostpoints, &
3842 & ewperiodic(rg), nsperiodic(rg), &
3843 & ocean(rg)%t(:,:,:,rindex3d,:))
3844# endif
3845 END IF
3846# endif
3847 END IF
3848 END DO
3849!
3850 RETURN
exchange_2d_mod
Definition exchange_2d.F:2
exchange_2d_mod::exchange_r2d_tile
subroutine exchange_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:253
exchange_2d_mod::exchange_u2d_tile
subroutine exchange_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:440
exchange_2d_mod::exchange_v2d_tile
subroutine exchange_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:627
exchange_3d_mod
Definition exchange_3d.F:2
exchange_3d_mod::exchange_u3d_tile
subroutine exchange_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:495
exchange_3d_mod::exchange_r3d_tile
subroutine exchange_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:283
exchange_3d_mod::exchange_v3d_tile
subroutine exchange_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:707
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_iounits
Definition mod_iounits.F:2
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
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::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::idvbar
integer idvbar
Definition mod_ncparam.F:360
mod_nesting::vcontact
type(t_ngc), dimension(:), allocatable vcontact
Definition mod_nesting.F:288
mod_nesting::ucontact
type(t_ngc), dimension(:), allocatable ucontact
Definition mod_nesting.F:287
mod_param::r3dvar
integer, parameter r3dvar
Definition mod_param.F:721
mod_param::u3dvar
integer, parameter u3dvar
Definition mod_param.F:722
mod_param::v3dvar
integer, parameter v3dvar
Definition mod_param.F:723
mod_stepping::knew
integer, dimension(:), allocatable knew
Definition mod_stepping.F:64
mp_exchange_mod::mp_exchange2d
subroutine mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:294
mp_exchange_mod::mp_exchange3d
subroutine mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:2037

References mod_param::bounds, mod_coupling::coupling, mod_param::domain, mod_scalars::dxmax, mod_scalars::ewperiodic, exchange_2d_mod::exchange_r2d_tile(), exchange_3d_mod::exchange_r3d_tile(), exchange_2d_mod::exchange_u2d_tile(), exchange_3d_mod::exchange_u3d_tile(), exchange_2d_mod::exchange_v2d_tile(), exchange_3d_mod::exchange_v3d_tile(), mod_scalars::exit_flag, fine2coarse2d(), fine2coarse3d(), strings_mod::founderror(), mod_grid::grid, mod_ncparam::idfsur, mod_ncparam::idtvar, mod_ncparam::idubar, mod_ncparam::iduvel, mod_ncparam::idvbar, mod_ncparam::idvvel, mod_stepping::knew, mod_parallel::master, mp_exchange_mod::mp_exchange2d(), mp_exchange_mod::mp_exchange3d(), mp_exchange_mod::mp_exchange4d(), mod_param::n, mod_nesting::ncontact, mod_param::nghostpoints, mod_stepping::nnew, mod_scalars::noerror, mod_scalars::nsperiodic, mod_param::nt, mod_ocean::ocean, mod_param::r2dvar, mod_param::r3dvar, mod_nesting::rcontact, mod_scalars::refinescale, mod_iounits::stdout, mod_param::u2dvar, mod_param::u3dvar, mod_nesting::ucontact, mod_param::v2dvar, mod_param::v3dvar, mod_nesting::vcontact, and mod_ncparam::vname.

Referenced by nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ fine2coarse2d()

subroutine, public nesting_mod::fine2coarse2d ( integer, intent(in) ng,
integer, intent(in) dg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) gtype,
character(len=*), intent(in) svname,
logical, intent(in) areaavg,
integer, intent(in) rscale,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) lbif,
integer, intent(in) ubif,
integer, intent(in) lbjf,
integer, intent(in) ubjf,
integer, intent(in) lbic,
integer, intent(in) ubic,
integer, intent(in) lbjc,
integer, intent(in) ubjc,
real(r8), dimension(lbif:,lbjf:), intent(in) adx,
real(r8), dimension(lbif:,lbjf:), intent(in) ady,
real(r8), dimension(lbic:,lbjc:), intent(in) pmc,
real(r8), dimension(lbic:,lbjc:), intent(in) pnc,
real(r8), dimension(lbic:,lbjc:), intent(in) hhc,
real(r8), dimension(lbif:,lbjf:), intent(in) amsk,
real(r8), dimension(lbic:,lbjc:), intent(in) cmsk,
real(r8), dimension(lbif:,lbjf:), intent(in) a,
real(r8), dimension(lbic:,lbjc:), intent(inout) c1,
real(r8), dimension(lbic:,lbjc:), intent(inout), optional c2 )

Definition at line 3853 of file nesting.F.

3879!
3880!=======================================================================
3881! !
3882! This routine replaces the coarse grid data inside the refinement !
3883! grid interior for a 2D state variable with its refined averaged !
3884! values: two-way nesting. !
3885! !
3886! On Input: !
3887! !
3888! ng Coarser grid number (integer) !
3889! dg Finer grid number (integer) !
3890! model Calling model identifier (integer) !
3891! tile Domain tile partition (integer) !
3892! gtype C-grid variable type (integer) !
3893! svname State variable name (string) !
3894! AreaAvg Switch for area averaging (logical) !
3895! Rscale Refinement grid scale (integer) !
3896! cr Contact region number to process (integer) !
3897! Npoints Number of points in the contact zone (integer) !
3898! contact Contact zone information variables (T_NGC structure) !
3899! LBiF Finer grid, I-dimension Lower bound (integer) !
3900! UBiF Finer grid, I-dimension Upper bound (integer) !
3901! LBjF Finer grid, J-dimension Lower bound (integer) !
3902! UBjF Finer grid, J-dimension Upper bound (integer) !
3903! LBiC Coarser grid, I-dimension Lower bound (integer) !
3904! UBiC Coarser grid, I-dimension Upper bound (integer) !
3905! LBjC Coarser grid, J-dimension Lower bound (integer) !
3906! UBjC Coarser grid, J-dimension Upper bound (integer) !
3907# ifdef DISTRIBUTE
3908! Adx Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
3909! Ady Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
3910# else
3911! dxF Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
3912! dyF Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
3913# endif
3914! pmC Coarser grid, inverse X-grid spacing (1/dx) at RHO !
3915! pnC Coarser grid, inverse Y-grid spacing (1/dy) at RHO !
3916! hhC Coarser grid, bathymetry at RHO !
3917# ifdef MASKING
3918# ifdef DISTRIBUTE
3919! Amsk Finer grid land/sea masking (2D array) !
3920# else
3921! Fmsk Finer grid land/sea masking (2D array) !
3922# endif
3923! Cmsk Coarser grid land/sea masking (2D array) !
3924# endif
3925# ifdef DISTRIBUTE
3926! A Finer grid 2D data !
3927# else
3928! F Finer grid 2D data !
3929# endif
3930! C1 Coarser grid 2D data, record 1 !
3931! C2 Coarser grid 2D data, record 2 (OPTIONAL) !
3932! !
3933! On Output: (mod_nesting) !
3934! !
3935! C1 Updated Coarser grid 2D data, record 1 !
3936! C2 Uodated Coarser grid 2D data, record 2 (OPTIONAL) !
3937! !
3938!=======================================================================
3939!
3940 USE mod_param
3941 USE mod_ncparam
3942 USE mod_nesting
3943 USE mod_scalars
3944!
3945# ifdef DISTRIBUTE
3946 USE distribute_mod, ONLY : mp_aggregate2d
3947# endif
3948 USE strings_mod, ONLY : founderror
3949!
3950! Imported variable declarations.
3951!
3952 logical, intent(in) :: AreaAvg
3953 integer, intent(in) :: ng, dg, model, tile
3954 integer, intent(in) :: gtype, cr, Npoints, Rscale
3955 integer, intent(in) :: LBiF, UBiF, LBjF, UBjF
3956 integer, intent(in) :: LBiC, UBiC, LBjC, UBjC
3957!
3958 character(len=*), intent(in) :: svname
3959!
3960 TYPE (T_NGC), intent(in) :: contact(:)
3961!
3962# ifdef ASSUMED_SHAPE
3963 real(r8), intent(in) :: pmC(LBiC:,LBjC:)
3964 real(r8), intent(in) :: pnC(LBiC:,LBjC:)
3965 real(r8), intent(in) :: hhC(LBiC:,LBjC:)
3966# ifdef MASKING
3967 real(r8), intent(in) :: Cmsk(LBiC:,LBjC:)
3968# ifdef DISTRIBUTE
3969 real(r8), intent(in) :: Amsk(LBiF:,LBjF:)
3970# else
3971 real(r8), intent(in) :: Fmsk(LBiF:,LBjF:)
3972# endif
3973# endif
3974# ifdef DISTRIBUTE
3975 real(r8), intent(in) :: A(LBiF:,LBjF:)
3976 real(r8), intent(in) :: Adx(LBiF:,LBjF:)
3977 real(r8), intent(in) :: Ady(LBiF:,LBjF:)
3978# else
3979 real(r8), intent(in) :: F(LBiF:,LBjF:)
3980 real(r8), intent(in) :: dxF(LBiF:,LBjF:)
3981 real(r8), intent(in) :: dyF(LBiF:,LBjF:)
3982# endif
3983 real(r8), intent(inout) :: C1(LBiC:,LBjC:)
3984 real(r8), intent(inout), optional :: C2(LBiC:,LBjC:)
3985# else
3986 real(r8), intent(in) :: pmC(LBiC:UBiC,LBjC:UBjC)
3987 real(r8), intent(in) :: pnC(LBiC:UBiC,LBjC:UBjC)
3988 real(r8), intent(in) :: hhC(LBiC:UBiC,LBjC:UBjC)
3989# ifdef MASKING
3990 real(r8), intent(in) :: Cmsk(LBiC:UBiC,LBjC:UBjC)
3991# ifdef DISTRIBUTE
3992 real(r8), intent(in) :: Amsk(LBiF:UBiF,LBjF:UBjF)
3993# else
3994 real(r8), intent(in) :: Fmsk(LBiF:UBiF,LBjF:UBjF)
3995# endif
3996# endif
3997# ifdef DISTRIBUTE
3998 real(r8), intent(in) :: A(LBiF:UBiF,LBjF:UBjF)
3999 real(r8), intent(in) :: Adx(LBiF:UBiF,LBjF:UBjF)
4000 real(r8), intent(in) :: Adx(LBiF:UBiF,LBjF:UBjF)
4001# else
4002 real(r8), intent(in) :: F(LBiF:UBiF,LBjF:UBjF)
4003 real(r8), intent(in) :: dxF(LBiF:UBiF,LBjF:UBjF)
4004 real(r8), intent(in) :: dyF(LBiF:UBiF,LBjF:UBjF)
4005# endif
4006 real(r8), intent(inout) :: C1(LBiC:UBiC,LBjC:UBjC)
4007 real(r8), intent(inout), optional :: C2(LBiC:UBiC,LBjC:UBjC)
4008# endif
4009!
4010! Local variable declarations.
4011!
4012 integer :: Iadd, Ic, Jadd, Jc, half, i, j, m
4013 integer :: Ib_east, Ib_west, Jb_north, Jb_south
4014# ifdef DISTRIBUTE
4015 integer :: LBi, UBi, LBj, UBj
4016# endif
4017!
4018 real(r8) :: areaC_inv, my_area, my_areasum, ratio
4019 real(r8) :: my_avg, my_count, my_sum
4020
4021# ifdef DISTRIBUTE
4022 real(r8), allocatable :: F(:,:)
4023 real(r8), allocatable :: dxF(:,:)
4024 real(r8), allocatable :: dyF(:,:)
4025# ifdef MASKING
4026 real(r8), allocatable :: Fmsk(:,:)
4027# endif
4028# endif
4029!
4030 character (len=*), parameter :: MyFile = &
4031 & __FILE__//", fine2coarse2d"
4032
4033# include "set_bounds.h"
4034!
4035!-----------------------------------------------------------------------
4036! Average interior fine grid state variable data to the coarse grid
4037! location. Then, replace coarse grid values with averaged data.
4038!-----------------------------------------------------------------------
4039
4040# ifdef DISTRIBUTE
4041!
4042! Allocate global work array(s).
4043!
4044 lbi=bounds(dg)%LBi(-1)
4045 ubi=bounds(dg)%UBi(-1)
4046 lbj=bounds(dg)%LBj(-1)
4047 ubj=bounds(dg)%UBj(-1)
4048 IF (.not.allocated(f)) THEN
4049 allocate ( f(lbi:ubi,lbj:ubj) )
4050 END IF
4051 IF (areaavg) THEN
4052 IF (.not.allocated(dxf)) THEN
4053 allocate ( dxf(lbi:ubi,lbj:ubj) )
4054 END IF
4055 IF (.not.allocated(dyf)) THEN
4056 allocate ( dyf(lbi:ubi,lbj:ubj) )
4057 END IF
4058 END IF
4059# ifdef MASKING
4060 IF (.not.allocated(fmsk)) THEN
4061 allocate ( fmsk(lbi:ubi,lbj:ubj) )
4062 END IF
4063# endif
4064!
4065! Gather finer grid data from all nodes in the group to build a global
4066! array.
4067!
4068 CALL mp_aggregate2d (dg, model, gtype, &
4069 & lbif, ubif, lbjf, ubjf, &
4070 & lbi, ubi, lbj, ubj, &
4071 & a, f)
4072 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4073!
4074 IF (areaavg) THEN
4075 CALL mp_aggregate2d (dg, model, gtype, &
4076 & lbif, ubif, lbjf, ubjf, &
4077 & lbi, ubi, lbj, ubj, &
4078 & adx, dxf)
4079 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4080
4081 CALL mp_aggregate2d (dg, model, gtype, &
4082 & lbif, ubif, lbjf, ubjf, &
4083 & lbi, ubi, lbj, ubj, &
4084 & ady, dyf)
4085 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4086 END IF
4087# ifdef MASKING
4088!
4089 CALL mp_aggregate2d (dg, model, gtype, &
4090 & lbif, ubif, lbjf, ubjf, &
4091 & lbi, ubi, lbj, ubj, &
4092 & amsk, fmsk)
4093 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4094# endif
4095# endif
4096!
4097! Average finer grid data to coarse grid according to the refinement
4098! ratio.
4099!
4100 half=(rscale-1)/2
4101 IF (areaavg) THEN ! area averaging
4102 DO m=1,npoints
4103 i=contact(cr)%Idg(m)
4104 j=contact(cr)%Jdg(m)
4105 ic=contact(cr)%Irg(m)
4106 jc=contact(cr)%Jrg(m)
4107 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4108 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4109 my_count=0.0_r8
4110 my_sum=0.0_r8
4111 my_areasum=0.0_r8
4112 DO jadd=-half,half
4113 DO iadd=-half,half
4114 my_area=dxf(i+iadd,j+jadd)*dyf(i+iadd,j+jadd)
4115 my_areasum=my_areasum+my_area
4116# ifdef MASKING
4117 my_sum=my_sum+ &
4118 & f(i+iadd,j+jadd)*my_area* &
4119 & min(1.0_r8,fmsk(i+iadd,j+jadd))
4120 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
4121# else
4122 my_sum=my_sum+ &
4123 & f(i+iadd,j+jadd)*my_area
4124# endif
4125 END DO
4126 END DO
4127 SELECT CASE (gtype) ! coarse grid inverse area
4128 CASE (r2dvar)
4129 areac_inv=pmc(ic,jc)*pnc(ic,jc)
4130 CASE (u2dvar)
4131 areac_inv=0.25_r8*(pmc(ic-1,jc)+pmc(ic,jc))* &
4132 & (pnc(ic-1,jc)+pnc(ic,jc))
4133 CASE (v2dvar)
4134 areac_inv=0.25_r8*(pmc(ic,jc-1)+pmc(ic,jc))* &
4135 & (pnc(ic,jc-1)+pnc(ic,jc))
4136 CASE DEFAULT
4137 areac_inv=pmc(ic,jc)*pnc(ic,jc)
4138 END SELECT
4139 ratio=my_areasum*areac_inv ! for debugging purposes
4140 my_avg=my_sum*areac_inv
4141# ifdef MASKING
4142 IF (my_count.gt.0.0_r8) THEN
4143 my_avg=my_avg*rscale*rscale/my_count
4144 END IF
4145 my_avg=my_avg*cmsk(ic,jc)
4146# endif
4147 c1(ic,jc)=my_avg
4148 IF (PRESENT(c2)) THEN
4149 c2(ic,jc)=my_avg
4150 END IF
4151 END IF
4152 END DO
4153 ELSE ! simple averaging
4154 DO m=1,npoints
4155 i=contact(cr)%Idg(m)
4156 j=contact(cr)%Jdg(m)
4157 ic=contact(cr)%Irg(m)
4158 jc=contact(cr)%Jrg(m)
4159 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4160 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4161 my_count=0.0_r8
4162 my_avg=0.0_r8
4163 my_sum=0.0_r8
4164 DO jadd=-half,half
4165 DO iadd=-half,half
4166# ifdef MASKING
4167 my_sum=my_sum+ &
4168 & f(i+iadd,j+jadd)*fmsk(i+iadd,j+jadd)
4169 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
4170# else
4171 my_sum=my_sum+ &
4172 & f(i+iadd,j+jadd)
4173 my_count=my_count+1.0_r8
4174# endif
4175 END DO
4176 END DO
4177 IF (my_count.gt.0.0_r8) my_avg=my_sum/my_count
4178# ifdef MASKING
4179 my_avg=my_avg*cmsk(ic,jc)
4180# ifdef WET_DRY
4181 IF (gtype.eq.r2dvar) THEN
4182 IF (my_avg.le.(dcrit(ng)-hhc(ic,jc))) THEN
4183 my_avg=dcrit(ng)-hhc(ic,jc)
4184 END IF
4185 END IF
4186# endif
4187# endif
4188!
4189 c1(ic,jc)=my_avg
4190 IF (PRESENT(c2)) THEN
4191 c2(ic,jc)=my_avg
4192 END IF
4193 END IF
4194 END DO
4195 END IF
4196# ifdef REFINE_BOUNDARY
4197!
4198!-----------------------------------------------------------------------
4199! Average finer grid BOUNDARY data to coarse grid U-type and V-type
4200! variables according to the refinement ratio.
4201!-----------------------------------------------------------------------
4202!
4203! U-type variables finer grid eastern and western boundaries.
4204!
4205 IF (gtype.eq.u2dvar) THEN
4206!
4207! Get indices of coarser grid (ng) corresponding to the corners of
4208! the finer grid (dg).
4209!
4210 ib_west=i_left(dg)
4211 ib_east=i_right(dg)
4212 jb_south=j_bottom(dg)
4213 jb_north=j_top(dg)
4214!
4215! Eastern boundary.
4216!
4217 i=lm(dg)+1 ! donor finer grid
4218 ic=ib_east ! receiver coarser grid
4219 DO jc=jb_south,jb_north-1
4220 j=(jc-jb_south)*rscale+half+1
4221 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4222 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4223 my_count=0.0_r8
4224 my_avg=0.0_r8
4225 my_sum=0.0_r8
4226 DO jadd=-half,half
4227 my_sum=my_sum+ &
4228 & f(i,j+jadd)
4229 my_count=my_count+1.0_r8
4230 END DO
4231 my_avg=my_sum/my_count
4232 c1(ic,jc)=my_avg
4233 END IF
4234 END DO
4235!
4236! Western boundary.
4237!
4238 i=1 ! donor finer grid
4239 ic=ib_west ! receiver coarser grid
4240 DO jc=jb_south,jb_north-1
4241 j=(jc-jb_south)*rscale+half+1
4242 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4243 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4244 my_count=0.0_r8
4245 my_avg=0.0_r8
4246 my_sum=0.0_r8
4247 DO jadd=-half,half
4248 my_sum=my_sum+ &
4249 & f(i,j+jadd)
4250 my_count=my_count+1.0_r8
4251 END DO
4252 my_avg=my_sum/my_count
4253 c1(ic,jc)=my_avg
4254 END IF
4255 END DO
4256 END IF
4257!
4258! V-type variables finer grid northern and southern boundaries.
4259!
4260 IF (gtype.eq.v2dvar) THEN
4261!
4262! Get indices of coarser grid (ng) corresponding to the corners of
4263! the finer grid (dg).
4264!
4265 ib_west=i_left(dg)
4266 ib_east=i_right(dg)
4267 jb_south=j_bottom(dg)
4268 jb_north=j_top(dg)
4269!
4270! Northern boundary.
4271!
4272 j=mm(dg)+1 ! donor finer grid
4273 jc=jb_north ! receiver coarser grid
4274 DO ic=ib_west,ib_east-1
4275 i=(ic-ib_west)*rscale+half+1
4276 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4277 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4278 my_count=0.0_r8
4279 my_avg=0.0_r8
4280 my_sum=0.0_r8
4281 DO iadd=-half,half
4282 my_sum=my_sum+ &
4283 & f(i+iadd,j)
4284 my_count=my_count+1.0_r8
4285 END DO
4286 my_avg=my_sum/my_count
4287 c1(ic,jc)=my_avg
4288 END IF
4289 END DO
4290!
4291! Southern boundary.
4292!
4293 j=1 ! donor finer grid
4294 jc=jb_south ! receiver coarser grid
4295 DO ic=ib_west,ib_east-1
4296 i=(ic-ib_west)*rscale+half+1
4297 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4298 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4299 my_count=0.0_r8
4300 my_avg=0.0_r8
4301 my_sum=0.0_r8
4302 DO iadd=-half,half
4303 my_sum=my_sum+ &
4304 & f(i+iadd,j)
4305 my_count=my_count+1.0_r8
4306 END DO
4307 my_avg=my_sum/my_count
4308 c1(ic,jc)=my_avg
4309 END IF
4310 END DO
4311 END IF
4312# endif
4313# ifdef DISTRIBUTE
4314!
4315! Deallocate work array.
4316!
4317 IF (allocated(f)) THEN
4318 deallocate (f)
4319 END IF
4320 IF (areaavg) THEN
4321 IF (allocated(dxf)) THEN
4322 deallocate (dxf)
4323 END IF
4324 IF (allocated(dyf)) THEN
4325 deallocate (dyf)
4326 END IF
4327 END IF
4328# ifdef MASKING
4329 IF (allocated(fmsk)) THEN
4330 deallocate (fmsk)
4331 END IF
4332# endif
4333# endif
4334!
4335 RETURN
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_param::lm
integer, dimension(:), allocatable lm
Definition mod_param.F:455
mod_param::mm
integer, dimension(:), allocatable mm
Definition mod_param.F:456
mod_scalars::dcrit
real(r8), dimension(:), allocatable dcrit
Definition mod_scalars.F:782

References mod_param::bounds, mod_scalars::dcrit, mod_scalars::exit_flag, strings_mod::founderror(), mod_nesting::i_left, mod_nesting::i_right, mod_nesting::j_bottom, mod_nesting::j_top, mod_param::lm, mod_param::mm, distribute_mod::mp_aggregate2d(), mod_scalars::noerror, mod_param::r2dvar, mod_param::u2dvar, and mod_param::v2dvar.

Referenced by fine2coarse(), and tl_nesting_mod::tl_fine2coarse().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ fine2coarse3d()

subroutine, public nesting_mod::fine2coarse3d ( integer, intent(in) ng,
integer, intent(in) dg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) gtype,
character(len=*), intent(in) svname,
logical, intent(in) areaavg,
integer, intent(in) rscale,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) lbif,
integer, intent(in) ubif,
integer, intent(in) lbjf,
integer, intent(in) ubjf,
integer, intent(in) lbkf,
integer, intent(in) ubkf,
integer, intent(in) lbic,
integer, intent(in) ubic,
integer, intent(in) lbjc,
integer, intent(in) ubjc,
integer, intent(in) lbkc,
integer, intent(in) ubkc,
real(r8), dimension(lbif:,lbjf:), intent(in) adx,
real(r8), dimension(lbif:,lbjf:), intent(in) ady,
real(r8), dimension(lbic:,lbjc:), intent(in) pmc,
real(r8), dimension(lbic:,lbjc:), intent(in) pnc,
real(r8), dimension(lbif:,lbjf:), intent(in) amsk,
real(r8), dimension(lbic:,lbjc:), intent(in) cmsk,
real(r8), dimension(lbif:,lbjf:,lbkf:), intent(in) a,
real(r8), dimension(lbic:,lbjc:,lbkc:), intent(inout) c )

Definition at line 4339 of file nesting.F.

4365!
4366!=======================================================================
4367! !
4368! This routine replaces the coarse grid data inside the refinement !
4369! grid interior for a 3D state variable with its refined averaged !
4370! values: two-way nesting. !
4371! !
4372! On Input: !
4373! !
4374! ng Coarser grid number (integer) !
4375! dg Finer grid number (integer) !
4376! model Calling model identifier (integer) !
4377! tile Domain tile partition (integer) !
4378! gtype C-grid variable type (integer) !
4379! svname State variable name (string) !
4380! AreaAvg Switch for area averaging (logical) !
4381! Rscale Refinement grid scale (integer) !
4382! cr Contact region number to process (integer) !
4383! Npoints Number of points in the contact zone (integer) !
4384! contact Contact zone information variables (T_NGC structure) !
4385! LBiF Finer grid, I-dimension Lower bound (integer) !
4386! UBiF Finer grid, I-dimension Upper bound (integer) !
4387! LBjF Finer grid, J-dimension Lower bound (integer) !
4388! UBjF Finer grid, J-dimension Upper bound (integer) !
4389! LBkF Finer grid, K-dimension Lower bound (integer) !
4390! UBkF Finer grid, K-dimension Upper bound (integer) !
4391! LBiC Coarser grid, I-dimension Lower bound (integer) !
4392! UBiC Coarser grid, I-dimension Upper bound (integer) !
4393! LBjC Coarser grid, J-dimension Lower bound (integer) !
4394! UBjC Coarser grid, J-dimension Upper bound (integer) !
4395! LBkC Coarser grid, K-dimension Lower bound (integer) !
4396! UBkC Coarser grid, K-dimension Upper bound (integer) !
4397# ifdef DISTRIBUTE
4398! Adx Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
4399! Ady Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
4400# else
4401! dxF Finer grid, X-grid spacing (1/pm: om_r, om_u, om_v) !
4402! dyF Finer grid, Y-grid spacing (1/pn: on_r, on_u, on_v) !
4403# endif
4404! pmC Coarser grid, inverse X-grid spacing (1/dx) at RHO !
4405! pnC Coarser grid, inverse Y-grid spacing (1/dy) at RHO !
4406# ifdef MASKING
4407# ifdef DISTRIBUTE
4408! Amsk Finer grid land/sea masking (2D array) !
4409# else
4410! Fmsk Finer grid land/sea masking (2D array) !
4411# endif
4412! Cmsk Coarser grid land/sea masking (2D array) !
4413# endif
4414# ifdef DISTRIBUTE
4415! A Finer grid 2D data !
4416# else
4417! F Finer grid 2D data !
4418# endif
4419! C Coarser grid 3D data !
4420! !
4421! On Output: (mod_nesting) !
4422! !
4423! C Updated Coarser grid 3D data !
4424! !
4425!=======================================================================
4426!
4427 USE mod_param
4428 USE mod_ncparam
4429 USE mod_nesting
4430 USE mod_scalars
4431!
4432# ifdef DISTRIBUTE
4433 USE distribute_mod, ONLY : mp_aggregate2d
4434 USE distribute_mod, ONLY : mp_aggregate3d
4435# endif
4436 USE strings_mod, ONLY : founderror
4437!
4438! Imported variable declarations.
4439!
4440 logical, intent(in) :: AreaAvg
4441 integer, intent(in) :: ng, dg, model, tile
4442 integer, intent(in) :: gtype, cr, Npoints, Rscale
4443 integer, intent(in) :: LBiF, UBiF, LBjF, UBjF, LBkF, UBkF
4444 integer, intent(in) :: LBiC, UBiC, LBjC, UBjC, LBkC, UBkC
4445!
4446 character(len=*), intent(in) :: svname
4447!
4448 TYPE (T_NGC), intent(in) :: contact(:)
4449!
4450# ifdef ASSUMED_SHAPE
4451 real(r8), intent(in) :: pmC(LBiC:,LBjC:)
4452 real(r8), intent(in) :: pnC(LBiC:,LBjC:)
4453# ifdef MASKING
4454 real(r8), intent(in) :: Cmsk(LBiC:,LBjC:)
4455# ifdef DISTRIBUTE
4456 real(r8), intent(in) :: Amsk(LBiF:,LBjF:)
4457# else
4458 real(r8), intent(in) :: Fmsk(LBiF:,LBjF:)
4459# endif
4460# endif
4461# ifdef DISTRIBUTE
4462 real(r8), intent(in) :: A(LBiF:,LBjF:,LBkF:)
4463 real(r8), intent(in) :: Adx(LBiF:,LBjF:)
4464 real(r8), intent(in) :: Ady(LBiF:,LBjF:)
4465# else
4466 real(r8), intent(in) :: F(LBiF:,LBjF:,LBkF:)
4467 real(r8), intent(in) :: dxF(LBiF:,LBjF:)
4468 real(r8), intent(in) :: dyF(LBiF:,LBjF:)
4469# endif
4470 real(r8), intent(inout) :: C(LBiC:,LBjC:,LBkC:)
4471# else
4472 real(r8), intent(in) :: pmC(LBiC:UBiC,LBjC:UBjC)
4473 real(r8), intent(in) :: pnC(LBiC:UBiC,LBjC:UBjC)
4474# ifdef MASKING
4475 real(r8), intent(in) :: Cmsk(LBiC:UBiC,LBjC:UBjC)
4476# ifdef DISTRIBUTE
4477 real(r8), intent(in) :: Amsk(LBiF:UBiF,LBjF:UBjF)
4478# else
4479 real(r8), intent(in) :: Fmsk(LBiF:UBiF,LBjF:UBjF)
4480# endif
4481# endif
4482# ifdef DISTRIBUTE
4483 real(r8), intent(in) :: A(LBiF:UBiF,LBjF:UBjF,LBkF:UBkF)
4484 real(r8), intent(in) :: Adx(LBiF:UBiF,LBjF:UBjF)
4485 real(r8), intent(in) :: Adx(LBiF:UBiF,LBjF:UBjF)
4486# else
4487 real(r8), intent(in) :: F(LBiF:UBiF,LBjF:UBjF,LBkF:UBkF)
4488 real(r8), intent(in) :: dxF(LBiF:UBiF,LBjF:UBjF)
4489 real(r8), intent(in) :: dyF(LBiF:UBiF,LBjF:UBjF)
4490# endif
4491 real(r8), intent(inout) :: C(LBiC:UBiC,LBjC:UBjC,LBkC:UBkC)
4492# endif
4493!
4494! Local variable declarations.
4495!
4496 integer :: Iadd, Ic, Jadd, Jc, half, i, j, k, m
4497 integer :: Ib_east, Ib_west, Jb_north, Jb_south
4498# ifdef DISTRIBUTE
4499 integer :: LBi, UBi, LBj, UBj
4500# endif
4501!
4502 real(r8) :: areaC_inv, my_area, my_areasum, ratio
4503 real(r8) :: my_avg, my_count, my_sum
4504
4505# ifdef DISTRIBUTE
4506 real(r8), allocatable :: F(:,:,:)
4507 real(r8), allocatable :: dxF(:,:)
4508 real(r8), allocatable :: dyF(:,:)
4509# ifdef MASKING
4510 real(r8), allocatable :: Fmsk(:,:)
4511# endif
4512# endif
4513!
4514 character (len=*), parameter :: MyFile = &
4515 & __FILE__//", fine2coarse3d"
4516
4517# include "set_bounds.h"
4518!
4519!-----------------------------------------------------------------------
4520! Average interior fine grid state variable data to the coarse grid
4521! location. Then, replace coarse grid values with averaged data.
4522!-----------------------------------------------------------------------
4523
4524# ifdef DISTRIBUTE
4525!
4526! Allocate global work array(s).
4527!
4528 lbi=bounds(dg)%LBi(-1)
4529 ubi=bounds(dg)%UBi(-1)
4530 lbj=bounds(dg)%LBj(-1)
4531 ubj=bounds(dg)%UBj(-1)
4532 IF (.not.allocated(f)) THEN
4533 allocate ( f(lbi:ubi,lbj:ubj,lbkf:ubkf) )
4534 END IF
4535 IF (areaavg) THEN
4536 IF (.not.allocated(dxf)) THEN
4537 allocate ( dxf(lbi:ubi,lbj:ubj) )
4538 END IF
4539 IF (.not.allocated(dyf)) THEN
4540 allocate ( dyf(lbi:ubi,lbj:ubj) )
4541 END IF
4542 END IF
4543# ifdef MASKING
4544 IF (.not.allocated(fmsk)) THEN
4545 allocate ( fmsk(lbi:ubi,lbj:ubj) )
4546 END IF
4547# endif
4548!
4549! Gather finer grid data from all nodes in the group to build a global
4550! array.
4551!
4552 CALL mp_aggregate3d (dg, model, gtype, &
4553 & lbif, ubif, lbjf, ubjf, &
4554 & lbi, ubi, lbj, ubj, &
4555 & lbkf, ubkf, &
4556 & a, f)
4557 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4558!
4559 IF (areaavg) THEN
4560 CALL mp_aggregate2d (dg, model, gtype, &
4561 & lbif, ubif, lbjf, ubjf, &
4562 & lbi, ubi, lbj, ubj, &
4563 & adx, dxf)
4564 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4565
4566 CALL mp_aggregate2d (dg, model, gtype, &
4567 & lbif, ubif, lbjf, ubjf, &
4568 & lbi, ubi, lbj, ubj, &
4569 & ady, dyf)
4570 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4571 END IF
4572# ifdef MASKING
4573!
4574 CALL mp_aggregate2d (dg, model, gtype, &
4575 & lbif, ubif, lbjf, ubjf, &
4576 & lbi, ubi, lbj, ubj, &
4577 & amsk, fmsk)
4578 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4579# endif
4580# endif
4581!
4582!-----------------------------------------------------------------------
4583! Average finer grid INTERIOR data to coarse grid according to the
4584! refinement ratio.
4585!-----------------------------------------------------------------------
4586!
4587 half=(rscale-1)/2
4588 IF (areaavg) THEN ! area averaging
4589 DO k=lbkc,ubkc
4590 DO m=1,npoints
4591 i=contact(cr)%Idg(m)
4592 j=contact(cr)%Jdg(m)
4593 ic=contact(cr)%Irg(m)
4594 jc=contact(cr)%Jrg(m)
4595 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4596 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4597 my_count=0.0_r8
4598 my_sum=0.0_r8
4599 my_areasum=0.0_r8
4600 DO jadd=-half,half
4601 DO iadd=-half,half
4602 my_area=dxf(i+iadd,j+jadd)*dyf(i+iadd,j+jadd)
4603 my_areasum=my_areasum+my_area
4604# ifdef MASKING
4605 my_sum=my_sum+ &
4606 & f(i+iadd,j+jadd,k)*my_area* &
4607 & min(1.0_r8,fmsk(i+iadd,j+jadd))
4608 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
4609# else
4610 my_sum=my_sum+ &
4611 & f(i+iadd,j+jadd,k)*my_area
4612# endif
4613 END DO
4614 END DO
4615 SELECT CASE (gtype) ! coarse grid inverse area
4616 CASE (r3dvar)
4617 areac_inv=pmc(ic,jc)*pnc(ic,jc)
4618 CASE (u3dvar)
4619 areac_inv=0.25_r8*(pmc(ic-1,jc)+pmc(ic,jc))* &
4620 & (pnc(ic-1,jc)+pnc(ic,jc))
4621 CASE (v3dvar)
4622 areac_inv=0.25_r8*(pmc(ic,jc-1)+pmc(ic,jc))* &
4623 & (pnc(ic,jc-1)+pnc(ic,jc))
4624 CASE DEFAULT
4625 areac_inv=pmc(ic,jc)*pnc(ic,jc)
4626 END SELECT
4627 ratio=my_areasum*areac_inv ! for debugging purposes
4628 my_avg=my_sum*areac_inv
4629# ifdef MASKING
4630 IF (my_count.gt.0.0_r8) THEN
4631 my_avg=my_avg*rscale*rscale/my_count
4632 END IF
4633 my_avg=my_avg*cmsk(ic,jc)
4634# endif
4635 c(ic,jc,k)=my_avg
4636 END IF
4637 END DO
4638 END DO
4639 ELSE ! simple averaging
4640 DO k=lbkc,ubkc
4641 DO m=1,npoints
4642 i=contact(cr)%Idg(m)
4643 j=contact(cr)%Jdg(m)
4644 ic=contact(cr)%Irg(m)
4645 jc=contact(cr)%Jrg(m)
4646 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4647 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4648 my_count=0.0_r8
4649 my_avg=0.0_r8
4650 my_sum=0.0_r8
4651 DO jadd=-half,half
4652 DO iadd=-half,half
4653# ifdef MASKING
4654 my_sum=my_sum+ &
4655 & f(i+iadd,j+jadd,k)*fmsk(i+iadd,j+jadd)
4656 my_count=my_count+min(1.0_r8,fmsk(i+iadd,j+jadd))
4657# else
4658 my_sum=my_sum+ &
4659 & f(i+iadd,j+jadd,k)
4660 my_count=my_count+1.0_r8
4661# endif
4662 END DO
4663 END DO
4664 IF (my_count.gt.0.0_r8) my_avg=my_sum/my_count
4665# ifdef MASKING
4666 my_avg=my_avg*cmsk(ic,jc)
4667# endif
4668 c(ic,jc,k)=my_avg
4669 END IF
4670 END DO
4671 END DO
4672 END IF
4673# ifdef REFINE_BOUNDARY
4674!
4675!-----------------------------------------------------------------------
4676! Average finer grid BOUNDARY data to coarse grid U-type and V-type
4677! variables according to the refinement ratio.
4678!-----------------------------------------------------------------------
4679!
4680! U-type variables finer grid eastern and western boundaries.
4681!
4682 IF (gtype.eq.u3dvar) THEN
4683!
4684! Get indices of coarser grid (ng) corresponding to the corners of
4685! the finer grid (dg).
4686!
4687 ib_west=i_left(dg)
4688 ib_east=i_right(dg)
4689 jb_south=j_bottom(dg)
4690 jb_north=j_top(dg)
4691!
4692! Eastern boundary.
4693!
4694 DO k=lbkc,ubkc
4695 i=lm(dg)+1 ! donor finer grid
4696 ic=ib_east ! receiver coarser grid
4697 DO jc=jb_south,jb_north-1
4698 j=(jc-jb_south)*rscale+half+1
4699 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4700 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4701 my_count=0.0_r8
4702 my_avg=0.0_r8
4703 my_sum=0.0_r8
4704 DO jadd=-half,half
4705 my_sum=my_sum+ &
4706 & f(i,j+jadd,k)
4707 my_count=my_count+1.0_r8
4708 END DO
4709 my_avg=my_sum/my_count
4710 c(ic,jc,k)=my_avg
4711 END IF
4712 END DO
4713 END DO
4714!
4715! Western boundary.
4716!
4717 DO k=lbkc,ubkc
4718 i=1 ! donor finer grid
4719 ic=ib_west ! receiver coarser grid
4720 DO jc=jb_south,jb_north-1
4721 j=(jc-jb_south)*rscale+half+1
4722 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4723 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4724 my_count=0.0_r8
4725 my_avg=0.0_r8
4726 my_sum=0.0_r8
4727 DO jadd=-half,half
4728 my_sum=my_sum+ &
4729 & f(i,j+jadd,k)
4730 my_count=my_count+1.0_r8
4731 END DO
4732 my_avg=my_sum/my_count
4733 c(ic,jc,k)=my_avg
4734 END IF
4735 END DO
4736 END DO
4737 END IF
4738!
4739! V-type variables finer grid northern and southern boundaries.
4740!
4741 IF (gtype.eq.v3dvar) THEN
4742!
4743! Get indices of coarser grid (ng) corresponding to the corners of
4744! the finer grid (dg).
4745!
4746 ib_west=i_left(dg)
4747 ib_east=i_right(dg)
4748 jb_south=j_bottom(dg)
4749 jb_north=j_top(dg)
4750!
4751! Northern boundary.
4752!
4753 DO k=lbkc,ubkc
4754 j=mm(dg)+1 ! donor finer grid
4755 jc=jb_north ! receiver coarser grid
4756 DO ic=ib_west,ib_east-1
4757 i=(ic-ib_west)*rscale+half+1
4758 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4759 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4760 my_count=0.0_r8
4761 my_avg=0.0_r8
4762 my_sum=0.0_r8
4763 DO iadd=-half,half
4764 my_sum=my_sum+ &
4765 & f(i+iadd,j,k)
4766 my_count=my_count+1.0_r8
4767 END DO
4768 my_avg=my_sum/my_count
4769 c(ic,jc,k)=my_avg
4770 END IF
4771 END DO
4772 END DO
4773!
4774! Southern boundary.
4775!
4776 DO k=lbkc,ubkc
4777 j=1 ! donor finer grid
4778 jc=jb_south ! receiver coarser grid
4779 DO ic=ib_west,ib_east-1
4780 i=(ic-ib_west)*rscale+half+1
4781 IF (((istr.le.ic).and.(ic.le.iend)).and. &
4782 & ((jstr.le.jc).and.(jc.le.jend))) THEN
4783 my_count=0.0_r8
4784 my_avg=0.0_r8
4785 my_sum=0.0_r8
4786 DO iadd=-half,half
4787 my_sum=my_sum+ &
4788 & f(i+iadd,j,k)
4789 my_count=my_count+1.0_r8
4790 END DO
4791 my_avg=my_sum/my_count
4792 c(ic,jc,k)=my_avg
4793 END IF
4794 END DO
4795 END DO
4796 END IF
4797# endif
4798# ifdef DISTRIBUTE
4799!
4800! Deallocate work array.
4801!
4802 IF (allocated(f)) THEN
4803 deallocate (f)
4804 END IF
4805 IF (areaavg) THEN
4806 IF (allocated(dxf)) THEN
4807 deallocate (dxf)
4808 END IF
4809 IF (allocated(dyf)) THEN
4810 deallocate (dyf)
4811 END IF
4812 END IF
4813# ifdef MASKING
4814 IF (allocated(fmsk)) THEN
4815 deallocate (fmsk)
4816 END IF
4817# endif
4818# endif
4819!
4820 RETURN
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

References mod_param::bounds, mod_scalars::exit_flag, strings_mod::founderror(), mod_nesting::i_left, mod_nesting::i_right, mod_nesting::j_bottom, mod_nesting::j_top, mod_param::lm, mod_param::mm, distribute_mod::mp_aggregate2d(), distribute_mod::mp_aggregate3d(), mod_scalars::noerror, mod_param::r3dvar, mod_param::u3dvar, and mod_param::v3dvar.

Referenced by fine2coarse(), and tl_nesting_mod::tl_fine2coarse().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ get_composite()

subroutine, private nesting_mod::get_composite ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) isection,
integer, intent(in) tile )
private

Definition at line 1986 of file nesting.F.

1987!
1988!=======================================================================
1989! !
1990! This routine gets the donor grid data required to process the !
1991! contact points of the current composite grid. It extracts the !
1992! donor cell points containing each contact point. In composite !
1993! grids, it is possible to have more than one contact region. !
1994! !
1995! The interpolation of composite grid contact points from donor !
1996! grid data is carried out in a different parallel region using !
1997! 'put_composite'. !
1998! !
1999! On Input: !
2000! !
2001! ng Composite grid number (integer) !
2002! model Calling model identifier (integer) !
2003! isection Governing equations time-stepping section in !
2004! main2d or main3d indicating which state !
2005! variables to process (integer) !
2006! tile Domain tile partition (integer) !
2007! !
2008! On Output: (mod_nesting) !
2009! !
2010! COMPOSITE Updated contact points structure. !
2011! !
2012!=======================================================================
2013!
2014 USE mod_param
2015 USE mod_coupling
2016 USE mod_forces
2017 USE mod_grid
2018 USE mod_ncparam
2019 USE mod_nesting
2020 USE mod_ocean
2021 USE mod_scalars
2022 USE mod_stepping
2023!
2024! Imported variable declarations.
2025!
2026 integer, intent(in) :: ng, model, isection, tile
2027!
2028! Local variable declarations.
2029!
2030 integer :: cr, dg, rg, nrec, rec
2031# ifdef SOLVE3D
2032 integer :: itrc
2033# endif
2034 integer :: LBi, UBi, LBj, UBj
2035 integer :: Tindex
2036!
2037!-----------------------------------------------------------------------
2038! Get donor grid data needed to process composite grid contact points.
2039! Only process those variables associated with the governing equation
2040! time-stepping section.
2041!-----------------------------------------------------------------------
2042!
2043 DO cr=1,ncontact
2044!
2045! Get data donor and data receiver grid numbers.
2046!
2047 dg=rcontact(cr)%donor_grid
2048 rg=rcontact(cr)%receiver_grid
2049!
2050! Process only contact region data for requested nested grid "ng".
2051!
2052 IF (rg.eq.ng) THEN
2053!
2054! Set donor grid lower and upper array indices.
2055!
2056 lbi=bounds(dg)%LBi(tile)
2057 ubi=bounds(dg)%UBi(tile)
2058 lbj=bounds(dg)%LBj(tile)
2059 ubj=bounds(dg)%UBj(tile)
2060!
2061! Process bottom stress (bustr, bvstr).
2062!
2063 IF (isection.eq.nbstr) THEN
2064 CALL get_contact2d (dg, model, tile, &
2065 & u2dvar, vname(1,idubms), &
2066 & cr, ucontact(cr)%Npoints, ucontact, &
2067 & lbi, ubi, lbj, ubj, &
2068 & forces(dg) % bustr, &
2069 & composite(cr) % bustr)
2070 CALL get_contact2d (dg, model, tile, &
2071 & v2dvar, vname(1,idvbms), &
2072 & cr, vcontact(cr)%Npoints, vcontact, &
2073 & lbi, ubi, lbj, ubj, &
2074 & forces(dg) % bvstr, &
2075 & composite(cr) % bvstr)
2076 END IF
2077!
2078! Process free-surface (zeta) at the appropriate time index.
2079!
2080 IF ((isection.eq.nfsic).or. &
2081 & (isection.eq.nzeta).or. &
2082 & (isection.eq.n2dps).or. &
2083 & (isection.eq.n2dcs)) THEN
2084 IF (isection.eq.nzeta) THEN
2085 nrec=2 ! process time records 1 and 2
2086 ELSE
2087 nrec=1 ! process knew record
2088 END IF
2089 DO rec=1,nrec
2090 IF (isection.eq.nzeta) THEN
2091 tindex=rec
2092 ELSE
2093 tindex=knew(dg)
2094 END IF
2095 CALL get_contact2d (dg, model, tile, &
2096 & r2dvar, vname(1,idfsur), &
2097 & cr, rcontact(cr)%Npoints, rcontact, &
2098 & lbi, ubi, lbj, ubj, &
2099 & ocean(dg) % zeta(:,:,tindex), &
2100 & composite(cr) % zeta(:,:,rec))
2101 END DO
2102 END IF
2103
2104# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3)
2105!
2106! Process free-surface equation rigth-hand-side (rzeta) term.
2107!
2108 IF (isection.eq.n2dps) THEN
2109 tindex=1
2110 CALL get_contact2d (dg, model, tile, &
2111 & r2dvar, vname(1,idrzet), &
2112 & cr, rcontact(cr)%Npoints, rcontact, &
2113 & lbi, ubi, lbj, ubj, &
2114 & ocean(dg) % rzeta(:,:,tindex), &
2115 & composite(cr) % rzeta)
2116 END IF
2117# endif
2118!
2119! Process 2D momentum components (ubar,vbar) at the appropriate time
2120! index.
2121!
2122 IF ((isection.eq.n2dic).or. &
2123 & (isection.eq.n2dps).or. &
2124 & (isection.eq.n2dcs).or. &
2125 & (isection.eq.n3duv)) THEN
2126 IF (isection.eq.n3duv) THEN
2127 nrec=2 ! process time records 1 and 2
2128 ELSE
2129 nrec=1 ! process knew record
2130 END IF
2131 DO rec=1,nrec
2132 IF (isection.eq.n3duv) THEN
2133 tindex=rec
2134 ELSE
2135 tindex=knew(dg)
2136 END IF
2137 CALL get_contact2d (dg, model, tile, &
2138 & u2dvar, vname(1,idubar), &
2139 & cr, ucontact(cr)%Npoints, ucontact, &
2140 & lbi, ubi, lbj, ubj, &
2141 & ocean(dg) % ubar(:,:,tindex), &
2142 & composite(cr) % ubar(:,:,rec))
2143 CALL get_contact2d (dg, model, tile, &
2144 & v2dvar, vname(1,idvbar), &
2145 & cr, vcontact(cr)%Npoints, vcontact, &
2146 & lbi, ubi, lbj, ubj, &
2147 & ocean(dg) % vbar(:,:,tindex), &
2148 & composite(cr) % vbar(:,:,rec))
2149 END DO
2150 END IF
2151
2152# ifdef SOLVE3D
2153!
2154! Process time averaged free-surface (Zt_avg1) and 2D momentum fluxes
2155! (DU_avg1, DV_avg1).
2156!
2157 IF (isection.eq.n2dfx) THEN
2158 CALL get_contact2d (dg, model, tile, &
2159 & r2dvar, 'Zt_avg1', &
2160 & cr, rcontact(cr)%Npoints, rcontact, &
2161 & lbi, ubi, lbj, ubj, &
2162 & coupling(dg) % Zt_avg1, &
2163 & composite(cr) % Zt_avg1)
2164 CALL get_contact2d (dg, model, tile, &
2165 & u2dvar, 'DU_avg1', &
2166 & cr, ucontact(cr)%Npoints, ucontact, &
2167 & lbi, ubi, lbj, ubj, &
2168 & coupling(dg) % DU_avg1, &
2169 & composite(cr) % DU_avg1)
2170 CALL get_contact2d (dg, model, tile, &
2171 & v2dvar, 'DV_avg1', &
2172 & cr, vcontact(cr)%Npoints, vcontact, &
2173 & lbi, ubi, lbj, ubj, &
2174 & coupling(dg) % DV_avg1, &
2175 & composite(cr) % DV_avg1)
2176 END IF
2177
2178# if !defined TS_FIXED
2179!
2180! Process tracer variables (t) at the appropriate time index.
2181!
2182 IF ((isection.eq.ntvic).or. &
2183 & (isection.eq.nrhst).or. &
2184 & (isection.eq.n3dtv)) THEN
2185 DO itrc=1,nt(ng)
2186 IF (isection.eq.nrhst) THEN
2187 tindex=3
2188 ELSE
2189 tindex=nnew(dg)
2190 END IF
2191 CALL get_contact3d (dg, model, tile, &
2192 & r3dvar, vname(1,idtvar(itrc)), &
2193 & cr, rcontact(cr)%Npoints, rcontact, &
2194 & lbi, ubi, lbj, ubj, 1, n(dg), &
2195 & ocean(dg) % t(:,:,:,tindex,itrc), &
2196 & composite(cr) % t(:,:,:,itrc))
2197 END DO
2198 END IF
2199# endif
2200!
2201! Process 3D momentum (u, v) at the appropriate time-index.
2202!
2203 IF ((isection.eq.n3dic).or. &
2204 & (isection.eq.n3duv)) THEN
2205 tindex=nnew(dg)
2206 CALL get_contact3d (dg, model, tile, &
2207 & u3dvar, vname(1,iduvel), &
2208 & cr, ucontact(cr)%Npoints, ucontact, &
2209 & lbi, ubi, lbj, ubj, 1, n(dg), &
2210 & ocean(dg) % u(:,:,:,tindex), &
2211 & composite(cr) % u)
2212 CALL get_contact3d (dg, model, tile, &
2213 & v3dvar, vname(1,idvvel), &
2214 & cr, vcontact(cr)%Npoints, vcontact, &
2215 & lbi, ubi, lbj, ubj, 1, n(dg), &
2216 & ocean(dg) % v(:,:,:,tindex), &
2217 & composite(cr) % v)
2218 END IF
2219!
2220! Process 3D momentum fluxes (Huon, Hvom).
2221!
2222 IF (isection.eq.n3duv) THEN
2223 CALL get_contact3d (dg, model, tile, &
2224 & u3dvar, 'Huon', &
2225 & cr, ucontact(cr)%Npoints, ucontact, &
2226 & lbi, ubi, lbj, ubj, 1, n(dg), &
2227 & grid(dg) % Huon, &
2228 & composite(cr) % Huon)
2229 CALL get_contact3d (dg, model, tile, &
2230 & v3dvar, 'Hvom', &
2231 & cr, vcontact(cr)%Npoints, vcontact, &
2232 & lbi, ubi, lbj, ubj, 1, n(dg), &
2233 & grid(dg) % Hvom, &
2234 & composite(cr) % Hvom)
2235 END IF
2236# endif
2237
2238 END IF
2239 END DO
2240!
2241 RETURN
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_ncparam::idvbms
integer idvbms
Definition mod_ncparam.F:365
mod_ncparam::idrzet
integer idrzet
Definition mod_ncparam.F:286
mod_ncparam::idubms
integer idubms
Definition mod_ncparam.F:330
mod_nesting::nrhst
integer, parameter nrhst
Definition mod_nesting.F:87
mod_nesting::n2dfx
integer, parameter n2dfx
Definition mod_nesting.F:92
mod_nesting::nzeta
integer, parameter nzeta
Definition mod_nesting.F:88
mod_nesting::ntvic
integer, parameter ntvic
Definition mod_nesting.F:85
mod_nesting::nfsic
integer, parameter nfsic
Definition mod_nesting.F:82
mod_nesting::n3dic
integer, parameter n3dic
Definition mod_nesting.F:84
mod_nesting::n3duv
integer, parameter n3duv
Definition mod_nesting.F:93
mod_nesting::n2dps
integer, parameter n2dps
Definition mod_nesting.F:90
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::nbstr
integer, parameter nbstr
Definition mod_nesting.F:86
mod_nesting::n2dcs
integer, parameter n2dcs
Definition mod_nesting.F:91

References mod_param::bounds, mod_nesting::composite, mod_coupling::coupling, mod_forces::forces, get_contact2d(), get_contact3d(), mod_grid::grid, mod_ncparam::idfsur, mod_ncparam::idrzet, mod_ncparam::idtvar, mod_ncparam::idubar, mod_ncparam::idubms, mod_ncparam::iduvel, mod_ncparam::idvbar, mod_ncparam::idvbms, mod_ncparam::idvvel, mod_stepping::knew, mod_param::n, mod_nesting::n2dcs, mod_nesting::n2dfx, mod_nesting::n2dic, mod_nesting::n2dps, mod_nesting::n3dic, mod_nesting::n3dtv, mod_nesting::n3duv, mod_nesting::nbstr, mod_nesting::ncontact, mod_nesting::nfsic, mod_stepping::nnew, mod_nesting::nrhst, mod_param::nt, mod_nesting::ntvic, mod_nesting::nzeta, mod_ocean::ocean, mod_param::r2dvar, mod_param::r3dvar, mod_nesting::rcontact, mod_param::u2dvar, mod_param::u3dvar, mod_nesting::ucontact, mod_param::v2dvar, mod_param::v3dvar, mod_nesting::vcontact, and mod_ncparam::vname.

Referenced by nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ get_contact2d()

subroutine, public nesting_mod::get_contact2d ( integer, intent(in) dg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) gtype,
character(len=*), intent(in) svname,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
real(r8), dimension(lbi:,lbj:), intent(in) ad,
real(r8), dimension(:,:), intent(inout) ac )

Definition at line 4824 of file nesting.F.

4829!
4830!=======================================================================
4831! !
4832! This routine gets the donor grid data (Ac) necessary to process !
4833! the contact points for a 2D state variable (Ad). It extracts the !
4834! donor cell points containing each contact point, Ac(1:4,:). !
4835! !
4836! On Input: !
4837! !
4838! dg Donor grid number (integer) !
4839! model Calling model identifier (integer) !
4840! tile Domain tile partition (integer) !
4841! gtype C-grid variable type (integer) !
4842! svname State variable name (string) !
4843! cr Contact region number to process (integer) !
4844! Npoints Number of points in the contact region (integer) !
4845! contact Contact region information variables (T_NGC structure)!
4846! LBi Donor grid, I-dimension Lower bound (integer) !
4847! UBi Donor grid, I-dimension Upper bound (integer) !
4848! LBj Donor grid, J-dimension Lower bound (integer) !
4849! UBj Donor grid, J-dimension Upper bound (integer) !
4850! Ad Donor grid data (2D array) !
4851! !
4852! On Input: !
4853! !
4854! Ac 2D state variable contact point data !
4855! !
4856!=======================================================================
4857!
4858 USE mod_param
4859 USE mod_ncparam
4860 USE mod_nesting
4861
4862# ifdef DISTRIBUTE
4863!
4864 USE distribute_mod, ONLY : mp_assemble
4865# endif
4866!
4867! Imported variable declarations.
4868!
4869 integer, intent(in) :: dg, model, tile
4870 integer, intent(in) :: gtype, cr, Npoints
4871 integer, intent(in) :: LBi, UBi, LBj, UBj
4872!
4873 character(len=*), intent(in) :: svname
4874!
4875 TYPE (T_NGC), intent(in) :: contact(:)
4876!
4877# ifdef ASSUMED_SHAPE
4878 real(r8), intent(in) :: Ad(LBi:,LBj:)
4879 real(r8), intent(inout) :: Ac(:,:)
4880# else
4881 real(r8), intent(in) :: Ad(LBi:UBi,LBj:UBj)
4882 real(r8), intent(inout) :: Ac(Npoints,4)
4883# endif
4884!
4885! Local variable declarations.
4886!
4887 integer :: i, ip1, j, jp1, m
4888 integer :: Imin, Imax, Jmin, Jmax
4889 integer :: Istr, Iend, Jstr, Jend
4890# ifdef DISTRIBUTE
4891 integer :: Npts
4892# endif
4893
4894 real(r8), parameter :: Aspv = 0.0_r8
4895!
4896!-----------------------------------------------------------------------
4897! Initialize.
4898!-----------------------------------------------------------------------
4899
4900# ifdef DISTRIBUTE
4901!
4902! Initialize contact points array to special value to facilite
4903! distribute-memory data collection from all nodes.
4904!
4905 npts=4*npoints
4906 DO m=1,npoints
4907 ac(1,m)=aspv
4908 ac(2,m)=aspv
4909 ac(3,m)=aspv
4910 ac(4,m)=aspv
4911 END DO
4912# endif
4913!
4914! Set starting and ending tile indices for the donor grids.
4915!
4916 SELECT CASE (gtype)
4917 CASE (r2dvar)
4918 imin=bounds(dg) % IstrT(-1) ! full RHO-grid range
4919 imax=bounds(dg) % IendT(-1)
4920 jmin=bounds(dg) % JstrT(-1)
4921 jmax=bounds(dg) % JendT(-1)
4922!
4923 istr=bounds(dg) % IstrT(tile) ! domain partition range
4924 iend=bounds(dg) % IendT(tile)
4925 jstr=bounds(dg) % JstrT(tile)
4926 jend=bounds(dg) % JendT(tile)
4927 CASE (u2dvar)
4928 imin=bounds(dg) % IstrP(-1) ! full U-grid range
4929 imax=bounds(dg) % IendT(-1)
4930 jmin=bounds(dg) % JstrT(-1)
4931 jmax=bounds(dg) % JendT(-1)
4932!
4933 istr=bounds(dg) % IstrP(tile) ! domain partition range
4934 iend=bounds(dg) % IendT(tile)
4935 jstr=bounds(dg) % JstrT(tile)
4936 jend=bounds(dg) % JendT(tile)
4937 CASE (v2dvar)
4938 imin=bounds(dg) % IstrT(-1) ! full V-grid range
4939 imax=bounds(dg) % IendT(-1)
4940 jmin=bounds(dg) % JstrP(-1)
4941 jmax=bounds(dg) % JendT(-1)
4942!
4943 istr=bounds(dg) % IstrT(tile) ! domain partition range
4944 iend=bounds(dg) % IendT(tile)
4945 jstr=bounds(dg) % JstrP(tile)
4946 jend=bounds(dg) % JendT(tile)
4947 END SELECT
4948!
4949!-----------------------------------------------------------------------
4950! Extract donor grid data at contact points.
4951!-----------------------------------------------------------------------
4952!
4953! Notice that the indices i+1 and j+1 are bounded the maximum values
4954! of the grid. This implies that contact point lies on the grid
4955! boundary.
4956!
4957 DO m=1,npoints
4958 i=contact(cr)%Idg(m)
4959 j=contact(cr)%Jdg(m)
4960 ip1=min(i+1,imax)
4961 jp1=min(j+1,jmax)
4962 IF (((istr.le.i).and.(i.le.iend)).and. &
4963 & ((jstr.le.j).and.(j.le.jend))) THEN
4964 ac(1,m)=ad(i ,j )
4965 ac(2,m)=ad(ip1,j )
4966 ac(3,m)=ad(ip1,jp1)
4967 ac(4,m)=ad(i ,jp1)
4968 END IF
4969 END DO
4970
4971# ifdef DISTRIBUTE
4972!
4973! Gather and broadcast data from all nodes.
4974!
4975 CALL mp_assemble (dg, model, npts, aspv, ac)
4976# endif
4977!
4978 RETURN

References mod_param::bounds, mod_param::r2dvar, mod_param::u2dvar, and mod_param::v2dvar.

Referenced by ad_nesting_mod::ad_get_composite(), get_composite(), get_refine(), tl_nesting_mod::tl_get_composite(), and tl_nesting_mod::tl_get_refine().

Here is the caller graph for this function:

◆ get_contact3d()

subroutine, public nesting_mod::get_contact3d ( integer, intent(in) dg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) gtype,
character(len=*), intent(in) svname,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
real(r8), dimension(lbi:,lbj:,lbk:), intent(in) ad,
real(r8), dimension(:,lbk:,:), intent(inout) ac )

Definition at line 4983 of file nesting.F.

4988!
4989!=======================================================================
4990! !
4991! This routine gets the donor grid data (Ac) necessary to process !
4992! the contact points for a 3D state variable (Ad). It extracts the !
4993! donor cell points containing each contact point, Ac(1:4,k,:). !
4994! !
4995! On Input: !
4996! !
4997! dg Donor grid number (integer) !
4998! model Calling model identifier (integer) !
4999! tile Domain tile partition (integer) !
5000! gtype C-grid variable type (integer) !
5001! svname State variable name (string) !
5002! cr Contact region number to process (integer) !
5003! Npoints Number of points in the contact region (integer) !
5004! contact Contact region information variables (T_NGC structure)!
5005! LBi Donor grid, I-dimension Lower bound (integer) !
5006! UBi Donor grid, I-dimension Upper bound (integer) !
5007! LBj Donor grid, J-dimension Lower bound (integer) !
5008! UBj Donor grid, J-dimension Upper bound (integer) !
5009! Ad Donor grid data (3D array) !
5010! !
5011! On Input: !
5012! !
5013! Ac 3D state variable contact point data !
5014! !
5015!=======================================================================
5016!
5017 USE mod_param
5018 USE mod_ncparam
5019 USE mod_nesting
5020
5021# ifdef DISTRIBUTE
5022!
5023 USE distribute_mod, ONLY : mp_assemble
5024# endif
5025!
5026! Imported variable declarations.
5027!
5028 integer, intent(in) :: dg, model, tile
5029 integer, intent(in) :: gtype, cr, Npoints
5030 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
5031!
5032 character(len=*), intent(in) :: svname
5033!
5034 TYPE (T_NGC), intent(in) :: contact(:)
5035!
5036# ifdef ASSUMED_SHAPE
5037 real(r8), intent(in) :: Ad(LBi:,LBj:,LBk:)
5038 real(r8), intent(inout) :: Ac(:,LBk:,:)
5039# else
5040 real(r8), intent(in) :: Ad(LBi:UBi,LBj:UBj,LBk:UBk)
5041 real(r8), intent(inout) :: Ac(4,LBk:UBk,Npoints)
5042# endif
5043!
5044! Local variable declarations.
5045!
5046 integer :: i, ip1, j, jp1, k, m
5047 integer :: Imin, Imax, Jmin, Jmax
5048 integer :: Istr, Iend, Jstr, Jend
5049# ifdef DISTRIBUTE
5050 integer :: Npts
5051# endif
5052
5053 real(r8), parameter :: Aspv = 0.0_r8
5054!
5055!-----------------------------------------------------------------------
5056! Initialize.
5057!-----------------------------------------------------------------------
5058
5059# ifdef DISTRIBUTE
5060!
5061! Initialize contact points array to special value to facilite
5062! distribute-memory data collection from all nodes.
5063!
5064 npts=4*(ubk-lbk+1)*npoints
5065 DO k=lbk,ubk
5066 DO m=1,npoints
5067 ac(1,k,m)=aspv
5068 ac(2,k,m)=aspv
5069 ac(3,k,m)=aspv
5070 ac(4,k,m)=aspv
5071 END DO
5072 END DO
5073# endif
5074!
5075! Set starting and ending tile indices for the donor grid.
5076!
5077 SELECT CASE (gtype)
5078 CASE (r3dvar)
5079 imin=bounds(dg) % IstrT(-1) ! full RHO-grid range
5080 imax=bounds(dg) % IendT(-1)
5081 jmin=bounds(dg) % JstrT(-1)
5082 jmax=bounds(dg) % JendT(-1)
5083!
5084 istr=bounds(dg) % IstrT(tile) ! domain partition range
5085 iend=bounds(dg) % IendT(tile)
5086 jstr=bounds(dg) % JstrT(tile)
5087 jend=bounds(dg) % JendT(tile)
5088 CASE (u3dvar)
5089 imin=bounds(dg) % IstrP(-1) ! full U-grid range
5090 imax=bounds(dg) % IendT(-1)
5091 jmin=bounds(dg) % JstrT(-1)
5092 jmax=bounds(dg) % JendT(-1)
5093!
5094 istr=bounds(dg) % IstrP(tile) ! domain partition range
5095 iend=bounds(dg) % IendT(tile)
5096 jstr=bounds(dg) % JstrT(tile)
5097 jend=bounds(dg) % JendT(tile)
5098 CASE (v3dvar)
5099 imin=bounds(dg) % IstrT(-1) ! full V-grid range
5100 imax=bounds(dg) % IendT(-1)
5101 jmin=bounds(dg) % JstrP(-1)
5102 jmax=bounds(dg) % JendT(-1)
5103!
5104 istr=bounds(dg) % IstrT(tile) ! domain partition range
5105 iend=bounds(dg) % IendT(tile)
5106 jstr=bounds(dg) % JstrP(tile)
5107 jend=bounds(dg) % JendT(tile)
5108 END SELECT
5109!
5110!-----------------------------------------------------------------------
5111! Extract donor grid data at contact points.
5112!-----------------------------------------------------------------------
5113!
5114! Notice that the indices i+1 and j+1 are bounded the maximum values
5115! of the grid. This implies that contact point lies on the grid
5116! boundary.
5117!
5118 DO k=lbk,ubk
5119 DO m=1,npoints
5120 i=contact(cr)%Idg(m)
5121 j=contact(cr)%Jdg(m)
5122 ip1=min(i+1,imax)
5123 jp1=min(j+1,jmax)
5124 IF (((istr.le.i).and.(i.le.iend)).and. &
5125 & ((jstr.le.j).and.(j.le.jend))) THEN
5126 ac(1,k,m)=ad(i ,j ,k)
5127 ac(2,k,m)=ad(ip1,j ,k)
5128 ac(3,k,m)=ad(ip1,jp1,k)
5129 ac(4,k,m)=ad(i ,jp1,k)
5130 END IF
5131 END DO
5132 END DO
5133
5134# ifdef DISTRIBUTE
5135!
5136! Gather and broadcast data from all nodes.
5137!
5138 CALL mp_assemble (dg, model, npts, aspv, ac(:,lbk:,:))
5139# endif
5140!
5141 RETURN

References mod_param::bounds, mod_param::r3dvar, mod_param::u3dvar, and mod_param::v3dvar.

Referenced by ad_nesting_mod::ad_get_composite(), get_composite(), get_refine(), tl_nesting_mod::tl_get_composite(), and tl_nesting_mod::tl_get_refine().

Here is the caller graph for this function:

◆ get_metrics()

subroutine, public nesting_mod::get_metrics ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) tile )

Definition at line 2244 of file nesting.F.

2245!
2246!=======================================================================
2247! !
2248! This routine extracts grid spacing metrics "on_u" and "om_v", !
2249! which are used to impose mass flux at the finer grid physical !
2250! boundaries in refinement applications. !
2251! !
2252! The extracted metrics is stored in REFINED structure and are !
2253! needed in 'put_refine2d'. !
2254! !
2255! On Input: !
2256! !
2257! ng Refinement grid number (integer) !
2258! model Calling model identifier (integer) !
2259! tile Domain tile partition (integer) !
2260! !
2261! On Output: (mod_nesting) !
2262! !
2263! REFINED Updated contact points structure. !
2264! !
2265!=======================================================================
2266!
2267 USE mod_param
2268 USE mod_grid
2269 USE mod_nesting
2270 USE mod_scalars
2271!
2272# ifdef DISTRIBUTE
2273 USE distribute_mod, ONLY : mp_assemble
2274# endif
2275 USE strings_mod, ONLY : founderror
2276!
2277! Imported variable declarations.
2278!
2279 integer, intent(in) :: ng, model, tile
2280!
2281! Local variable declarations.
2282!
2283 integer :: cr, dg, i, j, m
2284 integer :: Istr, Iend, Jstr, Jend
2285 integer :: NpointsU, NpointsV
2286!
2287 real(r8), parameter :: spv = 0.0_r8
2288!
2289 character (len=*), parameter :: MyFile = &
2290 & __FILE__//", get_metrics"
2291!
2292!-----------------------------------------------------------------------
2293! Extract grid spacing metrics.
2294!-----------------------------------------------------------------------
2295!
2296 DO cr=1,ncontact
2297!
2298! Get data donor grid number.
2299!
2300 dg=rcontact(cr)%donor_grid
2301!
2302! Extract grid spacing at U-points.
2303!
2304 istr=bounds(dg) % IstrP(tile)
2305 iend=bounds(dg) % IendT(tile)
2306 jstr=bounds(dg) % JstrT(tile)
2307 jend=bounds(dg) % JendT(tile)
2308!
2309 npointsu=ucontact(cr) % Npoints
2310 refined(cr) % on_u(1:npointsu) = spv
2311!
2312 DO m=1,npointsu
2313 i=ucontact(cr) % Idg(m)
2314 j=ucontact(cr) % Jdg(m)
2315 IF (((istr.le.i).and.(i.le.iend)).and. &
2316 & ((jstr.le.j).and.(j.le.jend))) THEN
2317 refined(cr) % on_u(m) = grid(dg) % on_u(i,j)
2318 END IF
2319 END DO
2320!
2321! Extract grid spacing at V-points.
2322!
2323 istr=bounds(dg) % IstrT(tile)
2324 iend=bounds(dg) % IendT(tile)
2325 jstr=bounds(dg) % JstrP(tile)
2326 jend=bounds(dg) % JendT(tile)
2327!
2328 npointsv=vcontact(cr) % Npoints
2329 refined(cr) % om_v(1:npointsv) = spv
2330!
2331 DO m=1,npointsv
2332 i=vcontact(cr) % Idg(m)
2333 j=vcontact(cr) % Jdg(m)
2334 IF (((istr.le.i).and.(i.le.iend)).and. &
2335 & ((jstr.le.j).and.(j.le.jend))) THEN
2336 refined(cr) % om_v(m) = grid(dg) % om_v(i,j)
2337 END IF
2338 END DO
2339
2340# ifdef DISTRIBUTE
2341!
2342! Exchange data between all nodes.
2343!
2344 CALL mp_assemble (dg, model, npointsu, spv, refined(cr) % on_u)
2345 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2346
2347 CALL mp_assemble (dg, model, npointsv, spv, refined(cr) % om_v)
2348 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2349# endif
2350
2351 END DO
2352!
2353 RETURN

References mod_param::bounds, mod_scalars::exit_flag, strings_mod::founderror(), mod_grid::grid, mod_nesting::ncontact, mod_scalars::noerror, mod_nesting::rcontact, mod_nesting::refined, mod_nesting::ucontact, and mod_nesting::vcontact.

Referenced by ad_nesting_mod::ad_nesting(), nesting(), and tl_nesting_mod::tl_nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ get_persisted2d()

subroutine, public nesting_mod::get_persisted2d ( integer, intent(in) dg,
integer, intent(in) rg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) gtype,
character(len=*), intent(in) svname,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
real(r8), dimension(lbi:,lbj:), intent(in) ad,
real(r8), dimension(:,:), intent(inout) ac )

Definition at line 5145 of file nesting.F.

5150!
5151!=======================================================================
5152! !
5153! This routine gets the donor grid data (Ac) necessary to process !
5154! the contact points for a 2D flux variable (Ad). It extracts the !
5155! donor cell points containing each contact point, Ac(1:4,:). !
5156! !
5157! This routine is different that 'get_contact2d'. It is used in !
5158! refinement to impose the appropriate coarser grid flux to insure !
5159! volume and mass conservation. The value of the coarse grid cell !
5160! is presisted over the refined grid points along its physical !
5161! boundary. This will facilitate that the sum of all the refined !
5162! grid point is the same as that of the coarse grid containing such !
5163! points. The spatial interpolation as set in 'get_contact2d' will !
5164! not conserve volume and mass. !
5165! !
5166! On Input: !
5167! !
5168! dg Donor grid number (integer) !
5169! rg Receiver grid number (integer) !
5170! model Calling model identifier (integer) !
5171! tile Domain tile partition (integer) !
5172! gtype C-grid variable type (integer) !
5173! svname State variable name (string) !
5174! cr Contact region number to process (integer) !
5175! Npoints Number of points in the contact region (integer) !
5176! contact Contact region information variables (T_NGC structure)!
5177! LBi Donor grid, I-dimension Lower bound (integer) !
5178! UBi Donor grid, I-dimension Upper bound (integer) !
5179! LBj Donor grid, J-dimension Lower bound (integer) !
5180! UBj Donor grid, J-dimension Upper bound (integer) !
5181! Ad Donor grid data (2D array) !
5182! !
5183! On Input: !
5184! !
5185! Ac 2D flux variable contact point data !
5186! !
5187!=======================================================================
5188!
5189 USE mod_param
5190 USE mod_ncparam
5191 USE mod_nesting
5192 USE mod_scalars
5193!
5194# ifdef DISTRIBUTE
5195 USE distribute_mod, ONLY : mp_assemble
5196# endif
5197 USE strings_mod, ONLY : founderror
5198!
5199! Imported variable declarations.
5200!
5201 integer, intent(in) :: dg, rg, model, tile
5202 integer, intent(in) :: gtype, cr, Npoints
5203 integer, intent(in) :: LBi, UBi, LBj, UBj
5204!
5205 character(len=*), intent(in) :: svname
5206!
5207 TYPE (T_NGC), intent(in) :: contact(:)
5208!
5209# ifdef ASSUMED_SHAPE
5210 real(r8), intent(in) :: Ad(LBi:,LBj:)
5211 real(r8), intent(inout) :: Ac(:,:)
5212# else
5213 real(r8), intent(in) :: Ad(LBi:UBi,LBj:UBj)
5214 real(r8), intent(inout) :: Ac(Npoints,4)
5215# endif
5216!
5217! Local variable declarations.
5218!
5219 integer :: Idg, Ip1, Irg, Jdg, Jp1, Jrg
5220 integer :: Imin, Imax, Jmin, Jmax
5221 integer :: Istr, Iend, Jstr, Jend
5222 integer :: i, i_add, j, j_add, m, m_add
5223# ifdef DISTRIBUTE
5224 integer :: Npts
5225# endif
5226!
5227 real(r8), parameter :: Aspv = 0.0_r8
5228 real(r8):: Rscale
5229!
5230 character (len=*), parameter :: MyFile = &
5231 & __FILE__//", get_persisted2d"
5232!
5233!-----------------------------------------------------------------------
5234! Initialize.
5235!-----------------------------------------------------------------------
5236
5237# ifdef DISTRIBUTE
5238!
5239! Initialize contact points array to special value to facilite
5240! distribute-memory data collection from all nodes.
5241!
5242 npts=4*npoints
5243 DO m=1,npoints
5244 ac(1,m)=aspv
5245 ac(2,m)=aspv
5246 ac(3,m)=aspv
5247 ac(4,m)=aspv
5248 END DO
5249# endif
5250!
5251! Set starting and ending tile indices for the donor grids.
5252!
5253 SELECT CASE (gtype)
5254 CASE (r2dvar)
5255 imin=bounds(dg) % IstrT(-1) ! full RHO-grid range
5256 imax=bounds(dg) % IendT(-1)
5257 jmin=bounds(dg) % JstrT(-1)
5258 jmax=bounds(dg) % JendT(-1)
5259!
5260 istr=bounds(dg) % IstrT(tile) ! domain partition range
5261 iend=bounds(dg) % IendT(tile)
5262 jstr=bounds(dg) % JstrT(tile)
5263 jend=bounds(dg) % JendT(tile)
5264!
5265 m_add=nstrr(cr)-1
5266 CASE (u2dvar)
5267 imin=bounds(dg) % IstrP(-1) ! full U-grid range
5268 imax=bounds(dg) % IendT(-1)
5269 jmin=bounds(dg) % JstrT(-1)
5270 jmax=bounds(dg) % JendT(-1)
5271!
5272 istr=bounds(dg) % IstrP(tile) ! domain partition range
5273 iend=bounds(dg) % IendT(tile)
5274 jstr=bounds(dg) % JstrT(tile)
5275 jend=bounds(dg) % JendT(tile)
5276!
5277 m_add=nstru(cr)-1
5278 CASE (v2dvar)
5279 imin=bounds(dg) % IstrT(-1) ! full V-grid range
5280 imax=bounds(dg) % IendT(-1)
5281 jmin=bounds(dg) % JstrP(-1)
5282 jmax=bounds(dg) % JendT(-1)
5283!
5284 istr=bounds(dg) % IstrT(tile) ! domain partition range
5285 iend=bounds(dg) % IendT(tile)
5286 jstr=bounds(dg) % JstrP(tile)
5287 jend=bounds(dg) % JendT(tile)
5288!
5289 m_add=nstrv(cr)-1
5290 END SELECT
5291!
5292!-----------------------------------------------------------------------
5293! Extract donor grid data at contact points.
5294!-----------------------------------------------------------------------
5295!
5296! Notice that the indices i+1 and j+1 are bounded the maximum values
5297! of the grid. This implies that contact point lies on the grid
5298! boundary.
5299!
5300 rscale=1.0_r8/real(refinescale(rg))
5301 DO m=1,npoints
5302 idg=contact(cr)%Idg(m)
5303 jdg=contact(cr)%Jdg(m)
5304 irg=contact(cr)%Irg(m)
5305 jrg=contact(cr)%Jrg(m)
5306 ip1=min(idg+1,imax)
5307 jp1=min(jdg+1,jmax)
5308 IF (((istr.le.idg).and.(idg.le.iend)).and. &
5309 & ((jstr.le.jdg).and.(jdg.le.jend))) THEN
5310 IF (on_boundary(m+m_add).gt.0) THEN
5311 IF ((on_boundary(m+m_add).eq.1).or. &
5312 & (on_boundary(m+m_add).eq.3)) THEN ! western and
5313 j_add=int(real(jrg-1,r8)*rscale) ! eastern edges
5314 j=j_bottom(rg)+j_add
5315 ac(1,m)=ad(idg,j)
5316 ac(2,m)=ad(idg,j)
5317 ac(3,m)=ad(idg,j)
5318 ac(4,m)=ad(idg,j)
5319 ELSE IF ((on_boundary(m+m_add).eq.2).or. &
5320 & (on_boundary(m+m_add).eq.4)) THEN ! southern and
5321 i_add=int(real(irg-1,r8)*rscale) ! northern edges
5322 i=i_left(rg)+i_add
5323 ac(1,m)=ad(i,jdg)
5324 ac(2,m)=ad(i,jdg)
5325 ac(3,m)=ad(i,jdg)
5326 ac(4,m)=ad(i,jdg)
5327 END IF
5328 ELSE
5329 ac(1,m)=ad(idg,jdg) ! contact point is not at
5330 ac(2,m)=ad(ip1,jdg) ! physical boundary, just
5331 ac(3,m)=ad(ip1,jp1) ! set values for spatial
5332 ac(4,m)=ad(idg,jp1) ! interpolation (not used)
5333 END IF
5334 END IF
5335 END DO
5336
5337# ifdef DISTRIBUTE
5338!
5339! Gather and broadcast data from all nodes.
5340!
5341 CALL mp_assemble (dg, model, npts, aspv, ac)
5342 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5343# endif
5344!
5345 RETURN
mod_nesting::nstrv
integer, dimension(:), allocatable nstrv
Definition mod_nesting.F:207
mod_nesting::on_boundary
integer, dimension(:), allocatable on_boundary
Definition mod_nesting.F:210
mod_nesting::nstru
integer, dimension(:), allocatable nstru
Definition mod_nesting.F:206
mod_nesting::nstrr
integer, dimension(:), allocatable nstrr
Definition mod_nesting.F:205

References mod_param::bounds, mod_scalars::exit_flag, strings_mod::founderror(), mod_nesting::i_left, mod_nesting::j_bottom, mod_scalars::noerror, mod_nesting::nstrr, mod_nesting::nstru, mod_nesting::nstrv, mod_nesting::on_boundary, mod_param::r2dvar, mod_scalars::refinescale, mod_param::u2dvar, and mod_param::v2dvar.

Referenced by ad_nesting_mod::ad_get_refine(), get_refine(), and tl_nesting_mod::tl_get_refine().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ get_refine()

subroutine, private nesting_mod::get_refine ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) tile )
private

Definition at line 2356 of file nesting.F.

2357!
2358!=======================================================================
2359! !
2360! This routine gets the donor grid data required to process the !
2361! contact points of the current refinement grid. It extracts !
2362! the donor cell points containing each contact point. !
2363! !
2364! The extracted data is stored in two-time rolling records which !
2365! are needed for the space and time interpolation in 'put_refine'. !
2366! !
2367! Except for initialization, this routine is called at the bottom !
2368! of the donor grid time step so all the values are updated for the !
2369! time(dg)+dt(dg). That is, in 2D applications it is called after !
2370! "step2d" corrector step and in 3D applications it is called after !
2371! "step3d_t". This is done to have the coarser grid snapshots at !
2372! time(dg) and time(dg)+dt(dg) to bound the interpolation of the !
2373! finer grid contact points. !
2374! !
2375! On Input: !
2376! !
2377! ng Refinement grid number (integer) !
2378! model Calling model identifier (integer) !
2379! tile Domain tile partition (integer) !
2380! !
2381! On Output: (mod_nesting) !
2382! !
2383! REFINED Updated contact points structure. !
2384! !
2385!=======================================================================
2386!
2387 USE mod_param
2388 USE mod_parallel
2389 USE mod_coupling
2390 USE mod_ncparam
2391 USE mod_nesting
2392 USE mod_ocean
2393 USE mod_scalars
2394 USE mod_stepping
2395!
2396! Imported variable declarations.
2397!
2398 integer, intent(in) :: ng, model, tile
2399!
2400! Local variable declarations.
2401!
2402# ifdef NESTING_DEBUG
2403 logical, save :: first = .true.
2404# endif
2405 integer :: Tindex2d, cr, dg, ir, rg, tnew
2406# ifdef SOLVE3D
2407 integer :: Tindex3d, itrc
2408# endif
2409 integer :: LBi, UBi, LBj, UBj
2410!
2411!-----------------------------------------------------------------------
2412! Get donor grid data needed to process refinement grid contact points.
2413! The extracted contact point data is stored in two time records to
2414! facilitate the space-time interpolation elsewhere.
2415!-----------------------------------------------------------------------
2416!
2417 DO cr=1,ncontact
2418!
2419! Get data donor and data receiver grid numbers.
2420!
2421 dg=rcontact(cr)%donor_grid
2422 rg=rcontact(cr)%receiver_grid
2423!
2424! Process only contact region data for requested nested grid "ng".
2425!
2426 IF ((dg.eq.coarserdonor(rg)).and.(dg.eq.ng)) THEN
2427!
2428! Set donor grid lower and upper array indices.
2429!
2430 lbi=bounds(dg)%LBi(tile)
2431 ubi=bounds(dg)%UBi(tile)
2432 lbj=bounds(dg)%LBj(tile)
2433 ubj=bounds(dg)%UBj(tile)
2434!
2435! Update rolling time indices. The contact data is stored in two time
2436! levels. We need a special case for ROMS initialization in "main2d"
2437! or "main3d" after the processing "ini_fields". Notice that a dt(dg)
2438! is added because this routine is called after the end of the time
2439! step.
2440!
2441 IF (rollingindex(cr).eq.0) THEN
2442 tnew=1 ! ROMS
2443 rollingindex(cr)=tnew ! initialization
2444 rollingtime(tnew,cr)=time(dg) ! step
2445 ELSE
2446 tnew=3-rollingindex(cr)
2447 rollingindex(cr)=tnew
2448 rollingtime(tnew,cr)=time(dg)+dt(dg)
2449 END IF
2450!
2451! Set donor grid time index to process. In 3D applications, the 2D
2452! record index to use can be either 1 or 2 since both ubar(:,:,1:2)
2453! and vbar(:,:,1:2) are set to its time-averaged values in "step3d_uv".
2454! That is, we can use Tindex2d=kstp(dg) or Tindex2d=knew(dg). However,
2455! in 2D applications we need to use Tindex2d=knew(dg).
2456!
2457 tindex2d=knew(dg)
2458# ifdef SOLVE3D
2459 tindex3d=nnew(dg)
2460# endif
2461
2462# ifdef NESTING_DEBUG
2463!
2464! If debugging, write information into Fortran unit 100 to check the
2465! logic of processing donor grid data.
2466!
2467 IF (domain(ng)%SouthWest_Test(tile)) THEN
2468 IF (master) THEN
2469 IF (first) THEN
2470 first=.false.
2471 WRITE (100,10)
2472 END IF
2473 WRITE (100,20) ng, cr, dg, rg, iic(dg), iic(rg), &
2474# ifdef SOLVE3D
2475 & 3-tnew, tnew, tindex2d, tindex3d, &
2476# else
2477 & 3-tnew, tnew, tindex2d, tindex2d, &
2478# endif
2479 & int(rollingtime(3-tnew,cr)), &
2480 & int(rollingtime(tnew,cr)), &
2481 & int(time(ng))
2482 10 FORMAT (2x,'ng',2x,'cr',2x,'dg',2x,'rg',5x,'iic',4x,'iic',&
2483 & 3x,'told',3x,'tnew',2x,'Tindex',1x,'Tindex', &
2484 & 2x,'time',3x,'time',3x,'time',/,20x,'(dg)', &
2485 & 3x,'(rg)',18x,'2D',5x,'3D',4x,'told',3x,'tnew', &
2486 & 3x,'(ng)',/)
2487 20 FORMAT (4i4,9i7)
2488 FLUSH (100)
2489 END IF
2490 END IF
2491# endif
2492!
2493! Extract free-surface.
2494!
2495# ifdef SOLVE3D
2496 CALL get_contact2d (dg, model, tile, &
2497 & r2dvar, 'Zt_avg1', &
2498 & cr, rcontact(cr)%Npoints, rcontact, &
2499 & lbi, ubi, lbj, ubj, &
2500 & coupling(dg) % Zt_avg1, &
2501 & refined(cr) % zeta(:,:,tnew))
2502# else
2503 CALL get_contact2d (dg, model, tile, &
2504 & r2dvar, 'zeta', &
2505 & cr, rcontact(cr)%Npoints, rcontact, &
2506 & lbi, ubi, lbj, ubj, &
2507 & ocean(dg) % zeta(:,:,tindex2d), &
2508 & refined(cr) % zeta(:,:,tnew))
2509# endif
2510!
2511! Extract 2D momentum components (ubar, vbar).
2512!
2513 CALL get_contact2d (dg, model, tile, &
2514 & u2dvar, vname(1,idubar), &
2515 & cr, ucontact(cr)%Npoints, ucontact, &
2516 & lbi, ubi, lbj, ubj, &
2517 & ocean(dg) % ubar(:,:,tindex2d), &
2518 & refined(cr) % ubar(:,:,tnew))
2519
2520 CALL get_contact2d (dg, model, tile, &
2521 & v2dvar, vname(1,idvbar), &
2522 & cr, vcontact(cr)%Npoints, vcontact, &
2523 & lbi, ubi, lbj, ubj, &
2524 & ocean(dg) % vbar(:,:,tindex2d), &
2525 & refined(cr) % vbar(:,:,tnew))
2526!
2527# ifdef SOLVE3D
2528! Interpolate time-averaged fluxes (U2d_flux, V2d_flux) at contact
2529# else
2530! Interpolate 2D momentum fluxes (U2d_flux, V2d_flux) at contact
2531# endif
2532! points. They will be used later to impose mass flux conservation
2533! at the finer grid boundary (see routine "put_refine2d").
2534!
2535 CALL get_persisted2d (dg, rg, model, tile, &
2536 & u2dvar, 'U2d_flux', &
2537 & cr, ucontact(cr)%Npoints, ucontact, &
2538 & lbi, ubi, lbj, ubj, &
2539# ifdef SOLVE3D
2540 & coupling(dg) % DU_avg2, &
2541# else
2542 & ocean(dg) % DU_flux, &
2543# endif
2544 & refined(cr) % U2d_flux(:,:,tnew))
2545
2546 CALL get_persisted2d (dg, rg, model, tile, &
2547 & v2dvar, 'V2d_flux', &
2548 & cr, vcontact(cr)%Npoints, vcontact, &
2549 & lbi, ubi, lbj, ubj, &
2550# ifdef SOLVE3D
2551 & coupling(dg) % DV_avg2, &
2552# else
2553 & ocean(dg) % DV_flux, &
2554# endif
2555 & refined(cr) % V2d_flux(:,:,tnew))
2556
2557# ifdef SOLVE3D
2558!
2559! Tracer-type variables.
2560!
2561 DO itrc=1,nt(dg)
2562 CALL get_contact3d (dg, model, tile, &
2563 & r3dvar, vname(1,idtvar(itrc)), &
2564 & cr, rcontact(cr)%Npoints, rcontact, &
2565 & lbi, ubi, lbj, ubj, 1, n(dg), &
2566 & ocean(dg) % t(:,:,:,tindex3d,itrc), &
2567 & refined(cr) % t(:,:,:,tnew,itrc))
2568 END DO
2569!
2570! Extract 3D momentum components (u, v).
2571!
2572 CALL get_contact3d (dg, model, tile, &
2573 & u3dvar, vname(1,iduvel), &
2574 & cr, ucontact(cr)%Npoints, ucontact, &
2575 & lbi, ubi, lbj, ubj, 1, n(dg), &
2576 & ocean(dg) % u(:,:,:,tindex3d), &
2577 & refined(cr) % u(:,:,:,tnew))
2578
2579 CALL get_contact3d (dg, model, tile, &
2580 & v3dvar, vname(1,idvvel), &
2581 & cr, vcontact(cr)%Npoints, vcontact, &
2582 & lbi, ubi, lbj, ubj, 1, n(dg), &
2583 & ocean(dg) % v(:,:,:,tindex3d), &
2584 & refined(cr) % v(:,:,:,tnew))
2585# endif
2586 END IF
2587 END DO
2588!
2589 RETURN
mod_nesting::coarserdonor
integer, dimension(:), allocatable coarserdonor
Definition mod_nesting.F:138
mod_nesting::rollingtime
real(dp), dimension(:,:), allocatable rollingtime
Definition mod_nesting.F:179

References mod_param::bounds, mod_nesting::coarserdonor, mod_coupling::coupling, mod_param::domain, mod_scalars::dt, get_contact2d(), get_contact3d(), get_persisted2d(), mod_ncparam::idtvar, mod_ncparam::idubar, mod_ncparam::iduvel, mod_ncparam::idvbar, mod_ncparam::idvvel, mod_scalars::iic, mod_stepping::knew, mod_parallel::master, mod_param::n, mod_nesting::ncontact, mod_stepping::nnew, mod_param::nt, mod_ocean::ocean, mod_param::r2dvar, mod_param::r3dvar, mod_nesting::rcontact, mod_nesting::refined, mod_nesting::rollingindex, mod_nesting::rollingtime, mod_scalars::time, mod_param::u2dvar, mod_param::u3dvar, mod_nesting::ucontact, mod_param::v2dvar, mod_param::v3dvar, mod_nesting::vcontact, and mod_ncparam::vname.

Referenced by nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ mask_hweights()

subroutine, public nesting_mod::mask_hweights ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) tile )

Definition at line 1199 of file nesting.F.

1200!
1201!=======================================================================
1202! !
1203! This routine scales the horizontal interpolation weights to account !
1204! for Land/Sea masking in the nested contact region. If wetting and !
1205! drying, the scaling is done at every time step since the Land/Sea !
1206! masking is time dependent. !
1207! !
1208! On Input: !
1209! !
1210! rg Receiver grid number (integer) !
1211! model Calling model identifier (integer) !
1212! tile Domain tile partition (integer) !
1213! !
1214! On Output: !
1215! !
1216! Lweight Updated linear interpolation weights !
1217# ifdef QUADRATIC_WEIGHTS
1218! Qweight Updated quadratic interpolation weights !
1219# endif
1220! !
1221!=======================================================================
1222!
1223 USE mod_param
1224 USE mod_grid
1225 USE mod_nesting
1226 USE mod_scalars
1227!
1228# ifdef DISTRIBUTE
1229 USE distribute_mod, ONLY : mp_assemble
1230# endif
1231 USE strings_mod, ONLY : founderror
1232!
1233! Imported variable declarations.
1234!
1235 integer, intent(in) :: ng, model, tile
1236!
1237! Local variable declarations.
1238!
1239 integer :: cr, dg, m, rg
1240 integer :: Istr, Iend, Jstr, Jend
1241 integer :: Idg, Idgp1, Jdg, Jdgp1
1242 integer :: NpointsR, NpointsU, NpointsV
1243# ifdef DISTRIBUTE
1244 integer :: Lpoints, Qpoints
1245# endif
1246!
1247 real(r8) :: cff
1248 real(r8) :: LWsum, LWsum_check, MaskLWsum
1249# ifdef QUADRATIC_WEIGHTS
1250 real(r8) :: QWsum, QWsum_check, MaskQWsum
1251# endif
1252# ifdef DISTRIBUTE
1253 real(r8), parameter :: spv = 0.0_r8
1254# endif
1255 real(r8), dimension(4) :: Lweight
1256# ifdef QUADRATIC_WEIGHTS
1257 real(r8), dimension(9) :: Qweight
1258# endif
1259# ifdef DISTRIBUTE
1260 real(r8), allocatable :: LW(:,:)
1261# ifdef QUADRATIC_WEIGHTS
1262 real(r8), allocatable :: QW(:,:)
1263# endif
1264# endif
1265!
1266 character (len=*), parameter :: MyFile = &
1267 & __FILE__//", mask_hweights"
1268!
1269!=======================================================================
1270! If appropriate, scale horizontal interpolation weights to account
1271! for Land/Sea masking.
1272!=======================================================================
1273!
1274 DO cr=1,ncontact
1275!
1276! Get data donor and data receiver grid numbers.
1277!
1278 dg=rcontact(cr)%donor_grid
1279 rg=rcontact(cr)%receiver_grid
1280!
1281 scale_weights : IF (refinedgrid(rg).and. &
1282 & (dg.eq.ng).and.(dg.lt.rg)) THEN
1283!
1284! Scale interpolation weigths for RHO-contact points.
1285!
1286 istr=bounds(dg) % Istr(tile)
1287 iend=bounds(dg) % Iend(tile)
1288 jstr=bounds(dg) % Jstr(tile)
1289 jend=bounds(dg) % Jend(tile)
1290!
1291!-----------------------------------------------------------------------
1292! Scale horizontal interpolation weigths for RHO-contact points.
1293!-----------------------------------------------------------------------
1294!
1295 npointsr=rcontact(cr)%Npoints
1296
1297# ifdef DISTRIBUTE
1298!
1299! If distributed-memory, allocate and initialize working arrays
1300! with special value (zero) to facilitate the global reduction
1301! when collecting data between all nodes.
1302!
1303 lpoints=4*npointsr
1304 IF (.not.allocated(lw)) THEN
1305 allocate ( lw(4,npointsr) )
1306 END IF
1307 lw=spv
1308
1309# ifdef QUADRATIC_WEIGHTS
1310 qpoints=9*npointsr
1311 IF (.not.allocated(qw)) THEN
1312 allocate ( qw(9,npointsr) )
1313 END IF
1314 qw=spv
1315# endif
1316# endif
1317!
1318! Scale interpolation weights.
1319!
1320 DO m=1,npointsr
1321 idg =rcontact(cr)%Idg(m)
1322 idgp1=min(idg+1, bounds(dg)%UBi(-1))
1323 jdg =rcontact(cr)%Jdg(m)
1324 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
1325 IF (((istr.le.idg).and.(idg.le.iend)).and. &
1326 & ((jstr.le.jdg).and.(jdg.le.jend))) THEN
1327!
1328! Linear interpolation weights.
1329!
1330 masklwsum=grid(dg)%rmask(idg ,jdg )+ &
1331 & grid(dg)%rmask(idgp1,jdg )+ &
1332 & grid(dg)%rmask(idgp1,jdgp1)+ &
1333 & grid(dg)%rmask(idg ,jdgp1)
1334 IF (masklwsum.lt.4) THEN
1335# ifdef WET_DRY
1336 lweight(1)=rcontact(cr)%LweightUnmasked(1,m)* &
1337 & grid(dg)%rmask_full(idg ,jdg )
1338 lweight(2)=rcontact(cr)%LweightUnmasked(2,m)* &
1339 & grid(dg)%rmask_full(idgp1,jdg )
1340 lweight(3)=rcontact(cr)%LweightUnmasked(3,m)* &
1341 & grid(dg)%rmask_full(idgp1,jdgp1)
1342 lweight(4)=rcontact(cr)%LweightUnmasked(4,m)* &
1343 & grid(dg)%rmask_full(idg ,jdgp1)
1344# else
1345 lweight(1)=rcontact(cr)%Lweight(1,m)* &
1346 & grid(dg)%rmask_full(idg ,jdg )
1347 lweight(2)=rcontact(cr)%Lweight(2,m)* &
1348 & grid(dg)%rmask_full(idgp1,jdg )
1349 lweight(3)=rcontact(cr)%Lweight(3,m)* &
1350 & grid(dg)%rmask_full(idgp1,jdgp1)
1351 lweight(4)=rcontact(cr)%Lweight(4,m)* &
1352 & grid(dg)%rmask_full(idg ,jdgp1)
1353# endif
1354 lwsum=sum(lweight)
1355 IF (lwsum.gt.0) THEN
1356 cff=1.0_r8/lwsum
1357 lweight(1)=cff*lweight(1) ! using only water points
1358 lweight(2)=cff*lweight(2) ! in the interpolation of
1359 lweight(3)=cff*lweight(3) ! of contact points
1360 lweight(4)=cff*lweight(4)
1361 ELSE
1362 lweight=0.0_r8 ! all the donor grid
1363 END IF ! corners are on land
1364 lwsum_check=sum(lweight)
1365# ifdef DISTRIBUTE
1366 lw(1,m)=lweight(1)
1367 lw(2,m)=lweight(2)
1368 lw(3,m)=lweight(3)
1369 lw(4,m)=lweight(4)
1370 ELSE
1371 lw(1,m)=rcontact(cr)%Lweight(1,m) ! we need to load
1372 lw(2,m)=rcontact(cr)%Lweight(2,m) ! unscaled values
1373 lw(3,m)=rcontact(cr)%Lweight(3,m) ! to facilitate
1374 lw(4,m)=rcontact(cr)%Lweight(4,m) ! parallel reduction
1375# else
1376 rcontact(cr)%Lweight(1,m)=lweight(1)
1377 rcontact(cr)%Lweight(2,m)=lweight(2)
1378 rcontact(cr)%Lweight(3,m)=lweight(3)
1379 rcontact(cr)%Lweight(4,m)=lweight(4)
1380# endif
1381 END IF
1382
1383# ifdef QUADRATIC_WEIGHTS
1384!
1385! Quadratic interpolation weights.
1386!
1387 maskqwsum=grid(dg)%rmask(idg-1, jdg-1)+ &
1388 & grid(dg)%rmask(idg , jdg-1)+ &
1389 & grid(dg)%rmask(idgp1, jdg-1)+ &
1390 & grid(dg)%rmask(idg-1, jdg )+ &
1391 & grid(dg)%rmask(idg , jdg )+ &
1392 & grid(dg)%rmask(idgp1, jdg )+ &
1393 & grid(dg)%rmask(idg-1, jdgp1)+ &
1394 & grid(dg)%rmask(idg , jdgp1)+ &
1395 & grid(dg)%rmask(idgp1, jdgp1)
1396 IF (maskqwsum.lt.9) THEN
1397# ifdef WET_DRY
1398 qweight(1)=rcontact(cr)%QweightUnmasked(1,m)* &
1399 & grid(dg)%rmask_full(idg-1,jdg-1)
1400 qweight(2)=rcontact(cr)%QweightUnmasked(2,m)* &
1401 & grid(dg)%rmask_full(idg ,jdg-1)
1402 qweight(3)=rcontact(cr)%QweightUnmasked(3,m)* &
1403 & grid(dg)%rmask_full(idgp1,jdg-1)
1404 qweight(4)=rcontact(cr)%QweightUnmasked(4,m)* &
1405 & grid(dg)%rmask_full(idg-1,jdg )
1406 qweight(5)=rcontact(cr)%QweightUnmasked(5,m)* &
1407 & grid(dg)%rmask_full(idg ,jdg )
1408 qweight(6)=rcontact(cr)%QweightUnmasked(6,m)* &
1409 & grid(dg)%rmask_full(idgp1,jdg )
1410 qweight(7)=rcontact(cr)%QweightUnmasked(7,m)* &
1411 & grid(dg)%rmask_full(idg-1,jdgp1)
1412 qweight(8)=rcontact(cr)%QweightUnmasked(8,m)* &
1413 & grid(dg)%rmask_full(idg ,jdgp1)
1414 qweight(9)=rcontact(cr)%QweightUnmasked(9,m)* &
1415 & grid(dg)%rmask_full(idgp1,jdgp1)
1416# else
1417 qweight(1)=rcontact(cr)%Qweight(1,m)* &
1418 & grid(dg)%rmask_full(idg-1,jdg-1)
1419 qweight(2)=rcontact(cr)%Qweight(2,m)* &
1420 & grid(dg)%rmask_full(idg ,jdg-1)
1421 qweight(3)=rcontact(cr)%Qweight(3,m)* &
1422 & grid(dg)%rmask_full(idgp1,jdg-1)
1423 qweight(4)=rcontact(cr)%Qweight(4,m)* &
1424 & grid(dg)%rmask_full(idg-1,jdg )
1425 qweight(5)=rcontact(cr)%Qweight(5,m)* &
1426 & grid(dg)%rmask_full(idg ,jdg )
1427 qweight(6)=rcontact(cr)%Qweight(6,m)* &
1428 & grid(dg)%rmask_full(idgp1,jdg )
1429 qweight(7)=rcontact(cr)%Qweight(7,m)* &
1430 & grid(dg)%rmask_full(idg-1,jdgp1)
1431 qweight(8)=rcontact(cr)%Qweight(8,m)* &
1432 & grid(dg)%rmask_full(idg ,jdgp1)
1433 qweight(9)=rcontact(cr)%Qweight(9,m)* &
1434 & grid(dg)%rmask_full(idgp1,jdgp1)
1435# endif
1436 qwsum=sum(qweight)
1437 IF (qwsum.gt.0) THEN
1438 cff=1.0_r8/qwsum
1439 qweight(1)=cff*qweight(1) ! using only water points
1440 qweight(2)=cff*qweight(2) ! in the interpolation of
1441 qweight(3)=cff*qweight(3) ! of contact points
1442 qweight(4)=cff*qweight(4)
1443 qweight(5)=cff*qweight(5)
1444 qweight(6)=cff*qweight(6)
1445 qweight(7)=cff*qweight(7)
1446 qweight(8)=cff*qweight(8)
1447 qweight(9)=cff*qweight(9)
1448 ELSE
1449 qweight=0.0_r8 ! all the donor grid
1450 END IF ! corners are on land
1451 qwsum_check=sum(qweight)
1452# ifdef DISTRIBUTE
1453 qw(1,m)=qweight(1)
1454 qw(2,m)=qweight(2)
1455 qw(3,m)=qweight(3)
1456 qw(4,m)=qweight(4)
1457 qw(5,m)=qweight(5)
1458 qw(6,m)=qweight(6)
1459 qw(7,m)=qweight(7)
1460 qw(8,m)=qweight(8)
1461 qw(9,m)=qweight(9)
1462 ELSE
1463 qw(1,m)=rcontact(cr)%Qweight(1,m) ! we need to load
1464 qw(2,m)=rcontact(cr)%Qweight(2,m) ! unscaled values
1465 qw(3,m)=rcontact(cr)%Qweight(3,m) ! to facilitate
1466 qw(4,m)=rcontact(cr)%Qweight(4,m) ! parallel reduction
1467 qw(5,m)=rcontact(cr)%Qweight(5,m)
1468 qw(6,m)=rcontact(cr)%Qweight(6,m)
1469 qw(7,m)=rcontact(cr)%Qweight(7,m)
1470 qw(8,m)=rcontact(cr)%Qweight(8,m)
1471 qw(9,m)=rcontact(cr)%Qweight(9,m)
1472# else
1473 rcontact(cr)%Qweight(1,m)=qweight(1)
1474 rcontact(cr)%Qweight(2,m)=qweight(2)
1475 rcontact(cr)%Qweight(3,m)=qweight(3)
1476 rcontact(cr)%Qweight(4,m)=qweight(4)
1477 rcontact(cr)%Qweight(5,m)=qweight(5)
1478 rcontact(cr)%Qweight(6,m)=qweight(6)
1479 rcontact(cr)%Qweight(7,m)=qweight(7)
1480 rcontact(cr)%Qweight(8,m)=qweight(8)
1481 rcontact(cr)%Qweight(9,m)=qweight(9)
1482# endif
1483 END IF
1484# endif
1485 END IF
1486 END DO
1487
1488# ifdef DISTRIBUTE
1489!
1490! Exchange data between all parallel nodes.
1491!
1492 CALL mp_assemble (dg, model, lpoints, spv, lw)
1493 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1494
1495# ifdef QUADRATIC_WEIGHTS
1496 CALL mp_assemble (dg, model, qpoints, spv, qw)
1497 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1498# endif
1499!
1500! Load exchanged weights.
1501!
1502 rcontact(cr)%Lweight(1:4,1:npointsr)=lw(1:4,1:npointsr)
1503# ifdef QUADRATIC_WEIGHTS
1504 rcontact(cr)%Qweight(1:9,1:npointsr)=qw(1:9,1:npointsr)
1505# endif
1506!
1507! Deallocate local work arrays.
1508!
1509 IF (allocated(lw)) THEN
1510 deallocate (lw)
1511 END IF
1512
1513# ifdef QUADRATIC_WEIGHTS
1514 IF (allocated(qw)) THEN
1515 deallocate (qw)
1516 END IF
1517# endif
1518# endif
1519!
1520!-----------------------------------------------------------------------
1521! Scale interpolation weigths for U-contact points.
1522!-----------------------------------------------------------------------
1523!
1524 npointsu=ucontact(cr)%Npoints
1525
1526# ifdef DISTRIBUTE
1527!
1528! If distributed-memory, allocate and initialize working arrays
1529! with special value (zero) to facilitate the global reduction
1530! when collecting data between all nodes.
1531!
1532 lpoints=4*npointsu
1533 IF (.not.allocated(lw)) THEN
1534 allocate ( lw(4,npointsu) )
1535 END IF
1536 lw=spv
1537
1538# ifdef QUADRATIC_WEIGHTS
1539 qpoints=9*npointsu
1540 IF (.not.allocated(qw)) THEN
1541 allocate ( qw(9,npointsu) )
1542 END IF
1543 qw=spv
1544# endif
1545# endif
1546!
1547! Scale interpolation weights.
1548!
1549 DO m=1,npointsu
1550 idg =ucontact(cr)%Idg(m)
1551 idgp1=min(idg+1, bounds(dg)%UBi(-1))
1552 jdg =ucontact(cr)%Jdg(m)
1553 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
1554 IF (((istr.le.idg).and.(idg.le.iend)).and. &
1555 & ((jstr.le.jdg).and.(jdg.le.jend))) THEN
1556!
1557! Linear interpolation weights.
1558!
1559 masklwsum=grid(dg)%umask_full(idg ,jdg )+ &
1560 & grid(dg)%umask_full(idgp1,jdg )+ &
1561 & grid(dg)%umask_full(idgp1,jdgp1)+ &
1562 & grid(dg)%umask_full(idg ,jdgp1)
1563 IF (masklwsum.lt.4) THEN
1564# ifdef WET_DRY
1565 lweight(1)=ucontact(cr)%LweightUnmasked(1,m)* &
1566 & grid(dg)%umask_full(idg ,jdg )
1567 lweight(2)=ucontact(cr)%LweightUnmasked(2,m)* &
1568 & grid(dg)%umask_full(idgp1,jdg )
1569 lweight(3)=ucontact(cr)%LweightUnmasked(3,m)* &
1570 & grid(dg)%umask_full(idgp1,jdgp1)
1571 lweight(4)=ucontact(cr)%LweightUnmasked(4,m)* &
1572 & grid(dg)%umask_full(idg ,jdgp1)
1573# else
1574 lweight(1)=ucontact(cr)%Lweight(1,m)* &
1575 & grid(dg)%umask_full(idg ,jdg )
1576 lweight(2)=ucontact(cr)%Lweight(2,m)* &
1577 & grid(dg)%umask_full(idgp1,jdg )
1578 lweight(3)=ucontact(cr)%Lweight(3,m)* &
1579 & grid(dg)%umask_full(idgp1,jdgp1)
1580 lweight(4)=ucontact(cr)%Lweight(4,m)* &
1581 & grid(dg)%umask_full(idg ,jdgp1)
1582# endif
1583 lwsum=sum(lweight)
1584 IF (lwsum.gt.0) THEN
1585 cff=1.0_r8/lwsum
1586 lweight(1)=cff*lweight(1) ! using only water points
1587 lweight(2)=cff*lweight(2) ! in the interpolation of
1588 lweight(3)=cff*lweight(3) ! of contact points
1589 lweight(4)=cff*lweight(4)
1590 ELSE
1591 lweight=0.0_r8 ! All the donor grid
1592 END IF ! corners are on land
1593 lwsum_check=sum(lweight)
1594# ifdef DISTRIBUTE
1595 lw(1,m)=lweight(1)
1596 lw(2,m)=lweight(2)
1597 lw(3,m)=lweight(3)
1598 lw(4,m)=lweight(4)
1599 ELSE
1600 lw(1,m)=ucontact(cr)%Lweight(1,m) ! we need to load
1601 lw(2,m)=ucontact(cr)%Lweight(2,m) ! unscaled values
1602 lw(3,m)=ucontact(cr)%Lweight(3,m) ! to facilitate
1603 lw(4,m)=ucontact(cr)%Lweight(4,m) ! parallel reduction
1604# else
1605 ucontact(cr)%Lweight(1,m)=lweight(1)
1606 ucontact(cr)%Lweight(2,m)=lweight(2)
1607 ucontact(cr)%Lweight(3,m)=lweight(3)
1608 ucontact(cr)%Lweight(4,m)=lweight(4)
1609# endif
1610 END IF
1611
1612# ifdef QUADRATIC_WEIGHTS
1613!
1614! Quadratic interpolation weights.
1615!
1616 maskqwsum=grid(dg)%umask_full(idg-1, jdg-1)+ &
1617 & grid(dg)%umask_full(idg , jdg-1)+ &
1618 & grid(dg)%umask_full(idgp1, jdg-1)+ &
1619 & grid(dg)%umask_full(idg-1, jdg )+ &
1620 & grid(dg)%umask_full(idg , jdg )+ &
1621 & grid(dg)%umask_full(idgp1, jdg )+ &
1622 & grid(dg)%umask_full(idg-1, jdgp1)+ &
1623 & grid(dg)%umask_full(idg , jdgp1)+ &
1624 & grid(dg)%umask_full(idgp1, jdgp1)
1625 IF (maskqwsum.lt.9) THEN
1626# ifdef WET_DRY
1627 qweight(1)=ucontact(cr)%QweightUnmasked(1,m)* &
1628 & grid(dg)%umask_full(idg-1,jdg-1)
1629 qweight(2)=ucontact(cr)%QweightUnmasked(2,m)* &
1630 & grid(dg)%umask_full(idg ,jdg-1)
1631 qweight(3)=ucontact(cr)%QweightUnmasked(3,m)* &
1632 & grid(dg)%umask_full(idgp1,jdg-1)
1633 qweight(4)=ucontact(cr)%QweightUnmasked(4,m)* &
1634 & grid(dg)%umask_full(idg-1,jdg )
1635 qweight(5)=ucontact(cr)%QweightUnmasked(5,m)* &
1636 & grid(dg)%umask_full(idg ,jdg )
1637 qweight(6)=ucontact(cr)%QweightUnmasked(6,m)* &
1638 & grid(dg)%umask_full(idgp1,jdg )
1639 qweight(7)=ucontact(cr)%QweightUnmasked(7,m)* &
1640 & grid(dg)%umask_full(idg-1,jdgp1)
1641 qweight(8)=ucontact(cr)%QweightUnmasked(8,m)* &
1642 & grid(dg)%umask_full(idg ,jdgp1)
1643 qweight(9)=ucontact(cr)%QweightUnmasked(9,m)* &
1644 & grid(dg)%umask_full(idgp1,jdgp1)
1645# else
1646 qweight(1)=ucontact(cr)%Qweight(1,m)* &
1647 & grid(dg)%umask_full(idg-1,jdg-1)
1648 qweight(2)=ucontact(cr)%Qweight(2,m)* &
1649 & grid(dg)%umask_full(idg ,jdg-1)
1650 qweight(3)=ucontact(cr)%Qweight(3,m)* &
1651 & grid(dg)%umask_full(idgp1,jdg-1)
1652 qweight(4)=ucontact(cr)%Qweight(4,m)* &
1653 & grid(dg)%umask_full(idg-1,jdg )
1654 qweight(5)=ucontact(cr)%Qweight(5,m)* &
1655 & grid(dg)%umask_full(idg ,jdg )
1656 qweight(6)=ucontact(cr)%Qweight(6,m)* &
1657 & grid(dg)%umask_full(idgp1,jdg )
1658 qweight(7)=ucontact(cr)%Qweight(7,m)* &
1659 & grid(dg)%umask_full(idg-1,jdgp1)
1660 qweight(8)=ucontact(cr)%Qweight(8,m)* &
1661 & grid(dg)%umask_full(idg ,jdgp1)
1662 qweight(9)=ucontact(cr)%Qweight(9,m)* &
1663 & grid(dg)%umask_full(idgp1,jdgp1)
1664# endif
1665 qwsum=sum(qweight)
1666 IF (qwsum.gt.0) THEN
1667 cff=1.0_r8/qwsum
1668 qweight(1)=cff*qweight(1) ! using only water points
1669 qweight(2)=cff*qweight(2) ! in the interpolation of
1670 qweight(3)=cff*qweight(3) ! of contact points
1671 qweight(4)=cff*qweight(4)
1672 qweight(5)=cff*qweight(5)
1673 qweight(6)=cff*qweight(6)
1674 qweight(7)=cff*qweight(7)
1675 qweight(8)=cff*qweight(8)
1676 qweight(9)=cff*qweight(9)
1677 ELSE
1678 qweight=0.0_r8 ! All the donor grid
1679 END IF ! corners are on land
1680 qwsum_check=sum(qweight)
1681# ifdef DISTRIBUTE
1682 qw(1,m)=qweight(1)
1683 qw(2,m)=qweight(2)
1684 qw(3,m)=qweight(3)
1685 qw(4,m)=qweight(4)
1686 qw(5,m)=qweight(5)
1687 qw(6,m)=qweight(6)
1688 qw(7,m)=qweight(7)
1689 qw(8,m)=qweight(8)
1690 qw(9,m)=qweight(9)
1691 ELSE
1692 qw(1,m)=ucontact(cr)%Qweight(1,m) ! we need to load
1693 qw(2,m)=ucontact(cr)%Qweight(2,m) ! unscaled values
1694 qw(3,m)=ucontact(cr)%Qweight(3,m) ! to facilitate
1695 qw(4,m)=ucontact(cr)%Qweight(4,m) ! parallel reduction
1696 qw(5,m)=ucontact(cr)%Qweight(5,m)
1697 qw(6,m)=ucontact(cr)%Qweight(6,m)
1698 qw(7,m)=ucontact(cr)%Qweight(7,m)
1699 qw(8,m)=ucontact(cr)%Qweight(8,m)
1700 qw(9,m)=ucontact(cr)%Qweight(9,m)
1701# else
1702 ucontact(cr)%Qweight(1,m)=qweight(1)
1703 ucontact(cr)%Qweight(2,m)=qweight(2)
1704 ucontact(cr)%Qweight(3,m)=qweight(3)
1705 ucontact(cr)%Qweight(4,m)=qweight(4)
1706 ucontact(cr)%Qweight(5,m)=qweight(5)
1707 ucontact(cr)%Qweight(6,m)=qweight(6)
1708 ucontact(cr)%Qweight(7,m)=qweight(7)
1709 ucontact(cr)%Qweight(8,m)=qweight(8)
1710 ucontact(cr)%Qweight(9,m)=qweight(9)
1711# endif
1712 END IF
1713# endif
1714 END IF
1715 END DO
1716
1717# ifdef DISTRIBUTE
1718!
1719! Exchange data between all parallel nodes.
1720!
1721 CALL mp_assemble (dg, model, lpoints, spv, lw)
1722 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1723
1724# ifdef QUADRATIC_WEIGHTS
1725 CALL mp_assemble (dg, model, qpoints, spv, qw)
1726 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1727# endif
1728!
1729! Load exchanged weights.
1730!
1731 ucontact(cr)%Lweight(1:4,1:npointsu)=lw(1:4,1:npointsu)
1732# ifdef QUADRATIC_WEIGHTS
1733 ucontact(cr)%Qweight(1:9,1:npointsu)=qw(1:9,1:npointsu)
1734# endif
1735!
1736! Deallocate local work arrays.
1737!
1738 IF (allocated(lw)) THEN
1739 deallocate (lw)
1740 END IF
1741
1742# ifdef QUADRATIC_WEIGHTS
1743 IF (allocated(qw)) THEN
1744 deallocate (qw)
1745 END IF
1746# endif
1747# endif
1748!
1749!-----------------------------------------------------------------------
1750! Scale interpolation weigths for V-contact points.
1751!-----------------------------------------------------------------------
1752!
1753 npointsv=vcontact(cr)%Npoints
1754
1755# ifdef DISTRIBUTE
1756!
1757! If distributed-memory, allocate and initialize working arrays
1758! with special value (zero) to facilitate the global reduction
1759! when collecting data between all nodes.
1760!
1761 lpoints=4*npointsv
1762 IF (.not.allocated(lw)) THEN
1763 allocate ( lw(4,npointsv) )
1764 END IF
1765 lw=spv
1766
1767# ifdef QUADRATIC_WEIGHTS
1768 lpoints=9*npointsv
1769 IF (.not.allocated(qw)) THEN
1770 allocate ( qw(9,npointsv) )
1771 END IF
1772 qw=spv
1773# endif
1774# endif
1775!
1776! Scale interpolation weights.
1777!
1778 DO m=1,npointsv
1779 idg =vcontact(cr)%Idg(m)
1780 idgp1=min(idg+1, bounds(dg)%UBi(-1))
1781 jdg =vcontact(cr)%Jdg(m)
1782 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
1783 IF (((istr.le.idg).and.(idg.le.iend)).and. &
1784 & ((jstr.le.jdg).and.(jdg.le.jend))) THEN
1785!
1786! Linear interpolation weights.
1787!
1788 masklwsum=grid(dg)%vmask_full(idg ,jdg )+ &
1789 & grid(dg)%vmask_full(idgp1,jdg )+ &
1790 & grid(dg)%vmask_full(idgp1,jdgp1)+ &
1791 & grid(dg)%vmask_full(idg ,jdgp1)
1792 IF (masklwsum.lt.4) THEN
1793# ifdef WET_DRY
1794 lweight(1)=vcontact(cr)%LweightUnmasked(1,m)* &
1795 & grid(dg)%vmask_full(idg ,jdg )
1796 lweight(2)=vcontact(cr)%LweightUnmasked(2,m)* &
1797 & grid(dg)%vmask_full(idgp1,jdg )
1798 lweight(3)=vcontact(cr)%LweightUnmasked(3,m)* &
1799 & grid(dg)%vmask_full(idgp1,jdgp1)
1800 lweight(4)=vcontact(cr)%LweightUnmasked(4,m)* &
1801 & grid(dg)%vmask_full(idg ,jdgp1)
1802# else
1803 lweight(1)=vcontact(cr)%Lweight(1,m)* &
1804 & grid(dg)%vmask_full(idg ,jdg )
1805 lweight(2)=vcontact(cr)%Lweight(2,m)* &
1806 & grid(dg)%vmask_full(idgp1,jdg )
1807 lweight(3)=vcontact(cr)%Lweight(3,m)* &
1808 & grid(dg)%vmask_full(idgp1,jdgp1)
1809 lweight(4)=vcontact(cr)%Lweight(4,m)* &
1810 & grid(dg)%vmask_full(idg ,jdgp1)
1811# endif
1812 lwsum=sum(lweight)
1813 IF (lwsum.gt.0) THEN
1814 cff=1.0_r8/lwsum
1815 lweight(1)=cff*lweight(1) ! using only water points
1816 lweight(2)=cff*lweight(2) ! in the interpolation of
1817 lweight(3)=cff*lweight(3) ! of contact points
1818 lweight(4)=cff*lweight(4)
1819 ELSE
1820 lweight=0.0_r8 ! All the donor grid
1821 END IF ! corners are on land
1822 lwsum_check=sum(lweight)
1823# ifdef DISTRIBUTE
1824 lw(1,m)=lweight(1)
1825 lw(2,m)=lweight(2)
1826 lw(3,m)=lweight(3)
1827 lw(4,m)=lweight(4)
1828 ELSE
1829 lw(1,m)=vcontact(cr)%Lweight(1,m) ! we need to load
1830 lw(2,m)=vcontact(cr)%Lweight(2,m) ! unscaled values
1831 lw(3,m)=vcontact(cr)%Lweight(3,m) ! to facilitate
1832 lw(4,m)=vcontact(cr)%Lweight(4,m) ! parallel reduction
1833# else
1834 vcontact(cr)%Lweight(1,m)=lweight(1)
1835 vcontact(cr)%Lweight(2,m)=lweight(2)
1836 vcontact(cr)%Lweight(3,m)=lweight(3)
1837 vcontact(cr)%Lweight(4,m)=lweight(4)
1838# endif
1839 END IF
1840
1841# ifdef QUADRATIC_WEIGHTS
1842!
1843! Quadratic interpolation weights.
1844!
1845 maskqwsum=grid(dg)%vmask_full(idg-1, jdg-1)+ &
1846 & grid(dg)%vmask_full(idg , jdg-1)+ &
1847 & grid(dg)%vmask_full(idgp1, jdg-1)+ &
1848 & grid(dg)%vmask_full(idg-1, jdg )+ &
1849 & grid(dg)%vmask_full(idg , jdg )+ &
1850 & grid(dg)%vmask_full(idgp1, jdg )+ &
1851 & grid(dg)%vmask_full(idg-1, jdgp1)+ &
1852 & grid(dg)%vmask_full(idg , jdgp1)+ &
1853 & grid(dg)%vmask_full(idgp1, jdgp1)
1854 IF (maskqwsum.lt.9) THEN
1855# ifdef WET_DRY
1856 qweight(1)=vcontact(cr)%QweightUnmasked(1,m)* &
1857 & grid(dg)%vmask_full(idg-1,jdg-1)
1858 qweight(2)=vcontact(cr)%QweightUnmasked(2,m)* &
1859 & grid(dg)%vmask_full(idg ,jdg-1)
1860 qweight(3)=vcontact(cr)%QweightUnmasked(3,m)* &
1861 & grid(dg)%vmask_full(idgp1,jdg-1)
1862 qweight(4)=vcontact(cr)%QweightUnmasked(4,m)* &
1863 & grid(dg)%vmask_full(idg-1,jdg )
1864 qweight(5)=vcontact(cr)%QweightUnmasked(5,m)* &
1865 & grid(dg)%vmask_full(idg ,jdg )
1866 qweight(6)=vcontact(cr)%QweightUnmasked(6,m)* &
1867 & grid(dg)%vmask_full(idgp1,jdg )
1868 qweight(7)=vcontact(cr)%QweightUnmasked(7,m)* &
1869 & grid(dg)%vmask_full(idg-1,jdgp1)
1870 qweight(8)=vcontact(cr)%QweightUnmasked(8,m)* &
1871 & grid(dg)%vmask_full(idg ,jdgp1)
1872 qweight(9)=vcontact(cr)%QweightUnmasked(9,m)* &
1873 & grid(dg)%vmask_full(idgp1,jdgp1)
1874# else
1875 qweight(1)=vcontact(cr)%Qweight(1,m)* &
1876 & grid(dg)%vmask_full(idg-1,jdg-1)
1877 qweight(2)=vcontact(cr)%Qweight(2,m)* &
1878 & grid(dg)%vmask_full(idg ,jdg-1)
1879 qweight(3)=vcontact(cr)%Qweight(3,m)* &
1880 & grid(dg)%vmask_full(idgp1,jdg-1)
1881 qweight(4)=vcontact(cr)%Qweight(4,m)* &
1882 & grid(dg)%vmask_full(idg-1,jdg )
1883 qweight(5)=vcontact(cr)%Qweight(5,m)* &
1884 & grid(dg)%vmask_full(idg ,jdg )
1885 qweight(6)=vcontact(cr)%Qweight(6,m)* &
1886 & grid(dg)%vmask_full(idgp1,jdg )
1887 qweight(7)=vcontact(cr)%Qweight(7,m)* &
1888 & grid(dg)%vmask_full(idg-1,jdgp1)
1889 qweight(8)=vcontact(cr)%Qweight(8,m)* &
1890 & grid(dg)%vmask_full(idg ,jdgp1)
1891 qweight(9)=vcontact(cr)%Qweight(9,m)* &
1892 & grid(dg)%vmask_full(idgp1,jdgp1)
1893# endif
1894 qwsum=sum(qweight)
1895 IF (qwsum.gt.0) THEN
1896 cff=1.0_r8/qwsum
1897 qweight(1)=cff*qweight(1) ! using only water points
1898 qweight(2)=cff*qweight(2) ! in the interpolation of
1899 qweight(3)=cff*qweight(3) ! of contact points
1900 qweight(4)=cff*qweight(4)
1901 qweight(5)=cff*qweight(5)
1902 qweight(6)=cff*qweight(6)
1903 qweight(7)=cff*qweight(7)
1904 qweight(8)=cff*qweight(8)
1905 qweight(9)=cff*qweight(9)
1906 ELSE
1907 qweight=0.0_r8 ! All the donor grid
1908 END IF ! corners are on land
1909 END IF
1910 qwsum_check=sum(qweight)
1911# ifdef DISTRIBUTE
1912 qw(1,m)=qweight(1)
1913 qw(2,m)=qweight(2)
1914 qw(3,m)=qweight(3)
1915 qw(4,m)=qweight(4)
1916 qw(5,m)=qweight(5)
1917 qw(6,m)=qweight(6)
1918 qw(7,m)=qweight(7)
1919 qw(8,m)=qweight(8)
1920 qw(9,m)=qweight(9)
1921 ELSE
1922 qw(1,m)=vcontact(cr)%Qweight(1,m) ! we need to load
1923 qw(2,m)=vcontact(cr)%Qweight(2,m) ! unscaled values
1924 qw(3,m)=vcontact(cr)%Qweight(3,m) ! to facilitate
1925 qw(4,m)=vcontact(cr)%Qweight(4,m) ! parallel reduction
1926 qw(5,m)=vcontact(cr)%Qweight(5,m)
1927 qw(6,m)=vcontact(cr)%Qweight(6,m)
1928 qw(7,m)=vcontact(cr)%Qweight(7,m)
1929 qw(8,m)=vcontact(cr)%Qweight(8,m)
1930 qw(9,m)=vcontact(cr)%Qweight(9,m)
1931# else
1932 vcontact(cr)%Qweight(1,m)=qweight(1)
1933 vcontact(cr)%Qweight(2,m)=qweight(2)
1934 vcontact(cr)%Qweight(3,m)=qweight(3)
1935 vcontact(cr)%Qweight(4,m)=qweight(4)
1936 vcontact(cr)%Qweight(5,m)=qweight(5)
1937 vcontact(cr)%Qweight(6,m)=qweight(6)
1938 vcontact(cr)%Qweight(7,m)=qweight(7)
1939 vcontact(cr)%Qweight(8,m)=qweight(8)
1940 vcontact(cr)%Qweight(9,m)=qweight(9)
1941# endif
1942 END IF
1943# endif
1944 END IF
1945 END DO
1946
1947# ifdef DISTRIBUTE
1948!
1949! Exchange data between all parallel nodes.
1950!
1951 CALL mp_assemble (dg, model, lpoints, spv, lw)
1952 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1953
1954# ifdef QUADRATIC_WEIGHTS
1955 CALL mp_assemble (dg, model, qpoints, spv, qw)
1956 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1957# endif
1958!
1959! Load exchanged weights.
1960!
1961 vcontact(cr)%Lweight(1:4,1:npointsv)=lw(1:4,1:npointsv)
1962# ifdef QUADRATIC_WEIGHTS
1963 vcontact(cr)%Qweight(1:9,1:npointsv)=qw(1:9,1:npointsv)
1964# endif
1965!
1966! Deallocate local work arrays.
1967!
1968 IF (allocated(lw)) THEN
1969 deallocate (lw)
1970 END IF
1971
1972# ifdef QUADRATIC_WEIGHTS
1973 IF (allocated(qw)) THEN
1974 deallocate (qw)
1975 END IF
1976# endif
1977# endif
1978
1979 END IF scale_weights
1980 END DO
1981!
1982 RETURN
mod_scalars::refinedgrid
logical, dimension(:), allocatable refinedgrid
Definition mod_scalars.F:494

References mod_param::bounds, mod_scalars::exit_flag, strings_mod::founderror(), mod_grid::grid, mod_nesting::ncontact, mod_scalars::noerror, mod_nesting::rcontact, mod_scalars::refinedgrid, mod_nesting::ucontact, and mod_nesting::vcontact.

Referenced by ad_nesting_mod::ad_nesting(), nesting(), and tl_nesting_mod::tl_nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ nesting()

subroutine, public nesting_mod::nesting ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) isection )

Definition at line 139 of file nesting.F.

140!
141!=======================================================================
142! !
143! This routine process the contact region points between composite !
144! grids. In composite grids, it is possible to have more than one !
145! contact region. !
146! !
147! On Input: !
148! !
149! ng Data receiver grid number (integer) !
150! model Calling model identifier (integer) !
151! isection Governing equations time-stepping section in !
152! main2d or main3d indicating which state !
153! variables to process (integer) !
154! !
155!=======================================================================
156!
157 USE mod_param
158 USE mod_parallel
159 USE mod_ncparam
160 USE mod_nesting
161 USE mod_scalars
162!
163# ifdef SOLVE3D
164 USE set_depth_mod, ONLY : set_depth
165# endif
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!
176 integer :: subs, tile, thread
177 integer :: ngc
178!
179 character (len=*), parameter :: MyFile = &
180 & __FILE__
181
182# ifdef PROFILE
183!
184!-----------------------------------------------------------------------
185! Turn on time clocks.
186!-----------------------------------------------------------------------
187!
188 CALL wclock_on (ng, model, 36, __line__, myfile)
189# endif
190# ifdef SOLVE3D
191!
192!-----------------------------------------------------------------------
193! Process vertical indices and interpolation weigths associated with
194! depth. Currently, vertical weights are used in composite grids
195! because their grids are not coincident. They are not needed in
196! refinement grids because the donor and receiver grids have the same
197! number of vertical levels and matching bathymetry. However, in
198! the future, it is possible to have configurations that require
199! vertical weights in refinement. The switch "get_Vweights" controls
200! if such weights are computed or not. If false, it will accelerate
201! computations because of less distributed-memory communications.
202!-----------------------------------------------------------------------
203!
204 IF ((isection.eq.nzwgt).and.get_vweights) THEN
205 DO tile=last_tile(ng),first_tile(ng),-1
206 CALL z_weights (ng, model, tile)
207 END DO
208!$OMP BARRIER
209 RETURN
210 END IF
211# endif
212
213# if defined MASKING || defined WET_DRY
214!
215!-----------------------------------------------------------------------
216! If Land/Sea masking, scale horizontal interpolation weights to
217! account for land contact points. If wetting and drying, the scaling
218! is done at every time-step because masking is time dependent.
219!-----------------------------------------------------------------------
220!
221 IF (isection.eq.nmask) THEN
222 DO tile=last_tile(ng),first_tile(ng),-1
223 CALL mask_hweights (ng, model, tile)
224 END DO
225!$OMP BARRIER
226 RETURN
227 END IF
228# endif
229!
230!-----------------------------------------------------------------------
231! If refinement grid, process contact points.
232!-----------------------------------------------------------------------
233!
234 IF (refinedgrid(ng)) THEN
235!
236! Extract grid spacing metrics (on_u and om_v) and load then to
237! REFINE(:) structure. These metrics are needed to impose mass
238! flux at the finer grid physical boundaries. It need to be done
239! separately because parallelism partions between all nested grid.
240!
241 IF (isection.eq.ndxdy) THEN
242 DO tile=first_tile(ng),last_tile(ng),+1
243 CALL get_metrics (ng, model, tile)
244 END DO
245!$OMP BARRIER
246!
247! Extract and store donor grid data at contact points.
248!
249 ELSE IF (isection.eq.ngetd) THEN
250 DO tile=first_tile(ng),last_tile(ng),+1
251 CALL get_refine (ng, model, tile)
252 END DO
253!$OMP BARRIER
254!
255! Fill refinement grid contact points variables by interpolating
256! (space, time) from extracted donor grid data. The free-surface
257! needs to be processed first and in a separate parallel region
258! because of shared-memory applications.
259!
260 ELSE IF (isection.eq.nputd) THEN
261 lputfsur=.true.
262 DO tile=first_tile(ng),last_tile(ng),+1
263 CALL put_refine (ng, model, tile, lputfsur)
264 END DO
265!$OMP BARRIER
266!
267 lputfsur=.false.
268 DO tile=first_tile(ng),last_tile(ng),+1
269 CALL put_refine (ng, model, tile, lputfsur)
270 END DO
271!$OMP BARRIER
272
273# ifdef NESTING_DEBUG
274!
275! If refinement, check mass flux conservation between coarser and
276! finer grids.
277!
278 ELSE IF (isection.eq.nmflx) THEN
279 DO tile=first_tile(ng),last_tile(ng),+1
280 CALL check_massflux (ng, model, tile)
281 END DO
282# endif
283
284# ifndef ONE_WAY
285!
286! Fine to coarse coupling: two-way nesting.
287!
288 ELSE IF (isection.eq.n2way) THEN
289
290 ngc=coarserdonor(ng) ! coarse grid number
291
292# if defined SOLVE3D && !defined NO_CORRECT_TRACER
293!
294! Correct coarse grid tracer values at the refinement grid, ng,
295! boundary with the refined accumulated fluxes (Hz*u*T/n, Hz*v*T/m).
296!
297 DO tile=first_tile(ngc),last_tile(ngc),+1
298 CALL correct_tracer (ngc, ng, model, tile)
299 END DO
300!$OMP BARRIER
301# endif
302!
303! Replace coarse grid 2D state variables with the averaged fine grid
304! values (two-way coupling).
305!
306 DO tile=last_tile(ngc),first_tile(ngc),-1
307 CALL fine2coarse (ng, model, r2dvar, tile)
308 END DO
309!$OMP BARRIER
310 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
311
312# ifdef SOLVE3D
313!
314! Update coarse grid depth variables. We have a new coarse grid
315! adjusted free-surface, Zt_avg1.
316!
317 DO tile=first_tile(ngc),last_tile(ngc),+1
318 CALL set_depth (ngc, tile, model)
319 END DO
320!$OMP BARRIER
321!
322! Replace coarse grid 3D state variables with the averaged fine grid
323! values (two-way coupling).
324!
325 DO tile=last_tile(ngc),first_tile(ngc),-1
326 CALL fine2coarse (ng, model, r3dvar, tile)
327 END DO
328!$OMP BARRIER
329 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
330# endif
331# else
332!
333! Fine to coarse coupling (two-way nesting) is not activated!
334!
335 ELSE IF (isection.eq.n2way) THEN
336# endif
337 END IF
338!
339!-----------------------------------------------------------------------
340! Otherwise, process contact points in composite grid.
341!-----------------------------------------------------------------------
342!
343 ELSE
344!
345! Get composite grid contact points data from donor grid. It extracts
346! the donor grid cell data necessary to interpolate state variables
347! at each contact point.
348!
349 DO tile=first_tile(ng),last_tile(ng),+1
350 CALL get_composite (ng, model, isection, tile)
351 END DO
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 put_composite (ng, model, isection, tile)
359 END DO
360!$OMP BARRIER
361
362 END IF
363
364# ifdef PROFILE
365!
366!-----------------------------------------------------------------------
367! Turn off time clocks.
368!-----------------------------------------------------------------------
369!
370 CALL wclock_off (ng, model, 36, __line__, myfile)
371# endif
372!
373 RETURN
mod_nesting::ngetd
integer, parameter ngetd
Definition mod_nesting.F:77
mod_nesting::nputd
integer, parameter nputd
Definition mod_nesting.F:79
mod_nesting::nzwgt
integer, parameter nzwgt
Definition mod_nesting.F:89
mod_nesting::ndxdy
integer, parameter ndxdy
Definition mod_nesting.F:76
mod_nesting::nmask
integer, parameter nmask
Definition mod_nesting.F:78
mod_nesting::n2way
integer, parameter n2way
Definition mod_nesting.F:80
mod_nesting::get_vweights
logical get_vweights
Definition mod_nesting.F:130
mod_nesting::nmflx
integer, parameter nmflx
Definition mod_nesting.F:75
mod_parallel::first_tile
integer, dimension(:), allocatable first_tile
Definition mod_parallel.F:62
mod_parallel::last_tile
integer, dimension(:), allocatable last_tile
Definition mod_parallel.F:63
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
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3

References check_massflux(), mod_nesting::coarserdonor, correct_tracer(), mod_scalars::exit_flag, fine2coarse(), mod_parallel::first_tile, strings_mod::founderror(), get_composite(), get_metrics(), get_refine(), mod_nesting::get_vweights, mod_parallel::last_tile, mask_hweights(), mod_nesting::n2way, mod_nesting::ndxdy, mod_nesting::ngetd, mod_nesting::nmask, mod_nesting::nmflx, mod_scalars::noerror, mod_nesting::nputd, mod_nesting::nzwgt, put_composite(), put_refine(), mod_param::r2dvar, mod_param::r3dvar, mod_scalars::refinedgrid, set_depth_mod::set_depth(), wclock_off(), wclock_on(), and z_weights().

Referenced by ad_main3d(), initial(), main3d(), roms_kernel_mod::nlm_initial(), set_grid(), and tl_main3d().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ put_composite()

subroutine, private nesting_mod::put_composite ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) isection,
integer, intent(in) tile )
private

Definition at line 2592 of file nesting.F.

2593!
2594!=======================================================================
2595! !
2596! This routine interpolates composite grid contact points from donor !
2597! grid data extracted in routine 'get_composite'. !
2598! !
2599! On Input: !
2600! !
2601! ng Composite grid number (integer) !
2602! model Calling model identifier (integer) !
2603! isection Governing equations time-stepping section in !
2604! main2d or main3d indicating which state !
2605! variables to process (integer) !
2606! tile Domain tile partition (integer) !
2607! !
2608!=======================================================================
2609!
2610 USE mod_param
2611 USE mod_coupling
2612 USE mod_forces
2613 USE mod_grid
2614 USE mod_ncparam
2615 USE mod_nesting
2616 USE mod_ocean
2617 USE mod_scalars
2618 USE mod_stepping
2619
2620# ifdef DISTRIBUTE
2621!
2622 USE mp_exchange_mod, ONLY : mp_exchange2d
2623# ifdef SOLVE3D
2624 USE mp_exchange_mod, ONLY : mp_exchange3d, mp_exchange4d
2625# endif
2626# endif
2627!
2628! Imported variable declarations.
2629!
2630 integer, intent(in) :: ng, model, isection, tile
2631!
2632! Local variable declarations.
2633!
2634 integer :: dg, rg, cr, nrec, rec
2635# ifdef SOLVE3D
2636 integer :: itrc
2637# endif
2638 integer :: LBi, UBi, LBj, UBj
2639 integer :: Tindex
2640!
2641!-----------------------------------------------------------------------
2642! Interpolate composite grid contact points from donor grid data.
2643! Only process those variables associated with the governing equation
2644! time-stepping section.
2645!-----------------------------------------------------------------------
2646!
2647 cr_loop : DO cr=1,ncontact
2648!
2649! Get data donor and data receiver grid numbers.
2650!
2651 dg=rcontact(cr)%donor_grid
2652 rg=rcontact(cr)%receiver_grid
2653!
2654! Process only contact region data for requested nested grid "ng".
2655!
2656 IF (rg.eq.ng) THEN
2657!
2658! Set receiver grid lower and upper array indices.
2659!
2660 lbi=bounds(rg)%LBi(tile)
2661 ubi=bounds(rg)%UBi(tile)
2662 lbj=bounds(rg)%LBj(tile)
2663 ubj=bounds(rg)%UBj(tile)
2664!
2665! Process bottom stress (bustr, bvstr).
2666!
2667 IF (isection.eq.nbstr) THEN
2668 CALL put_contact2d (rg, model, tile, &
2669 & u2dvar, vname(1,idubms), &
2670 & cr, ucontact(cr)%Npoints, ucontact, &
2671 & lbi, ubi, lbj, ubj, &
2672# ifdef MASKING
2673 & grid(rg) % umask, &
2674# endif
2675 & composite(cr) % bustr, &
2676 & forces(rg) % bustr)
2677 CALL put_contact2d (rg, model, tile, &
2678 & v2dvar, vname(1,idvbms), &
2679 & cr, vcontact(cr)%Npoints, vcontact, &
2680 & lbi, ubi, lbj, ubj, &
2681# ifdef MASKING
2682 & grid(rg) % vmask, &
2683# endif
2684 & composite(cr) % bvstr, &
2685 & forces(rg) % bvstr)
2686# ifdef DISTRIBUTE
2687 CALL mp_exchange2d (rg, tile, model, 2, &
2688 & lbi, ubi, lbj, ubj, &
2689 & nghostpoints, &
2690 & ewperiodic(rg), nsperiodic(rg), &
2691 & forces(rg) % bustr, &
2692 & forces(rg) % bvstr)
2693# endif
2694 END IF
2695!
2696! Process free-surface (zeta) at the appropriate time index.
2697!
2698 IF ((isection.eq.nfsic).or. &
2699 & (isection.eq.nzeta).or. &
2700 & (isection.eq.n2dps).or. &
2701 & (isection.eq.n2dcs)) THEN
2702 IF (isection.eq.nzeta) THEN
2703 nrec=2 ! process time records 1 and 2
2704 ELSE
2705 nrec=1 ! process knew record
2706 END IF
2707 DO rec=1,nrec
2708 IF (isection.eq.nzeta) THEN
2709 tindex=rec
2710 ELSE
2711 tindex=knew(rg)
2712 END IF
2713 CALL put_contact2d (rg, model, tile, &
2714 & r2dvar, vname(1,idfsur), &
2715 & cr, rcontact(cr)%Npoints, rcontact, &
2716 & lbi, ubi, lbj, ubj, &
2717# ifdef MASKING
2718 & grid(rg) % rmask, &
2719# endif
2720 & composite(cr) % zeta(:,:,rec), &
2721 & ocean(rg) % zeta(:,:,tindex))
2722# ifdef DISTRIBUTE
2723 CALL mp_exchange2d (rg, tile, model, 1, &
2724 & lbi, ubi, lbj, ubj, &
2725 & nghostpoints, &
2726 & ewperiodic(rg), nsperiodic(rg), &
2727 & ocean(rg) % zeta(:,:,tindex))
2728# endif
2729 END DO
2730 END IF
2731
2732# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3)
2733!
2734! Process free-surface equation rigth-hand-side (rzeta) term.
2735!
2736 IF (isection.eq.n2dps) THEN
2737 tindex=1
2738 CALL put_contact2d (rg, model, tile, &
2739 & r2dvar, vname(1,idrzet), &
2740 & cr, rcontact(cr)%Npoints, rcontact, &
2741 & lbi, ubi, lbj, ubj, &
2742# ifdef MASKING
2743 & grid(rg) % rmask, &
2744# endif
2745 & composite(cr) % rzeta, &
2746 & ocean(rg) % rzeta(:,:,tindex))
2747# ifdef DISTRIBUTE
2748 CALL mp_exchange2d (rg, tile, model, 1, &
2749 & lbi, ubi, lbj, ubj, &
2750 & nghostpoints, &
2751 & ewperiodic(rg), nsperiodic(rg), &
2752 & ocean(rg) % rzeta(:,:,tindex))
2753# endif
2754 END IF
2755# endif
2756!
2757! Process 2D momentum components (ubar,vbar) at the appropriate time
2758! index.
2759!
2760 IF ((isection.eq.n2dic).or. &
2761 & (isection.eq.n2dps).or. &
2762 & (isection.eq.n2dcs).or. &
2763 & (isection.eq.n3duv)) THEN
2764 IF (isection.eq.n3duv) THEN
2765 nrec=2 ! process time records 1 and 2
2766 ELSE
2767 nrec=1 ! process KNEW record
2768 END IF
2769 DO rec=1,nrec
2770 IF (isection.eq.n3duv) THEN
2771 tindex=rec
2772 ELSE
2773 tindex=knew(rg)
2774 END IF
2775 CALL put_contact2d (rg, model, tile, &
2776 & u2dvar, vname(1,idubar), &
2777 & cr, ucontact(cr)%Npoints, ucontact, &
2778 & lbi, ubi, lbj, ubj, &
2779# ifdef MASKING
2780 & grid(rg) % umask, &
2781# endif
2782 & composite(cr) % ubar(:,:,rec), &
2783 & ocean(rg) % ubar(:,:,tindex))
2784 CALL put_contact2d (rg, model, tile, &
2785 & v2dvar, vname(1,idvbar), &
2786 & cr, vcontact(cr)%Npoints, vcontact, &
2787 & lbi, ubi, lbj, ubj, &
2788# ifdef MASKING
2789 & grid(rg) % vmask, &
2790# endif
2791 & composite(cr) % vbar(:,:,rec), &
2792 & ocean(rg) % vbar(:,:,tindex))
2793# ifdef DISTRIBUTE
2794 CALL mp_exchange2d (rg, tile, model, 2, &
2795 & lbi, ubi, lbj, ubj, &
2796 & nghostpoints, &
2797 & ewperiodic(rg), nsperiodic(rg), &
2798 & ocean(rg) % ubar(:,:,tindex), &
2799 & ocean(rg) % vbar(:,:,tindex))
2800# endif
2801 END DO
2802 END IF
2803
2804# ifdef SOLVE3D
2805!
2806! Process time averaged free-surface (Zt_avg1) and 2D momentum fluxes
2807! (DU_avg1, DV_avg1).
2808!
2809 IF (isection.eq.n2dfx) THEN
2810 CALL put_contact2d (rg, model, tile, &
2811 & r2dvar, 'Zt_avg1', &
2812 & cr, rcontact(cr)%Npoints, rcontact, &
2813 & lbi, ubi, lbj, ubj, &
2814# ifdef MASKING
2815 & grid(rg) % rmask, &
2816# endif
2817 & composite(cr) % Zt_avg1, &
2818 & coupling(rg) % Zt_avg1)
2819 CALL put_contact2d (rg, model, tile, &
2820 & u2dvar, vname(1,idufx1), &
2821 & cr, ucontact(cr)%Npoints, ucontact, &
2822 & lbi, ubi, lbj, ubj, &
2823# ifdef MASKING
2824 & grid(rg) % umask, &
2825# endif
2826 & composite(cr) % DU_avg1, &
2827 & coupling(rg) % DU_avg1)
2828 CALL put_contact2d (rg, model, tile, &
2829 & v2dvar, vname(1,idvfx1), &
2830 & cr, vcontact(cr)%Npoints, vcontact, &
2831 & lbi, ubi, lbj, ubj, &
2832# ifdef MASKING
2833 & grid(rg) % vmask, &
2834# endif
2835 & composite(cr) % DV_avg1, &
2836 & coupling(rg) % DV_avg1)
2837# ifdef DISTRIBUTE
2838 CALL mp_exchange2d (rg, tile, model, 3, &
2839 & lbi, ubi, lbj, ubj, &
2840 & nghostpoints, &
2841 & ewperiodic(rg), nsperiodic(rg), &
2842 & coupling(rg) % Zt_avg1, &
2843 & coupling(rg) % DU_avg1, &
2844 & coupling(rg) % DV_avg1)
2845# endif
2846 END IF
2847
2848# if !defined TS_FIXED
2849!
2850! Process tracer variables (t) at the appropriate time index.
2851!
2852 IF ((isection.eq.ntvic).or. &
2853 & (isection.eq.nrhst).or. &
2854 & (isection.eq.n3dtv)) THEN
2855 DO itrc=1,nt(ng)
2856 IF (isection.eq.nrhst) THEN
2857 tindex=3
2858 ELSE
2859 tindex=nnew(rg)
2860 END IF
2861 CALL put_contact3d (rg, model, tile, &
2862 & r3dvar, vname(1,idtvar(itrc)), &
2863 & cr, rcontact(cr)%Npoints, rcontact, &
2864 & lbi, ubi, lbj, ubj, 1, n(rg), &
2865# ifdef MASKING
2866 & grid(rg) % rmask, &
2867# endif
2868 & composite(cr) % t(:,:,:,itrc), &
2869 & ocean(rg) % t(:,:,:,tindex,itrc))
2870 END DO
2871# ifdef DISTRIBUTE
2872 CALL mp_exchange4d (rg, tile, model, 1, &
2873 & lbi, ubi, lbj, ubj, 1, n(rg), 1, nt(rg),&
2874 & nghostpoints, &
2875 & ewperiodic(rg), nsperiodic(rg), &
2876 & ocean(rg) % t(:,:,:,tindex,:))
2877# endif
2878 END IF
2879# endif
2880!
2881! Process 3D momentum (u, v) at the appropriate time-index.
2882!
2883 IF ((isection.eq.n3dic).or. &
2884 & (isection.eq.n3duv)) THEN
2885 tindex=nnew(rg)
2886 CALL put_contact3d (rg, model, tile, &
2887 & u3dvar, vname(1,iduvel), &
2888 & cr, ucontact(cr)%Npoints, ucontact, &
2889 & lbi, ubi, lbj, ubj, 1, n(rg), &
2890# ifdef MASKING
2891 & grid(rg) % umask, &
2892# endif
2893 & composite(cr) % u, &
2894 & ocean(rg) % u(:,:,:,tindex))
2895 CALL put_contact3d (rg, model, tile, &
2896 & v3dvar, vname(1,idvvel), &
2897 & cr, vcontact(cr)%Npoints, vcontact, &
2898 & lbi, ubi, lbj, ubj, 1, n(rg), &
2899# ifdef MASKING
2900 & grid(rg) % vmask, &
2901# endif
2902 & composite(cr) % v, &
2903 & ocean(rg) % v(:,:,:,tindex))
2904# ifdef DISTRIBUTE
2905 CALL mp_exchange3d (rg, tile, model, 2, &
2906 & lbi, ubi, lbj, ubj, 1, n(rg), &
2907 & nghostpoints, &
2908 & ewperiodic(rg), nsperiodic(rg), &
2909 & ocean(rg) % u(:,:,:,tindex), &
2910 & ocean(rg) % v(:,:,:,tindex))
2911# endif
2912 END IF
2913!
2914! Process 3D momentum fluxes (Huon, Hvom).
2915!
2916 IF (isection.eq.n3duv) THEN
2917 CALL put_contact3d (rg, model, tile, &
2918 & u3dvar, 'Huon', &
2919 & cr, ucontact(cr)%Npoints, ucontact, &
2920 & lbi, ubi, lbj, ubj, 1, n(rg), &
2921# ifdef MASKING
2922 & grid(rg) % umask, &
2923# endif
2924 & composite(cr) % Huon, &
2925 & grid(rg) % Huon)
2926 CALL put_contact3d (rg, model, tile, &
2927 & v3dvar, 'Hvom', &
2928 & cr, vcontact(cr)%Npoints, vcontact, &
2929 & lbi, ubi, lbj, ubj, 1, n(rg), &
2930# ifdef MASKING
2931 & grid(rg) % vmask, &
2932# endif
2933 & composite(cr) % Hvom, &
2934 & grid(rg) % Hvom)
2935# ifdef DISTRIBUTE
2936 CALL mp_exchange3d (rg, tile, model, 2, &
2937 & lbi, ubi, lbj, ubj, 1, n(rg), &
2938 & nghostpoints, &
2939 & ewperiodic(rg), nsperiodic(rg), &
2940 & grid(rg) % Huon, &
2941 & grid(rg) % Hvom)
2942# endif
2943 END IF
2944# endif
2945
2946 END IF
2947 END DO cr_loop
2948!
2949 RETURN
mod_ncparam::idvfx1
integer idvfx1
Definition mod_ncparam.F:372
mod_ncparam::idufx1
integer idufx1
Definition mod_ncparam.F:337

References mod_param::bounds, mod_nesting::composite, mod_coupling::coupling, mod_scalars::ewperiodic, mod_forces::forces, mod_grid::grid, mod_ncparam::idfsur, mod_ncparam::idrzet, mod_ncparam::idtvar, mod_ncparam::idubar, mod_ncparam::idubms, mod_ncparam::idufx1, mod_ncparam::iduvel, mod_ncparam::idvbar, mod_ncparam::idvbms, mod_ncparam::idvfx1, mod_ncparam::idvvel, mod_stepping::knew, mp_exchange_mod::mp_exchange2d(), mp_exchange_mod::mp_exchange3d(), mp_exchange_mod::mp_exchange4d(), mod_param::n, mod_nesting::n2dcs, mod_nesting::n2dfx, mod_nesting::n2dic, mod_nesting::n2dps, mod_nesting::n3dic, mod_nesting::n3dtv, mod_nesting::n3duv, mod_nesting::nbstr, mod_nesting::ncontact, mod_nesting::nfsic, mod_param::nghostpoints, mod_stepping::nnew, mod_nesting::nrhst, mod_scalars::nsperiodic, mod_param::nt, mod_nesting::ntvic, mod_nesting::nzeta, mod_ocean::ocean, put_contact2d(), put_contact3d(), mod_param::r2dvar, mod_param::r3dvar, mod_nesting::rcontact, mod_param::u2dvar, mod_param::u3dvar, mod_nesting::ucontact, mod_param::v2dvar, mod_param::v3dvar, mod_nesting::vcontact, and mod_ncparam::vname.

Referenced by nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ put_contact2d()

subroutine nesting_mod::put_contact2d ( integer, intent(in) rg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) gtype,
character(len=*), intent(in) svname,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(:,:), intent(in) ac,
real(r8), dimension(lbi:,lbj:), intent(inout) ar )

Definition at line 5348 of file nesting.F.

5356!
5357!=======================================================================
5358! !
5359! This routine uses extracted donor grid data (Ac) to spatially !
5360! interpolate a 2D state variable at the receiver grid contact !
5361! points. If the donor and receiver grids are coincident, the !
5362! Lweight(1,:) is unity and Lweight(2:4,:) are zero. !
5363! !
5364! On Input: !
5365! !
5366! rg Receiver grid number (integer) !
5367! model Calling model identifier (integer) !
5368! tile Domain tile partition (integer) !
5369! gtype C-grid variable type (integer) !
5370! svname State variable name (string) !
5371! cr Contact region number to process (integer) !
5372! Npoints Number of points in the contact region (integer) !
5373! contact Contact region information variables (T_NGC structure)!
5374! LBi Receiver grid, I-dimension Lower bound (integer) !
5375! UBi Receiver grid, I-dimension Upper bound (integer) !
5376! LBj Receiver grid, J-dimension Lower bound (integer) !
5377! UBj Receiver grid, J-dimension Upper bound (integer) !
5378# ifdef MASKING
5379! Amask Receiver grid land/sea masking !
5380# endif
5381! Ac Contact point data extracted from donor grid !
5382! !
5383! On Output: !
5384! !
5385! Ar Updated receiver grid 2D state array !
5386! !
5387!=======================================================================
5388!
5389 USE mod_param
5390 USE mod_ncparam
5391 USE mod_nesting
5392!
5393! Imported variable declarations.
5394!
5395 integer, intent(in) :: rg, model, tile
5396 integer, intent(in) :: gtype, cr, Npoints
5397 integer, intent(in) :: LBi, UBi, LBj, UBj
5398!
5399 character(len=*), intent(in) :: svname
5400!
5401 TYPE (T_NGC), intent(in) :: contact(:)
5402!
5403# ifdef ASSUMED_SHAPE
5404 real(r8), intent(in) :: Ac(:,:)
5405# ifdef MASKING
5406 real(r8), intent(in) :: Amask(LBi:,LBj:)
5407# endif
5408 real(r8), intent(inout) :: Ar(LBi:,LBj:)
5409# else
5410 real(r8), intent(in) :: Ac(4,Npoints)
5411# ifdef MASKING
5412 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
5413# endif
5414 real(r8), intent(inout) :: Ar(LBi:UBi,LBj:UBj)
5415# endif
5416!
5417! Local variable declarations.
5418!
5419 integer :: i, j, m
5420 integer :: Istr, Iend, Jstr, Jend
5421!
5422!-----------------------------------------------------------------------
5423! Interpolate 2D data from donor grid to receiver grid contact points.
5424!-----------------------------------------------------------------------
5425!
5426! Set starting and ending tile indices for the receiver grid.
5427!
5428 SELECT CASE (gtype)
5429 CASE (r2dvar)
5430 istr=bounds(rg) % IstrT(tile)
5431 iend=bounds(rg) % IendT(tile)
5432 jstr=bounds(rg) % JstrT(tile)
5433 jend=bounds(rg) % JendT(tile)
5434 CASE (u2dvar)
5435 istr=bounds(rg) % IstrP(tile)
5436 iend=bounds(rg) % IendT(tile)
5437 jstr=bounds(rg) % JstrT(tile)
5438 jend=bounds(rg) % JendT(tile)
5439 CASE (v2dvar)
5440 istr=bounds(rg) % IstrT(tile)
5441 iend=bounds(rg) % IendT(tile)
5442 jstr=bounds(rg) % JstrP(tile)
5443 jend=bounds(rg) % JendT(tile)
5444 END SELECT
5445!
5446! Interpolate.
5447!
5448 DO m=1,npoints
5449 i=contact(cr)%Irg(m)
5450 j=contact(cr)%Jrg(m)
5451 IF (((istr.le.i).and.(i.le.iend)).and. &
5452 & ((jstr.le.j).and.(j.le.jend))) THEN
5453 ar(i,j)=contact(cr)%Lweight(1,m)*ac(1,m)+ &
5454 & contact(cr)%Lweight(2,m)*ac(2,m)+ &
5455 & contact(cr)%Lweight(3,m)*ac(3,m)+ &
5456 & contact(cr)%Lweight(4,m)*ac(4,m)
5457# ifdef MASKING
5458 ar(i,j)=ar(i,j)*amask(i,j)
5459# endif
5460 END IF
5461 END DO
5462!
5463 RETURN

References mod_param::bounds, mod_param::r2dvar, mod_param::u2dvar, and mod_param::v2dvar.

Referenced by put_composite(), and tl_nesting_mod::tl_put_composite().

Here is the caller graph for this function:

◆ put_contact3d()

subroutine nesting_mod::put_contact3d ( integer, intent(in) rg,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) gtype,
character(len=*), intent(in) svname,
integer, intent(in) cr,
integer, intent(in) npoints,
type (t_ngc), dimension(:), intent(in) contact,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj,
integer, intent(in) lbk,
integer, intent(in) ubk,
real(r8), dimension(lbi:,lbj:), intent(in) amask,
real(r8), dimension(:,:,:), intent(in) ac,
real(r8), dimension(lbi:,lbj:,lbk:), intent(inout) ar )

Definition at line 5468 of file nesting.F.

5476!
5477!=======================================================================
5478! !
5479! This routine uses extracted donor grid data (Ac) to spatially !
5480! interpolate a 3D state variable at the receiver grid contact !
5481! points. If the donor and receiver grids are concident, the !
5482! Lweight(1,:) is unity and Lweight(2:4,:) are zero. !
5483! !
5484! On Input: !
5485! !
5486! rg Receiver grid number (integer) !
5487! model Calling model identifier (integer) !
5488! tile Domain tile partition (integer) !
5489! gtype C-grid variable type (integer) !
5490! svname State variable name (string) !
5491! cr Contact region number to process (integer) !
5492! Npoints Number of points in the contact region (integer) !
5493! contact Contact region information variables (T_NGC structure)!
5494! LBi Receiver grid, I-dimension Lower bound (integer) !
5495! UBi Receiver grid, I-dimension Upper bound (integer) !
5496! LBj Receiver grid, J-dimension Lower bound (integer) !
5497! UBj Receiver grid, J-dimension Upper bound (integer) !
5498! LBk Receiver grid, K-dimension Lower bound (integer) !
5499! UBk Receiver grid, K-dimension Upper bound (integer) !
5500# ifdef MASKING
5501! Amask Receiver grid land/sea masking !
5502# endif
5503! Ac Contact point data extracted from donor grid !
5504! !
5505! On Output: !
5506! !
5507! Ar Updated receiver grid 3D state array !
5508! !
5509!=======================================================================
5510!
5511 USE mod_param
5512 USE mod_ncparam
5513 USE mod_nesting
5514!
5515! Imported variable declarations.
5516!
5517 integer, intent(in) :: rg, model, tile
5518 integer, intent(in) :: gtype, cr, Npoints
5519 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
5520!
5521 character(len=*), intent(in) :: svname
5522!
5523 TYPE (T_NGC), intent(in) :: contact(:)
5524!
5525# ifdef ASSUMED_SHAPE
5526 real(r8), intent(in) :: Ac(:,:,:)
5527# ifdef MASKING
5528 real(r8), intent(in) :: Amask(LBi:,LBj:)
5529# endif
5530 real(r8), intent(inout) :: Ar(LBi:,LBj:,LBk:)
5531# else
5532 real(r8), intent(in) :: Ac(Npoints,LBk:UBk,4)
5533# ifdef MASKING
5534 real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
5535# endif
5536 real(r8), intent(inout) :: Ar(LBi:UBi,LBj:UBj,LBk:UBk)
5537# endif
5538!
5539! Local variable declarations.
5540!
5541 integer :: i, j, k, kdg, kdgm1, m
5542 integer :: Istr, Iend, Jstr, Jend, Kmin
5543
5544 real(r8), dimension(8) :: cff
5545!
5546!-----------------------------------------------------------------------
5547! Interpolate 3D data from donor grid to receiver grid contact points.
5548!-----------------------------------------------------------------------
5549!
5550! Set starting and ending tile indices for the receiver grid.
5551!
5552 SELECT CASE (gtype)
5553 CASE (r3dvar)
5554 istr=bounds(rg) % IstrT(tile)
5555 iend=bounds(rg) % IendT(tile)
5556 jstr=bounds(rg) % JstrT(tile)
5557 jend=bounds(rg) % JendT(tile)
5558 kmin=1
5559 CASE (u3dvar)
5560 istr=bounds(rg) % IstrP(tile)
5561 iend=bounds(rg) % IendT(tile)
5562 jstr=bounds(rg) % JstrT(tile)
5563 jend=bounds(rg) % JendT(tile)
5564 kmin=1
5565 CASE (v3dvar)
5566 istr=bounds(rg) % IstrT(tile)
5567 iend=bounds(rg) % IendT(tile)
5568 jstr=bounds(rg) % JstrP(tile)
5569 jend=bounds(rg) % JendT(tile)
5570 kmin=1
5571 CASE (w3dvar)
5572 istr=bounds(rg) % IstrT(tile)
5573 iend=bounds(rg) % IendT(tile)
5574 jstr=bounds(rg) % JstrT(tile)
5575 jend=bounds(rg) % JendT(tile)
5576 kmin=0
5577 END SELECT
5578!
5579! Interpolate.
5580!
5581 DO k=lbk,ubk
5582 DO m=1,npoints
5583 i=contact(cr)%Irg(m)
5584 j=contact(cr)%Jrg(m)
5585 kdg=contact(cr)%Kdg(k,m)
5586 kdgm1=max(kdg-1,kmin)
5587 IF (((istr.le.i).and.(i.le.iend)).and. &
5588 & ((jstr.le.j).and.(j.le.jend))) THEN
5589 cff(1)=contact(cr)%Lweight(1,m)*contact(cr)%Vweight(1,k,m)
5590 cff(2)=contact(cr)%Lweight(2,m)*contact(cr)%Vweight(1,k,m)
5591 cff(3)=contact(cr)%Lweight(3,m)*contact(cr)%Vweight(1,k,m)
5592 cff(4)=contact(cr)%Lweight(4,m)*contact(cr)%Vweight(1,k,m)
5593 cff(5)=contact(cr)%Lweight(1,m)*contact(cr)%Vweight(2,k,m)
5594 cff(6)=contact(cr)%Lweight(2,m)*contact(cr)%Vweight(2,k,m)
5595 cff(7)=contact(cr)%Lweight(3,m)*contact(cr)%Vweight(2,k,m)
5596 cff(8)=contact(cr)%Lweight(4,m)*contact(cr)%Vweight(2,k,m)
5597 ar(i,j,k)=cff(1)*ac(1,kdgm1,m)+ &
5598 & cff(2)*ac(2,kdgm1,m)+ &
5599 & cff(3)*ac(3,kdgm1,m)+ &
5600 & cff(4)*ac(4,kdgm1,m)+ &
5601 & cff(5)*ac(1,kdg ,m)+ &
5602 & cff(6)*ac(2,kdg ,m)+ &
5603 & cff(7)*ac(3,kdg ,m)+ &
5604 & cff(8)*ac(4,kdg ,m)
5605# ifdef MASKING
5606 ar(i,j,k)=ar(i,j,k)*amask(i,j)
5607# endif
5608 END IF
5609 END DO
5610 END DO
5611!
5612 RETURN
mod_param::w3dvar
integer, parameter w3dvar
Definition mod_param.F:724

References mod_param::bounds, mod_param::r3dvar, mod_param::u3dvar, mod_param::v3dvar, and mod_param::w3dvar.

Referenced by put_composite().

Here is the caller graph for this function:

◆ put_refine()

subroutine, private nesting_mod::put_refine ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) tile,
logical, intent(in) lputfsur )
private

Definition at line 2952 of file nesting.F.

2953!
2954!=======================================================================
2955! !
2956! This routine interpolates refinement grid contact points from donor !
2957! grid data extracted in routine 'get_refine'. Notice that because of !
2958! shared-memory parallelism, the free-surface is processed first and !
2959! in a different parallel region.
2960! !
2961! On Input: !
2962! !
2963! ng Refinement grid number (integer) !
2964! model Calling model identifier (integer) !
2965! tile Domain tile partition (integer) !
2966! LputFsur Switch to process or not free-surface (logical) !
2967! !
2968!=======================================================================
2969!
2970 USE mod_param
2971 USE mod_coupling
2972 USE mod_forces
2973 USE mod_grid
2974 USE mod_ncparam
2975 USE mod_nesting
2976 USE mod_ocean
2977 USE mod_scalars
2978 USE mod_stepping
2979!
2980! Imported variable declarations.
2981!
2982 logical, intent(in) :: LputFsur
2983 integer, intent(in) :: ng, model, tile
2984!
2985! Local variable declarations.
2986!
2987 integer :: dg, rg, cr, nrec, rec
2988# ifdef SOLVE3D
2989 integer :: itrc
2990# endif
2991 integer :: LBi, UBi, LBj, UBj
2992 integer :: Tindex
2993!
2994!-----------------------------------------------------------------------
2995! Interpolate refinement grid contact points from donor grid data
2996! (space-time interpolation)
2997!-----------------------------------------------------------------------
2998!
2999 DO cr=1,ncontact
3000!
3001! Get data donor and data receiver grid numbers.
3002!
3003 dg=rcontact(cr)%donor_grid
3004 rg=rcontact(cr)%receiver_grid
3005!
3006! Process only contact region data for requested nested grid "ng", if
3007! donor grid is coarser than receiver grid. That is, we are only
3008! processing external contact points areas.
3009!
3010 IF ((rg.eq.ng).and.(dxmax(dg).gt.dxmax(rg))) THEN
3011!
3012! Set receiver grid lower and upper array indices.
3013!
3014 lbi=bounds(rg)%LBi(tile)
3015 ubi=bounds(rg)%UBi(tile)
3016 lbj=bounds(rg)%LBj(tile)
3017 ubj=bounds(rg)%UBj(tile)
3018!
3019! Fill free-surface separatelly.
3020!
3021 IF (lputfsur) THEN
3022 CALL put_refine2d (ng, dg, cr, model, tile, lputfsur, &
3023 & lbi, ubi, lbj, ubj)
3024 ELSE
3025!
3026! Fill other 2D state variables (like momentum) contact points.
3027!
3028 CALL put_refine2d (ng, dg, cr, model, tile, lputfsur, &
3029 & lbi, ubi, lbj, ubj)
3030
3031# ifdef SOLVE3D
3032!
3033! Fill 3D state variables contact points.
3034!
3035 CALL put_refine3d (ng, dg, cr, model, tile, &
3036 & lbi, ubi, lbj, ubj)
3037# endif
3038 END IF
3039 END IF
3040 END DO
3041!
3042 RETURN

References mod_param::bounds, mod_scalars::dxmax, mod_nesting::ncontact, put_refine2d(), put_refine3d(), and mod_nesting::rcontact.

Referenced by nesting().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ put_refine2d()

subroutine, private nesting_mod::put_refine2d ( integer, intent(in) ng,
integer, intent(in) dg,
integer, intent(in) cr,
integer, intent(in) model,
integer, intent(in) tile,
logical, intent(in) lputfsur,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj )
private

Definition at line 5616 of file nesting.F.

5618!
5619!=======================================================================
5620! !
5621! This routine interpolates (space, time) refinement grid 2D state !
5622! variables contact points using data from the donor grid. Notice !
5623! that because of shared-memory parallelism, the free-surface is !
5624! processed first and in a different parallel region. !
5625! !
5626! On Input: !
5627! !
5628! ng Refinement (receiver) grid number (integer) !
5629! dg Donor grid number (integer) !
5630! cr Contact region number to process (integer) !
5631! model Calling model identifier (integer) !
5632! tile Domain tile partition (integer) !
5633! LputFsur Switch to process or not free-surface (logical) !
5634! LBi Receiver grid, I-dimension Lower bound (integer) !
5635! UBi Receiver grid, I-dimension Upper bound (integer) !
5636! LBj Receiver grid, J-dimension Lower bound (integer) !
5637! UBj Receiver grid, J-dimension Upper bound (integer) !
5638! !
5639! On Output: OCEAN(ng) structure !
5640! !
5641! zeta Updated free-surface !
5642! ubar Updated 2D momentum in the XI-direction !
5643! vbar Updated 2D momentum in the ETA-direction !
5644! !
5645!=======================================================================
5646!
5647 USE mod_param
5648 USE mod_parallel
5649 USE mod_coupling
5650 USE mod_grid
5651 USE mod_nesting
5652 USE mod_ocean
5653 USE mod_scalars
5654 USE mod_stepping
5655 USE mod_iounits
5656
5657# ifdef DISTRIBUTE
5658!
5659 USE distribute_mod, ONLY : mp_assemble
5660 USE mp_exchange_mod, ONLY : mp_exchange2d
5661# endif
5662 USE strings_mod, ONLY : founderror
5663!
5664! Imported variable declarations.
5665!
5666 logical, intent(in) :: LputFsur
5667 integer, intent(in) :: ng, dg, cr, model, tile
5668 integer, intent(in) :: LBi, UBi, LBj, UBj
5669!
5670! Local variable declarations.
5671!
5672 logical :: Uboundary, Vboundary
5673!
5674# ifdef DISTRIBUTE
5675 integer :: ILB, IUB, JLB, JUB, NptsSN, NptsWE, my_tile
5676# endif
5677 integer :: NSUB, i, irec, j, kindex, m, tnew, told
5678 integer :: Idg, Jdg
5679!
5680# ifdef DISTRIBUTE
5681 real(r8), parameter :: spv = 0.0_r8
5682# endif
5683 real(dp) :: Wnew, Wold, SecScale, fac
5684 real(r8) :: cff, cff1
5685 real(r8) :: my_value
5686!
5687 character (len=*), parameter :: MyFile = &
5688 & __FILE__//", put_refined2d"
5689
5690# include "set_bounds.h"
5691!
5692!-----------------------------------------------------------------------
5693! Interpolate (space, time) refinement grid contact points for 2D state
5694! variables from donor grid.
5695!-----------------------------------------------------------------------
5696
5697# ifdef DISTRIBUTE
5698!
5699! Set global size of boundary edges.
5700!
5701 IF (.not.lputfsur) THEN
5702 my_tile=-1
5703 ilb=bounds(ng)%LBi(my_tile)
5704 iub=bounds(ng)%UBi(my_tile)
5705 jlb=bounds(ng)%LBj(my_tile)
5706 jub=bounds(ng)%UBj(my_tile)
5707 nptswe=jub-jlb+1
5708 nptssn=iub-ilb+1
5709
5710# ifdef NESTING_DEBUG
5711!
5712! If distributed-memory, initialize arrays used to check mass flux
5713! conservation with special value (zero) to facilitate the global
5714! reduction when collecting data between all nodes.
5715!
5716 bry_contact(iwest ,cr)%Mflux=spv
5717 bry_contact(ieast ,cr)%Mflux=spv
5718 bry_contact(isouth,cr)%Mflux=spv
5719 bry_contact(inorth,cr)%Mflux=spv
5720# endif
5721 END IF
5722# endif
5723!
5724! Set time snapshot indices for the donor grid data.
5725!
5726 told=3-rollingindex(cr)
5727 tnew=rollingindex(cr)
5728!
5729! Set linear time interpolation weights. Fractional seconds are
5730! rounded to the nearest milliseconds integer towards zero in the
5731! time interpolation weights.
5732!
5733 secscale=1000.0_dp ! seconds to milliseconds
5734!
5735 wold=anint((rollingtime(tnew,cr)-time(ng))*secscale,dp)
5736 wnew=anint((time(ng)-rollingtime(told,cr))*secscale,dp)
5737 fac=1.0_dp/(wold+wnew)
5738 wold=fac*wold
5739 wnew=fac*wnew
5740!
5741 IF (((wold*wnew).lt.0.0_dp).or.((wold+wnew).le.0.0_dp)) THEN
5742 IF (domain(ng)%SouthWest_Test(tile)) THEN
5743 IF (master) THEN
5744 WRITE (stdout,10) cr, dg, ng, &
5745 & iic(dg), told, tnew, &
5746 & iic(ng), wold, wnew, &
5747 & int(time(ng)), &
5748 & int(rollingtime(told,cr)), &
5749 & int(rollingtime(tnew,cr))
5750 END IF
5751 exit_flag=8
5752 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5753 END IF
5754 END IF
5755!
5756!-----------------------------------------------------------------------
5757! Process free-surface.
5758!-----------------------------------------------------------------------
5759!
5760 free_surface : IF (lputfsur) THEN
5761 DO m=1,rcontact(cr)%Npoints
5762 i=rcontact(cr)%Irg(m)
5763 j=rcontact(cr)%Jrg(m)
5764 IF (((istrt.le.i).and.(i.le.iendt)).and. &
5765 & ((jstrt.le.j).and.(j.le.jendt))) THEN
5766 my_value=wold*(rcontact(cr)%Lweight(1,m)* &
5767 & refined(cr)%zeta(1,m,told)+ &
5768 & rcontact(cr)%Lweight(2,m)* &
5769 & refined(cr)%zeta(2,m,told)+ &
5770 & rcontact(cr)%Lweight(3,m)* &
5771 & refined(cr)%zeta(3,m,told)+ &
5772 & rcontact(cr)%Lweight(4,m)* &
5773 & refined(cr)%zeta(4,m,told))+ &
5774 & wnew*(rcontact(cr)%Lweight(1,m)* &
5775 & refined(cr)%zeta(1,m,tnew)+ &
5776 & rcontact(cr)%Lweight(2,m)* &
5777 & refined(cr)%zeta(2,m,tnew)+ &
5778 & rcontact(cr)%Lweight(3,m)* &
5779 & refined(cr)%zeta(3,m,tnew)+ &
5780 & rcontact(cr)%Lweight(4,m)* &
5781 & refined(cr)%zeta(4,m,tnew))
5782# ifdef MASKING
5783 my_value=my_value*grid(ng)%rmask(i,j)
5784# endif
5785# ifdef WET_DRY
5786 IF (my_value.le.(dcrit(ng)-grid(ng)%h(i,j))) THEN
5787 my_value=dcrit(ng)-grid(ng)%h(i,j)
5788 END IF
5789# endif
5790# ifdef SOLVE3D
5791 ocean(ng)%zeta(i,j,1)=my_value
5792 ocean(ng)%zeta(i,j,2)=my_value
5793 ocean(ng)%zeta(i,j,3)=my_value
5794 coupling(ng)%Zt_avg1(i,j)=my_value
5795# else
5796 ocean(ng)%zeta(i,j,knew(ng))=my_value
5797# endif
5798 END IF
5799 END DO
5800
5801 ELSE
5802!
5803!-----------------------------------------------------------------------
5804! Process 2D momentum.
5805!-----------------------------------------------------------------------
5806!
5807! Notice that contact points at the domain western, eastern, southern
5808! and northern physical boundaries are avoided for the "kindex" time
5809! record. They are assigned in the mass flux computations below.
5810! This exception is done for adjoint correctness.
5811!
5812# ifdef SOLVE3D
5813 kindex=indx1(ng)
5814# else
5815 kindex=knew(ng)
5816# endif
5817!
5818! 2D momentum in the XI-direction.
5819!
5820 DO m=1,ucontact(cr)%Npoints
5821 i=ucontact(cr)%Irg(m)
5822 j=ucontact(cr)%Jrg(m)
5823 IF (((istrp.le.i).and.(i.le.iendt)).and. &
5824 & ((jstrt.le.j).and.(j.le.jendt))) THEN
5825 my_value=wold*(ucontact(cr)%Lweight(1,m)* &
5826 & refined(cr)%ubar(1,m,told)+ &
5827 & ucontact(cr)%Lweight(2,m)* &
5828 & refined(cr)%ubar(2,m,told)+ &
5829 & ucontact(cr)%Lweight(3,m)* &
5830 & refined(cr)%ubar(3,m,told)+ &
5831 & ucontact(cr)%Lweight(4,m)* &
5832 & refined(cr)%ubar(4,m,told))+ &
5833 & wnew*(ucontact(cr)%Lweight(1,m)* &
5834 & refined(cr)%ubar(1,m,tnew)+ &
5835 & ucontact(cr)%Lweight(2,m)* &
5836 & refined(cr)%ubar(2,m,tnew)+ &
5837 & ucontact(cr)%Lweight(3,m)* &
5838 & refined(cr)%ubar(3,m,tnew)+ &
5839 & ucontact(cr)%Lweight(4,m)* &
5840 & refined(cr)%ubar(4,m,tnew))
5841# ifdef MASKING
5842 my_value=my_value*grid(ng)%umask(i,j)
5843# endif
5844# ifdef WET_DRY
5845 my_value=my_value*grid(ng)%umask_wet(i,j)
5846# endif
5847 uboundary=(m.eq.bry_contact(iwest,cr)%C2Bindex(j)).or. &
5848 & (m.eq.bry_contact(ieast,cr)%C2Bindex(j))
5849# ifdef SOLVE3D
5850 DO irec=1,3
5851 IF(.not.(uboundary.and.(irec.eq.kindex))) THEN
5852 ocean(ng)%ubar(i,j,irec)=my_value
5853!! ELSE ! for debugging
5854!! OCEAN(ng)%ubar(i,j,irec)=0.0_r8 ! purposes
5855 END IF
5856 END DO
5857# else
5858 IF (.not.uboundary) THEN
5859 ocean(ng)%ubar(i,j,knew(ng))=my_value
5860 END IF
5861# endif
5862 END IF
5863 END DO
5864!
5865! 2D momentum in the ETA-direction.
5866!
5867 DO m=1,vcontact(cr)%Npoints
5868 i=vcontact(cr)%Irg(m)
5869 j=vcontact(cr)%Jrg(m)
5870 IF (((istrt.le.i).and.(i.le.iendt)).and. &
5871 & ((jstrp.le.j).and.(j.le.jendt))) THEN
5872 my_value=wold*(vcontact(cr)%Lweight(1,m)* &
5873 & refined(cr)%vbar(1,m,told)+ &
5874 & vcontact(cr)%Lweight(2,m)* &
5875 & refined(cr)%vbar(2,m,told)+ &
5876 & vcontact(cr)%Lweight(3,m)* &
5877 & refined(cr)%vbar(3,m,told)+ &
5878 & vcontact(cr)%Lweight(4,m)* &
5879 & refined(cr)%vbar(4,m,told))+ &
5880 & wnew*(vcontact(cr)%Lweight(1,m)* &
5881 & refined(cr)%vbar(1,m,tnew)+ &
5882 & vcontact(cr)%Lweight(2,m)* &
5883 & refined(cr)%vbar(2,m,tnew)+ &
5884 & vcontact(cr)%Lweight(3,m)* &
5885 & refined(cr)%vbar(3,m,tnew)+ &
5886 & vcontact(cr)%Lweight(4,m)* &
5887 & refined(cr)%vbar(4,m,tnew))
5888# ifdef MASKING
5889 my_value=my_value*grid(ng)%vmask(i,j)
5890# endif
5891# ifdef WET_DRY
5892 my_value=my_value*grid(ng)%vmask_wet(i,j)
5893# endif
5894 vboundary=(m.eq.bry_contact(isouth,cr)%C2Bindex(i)).or. &
5895 & (m.eq.bry_contact(inorth,cr)%C2Bindex(i))
5896# ifdef SOLVE3D
5897 DO irec=1,3
5898 IF (.not.(vboundary.and.(irec.eq.kindex))) THEN
5899 ocean(ng)%vbar(i,j,irec)=my_value
5900!! ELSE ! for debugging
5901!! OCEAN(ng)%vbar(i,j,irec)=0.0_r8 ! purposes
5902 END IF
5903 END DO
5904# else
5905 IF (.not.vboundary) THEN
5906 ocean(ng)%vbar(i,j,knew(ng))=my_value
5907 END IF
5908# endif
5909 END IF
5910 END DO
5911!
5912!-----------------------------------------------------------------------
5913! Impose mass flux at the finer grid physical boundaries. This is only
5914! done for "kindex" time record.
5915!
5916! Western/Eastern boundary:
5917!
5918! ubar(Ibry,:,kindex) = U2d_flux(Ibry,:) * pn(Ibry,:) / D(Ibry,:)
5919!
5920! Southern/Northern boundary:
5921!
5922! vbar(:,Jbry,kindex) = V2d_flux(:,Jbry) * pm(:,Jbry) / D(:,Jbry)
5923!
5924# ifdef SOLVE3D
5925! Notice that in 3D applications, "REFINED(cr)%U2d_flux" and
5926! "REFINED(cr)%V2d_flux" are computed from "DU_avg2" and "DV_avg2d"
5927! state variables, repectively.
5928# else
5929! Notice that in 2D applications, "REFINED(cr)%U2d_flux" and
5930! "REFINED(cr)%V2d_flux" are computed from "DU_flux" and "DV_flux"
5931! state variables, repectively.
5932# endif
5933!
5934! Use the latest coarse grid mass flux REFINED(cr)%U2D_flux(1,:,tnew)
5935! with a linear variation (cff1) to ensure that the sum of the refined
5936! grid fluxes equals the coarse grid flux.
5937!-----------------------------------------------------------------------
5938!
5939! Western edge.
5940!
5941 IF (domain(ng)%Western_Edge(tile)) THEN
5942 DO j=jstr,jend
5943 m=bry_contact(iwest,cr)%C2Bindex(j)
5944 idg=ucontact(cr)%Idg(m) ! for debugging
5945 jdg=ucontact(cr)%Jdg(m) ! purposes
5946 cff=0.5_r8*grid(ng)%on_u(istr,j)* &
5947 (grid(ng)%h(istr-1,j)+ &
5948 & ocean(ng)%zeta(istr-1,j,kindex)+ &
5949 & grid(ng)%h(istr ,j)+ &
5950 & ocean(ng)%zeta(istr ,j,kindex))
5951 cff1=grid(ng)%on_u(istr,j)/refined(cr)%on_u(m)
5952# ifdef TIME_INTERP_FLUX
5953 my_value=cff1*(wold*refined(cr)%U2d_flux(1,m,told)+ &
5954 & wnew*refined(cr)%U2d_flux(1,m,tnew))/cff
5955# else
5956 my_value=cff1*refined(cr)%U2d_flux(1,m,tnew)/cff
5957# endif
5958# ifdef WEC
5959 my_value=my_value-ocean(ng)%ubar_stokes(istr,j)
5960# endif
5961# ifdef MASKING
5962 my_value=my_value*grid(ng)%umask(istr,j)
5963# endif
5964# ifdef WET_DRY
5965 my_value=my_value*grid(ng)%umask_wet(istr,j)
5966# endif
5967# ifdef NESTING_DEBUG
5968 bry_contact(iwest,cr)%Mflux(j)=cff*my_value
5969# endif
5970 ocean(ng)%ubar(istr,j,kindex)=my_value
5971 END DO
5972 END IF
5973!
5974! Eastern edge.
5975!
5976 IF (domain(ng)%Eastern_Edge(tile)) THEN
5977 DO j=jstr,jend
5978 m=bry_contact(ieast,cr)%C2Bindex(j)
5979 idg=ucontact(cr)%Idg(m) ! for debugging
5980 jdg=ucontact(cr)%Jdg(m) ! purposes
5981 cff=0.5_r8*grid(ng)%on_u(iend+1,j)* &
5982 & (grid(ng)%h(iend+1,j)+ &
5983 & ocean(ng)%zeta(iend+1,j,kindex)+ &
5984 & grid(ng)%h(iend ,j)+ &
5985 & ocean(ng)%zeta(iend ,j,kindex))
5986 cff1=grid(ng)%on_u(iend+1,j)/refined(cr)%on_u(m)
5987# ifdef TIME_INTERP_FLUX
5988 my_value=cff1*(wold*refined(cr)%U2d_flux(1,m,told)+ &
5989 & wnew*refined(cr)%U2d_flux(1,m,tnew))/cff
5990# else
5991 my_value=cff1*refined(cr)%U2d_flux(1,m,tnew)/cff
5992# endif
5993# ifdef WEC
5994 my_value=my_value-ocean(ng)%ubar_stokes(iend+1,j)
5995# endif
5996# ifdef MASKING
5997 my_value=my_value*grid(ng)%umask(iend+1,j)
5998# endif
5999# ifdef WET_DRY
6000 my_value=my_value*grid(ng)%umask_wet(iend+1,j)
6001# endif
6002# ifdef NESTING_DEBUG
6003 bry_contact(ieast,cr)%Mflux(j)=cff*my_value
6004# endif
6005 ocean(ng)%ubar(iend+1,j,kindex)=my_value
6006 END DO
6007 END IF
6008!
6009! Southern edge.
6010!
6011 IF (domain(ng)%Southern_Edge(tile)) THEN
6012 DO i=istr,iend
6013 m=bry_contact(isouth,cr)%C2Bindex(i)
6014 idg=vcontact(cr)%Idg(m) ! for debugging
6015 jdg=vcontact(cr)%Jdg(m) ! purposes
6016 cff=0.5_r8*grid(ng)%om_v(i,jstr)* &
6017 & (grid(ng)%h(i,jstr-1)+ &
6018 & ocean(ng)%zeta(i,jstr-1,kindex)+ &
6019 & grid(ng)%h(i,jstr )+ &
6020 & ocean(ng)%zeta(i,jstr ,kindex))
6021 cff1=grid(ng)%om_v(i,jstr)/refined(cr)%om_v(m)
6022# ifdef TIME_INTERP_FLUX
6023 my_value=cff1*(wold*refined(cr)%V2d_flux(1,m,told)+ &
6024 & wnew*refined(cr)%V2d_flux(1,m,tnew))/cff
6025# else
6026 my_value=cff1*refined(cr)%V2d_flux(1,m,tnew)/cff
6027# endif
6028# ifdef WEC
6029 my_value=my_value-ocean(ng)%vbar_stokes(i,jstr)
6030# endif
6031# ifdef MASKING
6032 my_value=my_value*grid(ng)%vmask(i,jstr)
6033# endif
6034# ifdef WET_DRY
6035 my_value=my_value*grid(ng)%vmask_wet(i,jstr)
6036# endif
6037# ifdef NESTING_DEBUG
6038 bry_contact(isouth,cr)%Mflux(i)=cff*my_value
6039# endif
6040 ocean(ng)%vbar(i,jstr,kindex)=my_value
6041 END DO
6042 END IF
6043!
6044! Northern edge.
6045!
6046 IF (domain(ng)%Northern_Edge(tile)) THEN
6047 DO i=istr,iend
6048 m=bry_contact(inorth,cr)%C2Bindex(i)
6049 idg=vcontact(cr)%Idg(m) ! for debugging
6050 jdg=vcontact(cr)%Jdg(m) ! purposes
6051 cff=0.5_r8*grid(ng)%om_v(i,jend+1)* &
6052 & (grid(ng)%h(i,jend+1)+ &
6053 & ocean(ng)%zeta(i,jend+1,kindex)+ &
6054 & grid(ng)%h(i,jend )+ &
6055 & ocean(ng)%zeta(i,jend ,kindex))
6056 cff1=grid(ng)%om_v(i,jend+1)/refined(cr)%om_v(m)
6057# ifdef TIME_INTERP_FLUX
6058 my_value=cff1*(wold*refined(cr)%V2d_flux(1,m,told)+ &
6059 & wnew*refined(cr)%V2d_flux(1,m,tnew))/cff
6060# else
6061 my_value=cff1*refined(cr)%V2d_flux(1,m,tnew)/cff
6062# endif
6063# ifdef WEC
6064 my_value=my_value-ocean(ng)%vbar_stokes(i,jend+1)
6065# endif
6066# ifdef MASKING
6067 my_value=my_value*grid(ng)%vmask(i,jend+1)
6068# endif
6069# ifdef WET_DRY
6070 my_value=my_value*grid(ng)%vmask_wet(i,jend+1)
6071# endif
6072# ifdef NESTING_DEBUG
6073 bry_contact(inorth,cr)%Mflux(i)=cff*my_value
6074# endif
6075 ocean(ng)%vbar(i,jend+1,kindex)=my_value
6076 END DO
6077 END IF
6078
6079 END IF free_surface
6080
6081# ifdef DISTRIBUTE
6082!
6083!-----------------------------------------------------------------------
6084! Exchange tile information.
6085!-----------------------------------------------------------------------
6086!
6087! Free-surface.
6088!
6089 IF (lputfsur) THEN
6090# ifdef SOLVE3D
6091 CALL mp_exchange2d (ng, tile, model, 4, &
6092 & lbi, ubi, lbj, ubj, &
6093 & nghostpoints, &
6094 & ewperiodic(ng), nsperiodic(ng), &
6095 & coupling(ng)%Zt_avg1, &
6096 & ocean(ng)%zeta(:,:,1), &
6097 & ocean(ng)%zeta(:,:,2), &
6098 & ocean(ng)%zeta(:,:,3))
6099# else
6100 CALL mp_exchange2d (ng, tile, model, 1, &
6101 & lbi, ubi, lbj, ubj, &
6102 & nghostpoints, &
6103 & ewperiodic(ng), nsperiodic(ng), &
6104 & ocean(ng)%zeta(:,:,knew(ng)))
6105# endif
6106!
6107! 2D momentum.
6108!
6109 ELSE
6110# ifdef SOLVE3D
6111 CALL mp_exchange2d (ng, tile, model, 3, &
6112 & lbi, ubi, lbj, ubj, &
6113 & nghostpoints, &
6114 & ewperiodic(ng), nsperiodic(ng), &
6115 & ocean(ng)%ubar(:,:,1), &
6116 & ocean(ng)%ubar(:,:,2), &
6117 & ocean(ng)%ubar(:,:,3))
6118
6119 CALL mp_exchange2d (ng, tile, model, 3, &
6120 & lbi, ubi, lbj, ubj, &
6121 & nghostpoints, &
6122 & ewperiodic(ng), nsperiodic(ng), &
6123 & ocean(ng)%vbar(:,:,1), &
6124 & ocean(ng)%vbar(:,:,2), &
6125 & ocean(ng)%vbar(:,:,3))
6126# else
6127 CALL mp_exchange2d (ng, tile, model, 2, &
6128 & lbi, ubi, lbj, ubj, &
6129 & nghostpoints, &
6130 & ewperiodic(ng), nsperiodic(ng), &
6131 & ocean(ng)%ubar(:,:,knew(ng)), &
6132 & ocean(ng)%vbar(:,:,knew(ng)))
6133# endif
6134
6135# ifdef NESTING_DEBUG
6136!
6137 CALL mp_assemble (ng, model, nptswe, spv, &
6138 & bry_contact(iwest ,cr)%Mflux(jlb:))
6139 CALL mp_assemble (ng, model, nptswe, spv, &
6140 & bry_contact(ieast ,cr)%Mflux(jlb:))
6141 CALL mp_assemble (ng, model, nptssn, spv, &
6142 & bry_contact(isouth,cr)%Mflux(ilb:))
6143 CALL mp_assemble (ng, model, nptssn, spv, &
6144 & bry_contact(inorth,cr)%Mflux(ilb:))
6145# endif
6146 END IF
6147# endif
6148!
6149 10 FORMAT (/,' PUT_REFINE2D - unbounded contact points temporal: ', &
6150 & ' interpolation:', &
6151 & /,2x, 'cr = ',i2.2, &
6152 & 8x,'dg = ',i2.2, &
6153 & 8x,'ng = ',i2.2, &
6154 & /,2x, 'iic(dg) = ',i7.7, &
6155 & 3x,'told = ',i1, &
6156 & 9x,'tnew = ',i1, &
6157 & /,2x, 'iic(ng) = ',i7.7, &
6158 & 3x,'Wold = ',f8.5, &
6159 & 2x,'Wnew = ',f8.5, &
6160 & /,2x, 'time(ng) = ',i7.7, &
6161 & 3x,'time(told) = ',i7.7, &
6162 & 3x,'time(tnew) = ',i7.7)
6163!
6164 RETURN
mod_scalars::indx1
integer, dimension(:), allocatable indx1
Definition mod_scalars.F:248

References mod_param::bounds, mod_nesting::bry_contact, mod_coupling::coupling, mod_scalars::dcrit, mod_param::domain, mod_scalars::ewperiodic, mod_scalars::exit_flag, strings_mod::founderror(), mod_grid::grid, mod_scalars::ieast, mod_scalars::iic, mod_scalars::indx1, mod_scalars::inorth, mod_scalars::isouth, mod_scalars::iwest, mod_stepping::knew, mod_parallel::master, mp_exchange_mod::mp_exchange2d(), mod_param::nghostpoints, mod_scalars::noerror, mod_scalars::nsperiodic, mod_ocean::ocean, mod_nesting::rcontact, mod_nesting::refined, mod_nesting::rollingindex, mod_nesting::rollingtime, mod_iounits::stdout, mod_scalars::time, mod_nesting::ucontact, and mod_nesting::vcontact.

Referenced by put_refine().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ put_refine3d()

subroutine, private nesting_mod::put_refine3d ( integer, intent(in) ng,
integer, intent(in) dg,
integer, intent(in) cr,
integer, intent(in) model,
integer, intent(in) tile,
integer, intent(in) lbi,
integer, intent(in) ubi,
integer, intent(in) lbj,
integer, intent(in) ubj )
private

Definition at line 6169 of file nesting.F.

6171!
6172!=======================================================================
6173! !
6174! This routine interpolates (space, time) refinement grid 3D state !
6175! variables contact points using data from the donor grid. !
6176! !
6177! On Input: !
6178! !
6179! ng Refinement (receiver) grid number (integer) !
6180! dg Donor grid number (integer) !
6181! cr Contact region number to process (integer) !
6182! model Calling model identifier (integer) !
6183! tile Domain tile partition (integer) !
6184! LBi Receiver grid, I-dimension Lower bound (integer) !
6185! UBi Receiver grid, I-dimension Upper bound (integer) !
6186! LBj Receiver grid, J-dimension Lower bound (integer) !
6187! UBj Receiver grid, J-dimension Upper bound (integer) !
6188! !
6189! On Output: OCEAN(ng) structure !
6190! !
6191! t Updated tracer-type variables !
6192! u Updated 3D momentum in the XI-direction !
6193! v Updated 3D momentum in the ETA-direction !
6194! !
6195!=======================================================================
6196!
6197 USE mod_param
6198 USE mod_parallel
6199 USE mod_grid
6200 USE mod_nesting
6201 USE mod_ocean
6202 USE mod_scalars
6203 USE mod_stepping
6204 USE mod_iounits
6205
6206# ifdef DISTRIBUTE
6207!
6208 USE mp_exchange_mod, ONLY : mp_exchange3d, mp_exchange4d
6209# endif
6210 USE strings_mod, ONLY : founderror
6211!
6212! Imported variable declarations.
6213!
6214 integer, intent(in) :: ng, dg, cr, model, tile
6215 integer, intent(in) :: LBi, UBi, LBj, UBj
6216!
6217! Local variable declarations.
6218!
6219# ifdef NESTING_DEBUG
6220 logical, save :: first = .true.
6221!
6222# endif
6223 integer :: i, itrc, j, k, m, tnew, told
6224!
6225 real(dp) :: Wnew, Wold, SecScale, fac
6226 real(r8) :: my_value
6227!
6228 character (len=*), parameter :: MyFile = &
6229 & __FILE__//", put_refined3d"
6230
6231# include "set_bounds.h"
6232!
6233!-----------------------------------------------------------------------
6234! Interpolate (space, time) refinement grid contact points for 2D state
6235! variables from donor grid.
6236!-----------------------------------------------------------------------
6237!
6238! Set time snapshot indices for the donor grid data.
6239!
6240 told=3-rollingindex(cr)
6241 tnew=rollingindex(cr)
6242!
6243! Set linear time interpolation weights. Fractional seconds are
6244! rounded to the nearest milliseconds integer towards zero in the
6245! time interpolation weights.
6246!
6247 secscale=1000.0_dp ! seconds to milliseconds
6248!
6249 wold=anint((rollingtime(tnew,cr)-time(ng))*secscale,dp)
6250 wnew=anint((time(ng)-rollingtime(told,cr))*secscale,dp)
6251 fac=1.0_dp/(wold+wnew)
6252 wold=fac*wold
6253 wnew=fac*wnew
6254!
6255 IF (((wold*wnew).lt.0.0_dp).or.((wold+wnew).le.0.0_dp)) THEN
6256 IF (domain(ng)%SouthWest_Test(tile)) THEN
6257 IF (master) THEN
6258 WRITE (stdout,10) cr, dg, ng, &
6259 & iic(dg), told, tnew, &
6260 & iic(ng), wold, wnew, &
6261 & int(time(ng)), &
6262 & int(rollingtime(told,cr)), &
6263 & int(rollingtime(tnew,cr))
6264 END IF
6265 exit_flag=8
6266 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6267 END IF
6268 END IF
6269
6270# ifdef NESTING_DEBUG
6271!
6272! If debugging, write information into Fortran unit 200 to check the
6273! logic of interpolating from donor grid data.
6274!
6275 IF (domain(ng)%SouthWest_Test(tile)) THEN
6276 IF (master) THEN
6277 IF (first) THEN
6278 first=.false.
6279 WRITE (200,20)
6280 END IF
6281 WRITE (200,30) cr, dg, ng, iic(dg), iic(ng), told, tnew, &
6282 & int(time(ng)), &
6283 & int(rollingtime(told,cr)), &
6284 & int(rollingtime(tnew,cr)), &
6285 & wold, wnew
6286 20 FORMAT (3x,'cr',3x,'dg',3x,'ng',3x,'iic',2x,'iic',1x,'told', &
6287 & 1x,'tnew',3x,'time',3x,'time',3x,'time',5x,'Wold', &
6288 & 7x,'Wnew',/,17x,'(dg)',1x,'(ng)',13x,'(ng)',3x, &
6289 & 'told',3x,'tnew',/)
6290 30 FORMAT (7i5,3i7,2f11.4)
6291 FLUSH (200)
6292 END IF
6293 END IF
6294# endif
6295!
6296! Tracer-type variables.
6297!
6298 DO m=1,rcontact(cr)%Npoints
6299 i=rcontact(cr)%Irg(m)
6300 j=rcontact(cr)%Jrg(m)
6301 IF (((istrt.le.i).and.(i.le.iendt)).and. &
6302 & ((jstrt.le.j).and.(j.le.jendt))) THEN
6303 DO itrc=1,nt(ng)
6304 DO k=1,n(ng)
6305 my_value=wold* &
6306 & (rcontact(cr)%Lweight(1,m)* &
6307 & refined(cr)%t(1,k,m,told,itrc)+ &
6308 & rcontact(cr)%Lweight(2,m)* &
6309 & refined(cr)%t(2,k,m,told,itrc)+ &
6310 & rcontact(cr)%Lweight(3,m)* &
6311 & refined(cr)%t(3,k,m,told,itrc)+ &
6312 & rcontact(cr)%Lweight(4,m)* &
6313 & refined(cr)%t(4,k,m,told,itrc))+ &
6314 & wnew* &
6315 & (rcontact(cr)%Lweight(1,m)* &
6316 & refined(cr)%t(1,k,m,tnew,itrc)+ &
6317 & rcontact(cr)%Lweight(2,m)* &
6318 & refined(cr)%t(2,k,m,tnew,itrc)+ &
6319 & rcontact(cr)%Lweight(3,m)* &
6320 & refined(cr)%t(3,k,m,tnew,itrc)+ &
6321 & rcontact(cr)%Lweight(4,m)* &
6322 & refined(cr)%t(4,k,m,tnew,itrc))
6323# ifdef MASKING
6324 my_value=my_value*grid(ng)%rmask(i,j)
6325# endif
6326 ocean(ng)%t(i,j,k,1,itrc)=my_value
6327 ocean(ng)%t(i,j,k,2,itrc)=my_value
6328 ocean(ng)%t(i,j,k,3,itrc)=my_value
6329 END DO
6330 END DO
6331 END IF
6332 END DO
6333!
6334! 3D momentum in the XI-direction.
6335!
6336 DO m=1,ucontact(cr)%Npoints
6337 i=ucontact(cr)%Irg(m)
6338 j=ucontact(cr)%Jrg(m)
6339 IF (((istrp.le.i).and.(i.le.iendt)).and. &
6340 & ((jstrt.le.j).and.(j.le.jendt))) THEN
6341 DO k=1,n(ng)
6342 my_value=wold* &
6343 & (ucontact(cr)%Lweight(1,m)* &
6344 & refined(cr)%u(1,k,m,told)+ &
6345 & ucontact(cr)%Lweight(2,m)* &
6346 & refined(cr)%u(2,k,m,told)+ &
6347 & ucontact(cr)%Lweight(3,m)* &
6348 & refined(cr)%u(3,k,m,told)+ &
6349 & ucontact(cr)%Lweight(4,m)* &
6350 & refined(cr)%u(4,k,m,told))+ &
6351 & wnew* &
6352 & (ucontact(cr)%Lweight(1,m)* &
6353 & refined(cr)%u(1,k,m,tnew)+ &
6354 & ucontact(cr)%Lweight(2,m)* &
6355 & refined(cr)%u(2,k,m,tnew)+ &
6356 & ucontact(cr)%Lweight(3,m)* &
6357 & refined(cr)%u(3,k,m,tnew)+ &
6358 & ucontact(cr)%Lweight(4,m)* &
6359 & refined(cr)%u(4,k,m,tnew))
6360# ifdef MASKING
6361 my_value=my_value*grid(ng)%umask(i,j)
6362# endif
6363 ocean(ng)%u(i,j,k,1)=my_value
6364 ocean(ng)%u(i,j,k,2)=my_value
6365 END DO
6366 END IF
6367 END DO
6368!
6369! 3D momentum in the ETA-direction.
6370!
6371 DO m=1,vcontact(cr)%Npoints
6372 i=vcontact(cr)%Irg(m)
6373 j=vcontact(cr)%Jrg(m)
6374 IF (((istrt.le.i).and.(i.le.iendt)).and. &
6375 & ((jstrp.le.j).and.(j.le.jendt))) THEN
6376 DO k=1,n(ng)
6377 my_value=wold* &
6378 & (vcontact(cr)%Lweight(1,m)* &
6379 & refined(cr)%v(1,k,m,told)+ &
6380 & vcontact(cr)%Lweight(2,m)* &
6381 & refined(cr)%v(2,k,m,told)+ &
6382 & vcontact(cr)%Lweight(3,m)* &
6383 & refined(cr)%v(3,k,m,told)+ &
6384 & vcontact(cr)%Lweight(4,m)* &
6385 & refined(cr)%v(4,k,m,told))+ &
6386 & wnew* &
6387 & (vcontact(cr)%Lweight(1,m)* &
6388 & refined(cr)%v(1,k,m,tnew)+ &
6389 & vcontact(cr)%Lweight(2,m)* &
6390 & refined(cr)%v(2,k,m,tnew)+ &
6391 & vcontact(cr)%Lweight(3,m)* &
6392 & refined(cr)%v(3,k,m,tnew)+ &
6393 & vcontact(cr)%Lweight(4,m)* &
6394 & refined(cr)%v(4,k,m,tnew))
6395# ifdef MASKING
6396 my_value=my_value*grid(ng)%vmask(i,j)
6397# endif
6398 ocean(ng)%v(i,j,k,1)=my_value
6399 ocean(ng)%v(i,j,k,2)=my_value
6400 END DO
6401 END IF
6402 END DO
6403
6404# ifdef DISTRIBUTE
6405!
6406!-----------------------------------------------------------------------
6407! Exchange tile information.
6408!-----------------------------------------------------------------------
6409!
6410 CALL mp_exchange4d (ng, tile, model, 3, &
6411 & lbi, ubi, lbj, ubj, 1, n(ng), 1, nt(ng), &
6412 & nghostpoints, &
6413 & ewperiodic(ng), nsperiodic(ng), &
6414 & ocean(ng)%t(:,:,:,1,:), &
6415 & ocean(ng)%t(:,:,:,2,:), &
6416 & ocean(ng)%t(:,:,:,3,:))
6417
6418 CALL mp_exchange3d (ng, tile, model, 4, &
6419 & lbi, ubi, lbj, ubj, 1, n(ng), &
6420 & nghostpoints, &
6421 & ewperiodic(ng), nsperiodic(ng), &
6422 & ocean(ng)%u(:,:,:,1), &
6423 & ocean(ng)%u(:,:,:,2), &
6424 & ocean(ng)%v(:,:,:,1), &
6425 & ocean(ng)%v(:,:,:,2))
6426# endif
6427!
6428 10 FORMAT (/,' PUT_REFINE3D - unbounded contact points temporal: ', &
6429 & ' interpolation:', &
6430 & /,2x, 'cr = ',i2.2, &
6431 & 8x,'dg = ',i2.2, &
6432 & 8x,'ng = ',i2.2, &
6433 & /,2x, 'iic(dg) = ',i7.7, &
6434 & 3x,'told = ',i1, &
6435 & 9x,'tnew = ',i1, &
6436 & /,2x, 'iic(ng) = ',i7.7, &
6437 & 3x,'Wold = ',f8.5, &
6438 & 2x,'Wnew = ',f8.5, &
6439 & /,2x, 'time(ng) = ',i7.7, &
6440 & 3x,'time(told) = ',i7.7, &
6441 & 3x,'time(tnew) = ',i7.7)
6442!
6443 RETURN

References mod_param::domain, mod_scalars::ewperiodic, mod_scalars::exit_flag, strings_mod::founderror(), mod_grid::grid, mod_scalars::iic, mod_parallel::master, mp_exchange_mod::mp_exchange3d(), mp_exchange_mod::mp_exchange4d(), mod_param::n, mod_param::nghostpoints, mod_scalars::noerror, mod_scalars::nsperiodic, mod_param::nt, mod_ocean::ocean, mod_nesting::rcontact, mod_nesting::refined, mod_nesting::rollingindex, mod_nesting::rollingtime, mod_iounits::stdout, mod_scalars::time, mod_nesting::ucontact, and mod_nesting::vcontact.

Referenced by put_refine().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ z_weights()

subroutine, public nesting_mod::z_weights ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) tile )

Definition at line 6449 of file nesting.F.

6450!
6451!=======================================================================
6452! !
6453! This routine determines the vertical indices and interpolation !
6454! weights associated with depth, which are needed to process 3D !
6455! fields in the contact region. !
6456! !
6457! On Input: !
6458! !
6459! model Calling model identifier (integer) !
6460! tile Domain partition for composite grid ng (integer) !
6461! !
6462! On Output: Updated T_NGC type structures in mod_param: !
6463! !
6464! Rcontact Updated values for Kdg(:,:) and Vweigths (:,:,:) !
6465! Ucontact Updated values for Kdg(:,:) and Vweigths (:,:,:) !
6466! Vcontact Updated values for Kdg(:,:) and Vweigths (:,:,:) !
6467! !
6468!=======================================================================
6469!
6470 USE mod_param
6471 USE mod_grid
6472 USE mod_nesting
6473 USE mod_scalars
6474!
6475# ifdef DISTRIBUTE
6476 USE distribute_mod, ONLY : mp_assemble
6477# endif
6478 USE strings_mod, ONLY : founderror
6479!
6480! Imported variable declarations.
6481!
6482 integer, intent(in) :: ng, model, tile
6483!
6484! Local variable declarations.
6485!
6486 integer :: cr, dg, rg, i, j, k, m
6487 integer :: Idg, Jdg, Kdg, IminD, ImaxD, JminD, JmaxD
6488 integer :: Irg, Jrg, Krg, IminR, ImaxR, JminR, JmaxR
6489 integer :: Idgm1, Idgp1, Jdgm1, Jdgp1
6490 integer :: Npoints
6491# ifdef DISTRIBUTE
6492 integer :: Nkpts, Nwpts, Nzpts
6493
6494 integer, parameter :: ispv = 0
6495# endif
6496!
6497 real(r8), parameter :: spv = 0.0_r8
6498
6499 real(r8) :: Zbot, Zr, Ztop, dz, r1, r2
6500
6501 real(r8), allocatable :: Zd(:,:,:)
6502!
6503 character (len=*), parameter :: MyFile = &
6504 & __FILE__//", z_weights"
6505!
6506!=======================================================================
6507! Compute vertical indices and weights for each contact region.
6508!=======================================================================
6509!
6510 DO cr=1,ncontact
6511!
6512! Get donor and receiver grid numbers.
6513!
6514 dg=rcontact(cr)%donor_grid
6515 rg=rcontact(cr)%receiver_grid
6516!
6517! Process only contact region data for requested nested grid "ng".
6518!
6519 IF (rg.eq.ng) THEN
6520!
6521!-----------------------------------------------------------------------
6522! Process variables in structure Rcontact(cr).
6523!-----------------------------------------------------------------------
6524!
6525! Get number of contact points to process.
6526!
6527 npoints=rcontact(cr)%Npoints
6528!
6529! Set starting and ending tile indices for the donor and receiver
6530! grids.
6531!
6532 imind=bounds(dg) % IstrT(tile)
6533 imaxd=bounds(dg) % IendT(tile)
6534 jmind=bounds(dg) % JstrT(tile)
6535 jmaxd=bounds(dg) % JendT(tile)
6536!
6537 iminr=bounds(rg) % IstrT(tile)
6538 imaxr=bounds(rg) % IendT(tile)
6539 jminr=bounds(rg) % JstrT(tile)
6540 jmaxr=bounds(rg) % JendT(tile)
6541
6542# ifdef DISTRIBUTE
6543!
6544! If distributed-memory, initialize with special value (zero) to
6545! facilitate the global reduction when collecting data between all
6546! nodes.
6547!
6548 nkpts=n(rg)*npoints
6549 nwpts=2*nkpts
6550 nzpts=4*nkpts
6551
6552 rcontact(cr)%Kdg(1:n(rg),1:npoints)=ispv
6553 rcontact(cr)%Vweight(1:2,1:n(rg),1:npoints)=spv
6554# endif
6555!
6556! If coincident grids and requested, avoid vertical interpolation.
6557!
6558 r_contact : IF (.not.rcontact(cr)%interpolate.and. &
6559 & rcontact(cr)%coincident) THEN
6560 DO krg=1,n(rg)
6561 DO m=1,npoints
6562 irg=rcontact(cr)%Irg(m)
6563 jrg=rcontact(cr)%Jrg(m)
6564 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
6565 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
6566 rcontact(cr)%Kdg(krg,m)=krg
6567 rcontact(cr)%Vweight(1,krg,m)=1.0_r8
6568 rcontact(cr)%Vweight(2,krg,m)=0.0_r8
6569 END IF
6570 END DO
6571 END DO
6572!
6573! Otherwise, vertically interpolate because donor and receiver grids
6574! are not coincident.
6575!
6576 ELSE
6577!
6578! Allocate and initialize local working arrays.
6579!
6580 IF (.not.allocated(zd)) THEN
6581 allocate ( zd(4,n(dg),npoints) )
6582 END IF
6583 zd=spv
6584!
6585! Extract donor grid depths for each cell containing the receiver grid
6586! contact point. Notice that indices i+1 and j+1 are bounded to the
6587! maximum possible values in contact points at the edge of the contact
6588! region. In such cases, Lweight(1,m)=1 and Lweight(2:3,m)=0. This is
6589! done to avoid out of range errors. We need to take care of this in
6590! the adjoint code.
6591!
6592 DO kdg=1,n(dg)
6593 DO m=1,npoints
6594 idg =rcontact(cr)%Idg(m)
6595 idgp1=min(idg+1, bounds(dg)%UBi(-1))
6596 jdg =rcontact(cr)%Jdg(m)
6597 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
6598 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
6599 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
6600 zd(1,kdg,m)=grid(dg)%z_r(idg ,jdg ,kdg)
6601 zd(2,kdg,m)=grid(dg)%z_r(idgp1,jdg ,kdg)
6602 zd(3,kdg,m)=grid(dg)%z_r(idgp1,jdgp1,kdg)
6603 zd(4,kdg,m)=grid(dg)%z_r(idg ,jdgp1,kdg)
6604 END IF
6605 END DO
6606 END DO
6607
6608# ifdef DISTRIBUTE
6609!
6610! Exchange data between all parallel nodes.
6611!
6612 CALL mp_assemble (dg, model, nzpts, spv, zd)
6613 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6614# endif
6615!
6616! Determine donor grid vertical indices (Kdg) and weights (Vweight)
6617! needed for the interpolation of data at the receiver grid contact
6618! points.
6619!
6620 DO krg=1,n(rg)
6621 DO m=1,npoints
6622 irg=rcontact(cr)%Irg(m)
6623 jrg=rcontact(cr)%Jrg(m)
6624 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
6625 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
6626 ztop=rcontact(cr)%Lweight(1,m)*zd(1,n(dg),m)+ &
6627 & rcontact(cr)%Lweight(2,m)*zd(2,n(dg),m)+ &
6628 & rcontact(cr)%Lweight(3,m)*zd(3,n(dg),m)+ &
6629 & rcontact(cr)%Lweight(4,m)*zd(4,n(dg),m)
6630 zbot=rcontact(cr)%Lweight(1,m)*zd(1,1 ,m)+ &
6631 & rcontact(cr)%Lweight(2,m)*zd(2,1 ,m)+ &
6632 & rcontact(cr)%Lweight(3,m)*zd(3,1 ,m)+ &
6633 & rcontact(cr)%Lweight(4,m)*zd(4,1 ,m)
6634 zr=grid(rg)%z_r(irg,jrg,krg)
6635 IF (zr.ge.ztop) THEN ! If shallower, use top
6636 rcontact(cr)%Kdg(krg,m)=n(dg)! donor grid cell value
6637 rcontact(cr)%Vweight(1,krg,m)=0.0_r8
6638 rcontact(cr)%Vweight(2,krg,m)=1.0_r8
6639 ELSE IF (zbot.ge.zr) THEN ! If deeper, use bottom
6640 rcontact(cr)%Kdg(krg,m)=1 ! donor grid cell value
6641 rcontact(cr)%Vweight(1,krg,m)=0.0_r8
6642 rcontact(cr)%Vweight(2,krg,m)=1.0_r8
6643 ELSE ! bounded, interpolate
6644 DO kdg=n(dg),2,-1
6645 ztop=rcontact(cr)%Lweight(1,m)*zd(1,kdg ,m)+ &
6646 & rcontact(cr)%Lweight(2,m)*zd(2,kdg ,m)+ &
6647 & rcontact(cr)%Lweight(3,m)*zd(3,kdg ,m)+ &
6648 & rcontact(cr)%Lweight(4,m)*zd(4,kdg ,m)
6649 zbot=rcontact(cr)%Lweight(1,m)*zd(1,kdg-1,m)+ &
6650 & rcontact(cr)%Lweight(2,m)*zd(2,kdg-1,m)+ &
6651 & rcontact(cr)%Lweight(3,m)*zd(3,kdg-1,m)+ &
6652 & rcontact(cr)%Lweight(4,m)*zd(4,kdg-1,m)
6653 IF ((ztop.gt.zr).and.(zr.ge.zbot)) THEN
6654 dz=ztop-zbot
6655 r2=(zr-zbot)/dz
6656 r1=1.0_r8-r2
6657 rcontact(cr)%Kdg(krg,m)=kdg
6658 rcontact(cr)%Vweight(1,krg,m)=r1
6659 rcontact(cr)%Vweight(2,krg,m)=r2
6660 END IF
6661 END DO
6662 END IF
6663 END IF
6664 END DO
6665 END DO
6666 END IF r_contact
6667
6668# ifdef DISTRIBUTE
6669!
6670! Exchange data between all parallel nodes.
6671!
6672 CALL mp_assemble (rg, model, nkpts, ispv, rcontact(cr)%Kdg)
6673 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6674
6675 CALL mp_assemble (rg, model, nwpts, spv, rcontact(cr)%Vweight)
6676 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6677# endif
6678!
6679! Deallocate local work arrays.
6680!
6681 IF (allocated(zd)) THEN
6682 deallocate (zd)
6683 END IF
6684!
6685!-----------------------------------------------------------------------
6686! Process variables in structure Ucontact(cr).
6687!-----------------------------------------------------------------------
6688!
6689! Get number of contact points to process.
6690!
6691 npoints=ucontact(cr)%Npoints
6692!
6693! Set starting and ending tile indices for the donor and receiver
6694! grids.
6695!
6696 imind=bounds(dg) % IstrP(tile)
6697 imaxd=bounds(dg) % IendT(tile)
6698 jmind=bounds(dg) % JstrT(tile)
6699 jmaxd=bounds(dg) % JendT(tile)
6700!
6701 iminr=bounds(rg) % IstrP(tile)
6702 imaxr=bounds(rg) % IendT(tile)
6703 jminr=bounds(rg) % JstrT(tile)
6704 jmaxr=bounds(rg) % JendT(tile)
6705
6706# ifdef DISTRIBUTE
6707!
6708! If distributed-memory, initialize with special value (zero) to
6709! facilitate the global reduction when collecting data between all
6710! nodes.
6711!
6712 nkpts=n(rg)*npoints
6713 nwpts=2*nkpts
6714 nzpts=4*nkpts
6715
6716 ucontact(cr)%Kdg(1:n(rg),1:npoints)=ispv
6717 ucontact(cr)%Vweight(1:2,1:n(rg),1:npoints)=spv
6718# endif
6719!
6720! If coincident grids and requested, avoid vertical interpolation.
6721!
6722 u_contact : IF (.not.ucontact(cr)%interpolate.and. &
6723 & ucontact(cr)%coincident) THEN
6724 DO krg=1,n(rg)
6725 DO m=1,npoints
6726 irg=ucontact(cr)%Irg(m)
6727 jrg=ucontact(cr)%Jrg(m)
6728 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
6729 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
6730 ucontact(cr)%Kdg(krg,m)=krg
6731 ucontact(cr)%Vweight(1,krg,m)=1.0_r8
6732 ucontact(cr)%Vweight(2,krg,m)=0.0_r8
6733 END IF
6734 END DO
6735 END DO
6736!
6737! Otherwise, vertically interpolate because donor and receiver grids
6738! are not coincident.
6739!
6740 ELSE
6741!
6742! Allocate and initialize local working arrays.
6743!
6744 IF (.not.allocated(zd)) THEN
6745 allocate (zd(4,n(dg),npoints))
6746 END IF
6747 zd=spv
6748!
6749! Extract donor grid depths for each cell containing the receiver grid
6750! contact point. Notice that indices i-1, i+1 and j-1, j+1 are bounded
6751! the minimum/maximum possible values in contact points at the edge of
6752! the contact region. In such cases, the interpolation weights
6753! Lweight(1,m)=1 and Lweight(2:3,m)=0. This is done to avoid out of
6754! range errors. We need to take care of this in the adjoint code.
6755!
6756 DO kdg=1,n(dg)
6757 DO m=1,npoints
6758 idg =ucontact(cr)%Idg(m)
6759 idgm1=max(idg-1, bounds(dg)%LBi(-1))
6760 idgp1=min(idg+1, bounds(dg)%UBi(-1))
6761 jdg =ucontact(cr)%Jdg(m)
6762 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
6763 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
6764 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
6765 zd(1,kdg,m)=0.5_r8*(grid(dg)%z_r(idgm1,jdg ,kdg)+ &
6766 & grid(dg)%z_r(idg ,jdg ,kdg))
6767 zd(2,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdg ,kdg)+ &
6768 & grid(dg)%z_r(idgp1,jdg ,kdg))
6769 zd(3,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdgp1,kdg)+ &
6770 & grid(dg)%z_r(idgp1,jdgp1,kdg))
6771 zd(4,kdg,m)=0.5_r8*(grid(dg)%z_r(idgm1,jdgp1,kdg)+ &
6772 & grid(dg)%z_r(idg ,jdgp1,kdg))
6773 END IF
6774 END DO
6775 END DO
6776
6777# ifdef DISTRIBUTE
6778!
6779! Exchange data between all parallel nodes.
6780!
6781 CALL mp_assemble (dg, model, nzpts, spv, zd)
6782 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6783# endif
6784!
6785! Determine donor grid vertical indices (Kdg) and weights (Vweight)
6786! needed for the interpolation of data at the receiver grid contact
6787! points.
6788!
6789 DO krg=1,n(rg)
6790 DO m=1,npoints
6791 irg=ucontact(cr)%Irg(m)
6792 jrg=ucontact(cr)%Jrg(m)
6793 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
6794 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
6795 ztop=ucontact(cr)%Lweight(1,m)*zd(1,n(dg),m)+ &
6796 & ucontact(cr)%Lweight(2,m)*zd(2,n(dg),m)+ &
6797 & ucontact(cr)%Lweight(3,m)*zd(3,n(dg),m)+ &
6798 & ucontact(cr)%Lweight(4,m)*zd(4,n(dg),m)
6799 zbot=ucontact(cr)%Lweight(1,m)*zd(1,1 ,m)+ &
6800 & ucontact(cr)%Lweight(2,m)*zd(2,1 ,m)+ &
6801 & ucontact(cr)%Lweight(3,m)*zd(3,1 ,m)+ &
6802 & ucontact(cr)%Lweight(4,m)*zd(4,1 ,m)
6803 zr=0.5_r8*(grid(rg)%z_r(irg ,jrg,krg)+ &
6804 & grid(rg)%z_r(irg-1,jrg,krg))
6805 IF (zr.ge.ztop) THEN ! If shallower, use top
6806 ucontact(cr)%Kdg(krg,m)=n(dg)! donor grid cell value
6807 ucontact(cr)%Vweight(1,krg,m)=0.0_r8
6808 ucontact(cr)%Vweight(2,krg,m)=1.0_r8
6809 ELSE IF (zbot.ge.zr) THEN ! If deeper, use bottom
6810 ucontact(cr)%Kdg(krg,m)=1 ! donor grid cell value
6811 ucontact(cr)%Vweight(1,krg,m)=0.0_r8
6812 ucontact(cr)%Vweight(2,krg,m)=1.0_r8
6813 ELSE ! bounded, interpolate
6814 DO kdg=n(dg),2,-1
6815 ztop=ucontact(cr)%Lweight(1,m)*zd(1,kdg ,m)+ &
6816 & ucontact(cr)%Lweight(2,m)*zd(2,kdg ,m)+ &
6817 & ucontact(cr)%Lweight(3,m)*zd(3,kdg ,m)+ &
6818 & ucontact(cr)%Lweight(4,m)*zd(4,kdg ,m)
6819 zbot=ucontact(cr)%Lweight(1,m)*zd(1,kdg-1,m)+ &
6820 & ucontact(cr)%Lweight(2,m)*zd(2,kdg-1,m)+ &
6821 & ucontact(cr)%Lweight(3,m)*zd(3,kdg-1,m)+ &
6822 & ucontact(cr)%Lweight(4,m)*zd(4,kdg-1,m)
6823 IF ((ztop.gt.zr).and.(zr.ge.zbot)) THEN
6824 dz=ztop-zbot
6825 r2=(zr-zbot)/dz
6826 r1=1.0_r8-r2
6827 ucontact(cr)%Kdg(krg,m)=kdg
6828 ucontact(cr)%Vweight(1,krg,m)=r1
6829 ucontact(cr)%Vweight(2,krg,m)=r2
6830 END IF
6831 END DO
6832 END IF
6833 END IF
6834 END DO
6835 END DO
6836 END IF u_contact
6837
6838# ifdef DISTRIBUTE
6839!
6840! Exchange data between all parallel nodes.
6841!
6842 CALL mp_assemble (rg, model, nkpts, ispv, ucontact(cr)%Kdg)
6843 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6844
6845 CALL mp_assemble (rg, model, nwpts, spv, ucontact(cr)%Vweight)
6846 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6847# endif
6848!
6849! Deallocate local work arrays.
6850!
6851 IF (allocated(zd)) THEN
6852 deallocate (zd)
6853 END IF
6854!
6855!-----------------------------------------------------------------------
6856! Process variables in structure Vcontact(cr).
6857!-----------------------------------------------------------------------
6858!
6859! Get number of contact points to process.
6860!
6861 npoints=vcontact(cr)%Npoints
6862!
6863! Set starting and ending tile indices for the donor and receiver
6864! grids.
6865!
6866 imind=bounds(dg) % IstrT(tile)
6867 imaxd=bounds(dg) % IendT(tile)
6868 jmind=bounds(dg) % JstrP(tile)
6869 jmaxd=bounds(dg) % JendT(tile)
6870!
6871 iminr=bounds(rg) % IstrT(tile)
6872 imaxr=bounds(rg) % IendT(tile)
6873 jminr=bounds(rg) % JstrP(tile)
6874 jmaxr=bounds(rg) % JendT(tile)
6875
6876# ifdef DISTRIBUTE
6877!
6878! If distributed-memory, initialize with special value (zero) to
6879! facilitate the global reduction when collecting data between all
6880! nodes.
6881!
6882 nkpts=n(rg)*npoints
6883 nwpts=2*nkpts
6884 nzpts=4*nkpts
6885
6886 vcontact(cr)%Kdg(1:n(rg),1:npoints)=ispv
6887 vcontact(cr)%Vweight(1:2,1:n(rg),1:npoints)=spv
6888# endif
6889!
6890! If coincident grids and requested, avoid vertical interpolation.
6891!
6892 v_contact : IF (.not.vcontact(cr)%interpolate.and. &
6893 & vcontact(cr)%coincident) THEN
6894 DO krg=1,n(rg)
6895 DO m=1,npoints
6896 irg=vcontact(cr)%Irg(m)
6897 jrg=vcontact(cr)%Jrg(m)
6898 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
6899 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
6900 vcontact(cr)%Kdg(krg,m)=krg
6901 vcontact(cr)%Vweight(1,krg,m)=1.0_r8
6902 vcontact(cr)%Vweight(2,krg,m)=0.0_r8
6903 END IF
6904 END DO
6905 END DO
6906!
6907! Otherwise, vertically interpolate because donor and receiver grids
6908! are not coincident.
6909!
6910 ELSE
6911!
6912! Allocate and initialize local working arrays.
6913!
6914 IF (.not.allocated(zd)) THEN
6915 allocate (zd(4,n(dg),npoints))
6916 END IF
6917 zd=spv
6918!
6919! Extract donor grid depths for each cell containing the receiver grid
6920! contact point.
6921!
6922 DO kdg=1,n(dg)
6923 DO m=1,npoints
6924 idg=vcontact(cr)%Idg(m)
6925 idgp1=min(idg+1, bounds(dg)%UBi(-1))
6926 jdg=vcontact(cr)%Jdg(m)
6927 jdgm1=max(jdg-1, bounds(dg)%LBj(-1))
6928 jdgp1=min(jdg+1, bounds(dg)%UBj(-1))
6929 IF (((imind.le.idg).and.(idg.le.imaxd)).and. &
6930 & ((jmind.le.jdg).and.(jdg.le.jmaxd))) THEN
6931 zd(1,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdgm1,kdg)+ &
6932 & grid(dg)%z_r(idg ,jdg ,kdg))
6933 zd(2,kdg,m)=0.5_r8*(grid(dg)%z_r(idgp1,jdgm1,kdg)+ &
6934 & grid(dg)%z_r(idgp1,jdg ,kdg))
6935 zd(3,kdg,m)=0.5_r8*(grid(dg)%z_r(idgp1,jdg ,kdg)+ &
6936 & grid(dg)%z_r(idgp1,jdgp1,kdg))
6937 zd(4,kdg,m)=0.5_r8*(grid(dg)%z_r(idg ,jdg ,kdg)+ &
6938 & grid(dg)%z_r(idg ,jdgp1,kdg))
6939 END IF
6940 END DO
6941 END DO
6942
6943# ifdef DISTRIBUTE
6944!
6945! Exchange data between all parallel nodes.
6946!
6947 CALL mp_assemble (dg, model, nzpts, spv, zd)
6948 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6949# endif
6950!
6951! Determine donor grid vertical indices (Kdg) and weights (Vweight)
6952! needed for the interpolation of data at the receiver grid contact
6953! points.
6954!
6955 DO krg=1,n(rg)
6956 DO m=1,npoints
6957 irg=vcontact(cr)%Irg(m)
6958 jrg=vcontact(cr)%Jrg(m)
6959 IF (((iminr.le.irg).and.(irg.le.imaxr)).and. &
6960 & ((jminr.le.jrg).and.(jrg.le.jmaxr))) THEN
6961 ztop=vcontact(cr)%Lweight(1,m)*zd(1,n(dg),m)+ &
6962 & vcontact(cr)%Lweight(2,m)*zd(2,n(dg),m)+ &
6963 & vcontact(cr)%Lweight(3,m)*zd(3,n(dg),m)+ &
6964 & vcontact(cr)%Lweight(4,m)*zd(4,n(dg),m)
6965 zbot=vcontact(cr)%Lweight(1,m)*zd(1,1 ,m)+ &
6966 & vcontact(cr)%Lweight(2,m)*zd(2,1 ,m)+ &
6967 & vcontact(cr)%Lweight(3,m)*zd(3,1 ,m)+ &
6968 & vcontact(cr)%Lweight(4,m)*zd(4,1 ,m)
6969 zr=0.5_r8*(grid(rg)%z_r(irg,jrg ,krg)+ &
6970 & grid(rg)%z_r(irg,jrg-1,krg))
6971 IF (zr.ge.ztop) THEN ! If shallower, use top
6972 vcontact(cr)%Kdg(krg,m)=n(dg)! donor grid cell value
6973 vcontact(cr)%Vweight(1,krg,m)=0.0_r8
6974 vcontact(cr)%Vweight(2,krg,m)=1.0_r8
6975 ELSE IF (zbot.ge.zr) THEN ! If deeper, use bottom
6976 vcontact(cr)%Kdg(krg,m)=1 ! donor grid cell value
6977 vcontact(cr)%Vweight(1,krg,m)=0.0_r8
6978 vcontact(cr)%Vweight(2,krg,m)=1.0_r8
6979 ELSE ! bounded, interpolate
6980 DO kdg=n(dg),2,-1
6981 ztop=vcontact(cr)%Lweight(1,m)*zd(1,kdg ,m)+ &
6982 & vcontact(cr)%Lweight(2,m)*zd(2,kdg ,m)+ &
6983 & vcontact(cr)%Lweight(3,m)*zd(3,kdg ,m)+ &
6984 & vcontact(cr)%Lweight(4,m)*zd(4,kdg ,m)
6985 zbot=vcontact(cr)%Lweight(1,m)*zd(1,kdg-1,m)+ &
6986 & vcontact(cr)%Lweight(2,m)*zd(2,kdg-1,m)+ &
6987 & vcontact(cr)%Lweight(3,m)*zd(3,kdg-1,m)+ &
6988 & vcontact(cr)%Lweight(4,m)*zd(4,kdg-1,m)
6989 IF ((ztop.gt.zr).and.(zr.ge.zbot)) THEN
6990 dz=ztop-zbot
6991 r2=(zr-zbot)/dz
6992 r1=1.0_r8-r2
6993 vcontact(cr)%Kdg(krg,m)=kdg
6994 vcontact(cr)%Vweight(1,krg,m)=r1
6995 vcontact(cr)%Vweight(2,krg,m)=r2
6996 END IF
6997 END DO
6998 END IF
6999 END IF
7000 END DO
7001 END DO
7002 END IF v_contact
7003
7004# ifdef DISTRIBUTE
7005!
7006! Exchange data between all parallel nodes.
7007!
7008 CALL mp_assemble (rg, model, nkpts, ispv, vcontact(cr)%Kdg)
7009 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7010
7011 CALL mp_assemble (rg, model, nwpts, spv, vcontact(cr)%Vweight)
7012 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
7013# endif
7014!
7015! Deallocate local work arrays.
7016!
7017 IF (allocated(zd)) THEN
7018 deallocate (zd)
7019 END IF
7020
7021 END IF
7022 END DO
7023!
7024 RETURN

References mod_param::bounds, mod_scalars::exit_flag, strings_mod::founderror(), mod_grid::grid, mod_param::n, mod_nesting::ncontact, mod_scalars::noerror, mod_nesting::rcontact, mod_nesting::ucontact, and mod_nesting::vcontact.

Referenced by ad_nesting_mod::ad_nesting(), and nesting().

Here is the call graph for this function:
Here is the caller graph for this function: