clm_csmmod.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

! when the atm does a solar radiation computation). 
! The fluxes are then averaged between the send and receive calls. 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use clm_varctl   , only : csm_doflxave
    use time_manager , only : get_step_size, get_nstep
    use shr_const_mod, only : SHR_CONST_CDAY

!----------------------------- Arguments --------------------------
    logical, intent(in) :: doalb  !true=>next timestep a radiation time step
!-----------------------------------------------------------------

! ---------------------- Local variables --------------------------
    integer  :: ntspday           !model steps per day
    real(r8) :: dtime             !step size (seconds)   
    integer  :: nstep             !time step 
!-----------------------------------------------------------------

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

! Determine if send/receive information to/from flux coupler

    nstep = get_nstep()
    if (csm_doflxave) then
       if (nstep == 0) then
          dorecv = .true.
          dosend = .false.
       else if (nstep == 1) then
          dorecv = .false.
          dosend = doalb
       else
          dorecv = dosend
          dosend = doalb
       endif
    else
       if (nstep == 0) then
          dorecv = .true.
          dosend = .false.
       else if (nstep == 1) then
          dorecv = .false.
          dosend = .true.
       else
          dorecv = .true.
          dosend = .true.
       endif
    endif

! If at end of day: check if should write restart file or stop at next time step
! Note these statements must appear here since ibuffr is not received at every time 
! step when flux averaging occurs.

    csmstop_next = .false.
    csmrstrt     = .false.
    dtime        = get_step_size()
    ntspday      = nint(SHR_CONST_CDAY/dtime)
    if (mod(nstep,ntspday) == 0) then
       if (ibuffr(2) /= 0) then  !stop at end of day
          csmstop_next = .true.  !will stop on next time step
          write(6,*)'(CSM_DOSNDRCV) output restart and history files at nstep = ',nstep
       endif
       if (ibuffr(21) /= 0) then !write restart at end of day
          csmrstrt = .true.      !will write restart now
          write(6,*)'(CSM_DOSNDRCV) output restart and history files at nstep = ',nstep
       endif
    endif

    return
  END SUBROUTINE csm_dosndrcv

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

  SUBROUTINE csm_recv()

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Receive data from the flux coupler
! 
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use clm_varder           !derived type definition
    use clm_varcon           !physical constants
    use clm_varmap           !mapping variables

! --------------------------- Local variables ---------------------
    integer :: i,j,k,n             !indices 
    real(r8):: forc_rainc          !rainxy Atm flux mm/s   
    real(r8):: forc_rainl          !rainxy Atm flux mm/s   
    real(r8):: forc_snowc          !snowfxy Atm flux  mm/s 
    real(r8):: forc_snowl          !snowfxl Atm flux  mm/s 
    integer :: ier                 !return error code	
#if (defined SPMD)
    integer  :: numsendv(0:npes-1)    !vector of items to be sent
    integer  :: displsv(0:npes-1)     !displacement vector
    integer  :: numrecv               !number of items to be received
#endif
! -----------------------------------------------------------------

! Start timers

     if (timer_lnd_sendrecv) then
        call t_stopf ('lnd_sendrecv') ; timer_lnd_sendrecv = .false.
     endif

     call t_startf('lnd_recv')

! Receive message from flux coupler

    if (masterproc) then
       ibuffr(:)     = 0            
       recv2d(:,:,:) = 1.e30
       if (csm_timing) irtc_w = shr_sys_irtc()
       call shr_msg_recv_i (ibuffr, size(ibuffr), SHR_MSG_TID_CPL, SHR_MSG_TAG_C2L)
       call shr_msg_recv_r (recv2d, size(recv2d), SHR_MSG_TID_CPL, SHR_MSG_TAG_C2L)
       if (csm_timing) then
          irtc_r = shr_sys_irtc()
          write(6,9099) irtc_w,'d->l waiting'
9099      format('[mp timing]  irtc = ',i20,' ',a)
          write(6,9099) irtc_r,'d->l received'
       end if

! Do global integrals of fluxes if flagged

       if (debug_flag) then	
          write(6,*)
          write(6,100) 'lnd','recv', irecv_lwrad, global_sum(recv2d(1,1,irecv_lwrad),1.e30), ' lwrad'
          write(6,100) 'lnd','recv', irecv_rainc, global_sum(recv2d(1,1,irecv_rainc),1.e30), ' rainc'
          write(6,100) 'lnd','recv', irecv_rainl, global_sum(recv2d(1,1,irecv_rainl),1.e30), ' rainl'
          write(6,100) 'lnd','recv', irecv_snowc, global_sum(recv2d(1,1,irecv_snowc),1.e30), ' snowc'
          write(6,100) 'lnd','recv', irecv_snowl, global_sum(recv2d(1,1,irecv_snowl),1.e30), ' snowl'
          write(6,100) 'lnd','recv', irecv_soll , global_sum(recv2d(1,1,irecv_soll ),1.e30), ' soll '
          write(6,100) 'lnd','recv', irecv_sols , global_sum(recv2d(1,1,irecv_sols ),1.e30), ' sols '
          write(6,100) 'lnd','recv', irecv_solld, global_sum(recv2d(1,1,irecv_solld),1.e30), ' solld'
          write(6,100) 'lnd','recv', irecv_solsd, global_sum(recv2d(1,1,irecv_solsd),1.e30), ' solsd'
100       format('comm_diag ',a3,1x,a4,1x,i3,es26.19,a)
          write(6,*)
       endif
    endif  ! end of if-masteproc
#if (defined SPMD)
    call mpi_bcast (ibuffr, size(ibuffr), mpiint, 0, mpicom, ier)    
#endif

! Stop timer

     call t_stopf('lnd_recv') 

! Check if end of run now, if so stop (each processor does this) 

    csmstop_now = .false.
    if (ibuffr(3) /= 0) then 
       csmstop_now = .true.
       if (timer_lnd_recvsend) call t_stopf('lnd_recvsend')
       if (timer_lnd_sendrecv) call t_stopf('lnd_sendrecv')
       write(6,*)'(CSM_RECV) stop now signal from flux coupler'
       write(6,*)'(CSM_RECV) ibuffr(3) = ',ibuffr(3)
       if (masterproc) then
          write(6,9001)
          write(6,9002) ibuffr(4)
          write(6,9003)
9001      format(/////' ===========> Terminating CLM Model')
9002      format(     '      Date: ',i8)
9003      format(/////' <=========== CLM Model Terminated')
       endif
       RETURN
    endif

! More timer logic
 
     if (.not. timer_lnd_recvsend) then
        call t_startf('lnd_recvsend') ; timer_lnd_recvsend = .true.
     endif

! Map 2d received fields on [lsmlon]x[lsmlat] grid to subgrid vectors

    if (masterproc) then
       do k = 1,numpatch
          i = patchvec%ixy(k)    
          j = patchvec%jxy(k)    
          do n = 1,nrcv
             recv1d(n,k) = recv2d(i,j,n)
          end do
       end do
    end if

#if (defined SPMD)
    call compute_mpigs_patch(nrcv, numrecv, numsendv, displsv)
    if (masterproc) then
       call mpi_scatterv (recv1d, numsendv, displsv, mpir8, &
            scatter1d(1,begpatch), numrecv, mpir8 , 0, mpicom, ier)
    else
       call mpi_scatterv (0._r8, numsendv, displsv, mpir8, &
            scatter1d(1,begpatch), numrecv , mpir8, 0, mpicom, ier)
    endif
#else
    scatter1d => recv1d
#endif

! Split data from coupler into component arrays. Note that the precipitation fluxes received 
! from the coupler are in units of kg/s/m^2. To convert these precipitation rates in units of 
! mm/sec, one must divide by 1000 kg/m^3 and multiply by 1000 mm/m resulting in an overall 
! factor of unity. Below the units are therefore given in mm/s.

    do k = begpatch, endpatch
       clm(k)%forc_hgt      = scatter1d(irecv_hgt  ,k)
       clm(k)%forc_u        = scatter1d(irecv_u    ,k)
       clm(k)%forc_v        = scatter1d(irecv_v    ,k)
       clm(k)%forc_th       = scatter1d(irecv_th   ,k)
       clm(k)%forc_q        = scatter1d(irecv_q    ,k) 
       clm(k)%forc_pbot     = scatter1d(irecv_pbot ,k)
       clm(k)%forc_t        = scatter1d(irecv_t    ,k)
       clm(k)%forc_lwrad    = scatter1d(irecv_lwrad,k)                             
       forc_rainc           = scatter1d(irecv_rainc,k)                               
       forc_rainl           = scatter1d(irecv_rainl,k)                              
       forc_snowc           = scatter1d(irecv_snowc,k)                            
       forc_snowl           = scatter1d(irecv_snowl,k)                            
       clm(k)%forc_solad(2) = scatter1d(irecv_soll ,k)
       clm(k)%forc_solad(1) = scatter1d(irecv_sols ,k)
       clm(k)%forc_solai(2) = scatter1d(irecv_solld,k)
       clm(k)%forc_solai(1) = scatter1d(irecv_solsd,k)

       ! determine derived quantities

       clm(k)%forc_hgt_u = clm(k)%forc_hgt   !observational height of wind [m]            
       clm(k)%forc_hgt_t = clm(k)%forc_hgt   !observational height of temperature [m]     
       clm(k)%forc_hgt_q = clm(k)%forc_hgt   !observational height of humidity [m]        
       clm(k)%forc_vp    = clm(k)%forc_q*clm(k)%forc_pbot / (0.622+0.378*clm(k)%forc_q)   
       clm(k)%forc_rho   = (clm(k)%forc_pbot-0.378*clm(k)%forc_vp) / (rair*clm(k)%forc_t) 
       clm(k)%forc_co2   = pco2*clm(k)%forc_pbot                                          
       clm(k)%forc_o2    = po2*clm(k)%forc_pbot                                           

       ! Determine precipitation needed by clm

       clm(k)%forc_rain = forc_rainc + forc_rainl
       clm(k)%forc_snow = forc_snowc + forc_snowl
       if ( clm(k)%forc_snow > 0.0_r8  .and. clm(k)%forc_rain > 0.0_r8 ) then
          write(6,*) 'kpatch= ',k, &
               ' snow= ',clm(k)%forc_snow,' rain= ',clm(k)%forc_rain, &
               ' CLM cannot currently handle both non-zero rain and snow'
          call endrun
       elseif (clm(k)%forc_rain > 0.) then
          clm(k)%itypprc = 1
       elseif (clm(k)%forc_snow > 0.) then
          clm(k)%itypprc = 2
       else
          clm(k)%itypprc = 0
       endif
    end do

    return
  END SUBROUTINE csm_recv

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

  SUBROUTINE csm_send()

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Send data to the flux coupler
!
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use clm_varder
    use clm_varmap            !mapping arrays
    use clm_varctl            !run control variables    
    use clm_varsur            !surface variables
    use RtmMod      , only : ocnrof_vec
    use time_manager, only : get_curr_date

! --------------------------- Local variables ---------------------
    integer :: i,j,k,l,m,n !loop indices
    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
    integer :: ier                  !error return status
#endif
! -----------------------------------------------------------------
    
! Send data to the flux coupler

    if (timer_lnd_recvsend) then
       call t_stopf ('lnd_recvsend') ; timer_lnd_recvsend = .false.
    endif

! Start timer

    call t_startf('lnd_send')

! Determine 1d vector of fields that will be sent to coupler.
! Coupler has convention that fluxes are positive downward.

    do k = begpatch,endpatch
       send1d(isend_trad ,k) = clm(k)%t_rad         !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)
       if (csm_doflxave) then
          send1d(isend_taux ,k) = -taux_ave(k)                 
          send1d(isend_tauy ,k) = -tauy_ave(k)                 
          send1d(isend_lhflx,k) = -lhflx_ave(k)                
          send1d(isend_shflx,k) = -shflx_ave(k)                
          send1d(isend_lwup ,k) = -lwup_ave(k)                 
          send1d(isend_qflx ,k) = -qflx_ave(k)                 
          send1d(isend_swabs,k) = -swabs_ave(k)
       else