subroutine sub2grid(workin,cstate,sst,slndt,sicet,iflg)
!$$$ subprogram documentation block
! . . . .
! subprogram: sub2grid adjoint of grid2sub
! prgmmr: parrish org: np22 date: 1994-02-12
!
! abstract: adjoint of horizontal grid to subdomain
!
! program history log:
! 2004-02-03 kleist, new mpi strategy
! 2004-05-06 derber
! 2004-07-15 treadon - handle periodic subdomains
! 2004-07-28 treadon - add only on use declarations; add intent in/out
! 2004-10-26 kleist - remove u,v; do periodic update on st,vp
! 2004-03-30 treaon - change work1 dimension to max(iglobal,itotsub)
! 2008-04-03 safford - rm unused vars and uses
! 2010-04-01 treadon - move strip,strip_periodic,reorder to gridmod
!
! input argument list:
! t - t grid values
! p - p surface grid values
! q - q grid values
! oz - ozone grid values
! sst - sea surface temperature grid
! slndt - land surface temperature
! sicet - ice surface temperature
! cwmr - cloud water mixing ratio grid values
! st - streamfunction grid values
! vp - velocity potential grid values
! iflg = 1=not periodic, 2=periodic
!
! output argument list:
! workin - output grid values on full grid after vertical operations
!
! attributes:
! language: f90
! machine: ibm RS/6000 SP
!
!$$$
use kinds, only: r_kind,i_kind
use mpimod, only: irdsp_g,ircnt_g,iscnt_g,isdsp_g,&
ierror,mpi_comm_world,mpi_rtype
use gridmod, only: itotsub,lat1,lon1,lat2,lon2,iglobal,&
nlat,nlon,nsig,ltosi,ltosj,nsig1o,nnnn1o,vlevs,strip,strip_periodic,reorder
use jfunc, only: nsstsm,nozsm,nsltsm,ncwsm,nsitsm,nvpsm,nstsm,&
npsm,nqsm,ntsm
use constants, only: ione,izero,zero
use control_vectors
implicit none
! Declare passed variables
integer(i_kind) ,intent(in ) :: iflg
real(r_kind),dimension(lat2,lon2) ,intent(in ) :: sst,slndt,sicet
real(r_kind),dimension(nlat,nlon,nnnn1o),intent( out) :: workin
type(control_state) ,intent(in ) :: cstate
! Declare local variables
integer(i_kind) j,k,l,ni1,ni2
real(r_kind),dimension(lat1*lon1*vlevs):: xhatsm
real(r_kind),dimension(max(iglobal,itotsub),nsig1o):: work1 ! contain nsig1o slab of any variables
! Initialize variables
! do k=1,nsig1o
! do j=1,nlon
! do i=1,nlat
! workin(i,j,k)=zero
! end do
! end do
! end do
! do k=1,lat1*lon1*(nsig*6+4_i_kind)
! xhatsm(k)=zero
! end do
xhatsm=zero
workin=zero
! strip off boundary points and load vector for communication
if (iflg==ione) then
call strip(cstate%st ,xhatsm(nstsm) ,nsig)
call strip(cstate%vp ,xhatsm(nvpsm) ,nsig)
call strip(cstate%p ,xhatsm(npsm) ,ione)
call strip(cstate%t ,xhatsm(ntsm) ,nsig)
call strip(cstate%rh ,xhatsm(nqsm) ,nsig)
if (nrf3_oz>izero) call strip(cstate%oz,xhatsm(nozsm),nsig)
if (nrf2_sst>izero) then
call strip(sst ,xhatsm(nsstsm),ione)
call strip(slndt,xhatsm(nsltsm),ione)
call strip(sicet,xhatsm(nsitsm),ione)
end if
if (nrf3_cw>izero) call strip(cstate%cw ,xhatsm(ncwsm) ,nsig)
elseif (iflg==2_i_kind) then
call strip_periodic(cstate%st ,xhatsm(nstsm) ,nsig)
call strip_periodic(cstate%vp ,xhatsm(nvpsm) ,nsig)
call strip_periodic(cstate%p ,xhatsm(npsm) ,ione)
call strip_periodic(cstate%t ,xhatsm(ntsm) ,nsig)
call strip_periodic(cstate%rh ,xhatsm(nqsm) ,nsig)
if (nrf3_oz>izero) call strip_periodic(cstate%oz,xhatsm(nozsm),nsig)
if (nrf2_sst>izero) then
call strip_periodic(sst ,xhatsm(nsstsm),ione)
call strip_periodic(slndt,xhatsm(nsltsm),ione)
call strip_periodic(sicet,xhatsm(nsitsm),ione)
end if
if (nrf3_cw>izero) call strip_periodic(cstate%cw ,xhatsm(ncwsm) ,nsig)
else
write(6,*)'SUB2GRID: ***ERROR*** iflg=',iflg,' is an illegal value'
endif
! zero out work arrays
do k=1,nsig1o
do j=1,itotsub
work1(j,k)=zero
end do
end do
! send subdomain vector to global slabs
call mpi_alltoallv(xhatsm(1),iscnt_g,isdsp_g,&
mpi_rtype,work1(1,1),ircnt_g,irdsp_g,mpi_rtype,&
mpi_comm_world,ierror)
! reorder work1 array post communication
call reorder(work1,nsig1o,nnnn1o)
do k=1,nnnn1o
do l=1,iglobal
ni1=ltosi(l); ni2=ltosj(l)
workin(ni1,ni2,k)=work1(l,k)
end do
end do
return
end subroutine sub2grid
subroutine sub2grid2(workin,st,vp,pri,t,iflg)
!$$$ subprogram documentation block
! . . . .
! subprogram: sub2grid2 adjoint of grid2sub for bal
! prgmmr: parrish org: np22 date: 1994-02-12
!
! abstract: adjoint of horizontal grid to subdomain for balance variables
!
! program history log:
! 2008-04-21 derber, new mpi strategy
!
! input argument list:
! st - streamfunction grid values
! vp - velocity potential grid values
! pri - p surface grid values
! t - t grid values
! iflg = 1=not periodic, 2=periodic
!
! output argument list:
! workin - output grid values on full grid after vertical operations
!
! attributes:
! language: f90
! machine: ibm RS/6000 SP
!
!$$$
use kinds, only: r_kind,i_kind
use mpimod, only: irdbal_g,ircbal_g,iscbal_g,isdbal_g,&
ierror,mpi_comm_world,mpi_rtype,&
nnnvsbal,nlevsbal,ku_gs,kv_gs, &
kp_gs,kt_gs
use gridmod, only: itotsub,lat1,lon1,lat2,lon2,iglobal,&
nlat,nlon,nsig,ltosi,ltosj,&
strip,strip_periodic,reorder
use constants, only: ione,zero
implicit none
! Declare passed variables
integer(i_kind) ,intent(in ) :: iflg
real(r_kind),dimension(lat2,lon2,nsig+ione),intent(in ) :: pri
real(r_kind),dimension(lat2,lon2,nsig) ,intent(in ) :: t,vp,st
real(r_kind),dimension(nlat,nlon,nnnvsbal) ,intent( out) :: workin
! Declare local variables
integer(i_kind) j,k,l,ni1,ni2,ioff
real(r_kind),dimension(lat1*lon1*(nsig*4+ione)):: xhatsm
real(r_kind),dimension(max(iglobal,itotsub),nlevsbal):: work1 ! contain nsig1o slab of any variables
! strip off boundary points and load vector for communication
if (iflg==ione) then
do k=1,nsig
ioff=ku_gs(k)*lat1*lon1+ione
call strip(st (1,1,k),xhatsm(ioff),ione)
ioff=kv_gs(k)*lat1*lon1+ione
call strip(vp (1,1,k),xhatsm(ioff),ione)
ioff=kt_gs(k)*lat1*lon1+ione
call strip(t (1,1,k),xhatsm(ioff),ione)
end do
do k=1,nsig+ione
ioff=kp_gs(k)*lat1*lon1+ione
call strip(pri(1,1,k),xhatsm(ioff),ione)
end do
elseif (iflg==2_i_kind) then
do k=1,nsig
ioff=ku_gs(k)*lat1*lon1+ione
call strip_periodic(st (1,1,k),xhatsm(ioff),ione)
ioff=kv_gs(k)*lat1*lon1+ione
call strip_periodic(vp (1,1,k),xhatsm(ioff),ione)
ioff=kt_gs(k)*lat1*lon1+ione
call strip_periodic(t (1,1,k),xhatsm(ioff),ione)
end do
do k=1,nsig+ione
ioff=kp_gs(k)*lat1*lon1+ione
call strip_periodic(pri(1,1,k),xhatsm(ioff),ione)
end do
else
write(6,*)'SUB2GRID: ***ERROR*** iflg=',iflg,' is an illegal value'
endif
! zero out work arrays
do k=1,nlevsbal
do j=1,itotsub
work1(j,k)=zero
end do
end do
! send subdomain vector to global slabs
call mpi_alltoallv(xhatsm(1),iscbal_g,isdbal_g,&
mpi_rtype,work1(1,1),ircbal_g,irdbal_g,mpi_rtype,&
mpi_comm_world,ierror)
! reorder work1 array post communication
call reorder(work1,nlevsbal,nnnvsbal)
do k=1,nnnvsbal
do l=1,iglobal
ni1=ltosi(l); ni2=ltosj(l)
workin(ni1,ni2,k)=work1(l,k)
end do
end do
return
end subroutine sub2grid2