clm_csmmod.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

          send1d(isend_taux ,k) = -clm(k)%taux
          send1d(isend_tauy ,k) = -clm(k)%tauy
          send1d(isend_lhflx,k) = -clm(k)%eflx_lh_tot
          send1d(isend_shflx,k) = -clm(k)%eflx_sh_tot                      
          send1d(isend_lwup ,k) = -clm(k)%eflx_lwrad_out                     
          send1d(isend_qflx ,k) = -clm(k)%qflx_evap_tot
          send1d(isend_swabs,k) = -clm(k)%fsa
       endif
       send1d(isend_tref2m,k) =  clm(k)%t_ref2m          !tref
    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
    
! Send data to flux coupler
! First, map fields from 1d subgrid vector to 2d [lsmlon]x[lsmlat] grid, weighting
! by subgrid fraction. Use only points with wt > 0 so SPMD code will not use 
! uninitialized stack memory values for arrays like taux. NOTE: snow is sent as 
! zero over non-land because currently the ocn and sea-ice send no snow cover 
! to coupler and so the coupler sends back zero snow over non-land to 
! the atm (atm and land grid are currently assumed to be identical)

    if (masterproc) then

       do n = 1,nsnd
          where( landmask(:,:) > 0 ) 
             send2d(:,:,n) = 0.
          elsewhere
             send2d(:,:,n) = 1.e30
          endwhere
       end do
       send2d(:,:,isend_sno) = 0.     !reset snow to 0 everywhere
       do k = 1, numpatch
          if (patchvec%wtxy(k) /= 0.) then
             i = patchvec%ixy(k)    
             j = patchvec%jxy(k)    
             do n=1,nsnd 
                send2d(i,j,n) = send2d(i,j,n) + gather1d(n,k)*patchvec%wtxy(k)
             end do
          end if
       end do
       
       call get_curr_date (yr, mon, day, ncsec) 
       ncdate = yr*10000 + mon*100 + day

       ibuffs(4)  = ncdate           !model date (yyyymmdd)
       ibuffs(5)  = ncsec            !elapsed seconds in current 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
       
! Do global integrals if flag is set

       if (debug_flag) then	
          write(6,*)
          write(6,100) 'lnd','send', isend_taux , global_sum(send2d(1,1,isend_taux ),1.e30), ' taux'
          write(6,100) 'lnd','send', isend_tauy , global_sum(send2d(1,1,isend_tauy ),1.e30), ' tauy'
          write(6,100) 'lnd','send', isend_lhflx, global_sum(send2d(1,1,isend_lhflx),1.e30), ' lhflx'
          write(6,100) 'lnd','send', isend_shflx, global_sum(send2d(1,1,isend_shflx),1.e30), ' shflx'
          write(6,100) 'lnd','send', isend_lwup , global_sum(send2d(1,1,isend_lwup ),1.e30), ' lwup'
          write(6,100) 'lnd','send', isend_qflx , global_sum(send2d(1,1,isend_qflx ),1.e30), ' qflx'
          write(6,100) 'lnd','send', isend_swabs, global_sum(send2d(1,1,isend_swabs),1.e30), ' swabs'
          write(6,*)
100       format('comm_diag ',a3,1x,a4,1x,i3,es26.19,a)
       endif

    endif  ! end of if_masterproc

! Stop timers

    call t_stopf('lnd_send')

    if (.not. timer_lnd_recvsend) then
       call t_startf('lnd_sendrecv') ; timer_lnd_sendrecv = .true.
    endif

    return
  END SUBROUTINE csm_send

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

  SUBROUTINE csm_flxave() 

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Average output fluxes for flux coupler
! 
! Method: 
! Add land surface model output fluxes to accumulators every time step.
! When icnt==ncnt, compute the average flux over the time interval.
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

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

! ------------------------ local variables -----------------------------
    integer :: i,k,lat,n          !indices
    integer :: nstep              !model time step
! ----------------------------------------------------------------------

! Allocate dynamic memory if necessary

    if (.not. allocated(taux_ave)) then
       allocate (taux_ave(numpatch)) ; taux_ave(:) = inf 
    endif
    if (.not. allocated(tauy_ave)) then
       allocate (tauy_ave(numpatch)) ; tauy_ave(:) = inf 
    endif
    if (.not. allocated(lhflx_ave)) then
       allocate (lhflx_ave(numpatch)); lhflx_ave(:) = inf 
    endif
    if (.not. allocated(shflx_ave)) then
       allocate (shflx_ave(numpatch)); shflx_ave(:) = inf 
    endif
    if (.not. allocated(lwup_ave)) then
       allocate (lwup_ave(numpatch)) ; lwup_ave(:) = inf 
    endif
    if (.not. allocated(qflx_ave)) then
       allocate (qflx_ave(numpatch)) ; qflx_ave(:) = inf 
    endif
    if (.not. allocated(swabs_ave)) then
       allocate (swabs_ave(numpatch)) ; swabs_ave(:) = inf 
    endif

! Determine output flux averaging interval

    nstep = get_nstep()
    if (dorecv) then
       icnt = 1
       if ( nstep==0 ) then
          ncnt = irad + 1
       else
          ncnt = irad
       endif
       rncnt = 1./ncnt
    endif

! Initial call of averaging interval, copy data to accumulators

    if (icnt == 1) then
       do k = begpatch,endpatch
          taux_ave(k)  = clm(k)%taux
          tauy_ave(k)  = clm(k)%tauy
          lhflx_ave(k) = clm(k)%eflx_lh_tot
          shflx_ave(k) = clm(k)%eflx_sh_tot
          lwup_ave(k)  = clm(k)%eflx_lwrad_out
          qflx_ave(k)  = clm(k)%qflx_evap_tot
          swabs_ave(k) = clm(k)%fsa
       end do
       
! Final call of averaging interval, complete averaging 

    else if (icnt == ncnt) then
       do k = begpatch,endpatch
          taux_ave (k) = rncnt * (taux_ave(k)  + clm(k)%taux)
          tauy_ave (k) = rncnt * (tauy_ave(k)  + clm(k)%tauy)
          lhflx_ave(k) = rncnt * (lhflx_ave(k) + clm(k)%eflx_lh_tot)
          shflx_ave(k) = rncnt * (shflx_ave(k) + clm(k)%eflx_sh_tot)
          lwup_ave (k) = rncnt * (lwup_ave(k)  + clm(k)%eflx_lwrad_out)
          qflx_ave (k) = rncnt * (qflx_ave(k)  + clm(k)%qflx_evap_tot)
          swabs_ave(k) = rncnt * (swabs_ave(k) + clm(k)%fsa)
       end do

! Intermediate call, add data to accumulators

    else
       do k = begpatch,endpatch
          taux_ave (k) = taux_ave(k)  + clm(k)%taux
          tauy_ave(k)  = tauy_ave(k)  + clm(k)%tauy
          lhflx_ave(k) = lhflx_ave(k) + clm(k)%eflx_lh_tot
          shflx_ave(k) = shflx_ave(k) + clm(k)%eflx_sh_tot
          lwup_ave(k)  = lwup_ave(k)  + clm(k)%eflx_lwrad_out
          qflx_ave(k)  = qflx_ave(k)  + clm(k)%qflx_evap_tot
          swabs_ave(k) = swabs_ave(k) + clm(k)%fsa
       end do
    end if
    
! Increment counter

    icnt = icnt + 1
    
    return
  END SUBROUTINE csm_flxave

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

  SUBROUTINE 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 special data flag set by the coupler. This ensures that 
! the expected data is actually being sent by the coupler.
! 
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

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

    if ( spval == data )then
       write(6,*)'ERROR:(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 compat_check_spval
  
!===============================================================================

  SUBROUTINE csm_compat(cpl_maj_vers, cpl_min_vers, expect_maj_vers, expect_min_vers)

!-----------------------------------------------------------------------
! Checks that the message recieved from the coupler is compatable
! with the type of message that I expect to recieve.  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.
! Original Author: Erik Kluzek Dec/97
!-----------------------------------------------------------------------

!----------------------- Arguments -------------------------------------
    integer, intent(in) :: cpl_maj_vers    ! major version from coupler initial ibuffr array
    integer, intent(in) :: cpl_min_vers    ! minor version from coupler initial ibuffr array
    integer, intent(in) :: expect_maj_vers ! major version of the coupler I'm expecting
    integer, intent(in) :: expect_min_vers ! minor version of the coupler I'm expecting
!-----------------------------------------------------------------------

    write(6,*)'(cpl_COMPAT): This is revision: $Revision: 1.12.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 csm_compat

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

  real(r8) function global_sum(flux, spval)

!-----------------------------------------------------------------------
! Perform global integral
!-----------------------------------------------------------------------

    use clm_varsur, only : area                 !km^2

    real(r8), intent(in) :: flux(lsmlon,lsmlat) !W/m2, Kg/m2-s or N/m2
    real(r8), intent(in) :: spval               !points to not include in global sum

    integer :: i,j                              !indices

    global_sum = 0.
    do j = 1,lsmlat
       do i = 1,lsmlon
          if (flux(i,j) /= spval) then
             global_sum = global_sum + flux(i,j)*area(i,j)*1.e6
          endif
       end do
    end do

    return
  end function global_sum

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

#endif

end module clm_csmMod