CESM_Driver: map_snoglc_mct.F90 Source File

00001 module map_snoglc_mct
00002 
00003 !---------------------------------------------------------------------
00004 !
00005 ! Purpose:
00006 !
00007 ! Collect coupling routines for sequential coupling of SNO-GLC.
00008 !       
00009 ! Author: R. Jacob, M. Vertenstein
00010 !
00011 !---------------------------------------------------------------------
00012 
00013   use shr_sys_mod
00014   use mct_mod
00015   use seq_cdata_mod
00016   use seq_comm_mct
00017 
00018   implicit none
00019   save
00020   private  ! except
00021 
00022 !--------------------------------------------------------------------------
00023 ! Public interfaces
00024 !--------------------------------------------------------------------------
00025 
00026   public :: map_sno2glc_init_mct
00027   public :: map_glc2sno_init_mct
00028   public :: map_sno2glc_mct
00029   public :: map_glc2sno_mct
00030 
00031 !--------------------------------------------------------------------------
00032 ! Public data
00033 !--------------------------------------------------------------------------
00034 
00035 !--------------------------------------------------------------------------
00036 ! Private data
00037 !--------------------------------------------------------------------------
00038 
00039   type(mct_rearr), private :: Re_sno2glc
00040   type(mct_rearr), private :: Re_glc2sno
00041 
00042 #ifdef CPP_VECTOR
00043     logical :: usevector = .true.
00044 #else
00045     logical :: usevector = .false.
00046 #endif
00047 
00048 #ifdef SYSUNICOS
00049     logical :: usealltoall = .true.
00050 #else
00051     logical :: usealltoall = .false.
00052 #endif
00053 
00054   character(*),parameter :: subName = '(map_snoglc_mct)'
00055 
00056 !=======================================================================
00057    contains
00058 !=======================================================================
00059 
00060   subroutine map_glc2sno_init_mct( cdata_g, cdata_s)
00061 
00062     !-----------------------------------------------------
00063     ! 
00064     ! Arguments
00065     !
00066     type(seq_cdata),intent(in) :: cdata_g
00067     type(seq_cdata),intent(in) :: cdata_s
00068     !
00069     ! Local Variables
00070     !
00071     integer                  :: glcsize, snosize  ! global grid sizes      
00072     type(mct_gsMap), pointer :: gsMap_s           ! sno gsMap
00073     type(mct_gsMap), pointer :: gsMap_g           ! glc gsMap
00074     integer                  :: mpicom            ! communicator spanning glc and sno
00075     !-----------------------------------------------------
00076 
00077     call seq_cdata_setptrs(cdata_g, gsMap=gsMap_g)
00078     call seq_cdata_setptrs(cdata_s, gsMap=gsMap_s)
00079     call seq_cdata_setptrs(cdata_g, mpicom=mpicom)
00080 
00081     ! Sanity check
00082 
00083     glcsize = mct_gsMap_gsize(gsMap_g)
00084     snosize = mct_gsMap_gsize(gsMap_s)
00085     if (glcsize /= snosize) then
00086       write(logunit,*) "(map_glc2sno_init_mct) sno and glc are different."
00087       write(logunit,*) "(map_glc2sno_init_mct) Must be same size. Exiting."
00088       call shr_sys_abort(subName // "different size")
00089     endif
00090 
00091     ! Initialize rearranger
00092 
00093     call mct_rearr_init(gsMap_g, gsMap_s, mpicom, Re_glc2sno)
00094 
00095   end subroutine map_glc2sno_init_mct
00096 
00097 !=============================================================
00098 
00099   subroutine map_sno2glc_init_mct( cdata_s, cdata_g)
00100 
00101     !---------------------------------------------
00102     ! 
00103     ! Arguments
00104     !
00105     type(seq_cdata),intent(in) :: cdata_s
00106     type(seq_cdata),intent(in) :: cdata_g
00107     !
00108     ! Local Variables
00109     !
00110     integer                  :: glcsize, snosize  ! global grid sizes
00111     type(mct_gsMap), pointer :: gsMap_s           ! sno gsMap
00112     type(mct_gsMap), pointer :: gsMap_g           ! glc gsMap
00113     integer                  :: mpicom            ! communicator spanning glc and sno
00114     integer                  :: ka, km            ! indsnos
00115     type(mct_gGrid), pointer :: dom_s             ! sno domain
00116     type(mct_gGrid), pointer :: dom_g             ! glc domain
00117     integer                  :: lsize             ! size of attribute vector
00118     type(mct_aVect)          :: areasrc           ! glc areas from mapping file
00119     type(mct_aVect)          :: areadst           ! sno areas from mapping file
00120     !---------------------------------------------
00121 
00122     call seq_cdata_setptrs(cdata_s, gsMap=gsMap_s, dom=dom_s) 
00123     call seq_cdata_setptrs(cdata_g, gsMap=gsMap_g, dom=dom_g)
00124     call seq_cdata_setptrs(cdata_g, mpicom=mpicom)
00125 
00126     ! Sanity check
00127 
00128     glcsize = mct_gsMap_gsize(gsMap_g)
00129     snosize = mct_gsMap_gsize(gsMap_s)
00130     if (glcsize /= snosize) then
00131       write(logunit,*) "(map_sno2glc_init_mct) glc and sno grids are different."
00132       write(logunit,*) "(map_sno2glc_init_mct) Must be the same....Exiting."
00133       call shr_sys_abort(subName // "different glc,sno grids")
00134     endif
00135 
00136     ! Initialize rearranger
00137 
00138     call mct_rearr_init(gsMap_s, gsMap_g, mpicom, Re_sno2glc)
00139 
00140     ! Set glc aream to sno aream
00141     ! Note that "aream" attribute of dom_s%data is set in routine map_atm2sno_init_mct
00142 
00143     lsize = mct_gsMap_lsize(gsMap_s, mpicom)
00144     call mct_aVect_init( areasrc, rList="aream", lsize=lsize )
00145 
00146     lsize = mct_gsMap_lsize(gsMap_g, mpicom)
00147     call mct_aVect_init( areadst, rList="aream", lsize=lsize )
00148        
00149     km = mct_aVect_indexRA(dom_s%data,"aream")
00150     ka = mct_aVect_indexRA(areasrc   ,"aream")
00151     areasrc%rAttr(ka,:) = dom_s%data%rAttr(km,:)
00152 
00153     ! tcraig, 6/2010, initialize areadst with dom_g km because areasrc is only over land
00154     ka = mct_aVect_indexRA(areadst   ,"aream")
00155     km = mct_aVect_indexRA(dom_g%data,"aream")
00156     areadst%rAttr(ka,:) = dom_g%data%rAttr(km,:)
00157 
00158     call mct_rearr_rearrange(areasrc, areadst, Re_sno2glc, VECTOR=usevector, ALLTOALL=usealltoall)
00159 
00160     ka = mct_aVect_indexRA(areadst   ,"aream")
00161     km = mct_aVect_indexRA(dom_g%data,"aream")
00162     dom_g%data%rAttr(km,:) = areadst%rAttr(ka,:)
00163 
00164     call mct_aVect_clean(areasrc)      
00165     call mct_aVect_clean(areadst)      
00166 
00167   end subroutine map_sno2glc_init_mct  
00168 
00169 !=======================================================================
00170 
00171   subroutine map_glc2sno_mct( cdata_g, av_g, cdata_s, av_s, fluxlist, statelist )
00172 
00173     !-----------------------------------------------------
00174     ! 
00175     ! Arguments
00176     !
00177     type(seq_cdata),intent(in) :: cdata_g
00178     type(mct_aVect),intent(in) :: av_g
00179     type(seq_cdata),intent(in) :: cdata_s
00180     type(mct_aVect),intent(out):: av_s
00181     character(len=*),intent(in), optional :: fluxlist
00182     character(len=*),intent(in), optional :: statelist
00183     !-----------------------------------------------------
00184 
00185     if (present(fluxlist) .or. present(statelist)) then
00186        if (present(fluxlist)) then
00187           call mct_rearr_rearrange_fldlist(av_g, av_s, Re_glc2sno, VECTOR=usevector, &
00188                ALLTOALL=usealltoall, fldlist=fluxlist)
00189        endif
00190        if (present(statelist)) then
00191           call mct_rearr_rearrange_fldlist(av_g, av_s, Re_glc2sno, VECTOR=usevector, &
00192                ALLTOALL=usealltoall, fldlist=statelist)
00193        endif
00194     else
00195        call mct_rearr_rearrange(av_g, av_s, Re_glc2sno, VECTOR=usevector, ALLTOALL=usealltoall)
00196     end if
00197 
00198   end subroutine map_glc2sno_mct
00199 
00200 !=======================================================================
00201 
00202   subroutine map_sno2glc_mct( cdata_s, av_s, cdata_g, av_g, fluxlist, statelist)
00203 
00204     !-----------------------------------------------------
00205     ! 
00206     ! Arguments
00207     !
00208     type(seq_cdata),intent(in) :: cdata_s
00209     type(mct_aVect),intent(in) :: av_s
00210     type(seq_cdata),intent(in) :: cdata_g
00211     type(mct_aVect),intent(out):: av_g
00212     character(len=*),intent(in), optional :: fluxlist
00213     character(len=*),intent(in), optional :: statelist
00214     !-----------------------------------------------------
00215 
00216     if (present(fluxlist) .or. present(statelist)) then
00217        if (present(fluxlist)) then
00218           call mct_rearr_rearrange_fldlist(av_s, av_g, Re_sno2glc, VECTOR=usevector, &
00219                ALLTOALL=usealltoall, fldlist=fluxlist)
00220        endif
00221        if (present(statelist)) then
00222           call mct_rearr_rearrange_fldlist(av_s, av_g, Re_sno2glc, VECTOR=usevector, &
00223                ALLTOALL=usealltoall, fldlist=statelist)
00224        endif
00225     else
00226        call mct_rearr_rearrange(av_s, av_g, Re_sno2glc, VECTOR=usevector, ALLTOALL=usealltoall)
00227     end if
00228 
00229   end subroutine map_sno2glc_mct
00230 
00231 end module map_snoglc_mct