subroutine intrppx(nx,ggrid_g31,ggrid_g32,stfact,& 1,1
sfct,wind10,vtype,vfrac,stype,stemp,smoi,snow,trop, &
h,q,po,poz,zz,ts,wsp10,vty,vfr,sty,stp,sm,sn,trop5,&
dx,dy,nlon,lat1,lon1,nsig,n,delt,mype,npes)
!$$$ subprogram documentation block
! . . . .
! subprogram: intrppx creates vertical profile of t,q,p,zs
! prgmmr: parrish org: w/nmc22 date: 90-10-11
!
! abstract: creates vertical profile of t,q,p,zs includes time interp.
!
! program history log:
! 90-10-11 parrish
! 95-07-17 derber
! 97-08-15 matsumura
! 98-05-08 weiyu yang mpp version
! 99-08-24 derber, j., treadon, r., yang, w., first frozen mpp version
!
! input argument list:
! nx - 2*nlath
! t1 - input temperature at time 1
! q1 - input q at time 1
! p1 - input surface pressure at time 1
! oz1 - input ozone at time 1
! t2 - input temperature at time 2
! q2 - input q at time 2
! p2 - input surface pressure at time 2
! oz2 - input ozone at time 2
! t3 - input temperature at time 3
! q3 - input q at time 3
! p3 - input surface pressure at time 3
! oz3 - input ozone at time 3
! stfact - time factor
! dx - input x-coords of interpolation points (grid units)
! dy - input y-coords of interpolation points (grid units)
! nlon - number of longitudes
! lat1 - number of latitudes on gaussian grid in each sub-domain
! lon1 - number of longitudes on gaussian grid in each sub-domain
! nsig - number of sigma levels
! n - number of interpolatees for each pe sub-domain
! delt - time factor logical : true = time interpolate
! mype - pe number
!
! output argument list:
! h - output temperatures
! q - output q
! po - output surface pressure
! zz - output surface elevation
! poz - output ozone
!
! attributes:
! language: f90
! machine: ibm RS/6000 SP
!
!$$$
!--------
use type_kinds
, only: fp_kind
implicit none
include 'ijstart.h'
logical delt
integer mype,m1,ix1,nix1,k,k1,npes,n,n1,iy1,i,nlon,nx,lat1,nsig,lon1
integer niy1,ixp,niy,iyp,ix,nix,iy
real(fp_kind) zero,w00b,w10a,w10,w00,w01,tf1,w11,w10b,w01c,w11b,w11c,one
real(fp_kind) w10c,w00c,w01a,w01b,w11a,dely1,delx1,delx,dely,w00a,tf2,tf3
real(fp_kind) oneneg
real(fp_kind),dimension(lat1+2,lon1+2):: sfct,wind10
real(fp_kind),dimension(lat1+2,lon1+2):: vtype,vfrac,stype,stemp,smoi,snow,trop
real(fp_kind),dimension(n):: stfact,dx,dy,po,zz,ts,wsp10,vty,vfr,sty,stp,sm,sn,trop5
real(fp_kind),dimension(3,lat1+2,lon1+2,npes):: ggrid_g31
real(fp_kind),dimension(3,lat1+2,lon1+2,npes,2):: ggrid_g32
real(fp_kind),dimension(nsig,n):: h,q,poz
!ibm* prefetch_for_store(m1,zero,n1)
m1=mype+1; zero=0.0; n1=nsig+1; one=1.0; oneneg=-1.0
do i=1,n
!ibm* prefetch_for_store(ix1,iy1,nix1,niy1)
ix1=dx(i); iy1=dy(i)
nix1=nint(dx(i)); niy1=nint(dy(i))
ix1=max(1,min(ix1,nx))
nix1=max(1,min(nix1,nx))
!ibm* prefetch_for_store(delx,dely)
delx=dx(i)-ix1; dely=dy(i)-iy1; delx=max(zero,min(delx,one))
!ibm* prefetch_for_store(ix,iy)
ix=ix1-istart(m1)+2; iy=iy1-jstart(m1)+2
!ibm* prefetch_for_store(nix,niy)
nix=nix1-istart(m1)+2; niy=niy1-jstart(m1)+2
if(iy<1) then
iy1=iy1+nlon
!ibm* prefetch_for_store(iy)
iy=iy1-jstart(m1)+2
end if
if(niy<1) then
niy1=niy1+nlon
!ibm* prefetch_for_store(niy)
niy=niy1-jstart(m1)+2
end if
if(iy>lon1+1) then
iy1=iy1-nlon
!ibm* prefetch_for_store(iy)
iy=iy1-jstart(m1)+2
end if
if(niy>lon1+2) then
niy1=niy1-nlon
!ibm* prefetch_for_store(niy)
niy=niy1-jstart(m1)+2
end if
!ibm* prefetch_for_store(ixp,iyp)
ixp=ix+1; iyp=iy+1
if(ix1==nx) then
!ibm* prefetch_for_store(ixp)
ixp=ix
end if
!ibm* prefetch_for_store(delx1,dely1)
delx1=1.0-delx; dely1=1.0-dely
!ibm* prefetch_for_store(w00,w10,w01,w11)
w00=delx1*dely1; w10=delx*dely1; w01=delx1*dely; w11=delx*dely
!ibm* prefetch_for_store(zz(i),ts(i),vfr(i),stp(i))
zz(i)=ggrid_g31(1,ix,iy,n1)*w00+ggrid_g31(1,ixp,iy,n1)*w10&
+ggrid_g31(1,ix,iyp,n1)*w01+ggrid_g31(1,ixp,iyp,n1)*w11 ! z0.
ts(i)=sfct(ix,iy)*w00+sfct(ixp,iy)*w10+sfct(ix,iyp)*w01+sfct(ixp,iyp)*w11
vfr(i)=vfrac(ix,iy)*w00+vfrac(ixp,iy)*w10+vfrac(ix,iyp)*w01+vfrac(ixp,iyp)*w11
stp(i)=stemp(ix,iy)*w00+stemp(ixp,iy)*w10+stemp(ix,iyp)*w01+stemp(ixp,iyp)*w11
!ibm* prefetch_for_store(sm(i),sn(i),vty(i),sty(i))
sm(i)=smoi(ix,iy)*w00+smoi(ixp,iy)*w10+smoi(ix,iyp)*w01+smoi(ixp,iyp)*w11
sn(i)=snow(ix,iy)*w00+snow(ixp,iy)*w10+snow(ix,iyp)*w01+snow(ixp,iyp)*w11
trop5(i)=trop(ix,iy)*w00+trop(ixp,iy)*w10+trop(ix,iyp)*w01+trop(ixp,iyp)*w11
vty(i)=vtype(nix,niy)
sty(i)=stype(nix,niy)
!ibm* prefetch_for_store(wsp10(i),po(i))
wsp10(i)=wind10(ix,iy)*w00+wind10(ixp,iy)*w10+wind10(ix,iyp)*w01+&
wind10(ixp,iyp)*w11
if(delt) then
!ibm* prefetch_for_store(tf1,tf2,tf3)
tf1=-min(max(oneneg,stfact(i)),zero)
tf2=min(max(zero,1.0-abs(stfact(i))),one)
tf3=min(max(zero,stfact(i)),one)
!ibm* prefetch_for_store(w00a,w10a,w00b,w10b,w00c,w10c)
w00a=w00*tf2; w10a=w10*tf2
w00b=w00*tf1; w10b=w10*tf1
w00c=w00*tf3; w10c=w10*tf3
!ibm* prefetch_for_store(w01a,w11a,w01b,w11b,w01c,w11c)
w01a=w01*tf2; w11a=w11*tf2
w01b=w01*tf1; w11b=w11*tf1
w01c=w01*tf3; w11c=w11*tf3
po(i)=ggrid_g31(3,ix,iy ,n1 )*w00a+ggrid_g31(3,ixp,iy ,n1 )*w10a+&
ggrid_g31(3,ix,iyp,n1 )*w01a+ggrid_g31(3,ixp,iyp,n1 )*w11a+&
ggrid_g32(3,ix,iy ,n1,1)*w00b+ggrid_g32(3,ixp,iy ,n1,1)*w10b+&
ggrid_g32(3,ix,iyp,n1,1)*w01b+ggrid_g32(3,ixp,iyp,n1,1)*w11b+&
ggrid_g32(3,ix,iy ,n1,2)*w00c+ggrid_g32(3,ixp,iy ,n1,2)*w10c+&
ggrid_g32(3,ix,iyp,n1,2)*w01c+ggrid_g32(3,ixp,iyp,n1,2)*w11c
!ibm* prefetch_for_store(k1)
k1=n1
do k=1,nsig
k1=k1+1
!ibm* prefetch_for_store(h(k,i),q(k,i),poz(k,i))
h(k,i) =ggrid_g31(3,ix,iy ,k1 )*w00a+ggrid_g31(3,ixp,iy ,k1 )*w10a+&
ggrid_g31(3,ix,iyp,k1 )*w01a+ggrid_g31(3,ixp,iyp,k1 )*w11a+&
ggrid_g32(3,ix,iy ,k1,1)*w00b+ggrid_g32(3,ixp,iy ,k1,1)*w10b+&
ggrid_g32(3,ix,iyp,k1,1)*w01b+ggrid_g32(3,ixp,iyp,k1,1)*w11b+&
ggrid_g32(3,ix,iy ,k1,2)*w00c+ggrid_g32(3,ixp,iy ,k1,2)*w10c+&
ggrid_g32(3,ix,iyp,k1,2)*w01c+ggrid_g32(3,ixp,iyp,k1,2)*w11c
q(k,i) =ggrid_g31(1,ix,iy ,k1 )*w00a+ggrid_g31(1,ixp,iy ,k1 )*w10a+&
ggrid_g31(1,ix,iyp,k1 )*w01a+ggrid_g31(1,ixp,iyp,k1 )*w11a+&
ggrid_g32(1,ix,iy ,k1,1)*w00b+ggrid_g32(1,ixp,iy ,k1,1)*w10b+&
ggrid_g32(1,ix,iyp,k1,1)*w01b+ggrid_g32(1,ixp,iyp,k1,1)*w11b+&
ggrid_g32(1,ix,iy ,k1,2)*w00c+ggrid_g32(1,ixp,iy ,k1,2)*w10c+&
ggrid_g32(1,ix,iyp,k1,2)*w01c+ggrid_g32(1,ixp,iyp,k1,2)*w11c
poz(k,i)=ggrid_g31(2,ix,iy ,k1 )*w00a+ggrid_g31(2,ixp,iy ,k1 )*w10a+&
ggrid_g31(2,ix,iyp,k1 )*w01a+ggrid_g31(2,ixp,iyp,k1 )*w11a+&
ggrid_g32(2,ix,iy ,k1,1)*w00b+ggrid_g32(2,ixp,iy ,k1,1)*w10b+&
ggrid_g32(2,ix,iyp,k1,1)*w01b+ggrid_g32(2,ixp,iyp,k1,1)*w11b+&
ggrid_g32(2,ix,iy ,k1,2)*w00c+ggrid_g32(2,ixp,iy ,k1,2)*w10c+&
ggrid_g32(2,ix,iyp,k1,2)*w01c+ggrid_g32(2,ixp,iyp,k1,2)*w11c
end do
else
po(i)=ggrid_g31(3,ix,iy ,n1)*w00+ggrid_g31(3,ixp,iy ,n1)*w10+&
ggrid_g31(3,ix,iyp,n1)*w01+ggrid_g31(3,ixp,iyp,n1)*w11
!ibm* prefetch_for_store(k1)
k1=n1
do k=1,nsig
k1=k1+1
!ibm* prefetch_for_store(h(k,i),q(k,i),poz(k,i))
h(k,i) =ggrid_g31(3,ix,iy ,k1)*w00+ggrid_g31(3,ixp,iy ,k1)*w10+&
ggrid_g31(3,ix,iyp,k1)*w01+ggrid_g31(3,ixp,iyp,k1)*w11
q(k,i) =ggrid_g31(1,ix,iy ,k1)*w00+ggrid_g31(1,ixp,iy ,k1)*w10+&
ggrid_g31(1,ix,iyp,k1)*w01+ggrid_g31(1,ixp,iyp,k1)*w11
poz(k,i)=ggrid_g31(2,ix,iy ,k1)*w00+ggrid_g31(2,ixp,iy ,k1)*w10+&
ggrid_g31(2,ix,iyp,k1)*w01+ggrid_g31(2,ixp,iyp,k1)*w11
end do
end if
end do
return
end