!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE UPDEXBC ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE updexbc(mptr,iexbcbuf) 1,12
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Interpolate the external boundary data from base grid to grid mptr
!
!-----------------------------------------------------------------------
!
! AUTHOR: Yuhe Liu
! 04/15/1997
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! INPUT :
!
! mptr Grid ID number
!
! iexbcbuf Pointer that points to the location of external
! boundary data for base grid.
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
!
INCLUDE 'nodal.inc'
INCLUDE 'agrigrid.inc'
INCLUDE 'agrialloc.inc'
INCLUDE 'grddsc.inc'
INCLUDE 'agricst.inc'
INCLUDE 'globcst.inc'
INCLUDE 'exbc.inc'
!
!-----------------------------------------------------------------------
!
! Misc. local variables:
!
!-----------------------------------------------------------------------
!
INTEGER :: lisvar(22)
INTEGER :: mptr, iexbcbuf
INTEGER :: nxs,nys,nzs, nxys, nxyzs
INTEGER :: nx,ny,nz, nxy,nxyz
INTEGER :: i,j,k,ijk
INTEGER :: iu0exbc,iv0exbc,iw0exbc,ipt0exbc
INTEGER :: iudtexbc,ivdtexbc,iwdtexbc,iptdtexbc
INTEGER :: iuexbc,ivexbc,iwexbc,iptexbc
INTEGER :: iptr1,iptr2,iptr3,iptr4,iptr5,iptr6
INTEGER :: item3d,nwhts
REAL :: delta_t
!
!-----------------------------------------------------------------------
!
! Functions
!
!-----------------------------------------------------------------------
!
INTEGER :: igetsp,igtexbc
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
IF( intrpodr == 2 ) THEN
nwhts=9
ELSE
nwhts=4
END IF
nxs=node(5,1)
nys=node(6,1)
nzs=node(14,1)
nx=node(5,mptr)
ny=node(6,mptr)
nz=node(14,mptr)
nxy =nx*ny
nxyz=nxy*nz
nxys =nxs*nys
nxyzs=nxys*nzs
iptr1=igetsp(2*nxy)
iptr2=igetsp(2*nxy)
iptr3=igetsp(2*nxy)
iptr4=igetsp(nxy)
iptr5=igetsp(nwhts*nxy)
iptr6=igetsp(2*nxy)
item3d = igetsp( nxyzs )
delta_t = curtim - ( abstfcst0 - abstinit )
!
!-----------------------------------------------------------------------
!
! Interpolate uexbc
!
!-----------------------------------------------------------------------
!
iu0exbc = igtexbc(1,1,1)
iudtexbc = igtexbc(1,12,1)
DO k=1,nzs-1
DO j=1,nys-1
DO i=1,nxs
ijk = (k-1)*nxs*nys + (j-1)*nxs + i
a(item3d+ijk-1) = a(iu0exbc+ijk-1) + a(iudtexbc+ijk-1)*delta_t
END DO
END DO
END DO
iuexbc = iexbcbuf
lisvar(1) = 1
CALL itpnexbc
(mptr,lisvar,1,item3d,iuexbc, &
a(iptr1),a(iptr2),a(iptr3), &
a(iptr4),a(iptr5),a(iptr6),nxy,nwhts)
!
!-----------------------------------------------------------------------
!
! Interpolate vexbc
!
!-----------------------------------------------------------------------
!
iv0exbc = igtexbc(1,2,1)
ivdtexbc = igtexbc(1,13,1)
DO k=1,nzs-1
DO j=1,nys
DO i=1,nxs-1
ijk = (k-1)*nxs*nys + (j-1)*nxs + i
a(item3d+ijk-1) = a(iv0exbc+ijk-1) + a(ivdtexbc+ijk-1)*delta_t
END DO
END DO
END DO
ivexbc = iexbcbuf + 1*nxyz
lisvar(1) = 2
CALL itpnexbc
(mptr,lisvar,1,item3d,ivexbc, &
a(iptr1),a(iptr2),a(iptr3), &
a(iptr4),a(iptr5),a(iptr6),nxy,nwhts)
!
!-----------------------------------------------------------------------
!
! Interpolate wexbc
!
!-----------------------------------------------------------------------
!
iw0exbc = igtexbc(1,3,1)
iwdtexbc = igtexbc(1,14,1)
DO k=1,nzs
DO j=1,nys-1
DO i=1,nxs-1
ijk = (k-1)*nxs*nys + (j-1)*nxs + i
a(item3d+ijk-1) = a(iw0exbc+ijk-1) + a(iwdtexbc+ijk-1)*delta_t
END DO
END DO
END DO
iwexbc = iexbcbuf + 2*nxyz
lisvar(1) = 3
CALL itpnexbc
(mptr,lisvar,1,item3d,iwexbc, &
a(iptr1),a(iptr2),a(iptr3), &
a(iptr4),a(iptr5),a(iptr6),nxy,nwhts)
!
!-----------------------------------------------------------------------
!
! Interpolate scalar ptexbc.
!
!-----------------------------------------------------------------------
!
ipt0exbc = igtexbc(1,4,1)
iptdtexbc = igtexbc(1,15,1)
DO k=1,nzs-1
DO j=1,nys-1
DO i=1,nxs-1
ijk = (k-1)*nxs*nys + (j-1)*nxs + i
a(item3d+ijk-1) = a(ipt0exbc+ijk-1)+a(iptdtexbc+ijk-1)*delta_t
END DO
END DO
END DO
iptexbc = iexbcbuf + 3*nxyz
lisvar(1) = 4
CALL itpnexbc
(mptr,lisvar,1,item3d,iptexbc, &
a(iptr1),a(iptr2),a(iptr3), &
a(iptr4),a(iptr5),a(iptr6),nxy,nwhts)
CALL retexbc
(1,1,1,iu0exbc, .true.)
CALL retexbc
(1,2,1,iv0exbc, .true.)
CALL retexbc
(1,3,1,iw0exbc, .true.)
CALL retexbc
(1,4,1,ipt0exbc, .true.)
CALL retexbc
(1,12,1,iudtexbc, .true.)
CALL retexbc
(1,13,1,ivdtexbc, .true.)
CALL retexbc
(1,14,1,iwdtexbc, .true.)
CALL retexbc
(1,15,1,iptdtexbc,.true.)
RETURN
END SUBROUTINE updexbc
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE ITPNEXBC ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE itpnexbc(mrec,lisvar,nvar,isptr,irptr, & 4,3
pts,irec,isrc,igsrc,whts,pts1,nptrec,nwhts)
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Interpolate the external boundary data from base grid to grid mrec
!
!-----------------------------------------------------------------------
!
! AUTHOR: Yuhe Liu
! 04/15/1997
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: mrec,nptrec,nwhts
INTEGER :: isptr,irptr, nvar
INTEGER :: irec(2,nptrec),isrc(2,nptrec),igsrc(nptrec)
INTEGER :: lisvar(nvar)
REAL :: pts(2,nptrec),whts(nwhts,nptrec),pts1(2,nptrec)
INTEGER :: nxr,nyr,nzr
INTEGER :: nxs,nys,nzs
INTEGER :: nx1,ny1
INTEGER :: ist,jst,iend,jend
INTEGER :: ivar
INTEGER :: nw1,nw2
INTEGER :: numpts,npts0
INTEGER :: n3rd
INTEGER :: ierfl,iptcmp
INTEGER :: i,ii,j,jj, ip
REAL :: cosr,sinr
REAL :: x,y,xc,yc,xs,ys
REAL :: xor,yor,xorp,yorp
REAL :: dxr,dyr
REAL :: xshift,yshift
!
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
!
INCLUDE 'nodal.inc'
INCLUDE 'agrigrid.inc'
INCLUDE 'agrialloc.inc'
INCLUDE 'grddsc.inc'
INCLUDE 'agricst.inc'
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
nw1=nint( SQRT(FLOAT(nwhts)) )
nw2=nw1
IF(nvar == 0) RETURN
nxr=node(5,mrec)
nyr=node(6,mrec)
nzr=node(14,mrec)
nxs=node(5,1)
nys=node(6,1)
nzs=node(14,1)
cosr=rnode(21,mrec)
sinr=rnode(22,mrec)
dxr=rnode(9 ,mrec)
dyr=rnode(10,mrec)
xor=rnode(1,mrec)
yor=rnode(2,mrec)
ivar=lisvar(1)
xshift=stgexbc(1,ivar)
yshift=stgexbc(2,ivar)
nx1=nxr-idmexbc(1,ivar)
ny1=nyr-idmexbc(2,ivar)
xc=xshift*dxr*cosr
ys=yshift*dyr*sinr
xs=xshift*dxr*sinr
yc=yshift*dyr*cosr
xorp=xor+xc-ys
yorp=yor+xs+yc
!
! To calculate the absolute coordinates of all grid points including
! boundary and interior.
!
ist=1
jst=1
iend=nx1
jend=ny1
DO j=jst,jend
jj=(j-jst)*(iend-ist+1)
DO i=ist,iend
ii=jj+i-ist+1
x=(i-1)*dxr
y=(j-1)*dyr
pts (1,ii) = xorp+x*cosr-y*sinr
pts (2,ii) = yorp+x*sinr+y*cosr
irec(1,ii) = i
irec(2,ii) = j
END DO
END DO
numpts=(iend-ist+1)*(jend-jst+1)
npts0=numpts
!
! Find the source points for receive grid points pts
!
ierfl=0
iptcmp=1
CALL getsrc
(mrec,1, 1 ,xshift,yshift,pts,numpts, &
irec,igsrc,ierfl,iptcmp)
IF( (numpts /= npts0) .AND. verbose6 ) THEN
WRITE(6,'('' WARNING: IN INTNSL,'',I4,'' POINTS ON GRID '',I4, &
& '' got no source from source grid '',i4)') &
npts0-numpts, mrec, 1
WRITE(6,'('' IT WAS FOR EXBC VARIABLE NO. '',I4)') ivar
END IF
!
! Calculate weights of interpolation for points pts.
!
DO ip=1,numpts
pts1(1,ip)=pts(1,ip)
pts1(2,ip)=pts(2,ip)
END DO
CALL calwht_exbc
(mrec,pts1,isrc,whts,numpts,nwhts,ivar)
!
! Interpolate for variables in list lisvar from source grid MSRC
! to receive grid MREC.
!
DO i=1,nvar
ivar=lisvar(i)
n3rd=nzs
CALL intrps
( irec,isrc,whts,numpts,nw1,nw2)
END DO
500 CONTINUE
RETURN
END SUBROUTINE itpnexbc
!
!##################################################################
!##################################################################
!###### ######
!###### SUBROUTINE CALWHT_EXBC ######
!###### ######
!###### Developed by ######
!###### Center for Analysis and Prediction of Storms ######
!###### University of Oklahoma ######
!###### ######
!##################################################################
!##################################################################
!
SUBROUTINE calwht_exbc(mrec,points,isrc,whts,numpts,nwhts,ivar) 1
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! this routine calculates the weights for the interpolation
! of mass points or vertical velocity (stuff that doesn't need
! any rotation from base grid to grid mrec
!
! if nw = 4 bilinear interp., = 9 bi-quadratic
!
!-----------------------------------------------------------------------
!
! AUTHOR: Yuhe Liu
! 04/15/1997
!
! MODIFICATION HISTORY:
!
!-----------------------------------------------------------------------
!
! INPUT :
!
! mrec Grid ID number
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
INTEGER :: mrec
INTEGER :: numpts,nwhts
INTEGER :: isrc(2,numpts)
REAL :: points(2,numpts),whts(nwhts,numpts)
REAL :: xshift,yshift, yp
REAL :: alpha,alpha2
REAL :: tempx1,tempx2,tempx3
REAL :: tempy1,tempy2,tempy3
INTEGER :: i,ivar
!
!-----------------------------------------------------------------------
!
! Include files:
!
!-----------------------------------------------------------------------
!
INCLUDE 'nodal.inc'
INCLUDE 'agrigrid.inc'
INCLUDE 'agrialloc.inc'
INCLUDE 'grddsc.inc'
!
!-----------------------------------------------------------------------
!
! Misc. local variables:
!
!-----------------------------------------------------------------------
!
REAL :: cosc,sinc
REAL :: dxc,dyc
REAL :: odxc,odyc
REAL :: xor,yor,xorp,yorp
REAL :: xc,xs,yc,ys,x,y
!
!-----------------------------------------------------------------------
!
! Functions
!
!-----------------------------------------------------------------------
!
REAL :: fq, fl
REAL :: xp,x1,x2,x3,x4
fq(xp,x1,x2,x3,x4)=(xp-x2)*(xp-x3)/((x1-x2)*(x1-x3))+x4
fl(xp,x1,x2)=(xp-x2)/(x1-x2)
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
! Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
cosc = rnode( 21,1)
sinc = rnode( 22,1)
dxc = rnode(9,1)
dyc = rnode(10,1)
odxc = 1./dxc
odyc = 1./dyc
xor = rnode(1,1)
yor = rnode(2,1)
xshift=stgexbc(1,ivar)
yshift=stgexbc(2,ivar)
xc=xshift*dxc*cosc
ys=yshift*dyc*sinc
xs=xshift*dxc*sinc
yc=yshift*dyc*cosc
xorp=xor+xc-ys
yorp=yor+xs+yc
DO i=1,numpts
x=points(1,i)
y=points(2,i)
points(1,i)=1+( cosc*(x-xorp)+sinc*(y-yorp))*odxc
points(2,i)=1+(-sinc*(x-xorp)+cosc*(y-yorp))*odyc
END DO
!
! next, calculate weights for the interpolation
!
IF ( nwhts == 9 ) THEN
alpha=0.
alpha2=0.
DO i=1,numpts
xp=points(1,i)-FLOAT( nint(points(1,i)) )
yp=points(2,i)-FLOAT( nint(points(2,i)) )
tempy1=fq(yp,-1.,0.,1.,alpha)
tempy2=fq(yp,0.,-1.,1.,alpha2)
tempy3=fq(yp,1.,-1.,0.,alpha)
tempx1=fq(xp,-1.,0.,1.,alpha)
tempx2=fq(xp,0.,-1.,1.,alpha2)
tempx3=fq(xp,1.,-1.,0.,alpha)
whts(1,i)=tempy1*tempx1
whts(2,i)=tempy1*tempx2
whts(3,i)=tempy1*tempx3
whts(4,i)=tempy2*tempx1
whts(5,i)=tempy2*tempx2
whts(6,i)=tempy2*tempx3
whts(7,i)=tempy3*tempx1
whts(8,i)=tempy3*tempx2
whts(9,i)=tempy3*tempx3
isrc(1,i)=nint(points(1,i))
isrc(2,i)=nint(points(2,i))
END DO
ELSE
DO i=1,numpts
xp=points(1,i)-FLOAT( INT(points(1,i)) )
yp=points(2,i)-FLOAT( INT(points(2,i)) )
tempy1=fl(yp,0.,1.)
tempy2=fl(yp,1.,0.)
tempx1=fl(xp,0.,1.)
tempx2=fl(xp,1.,0.)
whts(1,i)=tempy1*tempx1
whts(2,i)=tempy1*tempx2
whts(3,i)=tempy2*tempx1
whts(4,i)=tempy2*tempx2
isrc(1,i)=INT(points(1,i))
isrc(2,i)=INT(points(2,i))
END DO
END IF
RETURN
END SUBROUTINE calwht_exbc