1 subroutine r8mkintrp2d(x,nx,y,ny,jspline,
2 > f,icoeff,ixdim,iydim,
3 > ibcxmin,bcxmin,ibcxmax,bcxmax,
4 > ibcymin,bcymin,ibcymax,bcymax,
13 INTEGER,
PARAMETER :: R8=selected_real_kind(12,100)
38 real*8 f(icoeff,ixdim,iydim)
60 integer :: ii,imul,imin,imax,ickx,icky
61 integer :: idum1,idum2
63 real*8 :: ztol = 0.0001_r8
64 real*8,
dimension(:,:),
allocatable :: wk2
73 imin=min(imin,jspline(ii))
74 imax=max(imax,jspline(ii))
75 if(jspline(ii).gt.0) imul=imul*2
78 if((imin.lt.-1).or.(imax.gt.2))
then
81 >
' ?mkintrp2d: spline type control out of range -1 to 2: ',
93 >
' ?mkintrp2d: spline/Hermite hybrid not supported (',
95 else if(imax.lt.1)
then
98 >
' ?mkintrp2d: zonal/linear hybrid not supported (',
104 if(imul.ne.icoeff)
then
106 >
' ?coeff dimension inconsistency for spline type codes ',
108 write(6,*)
' in mkintrp2d: expected: ',imul,
' got: ',icoeff
115 if(jspline(1).eq.-1)
then
121 if(jspline(2).eq.-1)
then
127 if((ickx.ne.ixdim).or.(icky.ne.iydim))
then
129 >
' ?mkintrp2d: dimensioning inconsistent with '//
130 >
'interpolation controls: ',jspline
131 write(6,*)
' expected: ',ickx,icky,
'; got: ',ixdim,iydim
136 if(jspline(1).le.0)
then
137 call r8splinck(x,nx,idum1,ztol,ier)
139 write(6,*)
' ?mkintrp2d: x axis not strict ascending.'
144 if(jspline(2).le.0)
then
145 call r8splinck(y,ny,idum1,ztol,ier)
147 write(6,*)
' ?mkintrp2d: y axis not strict ascending.'
157 if(jspline(1).eq.1)
then
158 if((min(ibcxmin,ibcxmax).lt.-1).or.
159 > (max(ibcxmin,ibcxmax).gt.1))
then
160 write(6,*)
' ?mkintrp2d: Bdy Cond code out of range for'
161 write(6,*)
' Hermite interpolation; (-1:1) allowed, '//
162 >
'found: ',ibcxmin,ibcxmax
167 if(ibcxmin.eq.-1)
then
169 else if((ibcxmin.eq.1).or.(ibcxmax.eq.1))
then
174 if(jspline(2).eq.1)
then
175 if((min(ibcymin,ibcymax).lt.-1).or.
176 > (max(ibcymin,ibcymax).gt.1))
then
177 write(6,*)
' ?mkintrp2d: Bdy Cond code out of range for'
178 write(6,*)
' Hermite interpolation; (-1:1) allowed, '//
179 >
'found: ',ibcymin,ibcymax
184 if(ibcymin.eq.-1)
then
186 else if((ibcymin.eq.1).or.(ibcymax.eq.1))
then
191 if(kspline.eq.1)
then
195 call r8util_bcherm2(f, ixdim, iydim,
196 > ibcxmin, ibcxmax, ibcymin, ibcymax,
197 > bcxmin, bcxmax, bcymin, bcymax,
200 call r8akherm2p(x,ixdim,y,iydim,
201 > f,ixdim,idum1,idum2,ipx,ipy,ier)
203 else if(kspline.eq.2)
then
206 call r8mkbicub(x,nx, y,ny, f,ixdim,
207 > ibcxmin,bcxmin,ibcxmax,bcxmax,
208 > ibcymin,bcymin,ibcymax,bcymax,
214 if(jspline(1).gt.0)
then
217 if(jspline(1).eq.1)
then
218 call r8util_bcherm1(f(1,1,ii), ixdim,
219 > ibcxmin, ibcxmax, bcxmin(ii), bcxmax(ii), x)
220 call r8akherm1p(x,ixdim,f(1,1,ii),idum1,ipx,ier)
222 else if(jspline(1).eq.2)
then
223 call r8mkspline(x,ixdim,f(1,1,ii),
224 > ibcxmin,bcxmin(ii), ibcxmax,bcxmax(ii),
235 wk2(1,1:iydim) = f(1,ii,1:iydim)
236 wk2(2,1:iydim) = 0.0_r8
237 if(jspline(2).eq.1)
then
238 call r8util_bcherm1(wk2, iydim,
239 > ibcymin, ibcymax, bcymin(ii), bcymax(ii), y)
240 call r8akherm1p(y,iydim,wk2,idum2,ipy,ier)
242 else if(jspline(2).eq.2)
then
243 call r8mkspline(y,iydim,wk2,
244 > ibcymin,bcymin(ii), ibcymax,bcymax(ii),
249 f(1:2,ii,1:iydim) = wk2(1:2,1:iydim)