atmdrvmod.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

          if (nint(x(i,j,9))==-1.or.nint(x(i,j,10))==-1) then
             if (nint(x(i,j,8)) /= -1) then
                forc_solsxy_a(i,j)  = 0.7 * (0.5 * x(i,j,8))
                forc_sollxy_a(i,j)  = forc_solsxy_a(i,j)
                forc_solsdxy_a(i,j) = 0.3 * (0.5 * x(i,j,8))
                forc_solldxy_a(i,j) = forc_solsdxy_a(i,j)
             else
                write(6,*)'ATM error: neither FSDSdir/dif nor'
                write(6,*)'       FSDS have been read in by atm_readdata'
                atmread_err = .true.
             end if
          else
             forc_solsxy_a(i,j)  = 0.5 * x(i,j,9)
             forc_sollxy_a(i,j)  = forc_solsxy_a(i,j)
             forc_solsdxy_a(i,j) = 0.5 * x(i,j,10)
             forc_solldxy_a(i,j) = forc_solsdxy_a(i,j)
          end if

! PRCXY, PRLXY

          if (nint(x(i,j,13))==-1.or.nint(x(i,j,14))==-1) then
             if (nint(x(i,j,12)).ne.-1) then
                prcxy_a(i,j) = 0.1 * x(i,j,12)
                prlxy_a(i,j) = 0.9 * x(i,j,12)
             else
                write(6,*)'ATM error: neither PRECC/L nor PRECT'
                write(6,*)'           have been read in by atm_readdata'
                atmread_err = .true.
             end if
          else
             prcxy_a(i,j) = x(i,j,13)
             prlxy_a(i,j) = x(i,j,14)
          end if

! FLWDSXY

          if (nint(x(i,j,11)) == -1) then
             e = forc_psrfxy_a(i,j) * forc_qxy_a(i,j) / (0.622 + 0.378 * forc_qxy_a(i,j))
             ea = 0.70 + 5.95e-05 * 0.01*e * exp(1500.0/forc_txy_a(i,j))             
             flwdsxy_a(i,j) = ea * sb * forc_txy_a(i,j)**4
          else
             flwdsxy_a(i,j) = x(i,j,11) 
          end if

       end do                 !end loop of latitudes
    end do                    !end loop of longitudes
!$OMP END PARALLEL DO

    if (atmread_err) then
       write(6,*) 'atm_readdata: error reading atm data'
       call endrun
    end if

    return
  end subroutine atm_readdata

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

  subroutine interpa2si

!----------------------------------------------------------------------- 
! 
! Purpose: 
! initialize variables for atm->land model surface interp
!
! Method: 
! 
! Author: Gordon Bonan
! 
!-----------------------------------------------------------------------

    use precision
    use clm_varpar, only : lsmlon, lsmlat
    use clm_varsur, only : numlon, longxy, latixy, lsmedge, lonw, lats, area
    use areaMod  
    implicit none

! ------------------------ local variables ---------------------------
    integer i,j,k                        !indices
    real(r8), allocatable :: lon_a(:,:)  !atm grid longitude cell edges
    real(r8), allocatable :: lat_a(:)    !atm grid latitude cell edges
    real(r8), allocatable :: area_a(:,:) !atm grid grid cell areas
    real(r8), allocatable :: mask_a(:,:) !dummy field: atm grid mask
    real(r8), allocatable :: mask_s(:,:) !dummy field: land model grid mask
! --------------------------------------------------------------------

! Dynamically allocate memory

    allocate (lon_a(atmlon+1,atmlat))
    allocate (lat_a(atmlat+1))
    allocate (area_a(atmlon,atmlat))
    allocate (mask_a(atmlon,atmlat))
    allocate (mask_s(lsmlon,lsmlat))

    if ( masterproc )then
       write (6,*) 'Attempting to initialize atm->land model grid interpolation .....'
       write (6,*) 'Initializing atm -> srf interpolation .....'
    end if

! --------------------------------------------------------------------
! Map from atmosphere grid to surface grid
! --------------------------------------------------------------------

! determine numlon for atmosphere grid 

    numlon_a(:) = 0
    do j = 1, atmlat
       do i = 1, atmlon
          if (longxy_a(i,j) /= 1.e36) numlon_a(j) = numlon_a(j) + 1
       end do
    end do

! [mask_a] = 1 means all grid cells on atm grid, regardless of whether
! land or ocean, will contribute to surface grid.

    do j = 1, atmlat
       do i = 1, numlon_a(j)
          mask_a(i,j) = 1.
       end do
    end do

! [mask_s] = 1 means all the surface grid is land. Used as dummy
! variable so code will not abort with false, non-valid error check

    do j = 1, lsmlat
       do i = 1, numlon(j)
          mask_s(i,j) = 1.
       end do
    end do

! For each surface grid cell: get lat [jovr_a2s] and lon [iovr_a2s] indices 
! and weights [wovr_a2s] of overlapping atm grid cells 

    call celledge (atmlat    , atmlon    , numlon_a  , longxy_a  , & 
                   latixy_a  , edge_a(1) , edge_a(2) , edge_a(3) , & 
                   edge_a(4) , lat_a     , lon_a     )

    call cellarea (atmlat    , atmlon    , numlon_a  , lat_a     , &
                   lon_a     , edge_a(1) , edge_a(2) , edge_a(3) , &
                   edge_a(4) , area_a    )

    call areaini (atmlon, atmlat, numlon_a, lon_a, lat_a, area_a, mask_a, &
                  lsmlon, lsmlat, numlon  , lonw , lats , area  , mask_s, &
                  mxovr , novr_a2s, iovr_a2s, jovr_a2s, wovr_a2s )

    deallocate (lon_a)
    deallocate (lat_a)
    deallocate (area_a)
    deallocate (mask_a)
    deallocate (mask_s)

    if ( masterproc )then
       write (6,*) 'Successfully made atm -> srf interpolation'
       write (6,*) 'Successfully initialized area-averaging interpolation'
       write (6,*)
    end if

    return
  end subroutine interpa2si

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

  subroutine interpa2s (forc_t_a  , forc_t_s  , zgcm_a  , zgcm_s  , &
                        forc_u_a  , forc_u_s  , forc_v_a  , forc_v_s  , &
                        forc_q_a  , forc_q_s  , prc_a   , prc_s   , &
                        prl_a   , prl_s   , flwds_a , flwds_s , &
                        forc_sols_a  , forc_sols_s  , forc_soll_a  , forc_soll_s  , &
                        forc_solsd_a , forc_solsd_s , forc_solld_a , forc_solld_s , &
                        forc_pbot_a  , forc_pbot_s  , forc_psrf_a  , forc_psrf_s  )

!----------------------------------------------------------------------- 
! 
! Purpose: 
! area average fields from atmosphere grid to surface grid
!
! Method: 
! 
! Author: Gordon Bonan
! 
!-----------------------------------------------------------------------

    use precision
    use clm_varpar, only : lsmlon, lsmlat
    use clm_varsur, only : numlon, longxy, latixy, lsmedge
    use areaMod  
    implicit none

! ------------------------ arguments ---------------------------------
    real(r8), intent(in)  ::  forc_t_a(atmlon,atmlat) !atm bottom level temperature (Kelvin)
    real(r8), intent(in)  ::  zgcm_a(atmlon,atmlat)   !atm bottom level height above surface (m)
    real(r8), intent(in)  ::  forc_u_a(atmlon,atmlat) !atm bottom level zonal wind (m/s)
    real(r8), intent(in)  ::  forc_v_a(atmlon,atmlat) !atm bottom level meridional wind (m/s)
    real(r8), intent(in)  ::  forc_q_a(atmlon,atmlat) !atm bottom level specific humidity (kg/kg)
    real(r8), intent(in)  ::   prc_a(atmlon,atmlat)   !convective precipitation rate (mm H2O/s)
    real(r8), intent(in)  ::   prl_a(atmlon,atmlat)   !large-scale precipitation rate (mm H2O/s)
    real(r8), intent(in)  :: flwds_a(atmlon,atmlat)   !downward longwave rad onto surface (W/m**2)
    real(r8), intent(in)  ::  forc_sols_a(atmlon,atmlat) !vis direct beam solar rad onto srf (W/m**2)
    real(r8), intent(in)  ::  forc_soll_a(atmlon,atmlat) !nir direct beam solar rad onto srf (W/m**2)
    real(r8), intent(in)  :: forc_solsd_a(atmlon,atmlat) !vis diffuse solar rad onto srf (W/m**2)
    real(r8), intent(in)  :: forc_solld_a(atmlon,atmlat) !nir diffuse solar rad onto srf(W/m**2)
    real(r8), intent(in)  ::  forc_pbot_a(atmlon,atmlat) !atm bottom level pressure (Pa)
    real(r8), intent(in)  ::  forc_psrf_a(atmlon,atmlat) !atm surface pressure (Pa)

    real(r8), intent(out) ::  forc_t_s(lsmlon,lsmlat) !atm bottom level temperature (Kelvin)
    real(r8), intent(out) ::  zgcm_s(lsmlon,lsmlat)   !atm bottom level height above surface (m)
    real(r8), intent(out) ::  forc_u_s(lsmlon,lsmlat) !atm bottom level zonal wind (m/s)
    real(r8), intent(out) ::  forc_v_s(lsmlon,lsmlat) !atm bottom level meridional wind (m/s)
    real(r8), intent(out) ::  forc_q_s(lsmlon,lsmlat) !atm bottom level specific humidity (kg/kg)
    real(r8), intent(out) ::   prc_s(lsmlon,lsmlat)   !convective precipitation rate (mm H2O/s)
    real(r8), intent(out) ::   prl_s(lsmlon,lsmlat)   !large-scale precipitation rate (mm H2O/s)
    real(r8), intent(out) :: flwds_s(lsmlon,lsmlat)   !downward longwave rad onto surface (W/m**2)
    real(r8), intent(out) ::  forc_sols_s(lsmlon,lsmlat) !vis direct beam solar rad onto srf (W/m**2)
    real(r8), intent(out) ::  forc_soll_s(lsmlon,lsmlat) !nir direct beam solar rad onto srf (W/m**2)
    real(r8), intent(out) :: forc_solsd_s(lsmlon,lsmlat) !vis diffuse solar rad onto srf (W/m**2)
    real(r8), intent(out) :: forc_solld_s(lsmlon,lsmlat) !nir diffuse solar rad onto srf(W/m**2)
    real(r8), intent(out) ::  forc_pbot_s(lsmlon,lsmlat) !atm bottom level pressure (Pa)
    real(r8), intent(out) ::  forc_psrf_s(lsmlon,lsmlat) !atm surface pressure (Pa)
! --------------------------------------------------------------------

! ------------------------ local variables ---------------------------
    integer  :: i,j                    !longitude,latitude loop indices
    real(r8) :: forc_u(atmlon,atmlat)  !dummy wind (u)
    real(r8) :: forc_v(atmlon,atmlat)  !dummy wind (v)
    logical  :: initinterp = .false.   !interpolation initialization flag
! --------------------------------------------------------------------

! Initialize

    if (.not. initinterp) then
       call interpa2si
       initinterp = .true.
    endif

! area-average absolute value of winds (i.e., regardless of
! direction) since land model cares about magnitude not direction.
! then need to adjust resultant stresses for direction of wind. 

!$OMP PARALLEL DO PRIVATE (j,i)
    do j = 1, atmlat
       do i = 1, numlon_a(j)
          forc_u(i,j) = abs(forc_u_a(i,j))
          forc_v(i,j) = abs(forc_v_a(i,j))
       end do
    end do
!$OMP END PARALLEL DO

    call areaave (atmlat   , atmlon   , numlon_a , forc_t_a  , &
                  lsmlat   , lsmlon   , numlon   , forc_t_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , zgcm_a  , &
                  lsmlat   , lsmlon   , numlon   , zgcm_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_u    , &
                  lsmlat   , lsmlon   , numlon   , forc_u_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_v    , &
                  lsmlat   , lsmlon   , numlon   , forc_v_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_q_a  , &
                  lsmlat   , lsmlon   , numlon   , forc_q_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_pbot_a  , &
                  lsmlat   , lsmlon   , numlon   , forc_pbot_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_psrf_a  , &
                  lsmlat   , lsmlon   , numlon   , forc_psrf_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , prc_a   , &
                  lsmlat   , lsmlon   , numlon   , prc_s   , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , prl_a   , &
                  lsmlat   , lsmlon   , numlon   , prl_s   , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , flwds_a , &
                  lsmlat   , lsmlon   , numlon   , flwds_s , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_sols_a  , &
                  lsmlat   , lsmlon   , numlon   , forc_sols_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_soll_a  , &
                  lsmlat   , lsmlon   , numlon   , forc_soll_s  , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_solsd_a , &
                  lsmlat   , lsmlon   , numlon   , forc_solsd_s , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    call areaave (atmlat   , atmlon   , numlon_a , forc_solld_a , &
                  lsmlat   , lsmlon   , numlon   , forc_solld_s , &
                  iovr_a2s , jovr_a2s , wovr_a2s , mxovr   )

    return
  end subroutine interpa2s

#endif

end module atmdrvMod