CESM_Driver: map_atmice_mct.F90 Source File

00001 module map_atmice_mct
00002 
00003 !---------------------------------------------------------------------
00004 !
00005 ! Purpose:
00006 !
00007 ! Collect coupling routines for sequential coupling of ICE-ATM.
00008 !
00009 ! Author: R. Jacob, M. Vertenstein
00010 !
00011 !---------------------------------------------------------------------
00012 
00013   use shr_kind_mod     , only: R8 => SHR_KIND_R8
00014   use shr_sys_mod
00015 
00016   use shr_mct_mod, only: shr_mct_sMatPInitnc
00017   use mct_mod
00018   use seq_flds_mod
00019   use seq_flds_indices
00020   use seq_cdata_mod
00021   use seq_comm_mct, only: logunit, loglevel
00022   use seq_infodata_mod
00023   use m_die
00024 
00025   implicit none
00026   save
00027   private  ! except
00028 
00029 !--------------------------------------------------------------------------
00030 ! Public interfaces
00031 !--------------------------------------------------------------------------
00032 
00033   public :: map_ice2atm_init_mct
00034   public :: map_ice2atm_mct
00035 ! atm2ice is not used or validated yet
00036   private :: map_atm2ice_init_mct   
00037   private :: map_atm2ice_mct
00038 
00039 !--------------------------------------------------------------------------
00040 ! Public data
00041 !--------------------------------------------------------------------------
00042 
00043 !--------------------------------------------------------------------------
00044 ! Private data
00045 !--------------------------------------------------------------------------
00046 
00047   type(mct_rearr), private :: Re_ice2atm
00048   type(mct_sMatp), private :: sMatp_Fi2a
00049   type(mct_sMatp), private :: sMatp_Si2a
00050 ! atm2ice is not used or validated yet
00051   type(mct_rearr), private :: Re_atm2ice
00052   type(mct_sMatp), private :: sMatp_Fa2i
00053   type(mct_sMatp), private :: sMatp_Sa2i
00054 
00055 #ifdef CPP_VECTOR
00056   logical :: usevector = .true.
00057 #else
00058   logical :: usevector = .false.
00059 #endif
00060 
00061 #ifdef SYSUNICOS
00062   logical :: usealltoall = .true.
00063 #else
00064   logical :: usealltoall = .false.
00065 #endif
00066   logical :: samegrid_mapa2i
00067 
00068 !=======================================================================
00069 contains
00070 !=======================================================================
00071 
00072   subroutine map_atm2ice_init_mct( cdata_a, cdata_i)
00073 
00074     !-----------------------------------------------
00075     !
00076     ! Arguments
00077     !
00078     type(seq_cdata),intent(in) :: cdata_a
00079     type(seq_cdata),intent(in) :: cdata_i
00080     !
00081     ! Local variables
00082     !
00083     type(seq_infodata_type), pointer :: infodata
00084     type(mct_gsMap), pointer :: gsMap_a
00085     type(mct_gsMap), pointer :: gsMap_i
00086     integer                  :: mpicom
00087     character(*),parameter :: subName = '(map_atm2ice_init_mct) '
00088     !-----------------------------------------------
00089 
00090     call seq_cdata_setptrs(cdata_a, gsMap=gsMap_a)
00091     call seq_cdata_setptrs(cdata_i, gsMap=gsMap_i)
00092     call seq_cdata_setptrs(cdata_a, mpicom=mpicom, infodata=infodata)
00093 
00094     call seq_infodata_GetData( infodata, samegrid_ao=samegrid_mapa2i)
00095 
00096     if (samegrid_mapa2i) then
00097 
00098        call mct_rearr_init(gsMap_a, gsMap_i, mpicom, Re_atm2ice)
00099 
00100     else
00101 
00102        call shr_mct_sMatPInitnc(sMatp_Fa2i,gsMap_a,gsMap_i,"seq_maps.rc", &
00103             "atm2iceFmapname:","atm2iceFmaptype:",mpicom)
00104        call shr_mct_sMatPInitnc(sMatp_Sa2i,gsMap_a,gsMap_i,"seq_maps.rc", &
00105             "atm2iceSmapname:","atm2iceSmaptype:",mpicom)
00106 
00107     endif
00108     
00109   end subroutine map_atm2ice_init_mct
00110 
00111 !=======================================================================
00112 
00113   subroutine map_ice2atm_init_mct( cdata_i, cdata_a)
00114 
00115     !-----------------------------------------------
00116     !
00117     ! Arguments
00118     !
00119     type(seq_cdata), intent(in) :: cdata_i
00120     type(seq_cdata), intent(in) :: cdata_a
00121     !
00122     ! Local variables
00123     !
00124     type(seq_infodata_type), pointer :: infodata
00125     type(mct_gsMap), pointer :: gsMap_i           ! ice gsMap
00126     type(mct_gsMap), pointer :: gsMap_a           ! atm gsMap
00127     type(mct_gGrid), pointer :: dom_i             ! ice domain
00128     type(mct_gGrid), pointer :: dom_a             ! atm domain
00129     integer                  :: mpicom            ! communicator spanning atm and ice
00130     character(*),parameter :: subName = '(map_ice2atm_init_mct) '
00131     !-----------------------------------------------
00132 
00133     call seq_cdata_setptrs(cdata_i, gsMap=gsMap_i, dom=dom_i)
00134     call seq_cdata_setptrs(cdata_a, gsMap=gsMap_a, dom=dom_a)
00135     call seq_cdata_setptrs(cdata_a, mpicom=mpicom, infodata=infodata)
00136 
00137     call seq_infodata_GetData( infodata, samegrid_ao=samegrid_mapa2i)
00138 
00139     ! Initialize ice->atm mapping or rearranging
00140 
00141     if(samegrid_mapa2i) then
00142 
00143       call mct_rearr_init(gsMap_i, gsMap_a, mpicom, Re_ice2atm)
00144 
00145     else
00146 
00147       call shr_mct_sMatPInitnc(sMatp_Fi2a, gsMap_i, gsMap_a, "seq_maps.rc", &
00148         "ice2atmFmapname:", "ice2atmFmaptype:", mpicom)
00149 
00150       call shr_mct_sMatPInitnc(sMatp_Si2a, gsMap_i, gsMap_a, "seq_maps.rc", &
00151         "ice2atmSmapname:", "ice2atmSmaptype:", mpicom)
00152 
00153     endif
00154 
00155   end subroutine map_ice2atm_init_mct
00156 
00157 !=======================================================================
00158 
00159   subroutine map_atm2ice_mct( cdata_a, av_a, cdata_i, av_i, &
00160                               fluxlist, statelist)
00161 
00162     !-----------------------------------------------
00163     !
00164     ! Arguments
00165     !
00166     type(seq_cdata) ,intent(in)           :: cdata_a
00167     type(mct_aVect) ,intent(in)           :: av_a
00168     type(seq_cdata) ,intent(in)           :: cdata_i
00169     type(mct_aVect) ,intent(out)          :: av_i
00170     character(len=*),intent(in), optional :: fluxlist
00171     character(len=*),intent(in), optional :: statelist
00172     !
00173     ! Local variables
00174     !
00175     integer         :: lsize      ! temporary
00176     type(mct_aVect) :: av_i_f     ! temporary flux attribute vector
00177     type(mct_aVect) :: av_i_s     ! temporary state attribute vector
00178     type(mct_aVect) :: av_a_fl    ! temporary av for rearranging
00179     type(mct_aVect) :: av_i_fl    ! temporary av for rearranging
00180     character(*),parameter :: subName = '(map_atm2ice_mct) '
00181     !-----------------------------------------------
00182 
00183     if(samegrid_mapa2i) then
00184 
00185       if (present(fluxlist) .or. present(statelist)) then
00186          if (present(fluxlist)) then
00187             call mct_rearr_rearrange_fldlist(av_a, av_i, Re_atm2ice, VECTOR=usevector, &
00188                 ALLTOALL=usealltoall, fldlist=fluxlist)
00189          end if
00190          if (present(statelist)) then
00191             call mct_rearr_rearrange_fldlist(av_a, av_i, Re_atm2ice, VECTOR=usevector, &
00192                  ALLTOALL=usealltoall, fldlist=statelist)
00193          end if
00194       else
00195          call mct_rearr_rearrange(av_a, av_i, Re_atm2ice, VECTOR=usevector, ALLTOALL=usealltoall)
00196       endif
00197 
00198     else
00199 
00200       if (present(fluxlist) .or. present(statelist)) then
00201          if (present(fluxlist)) then
00202             lsize = mct_aVect_lsize(av_i)
00203             call mct_aVect_init (av_i_f, rlist=fluxlist , lsize=lsize)
00204             call mct_sMat_avMult(av_a, sMatp_Fa2i, av_i_f, VECTOR=usevector, rList=fluxlist)
00205             call mct_aVect_copy (aVin=av_i_f, aVout=av_i, vector=usevector)
00206             call mct_aVect_clean(av_i_f)
00207          end if
00208          if (present(statelist)) then
00209             lsize = mct_aVect_lsize(av_i)
00210             call mct_aVect_init (av_i_s, rlist=statelist , lsize=lsize)
00211             call mct_sMat_avMult(av_a, sMatp_Sa2i, av_i_s, VECTOR=usevector, rList=statelist)
00212             call mct_aVect_copy (aVin=av_i_s, aVout=av_i, vector=usevector)
00213             call mct_aVect_clean(av_i_s)
00214          end if
00215       else
00216          !--- default is flux mapping
00217          call mct_sMat_avMult(av_a, sMatp_Fa2i, av_i, VECTOR=usevector)
00218       endif
00219 
00220     endif
00221 
00222   end subroutine map_atm2ice_mct
00223 
00224 !=======================================================================
00225 
00226   subroutine map_ice2atm_mct( cdata_i, av_i, cdata_a, av_a, &
00227                               fractions_i, fractions_a, &
00228                               fluxlist, statelist)
00229 
00230     !-----------------------------------------------
00231     !
00232     ! Arguments
00233     !
00234     type(seq_cdata) ,intent(in)           :: cdata_i
00235     type(mct_AVect) ,intent(in)           :: av_i
00236     type(seq_cdata) ,intent(in)           :: cdata_a
00237     type(mct_AVect) ,intent(out)          :: av_a
00238     type(mct_AVect) ,intent(in), optional :: fractions_i
00239     type(mct_AVect) ,intent(in), optional :: fractions_a
00240     character(len=*),intent(in), optional :: fluxlist
00241     character(len=*),intent(in), optional :: statelist
00242     !
00243     ! Local Variables
00244     !
00245     integer              :: n,ki,i,j       ! indices
00246     integer              :: numats,ier     ! number of attributes
00247     integer              :: lsize          ! size of attribute vector
00248     type(mct_aVect)      :: temp           ! temporary
00249     type(mct_aVect)      :: av_a_f, av_a_s ! temporary
00250     real(R8),allocatable :: recip(:)       ! temporary
00251     character(*),parameter :: subName = '(map_ice2atm_mct) '
00252     !-----------------------------------------------
00253 
00254     if (samegrid_mapa2i) then
00255 
00256        if (present(fluxlist) .or. present(statelist)) then
00257           if (present(fluxlist)) then
00258              call mct_rearr_rearrange_fldlist(av_i, av_a, Re_ice2atm, VECTOR=usevector, &
00259                   ALLTOALL=usealltoall, fldlist=fluxlist)
00260           end if
00261           if (present(statelist)) then
00262              call mct_rearr_rearrange_fldlist(av_i, av_a, Re_ice2atm, VECTOR=usevector, &
00263                   ALLTOALL=usealltoall, fldlist=statelist)
00264           end if
00265        else
00266           call mct_rearr_rearrange(av_i, av_a, Re_ice2atm, VECTOR=usevector, ALLTOALL=usealltoall)
00267        endif
00268 
00269     else
00270 
00271        if (present(fractions_i) .and. present(fractions_a)) then
00272 
00273           ! Normalize input data with fraction of ice  
00274 
00275           lsize = mct_aVect_lsize(av_i)
00276           call mct_aVect_init(temp, av_i, lsize=lsize)
00277           numats = mct_aVect_nRAttr(av_i)
00278           ki = mct_aVect_indexRA(fractions_i,"ifrac")
00279           do j= 1,lsize
00280              do i =1,numats
00281                 temp%rAttr(i,j) = av_i%rAttr(i,j) * fractions_i%rAttr(ki,j)
00282              enddo
00283           enddo
00284           
00285           ! Perform mapping
00286 
00287           if (present(fluxlist) .or. present(statelist)) then
00288              if (present(fluxlist)) then 
00289                 lsize = mct_aVect_lsize(av_a)
00290                 call mct_aVect_init (av_a_f, rlist=fluxlist , lsize=lsize)
00291                 call mct_sMat_avMult(temp, sMatp_Fi2a, av_a_f, VECTOR=usevector, rList=fluxlist)
00292                 call mct_aVect_copy (aVin=av_a_f, aVout=av_a, vector=usevector)
00293                 call mct_aVect_clean(av_a_f)
00294              end if
00295              if (present(statelist)) then
00296                 lsize = mct_aVect_lsize(av_a)
00297                 call mct_aVect_init (av_a_s, rlist=statelist, lsize=lsize)
00298                 call mct_sMat_avMult(temp, sMatp_Si2a, av_a_s, VECTOR=usevector, rList=statelist)
00299                 call mct_aVect_copy (aVin=av_a_s, aVout=av_a, vector=usevector)
00300                 call mct_aVect_clean(av_a_s)
00301              end if
00302           else
00303              !--- default is flux mapping
00304              call mct_sMat_avMult(temp, sMatp_Fi2a, av_a, VECTOR=usevector)
00305           endif
00306           
00307           ! Clean up temporary vector
00308           
00309           call mct_aVect_clean(temp)
00310 
00311           ! Denormalize output data with fraction of ice on atmosphere grid (icefrac_a)
00312 
00313           lsize  = mct_aVect_lsize(av_a)
00314           numats = mct_aVect_nRAttr(av_a)
00315           allocate(recip(lsize),stat=ier)
00316           if(ier/=0) call die(subName,'allocate recip',ier)
00317           
00318           ki = mct_aVect_indexRA(fractions_a,"ifrac")
00319           do j = 1,lsize
00320              recip(j) = 0.0_R8
00321              if(fractions_a%rAttr(ki,j) /= 0.0_R8) then
00322                 recip(j)= 1.0_R8 / fractions_a%rAttr(ki,j)
00323              end if
00324              do i =1,numats
00325                 av_a%rAttr(i,j) = av_a%rAttr(i,j) * recip(j)
00326              enddo
00327           enddo
00328           
00329           deallocate(recip,stat=ier)
00330           if(ier/=0) call die(subName,'deallocate recip',ier)
00331           
00332        else
00333 
00334           if (present(fluxlist) .or. present(statelist)) then
00335              if (present(fluxlist)) then 
00336                 lsize = mct_aVect_lsize(av_a)
00337                 call mct_aVect_init (av_a_f, rlist=fluxlist , lsize=lsize)
00338                 call mct_sMat_avMult(av_i, sMatp_Fi2a, av_a_f, VECTOR=usevector, rList=fluxlist)
00339                 call mct_aVect_copy (aVin=av_a_f, aVout=av_a, vector=usevector)
00340                 call mct_aVect_clean(av_a_f)
00341              end if
00342              if (present(statelist)) then
00343                 lsize = mct_aVect_lsize(av_a)
00344                 call mct_aVect_init (av_a_s, rlist=statelist, lsize=lsize)
00345                 call mct_sMat_avMult(av_i, sMatp_Si2a, av_a_s, VECTOR=usevector, rList=statelist)
00346                 call mct_aVect_copy (aVin=av_a_s, aVout=av_a, vector=usevector)
00347                 call mct_aVect_clean(av_a_s)
00348              end if
00349           else
00350              !--- default is flux mapping
00351              call mct_sMat_avMult(av_i, sMatp_Fi2a, av_a, VECTOR=usevector)
00352           endif
00353          
00354       end if
00355 
00356    endif
00357 
00358  end subroutine map_ice2atm_mct
00359 
00360 !=======================================================================
00361 
00362 end module map_atmice_mct