PROGRAM LA_CGBSVX_ET_EXAMPLE
!
!  -- LAPACK95 INTERFACE DRIVER ROUTINE (VERSION 3.0) --
!     UNI-C, DENMARK; UNIV. OF TENNESSEE, USA; NAG LTD., UK
!     SEPTEMBER, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_GBSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F9.3,1H,,F9.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: K, KL, KU, I, J, INFO, N, NRHS
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IPIV(:)
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:), B(:,:), X(:,:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'CGBSVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, KL, KU, NRHS
   PRINT *, 'N = ', N, ' KL = ', KL, ' KU = ', KU, ' NRHS = ', NRHS
   ALLOCATE ( A(KL+KU+1,N), AA(KL+KU+1,N), B(N,NRHS), BB(N,NRHS), X(N,NRHS), IPIV(N) )
!
      AA = HUGE(1.0_WP)
      DO I = 1, 1+KU
        READ (NIN, *) (AA(I, J), J = KU-I+2,N)
      ENDDO
      DO I = 2+KU, KL+KU+1
        READ (NIN, *) (AA(I, J), J = 1, N-I+KU+1)
      ENDDO
      B = 0.0_WP
      DO I = 1, NRHS
         DO J = 1, N
            DO K = MAX(1,J-KL), MIN(J+KU,N)
               BB(J,I) = AA(KU+1+J-K,K) + BB(J,I)
            ENDDO
         ENDDO
         BB(:,I) = BB(:,I)*I
      ENDDO
      A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, KL+KU+1
        WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,:)
      ENDDO
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_CGBSVX LAPACK SUBROUTINE Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX( A, B, X, KL, IPIV=IPIV, INFO=INFO )'
   A=AA; B=BB
   CALL LA_GBSVX( A, B, X, KL, IPIV=IPIV, INFO=INFO )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX, INFO = ', INFO
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*) 'Pivots: ', IPIV
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), KL, IPIV=IPIV, INFO=INFO )'
   A=AA; B=BB
   CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), KL, IPIV=IPIV, INFO=INFO )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX, INFO = ', INFO
   WRITE (NOUT,FMT) X(:,1)
   WRITE(NOUT,*) 'Pivots: ', IPIV
!
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX:'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX( A, B, X, KL )'
   A=AA; B=BB
   CALL LA_GBSVX( A, B, X, KL )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX(A, B(1:N,1), X(1:N,1), KL)'
   A=AA; B=BB
   CALL LA_GBSVX(A, B(1:N,1), X(1:N,1), KL)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX:'
   WRITE (NOUT,FMT) X(:,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX(A, B, X, IPIV=IPIV)'
   A=AA; B=BB
   CALL LA_GBSVX( A, B, X, IPIV=IPIV)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*) 'Pivots: ', IPIV
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), IPIV=IPIV )'
   A=AA; B=BB
   CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), IPIV=IPIV )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX:'
   WRITE (NOUT,FMT) X(1:N,1)
   WRITE(NOUT,*) 'Pivots: ', IPIV
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX(A(4:4,:), B, X, INFO =INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_GBSVX( A(4:4,:), B, X, INFO=INFO)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX, INFO = ', INFO
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX( A(4:4,:), B(1:N,1), X(1:N,1), INFO=INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_GBSVX( A(4:4,:), B(1:N,1), X(1:N,1), INFO=INFO )
   WRITE(NOUT,*)'   B - the RHS vector.'
   WRITE (NOUT,FMT) B(1:N,1)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GBSVX, INFO = ', INFO
   WRITE (NOUT,FMT) X(1:N,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX(A(4:4,:), B, X, 1, INFO =INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_GBSVX( A(4:4,:), B, X, 1, INFO=INFO)
   WRITE(NOUT,*)' INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX(A(4:4,:), B, X, 6, INFO =INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_GBSVX( A(4:4,:), B, X, 1, INFO=INFO)
   WRITE(NOUT,*)' INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), 1, INFO=INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), 6, INFO=INFO )
   WRITE(NOUT,*)'    INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), 6 )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_GBSVX( A, B(1:N,1), X(1:N,1), 6 )
   WRITE(NOUT,*)'   INFO = ', INFO
!
END PROGRAM LA_CGBSVX_ET_EXAMPLE


! $UWHPSC/codes/fortran/sub1.f90

program sub1
    implicit none
    real(kind=8) :: y,z

    y = 2.
    call fsub(y,z)
    print *, "z = ",z
end program sub1

subroutine fsub(x,f)
    implicit none
    real(kind=8), intent(in) :: x
    real(kind=8), intent(out) :: f
    f = x**2
end subroutine fsub


      subroutine bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk,
     * iwrk,kwrk,ier)
c  subroutine bispev evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,...
c  ,my a bivariate spline s(x,y) of degrees kx and ky, given in the
c  b-spline representation.
c
c  calling sequence:
c     call bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk,
c    * iwrk,kwrk,ier)
c
c  input parameters:
c   tx    : real array, length nx, which contains the position of the
c           knots in the x-direction.
c   nx    : integer, giving the total number of knots in the x-direction
c   ty    : real array, length ny, which contains the position of the
c           knots in the y-direction.
c   ny    : integer, giving the total number of knots in the y-direction
c   c     : real array, length (nx-kx-1)*(ny-ky-1), which contains the
c           b-spline coefficients.
c   kx,ky : integer values, giving the degrees of the spline.
c   x     : real array of dimension (mx).
c           before entry x(i) must be set to the x co-ordinate of the
c           i-th grid point along the x-axis.
c           tx(kx+1)<=x(i-1)<=x(i)<=tx(nx-kx), i=2,...,mx.
c   mx    : on entry mx must specify the number of grid points along
c           the x-axis. mx >=1.
c   y     : real array of dimension (my).
c           before entry y(j) must be set to the y co-ordinate of the
c           j-th grid point along the y-axis.
c           ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my.
c   my    : on entry my must specify the number of grid points along
c           the y-axis. my >=1.
c   wrk   : real array of dimension lwrk. used as workspace.
c   lwrk  : integer, specifying the dimension of wrk.
c           lwrk >= mx*(kx+1)+my*(ky+1)
c   iwrk  : integer array of dimension kwrk. used as workspace.
c   kwrk  : integer, specifying the dimension of iwrk. kwrk >= mx+my.
c
c  output parameters:
c   z     : real array of dimension (mx*my).
c           on succesful exit z(my*(i-1)+j) contains the value of s(x,y)
c           at the point (x(i),y(j)),i=1,...,mx;j=1,...,my.
c   ier   : integer error flag
c    ier=0 : normal return
c    ier=10: invalid input data (see restrictions)
c
c  restrictions:
c   mx >=1, my >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my
c   tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx
c   ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my
c
c  other subroutines required:
c    fpbisp,fpbspl
c
c  references :
c    de boor c : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c    cox m.g.  : the numerical evaluation of b-splines, j. inst. maths
c                applics 10 (1972) 134-149.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      integer nx,ny,kx,ky,mx,my,lwrk,kwrk,ier
c  ..array arguments..
      integer iwrk(kwrk)
      real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my),
     * wrk(lwrk)
c  ..local scalars..
      integer i,iw,lwest
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      lwest = (kx+1)*mx+(ky+1)*my
      if(lwrk.lt.lwest) go to 100
      if(kwrk.lt.(mx+my)) go to 100
      if(mx-1) 100,30,10
  10  do 20 i=2,mx
        if(x(i).lt.x(i-1)) go to 100
  20  continue
  30  if(my-1) 100,60,40
  40  do 50 i=2,my
        if(y(i).lt.y(i-1)) go to 100
  50  continue
  60  ier = 0
      iw = mx*(kx+1)+1
      call fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk(1),wrk(iw),
     * iwrk(1),iwrk(mx+1))
 100  return
      end
      subroutine fpback(a,z,n,k,c,nest)
c  subroutine fpback calculates the solution of the system of
c  equations a*c = z with a a n x n upper triangular matrix
c  of bandwidth k.
c  ..
c  ..scalar arguments..
      integer n,k,nest
c  ..array arguments..
      real a(nest,k),z(n),c(n)
c  ..local scalars..
      real store
      integer i,i1,j,k1,l,m
c  ..
      k1 = k-1
      c(n) = z(n)/a(n,1)
      i = n-1
      if(i.eq.0) go to 30
      do 20 j=2,n
        store = z(i)
        i1 = k1
        if(j.le.k1) i1 = j-1
        m = i
        do 10 l=1,i1
          m = m+1
          store = store-c(m)*a(i,l+1)
  10    continue
        c(i) = store/a(i,1)
        i = i-1
  20  continue
  30  return
      end
      subroutine fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wx,wy,lx,ly)
c  ..scalar arguments..
      integer nx,ny,kx,ky,mx,my
c  ..array arguments..
      integer lx(mx),ly(my)
      real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my),
     * wx(mx,kx+1),wy(my,ky+1)
c  ..local scalars..
      integer i, j, i1, j1
      integer kx1,ky1,l,l1,l2,m,nkx1,nky1
      real arg,sp,tb,te
c  ..local arrays..
      real h(6)
c  ..subroutine references..
c    fpbspl
c  ..
      kx1 = kx+1
      nkx1 = nx-kx1
      tb = tx(kx1)
      te = tx(nkx1+1)
      l = kx1
      l1 = l+1
      do 40 i=1,mx
        arg = x(i)
        if(arg.lt.tb) arg = tb
        if(arg.gt.te) arg = te
  10    if(arg.lt.tx(l1) .or. l.eq.nkx1) go to 20
        l = l1
        l1 = l+1
        go to 10
  20    call fpbspl(tx,nx,kx,arg,l,h)
        lx(i) = l-kx1
        do 30 j=1,kx1
          wx(i,j) = h(j)
  30    continue
  40  continue
      ky1 = ky+1
      nky1 = ny-ky1
      tb = ty(ky1)
      te = ty(nky1+1)
      l = ky1
      l1 = l+1
      do 80 i=1,my
        arg = y(i)
        if(arg.lt.tb) arg = tb
        if(arg.gt.te) arg = te
  50    if(arg.lt.ty(l1) .or. l.eq.nky1) go to 60
        l = l1
        l1 = l+1
        go to 50
  60    call fpbspl(ty,ny,ky,arg,l,h)
        ly(i) = l-ky1
        do 70 j=1,ky1
          wy(i,j) = h(j)
  70    continue
  80  continue
      m = 0
      do 130 i=1,mx
        l = lx(i)*nky1
        do 90 i1=1,kx1
          h(i1) = wx(i,i1)
  90    continue
        do 120 j=1,my
          l1 = l+ly(j)
          sp = 0.
          do 110 i1=1,kx1
            l2 = l1
            do 100 j1=1,ky1
              l2 = l2+1
              sp = sp+c(l2)*h(i1)*wy(j,j1)
 100        continue
            l1 = l1+nky1
 110      continue
          m = m+1
          z(m) = sp
 120    continue
 130  continue
      return
      end

      subroutine fpbspl(t,n,k,x,l,h)
c  subroutine fpbspl evaluates the (k+1) non-zero b-splines of
c  degree k at t(l) <= x < t(l+1) using the stable recurrence
c  relation of de boor and cox.
c  ..
c  ..scalar arguments..
      real x
      integer n,k,l
c  ..array arguments..
      real t(n),h(6)
c  ..local scalars..
      real f,one
      integer i,j,li,lj
c  ..local arrays..
      real hh(5)
c  ..
      one = 0.1e+01
      h(1) = one
      do 20 j=1,k
        do 10 i=1,j
          hh(i) = h(i)
  10    continue
        h(1) = 0.
        do 20 i=1,j
          li = l+i
          lj = li-j
          f = hh(i)/(t(li)-t(lj))
          h(i) = h(i)+f*(t(li)-x)
          h(i+1) = f*(x-t(lj))
  20  continue
      return
      end
      subroutine fpchec(x,m,t,n,k,ier)
c  subroutine fpchec verifies the number and the position of the knots
c  t(j),j=1,2,...,n of a spline of degree k, in relation to the number
c  and the position of the data points x(i),i=1,2,...,m. if all of the
c  following conditions are fulfilled, the error parameter ier is set
c  to zero. if one of the conditions is violated ier is set to ten.
c      1) k+1 <= n-k-1 <= m
c      2) t(1) <= t(2) <= ... <= t(k+1)
c         t(n-k) <= t(n-k+1) <= ... <= t(n)
c      3) t(k+1) < t(k+2) < ... < t(n-k)
c      4) t(k+1) <= x(i) <= t(n-k)
c      5) the conditions specified by schoenberg and whitney must hold
c         for at least one subset of data points, i.e. there must be a
c         subset of data points y(j) such that
c             t(j) < y(j) < t(j+k+1), j=1,2,...,n-k-1
c  ..
c  ..scalar arguments..
      integer m,n,k,ier
c  ..array arguments..
      real x(m),t(n)
c  ..local scalars..
      integer i,j,k1,k2,l,nk1,nk2,nk3
      real tj,tl
c  ..
      k1 = k+1
      k2 = k1+1
      nk1 = n-k1
      nk2 = nk1+1
      ier = 10
c  check condition no 1
      if(nk1.lt.k1 .or. nk1.gt.m) go to 80
c  check condition no 2
      j = n
      do 20 i=1,k
        if(t(i).gt.t(i+1)) go to 80
        if(t(j).lt.t(j-1)) go to 80
        j = j-1
  20  continue
c  check condition no 3
      do 30 i=k2,nk2
        if(t(i).le.t(i-1)) go to 80
  30  continue
c  check condition no 4
      if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 80
c  check condition no 5
      if(x(1).ge.t(k2) .or. x(m).le.t(nk1)) go to 80
      i = 1
      l = k2
      nk3 = nk1-1
      if(nk3.lt.2) go to 70
      do 60 j=2,nk3
        tj = t(j)
        l = l+1
        tl = t(l)
  40    i = i+1
        if(i.ge.m) go to 80
        if(x(i).le.tj) go to 40
        if(x(i).ge.tl) go to 80
  60  continue
  70  ier = 0
  80  return
      end
      subroutine fpdisc(t,n,k2,b,nest)
c  subroutine fpdisc calculates the discontinuity jumps of the kth
c  derivative of the b-splines of degree k at the knots t(k+2)..t(n-k-1)
c  ..scalar arguments..
      integer n,k2,nest
c  ..array arguments..
      real t(n),b(nest,k2)
c  ..local scalars..
      real an,fac,prod
      integer i,ik,j,jk,k,k1,l,lj,lk,lmk,lp,nk1,nrint
c  ..local array..
      real h(12)
c  ..
      k1 = k2-1
      k = k1-1
      nk1 = n-k1
      nrint = nk1-k
      an = nrint
      fac = an/(t(nk1+1)-t(k1))
      do 40 l=k2,nk1
        lmk = l-k1
        do 10 j=1,k1
          ik = j+k1
          lj = l+j
          lk = lj-k2
          h(j) = t(l)-t(lk)
          h(ik) = t(l)-t(lj)
  10    continue
        lp = lmk
        do 30 j=1,k2
          jk = j
          prod = h(j)
          do 20 i=1,k
            jk = jk+1
            prod = prod*h(jk)*fac
  20      continue
          lk = lp+k1
          b(lmk,j) = (t(lk)-t(lp))/prod
          lp = lp+1
  30    continue
  40  continue
      return
      end
      subroutine fpgivs(piv,ww,cos,sin)
c  subroutine fpgivs calculates the parameters of a givens
c  transformation .
c  ..
c  ..scalar arguments..
      real piv,ww,cos,sin
c  ..local scalars..
      real dd,one,store
c  ..function references..
      real abs,sqrt
c  ..
      one = 0.1e+01
      store = abs(piv)
      if(store.ge.ww) dd = store*sqrt(one+(ww/piv)**2)
      if(store.lt.ww) dd = ww*sqrt(one+(piv/ww)**2)
      cos = ww/dd
      sin = piv/dd
      ww = dd
      return
      end
      subroutine fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,
     * ty,ny,p,c,nc,fp,fpx,fpy,mm,mynx,kx1,kx2,ky1,ky2,spx,spy,right,q,
     * ax,ay,bx,by,nrx,nry)
c  ..
c  ..scalar arguments..
      real p,fp
      integer ifsx,ifsy,ifbx,ifby,mx,my,mz,kx,ky,nx,ny,nc,mm,mynx,
     * kx1,kx2,ky1,ky2
c  ..array arguments..
      real x(mx),y(my),z(mz),tx(nx),ty(ny),c(nc),spx(mx,kx1),spy(my,ky1)
     * ,right(mm),q(mynx),ax(nx,kx2),bx(nx,kx2),ay(ny,ky2),by(ny,ky2),
     * fpx(nx),fpy(ny)
      integer nrx(mx),nry(my)
c  ..local scalars..
      real arg,cos,fac,pinv,piv,sin,term,one,half
      integer i,ibandx,ibandy,ic,iq,irot,it,iz,i1,i2,i3,j,k,k1,k2,l,
     * l1,l2,ncof,nk1x,nk1y,nrold,nroldx,nroldy,number,numx,numx1,
     * numy,numy1,n1
c  ..local arrays..
      real h(7)
c  ..subroutine references..
c    fpback,fpbspl,fpgivs,fpdisc,fprota
c  ..
c  the b-spline coefficients of the smoothing spline are calculated as
c  the least-squares solution of the over-determined linear system of
c  equations  (ay) c (ax)' = q       where
c
c               |   (spx)    |            |   (spy)    |
c        (ax) = | ---------- |     (ay) = | ---------- |
c               | (1/p) (bx) |            | (1/p) (by) |
c
c                                | z  ' 0 |
c                            q = | ------ |
c                                | 0  ' 0 |
c
c  with c      : the (ny-ky-1) x (nx-kx-1) matrix which contains the
c                b-spline coefficients.
c       z      : the my x mx matrix which contains the function values.
c       spx,spy: the mx x (nx-kx-1) and  my x (ny-ky-1) observation
c                matrices according to the least-squares problems in
c                the x- and y-direction.
c       bx,by  : the (nx-2*kx-1) x (nx-kx-1) and (ny-2*ky-1) x (ny-ky-1)
c                matrices which contain the discontinuity jumps of the
c                derivatives of the b-splines in the x- and y-direction.
      one = 1
      half = 0.5
      nk1x = nx-kx1
      nk1y = ny-ky1
      if(p.gt.0.) pinv = one/p
c  it depends on the value of the flags ifsx,ifsy,ifbx and ifby and on
c  the value of p whether the matrices (spx),(spy),(bx) and (by) still
c  must be determined.
      if(ifsx.ne.0) go to 50
c  calculate the non-zero elements of the matrix (spx) which is the
c  observation matrix according to the least-squares spline approximat-
c  ion problem in the x-direction.
      l = kx1
      l1 = kx2
      number = 0
      do 40 it=1,mx
        arg = x(it)
  10    if(arg.lt.tx(l1) .or. l.eq.nk1x) go to 20
        l = l1
        l1 = l+1
        number = number+1
        go to 10
  20    call fpbspl(tx,nx,kx,arg,l,h)
        do 30 i=1,kx1
          spx(it,i) = h(i)
  30    continue
        nrx(it) = number
  40  continue
      ifsx = 1
  50  if(ifsy.ne.0) go to 100
c  calculate the non-zero elements of the matrix (spy) which is the
c  observation matrix according to the least-squares spline approximat-
c  ion problem in the y-direction.
      l = ky1
      l1 = ky2
      number = 0
      do 90 it=1,my
        arg = y(it)
  60    if(arg.lt.ty(l1) .or. l.eq.nk1y) go to 70
        l = l1
        l1 = l+1
        number = number+1
        go to 60
  70    call fpbspl(ty,ny,ky,arg,l,h)
        do 80 i=1,ky1
          spy(it,i) = h(i)
  80    continue
        nry(it) = number
  90  continue
      ifsy = 1
 100  if(p.le.0.) go to 120
c  calculate the non-zero elements of the matrix (bx).
      if(ifbx.ne.0 .or. nx.eq.2*kx1) go to 110
      call fpdisc(tx,nx,kx2,bx,nx)
      ifbx = 1
c  calculate the non-zero elements of the matrix (by).
 110  if(ifby.ne.0 .or. ny.eq.2*ky1) go to 120
      call fpdisc(ty,ny,ky2,by,ny)
      ifby = 1
c  reduce the matrix (ax) to upper triangular form (rx) using givens
c  rotations. apply the same transformations to the rows of matrix q
c  to obtain the my x (nx-kx-1) matrix g.
c  store matrix (rx) into (ax) and g into q.
 120  l = my*nk1x
c  initialization.
      do 130 i=1,l
        q(i) = 0.
 130  continue
      do 140 i=1,nk1x
        do 140 j=1,kx2
          ax(i,j) = 0.
 140  continue
      l = 0
      nrold = 0
c  ibandx denotes the bandwidth of the matrices (ax) and (rx).
      ibandx = kx1
      do 270 it=1,mx
        number = nrx(it)
 150    if(nrold.eq.number) go to 180
        if(p.le.0.) go to 260
        ibandx = kx2
c  fetch a new row of matrix (bx).
        n1 = nrold+1
        do 160 j=1,kx2
          h(j) = bx(n1,j)*pinv
 160    continue
c  find the appropriate column of q.
        do 170 j=1,my
          right(j) = 0.
 170    continue
        irot = nrold
        go to 210
c  fetch a new row of matrix (spx).
 180    h(ibandx) = 0.
        do 190 j=1,kx1
          h(j) = spx(it,j)
 190    continue
c  find the appropriate column of q.
        do 200 j=1,my
          l = l+1
          right(j) = z(l)
 200    continue
        irot = number
c  rotate the new row of matrix (ax) into triangle.
 210    do 240 i=1,ibandx
          irot = irot+1
          piv = h(i)
          if(piv.eq.0.) go to 240
c  calculate the parameters of the givens transformation.
          call fpgivs(piv,ax(irot,1),cos,sin)
c  apply that transformation to the rows of matrix q.
          iq = (irot-1)*my
          do 220 j=1,my
            iq = iq+1
            call fprota(cos,sin,right(j),q(iq))
 220      continue
c  apply that transformation to the columns of (ax).
          if(i.eq.ibandx) go to 250
          i2 = 1
          i3 = i+1
          do 230 j=i3,ibandx
            i2 = i2+1
            call fprota(cos,sin,h(j),ax(irot,i2))
 230      continue
 240    continue
 250    if(nrold.eq.number) go to 270
 260    nrold = nrold+1
        go to 150
 270  continue
c  reduce the matrix (ay) to upper triangular form (ry) using givens
c  rotations. apply the same transformations to the columns of matrix g
c  to obtain the (ny-ky-1) x (nx-kx-1) matrix h.
c  store matrix (ry) into (ay) and h into c.
      ncof = nk1x*nk1y
c  initialization.
      do 280 i=1,ncof
        c(i) = 0.
 280  continue
      do 290 i=1,nk1y
        do 290 j=1,ky2
          ay(i,j) = 0.
 290  continue
      nrold = 0
c  ibandy denotes the bandwidth of the matrices (ay) and (ry).
      ibandy = ky1
      do 420 it=1,my
        number = nry(it)
 300    if(nrold.eq.number) go to 330
        if(p.le.0.) go to 410
        ibandy = ky2
c  fetch a new row of matrix (by).
        n1 = nrold+1
        do 310 j=1,ky2
          h(j) = by(n1,j)*pinv
 310    continue
c  find the appropiate row of g.
        do 320 j=1,nk1x
          right(j) = 0.
 320    continue
        irot = nrold
        go to 360
c  fetch a new row of matrix (spy)
 330    h(ibandy) = 0.
        do 340 j=1,ky1
          h(j) = spy(it,j)
 340    continue
c  find the appropiate row of g.
        l = it
        do 350 j=1,nk1x
          right(j) = q(l)
          l = l+my
 350    continue
        irot = number
c  rotate the new row of matrix (ay) into triangle.
 360    do 390 i=1,ibandy
          irot = irot+1
          piv = h(i)
          if(piv.eq.0.) go to 390
c  calculate the parameters of the givens transformation.
          call fpgivs(piv,ay(irot,1),cos,sin)
c  apply that transformation to the colums of matrix g.
          ic = irot
          do 370 j=1,nk1x
            call fprota(cos,sin,right(j),c(ic))
            ic = ic+nk1y
 370      continue
c  apply that transformation to the columns of matrix (ay).
          if(i.eq.ibandy) go to 400
          i2 = 1
          i3 = i+1
          do 380 j=i3,ibandy
            i2 = i2+1
            call fprota(cos,sin,h(j),ay(irot,i2))
 380      continue
 390    continue
 400    if(nrold.eq.number) go to 420
 410    nrold = nrold+1
        go to 300
 420  continue
c  backward substitution to obtain the b-spline coefficients as the
c  solution of the linear system    (ry) c (rx)' = h.
c  first step: solve the system  (ry) (c1) = h.
      k = 1
      do 450 i=1,nk1x
        call fpback(ay,c(k),nk1y,ibandy,c(k),ny)
        k = k+nk1y
 450  continue
c  second step: solve the system  c (rx)' = (c1).
      k = 0
      do 480 j=1,nk1y
        k = k+1
        l = k
        do 460 i=1,nk1x
          right(i) = c(l)
          l = l+nk1y
 460    continue
        call fpback(ax,right,nk1x,ibandx,right,nx)
        l = k
        do 470 i=1,nk1x
          c(l) = right(i)
          l = l+nk1y
 470    continue
 480  continue
c  calculate the quantities
c    res(i,j) = (z(i,j) - s(x(i),y(j)))**2 , i=1,2,..,mx;j=1,2,..,my
c    fp = sumi=1,mx(sumj=1,my(res(i,j)))
c    fpx(r) = sum''i(sumj=1,my(res(i,j))) , r=1,2,...,nx-2*kx-1
c                  tx(r+kx) <= x(i) <= tx(r+kx+1)
c    fpy(r) = sumi=1,mx(sum''j(res(i,j))) , r=1,2,...,ny-2*ky-1
c                  ty(r+ky) <= y(j) <= ty(r+ky+1)
      fp = 0.
      do 490 i=1,nx
        fpx(i) = 0.
 490  continue
      do 500 i=1,ny
        fpy(i) = 0.
 500  continue
      nk1y = ny-ky1
      iz = 0
      nroldx = 0
c  main loop for the different grid points.
      do 550 i1=1,mx
        numx = nrx(i1)
        numx1 = numx+1
        nroldy = 0
        do 540 i2=1,my
          numy = nry(i2)
          numy1 = numy+1
          iz = iz+1
c  evaluate s(x,y) at the current grid point by making the sum of the
c  cross products of the non-zero b-splines at (x,y), multiplied with
c  the appropiate b-spline coefficients.
          term = 0.
          k1 = numx*nk1y+numy
          do 520 l1=1,kx1
            k2 = k1
            fac = spx(i1,l1)
            do 510 l2=1,ky1
              k2 = k2+1
              term = term+fac*spy(i2,l2)*c(k2)
 510        continue
            k1 = k1+nk1y
 520      continue
c  calculate the squared residual at the current grid point.
          term = (z(iz)-term)**2
c  adjust the different parameters.
          fp = fp+term
          fpx(numx1) = fpx(numx1)+term
          fpy(numy1) = fpy(numy1)+term
          fac = term*half
          if(numy.eq.nroldy) go to 530
          fpy(numy1) = fpy(numy1)-fac
          fpy(numy) = fpy(numy)+fac
 530      nroldy = numy
          if(numx.eq.nroldx) go to 540
          fpx(numx1) = fpx(numx1)-fac
          fpx(numx) = fpx(numx)+fac
 540    continue
        nroldx = numx
 550  continue
      return
      end

      subroutine fpknot(x,m,t,n,fpint,nrdata,nrint,nest,istart)
c  subroutine fpknot locates an additional knot for a spline of degree
c  k and adjusts the corresponding parameters,i.e.
c    t     : the position of the knots.
c    n     : the number of knots.
c    nrint : the number of knotintervals.
c    fpint : the sum of squares of residual right hand sides
c            for each knot interval.
c    nrdata: the number of data points inside each knot interval.
c  istart indicates that the smallest data point at which the new knot
c  may be added is x(istart+1)
c  ..
c  ..scalar arguments..
      integer m,n,nrint,nest,istart
c  ..array arguments..
      real x(m),t(nest),fpint(nest)
      integer nrdata(nest)
c  ..local scalars..
      real an,am,fpmax
      integer ihalf,j,jbegin,jj,jk,jpoint,k,maxbeg,maxpt,
     * next,nrx,number
c  ..
      k = (n-nrint-1)/2
c  search for knot interval t(number+k) <= x <= t(number+k+1) where
c  fpint(number) is maximal on the condition that nrdata(number)
c  not equals zero.
      fpmax = 0.
      jbegin = istart
      do 20 j=1,nrint
        jpoint = nrdata(j)
        if(fpmax.ge.fpint(j) .or. jpoint.eq.0) go to 10
        fpmax = fpint(j)
        number = j
        maxpt = jpoint
        maxbeg = jbegin
  10    jbegin = jbegin+jpoint+1
  20  continue
c  let coincide the new knot t(number+k+1) with a data point x(nrx)
c  inside the old knot interval t(number+k) <= x <= t(number+k+1).
      ihalf = maxpt/2+1
      nrx = maxbeg+ihalf
      next = number+1
      if(next.gt.nrint) go to 40
c  adjust the different parameters.
      do 30 j=next,nrint
        jj = next+nrint-j
        fpint(jj+1) = fpint(jj)
        nrdata(jj+1) = nrdata(jj)
        jk = jj+k
        t(jk+1) = t(jk)
  30  continue
  40  nrdata(number) = ihalf-1
      nrdata(next) = maxpt-ihalf
      am = maxpt
      an = nrdata(number)
      fpint(number) = fpmax*an/am
      an = nrdata(next)
      fpint(next) = fpmax*an/am
      jk = next+k
      t(jk) = x(nrx)
      n = n+1
      nrint = nrint+1
      return
      end
      real function fprati(p1,f1,p2,f2,p3,f3)
c  given three points (p1,f1),(p2,f2) and (p3,f3), function fprati
c  gives the value of p such that the rational interpolating function
c  of the form r(p) = (u*p+v)/(p+w) equals zero at p.
c  ..
c  ..scalar arguments..
      real p1,f1,p2,f2,p3,f3
c  ..local scalars..
      real h1,h2,h3,p
c  ..
      if(p3.gt.0.) go to 10
c  value of p in case p3 = infinity.
      p = (p1*(f1-f3)*f2-p2*(f2-f3)*f1)/((f1-f2)*f3)
      go to 20
c  value of p in case p3 ^= infinity.
  10  h1 = f1*(f2-f3)
      h2 = f2*(f3-f1)
      h3 = f3*(f1-f2)
      p = -(p1*p2*h3+p2*p3*h1+p3*p1*h2)/(p1*h1+p2*h2+p3*h3)
c  adjust the value of p1,f1,p3 and f3 such that f1 > 0 and f3 < 0.
  20  if(f2.lt.0.) go to 30
      p1 = p2
      f1 = f2
      go to 40
  30  p3 = p2
      f3 = f2
  40  fprati = p
      return
      end
      subroutine fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,
     * nxest,nyest,tol,maxit,nc,nx,tx,ny,ty,c,fp,fp0,fpold,reducx,
     * reducy,fpintx,fpinty,lastdi,nplusx,nplusy,nrx,nry,nrdatx,nrdaty,
     * wrk,lwrk,ier)
c  ..
c  ..scalar arguments..
      real xb,xe,yb,ye,s,tol,fp,fp0,fpold,reducx,reducy
      integer iopt,mx,my,mz,kx,ky,nxest,nyest,maxit,nc,nx,ny,lastdi,
     * nplusx,nplusy,lwrk,ier
c  ..array arguments..
      real x(mx),y(my),z(mz),tx(nxest),ty(nyest),c(nc),fpintx(nxest),
     * fpinty(nyest),wrk(lwrk)
      integer nrdatx(nxest),nrdaty(nyest),nrx(mx),nry(my)
c  ..local scalars
      real acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,half,con1,con9,con4
      integer i,ich1,ich3,ifbx,ifby,ifsx,ifsy,iter,j,kx1,kx2,ky1,ky2,
     * k3,l,lax,lay,lbx,lby,lq,lri,lsx,lsy,mk1,mm,mpm,mynx,ncof,
     * nk1x,nk1y,nmaxx,nmaxy,nminx,nminy,nplx,nply,npl1,nrintx,
     * nrinty,nxe,nxk,nye
c  ..function references..
      real abs,fprati
      integer max0,min0
c  ..subroutine references..
c    fpgrre,fpknot
c  ..
c   set constants
      one = 1
      half = 0.5e0
      con1 = 0.1e0
      con9 = 0.9e0
      con4 = 0.4e-01
c  we partition the working space.
      kx1 = kx+1
      ky1 = ky+1
      kx2 = kx1+1
      ky2 = ky1+1
      lsx = 1
      lsy = lsx+mx*kx1
      lri = lsy+my*ky1
      mm = max0(nxest,my)
      lq = lri+mm
      mynx = nxest*my
      lax = lq+mynx
      nxk = nxest*kx2
      lbx = lax+nxk
      lay = lbx+nxk
      lby = lay+nyest*ky2
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c part 1: determination of the number of knots and their position.     c
c ****************************************************************     c
c  given a set of knots we compute the least-squares spline sinf(x,y), c
c  and the corresponding sum of squared residuals fp=f(p=inf).         c
c  if iopt=-1  sinf(x,y) is the requested approximation.               c
c  if iopt=0 or iopt=1 we check whether we can accept the knots:       c
c    if fp <=s we will continue with the current set of knots.         c
c    if fp > s we will increase the number of knots and compute the    c
c       corresponding least-squares spline until finally fp<=s.        c
c    the initial choice of knots depends on the value of s and iopt.   c
c    if s=0 we have spline interpolation; in that case the number of   c
c    knots equals nmaxx = mx+kx+1  and  nmaxy = my+ky+1.               c
c    if s>0 and                                                        c
c     *iopt=0 we first compute the least-squares polynomial of degree  c
c      kx in x and ky in y; nx=nminx=2*kx+2 and ny=nymin=2*ky+2.       c
c     *iopt=1 we start with the knots found at the last call of the    c
c      routine, except for the case that s > fp0; then we can compute  c
c      the least-squares polynomial directly.                          c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  determine the number of knots for polynomial approximation.
      nminx = 2*kx1
      nminy = 2*ky1
      if(iopt.lt.0) go to 120
c  acc denotes the absolute tolerance for the root of f(p)=s.
      acc = tol*s
c  find nmaxx and nmaxy which denote the number of knots in x- and y-
c  direction in case of spline interpolation.
      nmaxx = mx+kx1
      nmaxy = my+ky1
c  find nxe and nye which denote the maximum number of knots
c  allowed in each direction
      nxe = min0(nmaxx,nxest)
      nye = min0(nmaxy,nyest)
      if(s.gt.0.) go to 100
c  if s = 0, s(x,y) is an interpolating spline.
      nx = nmaxx
      ny = nmaxy
c  test whether the required storage space exceeds the available one.
      if(ny.gt.nyest .or. nx.gt.nxest) go to 420
c  find the position of the interior knots in case of interpolation.
c  the knots in the x-direction.
      mk1 = mx-kx1
      if(mk1.eq.0) go to 60
      k3 = kx/2
      i = kx1+1
      j = k3+2
      if(k3*2.eq.kx) go to 40
      do 30 l=1,mk1
        tx(i) = x(j)
        i = i+1
        j = j+1
  30  continue
      go to 60
  40  do 50 l=1,mk1
        tx(i) = (x(j)+x(j-1))*half
        i = i+1
        j = j+1
  50  continue
c  the knots in the y-direction.
  60  mk1 = my-ky1
      if(mk1.eq.0) go to 120
      k3 = ky/2
      i = ky1+1
      j = k3+2
      if(k3*2.eq.ky) go to 80
      do 70 l=1,mk1
        ty(i) = y(j)
        i = i+1
        j = j+1
  70  continue
      go to 120
  80  do 90 l=1,mk1
        ty(i) = (y(j)+y(j-1))*half
        i = i+1
        j = j+1
  90  continue
      go to 120
c  if s > 0 our initial choice of knots depends on the value of iopt.
 100  if(iopt.eq.0) go to 115
      if(fp0.le.s) go to 115
c  if iopt=1 and fp0 > s we start computing the least- squares spline
c  according to the set of knots found at the last call of the routine.
c  we determine the number of grid coordinates x(i) inside each knot
c  interval (tx(l),tx(l+1)).
      l = kx2
      j = 1
      nrdatx(1) = 0
      mpm = mx-1
      do 105 i=2,mpm
        nrdatx(j) = nrdatx(j)+1
        if(x(i).lt.tx(l)) go to 105
        nrdatx(j) = nrdatx(j)-1
        l = l+1
        j = j+1
        nrdatx(j) = 0
 105  continue
c  we determine the number of grid coordinates y(i) inside each knot
c  interval (ty(l),ty(l+1)).
      l = ky2
      j = 1
      nrdaty(1) = 0
      mpm = my-1
      do 110 i=2,mpm
        nrdaty(j) = nrdaty(j)+1
        if(y(i).lt.ty(l)) go to 110
        nrdaty(j) = nrdaty(j)-1
        l = l+1
        j = j+1
        nrdaty(j) = 0
 110  continue
      go to 120
c  if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares
c  polynomial of degree kx in x and ky in y (which is a spline without
c  interior knots).
 115  nx = nminx
      ny = nminy
      nrdatx(1) = mx-2
      nrdaty(1) = my-2
      lastdi = 0
      nplusx = 0
      nplusy = 0
      fp0 = 0.
      fpold = 0.
      reducx = 0.
      reducy = 0.
 120  mpm = mx+my
      ifsx = 0
      ifsy = 0
      ifbx = 0
      ifby = 0
      p = -one
c  main loop for the different sets of knots.mpm=mx+my is a save upper
c  bound for the number of trials.
      do 250 iter=1,mpm
        if(nx.eq.nminx .and. ny.eq.nminy) ier = -2
c  find nrintx (nrinty) which is the number of knot intervals in the
c  x-direction (y-direction).
        nrintx = nx-nminx+1
        nrinty = ny-nminy+1
c  find ncof, the number of b-spline coefficients for the current set
c  of knots.
        nk1x = nx-kx1
        nk1y = ny-ky1
        ncof = nk1x*nk1y
c  find the position of the additional knots which are needed for the
c  b-spline representation of s(x,y).
        i = nx
        do 130 j=1,kx1
          tx(j) = xb
          tx(i) = xe
          i = i-1
 130    continue
        i = ny
        do 140 j=1,ky1
          ty(j) = yb
          ty(i) = ye
          i = i-1
 140    continue
c  find the least-squares spline sinf(x,y) and calculate for each knot
c  interval tx(j+kx)<=x<=tx(j+kx+1) (ty(j+ky)<=y<=ty(j+ky+1)) the sum
c  of squared residuals fpintx(j),j=1,2,...,nx-2*kx-1 (fpinty(j),j=1,2,
c  ...,ny-2*ky-1) for the data points having their absciss (ordinate)-
c  value belonging to that interval.
c  fp gives the total sum of squared residuals.
        call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty,
     *  ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx),
     *  wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby),
     *  nrx,nry)
        if(ier.eq.(-2)) fp0 = fp
c  test whether the least-squares spline is an acceptable solution.
        if(iopt.lt.0) go to 440
        fpms = fp-s
        if(abs(fpms) .lt. acc) go to 440
c  if f(p=inf) < s, we accept the choice of knots.
        if(fpms.lt.0.) go to 300
c  if nx=nmaxx and ny=nmaxy, sinf(x,y) is an interpolating spline.
        if(nx.eq.nmaxx .and. ny.eq.nmaxy) go to 430
c  increase the number of knots.
c  if nx=nxe and ny=nye we cannot further increase the number of knots
c  because of the storage capacity limitation.
        if(nx.eq.nxe .and. ny.eq.nye) go to 420
        ier = 0
c  adjust the parameter reducx or reducy according to the direction
c  in which the last added knots were located.
        if(lastdi) 150,170,160
 150    reducx = fpold-fp
        go to 170
 160    reducy = fpold-fp
c  store the sum of squared residuals for the current set of knots.
 170    fpold = fp
c  find nplx, the number of knots we should add in the x-direction.
        nplx = 1
        if(nx.eq.nminx) go to 180
        npl1 = nplusx*2
        rn = nplusx
        if(reducx.gt.acc) npl1 = rn*fpms/reducx
        nplx = min0(nplusx*2,max0(npl1,nplusx/2,1))
c  find nply, the number of knots we should add in the y-direction.
 180    nply = 1
        if(ny.eq.nminy) go to 190
        npl1 = nplusy*2
        rn = nplusy
        if(reducy.gt.acc) npl1 = rn*fpms/reducy
        nply = min0(nplusy*2,max0(npl1,nplusy/2,1))
 190    if(nplx-nply) 210,200,230
 200    if(lastdi.lt.0) go to 230
 210    if(nx.eq.nxe) go to 230
c  addition in the x-direction.
        lastdi = -1
        nplusx = nplx
        ifsx = 0
        do 220 l=1,nplusx
c  add a new knot in the x-direction
          call fpknot(x,mx,tx,nx,fpintx,nrdatx,nrintx,nxest,1)
c  test whether we cannot further increase the number of knots in the
c  x-direction.
          if(nx.eq.nxe) go to 250
 220    continue
        go to 250
 230    if(ny.eq.nye) go to 210
c  addition in the y-direction.
        lastdi = 1
        nplusy = nply
        ifsy = 0
        do 240 l=1,nplusy
c  add a new knot in the y-direction.
          call fpknot(y,my,ty,ny,fpinty,nrdaty,nrinty,nyest,1)
c  test whether we cannot further increase the number of knots in the
c  y-direction.
          if(ny.eq.nye) go to 250
 240    continue
c  restart the computations with the new set of knots.
 250  continue
c  test whether the least-squares polynomial is a solution of our
c  approximation problem.
 300  if(ier.eq.(-2)) go to 440
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c part 2: determination of the smoothing spline sp(x,y)                c
c *****************************************************                c
c  we have determined the number of knots and their position. we now   c
c  compute the b-spline coefficients of the smoothing spline sp(x,y).  c
c  this smoothing spline varies with the parameter p in such a way thatc
c    f(p) = sumi=1,mx(sumj=1,my((z(i,j)-sp(x(i),y(j)))**2)             c
c  is a continuous, strictly decreasing function of p. moreover the    c
c  least-squares polynomial corresponds to p=0 and the least-squares   c
c  spline to p=infinity. iteratively we then have to determine the     c
c  positive value of p such that f(p)=s. the process which is proposed c
c  here makes use of rational interpolation. f(p) is approximated by a c
c  rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3)  c
c  with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c
c  are used to calculate the new value of p such that r(p)=s.          c
c  convergence is guaranteed by taking f1 > 0 and f3 < 0.              c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  initial value for p.
      p1 = 0.
      f1 = fp0-s
      p3 = -one
      f3 = fpms
      p = one
      ich1 = 0
      ich3 = 0
c  iteration process to find the root of f(p)=s.
      do 350 iter = 1,maxit
c  find the smoothing spline sp(x,y) and the corresponding sum of
c  squared residuals fp.
        call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty,
     *  ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx),
     *  wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby),
     *  nrx,nry)
c  test whether the approximation sp(x,y) is an acceptable solution.
        fpms = fp-s
        if(abs(fpms).lt.acc) go to 440
c  test whether the maximum allowable number of iterations has been
c  reached.
        if(iter.eq.maxit) go to 400
c  carry out one more step of the iteration process.
        p2 = p
        f2 = fpms
        if(ich3.ne.0) go to 320
        if((f2-f3).gt.acc) go to 310
c  our initial choice of p is too large.
        p3 = p2
        f3 = f2
        p = p*con4
        if(p.le.p1) p = p1*con9 + p2*con1
        go to 350
 310    if(f2.lt.0.) ich3 = 1
 320    if(ich1.ne.0) go to 340
        if((f1-f2).gt.acc) go to 330
c  our initial choice of p is too small
        p1 = p2
        f1 = f2
        p = p/con4
        if(p3.lt.0.) go to 350
        if(p.ge.p3) p = p2*con1 + p3*con9
        go to 350
c  test whether the iteration process proceeds as theoretically
c  expected.
 330    if(f2.gt.0.) ich1 = 1
 340    if(f2.ge.f1 .or. f2.le.f3) go to 410
c  find the new value of p.
        p = fprati(p1,f1,p2,f2,p3,f3)
 350  continue
c  error codes and messages.
 400  ier = 3
      go to 440
 410  ier = 2
      go to 440
 420  ier = 1
      go to 440
 430  ier = -1
      fp = 0.
 440  return
      end

      subroutine fprota(cos,sin,a,b)
c  subroutine fprota applies a givens rotation to a and b.
c  ..
c  ..scalar arguments..
      real cos,sin,a,b
c ..local scalars..
      real stor1,stor2
c  ..
      stor1 = a
      stor2 = b
      b = cos*stor2+sin*stor1
      a = cos*stor1-sin*stor2
      return
      end
      subroutine regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,
     * nxest,nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c given the set of values z(i,j) on the rectangular grid (x(i),y(j)),
c i=1,...,mx;j=1,...,my, subroutine regrid determines a smooth bivar-
c iate spline approximation s(x,y) of degrees kx and ky on the rect-
c angle xb <= x <= xe, yb <= y <= ye.
c if iopt = -1 regrid calculates the least-squares spline according
c to a given set of knots.
c if iopt >= 0 the total numbers nx and ny of these knots and their
c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic-
c ally by the routine. the smoothness of s(x,y) is then achieved by
c minimalizing the discontinuity jumps in the derivatives of s(x,y)
c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1).
c the amounth of smoothness is determined by the condition that f(p) =
c sum ((z(i,j)-s(x(i),y(j))))**2) be <= s, with s a given non-negative
c constant, called the smoothing factor.
c the fit is given in the b-spline representation (b-spline coefficients
c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval-
c uated by means of subroutine bispev.
c
c calling sequence:
c     call regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
c    *  nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c
c parameters:
c  iopt  : integer flag. on entry iopt must specify whether a least-
c          squares spline (iopt=-1) or a smoothing spline (iopt=0 or 1)
c          must be determined.
c          if iopt=0 the routine will start with an initial set of knots
c          tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i=
c          1,...,ky+1. if iopt=1 the routine will continue with the set
c          of knots found at the last call of the routine.
c          attention: a call with iopt=1 must always be immediately pre-
c                     ceded by another call with iopt=1 or iopt=0 and
c                     s.ne.0.
c          unchanged on exit.
c  mx    : integer. on entry mx must specify the number of grid points
c          along the x-axis. mx > kx . unchanged on exit.
c  x     : real array of dimension at least (mx). before entry, x(i)
c          must be set to the x-co-ordinate of the i-th grid point
c          along the x-axis, for i=1,2,...,mx. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c  my    : integer. on entry my must specify the number of grid points
c          along the y-axis. my > ky . unchanged on exit.
c  y     : real array of dimension at least (my). before entry, y(j)
c          must be set to the y-co-ordinate of the j-th grid point
c          along the y-axis, for j=1,2,...,my. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c  z     : real array of dimension at least (mx*my).
c          before entry, z(my*(i-1)+j) must be set to the data value at
c          the grid point (x(i),y(j)) for i=1,...,mx and j=1,...,my.
c          unchanged on exit.
c  xb,xe : real values. on entry xb,xe,yb and ye must specify the bound-
c  yb,ye   aries of the rectangular approximation domain.
c          xb<=x(i)<=xe,i=1,...,mx; yb<=y(j)<=ye,j=1,...,my.
c          unchanged on exit.
c  kx,ky : integer values. on entry kx and ky must specify the degrees
c          of the spline. 1<=kx,ky<=5. it is recommended to use bicubic
c          (kx=ky=3) splines. unchanged on exit.
c  s     : real. on entry (in case iopt>=0) s must specify the smoothing
c          factor. s >=0. unchanged on exit.
c          for advice on the choice of s see further comments
c  nxest : integer. unchanged on exit.
c  nyest : integer. unchanged on exit.
c          on entry, nxest and nyest must specify an upper bound for the
c          number of knots required in the x- and y-directions respect.
c          these numbers will also determine the storage space needed by
c          the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1).
c          in most practical situation nxest = mx/2, nyest=my/2, will
c          be sufficient. always large enough are nxest=mx+kx+1, nyest=
c          my+ky+1, the number of knots needed for interpolation (s=0).
c          see also further comments.
c  nx    : integer.
c          unless ier=10 (in case iopt >=0), nx will contain the total
c          number of knots with respect to the x-variable, of the spline
c          approximation returned. if the computation mode iopt=1 is
c          used, the value of nx should be left unchanged between sub-
c          sequent calls.
c          in case iopt=-1, the value of nx should be specified on entry
c  tx    : real array of dimension nmax.
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the x-variable, i.e. the position of
c          the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the
c          position of the additional knots tx(1)=...=tx(kx+1)=xb and
c          tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat.
c          if the computation mode iopt=1 is used, the values of tx(1),
c          ...,tx(nx) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values tx(kx+2),
c          ...tx(nx-kx-1) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  ny    : integer.
c          unless ier=10 (in case iopt >=0), ny will contain the total
c          number of knots with respect to the y-variable, of the spline
c          approximation returned. if the computation mode iopt=1 is
c          used, the value of ny should be left unchanged between sub-
c          sequent calls.
c          in case iopt=-1, the value of ny should be specified on entry
c  ty    : real array of dimension nmax.
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the y-variable, i.e. the position of
c          the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the
c          position of the additional knots ty(1)=...=ty(ky+1)=yb and
c          ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat.
c          if the computation mode iopt=1 is used, the values of ty(1),
c          ...,ty(ny) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values ty(ky+2),
c          ...ty(ny-ky-1) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  c     : real array of dimension at least (nxest-kx-1)*(nyest-ky-1).
c          on succesful exit, c contains the coefficients of the spline
c          approximation s(x,y)
c  fp    : real. unless ier=10, fp contains the sum of squared
c          residuals of the spline approximation returned.
c  wrk   : real array of dimension (lwrk). used as workspace.
c          if the computation mode iopt=1 is used the values of wrk(1),
c          ...,wrk(4) should be left unchanged between subsequent calls.
c  lwrk  : integer. on entry lwrk must specify the actual dimension of
c          the array wrk as declared in the calling (sub)program.
c          lwrk must not be too small.
c           lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+
c            my*(ky+1) +u
c           where u is the larger of my and nxest.
c  iwrk  : integer array of dimension (kwrk). used as workspace.
c          if the computation mode iopt=1 is used the values of iwrk(1),
c          ...,iwrk(3) should be left unchanged between subsequent calls
c  kwrk  : integer. on entry kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program.
c          kwrk >= 3+mx+my+nxest+nyest.
c  ier   : integer. unless the routine detects an error, ier contains a
c          non-positive value on exit, i.e.
c   ier=0  : normal return. the spline returned has a residual sum of
c            squares fp such that abs(fp-s)/s <= tol with tol a relat-
c            ive tolerance set to 0.001 by the program.
c   ier=-1 : normal return. the spline returned is an interpolating
c            spline (fp=0).
c   ier=-2 : normal return. the spline returned is the least-squares
c            polynomial of degrees kx and ky. in this extreme case fp
c            gives the upper bound for the smoothing factor s.
c   ier=1  : error. the required storage space exceeds the available
c            storage space, as specified by the parameters nxest and
c            nyest.
c            probably causes : nxest or nyest too small. if these param-
c            eters are already large, it may also indicate that s is
c            too small
c            the approximation returned is the least-squares spline
c            according to the current set of knots. the parameter fp
c            gives the corresponding sum of squared residuals (fp>s).
c   ier=2  : error. a theoretically impossible result was found during
c            the iteration proces for finding a smoothing spline with
c            fp = s. probably causes : s too small.
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            abs(fp-s)/s < tol.
c   ier=3  : error. the maximal number of iterations maxit (set to 20
c            by the program) allowed for finding a smoothing spline
c            with fp=s has been reached. probably causes : s too small
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            abs(fp-s)/s < tol.
c   ier=10 : error. on entry, the input data are controlled on validity
c            the following restrictions must be satisfied.
c            -1<=iopt<=1, 1<=kx,ky<=5, mx>kx, my>ky, nxest>=2*kx+2,
c            nyest>=2*ky+2, kwrk>=3+mx+my+nxest+nyest,
c            lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+
c             my*(ky+1) +max(my,nxest),
c            xb<=x(i-1)<x(i)<=xe,i=2,..,mx,yb<=y(j-1)<y(j)<=ye,j=2,..,my
c            if iopt=-1: 2*kx+2<=nx<=min(nxest,mx+kx+1)
c                        xb<tx(kx+2)<tx(kx+3)<...<tx(nx-kx-1)<xe
c                        2*ky+2<=ny<=min(nyest,my+ky+1)
c                        yb<ty(ky+2)<ty(ky+3)<...<ty(ny-ky-1)<ye
c                    the schoenberg-whitney conditions, i.e. there must
c                    be subset of grid co-ordinates xx(p) and yy(q) such
c                    that   tx(p) < xx(p) < tx(p+kx+1) ,p=1,...,nx-kx-1
c                           ty(q) < yy(q) < ty(q+ky+1) ,q=1,...,ny-ky-1
c            if iopt>=0: s>=0
c                        if s=0 : nxest>=mx+kx+1, nyest>=my+ky+1
c            if one of these conditions is found to be violated,control
c            is immediately repassed to the calling program. in that
c            case there is no approximation returned.
c
c further comments:
c   regrid does not allow individual weighting of the data-values.
c   so, if these were determined to widely different accuracies, then
c   perhaps the general data set routine surfit should rather be used
c   in spite of efficiency.
c   by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the spline will be too smooth and signal will be
c   lost ; if s is too small the spline will pick up too much noise. in
c   the extreme cases the program will return an interpolating spline if
c   s=0 and the least-squares polynomial (degrees kx,ky) if s is
c   very large. between these extremes, a properly chosen s will result
c   in a good compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the accuracy of the data values.
c   if the user has an idea of the statistical errors on the data, he
c   can also find a proper estimate for s. for, by assuming that, if he
c   specifies the right s, regrid will return a spline s(x,y) which
c   exactly reproduces the function underlying the data he can evaluate
c   the sum((z(i,j)-s(x(i),y(j)))**2) to find a good estimate for this s
c   for example, if he knows that the statistical errors on his z(i,j)-
c   values is not greater than 0.1, he may expect that a good s should
c   have a value not larger than mx*my*(0.1)**2.
c   if nothing is known about the statistical error in z(i,j), s must
c   be determined by trial and error, taking account of the comments
c   above. the best is then to start with a very large value of s (to
c   determine the least-squares polynomial and the corresponding upper
c   bound fp0 for s) and then to progressively decrease the value of s
c   ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
c   and more carefully as the approximation shows more detail) to
c   obtain closer fits.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt=0.
c   if iopt=1 the program will continue with the set of knots found at
c   the last call of the routine. this will save a lot of computation
c   time if regrid is called repeatedly for different values of s.
c   the number of knots of the spline returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   function underlying the data. if the computation mode iopt=1
c   is used, the knots returned may also depend on the s-values at
c   previous calls (if these were smaller). therefore, if after a number
c   of trials with different s-values and iopt=1, the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   regrid once more with the selected value for s but now with iopt=0.
c   indeed, regrid may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c   the number of knots may also depend on the upper bounds nxest and
c   nyest. indeed, if at a certain stage in regrid the number of knots
c   in one direction (say nx) has reached the value of its upper bound
c   (nxest), then from that moment on all subsequent knots are added
c   in the other (y) direction. this may indicate that the value of
c   nxest is too small. on the other hand, it gives the user the option
c   of limiting the number of knots the routine locates in any direction
c   for example, by setting nxest=2*kx+2 (the lowest allowable value for
c   nxest), the user can indicate that he wants an approximation which
c   is a simple polynomial of degree kx in the variable x.
c
c  other subroutines required:
c    fpback,fpbspl,fpregr,fpdisc,fpgivs,fpgrre,fprati,fprota,fpchec,
c    fpknot
c
c  references:
c   dierckx p. : a fast algorithm for smoothing data on a rectangular
c                grid while using spline functions, siam j.numer.anal.
c                19 (1982) 1286-1304.
c   dierckx p. : a fast algorithm for smoothing data on a rectangular
c                grid while using spline functions, report tw53, dept.
c                computer science,k.u.leuven, 1980.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : may 1979
c  latest update : march 1989
c
c  ..
      implicit none
c  ..scalar arguments..
      real xb,xe,yb,ye,s,fp
      integer iopt,mx,my,kx,ky,nxest,nyest,nx,ny,lwrk,kwrk,ier
c  ..array arguments..
      real x(mx),y(my),z(mx*my),tx(nxest),ty(nyest),
     * c((nxest-kx-1)*(nyest-ky-1)),wrk(lwrk)
      integer iwrk(kwrk)
c  ..local scalars..
      real tol
      integer i,j,jwrk,kndx,kndy,knrx,knry,kwest,kx1,kx2,ky1,ky2,
     * lfpx,lfpy,lwest,lww,maxit,nc,nminx,nminy,mz
c  ..function references..
      integer max0
c  ..subroutine references..
c    fpregr,fpchec
c  ..
c  we set up the parameters tol and maxit.
      maxit = 20
      tol = 0.1e-02
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(kx.le.0 .or. kx.gt.5) go to 70
      kx1 = kx+1
      kx2 = kx1+1
      if(ky.le.0 .or. ky.gt.5) go to 70
      ky1 = ky+1
      ky2 = ky1+1
      if(iopt.lt.(-1) .or. iopt.gt.1) go to 70
      nminx = 2*kx1
      if(mx.lt.kx1 .or. nxest.lt.nminx) go to 70
      nminy = 2*ky1
      if(my.lt.ky1 .or. nyest.lt.nminy) go to 70
      mz = mx*my
      nc = (nxest-kx1)*(nyest-ky1)
      lwest = 4+nxest*(my+2*kx2+1)+nyest*(2*ky2+1)+mx*kx1+
     * my*ky1+max0(nxest,my)
      kwest = 3+mx+my+nxest+nyest
      if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 70
      if(xb.gt.x(1) .or. xe.lt.x(mx)) go to 70
      do 10 i=2,mx
        if(x(i-1).ge.x(i)) go to 70
  10  continue
      if(yb.gt.y(1) .or. ye.lt.y(my)) go to 70
      do 20 i=2,my
        if(y(i-1).ge.y(i)) go to 70
  20  continue
      if(iopt.ge.0) go to 50
      if(nx.lt.nminx .or. nx.gt.nxest) go to 70
      j = nx
      do 30 i=1,kx1
        tx(i) = xb
        tx(j) = xe
        j = j-1
  30  continue
      call fpchec(x,mx,tx,nx,kx,ier)
      if(ier.ne.0) go to 70
      if(ny.lt.nminy .or. ny.gt.nyest) go to 70
      j = ny
      do 40 i=1,ky1
        ty(i) = yb
        ty(j) = ye
        j = j-1
  40  continue
      call fpchec(y,my,ty,ny,ky,ier)
      if(ier) 70,60,70
  50  if(s.lt.0.) go to 70
      if(s.eq.0. .and. (nxest.lt.(mx+kx1) .or. nyest.lt.(my+ky1)) )
     * go to 70
      ier = 0
c  we partition the working space and determine the spline approximation
  60  lfpx = 5
      lfpy = lfpx+nxest
      lww = lfpy+nyest
      jwrk = lwrk-4-nxest-nyest
      knrx = 4
      knry = knrx+mx
      kndx = knry+my
      kndy = kndx+nxest
      call fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
     * tol,maxit,nc,nx,tx,ny,ty,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),
     * wrk(lfpx),wrk(lfpy),iwrk(1),iwrk(2),iwrk(3),iwrk(knrx),
     * iwrk(knry),iwrk(kndx),iwrk(kndy),wrk(lww),jwrk,ier)
  70  return
      end


! { dg-do compile }
! { dg-options "-Wunused-parameter" }
! PR66605
MODULE test
  IMPLICIT NONE
  INTEGER, PARAMETER :: wp = KIND(1.0D0)
CONTAINS
SUBROUTINE sub (neq, time, y, dydt)
  IMPLICIT NONE
    INTEGER :: neq
    REAL(WP) :: time, y(neq), dydt(neq)

    dydt(1) = 1.0 / y(1)
END SUBROUTINE sub
END MODULE


! bounds_forcing.f

! spcify variable boundary conditions, atmospheric forcing, restoring

!_______________________________________________________________________
      subroutine bcond(idx)
! apply open boundary conditions
! closed boundary conditions are automatically enabled through
! specification of the masks, dum, dvm and fsm, in which case the open
! boundary conditions, included below, will be overwritten
      implicit none
      include 'pom.h'
      integer idx
      integer i,j,k
      double precision ga,u1,wm
      double precision hmax

      if(idx.eq.1) then

! External (2-D) elevation boundary conditions (Clamped)
        if(n_west.eq.-1) then
!          elf(1,:) = elw
          elf(1,:) = elf(2,:)
        end if
        if(n_east.eq.-1) then
!          elf(im,:) = ele
          elf(im,:) = elf(imm1,:)
        end if

        if(n_south.eq.-1) then
!          elf(:,1) = els
          elf(:,1) = elf(:,2)
        end if
        if(n_north.eq.-1) then
!          elf(:,jm) = eln
          elf(:,jm) = elf(:,jmm1)
        end if

        elf = elf*fsm

        return

      else if(idx.eq.2) then

! external (2-D) velocity boundary conditions
        ! west
        if(n_west.eq.-1) then
          uaf(2,2:jmm1) = uabw(2:jmm1)
     $            -rfw*sqrt(grav/d(2,2:jmm1))*(el(2,2:jmm1)-elw(2:jmm1))
          uaf(2,2:jmm1) = ramp*uaf(2,2:jmm1)
          uaf(1,2:jmm1) = uaf(2,2:jmm1)
          vaf(1,2:jmm1) = vabw(2:jmm1)
        end if

        ! east
        if(n_east.eq.-1) then
          uaf(im,2:jmm1) = uabe(2:jmm1)
     $      +rfe*sqrt(grav/d(imm1,2:jmm1))*(el(imm1,2:jmm1)-ele(2:jmm1))
          uaf(im,2:jmm1) = ramp*uaf(im,2:jmm1)
          vaf(im,2:jmm1) = vabe(2:jmm1)
        end if

        ! south
        if(n_south.eq.-1) then
          vaf(2:imm1,2) = vabs(2:imm1)
     $            -rfs*sqrt(grav/d(2:imm1,2))*(el(2:imm1,2)-els(2:imm1))
          vaf(2:imm1,2) = ramp*vaf(2:imm1,2)
          vaf(2:imm1,1) = vaf(2:imm1,2)
          uaf(2:imm1,1) = uabs(2:imm1)
        end if

        ! north
        if(n_north.eq.-1) then
          vaf(2:imm1,jm) = vabn(2:imm1)
     $      +rfn*sqrt(grav/d(2:imm1,jmm1))*(el(2:imm1,jmm1)-eln(2:imm1))
          vaf(2:imm1,jm) = ramp*vaf(2:imm1,jm)
          uaf(2:imm1,jm) = uabn(2:imm1)
        end if

        uaf = uaf*dum
        vaf = vaf*dvm

        return

      else if(idx.eq.3) then

! internal (3-D) velocity boundary conditions
! radiation conditions
! smoothing is used in the direction tangential to the boundaries
        hmax=maxval(d) !4500.d0

        do k=1,kbm1
          do j=2,jmm1
            ! east
            if(n_east.eq.-1) then
              ga=sqrt(d(im,j)/hmax)
              uf(im,j,k)=ga*(.25d0*u(imm1,j-1,k)+.5d0*u(imm1,j,k)
     $                       +.25d0*u(imm1,j+1,k))
     $                    +(1.d0-ga)*(.25d0*ube(j-1,k)+.5d0*ube(j,k)
     $                      +.25d0*ube(j+1,k))
              vf(im,j,k)=vbe(j,k)
            end if
            ! west
            if(n_west.eq.-1) then
              ga=sqrt(d(1,j)/hmax)
              uf(2,j,k)=ga*(.25d0*u(3,j-1,k)+.5d0*u(3,j,k)
     $                      +.25d0*u(3,j+1,k))
     $                   +(1.d0-ga)*(.25d0*ubw(j-1,k)+.5d0*ubw(j,k)
     $                     +.25d0*ubw(j+1,k))
              uf(1,j,k)=uf(2,j,k)
              vf(1,j,k)=vbw(j,k)
            end if
          end do
        end do

        do k=1,kbm1
          do i=2,imm1
            ! south
            if(n_south.eq.-1) then
              ga=sqrt(d(i,1)/hmax)
              vf(i,2,k)=ga*(.25d0*v(i-1,3,k)+.5d0*v(i,3,k)
     $                      +.25d0*v(i+1,3,k))
     $                   +(1.d0-ga)*(.25d0*vbs(i-1,k)+.5d0*vbs(i,k)
     $                     +.25d0*vbs(i+1,k))
              vf(i,1,k)=vf(i,2,k)
              uf(i,1,k)=ubs(i,k)
            end if
            ! north
            if(n_north.eq.-1) then
              ga=sqrt(d(i,jm)/hmax)
              vf(i,jm,k)=ga*(.25d0*v(i-1,jmm1,k)+.5d0*v(i,jmm1,k)
     $                       +.25d0*v(i+1,jmm1,k))
     $                    +(1.d0-ga)*(.25d0*vbn(i-1,k)+.5d0*vbn(i,k)
     $                      +.25d0*vbn(i+1,k))
              uf(i,jm,k)=ubn(i,k)
            end if
          end do
        end do

        do k=1,kbm1
          do j=1,jm
            do i=1,im
              uf(i,j,k)=uf(i,j,k)*dum(i,j)
              vf(i,j,k)=vf(i,j,k)*dvm(i,j)
            end do
          end do
        end do

        return

      else if(idx.eq.4) then

! temperature and salinity boundary conditions (using uf and vf,
! respectively)
        do k=1,kbm1
          do j=1,jm
            ! east
            if(n_east.eq.-1) then
              u1=2.d0*u(im,j,k)*dti/(dx(im,j)+dx(imm1,j))
              if(u1.le.0.d0) then
                uf(im,j,k)=t(im,j,k)-u1*(tbe(j,k)-t(im,j,k))
                vf(im,j,k)=s(im,j,k)-u1*(sbe(j,k)-s(im,j,k))
              else
                uf(im,j,k)=t(im,j,k)-u1*(t(im,j,k)-t(imm1,j,k))
                vf(im,j,k)=s(im,j,k)-u1*(s(im,j,k)-s(imm1,j,k))
                if(k.ne.1.and.k.ne.kbm1) then
                  wm=.5d0*(w(imm1,j,k)+w(imm1,j,k+1))*dti
     $                /((zz(k-1)-zz(k+1))*dt(imm1,j))
                  uf(im,j,k)=uf(im,j,k)-wm*(t(imm1,j,k-1)-t(imm1,j,k+1))
                  vf(im,j,k)=vf(im,j,k)-wm*(s(imm1,j,k-1)-s(imm1,j,k+1))
                endif
              end if
            end if

            ! west
            if(n_west.eq.-1) then
              u1=2.d0*u(2,j,k)*dti/(dx(1,j)+dx(2,j))
              if(u1.ge.0.d0) then
                uf(1,j,k)=t(1,j,k)-u1*(t(1,j,k)-tbw(j,k))
                vf(1,j,k)=s(1,j,k)-u1*(s(1,j,k)-sbw(j,k))
              else
                uf(1,j,k)=t(1,j,k)-u1*(t(2,j,k)-t(1,j,k))
                vf(1,j,k)=s(1,j,k)-u1*(s(2,j,k)-s(1,j,k))
                if(k.ne.1.and.k.ne.kbm1) then
                  wm=.5d0*(w(2,j,k)+w(2,j,k+1))*dti
     $                /((zz(k-1)-zz(k+1))*dt(2,j))
                  uf(1,j,k)=uf(1,j,k)-wm*(t(2,j,k-1)-t(2,j,k+1))
                  vf(1,j,k)=vf(1,j,k)-wm*(s(2,j,k-1)-s(2,j,k+1))
                end if
              end if
            end if
          end do

          do i=1,im
            ! south
            if(n_south.eq.-1) then
              u1=2.d0*v(i,2,k)*dti/(dy(i,1)+dy(i,2))
              if(u1.ge.0.d0) then
                uf(i,1,k)=t(i,1,k)-u1*(t(i,1,k)-tbs(i,k))
                vf(i,1,k)=s(i,1,k)-u1*(s(i,1,k)-sbs(i,k))
              else
                uf(i,1,k)=t(i,1,k)-u1*(t(i,2,k)-t(i,1,k))
                vf(i,1,k)=s(i,1,k)-u1*(s(i,2,k)-s(i,1,k))
                if(k.ne.1.and.k.ne.kbm1) then
                  wm=.5d0*(w(i,2,k)+w(i,2,k+1))*dti
     $                /((zz(k-1)-zz(k+1))*dt(i,2))
                  uf(i,1,k)=uf(i,1,k)-wm*(t(i,2,k-1)-t(i,2,k+1))
                  vf(i,1,k)=vf(i,1,k)-wm*(s(i,2,k-1)-s(i,2,k+1))
                end if
              end if
            end if

            ! north
            if(n_north.eq.-1) then
              u1=2.d0*v(i,jm,k)*dti/(dy(i,jm)+dy(i,jmm1))
              if(u1.le.0.d0) then
                uf(i,jm,k)=t(i,jm,k)-u1*(tbn(i,k)-t(i,jm,k))
                vf(i,jm,k)=s(i,jm,k)-u1*(sbn(i,k)-s(i,jm,k))
              else
                uf(i,jm,k)=t(i,jm,k)-u1*(t(i,jm,k)-t(i,jmm1,k))
                vf(i,jm,k)=s(i,jm,k)-u1*(s(i,jm,k)-s(i,jmm1,k))
                if(k.ne.1.and.k.ne.kbm1) then
                  wm=.5d0*(w(i,jmm1,k)+w(i,jmm1,k+1))*dti
     $                /((zz(k-1)-zz(k+1))*dt(i,jmm1))
                  uf(i,jm,k)=uf(i,jm,k)-wm*(t(i,jmm1,k-1)-t(i,jmm1,k+1))
                  vf(i,jm,k)=vf(i,jm,k)-wm*(s(i,jmm1,k-1)-s(i,jmm1,k+1))
                end if
              end if
            end if
          end do
        end do

        do k=1,kbm1
          do j=1,jm
            do i=1,im
              uf(i,j,k)=uf(i,j,k)*fsm(i,j)
              vf(i,j,k)=vf(i,j,k)*fsm(i,j)
            end do
          end do
        end do

        return

      else if(idx.eq.5) then

! vertical velocity boundary conditions
        do k=1,kbm1
          do j=1,jm
            do i=1,im
              w(i,j,k)=w(i,j,k)*fsm(i,j)
            end do
          end do
        end do

        return

      else if(idx.eq.6) then

! q2 and q2l boundary conditions

        do k=1,kb
          do j=1,jm
            ! west
            if(n_west.eq.-1) then
              u1=2.d0*u(2,j,k)*dti/(dx(1,j)+dx(2,j))
              if(u1.ge.0.d0) then
                uf(1,j,k)=q2(1,j,k)-u1*(q2(1,j,k)-small)
                vf(1,j,k)=q2l(1,j,k)-u1*(q2l(1,j,k)-small)
              else
                uf(1,j,k)=q2(1,j,k)-u1*(q2(2,j,k)-q2(1,j,k))
                vf(1,j,k)=q2l(1,j,k)-u1*(q2l(2,j,k)-q2l(1,j,k))
              end if
            end if

            ! east
            if(n_east.eq.-1) then
              u1=2.d0*u(im,j,k)*dti/(dx(im,j)+dx(imm1,j))
              if(u1.le.0.d0) then
                uf(im,j,k)=q2(im,j,k)-u1*(small-q2(im,j,k))
                vf(im,j,k)=q2l(im,j,k)-u1*(small-q2l(im,j,k))
              else
                uf(im,j,k)=q2(im,j,k)-u1*(q2(im,j,k)-q2(imm1,j,k))
                vf(im,j,k)=q2l(im,j,k)-u1*(q2l(im,j,k)-q2l(imm1,j,k))
              end if
            end if
          end do

          do i=1,im
            ! south
            if(n_south.eq.-1) then
              u1=2.d0*v(i,2,k)*dti/(dy(i,1)+dy(i,2))
              if(u1.ge.0.d0) then
                uf(i,1,k)=q2(i,1,k)-u1*(q2(i,1,k)-small)
                vf(i,1,k)=q2l(i,1,k)-u1*(q2l(i,1,k)-small)
              else
                uf(i,1,k)=q2(i,1,k)-u1*(q2(i,2,k)-q2(i,1,k))
                vf(i,1,k)=q2l(i,1,k)-u1*(q2l(i,2,k)-q2l(i,1,k))
              end if
            end if

            ! north
            if(n_north.eq.-1) then
              u1=2.d0*v(i,jm,k)*dti/(dy(i,jm)+dy(i,jmm1))
              if(u1.le.0.d0) then
                uf(i,jm,k)=q2(i,jm,k)-u1*(small-q2(i,jm,k))
                vf(i,jm,k)=q2l(i,jm,k)-u1*(small-q2l(i,jm,k))
              else
                uf(i,jm,k)=q2(i,jm,k)-u1*(q2(i,jm,k)-q2(i,jmm1,k))
                vf(i,jm,k)=q2l(i,jm,k)-u1*(q2l(i,jm,k)-q2l(i,jmm1,k))
              end if
            end if
          end do
        end do

        do k=1,kb
          do j=1,jm
            do i=1,im
              uf(i,j,k)=uf(i,j,k)*fsm(i,j)+1.d-10
              vf(i,j,k)=vf(i,j,k)*fsm(i,j)+1.d-10
            end do
          end do
        end do

        return

      endif

      end

!_______________________________________________________________________
      subroutine bcondorl(idx)
! this is an optional subroutine replacing  bcond and using Orlanski's
! scheme (J. Comp. Phys. 21, 251-269, 1976), specialized for the
! seamount problem
      implicit none
      include 'pom.h'
      integer idx
      double precision cl,denom
!      double precision ar,eps
      integer i,j,k

      if(idx.eq.1) then

! external (2-D) elevation boundary conditions
        if(n_west.eq.-1) elf(1,:)=elf(2,:)
        if(n_east.eq.-1) elf(im,:)=elf(imm1,:)

        elf = elf*fsm

        return

      else if(idx.eq.2) then

! external (2-D) velocity  boundary conditions
        do j=2,jmm1
          ! east
          if(n_east.eq.-1) then
            denom=(uaf(im-1,j)+uab(im-1,j)-2.d0*ua(im-2,j))
            if(denom.eq.0.0d0)denom=0.01d0
            cl=(uab(im-1,j)-uaf(im-1,j))/denom
            if(cl.gt.1.d0) cl=1.d0
            if(cl.lt.0.d0) cl=0.d0
            uaf(im,j)=(uab(im,j)*(1.d0-cl)+2.d0*cl*ua(im-1,j))
     $                  /(1.d0+cl)
            vaf(im,j)=0.d0
          end if

          ! west
          if(n_west.eq.-1) then
            denom=(uaf(3,j)+uab(3,j)-2.d0*ua(4,j))
            if(denom.eq.0.0d0)denom=0.01d0
            cl=(uab(3,j)-uaf(3,j))/denom
            if(cl.gt.1.d0) cl=1.d0
            if(cl.lt.0.d0) cl=0.d0
            uaf(2,j)=(uab(2,j)*(1.d0-cl)+2.d0*cl*ua(3,j))
     $                 /(1.d0+cl)
            uaf(1,j)=uaf(2,j)
            vaf(1,j)=0.d0
          end if
        end do

        do i=2,imm1
          ! south
          if(n_south.eq.-1) then
            denom=(vaf(i,3)+vab(i,3)-2.d0*va(i,4))
            if(denom.eq.0.0d0)denom=0.01d0
            cl=(vab(i,3)-vaf(i,3))/denom
            if(cl.gt.1.d0) cl=1.d0
            if(cl.lt.0.d0) cl=0.d0
            vaf(i,2)=(vab(i,2)*(1.d0-cl)+2.d0*cl*va(i,3))
     $                 /(1.d0+cl)
            vaf(i,1)=vaf(i,2)
            uaf(i,1)=0.d0
          end if

          ! north
          if(n_north.eq.-1) then
            denom=(vaf(i,jm-1)+vab(i,jm-1)-2.d0*va(i,jm-2))
            if(denom.eq.0.0d0)denom=0.01d0
            cl=(vab(i,jm-1)-vaf(i,jm-1))/denom
            if(cl.gt.1.d0) cl=1.d0
            if(cl.lt.0.d0) cl=0.d0
            vaf(i,jm)=(vab(i,jm)*(1.d0-cl)+2.d0*cl*va(i,jm-1))
     $                  /(1.d0+cl)
            uaf(i,jm)=0.d0
          end if
        end do

        do j=1,jm
          do i=1,im
            uaf(i,j)=uaf(i,j)*dum(i,j)
            vaf(i,j)=vaf(i,j)*dvm(i,j)
          end do
        end do

        return

      else if(idx.eq.3) then

! internal (3-D) velocity boundary conditions

        do k=1,kbm1
          do j=2,jmm1
            ! east
            if(n_east.eq.-1) then
              denom=(uf(im-1,j,k)+ub(im-1,j,k)-2.d0*u(im-2,j,k))
              if(denom.eq.0.d0)denom=0.01d0
              cl=(ub(im-1,j,k)-uf(im-1,j,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              uf(im,j,k)=(ub(im,j,k)*(1.d0-cl)+2.d0*cl*u(im-1,j,k))
     $                    /(1.d0+cl)
              vf(im,j,k)=0.d0
            end if

            ! west
            if(n_west.eq.-1) then
              denom=(uf(3,j,k)+ub(3,j,k)-2.d0*u(4,j,k))
              if(denom.eq.0.d0)denom=0.01d0
              cl=(ub(3,j,k)-uf(3,j,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              uf(2,j,k)=(ub(2,j,k)*(1.d0-cl)+2.d0*cl*u(3,j,k))
     $                   /(1.d0+cl)
              uf(1,j,k)=uf(2,j,k)
              vf(1,j,k)=0.d0
            end if
          end do

          do i=2,imm1
            ! south
            if(n_south.eq.-1) then
              denom=(vf(i,3,k)+vb(i,3,k)-2.d0*v(i,4,k))
              if(abs(denom).eq.0.0d0)denom=0.01d0
              cl=(vb(i,3,k)-vf(i,3,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              vf(i,2,k)=(vb(i,2,k)*(1.d0-cl)+2.d0*cl*v(i,3,k))
     $                   /(1.d0+cl)
              vf(i,1,k)=vf(i,2,k)
              uf(i,1,k)=0.d0
            end if

            ! north
            if(n_north.eq.-1) then
              denom=(vf(i,jm-1,k)+vb(i,jm-1,k)-2.d0*v(i,jm-2,k))
              if(abs(denom).eq.0.0d0)denom=0.01d0
              cl=(vb(i,jm-1,k)-vf(i,jm-1,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              vf(i,jm,k)=(vb(i,jm,k)*(1.d0-cl)+2.d0*cl*v(i,jm-1,k))
     $                    /(1.d0+cl)
              uf(i,jm,k)=0.d0
            end if
          end do
        end do

        do k=1,kbm1
          do j=1,jm
            do i=1,im
              uf(i,j,k)=uf(i,j,k)*dum(i,j)
              vf(i,j,k)=vf(i,j,k)*dvm(i,j)
            end do
          end do
        end do

        return

      else if(idx.eq.4) then

! temperature and salinity boundary conditions (using uf and vf,
! respectively)
        do k=1,kbm1
          do j=1,jm
            ! east
            if(n_east.eq.-1) then
              ube(j,k)=ub(im,j,k)
              denom=(uf(im-1,j,k)+tb(im-1,j,k)-2.d0*t(im-2,j,k))
              if(denom.eq.0.d0) denom=0.01d0
              cl=(tb(im-1,j,k)-uf(im-1,j,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              uf(im,j,k)=(tb(im,j,k)*(1.d0-cl)+2.d0*cl*t(im-1,j,k))
     $                    /(1.d0+cl)
              if(cl.eq.0.d0.and.ube(j,k).le.0.d0) uf(im,j,k)=tbe(j,k)

              denom=(vf(im-1,j,k)+sb(im-1,j,k)-2.d0*s(im-2,j,k))
              if(denom.eq.0.d0) denom=0.01d0
              cl=(sb(im-1,j,k)-vf(im-1,j,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              vf(im,j,k)=(sb(im,j,k)*(1.d0-cl)+2.d0*cl*s(im-1,j,k))
     $                    /(1.d0+cl)
              if(cl.eq.0.d0.and.ube(j,k).le.0.d0) vf(im,j,k)=sbe(j,k)
            end if

            ! west
            if(n_west.eq.-1) then
              ubw(j,k)=ub(2,j,k)
              denom=(uf(2,j,k)+tb(2,j,k)-2.d0*t(3,j,k))
              if(denom.eq.0.d0) denom=0.01d0
              cl=(tb(2,j,k)-uf(2,j,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              uf(1,j,k)=(tb(1,j,k)*(1.d0-cl)+2.d0*cl*t(2,j,k))/(1.d0+cl)
              if(cl.eq.0.d0.and.ubw(j,k).ge.0.d0) uf(1,j,k)=tbw(j,k)

              denom=(vf(2,j,k)+sb(2,j,k)-2.d0*s(3,j,k))
              if(denom.eq.0.d0) denom=0.01d0
              cl=(sb(2,j,k)-vf(2,j,k))/denom
              if(cl.gt.1.d0) cl=1.d0
              if(cl.lt.0.d0) cl=0.d0
              vf(1,j,k)=(sb(1,j,k)*(1.d0-cl)+2.d0*cl*s(2,j,k))/(1.d0+cl)
              if(cl.eq.0.d0.and.ubw(j,k).ge.0.d0) vf(1,j,k)=sbw(j,k)
            end if
          end do
        end do

        do k=1,kbm1
          do j=1,jm
            do i=1,im
              uf(i,j,k)=uf(i,j,k)*fsm(i,j)
              vf(i,j,k)=vf(i,j,k)*fsm(i,j)
            end do
          end do
        end do

        return

      else if(idx.eq.5) then

! vertical velocity boundary conditions
        do k=1,kbm1
          do j=1,jm
            do i=1,im
              w(i,j,k)=w(i,j,k)*fsm(i,j)
            end do
          end do
        end do

        return

      else if(idx.eq.6) then

! q2 and q2l boundary conditions
        do k=1,kb
          do j=1,jm
            if(n_east.eq.-1) then
              uf(im,j,k)=1.d-10
              vf(im,j,k)=1.d-10
            end if
            if(n_west.eq.-1) then
              uf(1,j,k)=1.d-10
              vf(1,j,k)=1.d-10
            end if
          end do

          do j=1,jm
            do i=1,im
              uf(i,j,k)=uf(i,j,k)*fsm(i,j)
              vf(i,j,k)=vf(i,j,k)*fsm(i,j)
            end do
          end do
        end do

        return

      endif

      end

! _____________________________________________________________________
      subroutine lateral_bc
! create variable lateral boundary conditions
      implicit none
      include 'pom.h'
      integer nz
      parameter(nz=40)
      integer i,j,k,ntime,ibc
      double precision tbc,fold,fnew
!      double precision z0(nz),hs(im,jm)
!      double precision t_w(jm,nz),s_w(jm,nz),t_e(jm,nz),s_e(jm,nz),q,
!     $       t_n(im,nz),s_n(im,nz),t_s(im,nz),s_s(im,nz)
!      double precision ts1(im,jm,nz),ss1(im,jm,nz)
!      double precision ts2(im,jm,kb),ss2(im,jm,kb)

      tbc=1./24. ! time between bc files (days)
      ibc=int(tbc*86400.d0/dti)
      ntime=int(time/tbc)
! read bc data
      ! read initial bc file
      if (iint.eq.1) then
        call read_boundary_conditions_pnetcdf((iint+cont_bry)/ibc+1,kb
     $                         ,tbwf,sbwf,ubwf,vbwf,tbef,sbef,ubef,vbef
     $                         ,tbnf,sbnf,vbnf,ubnf,tbsf,sbsf,vbsf,ubsf
     $                         ,elw,ele,eln,els)
! integrate by depth
        uabwf = 0.
        vabwf = 0.
        uabef = 0.
        vabef = 0.
        uabnf = 0.
        vabnf = 0.
        uabsf = 0.
        vabsf = 0.
        do k = 1,kb
          uabwf(:) = uabwf(:) + ubwf(:,k)*dz(k)
          vabwf(:) = vabwf(:) + vbwf(:,k)*dz(k)
          uabef(:) = uabef(:) + ubef(:,k)*dz(k)
          vabef(:) = vabef(:) + vbef(:,k)*dz(k)
          uabnf(:) = uabnf(:) + ubnf(:,k)*dz(k)
          vabnf(:) = vabnf(:) + vbnf(:,k)*dz(k)
          uabsf(:) = uabsf(:) + ubsf(:,k)*dz(k)
          vabsf(:) = vabsf(:) + vbsf(:,k)*dz(k)
        end do
!  south
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(i,2)
!            do k=1,nz
!              ts1(i,j,k)=t_s(i,k)
!              ss1(i,j,k)=s_s(i,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do i=1,im
!          do k=1,kb
!            !write(52,'(2(i4),e16.7)') i,k,ss2(i,jm/2,k)
!            tbsf(i,k)=ts2(i,jm/2,k)
!            sbsf(i,k)=ss2(i,jm/2,k)
!          end do
!        end do
! north
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(i,jmm1)
!            do k=1,nz
!              ts1(i,j,k)=t_n(i,k)
!              ss1(i,j,k)=s_n(i,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do i=1,im
!          do k=1,kb
!            tbnf(i,k)=ts2(i,jm/2,k)
!            sbnf(i,k)=ss2(i,jm/2,k)
!          end do
!        end do
! east
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(imm1,j)
!            do k=1,nz
!              ts1(i,j,k)=t_e(j,k)
!              ss1(i,j,k)=s_e(j,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do j=1,jm
!          do k=1,kb
!            tbef(j,k)=ts2(im/2,j,k)
!            sbef(j,k)=ss2(im/2,j,k)
!          end do
!        end do
! west
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(2,j)
!            do k=1,nz
!              ts1(i,j,k)=t_w(j,k)
!              ss1(i,j,k)=s_w(j,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do j=1,jm
!          do k=1,kb
!            tbwf(j,k)=ts2(im/2,j,k)
!            sbwf(j,k)=ss2(im/2,j,k)
!          end do
!        end do

      end if
      ! read bc file corresponding to next time
      if (iint.eq.1 .or. mod(iint+cont_bry,ibc).eq.0.) then
        tbwb = tbwf
        sbwb = sbwf
        tbeb = tbef
        sbeb = sbef
        tbnb = tbnf
        sbnb = sbnf
        tbsb = tbsf
        sbsb = sbsf
        uabwb = uabwf
        uabeb = uabef
        vabnb = vabnf
        vabsb = vabsf
        if (iint.ne.iend) then
          call read_boundary_conditions_pnetcdf(
     $                                     (iint+cont_bry+ibc)/ibc+1,kb
     $     ,tbwf,sbwf,ubwf,vbwf,tbef,sbef,ubef,vbef,tbnf,sbnf,vbnf,ubnf
     $                             ,tbsf,sbsf,vbsf,ubsf,elw,ele,eln,els)
! integrate by depth
          uabwf = 0.
          vabwf = 0.
          uabef = 0.
          vabef = 0.
          uabnf = 0.
          vabnf = 0.
          uabsf = 0.
          vabsf = 0.
          do k=1,kb
            uabwf(:) = uabwf(:) + ubwf(:,k)*dz(k)
            vabwf(:) = vabwf(:) + vbwf(:,k)*dz(k)
            uabef(:) = uabef(:) + ubef(:,k)*dz(k)
            vabef(:) = vabef(:) + vbef(:,k)*dz(k)
            uabnf(:) = uabnf(:) + ubnf(:,k)*dz(k)
            vabnf(:) = vabnf(:) + vbnf(:,k)*dz(k)
            uabsf(:) = uabsf(:) + ubsf(:,k)*dz(k)
            vabsf(:) = vabsf(:) + vbsf(:,k)*dz(k)
          end do
! south
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(i,2)
!            do k=1,nz
!              ts1(i,j,k)=t_s(i,k)
!              ss1(i,j,k)=s_s(i,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do i=1,im
!          do k=1,kb
!            tbsf(i,k)=ts2(i,jm/2,k)
!            sbsf(i,k)=ss2(i,jm/2,k)
!          end do
!        end do
! north
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(i,jmm1)
!            do k=1,nz
!              ts1(i,j,k)=t_n(i,k)
!              ss1(i,j,k)=s_n(i,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do i=1,im
!          do k=1,kb
!            tbnf(i,k)=ts2(i,jm/2,k)
!            sbnf(i,k)=ss2(i,jm/2,k)
!          end do
!        end do
! east
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(imm1,j)
!            do k=1,nz
!              ts1(i,j,k)=t_e(j,k)
!              ss1(i,j,k)=s_e(j,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do j=1,jm
!          do k=1,kb
!            tbef(j,k)=ts2(im/2,j,k)
!            sbef(j,k)=ss2(im/2,j,k)
!          end do
!        end do
! west
!        do i=1,im
!          do j=1,jm
!            hs(i,j)=h(2,j)
!            do k=1,nz
!              ts1(i,j,k)=t_w(j,k)
!              ss1(i,j,k)=s_w(j,k)
!            end do
!          end do
!        end do
!        call ztosig(z0,ts1,zz,hs,ts2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call ztosig(z0,ss1,zz,hs,ss2,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        do j=1,jm
!          do k=1,kb
!            tbwf(j,k)=ts2(im/2,j,k)
!            sbwf(j,k)=ss2(im/2,j,k)
!          end do
!        end do
! end
        end if
      end if

! linear interpolation in time
      fnew=time/tbc-real(ntime, 8)
      fold=1.-fnew
      tbw(1:jm,1:kb) = fold*tbwb(1:jm,1:kb)+fnew*tbwf(1:jm,1:kb)
      sbw(1:jm,1:kb) = fold*sbwb(1:jm,1:kb)+fnew*sbwf(1:jm,1:kb)
      ubw(1:jm,1:kb) = fold*ubwb(1:jm,1:kb)+fnew*ubwf(1:jm,1:kb)
      tbe(1:jm,1:kb) = fold*tbeb(1:jm,1:kb)+fnew*tbef(1:jm,1:kb)
      sbe(1:jm,1:kb) = fold*sbeb(1:jm,1:kb)+fnew*sbef(1:jm,1:kb)
      ube(1:jm,1:kb) = fold*ubeb(1:jm,1:kb)+fnew*ubef(1:jm,1:kb)
      tbn(1:im,1:kb) = fold*tbnb(1:im,1:kb)+fnew*tbnf(1:im,1:kb)
      sbn(1:im,1:kb) = fold*sbnb(1:im,1:kb)+fnew*sbnf(1:im,1:kb)
      vbn(1:im,1:kb) = fold*vbnb(1:im,1:kb)+fnew*vbnf(1:im,1:kb)
      tbs(1:im,1:kb) = fold*tbsb(1:im,1:kb)+fnew*tbsf(1:im,1:kb)
      sbs(1:im,1:kb) = fold*sbsb(1:im,1:kb)+fnew*sbsf(1:im,1:kb)
      vbs(1:im,1:kb) = fold*vbsb(1:im,1:kb)+fnew*vbsf(1:im,1:kb)
      uabe = 0.
      uabw = 0.
      vabn = 0.
      vabs = 0.
      do k=1,kb
        uabe(1:jm) = uabe(1:jm) + ube(1:jm,k)*dz(k)
        uabw(1:jm) = uabw(1:jm) + ubw(1:jm,k)*dz(k)
        vabn(1:im) = vabn(1:im) + vbn(1:im,k)*dz(k)
        vabs(1:im) = vabs(1:im) + vbs(1:im,k)*dz(k)
      end do

      return
      end

!_______________________________________________________________________
      subroutine wind
! read and interpolate (in time) wind stress
      implicit none
      include 'pom.h'
      integer i,j,ntime,iwind
      double precision twind,fold,fnew
      double precision, dimension(im,jm) :: wu, wv

      twind= .125!30. ! time between wind files (days)
      iwind=int(twind*86400.d0/dti)

! read wind stress data
      ! read initial wind file
      if (iint.eq.1) then
        call read_wind_pnetcdf((iint+cont_bry)/iwind+1,wu,wv)
        wusurff(1:im,1:jm) = wu
        wvsurff(1:im,1:jm) = wv
      end if
      ! read wind file corresponding to next time
      if (iint.eq.1 .or. mod(iint+cont_bry,iwind).eq.0.) then
        do i=1,im
          do j=1,jm
            wusurfb(i,j)=wusurff(i,j)
            wvsurfb(i,j)=wvsurff(i,j)
          end do
        end do
        if (iint.ne.iend) then
          call read_wind_pnetcdf((iint+cont_bry+iwind)/iwind+1,wu,wv)
          wusurff(1:im,1:jm) = wu
          wvsurff(1:im,1:jm) = wv
        end if
      end if

! linear interpolation in time
      ntime=int(time/twind)
      fnew=time/twind-ntime
      fold=1.-fnew
      wusurf(1:im,1:jm)=fold*wusurfb(1:im,1:jm)+fnew*wusurff(1:im,1:jm)
      wvsurf(1:im,1:jm)=fold*wvsurfb(1:im,1:jm)+fnew*wvsurff(1:im,1:jm)

      return
      end

!_______________________________________________________________________
      subroutine heat
! read and interpolate heat flux in time
      implicit none
      include 'pom.h'
      integer i,j,ntime,iheat
      double precision theat,fold,fnew
      double precision, dimension(im,jm) :: shf, swr

      theat=.125 ! time between heat forcing (days)
      iheat=int(theat*86400.d0/dti)

! read heat stress data
      ! read initial heat file
      if (iint.eq.1) then
        call read_heat_pnetcdf((iint+cont_bry)/iheat+1,shf,swr)
        wtsurff(1:im,1:jm) = shf
        swradf(1:im,1:jm) = swr
      end if
      ! read heat forcing corresponding to next theat
      if (iint.eq.1 .or. mod(iint+cont_bry,iheat).eq.0.) then
        do i=1,im
          do j=1,jm
            wtsurfb(i,j)=wtsurff(i,j)
            swradb(i,j)=swradf(i,j)
          end do
        end do
        if (iint/=iend) then
          call read_heat_pnetcdf((iint+cont_bry+iheat)/iheat+1,shf,swr)
          wtsurff(1:im,1:jm) = shf
          swradf(1:im,1:jm) = swr
        end if
      end if

! linear interpolation in time
      ntime=int(time/theat)
      fnew=time/theat-ntime
      fold=1.-fnew
      do i=1,im
        do j=1,jm
          wtsurf(i,j)=fold*wtsurfb(i,j)+fnew*wtsurff(i,j)
          swrad(i,j)=fold*swradb(i,j)+fnew*swradf(i,j)
        end do
      end do

      return
      end

!_______________________________________________________________________
      subroutine surface
! read and interpolate heat flux in time
      implicit none
      include 'pom.h'
      integer i,j,ntime,isrf
      double precision tsrf!,fold,fnew
      double precision, dimension(im,jm) :: sst, sss

      tsrf=.125 ! time between heat forcing (days)
      isrf=int(tsrf*86400.d0/dti)

! read heat stress data
      ! read surface fields (no interpolation)
      if (iint.eq.1 .or. mod(iint+cont_bry,isrf).eq.0.) then
        call read_surface_pnetcdf((iint+cont_bry)/isrf+1,sst,sss)
        tsurf(1:im,1:jm) = sst
!        ssurf(1:im,1:jm) = sss ! Do not overwrite SSS yet.
      end if

      return
      end

!_______________________________________________________________________
      subroutine water
! read and interpolate water flux in time
      implicit none
      include 'pom.h'
      integer i,j,ntime,iwater
      double precision twater,fold,fnew

      twater=1. ! time between wind forcing (days)
      iwater=int(twater*86400.d0/dti)

! read wind stress data
      ! read initial water file
      if (iint.eq.1) call read_water_pnetcdf(iint/iwater,wssurff)
      ! read heat forcing corresponding to next twind
      if (iint.eq.1 .or. mod(iint,iwater).eq.0.) then
        do i=1,im
          do j=1,jm
            wssurfb(i,j)=wssurff(i,j)
          end do
        end do
        call read_water_pnetcdf((iint+iwater)/iwater,wssurff)
      end if

! linear interpolation in time
      ntime=int(time/twater)
      fnew=time/twater-ntime
      fold=1.-fnew
      do i=1,im
        do j=1,jm
          wssurf(i,j)=fold*wssurfb(i,j)+fnew*wssurff(i,j)
        end do
      end do

      return
      end

! _____________________________________________________________________
      subroutine restore_interior
! read, interpolate (in time) and apply restore interior data
      implicit none
      include 'pom.h'
      integer nz
      parameter(nz=40)
      double precision z0(nz),tr(im,jm,kb),sr(im,jm,kb)
      integer i,j,k,ntime,irst
      double precision trst,fold,fnew

      trst=30. ! time between restore files (days)
      irst=int(trst*86400.d0/dti)
      ntime=int(time/trst)

! read restore data
      ! read initial restore file
      if (iint.eq.2) then
        call read_restore_ts_interior_pnetcdf((iint/irst)+1,kb,tr,sr)
        trstrf(1:im,1:jm,:) = tr
        srstrf(1:im,1:jm,:) = sr
        taurstrf = 1./trst
!        call ztosig(z0,f0,zz,h,trstrf,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call read_restore_s_interior_pnetcdf(iint/irst,nz,z0,f0)
!        call ztosig(z0,f0,zz,h,srstrf,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!        call read_restore_tau_interior_pnetcdf(iint/irst,nz,z0,f0)
!        call ztosig(z0,f0,zz,h,taurstrf,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
      end if
      ! read restore file corresponding to next time
      if (iint.eq.2 .or. mod(iint,irst).eq.0.) then
        do k=1,kbm1
          do i=1,im
            do j=1,jm
              trstrb(i,j,k)=trstrf(i,j,k)
              srstrb(i,j,k)=srstrf(i,j,k)
              taurstrb(i,j,k)=taurstrf(i,j,k)
            end do
          end do
        end do
        if (iint.ne.iend) then
          call read_restore_ts_interior_pnetcdf((iint+irst)/irst+1,kb,
     $                                                            tr,sr)
          trstrf(1:im,1:jm,:) = tr
          srstrf(1:im,1:jm,:) = sr
          taurstrf = 1./trst
!          call ztosig(z0,f0,zz,h,trstrf,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!          call read_restore_s_interior_pnetcdf((iint+irst)/irst,nz,z0,
!     $                                                               f0)
!          call ztosig(z0,f0,zz,h,srstrf,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
!          call read_restore_tau_interior_pnetcdf((iint+irst)/irst,nz,
!     $                                                            z0,f0)
!          call ztosig(z0,f0,zz,h,taurstrf,im,jm,nz,kb,
!     $                  im_local,jm_local,n_west,n_east,n_south,n_north)
        end if
      end if

! linear interpolation in time
      fnew=time/trst-ntime
      fold=1.-fnew
      do k=1,kbm1
        do i=1,im
          do j=1,jm
            trstr(i,j,k)=fold*trstrb(i,j,k)+fnew*trstrf(i,j,k)
            srstr(i,j,k)=fold*srstrb(i,j,k)+fnew*srstrf(i,j,k)
            taurstr(i,j,k)=fold*taurstrb(i,j,k)+fnew*taurstrf(i,j,k)
          end do
        end do
      end do

! restore
      do k=1,kbm1
        do i=1,im
          do j=1,jm
            t(i,j,k)=t(i,j,k)+2.*dti/86400.*taurstr(i,j,k)*
     $                                           (trstr(i,j,k)-t(i,j,k))
            tb(i,j,k)=tb(i,j,k)+2.*dti/86400.*taurstr(i,j,k)*
     $                                          (trstr(i,j,k)-tb(i,j,k))
            s(i,j,k)=s(i,j,k)+2.*dti/86400.*taurstr(i,j,k)*
     $                                           (srstr(i,j,k)-s(i,j,k))
            sb(i,j,k)=sb(i,j,k)+2.*dti/86400.*taurstr(i,j,k)*
     $                                          (srstr(i,j,k)-sb(i,j,k))
          end do
        end do
      end do

! mask
      do k=1,kbm1
        t(:,:,k)  = t(:,:,k)*fsm
        tb(:,:,k) = tb(:,:,k)*fsm
        s(:,:,k)  = s(:,:,k)*fsm
        sb(:,:,k) = sb(:,:,k)*fsm
      end do

      return
      end