! 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,bcxmin,ibcxmax,bcxmax,
     >                    ibcthmin,bcthmin,ibcthmax,bcthmax,
     >                    wk,nwk,ilinx,ilinth,ier)
c
      IMPLICIT NONE
C============
C idecl:  explicitize implicit INTEGER declarations:
      INTEGER inx,inth,inf3,nwk,iflg2,ibcthmin,ix,ibcthmax,ier,itest,
     > ibcxmin,ibcxmax,ilinx,ierx,ilinth,ierth,ia1,ia2,ia3,ia4,ia5,ith,
     > iadr,ibcxmina,ibcxmaxa,ic,ibcthmina,ibcthmaxa,iasc,iinc,iawk,jx,
     > jth,ii,idum,ia,ia1w,ia2w,ia3w,ia4w,ia5w,iaspl,iaxsp,iaxsp1
C============
C idecl:  explicitize implicit REAL declarations:
      REAL*8 xo2,xo6,zhxn,zhth,zcur,zdiff1,zdiff2
C============
      REAL*8 x(inx),th(inth),fspl(4,4,inf3,inth),wk(nwk)
      REAL*8 bcxmin(inth),bcxmax(inth)
      REAL*8 bcthmin(inx),bcthmax(inx)
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
      integer iselect1(10)
      integer iselect2(10)
c
c---------------------------------
c
c  see if 2nd pass is needed due to "non-linear" d/dth bdy cond.
c
      iflg2=0
      if(ibcthmin.ne.-1) then
         if((ibcthmin.eq.1).or.(ibcthmin.eq.2)) then
            do ix=1,inx
               if (bcthmin(ix).ne.0.0D0) iflg2=1
            enddo
         endif
         if((ibcthmax.eq.1).or.(ibcthmax.eq.2)) then
            do ix=1,inx
               if (bcthmax(ix).ne.0.0D0) iflg2=1
            enddo
         endif
      endif
c
      ier=0
      itest=5*max(inx,inth)
      if(iflg2.eq.1) then
         itest=itest +4*inx*inth
      endif
c
      if(nwk.lt.itest) then
         write(6,9901) nwk,itest
 9901    format(' ?bcspline:  workspace too small:'/
     >          '  user supplied:  nwk=',i6,'; need at least:  ',i6/
     >          '  nwk=4*nx*ny +5*max(nx,ny) will work for any user'/
     >          '  choice of bdy conditions.')
         ier=1
      endif
      if(inx.lt.4) then
         write(6,'('' ?bcspline:  at least 4 x points required.'')')
         ier=1
      endif
      if(inth.lt.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.ge.0) call ibc_ck(ibcxmax,'bcspline','xmax',0,4,ier)
      call ibc_ck(ibcthmin,'bcspline','thmin',-1,4,ier)
      if(ibcthmin.ge.0) call ibc_ck(ibcthmax,'bcspline','thmax',0,4,ier)
c
c  check ilinx & x vector
c
      call r8splinck(x,inx,ilinx,1.0D-3,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?bcspline:  x axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call r8splinck(th,inth,ilinth,1.0D-3,ierth)
      if(ierth.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?bcspline:  th axis not strict ascending'')')
      endif
c
      if(ier.ne.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.eq.-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.eq.-1) then
c
c  copy ordinates in
c
            do ix=1,inx
               wk(ia1-1+ix)=fspl(1,1,ix,ith)
            enddo
c
            call r8pspline(inx,x,wk(ia1),
     >                           wk(ia2),wk(ia3),wk(ia4),wk(ia5))
c
c  copy coeffs out
c
            do ix=1,inx-1
               fspl(2,1,ix,ith)=wk(ia2-1+ix)
               fspl(3,1,ix,ith)=wk(ia3-1+ix)
               fspl(4,1,ix,ith)=wk(ia4-1+ix)
            enddo
c
         else
c
c  copy ordinates in
            do ix=1,inx
               iadr=1+(ix-1)*4
               wk(iadr)=fspl(1,1,ix,ith)
            enddo
c
            ibcxmina=ibcxmin
            if((ibcxmin.eq.1).or.(ibcxmin.eq.2)) then
               wk(2)=bcxmin(ith)
            else if(ibcxmin.gt.2) then
               wk(2)=0.0D0
               ibcxmina=ibcxmin-2
            endif
c
            ibcxmaxa=ibcxmax
            if((ibcxmax.eq.1).or.(ibcxmax.eq.2)) then
               wk(iadr+1)=bcxmax(ith)
            else if(ibcxmax.gt.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
            do ix=1,inx-1
               fspl(2,1,ix,ith)=wk((ix-1)*4+2)
               fspl(3,1,ix,ith)=wk((ix-1)*4+3)*xo2
               fspl(4,1,ix,ith)=wk((ix-1)*4+4)*xo6
            enddo
         endif
c
      enddo
c
c-----------------------------------
c
c  spline in theta direction
c
c  workspace address offsets
c
      if(ibcthmin.eq.-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.eq.-1) then
c
c  copy ordinates in
c
               do ith=1,inth
                  wk(ia1-1+ith)=fspl(ic,1,ix,ith)
               enddo
c
               call r8pspline(inth,th,wk(ia1),
     >                           wk(ia2),wk(ia3),wk(ia4),wk(ia5))
c
c  copy coeffs out
c
               do ith=1,inth-1
                  fspl(ic,2,ix,ith)=wk(ia2-1+ith)
                  fspl(ic,3,ix,ith)=wk(ia3-1+ith)
                  fspl(ic,4,ix,ith)=wk(ia4-1+ith)
               enddo
c
            else
c
c  first pass:  use "not-a-knot" -- if flag indicates BC correction
c  will be needed
c
               if(iflg2.eq.1) then
                  ibcthmina=0
                  ibcthmaxa=0
               else
                  if(ibcthmin.gt.2) then
                     ibcthmina=ibcthmin-2
                  else
                     ibcthmina=ibcthmin
                  endif
                  if(ibcthmax.gt.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)
               enddo
               wk(2)=0.0D0
               wk(iadr+1)=0.0D0
c
               call r8cubsplb(th,wk,inth,ibcthmina,ibcthmaxa)
c
c  copy the coefficients out
c
               do ith=1,inth-1
                  fspl(ic,2,ix,ith)=wk((ith-1)*4+2)
                  fspl(ic,3,ix,ith)=wk((ith-1)*4+3)*xo2
                  fspl(ic,4,ix,ith)=wk((ith-1)*4+4)*xo6
               enddo
c
            endif
c
         enddo
c
      enddo
c
c  now make correction for user BC's if needed
c
      if(iflg2.eq.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
         do ii=1,10
            iselect1(ii)=0
            iselect2(ii)=0
         enddo
         if(ibcthmin.eq.1) iselect1(3)=1
         if(ibcthmin.eq.2) iselect1(5)=1
         if(ibcthmax.eq.1) iselect2(3)=1
         if(ibcthmax.eq.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.eq.1) then
               if(ix.lt.inx) then
                  zcur=fspl(1,2,ix,1)   ! 1st deriv.
               else
                  zcur=fspl(1,2,jx,1)+zhxn*(fspl(2,2,jx,1)+zhxn*
     >               (fspl(3,2,jx,1)+zhxn*fspl(4,2,jx,1)))
               endif
            else if(ibcthmin.eq.2) then
               if(ix.lt.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*
     >               (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.eq.1) then
               if(ix.lt.inx) then
c  1st deriv.
                  zcur=fspl(1,2,ix,jth)+zhth*(2.0D0*fspl(1,3,ix,jth)+
     >               zhth*3.0D0*fspl(1,4,ix,jth))
               else
                  call r8bcspeval(x(inx),th(inth),iselect2,  zcur,
     >               x,inx,th,inth,ilinx,ilinth,fspl,inf3,ier)
                  if(ier.ne.0) return
               endif
            else if(ibcthmax.eq.2) then
               if(ix.lt.inx) then
c  2nd deriv.
                  zcur=2.0D0*fspl(1,3,ix,jth)+
     >               6.0D0*zhth*fspl(1,4,ix,jth)
               else
                  call r8bcspeval(x(inx),th(inth),iselect2,  zcur,
     >               x,inx,th,inth,ilinx,ilinth,fspl,inf3,ier)
                  if(ier.ne.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
            do ith=1,inth
               wk(iadr+(ith-1)*4)=0.0D0
            enddo
c
            if(ibcthmin.gt.2) then
               ibcthmina=ibcthmin-2
            else
               ibcthmina=ibcthmin
            endif
c
            if(ibcthmax.gt.2) then
               ibcthmaxa=ibcthmax-2
            else
               ibcthmaxa=ibcthmax
            endif
c
            call r8cspline(th,inth,wk(iadr),
     >         ibcthmina,zdiff1,ibcthmaxa,zdiff2,wk(iawk),5*inth,idum,
     >         ier)
            if(ier.ne.0) return
         enddo
c
c  add in results to main array
c
         do ix=1,inx-1
            iadr=iasc+(ix-1)*iinc
            do ith=1,inth-1
               do ic=2,4
                  ia=iadr+(ith-1)*4 -1
                  fspl(1,ic,ix,ith)=fspl(1,ic,ix,ith)+wk(ia+ic)
               enddo
            enddo
         enddo
c
c  compute the x splines of the th spline correction coeffs
c
         if(ibcxmin.eq.-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.eq.-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)
                  enddo
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),wk(ia4w),wk(ia5w))
c
                  do ix=1,inx-1
                     fspl(2,ic,ix,ith)=fspl(2,ic,ix,ith)+wk(ia2w+ix-1)
                     fspl(3,ic,ix,ith)=fspl(3,ic,ix,ith)+wk(ia3w+ix-1)
                     fspl(4,ic,ix,ith)=fspl(4,ic,ix,ith)+wk(ia4w+ix-1)
                  enddo
               enddo
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)
                  enddo
                  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)
                     fspl(3,ic,ix,ith)=fspl(3,ic,ix,ith)+
     >                  wk(iaxsp1+3)*xo2
                     fspl(4,ic,ix,ith)=fspl(4,ic,ix,ith)+
     >                  wk(iaxsp1+4)*xo6
                  enddo
               enddo
c
            endif                       ! periodic / non-periodic
c
         enddo                          ! ith
c
      endif                             ! BC correction needs test
c
      return
      end
