c----------------------
! 07Jun1999 fgtok -impno -s r8_precision.sub r8_names.table "r8con.csh conversion"
c  bcspline -- dmc 30 May 1996
c
c  set up coefficients for bicubic spline with following BC's:
c  FULL BC CONTROL at all bdys
c
c  algorithm note -- handling of y & z explicit BC's while maintaining
c  full C2 differentiability is delicate.  Basic method:  use a fully
c  C2 method based on the "not-a-knot" BC, and then, correct to meet
c  each user BC by calculating a C2 spline that is zero at all grid
c  points but satisfies a BC which is the difference btw the user spec
c  and the not-a-knot result; add the coeffs of this into the original.
c
c  for this more workspace is needed: nwk .ge. 4*inx*inth +5*max(inx,inth)
c
c
      subroutine r8bcspline(x, inx, th, inth, fspl, inf3, ibcxmin, 
     1   bcxmin, ibcxmax, bcxmax, ibcthmin, bcthmin, ibcthmax, bcthmax, 
     2   wk, nwk, ilinx, ilinth, ier)
C...Translated by Pacific-Sierra Research VAST-90 2.06G2  10:50:51  10/ 1/01  
C...Switches: -p4 -yb
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer inx, inth, inf3, ibcxmin, ibcxmax, ibcthmin, ibcthmax, nwk
     1   , ilinx, ilinth, ier
      real*8, dimension(inx) :: x
      real*8, dimension(inth) :: th
      real*8, dimension(4,4,inf3,inth) :: fspl
      real*8, dimension(inth) :: bcxmin, bcxmax
      real*8, dimension(inx) :: bcthmin, bcthmax
      real*8, dimension(nwk) :: wk
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: iflg2, ix, itest, ierx, ierth, ia1, ia2, ia3, ia4, ia5
     1   , ith, iadr, ibcxmina, ibcxmaxa, ic, ibcthmina, ibcthmaxa, iasc
     2   , iinc, iawk, jx, jth, ii, idum, ia, ia1w, ia2w, ia3w, ia4w, 
     3   ia5w, iaspl, iaxsp, iaxsp1
      integer, dimension(10) :: iselect1, iselect2
      real*8 :: xo2, xo6, zhxn, zhth, zcur, zdiff1, zdiff2
C-----------------------------------------------
C============
C idecl:  explicitize implicit INTEGER declarations:
C============
C idecl:  explicitize implicit REAL declarations:
C============
c
c  input:
c    x(1...inx) -- abscissae, first dimension of data
c   th(1...inth) -- abscissae, second (periodic) dimension of data
c   fspl(1,1,1..inx,1..inth) -- function values
c   inf3 -- fspl dimensioning, inf3.ge.inx required.
c
c  boundary conditions input:
c   ibcxmin -- indicator for boundary condition at x(1):
c    bcxmin(...) -- boundary condition data
c     =-1 -- periodic boundary condition
c     =0 -- use "not a knot", bcxmin(...) ignored
c     =1 -- match slope, specified at x(1),th(ith) by bcxmin(ith)
c     =2 -- match 2nd derivative, specified at x(1),th(ith) by bcxmin(ith)
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all th(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all th(j)
c   NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c   NOTE:  if ibcxmin=-1, ibcxmax is ignored! ...and the BC is periodic.
c
c   ibcthmin -- indicator for boundary condition at th(1):
c    bcthmin(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c   ibcthmax -- indicator for boundary condition at th(inth):
c    bcthmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c   NOTE:  if ibcthmin=-1, ibcthmax is ignored! ...and the BC is periodic.
c
c   NOTE the bcxmin,bcxmax,bcthmin,bcthmax arrays are only used if the
c     corresponding boundary condition flags are set to 1 or 2.
c     Carefully note the dimensioning of these arrays!
c
c  output:
c   fspl(*,*,1..inx,1..inth) -- bicubic spline coeffs (4x4)
c   ...fspl(1,1,*,*) is not replaced.
c
c   ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
c   ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
c
c   ier -- completion code, 0 for normal
c
c  workspace:
c   wk -- must be at least 5*max(inx,inth) large
c                          5*max(inx,inth) + 4*inx*inth large
c                          if explicit non-zero d/dth or d2/dth2 BC's
c                          are supplied.
c  nwk -- size of workspace of workspace provided
c
c---------------------------------
c  compute bicubic spline of 2d function, given values at the grid
c  grid crossing points, f(1,1,i,j)=f(x(i),th(j)).
c
c  on evaluation:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                       and th btw th(j) and th(j+1), dt=th-th(j),
c
c      spline =
c        f(1,1,i,j) + dx*f(2,1,i,j) + dx**2*f(3,1,i,j) + dx**3*f(4,1,i,j)
c   +dt*(f(1,2,i,j) + dx*f(2,2,i,j) + dx**2*f(3,2,i,j) + dx**3*f(4,2,i,j))
c   +d2*(f(1,3,i,j) + dx*f(2,3,i,j) + dx**2*f(3,3,i,j) + dx**3*f(4,3,i,j))
c   +d3*(f(1,4,i,j) + dx*f(2,4,i,j) + dx**2*f(3,4,i,j) + dx**3*f(4,4,i,j))
c
c      where d2=dt**2 and d3=dt**3.
c
c
c---------------------------------
c
c  see if 2nd pass is needed due to "non-linear" d/dth bdy cond.
c
      iflg2 = 0
      if (ibcthmin /= (-1)) then
         if (ibcthmin==1 .or. ibcthmin==2) then
            do ix = 1, inx
               if (bcthmin(ix) /= 0.0D0) iflg2 = 1
            end do
         endif
         if (ibcthmax==1 .or. ibcthmax==2) then
            do ix = 1, inx
               if (bcthmax(ix) /= 0.0D0) iflg2 = 1
            end do
         endif
      endif
c
      ier = 0
      itest = 5*max(inx,inth)
      if (iflg2 == 1) itest = itest + 4*inx*inth
c
      if (nwk < itest) then
         write (6, 9901) nwk, itest
 9901    format(' ?bcspline:  workspace too small:'/
     1      '  user supplied:  nwk=',i6,'; need at least:  ',i6/
     2      '  nwk=4*nx*ny +5*max(nx,ny) will work for any user'/
     3      '  choice of bdy conditions.')
         ier = 1
      endif
      if (inx < 4) then
         write (6, '('' ?bcspline:  at least 4 x points required.'')')
         ier = 1
      endif
      if (inth < 4) then
         write (6, '('' ?bcspline:  need at least 4 theta points.'')')
         ier = 1
      endif
c
      call ibc_ck (ibcxmin, 'bcspline', 'xmin', -1, 4, ier)
      if (ibcxmin >= 0) call ibc_ck (ibcxmax, 'bcspline', 'xmax', 0, 4, 
     1   ier)
      call ibc_ck (ibcthmin, 'bcspline', 'thmin', -1, 4, ier)
      if (ibcthmin >= 0) call ibc_ck (ibcthmax, 'bcspline', 'thmax', 0, 
     1   4, ier)
c
c  check ilinx & x vector
c
      call r8splinck (x, inx, ilinx, 1.0D-3, ierx)
      if (ierx /= 0) ier = 2
      if (ier == 2) write (6, 
     1   '('' ?bcspline:  x axis not strict ascending'')')
c
c  check ilinth & th vector
c
      call r8splinck (th, inth, ilinth, 1.0D-3, ierth)
      if (ierth /= 0) ier = 3
      if (ier == 3) write (6, 
     1   '('' ?bcspline:  th axis not strict ascending'')')
c
      if (ier /= 0) return 
c
c------------------------------------
c
      xo2 = 0.5D0
      xo6 = 1.0D0/6.0D0
c
c  spline in x direction
c
c  workspace address offsets (for pspline)
c
      if (ibcxmin == (-1)) then
         ia1 = 1
         ia2 = ia1 + inx
         ia3 = ia2 + inx
         ia4 = ia3 + inx
         ia5 = ia4 + inx
      endif
c
      do ith = 1, inth
c
c  copy the function in
c
         if (ibcxmin == (-1)) then
c
c  copy ordinates in
c
            wk(ia1:inx-1+ia1) = fspl(1,1,:inx,ith)
c
            call r8pspline (inx, x, wk(ia1), wk(ia2), wk(ia3), wk(ia4), 
     1         wk(ia5))
c
c  copy coeffs out
c
            fspl(2,1,:inx-1,ith) = wk(ia2:inx-2+ia2)
            fspl(3,1,:inx-1,ith) = wk(ia3:inx-2+ia3)
            fspl(4,1,:inx-1,ith) = wk(ia4:inx-2+ia4)
c
         else
c
c  copy ordinates in
            do ix = 1, inx
               iadr = 1 + (ix - 1)*4
               wk(iadr) = fspl(1,1,ix,ith)
            end do
c
            ibcxmina = ibcxmin
            if (ibcxmin==1 .or. ibcxmin==2) then
               wk(2) = bcxmin(ith)
            else if (ibcxmin > 2) then
               wk(2) = 0.0D0
               ibcxmina = ibcxmin - 2
            endif
c
            ibcxmaxa = ibcxmax
            if (ibcxmax==1 .or. ibcxmax==2) then
               wk(iadr+1) = bcxmax(ith)
            else if (ibcxmax > 2) then
               wk(iadr+1) = 0.0D0
               ibcxmaxa = ibcxmax - 2
            endif
c
            call r8cubsplb (x, wk, inx, ibcxmina, ibcxmaxa)
c
c  copy the coefficients out
c
            fspl(2,1,:inx-1,ith) = wk(2:inx*4-6:4)
            fspl(3,1,:inx-1,ith) = wk(3:inx*4-5:4)*xo2
            fspl(4,1,:inx-1,ith) = wk(4:(inx-1)*4:4)*xo6
         endif
c
      end do
c
c-----------------------------------
c
c  spline in theta direction
c
c  workspace address offsets
c
      if (ibcthmin == (-1)) then
         ia1 = 1
         ia2 = ia1 + inth
         ia3 = ia2 + inth
         ia4 = ia3 + inth
         ia5 = ia4 + inth
      endif
c
      do ix = 1, inx - 1
c
c  spline each x coeff
c
         do ic = 1, 4
c
            if (ibcthmin == (-1)) then
c
c  copy ordinates in
c
               wk(ia1:inth-1+ia1) = fspl(ic,1,ix,:inth)
c
               call r8pspline (inth, th, wk(ia1), wk(ia2), wk(ia3), wk(
     1            ia4), wk(ia5))
c
c  copy coeffs out
c
               fspl(ic,2,ix,:inth-1) = wk(ia2:inth-2+ia2)
               fspl(ic,3,ix,:inth-1) = wk(ia3:inth-2+ia3)
               fspl(ic,4,ix,:inth-1) = wk(ia4:inth-2+ia4)
c
            else
c
c  first pass:  use "not-a-knot" -- if flag indicates BC correction
c  will be needed
c
               if (iflg2 == 1) then
                  ibcthmina = 0
                  ibcthmaxa = 0
               else
                  if (ibcthmin > 2) then
                     ibcthmina = ibcthmin - 2
                  else
                     ibcthmina = ibcthmin
                  endif
                  if (ibcthmax > 2) then
                     ibcthmaxa = ibcthmax - 2
                  else
                     ibcthmaxa = ibcthmax
                  endif
               endif
c
c  copy ordinates in
               do ith = 1, inth
                  iadr = 1 + (ith - 1)*4
                  wk(iadr) = fspl(ic,1,ix,ith)
               end do
               wk(2) = 0.0D0
               wk(iadr+1) = 0.0D0
c
               call r8cubsplb (th, wk, inth, ibcthmina, ibcthmaxa)
c
c  copy the coefficients out
c
               fspl(ic,2,ix,:inth-1) = wk(2:inth*4-6:4)
               fspl(ic,3,ix,:inth-1) = wk(3:inth*4-5:4)*xo2
               fspl(ic,4,ix,:inth-1) = wk(4:(inth-1)*4:4)*xo6
c
            endif
c
         end do
c
      end do
c
c  now make correction for user BC's if needed
c
      if (iflg2 == 1) then
c
         iasc = 1                       ! wk addr for correction splines
         iinc = 4*inth                  ! spacing btw correction splines
         iawk = iasc + 4*inth*inx
c
c  last grid zone widths
c
         zhxn = x(inx) - x(inx-1)
         jx = inx - 1
         zhth = th(inth) - th(inth-1)
         jth = inth - 1
c
         iselect1 = 0
         iselect2 = 0
         if (ibcthmin == 1) iselect1(3) = 1
         if (ibcthmin == 2) iselect1(5) = 1
         if (ibcthmax == 1) iselect2(3) = 1
         if (ibcthmax == 2) iselect2(5) = 1
c
c  loop over BC's
c
         do ix = 1, inx
c
c  (a) d/dth @ th(1) difference btw current BC and user request
c
            if (ibcthmin == 1) then
               if (ix < inx) then
                  zcur = fspl(1,2,ix,1)          ! 1st deriv.
               else
                  zcur = fspl(1,2,jx,1) + zhxn*(fspl(2,2,jx,1)+zhxn*(
     1               fspl(3,2,jx,1)+zhxn*fspl(4,2,jx,1)))
               endif
            else if (ibcthmin == 2) then
               if (ix < inx) then
                  zcur = 2.0D0*fspl(1,3,ix,1)    ! 2nd deriv.
               else
                  zcur = 2.0D0*(fspl(1,3,jx,1)+zhxn*(fspl(2,3,jx,1)+zhxn
     1               *(fspl(3,3,jx,1)+zhxn*fspl(4,3,jx,1))))
               endif
            else
               zcur = bcthmin(ix)
            endif
            zdiff1 = bcthmin(ix) - zcur
c
c  (b) d/dth @ th(inth) difference btw current BC and user request
c
            if (ibcthmax == 1) then
               if (ix < inx) then
c  1st deriv.
                  zcur = fspl(1,2,ix,jth) + zhth*(2.0D0*fspl(1,3,ix,jth)
     1               +zhth*3.0D0*fspl(1,4,ix,jth))
               else
                  call r8bcspeval (x(inx), th(inth), iselect2, zcur, x, 
     1               inx, th, inth, ilinx, ilinth, fspl, inf3, ier)
                  if (ier /= 0) return 
               endif
            else if (ibcthmax == 2) then
               if (ix < inx) then
c  2nd deriv.
                  zcur = 2.0D0*fspl(1,3,ix,jth) + 6.0D0*zhth*fspl(1,4,ix
     1               ,jth)
               else
                  call r8bcspeval (x(inx), th(inth), iselect2, zcur, x, 
     1               inx, th, inth, ilinx, ilinth, fspl, inf3, ier)
                  if (ier /= 0) return 
               endif
            else
               zcur = bcthmax(ix)
            endif
            zdiff2 = bcthmax(ix) - zcur
c
c  ok compute the theta spline with BC's to span the difference(s)
c  these theta "correction splines" are zero at all the grid points
c  but have at least one non-zero 1st or 2nd derivative BC
c
            iadr = iasc + (ix - 1)*iinc
            wk(iadr:(inth-1)*4+iadr:4) = 0.0D0
c
            if (ibcthmin > 2) then
               ibcthmina = ibcthmin - 2
            else
               ibcthmina = ibcthmin
            endif
c
            if (ibcthmax > 2) then
               ibcthmaxa = ibcthmax - 2
            else
               ibcthmaxa = ibcthmax
            endif
c
            call r8cspline (th, inth, wk(iadr), ibcthmina, zdiff1, 
     1         ibcthmaxa, zdiff2, wk(iawk), 5*inth, idum, ier)
            if (ier /= 0) return 
         end do
c
c  add in results to main array
c
         do ix = 1, inx - 1
            iadr = iasc + (ix - 1)*iinc
            do ith = 1, inth - 1
               ia = iadr + (ith - 1)*4 - 1
               fspl(1,2:4,ix,ith) = fspl(1,2:4,ix,ith) + wk(ia+2:4+ia)
            end do
         end do
c
c  compute the x splines of the th spline correction coeffs
c
         if (ibcxmin == (-1)) then
            ia1w = iawk
            ia2w = ia1w + inx
            ia3w = ia2w + inx
            ia4w = ia3w + inx
            ia5w = ia4w + inx
         endif
c
         do ith = 1, inth - 1
            if (ibcxmin == (-1)) then
               do ic = 2, 4
                  do ix = 1, inx
                     iaspl = iasc + iinc*(ix - 1) + 4*(ith - 1)
                     wk(ia1w+ix-1) = wk(iaspl+ic-1)
                  end do
c
c  periodic spline of correction spline higher coeffs (1st coeffs are
c  all zero by defn of the correction spline
c
                  call r8pspline (inx, x, wk(ia1w), wk(ia2w), wk(ia3w), 
     1               wk(ia4w), wk(ia5w))
c
                  fspl(2,ic,:inx-1,ith) = fspl(2,ic,:inx-1,ith) + wk(
     1               ia2w:inx-2+ia2w)
                  fspl(3,ic,:inx-1,ith) = fspl(3,ic,:inx-1,ith) + wk(
     1               ia3w:inx-2+ia3w)
                  fspl(4,ic,:inx-1,ith) = fspl(4,ic,:inx-1,ith) + wk(
     1               ia4w:inx-2+ia4w)
               end do
c
            else
c
c  non-periodic BC in x direction -- specify zero on BC of coeff splines
c  so as not to affect the main array x BC.
c
               do ic = 2, 4
                  do ix = 1, inx
                     iaspl = iasc + iinc*(ix - 1) + 4*(ith - 1)
                     iaxsp = iawk + 4*(ix - 1)
                     wk(iaxsp) = wk(iaspl+ic-1)
                  end do
                  wk(iawk+1) = 0.0D0
                  wk(iaxsp+1) = 0.0D0
c
                  call r8cubsplb (x, wk(iawk), inx, ibcxmina, ibcxmaxa)
c
                  do ix = 1, inx - 1
                     iaxsp1 = iawk + 4*(ix - 1) - 1
                     fspl(2,ic,ix,ith) = fspl(2,ic,ix,ith) + wk(iaxsp1+2
     1                  )
                     fspl(3,ic,ix,ith) = fspl(3,ic,ix,ith) + wk(iaxsp1+3
     1                  )*xo2
                     fspl(4,ic,ix,ith) = fspl(4,ic,ix,ith) + wk(iaxsp1+4
     1                  )*xo6
                  end do
               end do
c
            endif                              ! periodic / non-periodic
c
         end do                                  ! ith
c
      endif                                   ! BC correction needs test
c
      return 
      end subroutine r8bcspline
