ROMS
Loading...
Searching...
No Matches
Macros | Functions/Subroutines
packing.F File Reference
#include "cppdefs.h"
#include "tile.h"
#include "set_bounds.h"
Include dependency graph for packing.F:

Go to the source code of this file.

Macros

#define ENERGYNORM_SCALE
 
#define IR_RANGE   IstrT,IendT
 
#define IU_RANGE   IstrP,IendT
 
#define JR_RANGE   JstrT,JendT
 
#define JV_RANGE   JstrP,JendT
 

Functions/Subroutines

program __packing_f__
 
subroutine c_norm2 (ng, model, mstr, mend, evaluer, evaluei, evectorr, evectori, state, norm2)
 
subroutine r_norm2 (ng, model, mstr, mend, evalue, evector, state, norm2)
 
subroutine ad_pack (ng, tile, mstr, mend, ad_state)
 
subroutine ad_pack_tile (ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kstp, nstp, mstr, mend, ad_state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, f_t, f_u, f_v, ad_stflx, f_ubar, f_vbar, f_zeta, ad_sustr, ad_svstr)
 
subroutine ad_unpack (ng, tile, mstr, mend, state)
 
subroutine ad_unpack_tile (ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kout, nout, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, mstr, mend, state)
 
subroutine tl_pack (ng, tile, mstr, mend, tl_state)
 
subroutine tl_pack_tile (ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, krhs, kstp, knew, nstp, mstr, mend, tl_state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, tl_t, tl_u, tl_v, tl_zeta)
 
subroutine tl_unpack (ng, tile, mstr, mend, state)
 
subroutine tl_unpack_tile (ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kstp, nstp, mstr, mend, state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, tl_t, tl_u, tl_v, tl_zeta, tl_stflx, tl_sustr, tl_svstr)
 
subroutine so_semi_white (ng, tile, mstr, mend, state, ad_state)
 
subroutine so_semi_red (ng, tile, mstr, mend, state, ad_state)
 
subroutine sp_bcoef (ng, ntad, nttl, bcoef)
 
subroutine sp_acoef (ng, ntad, nttl, acoef)
 
real(r8) function sp_autoc (ng, idf)
 

Macro Definition Documentation

◆ ENERGYNORM_SCALE

#define ENERGYNORM_SCALE

◆ IR_RANGE

#define IR_RANGE   IstrT,IendT

◆ IU_RANGE

#define IU_RANGE   IstrP,IendT

◆ JR_RANGE

#define JR_RANGE   JstrT,JendT

◆ JV_RANGE

#define JV_RANGE   JstrP,JendT

Function/Subroutine Documentation

◆ __packing_f__()

program __packing_f__

Definition at line 4 of file packing.F.

References ad_pack(), ad_unpack(), c_norm2(), r_norm2(), so_semi_red(), so_semi_white(), tl_pack(), and tl_unpack().

Here is the call graph for this function:

◆ ad_pack()

subroutine __packing_f__::ad_pack ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(out) ad_state )
private

Definition at line 340 of file packing.F.

341!
342!=======================================================================
343! !
344! This routine packs the adjoint variables into the state vector. !
345! The state vector contains only interior water points. !
346! !
347!=======================================================================
348!
349 USE mod_param
350 USE mod_forces
351 USE mod_grid
352 USE mod_ocean
353 USE mod_stepping
354# ifdef DISTRIBUTE
355 USE mod_storage
356# endif
357# ifdef DISTRIBUTE
358!
359 USE distribute_mod, ONLY : mp_scatter_state
360# endif
361!
362! Imported variable declarations.
363!
364 integer, intent(in) :: ng, tile
365 integer, intent(in) :: Mstr, Mend
366# ifdef ASSUMED_SHAPE
367 real(r8), intent(out) :: ad_state(Mstr:)
368# else
369 real(r8), intent(out) :: ad_state(Mstr:Mend)
370# endif
371!
372! Local variable declarations.
373!
374 character (len=*), parameter :: MyFile = &
375 & __FILE__//", ad_pack"
376!
377# include "tile.h"
378!
379# ifdef PROFILE
380 CALL wclock_on (ng, iadm, 2, __line__, myfile)
381# endif
382
383 CALL ad_pack_tile (ng, tile, &
384 & lbi, ubi, lbj, ubj, &
385 & imins, imaxs, jmins, jmaxs, &
386 & kstp(ng), &
387# ifdef SOLVE3D
388 & nstp(ng), &
389# endif
390# ifdef DISTRIBUTE
391 & 1, mstate(ng), swork, &
392# else
393 & mstr, mend, ad_state, &
394# endif
395# ifdef MASKING
396 & grid(ng) % IJwaterR, &
397 & grid(ng) % IJwaterU, &
398 & grid(ng) % IJwaterV, &
399 & grid(ng) % rmask, &
400 & grid(ng) % umask, &
401 & grid(ng) % vmask, &
402# endif
403 & grid(ng) % h, &
404# ifdef SOLVE3D
405 & grid(ng) % Hz, &
406 & ocean(ng) % f_t, &
407 & ocean(ng) % f_u, &
408 & ocean(ng) % f_v, &
409 & forces(ng) % ad_stflx, &
410# endif
411 & ocean(ng) % f_ubar, &
412 & ocean(ng) % f_vbar, &
413 & ocean(ng) % f_zeta, &
414 & forces(ng) % ad_sustr, &
415 & forces(ng) % ad_svstr)
416
417# ifdef PROFILE
418 CALL wclock_off (ng, iadm, 2, __line__, myfile)
419# endif
420
421# ifdef DISTRIBUTE
422!
423! Scatter (global to threaded) adjoint state solution to all
424! distributed nodes.
425!
426 CALL mp_scatter_state (ng, iadm, mstr, mend, mstate(ng), &
427 & swork, ad_state)
428# endif
429!
430 RETURN
distribute_mod
Definition distribute.F:3
distribute_mod::mp_scatter_state
subroutine mp_scatter_state(ng, model, mstr, mend, asize, a, awrk)
Definition distribute.F:8502
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_param
Definition mod_param.F:2
mod_param::mstate
integer, dimension(:), allocatable mstate
Definition mod_param.F:644
mod_param::iadm
integer, parameter iadm
Definition mod_param.F:665
mod_stepping
Definition mod_stepping.F:2
mod_stepping::kstp
integer, dimension(:), allocatable kstp
Definition mod_stepping.F:66
mod_stepping::nstp
integer, dimension(:), allocatable nstp
Definition mod_stepping.F:71
mod_storage
Definition mod_storage.F:2
mod_storage::swork
real(r8), dimension(:), allocatable swork
Definition mod_storage.F:132
ad_pack_tile
subroutine ad_pack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kstp, nstp, mstr, mend, ad_state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, f_t, f_u, f_v, ad_stflx, f_ubar, f_vbar, f_zeta, ad_sustr, ad_svstr)
Definition packing.F:453
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 ad_pack_tile(), mod_forces::forces, mod_grid::grid, mod_param::iadm, mod_stepping::kstp, distribute_mod::mp_scatter_state(), mod_param::mstate, mod_stepping::nstp, mod_ocean::ocean, mod_storage::swork, wclock_off(), and wclock_on().

Referenced by __packing_f__(), ad_main3d(), propagator_mod::propagator_afte(), propagator_mod::propagator_fsv(), and propagator_mod::propagator_op().

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

◆ ad_pack_tile()

subroutine __packing_f__::ad_pack_tile ( integer, intent(in) ng,
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,
integer, intent(in) kstp,
integer, intent(in) nstp,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(out) ad_state,
integer, dimension(lbi:,lbj:), intent(in) ijwaterr,
integer, dimension(lbi:,lbj:), intent(in) ijwateru,
integer, dimension(lbi:,lbj:), intent(in) ijwaterv,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbi:,lbj:), intent(in) h,
real(r8), dimension(lbi:,lbj:,:), intent(in) hz,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) f_t,
real(r8), dimension(lbi:,lbj:,:), intent(inout) f_u,
real(r8), dimension(lbi:,lbj:,:), intent(inout) f_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) ad_stflx,
real(r8), dimension(lbi:,lbj:), intent(inout) f_ubar,
real(r8), dimension(lbi:,lbj:), intent(inout) f_vbar,
real(r8), dimension(lbi:,lbj:), intent(inout) f_zeta,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_sustr,
real(r8), dimension(lbi:,lbj:), intent(inout) ad_svstr )
private

Definition at line 434 of file packing.F.

453!***********************************************************************
454!
455 USE mod_param
456 USE mod_parallel
457 USE mod_forces
458 USE mod_ncparam
459 USE mod_scalars
460 USE mod_ocean
461!
462# ifdef FORCING_SV
463 USE ad_exchange_2d_mod
464# ifdef SOLVE3D
465 USE ad_exchange_3d_mod
466# endif
467# ifdef DISTRIBUTE
468 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
469# ifdef SOLVE3D
470 USE mp_exchange_mod, ONLY : ad_mp_exchange3d, ad_mp_exchange4d
471# endif
472# endif
473# endif
474!
475! Imported variable declarations.
476!
477 integer, intent(in) :: ng, tile
478 integer, intent(in) :: LBi, UBi, LBj, UBj
479 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
480 integer, intent(in) :: Mstr, Mend
481 integer, intent(in) :: kstp
482# ifdef SOLVE3D
483 integer, intent(in) :: nstp
484# endif
485!
486# ifdef ASSUMED_SHAPE
487# ifdef MASKING
488 integer, intent(in) :: IJwaterR(LBi:,LBj:)
489 integer, intent(in) :: IJwaterU(LBi:,LBj:)
490 integer, intent(in) :: IJwaterV(LBi:,LBj:)
491
492 real(r8), intent(in) :: rmask(LBi:,LBj:)
493 real(r8), intent(in) :: umask(LBi:,LBj:)
494 real(r8), intent(in) :: vmask(LBi:,LBj:)
495# endif
496 real(r8), intent(in) :: h(LBi:,LBj:)
497# ifdef SOLVE3D
498 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
499
500 real(r8), intent(inout) :: f_t(LBi:,LBj:,:,:)
501 real(r8), intent(inout) :: f_u(LBi:,LBj:,:)
502 real(r8), intent(inout) :: f_v(LBi:,LBj:,:)
503 real(r8), intent(inout) :: ad_stflx(LBi:,LBj:,:)
504# endif
505 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
506 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
507 real(r8), intent(inout) :: f_zeta(LBi:,LBj:)
508 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
509 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
510 real(r8), intent(out) :: ad_state(Mstr:)
511# else
512# ifdef MASKING
513 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
514 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
515 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
516
517 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
518 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
519 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
520# endif
521 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
522# ifdef SOLVE3D
523 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
524
525 real(r8), intent(inout) :: f_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
526 real(r8), intent(inout) :: f_u(LBi:UBi,LBj:UBj,N(ng))
527 real(r8), intent(inout) :: f_v(LBi:UBi,LBj:UBj,N(ng))
528 real(r8), intent(inout) :: ad_stflx(LBi:UBi,LBj:UBj,NT(ng))
529# endif
530 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
531 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
532 real(r8), intent(inout) :: f_zeta(LBi:UBi,LBj:UBj)
533 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
534 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
535 real(r8), intent(out) :: ad_state(Mstr:Mend)
536# endif
537!
538! Local variable declarations.
539!
540# ifndef MASKING
541 integer :: Imax, Ioff, Jmax, Joff
542# endif
543 integer :: Uoff, Voff
544 integer :: i, iadd, icount, is, itrc, j, k
545
546# ifdef SALINITY
547 integer, dimension(7+2*NT(ng)) :: offset
548# else
549 integer, dimension(7+2*(NT(ng)+1)) :: offset
550# endif
551
552 real(r8), parameter :: Aspv = 0.0_r8
553
554 real(r8) :: cff, scale
555
556# ifdef SOLVE3D
557 real(r8) :: cff1, cff2
558 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CF
559 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC
560# endif
561
562# include "set_bounds.h"
563
564# ifdef DISTRIBUTE
565!
566!-----------------------------------------------------------------------
567! Initialize adjoint state vector with special value (zero) to
568! facilitate gathering/scattering communications between all nodes.
569! This is achieved by summing all the buffers.
570!-----------------------------------------------------------------------
571!
572 DO is=mstr,mend
573 ad_state(is)=aspv
574 END DO
575# endif
576
577# ifdef FORCING_SV
578!
579! Impose adjoint periodic boundary conditions as appropriate.
580!
581# ifdef DISTRIBUTE
582 CALL ad_mp_exchange2d (ng, tile, iadm, 1, &
583 & lbi, ubi, lbj, ubj, &
584 & nghostpoints, &
585 & ewperiodic(ng), nsperiodic(ng), &
586 & f_zeta)
587# ifndef SOLVE3D
588 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
589 & lbi, ubi, lbj, ubj, &
590 & nghostpoints, &
591 & ewperiodic(ng), nsperiodic(ng), &
592 & f_ubar, f_vbar)
593# else
594 CALL ad_mp_exchange3d (ng, tile, iadm, 2, &
595 & lbi, ubi, lbj, ubj, 1, n(ng), &
596 & nghostpoints, &
597 & ewperiodic(ng), nsperiodic(ng), f_u, f_v)
598 CALL ad_mp_exchange4d (ng, tile, iadm, 1, &
599 & lbi, ubi, lbj, ubj, 1, n(ng), 1, nt(ng), &
600 & nghostpoints, &
601 & ewperiodic(ng), nsperiodic(ng), f_t)
602# endif
603# endif
604!
605 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
606 CALL ad_exchange_r2d_tile (ng, tile, &
607 & lbi, ubi, lbj, ubj, f_zeta)
608# ifndef SOLVE3D
609 CALL ad_exchange_u2d_tile (ng, tile, &
610 & lbi, ubi, lbj, ubj, f_ubar)
611 CALL ad_exchange_v2d_tile (ng, tile, &
612 & lbi, ubi, lbj, ubj, f_vbar)
613# else
614 CALL ad_exchange_u3d_tile (ng, tile, &
615 & lbi, ubi, lbj, ubj, 1, n(ng), f_u)
616 CALL ad_exchange_v3d_tile (ng, tile, &
617 & lbi, ubi, lbj, ubj, 1, n(ng), f_v)
618 DO itrc=1,nt(ng)
619 CALL ad_exchange_r3d_tile (ng, tile, &
620 & lbi, ubi, lbj, ubj, 1, n(ng), &
621 & f_t(:,:,:,itrc))
622 END DO
623# endif
624 END IF
625
626# endif
627!
628!-----------------------------------------------------------------------
629! Load adjoint STATE variables into full 1D state vector.
630!-----------------------------------------------------------------------
631!
632! Set offsets for momentum variables due to periodic boundary
633! conditions. Recall that in East-West periodic boundary conditions
634! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
635! applications IstrV=1 or else IstrV=2.
636!
637 IF (ewperiodic(ng)) THEN
638 uoff=0
639 ELSE
640 uoff=1
641 END IF
642!
643 IF (nsperiodic(ng)) THEN
644 voff=0
645 ELSE
646 voff=1
647 END IF
648!
649! Determine the index offset for each variable in the state vector.
650# ifdef MASKING
651! Notice that in Land/Sea masking application the state vector only
652! contains water points to avoid large null space.
653# endif
654!
655! First clear the "offset" array.
656!
657 offset=0
658!
659# ifdef SOLVE3D
660# ifdef MASKING
661 IF (scalars(ng)%Fstate(isfsur)) THEN
662 offset(isfsur)=0
663 END IF
664 IF (scalars(ng)%Fstate(isuvel)) THEN
665 offset(isuvel)=offset(isfsur)+nwaterr(ng)
666 END IF
667 IF (scalars(ng)%Fstate(isvvel)) THEN
668 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
669 END IF
670 iadd=nwaterv(ng)*n(ng)
671 DO itrc=1,nt(ng)
672 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
673 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
674 iadd=nwaterr(ng)*n(ng)
675 END IF
676 END DO
677 IF (scalars(ng)%Fstate(isustr)) THEN
678 offset(isustr)=0
679 END IF
680 IF (scalars(ng)%Fstate(isvstr)) THEN
681 offset(isvstr)=offset(isustr)+nwateru(ng)
682 END IF
683 DO itrc=1,nt(ng)
684 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
685 IF (itrc.eq.1) THEN
686 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
687 ELSE
688 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
689 END IF
690 END IF
691 END DO
692# else
693# ifdef FULL_GRID
694 IF (scalars(ng)%Fstate(isfsur)) THEN
695 offset(isfsur)=0
696 END IF
697 IF (scalars(ng)%Fstate(isuvel)) THEN
698 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
699 END IF
700 IF (scalars(ng)%Fstate(isvvel)) THEN
701 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
702 END IF
703 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
704 DO itrc=1,nt(ng)
705 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
706 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
707 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
708 END IF
709 END DO
710 IF (scalars(ng)%Fstate(isustr)) THEN
711 offset(isustr)=0
712 END IF
713 IF (scalars(ng)%Fstate(isvstr)) THEN
714 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
715 END IF
716 DO itrc=1,nt(ng)
717 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
718 IF (itrc.eq.1) THEN
719 offset(istsur(itrc))=offset(isvstr)+ &
720 & (lm(ng)+2)*(mm(ng)+1)
721 ELSE
722 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
723 & (lm(ng)+2)*(mm(ng)+2)
724 END IF
725 END IF
726 END DO
727# else
728 IF (scalars(ng)%Fstate(isfsur)) THEN
729 offset(isfsur)=0
730 END IF
731 IF (scalars(ng)%Fstate(isuvel)) THEN
732 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
733 END IF
734 IF (scalars(ng)%Fstate(isvvel)) THEN
735 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
736 END IF
737 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
738 DO itrc=1,nt(ng)
739 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
740 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
741 iadd=lm(ng)*mm(ng)*n(ng)
742 END IF
743 END DO
744 IF (scalars(ng)%Fstate(isustr)) THEN
745 offset(isustr)=0
746 END IF
747 IF (scalars(ng)%Fstate(isvstr)) THEN
748 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
749 END IF
750 DO itrc=1,nt(ng)
751 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
752 IF (itrc.eq.1) THEN
753 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
754 ELSE
755 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
756 END IF
757 END IF
758 END DO
759# endif
760# endif
761# else
762# ifdef MASKING
763 IF (scalars(ng)%Fstate(isfsur)) THEN
764 offset(isfsur)=0
765 END IF
766 IF (scalars(ng)%Fstate(isubar)) THEN
767 offset(isubar)=offset(isfsur)+nwaterr(ng)
768 END IF
769 IF (scalars(ng)%Fstate(isvbar)) THEN
770 offset(isvbar)=offset(isubar)+nwateru(ng)
771 END IF
772 IF (scalars(ng)%Fstate(isustr)) THEN
773 offset(isustr)=0
774 END IF
775 IF (scalars(ng)%Fstate(isvstr)) THEN
776 offset(isvstr)=offset(isustr)+nwateru(ng)
777 END IF
778# else
779# ifdef FULL_GRID
780 IF (scalars(ng)%Fstate(isfsur)) THEN
781 offset(isfsur)=0
782 END IF
783 IF (scalars(ng)%Fstate(isubar)) THEN
784 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
785 END IF
786 IF (scalars(ng)%Fstate(isvbar) THEN
787 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
788 END IF
789 IF (scalars(ng)%Fstate(isustr)) THEN
790 offset(isustr)=0
791 END IF
792 IF (scalars(ng)%Fstate(isvstr)) THEN
793 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
794 END IF
795# else
796 IF (scalars(ng)%Fstate(isfsur)) THEN
797 offset(isfsur)=0
798 END IF
799 IF (scalars(ng)%Fstate(isubar)) THEN
800 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
801 END IF
802 IF (scalars(ng)%Fstate(isvbar) THEN
803 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
804 END IF
805 IF (scalars(ng)%Fstate(isustr)) THEN
806 offset(isustr)=0
807 END IF
808 IF (scalars(ng)%Fstate(isustr)) THEN
809 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
810 END IF
811# endif
812# endif
813# endif
814!
815! Load adjoint of free-surface.
816!
817 IF (scalars(ng)%Fstate(isfsur)) THEN
818# ifndef MASKING
819# ifdef FULL_GRID
820 imax=lm(ng)+2
821 ioff=1
822 joff=0
823# else
824 imax=lm(ng)
825 ioff=0
826 joff=1
827# endif
828# endif
829# ifdef ENERGYNORM_SCALE
830 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
831# else
832 scale=1.0_r8
833# endif
834 DO j=jr_range
835 DO i=ir_range
836# ifdef MASKING
837 IF (rmask(i,j).gt.0.0_r8) THEN
838 is=ijwaterr(i,j)+offset(isfsur)
839 ad_state(is)=scale*f_zeta(i,j)
840 f_zeta(i,j)=0.0_r8
841 ELSE
842 f_zeta(i,j)=0.0_r8
843 END IF
844# else
845 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
846 ad_state(is)=scale*f_zeta(i,j)
847 f_zeta(i,j)=0.0_r8
848# endif
849 END DO
850 END DO
851 END IF
852
853# ifndef SOLVE3D
854!
855! Load adjoint of 2D U-velocity.
856!
857 IF (scalars(ng)%Fstate(isubar)) THEN
858# ifndef MASKING
859# ifdef FULL_GRID
860 imax=lm(ng)+1
861 ioff=0
862 joff=0
863# else
864 imax=lm(ng)-uoff
865 ioff=uoff
866 joff=1
867# endif
868# endif
869# ifdef ENERGYNORM_SCALE
870 cff=0.25_r8*rho0
871# else
872 scale=1.0_r8
873# endif
874 DO j=jr_range
875 DO i=iu_range
876# ifdef ENERGYNORM_SCALE
877 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
878# endif
879# ifdef MASKING
880 IF (umask(i,j).gt.0.0_r8) THEN
881 is=ijwateru(i,j)+offset(isubar)
882 ad_state(is)=scale*f_ubar(i,j)
883 f_ubar(i,j)=0.0_r8
884 ELSE
885 f_ubar(i,j)=0.0_r8
886 END IF
887# else
888 is=(i-ioff)+(j-joff)*imax+offset(isubar)
889 ad_state(is)=scale*f_ubar(i,j)
890 f_ubar(i,j)=0.0_r8
891# endif
892 END DO
893 END DO
894 END IF
895!
896! Load adjoint of 2D V-velocity.
897!
898 IF (scalars(ng)%Fstate(isvbar)) THEN
899# ifndef MASKING
900# ifdef FULL_GRID
901 imax=lm(ng)+2
902 ioff=1
903 joff=1
904# else
905 imax=lm(ng)
906 ioff=0
907 joff=1+voff
908# endif
909# endif
910# ifdef ENERGYNORM_SCALE
911 cff=0.25_r8*rho0
912# else
913 scale=1.0_r8
914# endif
915 DO j=jv_range
916 DO i=ir_range
917# ifdef ENERGYNORM_SCALE
918 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
919# endif
920# ifdef MASKING
921 IF (vmask(i,j).gt.0.0_r8) THEN
922 is=ijwaterv(i,j)+offset(isvbar)
923 ad_state(is)=scale*f_vbar(i,j)
924 f_vbar(i,j)=0.0_r8
925 ELSE
926 f_vbar(i,j)=0.0_r8
927 END IF
928# else
929 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
930 ad_state(is)=scale*f_vbar(i,j)
931 f_vbar(i,j)=0.0_r8
932# endif
933 END DO
934 END DO
935 END IF
936
937# else
938!
939! Load adjoint of 3D U-velocity.
940!
941 IF (scalars(ng)%Fstate(isuvel)) THEN
942!
943! Compute the adjoint forcing for tl_ubar based on f_u.
944!
945 DO j=jr_range
946 DO i=iu_range
947 dc(i,0)=0.0_r8
948 cf(i,0)=0.0_r8
949 END DO
950 DO k=1,n(ng)
951 DO i=iu_range
952 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i-1,j,k))
953 dc(i,0)=dc(i,0)+dc(i,k)
954 END DO
955 END DO
956 DO i=iu_range
957 cff2=f_ubar(i,j)
958 f_ubar(i,j)=0.0_r8
959# ifdef MASKING
960 cff2=cff2*umask(i,j)
961# endif
962 cff1=1.0_r8/dc(i,0)
963 cf(i,0)=cff2*cff1
964 cff2=0.0_r8
965 END DO
966 DO k=1,n(ng)
967 DO i=iu_range
968 f_u(i,j,k)=f_u(i,j,k)+dc(i,k)*cf(i,0)
969 END DO
970 END DO
971 DO i=iu_range
972 cf(i,0)=0.0_r8
973 END DO
974 END DO
975# ifndef MASKING
976# ifdef FULL_GRID
977 imax=lm(ng)+1
978 jmax=mm(ng)+2
979 ioff=0
980 joff=0
981# else
982 imax=lm(ng)-uoff
983 jmax=mm(ng)
984 ioff=uoff
985 joff=1
986# endif
987# endif
988# ifdef ENERGYNORM_SCALE
989 cff=0.25_r8*rho0
990# else
991 scale=1.0_r8
992# endif
993 DO k=1,n(ng)
994# ifdef MASKING
995 iadd=(k-1)*nwateru(ng)+offset(isuvel)
996# else
997 iadd=(k-1)*imax*jmax+offset(isuvel)
998# endif
999 DO j=jr_range
1000 DO i=iu_range
1001# ifdef ENERGYNORM_SCALE
1002 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
1003# endif
1004# ifdef MASKING
1005 IF (umask(i,j).gt.0.0_r8) THEN
1006 is=ijwateru(i,j)+iadd
1007 ad_state(is)=scale*f_u(i,j,k)
1008 f_u(i,j,k)=0.0_r8
1009 ELSE
1010 f_u(i,j,k)=0.0_r8
1011 END IF
1012# else
1013 is=(i-ioff)+(j-joff)*imax+iadd
1014 ad_state(is)=scale*f_u(i,j,k)
1015 f_u(i,j,k)=0.0_r8
1016# endif
1017 END DO
1018 END DO
1019 END DO
1020 END IF
1021!
1022! Load adjoint of 3D V-velocity.
1023!
1024 IF (scalars(ng)%Fstate(isvvel)) THEN
1025!
1026! Compute the adjoint forcing for tl_vbar based on f_v.
1027!
1028 DO j=jv_range
1029 IF (j.ge.jstrm) THEN
1030 DO i=ir_range
1031 dc(i,0)=0.0_r8
1032 cf(i,0)=0.0_r8
1033 END DO
1034 DO k=1,n(ng)
1035 DO i=ir_range
1036 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i,j-1,k))
1037 dc(i,0)=dc(i,0)+dc(i,k)
1038 END DO
1039 END DO
1040 DO i=ir_range
1041 cff2=f_vbar(i,j)
1042 f_vbar(i,j)=0.0_r8
1043# ifdef MASKING
1044 cff2=cff2*vmask(i,j)
1045# endif
1046 cff1=1.0_r8/dc(i,0)
1047 cf(i,0)=cff2*cff1
1048 cff2=0.0_r8
1049 END DO
1050 DO k=1,n(ng)
1051 DO i=ir_range
1052 f_v(i,j,k)=f_v(i,j,k)+dc(i,k)*cf(i,0)
1053 END DO
1054 END DO
1055 DO i=ir_range
1056 cf(i,0)=0.0_r8
1057 END DO
1058 END IF
1059 END DO
1060# ifndef MASKING
1061# ifdef FULL_GRID
1062 imax=lm(ng)+2
1063 jmax=mm(ng)+1
1064 ioff=1
1065 joff=1
1066# else
1067 imax=lm(ng)
1068 jmax=mm(ng)-voff
1069 ioff=0
1070 joff=1+voff
1071# endif
1072# endif
1073# ifdef ENERGYNORM_SCALE
1074 cff=0.25_r8*rho0
1075# else
1076 scale=1.0_r8
1077# endif
1078 DO k=1,n(ng)
1079# ifdef MASKING
1080 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
1081# else
1082 iadd=(k-1)*imax*jmax+offset(isvvel)
1083# endif
1084 DO j=jv_range
1085 DO i=ir_range
1086# ifdef ENERGYNORM_SCALE
1087 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
1088# endif
1089# ifdef MASKING
1090 IF (vmask(i,j).gt.0.0_r8) THEN
1091 is=ijwaterv(i,j)+iadd
1092 ad_state(is)=scale*f_v(i,j,k)
1093 f_v(i,j,k)=0.0_r8
1094 ELSE
1095 f_v(i,j,k)=0.0_r8
1096 END IF
1097# else
1098 is=(i+ioff)+(j-joff)*imax+iadd
1099 ad_state(is)=scale*f_v(i,j,k)
1100 f_v(i,j,k)=0.0_r8
1101# endif
1102 END DO
1103 END DO
1104 END DO
1105 END IF
1106!
1107! Load adjoint of tracers variables.
1108!
1109 DO itrc=1,nt(ng)
1110 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
1111# ifndef MASKING
1112# ifdef FULL_GRID
1113 imax=lm(ng)+2
1114 jmax=mm(ng)+2
1115 ioff=1
1116 joff=0
1117# else
1118 imax=lm(ng)
1119 jmax=mm(ng)
1120 ioff=0
1121 joff=1
1122# endif
1123# endif
1124# ifdef ENERGYNORM_SCALE
1125 IF (itrc.eq.itemp) THEN
1126 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
1127 ELSE IF (itrc.eq.isalt) THEN
1128 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
1129 ELSE
1130 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
1131 END IF
1132# else
1133 scale=1.0_r8
1134# endif
1135 DO k=1,n(ng)
1136# ifdef MASKING
1137 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
1138# else
1139 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
1140# endif
1141 DO j=jr_range
1142 DO i=ir_range
1143# ifdef ENERGYNORM_SCALE
1144 scale=1.0_r8/sqrt(cff*hz(i,j,k))
1145# endif
1146# ifdef MASKING
1147 IF (rmask(i,j).gt.0.0_r8) THEN
1148 is=ijwaterr(i,j)+iadd
1149 ad_state(is)=scale*f_t(i,j,k,itrc)
1150 f_t(i,j,k,itrc)=0.0_r8
1151 ELSE
1152 f_t(i,j,k,itrc)=0.0_r8
1153 END IF
1154# else
1155 is=(i+ioff)+(j-joff)*imax+iadd
1156 ad_state(is)=scale*f_t(i,j,k,itrc)
1157 f_t(i,j,k,itrc)=0.0_r8
1158# endif
1159 END DO
1160 END DO
1161 END DO
1162 END IF
1163 END DO
1164# endif
1165!
1166! Load adjoint of surface U-stress.
1167!
1168 IF (scalars(ng)%Fstate(isustr)) THEN
1169# ifndef MASKING
1170# ifdef FULL_GRID
1171 imax=lm(ng)+1
1172 ioff=0
1173 joff=0
1174# else
1175 imax=lm(ng)-uoff
1176 ioff=uoff
1177 joff=1
1178# endif
1179# endif
1180 scale=1.0_r8
1181 DO j=jr_range
1182 DO i=iu_range
1183# ifdef MASKING
1184 IF (umask(i,j).gt.0.0_r8) THEN
1185 is=ijwateru(i,j)+offset(isustr)
1186 ad_state(is)=scale*ad_sustr(i,j)
1187 END IF
1188# else
1189 is=(i-ioff)+(j-joff)*imax+offset(isustr)
1190 ad_state(is)=scale*ad_sustr(i,j)
1191# endif
1192 END DO
1193 END DO
1194 END IF
1195!
1196! Load adjoint of surface V-stress.
1197!
1198 IF (scalars(ng)%Fstate(isvstr)) THEN
1199# ifndef MASKING
1200# ifdef FULL_GRID
1201 imax=lm(ng)+2
1202 ioff=1
1203 joff=1
1204# else
1205 imax=lm(ng)
1206 ioff=0
1207 joff=1+voff
1208# endif
1209# endif
1210 scale=1.0_r8
1211 DO j=jv_range
1212 DO i=ir_range
1213# ifdef MASKING
1214 IF (vmask(i,j).gt.0.0_r8) THEN
1215 is=ijwaterv(i,j)+offset(isvstr)
1216 ad_state(is)=scale*ad_svstr(i,j)
1217 END IF
1218# else
1219 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
1220 ad_state(is)=scale*ad_svstr(i,j)
1221# endif
1222 END DO
1223 END DO
1224 END IF
1225
1226# ifdef SOLVE3D
1227!
1228! Load adjoint of surface tracer flux variables.
1229!
1230 DO itrc=1,nt(ng)
1231 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
1232# ifndef MASKING
1233# ifdef FULL_GRID
1234 imax=lm(ng)+2
1235 jmax=mm(ng)+2
1236 ioff=1
1237 joff=0
1238# else
1239 imax=lm(ng)
1240 jmax=mm(ng)
1241 ioff=0
1242 joff=1
1243# endif
1244# endif
1245 scale=1.0_r8
1246 DO j=jr_range
1247 DO i=ir_range
1248# ifdef MASKING
1249 IF (rmask(i,j).gt.0.0_r8) THEN
1250 is=ijwaterr(i,j)+offset(istsur(itrc))
1251 ad_state(is)=scale*ad_stflx(i,j,itrc)
1252 END IF
1253# else
1254 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
1255 ad_state(is)=scale*ad_stflx(i,j,itrc)
1256# endif
1257 END DO
1258 END DO
1259 END IF
1260 END DO
1261# endif
1262!
1263 RETURN
ad_exchange_2d_mod
Definition ad_exchange_2d.F:2
ad_exchange_2d_mod::ad_exchange_u2d_tile
subroutine ad_exchange_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:816
ad_exchange_2d_mod::ad_exchange_v2d_tile
subroutine ad_exchange_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:1201
ad_exchange_2d_mod::ad_exchange_r2d_tile
subroutine ad_exchange_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:431
ad_exchange_3d_mod
Definition ad_exchange_3d.F:2
ad_exchange_3d_mod::ad_exchange_v3d_tile
subroutine ad_exchange_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:1283
ad_exchange_3d_mod::ad_exchange_r3d_tile
subroutine ad_exchange_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:461
ad_exchange_3d_mod::ad_exchange_u3d_tile
subroutine ad_exchange_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:872
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::isvvel
integer isvvel
Definition mod_ncparam.F:507
mod_ncparam::isvbar
integer isvbar
Definition mod_ncparam.F:505
mod_ncparam::nwaterv
integer, dimension(:), allocatable nwaterv
Definition mod_ncparam.F:123
mod_ncparam::isvstr
integer isvstr
Definition mod_ncparam.F:511
mod_ncparam::nwateru
integer, dimension(:), allocatable nwateru
Definition mod_ncparam.F:122
mod_ncparam::istvar
integer, dimension(:), allocatable istvar
Definition mod_ncparam.F:520
mod_ncparam::isuvel
integer isuvel
Definition mod_ncparam.F:506
mod_ncparam::isfsur
integer isfsur
Definition mod_ncparam.F:503
mod_ncparam::isustr
integer isustr
Definition mod_ncparam.F:510
mod_ncparam::isubar
integer isubar
Definition mod_ncparam.F:504
mod_ncparam::istsur
integer, dimension(:), allocatable istsur
Definition mod_ncparam.F:519
mod_ncparam::nwaterr
integer, dimension(:), allocatable nwaterr
Definition mod_ncparam.F:121
mod_parallel
Definition mod_parallel.F:2
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::lm
integer, dimension(:), allocatable lm
Definition mod_param.F:455
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_param::mm
integer, dimension(:), allocatable mm
Definition mod_param.F:456
mod_scalars
Definition mod_scalars.F:2
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::bvf_bak
real(dp) bvf_bak
Definition mod_scalars.F:791
mod_scalars::tcoef
real(r8), dimension(:), allocatable tcoef
Definition mod_scalars.F:732
mod_scalars::isalt
integer isalt
Definition mod_scalars.F:127
mod_scalars::itemp
integer itemp
Definition mod_scalars.F:126
mod_scalars::scalars
type(t_scalars), dimension(:), allocatable scalars
Definition mod_scalars.F:65
mod_scalars::g
real(dp) g
Definition mod_scalars.F:464
mod_scalars::rho0
real(dp) rho0
Definition mod_scalars.F:787
mod_scalars::scoef
real(r8), dimension(:), allocatable scoef
Definition mod_scalars.F:733
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::ad_mp_exchange3d
subroutine ad_mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:5451
mp_exchange_mod::ad_mp_exchange4d
subroutine ad_mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c)
Definition mp_exchange.F:7058
mp_exchange_mod::ad_mp_exchange2d
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:4058

References ad_exchange_2d_mod::ad_exchange_r2d_tile(), ad_exchange_3d_mod::ad_exchange_r3d_tile(), ad_exchange_2d_mod::ad_exchange_u2d_tile(), ad_exchange_3d_mod::ad_exchange_u3d_tile(), ad_exchange_2d_mod::ad_exchange_v2d_tile(), ad_exchange_3d_mod::ad_exchange_v3d_tile(), mp_exchange_mod::ad_mp_exchange2d(), mp_exchange_mod::ad_mp_exchange3d(), mp_exchange_mod::ad_mp_exchange4d(), ad_pack_tile(), mod_iounits::adm, mod_scalars::bvf_bak, mod_scalars::dt, mod_scalars::ewperiodic, mod_scalars::exit_flag, mod_forces::forces, strings_mod::founderror(), mod_scalars::g, mod_grid::grid, mod_param::iadm, mod_ncparam::idfsur, mod_ncparam::idtsur, mod_ncparam::idubar, mod_ncparam::idusms, mod_ncparam::iduvel, mod_ncparam::idvbar, mod_ncparam::idvsms, mod_ncparam::idvvel, mod_ncparam::io_nf90, mod_ncparam::io_pio, mod_pio_netcdf::iodesc_dp_r2dvar, mod_pio_netcdf::iodesc_dp_r3dvar, mod_pio_netcdf::iodesc_dp_u2dvar, mod_pio_netcdf::iodesc_dp_u3dvar, mod_pio_netcdf::iodesc_dp_v2dvar, mod_pio_netcdf::iodesc_dp_v3dvar, mod_pio_netcdf::iodesc_sp_r2dvar, mod_pio_netcdf::iodesc_sp_r3dvar, mod_pio_netcdf::iodesc_sp_u2dvar, mod_pio_netcdf::iodesc_sp_u3dvar, mod_pio_netcdf::iodesc_sp_v2dvar, mod_pio_netcdf::iodesc_sp_v3dvar, mod_iounits::ioerror, mod_scalars::isalt, mod_ncparam::isfsur, mod_ncparam::istsur, mod_ncparam::istvar, mod_ncparam::isubar, mod_ncparam::isustr, mod_ncparam::isuvel, mod_ncparam::isvbar, mod_ncparam::isvstr, mod_ncparam::isvvel, mod_scalars::itemp, mod_stepping::kstp, mod_param::lm, mod_parallel::master, mod_param::mm, distribute_mod::mp_scatter_state(), mod_param::mstate, mod_param::n, mod_scalars::nadj, mod_param::nghostpoints, mod_scalars::nintervals, mod_scalars::nsperiodic, mod_stepping::nstp, mod_param::nt, mod_scalars::ntimes, mod_ncparam::nwaterr, mod_ncparam::nwateru, mod_ncparam::nwaterv, mod_ocean::ocean, mod_param::r2dvar, mod_param::r3dvar, mod_scalars::rho0, mod_scalars::scalars, mod_scalars::scoef, sp_bcoef(), mod_iounits::stdout, mod_storage::storage, mod_storage::swork, mod_scalars::tcoef, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, mod_ncparam::vname, wclock_off(), and wclock_on().

Referenced by ad_pack(), and ad_pack_tile().

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

◆ ad_unpack()

subroutine __packing_f__::ad_unpack ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(in) state )
private

Definition at line 4711 of file packing.F.

4712!
4713!=======================================================================
4714! !
4715! This routine unpacks the requested adjoint state and/or surface !
4716! forcing variables used in stochastic optimals. The state vector !
4717! contains only interior water points. !
4718! !
4719!=======================================================================
4720!
4721 USE mod_param
4722 USE mod_grid
4723 USE mod_forces
4724 USE mod_stepping
4725# ifdef DISTRIBUTE
4726 USE mod_storage
4727# endif
4728# ifdef DISTRIBUTE
4729!
4730 USE distribute_mod, ONLY : mp_gather_state
4731# endif
4732!
4733! Imported variable declarations.
4734!
4735 integer, intent(in) :: ng, tile
4736 integer, intent(in) :: Mstr, Mend
4737# ifdef ASSUMED_SHAPE
4738 real(r8), intent(in) :: state(Mstr:)
4739# else
4740 real(r8), intent(in) :: state(Mstr:Mend)
4741# endif
4742!
4743! Local variable declarations.
4744!
4745 character (len=*), parameter :: MyFile = &
4746 & __FILE__//", ad_unpak"
4747!
4748# include "tile.h"
4749!
4750# ifdef DISTRIBUTE
4751!
4752! Gather (threaded to global) adjoint state solution from all
4753! distributed nodes.
4754!
4755 CALL mp_gather_state (ng, inlm, mstr, mend, mstate(ng), &
4756 & state, swork)
4757!
4758# endif
4759
4760# ifdef PROFILE
4761 CALL wclock_on (ng, iadm, 2, __line__, myfile)
4762# endif
4763
4764 CALL ad_unpack_tile (ng, tile, &
4765 & lbi, ubi, lbj, ubj, &
4766 & imins, imaxs, jmins, jmaxs, &
4767# ifdef STOCHASTIC_OPT
4768 & knew(ng), &
4769# else
4770 & kstp(ng), &
4771# endif
4772# ifdef SOLVE3D
4773 & nstp(ng), &
4774# endif
4775# ifdef MASKING
4776 & grid(ng) % IJwaterR, &
4777 & grid(ng) % IJwaterU, &
4778 & grid(ng) % IJwaterV, &
4779 & grid(ng) % rmask, &
4780 & grid(ng) % umask, &
4781 & grid(ng) % vmask, &
4782# endif
4783# ifdef ENERGYNORM_SCALE
4784 & grid(ng) % h, &
4785# ifdef SOLVE3D
4786 & grid(ng) % Hz, &
4787# endif
4788# endif
4789# ifdef DISTRIBUTE
4790 & 1, mstate(ng), swork)
4791# else
4792 & mstr, mend, state)
4793# endif
4794
4795# ifdef PROFILE
4796 CALL wclock_off (ng, iadm, 2, __line__, myfile)
4797# endif
4798!
4799 RETURN
distribute_mod::mp_gather_state
subroutine mp_gather_state(ng, model, mstr, mend, asize, a, awrk)
Definition distribute.F:5143
mod_param::inlm
integer, parameter inlm
Definition mod_param.F:662
mod_stepping::knew
integer, dimension(:), allocatable knew
Definition mod_stepping.F:64
ad_unpack_tile
subroutine ad_unpack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kout, nout, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, mstr, mend, state)
Definition packing.F:4821

References ad_unpack_tile(), mod_grid::grid, mod_param::iadm, mod_param::inlm, mod_stepping::knew, mod_stepping::kstp, distribute_mod::mp_gather_state(), mod_param::mstate, mod_stepping::nstp, mod_storage::swork, wclock_off(), and wclock_on().

Referenced by __packing_f__(), propagator_mod::propagator_afte(), and propagator_mod::propagator_hso().

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

◆ ad_unpack_tile()

subroutine __packing_f__::ad_unpack_tile ( integer, intent(in) ng,
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,
integer, intent(in) kout,
integer, intent(in) nout,
integer, dimension(lbi:,lbj:), intent(in) ijwaterr,
integer, dimension(lbi:,lbj:), intent(in) ijwateru,
integer, dimension(lbi:,lbj:), intent(in) ijwaterv,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbi:,lbj:), intent(in) h,
real(r8), dimension(lbi:,lbj:,:), intent(in) hz,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(in) state )
private

Definition at line 4803 of file packing.F.

4821!***********************************************************************
4822!
4823 USE mod_param
4824 USE mod_parallel
4825 USE mod_forces
4826 USE mod_ncparam
4827 USE mod_ocean
4828 USE mod_scalars
4829!
4830! Imported variable declarations.
4831!
4832 integer, intent(in) :: ng, tile
4833 integer, intent(in) :: LBi, UBi, LBj, UBj
4834 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
4835 integer, intent(in) :: kout
4836# ifdef SOLVE3D
4837 integer, intent(in) :: nout
4838# endif
4839 integer, intent(in) :: Mstr, Mend
4840!
4841# ifdef ASSUMED_SHAPE
4842# ifdef MASKING
4843 integer, intent(in) :: IJwaterR(LBi:,LBj:)
4844 integer, intent(in) :: IJwaterU(LBi:,LBj:)
4845 integer, intent(in) :: IJwaterV(LBi:,LBj:)
4846
4847 real(r8), intent(in) :: rmask(LBi:,LBj:)
4848 real(r8), intent(in) :: umask(LBi:,LBj:)
4849 real(r8), intent(in) :: vmask(LBi:,LBj:)
4850# endif
4851# ifdef ENERGYNORM_SCALE
4852 real(r8), intent(in) :: h(LBi:,LBj:)
4853# ifdef SOLVE3D
4854 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
4855# endif
4856# endif
4857 real(r8), intent(in) :: state(Mstr:)
4858# else
4859# ifdef MASKING
4860 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
4861 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
4862 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
4863
4864 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
4865 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
4866 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
4867# endif
4868# ifdef ENERGYNORM_SCALE
4869 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
4870# ifdef SOLVE3D
4871 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
4872# endif
4873# endif
4874 real(r8), intent(in) :: state(Mstr:Mend)
4875# endif
4876!
4877! Local variable declarations.
4878!
4879# ifndef MASKING
4880 integer :: Imax, Ioff, Jmax, Joff
4881# endif
4882 integer :: Uoff, Voff
4883 integer :: i, iadd, icount, is, itrc, j, k
4884
4885# ifdef SOLVE3D
4886# ifdef SALINITY
4887 integer, dimension(7+2*NT(ng)) :: offset
4888# else
4889 integer, dimension(7+2*(NT(ng)+1)) :: offset
4890# endif
4891# else
4892 integer, dimension(5) :: offset
4893# endif
4894
4895 real(r8) :: cff, scale
4896
4897# include "set_bounds.h"
4898!
4899!-----------------------------------------------------------------------
4900! Extract adjoint FORCING variables from full 1D state vector.
4901!-----------------------------------------------------------------------
4902!
4903! Set offsets for momentum variables due to periodic boundary
4904! conditions. Recall that in East-West periodic boundary conditions
4905! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
4906! applications IstrV=1 or else IstrV=2.
4907!
4908 IF (ewperiodic(ng)) THEN
4909 uoff=0
4910 ELSE
4911 uoff=1
4912 END IF
4913!
4914 IF (nsperiodic(ng)) THEN
4915 voff=0
4916 ELSE
4917 voff=1
4918 END IF
4919!
4920! Determine the index offset for each variable in the state vector.
4921# ifdef MASKING
4922! Notice that in Land/Sea masking application the state vector only
4923! contains water points to avoid large null space.
4924# endif
4925!
4926! First clear the "offset" array.
4927!
4928 offset=0
4929!
4930# ifdef SOLVE3D
4931# ifdef MASKING
4932 IF (scalars(ng)%Fstate(isfsur)) THEN
4933 offset(isfsur)=0
4934 END IF
4935 IF (scalars(ng)%Fstate(isuvel)) THEN
4936 offset(isuvel)=offset(isfsur)+nwaterr(ng)
4937 END IF
4938 IF (scalars(ng)%Fstate(isvvel)) THEN
4939 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
4940 END IF
4941 iadd=nwaterv(ng)*n(ng)
4942 DO itrc=1,nt(ng)
4943 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
4944 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
4945 iadd=nwaterr(ng)*n(ng)
4946 END IF
4947 END DO
4948 IF (scalars(ng)%Fstate(isustr)) THEN
4949 offset(isustr)=0
4950 END IF
4951 IF (scalars(ng)%Fstate(isvstr)) THEN
4952 offset(isvstr)=offset(isustr)+nwateru(ng)
4953 END IF
4954 DO itrc=1,nt(ng)
4955 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
4956 IF (itrc.eq.1) THEN
4957 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
4958 ELSE
4959 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
4960 END IF
4961 END IF
4962 END DO
4963# else
4964# ifdef FULL_GRID
4965 IF (scalars(ng)%Fstate(isfsur)) THEN
4966 offset(isfsur)=0
4967 END IF
4968 IF (scalars(ng)%Fstate(isuvel)) THEN
4969 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
4970 END IF
4971 IF (scalars(ng)%Fstate(isvvel)) THEN
4972 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
4973 END IF
4974 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
4975 DO itrc=1,nt(ng)
4976 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
4977 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
4978 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
4979 END IF
4980 END DO
4981 IF (scalars(ng)%Fstate(isustr)) THEN
4982 offset(isustr)=0
4983 END IF
4984 IF (scalars(ng)%Fstate(isvstr)) THEN
4985 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
4986 END IF
4987 DO itrc=1,nt(ng)
4988 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
4989 IF (itrc.eq.1) THEN
4990 offset(istsur(itrc))=offset(isvstr)+ &
4991 & (lm(ng)+2)*(mm(ng)+1)
4992 ELSE
4993 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
4994 & (lm(ng)+2)*(mm(ng)+2)
4995 END IF
4996 END IF
4997 END DO
4998# else
4999 IF (scalars(ng)%Fstate(isfsur)) THEN
5000 offset(isfsur)=0
5001 END IF
5002 IF (scalars(ng)%Fstate(isuvel)) THEN
5003 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
5004 END IF
5005 IF (scalars(ng)%Fstate(isvvel)) THEN
5006 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
5007 END IF
5008 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
5009 DO itrc=1,nt(ng)
5010 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
5011 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
5012 iadd=lm(ng)*mm(ng)*n(ng)
5013 END IF
5014 END DO
5015 IF (scalars(ng)%Fstate(isustr)) THEN
5016 offset(isustr)=0
5017 END IF
5018 IF (scalars(ng)%Fstate(isvstr)) THEN
5019 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
5020 END IF
5021 DO itrc=1,nt(ng)
5022 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
5023 IF (itrc.eq.1) THEN
5024 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
5025 ELSE
5026 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
5027 END IF
5028 END IF
5029 END DO
5030# endif
5031# endif
5032# else
5033# ifdef MASKING
5034 IF (scalars(ng)%Fstate(isfsur)) THEN
5035 offset(isfsur)=0
5036 END IF
5037 IF (scalars(ng)%Fstate(isubar)) THEN
5038 offset(isubar)=offset(isfsur)+nwaterr(ng)
5039 END IF
5040 IF (scalars(ng)%Fstate(isvbar)) THEN
5041 offset(isvbar)=offset(isubar)+nwateru(ng)
5042 END IF
5043 IF (scalars(ng)%Fstate(isustr)) THEN
5044 offset(isustr)=0
5045 END IF
5046 IF (scalars(ng)%Fstate(isvstr)) THEN
5047 offset(isvstr)=offset(isustr)+nwateru(ng)
5048 END IF
5049# else
5050# ifdef FULL_GRID
5051 IF (scalars(ng)%Fstate(isfsur)) THEN
5052 offset(isfsur)=0
5053 END IF
5054 IF (scalars(ng)%Fstate(isubar)) THEN
5055 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
5056 END IF
5057 IF (scalars(ng)%Fstate(isvbar) THEN
5058 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
5059 END IF
5060 IF (scalars(ng)%Fstate(isustr)) THEN
5061 offset(isustr)=0
5062 END IF
5063 IF (scalars(ng)%Fstate(isvstr)) THEN
5064 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
5065 END IF
5066# else
5067 IF (scalars(ng)%Fstate(isfsur)) THEN
5068 offset(isfsur)=0
5069 END IF
5070 IF (scalars(ng)%Fstate(isubar)) THEN
5071 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
5072 END IF
5073 IF (scalars(ng)%Fstate(isvbar) THEN
5074 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
5075 END IF
5076 IF (scalars(ng)%Fstate(isustr)) THEN
5077 offset(isustr)=0
5078 END IF
5079 IF (scalars(ng)%Fstate(isustr)) THEN
5080 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
5081 END IF
5082# endif
5083# endif
5084# endif
5085!
5086! Extract adjoint free-surface.
5087!
5088 IF (scalars(ng)%Fstate(isfsur)) THEN
5089# ifndef MASKING
5090# ifdef FULL_GRID
5091 imax=lm(ng)+2
5092 ioff=1
5093 joff=0
5094# else
5095 imax=lm(ng)
5096 ioff=0
5097 joff=1
5098# endif
5099# endif
5100# ifdef ENERGYNORM_SCALE
5101 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
5102# else
5103 scale=1.0_r8
5104# endif
5105 DO j=jr_range
5106 DO i=ir_range
5107# ifdef MASKING
5108 IF (rmask(i,j).gt.0.0_r8) THEN
5109 is=ijwaterr(i,j)+offset(isfsur)
5110 ocean(ng)%ad_zeta(i,j,kout)=scale*state(is)
5111 ELSE
5112 ocean(ng)%ad_zeta(i,j,kout)=0.0_r8
5113 END IF
5114# else
5115 is=(i-ioff)+(j-joff)*imax+offset(isfsur)
5116 ocean(ng)%ad_zeta(i,j,kout)=scale*state(is)
5117# endif
5118 END DO
5119 END DO
5120 END IF
5121
5122# ifndef SOLVE3D
5123!
5124! Extract adjoint 2D U-velocity.
5125!
5126 IF (scalars(ng)%Fstate(isubar)) THEN
5127# ifndef MASKING
5128# ifdef FULL_GRID
5129 imax=lm(ng)+1
5130 ioff=0
5131 joff=0
5132# else
5133 imax=lm(ng)-uoff
5134 ioff=uoff
5135 joff=1
5136# endif
5137# endif
5138# ifdef ENERGYNORM_SCALE
5139 cff=0.25_r8*rho0
5140# else
5141 scale=1.0_r8
5142# endif
5143 DO j=jr_range
5144 DO i=iu_range
5145# ifdef ENERGYNORM_SCALE
5146 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
5147# endif
5148# ifdef MASKING
5149 IF (umask(i,j).gt.0.0_r8) THEN
5150 is=ijwateru(i,j)+offset(isubar)
5151 ocean(ng)%ad_ubar(i,j,kout)=scale*state(is)
5152 ELSE
5153 ocean(ng)%ubar(i,j,kout)=0.0_r8
5154 END IF
5155# else
5156 is=(i-ioff)+(j-joff)*imax+offset(isubar)
5157 ocean(ng)%ad_ubar(i,j,kout)=scale*state(is)
5158# endif
5159 END DO
5160 END DO
5161 END IF
5162!
5163! Extract adjoint 2D V-velocity.
5164!
5165 IF (scalars(ng)%Fstate(isvbar)) THEN
5166# ifndef MASKING
5167# ifdef FULL_GRID
5168 imax=lm(ng)+2
5169 ioff=1
5170 joff=1
5171# else
5172 imax=lm(ng)
5173 ioff=0
5174 joff=1+voff
5175# endif
5176# endif
5177# ifdef ENERGYNORM_SCALE
5178 cff=0.25_r8*rho0
5179# else
5180 scale=1.0_r8
5181# endif
5182 DO j=jv_range
5183 DO i=ir_range
5184# ifdef ENERGYNORM_SCALE
5185 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
5186# endif
5187# ifdef MASKING
5188 IF (vmask(i,j).gt.0.0_r8) THEN
5189 is=ijwaterv(i,j)+offset(isvbar)
5190 ocean(ng)%ad_vbar(i,j,kout)=scale*state(is)
5191 ELSE
5192 ocean(ng)%ad_vbar(i,j,kout)=0.0_r8
5193 END IF
5194# else
5195 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
5196 ocean(ng)%ad_vbar(i,j,kout)=scale*state(is)
5197# endif
5198 END DO
5199 END DO
5200 END IF
5201
5202# else
5203!
5204! Extract adjoint 3D U-velocity.
5205!
5206 IF (scalars(ng)%Fstate(isuvel)) THEN
5207# ifndef MASKING
5208# ifdef FULL_GRID
5209 imax=lm(ng)+1
5210 jmax=mm(ng)+2
5211 ioff=0
5212 joff=0
5213# else
5214 imax=lm(ng)-uoff
5215 jmax=mm(ng)
5216 ioff=uoff
5217 joff=1
5218# endif
5219# endif
5220# ifdef ENERGYNORM_SCALE
5221 cff=0.25_r8*rho0
5222# else
5223 scale=1.0_r8
5224# endif
5225 DO k=1,n(ng)
5226# ifdef MASKING
5227 iadd=(k-1)*nwateru(ng)+offset(isuvel)
5228# else
5229 iadd=(k-1)*imax*jmax+offset(isuvel)
5230# endif
5231 DO j=jr_range
5232 DO i=iu_range
5233# ifdef MASKING
5234 IF (umask(i,j).gt.0.0_r8) THEN
5235# ifdef ENERGYNORM_SCALE
5236 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
5237# endif
5238 is=ijwateru(i,j)+iadd
5239 ocean(ng)%ad_u(i,j,k,nout)=scale*state(is)
5240 ELSE
5241 ocean(ng)%ad_u(i,j,k,nout)=0.0_r8
5242 END IF
5243# else
5244# ifdef ENERGYNORM_SCALE
5245 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
5246# endif
5247 is=(i-ioff)+(j-joff)*imax+iadd
5248 ocean(ng)%ad_u(i,j,k,nout)=scale*state(is)
5249# endif
5250 END DO
5251 END DO
5252 END DO
5253 END IF
5254!
5255! Extract adjoint 3D V-velocity.
5256!
5257 IF (scalars(ng)%Fstate(isvvel)) THEN
5258# ifndef MASKING
5259# ifdef FULL_GRID
5260 imax=lm(ng)+2
5261 jmax=mm(ng)+1
5262 ioff=1
5263 joff=1
5264# else
5265 imax=lm(ng)
5266 jmax=mm(ng)-voff
5267 ioff=0
5268 joff=1+voff
5269# endif
5270# endif
5271# ifdef ENERGYNORM_SCALE
5272 cff=0.25_r8*rho0
5273# else
5274 scale=1.0_r8
5275# endif
5276 DO k=1,n(ng)
5277# ifdef MASKING
5278 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
5279# else
5280 iadd=(k-1)*imax*jmax+offset(isvvel)
5281# endif
5282 DO j=jv_range
5283 DO i=ir_range
5284# ifdef MASKING
5285 IF (vmask(i,j).gt.0.0_r8) THEN
5286# ifdef ENERGYNORM_SCALE
5287 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
5288# endif
5289 is=ijwaterv(i,j)+iadd
5290 ocean(ng)%ad_v(i,j,k,nout)=scale*state(is)
5291 ELSE
5292 ocean(ng)%ad_v(i,j,k,nout)=0.0_r8
5293 END IF
5294# else
5295# ifdef ENERGYNORM_SCALE
5296 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
5297# endif
5298 is=(i+ioff)+(j-joff)*imax+iadd
5299 ocean(ng)%ad_v(i,j,k,nout)=scale*state(is)
5300# endif
5301 END DO
5302 END DO
5303 END DO
5304 END IF
5305!
5306! Extract adjoint tracers variables.
5307!
5308 DO itrc=1,nt(ng)
5309 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
5310# ifndef MASKING
5311# ifdef FULL_GRID
5312 imax=lm(ng)+2
5313 jmax=mm(ng)+2
5314 ioff=1
5315 joff=0
5316# else
5317 imax=lm(ng)
5318 jmax=mm(ng)
5319 ioff=0
5320 joff=1
5321# endif
5322# endif
5323# ifdef ENERGYNORM_SCALE
5324 IF (itrc.eq.itemp) THEN
5325 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
5326 ELSE IF (itrc.eq.isalt) THEN
5327 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
5328 ELSE
5329 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
5330 END IF
5331# else
5332 scale=1.0_r8
5333# endif
5334 DO k=1,n(ng)
5335# ifdef MASKING
5336 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
5337# else
5338 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
5339# endif
5340 DO j=jr_range
5341 DO i=ir_range
5342# ifdef MASKING
5343 IF (rmask(i,j).gt.0.0_r8) THEN
5344# ifdef ENERGYNORM_SCALE
5345 scale=1.0_r8/sqrt(cff*hz(i,j,k))
5346# endif
5347 is=ijwaterr(i,j)+iadd
5348 ocean(ng)%ad_t(i,j,k,nout,itrc)=scale*state(is)
5349 ELSE
5350 ocean(ng)%ad_t(i,j,k,nout,itrc)=0.0_r8
5351 END IF
5352# else
5353# ifdef ENERGYNORM_SCALE
5354 scale=1.0_r8/sqrt(cff*hz(i,j,k))
5355# endif
5356 is=(i+ioff)+(j-joff)*imax+iadd
5357 ocean(ng)%ad_t(i,j,k,nout,itrc)=scale*state(is)
5358# endif
5359 END DO
5360 END DO
5361 END DO
5362 END IF
5363 END DO
5364# endif
5365!
5366! Extract adjoint surface U-momentum stress.
5367!
5368 IF (scalars(ng)%Fstate(isustr)) THEN
5369# ifndef MASKING
5370# ifdef FULL_GRID
5371 imax=lm(ng)+1
5372 ioff=0
5373 joff=0
5374# else
5375 imax=lm(ng)-uoff
5376 ioff=uoff
5377 joff=1
5378# endif
5379# endif
5380 scale=1.0_r8
5381 DO j=jr_range
5382 DO i=iu_range
5383# ifdef MASKING
5384 IF (umask(i,j).gt.0.0_r8) THEN
5385 is=ijwateru(i,j)+offset(isustr)
5386 forces(ng)%ad_sustr(i,j)=scale*state(is)
5387 ELSE
5388 forces(ng)%ad_sustr(i,j)=0.0_r8
5389 END IF
5390# else
5391 is=(i-ioff)+(j-joff)*imax+offset(isustr)
5392 forces(ng)%ad_sustr(i,j)=scale*state(is)
5393# endif
5394 END DO
5395 END DO
5396 END IF
5397!
5398! Extract adjoint surface V-momentum stress.
5399!
5400 IF (scalars(ng)%Fstate(isvstr)) THEN
5401# ifndef MASKING
5402# ifdef FULL_GRID
5403 imax=lm(ng)+2
5404 ioff=1
5405 joff=1
5406# else
5407 imax=lm(ng)
5408 ioff=0
5409 joff=1+voff
5410# endif
5411# endif
5412 scale=1.0_r8
5413 DO j=jv_range
5414 DO i=ir_range
5415# ifdef MASKING
5416 IF (vmask(i,j).gt.0.0_r8) THEN
5417 is=ijwaterv(i,j)+offset(isvstr)
5418 forces(ng)%ad_svstr(i,j)=scale*state(is)
5419 ELSE
5420 forces(ng)%ad_svstr(i,j)=0.0_r8
5421 END IF
5422# else
5423 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
5424 forces(ng)%ad_svstr(i,j)=scale*state(is)
5425# endif
5426 END DO
5427 END DO
5428 END IF
5429
5430# ifdef SOLVE3D
5431!
5432! Extract adjoint surface tracer flux variables.
5433!
5434 DO itrc=1,nt(ng)
5435 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
5436# ifndef MASKING
5437# ifdef FULL_GRID
5438 imax=lm(ng)+2
5439 jmax=mm(ng)+2
5440 ioff=1
5441 joff=0
5442# else
5443 imax=lm(ng)
5444 jmax=mm(ng)
5445 ioff=0
5446 joff=1
5447# endif
5448# endif
5449 scale=1.0_r8
5450 DO j=jr_range
5451 DO i=ir_range
5452# ifdef MASKING
5453 IF (rmask(i,j).gt.0.0_r8) THEN
5454 is=ijwaterr(i,j)+offset(istvar(itrc))
5455 forces(ng)%ad_stflx(i,j,itrc)=scale*state(is)
5456 ELSE
5457 forces(ng)%ad_stflx(i,j,itrc)=0.0_r8
5458 END IF
5459# else
5460 is=(i+ioff)+(j-joff)*imax+offset(istvar(itrc))
5461 forces(ng)%ad_stflx(i,j,itrc)=scale*state(is)
5462# endif
5463 END DO
5464 END DO
5465 END IF
5466 END DO
5467# endif
5468!
5469 RETURN

References ad_unpack_tile(), mod_scalars::bvf_bak, mod_scalars::ewperiodic, mod_forces::forces, mod_scalars::g, mod_grid::grid, mod_param::iadm, mod_scalars::isalt, mod_ncparam::isfsur, mod_ncparam::istsur, mod_ncparam::istvar, mod_ncparam::isubar, mod_ncparam::isustr, mod_ncparam::isuvel, mod_ncparam::isvbar, mod_ncparam::isvstr, mod_ncparam::isvvel, mod_scalars::itemp, mod_param::itlm, mod_stepping::knew, mod_param::lm, mod_param::mm, distribute_mod::mp_gather_state(), mod_param::mstate, mod_scalars::nsperiodic, mod_stepping::nstp, mod_param::nt, mod_ncparam::nwaterr, mod_ncparam::nwateru, mod_ncparam::nwaterv, mod_ocean::ocean, mod_scalars::rho0, mod_scalars::scalars, mod_scalars::scoef, mod_storage::swork, mod_scalars::tcoef, wclock_off(), and wclock_on().

Referenced by ad_unpack(), and ad_unpack_tile().

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

◆ c_norm2()

subroutine __packing_f__::c_norm2 ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), intent(in) evaluer,
real(r8), intent(in) evaluei,
real(r8), dimension(mstr:), intent(in) evectorr,
real(r8), dimension(mstr:), intent(in) evectori,
real(r8), dimension(mstr:), intent(in) state,
real(r8), intent(out) norm2 )
private

Definition at line 72 of file packing.F.

75!
76!=======================================================================
77! !
78! This function computes the Euclidean norm between the propagator !
79! real/imaginary Ritz eigenvalue (EvalueR, EvalueI) and eigenvector !
80! (EvectorR, EvectorI) with state vector (state): !
81! !
82! norm2 = Euclidean NORM (state(:) + EvalueR * EvectorR(:) + !
83! EvalueI * EvectorI(:)) !
84! !
85! WARNING: This function is only intended for serial or distributed !
86! memory applications. There is not tiled partitions. All !
87! quantities are vectors. It replaces the calls to "daxpy" !
88! and "dnrm2" from the BLAS library. This "legacy" library !
89! gives different results when called inside modules and !
90! the input arguments are pointers (specially using ifort). !
91! !
92!=======================================================================
93!
94 USE mod_param
95 USE mod_parallel
96
97# ifdef DISTRIBUTE
98!
99 USE distribute_mod, ONLY : mp_reduce
100# endif
101!
102! Imported variable declarations.
103!
104 integer, intent(in) :: ng, model
105 integer, intent(in) :: Mstr, Mend
106
107 real(r8), intent(in) :: EvalueR
108 real(r8), intent(in) :: EvalueI
109
110# ifdef ASSUMED_SHAPE
111 real(r8), intent(in) :: EvectorR(Mstr:)
112 real(r8), intent(in) :: EvectorI(Mstr:)
113 real(r8), intent(in) :: state(Mstr:)
114# else
115 real(r8), intent(in) :: EvectorR(Mstr:Mend)
116 real(r8), intent(in) :: EvectorI(Mstr:Mend)
117 real(r8), intent(in) :: state(Mstr:Mend)
118# endif
119 real(r8), intent(out) :: norm2
120!
121! Local variable declarations.
122!
123 integer :: NSUB, is
124
125 real(r8) :: cff, my_norm2
126
127# ifdef DISTRIBUTE
128 character (len=3) :: op_handle
129# endif
130!
131!-----------------------------------------------------------------------
132! Compute the Euclidean norm of: state(:) + Rvalue * Rvector(:)
133!-----------------------------------------------------------------------
134!
135! Accumulate squared sum.
136!
137 my_norm2=0.0_r8
138 DO is=mstr,mend
139 cff=state(is)+evaluer*evectorr(is)+ &
140 & evaluei*evectori(is)
141 my_norm2=my_norm2+cff*cff
142 END DO
143!
144! Take sum squared-root: perform global reduction.
145!
146# ifdef DISTRIBUTE
147 nsub=1 ! distributed-memory
148# else
149 nsub=ntilex(ng)*ntilee(ng) ! tiled application
150# endif
151!$OMP CRITICAL (C_NORM)
152 IF (tile_count.eq.0) THEN
153 norm2=my_norm2
154 ELSE
155 norm2=norm2+my_norm2
156 END IF
157 tile_count=tile_count+1
158 IF (tile_count.eq.nsub) THEN
159 tile_count=0
160# ifdef DISTRIBUTE
161 op_handle='SUM'
162 CALL mp_reduce (ng, model, 1, norm2, op_handle)
163# endif
164 END IF
165!$OMP END CRITICAL (C_NORM)
166 norm2=sqrt(norm2)
167!
168 RETURN
distribute_mod::mp_reduce
Definition distribute.F:113
mod_parallel::tile_count
integer tile_count
Definition mod_parallel.F:89
mod_param::ntilex
integer, dimension(:), allocatable ntilex
Definition mod_param.F:685
mod_param::ntilee
integer, dimension(:), allocatable ntilee
Definition mod_param.F:686

References mod_param::ntilee, mod_param::ntilex, and mod_parallel::tile_count.

Referenced by __packing_f__().

Here is the caller graph for this function:

◆ r_norm2()

subroutine __packing_f__::r_norm2 ( integer, intent(in) ng,
integer, intent(in) model,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), intent(in) evalue,
real(r8), dimension(mstr:), intent(in) evector,
real(r8), dimension(mstr:), intent(in) state,
real(r8), intent(out) norm2 )
private

Definition at line 173 of file packing.F.

175!
176!=======================================================================
177! !
178! This function computes the Euclidean norm between the propagator !
179! real Ritz eigenvalue (Evalue) and eigenvector (Evector) with the !
180! state vector (state): !
181! !
182! norm2 = Euclidean NORM (state(:) + Evalue * Evector(:)) !
183! !
184! WARNING: The norm is computed by the master thread and broadcasted !
185! to all the nodes in the group. It is used when the state !
186! vector is not partitioned between all nodes. !
187! !
188!=======================================================================
189!
190 USE mod_param
191 USE mod_parallel
192
193# ifdef DISTRIBUTE
194!
195 USE distribute_mod, ONLY : mp_bcastf
196# endif
197!
198! Imported variable declarations.
199!
200 integer, intent(in) :: ng, model
201 integer, intent(in) :: Mstr, Mend
202
203 real(r8), intent(in) :: Evalue
204
205# ifdef ASSUMED_SHAPE
206 real(r8), intent(in) :: Evector(Mstr:)
207 real(r8), intent(in) :: state(Mstr:)
208# else
209 real(r8), intent(in) :: Evector(Mstr:Mend)
210 real(r8), intent(in) :: state(Mstr:Mend)
211# endif
212 real(r8), intent(out) :: norm2
213!
214! Local variable declarations.
215!
216 integer :: NSUB, is
217
218 real(r8) :: cff, my_norm2
219!
220!-----------------------------------------------------------------------
221! Compute the Euclidean norm of: state(:) + Rvalue * Rvector(:)
222!-----------------------------------------------------------------------
223!
224! Accumulate squared sum.
225!
226 IF (master) THEN
227 my_norm2=0.0_r8
228 DO is=mstr,mend
229 cff=state(is)+evalue*evector(is)
230 my_norm2=my_norm2+cff*cff
231 END DO
232 norm2=sqrt(my_norm2)
233 END IF
234
235# ifdef DISTRIBUTE
236 CALL mp_bcastf (ng, model, norm2)
237# endif
238!
239 RETURN
distribute_mod::mp_bcastf
Definition distribute.F:75
mod_parallel::master
logical master
Definition mod_parallel.F:40

References mod_parallel::master, mod_param::ntilee, mod_param::ntilex, and mod_parallel::tile_count.

Referenced by __packing_f__().

Here is the caller graph for this function:

◆ so_semi_red()

subroutine __packing_f__::so_semi_red ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:mend), intent(in) state,
real(r8), dimension(mstr:mend), intent(out) ad_state )
private

Definition at line 8980 of file packing.F.

8981!
8982!=======================================================================
8983! !
8984! This routine computes a new stochastic optimals perturbation vector !
8985! (seminorm estimation) assuming red noise forcing using ARPACK. !
8986! !
8987!=======================================================================
8988!
8989 USE mod_param
8990 USE mod_parallel
8991 USE mod_iounits
8992 USE mod_storage
8993 USE mod_scalars
8994# ifdef DISTRIBUTE
8995!
8996 USE distribute_mod, ONLY : mp_reduce
8997# endif
8998!
8999! Imported variable declarations.
9000!
9001 integer, intent(in) :: ng, tile
9002 integer, intent(in) :: Mstr, Mend
9003# ifdef ASSUMED_SHAPE
9004 real(r8), intent(in) :: state(Mstr:)
9005 real(r8), intent(out) :: ad_state(Mstr:)
9006# else
9007 real(r8), intent(in) :: state(Mstr:Mend)
9008 real(r8), intent(out) :: ad_state(Mstr:Mend)
9009# endif
9010!
9011! Local variable declarations.
9012!
9013 integer :: NSUB, is, ntAD, ntTL, rec, rec1
9014
9015 real(r8) :: SOnorm, my_TRnorm
9016
9017 real(r8), dimension(Nsemi(ng)) :: Bcoef
9018 real(r8), dimension(Nsemi(ng)) :: SOdotprod
9019 real(r8), dimension(Nsemi(ng)) :: my_dotprod
9020
9021# ifdef DISTRIBUTE
9022 character (len=3), dimension(Nsemi(ng)) :: op_handle
9023# endif
9024
9025# include "tile.h"
9026!
9027!-----------------------------------------------------------------------
9028! Compute seminorm, stochastic optimals adjoint perturbation vector.
9029!-----------------------------------------------------------------------
9030!
9031! Initialize adjoint state vector.
9032!
9033 DO is=mstr,mend
9034 ad_state(is)=0.0_r8
9035 END DO
9036!
9037! First compute the dot-products.
9038!
9039 DO rec=1,nsemi(ng)
9040 my_dotprod(rec)=0.0_r8
9041 DO is=mstr,mend
9042 my_dotprod(rec)=my_dotprod(rec)+ &
9043 & storage(ng)%so_state(is,rec)*state(is)
9044 END DO
9045 END DO
9046!
9047! Global reduction of dot products.
9048!
9049# ifdef DISTRIBUTE
9050 nsub=1 ! distributed-memory
9051# else
9052 IF (domain(ng)%SouthWest_Corner(tile).and. &
9053 & domain(ng)%NorthEast_Corner(tile)) THEN
9054 nsub=1 ! non-tiled application
9055 ELSE
9056 nsub=ntilex(ng)*ntilee(ng) ! tiled application
9057 END IF
9058# endif
9059!$OMP CRITICAL (SO_DOT)
9060 IF (tile_count.eq.0) THEN
9061 DO rec=1,nsemi(ng)
9062 sodotprod(rec)=0.0_r8
9063 END DO
9064 END IF
9065 DO rec=1,nsemi(ng)
9066 sodotprod(rec)=sodotprod(rec)+my_dotprod(rec)
9067 END DO
9068 tile_count=tile_count+1
9069 IF (tile_count.eq.nsub) THEN
9070 tile_count=0
9071# ifdef DISTRIBUTE
9072 DO rec=1,nsemi(ng)
9073 op_handle(rec)='SUM'
9074 END DO
9075 CALL mp_reduce (ng, iadm, nsemi(ng), sodotprod, op_handle)
9076# endif
9077 END IF
9078!$OMP END CRITICAL (SO_DOT)
9079!
9080! Second, loop over time twice allowing for the decorrelation due to the
9081! red noise AR(1) process with assumed decorrelation time SOdecay.
9082!
9083 IF (master) THEN
9084 WRITE (stdout,'(/)')
9085 END IF
9086 my_trnorm=0.0_r8
9087!
9088 DO rec=1,nsemi(ng)
9089 ntad=(rec-1)*nadj(ng)+1
9090 sonorm=0.0_r8
9091 DO rec1=1,nsemi(ng)
9092 nttl=(rec1-1)*nadj(ng)+1
9093 CALL sp_bcoef (ng, ntad, nttl, bcoef(rec1))
9094 sonorm=sonorm+bcoef(rec1)*sodotprod(rec1)
9095 DO is=mstr,mend
9096 my_trnorm=my_trnorm+ &
9097 & storage(ng)%so_state(is,rec )*bcoef(rec1)* &
9098 & storage(ng)%so_state(is,rec1)
9099 END DO
9100 END DO
9101!
9102! Report normalization factors.
9103!
9104 IF (master) THEN
9105 WRITE (stdout,10) rec, sodotprod(rec), bcoef(rec), sonorm
9106 10 FORMAT (1x,'Rec = ',i2.2,1x,'SOdotprod = ',1p,e13.6,0p, &
9107 & 1x,'Bcoef = ',1p,e13.6,0p,1x,'SOnorm = ',1p,e13.6)
9108 END IF
9109!
9110! Compute new perturbation vector.
9111!
9112 DO is=mstr,mend
9113 ad_state(is)=ad_state(is)+ &
9114 & sonorm*storage(ng)%so_state(is,rec)
9115 END DO
9116 END DO
9117!
9118! Global reduction of normalization factor, TRnorm.
9119!
9120# ifdef DISTRIBUTE
9121 nsub=1 ! distributed-memory
9122# else
9123 IF (domain(ng)%SouthWest_Corner(tile).and. &
9124 & domain(ng)%NorthEast_Corner(tile)) THEN
9125 nsub=1 ! non-tiled application
9126 ELSE
9127 nsub=ntilex(ng)*ntilee(ng) ! tiled application
9128 END IF
9129# endif
9130!$OMP CRITICAL (TR_NORM)
9131 IF (tile_count.eq.0) THEN
9132 trnorm(ng)=0.0_r8
9133 END IF
9134 trnorm(ng)=trnorm(ng)+my_trnorm
9135 tile_count=tile_count+1
9136 IF (tile_count.eq.nsub) THEN
9137 tile_count=0
9138# ifdef DISTRIBUTE
9139 op_handle(1)='SUM'
9140 CALL mp_reduce (ng, iadm, 1, trnorm(ng), op_handle(1))
9141# endif
9142 END IF
9143!$OMP END CRITICAL (TR_NORM)
9144!
9145 RETURN
mod_iounits
Definition mod_iounits.F:2
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_param::nsemi
integer, dimension(:), allocatable nsemi
Definition mod_param.F:655
mod_scalars::trnorm
real(r8), dimension(:), allocatable trnorm
Definition mod_scalars.F:1235
mod_scalars::nadj
integer, dimension(:), allocatable nadj
Definition mod_scalars.F:1072
mod_storage::storage
type(t_storage), dimension(:), allocatable storage
Definition mod_storage.F:91
sp_bcoef
subroutine sp_bcoef(ng, ntad, nttl, bcoef)
Definition packing.F:9153

References mod_param::domain, mod_param::iadm, mod_parallel::master, mod_scalars::nadj, mod_param::nsemi, mod_param::ntilee, mod_param::ntilex, sp_bcoef(), mod_iounits::stdout, mod_storage::storage, mod_parallel::tile_count, and mod_scalars::trnorm.

Referenced by __packing_f__(), and propagator_mod::propagator_so_semi().

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

◆ so_semi_white()

subroutine __packing_f__::so_semi_white ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(in) state,
real(r8), dimension(mstr:), intent(out) ad_state )
private

Definition at line 8787 of file packing.F.

8788!
8789!=======================================================================
8790! !
8791! This routine computes a new stochastic optimals perturbation vector !
8792! (seminorm estimation) assuming white noise forcing using ARPACK. !
8793! !
8794!=======================================================================
8795!
8796 USE mod_param
8797 USE mod_parallel
8798 USE mod_scalars
8799 USE mod_storage
8800# ifdef DISTRIBUTE
8801!
8802 USE distribute_mod, ONLY : mp_reduce
8803# endif
8804!
8805! Imported variable declarations.
8806!
8807 integer, intent(in) :: ng, tile
8808 integer, intent(in) :: Mstr, Mend
8809# ifdef ASSUMED_SHAPE
8810 real(r8), intent(in) :: state(Mstr:)
8811 real(r8), intent(out) :: ad_state(Mstr:)
8812# else
8813 real(r8), intent(in) :: state(Mstr:Mend)
8814 real(r8), intent(out) :: ad_state(Mstr:Mend)
8815# endif
8816!
8817! Local variable declarations.
8818!
8819 integer :: NSUB, is, rec
8820
8821 real(r8) :: SOnorm, my_SOnorm, my_TRnorm
8822 real(r8) :: SOnorm1, my_SOnorm1
8823 real(r8) :: cff, cff1, cff2
8824
8825# ifdef DISTRIBUTE
8826 real(r8), dimension(3) :: rbuffer
8827
8828 character (len=3), dimension(3) :: op_handle
8829# endif
8830
8831# include "tile.h"
8832!
8833!-----------------------------------------------------------------------
8834! Compute seminorm, stochastic optimals adjoint perturbation vector.
8835!-----------------------------------------------------------------------
8836!
8837! Initialize adjoint state vector.
8838!
8839 DO is=mstr,mend
8840 ad_state(is)=0.0_r8
8841 END DO
8842!
8843! Sum over all adjoint surface forcing records available in "so_state'.
8844!
8845 IF (master) THEN
8846 WRITE (stdout,'(/)')
8847 END IF
8848 my_trnorm=0.0_r8
8849!
8850 DO rec=1,nsemi(ng)
8851!
8852! Compute normalization factor.
8853!
8854 cff=real((nadj(ng)-1)*(2*nadj(ng)-1),r8)/real(6*nadj(ng),r8)
8855 cff1=1.0_r8+cff
8856 cff2=0.5_r8*real((nadj(ng)-1))-cff
8857!
8858 my_sonorm=0.0_r8
8859 my_sonorm1=0.0_r8
8860 DO is=mstr,mend
8861 my_sonorm=my_sonorm+ &
8862 & storage(ng)%so_state(is,rec)*state(is)
8863 END DO
8864!
8865 IF (rec.ne.nsemi(ng)) THEN
8866 DO is=mstr,mend
8867 my_sonorm1=my_sonorm1+ &
8868 & storage(ng)%so_state(is,rec+1)*state(is)
8869 my_trnorm=my_trnorm+ &
8870 & cff1*storage(ng)%so_state(is,rec)* &
8871 & storage(ng)%so_state(is,rec)+ &
8872 & 2.0_r8*cff2*storage(ng)%so_state(is,rec )* &
8873 & storage(ng)%so_state(is,rec+1)+ &
8874 & cff*storage(ng)%so_state(is,rec+1)* &
8875 & storage(ng)%so_state(is,rec+1)
8876 END DO
8877 ELSE
8878 DO is=mstr,mend
8879 my_trnorm=my_trnorm+ &
8880 & storage(ng)%so_state(is,rec)* &
8881 & storage(ng)%so_state(is,rec)
8882 END DO
8883 END IF
8884!
8885! Global reduction of normalization factor.
8886!
8887# ifdef DISTRIBUTE
8888 nsub=1 ! distributed-memory
8889# else
8890 IF (domain(ng)%SouthWest_Corner(tile).and. &
8891 & domain(ng)%NorthEast_Corner(tile)) THEN
8892 nsub=1 ! non-tiled application
8893 ELSE
8894 nsub=ntilex(ng)*ntilee(ng) ! tiled application
8895 END IF
8896# endif
8897!$OMP CRITICAL (SO_NORM)
8898 IF (tile_count.eq.0) THEN
8899 sonorm=0.0_r8
8900 sonorm1=0.0_r8
8901 IF (rec.eq.1) THEN
8902 trnorm(ng)=0.0_r8
8903 END IF
8904 END IF
8905 sonorm=sonorm+my_sonorm
8906 sonorm1=sonorm1+my_sonorm1
8907 tile_count=tile_count+1
8908 IF (tile_count.eq.nsub) THEN
8909 tile_count=0
8910# ifdef DISTRIBUTE
8911 rbuffer(1)=sonorm
8912 rbuffer(2)=sonorm1
8913 op_handle(1)='SUM'
8914 op_handle(2)='SUM'
8915 CALL mp_reduce (ng, iadm, 2, rbuffer, op_handle)
8916 sonorm=rbuffer(1)
8917 sonorm1=rbuffer(2)
8918# endif
8919 END IF
8920!$OMP END CRITICAL (SO_NORM)
8921!
8922! Report normalization factors.
8923!
8924 IF (master) THEN
8925 WRITE (stdout,10) rec, sonorm, sonorm1
8926 10 FORMAT (3x,'Rec = ',i2.2,2x,'SOnorm = ',1p,e15.8,0p, &
8927 & 2x,'SOnorm1 = ',1p,e15.8)
8928 END IF
8929!
8930! Compute new perturbation vector.
8931!
8932 IF (rec.ne.nsemi(ng)) THEN
8933 DO is=mstr,mend
8934 ad_state(is)=ad_state(is)+ &
8935 & cff1*sonorm *storage(ng)%so_state(is,rec )+ &
8936 & cff2*sonorm1*storage(ng)%so_state(is,rec )+ &
8937 & cff2*sonorm *storage(ng)%so_state(is,rec+1)+ &
8938 & cff *sonorm1*storage(ng)%so_state(is,rec+1)
8939 END DO
8940 ELSE
8941 DO is=mstr,mend
8942 ad_state(is)=ad_state(is)+ &
8943 & sonorm*storage(ng)%so_state(is,rec)
8944 END DO
8945 END IF
8946 END DO
8947!
8948! Global reduction of normalization factor, TRnorm.
8949!
8950# ifdef DISTRIBUTE
8951 nsub=1 ! distributed-memory
8952# else
8953 IF (domain(ng)%SouthWest_Corner(tile).and. &
8954 & domain(ng)%NorthEast_Corner(tile)) THEN
8955 nsub=1 ! non-tiled application
8956 ELSE
8957 nsub=ntilex(ng)*ntilee(ng) ! tiled application
8958 END IF
8959# endif
8960!$OMP CRITICAL (TR_NORM)
8961 IF (tile_count.eq.0) THEN
8962 trnorm(ng)=0.0_r8
8963 END IF
8964 trnorm(ng)=trnorm(ng)+my_trnorm
8965 tile_count=tile_count+1
8966 IF (tile_count.eq.nsub) THEN
8967 tile_count=0
8968# ifdef DISTRIBUTE
8969 op_handle(1)='SUM'
8970 CALL mp_reduce (ng, iadm, 1, trnorm(ng), op_handle(1))
8971# endif
8972 END IF
8973!$OMP END CRITICAL (TR_NORM)
8974!
8975 RETURN

References mod_param::domain, mod_param::iadm, mod_parallel::master, mod_scalars::nadj, mod_param::nsemi, mod_param::ntilee, mod_param::ntilex, mod_storage::storage, mod_parallel::tile_count, and mod_scalars::trnorm.

Referenced by __packing_f__(), and propagator_mod::propagator_so_semi().

Here is the caller graph for this function:

◆ sp_acoef()

subroutine __packing_f__::sp_acoef ( integer, intent(in) ng,
integer, intent(in) ntad,
integer, intent(in) nttl,
real(r8), intent(out) acoef )
private

Definition at line 9223 of file packing.F.

9224!
9225!=======================================================================
9226! !
9227! This routine is used to compute red noise stochastic processes !
9228! time-lagged coefficient, Acoef, used to evaluate inner time !
9229! integral. Currently, a discrete-time Markov chain model is !
9230! assumed with autoregressive order-one processes, AR(1). Notice !
9231! that function SP_AUTOC is used to set autocorrelation model. !
9232! !
9233!=======================================================================
9234!
9235 USE mod_scalars
9236!
9237! Imported variable declarations.
9238!
9239 integer, intent(in) :: ng, ntAD, ntTL
9240
9241 real(r8), intent(out):: Acoef
9242!
9243! Local variable declarations.
9244!
9245 integer :: i, idf1, idf2, idf4
9246
9247 real(r8) :: df3, rov
9248!
9249!-----------------------------------------------------------------------
9250! Compute red noise stochastic process time-lagged coefficients to
9251! evaluate discrete inner time-integral. Currently, only Markov
9252! processes, AR(1), are considered.
9253!-----------------------------------------------------------------------
9254!
9255! Here, ntAD is the current timestep corresponding to time when
9256! solution is saved.
9257!
9258 rov=1.0_r8/real(nadj(ng),r8)
9259 IF ((nttl.gt.1).and.(nttl.lt.ntimes(ng)+1)) THEN
9260 acoef=0.0_r8
9261 DO i=1,nadj(ng)-1
9262 idf1=iabs(ntad-nttl-i)+1
9263 idf2=iabs(ntad-(nttl-nadj(ng))-i)+1
9264 df3=real(i,r8)*rov
9265 acoef=acoef+sp_autoc(ng,idf1)*(1.0_r8-df3)+ &
9266 & sp_autoc(ng,idf2)*df3
9267 END DO
9268 idf4=iabs(ntad-nttl)+1
9269 acoef=acoef+sp_autoc(ng,idf4)
9270 ELSE IF (nttl.eq.1) THEN
9271 acoef=0.0_r8
9272 DO i=1,nadj(ng)-1
9273 idf1=iabs(ntad-1-i)+1
9274 df3=real(i,r8)*rov
9275 acoef=acoef+sp_autoc(ng,idf1)*(1.0_r8-df3)
9276 END DO
9277 idf4=iabs(ntad-1)+1
9278 acoef=acoef+sp_autoc(ng,idf4)
9279 ELSE IF (nttl.eq.ntimes(ng)+1) THEN
9280 acoef=0.0_r8
9281 DO i=1,nadj(ng)-1
9282 idf2=iabs(ntad-ntimes(ng)-1+nadj(ng)-i)+1
9283 df3=real(i,r8)*rov
9284 acoef=acoef+sp_autoc(ng,idf2)*df3
9285 END DO
9286 idf4=iabs(ntad-ntimes(ng)-1)+1
9287 acoef=acoef+sp_autoc(ng,idf4)
9288 END IF
9289!
9290 RETURN
mod_scalars::ntimes
integer, dimension(:), allocatable ntimes
Definition mod_scalars.F:336
sp_autoc
real(r8) function sp_autoc(ng, idf)
Definition packing.F:9294

References mod_scalars::nadj, mod_scalars::ntimes, and sp_autoc().

Referenced by sp_bcoef().

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

◆ sp_autoc()

real(r8) function __packing_f__::sp_autoc ( integer, intent(in) ng,
integer, intent(in) idf )
private

Definition at line 9293 of file packing.F.

9294!
9295!=======================================================================
9296! !
9297! This routine is used to compute red noise stochastic processes !
9298! autocorrelation model. Notice that only AR(1) processes are !
9299! considered. However, other models can be easily implemented in !
9300! terms of look tables. !
9301!
9302!=======================================================================
9303!
9304 USE mod_scalars
9305!
9306! Imported variable declarations.
9307!
9308 integer, intent(in) :: ng, idf
9309!
9310! Function result.
9311!
9312 real(r8) :: sp_autoc
9313!
9314!-----------------------------------------------------------------------
9315! Set autocorrelation model.
9316!-----------------------------------------------------------------------
9317# ifdef SO_NON_AR1
9318!
9319! Use a user-defined temporal decorrelation function such as in the
9320! form of a look-up table computed from actual data.
9321!
9322 sp_autoc=0.0_r8
9323# else
9324!
9325! Assume an AR(1) process with decorrelation time SO_decay.
9326!
9327 sp_autoc=exp(-abs(real(idf-1,r8))*dt(ng)/so_decay(ng))
9328# endif
9329!
9330 RETURN
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::so_decay
real(r8), dimension(:), allocatable so_decay
Definition mod_scalars.F:1240

References mod_scalars::dt, mod_scalars::so_decay, and sp_autoc().

Referenced by sp_acoef(), and sp_autoc().

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

◆ sp_bcoef()

subroutine __packing_f__::sp_bcoef ( integer, intent(in) ng,
integer, intent(in) ntad,
integer, intent(in) nttl,
real(r8), intent(out) bcoef )
private

Definition at line 9152 of file packing.F.

9153!
9154!=======================================================================
9155! !
9156! This routine is used to compute red noise stochastic processes !
9157! time-lagged coefficient, Bcoef, used to evaluate discrete !
9158! double-time integrals. Currently, a discrete-time Markov chain !
9159! model is assumed with autoregressive order-one processes, AR(1). !
9160! Notice that the routine SP_ACOEF is called to compute the inner !
9161! integral. !
9162! !
9163!=======================================================================
9164!
9165 USE mod_scalars
9166!
9167! Imported variable declarations.
9168!
9169 integer, intent(in) :: ng, ntAD, ntTL
9170
9171 real(r8), intent(out):: Bcoef
9172!
9173! Local variable declarations.
9174!
9175 integer :: i, it1, it2
9176
9177 real(r8) :: Acoef, Acoef1, Acoef2, df1, rov
9178
9179!
9180!-----------------------------------------------------------------------
9181! Compute red noise stochastic process time-lagged coefficient to
9182! evaluate discrete double time-integrals. Currently, only Markov
9183! processes, AR(1), are considered.
9184!-----------------------------------------------------------------------
9185!
9186! Here, ntAD is the current model timestep and ntTL is the timestep
9187! associated with forcing.
9188!
9189 rov=1.0_r8/real(nadj(ng),r8)
9190!
9191 IF ((ntad.gt.1).and.(ntad.lt.ntimes(ng)+1)) THEN
9192 it1=ntad
9193 it2=ntad-nadj(ng)
9194 CALL sp_acoef (ng, it1, nttl, acoef)
9195 bcoef=acoef
9196 DO i=1,nadj(ng)-1
9197 CALL sp_acoef (ng, it1+i, nttl, acoef1)
9198 CALL sp_acoef (ng, it2+i, nttl, acoef2)
9199 df1=real(i,r8)*rov
9200 bcoef=bcoef+(1.0_r8-df1)*acoef1+df1*acoef2
9201 END DO
9202 ELSE IF (ntad.eq.1) THEN
9203 CALL sp_acoef (ng, 1, nttl, acoef)
9204 bcoef=acoef
9205 DO i=1,nadj(ng)-1
9206 CALL sp_acoef (ng, 1+i, nttl, acoef1)
9207 df1=real(i,r8)*rov
9208 bcoef=bcoef+(1.0_r8-df1)*acoef1
9209 END DO
9210 ELSE IF (ntad.eq.ntimes(ng)+1) THEN
9211 CALL sp_acoef (ng, ntimes(ng)+1, nttl, acoef)
9212 bcoef=acoef
9213 DO i=1,nadj(ng)-1
9214 CALL sp_acoef (ng, ntimes(ng)+1-nadj(ng)+i, nttl, acoef1)
9215 df1=real(i,r8)*rov
9216 bcoef=bcoef+df1*acoef1
9217 END DO
9218 END IF
9219!
9220 RETURN
sp_acoef
subroutine sp_acoef(ng, ntad, nttl, acoef)
Definition packing.F:9224

References mod_scalars::nadj, mod_scalars::ntimes, and sp_acoef().

Referenced by ad_pack_tile(), and so_semi_red().

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

◆ tl_pack()

subroutine __packing_f__::tl_pack ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(out) tl_state )
private

Definition at line 6014 of file packing.F.

6015!
6016!=======================================================================
6017! !
6018! This routine packs the tangent linear variables into the state !
6019! vetor. The state vector contains only interior water points. !
6020! !
6021!=======================================================================
6022!
6023 USE mod_param
6024 USE mod_grid
6025 USE mod_ocean
6026 USE mod_stepping
6027# ifdef DISTRIBUTE
6028 USE mod_storage
6029# endif
6030# ifdef DISTRIBUTE
6031!
6032 USE distribute_mod, ONLY : mp_scatter_state
6033# endif
6034!
6035! Imported variable declarations.
6036!
6037 integer, intent(in) :: ng, tile
6038 integer, intent(in) :: Mstr, Mend
6039# ifdef ASSUMED_SHAPE
6040 real(r8), intent(out) :: tl_state(Mstr:)
6041# else
6042 real(r8), intent(out) :: tl_state(Mstr:Mend)
6043# endif
6044!
6045! Local variable declarations.
6046!
6047 character (len=*), parameter :: MyFile = &
6048 & __FILE__//", tl_pack"
6049
6050# include "tile.h"
6051!
6052# ifdef PROFILE
6053 CALL wclock_on (ng, itlm, 2, __line__, myfile)
6054# endif
6055 CALL tl_pack_tile (ng, tile, &
6056 & lbi, ubi, lbj, ubj, &
6057 & imins, imaxs, jmins, jmaxs, &
6058 & krhs(ng), kstp(ng), knew(ng), &
6059# ifdef SOLVE3D
6060 & nstp(ng), &
6061# endif
6062# ifdef DISTRIBUTE
6063 & 1, mstate(ng), swork, &
6064# else
6065 & mstr, mend, tl_state, &
6066# endif
6067# ifdef MASKING
6068 & grid(ng) % IJwaterR, &
6069 & grid(ng) % IJwaterU, &
6070 & grid(ng) % IJwaterV, &
6071 & grid(ng) % rmask, &
6072 & grid(ng) % umask, &
6073 & grid(ng) % vmask, &
6074# endif
6075 & grid(ng) % h, &
6076# ifdef SOLVE3D
6077 & grid(ng) % Hz, &
6078 & ocean(ng) % tl_t, &
6079 & ocean(ng) % tl_u, &
6080 & ocean(ng) % tl_v, &
6081# else
6082 & ocean(ng) % tl_ubar, &
6083 & ocean(ng) % tl_vbar, &
6084# endif
6085 & ocean(ng) % tl_zeta)
6086
6087# ifdef DISTRIBUTE
6088!
6089! Scatter (global to threaded) tangent linear state solution to all
6090! distributed nodes.
6091!
6092 CALL mp_scatter_state (ng, itlm, mstr, mend, mstate(ng), &
6093 & swork, tl_state)
6094# endif
6095
6096# ifdef PROFILE
6097 CALL wclock_off (ng, itlm, 2, __line__, myfile)
6098# endif
6099!
6100 RETURN
mod_param::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_stepping::krhs
integer, dimension(:), allocatable krhs
Definition mod_stepping.F:65
tl_pack_tile
subroutine tl_pack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, krhs, kstp, knew, nstp, mstr, mend, tl_state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, tl_t, tl_u, tl_v, tl_zeta)
Definition packing.F:6124

References mod_grid::grid, mod_param::itlm, mod_stepping::knew, mod_stepping::krhs, mod_stepping::kstp, distribute_mod::mp_scatter_state(), mod_param::mstate, mod_stepping::nstp, mod_ocean::ocean, mod_storage::swork, tl_pack_tile(), wclock_off(), and wclock_on().

Referenced by __packing_f__(), and propagator_mod::propagator_fte().

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

◆ tl_pack_tile()

subroutine __packing_f__::tl_pack_tile ( integer, intent(in) ng,
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,
integer, intent(in) krhs,
integer, intent(in) kstp,
integer, intent(in) knew,
integer, intent(in) nstp,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(out) tl_state,
integer, dimension(lbi:,lbj:), intent(in) ijwaterr,
integer, dimension(lbi:,lbj:), intent(in) ijwateru,
integer, dimension(lbi:,lbj:), intent(in) ijwaterv,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbi:,lbj:), intent(in) h,
real(r8), dimension(lbi:,lbj:,:), intent(in) hz,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta )
private

Definition at line 6104 of file packing.F.

6124!***********************************************************************
6125!
6126 USE mod_param
6127 USE mod_parallel
6128 USE mod_ncparam
6129 USE mod_scalars
6130!
6131! Imported variable declarations.
6132!
6133 integer, intent(in) :: ng, tile
6134 integer, intent(in) :: LBi, UBi, LBj, UBj
6135 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
6136 integer, intent(in) :: Mstr, Mend
6137 integer, intent(in) :: krhs, kstp, knew
6138# ifdef SOLVE3D
6139 integer, intent(in) :: nstp
6140# endif
6141!
6142# ifdef ASSUMED_SHAPE
6143# ifdef MASKING
6144 integer, intent(in) :: IJwaterR(LBi:,LBj:)
6145 integer, intent(in) :: IJwaterU(LBi:,LBj:)
6146 integer, intent(in) :: IJwaterV(LBi:,LBj:)
6147
6148 real(r8), intent(in) :: rmask(LBi:,LBj:)
6149 real(r8), intent(in) :: umask(LBi:,LBj:)
6150 real(r8), intent(in) :: vmask(LBi:,LBj:)
6151# endif
6152 real(r8), intent(in) :: h(LBi:,LBj:)
6153# ifdef SOLVE3D
6154 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
6155
6156 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
6157 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
6158 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
6159# else
6160 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
6161 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
6162# endif
6163 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
6164
6165 real(r8), intent(out) :: tl_state(Mstr:)
6166# else
6167# ifdef MASKING
6168 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
6169 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
6170 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
6171
6172 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
6173 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
6174 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
6175# endif
6176 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
6177# ifdef SOLVE3D
6178 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
6179
6180 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
6181 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
6182 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
6183# else
6184 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
6185 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
6186# endif
6187 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
6188
6189 real(r8), intent(out) :: tl_state(Mstr:Mend)
6190# endif
6191!
6192! Local variable declarations.
6193!
6194# ifndef MASKING
6195 integer :: Imax, Ioff, Jmax, Joff
6196# endif
6197 integer :: Uoff, Voff
6198 integer :: i, iadd, is, itrc, j, k
6199
6200 integer, dimension(5+NT(ng)) :: offset
6201
6202 real(r8), parameter :: Aspv = 0.0_r8
6203
6204 real(r8) :: cff, scale
6205
6206# include "set_bounds.h"
6207
6208# ifdef DISTRIBUTE
6209!
6210!-----------------------------------------------------------------------
6211! Initialize tangent linear state vector with special value (zero) to
6212! facilitate gathering/scattering communications between all nodes.
6213! This is achieved by summing all the buffers.
6214!-----------------------------------------------------------------------
6215!
6216 DO is=mstr,mend
6217 tl_state(is)=aspv
6218 END DO
6219# endif
6220!
6221!-----------------------------------------------------------------------
6222! Load tangent linear state variables into full 1D state vector.
6223!-----------------------------------------------------------------------
6224!
6225! Set offsets for momentum variables due to periodic boundary
6226! conditions. Recall that in East-West periodic boundary conditions
6227! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
6228! applications IstrV=1 or else IstrV=2.
6229!
6230 IF (ewperiodic(ng)) THEN
6231 uoff=0
6232 ELSE
6233 uoff=1
6234 END IF
6235!
6236 IF (nsperiodic(ng)) THEN
6237 voff=0
6238 ELSE
6239 voff=1
6240 END IF
6241!
6242! Determine the index offset for each variable in the state vector.
6243# ifdef MASKING
6244! Notice that in Land/Sea masking application the state vector only
6245! contains water points to avoid large null space.
6246# endif
6247!
6248# ifdef SOLVE3D
6249# ifdef MASKING
6250 offset(isfsur)=0
6251 offset(isuvel)=offset(isfsur)+nwaterr(ng)
6252 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
6253 iadd=nwaterv(ng)*n(ng)
6254 DO itrc=1,nt(ng)
6255 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6256 iadd=nwaterr(ng)*n(ng)
6257 END DO
6258# else
6259# ifdef FULL_GRID
6260 offset(isfsur)=0
6261 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6262 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
6263 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
6264 DO itrc=1,nt(ng)
6265 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6266 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
6267 END DO
6268# else
6269 offset(isfsur)=0
6270 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
6271
6272 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
6273 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
6274 DO itrc=1,nt(ng)
6275 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6276 iadd=lm(ng)*mm(ng)*n(ng)
6277 END DO
6278# endif
6279# endif
6280# else
6281# ifdef MASKING
6282 offset(isfsur)=0
6283 offset(isubar)=offset(isfsur)+nwaterr(ng)
6284 offset(isvbar)=offset(isubar)+nwateru(ng)
6285# else
6286# ifdef FULL_GRID
6287 offset(isfsur)=0
6288 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6289 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
6290# else
6291 offset(isfsur)=0
6292 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
6293 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
6294# endif
6295# endif
6296# endif
6297!
6298! Load tangent linear free-surface.
6299!
6300# ifndef MASKING
6301# ifdef FULL_GRID
6302 imax=lm(ng)+2
6303 ioff=1
6304 joff=0
6305# else
6306 imax=lm(ng)
6307 ioff=0
6308 joff=1
6309# endif
6310# endif
6311# ifdef ENERGYNORM_SCALE
6312 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
6313# else
6314 scale=1.0_r8
6315# endif
6316 DO j=jr_range
6317 DO i=ir_range
6318# ifdef MASKING
6319 IF (rmask(i,j).gt.0.0_r8) THEN
6320 is=ijwaterr(i,j)+offset(isfsur)
6321 tl_state(is)=scale*tl_zeta(i,j,knew)
6322 END IF
6323# else
6324 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
6325 tl_state(is)=scale*tl_zeta(i,j,knew)
6326# endif
6327 END DO
6328 END DO
6329# ifndef SOLVE3D
6330!
6331! Load tangent linear 2D U-velocity.
6332!
6333# ifndef MASKING
6334# ifdef FULL_GRID
6335 imax=lm(ng)+1
6336 ioff=0
6337 joff=0
6338# else
6339 imax=lm(ng)-uoff
6340 ioff=uoff
6341 joff=1
6342# endif
6343# endif
6344# ifdef ENERGYNORM_SCALE
6345 cff=0.25_r8*rho0
6346# else
6347 scale=1.0_r8
6348# endif
6349 DO j=jr_range
6350 DO i=iu_range
6351# ifdef ENERGYNORM_SCALE
6352 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
6353# endif
6354# ifdef MASKING
6355 IF (umask(i,j).gt.0.0_r8) THEN
6356 is=ijwateru(i,j)+offset(isubar)
6357 tl_state(is)=scale*tl_ubar(i,j,knew)
6358 END IF
6359# else
6360 is=(i-ioff)+(j-joff)*imax+offset(isubar)
6361 tl_state(is)=scale*tl_ubar(i,j,knew)
6362# endif
6363 END DO
6364 END DO
6365!
6366! Load tangent linear 2D V-velocity.
6367!
6368# ifndef MASKING
6369# ifdef FULL_GRID
6370 imax=lm(ng)+2
6371 ioff=1
6372 joff=1
6373# else
6374 imax=lm(ng)
6375 ioff=0
6376 joff=1+voff
6377# endif
6378# endif
6379# ifdef ENERGYNORM_SCALE
6380 cff=0.25_r8*rho0
6381# else
6382 scale=1.0_r8
6383# endif
6384 DO j=jv_range
6385 DO i=ir_range
6386# ifdef ENERGYNORM_SCALE
6387 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
6388# endif
6389# ifdef MASKING
6390 IF (vmask(i,j).gt.0.0_r8) THEN
6391 is=ijwaterv(i,j)+offset(isvbar)
6392 tl_state(is)=scale*tl_vbar(i,j,knew)
6393 END IF
6394# else
6395 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
6396 tl_state(is)=scale*tl_vbar(i,j,knew)
6397# endif
6398 END DO
6399 END DO
6400# else
6401!
6402! Load tangent linear 3D U-velocity.
6403!
6404# ifndef MASKING
6405# ifdef FULL_GRID
6406 imax=lm(ng)+1
6407 jmax=mm(ng)+2
6408 ioff=0
6409 joff=0
6410# else
6411 imax=lm(ng)-uoff
6412 jmax=mm(ng)
6413 ioff=uoff
6414 joff=1
6415# endif
6416# endif
6417# ifdef ENERGYNORM_SCALE
6418 cff=0.25_r8*rho0
6419# else
6420 scale=1.0_r8
6421# endif
6422 DO k=1,n(ng)
6423# ifdef MASKING
6424 iadd=(k-1)*nwateru(ng)+offset(isuvel)
6425# else
6426 iadd=(k-1)*imax*jmax+offset(isuvel)
6427# endif
6428 DO j=jr_range
6429 DO i=iu_range
6430# ifdef MASKING
6431 IF (umask(i,j).gt.0.0_r8) THEN
6432# ifdef ENERGYNORM_SCALE
6433 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
6434# endif
6435 is=ijwateru(i,j)+iadd
6436 tl_state(is)=scale*tl_u(i,j,k,nstp)
6437 END IF
6438# else
6439# ifdef ENERGYNORM_SCALE
6440 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
6441# endif
6442 is=(i-ioff)+(j-joff)*imax+iadd
6443 tl_state(is)=scale*tl_u(i,j,k,nstp)
6444# endif
6445 END DO
6446 END DO
6447 END DO
6448!
6449! Load tangent linear 3D V-velocity.
6450!
6451# ifndef MASKING
6452# ifdef FULL_GRID
6453 imax=lm(ng)+2
6454 jmax=mm(ng)+1
6455 ioff=1
6456 joff=1
6457# else
6458 imax=lm(ng)
6459 jmax=mm(ng)-voff
6460 ioff=0
6461 joff=1+voff
6462# endif
6463# endif
6464# ifdef ENERGYNORM_SCALE
6465 cff=0.25_r8*rho0
6466# else
6467 scale=1.0_r8
6468# endif
6469 DO k=1,n(ng)
6470# ifdef MASKING
6471 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
6472# else
6473 iadd=(k-1)*imax*jmax+offset(isvvel)
6474# endif
6475 DO j=jv_range
6476 DO i=ir_range
6477# ifdef MASKING
6478 IF (vmask(i,j).gt.0.0_r8) THEN
6479# ifdef ENERGYNORM_SCALE
6480 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
6481# endif
6482 is=ijwaterv(i,j)+iadd
6483 tl_state(is)=scale*tl_v(i,j,k,nstp)
6484 END IF
6485# else
6486# ifdef ENERGYNORM_SCALE
6487 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
6488# endif
6489 is=(i+ioff)+(j-joff)*imax+iadd
6490 tl_state(is)=scale*tl_v(i,j,k,nstp)
6491# endif
6492 END DO
6493 END DO
6494 END DO
6495!
6496! Load tangent linear tracers variables. For now, use salinity scale
6497! for passive tracers.
6498!
6499# ifndef MASKING
6500# ifdef FULL_GRID
6501 imax=lm(ng)+2
6502 jmax=mm(ng)+2
6503 ioff=1
6504 joff=0
6505# else
6506 imax=lm(ng)
6507 jmax=mm(ng)
6508 ioff=0
6509 joff=1
6510# endif
6511# endif
6512 DO itrc=1,nt(ng)
6513# ifdef ENERGYNORM_SCALE
6514 IF (itrc.eq.itemp) THEN
6515 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
6516 ELSE IF (itrc.eq.isalt) THEN
6517 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
6518 ELSE
6519 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
6520 END IF
6521# else
6522 scale=1.0_r8
6523# endif
6524 DO k=1,n(ng)
6525# ifdef MASKING
6526 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
6527# else
6528 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
6529# endif
6530 DO j=jr_range
6531 DO i=ir_range
6532# ifdef MASKING
6533 IF (rmask(i,j).gt.0.0_r8) THEN
6534# ifdef ENERGYNORM_SCALE
6535 scale=1.0_r8/sqrt(cff*hz(i,j,k))
6536# endif
6537 is=ijwaterr(i,j)+iadd
6538 tl_state(is)=scale*tl_t(i,j,k,nstp,itrc)
6539 END IF
6540# else
6541# ifdef ENERGYNORM_SCALE
6542 scale=1.0_r8/sqrt(cff*hz(i,j,k))
6543# endif
6544 is=(i+ioff)+(j-joff)*imax+iadd
6545 tl_state(is)=scale*tl_t(i,j,k,nstp,itrc)
6546# endif
6547 END DO
6548 END DO
6549 END DO
6550 END DO
6551# endif
6552!
6553 RETURN

References mod_scalars::bvf_bak, mod_scalars::ewperiodic, mod_scalars::g, mod_scalars::isalt, mod_ncparam::isfsur, mod_ncparam::istvar, mod_ncparam::isubar, mod_ncparam::isuvel, mod_ncparam::isvbar, mod_ncparam::isvvel, mod_scalars::itemp, mod_param::lm, mod_param::mm, mod_scalars::nsperiodic, mod_ncparam::nwaterr, mod_ncparam::nwateru, mod_ncparam::nwaterv, mod_scalars::rho0, mod_scalars::scoef, and mod_scalars::tcoef.

Referenced by tl_pack().

Here is the caller graph for this function:

◆ tl_unpack()

subroutine __packing_f__::tl_unpack ( integer, intent(in) ng,
integer, intent(in) tile,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(in) state )
private

Definition at line 6560 of file packing.F.

6561!
6562!=======================================================================
6563! !
6564! This routine unpacks the tangent linear variables from the state !
6565! vector. If applicable, the state vector includes only unmasked !
6566! water points. !
6567! !
6568!=======================================================================
6569!
6570 USE mod_param
6571 USE mod_grid
6572 USE mod_ocean
6573 USE mod_forces
6574 USE mod_stepping
6575# ifdef DISTRIBUTE
6576 USE mod_storage
6577# endif
6578# ifdef DISTRIBUTE
6579!
6580 USE distribute_mod, ONLY : mp_gather_state
6581# endif
6582!
6583! Imported variable declarations.
6584!
6585 integer, intent(in) :: ng, tile
6586 integer, intent(in) :: Mstr, Mend
6587# ifdef ASSUMED_SHAPE
6588 real(r8), intent(in) :: state(Mstr:)
6589# else
6590 real(r8), intent(in) :: state(Mstr:Mend)
6591# endif
6592!
6593! Local variable declarations.
6594!
6595 character (len=*), parameter :: MyFile = &
6596 & __FILE__//", tl_unpack"
6597!
6598# include "tile.h"
6599!
6600# ifdef PROFILE
6601 CALL wclock_on (ng, itlm, 2, __line__, myfile)
6602# endif
6603
6604# ifdef DISTRIBUTE
6605!
6606! Gather (threaded to global) tangent linear state solution from all
6607! distributed nodes.
6608!
6609 CALL mp_gather_state (ng, itlm, mstr, mend, mstate(ng), &
6610 & state, swork)
6611!
6612# endif
6613 CALL tl_unpack_tile (ng, tile, &
6614 & lbi, ubi, lbj, ubj, &
6615 & imins, imaxs, jmins, jmaxs, &
6616 & kstp(ng), &
6617# ifdef SOLVE3D
6618 & nstp(ng), &
6619# endif
6620# ifdef DISTRIBUTE
6621 & 1, mstate(ng), swork, &
6622# else
6623 & mstr, mend, state, &
6624# endif
6625# ifdef MASKING
6626 & grid(ng) % IJwaterR, &
6627 & grid(ng) % IJwaterU, &
6628 & grid(ng) % IJwaterV, &
6629 & grid(ng) % rmask, &
6630 & grid(ng) % umask, &
6631 & grid(ng) % vmask, &
6632# endif
6633 & grid(ng) % h, &
6634# ifdef SOLVE3D
6635 & grid(ng) % Hz, &
6636 & ocean(ng) % tl_t, &
6637 & ocean(ng) % tl_u, &
6638 & ocean(ng) % tl_v, &
6639# else
6640 & ocean(ng) % tl_ubar, &
6641 & ocean(ng) % tl_vbar, &
6642# endif
6643 & ocean(ng) % tl_zeta, &
6644# ifdef SOLVE3D
6645 & forces(ng) % tl_stflx, &
6646# endif
6647 & forces(ng) % tl_sustr, &
6648 & forces(ng) % tl_svstr)
6649
6650# ifdef PROFILE
6651 CALL wclock_off (ng, itlm, 2, __line__, myfile)
6652# endif
6653!
6654 RETURN
tl_unpack_tile
subroutine tl_unpack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kstp, nstp, mstr, mend, state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, tl_t, tl_u, tl_v, tl_zeta, tl_stflx, tl_sustr, tl_svstr)
Definition packing.F:6682

References mod_forces::forces, mod_grid::grid, mod_param::itlm, mod_stepping::kstp, distribute_mod::mp_gather_state(), mod_param::mstate, mod_stepping::nstp, mod_ocean::ocean, mod_storage::swork, tl_unpack_tile(), wclock_off(), and wclock_on().

Referenced by __packing_f__(), propagator_mod::propagator_fsv(), propagator_mod::propagator_fte(), propagator_mod::propagator_hso(), propagator_mod::propagator_op(), and propagator_mod::propagator_so().

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

◆ tl_unpack_tile()

subroutine __packing_f__::tl_unpack_tile ( integer, intent(in) ng,
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,
integer, intent(in) kstp,
integer, intent(in) nstp,
integer, intent(in) mstr,
integer, intent(in) mend,
real(r8), dimension(mstr:), intent(in) state,
integer, dimension(lbi:,lbj:), intent(in) ijwaterr,
integer, dimension(lbi:,lbj:), intent(in) ijwateru,
integer, dimension(lbi:,lbj:), intent(in) ijwaterv,
real(r8), dimension(lbi:,lbj:), intent(in) rmask,
real(r8), dimension(lbi:,lbj:), intent(in) umask,
real(r8), dimension(lbi:,lbj:), intent(in) vmask,
real(r8), dimension(lbi:,lbj:), intent(in) h,
real(r8), dimension(lbi:,lbj:,:), intent(in) hz,
real(r8), dimension(lbi:,lbj:,:,:,:), intent(inout) tl_t,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_u,
real(r8), dimension(lbi:,lbj:,:,:), intent(inout) tl_v,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_zeta,
real(r8), dimension(lbi:,lbj:,:), intent(inout) tl_stflx,
real(r8), dimension(lbi:,lbj:), intent(inout) tl_sustr,
real(r8), dimension(lbi:,lbj:), intent(inout) tl_svstr )
private

Definition at line 6658 of file packing.F.

6682!***********************************************************************
6683!
6684 USE mod_param
6685 USE mod_parallel
6686 USE mod_forces
6687 USE mod_ncparam
6688 USE mod_ocean
6689 USE mod_scalars
6690!
6691! Imported variable declarations.
6692!
6693 integer, intent(in) :: ng, tile
6694 integer, intent(in) :: LBi, UBi, LBj, UBj
6695 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
6696 integer, intent(in) :: Mstr, Mend
6697 integer, intent(in) :: kstp
6698# ifdef SOLVE3D
6699 integer, intent(in) :: nstp
6700# endif
6701!
6702# ifdef ASSUMED_SHAPE
6703# ifdef MASKING
6704 integer, intent(in) :: IJwaterR(LBi:,LBj:)
6705 integer, intent(in) :: IJwaterU(LBi:,LBj:)
6706 integer, intent(in) :: IJwaterV(LBi:,LBj:)
6707
6708 real(r8), intent(in) :: rmask(LBi:,LBj:)
6709 real(r8), intent(in) :: umask(LBi:,LBj:)
6710 real(r8), intent(in) :: vmask(LBi:,LBj:)
6711# endif
6712 real(r8), intent(in) :: state(Mstr:)
6713 real(r8), intent(in) :: h(LBi:,LBj:)
6714# ifdef SOLVE3D
6715 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
6716
6717 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
6718 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
6719 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
6720 real(r8), intent(inout) :: tl_stflx(LBi:,LBj:,:)
6721# else
6722 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
6723 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
6724# endif
6725 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
6726 real(r8), intent(inout) :: tl_sustr(LBi:,LBj:)
6727 real(r8), intent(inout) :: tl_svstr(LBi:,LBj:)
6728# else
6729# ifdef MASKING
6730 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
6731 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
6732 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
6733
6734 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
6735 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
6736 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
6737# endif
6738 real(r8), intent(in) :: state(Mstr:Mend)
6739 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
6740# ifdef SOLVE3D
6741 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
6742
6743 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
6744 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
6745 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
6746 real(r8), intent(inout) :: tl_stflx(LBi:UBi,LBj:UBj,NT(ng))
6747# else
6748 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
6749 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
6750# endif
6751 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
6752 real(r8), intent(inout) :: tl_sustr(LBi:UBi,LBj:UBj)
6753 real(r8), intent(inout) :: tl_svstr(LBi:UBi,LBj:UBj)
6754# endif
6755!
6756! Local variable declarations.
6757!
6758# ifndef MASKING
6759 integer :: Imax, Ioff, Jmax, Joff
6760# endif
6761 integer :: Uoff, Voff
6762 integer :: i, iadd, icount, is, itrc, j, k
6763
6764# ifdef SALINITY
6765 integer, dimension(7+2*NT(ng)) :: offset
6766# else
6767 integer, dimension(7+2*(NT(ng)+1)) :: offset
6768# endif
6769
6770 real(r8) :: cff, scale
6771
6772# include "set_bounds.h"
6773!
6774!-----------------------------------------------------------------------
6775! Extract tangent linear FORCING variables from full 1D state vector.
6776!-----------------------------------------------------------------------
6777!
6778! Set offsets for momentum variables due to periodic boundary
6779! conditions. Recall that in East-West periodic boundary conditions
6780! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
6781! applications IstrV=1 or else IstrV=2.
6782!
6783 IF (ewperiodic(ng)) THEN
6784 uoff=0
6785 ELSE
6786 uoff=1
6787 END IF
6788!
6789 IF (nsperiodic(ng)) THEN
6790 voff=0
6791 ELSE
6792 voff=1
6793 END IF
6794!
6795! Determine the index offset for each variable in the state vector.
6796# ifdef MASKING
6797! Notice that in Land/Sea masking application the state vector only
6798! contains water points to avoid large null space.
6799# endif
6800!
6801! First clear the "offset" array.
6802!
6803 offset=0
6804!
6805# ifdef SOLVE3D
6806# ifdef MASKING
6807 IF (scalars(ng)%Fstate(isfsur)) THEN
6808 offset(isfsur)=0
6809 END IF
6810 IF (scalars(ng)%Fstate(isuvel)) THEN
6811 offset(isuvel)=offset(isfsur)+nwaterr(ng)
6812 END IF
6813 IF (scalars(ng)%Fstate(isvvel)) THEN
6814 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
6815 END IF
6816 iadd=nwaterv(ng)*n(ng)
6817 DO itrc=1,nt(ng)
6818 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
6819 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6820 iadd=nwaterr(ng)*n(ng)
6821 END IF
6822 END DO
6823 IF (scalars(ng)%Fstate(isustr)) THEN
6824 offset(isustr)=0
6825 END IF
6826 IF (scalars(ng)%Fstate(isvstr)) THEN
6827 offset(isvstr)=offset(isustr)+nwateru(ng)
6828 END IF
6829 DO itrc=1,nt(ng)
6830 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
6831 IF (itrc.eq.1) THEN
6832 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
6833 ELSE
6834 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
6835 END IF
6836 END IF
6837 END DO
6838# else
6839# ifdef FULL_GRID
6840 IF (scalars(ng)%Fstate(isfsur)) THEN
6841 offset(isfsur)=0
6842 END IF
6843 IF (scalars(ng)%Fstate(isuvel)) THEN
6844 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6845 END IF
6846 IF (scalars(ng)%Fstate(isvvel)) THEN
6847 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
6848 END IF
6849 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
6850 DO itrc=1,nt(ng)
6851 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
6852 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6853 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
6854 END IF
6855 END DO
6856 IF (scalars(ng)%Fstate(isustr)) THEN
6857 offset(isustr)=0
6858 END IF
6859 IF (scalars(ng)%Fstate(isvstr)) THEN
6860 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
6861 END IF
6862 DO itrc=1,nt(ng)
6863 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
6864 IF (itrc.eq.1) THEN
6865 offset(istsur(itrc))=offset(isvstr)+ &
6866 & (lm(ng)+2)*(mm(ng)+1)
6867 ELSE
6868 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
6869 & (lm(ng)+2)*(mm(ng)+2)
6870 END IF
6871 END IF
6872 END DO
6873# else
6874 IF (scalars(ng)%Fstate(isfsur)) THEN
6875 offset(isfsur)=0
6876 END IF
6877 IF (scalars(ng)%Fstate(isuvel)) THEN
6878 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
6879 END IF
6880 IF (scalars(ng)%Fstate(isvvel)) THEN
6881 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
6882 END IF
6883 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
6884 DO itrc=1,nt(ng)
6885 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
6886 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6887 iadd=lm(ng)*mm(ng)*n(ng)
6888 END IF
6889 END DO
6890 IF (scalars(ng)%Fstate(isustr)) THEN
6891 offset(isustr)=0
6892 END IF
6893 IF (scalars(ng)%Fstate(isvstr)) THEN
6894 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
6895 END IF
6896 DO itrc=1,nt(ng)
6897 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
6898 IF (itrc.eq.1) THEN
6899 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
6900 ELSE
6901 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
6902 END IF
6903 END IF
6904 END DO
6905# endif
6906# endif
6907# else
6908# ifdef MASKING
6909 IF (scalars(ng)%Fstate(isfsur)) THEN
6910 offset(isfsur)=0
6911 END IF
6912 IF (scalars(ng)%Fstate(isubar)) THEN
6913 offset(isubar)=offset(isfsur)+nwaterr(ng)
6914 END IF
6915 IF (scalars(ng)%Fstate(isvbar)) THEN
6916 offset(isvbar)=offset(isubar)+nwateru(ng)
6917 END IF
6918 IF (scalars(ng)%Fstate(isustr)) THEN
6919 offset(isustr)=0
6920 END IF
6921 IF (scalars(ng)%Fstate(isvstr)) THEN
6922 offset(isvstr)=offset(isustr)+nwateru(ng)
6923 END IF
6924# else
6925# ifdef FULL_GRID
6926 IF (scalars(ng)%Fstate(isfsur)) THEN
6927 offset(isfsur)=0
6928 END IF
6929 IF (scalars(ng)%Fstate(isubar)) THEN
6930 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6931 END IF
6932 IF (scalars(ng)%Fstate(isvbar) THEN
6933 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
6934 END IF
6935 IF (scalars(ng)%Fstate(isustr)) THEN
6936 offset(isustr)=0
6937 END IF
6938 IF (scalars(ng)%Fstate(isvstr)) THEN
6939 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
6940 END IF
6941# else
6942 IF (scalars(ng)%Fstate(isfsur)) THEN
6943 offset(isfsur)=0
6944 END IF
6945 IF (scalars(ng)%Fstate(isubar)) THEN
6946 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
6947 END IF
6948 IF (scalars(ng)%Fstate(isvbar) THEN
6949 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
6950 END IF
6951 IF (scalars(ng)%Fstate(isustr)) THEN
6952 offset(isustr)=0
6953 END IF
6954 IF (scalars(ng)%Fstate(isustr)) THEN
6955 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
6956 END IF
6957# endif
6958# endif
6959# endif
6960!
6961! Extract tangent linear free-surface.
6962!
6963 IF (scalars(ng)%Fstate(isfsur)) THEN
6964# ifndef MASKING
6965# ifdef FULL_GRID
6966 imax=lm(ng)+2
6967 ioff=1
6968 joff=0
6969# else
6970 imax=lm(ng)
6971 ioff=0
6972 joff=1
6973# endif
6974# endif
6975# ifdef ENERGYNORM_SCALE
6976 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
6977# else
6978 scale=1.0_r8
6979# endif
6980 DO j=jr_range
6981 DO i=ir_range
6982# ifdef MASKING
6983 IF (rmask(i,j).gt.0.0_r8) THEN
6984 is=ijwaterr(i,j)+offset(isfsur)
6985 tl_zeta(i,j,kstp)=scale*state(is)
6986 ELSE
6987 tl_zeta(i,j,kstp)=0.0_r8
6988 END IF
6989# else
6990 is=(i-ioff)+(j-joff)*imax+offset(isfsur)
6991 tl_zeta(i,j,kstp)=scale*state(is)
6992# endif
6993 END DO
6994 END DO
6995 END IF
6996
6997# ifndef SOLVE3D
6998!
6999! Extract tangent linear 2D U-velocity.
7000!
7001 IF (scalars(ng)%Fstate(isubar)) THEN
7002# ifndef MASKING
7003# ifdef FULL_GRID
7004 imax=lm(ng)+1
7005 ioff=0
7006 joff=0
7007# else
7008 imax=lm(ng)-uoff
7009 ioff=uoff
7010 joff=1
7011# endif
7012# endif
7013# ifdef ENERGYNORM_SCALE
7014 cff=0.25_r8*rho0
7015# else
7016 scale=1.0_r8
7017# endif
7018 DO j=jr_range
7019 DO i=iu_range
7020# ifdef ENERGYNORM_SCALE
7021 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
7022# endif
7023# ifdef MASKING
7024 IF (umask(i,j).gt.0.0_r8) THEN
7025 is=ijwateru(i,j)+offset(isubar)
7026 tl_ubar(i,j,kstp)=scale*state(is)
7027 ELSE
7028 tl_ubar(i,j,kstp)=0.0_r8
7029 END IF
7030# else
7031 is=(i-ioff)+(j-joff)*imax+offset(isubar)
7032 tl_ubar(i,j,kstp)=scale*state(is)
7033# endif
7034 END DO
7035 END DO
7036 END IF
7037!
7038! Extract tangent linear 2D V-velocity.
7039!
7040 IF (scalars(ng)%Fstate(isvbar)) THEN
7041# ifndef MASKING
7042# ifdef FULL_GRID
7043 imax=lm(ng)+2
7044 ioff=1
7045 joff=1
7046# else
7047 imax=lm(ng)
7048 ioff=0
7049 joff=1+voff
7050# endif
7051# endif
7052# ifdef ENERGYNORM_SCALE
7053 cff=0.25_r8*rho0
7054# else
7055 scale=1.0_r8
7056# endif
7057 DO j=jv_range
7058 DO i=ir_range
7059# ifdef ENERGYNORM_SCALE
7060 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
7061# endif
7062# ifdef MASKING
7063 IF (vmask(i,j).gt.0.0_r8) THEN
7064 is=ijwaterv(i,j)+offset(isvbar)
7065 tl_vbar(i,j,kstp)=scale*state(is)
7066 ELSE
7067 tl_vbar(i,j,kstp)=0.0_r8
7068 END IF
7069# else
7070 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
7071 tl_vbar(i,j,kstp)=scale*state(is)
7072# endif
7073 END DO
7074 END DO
7075 END IF
7076
7077# else
7078!
7079! Extract tangent linear 3D U-velocity.
7080!
7081 IF (scalars(ng)%Fstate(isuvel)) THEN
7082# ifndef MASKING
7083# ifdef FULL_GRID
7084 imax=lm(ng)+1
7085 jmax=mm(ng)+2
7086 ioff=0
7087 joff=0
7088# else
7089 imax=lm(ng)-uoff
7090 jmax=mm(ng)
7091 ioff=uoff
7092 joff=1
7093# endif
7094# endif
7095# ifdef ENERGYNORM_SCALE
7096 cff=0.25_r8*rho0
7097# else
7098 scale=1.0_r8
7099# endif
7100 DO k=1,n(ng)
7101# ifdef MASKING
7102 iadd=(k-1)*nwateru(ng)+offset(isuvel)
7103# else
7104 iadd=(k-1)*imax*jmax+offset(isuvel)
7105# endif
7106 DO j=jr_range
7107 DO i=iu_range
7108# ifdef MASKING
7109 IF (umask(i,j).gt.0.0_r8) THEN
7110# ifdef ENERGYNORM_SCALE
7111 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
7112# endif
7113 is=ijwateru(i,j)+iadd
7114 tl_u(i,j,k,nstp)=scale*state(is)
7115 ELSE
7116 tl_u(i,j,k,nstp)=0.0_r8
7117 END IF
7118# else
7119# ifdef ENERGYNORM_SCALE
7120 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
7121# endif
7122 is=(i-ioff)+(j-joff)*imax+iadd
7123 tl_u(i,j,k,nstp)=scale*state(is)
7124# endif
7125 END DO
7126 END DO
7127 END DO
7128 END IF
7129!
7130! Extract tangent linear 3D V-velocity.
7131!
7132 IF (scalars(ng)%Fstate(isvvel)) THEN
7133# ifndef MASKING
7134# ifdef FULL_GRID
7135 imax=lm(ng)+2
7136 jmax=mm(ng)+1
7137 ioff=1
7138 joff=1
7139# else
7140 imax=lm(ng)
7141 jmax=mm(ng)-voff
7142 ioff=0
7143 joff=1+voff
7144# endif
7145# endif
7146# ifdef ENERGYNORM_SCALE
7147 cff=0.25_r8*rho0
7148# else
7149 scale=1.0_r8
7150# endif
7151 DO k=1,n(ng)
7152# ifdef MASKING
7153 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
7154# else
7155 iadd=(k-1)*imax*jmax+offset(isvvel)
7156# endif
7157 DO j=jv_range
7158 DO i=ir_range
7159# ifdef MASKING
7160 IF (vmask(i,j).gt.0.0_r8) THEN
7161# ifdef ENERGYNORM_SCALE
7162 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
7163# endif
7164 is=ijwaterv(i,j)+iadd
7165 tl_v(i,j,k,nstp)=scale*state(is)
7166 ELSE
7167 tl_v(i,j,k,nstp)=0.0_r8
7168 END IF
7169# else
7170# ifdef ENERGYNORM_SCALE
7171 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
7172# endif
7173 is=(i+ioff)+(j-joff)*imax+iadd
7174 tl_v(i,j,k,nstp)=scale*state(is)
7175# endif
7176 END DO
7177 END DO
7178 END DO
7179 END IF
7180!
7181! Extract tangent linear tracers variables.
7182!
7183 DO itrc=1,nt(ng)
7184 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
7185# ifndef MASKING
7186# ifdef FULL_GRID
7187 imax=lm(ng)+2
7188 jmax=mm(ng)+2
7189 ioff=1
7190 joff=0
7191# else
7192 imax=lm(ng)
7193 jmax=mm(ng)
7194 ioff=0
7195 joff=1
7196# endif
7197# endif
7198# ifdef ENERGYNORM_SCALE
7199 IF (itrc.eq.itemp) THEN
7200 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
7201 ELSE IF (itrc.eq.isalt) THEN
7202 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
7203 ELSE
7204 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
7205 END IF
7206# else
7207 scale=1.0_r8
7208# endif
7209 DO k=1,n(ng)
7210# ifdef MASKING
7211 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
7212# else
7213 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
7214# endif
7215 DO j=jr_range
7216 DO i=ir_range
7217# ifdef MASKING
7218 IF (rmask(i,j).gt.0.0_r8) THEN
7219# ifdef ENERGYNORM_SCALE
7220 scale=1.0_r8/sqrt(cff*hz(i,j,k))
7221# endif
7222 is=ijwaterr(i,j)+iadd
7223 tl_t(i,j,k,nstp,itrc)=scale*state(is)
7224 ELSE
7225 tl_t(i,j,k,nstp,itrc)=0.0_r8
7226 END IF
7227# else
7228# ifdef ENERGYNORM_SCALE
7229 scale=1.0_r8/sqrt(cff*hz(i,j,k))
7230# endif
7231 is=(i+ioff)+(j-joff)*imax+iadd
7232 tl_t(i,j,k,nstp,itrc)=scale*state(is)
7233# endif
7234 END DO
7235 END DO
7236 END DO
7237 END IF
7238 END DO
7239# endif
7240!
7241! Extract tangent linear surface U-momentum stress.
7242!
7243 IF (scalars(ng)%Fstate(isustr)) THEN
7244# ifndef MASKING
7245# ifdef FULL_GRID
7246 imax=lm(ng)+1
7247 ioff=0
7248 joff=0
7249# else
7250 imax=lm(ng)-uoff
7251 ioff=uoff
7252 joff=1
7253# endif
7254# endif
7255 scale=1.0_r8
7256 DO j=jr_range
7257 DO i=iu_range
7258# ifdef MASKING
7259 IF (umask(i,j).gt.0.0_r8) THEN
7260 is=ijwateru(i,j)+offset(isustr)
7261 tl_sustr(i,j)=scale*state(is)
7262 ELSE
7263 tl_sustr(i,j)=0.0_r8
7264 END IF
7265# else
7266 is=(i-ioff)+(j-joff)*imax+offset(isustr)
7267 tl_sustr(i,j)=scale*state(is)
7268# endif
7269 END DO
7270 END DO
7271 END IF
7272!
7273! Extract tangent linear surface V-momentum stress.
7274!
7275 IF (scalars(ng)%Fstate(isvstr)) THEN
7276# ifndef MASKING
7277# ifdef FULL_GRID
7278 imax=lm(ng)+2
7279 ioff=1
7280 joff=1
7281# else
7282 imax=lm(ng)
7283 ioff=0
7284 joff=1+voff
7285# endif
7286# endif
7287 scale=1.0_r8
7288 DO j=jv_range
7289 DO i=ir_range
7290# ifdef MASKING
7291 IF (vmask(i,j).gt.0.0_r8) THEN
7292 is=ijwaterv(i,j)+offset(isvstr)
7293 tl_svstr(i,j)=scale*state(is)
7294 ELSE
7295 tl_svstr(i,j)=0.0_r8
7296 END IF
7297# else
7298 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
7299 tl_svstr(i,j)=scale*state(is)
7300# endif
7301 END DO
7302 END DO
7303 END IF
7304
7305# ifdef SOLVE3D
7306!
7307! Extract tangent linear surface tracer flux variables.
7308!
7309 DO itrc=1,nt(ng)
7310 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
7311# ifndef MASKING
7312# ifdef FULL_GRID
7313 imax=lm(ng)+2
7314 jmax=mm(ng)+2
7315 ioff=1
7316 joff=0
7317# else
7318 imax=lm(ng)
7319 jmax=mm(ng)
7320 ioff=0
7321 joff=1
7322# endif
7323# endif
7324 scale=1.0_r8
7325 DO j=jr_range
7326 DO i=ir_range
7327# ifdef MASKING
7328 IF (rmask(i,j).gt.0.0_r8) THEN
7329 is=ijwaterr(i,j)+offset(istsur(itrc))
7330 tl_stflx(i,j,itrc)=scale*state(is)
7331 ELSE
7332 tl_stflx(i,j,itrc)=0.0_r8
7333 END IF
7334# else
7335 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
7336 tl_stflx(i,j,itrc)=scale*state(is)
7337# endif
7338 END DO
7339 END DO
7340 END IF
7341 END DO
7342# endif
7343!
7344 RETURN

References mod_scalars::bvf_bak, 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_forces::forces, mod_scalars::g, mod_grid::grid, mod_scalars::isalt, mod_ncparam::isfsur, mod_ncparam::istsur, mod_ncparam::istvar, mod_ncparam::isubar, mod_ncparam::isustr, mod_ncparam::isuvel, mod_ncparam::isvbar, mod_ncparam::isvstr, mod_ncparam::isvvel, mod_scalars::itemp, mod_param::itlm, mod_stepping::kstp, mod_param::lm, mod_param::mm, mp_exchange_mod::mp_exchange2d(), mp_exchange_mod::mp_exchange3d(), mp_exchange_mod::mp_exchange4d(), distribute_mod::mp_gather_state(), mod_param::mstate, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_stepping::nstp, mod_ncparam::nwaterr, mod_ncparam::nwateru, mod_ncparam::nwaterv, mod_ocean::ocean, mod_scalars::rho0, mod_scalars::scalars, mod_scalars::scoef, mod_storage::swork, mod_scalars::tcoef, tl_unpack_tile(), wclock_off(), and wclock_on().

Referenced by tl_unpack(), and tl_unpack_tile().

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