clm_csmmod.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

       call shr_msg_send_i (ibuffs ,nibuff, SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)

! Send "invalid" land model grid and mask data

       call shr_msg_send_r (rtemp_lnd(1:lsmlon*lsmlat  ), lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (rtemp_lnd(1:lsmlon*lsmlat  ), lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (rtemp_lnd(1:lsmlon*lsmlat*4), lsmlon*lsmlat*4, SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (rtemp_lnd(1:lsmlon*lsmlat*4), lsmlon*lsmlat*4, SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (rtemp_lnd(1:lsmlon*lsmlat  ), lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_i (itemp_lnd(1:lsmlon*lsmlat  ), lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)

! Send "valid" RTM grid and mask data 
      
       temp_area(:,:) = area_r(:,:)/(re*re)  !convert from km^2 to radians^2 before sending to coupler
       temp_mask(:,:) = 1 - mask_r(:,:)      !make coupler runoff mask 1 over ocean and 0 over land 

       call shr_msg_send_r (longxy_r , rtmlon*rtmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (latixy_r , rtmlon*rtmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (rtemp_rtm, rtmlon*rtmlat*4, SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (rtemp_rtm, rtmlon*rtmlat*4, SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_r (temp_area, rtmlon*rtmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_i (temp_mask, rtmlon*rtmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)

       write(6,*)'(CSM_SENDCONTROL): there will be ',ncpday, &
            ' send/recv calls per day from the land model to the flux coupler'
       write(6,*)'(CSM_SENDCONTROL):sent l->d control data msg_id = ',SHR_MSG_TAG_L2CI

    endif

  END SUBROUTINE csm_sendcontrol

!===============================================================================

  SUBROUTINE csm_recvgrid (cam_longxy, cam_latixy, cam_numlon, cam_landfrac, cam_landmask) 

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Receive valid land grid and land mask from coupler
! 
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

! ---------------------- arguments--------------------------------------
    integer , intent(out) :: cam_numlon(lsmlat)           !cam number of longitudes 
    real(r8), intent(out) :: cam_longxy(lsmlon,lsmlat)    !cam lon values
    real(r8), intent(out) :: cam_latixy(lsmlon,lsmlat)    !cam lat values 
    real(r8), intent(out) :: cam_landfrac(lsmlon,lsmlat)  !cam fractional land
    integer , intent(out) :: cam_landmask(lsmlon,lsmlat)  !cam land mask
!-----------------------------------------------------------------------

! ---------------------- Local variables -------------------------------
    integer  i,j                      !loop indices
    real(r8) xe(4,lsmlon,lsmlat)      !coupler land grid edges 
    real(r8) ye(4,lsmlon,lsmlat)      !coupler land grid edges
    real(r8) area_a(lsmlon,lsmlat)    !coupler atm grid areas
    integer  mask_a(lsmlon,lsmlat)    !coupler atm valid grid mask 
!-----------------------------------------------------------------------

    if (masterproc) then

       ibuffr(:) = 0
       
       call shr_msg_recv_i (ibuffr       ,nibuff         , SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_r (cam_longxy   ,lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_r (cam_latixy   ,lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_r (xe           ,lsmlon*lsmlat*4, SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_r (ye           ,lsmlon*lsmlat*4, SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_r (area_a       ,lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_r (cam_landfrac ,lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_i (cam_landmask ,lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       call shr_msg_recv_i (mask_a       ,lsmlon*lsmlat  , SHR_MSG_TID_CPL, SHR_MSG_TAG_C2LI)
       
       write(6,*)'(CSM_SENDGRID):recd d->l land grid, msg_id= ',SHR_MSG_TAG_C2L
       
! USE mask_a to determine number of valid longitudes for each latitude band 
! this is the only use for mask_a
       
       cam_numlon(:) = 0
       do j = 1,lsmlat
          do i= 1,lsmlon
             if (mask_a(i,j) /= 0) cam_numlon(j) = cam_numlon(j)+1
          end do
       end do
       
    endif  !end of if-masterproc block
    
    return
  END SUBROUTINE csm_recvgrid

!===============================================================================

  SUBROUTINE csm_sendrunoff()

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Send valid runoff information back to flux coupler
! 
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use RtmMod, only : ocnrof_iindx, ocnrof_jindx, ocnrof_vec

    if (masterproc) then

! Send integer buffer control info

       ibuffs(7)  = lsmlon           !number of model longitudes
       ibuffs(8)  = lsmlat           !number of model latitudes
       ibuffs(36) = size(ocnrof_vec) !number of data points in compressed runoff data 
       ibuffs(37) = rtmlon           !number of longitudes in uncompressed 2d runoff array
       ibuffs(38) = rtmlat           !number of latitudes  in uncompressed 2d runoff array

       call shr_msg_send_i(ibuffs       ,nibuff          , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)

! Send runoff vector compression info

       call shr_msg_send_i(ocnrof_iindx, size(ocnrof_vec), SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)
       call shr_msg_send_i(ocnrof_jindx, size(ocnrof_vec), SHR_MSG_TID_CPL, SHR_MSG_TAG_L2CI)

       write(6,*) '(CSM_SENDROF):sent l->d valid initial runoff info msg_id = ',SHR_MSG_TAG_L2CI

    endif

  END SUBROUTINE csm_sendrunoff

!===============================================================================

  SUBROUTINE csm_sendalb
 
!----------------------------------------------------------------------- 
! 
! Purpose: 
! Send initial albedos, surface temperature and snow data to the 
! flux coupler
! 
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use clm_varder
    use clm_varsur                    
    use clm_varmap                    
    use clm_varctl  , only : csm_doflxave, nsrest
    use RtmMod      , only : ocnrof_vec
    use time_manager, only : get_curr_date, get_prev_date
	
! --------------------------- Local variables ---------------------
    integer  :: i,j,k,l,m,n !loop indices
    real(r8) :: wt          !weight  
    integer  :: yr          !current year 
    integer  :: mon         !current month 
    integer  :: day         !current day (0, 1, ...)
    integer  :: ncsec       !current seconds of current date (0, ..., 86400)
    integer  :: ncdate      !current date (yymmdd format) (e.g., 021105)
#if (defined SPMD)
    integer  :: numrecvv(0:npes-1) !vector of items to be received  
    integer  :: displsv(0:npes-1)  !displacement vector
    integer  :: numsend            !number of items to be sent
#endif
    integer  :: ier                !return error code
! -----------------------------------------------------------------

! Allocate dynamic memory 
 
    allocate (send1d(nsnd,begpatch:endpatch), STAT=ier) 
    if (ier /= 0) then
       write(6,*)'CSM_SENDALB error: send1d allocation error'
       call endrun
    endif
    send1d(:,:)=inf

#if (defined SPMD)
    if (masterproc) then
       allocate (gather1d(nsnd,numpatch), STAT=ier)
       if (ier /= 0) then
          write(6,*)'CSM_SENDALB error: gather1d allocation error'
          call endrun
       endif
       gather1d(:,:) = inf
    endif
#else
    gather1d => send1d
#endif

    if (masterproc) then
       allocate (recv1d(nrcv,numpatch), STAT=ier) 
       if (ier /= 0) then
          write(6,*)'CSM_SENDALB error: recv1d allocation error'
          call endrun
       endif
       recv1d(:,:)=inf
    endif

#if (defined SPMD)
    allocate (scatter1d(nrcv,begpatch:endpatch), STAT=ier) 
    if (ier /= 0) then
       write(6,*)'CSM_SENDALB error: scatter1d allocation error'
       call endrun
    endif
    scatter1d(:,:) = inf
#else
    scatter1d => recv1d
#endif

! Send first data to coupler

    if (nsrest == 0) then   !initial run

! On initial timestep ONLY: determine 1d vector of states that will be sent
! to coupler and map fields from 1d subgrid vector to 2d [lsmlon]x[lsmlat] grid.

       do k = begpatch,endpatch
          send1d(:,k)            = 1.e30                !don't want to send NaN 
          send1d(isend_trad ,k)  = clm(k)%t_grnd        !tsxy
          send1d(isend_asdir,k)  = clm(k)%albd(1)       !asdir
          send1d(isend_aldir,k)  = clm(k)%albd(2)       !aldir
          send1d(isend_asdif,k)  = clm(k)%albi(1)       !asdif
          send1d(isend_aldif,k)  = clm(k)%albi(2)       !aldif
          send1d(isend_sno  ,k)  = clm(k)%h2osno/1000.  !snow (convert from mm to m)
       end do

#if (defined SPMD)
       call compute_mpigs_patch(nsnd, numsend, numrecvv, displsv)
       if (masterproc) then
          call mpi_gatherv (send1d(1,begpatch), numsend , mpir8, &
               gather1d, numrecvv, displsv, mpir8, 0, mpicom, ier)
       else
          call mpi_gatherv (send1d(1,begpatch), numsend , mpir8, &
               0._r8, numrecvv, displsv, mpir8, 0, mpicom, ier)
       endif
#else
       gather1d => send1d
#endif

       if (masterproc ) then
          do n=1,nsnd
             where (landmask(:,:) > 0) 
                send2d(:,:,n) = 0.
             elsewhere
                send2d(:,:,n) = 1.e30
             end where
          end do
          send2d(:,:,isend_sno) = 0. ! snow initialized to 0 everywhere
          do k = 1,numpatch
             if (patchvec%wtxy(k) /= 0.) then
                i  = patchvec%ixy(k)    
                j  = patchvec%jxy(k)    
                wt = patchvec%wtxy(k) 
                do n = 1,nsnd
                   send2d(i,j,n) = send2d(i,j,n) + gather1d(n,k)*wt
                end do
             end if
          end do
       endif

    else  ! restart run

! On a restart run, no meaningful data is sent to the flux coupler - 
! this includes the ocean runoff vector (which should only contain zero values)
! since the runoff code (riverfluxrtm) has not been called yet

       if (masterproc) send2d(:,:,:) = 1.e30  ! this will be sent on a restart timestep

    endif  
      
! Send data to coupler
! Determine time index to send to coupler. Note that for a restart run,
! the next time step is nstep+1. But must send current time step to 
! flux coupler here. 

    if (masterproc) then

       if (nsrest == 0) then
          call get_curr_date (yr, mon, day, ncsec) 
       else
          call get_prev_date (yr, mon, day, ncsec)
       endif
       ncdate = yr*10000 + mon*100 + day

       ibuffs(4) = ncdate  !model date (yyyymmdd)
       ibuffs(5) = ncsec   !elapsed seconds in model date

       call shr_msg_send_i (ibuffs    , size(ibuffs)    , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2C)
       call shr_msg_send_r (send2d    , size(send2d)    , SHR_MSG_TID_CPL, SHR_MSG_TAG_L2C)
       call shr_msg_send_r (ocnrof_vec, size(ocnrof_vec), SHR_MSG_TID_CPL, SHR_MSG_TAG_L2C)

       if (csm_timing) then
          irtc_s = shr_sys_irtc()
          write(6,9099) irtc_s,'l->d sending'
9099      format('[mp timing]  irtc = ',i20,' ',a)
       end if

    endif  ! end of if_masterproc

    return
  END SUBROUTINE csm_sendalb

!===============================================================================

  SUBROUTINE csm_dosndrcv (doalb)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Determine when to send and receive messages to/from the
! flux coupler on this time-step.
! 
! Method: 
! Determine if send/receive information to/from flux coupler
! Send msgs (land state and fluxes) to the flux coupler only when 
! doalb is true (i.e. on time steps before the atm does a solar
! radiation computation). Receive msgs (atm state) from the
! flux coupler only when dorad is true (i.e. on time steps