dp_coupling.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

          if (local_dp_map) then

!$omp parallel do private(lchnk, i, k, ncol, m, lons, lats)

             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)

                do k = 1, plev
                   do i = 1, ncol
                      dvdtxy(lons(i),k,lats(i)) = phys_tend(lchnk)%dvdt(i,k)
                      dudtxy(lons(i),k,lats(i)) = phys_tend(lchnk)%dudt(i,k)
                      ptxy  (lons(i),lats(i),k) = phys_state(lchnk)%t(i,k)
                   enddo
                enddo

                do m=1,ppcnst
                   do k=1,plev
                      do i=1,ncol
                         q3xy(lons(i),lats(i),k,m) = phys_state(lchnk)%q(i,k,m)
                      end do
                   end do
                end do

             enddo

          else

             tsize = 3 + ppcnst

             blksiz = (endlatxy-beglatxy+1)*(endlonxy-beglonxy+1)
             allocate(bpter(blksiz,0:plev))
             allocate(bbuffer(tsize*block_buf_nrecs))
             allocate(cbuffer(tsize*chunk_buf_nrecs))

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

                call chunk_to_block_send_pters(lchnk,pcols,plev+1,tsize,cpter)

                do i=1,ncol

                   do k=1,plev

                      cbuffer(cpter(i,k))   = phys_tend(lchnk)%dvdt(i,k)
                      cbuffer(cpter(i,k)+1) = phys_tend(lchnk)%dudt(i,k)
                      cbuffer(cpter(i,k)+2) = phys_state(lchnk)%t(i,k)

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

                   end do
  
                end do

             end do

             call transpose_chunk_to_block(tsize, cbuffer, bbuffer)

             call chunk_to_block_recv_pters(iam+1,blksiz,plev+1,tsize,bpter)

             ib = 0
             do j=beglatxy,endlatxy
                do i=beglonxy,endlonxy
                   ib = ib + 1

                   do k=1,plev
                      dvdtxy(i,k,j) = bbuffer(bpter(ib,k))
                      dudtxy(i,k,j) = bbuffer(bpter(ib,k)+1)
                      ptxy  (i,j,k) = bbuffer(bpter(ib,k)+2)

                      do m=1,ppcnst
                         q3xy(i,j,k,m) = bbuffer(bpter(ib,k)+2+m)
                      end do

                   enddo
                enddo
             enddo

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

          endif

          if (.not. full_phys) then
!$omp parallel do private(i, j, k)
             do k=1,plev
                do j=beglatxy,endlatxy
                   do i=beglonxy,endlonxy
                      ptxy(i,j,k) = ptxy(i,j,k) / pkzxy(i,j,k)
                   enddo
                enddo
             enddo
          endif

       endif

#if defined (SPMD)
! Transpose from xy to yz decomposition
       call t_startf('transpose_bck2')

       if (.not. adiabatic) then
          call redistributestart (inter_ikj, .false., dudtxy)
          call redistributefinish(inter_ikj, .false., dudt)

          call redistributestart (inter_ikj, .false., dvdtxy)
          call redistributefinish(inter_ikj, .false., dvdt)
       endif

       call redistributestart (inter_ijk, .false., ptxy)
       call redistributefinish(inter_ijk, .false., yzt)
!
! TEMPORARY:  copy YZT to PT
!
!$omp parallel do private(i,j,k)
       do k=beglev,endlev
          do j = beglat,endlat
             do i=1,plon
                pt(i,j,k) = yzt(i,j,k)
             enddo
          enddo
       enddo

       call redistributestart (inter_q3, .false., q3xy)
       call redistributefinish(inter_q3, .false., q3t)
!
! TEMPORARY:  copy Q3 to Q3T, U3SXY to XYT
!
!$omp parallel do private(i,j,k,m)
       do m=1,ppcnst
          do k=beglev,endlev
             do j = beglat,endlat
                do i=1,plon
                   q3(i,j,k,m) = q3t(i,j,k,m)
                enddo
             enddo
          enddo
       enddo
!$omp parallel do private(i,j,k)
       do k=1,plev
          do j = beglatxy,endlatxy
             do i=beglonxy,endlonxy
                xyt(i,j,k) = u3sxy(i,j,k)
             enddo
          enddo
       enddo

       call redistributestart (inter_ijk, .false., xyt)   ! send U3SXY
       call redistributefinish(inter_ijk, .false., yzt)   ! recv U3S
!
! TEMPORARY:  copy YZT to U3S
!
!$omp parallel do private(i,j,k)
       do k=beglev,endlev
          do j = beglat,endlat
             do i=1,plon
                u3s(i,j,k) = yzt(i,j,k)
             enddo
          enddo
       enddo


       call redistributestart (inter_ijk, .false., v3sxy)
       call redistributefinish(inter_ijk, .false., yzt)  ! recv V3S
!
! TEMPORARY:  copy YZT to U3S
!
!$omp parallel do private(i,j,k)
       do k=beglev,endlev
          do j = beglat,endlat
             do i=1,plon
                v3s(i,j,k) = yzt(i,j,k)
             enddo
          enddo
       enddo


       call t_stopf('transpose_bck2')
#endif

    else

! -------------------------------------------------------------------------
! Copy onto yz decomposition
! -------------------------------------------------------------------------

       if (.not. adiabatic) then

          if (local_dp_map) then

!$omp parallel do private(lchnk, i, k, ncol, m, lons, lats)

             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)

                do k = 1, plev
                   do i = 1, ncol
                      dvdt(lons(i),k,lats(i)) = phys_tend(lchnk)%dvdt(i,k)
                      dudt(lons(i),k,lats(i)) = phys_tend(lchnk)%dudt(i,k)
                      pt  (lons(i),lats(i),k) = phys_state(lchnk)%t(i,k)
                   enddo
                enddo

                do m=1,ppcnst
                   do k=1,plev
                      do i=1,ncol
                         q3(lons(i),lats(i),k,m) = phys_state(lchnk)%q(i,k,m)
                      end do
                   end do
                end do

             enddo

          else

             tsize = 3 + ppcnst
             allocate(bpter(plon,0:plev))
             allocate(bbuffer(tsize*block_buf_nrecs))
             allocate(cbuffer(tsize*chunk_buf_nrecs))

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

                call chunk_to_block_send_pters(lchnk,pcols,plev+1,tsize,cpter)

                do i=1,ncol

                   do k=1,plev

                      cbuffer(cpter(i,k))   = phys_tend(lchnk)%dvdt(i,k)
                      cbuffer(cpter(i,k)+1) = phys_tend(lchnk)%dudt(i,k)
                      cbuffer(cpter(i,k)+2) = phys_state(lchnk)%t(i,k)

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

                   end do

                end do

             end do

             call transpose_chunk_to_block(tsize, cbuffer, bbuffer)

             do j=beglat,endlat
 
                call chunk_to_block_recv_pters(j,plon,plev+1,tsize,bpter)

                do i=1,nlon(j)

                   do k=1,plev

                      dvdt(i,k,j) = bbuffer(bpter(i,k))
                      dudt(i,k,j) = bbuffer(bpter(i,k)+1)
                      pt  (i,j,k) = bbuffer(bpter(i,k)+2)

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

                   end do

                end do

             end do

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

          endif

          if (.not. full_phys) then
!$omp parallel do private(i, j, k)
             do k=1,plev
                do j=beglat,endlat
                   do i=1,plon
                      pt(i,j,k) = pt(i,j,k) / pkz(i,j,k)
                   enddo
                enddo
             enddo
          endif

       endif

    endif

    if (.not. adiabatic) then

! -------------------------------------------------------------------------
! Update u3s and v3s from tendencies dudt and dvdt.
! -------------------------------------------------------------------------
       dt5 = .5*dtime
       call uv3s_update(dudt, u3s, dvdt, v3s, dt5,                     &
                        plon, plat, plev, beglat, endlat,              &
                        ng_d, ng_s, ng_s, ng_d, beglev, endlev)

    endif

! -------------------------------------------------------------------------
! Compute pt, q3, pe, delp, ps, peln, pkz and pk.
! For 2-D decomposition, delp is transposed to delpxy, pexy is computed
!  from delpxy (and ptop), and pexy is transposed back to pe.
! Note that pt, q3 and pe are input parameters as well.
! The quantity qtmp was originally computed in stepon, just prior to
!  d_p_coupling.
! For ideal or adiabatic physics, fewer quantities are updated.
! -------------------------------------------------------------------------
    call p_d_adjust(pe,   pt,   q3,  qtmp,   delp,   ps,      &
                    peln, pk,   pkz,  zvir,    cappa,  delpxy, &
                    pexy, ptop, full_phys  )
 
!EOC
  end subroutine p_d_coupling
!-----------------------------------------------------------------------
end module dp_coupling