dp_coupling.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

       if (full_phys) then
!$omp parallel do private(i, j, k)
          do j=beglat,endlat
             do k=1,plev
                do i=1,plon
                   qtmp(i,k,j) = q3(i,j,k,1)
                enddo
             enddo
          enddo
       endif

!-----------------------------------------------------------------------
! Transform dynamics staggered winds to physics grid (D=>A)
!-----------------------------------------------------------------------

       allocate (u3(plon, plev, beglat:endlat))
       allocate (v3(plon, plev, beglat:endlat))

       call d2a3dikj(u3s,    v3s,     u3,    v3,   plon,  plat, plev,    &
                     beglat, endlat,  ng_d,  ng_d, ng_s,  ng_s, ng_d,    &
                     1, plon, coslon, sinlon)

!-----------------------------------------------------------------------
! Copy data from dynamics data structure to physics data structure
!-----------------------------------------------------------------------

       if (local_dp_map) then

!$OMP PARALLEL DO PRIVATE (LCHNK, NCOL, I, K, M, LONS, LATS, PIC)

          do lchnk = begchunk,endchunk
             ncol = get_ncols_p(lchnk)
             call get_lon_all_p(lchnk, ncol, lons)
             call get_lat_all_p(lchnk, ncol, lats)
             phys_state(lchnk)%ncol = ncol
             phys_state(lchnk)%lchnk = lchnk

             do i=1,ncol
                phys_state(lchnk)%ps(i)   = ps(lons(i),lats(i))
                phys_state(lchnk)%phis(i) = phis(lons(i),lats(i))
                pic(i) = pk(lons(i),lats(i),pver+1)
             enddo

             do k=1,plev
                do i=1,ncol
                   phys_state(lchnk)%u    (i,k) = u3(lons(i),k,lats(i))
                   phys_state(lchnk)%v    (i,k) = v3(lons(i),k,lats(i))
                   phys_state(lchnk)%omega(i,k) = omga(lons(i),k,lats(i))
                   if (full_phys) then
                      phys_state(lchnk)%t    (i,k) = t3(lons(i),k,lats(i)) / (1. + zvir*q3(lons(i),lats(i),k,1))
                      phys_state(lchnk)%exner(i,k) = pic(i) / pkz(lons(i),lats(i),k) 
                   else
                      phys_state(lchnk)%t    (i,k) = pt(lons(i),lats(i),k) * pkz(lons(i),lats(i),k)
                   end if
                end do
             end do

             do k=1,plev+1
                do i=1,ncol
!
! edge-level pressure arrays: copy from the arrays computed by dynpkg
!
                   phys_state(lchnk)%pint  (i,k) = pe  (lons(i),k,lats(i))
                   phys_state(lchnk)%lnpint(i,k) = peln(lons(i),k,lats(i))
                end do
             end do

!
! Copy constituents
!
             do m=1,ppcnst
                do k=1,plev
                   do i=1,ncol
                      phys_state(lchnk)%q(i,k,m) = q3(lons(i),lats(i),k,m)
                   end do
                end do
             end do
 
          end do   ! begchunk:endchunk loop

       else

          tsize = 7 + ppcnst

          allocate(bpter(plon,0:plev))
          allocate(bbuffer(tsize*block_buf_nrecs))
          allocate(cbuffer(tsize*chunk_buf_nrecs))

          do j=beglat,endlat

             call block_to_chunk_send_pters(j,plon,plev+1,tsize,bpter)

             do i=1,nlon(j)

                bbuffer(bpter(i,0))   = pe(i,plev+1,j)
                bbuffer(bpter(i,0)+1) = peln(i,plev+1,j)
                bbuffer(bpter(i,0)+2) = ps(i,j)
                bbuffer(bpter(i,0)+3) = phis(i,j)

                do k=1,plev

                   bbuffer(bpter(i,k))   = pe(i,k,j)
                   bbuffer(bpter(i,k)+1) = peln(i,k,j)
                   bbuffer(bpter(i,k)+2) = u3    (i,k,j)
                   bbuffer(bpter(i,k)+3) = v3    (i,k,j)
                   bbuffer(bpter(i,k)+4) = omga(i,k,j)
                   if (full_phys) then
                      bbuffer(bpter(i,k)+5) = t3(i,k,j) / (1. + zvir*q3(i,j,k,1))
                      bbuffer(bpter(i,k)+6) = pk(i,j,pver+1) / pkz(i,j,k) 
                   else
                      bbuffer(bpter(i,k)+6) = pt(i,j,k) * pkz(i,j,k)
                   end if

                   do m=1,ppcnst
                      bbuffer(bpter(i,k)+6+m) = q3(i,j,k,m)
                   end do

                end do

             end do

          end do   ! beglat:endlat loop

          call transpose_block_to_chunk(tsize, bbuffer, cbuffer)

          do lchnk = begchunk,endchunk
             ncol = get_ncols_p(lchnk)
             phys_state(lchnk)%ncol  = ncol
             phys_state(lchnk)%lchnk = lchnk

             call block_to_chunk_recv_pters(lchnk,pcols,pver+1,tsize,cpter)

             do i=1,ncol

                phys_state(lchnk)%pint  (i,pver+1) = cbuffer(cpter(i,0))
                phys_state(lchnk)%lnpint(i,pver+1) = cbuffer(cpter(i,0)+1)
                phys_state(lchnk)%ps(i)            = cbuffer(cpter(i,0)+2)
                phys_state(lchnk)%phis(i)          = cbuffer(cpter(i,0)+3)

                do k=1,plev

                   phys_state(lchnk)%pint  (i,k) = cbuffer(cpter(i,k))
                   phys_state(lchnk)%lnpint(i,k) = cbuffer(cpter(i,k)+1)
                   phys_state(lchnk)%u     (i,k) = cbuffer(cpter(i,k)+2)
                   phys_state(lchnk)%v     (i,k) = cbuffer(cpter(i,k)+3)
                   phys_state(lchnk)%omega (i,k) = cbuffer(cpter(i,k)+4)
                   if (full_phys) then
                      phys_state(lchnk)%t    (i,k) = cbuffer(cpter(i,k)+5)
                      phys_state(lchnk)%exner(i,k) = cbuffer(cpter(i,k)+6)
                   else
                      phys_state(lchnk)%t    (i,k) = cbuffer(cpter(i,k)+6)
                   end if

                   do m=1,ppcnst
                      phys_state(lchnk)%q(i,k,m) = cbuffer(cpter(i,k)+6+m)
                   end do

                end do
             end do

          end do   ! begchunk:endchunk loop

          deallocate(bpter)
          deallocate(bbuffer)
          deallocate(cbuffer)

       endif

    endif

!
! Evaluate derived quantities
!
    do lchnk = begchunk,endchunk
       ncol = get_ncols_p(lchnk)
       do k=1,plev
          do i=1,ncol
             phys_state(lchnk)%pdel (i,k) = phys_state(lchnk)%pint(i,k+1) - phys_state(lchnk)%pint(i,k)
             phys_state(lchnk)%pmid (i,k) = 0.5*(phys_state(lchnk)%pint(i,k) + phys_state(lchnk)%pint(i,k+1))
             phys_state(lchnk)%lnpmid(i,k) = log(phys_state(lchnk)%pmid(i,k))
          end do
       end do
    end do

    if (iam .eq. 0) then
       if (twod_decomp .eq. 1) then
          do k = 1, plev+1
              pe11k(k) = pexy(1,k,1)
          enddo
       else
          do k = 1, plev+1
              pe11k(k) = pe(1,k,1)
          enddo
       endif
    else
       do k = 1, plev+1
           pe11k(k) = 0.
       enddo
    endif
#if defined (SPMD)
    call parcollective(mpicom, sumop, plev+1, pe11k)
#endif
    do k = 1, plev+1
        pe11kln(k) = log (pe11k(k))
    enddo

    deallocate (u3)
    deallocate (v3)

!EOC
  end subroutine d_p_coupling
!-----------------------------------------------------------------------

!-----------------------------------------------------------------------
!BOP
! !IROUTINE: p_d_coupling --- convert physics output to dynamics input
!
! !INTERFACE: 
  subroutine p_d_coupling(phys_state, phys_tend, full_phys,        &
                          adiabatic,                               &
                          q3, pt,   dudt,      dvdt,    pkz,     &
                          q3xy, ptxy, dudtxy,    dvdtxy,  pkzxy,   &
                          dtime, u3s, v3s,       u3sxy,   v3sxy,   &
                          zvir,       cappa,     ptop,     pk,     &
                          peln,       ps,        qtmp,             &
                          pe,         pexy,      delp,     delpxy )

! !USES:
    use dynamics_vars, only : ng_d, ng_s, yzt, q3t, xyt
#if defined ( SPMD )
    use spmd_dyn, only : inter_ijk, inter_ikj, inter_q3
    use redistributemodule, only : redistributetype, redistributestart,  &
                   redistributefinish
#endif
!-----------------------------------------------------------------------
    implicit none

! Variables ending in xy are xy-decomposition instanciations.

! !INPUT PARAMETERS:
    type(physics_state), intent(in), dimension(begchunk:endchunk) :: phys_state
    type(physics_tend),  intent(in), dimension(begchunk:endchunk) :: phys_tend
    logical,  intent(in) :: full_phys
    logical,  intent(in) :: adiabatic
    real(r8), intent(in) :: dtime
    real(r8), intent(in) :: zvir
    real(r8), intent(in) :: cappa
    real(r8), intent(in) :: ptop
! xy-decomposition instanciation immediately below
    real(r8), intent(in) :: pkzxy(beglonxy:endlonxy,beglatxy:endlatxy,plev)
    real(r8), intent(in) :: qtmp(plon,beglev:endlev,beglat:endlat)
    real(r8), intent(in) :: u3sxy(beglonxy:endlonxy,beglatxy:endlatxy+1,plev)
    real(r8), intent(in) :: v3sxy(beglonxy:endlonxy,beglatxy:endlatxy,plev)

! !INPUT/OUTPUT PARAMETERS:
    real(r8), intent(inout) :: u3s(plon,beglat-ng_d:endlat+ng_s,beglev:endlev)
    real(r8), intent(inout) :: v3s(plon,beglat-ng_s:endlat+ng_d,beglev:endlev)
    real(r8), intent(inout) :: pkz(plon,beglat:endlat,beglev:endlev)
    real(r8), intent(inout) :: pe(plon,beglev:endlev+1,beglat:endlat)
! xy-decomposition instantiation immediately below
    real(r8), intent(inout) :: pexy(beglonxy:endlonxy,plev+1,beglatxy:endlatxy) ! work variable

! !OUTPUT PARAMETERS:
    real(r8), intent(out) :: pt(plon,beglat-ng_d:endlat+ng_d,beglev:endlev)
    real(r8), intent(out) :: q3(plon,beglat-ng_d:endlat+ng_d,beglev:endlev,ppcnst) ! constituents
! xy-decomposition instantiation immediately below
    real(r8), intent(out) :: ptxy(beglonxy:endlonxy,beglatxy:endlatxy,plev)
    real(r8), intent(out) :: q3xy(beglonxy:endlonxy,beglatxy:endlatxy,plev,ppcnst)

    real(r8), intent(out) :: dudt(plon,beglev:endlev,beglat:endlat) ! U-velocity tendency
    real(r8), intent(out) :: dvdt(plon,beglev:endlev,beglat:endlat) ! V-velocity tendency
! xy-decomposition instantiation immediately below
    real(r8), intent(out) :: dudtxy(beglonxy:endlonxy,plev,beglatxy:endlatxy)
    real(r8), intent(out) :: dvdtxy(beglonxy:endlonxy,plev,beglatxy:endlatxy)

    real(r8), intent(out) :: pk(plon,beglat:endlat,beglev:endlev+1)
    real(r8), intent(out) :: peln(plon,beglev:endlev+1,beglat:endlat)
    real(r8), intent(out) :: delp(plon,beglat:endlat,beglev:endlev)
! xy-decomposition instanciation immediately below
    real(r8), intent(out) :: delpxy(beglonxy:endlonxy,beglatxy:endlatxy,plev) ! work variable

    real(r8), intent(out) :: ps(plon,beglat:endlat,beglev)

! !DESCRIPTION:
!
!   Coupler for converting physics output variables into dynamics input variables
!
! !REVISION HISTORY:
!   00.06.01   Boville    Creation
!   01.06.08   AAM        Compactified
!   01.07.13   AAM        Some support for multi-2D decompositions
!   02.03.01   Worley     Support for nontrivial physics remapping
!
!EOP
!-----------------------------------------------------------------------
!BOC
! !LOCAL VARIABLES:
    integer :: i, ib, k, m, j, lchnk  ! indices
    integer :: ncol                   ! number of columns in current chunk
    integer :: lats(pcols)            ! array of latitude indices
    integer :: lons(pcols)            ! array of longitude indices
    integer :: blksiz                 ! number of columns in 2D block
    integer :: tsize                  ! amount of data per grid point passed to physics
    integer, allocatable, dimension(:,:) :: bpter
                                     ! offsets into block buffer for unpacking data
    integer :: cpter(pcols,0:pver)   ! offsets into chunk buffer for packing data

    real(r8) :: dt5
    real(r8), allocatable, dimension(:) :: &
       bbuffer, cbuffer               ! transpose buffers
!---------------------------End Local workspace-------------------------

! -------------------------------------------------------------------------
! Copy temperature, tendencies and constituents to dynamics data structures
! For adiabatic case, compute transposes only (2-D decomposition)
! -------------------------------------------------------------------------

    if (twod_decomp .eq. 1) then

! -------------------------------------------------------------------------
! Copy onto xy decomposition, then transpose to yz decomposition
! -------------------------------------------------------------------------

       if (.not. adiabatic) then