ccsm_msg.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

       ibuff(7) = plon               ! number of model longitudes
       ibuff(8) = plat               ! number of model latitudes
       ibuff(9) = msgpday            ! number of send/recv msgs per day
       if (nstep == 0) ibuff(34) = 1 ! do extra albedo calculation on startup
       ibuff(35) = 1                 ! use own restart info, not coupler's
!
! Constants
!
       pie       = acos(-1.)
       degtorad  = pie / 180.0
!
! Mask for which cells are active and inactive and 2D latitude grid
!
       mask(:,:)    = 0        ! Initialize mask so that cells are inactive
       clatdeg(:,:) = spval
       clondeg(:,:) = spval
       do lat = 1, plat
         mask(1:nlon(lat),lat)    = 1     ! Active cells
         clatdeg(1:nlon(lat),lat) = latdeg(lat) ! Put latitude in 2D array
         clondeg(1:nlon(lat),lat) = londeg(1:nlon(lat),lat)
       end do
!
! Send vertices of each grid point
! Verticies are ordered as follows: 
! 1=lower left, 2 = upper left, 3 = upper right, 4 = lower right
!
       ns_vert(:,:,:) = spval
       ew_vert(:,:,:) = spval
!
! Longitude vertices
!
       do lat = 1, plat
         ew_vert(1,1,lat)             = (londeg(1,lat) - 360.0 + londeg(nlon(lat),lat))*0.5
         ew_vert(1,2:nlon(lat),lat)   = (londeg(1:nlon(lat)-1,lat) + &
                                         londeg(2:nlon(lat),lat))*0.5
         ew_vert(2,:nlon(lat),lat)    = ew_vert(1,:nlon(lat),lat)  ! Copy lowleft corner to upleft
         ew_vert(3,:nlon(lat)-1,lat)  = ew_vert(1,2:nlon(lat),lat)
         ew_vert(3,nlon(lat),lat)     = (londeg(nlon(lat),lat) + (360.0 + londeg(1,lat)))*0.5
         ew_vert(4,:nlon(lat),lat)    = ew_vert(3,:nlon(lat),lat)  ! Copy lowright corner to upright
       end do
!
! Latitude
!
       if ( dycore_is('LR') )then
         ns_vert(1,:nlon(1),1)         = -90.0 + (latdeg(1) - latdeg(2))*0.5
         ns_vert(2,:nlon(plat),plat)   =  90.0 + (latdeg(plat) - latdeg(plat-1))*0.5
       else
         ns_vert(1,:nlon(1),1)         = -90.0
         ns_vert(2,:nlon(plat),plat)   =  90.0
       end if
       ns_vert(4,:nlon(1),1)       = ns_vert(1,nlon(1),1)        ! Copy lower left to lower right
       ns_vert(3,:nlon(plat),plat) = ns_vert(2,nlon(plat),plat)  ! Copy up left to up right
       do lat = 2, plat
         ns_vert(1,:nlon(lat),lat) = (latdeg(lat) + latdeg(lat-1) )*0.5
         ns_vert(4,:nlon(lat),lat) = ns_vert(1,:nlon(lat),lat)
       end do
       do lat = 1, plat-1
         ns_vert(2,:nlon(lat),lat) = (latdeg(lat) + latdeg(lat+1) )*0.5
         ns_vert(3,:nlon(lat),lat) = ns_vert(2,:nlon(lat),lat)
       end do
!
! Get area of grid cells (as radians squared)
!
       area(:,:) = 0.0
       do lat = 1, plat
         do lon = 1, nlon(lat)
           del_phi = sin( ns_vert(2,lon,lat)*degtorad ) - sin( ns_vert(1,lon,lat)*degtorad )
           del_theta = ( ew_vert(4,lon,lat) - ew_vert(1,lon,lat) )*degtorad
           area(lon,lat) = del_theta*del_phi
         end do
       end do
!
! If grid has a pole point (as in Lin-Rood dynamics
!
      if ( dycore_is('LR') )then
         lat = 1
         mask(2:nlon(lat),lat) = 0   ! Only active one point on pole
         do lon = 1, nlon(lat)
           del_phi = -sin( latdeg(lat)*degtorad ) + sin( ns_vert(2,lon,lat)*degtorad )
           del_theta = ( ew_vert(4,lon,lat) - ew_vert(1,lon,lat) )*degtorad
           area(lon,lat)  = del_theta*del_phi
         end do
         lat = plat
         mask(2:nlon(lat),lat) = 0   ! Only active one point on pole
         do lon = 1, nlon(lat)
           del_phi =  sin( latdeg(lat)*degtorad ) - sin( ns_vert(1,lon,lat)*degtorad )
           del_theta = ( ew_vert(4,lon,lat) - ew_vert(1,lon,lat) )*degtorad
           area(lon,lat)  = del_theta*del_phi
         end do
       end if
       if ( abs(sum(area) - 4.0*pie) > 1.e-12 )then
         write (6,*) 'CCSM_MSG_SENDGRID: sum of areas on globe does not = 4*pi'
         write (6,*) ' sum of areas = ', sum(area)
         call endrun
       end if
!
! Send ibuff and grid information to flux coupler.
!
       call shr_msg_send_i (ibuff  , nibuff     , SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)
       call shr_msg_send_r (clondeg,  size(clondeg), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)
       call shr_msg_send_r (clatdeg, size(clatdeg), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)
       call shr_msg_send_r (ew_vert, size(ew_vert), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)
       call shr_msg_send_r (ns_vert, size(ns_vert), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)
       call shr_msg_send_r (area   , size(area), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)
       call shr_msg_send_i (mask   , size(mask), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)
       write(6,*)'(CCSM_MSG_SENDGRID): sent a->d startup msg_id = ',SHR_MSG_TAG_A2CI
       call shr_sys_flush(6)

    endif  ! end of if-masterproc

    return
  end subroutine ccsm_msg_sendgrid

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

  subroutine ccsm_msg_getalb

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Send first time of albedo calculation (along with dummy data) to
! coupler and get albedos along with snow and ocn/ice fractions back 
! 
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use comsrf, only: srfflx_state2d,surface_state2d, icefrac, ocnfrac,snowhice,snowhland
    use time_manager, only: get_start_date

#include <comctl.h>

!--------------------------Local Variables------------------------------
    integer i,m,n,lat                   ! indices
    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
#ifdef SPMD
    integer :: numperlat         ! number of values per latitude band
    integer :: numsend(0:npes-1) ! number of items to be sent
    integer :: numrecv           ! number of items to be received
    integer :: displs(0:npes-1)  ! displacement array
#endif
!-----------------------------------------------------------------------
!
    if (masterproc) then
!
! Send first time of albedo calculation (along with dummy data) to the flux coupler. 
!
       call get_start_date(yr, mon, day, cseccsm)
       cdatecsm = yr*10000 + mon*100 + day

       ibuff(:)  = 0
       ibuff(4)  = cdatecsm   ! model date (yyyymmdd)
       ibuff(5)  = cseccsm    ! elapsed seconds in current day
       ibuff(6)  = 0          ! current 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) = 0          ! albedo calculation time shift

       arput(:,:,:) = 1.0e+36
       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) irtc_s = shr_sys_irtc()
!     
! Receive merged surface state from flux coupler.
!   
       ibuff(:) = 0
       if (csm_timing) irtc_w = shr_sys_irtc()
       call shr_msg_recv_i (ibuff, size(ibuff), SHR_MSG_TID_CPL, SHR_MSG_TAG_C2A)
       call shr_msg_recv_r (arget, size(arget), SHR_MSG_TID_CPL, SHR_MSG_TAG_C2A)
       if (csm_timing) then
          irtc_r = shr_sys_irtc()
          write(6,9099) irtc_s,'a->d sending'
          write(6,9099) irtc_w,'d->a waiting'
          write(6,9099) irtc_r,'d->a received'
       end if
       write(6,*) '(CCSM_MSG_GETALB) recd d->a surface state, msg_id= ',SHR_MSG_TAG_C2A
       call shr_sys_flush(6)

    endif  ! end of if-masteproc
!
! Extract the surface state variables and surface type fractions.
! NOTE: at the initial time the flux coupler only sends surface 
! states, NOT surface fluxes.
!
#if (defined SPMD)
    do n=1,nrcv
       do lat=1,plat
          arget_buf(:,n,lat) = arget(:,lat,n)
       end do
    end do
    numperlat = plon*nrcv
    call compute_gsfactors (numperlat, numrecv, numsend, displs)
    if ( masterproc ) then
      call mpiscatterv (arget_buf, numsend, displs, mpir8, arget_spmd(1,1,beglat), &
                        numrecv, mpir8, 0, mpicom)
    else
      call mpiscatterv (0.0_r8, numsend, displs, mpir8, arget_spmd(1,1,beglat), &
                        numrecv, mpir8, 0, mpicom)
    end if
    do lat=beglat,endlat
       do i=1,plon
          srfflx_state2d(lat)%asdir(i)  = arget_spmd(i,7 ,lat) ! Surface state variable
          srfflx_state2d(lat)%aldir(i)  = arget_spmd(i,8 ,lat) ! Surface state variable
          srfflx_state2d(lat)%asdif(i)  = arget_spmd(i,9 ,lat) ! Surface state variable
          srfflx_state2d(lat)%aldif(i)  = arget_spmd(i,10,lat) ! Surface state variable
          srfflx_state2d(lat)%ts(i)     = arget_spmd(i,11,lat) ! Surface state variable
          snowhland(i,lat)  = arget_spmd(i,12,lat) ! Surface state variable
          icefrac(i,lat)= arget_spmd(i,13,lat) ! Surface type fraction
          ocnfrac(i,lat)= arget_spmd(i,14,lat) ! Surface type fraction
       end do
    end do
#else 
    do lat=beglat,endlat
       do i=1,plon
          srfflx_state2d(lat)%asdir(i)  = arget(i,lat,7 ) ! Surface state variable
          srfflx_state2d(lat)%aldir(i)  = arget(i,lat,8 ) ! Surface state variable
          srfflx_state2d(lat)%asdif(i)  = arget(i,lat,9 ) ! Surface state variable
          srfflx_state2d(lat)%aldif(i)  = arget(i,lat,10) ! Surface state variable
          srfflx_state2d(lat)%ts(i)     = arget(i,lat,11) ! Surface state variable
          snowhland(i,lat)  = arget(i,lat,12) ! Surface state variable
          icefrac(i,lat)= arget(i,lat,13) ! Surface type fraction
          ocnfrac(i,lat)= arget(i,lat,14) ! Surface type fraction
       end do
    end do
#endif
!
! Set snowh over ice to zero since flux coupler only returns snowh over land
!
    snowhice(:,:) = 0.0

9099 format('[mp timing]  irtc = ',i20,' ',a)

    return
  end subroutine ccsm_msg_getalb

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

  subroutine ccsm_msg_compat( cpl_maj_vers, cpl_min_vers, expect_maj_vers, expect_min_vers )

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Checks that the message recieved from the coupler is compatable
! with the type of message that I expect to recieve.  
! 
! Method: 
! If the minor version numbers differ I print a warning message.  If the major
! numbers differ I abort since that means that the change is drastic enough that 
! I can't run with the differences.
! 
! Author: Erik Kluzek
! 
!-----------------------arguments---------------------------------------
    integer, intent(in) :: cpl_maj_vers    ! major version from coupler initial ibuff array
    integer, intent(in) :: cpl_min_vers    ! minor version from coupler initial ibuff array
    integer(SHR_KIND_IN), intent(in) :: expect_maj_vers ! major version of the coupler I'm expecting
    integer(SHR_KIND_IN), intent(in) :: expect_min_vers ! minor version of the coupler I'm expecting
!-----------------------------------------------------------------------
    write(6,*)'(CCSM_MSG_COMPAT): This is revision: $Revision: 1.11.2.6 $'
    write(6,*)'              Tag: $Name: cam2_0_brnchT_release3 $'
    write(6,*)'              of the message compatability interface:'
    if ( cpl_min_vers /= expect_min_vers ) then
       write(6,*)'WARNING(cpl_compat):: Minor version of coupler messages different than expected: '
       write(6,*)'The version of the coupler being used is: ', cpl_min_vers
       write(6,*)'The version I expect is:                  ', expect_min_vers
    end if
    if ( cpl_maj_vers /= expect_maj_vers )then
       write(6,*) 'ERROR(cpl_compat):: Major version of coupler messages different than expected: '
       write(6,*) 'The version of the coupler being used is: ', cpl_maj_vers
       write(6,*) 'The version I expect is:                  ', expect_maj_vers
       call endrun
    end if
    return
  end subroutine ccsm_msg_compat

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

  subroutine ccsm_compat_check_spval( spval, data, string )

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Check that the given piece of real data sent from the coupler is valid data 
! and not the couplers special data flag.  This ensures that the data
! you expect is actually being sent by the coupler.
! 
! Method: 
! 
! Author: Erik Kluzek
! 
!-----------------------------------------------------------------------

!------------------ Arguments ------------------------------------------
    real(r8) , intent(in) ::  spval, data
    character, intent(in) ::  string*(*)
!-----------------------------------------------------------------------

    if ( spval == data )then
       write(6,*)'ERROR::( lsm_compat_check_spval) msg incompatibility'
       write(6,*)'ERROR:: I expect to recieve the data type: ', string
       write(6,*)'from CPL, but all I got was the special data flag'
       write(6,*)'coupler must not be sending this data, you are'
       write(6,*)'running with an incompatable version of the coupler'
       call endrun
    end if

    return
  end subroutine ccsm_compat_check_spval

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

#endif

end module ccsm_msg