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