ccsm_msg.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

!
! Initialize ibuff
!
       ibuff(:)  = 0
       ibuff(4)  = cdatecsm   ! model date (yyyymmdd)
       ibuff(5)  = cseccsm    ! elapsed seconds in current day
       ibuff(6)  = nstepcsm   ! ending model time step 
!
! Send final message
!
       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)
!
! Receive final message
!
       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)

    endif

    return
   end subroutine ccsmfin

   subroutine write_restart_ccsm
!----------------------------------------------------------------------- 
! 
! Purpose: 
! Write COUP_CSM specific variables to restart dataset
! 
! Author: 
! 
!-----------------------------------------------------------------------

#include <comlun.h>
#include <comctl.h>

!---------------------------Local variables-----------------------------
   integer ioerr          ! error return
!-----------------------------------------------------------------------
!
! Write out flux averaging flag
!
   if (masterproc) then
      write (nrg, iostat=ioerr) flxave
      if (ioerr /= 0 ) then
         write (6,*) 'ioerror ',ioerr,' on i/o unit= ',nrg
         call endrun
      end if
   endif
!
! If flux averaging is enabled write out necessary info
!
   if (flxave) then
      if (masterproc) then
         write(nrg, iostat=ioerr) dosend, countfa, arget
         if (ioerr /= 0 ) then
            write (6,*) 'ioerror ',ioerr,' on i/o unit= ',nrg
            call endrun
         end if
      end if
      call wrtout_r8 (nrg, precca , plon)
      call wrtout_r8 (nrg, precla , plon)
      call wrtout_r8 (nrg, precsca, plon)
      call wrtout_r8 (nrg, precsla, plon)
   endif

   return
   end subroutine write_restart_ccsm

   subroutine read_restart_ccsm
!-----------------------------------------------------------------------
! Read in COUP_CSM specific variables and determine surface state
! variables and fluxes from arget. NOTE: are not assured that will 
! do a recv upon restart if flux averaging is used so must split 
! these variables off from arget since most are not individually 
! written out to the restart file.
!-----------------------------------------------------------------------
    use comsrf, only: srfflx_state2d,surface_state2d, icefrac, ocnfrac, &
                      landfrac, snowhland

#include <comlun.h>
#include <comctl.h>

!---------------------------Local variables-----------------------------
   integer i,n,lat      ! indices
   integer ioerr        ! error return
   integer len          ! length for spmd
   logical flxave_res   ! flux averaging flag from restart file
#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
   integer :: ierr              ! error flag
#endif
!-----------------------------------------------------------------------
!
! Read in flux averaging flag

   if (masterproc) then
      read (nrg, iostat=ioerr) flxave_res
      if (ioerr /= 0 ) then
         write (6,*) 'ioerror ',ioerr,' on i/o unit = ',nrg
         call endrun
      end if
      if ((      flxave_res .and. .not. flxave) .or. &
         (.not. flxave_res .and.       flxave)) then
         write(6,*)'(READ_RESTART_CCSM): namelist flxave value = ',flxave, &
            ' must equal restart flxave value ',flxave_res
         call endrun
      endif
   endif
! If flux averaging is enabled read in necessary info

   if (flxave) then

      if (masterproc) then
         read(nrg, iostat=ioerr) dosend, countfa, arget
         if (ioerr /= 0 ) then
            write (6,*) 'ioerror ',ioerr,' on i/o unit = ',nrg
            call endrun
         end if
      endif
      call readin_r8 (nrg, precca , plon)
      call readin_r8 (nrg, precla , plon)
      call readin_r8 (nrg, precsca, plon)
      call readin_r8 (nrg, precsla, plon)
#ifdef SPMD
      call mpibcast (dosend , 1, mpilog ,0,mpicom)
      call mpibcast (countfa, 1 ,mpiint ,0,mpicom)   
      if (masterproc) then
         if ( .not. allocated(arget_buf) )then
            allocate(arget_buf(plon,nrcv,plat), STAT=ierr)
            if (ierr /= 0) then
               write(6,*)'(READ_RESTART_CCSM) arget_buf allocation error'
               call endrun
            endif
         end if
         do n=1,nrcv
            do lat=1,plat
               do i=1,plon
                  arget_buf(i,n,lat) = arget(i,lat,n)
               end do
            end do
         end do
      endif

      if ( .not. allocated(arget_spmd) )then
         allocate(arget_spmd(plon,nrcv,beglat:endlat), STAT=ierr)
         if (ierr /= 0) then
            write(6,*)'(READ_RESTART_CCSM) arget_spmd allocation error'
            call endrun
         endif
      end if
      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 n=1,nrcv
         do lat=beglat,endlat
            do i=1,plon
               arget(i,lat,n) = arget_spmd(i,n,lat)
            end do
         end do
      end do
#endif
      do lat=beglat,endlat
         do i=1,plon
            srfflx_state2d(lat)%wsx(i)    = -arget(i,lat,1)  ! Atmosphere-surface flux
            srfflx_state2d(lat)%wsy(i)    = -arget(i,lat,2)  ! Atmosphere-surface flux
            srfflx_state2d(lat)%lhf(i)    = -arget(i,lat,3)  ! Atmosphere-surface flux
            srfflx_state2d(lat)%shf(i)    = -arget(i,lat,4)  ! Atmosphere-surface flux
            srfflx_state2d(lat)%lwup(i)   = -arget(i,lat,5)  ! Atmosphere-surface flux
            srfflx_state2d(lat)%cflx(i,1) = -arget(i,lat,6)  ! Atmosphere-surface flux
            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
            srfflx_state2d(lat)%tref(i) =  arget(i,lat,15) ! Surface state variable
!
! Get land-fraction
!
            if (icefrac(i,lat) + ocnfrac(i,lat) <= .999) then
               landfrac(i,lat) = 1.
               ocnfrac(i,lat) = 0.
            else
               landfrac(i,lat) = 0.
               ocnfrac(i,lat) = 1.
            end if
         end do
      end do

   endif   ! end of if-flxave

   return
   end subroutine read_restart_ccsm

   subroutine initialize_ccsm_msg
!-----------------------------------------------------------------------
!
! Purpose:
! Initialize data so that if data used before set the program will die.
!
! Method:
!
! Author: Mariana Vertenstein
!
!-----------------------------------------------------------------------
    use infnan
    integer ierr

    allocate (rho     (plond,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) rho allocation error'
       call endrun
    endif
    allocate (netsw   (plond,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) netsw allocation error'
       call endrun
    endif
    allocate (psl     (plond,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) psl allocation error'
       call endrun
    endif
    allocate (precca  (plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) precca allocation error'
       call endrun
    endif
    allocate (precla  (plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) precla allocation error'
       call endrun
    endif
    allocate (precsca (plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) precsca allocation error'
       call endrun
    endif
    allocate (precsla (plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) precsla allocation error'
       call endrun
    endif
    allocate (rainconv(plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) rainconv allocation error'
       call endrun
    endif
    allocate (rainlrsc(plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) rainlrsc allocation error'
       call endrun
    endif
    allocate (snowconv(plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) snowconv allocation error'
       call endrun
    endif
    allocate (snowlrsc(plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) snowlrsc allocation error'
       call endrun
    endif
    allocate (prc_err (plon ,beglat:endlat), STAT=ierr)
    if (ierr /= 0) then
       write(6,*)'(INITIALIZE_CCSM_MSG) prc_err allocation error'
       call endrun
    endif
!
! Initialize to NaN or Inf
!
    rho      (:,:) = inf
    netsw    (:,:) = inf
    psl      (:,:) = inf
    precca   (:,:) = inf
    precla   (:,:) = inf
    precsca  (:,:) = inf
    precsla  (:,:) = inf
    snowconv (:,:) = inf
    snowlrsc (:,:) = inf
    rainconv (:,:) = inf
    rainlrsc (:,:) = inf
    prc_err  (:,:) = inf

   end subroutine initialize_ccsm_msg

!===============================================================================
! The following subroutines private to this module!
!===============================================================================

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

  subroutine msgsnd

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

     use time_manager, only: get_nstep, get_step_size, get_curr_date, &
                             get_prev_date

#include <comctl.h>