V3FIT
r8mkspl3zb.f
1  subroutine r8mkspl3zb(fun,x,nx,th,nth,ph,nph,fspl,nf2,nf3,
2  > ibcxmin,bcxmin,ibcxmax,bcxmax,nb1,
3  > wk,inwk,ilinx,ilinth,ilinph,ier)
4 C
5 C create a tricubic biperiodic spline with knots at grid points and
6 C function values from the callable function `fun' passed.
7 C
8 C use tpsplinb to setup the spline coefficients
9 C
10 C periodic boundary condition for theta & phi grids.
11 C boundary condition data may be specified at x(1) and x(nx) for each
12 C theta & phi:
13 C ibcxmin=0 ==> "not a knot" boundary condition, cf cubspl.for
14 C ibcxmin=1 ==> match slope, bcxmin(ith,iph) gives df/dx at
15 C x(1),th(ith),ph(iph)
16 C ibcxmin=2 ==> match 2nd derivative, given at x(1),th(ith),ph(iph)
17 C by bcxmin(ith,iph)
18 C
19 C ibcxmax,bcxmax have analogous interpretation -- at x(nx).
20 C
21 !============
22 ! idecl: explicitize implicit INTEGER declarations:
23  IMPLICIT NONE
24  INTEGER, PARAMETER :: R8=selected_real_kind(12,100)
25  INTEGER nth,nph,nf2,nf3,nb1,inwk,nx,iph,ith,ix
26 !============
27 ! idecl: explicitize implicit REAL declarations:
28  real*8 fun,zdummy
29 !============
30  external fun ! passed real function(x,th)
31  REAL*8 x(nx) ! x coordinate array
32  real*8 th(nth) ! th coordinate array
33  real*8 ph(nph) ! ph coordinate array
34 C
35  real*8 fspl(8,nf2,nf3,nph) ! function data / spline coeff array
36  real*8 wk(inwk) ! workspace for bpsplinb
37 C
38  integer ibcxmin ! boundary condition indicator
39  REAL*8 bcxmin(nb1,nph) ! boundary condition data
40  integer ibcxmax ! boundary condition indicator
41  real*8 bcxmax(nb1,nph) ! boundary condition data
42 C
43  integer ilinx ! output =1 if x(...) evenly spaced
44  integer ilinth ! output =1 if th(...) evenly spaced
45  integer ilinph ! output =1 if ph(...) evenly spaced
46 C
47  integer ier ! completion code from bpspline
48 C
49 C----------------------------
50 C
51  ier=0
52  if(nf2.lt.nx) then
53  write(6,'('.lt.' ?mkspl3pb -- array dim error, nf2 nx'')')
54  ier=1
55  endif
56  if(nf3.lt.nth) then
57  write(6,'('.lt.' ?mkspl3pb -- array dim error, nf3 nth'')')
58  ier=2
59  endif
60  if(nb1.lt.nth) then
61  write(6,'('.lt.' ?mkspl3pb -- array dim error, nb1 nth'')')
62  ier=3
63  endif
64 
65  if(ier.ne.0) return
66 C
67  do iph=1,nph
68  do ith=1,nth
69  do ix=1,nx
70  fspl(1,ix,ith,iph)=fun(x(ix),th(ith),ph(iph))
71  enddo
72  enddo
73  enddo
74 C
75  call r8mktricubw(x,nx,th,nth,ph,nph,fspl,nf2,nf3,
76  > ibcxmin,bcxmin,ibcxmax,bcxmax,nb1,
77  > -1,zdummy,-1,zdummy,max(nx,nth,nph),
78  > -1,zdummy,-1,zdummy,max(nx,nth,nph),
79  > wk,inwk,ilinx,ilinth,ilinph,ier)
80 C
81  return
82  end