ccsm_msg.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

!---------------------------Local workspace-----------------------------
    integer i,lat,n                ! longitude,latitude,count indices
    integer nstep                  ! current time step
    integer nstepcsm               ! time step sent to flux coupler
    integer yr, mon, day           ! year, month, day components of cdatecsm
    integer cdatecsm,cseccsm       ! current date,sec 
    integer msgpday                ! number of send/recv msgs per day
    logical nextsw                 ! set to true for next sw calculation
    real(r8) dtime                 ! timestep size
    real(r8) albshift              ! albedo calculation time shift
!-----------------------------------------------------------------------

    nstep = get_nstep()
    dtime = get_step_size()
!
! Determine time step sent to flux coupler and corresponding date.
!
    if (nstep==0) then               
       nstepcsm = nstep
       call get_curr_date(yr, mon, day, cseccsm)
       cdatecsm = yr*10000 + mon*100 + day
    else
       nstepcsm = nstep - 1
       call get_prev_date(yr, mon, day, cseccsm)
       cdatecsm = yr*10000 + mon*100 + day
    end if
!
! Determine albedo calculation time shift, which is the time interval 
! from nstepcsm until the next short wave calculation.

    if (nstep /= 0) then               
       if (flxave) then
          albshift = nint((nstep+iradsw-nstepcsm)*dtime)
       else
          nextsw = .false.
          n = 1
          do while (.not. nextsw)
             nextsw = (mod((nstep+n-1),iradsw)==0)
             if (nextsw) albshift = nint((nstep+n-nstepcsm)*dtime)
             n = n+1
          end do
       endif
    else
       albshift = nint(iradsw*dtime) + dtime
    endif
!
! Determine number of send/recv msgs per day
!
    if (flxave) then                
       msgpday = nint(86400./dtime)/iradsw 
    else
       msgpday = nint(86400./dtime)      
    endif
!
! Determine ibuff array
!
    ibuff(:)  = 0
    ibuff(4)  = cdatecsm            ! model date (yyyymmdd)
    ibuff(5)  = cseccsm             ! elapsed seconds in current day
    ibuff(6)  = nstepcsm            ! model time step 
    ibuff(7)  = plon                ! number of model longitudes
    ibuff(8)  = plat                ! number of model latitudes
    ibuff(9)  = msgpday             ! number of send/recv msgs per day
    ibuff(32) = albshift            ! albedo calculation time shift
!
! Send data to coupler
!
    call shr_msg_send_i (ibuff, size(ibuff), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2C)
    call shr_msg_send_r (arput, size(arput), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2C)
    if (csm_timing) then
       irtc_s = shr_sys_irtc()
       write(6,9099) irtc_s,'a->d sending'
    end if
9099 format('[mp timing]  irtc = ',i20,' ',a)

    return
  end subroutine msgsnd

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

  subroutine ccsmave (iradsw, nstep, dosw)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Average the input fluxes to lsm between solar radiation times.
! 
! Method: 
! Currently, the only flux requiring averaging is the precipitation, 
! since the radiative fluxes are constant over the averaging interval.
! 
! Author: Byron Boville
! 
!-----------------------------------------------------------------------

    use comsrf, only: surface_state2d

!------------------------------Arguments--------------------------------
    integer, intent(in) :: iradsw  ! solar radiation interval
    integer, intent(in) ::  nstep  ! time step number
    logical, intent(in) ::  dosw   ! time to compute averages (solar radiation time)
!-----------------------------------------------------------------------

!---------------------------Local workspace-----------------------------
    integer i,lat    ! longitude,level,latitude indices
    real(r8) rcount  ! reciprocal of count
!-----------------------------------------------------------------------
!
! If iradsw == 1, then no averaging is required
!
    if (iradsw == 1) return
!
! Set the counter and normalizing factor
!
    if (nstep == 0) countfa = 0
    countfa = countfa + 1
    if (dosw) then
       rcount = 1./countfa
    end if

!$OMP PARALLEL DO PRIVATE(lat,i)
    do lat = beglat,endlat

       if (countfa == 1) then
          do i = 1, nlon(lat)
             precca(i,lat)  = surface_state2d(lat)%precc(i)   
             precla(i,lat)  = surface_state2d(lat)%precl(i)   
             precsca(i,lat) = surface_state2d(lat)%precsc(i)   
             precsla(i,lat) = surface_state2d(lat)%precsl(i)   
          end do
!
! Final call of averaging interval, complete averaging and copy data back
!
       else if (dosw) then
          do i = 1, nlon(lat)
             precca(i,lat)  = rcount*(precca(i,lat) + surface_state2d(lat)%precc(i))
             precla(i,lat)  = rcount*(precla(i,lat) + surface_state2d(lat)%precl(i))
             precsca(i,lat) = rcount*(precsca(i,lat) + surface_state2d(lat)%precsc(i))
             precsla(i,lat) = rcount*(precsla(i,lat) + surface_state2d(lat)%precsl(i))
          end do
!
! Intermediate call, add data to accumulators
!
       else
          do i = 1, nlon(lat)
             precca(i,lat)  = precca(i,lat) + surface_state2d(lat)%precc(i)   
             precla(i,lat)  = precla(i,lat) + surface_state2d(lat)%precl(i)   
             precsca(i,lat) = precsca(i,lat) + surface_state2d(lat)%precsc(i)   
             precsla(i,lat) = precsla(i,lat) + surface_state2d(lat)%precsl(i)   
          end do
       end if
    end do
!
! Reset the counter if the average was just computed
!
    if (dosw) then
       countfa = 0
    end if

    return
  end subroutine ccsmave

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

  subroutine ccsm_msg_getorb

!----------------------------------------------------------------------- 
! 
! Purpose: Get orbital values from flux coupler
! 
! Method: 
! 
! Author: Erik Kluzek
! 
!-----------------------------------------------------------------------

     use physconst, only:

#include <comctl.h>
#include <comsol.h>

!--------------------------Local Variables------------------------------
    integer cplcdate           ! current date from coupler      
    integer cplcsec            ! elapsed sec on current date    
    integer info_time          ! T => turn on msg-passing timing
    integer maj_vers           ! Coupler major message compatibility version
    integer min_vers           ! Coupler minor message compatibility version
    integer ierr               ! Return error  
!
!-----------------------------------------------------------------------
!
    if (masterproc) then
!
! Receive first ibuff message from coupler. This is currently only used
! to determine if output csm timing will occur.
!
       ibuff(:) = 0
       call shr_msg_recv_i (ibuff, nibuff, SHR_MSG_TID_CPL, SHR_MSG_TAG_C2AI)

       ierr      = ibuff( 1)  ! error code
       cplcdate  = ibuff( 4)  ! current date from coupler
       cplcsec   = ibuff( 5)  ! elapsed sec on current date
       info_time = ibuff(11)  ! T => turn on msg-passing timing
       maj_vers  = ibuff(40)  ! Coupler message major version
       min_vers  = ibuff(41)  ! Coupler message minor version
       ncbuff    = ibuff(42)  ! Size of character data to recieve
       write(6,*)'(CCSM_MSG_GET_ORB): recd d->a initial ibuf msg_id = ',SHR_MSG_TAG_C2AI
       call shr_sys_flush(6)
!
! Check that the version of the message from the coupler is version expected
!
       call ccsm_msg_compat(maj_vers, min_vers, SHR_MSG_A_MAJ_V04, SHR_MSG_A_MIN_V00)
!
! Receive first floating point rbuff message from coupler.
!
       rbuff(:) = 0.0
       call shr_msg_recv_r (rbuff, nibuff, SHR_MSG_TID_CPL, SHR_MSG_TAG_C2AI)

       spval  = rbuff(1)      !Special flag value for data
       eccen  = rbuff(2)      !Earth's eccentricity of orbit
       obliqr = rbuff(3)      !Earth's Obliquity radians
       lambm0 = rbuff(4)      !longitude of perihelion at v-equinox
       mvelpp = rbuff(5)      !Earth's Moving vernal equinox of orbit + pi
!
! Check that data sent is good data and not the special value
!
       call ccsm_compat_check_spval(spval, eccen ,'Eccentricity' )
       call ccsm_compat_check_spval(spval, obliqr,'Obliquity' )
       call ccsm_compat_check_spval(spval, lambm0,'long of perh.' )
       call ccsm_compat_check_spval(spval, mvelpp,'Moving lon of perh')
       write(6,*)'(CCSM_MSG_GET_ORB): eccen:  ', eccen
       write(6,*)'(CCSM_MSG_GET_ORB): obliqr: ', obliqr
       write(6,*)'(CCSM_MSG_GET_ORB): lambm0: ', lambm0
       write(6,*)'(CCSM_MSG_GET_ORB): mvelpp: ', mvelpp
       write(6,*)'(CCSM_MSG_GET_ORB): recd d->a initial real buf msg_id = ',SHR_MSG_TAG_C2AI
       call shr_sys_flush(6)
!
! Receive character data cbuff message from coupler.
!
       if ( ncbuff > 0 )then
          call shr_msg_recv_c (cbuff, ncbuff, SHR_MSG_TID_CPL, SHR_MSG_TAG_C2AI)
          write(6,*)'(CCSM_MSG_GET_ORB): recd d->a initial char. buf msg_id= ',SHR_MSG_TAG_C2AI
          call shr_sys_flush(6)
       end if
!
! Determine if will output csm timing info.
!
       if (info_time == 0) then
          csm_timing = .false.
       else
          csm_timing = .true.
       endif

    endif ! End of if-masterproc

#if ( defined SPMD )
    call mpibcast(spval , 1, mpir8, 0, mpicom)
    call mpibcast(eccen , 1, mpir8, 0, mpicom)
    call mpibcast(obliqr, 1, mpir8, 0, mpicom)
    call mpibcast(lambm0, 1, mpir8, 0, mpicom)
    call mpibcast(mvelpp, 1, mpir8, 0, mpicom)
#endif

    return
  end subroutine ccsm_msg_getorb

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

  subroutine ccsm_msg_sendgrid

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

    use infnan
    use commap, only: latdeg, londeg
    use dycore, only: dycore_is
    use time_manager, only: get_nstep, get_step_size

#include <comctl.h>

!--------------------------Local Variables------------------------------
    integer lat, lon              ! loop indices
    integer nstep                  ! current time step
    integer msgpday               ! number of send/recv msgs per day
    integer(SHR_KIND_IN) ::  mask(plon,plat)       ! Mask of valid data
    real(r8) dtime                ! timestep size [s]
    real(r8) area(plon,plat)      ! Area in radians squared for each grid point
    real(r8) clondeg(plon,plat)   ! Longitude grid
    real(r8) clatdeg(plon,plat)   ! latitude grid as 2 dimensional array
    real(r8) ns_vert(4,plon,plat) ! latitude grid vertices
    real(r8) ew_vert(4,plon,plat) ! longitude grid vertices
    real(r8) del_theta            ! difference in latitude at a grid point
    real(r8) del_phi              ! difference in longitude at a grid point
    real(r8) pie                  ! mathmatical constant 3.1415...
    real(r8) degtorad             ! convert degrees to radians
!-----------------------------------------------------------------------

    if (masterproc) then

       nstep = get_nstep()
       dtime = get_step_size()
!
! Determine number of send/recv msgs per day
!
       if (flxave) then                
          msgpday = nint(86400./dtime)/iradsw 
       else
          msgpday = nint(86400./dtime)      
       endif
       write(6,*)'(CCSM_MSG_SENDGRID): there are ',msgpday,' send/recv msgs per day'
       call shr_sys_flush(6)
!
! Determine ibuff sent to coupler
!
       ibuff(:) = 0