c
c
c ... file rgrd2u.f
c
c     this file contains documentation followed by fortran code for
c     subroutine rgrd2u and additional subroutines.
c
c ... author
c
c     John C. Adams (NCAR 1999)
c
c ... subroutine rgrd2u(nx,ny,p,mx,my,q,intpol,w,lw,iw,liw,ier)
c
c ... purpose
c
c     subroutine rgrd2u interpolates the nx by ny array p onto
c     the mx by my array q.  linear or cubic interpolation is
c     used in each direction (see aargumentintpol).  it is assumed
c     that p and q are values on uniform nx by ny and mx by my grids
c     superimposed on the same rectangle (INCLUDING BOUNDARIES).
c     if p and q are values on nonuniform orthogonal grids and/or
c     if the grid on which q is defined lies within the p grid
c     then subroutine rgrd2 (see file rgrd2.f) should be used.
c
c ... language
c
c     coded in portable FORTRAN77 and FORTRAN90
c
c ... test program
c
c     file trgrd2u.f on regridpack includes a test program for subroutine rgrd2u
c
c
c ... method
c
c     linear or cubic interpolation (see intpol) is used in each
c     direction for which the q grid is not a subgrid of the p grid.
c     [the mx (my) uniform grid is a subgrid of the nx (ny) uniform
c     grid if and only if mx-1 (my-1) divides nx-1 (ny-1)].
c     values are set directly without (the need for) interpolation
c     in subgrid directions.
c
c ... required files
c
c     file rgrd1u.f must be loaded with rgrd2u.f.  it includes
c     subroutines called by the routines in rgrd2u.f
c
c ... efficiency
c
c     inner most loops in regridpack software vectorize.  If
c     the arguments mx,my (see below) have different values, optimal
c     vectorization will be achieved if mx > my.
c
c
c *** input arguments ***
c
c
c ... nx
c
c     the integer first dimension of p.  nx > 1 if intpol(1) = 1 or
c     nx > 3 if intpol(1) = 3 is required (see ier = 2).
c
c ... ny
c
c     the integer second dimension of p.  ny > 1 if intpol(2) = 1 or
c     ny > 3 if intpol(2) = 3 is required (see ier = 2).
c
c ... p
c
c     a real nx by ny array of given values
c
c ... mx
c
c     the integer first dimension of q.  mx > 1 is required (see ier = 1)
c
c ... my
c
c     the integer second dimension of q. my > 1 is required (see ier = 1)
c
c ... intpol
c
c     an integer vector of dimension 2 which sets linear or cubic
c     interpolation in each of the x,y directions as follows:
c
c        intpol(1) = 1 sets linear interpolation in the x direction
c        intpol(1) = 3 sets cubic interpolation in the x direction.
c
c        intpol(2) = 1 sets linear interpolation in the y direction
c        intpol(2) = 3 sets cubic interpolation in the y direction.
c
c     values other than 1 or 3 in intpol are not allowed (ier = 3).
c
c ... w
c
c     a real work space of length at least lw which must be provided in the
c     routine calling rgrd2u
c
c ... lw
c
c     the integer length of the work space w.
c
c          let lwx = 1 if mx-1 divides nx-1; otherwise
c          let lwx =   mx if intpol(1) = 1 or
c          let lwx = 4*mx if intpol(1) = 3
c
c          let lwy = 0 if my-1 divides ny-1; otherwise
c          let lwy = 2*mx+my if intpol(2) = 1 or
c          let lwy = 4*(mx+my)  if intpol(2) = 3
c
c     then lw must be greater than or equal to lwx+lwy
c
c ... iw
c
c     an integer work space of length at least liw which must be provided in the
c     routine calling rgrd2u
c
c ... liw
c
c     the integer length of the integer work space iw.  liw must be greater than
c     or equal to mx+my.
c
c *** output arguments ***
c
c
c ... q
c
c     a real mx by my array of values which are interpolated from p.
c
c ... ier
c
c     an integer error flag set as follows:
c
c     ier = 0 if no errors in input arguments are detected
c
c     ier = 1 if  min0(mx,my) < 2
c
c     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
c                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3.
c
c     ier = 3 if intpol(1) or intpol(2) is not equal to 1 or 3
c
c     ier = 4 if lw or liw is to small (insufficient work space)
c
c ************************************************************************
c
c     end of rgrd2u documentation, fortran code follows:
c
c ************************************************************************
c
      subroutine rgrd2u(nx,ny,p,mx,my,q,intpol,w,lw,iw,liw,ier)
c
c     two dimensional linear or cubic interpolation of p onto q
c     assuming p and q lie on nx by ny and and mx by my uniform  grids
c     which subdivide the same rectangle (including boundaries)
c
      implicit none
      integer nx,ny,mx,my,intpol(2),lw,liw,ier
      real p(nx,ny),q(mx,my),w(lw)
      integer inmx,jnmy,isubx,jsuby,lwx,lwy,jy,iw(liw)
      integer j2,j3,j4,j5,j6,j7,j8,j9,i2,i3,i4,i5
c
c     check input aarguments
c
      ier = 1
c
c     check mx,my
c
      if (min0(mx,my) .lt. 2) return
c
c     check intpol
c
      ier = 3
      if (intpol(1).ne.1 .and. intpol(1).ne.3) return
      if (intpol(2).ne.1 .and. intpol(2).ne.3) return
c
c     check nx,ny
c
      ier = 2
      if (intpol(1).eq.1 .and. nx.lt.2) return
      if (intpol(1).eq.3 .and. nx.lt.4) return
      if (intpol(2).eq.1 .and. ny.lt.2) return
      if (intpol(2).eq.3 .and. ny.lt.4) return
c
c     set subgrid indicators
c
      inmx = (nx-1)/(mx-1)
      jnmy = (ny-1)/(my-1)
      isubx = nx - inmx*(mx-1)
      jsuby = ny - jnmy*(my-1)
c
c     check work space length input
c
      ier = 4
      lwx = 1
      lwy = 0
      if (isubx.ne.1) then
      if (intpol(1).eq.1) then
      lwx = mx
      else
      lwx = mx
      end if
      end if
      if (jsuby.ne.1) then
      if (intpol(2).eq.1) then
      lwy = (my+2*mx)
      else
      lwy = 4*(mx+my)
      end if
      end if
      if (lw .lt. lwx+lwy) return
      if (liw .lt. mx+my) return
c
c     input arguments o.k.
c
      ier = 0
      jy = mx+1
c
c     preset work space pointers
c
      j2 = 1
      j3 = j2
      j4 = j3
      j5 = j4
      j6 = j5
      j7 = j6
      j8 = j7
      j9 = j8
      i2 = j9
      i3 = i2
      i4 = i3
      i5 = i4

      if (intpol(2) .eq.1) then
c
c     linearly interpolate in y
c
	if (jsuby.ne.1) then
	  j2 = 1
	  j3 = j2
	  j4 = j3+my
	  j5 = j4
	  j6 = j5
	  j7 = j6
	  j8 = j7+mx
	  j9 = j8+mx
c
c     set y interpolation indices and scales and linearly interpolate
c
	  call linmxu(ny,my,iw(jy),w(j3))
	  i2 = j9
	end if
c
c     set work space portion and indices which depend on x interpolation
c
	if (isubx.ne.1) then
	  if (intpol(1) .eq. 1) then
	    i3 = i2
	    i4 = i3
	    i5 = i4
	    call linmxu(nx,mx,iw,w(i3))
	  else
	    i3 = i2+mx
	    i4 = i3+mx
	    i5 = i4+mx
	    call cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
	  end if
	end if
	call lint2u(nx,ny,p,mx,my,q,intpol,iw(jy),w(j3),w(j7),
     +  w(j8),iw,w(i2),w(i3),w(i4),w(i5),inmx,jnmy,isubx,jsuby)
	return

      else
c
c     cubically interpolate in y, set indice pointers
c
	if (jsuby.ne.1) then
	  j2 = 1
	  j3 = j2+my
	  j4 = j3+my
	  j5 = j4+my
	  j6 = j5+my
	  j7 = j6+mx
	  j8 = j7+mx
	  j9 = j8+mx
c
c     set y interpolation indices and scales and cubically interpolate in y
c
	  call cubnmxu(ny,my,iw(jy),w(j2),w(j3),w(j4),w(j5))
	  i2 =  j9+mx
	end if
c
c     set work space portion and indices which depend on x interpolation
c
	if (isubx.ne.1) then
	  if (intpol(1) .eq. 1) then
	    i3 = i2
	    i4 = i3
	    i5 = i4
	    call linmxu(nx,mx,iw,w(i3))
	  else
	    i3 = i2+mx
	    i4 = i3+mx
	    i5 = i4+mx
	    call cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
	  end if
	end if
	call cubt2u(nx,ny,p,mx,my,q,intpol,iw(jy),w(j2),w(j3),w(j4),
     +  w(j5),w(j6),w(j7),w(j8),w(j9),iw,w(i2),w(i3),w(i4),w(i5),
     +  inmx,jnmy,isubx,jsuby)
	return
      end if
      end

      subroutine lint2u(nx,ny,p,mx,my,q,intpol,jy,dy,pj,pjp,ix,dxm,dx,
     +                  dxp,dxpp,inmx,jnmy,isubx,jsuby)
      implicit none
      integer nx,ny,mx,my,intpol(2),jy(my),ix(mx),inmx,jnmy,isubx,jsuby
      integer j,jj,ii,jsave
      real p(nx,ny),q(mx,my)
      real dy(my),pj(mx),pjp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
c
c     linearly interpolate p onto q in y
c
      if (intpol(1) .eq. 1) then
c
c     linear in x
c
	if (jsuby .eq. 1) then
c
c     my grid is subset of ny grid
c
	do jj=1,my
	  j = jnmy*(jj-1)+1
	  call lint1u(nx,p(1,j),mx,q(1,jj),ix,dx,inmx,isubx)
	end do
	return
	end if

	jsave = -1
	do jj=1,my
	j = jy(jj)
	if (j .eq. jsave) then
c
c     pointer has not moved, no interpolation in pj,pjp necessary
c
	else if (j .eq. jsave+1) then
	  do ii=1,mx
	    pj(ii) = pjp(ii)
	  end do
	  call lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
	else
	  call lint1u(nx,p(1,j),mx,pj,ix,dx,inmx,isubx)
	  call lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
	end if
c
c     update pointer
c
	jsave = j
	do ii=1,mx
	  q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
	  end do
	end do

	return

      else
c
c     cubic in x
c
	if (jsuby .eq. 1) then
c
c     my grid is subset of ny grid
c
	  do jj=1,my
	    j = jnmy*(jj-1)+1
	    call cubt1u(nx,p(1,j),mx,q(1,jj),ix,dxm,dx,dxp,dxpp,
     +           inmx,isubx)
	  end do
	  return
	end if

	jsave = -1
	do jj=1,my
	  j = jy(jj)
	  if (j .eq. jsave) then
c
c     no interpolation in pj,pjp necessary
c
	  else if (j .eq. jsave+1) then
	    do ii=1,mx
	      pj(ii) = pjp(ii)
	    end do
	    call cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	  else
	    call cubt1u(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	   call cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp,
     +                 inmx,isubx)
	  end if
c
c     update  pointer
c
	  jsave = j
	  do ii=1,mx
	    q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
	  end do
	end do
	return

      end if

      end

      subroutine cubt2u(nx,ny,p,mx,my,q,intpol,jy,dym,dy,dyp,dypp,
     +pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp,inmx,jnmy,isubx,jsuby)
      implicit none
      integer nx,ny,mx,my,intpol(2),jy(my),ix(mx),inmx,jnmy,isubx,jsuby
      integer j,jj,ii,jsave
      real p(nx,ny),q(mx,my)
      real dym(my),dy(my),dyp(my),dypp(my)
      real pjm(mx),pj(mx),pjp(mx),pjpp(mx)
      real dxm(mx),dx(mx),dxp(mx),dxpp(mx)
c
c     cubically interpolate p onto q in y
c
      if (intpol(1) .eq. 1) then
c
c     linear in x
c
	if (jsuby .eq. 1) then
c
c     my grid is subset of ny grid
c
	  do jj=1,my
	    j = jnmy*(jj-1)+1
	    call lint1u(nx,p(1,j),mx,q(1,jj),ix,dx,inmx,isubx)
	  end do
	  return
	end if

	jsave = -3
	do jj=1,my
	  j = jy(jj)
c
c     load pjm,pj,pjp,pjpp
c
	  if (j.eq.jsave) then
c     no updates or x interpolation necessary
	  else if (j.eq.jsave+1) then
	    do ii=1,mx
	      pjm(ii) = pj(ii)
	      pj(ii) = pjp(ii)
	      pjp(ii) = pjpp(ii)
	    end do
	    call lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
	  else if (j.eq.jsave+2) then
	    do ii=1,mx
	      pjm(ii) = pjp(ii)
	     pj(ii) = pjpp(ii)
	    end do
	    call lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
	    call lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
	  else if (j.eq.jsave+3) then
	    do ii=1,mx
	      pjm(ii) = pjpp(ii)
	    end do
	    call lint1u(nx,p(1,j),mx,pj,ix,dx,inmx,isubx)
	    call lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
	    call lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
	  else
c     load all four (no updates)
	    call lint1u(nx,p(1,j-1),mx,pjm,ix,dx,inmx,isubx)
	    call lint1u(nx,p(1,j),mx,pj,ix,dx,inmx,isubx)
	    call lint1u(nx,p(1,j+1),mx,pjp,ix,dx,inmx,isubx)
	    call lint1u(nx,p(1,j+2),mx,pjpp,ix,dx,inmx,isubx)
	  end if
c
c     update pointer
c
	  jsave = j
	  do ii=1,mx
	    q(ii,jj) = dym(jj)*pjm(ii) + dy(jj)*pj(ii) +
     +                 dyp(jj)*pjp(ii) + dypp(jj)*pjpp(ii)
	  end do
	end do
	return

      else
c
c     cubic in x
c

	if (jsuby .eq. 1) then
c
c     my grid is subset of ny grid
c
	  do jj=1,my
	    j = jnmy*(jj-1)+1
	    call cubt1u(nx,p(1,j),mx,q(1,jj),ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	  end do
	  return
	end if

	jsave = -3
	do jj=1,my
	  j = jy(jj)
c
c     load pjm,pj,pjp,pjpp
c
	  if (j.eq.jsave) then
c     no updates or x interpolation necessary
	  else if (j.eq.jsave+1) then
	    do ii=1,mx
	      pjm(ii) = pj(ii)
	      pj(ii) = pjp(ii)
	      pjp(ii) = pjpp(ii)
	    end do
	    call cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	  else if (j.eq.jsave+2) then
	    do ii=1,mx
	      pjm(ii) = pjp(ii)
	      pj(ii) = pjpp(ii)
	    end do
	    call cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	    call cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	  else if (j.eq.jsave+3) then
	    do ii=1,mx
	      pjm(ii) = pjpp(ii)
	    end do
	    call cubt1u(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	    call cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	    call cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	  else
c     load all four (no updates)
	    call cubt1u(nx,p(1,j-1),mx,pjm,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	    call cubt1u(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	    call cubt1u(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	    call cubt1u(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp,
     +                  inmx,isubx)
	  end if
c
c     update pointer
c
	  jsave = j
	  do ii=1,mx
	    q(ii,jj) = dym(jj)*pjm(ii) + dy(jj)*pj(ii) +
     +                 dyp(jj)*pjp(ii) + dypp(jj)*pjpp(ii)
	  end do
	end do
      return

      end if

      end


      DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG,
     $                                  LDQG, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the value of the one norm, or the Frobenius norm, or
C     the infinity norm, or the element of largest absolute value
C     of a real skew-Hamiltonian matrix
C
C                   [  A   G  ]          T         T
C             X  =  [       T ],   G = -G,   Q = -Q,
C                   [  Q   A  ]
C
C     or of a real Hamiltonian matrix
C
C                   [  A   G  ]          T         T
C             X  =  [       T ],   G =  G,   Q =  Q,
C                   [  Q  -A  ]
C
C     where A, G and Q are real n-by-n matrices.
C
C     Note that for this kind of matrices the infinity norm is equal
C     to the one norm.
C
C     FUNCTION VALUE
C
C     MA02ID  DOUBLE PRECISION
C             The computed norm.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYP     CHARACTER*1
C             Specifies the type of the input matrix X:
C             = 'S':         X is skew-Hamiltonian;
C             = 'H':         X is Hamiltonian.
C
C     NORM    CHARACTER*1
C             Specifies the value to be returned in MA02ID:
C             = '1' or 'O':  one norm of X;
C             = 'F' or 'E':  Frobenius norm of X;
C             = 'I':         infinity norm of X;
C             = 'M':         max(abs(X(i,j)).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     QG      (input) DOUBLE PRECISION array, dimension (LDQG,N+1)
C             On entry, the leading N-by-N+1 part of this array must
C             contain in columns 1:N the lower triangular part of the
C             matrix Q and in columns 2:N+1 the upper triangular part
C             of the matrix G. If TYP = 'S', the parts containing the
C             diagonal and the first supdiagonal of this array are not
C             referenced.
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             where LDWORK >= 2*N when NORM = '1', NORM = 'I' or
C             NORM = 'O'; otherwise, DWORK is not referenced.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLANHA).
C     V. Sima, Jan. 2016 (removed O(N) tests in several loops).
C
C     KEYWORDS
C
C     Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian
C     matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER          NORM, TYP
      INTEGER            LDA, LDQG, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), DWORK(*), QG(LDQG,*)
C     .. Local Scalars ..
      LOGICAL            LSH
      INTEGER            I, J
      DOUBLE PRECISION   DSCL, DSUM, SCALE, SUM, TEMP, VALUE
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLANGE, DLAPY2
      EXTERNAL           DLANGE, DLAPY2, LSAME
C     .. External Subroutines ..
      EXTERNAL           DLASSQ
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
C
C     .. Executable Statements ..
C
      LSH = LSAME( TYP, 'S' )
C
      IF ( N.EQ.0 ) THEN
         VALUE = ZERO
C
      ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN
C
C        Find max(abs(A(i,j))).
C
         VALUE = DLANGE( 'MaxElement', N, N, A, LDA, DWORK )
         IF ( N.GT.1 ) THEN
            DO 30  J = 1, N+1
               DO 10  I = 1, J-2
                  VALUE = MAX( VALUE, ABS( QG(I,J) ) )
   10          CONTINUE
               DO 20  I = J+1, N
                  VALUE = MAX( VALUE, ABS( QG(I,J) ) )
   20          CONTINUE
   30       CONTINUE
         END IF
C
      ELSE IF ( LSAME( NORM, 'M' ) ) THEN
C
C        Find max( abs( A(i,j) ), abs( QG(i,j) ) ).
C
         VALUE = MAX( DLANGE( 'MaxElement', N, N, A, LDA, DWORK ),
     $                DLANGE( 'MaxElement', N, N+1, QG, LDQG,
     $                        DWORK ) )
C
      ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR.
     $            LSAME( NORM, 'I' ) ) .AND. LSH ) THEN
C
C        Find the column and row sums of A (in one pass).
C
         VALUE = ZERO
         DO 40 I = 1, N
            DWORK(I) = ZERO
   40    CONTINUE
C
         DO 60 J = 1, N
            SUM = ZERO
            DO 50 I = 1, N
               TEMP = ABS( A(I,J) )
               SUM  = SUM + TEMP
               DWORK(I) = DWORK(I) + TEMP
   50       CONTINUE
            DWORK(N+J) = SUM
   60    CONTINUE
C
C        Compute the maximal absolute column sum.
C
         DO 90 J = 1, N
            DO 70  I = 1, J-2
               TEMP = ABS( QG(I,J) )
               DWORK(I) = DWORK(I) + TEMP
               DWORK(J-1) = DWORK(J-1) + TEMP
   70       CONTINUE
            SUM = DWORK(N+J)
            DO 80  I = J+1, N
               TEMP = ABS( QG(I,J) )
               SUM  = SUM + TEMP
               DWORK(N+I) = DWORK(N+I) + TEMP
   80       CONTINUE
            VALUE = MAX( VALUE, SUM )
   90    CONTINUE
         DO 100  I = 1, N-1
            TEMP = ABS( QG(I,N+1) )
            DWORK(I) = DWORK(I) + TEMP
            DWORK(N) = DWORK(N) + TEMP
  100    CONTINUE
         DO 110 I = 1, N
            VALUE = MAX( VALUE, DWORK(I) )
  110    CONTINUE
C
      ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR.
     $          LSAME( NORM, 'I' ) ) THEN
C
C        Find the column and row sums of A (in one pass).
C
         VALUE = ZERO
         DO 120 I = 1, N
            DWORK(I) = ZERO
  120   CONTINUE
C
         DO 140 J = 1, N
            SUM = ZERO
            DO 130 I = 1, N
               TEMP = ABS( A(I,J) )
               SUM  = SUM + TEMP
               DWORK(I) = DWORK(I) + TEMP
  130       CONTINUE
            DWORK(N+J) = SUM
  140    CONTINUE
C
C        Compute the maximal absolute column sum.
C
         SUM = DWORK(N+1) + ABS( QG(1,1) )
         DO 150 I = 2, N
            TEMP = ABS( QG(I,1) )
            SUM  = SUM + TEMP
            DWORK(N+I) = DWORK(N+I) + TEMP
  150    CONTINUE
         VALUE = MAX( VALUE, SUM )
         DO 180 J = 2, N
            DO 160  I = 1, J-2
               TEMP = ABS( QG(I,J) )
               DWORK(I) = DWORK(I) + TEMP
               DWORK(J-1) = DWORK(J-1) + TEMP
  160       CONTINUE
            DWORK(J-1) = DWORK(J-1) + ABS( QG(J-1,J) )
            SUM = DWORK(N+J) + ABS( QG(J,J) )
            DO 170 I = J+1, N
               TEMP = ABS( QG(I,J) )
               SUM  = SUM + TEMP
               DWORK(N+I) = DWORK(N+I) + TEMP
  170       CONTINUE
            VALUE = MAX( VALUE, SUM )
  180    CONTINUE
         DO 190  I = 1, J-2
            TEMP = ABS( QG(I,N+1) )
            DWORK(I) = DWORK(I) + TEMP
            DWORK(N) = DWORK(N) + TEMP
  190    CONTINUE
         DWORK(N) = DWORK(N) + ABS( QG(N,N+1) )
         DO 200 I = 1, N
            VALUE = MAX( VALUE, DWORK(I) )
  200    CONTINUE
C
      ELSE IF ( ( LSAME( NORM, 'F' ) .OR.
     $            LSAME( NORM, 'E' ) ) .AND. LSH ) THEN
C
C        Find normF(A).
C
         SCALE = ZERO
         SUM = ONE
         DO 210 J = 1, N
            CALL DLASSQ( N, A(1,J), 1, SCALE, SUM )
  210    CONTINUE
C
C        Add normF(G) and normF(Q).
C
         IF ( N.GT.1 )
     $      CALL DLASSQ( N-1, QG(2,1), 1, SCALE, SUM )
         IF ( N.GT.2 )
     $      CALL DLASSQ( N-2, QG(3,2), 1, SCALE, SUM )
         DO 220 J = 3, N-1
            CALL DLASSQ( J-2, QG(1,J),   1, SCALE, SUM )
            CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM )
  220    CONTINUE
         CALL DLASSQ( N-2, QG(1,N),   1, SCALE, SUM )
         CALL DLASSQ( N-1, QG(1,N+1), 1, SCALE, SUM )
         VALUE = SQRT( TWO )*SCALE*SQRT( SUM )
C
      ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN
C
         SCALE = ZERO
         SUM = ONE
         DO 230 J = 1, N
            CALL DLASSQ( N, A(1,J), 1, SCALE, SUM )
  230    CONTINUE
C
         DSCL = ZERO
         DSUM = ONE
         CALL DLASSQ( 1, QG(1,1), 1, DSCL, DSUM )
         IF ( N.GT.1 )
     $      CALL DLASSQ( N-1, QG(2,1), 1, SCALE, SUM )
         DO 240 J = 2, N
            CALL DLASSQ( J-2, QG(1,J),   1, SCALE, SUM )
            CALL DLASSQ( 2,   QG(J-1,J), 1, DSCL, DSUM )
            CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM )
  240    CONTINUE
         CALL DLASSQ( N-1, QG(1,N+1), 1, SCALE, SUM )
         CALL DLASSQ( 1,   QG(N,N+1), 1, DSCL, DSUM )
         VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ),
     $                   DSCL*SQRT( DSUM ) )
      END IF
C
      MA02ID = VALUE
      RETURN
C *** Last line of MA02ID ***
      END


      SUBROUTINE PERVEC (VX1,VY1,VZ1, VX2,VY2,VZ2, VX3,VY3,VZ3)

C  This subroutine accepts two 3D vectors and returns a vector
C  orthogonal to the first, in the plane of the first two vectors,
C  whose dot product with the second vector is positive, hence
C  the angle between them is < 90 degrees.  I.e. the 2nd vector
C  minus the 3rd results in a vector with the same direction (but
C  not length) as the 1st.  K is the factor by which V1 is
C  multiplied and then subtracted from V2 - i.e.
C
C       V3 = V2 - K*V1

C                     _
C                     /|A
C                   /   |
C                 /     |
C            V2 /       | V3
C             /         |
C           /           |
C         /             |
C       /               |
C      ----------->.....|
C          V1
C      \________________/
C           V2 - V3

C  Or, V1 can be thought of as the attitude numbers for a plane, and
C  then V3 is the result of the normal projection of V2 into the plane.
C
C  Closely related to PTPLDS, which is a slightly more general case.

      REAL  VX1,VY1,VZ1, VX2,VY2,VZ2, VX3,VY3,VZ3, K, DOTPRD, VECL2

      K = DOTPRD (VX1,VY1,VZ1, VX2,VY2,VZ2) / VECL2 (VX1, VY1, VZ1)
      VX3 = VX2 - K*VX1
      VY3 = VY2 - K*VY1
      VZ3 = VZ2 - K*VZ1

      END


      SUBROUTINE HYBSVD(NA, NU, NV, NZ, NB, M, N, A, W, MATU, U, MATV,
     * V, Z, B, IRHS, IERR, RV1)
      INTEGER NA, NU, NV, NZ, M, N, IRHS, IERR, MIN0
      REAL*8 A(NA,1), W(1), U(NU,1), V(NV,1), Z(NZ,1), B(NB,IRHS)
      REAL*8 RV1(1)
      LOGICAL MATU, MATV
C
C     THIS ROUTINE IS A MODIFICATION OF THE GOLUB-REINSCH PROCEDURE (1)
C                                                           T
C     FOR COMPUTING THE SINGULAR VALUE DECOMPOSITION A = UWV  OF A
C     REAL M BY N RECTANGULAR MATRIX. U IS M BY MIN(M,N) CONTAINING
C     THE LEFT SINGULAR VECTORS, W IS A MIN(M,N) BY MIN(M,N) DIAGONAL
C     MATRIX CONTAINING THE SINGULAR VALUES, AND V IS N BY MIN(M,N)
C     CONTAINING THE RIGHT SINGULAR VECTORS.
C
C     THE ALGORITHM IMPLEMENTED IN THIS
C     ROUTINE HAS A HYBRID NATURE.  WHEN M IS APPROXIMATELY EQUAL TO N,
C     THE GOLUB-REINSCH ALGORITHM IS USED, BUT WHEN EITHER OF THE RATIOS
C     M/N OR N/M IS GREATER THAN ABOUT 2,
C     A MODIFIED VERSION OF THE GOLUB-REINSCH
C     ALGORITHM IS USED.  THIS MODIFIED ALGORITHM FIRST TRANSFORMS A
C                                                                T
C     INTO UPPER TRIANGULAR FORM BY HOUSEHOLDER TRANSFORMATIONS L
C     AND THEN USES THE GOLUB-REINSCH ALGORITHM TO FIND THE SINGULAR
C     VALUE DECOMPOSITION OF THE RESULTING UPPER TRIANGULAR MATRIX R.
C     WHEN U IS NEEDED EXPLICITLY IN THE CASE M.GE.N (OR V IN THE CASE
C     M.LT.N), AN EXTRA ARRAY Z (OF SIZE AT LEAST
C     MIN(M,N)**2) IS NEEDED, BUT OTHERWISE Z IS NOT REFERENCED
C     AND NO EXTRA STORAGE IS REQUIRED.  THIS HYBRID METHOD
C     SHOULD BE MORE EFFICIENT THAN THE GOLUB-REINSCH ALGORITHM WHEN
C     M/N OR N/M IS LARGE.  FOR DETAILS, SEE (2).
C
C     WHEN M .GE. N,
C     HYBSVD CAN ALSO BE USED TO COMPUTE THE MINIMAL LENGTH LEAST
C     SQUARES SOLUTION TO THE OVERDETERMINED LINEAR SYSTEM A*X=B.
C     IF M .LT. N (I.E. FOR UNDERDETERMINED SYSTEMS), THE RHS B
C     IS NOT PROCESSED.
C
C     NOTICE THAT THE SINGULAR VALUE DECOMPOSITION OF A MATRIX
C     IS UNIQUE ONLY UP TO THE SIGN OF THE CORRESPONDING COLUMNS
C     OF U AND V.
C
C     THIS ROUTINE HAS BEEN CHECKED BY THE PFORT VERIFIER (3) FOR
C     ADHERENCE TO A LARGE, CAREFULLY DEFINED, PORTABLE SUBSET OF
C     AMERICAN NATIONAL STANDARD FORTRAN CALLED PFORT.
C
C     REFERENCES:
C
C     (1) GOLUB,G.H. AND REINSCH,C. (1970) 'SINGULAR VALUE
C         DECOMPOSITION AND LEAST SQUARES SOLUTIONS,'
C         NUMER. MATH. 14,403-420, 1970.
C
C     (2) CHAN,T.F. (1982) 'AN IMPROVED ALGORITHM FOR COMPUTING
C         THE SINGULAR VALUE DECOMPOSITION,' ACM TOMS, VOL.8,
C         NO. 1, MARCH, 1982.
C
C     (3) RYDER,B.G. (1974) 'THE PFORT VERIFIER,' SOFTWARE -
C         PRACTICE AND EXPERIENCE, VOL.4, 359-377, 1974.
C
C     ON INPUT:
C
C        NA MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C          ARRAY PARAMETER A AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.  NOTE THAT NA MUST BE AT LEAST
C          AS LARGE AS M.
C
C        NU MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C          ARRAY U AS DECLARED IN THE CALLING PROGRAM DIMENSION
C          STATEMENT. NU MUST BE AT LEAST AS LARGE AS M.
C
C        NV MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C          ARRAY PARAMETER V AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT. NV MUST BE AT LEAST AS LARGE AS N.
C
C        NZ MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C          ARRAY PARAMETER Z AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.  NOTE THAT NZ MUST BE AT LEAST
C          AS LARGE AS MIN(M,N).
C
C        NB MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C          ARRAY PARAMETER B AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT. NB MUST BE AT LEAST AS LARGE AS M.
C
C        M IS THE NUMBER OF ROWS OF A (AND U).
C
C        N IS THE NUMBER OF COLUMNS OF A (AND NUMBER OF ROWS OF V).
C
C        A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED.
C
C        B CONTAINS THE IRHS RIGHT-HAND-SIDES OF THE OVERDETERMINED
C         LINEAR SYSTEM A*X=B. IF IRHS .GT. 0 AND M .GE. N,
C         THEN ON OUTPUT, THE FIRST N COMPONENTS OF THESE IRHS COLUMNS
C                       T
C         WILL CONTAIN U B. THUS, TO COMPUTE THE MINIMAL LENGTH LEAST
C                                               +
C         SQUARES SOLUTION, ONE MUST COMPUTE V*W  TIMES THE COLUMNS OF
C                   +                        +
C         B, WHERE W  IS A DIAGONAL MATRIX, W (I)=0 IF W(I) IS
C         NEGLIGIBLE, OTHERWISE IS 1/W(I). IF IRHS=0 OR M.LT.N,
C         B IS NOT REFERENCED.
C
C        IRHS IS THE NUMBER OF RIGHT-HAND-SIDES OF THE OVERDETERMINED
C         SYSTEM A*X=B. IRHS SHOULD BE SET TO ZERO IF ONLY THE SINGULAR
C         VALUE DECOMPOSITION OF A IS DESIRED.
C
C        MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE
C          DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE.
C
C        MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE
C          DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE.
C
C        WHEN HYBSVD IS USED TO COMPUTE THE MINIMAL LENGTH LEAST
C        SQUARES SOLUTION TO AN OVERDETERMINED SYSTEM, MATU SHOULD
C        BE SET TO .FALSE. , AND MATV SHOULD BE SET TO .TRUE.  .
C
C     ON OUTPUT:
C
C        A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V).
C
C        W CONTAINS THE (NON-NEGATIVE) SINGULAR VALUES OF A (THE
C          DIAGONAL ELEMENTS OF W).  THEY ARE SORTED IN DESCENDING
C          ORDER.  IF AN ERROR EXIT IS MADE, THE SINGULAR VALUES
C          SHOULD BE CORRECT AND SORTED FOR INDICES IERR+1,...,MIN(M,N).
C
C        U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE
C          DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE.  IF MATU IS
C          FALSE, THEN U IS EITHER USED AS A TEMPORARY STORAGE (IF
C          M .GE. N) OR NOT REFERENCED (IF M .LT. N).
C          U MAY COINCIDE WITH A IN THE CALLING SEQUENCE.
C          IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING
C          TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT.
C
C        V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF
C          MATV HAS BEEN SET TO .TRUE.  IF MATV IS
C          FALSE, THEN V IS EITHER USED AS A TEMPORARY STORAGE (IF
C          M .LT. N) OR NOT REFERENCED (IF M .GE. N).
C          IF M .GE. N, V MAY ALSO COINCIDE WITH A.  IF AN ERROR
C          EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO INDICES OF
C          CORRECT SINGULAR VALUES SHOULD BE CORRECT.
C
C        Z CONTAINS THE MATRIX X IN THE SINGULAR VALUE DECOMPOSITION
C                  T
C          OF R=XSY,  IF THE MODIFIED ALGORITHM IS USED. IF THE
C          GOLUB-REINSCH PROCEDURE IS USED, THEN IT IS NOT REFERENCED.
C          IF MATU HAS BEEN SET TO .FALSE. IN THE CASE M.GE.N (OR
C          MATV SET TO .FALSE. IN THE CASE M.LT.N), THEN Z IS NOT
C          REFERENCED AND NO EXTRA STORAGE IS REQUIRED.
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          K          IF THE K-TH SINGULAR VALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C          -1         IF IRHS .LT. 0 .
C          -2         IF M .LT. 1 .OR. N .LT. 1
C          -3         IF NA .LT. M .OR. NU .LT. M .OR. NB .LT. M.
C          -4         IF NV .LT. N .
C          -5         IF NZ .LT. MIN(M,N).
C
C        RV1 IS A TEMPORARY STORAGE ARRAY OF LENGTH AT LEAST MIN(M,N).
C
C     PROGRAMMED BY : TONY CHAN
C                     BOX 2158, YALE STATION,
C                     COMPUTER SCIENCE DEPT, YALE UNIV.,
C                     NEW HAVEN, CT 06520.
C     LAST MODIFIED : JANUARY, 1982.
C
C     HYBSVD USES THE FOLLOWING FUNCTIONS AND SUBROUTINES.
C       INTERNAL  GRSVD, MGNSVD, SRELPR
C       FORTRAN   MIN0,DABS,DSQRT,DFLOAT,DSIGN,DMAX1
C       BLAS      SSWAP
C
C     -----------------------------------------------------------------
C     ERROR CHECK.
C
      IERR = 0
      IF (IRHS.GE.0) GO TO 10
      IERR = -1
      RETURN
   10 IF (M.GE.1 .AND. N.GE.1) GO TO 20
      IERR = -2
      RETURN
   20 IF (NA.GE.M .AND. NU.GE.M .AND. NB.GE.M) GO TO 30
      IERR = -3
      RETURN
   30 IF (NV.GE.N) GO TO 40
      IERR = -4
      RETURN
   40 IF (NZ.GE.MIN0(M,N)) GO TO 50
      IERR = -5
      RETURN
   50 CONTINUE
C
C     FIRST COPIES A INTO EITHER U OR V ACCORDING TO WHETHER
C     M .GE. N OR M .LT. N, AND THEN CALLS SUBROUTINE MGNSVD
C     WHICH ASSUMES THAT NUMBER OF ROWS .GE. NUMBER OF COLUMNS.
C
      IF (M.LT.N) GO TO 80
C
C       M .GE. N  CASE.
C
      DO 70 I=1,M
        DO 60 J=1,N
          U(I,J) = A(I,J)
   60   CONTINUE
   70 CONTINUE
C
      CALL MGNSVD(NU, NV, NZ, NB, M, N, W, MATU, U, MATV, V, Z, B,
     * IRHS, IERR, RV1)
      RETURN
C
   80 CONTINUE
C                              T
C       M .LT. N CASE. COPIES A  INTO V.
C
      DO 100 I=1,M
        DO 90 J=1,N
          V(J,I) = A(I,J)
   90   CONTINUE
  100 CONTINUE
      CALL MGNSVD(NV, NU, NZ, NB, N, M, W, MATV, V, MATU, U, Z, B, 0,
     * IERR, RV1)
      RETURN
      END
C                                                                       MGN   10
      SUBROUTINE MGNSVD(NU, NV, NZ, NB, M, N, W, MATU, U, MATV, V, Z,   MGN   20
     * B, IRHS, IERR, RV1)
C
C     THE DESCRIPTION OF SUBROUTINE MGNSVD IS ALMOST IDENTICAL
C     TO THAT FOR SUBROUTINE HYBSVD ABOVE, WITH THE EXCEPTION
C     THAT MGNSVD ASSUMES M .GE. N.
C     IT ALSO ASSUMES THAT A COPY OF THE MATRIX A IS IN THE ARRAY U.
C
      INTEGER NU, NV, NZ, M, N, IRHS, IERR, IP1, I, J, K, IM1, IBACK
      REAL*8 W(1), U(NU,1), V(NV,1), Z(NZ,1), B(NB,IRHS), RV1(1)
      REAL*8 XOVRPT, C, R, G, SCALE, DSIGN, DABS, DSQRT, F, S, H
      REAL*8 DFLOAT
      LOGICAL MATU, MATV
C
C     SET VALUE FOR C. THE VALUE FOR C DEPENDS ON THE RELATIVE
C     EFFICIENCY OF FLOATING POINT MULTIPLICATIONS, FLOATING POINT
C     ADDITIONS AND TWO-DIMENSIONAL ARRAY INDEXINGS ON THE
C     COMPUTER WHERE THIS SUBROUTINE IS TO BE RUN.  C SHOULD
C     USUALLY BE BETWEEN 2 AND 4.  FOR DETAILS ON CHOOSING C, SEE
C     (2).  THE ALGORITHM IS NOT SENSITIVE TO THE VALUE OF C
C     ACTUALLY USED AS LONG AS C IS BETWEEN 2 AND 4.
C
      C = 4.d0
C
C     DETERMINE CROSS-OVER POINT
C
      IF (MATU .AND. MATV) XOVRPT = (C+7.d0/3.d0)/C
      IF (MATU .AND. .NOT.MATV) XOVRPT = (C+7.d0/3.d0)/C
      IF (.NOT.MATU .AND. MATV) XOVRPT = 5.d0/3.d0
      IF (.NOT.MATU .AND. .NOT.MATV) XOVRPT = 5.d0/3.d0
C
C     DETERMINE WHETHER TO USE GOLUB-REINSCH OR THE MODIFIED
C     ALGORITHM.
C
      R = DFLOAT(M)/DFLOAT(N)
      IF (R.GE.XOVRPT) GO TO 10
C
C     USE GOLUB-REINSCH PROCEDURE
C
      CALL GRSVD(NU, NV, NB, M, N, W, MATU, U, MATV, V, B, IRHS, IERR,
     * RV1)
      GO TO 330
C
C     USE MODIFIED ALGORITHM
C
   10 CONTINUE
C
C     TRIANGULARIZE U BY HOUSEHOLDER TRANSFORMATIONS, USING
C     W AND RV1 AS TEMPORARY STORAGE.
C
      DO 110 I=1,N
        G = 0.d0
        S = 0.d0
        SCALE = 0.d0
C
C         PERFORM SCALING OF COLUMNS TO AVOID UNNECSSARY OVERFLOW
C         OR UNDERFLOW
C
        DO 20 K=I,M
          SCALE = SCALE + DABS(U(K,I))
   20   CONTINUE
        IF (SCALE.EQ.0.d0) GO TO 110
        DO 30 K=I,M
          U(K,I) = U(K,I)/SCALE
          S = S + U(K,I)*U(K,I)
   30   CONTINUE
C
C         THE VECTOR E OF THE HOUSEHOLDER TRANSFORMATION I + EE'/H
C         WILL BE STORED IN COLUMN I OF U. THE TRANSFORMED ELEMENT
C         U(I,I) WILL BE STORED IN W(I) AND THE SCALAR H IN
C         RV1(I).
C
        F = U(I,I)
        G = -DSIGN(DSQRT(S),F)
        H = F*G - S
        U(I,I) = F - G
        RV1(I) = H
        W(I) = SCALE*G
C
        IF (I.EQ.N) GO TO 70
C
C         APPLY TRANSFORMATIONS TO REMAINING COLUMNS OF A
C
        IP1 = I + 1
        DO 60 J=IP1,N
          S = 0.d0
          DO 40 K=I,M
            S = S + U(K,I)*U(K,J)
   40     CONTINUE
          F = S/H
          DO 50 K=I,M
            U(K,J) = U(K,J) + F*U(K,I)
   50     CONTINUE
   60   CONTINUE
C
C         APPLY TRANSFORMATIONS TO COLUMNS OF B IF IRHS .GT. 0
C
   70   IF (IRHS.EQ.0) GO TO 110
        DO 100 J=1,IRHS
          S = 0.d0
          DO 80 K=I,M
            S = S + U(K,I)*B(K,J)
   80     CONTINUE
          F = S/H
          DO 90 K=I,M
            B(K,J) = B(K,J) + F*U(K,I)
   90     CONTINUE
  100   CONTINUE
  110 CONTINUE
C
C     COPY R INTO Z IF MATU = .TRUE.
C
      IF (.NOT.MATU) GO TO 290
      DO 130 I=1,N
        DO 120 J=I,N
          Z(J,I) = 0.d0
          Z(I,J) = U(I,J)
  120   CONTINUE
        Z(I,I) = W(I)
  130 CONTINUE
C
C     ACCUMULATE HOUSEHOLDER TRANSFORMATIONS IN U
C
      DO 240 IBACK=1,N
        I = N - IBACK + 1
        IP1 = I + 1
        G = W(I)
        H = RV1(I)
        IF (I.EQ.N) GO TO 150
C
        DO 140 J=IP1,N
          U(I,J) = 0.d0
  140   CONTINUE
C
  150   IF (H.EQ.0.d0) GO TO 210
        IF (I.EQ.N) GO TO 190
C
        DO 180 J=IP1,N
          S = 0.d0
          DO 160 K=IP1,M
            S = S + U(K,I)*U(K,J)
  160     CONTINUE
          F = S/H
          DO 170 K=I,M
            U(K,J) = U(K,J) + F*U(K,I)
  170     CONTINUE
  180   CONTINUE
C
  190   S = U(I,I)/H
        DO 200 J=I,M
          U(J,I) = U(J,I)*S
  200   CONTINUE
        GO TO 230
C
  210   DO 220 J=I,M
          U(J,I) = 0.d0
  220   CONTINUE
  230   U(I,I) = U(I,I) + 1.d0
  240 CONTINUE
C
C     COMPUTE SVD OF R (WHICH IS STORED IN Z)
C
      CALL GRSVD(NZ, NV, NB, N, N, W, MATU, Z, MATV, V, B, IRHS, IERR,
     * RV1)
C
C                                      T
C     FORM L*X TO OBTAIN U (WHERE R=XWY ). X IS RETURNED IN Z
C     BY GRSVD. THE MATRIX MULTIPLY IS DONE ONE ROW AT A TIME,
C     USING RV1 AS SCRATCH SPACE.
C
      DO 280 I=1,M
        DO 260 J=1,N
          S = 0.d0
          DO 250 K=1,N
            S = S + U(I,K)*Z(K,J)
  250     CONTINUE
          RV1(J) = S
  260   CONTINUE
        DO 270 J=1,N
          U(I,J) = RV1(J)
  270   CONTINUE
  280 CONTINUE
      GO TO 330
C
C     FORM R IN U BY ZEROING THE LOWER TRIANGULAR PART OF R IN U
C
  290 IF (N.EQ.1) GO TO 320
      DO 310 I=2,N
        IM1 = I - 1
        DO 300 J=1,IM1
          U(I,J) = 0.d0
  300   CONTINUE
        U(I,I) = W(I)
  310 CONTINUE
  320 U(1,1) = W(1)
C
      CALL GRSVD(NU, NV, NB, N, N, W, MATU, U, MATV, V, B, IRHS, IERR,
     * RV1)
  330 CONTINUE
      IERRP1 = IERR + 1
      IF (IERR.LT.0 .OR. N.LE.1 .OR. IERRP1.EQ.N) RETURN
C
C     SORT SINGULAR VALUES AND EXCHANGE COLUMNS OF U AND V ACCORDINGLY.
C     SELECTION SORT MINIMIZES SWAPPING OF U AND V.
C
      NM1 = N - 1
      DO 360 I=IERRP1,NM1
C...    FIND INDEX OF MAXIMUM SINGULAR VALUE
        ID = I
        IP1 = I + 1
        DO 340 J=IP1,N
          IF (W(J).GT.W(ID)) ID = J
  340   CONTINUE
        IF (ID.EQ.I) GO TO 360
C...    SWAP SINGULAR VALUES AND VECTORS
        T = W(I)
        W(I) = W(ID)
        W(ID) = T
        IF (MATV) CALL SSWAP(N, V(1,I), 1, V(1,ID), 1)
        IF (MATU) CALL SSWAP(M, U(1,I), 1, U(1,ID), 1)
        IF (IRHS.LT.1) GO TO 360
        DO 350 KRHS=1,IRHS
          T = B(I,KRHS)
          B(I,KRHS) = B(ID,KRHS)
          B(ID,KRHS) = T
  350   CONTINUE
  360 CONTINUE
      RETURN
C     ************** LAST CARD OF HYBSVD *****************
      END
      SUBROUTINE GRSVD(NU, NV, NB, M, N, W, MATU, U, MATV, V, B, IRHS,  GRS   10
     * IERR, RV1)
C
      INTEGER I, J, K, L, M, N, II, I1, KK, K1, LL, L1, MN, NU, NV, NB,
     * ITS, IERR, IRHS
      REAL*8 W(1), U(NU,1), V(NV,1), B(NB,IRHS), RV1(1)
      REAL*8 C, F, G, H, S, X, Y, Z, EPS, SCALE, SRELPR, DUMMY
      REAL*8 DSQRT, DMAX1, DABS, DSIGN
      LOGICAL MATU, MATV
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD,
C     NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971).
C
C     THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION
C          T
C     A=USV  OF A REAL M BY N RECTANGULAR MATRIX.  HOUSEHOLDER
C     BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED.
C     GRSVD ASSUMES THAT A COPY OF THE MATRIX A IS IN THE ARRAY U. IT
C     ALSO ASSUMES M .GE. N.  IF M .LT. N, THEN COMPUTE THE SINGULAR
C                             T       T    T             T
C     VALUE DECOMPOSITION OF A .  IF A =UWV  , THEN A=VWU  .
C
C     GRSVD CAN ALSO BE USED TO COMPUTE THE MINIMAL LENGTH LEAST SQUARES
C     SOLUTION TO THE OVERDETERMINED LINEAR SYSTEM A*X=B.
C
C     ON INPUT-
C
C        NU MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS U AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.  NOTE THAT NU MUST BE AT LEAST
C          AS LARGE AS M,
C
C        NV MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C          ARRAY PARAMETER V AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.  NV MUST BE AT LEAST AS LARGE AS N,
C
C        NB MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS B AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.  NOTE THAT NB MUST BE AT LEAST
C          AS LARGE AS M,
C
C        M IS THE NUMBER OF ROWS OF A (AND U),
C
C        N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V,
C
C        A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED,
C
C        B CONTAINS THE IRHS RIGHT-HAND-SIDES OF THE OVERDETERMINED
C          LINEAR SYSTEM A*X=B.  IF IRHS .GT. 0,  THEN ON OUTPUT,
C          THE FIRST N COMPONENTS OF THESE IRHS COLUMNS OF B
C                        T
C          WILL CONTAIN U B.  THUS, TO COMPUTE THE MINIMAL LENGTH LEAST
C                                                +
C          SQUARES SOLUTION, ONE MUST COMPUTE V*W  TIMES THE COLUMNS OF
C                    +                        +
C          B, WHERE W  IS A DIAGONAL MATRIX, W (I)=0 IF W(I) IS
C          NEGLIGIBLE, OTHERWISE IS 1/W(I).  IF IRHS=0, B MAY COINCIDE
C          WITH A OR U AND WILL NOT BE REFERENCED,
C
C        IRHS IS THE NUMBER OF RIGHT-HAND-SIDES OF THE OVERDETERMINED
C          SYSTEM A*X=B.  IRHS SHOULD BE SET TO ZERO IF ONLY THE SINGULA
C          VALUE DECOMPOSITION OF A IS DESIRED,
C
C        MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE
C          DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE,
C
C        MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE
C          DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE.
C
C     ON OUTPUT-
C
C        W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE
C          DIAGONAL ELEMENTS OF S).  THEY ARE UNORDERED.  IF AN
C          ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,IERR+2,...,N,
C
C        U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE
C          DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE.  OTHERWISE
C          U IS USED AS A TEMPORARY ARRAY.
C          IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING
C          TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT,
C
C        V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF
C          MATV HAS BEEN SET TO .TRUE.  OTHERWISE V IS NOT REFERENCED.
C          IF AN ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO
C          INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          K          IF THE K-TH SINGULAR VALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS,
C          -1         IF IRHS .LT. 0 ,
C          -2         IF M .LT. N ,
C          -3         IF NU .LT. M .OR. NB .LT. M,
C          -4         IF NV .LT. N .
C
C        RV1 IS A TEMPORARY STORAGE ARRAY.
C
C        THIS SUBROUTINE HAS BEEN CHECKED BY THE PFORT VERIFIER
C        (RYDER, B.G. 'THE PFORT VERIFIER', SOFTWARE - PRACTICE AND
C        EXPERIENCE, VOL.4, 359-377, 1974) FOR ADHERENCE TO A LARGE,
C        CAREFULLY DEFINED, PORTABLE SUBSET OF AMERICAN NATIONAL STANDAR
C        FORTRAN CALLED PFORT.
C
C        ORIGINAL VERSION OF THIS CODE IS SUBROUTINE SVD IN RELEASE 2 OF
C        EISPACK.
C
C        MODIFIED BY TONY F. CHAN,
C                    COMP. SCI. DEPT, YALE UNIV.,
C                    BOX 2158, YALE STATION,
C                    CT 06520
C        LAST MODIFIED : JANUARY, 1982.
C
C     ------------------------------------------------------------------
C
C     ********** SRELPR IS A MACHINE-DEPENDENT FUNCTION SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
C
      IERR = 0
      IF (IRHS.GE.0) GO TO 10
      IERR = -1
      RETURN
   10 IF (M.GE.N) GO TO 20
      IERR = -2
      RETURN
   20 IF (NU.GE.M .AND. NB.GE.M) GO TO 30
      IERR = -3
      RETURN
   30 IF (NV.GE.N) GO TO 40
      IERR = -4
      RETURN
   40 CONTINUE
C
C     ********** HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM **********
      G = 0.d0
      SCALE = 0.d0
      X = 0.d0
C
      DO 260 I=1,N
        L = I + 1
        RV1(I) = SCALE*G
        G = 0.d0
        S = 0.d0
        SCALE = 0.d0
C
C     COMPUTE LEFT TRANSFORMATIONS THAT ZERO THE SUBDIAGONAL ELEMENTS
C     OF THE I-TH COLUMN.
C
        DO 50 K=I,M
          SCALE = SCALE + DABS(U(K,I))
   50   CONTINUE
C
        IF (SCALE.EQ.0.d0) GO TO 160
C
        DO 60 K=I,M
          U(K,I) = U(K,I)/SCALE
          S = S + U(K,I)**2
   60   CONTINUE
C
        F = U(I,I)
        G = -DSIGN(DSQRT(S),F)
        H = F*G - S
        U(I,I) = F - G
        IF (I.EQ.N) GO TO 100
C
C     APPLY LEFT TRANSFORMATIONS TO REMAINING COLUMNS OF A.
C
        DO 90 J=L,N
          S = 0.d0
C
          DO 70 K=I,M
            S = S + U(K,I)*U(K,J)
   70     CONTINUE
C
          F = S/H
C
          DO 80 K=I,M
            U(K,J) = U(K,J) + F*U(K,I)
   80     CONTINUE
   90   CONTINUE
C
C      APPLY LEFT TRANSFORMATIONS TO THE COLUMNS OF B IF IRHS .GT. 0
C
  100   IF (IRHS.EQ.0) GO TO 140
        DO 130 J=1,IRHS
          S = 0.d0
          DO 110 K=I,M
            S = S + U(K,I)*B(K,J)
  110     CONTINUE
          F = S/H
          DO 120 K=I,M
            B(K,J) = B(K,J) + F*U(K,I)
  120     CONTINUE
  130   CONTINUE
C
C     COMPUTE RIGHT TRANSFORMATIONS.
C
  140   DO 150 K=I,M
          U(K,I) = SCALE*U(K,I)
  150   CONTINUE
C
  160   W(I) = SCALE*G
        G = 0.d0
        S = 0.d0
        SCALE = 0.d0
        IF (I.GT.M .OR. I.EQ.N) GO TO 250
C
        DO 170 K=L,N
          SCALE = SCALE + DABS(U(I,K))
  170   CONTINUE
C
        IF (SCALE.EQ.0.d0) GO TO 250
C
        DO 180 K=L,N
          U(I,K) = U(I,K)/SCALE
          S = S + U(I,K)**2
  180   CONTINUE
C
        F = U(I,L)
        G = -DSIGN(DSQRT(S),F)
        H = F*G - S
        U(I,L) = F - G
C
        DO 190 K=L,N
          RV1(K) = U(I,K)/H
  190   CONTINUE
C
        IF (I.EQ.M) GO TO 230
C
        DO 220 J=L,M
          S = 0.d0
C
          DO 200 K=L,N
            S = S + U(J,K)*U(I,K)
  200     CONTINUE
C
          DO 210 K=L,N
            U(J,K) = U(J,K) + S*RV1(K)
  210     CONTINUE
  220   CONTINUE
C
  230   DO 240 K=L,N
          U(I,K) = SCALE*U(I,K)
  240   CONTINUE
C
  250   X = DMAX1(X,DABS(W(I))+DABS(RV1(I)))
  260 CONTINUE
C     ********** ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS **********
      IF (.NOT.MATV) GO TO 350
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
      DO 340 II=1,N
        I = N + 1 - II
        IF (I.EQ.N) GO TO 330
        IF (G.EQ.0.d0) GO TO 310
C
        DO 270 J=L,N
C     ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
          V(J,I) = (U(I,J)/U(I,L))/G
  270   CONTINUE
C
        DO 300 J=L,N
          S = 0.d0
C
          DO 280 K=L,N
            S = S + U(I,K)*V(K,J)
  280     CONTINUE
C
          DO 290 K=L,N
            V(K,J) = V(K,J) + S*V(K,I)
  290     CONTINUE
  300   CONTINUE
C
  310   DO 320 J=L,N
          V(I,J) = 0.d0
          V(J,I) = 0.d0
  320   CONTINUE
C
  330   V(I,I) = 1.d0
        G = RV1(I)
        L = I
  340 CONTINUE
C     ********** ACCUMULATION OF LEFT-HAND TRANSFORMATIONS **********
  350 IF (.NOT.MATU) GO TO 470
C     **********FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- **********
      MN = N
      IF (M.LT.N) MN = M
C
      DO 460 II=1,MN
        I = MN + 1 - II
        L = I + 1
        G = W(I)
        IF (I.EQ.N) GO TO 370
C
        DO 360 J=L,N
          U(I,J) = 0.d0
  360   CONTINUE
C
  370   IF (G.EQ.0.d0) GO TO 430
        IF (I.EQ.MN) GO TO 410
C
        DO 400 J=L,N
          S = 0.d0
C
          DO 380 K=L,M
            S = S + U(K,I)*U(K,J)
  380     CONTINUE
C     ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
          F = (S/U(I,I))/G
C
          DO 390 K=I,M
            U(K,J) = U(K,J) + F*U(K,I)
  390     CONTINUE
  400   CONTINUE
C
  410   DO 420 J=I,M
          U(J,I) = U(J,I)/G
  420   CONTINUE
C
        GO TO 450
C
  430   DO 440 J=I,M
          U(J,I) = 0.d0
  440   CONTINUE
C
  450   U(I,I) = U(I,I) + 1.d0
  460 CONTINUE
C     ********** DIAGONALIZATION OF THE BIDIAGONAL FORM **********
  470 EPS = SRELPR(DUMMY)*X
C     ********** FOR K=N STEP -1 UNTIL 1 DO -- **********
      DO 650 KK=1,N
        K1 = N - KK
        K = K1 + 1
        ITS = 0
C     ********** TEST FOR SPLITTING.
C                FOR L=K STEP -1 UNTIL 1 DO -- **********
  480   DO 490 LL=1,K
          L1 = K - LL
          L = L1 + 1
          IF (DABS(RV1(L)).LE.EPS) GO TO 550
C     ********** RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
          IF (DABS(W(L1)).LE.EPS) GO TO 500
  490   CONTINUE
C     ********** CANCELLATION OF RV1(L) IF L GREATER THAN 1 **********
  500   C = 0.d0
        S = 1.d0
C
        DO 540 I=L,K
          F = S*RV1(I)
          RV1(I) = C*RV1(I)
          IF (DABS(F).LE.EPS) GO TO 550
          G = W(I)
          H = DSQRT(F*F+G*G)
          W(I) = H
          C = G/H
          S = -F/H
C
C     APPLY LEFT TRANSFORMATIONS TO B IF IRHS .GT. 0
C
          IF (IRHS.EQ.0) GO TO 520
          DO 510 J=1,IRHS
            Y = B(L1,J)
            Z = B(I,J)
            B(L1,J) = Y*C + Z*S
            B(I,J) = -Y*S + Z*C
  510     CONTINUE
  520     CONTINUE
C
          IF (.NOT.MATU) GO TO 540
C
          DO 530 J=1,M
            Y = U(J,L1)
            Z = U(J,I)
            U(J,L1) = Y*C + Z*S
            U(J,I) = -Y*S + Z*C
  530     CONTINUE
C
  540   CONTINUE
C     ********** TEST FOR CONVERGENCE **********
  550   Z = W(K)
        IF (L.EQ.K) GO TO 630
C     ********** SHIFT FROM BOTTOM 2 BY 2 MINOR **********
        IF (ITS.EQ.30) GO TO 660
        ITS = ITS + 1
        X = W(L)
        Y = W(K1)
        G = RV1(K1)
        H = RV1(K)
        F = ((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.d0*H*Y)
        G = DSQRT(F*F+1.0)
        F = ((X-Z)*(X+Z)+H*(Y/(F+DSIGN(G,F))-H))/X
C     ********** NEXT QR TRANSFORMATION **********
        C = 1.0
        S = 1.0
C
        DO 620 I1=L,K1
          I = I1 + 1
          G = RV1(I)
          Y = W(I)
          H = S*G
          G = C*G
          Z = DSQRT(F*F+H*H)
          RV1(I1) = Z
          C = F/Z
          S = H/Z
          F = X*C + G*S
          G = -X*S + G*C
          H = Y*S
          Y = Y*C
          IF (.NOT.MATV) GO TO 570
C
          DO 560 J=1,N
            X = V(J,I1)
            Z = V(J,I)
            V(J,I1) = X*C + Z*S
            V(J,I) = -X*S + Z*C
  560     CONTINUE
C
  570     Z = DSQRT(F*F+H*H)
          W(I1) = Z
C     ********** ROTATION CAN BE ARBITRARY IF Z IS ZERO **********
          IF (Z.EQ.0.d0) GO TO 580
          C = F/Z
          S = H/Z
  580     F = C*G + S*Y
          X = -S*G + C*Y
C
C     APPLY LEFT TRANSFORMATIONS TO B IF IRHS .GT. 0
C
          IF (IRHS.EQ.0) GO TO 600
          DO 590 J=1,IRHS
            Y = B(I1,J)
            Z = B(I,J)
            B(I1,J) = Y*C + Z*S
            B(I,J) = -Y*S + Z*C
  590     CONTINUE
  600     CONTINUE
C
          IF (.NOT.MATU) GO TO 620
C
          DO 610 J=1,M
            Y = U(J,I1)
            Z = U(J,I)
            U(J,I1) = Y*C + Z*S
            U(J,I) = -Y*S + Z*C
  610     CONTINUE
C
  620   CONTINUE
C
        RV1(L) = 0.d0
        RV1(K) = F
        W(K) = X
        GO TO 480
C     ********** CONVERGENCE **********
  630   IF (Z.GE.0.d0) GO TO 650
C     ********** W(K) IS MADE NON-NEGATIVE **********
        W(K) = -Z
        IF (.NOT.MATV) GO TO 650
C
        DO 640 J=1,N
          V(J,K) = -V(J,K)
  640   CONTINUE
C
  650 CONTINUE
C
      GO TO 670
C     ********** SET ERROR -- NO CONVERGENCE TO A
C                SINGULAR VALUE AFTER 30 ITERATIONS **********
  660 IERR = K
  670 RETURN
C     ********** LAST CARD OF GRSVD **********
      END
      SUBROUTINE SSWAP(N, SX, INCX, SY, INCY)                           SSW   10
C
C     INTERCHANGES TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO 1.
C     JACK DONGARRA, LINPACK, 3/11/78.
C
      REAL*8 SX(1), SY(1), STEMP
      INTEGER I, INCX, INCY, IX, IY, M, MP1, N
C
      IF (N.LE.0) RETURN
      IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
C
C       CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
C         TO 1
C
      IX = 1
      IY = 1
      IF (INCX.LT.0) IX = (-N+1)*INCX + 1
      IF (INCY.LT.0) IY = (-N+1)*INCY + 1
      DO 10 I=1,N
        STEMP = SX(IX)
        SX(IX) = SY(IY)
        SY(IY) = STEMP
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP
C
   20 M = MOD(N,3)
      IF (M.EQ.0) GO TO 40
      DO 30 I=1,M
        STEMP = SX(I)
        SX(I) = SY(I)
        SY(I) = STEMP
   30 CONTINUE
      IF (N.LT.3) RETURN
   40 MP1 = M + 1
      DO 50 I=MP1,N,3
        STEMP = SX(I)
        SX(I) = SY(I)
        SY(I) = STEMP
        STEMP = SX(I+1)
        SX(I+1) = SY(I+1)
        SY(I+1) = STEMP
        STEMP = SX(I+2)
        SX(I+2) = SY(I+2)
        SY(I+2) = STEMP
   50 CONTINUE
      RETURN
      END
      REAL*8 FUNCTION SRELPR(DUMMY)                                       SRE   10
      REAL*8 DUMMY
C
C     SRELPR COMPUTES THE RELATIVE PRECISION OF THE FLOATING POINT
C     ARITHMETIC OF THE MACHINE.
C
C     IF TROUBLE WITH AUTOMATIC COMPUTATION OF THESE QUANTITIES,
C     THEY CAN BE SET BY DIRECT ASSIGNMENT STATEMENTS.
C     ASSUME THE COMPUTER HAS
C
C        B = BASE OF ARITHMETIC
C        T = NUMBER OF BASE  B  DIGITS
C
C     THEN
C
C        SRELPR = B**(1-T)
C
      REAL*8 S
C
      SRELPR = 1.d0
   10 SRELPR = SRELPR/2.d0
      S = 1.d0 + SRELPR
      IF (S.GT.1.d0) GO TO 10
      SRELPR = 2.d0*SRELPR
      RETURN
      END


*> \brief  SGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGBSV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               AB( LDAB, * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGBSV computes the solution to a real system of linear equations
*> A * X = B, where A is a band matrix of order N with KL subdiagonals
*> and KU superdiagonals, and X and B are N-by-NRHS matrices.
*>
*> The LU decomposition with partial pivoting and row interchanges is
*> used to factor A as A = L * U, where L is a product of permutation
*> and unit lower triangular matrices with KL subdiagonals, and U is
*> upper triangular with KL+KU superdiagonals.  The factored form of A
*> is then used to solve the system of equations A * X = B.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of linear equations, i.e., the order of the
*>          matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The number of subdiagonals within the band of A.  KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The number of superdiagonals within the band of A.  KU >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*>          AB is REAL array, dimension (LDAB,N)
*>          On entry, the matrix A in band storage, in rows KL+1 to
*>          2*KL+KU+1; rows 1 to KL of the array need not be set.
*>          The j-th column of A is stored in the j-th column of the
*>          array AB as follows:
*>          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
*>          On exit, details of the factorization: U is stored as an
*>          upper triangular band matrix with KL+KU superdiagonals in
*>          rows 1 to KL+KU+1, and the multipliers used during the
*>          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*>          See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices that define the permutation matrix P;
*>          row i of the matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, the N-by-NRHS right hand side matrix B.
*>          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
*>                has been completed, but the factor U is exactly
*>                singular, and the solution has not been computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realGBsolve
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The band storage scheme is illustrated by the following example, when
*>  M = N = 6, KL = 2, KU = 1:
*>
*>  On entry:                       On exit:
*>
*>      *    *    *    +    +    +       *    *    *   u14  u25  u36
*>      *    *    +    +    +    +       *    *   u13  u24  u35  u46
*>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*>     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
*>     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
*>
*>  Array elements marked * are not used by the routine; elements marked
*>  + need not be set on entry, but are required by the routine to store
*>  elements of U because of fill-in resulting from the row interchanges.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
*
*  -- LAPACK driver routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               AB( LDAB, * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           SGBTRF, SGBTRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( KL.LT.0 ) THEN
         INFO = -2
      ELSE IF( KU.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
         INFO = -9
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGBSV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of the band matrix A.
*
      CALL SGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL SGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
     $                B, LDB, INFO )
      END IF
      RETURN
*
*     End of SGBSV
*
      END


      DOUBLE PRECISION FUNCTION DAPOLY(N,P)
C
C     CALCULATES AREA OF A POLYGON DESCRIBED BY N POINTS (P)
C        ( N .LE. 10 )
C
C        AREA= -1* LINE INTEGRAL OF Y*DX
C
C     AREA CONTRIBUTION FROM SIDE WHOSE ENDS ARE P(I), P(J):
C        A(I,J)= 0.5 * (Y(I)+Y(J)) * (X(I)-X(J))
C
      DOUBLE PRECISION P(2,1)
      INTEGER KEDGE(2,10), K(2,10)
C
      DATA KEDGE/ 1,2,  2,3,  3,4,  4,5,  5,6,  6,7,  7,8,  8,9,  9,10,
     1  10,1/
C
      DO 10 I=1,2
      DO 10 J=1,N
   10 K(I,J)= KEDGE(I,J)
      K(2,N)= 1
      DAPOLY= 0.0
C
      DO 20  NN= 1,N
      K1= K(1,NN)
      K2= K(2,NN)
   20 DAPOLY= DAPOLY +5.D-1 * (P(2,K1)+P(2,K2)) * (P(1,K1)-P(1,K2))
      RETURN
      END


SUBROUTINE gcf(gammcf,a,x,gln)
INTEGER ITMAX
REAL a,gammcf,gln,x,EPS,FPMIN
PARAMETER (ITMAX=100,EPS=3.e-7,FPMIN=1.e-30)
!CU    USES gammln
INTEGER i
REAL an,b,c,d,del,h,gammln
gln=gammln(a)
b=x+1.-a
c=1./FPMIN
d=1./b
h=d
do i=1,ITMAX
  an=-i*(i-a)
  b=b+2.
  d=an*d+b
  if(abs(d).lt.FPMIN)d=FPMIN
  c=b+an/c
  if(abs(c).lt.FPMIN)c=FPMIN
  d=1./d
  del=d*c
  h=h*del
  if(abs(del-1.).lt.EPS)goto 1
enddo
pause 'a too large, ITMAX too small in gcf'
1     gammcf=exp(-x+a*log(x)-gln)*h
return
END


	subroutine fastf(Fr,Fi,n)
c
c	n  = the number of data points=2**m
c	Fr = the real data set
c	Fi is the imaginary part of data set (=0.0 if only real)
c
c	first compute m
c
	real*4 Fr(n), Fi(n), Gr, Gi, Er, Ei, Eu, Ez
	m=0
	kd=n
 1	kd=kd/2
	m=m+1
	if (kd .ge. 2) go to 1
	nd2=n/2
	nm1=n-1
	l=1
c
c	shuffle input data in binary digit reverse order
c
	do 4 k=1,nm1
	if (k .ge. l) go to 2
	Gr=Fr(l)
	Gi=Fi(l)
	Fr(l)=Fr(k)
	Fi(l)=Fi(k)
	Fr(k)=Gr
	Fi(k)=Gi
 2	nnd2=nd2
 ! 3	if(nnd2 .ge. l) go to 4
 3	if(nnd2 .lt. l) then
	   l=l-nnd2
	   nnd2=nnd2/2
	   go to 3
        endif
 !  4	l=l+nnd2
    4   continue
  	l=l+nnd2
	pi=3.14159265
c
c	first arrange accounting of m stage
c
	do 7 j=1,m
	nj=2**j
	njd2=nj/2
	Eu=1.0
	Ez=0.0
	Er=cos(-pi/njd2)
	Ei=sin(-pi/njd2)
c
c	compute fourie transform in each m stage
c
	do 6 it=1,njd2
           do 5 iw=it,n,nj
	        iwj=iw+njd2
	        Gr=Fr(iwj)*Eu-Fi(iwj)*Ez
	        Gi=Fi(iwj)*Eu+Fr(iwj)*Ez
	        Fr(iwj)=Fr(iw)-Gr
	        Fi(iwj)=Fi(iw)-Gi
	        Fr(iw) =Fr(iw)+Gr
 !5	Fi(iw) =Fi(iw)+Gi
                Fi(iw) =Fi(iw)+Gi
    5      continue
	   Seu=Eu
	   Eu=Seu*Er-Ez*Ei
 !  6	Ez=Ez*Er+Seu*Ei
           Ez=Ez*Er+Seu*Ei
    6  continue
    7  continue
	Return
	End


C     PROGRAM No. 2: DISCRETE VORTEX METHOD (THIN WING, ELLIPTIC CAMBER)
C     -----------------------------------------------------------------
C     DISCRETE VORTEX MODEL FOR THIN AIRFOILS (JOE KATZ,CIRCA 1986)

      DIMENSION GAMMA(52),XC(52),ZC(52),X(52),Z(52)
      DIMENSION ENX(52),ENZ(52),A(52,52),IP(52)
      DIMENSION DL(52),DCP(52),DCP1(52)

      N=10
      C=1.0
      EPSILON=0.1*C
      ALFA1=10.0
      PAY=3.141592654
      ALFA=ALFA1*PAY/180.0
      RO=1.
      V=1.
      UINF=COS(ALFA)*V
      WINF=SIN(ALFA)*V
      QUE=0.5*RO*V*V

C     GRID GENERATION (N PANELS)
      DX=C/N
      DO 1 I=1,N
C        COLLOCATION POINT
         XC(I) = C/N*(I-0.25)
         ZC(I) = 4.*EPSILON*XC(I)/C*(1.-XC(I)/C)
C        VORTEX POINT
         X(I) = C/N*(I-0.75)
         Z(I) = 4.*EPSILON*X(I)/C*(1.-X(I)/C)
C        NORMAL AT COLLOCATION POINT; N=(ENX,ENZ)
         DETADX=4.*EPSILON/C*(1.-2.*XC(I)/C)
         SQ=SQRT(1+DETADX**2)
         ENX(I)=-DETADX/SQ
 1       ENZ(I)= 1./SQ

C     INFLUENCE COEFFICIENTS
      DO 3 I=1,N
         DO 2 J=1,N
            CALL VOR2D(XC(I),ZC(I),X(J),Z(J),1.0,U,W)
            A(I,J)=U*ENX(I)+W*ENZ(I)
 2             CONTINUE
C           THE RHS VECTOR IS PLACED IN THE GAMMA VECTOR
         GAMMA(I)=-UINF*ENX(I)-WINF*ENZ(I)
 3          CONTINUE

C     SOLUTION OF THE PROBLEM: RHS(I)=A(I,J)*GAMMA(I)
      CALL DECOMP(N,52,A,IP)
      CALL SOLVER(N,52,A,GAMMA,IP)

C     AERODYNAMIC LOADS
      BL=0.0
      DO 4 I=1,N
         DL(I)=RO*V*GAMMA(I)
         DCP(I)=DL(I)/DX/QUE
C        DCP1 IS THE ANALYTIC SOLUTION
         DD=32.*EPSILON/C*SQRT(X(I)/C*(1.-X(I)/C))
         DCP1(I)=4.*SQRT((C-X(I))/X(I))*ALFA+DD
 4       BL=BL+DL(I)
         CL=BL/(QUE*C)
         CL1=2.*PAY*(ALFA+2*EPSILON/C)
C     CL1,DCP1-ARE THE EXACT SOLUTIONS

C     OUTPUT
      WRITE(6,14)
      WRITE(6,15) V,CL,CL1,N,ALFA1
      DO 5 I=1,N
 5        WRITE(6,16)I,X(I),DCP(I),DCP1(I)

 14   FORMAT( ' THIN AIRFOIL WITH ELLIPTIC CAMBER ')
 15   FORMAT( ' V=',F7.1,3X,'CL=',F7.3,3X,'CL(EXACT)=',F7.3,3X,'N= ',
     $I6,3X,'ALPHA= ',F6.1)
 16   FORMAT( I5,3X,'X=',F8.2,5X,'DCP=',F8.2,3X,'DCP(EXACT)=',5F6.2)

C     PLOTTER OUTPUT IS PLACED HERE (e.g. DCP AND DCP1-VS-X/C)

      STOP
      END

      SUBROUTINE VOR2D(X,Z,X1,Z1,GAMMA,U,W)
C     CALCULATES INFLUENCE OF VORTEX AT (X1,Z1)
      PAY=3.141592654
      U=0.0
      W=0.0
      RX=X-X1
      RZ=Z-Z1
      R=SQRT(RX**2+RZ**2)
      IF(R.LT.0.001) GOTO 1
         V=0.5/PAY*GAMMA/R
         U=V*(RZ/R)
         W=V*(-RX/R)
 1          CONTINUE
      RETURN
      END
C
C     THE FOLLOWING SUBROUTINES ARE LISTED WITH THE STEADY STATE
C     VORTEX LATTICE SOLVER (program No. 13).
C
C     SUBROUTINE DECOMP(N,NDIM,A,IP)
C     SUBROUTINE SOLVER(N,NDIM,A,B,IP)


module helmholtz
! contains all variables and subroutines necessary to solve
! Helmholtz equation of the form: (D^2 - k^2 - dtnui)u = rhs
! with Dirichlet boundary conditions at zpts(1) and zpts(nzp)
! setting dtfac to zero solves the corresponding Poisson eqn

implicit none
public
save

contains

subroutine diagonalize_matrix(D2,n,lamda,e,ei)
    ! find eigenvalues and eigenvectors of d^2/dz^2 matrix D2
    ! to diagonalize it s.t. D2 = E lamda E^-1, where diag is diagonal,
    ! and E are the matrices whose columns are eigenvectors
    use flags, only: debug
    !     use dim, only: nzp,nz,nzm
    !     use mats
    use mpicom, only: myid
    use formatstrings
    integer, intent(in) :: n
    real, dimension(n,n) :: D2
    real, dimension(n), intent(out) :: lamda
    real, dimension(n,n), intent(out) :: e, ei
    ! local vars req'd for LAPACK
    character*1 :: jobvl, jobvr
    integer :: k, i, info, lwork, lda, ldb, ldvl, ldvr
    integer, allocatable, dimension(:) :: ipiv
    real, allocatable, dimension(:,:) :: A, B, vl, vr
    real, allocatable, dimension(:) :: work, alphar, alphai, beta
    !     real :: tmp

    ! setup input for LAPACK SGGEV which calculates eigenvalues,
    ! and eigenvectors for problem A v = lamda*B v
    jobvl = 'N'
    jobvr = 'V'
    !     n = nzm
    lda = n
    ldb = n
    ldvl = n
    ldvr = n
    lwork = 10*n
    allocate( A(lda,n), B(ldb,n), vl(ldvl,n), vr(ldvr,n), work(lwork), alphar(n), alphai(n), beta(n), ipiv(n) )

    ! A = D2(2:nz,2:nz) because we always solve helmholtz and poisson eqn
    ! with homogeneous boundary conditions e.g.:
    ! [D^2 - k^2 - 2/(nu*dt)] phi = RHS + hbot(z)bc1(x,y) + h2(z)bc2(x,y)
    ! where phi(z=0,H or -1,1) = 0
    !     A = D2(ns:n+1,ns:n+1)
    A = D2

    ! B is the identity matrix in this case because we want the solution to
    ! the classical eigenvalue problem A v = lamda*v
    B = 0.0
    do k=1,n
        B(k,k) = 1.
    end do

    ! DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
    !     the generalized eigenvalues, and optionally, the left and/or right
    !     generalized eigenvectors.
    !     A generalized eigenvalue for a pair of matrices (A,B) is a scalar
    !     lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
    !     singular. It is usually represented as the pair (alpha,beta), as
    !     there is a reasonable interpretation for beta=0, and even for both
    !     being zero.
    !     The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
    !     of (A,B) satisfies
    !              A * v(j) = lambda(j) * B * v(j).
    !     The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
    !     of (A,B) satisfies
    !              u(j)**H * A  = lambda(j) * u(j)**H * B .
    !     where u(j)**H is the conjugate-transpose of u(j).
    call dggev( jobvl, jobvr, n, A, lda, B, ldb, alphar, alphai, beta, vl, ldvl, vr, ldvr, work, lwork, info )
    ! check for errors
    if (info>=2 .and. myid==0) write(*,'((//,A),I11.4)') 'info =', info

    if (debug>=2) then
        ! scale each eigen vector by its first value for comparison with previous code results
        do k=1,n
            vr(:,k) = vr(:,k)/vr(1,k)
        end do
    end if

    ! store calculate eigenvalues in lamda, and eigenvectors in e
    lamda = 0.0
    lamda(1:n) = alphar/beta ! assuming only real eigenvalues
    e(1:n,1:n) = vr

    ! switch last two eigenvalues if they are in wrong order
    !     if (lamda(n)<lamda(n-1)) then
    !         tmp = lamda(n)
    !         lamda(n) = lamda(n-1)
    !         lamda(n-1) = tmp
    !         vl(:,n) = e(:,n)
    !         e(:,n) = e(:,n-1)
    !         e(:,n-1) = vl(:,n)
    !     end if

    ! now find E^-1 = vr^-1
    ! first get LU decomposition
    call dgetrf( n, n, vr, lda, ipiv, info )
    ! then solve for inverse
    call dgetri( n, vr, lda, ipiv, work, lwork, info )
    ! check for errors
    if (debug>=2 .and. myid==0) write(*,'((//,A),I11.4)') 'info =', info

    ! store E^-1 into ei
    ei(1:n,1:n) = vr

    if (debug>=1 .and. myid==0) then
        write(*,'((//,A),I11.4)') 'info =', info
        write(*,'(//,A)') 'eigenvalues ='
        write(*,'(2(E14.7,'',''))') (lamda(i),alphai(i),i=1,n)
    !         write(*,'(//,A)') 'right eigenvectors ='
    !         write(*,fm3) ((e(i,k),k=1,n),i=1,n)
    !         write(*,'(//,A)') 'inv(E) ='
    !         write(*,fm3) ((ei(i,k),k=1,n),i=1,n)
    end if

    ! deallocate all local vars
    deallocate( A, B, vl, vr, work, alphar, alphai, beta, ipiv )

end subroutine diagonalize_matrix

subroutine solve_helmholtz(rhs,dtnui,n,diag,smat,simat)
    ! solves the Helmholtz or Poisson eqn with homogeneous boundary conditions
    use dim
    use grid
    !     use mats
    ! i/o
    integer, intent(in) :: n
    real, dimension(nxpl,ny,nzpl), intent(inout) :: rhs
    real, intent(in) :: dtnui
    real, dimension(n), intent(in) :: diag
    real, dimension(n,n), intent(in) :: smat,simat
    ! vars
    integer :: i, j, k, ks, ke
    real, allocatable, dimension(:) :: denom
    real, allocatable, dimension(:,:) :: dfac
    real, allocatable, dimension(:,:,:) :: q, trhs
    real :: mindiag

    mindiag = 1.E-4
    ks = 2; ke = nz;
    if (n==nz) ks = 2; ke = n+1;

    ! allocate local vars
    allocate( dfac(nxpl,ny), q(nxpl,ny,n), trhs(nxpl,ny,n), denom(n) )
    ! copy rhs into q
    q = rhs(:,:,ks:ke)
    ! denom
    i = 1
    do k=ks,ke
        denom(i) = diag(k-1)
        i = i +1
    end do
    ! solve (D^2 - k^2 - dtnui)u = rhs
    ! using previously decomposed matrix D^2 = E diag E^-1 s.t.
    ! (D^2 - k^2 - dtnui)q = (E diag E^-1 - I (k^2 + dtnui))q = rhs
    ! left multiply eqn by E^-1, right multiply by E and obtain
    ! (diag - I (k^2 + dtnui))q = E^-1 rhs E
    ! q(z) = E^-1 rhs(z) E / (diag(z) - I (k^2 + dtnui)) for each i,j
    do j=1,ny
        do i=1,nxpl
            ! dfac = -k^2 -dtnui
            dfac(i,j) = -wavxx(i) - wavyy(j) - dtnui
            ! left multiply eqn by E^-1,
!              trhs(i,j,:) = matmul(simat,q(i,j,:))
          call DGEMV ( 'N', n, n, 1.0, simat, n, q(i,j,:), 1, 0.0, trhs(i,j,:), 1 )
!                 trhs(i,j,ks:ke) = matmul(rhs(i,j,ks:ke),simat)

            ! q(z) = E^-1 rhs(z) E / (diag(z) - I (k^2 + dtnui))
!             trhs(i,j,ks:ke) = trhs(i,j,ks:ke)/(diag(1:nzm) + dfac(i,j))
    !             trhs(i+1,j,ks:ke) = trhs(i+1,j,ks:ke)/(diag(1:nzm) + dfac(ii,j))
            trhs(i,j,:) = trhs(i,j,:)/(denom(:) + dfac(i,j))
!             do k=ks,ke
!                 if (abs(diag(k-1)+ dfac(i,j)) >= mindiag ) then
!                     trhs(i,j,k) = trhs(i,j,k)/(diag(k-1) + dfac(i,j))
!                 else
!                     trhs(i,j,k) = 0.0
!                 end if
!             end do
            ! right multiply by E
!              q(i,j,:) = matmul(smat,trhs(i,j,:))
           call DGEMV ( 'N', n, n, 1.0, smat, n, trhs(i,j,:), 1, 0.0, q(i,j,:), 1 )
    !             q(i,j,ks:ke) = matmul(trhs(i,j,ks:ke),smat)
    !             q(i,j,ks:ke) = q(i,j,ks:ke)/( diag(1:nzm) + dfac(ii,j) )
            ! copy soln into imaginary part of mode since dfac doesn't change
    !             q(i+1,j,ks:ke) = q(i,j,ks:ke)
        end do
    end do

    rhs(:,:,ks:ke) = q

    ! apply homogeneous boundary conditions
!     if (n==nzm) then
        rhs(:,:,1) = 0.0
        rhs(:,:,nzp) = 0.0
!     end if
    ! deallocate local vars
    deallocate(dfac, q, trhs, denom)

end subroutine solve_helmholtz

subroutine solve_nhom_helmholtz(rhs, bc, dtnui, diag, smat, simat)
    ! solves the Helmholtz or Poisson eqn with non-homogeneous boundary conditions
    ! bc(x,y,z=zpts(nzp)) and bc(x,y,z=zpts(1)) using Green's function method:
    ! (D^2 - k^2 - dtnui)u = rhs, let u = phi + htop(z)f1(x,y) + hbot(z)f2(x,y) s.t.
    ! (D^2 - k^2 - dtnui)phi = rhs - (D^2 - k^2 - dtnui)(htop(z)f1(x,y) + hbot(z)f2(x,y))
    ! where phi has homogeneous boundary conditions
    use dim
    use grid
    use runparam, only: mapping, blfac
    use paral, only: wbar, wbarpp
    !     use mats
    use flags, only: debug
    use formatstrings
    use mpicom, only: myid
    ! i/o
    real, dimension(nxpl,ny,nzpl), intent(inout) :: rhs
    real, dimension(nxpl,ny,nzpl), intent(in) :: bc
    real, intent(in) :: dtnui
    !     integer, intent(in) :: mapping
    real, dimension(nzpl), intent(in) :: diag
    real, dimension(nzpl,nzpl), intent(in) :: smat,simat
    ! vars
    integer :: i, j, k
    real, allocatable, dimension(:) :: hbot, htop, d2hbot, d2htop
    real :: btop, bbot, atop, abot, width, h

    ! allocate vars
    allocate( hbot(nzp), htop(nzp), d2hbot(nzp), d2htop(nzp) )
    ! based on mapping, compute what hbot and h2 should be:
    select case(mapping)
        case(0) ! channel flow
            ! linear htop, hbot
            width = zpts(1) - zpts(nzp)
            htop(1:nzp) = (zpts(1:nzp) - zpts(nzp))/width ! hbot(1) = 1, hbot(nzp) = 0
            hbot(1:nzp) = -(zpts(1:nzp) - zpts(1))/width  ! h2(1) = 0, h2(nzp) = 1
            d2htop = 0.0
            d2hbot = 0.0
        case(1) ! semi-infinite BL
            ! exponential from blayscal
            h = zpts(1) - zpts(nzp)
            btop = 0.2
            bbot = 50.0
    !         htop = wbar/wbar(1)
    !         htop(nzp) = 0.0
    !         d2htop = wbarpp/wbar(1)
            htop(1:nzp) = 0.0!exp( -btop*(h-zpts(1:nzp)) )
            d2htop = 0.0!btop**2.0*htop
!             hbot = ( exp(-bbot*zpts) - exp(bbot*(zpts-2.0*h)) )
!             hbot = hbot/( 1.-exp(-2.0*bbot*h) )
!             d2hbot = bbot**2.0*hbot
            hbot(1:nzp) = exp( -bbot*zpts(1:nzp) )
            hbot(1) = 0.0
            d2hbot(:) = bbot**2.0*hbot(:)
        case(2) ! well-resolved Blasius BL problem
            h = zpts(1) - zpts(nzp)
            bbot = 5.0 !blfac
            hbot = ( exp(-bbot*zpts) - exp(bbot*(zpts-2.0*h)) )
            hbot = hbot/( 1.-exp(-2.0*bbot*h) )
            d2hbot = bbot**2*hbot
            htop = wbar/wbar(1)
            htop(nzp) = 0.
            d2htop = wbarpp/wbar(1)
            ! exponential for bottom from blayscal, CTR blending-function for top
            ! to ensure dhtop/dz | z=zpts(1) = 0
!             h = zpts(1) - zpts(nzp)
!             btop = 8.*atan(1.)
!     !         btop = .001
!             htop(1:nzp) = zpts(1:nzp)/h - sin( btop*zpts(1:nzp)/h )/btop
!             d2htop = btop/h**2.0*sin( btop*zpts(1:nzp)/h )

        case(3) ! channel flow from z = 0 to zlen
            btop = 50.0
            bbot = 50.0
            ! exponential from blayscal but equal at both ends
    !         htop(1:nzp) = exp( -btop*(zpts(1)-zpts(1:nzp)) )
    !         htop(nzp) = 0.0
    !         hbot(1:nzp) = exp( -bbot*zpts(1:nzp) )
    !         hbot(1) = 0.0
    !         d2htop = btop**2.0*htop
    !         d2hbot = bbot**2.0*hbot
            ! exponential with proper zero BC at other end
            h = zpts(1) - zpts(nzp)
            hbot = ( exp(-bbot*zpts) - exp(bbot*(zpts-2.0*h)) )
            hbot = hbot/( 1.-exp(-2.0*bbot*h) )
            d2hbot = bbot**2.0*hbot
            htop = exp(btop*(zpts-h))*(1.-exp(-2.0*btop*zpts))
            htop = htop/( 1.-exp(-2.0*btop*h) )
            d2htop = btop**2.0*htop
            ! CTR belnding function using x - sin(2pi*x/xlen)/2pi
    !         h = zpts(1) - zpts(nzp)
    !         btop = 8.*atan(1.)
    !         htop(1:nzp) = zpts(1:nzp)/h - sin( btop*zpts(1:nzp)/h )/btop
    !         d2htop = btop/h**2.0*sin( btop*zpts(1:nzp)/h )
    !         hbot = 1. - htop
    !         d2hbot = -d2htop

    end select

    if (debug>=2 .and. myid==0) then
        write(*,'(//,A)') '-----------------helmholtz----------------'
        write(*,*) 'hbot(z)='
        write(*,fm3) hbot(1:nzp)
        write(*,*) 'd^2 hbot/dz^2 ='
        write(*,fm3) d2hbot(1:nzp)
        write(*,*) 'htop(z)='
        write(*,fm3) htop(1:nzp)
        write(*,*) 'd^2 htop/dz^2 ='
        write(*,fm3) d2htop(1:nzp)
        write(*,*) 'h(z)*bc = '
        write(*,fm3) hbot(1:nzp)*bc(1,1,nzp) + htop(1:nzp)*bc(1,1,1)
    end if

    ! rhs = rhs - (D^2 - k^2 - dtnui)(htop(z)f1(x,y) + hbot(z)f2(x,y))
    do k=1,nzp
        do j=1,ny
            do i=1,nxpl
                abot = ( d2hbot(k) + (-wavxx(i) - wavyy(j) - dtnui)*hbot(k) )
                rhs(i,j,k) = rhs(i,j,k) - abot*bc(i,j,nzp)

                atop = ( d2htop(k) + (-wavxx(i) - wavyy(j) - dtnui)*htop(k) )
                rhs(i,j,k) = rhs(i,j,k) - atop*bc(i,j,1)
            end do
        end do
    end do

    if (debug>=2 .and. myid==0) then
        write(*,*) 'rhs(x,z) before helmholtz='
        write(*,fm1f) (rhs(1:nxpl,1,k),k=1,nzp)
    end if

    ! now solve for phi
    call solve_helmholtz(rhs, dtnui, nzm, diag, smat, simat)

    if (debug>=2 .and. myid==0) then
        write(*,*) 'rhs(x,z) after helmholtz='
        write(*,fm1f) (rhs(1:nxpl,1,k),k=1,nzp)
    end if

    ! form complete field u = phi + htop(z)f1(x,y) + hbot(z)f2(x,y)
    do k=1,nzpl
        rhs(:,:,k) = rhs(:,:,k) + hbot(k)*bc(:,:,nzp) + htop(k)*bc(:,:,1)
    end do

    deallocate(htop,hbot,d2htop,d2hbot)

end subroutine solve_nhom_helmholtz

end module helmholtz


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_radii( n, gg, r_in, r_out )

!  gg contains (in packed format) the lower triangular matrix G
!  which defines the ellipsoid E = {x | |G^T * x | <=1 }.
!  This routine returns in  r_in  and  r_out  the rdii of the
!  inscribed and circumscribed balls.  These are the inverses of the
!  larges and smallest singular vaues of G.

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: gg((n*(n+1))/2)
real(k_dp), intent(out) :: r_in, r_out

real(k_dp)   :: a(n,n), sv(n), u(n,n), vt(n,n), work(10*n*n+20*n)
integer      :: lwork, info, i, j, k
character(1) :: jobu, jobvt

lwork = 10*n*n+20*n

if( n > 1 ) then

! unpack gg into a

   a = 0.d0
   k = 0
   do j = 1, n
      do i = j, n
         k = k + 1
	     a(i,j) = gg(k)
      end do
   end do

!  form singular values

   jobu  = 'A'  !XXX 'N' should be sufficient, but leads to unexplained error
   jobvt = 'N'

   call dgesvd( jobu, jobvt, n, n, a, n, sv, u, n, vt, n, work, lwork, info )

   if( info /= 0 ) then
      write(0,*)'ell_radii: info, n, lwork, work(1) = ', info, n, lwork, work(1)
      write(0,*)'sv = '
      write(0,'(1p,5e13.4)') sv
      stop
   endif

elseif( n ==1 ) then

   sv(1) = gg(1)

else
   write(0,*)'ell_radii: invalid n = ', n
   stop
endif

if( sv(n) <= 0.d0 ) then
   write(0,*)'ell_radii: bad singular value ', sv
   stop
endif

r_in  = 1.d0 / sv(1)
r_out = 1.d0 / sv(n)

return
end subroutine ell_radii


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Complex polylogarithm \f$\mathrm{Li}_4(z)\f$
!> @param z complex argument
!> @return \f$\mathrm{Li}_4(z)\f$
!> @author Alexander Voigt
!*********************************************************************
double complex function cdli4(z)
  implicit none
  double complex :: z, u, u2, u4, u8, c3, lmz, r, fast_pos_cdlog
  double precision :: rz, iz, nz, pz, lnz, arg, sgn
  double precision, parameter :: PI    = 3.1415926535897932D0
  double precision, parameter :: PI2   = 9.8696044010893586D0
  double precision, parameter :: PI4   = 97.409091034002437D0
  double precision, parameter :: zeta4 = 1.0823232337111382D0
  double precision, parameter :: c1    = 1.2020569031595943D0
  double precision, parameter :: c2    = 0.82246703342411322D0
  double precision, parameter :: c4    = -1D0/48D0
  double precision, parameter :: bf(18) = (/           &
      1.0D0                 , -7.0D0/16.0D0          , &
      1.1651234567901235D-01, -1.9820601851851852D-02, &
      1.9279320987654321D-03, -3.1057098765432099D-05, &
     -1.5624009114857835D-05,  8.4851235467732066D-07, &
      2.2909616603189711D-07, -2.1832614218526917D-08, &
     -3.8828248791720156D-09,  5.4462921032203321D-10, &
      6.9608052106827254D-11, -1.3375737686445215D-11, &
     -1.2784852685266572D-12,  3.2605628580248922D-13, &
      2.3647571168618257D-14, -7.9231351220311617D-15  /)
  double precision, parameter :: cs(7) = (/            &
     -6.9444444444444444D-04, 1.6534391534391534D-06,  &
     -1.0935444136502338D-08, 1.0438378493934049D-10,  &
     -1.2165942300622435D-12, 1.6130006528350101D-14,  &
     -2.3428810452879340D-16                           /)

  rz = real(z)
  iz = aimag(z)

   if (iz .eq. 0) then
      if (rz .eq. 0) then
         cdli4 = 0
         return
      endif
      if (rz .eq. 1) then
         cdli4 = zeta4
         return
      endif
      if (rz .eq. -1) then
         cdli4 = -7*PI4/720
         return
      endif
   endif

   nz  = rz**2 + iz**2
   pz  = datan2(iz, rz)
   lnz = 0.5D0*log(nz)

   if (lnz**2 + pz**2 .lt. 1) then ! |log(z)| < 1
      u = dcmplx(lnz, pz) ! log(z)
      u2 = u**2
      u4 = u2**2
      u8 = u4**2
      c3 = (11D0/6 - fast_pos_cdlog(-u))/6
      cdli4 = zeta4 + u2 * (c2 + u2 * c4) +                   &
          u * (                                               &
              c1 +                                            &
              c3*u2 +                                         &
              u4*(cs(1) + u2*cs(2)) +                         &
              u8*(cs(3) + u2*cs(4) + u4*(cs(5) + u2*cs(6))) + &
              u8*u8*cs(7)                                     &
          )
      return
   endif

   if (nz .le. 1) then
      u = -fast_pos_cdlog(1 - z)
      r = 0
      sgn = 1
   else ! nz > 1
      if (pz .gt. 0) then
         arg = pz - PI
      else
         arg = pz + PI
      endif
      lmz = dcmplx(lnz, arg) ! log(-z)
      u = -fast_pos_cdlog(1 - 1/z)
      r = (-7*PI4 + lmz**2*(-30*PI2 - 15*lmz**2))/360
      sgn = -1
   endif

   u2 = u**2
   u4 = u2**2
   u8 = u4**2

   cdli4 =                                                      &
      r + sgn * (                                               &
         u*bf(1) +                                              &
         u2*(bf(2) + u*bf(3)) +                                 &
         u4*(bf(4) + u*bf(5) + u2*(bf(6) + u*bf(7))) +          &
         u8*(bf(8) + u*bf(9) + u2*(bf(10) + u*bf(11)) +         &
             u4*(bf(12) + u*bf(13) + u2*(bf(14) + u*bf(15)))) + &
         u8*u8*(bf(16) + u*bf(17) + u2*bf(18))                  &
      )

end function cdli4