V3FIT
r8gridbicub.f
1  subroutine r8gridbicub(
2  > x_newgrid,nx_new,y_newgrid,ny_new,f_new,if1,
3  > nx,xpkg,ny,ypkg,fspl,inf3,iwarn,ier)
4 c
5 c regrid a spline function f defined vs. x,y as in xpkg,ypkg
6 c to a new grid, given by x_newgrid, y_newgrid
7 c
8 c set warning flag if the range x_newgrid, y_newgrid
9 c exceeds the range of the original xpkg,ypkg.
10 c
11 c (xpkg,ypkg -- axis data, see genxpkg subroutine)
12 c
13 c input:
14 c
15 !============
16 ! idecl: explicitize implicit INTEGER declarations:
17  IMPLICIT NONE
18  INTEGER, PARAMETER :: R8=selected_real_kind(12,100)
19  INTEGER ny_new,nx_new,iy
20 !============
21  real*8 x_newgrid(nx_new) ! new x grid
22  real*8 y_newgrid(ny_new) ! new y grid
23 c
24 c output:
25 c
26  integer if1 ! 1st dimension of f_new
27  REAL*8 f_new(if1,ny_new) ! f evaluated on this grid
28 c
29 c input:
30 c
31  integer nx ! size of old grid
32  REAL*8 xpkg(nx,4) ! old grid "package"
33  integer ny ! size of old grid
34  real*8 ypkg(ny,4) ! old grid "package"
35 c
36  integer inf3 ! array dimension
37  REAL*8 fspl(4,inf3,ny) ! compact spline coefficients of f
38 c
39 c output:
40 c condition codes, =0 for normal exit
41 c
42  integer iwarn ! =1 if new grid points out of range
43  integer ier ! =1 if there is an argument error
44 c
45 c--------------------------------------------
46 c local
47 c
48  real*8 ytmp(nx_new)
49  integer ict(6)
50 c
51  data ict/1,0,0,0,0,0/
52 c
53 c--------------------------------------------
54 c
55  do iy=1,ny_new
56  ytmp=y_newgrid(iy)
57  call r8vecbicub(ict,nx_new,x_newgrid,ytmp,nx_new,f_new(1,iy),
58  > nx,xpkg,ny,ypkg,fspl,inf3,iwarn,ier)
59  enddo
60 c
61  return
62  end