mct_mod.F90

Go to the documentation of this file.

!===============================================================================
! SVN $Id: mct_mod.F90 22436 2010-04-18 05:32:48Z tcraig $
! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel01_share3_100616/shr/mct_mod.F90 $
!===============================================================================
!BOP ===========================================================================
!
! !MODULE: mct_mod -- provides a standard API naming convention for MCT code
!
! !DESCRIPTION:
!    This module should be used instead of accessing mct modules directly.  
!    This module:
!    \begin{itemize}
!    \item Uses Fortran {\sf use} renaming of MCT routines and data types so that they
!          all have an mct\_ prefix and related data types and routines have related names. 
!    \item Provides easy and uniform access to 
!          all MCT routines and data types that must be accessed.
!    \item Provides a convienient list of 
!          all MCT routines and data types that can be accessed.
!    \item Blocks access to MCT routines that are not used in cpl6.
!    \end{itemize}
!    This module also includes some MCT-only functions to augment
!    the MCT library.
!
! !REVISION HISTORY:
!     2001-Aug-14 - B. Kauffman - first prototype
!     2006-Apr-13 - M. Vertenstein - modified for sequential mode
!     2007-Mar-01 - R. Jacob - moved to shr
!
! !INTERFACE: ------------------------------------------------------------------
module mct_mod

! !USES:

   use shr_kind_mod         ! shared kinds
   use shr_sys_mod          ! share system routines
   use shr_mpi_mod          ! mpi layer
   use shr_const_mod        ! constants

   use shr_log_mod          ,only: s_loglev               => shr_log_Level
   use shr_log_mod          ,only: s_logunit              => shr_log_Unit

   use m_MCTWorld           ,only: mct_world_init         => init

   use m_AttrVect           ,only: mct_aVect              => AttrVect
   use m_AttrVect           ,only: mct_aVect_init         => init
   use m_AttrVect           ,only: mct_aVect_clean        => clean
   use m_AttrVect           ,only: mct_aVect_zero         => zero
   use m_AttrVect           ,only: mct_aVect_lsize        => lsize
   use m_AttrVect           ,only: mct_aVect_indexIA      => indexIA
   use m_AttrVect           ,only: mct_aVect_indexRA      => indexRA
   use m_AttrVect           ,only: mct_aVect_importRattr  => importRattr
   use m_AttrVect           ,only: mct_aVect_exportRattr  => exportRattr
   use m_AttrVect           ,only: mct_aVect_getIList     => getIList
   use m_AttrVect           ,only: mct_aVect_getRList     => getRList
   use m_AttrVect           ,only: mct_aVect_exportIList2c=> exportIListToChar
   use m_AttrVect           ,only: mct_aVect_exportRList2c=> exportRListToChar
   use m_AttrVect           ,only: mct_aVect_nIAttr       => nIAttr
   use m_AttrVect           ,only: mct_aVect_nRAttr       => nRAttr
   use m_AttrVect           ,only: mct_aVect_copy         => Copy
   use m_AttrVect           ,only: mct_aVect_permute      => Permute
   use m_AttrVect           ,only: mct_aVect_unpermute    => Unpermute
   use m_AttrVectComms      ,only: mct_aVect_scatter      => scatter
   use m_AttrVectComms      ,only: mct_aVect_gather       => gather 
   use m_AttrVectComms      ,only: mct_aVect_bcast        => bcast  

   use m_Accumulator        ,only: mct_accum              => Accumulator
   use m_Accumulator        ,only: mct_accum_init         => init
   use m_Accumulator        ,only: mct_accum_zero         => zero
   use m_Accumulator        ,only: mct_accum_accumulate   => accumulate
!   use m_Accumulator        ,only: mct_accum_average      => average

   use m_GeneralGrid        ,only: mct_gGrid              => GeneralGrid
   use m_GeneralGrid        ,only: mct_gGrid_init         => init
   use m_GeneralGrid        ,only: mct_gGrid_clean        => clean
   use m_GeneralGrid        ,only: mct_gGrid_dims         => dims
   use m_GeneralGrid        ,only: mct_gGrid_lsize        => lsize
   use m_GeneralGrid        ,only: mct_ggrid_indexIA      => indexIA
   use m_GeneralGrid        ,only: mct_gGrid_indexRA      => indexRA
   use m_GeneralGrid        ,only: mct_gGrid_exportRattr  => exportRattr
   use m_GeneralGrid        ,only: mct_gGrid_importRattr  => importRattr
   use m_GeneralGrid        ,only: mct_gGrid_exportIattr  => exportIattr
   use m_GeneralGrid        ,only: mct_gGrid_importIattr  => importIattr
   use m_GeneralGrid        ,only: mct_gGrid_permute      => permute
   use m_GeneralGridComms   ,only: mct_gGrid_scatter      => scatter
   use m_GeneralGridComms   ,only: mct_gGrid_gather       => gather 
   use m_GeneralGridComms   ,only: mct_gGrid_bcast        => bcast  

   use m_Transfer           ,only: mct_send               => Send
   use m_Transfer           ,only: mct_recv               => Recv
      
   use m_GlobalSegMap       ,only: mct_gsMap              => GlobalSegMap
   use m_GlobalSegMap       ,only: mct_gsMap_init         => init
   use m_GlobalSegMap       ,only: mct_gsMap_clean        => clean
   use m_GlobalSegMap       ,only: mct_gsMap_lsize        => lsize
   use m_GlobalSegMap       ,only: mct_gsMap_gsize        => gsize
   use m_GlobalSegMap       ,only: mct_gsMap_gstorage     => GlobalStorage
   use m_GlobalSegMap       ,only: mct_gsMap_ngseg        => ngseg
   use m_GlobalSegMap       ,only: mct_gsMap_nlseg        => nlseg
   use m_GlobalSegMap       ,only: mct_gsMap_maxnlseg     => max_nlseg
   use m_GlobalSegMap       ,only: mct_gsMap_activepes    => active_pes
   use m_GlobalSegMap       ,only: mct_gsMap_copy         => copy
   use m_GlobalSegMap       ,only: mct_gsMap_increasing   => increasing
   use m_GlobalSegMap       ,only: mct_gsMap_orderedPoints=> OrderedPoints
   use m_GlobalSegMapComms  ,only: mct_gsMap_bcast        => bcast 

   use m_Rearranger         ,only: mct_rearr              => Rearranger
   use m_Rearranger         ,only: mct_rearr_init         => init
   use m_Rearranger         ,only: mct_rearr_clean        => clean
   use m_Rearranger         ,only: mct_rearr_rearrange    => rearrange

   use m_Router             ,only: mct_router             => Router
   use m_Router             ,only: mct_router_init        => init

   use m_SparseMatrixToMaps ,only: mct_sMat_2XgsMap       => SparseMatrixToXGlobalSegMap
   use m_SparseMatrixToMaps ,only: mct_sMat_2YgsMap       => SparseMatrixToYGlobalSegMap
   use m_SparseMatrix       ,only: mct_sMat               => SparseMatrix
   use m_SparseMatrix       ,only: mct_sMat_Init          => init
   use m_SparseMatrix       ,only: mct_sMat_Vecinit       => vecinit
   use m_SparseMatrix       ,only: mct_sMat_Clean         => clean
   use m_SparseMatrix       ,only: mct_sMat_indexIA       => indexIA
   use m_SparseMatrix       ,only: mct_sMat_indexRA       => indexRA
   use m_SparseMatrix       ,only: mct_sMat_lsize         => lsize
   use m_SparseMatrix       ,only: mct_sMat_nrows         => nRows
   use m_SparseMatrix       ,only: mct_sMat_ncols         => nCols
   use m_SparseMatrix       ,only: mct_sMat_SortPermute   => SortPermute
   use m_SparseMatrix       ,only: mct_sMat_GNumEl        => GlobalNumElements
   use m_SparseMatrix       ,only: mct_sMat_ImpGRowI      => ImportGlobalRowIndices
   use m_SparseMatrix       ,only: mct_sMat_ImpGColI      => ImportGlobalColumnIndices
   use m_SparseMatrix       ,only: mct_sMat_ImpLRowI      => ImportLocalRowIndices
   use m_SparseMatrix       ,only: mct_sMat_ImpLColI      => ImportLocalColumnIndices
   use m_SparseMatrix       ,only: mct_sMat_ImpMatrix     => ImportMatrixElements
   use m_SparseMatrix       ,only: mct_sMat_ExpGRowI      => ExportGlobalRowIndices
   use m_SparseMatrix       ,only: mct_sMat_ExpGColI      => ExportGlobalColumnIndices
   use m_SparseMatrix       ,only: mct_sMat_ExpLRowI      => ExportLocalRowIndices
   use m_SparseMatrix       ,only: mct_sMat_ExpLColI      => ExportLocalColumnIndices
   use m_SparseMatrix       ,only: mct_sMat_ExpMatrix     => ExportMatrixElements
   use m_SparseMatrixComms  ,only: mct_sMat_ScatterByRow  => ScatterByRow
   use m_SparseMatrixComms  ,only: mct_sMat_ScatterByCol  => ScatterByColumn
   use m_SparseMatrixPlus   ,only: mct_sMatP              => SparseMatrixPlus
   use m_SparseMatrixPlus   ,only: mct_sMatP_Init         => init
   use m_SparseMatrixPlus   ,only: mct_sMatP_Vecinit      => vecinit
   use m_SparseMatrixPlus   ,only: mct_sMatP_clean        => clean
   use m_MatAttrVectMul     ,only: mct_sMat_avMult        => sMatAvMult
   use m_GlobalToLocal      ,only: mct_sMat_g2lMat        => GlobalToLocalMatrix

   use m_List               ,only: mct_list               => list     
   use m_List               ,only: mct_list_init          => init
   use m_List               ,only: mct_list_get           => get 
   use m_List               ,only: mct_list_nitem         => nitem 
   use m_List               ,only: mct_list_clean         => clean
   use m_string             ,only: mct_string             => string 
   use m_string             ,only: mct_string_clean       => clean
   use m_string             ,only: mct_string_toChar      => toChar 
   use m_die                ,only: mct_perr_die           => mp_perr_die
   use m_die                ,only: mct_die                => die
   use m_inpak90


   use m_Permuter           ,only: mct_permute            => Permute

   use m_MergeSorts         ,only: mct_indexset           => IndexSet
   use m_MergeSorts         ,only: mct_indexsort          => IndexSort

   implicit none

!EOP

   !--- local kinds ---
   integer,parameter,private :: R8 = SHR_KIND_R8
   integer,parameter,private :: IN = SHR_KIND_IN
   integer,parameter,private :: CL = SHR_KIND_CL

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
contains
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: mct_aVect_info - print out aVect info for debugging
!
! !DESCRIPTION:
!     Print out information about the input MCT {\it AttributeVector}
!     {\tt aVect} to stdout. {\tt flag} sets the level of information:
!     \begin{enumerate}
!     \item  print out names of attributes in {\tt aVect}.
!     \item  also print out local max and min of data in {\tt aVect}.
!     \item  also print out global max and min of data in {\tt aVect}.
!     \item  Same as 3 but include name of this routine.
!     \end{enumerate}
!     If {\tt flag} is 3 or higher, then optional argument {\tt comm}
!     must be provided.
!     If optional argument {\tt fld} is present, only information for
!     that field will be printed.
!     If optional argument {\tt istr} is present, it will be output
!     before any of the information.
!
!
! !REVISION HISTORY:
!     2003 Jul 01 - B. Kauffman, T. Craig - first version
!
! !INTERFACE: ------------------------------------------------------------------

subroutine mct_aVect_info(flag,aVect,comm,pe,fld,istr)

! !USES:
  
! !INPUT/OUTPUT PARAMETERS:

   integer(IN)    ,intent(in)           :: flag  ! info level flag
   type(mct_aVect),intent(in)           :: aVect ! Attribute vector
   integer(IN)    ,intent(in),optional  :: comm  ! MPI communicator
   integer(IN)    ,intent(in),optional  :: pe    ! processor number
   character(*)   ,intent(in),optional  :: fld   ! fld
   character(*)   ,intent(in),optional  :: istr  ! string for print

!EOP

   !--- local ---
   integer(IN)          :: i,j,k,n      ! generic indicies
   integer(IN)          :: ks,ke        ! start and stop k indices
   integer(IN)          :: nflds        ! number of flds in AV to diagnose
   integer(IN)          :: nsize        ! grid point size of AV
   type(mct_string)     :: item         ! mct string
   character(CL)        :: itemc        ! item converted to char
   integer(IN)          :: comm_loc     ! local variable for comm
   integer(IN)          :: pe_loc       ! local variable for pe
   logical              :: commOK       ! is comm available
   logical              :: peOK         ! is pe available
   real(R8),allocatable :: minl(:)      ! local  min
   real(R8),allocatable :: ming(:)      ! global min
   real(R8),allocatable :: maxl(:)      ! local  max
   real(R8),allocatable :: maxg(:)      ! global max

   !--- formats ---
   character(*),parameter :: subName = '(mct_aVect_info) '
   character(*),parameter :: F00 = "('(mct_aVect_info) ',8a)"
   character(*),parameter :: F01 = "('(mct_aVect_info) ',a,i9)"
   character(*),parameter :: F02 = "('(mct_aVect_info) ',240a)"
   character(*),parameter :: F03 = "('(mct_aVect_info) ',a,2es11.3,i4,2x,a)"

!-------------------------------------------------------------------------------
! NOTE: has hard-coded knowledge/assumptions about mct aVect data type internals
!-------------------------------------------------------------------------------

   commOK = .false.
   peOK   = .false.

   if (present(pe)) then
     peOK = .true.
     pe_loc = pe
   endif
   if (present(comm)) then
     commOK = .true.
     comm_loc = comm
     if (.not.PEOK) then
       call shr_mpi_commrank(comm,pe_loc,subName)
       peOK = .true.
     endif
   endif

   nsize = mct_aVect_lsize(aVect)

   if (present(fld)) then
     nflds = 1
     ks = mct_aVect_indexRA(aVect,fld,perrWith=subName)
     ke = ks
   else
     nflds = mct_aVect_nRAttr(aVect)
     ks = 1
     ke = nflds
   endif

   if (flag >= 1) then
     if (present(istr)) then
        if (s_loglev > 0) write(s_logunit,*) trim(istr)
     endif
     if (s_loglev > 0) write(s_logunit,F01) "local size =",nsize
     if (associated(aVect%iList%bf)) then
        if (s_loglev > 0) write(s_logunit,F02) "iList = ",aVect%iList%bf
     endif
     if (associated(aVect%rList%bf)) then
        if (s_loglev > 0) write(s_logunit,F02) "rList = ",aVect%rList%bf
     endif
   endif

   if (flag >= 2) then

     allocate(minl(nflds))
     allocate(maxl(nflds))

     do k=ks,ke
       minl(k) = minval(aVect%rAttr(k,:))
       maxl(k) = maxval(aVect%rAttr(k,:))
     enddo

     if (flag >= 4 .and. commOK) then
       allocate(ming(nflds))
       allocate(maxg(nflds))
       ming = 0._R8
       maxg = 0._R8
       call shr_mpi_min(minl,ming,comm,subName)
       call shr_mpi_max(maxl,maxg,comm,subName)
     endif

     do k=ks,ke
       call mct_aVect_getRList(item,k,aVect)
       itemc = mct_string_toChar(item)
       call mct_string_clean(item)
       if (s_loglev > 0) write(s_logunit,F03) 'l min/max ',minl(k),maxl(k),k,trim(itemc)
       if (flag >= 3 .and. commOK) then
         if ((peOK .and. pe_loc == 0) .or. .not.peOK) then
           if (s_loglev > 0) write(s_logunit,F03) 'g min/max ',ming(k),maxg(k),k,trim(itemc)
         endif
       endif
       if (flag >= 4 .and. commOK) then
         if ((peOK .and. pe_loc == 0) .or. .not.peOK) then
           if (s_loglev > 0) write(s_logunit,*) trim(subName),'g min/max ',ming(k),maxg(k),k,trim(itemc)
         endif
       endif
     enddo

      deallocate(minl)
      deallocate(maxl)
      if (flag >= 4 .and. commOK) then
         deallocate(ming)
         deallocate(maxg)
      endif

   endif

   call shr_sys_flush(s_logunit)

end subroutine mct_aVect_info

!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: mct_aVect_getRAttr - get real F90 array data out of an aVect
!
! !DESCRIPTION:
!     Get the data associated with attribute {\tt str} in 
!     {\it AttributeVector} {\tt aVect} and return in the
!     real F90 array data {\tt data}.
!     {\tt rcode} will be 0 if succesful, 1 if size of {\tt data}
!     does not match size  of {\tt aVect} and 2 if {\tt str} is
!     not found.
!
! !REMARKS:
!   This is like the MCT routine exportRAttr except the output argument
!   is not a pointer.
!
! !REVISION HISTORY:
!     2002 Apr xx - B. Kauffman - first version
!
! !INTERFACE: ------------------------------------------------------------------

subroutine mct_aVect_getRAttr(aVect,str,data,rcode)

! !INPUT/OUTPUT PARAMETERS:

   type(mct_aVect),intent(in)  :: aVect    ! an Attribute vector
   character(*)       ,intent(in)  :: str      ! field name string
   real(R8)           ,intent(out) :: data(:)  ! an F90 array
   integer(IN)        ,intent(out) :: rcode    ! return code

!EOP

   !--- local ---
   integer(IN) :: k,n,m
   integer(IN) :: aVsize

   !--- formats ---
   character(*),parameter :: subName = "(mct_aVect_getRAttr) "
   character(*),parameter :: F00 = "('(mct_aVect_getRAttr) ',8a)"

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   rcode = 0

   n = mct_aVect_lsize(aVect)
   m = size(data)
   if (n /= m) then
      if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: size aV,data,attr = ",n,m,trim(str)
      data = SHR_CONST_SPVAL
      rcode = 1
      return
   end if
   
   k = mct_aVect_indexRA(aVect,trim(str) ,perrWith=subName)
   if ( k < 1) then
      if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: attribute not found, var = ",trim(str),", k=",k
      data = SHR_CONST_SPVAL
      rcode = 2
      return
   end if

   data(:) = aVect%rAttr(k,:)

end subroutine mct_aVect_getRAttr

!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: mct_aVect_putRAttr - put real F90 array data into an aVect
!
! !DESCRIPTION:
!     Put the data in array {\tt data} into the  {\it AttributeVector}
!     {\tt aVect} under the attribute {\tt str}.
!     {\tt rcode} will be 0 if succesful, 1 if size of {\tt data}
!     does not match size  of {\tt aVect} and 2 if {\tt str} is not
!     found.
!
! !REMARKS:
!   This is like the MCT routine importRAttr except the output argument
!   is not a pointer.

! !REVISION HISTORY:
!     2002 Apr xx - B. Kauffman - first version
!
! !INTERFACE: ------------------------------------------------------------------

subroutine mct_aVect_putRAttr(aVect,str,data,rcode)

! !INPUT/OUTPUT PARAMETERS:

   type(mct_aVect),intent(out) :: aVect ! Attribute vector
   character(*)       ,intent(in)  :: str
   real(R8)           ,intent(in)  :: data(:)
   integer(IN)        ,intent(out) :: rcode

!EOP

   !--- local ---
   integer(IN) :: k,n,m
   integer(IN) :: aVsize

   !--- formats ---
   character(*),parameter :: subName = "(mct_aVect_putRAttr) "
   character(*),parameter :: F00 = "('(mct_aVect_putRAttr) ',8a)"

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   rcode = 0

   n = mct_aVect_lsize(aVect)
   m = size(data)
   if (n /= m) then
      if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: size aV,data,attr = ",n,m,trim(str)
      rcode = 1
      return
   end if
   
   k = mct_aVect_indexRA(aVect,trim(str) ,perrWith=subName)
   if ( k < 1) then
      if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: attribute not found, var = ",trim(str),", k=",k
      rcode = 2
      return
   end if

   aVect%rAttr(k,:) = data(:) 

end subroutine mct_aVect_putRAttr

!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: mct_aVect_accum - accumulate attributes from one aVect to another
!
! !DESCRIPTION:
! This routine accumulates from input argment {\tt aVin} into the output 
! {\it AttrVect} argument {\tt aVout} the real and integer attributes specified in 
! input {\tt CHARACTER} argument {\tt iList} and {\tt rList}. The attributes can
! be listed in any order.  If neither {\tt iList} nor {\tt rList} are provided, 
! all attributes shared between {\tt aVin} and {\tt aVout} will be copied.
!
! If any attributes in {\tt aVout} have different names but represent the
! the same quantity and should still be copied, you must provide a translation
! argument {\tt TrList} and/or {\tt TiList}.  The translation arguments should
! be identical to the {\tt rList} or {\tt iList} but with the correct {\tt aVout}
! name subsititued at the appropriate place.
!
! {\bf N.B.:}  This routine will fail if the {\tt aVout} is not initialized or
! if any of the specified attributes are not present in either {\tt aVout} or {\tt aVin}.
!
! !REVISION HISTORY:
!    2002 Sep 15 - ? - initial version.
!
! !INTERFACE: ------------------------------------------------------------------

subroutine mct_aVect_accum(aVin, rList, TrList, iList, TiList, aVout)


! !USES:

   use m_die ,          only : die
   use m_stdio ,        only : stderr
   use m_String ,       only : String_toChar => toChar
   use m_String ,       only : String
   use m_String ,       only : String_init
   use m_String ,       only : String_clean => clean
   use m_List ,         only : List
   use m_List,          only : List_get => get
   use m_List,          only : List_nullify => nullify
   use m_List,          only : List_clean => clean
   use m_List,          only : init,nitem
   use m_AttrVect,      only : AttrVect
   use m_AttrVect,      only : lsize
   use m_AttrVect,      only : SharedAttrIndexList

   implicit none

!INPUT/OUTPUT PARAMETERS

   type(AttrVect)        ,intent(in)    :: aVin
   character(*), optional,intent(in)    :: iList
   character(*), optional,intent(in)    :: rList
   character(*), optional,intent(in)    :: TiList
   character(*), optional,intent(in)    :: TrList
   type(AttrVect)        ,intent(inout) :: aVout

!EOP

   !--- local ---
   type(List)   :: rcpList       !  The list of real attributes to accum
   type(List)   :: icpList       !  The list of integer attributes to accum
   type(List)   :: TrcpList      !  Names of output attributes corresponding to input
   type(List)   :: TicpList      !  Names of output attributes corresponding to input
   type(String) :: attr          !  an individual attribute
   type(String) :: attr2         !  an individual attribute
   integer(IN)  :: i,j           ! generic indicies
   integer(IN)  :: rcode         ! return code
   integer(IN)  :: inx,outx
   integer(IN)  :: num_indices   ! Overlapping attribute index number

   !--- Overlapping attribute index storage arrays: ---
   integer(IN), dimension(:), pointer :: aVinindices, aVoutindices

   character(7) :: data_flag      ! character variable used as data type flag

   !--- formats ---
   character(*),parameter :: myname_='mct_accum'

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   call List_nullify(rcpList)
   call List_nullify(icpList)
   call List_nullify(TrcpList)
   call List_nullify(TicpList)

   if (lsize(aVin) .ne. lsize(aVout)) then
      write(stderr,'(2a)')myname_, &
      'MCTERROR:  Input aV and output aV do not have the same size'
      write(stderr,*)myname_, &
      'MCTERROR: ',lsize(aVin),lsize(aVout)
      call die(myname_,'lsize check',rcode)
   endif

   !----------------------------------------------------------------------------
   ! Accum the listed real attributes
   !----------------------------------------------------------------------------
   if ( present(rList)) then
     if( len_trim(rList)>0 ) then

      call init(rcpList,rList)    ! init.List()

      !--- check translation list ---
      if ( present(TrList) ) then 
       if(len_trim(TrList)>0 ) then
         call init(TrcpList,TrList)
         if ( nitem(rcpList) .ne. nitem(TrcpList)) then
            write(stderr,'(2a)')myname_, &
            'MCTERROR:  Input rList and TrList do not have the same size'
            call die(myname_,'nitem TrList check',rcode)
         endif
       endif
      endif

      if (nitem(rcpList) .ge. 1) then
         do i=1,lsize(aVin)
         do j=1,nitem(rcpList)
            call List_get(attr,j,rcpList)
            if (present(TrList)) then
               call List_get(attr2,j,TrcpList)
            else
               call String_init(attr2,attr)
            endif
            inx=mct_aVect_indexRA(aVin,String_toChar(attr),dieWith=myname_//'real aVin')
            outx=mct_aVect_indexRA(aVout,String_toChar(attr2),dieWith=myname_//'real aVout')
            aVout%rAttr(outx,i)=aVout%rAttr(outx,i)+aVin%rAttr(inx,i)
            call String_clean(attr)
            call String_clean(attr2)
         enddo
         enddo
      endif

     call List_clean(rcpList)
     if (present(TrList)) call List_clean(TrcpList)

     endif
   endif

   !----------------------------------------------------------------------------
   ! Accum the listed integer attributes 
   !----------------------------------------------------------------------------
   if ( present(iList) ) then
     if (len_trim(iList)>0 ) then

      call init(icpList,iList)    ! init.List()

      !--- check translation list ---
      if ( present(TiList) ) then
        if (len_trim(TiList)>0 ) then
         call init(TicpList,TiList)
         if ( nitem(icpList) .ne. nitem(TicpList)) then
             write(stderr,'(2a)')myname_, &
            'MCTERROR:  Input iList and TiList do not have the same size'
            call die(myname_,'nitem TiList check',rcode)
         endif
        endif
      endif

     if (nitem(icpList) .ge. 1) then
        do i=1,lsize(aVin)
        do j=1,nitem(icpList)
           call List_get(attr,j,icpList)
           if (present(TiList)) then
              call List_get(attr2,j,TicpList)
           else
              call String_init(attr2,attr)
           endif
           inx =mct_aVect_indexIA(aVin ,String_toChar(attr) ,dieWith=myname_//'int aVin')
           outx=mct_aVect_indexIA(aVout,String_toChar(attr2),dieWith=myname_//'int aVout')
           aVout%iAttr(outx,i)=aVout%iAttr(outx,i)+aVin%iAttr(inx,i)
           call String_clean(attr)
           call String_clean(attr2)
        enddo
        enddo
     endif

     call List_clean(icpList)
     if (present(TrList)) call List_clean(TicpList)

     endif
   endif

   !----------------------------------------------------------------------------
   ! if neither rList nor iList is present, accum shared attibutes from in to out
   !----------------------------------------------------------------------------
   if ( .not.present(rList) .and. .not.present(iList)) then

      data_flag = 'REAL'
      call SharedAttrIndexList(aVin, aVout, data_flag, num_indices, &
                                aVinindices, aVoutindices)
      if (num_indices .gt. 0) then
#ifdef CPP_VECTOR
         do j=1,num_indices
!CDIR SELECT(VECTOR)
!DIR$ CONCURRENT
         do i=1,lsize(aVin)
#else
         do i=1,lsize(aVin)
         do j=1,num_indices
#endif
            aVout%rAttr(aVoutindices(j),i)= &
            & aVout%rAttr(aVoutindices(j),i)+aVin%rAttr(aVinindices(j),i)
         enddo
         enddo
      endif
      deallocate(aVinindices, aVoutindices,stat=rcode)
      if (rcode /= 0) call die(myname_,'deallocate real(Vinindices...',rcode)

      data_flag = 'INTEGER'
      call SharedAttrIndexList(aVin, aVout, data_flag, num_indices, &
                                aVinindices, aVoutindices)
      if (num_indices .gt. 0) then
#ifdef CPP_VECTOR
         do j=1,num_indices
!CDIR SELECT(VECTOR)
!DIR$ CONCURRENT
         do i=1,lsize(aVin)
#else
         do i=1,lsize(aVin)
         do j=1,num_indices
#endif
            aVout%iAttr(aVoutindices(j),i)= &
            & aVout%iAttr(aVoutindices(j),i)+aVin%iAttr(aVinindices(j),i)
         enddo
         enddo
      endif
      deallocate(aVinindices, aVoutindices,stat=rcode)
      if (rcode /= 0) call die(myname_,'deallocate int(Vinindices...',rcode)

   endif

end subroutine mct_aVect_accum

!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: mct_avect_mult - multiply an attribute vector by a field.
!
! !DESCRIPTION:
!     Replace each field in {\tt av} by the product of that field and the
!     field {\tt fld1} from input argument {\tt av1}.
!
!     If optional argument {\tt bunlist} is present, only those attributes 
!     in {\tt bun} will be replaced.
!
!     If optional argument {\tt initav} is present, then the data in {\tt av}
!     is replaced by the product of the data in {\tt initav} and {\tt fld1}
!     from {\tt av1}. NOTE:  this assume {\tt initav} has the exact same
!     attributes in the same order as {\tt av}.
!
!
! !REVISION HISTORY:
!     2007-Jun-11 - M. Vertenstein -- initial version
!
! !INTERFACE: ------------------------------------------------------------------

subroutine mct_avect_mult(av,av1,fld1,avlist)

! !USES:

! !INPUT/OUTPUT PARAMETERS:

   type(mct_aVect)      ,intent(inout) :: av       ! attribute vector output
   type(mct_aVect)      ,intent(in)    :: av1      ! attribute vector input
   character(*)         ,intent(in)    :: fld1     ! av1 field name
   character(*),optional,intent(in)    :: avlist   ! sublist of field in av

!EOP

   !--- local ---
   integer(IN) :: n,m            ! generic indicies
   integer(IN) :: npts           ! number of points (local) in an aVect field
   integer(IN) :: nfld           ! number of fields (local) in an aVect field
   integer(IN) :: nfldi          ! number of fields (local) in an aVect field
   integer(IN) :: nptsx          ! number of points (local) in an aVect field
   integer(IN) :: nptsi          ! number of points (local) in an aVect field
   integer(IN) :: kfld           ! field number of fld1 in av1
   integer(IN),dimension(:),allocatable :: kfldin   ! field numbers of avlist in av
   type(mct_list)   :: blist     ! avlist as a List
   type(mct_string) :: tattr     ! an attribute

   !--- formats ---
   character(*),parameter :: subName = '(mct_aVect_mult) '

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   nptsx = mct_aVect_lsize(av1)
   npts  = mct_aVect_lsize(av)
   if (nptsx /= npts .and. s_loglev > 0) write(s_logunit,*) subName,' ERROR: npts error1 ',npts,nptsx

   kfld  = mct_aVect_indexRA(av1,fld1,perrWith=subName)

   if (present(avlist)) then

     call mct_list_init(blist,avlist)

     nfld=mct_list_nitem(blist)

     allocate(kfldin(nfld))
     do m=1,nfld
       call mct_list_get(tattr,m,blist)
       kfldin(m) = mct_aVect_indexRA(av,mct_string_toChar(tattr))
       call mct_string_clean(tattr)
     enddo
     call mct_list_clean(blist)

#ifdef CPP_VECTOR
     do m=1,nfld
!CDIR SELECT(VECTOR)
!DIR$ CONCURRENT
     do n=1,npts
#else
     do n=1,npts
     do m=1,nfld
#endif
        av%rAttr(kfldin(m),n) = av%rAttr(kfldin(m),n)*av1%rAttr(kfld,n)
     enddo
     enddo

     deallocate(kfldin)

   else

     nfld  = mct_aVect_nRAttr(av)

#ifdef CPP_VECTOR
     do m=1,nfld
!CDIR SELECT(VECTOR)
!DIR$ CONCURRENT
     do n=1,npts
#else
     do n=1,npts
     do m=1,nfld
#endif
        av%rAttr(m,n) = av%rAttr(m,n)*av1%rAttr(kfld,n)
     enddo
     enddo

   endif

end subroutine mct_aVect_mult

!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: mct_avect_vecmult - multiply an attribute vector by a field.
!
! !DESCRIPTION:
!     Replace each field in {\tt av} by the product of that field and the
!     field {\tt fld1} from input argument {\tt av1}.
!
!     If optional argument {\tt bunlist} is present, only those attributes 
!     in {\tt bun} will be replaced.
!
!     If optional argument {\tt initav} is present, then the data in {\tt av}
!     is replaced by the product of the data in {\tt initav} and {\tt fld1}
!     from {\tt av1}. NOTE:  this assume {\tt initav} has the exact same
!     attributes in the same order as {\tt av}.
!
!
! !REVISION HISTORY:
!     2007-Jun-11 - M. Vertenstein -- initial version
!
! !INTERFACE: ------------------------------------------------------------------

subroutine mct_avect_vecmult(av,vec,avlist)

! !USES:

! !INPUT/OUTPUT PARAMETERS:

   type(mct_aVect)      ,intent(inout) :: av       ! attribute vector output
   real(R8)             ,intent(in)    :: vec(:)
   character(*),optional,intent(in)    :: avlist   ! sublist of field in av

!EOP

   !--- local ---
   integer(IN) :: n,m            ! generic indicies
   integer(IN) :: npts           ! number of points (local) in an aVect field
   integer(IN) :: nfld           ! number of fields (local) in an aVect field
   integer(IN) :: nfldi          ! number of fields (local) in an aVect field
   integer(IN) :: nptsx          ! number of points (local) in an aVect field
   integer(IN) :: nptsi          ! number of points (local) in an aVect field
   integer(IN),dimension(:),allocatable :: kfldin   ! field numbers of avlist in av
   type(mct_list)   :: blist     ! avlist as a List
   type(mct_string) :: tattr     ! an attribute

   !--- formats ---
   character(*),parameter :: subName = '(mct_aVect_vecmult) '

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   nptsx = size(vec,1)
   npts  = mct_aVect_lsize(av)
   if (nptsx /= npts .and. s_loglev > 0) write(s_logunit,*) subName,' ERROR: npts error1 ',npts,nptsx


   if (present(avlist)) then

     call mct_list_init(blist,avlist)

     nfld=mct_list_nitem(blist)

     allocate(kfldin(nfld))
     do m=1,nfld
       call mct_list_get(tattr,m,blist)
       kfldin(m) = mct_aVect_indexRA(av,mct_string_toChar(tattr))
       call mct_string_clean(tattr)
     enddo
     call mct_list_clean(blist)

#ifdef CPP_VECTOR
     do m=1,nfld
!CDIR SELECT(VECTOR)
!DIR$ CONCURRENT
     do n=1,npts
#else
     do n=1,npts
     do m=1,nfld
#endif
        av%rAttr(kfldin(m),n) = av%rAttr(kfldin(m),n)*vec(n)
     enddo
     enddo

     deallocate(kfldin)

   else

     nfld  = mct_aVect_nRAttr(av)

#ifdef CPP_VECTOR
     do m=1,nfld
!CDIR SELECT(VECTOR)
!DIR$ CONCURRENT
     do n=1,npts
#else
     do n=1,npts
     do m=1,nfld
#endif
        av%rAttr(m,n) = av%rAttr(m,n)*vec(n)
     enddo
     enddo

   endif

end subroutine mct_aVect_vecmult

!===============================================================================
!BOP ===========================================================================
!
! !IROUTINE: mct_aVect_avg - averages an accumulated attribute vector
!
! !DESCRIPTION:
!     Average the data in attribute vector {\tt aVect}.  Divides all fields in 
!     the attribute vector {\tt aVect} by the value of the input counter.
!
! !REVISION HISTORY:
!     2002-Sep-15 - T. Craig -- initial version
!
! !INTERFACE: ------------------------------------------------------------------

subroutine mct_aVect_avg(aVect, counter)

! !USES:

! !INPUT/OUTPUT PARAMETERS:

   type(mct_aVect),intent(inout) :: aVect   ! bundle to read
   integer        ,intent(in)    :: counter ! counter 

!EOP

   !--- local ---
   integer(IN) :: i,j    ! generic indicies
   integer(IN) :: npts   ! number of points (local) in an aVect field
   integer(IN) :: nflds  ! number of aVect fields (real)
   real(R8)    :: ravg   ! accumulation count

   !--- formats ---
   character(*),parameter :: subName = '(mct_aVect_avg) '

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   if (counter == 0) return

   ravg = 1.0_R8/real(counter,R8)

   nflds = mct_aVect_nRAttr(aVect)
   npts  = mct_aVect_lsize (aVect)
!DIR$ CONCURRENT
!DIR$ PREFERVECTOR
   do i=1,npts 
   do j=1,nflds
      aVect%rattr(j,i) = aVect%rattr(j,i)*ravg
   enddo
   enddo

end subroutine mct_aVect_avg

! !BOP ===========================================================================
!
! !IROUTINE:  subroutine mct_rearr_rearrange_fldlst - rearrange on a fieldlist
!
! !DESCRIPTION: 
!     Perform regarranger between two attribute vectors only on the fieldlist
!     that is provided
!
!
! !REVISION HISTORY: 
!    2007-Jun-22 - M. Vertenstein - first version
! 
! !INTERFACE:  -----------------------------------------------------------------

subroutine mct_rearr_rearrange_fldlist(avi, avo, Rearr, vector, alltoall, fldlist)

! !USES:

! !INPUT/OUTPUT PARAMETERS:

   type(mct_aVect) , intent(in)  :: avi
   type(mct_aVect) , intent(out) :: avo
   type(mct_rearr) , intent(in)  :: Rearr
   logical         , intent(in)  :: vector
   logical         , intent(in)  :: alltoall
   character(len=*), intent(in)  :: fldlist   
! !EOP

   !---local ---
   type(mct_aVect) :: avi_fl
   type(mct_aVect) :: avo_fl
   integer(IN)     :: lsize

   !--- formats ---
   character(*),parameter :: subName = '(mct_rearr_rearrange_fldlist) '

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   lsize = mct_aVect_lsize(avi)
   call mct_aVect_init (avi_fl, rlist=fldlist, lsize=lsize)
   call mct_aVect_zero (avi_fl)

   lsize = mct_aVect_lsize(avo)
   call mct_aVect_init (avo_fl, rlist=fldlist, lsize=lsize)
   call mct_aVect_zero (avo_fl)
   
   call mct_aVect_copy (aVin=avi, aVout=avi_fl)
   call mct_rearr_rearrange(avi_fl, avo_fl, Rearr, VECTOR=vector, ALLTOALL=alltoall)
   call mct_aVect_copy (aVin=avo_fl, aVout=avo, vector=vector)

   call mct_aVect_clean(avi_fl)
   call mct_aVect_clean(avo_fl)

end subroutine mct_rearr_rearrange_fldlist


! !BOP ===========================================================================
!
! !IROUTINE:  mct_myindex - binary search for index in list
!
! !DESCRIPTION: 
!     Do a binary search to see if a value is contained in a list of
!     values.  return true or false.  starti must be monotonically
!     increasing, function does NOT check this.
!
!
! !REVISION HISTORY: 
!    2007-Jan-17 - T. Craig -- first version
!    2007-Mar-20 - R. Jacob - move to mct_mod
! 
! !INTERFACE:  -----------------------------------------------------------------

logical function mct_myindex(index,starti,counti)

! !USES:

! !INPUT/OUTPUT PARAMETERS:

   integer(IN) :: index       ! is this index in start/count list
   integer(IN) :: starti(:)   ! start list
   integer(IN) :: counti(:)   ! count list

! !EOP

   !--- local ---
   integer(IN)    :: nl,nc,nr,ncprev 
   integer(IN)    :: lsize
   logical        :: stopnow

   !--- formats ---
   character(*),parameter :: subName = '(mct_myindex) '

!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------

   mct_myindex = .false.

   lsize = size(starti)
   if (lsize < 1) return

   nl = 0
   nr = lsize + 1
   nc = (nl+nr)/2
   stopnow = .false.
   do while (.not.stopnow)
      if (index < starti(nc)) then
         nr = nc
      elseif (index > (starti(nc) + counti(nc) - 1)) then
         nl = nc
      else
         mct_myindex = .true.
         return
      endif
      ncprev = nc
      nc = (nl + nr)/2
      if (nc == ncprev .or. nc < 1 .or. nc > lsize) stopnow = .true.
   enddo

   mct_myindex = .false.
   return

end function mct_myindex
!===============================================================================

end module mct_mod

---