module mrg_x2a_mct 1,6
use shr_kind_mod
, only: r8 => shr_kind_r8
use mct_mod
use seq_flds_mod
use seq_flds_indices
use seq_comm_mct
use seq_cdata_mod
implicit none
save
private ! except
!--------------------------------------------------------------------------
! Public interfaces
!--------------------------------------------------------------------------
public :: mrg_x2a_init_mct
public :: mrg_x2a_run_mct
public :: mrg_x2a_final_mct
!--------------------------------------------------------------------------
! Private interfaces
!--------------------------------------------------------------------------
!
!--------------------------------------------------------------------------
! Private data
!--------------------------------------------------------------------------
!
!===========================================================================================
contains
!===========================================================================================
!
subroutine mrg_x2a_init_mct( cdata_a, l2x_a, o2x_a, i2x_a, xao_a ) 1,1
!-----------------------------------------------------------------------
!
! Arguments
!
type(seq_cdata), intent(in) :: cdata_a
type(mct_aVect), intent(inout) :: l2x_a
type(mct_aVect), intent(inout) :: o2x_a
type(mct_aVect), intent(inout) :: i2x_a
type(mct_aVect), intent(inout) :: xao_a
!
! Locals
!
type(mct_gsmap), pointer :: gsMap_a
integer :: lsize
integer :: mpicom
!-----------------------------------------------------------------------
! Get atmosphere gsMap
call seq_cdata_setptrs(cdata_a, gsMap=gsMap_a, mpicom=mpicom)
lsize = mct_GSMap_lsize(GSMap_a, mpicom)
! Initialize av for land export state on atmosphere grid/ decomp
call mct_aVect_init(l2x_a, rList=seq_flds_l2x_fields, lsize=lsize)
call mct_aVect_zero(l2x_a)
! Initialize av for ocn export state on atmosphere grid/decomp
call mct_aVect_init(o2x_a, rList=seq_flds_o2x_fields, lsize=lsize)
call mct_aVect_zero(o2x_a)
! Initialize av for ice export state on atmosphere grid/decomp
call mct_aVect_init(i2x_a, rList=seq_flds_i2x_fields, lsize=lsize)
call mct_aVect_zero(i2x_a)
! Initialize av for atm/ocn flux calculation on atmosphere grid/decomp
call mct_aVect_init(xao_a, rList=seq_flds_xao_fields, lsize=lsize)
call mct_aVect_zero(xao_a)
end subroutine mrg_x2a_init_mct
!===========================================================================================
subroutine mrg_x2a_run_mct( cdata_a, l2x_a, o2x_a, xao_a, i2x_a, fractions_a, x2a_a ) 2
!-----------------------------------------------------------------------
!
! Arguments
!
type(seq_cdata), intent(in) :: cdata_a
type(mct_aVect), intent(in) :: l2x_a
type(mct_aVect), intent(in) :: o2x_a
type(mct_aVect), intent(in) :: xao_a
type(mct_aVect), intent(in) :: i2x_a
type(mct_aVect), intent(in) :: fractions_a
type(mct_aVect), intent(inout) :: x2a_a
!-----------------------------------------------------------------------
!
! Local workspace
!
logical :: usevector ! use vector-friendly mct_copy
integer :: n, ki, kl, ko ! indices
real(r8) :: frac ! temporary
integer :: lsize ! temporary
!-----------------------------------------------------------------------
!
! Zero attribute vector
!
call mct_avect_zero(x2a_a)
!
! Update surface fractions
!
! lSize = mct_avect_lSize(x2a_a)
ki=mct_aVect_indexRA(fractions_a,"ifrac")
kl=mct_aVect_indexRA(fractions_a,"lfrac")
ko=mct_aVect_indexRA(fractions_a,"ofrac")
! do n = 1,lSize
! tcx moved below (after the avect_copy) to reduce risk and improve cache use
! x2a_a%rAttr(index_x2a_Sx_lfrac,n) = fractions_a%Rattr(kl,n)
! x2a_a%rAttr(index_x2a_Sx_ifrac,n) = fractions_a%Rattr(ki,n)
! x2a_a%rAttr(index_x2a_Sx_ofrac,n) = fractions_a%Rattr(ko,n)
! end do
!
! Copy attributes that do not need to be merged
! These are assumed to have the same name in
! (o2x_a and x2a_a) and in (l2x_a and x2a_a), etc.
!
#ifdef CPP_VECTOR
usevector = .true.
#else
usevector = .false.
#endif
call mct_aVect_copy(aVin=l2x_a, aVout=x2a_a, vector=usevector)
call mct_aVect_copy(aVin=o2x_a, aVout=x2a_a, vector=usevector)
call mct_aVect_copy(aVin=i2x_a, aVout=x2a_a, vector=usevector)
call mct_aVect_copy(aVin=xao_a, aVout=x2a_a, vector=usevector)
!
! Merge based on fractional cell coverage
!
lsize = mct_avect_lsize(x2a_a)
do n = 1,lsize
x2a_a%rAttr(index_x2a_Sx_lfrac,n) = fractions_a%Rattr(kl,n)
x2a_a%rAttr(index_x2a_Sx_ifrac,n) = fractions_a%Rattr(ki,n)
x2a_a%rAttr(index_x2a_Sx_ofrac,n) = fractions_a%Rattr(ko,n)
frac = x2a_a%rAttr(index_x2a_Sx_lfrac,n)
if (frac > 0._r8) then
x2a_a%rAttr(index_x2a_Sx_avsdr,n) = x2a_a%rAttr(index_x2a_Sx_avsdr,n) + &
l2x_a%rAttr(index_l2x_Sl_avsdr,n) * frac
x2a_a%rAttr(index_x2a_Sx_avsdf,n) = x2a_a%rAttr(index_x2a_Sx_avsdf,n) + &
l2x_a%rAttr(index_l2x_Sl_avsdf,n) * frac
x2a_a%rAttr(index_x2a_Sx_anidr,n) = x2a_a%rAttr(index_x2a_Sx_anidr,n) + &
l2x_a%rAttr(index_l2x_Sl_anidr,n) * frac
x2a_a%rAttr(index_x2a_Sx_anidf,n) = x2a_a%rAttr(index_x2a_Sx_anidf,n) + &
l2x_a%rAttr(index_l2x_Sl_anidf,n) * frac
x2a_a%rAttr(index_x2a_Sx_tref,n) = x2a_a%rAttr(index_x2a_Sx_tref,n) + &
l2x_a%rAttr(index_l2x_Sl_tref,n) * frac
x2a_a%rAttr(index_x2a_Sx_qref,n) = x2a_a%rAttr(index_x2a_Sx_qref,n) + &
l2x_a%rAttr(index_l2x_Sl_qref,n) * frac
x2a_a%rAttr(index_x2a_Faxx_evap,n) = x2a_a%rAttr(index_x2a_Faxx_evap,n) + &
l2x_a%rAttr(index_l2x_Fall_evap,n) * frac
x2a_a%rAttr(index_x2a_Faxx_lwup,n) = x2a_a%rAttr(index_x2a_Faxx_lwup,n) + &
l2x_a%rAttr(index_l2x_Fall_lwup,n) * frac
x2a_a%rAttr(index_x2a_Faxx_sen,n) = x2a_a%rAttr(index_x2a_Faxx_sen,n) + &
l2x_a%rAttr(index_l2x_Fall_sen,n) * frac
x2a_a%rAttr(index_x2a_Faxx_lat,n) = x2a_a%rAttr(index_x2a_Faxx_lat,n) + &
l2x_a%rAttr(index_l2x_Fall_lat,n) * frac
x2a_a%rAttr(index_x2a_Faxx_taux,n) = x2a_a%rAttr(index_x2a_Faxx_taux,n) + &
l2x_a%rAttr(index_l2x_Fall_taux,n) * frac
x2a_a%rAttr(index_x2a_Faxx_tauy,n) = x2a_a%rAttr(index_x2a_Faxx_tauy,n) + &
l2x_a%rAttr(index_l2x_Fall_tauy,n) * frac
x2a_a%rAttr(index_x2a_Sx_t,n) = x2a_a%rAttr(index_x2a_Sx_t,n) + &
l2x_a%rAttr(index_l2x_Sl_t,n) * frac
!--- CO2 flux from lnd ---
if ( (index_x2a_Faxx_fco2_lnd /=0) .and. (index_l2x_Fall_nee /=0)) then
x2a_a%rAttr(index_x2a_Faxx_fco2_lnd,n) = l2x_a%rAttr(index_l2x_Fall_nee,n) * frac
end if
if ( index_x2a_Faxx_flxvoc1 /= 0 ) &
x2a_a%rAttr(index_x2a_Faxx_flxvoc1,n) = l2x_a%rAttr(index_l2x_Fall_flxvoc1,n)* frac
if ( index_x2a_Faxx_flxvoc2 /= 0 ) &
x2a_a%rAttr(index_x2a_Faxx_flxvoc2,n) = l2x_a%rAttr(index_l2x_Fall_flxvoc2,n)* frac
if ( index_x2a_Faxx_flxvoc3 /= 0 ) &
x2a_a%rAttr(index_x2a_Faxx_flxvoc3,n) = l2x_a%rAttr(index_l2x_Fall_flxvoc3,n)* frac
if ( index_x2a_Faxx_flxvoc4 /= 0 ) &
x2a_a%rAttr(index_x2a_Faxx_flxvoc4,n) = l2x_a%rAttr(index_l2x_Fall_flxvoc4,n)* frac
if ( index_x2a_Faxx_flxvoc5 /= 0 ) &
x2a_a%rAttr(index_x2a_Faxx_flxvoc5,n) = l2x_a%rAttr(index_l2x_Fall_flxvoc5,n)* frac
end if
frac = x2a_a%rAttr(index_x2a_Sx_ifrac,n)
if (frac > 0._r8) then
x2a_a%rAttr(index_x2a_Sx_avsdr,n) = x2a_a%rAttr(index_x2a_Sx_avsdr,n) + &
i2x_a%rAttr(index_i2x_Si_avsdr,n) * frac
x2a_a%rAttr(index_x2a_Sx_avsdf,n) = x2a_a%rAttr(index_x2a_Sx_avsdf,n) + &
i2x_a%rAttr(index_i2x_Si_avsdf,n) * frac
x2a_a%rAttr(index_x2a_Sx_anidr,n) = x2a_a%rAttr(index_x2a_Sx_anidr,n) + &
i2x_a%rAttr(index_i2x_Si_anidr,n) * frac
x2a_a%rAttr(index_x2a_Sx_anidf,n) = x2a_a%rAttr(index_x2a_Sx_anidf,n) + &
i2x_a%rAttr(index_i2x_Si_anidf,n) * frac
x2a_a%rAttr(index_x2a_Sx_tref,n) = x2a_a%rAttr(index_x2a_Sx_tref,n) + &
i2x_a%rAttr(index_i2x_Si_tref,n) * frac
x2a_a%rAttr(index_x2a_Sx_qref,n) = x2a_a%rAttr(index_x2a_Sx_qref,n) + &
i2x_a%rAttr(index_i2x_Si_qref,n) * frac
x2a_a%rAttr(index_x2a_Faxx_evap,n) = x2a_a%rAttr(index_x2a_Faxx_evap,n) + &
i2x_a%rAttr(index_i2x_Faii_evap,n) * frac
x2a_a%rAttr(index_x2a_Faxx_lwup,n) = x2a_a%rAttr(index_x2a_Faxx_lwup,n) + &
i2x_a%rAttr(index_i2x_Faii_lwup,n) * frac
x2a_a%rAttr(index_x2a_Faxx_sen,n) = x2a_a%rAttr(index_x2a_Faxx_sen,n) + &
i2x_a%rAttr(index_i2x_Faii_sen,n) * frac
x2a_a%rAttr(index_x2a_Faxx_lat,n) = x2a_a%rAttr(index_x2a_Faxx_lat,n) + &
i2x_a%rAttr(index_i2x_Faii_lat,n) * frac
x2a_a%rAttr(index_x2a_Faxx_taux,n) = x2a_a%rAttr(index_x2a_Faxx_taux,n) + &
i2x_a%rAttr(index_i2x_Faii_taux,n) * frac
x2a_a%rAttr(index_x2a_Faxx_tauy,n) = x2a_a%rAttr(index_x2a_Faxx_tauy,n) + &
i2x_a%rAttr(index_i2x_Faii_tauy,n) * frac
x2a_a%rAttr(index_x2a_Sx_t,n) = x2a_a%rAttr(index_x2a_Sx_t,n) + &
i2x_a%rAttr(index_i2x_Si_t,n) * frac
end if
frac = x2a_a%rAttr(index_x2a_Sx_ofrac,n)
if (frac > 0._r8) then
x2a_a%rAttr(index_x2a_Sx_avsdr,n) = x2a_a%rAttr(index_x2a_Sx_avsdr,n) + &
xao_a%rAttr(index_xao_So_avsdr,n) * frac
x2a_a%rAttr(index_x2a_Sx_avsdf,n) = x2a_a%rAttr(index_x2a_Sx_avsdf,n) + &
xao_a%rAttr(index_xao_So_avsdf,n) * frac
x2a_a%rAttr(index_x2a_Sx_anidr,n) = x2a_a%rAttr(index_x2a_Sx_anidr,n) + &
xao_a%rAttr(index_xao_So_anidr,n) * frac
x2a_a%rAttr(index_x2a_Sx_anidf,n) = x2a_a%rAttr(index_x2a_Sx_anidf,n) + &
xao_a%rAttr(index_xao_So_anidf,n) * frac
x2a_a%rAttr(index_x2a_Sx_tref,n) = x2a_a%rAttr(index_x2a_Sx_tref,n) + &
xao_a%rAttr(index_xao_So_tref,n) * frac
x2a_a%rAttr(index_x2a_Sx_qref,n) = x2a_a%rAttr(index_x2a_Sx_qref,n) + &
xao_a%rAttr(index_xao_So_qref,n) * frac
x2a_a%rAttr(index_x2a_Faxx_evap,n) = x2a_a%rAttr(index_x2a_Faxx_evap,n) + &
xao_a%rAttr(index_xao_Faox_evap,n) * frac
x2a_a%rAttr(index_x2a_Faxx_lwup,n) = x2a_a%rAttr(index_x2a_Faxx_lwup,n) + &
xao_a%rAttr(index_xao_Faox_lwup,n) * frac
x2a_a%rAttr(index_x2a_Faxx_sen,n) = x2a_a%rAttr(index_x2a_Faxx_sen,n) + &
xao_a%rAttr(index_xao_Faox_sen,n) * frac
x2a_a%rAttr(index_x2a_Faxx_lat,n) = x2a_a%rAttr(index_x2a_Faxx_lat,n) + &
xao_a%rAttr(index_xao_Faox_lat,n) * frac
x2a_a%rAttr(index_x2a_Faxx_taux,n) = x2a_a%rAttr(index_x2a_Faxx_taux,n) + &
xao_a%rAttr(index_xao_Faox_taux,n) * frac
x2a_a%rAttr(index_x2a_Faxx_tauy,n) = x2a_a%rAttr(index_x2a_Faxx_tauy,n) + &
xao_a%rAttr(index_xao_Faox_tauy,n) * frac
x2a_a%rAttr(index_x2a_Sx_t,n) = x2a_a%rAttr(index_x2a_Sx_t,n) + &
o2x_a%rAttr(index_o2x_So_t,n) * frac
end if
!--- CO2 flux from ocn ---
if ( (index_x2a_Faxx_fco2_ocn /=0) .and. (index_o2x_Faoo_fco2 /=0)) then
x2a_a%rAttr(index_x2a_Faxx_fco2_ocn,n) = o2x_a%rAttr(index_o2x_Faoo_fco2,n)
end if
!--- DMS flux from ocn ---
if ( (index_x2a_Faxx_fdms /=0) .and. (index_o2x_Faoo_fdms /=0)) then
x2a_a%rAttr(index_x2a_Faxx_fdms,n) = o2x_a%rAttr(index_o2x_Faoo_fdms,n)
end if
end do
end subroutine mrg_x2a_run_mct
!
!===========================================================================================
!
subroutine mrg_x2a_final_mct
! ******************
! Do nothing for now
! ******************
end subroutine mrg_x2a_final_mct
end module mrg_x2a_mct