module mrg_x2o_mct 1,7 use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl use mct_mod use seq_flds_mod use seq_flds_indices use seq_comm_mct use seq_cdata_mod use seq_infodata_mod implicit none save private ! except !-------------------------------------------------------------------------- ! Public interfaces !-------------------------------------------------------------------------- public :: mrg_x2o_init_mct public :: mrg_x2o_run_mct public :: mrg_x2o_final_mct !-------------------------------------------------------------------------- ! Private data !-------------------------------------------------------------------------- !=========================================================================================== contains !=========================================================================================== subroutine mrg_x2o_init_mct( cdata_o, a2x_o, i2x_o, r2x_o ) 1,1 !----------------------------------------------------------------------- type(seq_cdata), intent(in) :: cdata_o type(mct_aVect), intent(inout) :: a2x_o type(mct_aVect), intent(inout) :: i2x_o type(mct_aVect), intent(inout) :: r2x_o type(mct_gsMap), pointer :: gsMap_ocn integer :: mpicom !----------------------------------------------------------------------- ! Set gsMap call seq_cdata_setptrs(cdata_o, gsMap=gsMap_ocn, mpicom=mpicom) ! Initialize av for atmosphere export state on ocn decomp call mct_aVect_init(a2x_o, rList=seq_flds_a2x_fields, & lsize=MCT_GSMap_lsize(GSMap_ocn, mpicom)) call mct_aVect_zero(a2x_o) ! Initialize av for ice export state on ocn decomp call mct_aVect_init(i2x_o, rList=seq_flds_i2x_fields, & lsize=mct_GSMap_lsize(GSMap_ocn, mpicom)) call mct_aVect_zero(i2x_o) ! Initialize av for rof export state on ocn decomp call mct_aVect_init(r2x_o, rList=seq_flds_r2x_fields, & lsize=mct_GSMap_lsize(GSMap_ocn, mpicom)) call mct_aVect_zero(r2x_o) end subroutine mrg_x2o_init_mct !=========================================================================================== !! subroutine mrg_x2o_run_mct( cdata_o, a2x_o, i2x_o, r2x_o, xao_o, fractions_o, x2o_o ) subroutine mrg_x2o_run_mct( cdata_o, a2x_o, i2x_o, xao_o, fractions_o, x2o_o ) 1,3 !----------------------------------------------------------------------- ! ! Arguments ! type(seq_cdata), intent(in) :: cdata_o type(mct_aVect), intent(in) :: a2x_o type(mct_aVect), intent(in) :: i2x_o !! type(mct_aVect), intent(in) :: r2x_o type(mct_aVect), intent(in) :: xao_o type(mct_aVect), intent(in) :: fractions_o type(mct_aVect), intent(inout) :: x2o_o ! ! Local variables ! integer :: n, ki, ko, kir, kor integer :: lsize real(r8) :: ifrac,ifracr real(r8) :: afrac,afracr logical :: usevector ! use vector-friendly mct_copy real(r8) :: flux_epbalfact character(len=cl) :: flux_epbal type(seq_infodata_type),pointer :: infodata real(r8) :: frac_sum real(r8) :: avsdr, anidr, avsdf, anidf ! albedos real(r8) :: fswabsv, fswabsi ! sw !----- formats ----- character(*),parameter :: F01 = "('(mrg_x2o_run_mct) ',a,3e11.3,a,f9.6)" character(*),parameter :: subName = '(mrg_x2o_run_mct) ' !----------------------------------------------------------------------- ! ! Copy runoff vector directly ! #ifdef CPP_VECTOR usevector = .true. #else usevector = .false. #endif call seq_cdata_setptrs(cdata_o, infodata=infodata) call mct_aVect_zero(x2o_o) call mct_aVect_copy(aVin=a2x_o, aVout=x2o_o, vector=usevector) call mct_aVect_copy(aVin=i2x_o, aVout=x2o_o, vector=usevector) ! tcx moved out to a separate accumulate !! call mct_aVect_copy(aVin=r2x_o, aVout=x2o_o, vector=usevector) call mct_aVect_copy(aVin=xao_o, aVout=x2o_o, vector=usevector) call seq_infodata_GetData(infodata,flux_epbal=flux_epbal) flux_epbalfact = 1.0_r8 if (trim(flux_epbal) == 'ocn') then call seq_infodata_GetData(infodata, precip_fact = flux_epbalfact) flux_epbalfact = flux_epbalfact * 1.0e-6_r8 end if if (flux_epbalfact <= 0.0_R8) then if (loglevel > 0) write(logunit,F01) 'WARNING: factor from ocn = ',flux_epbalfact if (loglevel > 0) write(logunit,F01) 'WARNING: resetting flux_epbalfact to 1.0' flux_epbalfact = 1.0_r8 end if ! ! Compute input ocn state (note that this only applies to non-land portion of gridcell) ! ki = mct_aVect_indexRa(fractions_o,"ifrac",perrWith=subName) ko = mct_aVect_indexRa(fractions_o,"ofrac",perrWith=subName) kir = mct_aVect_indexRa(fractions_o,"ifrad",perrWith=subName) kor = mct_aVect_indexRa(fractions_o,"ofrad",perrWith=subName) lsize = mct_aVect_lsize(x2o_o) do n = 1,lsize ifrac = fractions_o%rAttr(ki,n) afrac = fractions_o%rAttr(ko,n) frac_sum = ifrac + afrac if ((frac_sum) /= 0._r8) then ifrac = ifrac / (frac_sum) afrac = afrac / (frac_sum) endif ifracr = fractions_o%rAttr(kir,n) afracr = fractions_o%rAttr(kor,n) frac_sum = ifracr + afracr if ((frac_sum) /= 0._r8) then ifracr = ifracr / (frac_sum) afracr = afracr / (frac_sum) endif x2o_o%rAttr(index_x2o_Foxx_taux ,n) = xao_o%rAttr(index_xao_Faox_taux ,n) * afrac + & i2x_o%rAttr(index_i2x_Fioi_taux ,n) * ifrac x2o_o%rAttr(index_x2o_Foxx_tauy ,n) = xao_o%rAttr(index_xao_Faox_tauy ,n) * afrac + & i2x_o%rAttr(index_i2x_Fioi_tauy ,n) * ifrac ! --- was flux_solar: avsdr = xao_o%rAttr(index_xao_So_avsdr,n) anidr = xao_o%rAttr(index_xao_So_anidr,n) avsdf = xao_o%rAttr(index_xao_So_avsdf,n) anidf = xao_o%rAttr(index_xao_So_anidf,n) fswabsv = a2x_o%rAttr(index_a2x_Faxa_swvdr,n) * (1.0_R8 - avsdr) & + a2x_o%rAttr(index_a2x_Faxa_swvdf,n) * (1.0_R8 - avsdf) fswabsi = a2x_o%rAttr(index_a2x_Faxa_swndr,n) * (1.0_R8 - anidr) & + a2x_o%rAttr(index_a2x_Faxa_swndf,n) * (1.0_R8 - anidf) x2o_o%rAttr(index_x2o_Foxx_swnet,n) = (fswabsv + fswabsi) * afracr + & i2x_o%rAttr(index_i2x_Fioi_swpen,n) * ifrac x2o_o%rAttr(index_x2o_Foxx_lat ,n) = xao_o%rAttr(index_xao_Faox_lat ,n) * afrac x2o_o%rAttr(index_x2o_Foxx_sen ,n) = xao_o%rAttr(index_xao_Faox_sen ,n) * afrac x2o_o%rAttr(index_x2o_Foxx_evap ,n) = xao_o%rAttr(index_xao_Faox_evap ,n) * afrac x2o_o%rAttr(index_x2o_Foxx_lwup ,n) = xao_o%rAttr(index_xao_Faox_lwup ,n) * afrac x2o_o%rAttr(index_x2o_Foxx_lwdn ,n) = a2x_o%rAttr(index_a2x_Faxa_lwdn ,n) * afrac x2o_o%rAttr(index_x2o_Foxx_snow ,n) = a2x_o%rAttr(index_a2x_Faxa_snowc,n) * afrac + & a2x_o%rAttr(index_a2x_Faxa_snowl,n) * afrac x2o_o%rAttr(index_x2o_Foxx_rain ,n) = a2x_o%rAttr(index_a2x_Faxa_rainc,n) * afrac + & a2x_o%rAttr(index_a2x_Faxa_rainl,n) * afrac x2o_o%rAttr(index_x2o_Foxx_melth,n) = i2x_o%rAttr(index_i2x_Fioi_melth,n) * ifrac x2o_o%rAttr(index_x2o_Foxx_meltw,n) = i2x_o%rAttr(index_i2x_Fioi_meltw,n) * ifrac x2o_o%rAttr(index_x2o_Foxx_salt ,n) = i2x_o%rAttr(index_i2x_Fioi_salt ,n) * ifrac ! scale total precip and runoff by flufx_epbalfact (TODO: note in cpl6 this was always ! done over points where imask was > 0 - how does this translate here?) x2o_o%rAttr(index_x2o_Foxx_rain ,n) = x2o_o%rAttr(index_x2o_Foxx_rain ,n) * flux_epbalfact x2o_o%rAttr(index_x2o_Foxx_snow ,n) = x2o_o%rAttr(index_x2o_Foxx_snow ,n) * flux_epbalfact x2o_o%rAttr(index_x2o_Forr_roff ,n) = x2o_o%rAttr(index_x2o_Forr_roff ,n) * flux_epbalfact x2o_o%rAttr(index_x2o_Forr_ioff ,n) = x2o_o%rAttr(index_x2o_Forr_ioff ,n) * flux_epbalfact x2o_o%rAttr(index_x2o_Foxx_prec ,n) = x2o_o%rAttr(index_x2o_Foxx_rain ,n) + & x2o_o%rAttr(index_x2o_Foxx_snow ,n) x2o_o%rAttr(index_x2o_Foxx_bcphidry,n) = a2x_o%rAttr(index_a2x_Faxa_bcphidry,n) * afrac x2o_o%rAttr(index_x2o_Foxx_bcphodry,n) = a2x_o%rAttr(index_a2x_Faxa_bcphodry,n) * afrac x2o_o%rAttr(index_x2o_Foxx_bcphiwet,n) = a2x_o%rAttr(index_a2x_Faxa_bcphiwet,n) * afrac x2o_o%rAttr(index_x2o_Foxx_ocphidry,n) = a2x_o%rAttr(index_a2x_Faxa_ocphidry,n) * afrac x2o_o%rAttr(index_x2o_Foxx_ocphodry,n) = a2x_o%rAttr(index_a2x_Faxa_ocphodry,n) * afrac x2o_o%rAttr(index_x2o_Foxx_ocphiwet,n) = a2x_o%rAttr(index_a2x_Faxa_ocphiwet,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstwet1,n) = a2x_o%rAttr(index_a2x_Faxa_dstwet1,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstwet2,n) = a2x_o%rAttr(index_a2x_Faxa_dstwet2,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstwet3,n) = a2x_o%rAttr(index_a2x_Faxa_dstwet3,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstwet4,n) = a2x_o%rAttr(index_a2x_Faxa_dstwet4,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstdry1,n) = a2x_o%rAttr(index_a2x_Faxa_dstdry1,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstdry2,n) = a2x_o%rAttr(index_a2x_Faxa_dstdry2,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstdry3,n) = a2x_o%rAttr(index_a2x_Faxa_dstdry3,n) * afrac x2o_o%rAttr(index_x2o_Foxx_dstdry4,n) = a2x_o%rAttr(index_a2x_Faxa_dstdry4,n) * afrac end do end subroutine mrg_x2o_run_mct ! !=========================================================================================== ! subroutine mrg_x2o_final_mct ! ****************** ! Do nothing for now ! ****************** end subroutine mrg_x2o_final_mct end module mrg_x2o_mct