!!**.****|****.****|****.****|****.****|****.****|****.****|****.****|****.****|
!! * inter.f *                                     galprop package * 4/14/2000
!!**"****!****"****!****"****!****"****!****"****!****"****!****"****!****"****|

      SUBROUTINE INTER(XX,FF,NN,X0,F1)
C********************************************************************
C* INTERPOLATION BY THE CUBIC POLINOM, REAL*4 version               *
C* XX,FF  ARE THE ARGUMENT AND FUNCTION ARRAYS (j=1..NN);           *
C* X0  IS THE ARGUMENT AT WHICH THE FUNCTION IS TO BE EVALUATED;    *
C* F1  ON EXIT, IS THE EVALUATED VALUE OF THE FUNCTION.             *
C********************************************************************
      IMPLICIT real (A-H,O-Z)
      IMPLICIT integer (I-N)
      DIMENSION XX(NN),FF(NN)
      IN=0
      N1=NN-1
      DO 1 M=1,N1
         IF(X0.GE.XX(M).AND.X0.LE.XX(M+1)) GOTO 2
1           CONTINUE
2     IN=M
      IF(IN.EQ.1.OR.X0.LT.XX(1)) IN=2
      IF(IN.EQ.N1.OR.X0.GT.XX(NN)) IN=NN-2
      X1=XX(IN-1)
      X2=XX(IN)
      X3=XX(IN+1)
      X4=XX(IN+2)
      Y1=FF(IN-1)
      Y2=FF(IN)
      Y3=FF(IN+1)
      Y4=FF(IN+2)
      X01=X0-X1
      X02=X0-X2
      X03=X0-X3
      X04=X0-X4
      X12=X1-X2
      X13=X1-X3
      X14=X1-X4
      X23=X2-X3
      X24=X2-X4
      X34=X3-X4
      X1= X02*X03*X04/X12/X13/X14
      X2=-X01*X03*X04/X12/X23/X24
      X3= X01*X02*X04/X13/X23/X34
      X4=-X01*X02*X03/X14/X24/X34
      F1= Y1*X1+Y2*X2+Y3*X3+Y4*X4
      RETURN
      END

      SUBROUTINE DINTER(XX,FF,NN,X0,F1)
C********************************************************************
C* INTERPOLATION BY CUBIC POLINOM, REAL*8 version                   *
C* XX,FF  ARE THE ARGUMENT AND FUNCTION ARRAYS (j=1..NN);           *
C* X0  IS THE ARGUMENT AT WHICH THE FUNCTION IS TO BE EVALUATED;    *
C* F1  ON EXIT, IS THE EVALUATED VALUE OF THE FUNCTION.             *
C********************************************************************
      IMPLICIT real*8  (A-H,O-Z)
      IMPLICIT integer (I-N)
      DIMENSION XX(NN),FF(NN)
      IN=0
      N1=NN-1
      DO 1 M=1,N1
         IF(X0.GE.XX(M).AND.X0.LE.XX(M+1)) GOTO 2
1           CONTINUE
2     IN=M
      IF(IN.EQ.1.OR.X0.LT.XX(1)) IN=2
      IF(IN.EQ.N1.OR.X0.GT.XX(NN)) IN=NN-2
      X1=XX(IN-1)
      X2=XX(IN)
      X3=XX(IN+1)
      X4=XX(IN+2)
      Y1=FF(IN-1)
      Y2=FF(IN)
      Y3=FF(IN+1)
      Y4=FF(IN+2)
      X01=X0-X1
      X02=X0-X2
      X03=X0-X3
      X04=X0-X4
      X12=X1-X2
      X13=X1-X3
      X14=X1-X4
      X23=X2-X3
      X24=X2-X4
      X34=X3-X4
      X1= X02*X03*X04/X12/X13/X14
      X2=-X01*X03*X04/X12/X23/X24
      X3= X01*X02*X04/X13/X23/X34
      X4=-X01*X02*X03/X14/X24/X34
      F1= Y1*X1+Y2*X2+Y3*X3+Y4*X4
      RETURN
      END


      SUBROUTINE MB03HZ( S11, S12, H11, H12, CO, SI )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute a unitary matrix Q for a complex regular 2-by-2
C     skew-Hamiltonian/Hamiltonian pencil aS - bH with
C
C         (  S11  S12  )        (  H11  H12  )
C     S = (            ),   H = (            ),
C         (   0   S11' )        (   0  -H11' )
C
C     such that J Q' J' (aS - bH) Q is upper triangular but the
C     eigenvalues are in reversed order. The matrix Q is represented by
C
C         (  CO  SI  )
C     Q = (          ).
C         ( -SI' CO  )
C
C     The notation M' denotes the conjugate transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     S11     (input) COMPLEX*16
C             Upper left element of the skew-Hamiltonian matrix S.
C
C     S12     (input) COMPLEX*16
C             Upper right element of the skew-Hamiltonian matrix S.
C
C     H11     (input) COMPLEX*16
C             Upper left element of the Hamiltonian matrix H.
C
C     H12     (input) COMPLEX*16
C             Upper right element of the Hamiltonian matrix H.
C
C     CO      (output) DOUBLE PRECISION
C             Upper left element of Q.
C
C     SI      (output) COMPLEX*16
C             Upper right element of Q.
C
C     METHOD
C
C     The algorithm uses unitary transformations as described on page 43
C     in [1].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, January 28, 2009.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZHAUEX).
C     V. Sima, Jan. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, skew-Hamiltonian/Hamiltonian pencil, upper
C     triangular matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   CO
      COMPLEX*16         H11, H12, S11, S12, SI
C
C     .. Local Scalars ..
      COMPLEX*16         G, TMP
C
C     .. External Subroutines ..
      EXTERNAL           ZLARTG
C
C     .. Intrinsic Functions ..
      INTRINSIC          CONJG, DBLE
C
C     .. Executable Statements ..
C
      G = TWO*DBLE( H11*CONJG( S11 ) )
      CALL ZLARTG( CONJG( S11 )*H12 + S12*CONJG( H11 ), G, CO, SI, TMP )
C
      RETURN
C *** Last line of MB03HZ ***
      END


!====================================================================
    SUBROUTINE facdyk(ktx, k, ipvtd, dyk)
!====================================================================
!
!   Sets up the matrix
!
!       DD(i,j)-k*(k+1)*rm2
!
!   for solving the following differential equation by the
!   spline-Galerkin method:
!
!       (d^2-k(k+1)/r^2)yk(r) = -(2k+1) B_jf B_js(r)/r,
!
!   with boundary conditions:
!       at r=0, yk(r) = 0;
!       at r=rmax, yk(r) = const, if k=0,
!                  dy/dr + (k/r)y = B_jf(r) B_js(r) if k>0.
!
!   CALL:    dgbfa (LINPACK)  or DGBTRF (LAPACK)
!
!--------------------------------------------------------------------
!
!   on entry
!   --------
!       ktx  the leading dimension of dyk
!       k    the order of y.
!
!   on exit
!   -------
!       dyk  factorized array for the differential with operator
!            (d^2-k(k+1)/r^2). dyk is banded with
!            width 3*ks-2. The first ks-1 rows are zeros, and the
!            following k rows are the elements above the diagnal,
!            the last ks-1 rows are the elements below the diagnal of
!            the original arrays.
!
!--------------------------------------------------------------------

       USE spline_param; USE spline_grid; USE spline_galerkin

       IMPLICIT NONE
       INTEGER(4), INTENT(IN) :: ktx, k
       REAL(8), DIMENSION(ktx, ns) :: dyk
       INTEGER(4), DIMENSION(ns) :: ipvtd

       REAL(8) :: fkk
       INTEGER(4) :: i, j, nn, ier

       fkk = -k*(k + 1)
       dyk = 0.d0              ! .. clear the dyk array

       ! .. set up dyk

       ! .. lower portion

       do j = 1, ks
          do i = ks - j + 1, ns
             dyk(3*ks - 1 - j, i - ks + j) = db2(i, j) + fkk*rm2(i, j)
          end do
       end do

       ! .. upper portion

       do j = 2, ks
          do i = 1, ns - j + 1
             dyk(2*ks - j, i + j - 1) = db2(i + j - 1, ks - j + 1) + fkk*rm2(i + j - 1, ks - j + 1)
          end do
       end do

       ! .. correct the upper portion of the matrix for the asymmetry
       ! .. of d^2/dr^2

       j = 2*ks - 2
       dyk(j, ns) = dyk(j, ns) + db2(1, 1) - db2(ns, ks - 1)

       ! .. apply the zero boundary condition at the origin and modify the
       ! .. last equation for the boundary condition at rmax

       do i = 1, ks
          j = 2*ks - i
          dyk(j, i) = 0.d0
          j = 3*ks - 1 - i
          dyk(j, ns - ks + i) = 0.d0
       end do
       dyk(2*ks - 1, 1) = 1.d0

       ! .. apply the boundary condition at rmax
       ! .. yk(r) = const, if k=0,
       ! .. dy/dr + (k/r)y = B_jf(r) B_js(r) if k>0.

       if (k /= 0) then
          nn = nv + 1
          dyk(2*ks, ns - 1) = bspd(nn, 1, ks - 1, 1)
          dyk(2*ks - 1, ns) = bspd(nn, 1, ks, 1) + bsp(nn, 1, ks)*k/t(ns + 1)
       else
          dyk(2*ks - 1, ns) = 1.d0
       end if

       ! .. factorize dyk

!    CALL dgbfa(dyk,ktx,ns,ks-1,ks-1,ipvtd,ier)
!    IF (ier /= 0) STOP 'FACDYK: dgbtrf from LINPACK failed'

       Call DGBTRF(ns, ns, ks - 1, ks - 1, dyk, ktx, ipvtd, ier)
       if (ier .ne. 0) Stop 'FACDYK: dgbtrf from LAPACK failed'

    END SUBROUTINE facdyk


C AREA OF A TRIANGLE WITH A STANDARD SQUARE ROOT FUNCTION
C INPUT - TAPE READER UNIT 5, INTEGER INPUT
C OUTPUT - LINE PRINTER UNIT 6, REAL OUTPUT
C INPUT ERROR DISPLAY ERROR OUTPUT CODE 1 IN JOB CONTROL LISTING
C      READ INPUT TAPE 5, 501, IA, IB, IC
  501 FORMAT (3I5)
C IA, IB, AND IC MAY NOT BE NEGATIVE OR ZERO
C FURTHERMORE, THE SUM OF TWO SIDES OF A TRIANGLE
C MUST BE GREATER THAN THE THIRD SIDE, SO WE CHECK FOR THAT, TOO
      IF (IA) 777, 777, 701
  701 IF (IB) 777, 777, 702
  702 IF (IC) 777, 777, 703
  703 IF (IA+IB-IC) 777, 777, 704
  704 IF (IA+IC-IB) 777, 777, 705
  705 IF (IB+IC-IA) 777, 777, 799
  777 STOP 1
C USING HERON'S FORMULA WE CALCULATE THE
C AREA OF THE TRIANGLE
  799 S = FLOATF (IA + IB + IC) / 2.0
      AREA = SQRTF( S * (S - FLOATF(IA)) * (S - FLOATF(IB)) *
     +     (S - FLOATF(IC)))
      WRITE OUTPUT TAPE 6, 601, IA, IB, IC, AREA
  601 FORMAT (4H A= ,I5,5H  B= ,I5,5H  C= ,I5,8H  AREA= ,F10.2,
     +        13H SQUARE UNITS)
      STOP
      END


*> \brief \b DORCSD2BY1
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORCSD2BY1 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
*                              X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
*                              LDV1T, WORK, LWORK, IWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOBU1, JOBU2, JOBV1T
*       INTEGER            INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
*      $                   M, P, Q
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   THETA(*)
*       DOUBLE PRECISION   U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
*      $                   X11(LDX11,*), X21(LDX21,*)
*       INTEGER            IWORK(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*>\verbatim
*>
*> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
*> orthonormal columns that has been partitioned into a 2-by-1 block
*> structure:
*>
*>                                [  I1 0  0 ]
*>                                [  0  C  0 ]
*>          [ X11 ]   [ U1 |    ] [  0  0  0 ]
*>      X = [-----] = [---------] [----------] V1**T .
*>          [ X21 ]   [    | U2 ] [  0  0  0 ]
*>                                [  0  S  0 ]
*>                                [  0  0  I2]
*>
*> X11 is P-by-Q. The orthogonal matrices U1, U2, and V1 are P-by-P,
*> (M-P)-by-(M-P), and Q-by-Q, respectively. C and S are R-by-R
*> nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which
*> R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a
*> K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBU1
*> \verbatim
*>          JOBU1 is CHARACTER
*>          = 'Y':      U1 is computed;
*>          otherwise:  U1 is not computed.
*> \endverbatim
*>
*> \param[in] JOBU2
*> \verbatim
*>          JOBU2 is CHARACTER
*>          = 'Y':      U2 is computed;
*>          otherwise:  U2 is not computed.
*> \endverbatim
*>
*> \param[in] JOBV1T
*> \verbatim
*>          JOBV1T is CHARACTER
*>          = 'Y':      V1T is computed;
*>          otherwise:  V1T is not computed.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows in X.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is INTEGER
*>          The number of rows in X11. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*>          Q is INTEGER
*>          The number of columns in X11 and X21. 0 <= Q <= M.
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*>          X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
*>          On entry, part of the orthogonal matrix whose CSD is desired.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*>          LDX11 is INTEGER
*>          The leading dimension of X11. LDX11 >= MAX(1,P).
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*>          X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
*>          On entry, part of the orthogonal matrix whose CSD is desired.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*>          LDX21 is INTEGER
*>          The leading dimension of X21. LDX21 >= MAX(1,M-P).
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*>          THETA is DOUBLE PRECISION array, dimension (R), in which R =
*>          MIN(P,M-P,Q,M-Q).
*>          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
*>          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
*> \endverbatim
*>
*> \param[out] U1
*> \verbatim
*>          U1 is DOUBLE PRECISION array, dimension (P)
*>          If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
*> \endverbatim
*>
*> \param[in] LDU1
*> \verbatim
*>          LDU1 is INTEGER
*>          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
*>          MAX(1,P).
*> \endverbatim
*>
*> \param[out] U2
*> \verbatim
*>          U2 is DOUBLE PRECISION array, dimension (M-P)
*>          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
*>          matrix U2.
*> \endverbatim
*>
*> \param[in] LDU2
*> \verbatim
*>          LDU2 is INTEGER
*>          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
*>          MAX(1,M-P).
*> \endverbatim
*>
*> \param[out] V1T
*> \verbatim
*>          V1T is DOUBLE PRECISION array, dimension (Q)
*>          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
*>          matrix V1**T.
*> \endverbatim
*>
*> \param[in] LDV1T
*> \verbatim
*>          LDV1T is INTEGER
*>          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
*>          MAX(1,Q).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*>          If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
*>          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
*>          define the matrix in intermediate bidiagonal-block form
*>          remaining after nonconvergence. INFO specifies the number
*>          of nonzero PHI's.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the work array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*>          > 0:  DBBCSD did not converge. See the description of WORK
*>                above for details.
*> \endverbatim
*
*> \par References:
*  ================
*>
*>  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*>      Algorithms, 50(1):33-65, 2009.
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup doubleOTHERcomputational
*
*  =====================================================================
      SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
     $                       X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
     $                       LDV1T, WORK, LWORK, IWORK, INFO )
*
*  -- LAPACK computational routine (3.5.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          JOBU1, JOBU2, JOBV1T
      INTEGER            INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
     $                   M, P, Q
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   THETA(*)
      DOUBLE PRECISION   U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
     $                   X11(LDX11,*), X21(LDX21,*)
      INTEGER            IWORK(*)
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
*     ..
*     .. Local Scalars ..
      INTEGER            CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
     $                   IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
     $                   IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
     $                   J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
     $                   LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
     $                   LWORKMIN, LWORKOPT, R
      LOGICAL            LQUERY, WANTU1, WANTU2, WANTV1T
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   DUM1(1), DUM2(1,1)
*     ..
*     .. External Subroutines ..
      EXTERNAL           DBBCSD, DCOPY, DLACPY, DLAPMR, DLAPMT, DORBDB1,
     $                   DORBDB2, DORBDB3, DORBDB4, DORGLQ, DORGQR,
     $                   XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Function ..
      INTRINSIC          INT, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test input arguments
*
      INFO = 0
      WANTU1 = LSAME( JOBU1, 'Y' )
      WANTU2 = LSAME( JOBU2, 'Y' )
      WANTV1T = LSAME( JOBV1T, 'Y' )
      LQUERY = LWORK .EQ. -1
*
      IF( M .LT. 0 ) THEN
         INFO = -4
      ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
         INFO = -5
      ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
         INFO = -6
      ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
         INFO = -8
      ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
         INFO = -10
      ELSE IF( WANTU1 .AND. LDU1 .LT. MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( WANTU2 .AND. LDU2 .LT. MAX( 1, M - P ) ) THEN
         INFO = -15
      ELSE IF( WANTV1T .AND. LDV1T .LT. MAX( 1, Q ) ) THEN
         INFO = -17
      END IF
*
      R = MIN( P, M-P, Q, M-Q )
*
*     Compute workspace
*
*       WORK layout:
*     |-------------------------------------------------------|
*     | LWORKOPT (1)                                          |
*     |-------------------------------------------------------|
*     | PHI (MAX(1,R-1))                                      |
*     |-------------------------------------------------------|
*     | TAUP1 (MAX(1,P))                        | B11D (R)    |
*     | TAUP2 (MAX(1,M-P))                      | B11E (R-1)  |
*     | TAUQ1 (MAX(1,Q))                        | B12D (R)    |
*     |-----------------------------------------| B12E (R-1)  |
*     | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R)    |
*     |             |             |             | B21E (R-1)  |
*     |             |             |             | B22D (R)    |
*     |             |             |             | B22E (R-1)  |
*     |             |             |             | DBBCSD WORK |
*     |-------------------------------------------------------|
*
      IF( INFO .EQ. 0 ) THEN
         IPHI = 2
         IB11D = IPHI + MAX( 1, R-1 )
         IB11E = IB11D + MAX( 1, R )
         IB12D = IB11E + MAX( 1, R - 1 )
         IB12E = IB12D + MAX( 1, R )
         IB21D = IB12E + MAX( 1, R - 1 )
         IB21E = IB21D + MAX( 1, R )
         IB22D = IB21E + MAX( 1, R - 1 )
         IB22E = IB22D + MAX( 1, R )
         IBBCSD = IB22E + MAX( 1, R - 1 )
         ITAUP1 = IPHI + MAX( 1, R-1 )
         ITAUP2 = ITAUP1 + MAX( 1, P )
         ITAUQ1 = ITAUP2 + MAX( 1, M-P )
         IORBDB = ITAUQ1 + MAX( 1, Q )
         IORGQR = ITAUQ1 + MAX( 1, Q )
         IORGLQ = ITAUQ1 + MAX( 1, Q )
         LORGQRMIN = 1
         LORGQROPT = 1
         LORGLQMIN = 1
         LORGLQOPT = 1
         IF( R .EQ. Q ) THEN
            CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                    DUM1, DUM1, DUM1, DUM1, WORK,
     $                    -1, CHILDINFO )
            LORBDB = INT( WORK(1) )
            IF( WANTU1 .AND. P .GT. 0 ) THEN
               CALL DORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1,
     $                      CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, P )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            ENDIF
            IF( WANTU2 .AND. M-P .GT. 0 ) THEN
               CALL DORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1),
     $                      -1, CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, M-P )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            END IF
            IF( WANTV1T .AND. Q .GT. 0 ) THEN
               CALL DORGLQ( Q-1, Q-1, Q-1, V1T, LDV1T,
     $                      DUM1, WORK(1), -1, CHILDINFO )
               LORGLQMIN = MAX( LORGLQMIN, Q-1 )
               LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) )
            END IF
            CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
     $                   DUM1, U1, LDU1, U2, LDU2, V1T, LDV1T,
     $                   DUM2, 1, DUM1, DUM1, DUM1,
     $                   DUM1, DUM1, DUM1, DUM1,
     $                   DUM1, WORK(1), -1, CHILDINFO )
            LBBCSD = INT( WORK(1) )
         ELSE IF( R .EQ. P ) THEN
            CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                    DUM1, DUM1, DUM1, DUM1,
     $                    WORK(1), -1, CHILDINFO )
            LORBDB = INT( WORK(1) )
            IF( WANTU1 .AND. P .GT. 0 ) THEN
               CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, DUM1,
     $                      WORK(1), -1, CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, P-1 )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            END IF
            IF( WANTU2 .AND. M-P .GT. 0 ) THEN
               CALL DORGQR( M-P, M-P, Q, U2, LDU2, DUM1, WORK(1),
     $                      -1, CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, M-P )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            END IF
            IF( WANTV1T .AND. Q .GT. 0 ) THEN
               CALL DORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1,
     $                      CHILDINFO )
               LORGLQMIN = MAX( LORGLQMIN, Q )
               LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) )
            END IF
            CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
     $                   DUM1, V1T, LDV1T, DUM2, 1, U1, LDU1,
     $                   U2, LDU2, DUM1, DUM1, DUM1,
     $                   DUM1, DUM1, DUM1, DUM1,
     $                   DUM1, WORK(1), -1, CHILDINFO )
            LBBCSD = INT( WORK(1) )
         ELSE IF( R .EQ. M-P ) THEN
            CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                    DUM1, DUM1, DUM1, DUM1,
     $                    WORK(1), -1, CHILDINFO )
            LORBDB = INT( WORK(1) )
            IF( WANTU1 .AND. P .GT. 0 ) THEN
               CALL DORGQR( P, P, Q, U1, LDU1, DUM1, WORK(1), -1,
     $                      CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, P )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            END IF
            IF( WANTU2 .AND. M-P .GT. 0 ) THEN
               CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
     $                      DUM1, WORK(1), -1, CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, M-P-1 )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            END IF
            IF( WANTV1T .AND. Q .GT. 0 ) THEN
               CALL DORGLQ( Q, Q, R, V1T, LDV1T, DUM1, WORK(1), -1,
     $                      CHILDINFO )
               LORGLQMIN = MAX( LORGLQMIN, Q )
               LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) )
            END IF
            CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
     $                   THETA, DUM1, DUM2, 1, V1T, LDV1T, U2,
     $                   LDU2, U1, LDU1, DUM1, DUM1, DUM1,
     $                   DUM1, DUM1, DUM1, DUM1,
     $                   DUM1, WORK(1), -1, CHILDINFO )
            LBBCSD = INT( WORK(1) )
         ELSE
            CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                    DUM1, DUM1, DUM1, DUM1,
     $                    DUM1, WORK(1), -1, CHILDINFO )
            LORBDB = M + INT( WORK(1) )
            IF( WANTU1 .AND. P .GT. 0 ) THEN
               CALL DORGQR( P, P, M-Q, U1, LDU1, DUM1, WORK(1), -1,
     $                      CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, P )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            END IF
            IF( WANTU2 .AND. M-P .GT. 0 ) THEN
               CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, DUM1, WORK(1),
     $                      -1, CHILDINFO )
               LORGQRMIN = MAX( LORGQRMIN, M-P )
               LORGQROPT = MAX( LORGQROPT, INT( WORK(1) ) )
            END IF
            IF( WANTV1T .AND. Q .GT. 0 ) THEN
               CALL DORGLQ( Q, Q, Q, V1T, LDV1T, DUM1, WORK(1), -1,
     $                      CHILDINFO )
               LORGLQMIN = MAX( LORGLQMIN, Q )
               LORGLQOPT = MAX( LORGLQOPT, INT( WORK(1) ) )
            END IF
            CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
     $                   THETA, DUM1, U2, LDU2, U1, LDU1, DUM2,
     $                   1, V1T, LDV1T, DUM1, DUM1, DUM1,
     $                   DUM1, DUM1, DUM1, DUM1,
     $                   DUM1, WORK(1), -1, CHILDINFO )
            LBBCSD = INT( WORK(1) )
         END IF
         LWORKMIN = MAX( IORBDB+LORBDB-1,
     $                   IORGQR+LORGQRMIN-1,
     $                   IORGLQ+LORGLQMIN-1,
     $                   IBBCSD+LBBCSD-1 )
         LWORKOPT = MAX( IORBDB+LORBDB-1,
     $                   IORGQR+LORGQROPT-1,
     $                   IORGLQ+LORGLQOPT-1,
     $                   IBBCSD+LBBCSD-1 )
         WORK(1) = LWORKOPT
         IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
            INFO = -19
         END IF
      END IF
      IF( INFO .NE. 0 ) THEN
         CALL XERBLA( 'DORCSD2BY1', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
      LORGQR = LWORK-IORGQR+1
      LORGLQ = LWORK-IORGLQ+1
*
*     Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
*     in which R = MIN(P,M-P,Q,M-Q)
*
      IF( R .EQ. Q ) THEN
*
*        Case 1: R = Q
*
*        Simultaneously bidiagonalize X11 and X21
*
         CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                 WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
     $                 WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
*        Accumulate Householder reflectors
*
         IF( WANTU1 .AND. P .GT. 0 ) THEN
            CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
            CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
     $                   LORGQR, CHILDINFO )
         END IF
         IF( WANTU2 .AND. M-P .GT. 0 ) THEN
            CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
            CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
     $                   WORK(IORGQR), LORGQR, CHILDINFO )
         END IF
         IF( WANTV1T .AND. Q .GT. 0 ) THEN
            V1T(1,1) = ONE
            DO J = 2, Q
               V1T(1,J) = ZERO
               V1T(J,1) = ZERO
            END DO
            CALL DLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
     $                   LDV1T )
            CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
     $                   WORK(IORGLQ), LORGLQ, CHILDINFO )
         END IF
*
*        Simultaneously diagonalize X11 and X21.
*
         CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
     $                WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T,
     $                DUM2, 1, WORK(IB11D), WORK(IB11E),
     $                WORK(IB12D), WORK(IB12E), WORK(IB21D),
     $                WORK(IB21E), WORK(IB22D), WORK(IB22E),
     $                WORK(IBBCSD), LBBCSD, CHILDINFO )
*
*        Permute rows and columns to place zero submatrices in
*        preferred positions
*
         IF( Q .GT. 0 .AND. WANTU2 ) THEN
            DO I = 1, Q
               IWORK(I) = M - P - Q + I
            END DO
            DO I = Q + 1, M - P
               IWORK(I) = I - Q
            END DO
            CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
         END IF
      ELSE IF( R .EQ. P ) THEN
*
*        Case 2: R = P
*
*        Simultaneously bidiagonalize X11 and X21
*
         CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                 WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
     $                 WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
*        Accumulate Householder reflectors
*
         IF( WANTU1 .AND. P .GT. 0 ) THEN
            U1(1,1) = ONE
            DO J = 2, P
               U1(1,J) = ZERO
               U1(J,1) = ZERO
            END DO
            CALL DLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
            CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
     $                   WORK(IORGQR), LORGQR, CHILDINFO )
         END IF
         IF( WANTU2 .AND. M-P .GT. 0 ) THEN
            CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
            CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
     $                   WORK(IORGQR), LORGQR, CHILDINFO )
         END IF
         IF( WANTV1T .AND. Q .GT. 0 ) THEN
            CALL DLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
            CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
     $                   WORK(IORGLQ), LORGLQ, CHILDINFO )
         END IF
*
*        Simultaneously diagonalize X11 and X21.
*
         CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
     $                WORK(IPHI), V1T, LDV1T, DUM2, 1, U1, LDU1, U2,
     $                LDU2, WORK(IB11D), WORK(IB11E), WORK(IB12D),
     $                WORK(IB12E), WORK(IB21D), WORK(IB21E),
     $                WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
     $                CHILDINFO )
*
*        Permute rows and columns to place identity submatrices in
*        preferred positions
*
         IF( Q .GT. 0 .AND. WANTU2 ) THEN
            DO I = 1, Q
               IWORK(I) = M - P - Q + I
            END DO
            DO I = Q + 1, M - P
               IWORK(I) = I - Q
            END DO
            CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
         END IF
      ELSE IF( R .EQ. M-P ) THEN
*
*        Case 3: R = M-P
*
*        Simultaneously bidiagonalize X11 and X21
*
         CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                 WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
     $                 WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
*
*        Accumulate Householder reflectors
*
         IF( WANTU1 .AND. P .GT. 0 ) THEN
            CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
            CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
     $                   LORGQR, CHILDINFO )
         END IF
         IF( WANTU2 .AND. M-P .GT. 0 ) THEN
            U2(1,1) = ONE
            DO J = 2, M-P
               U2(1,J) = ZERO
               U2(J,1) = ZERO
            END DO
            CALL DLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
     $                   LDU2 )
            CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
     $                   WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
         END IF
         IF( WANTV1T .AND. Q .GT. 0 ) THEN
            CALL DLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
            CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
     $                   WORK(IORGLQ), LORGLQ, CHILDINFO )
         END IF
*
*        Simultaneously diagonalize X11 and X21.
*
         CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
     $                THETA, WORK(IPHI), DUM2, 1, V1T, LDV1T, U2,
     $                LDU2, U1, LDU1, WORK(IB11D), WORK(IB11E),
     $                WORK(IB12D), WORK(IB12E), WORK(IB21D),
     $                WORK(IB21E), WORK(IB22D), WORK(IB22E),
     $                WORK(IBBCSD), LBBCSD, CHILDINFO )
*
*        Permute rows and columns to place identity submatrices in
*        preferred positions
*
         IF( Q .GT. R ) THEN
            DO I = 1, R
               IWORK(I) = Q - R + I
            END DO
            DO I = R + 1, Q
               IWORK(I) = I - R
            END DO
            IF( WANTU1 ) THEN
               CALL DLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
            END IF
            IF( WANTV1T ) THEN
               CALL DLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
            END IF
         END IF
      ELSE
*
*        Case 4: R = M-Q
*
*        Simultaneously bidiagonalize X11 and X21
*
         CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
     $                 WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
     $                 WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
     $                 LORBDB-M, CHILDINFO )
*
*        Accumulate Householder reflectors
*
         IF( WANTU2 .AND. M-P .GT. 0 ) THEN
            CALL DCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
         END IF
         IF( WANTU1 .AND. P .GT. 0 ) THEN
            CALL DCOPY( P, WORK(IORBDB), 1, U1, 1 )
            DO J = 2, P
               U1(1,J) = ZERO
            END DO
            CALL DLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
     $                   LDU1 )
            CALL DORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
     $                   WORK(IORGQR), LORGQR, CHILDINFO )
         END IF
         IF( WANTU2 .AND. M-P .GT. 0 ) THEN
            DO J = 2, M-P
               U2(1,J) = ZERO
            END DO
            CALL DLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
     $                   LDU2 )
            CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
     $                   WORK(IORGQR), LORGQR, CHILDINFO )
         END IF
         IF( WANTV1T .AND. Q .GT. 0 ) THEN
            CALL DLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
            CALL DLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
     $                   V1T(M-Q+1,M-Q+1), LDV1T )
            CALL DLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
     $                   V1T(P+1,P+1), LDV1T )
            CALL DORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
     $                   WORK(IORGLQ), LORGLQ, CHILDINFO )
         END IF
*
*        Simultaneously diagonalize X11 and X21.
*
         CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
     $                THETA, WORK(IPHI), U2, LDU2, U1, LDU1, DUM2,
     $                1, V1T, LDV1T, WORK(IB11D), WORK(IB11E),
     $                WORK(IB12D), WORK(IB12E), WORK(IB21D),
     $                WORK(IB21E), WORK(IB22D), WORK(IB22E),
     $                WORK(IBBCSD), LBBCSD, CHILDINFO )
*
*        Permute rows and columns to place identity submatrices in
*        preferred positions
*
         IF( P .GT. R ) THEN
            DO I = 1, R
               IWORK(I) = P - R + I
            END DO
            DO I = R + 1, P
               IWORK(I) = I - R
            END DO
            IF( WANTU1 ) THEN
               CALL DLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
            END IF
            IF( WANTV1T ) THEN
               CALL DLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DORCSD2BY1
*
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine hcrit(xflow,rho,b,theta,dg,sqrts0,hk)
!
!     determine the critical depth
!
      implicit none
!
      real*8 xflow,rho,b,dg,sqrts0,hk,theta,tth,c1,xflow2,
     &  A,dBBdh,dAdh,BB,dhk
!
      hk=((xflow/(rho*b))**2/(dg*sqrts0))**(1.d0/3.d0)
!
      if(dabs(theta).lt.1.d-10) return
!
!     critical depth for trapezoid, non-rectangular cross section
!
      tth=dtan(theta)
      c1=rho*rho*dg*sqrts0
      xflow2=xflow*xflow
!
      do
         A=hk*(b+hk*tth)
         dBBdh=2.d0*tth
         dAdh=b+hk*dBBdh
         BB=dAdh
         dhk=(xflow2*BB-c1*A**3)/(xflow2*dBBdh-3.d0*c1*A*A*dAdh)
         if(dabs(dhk)/dhk.lt.1.d-3) exit
         hk=hk-dhk
      enddo
!
      return
      end


program main

   implicit none

   integer :: i, j
   real :: s1

   real, dimension(10, 10) :: c1010, d1010

   s1 = 0.125

   d1010 = 0.0
   d1010(1:9:2, 1:9:2) = reshape([((sin(real(i))*sin(real(j)), i=1, 5), j=1, 5)], [5, 5])
   d1010(2:10:2, 2:10:2) = reshape([((cos(real(i))*cos(real(j)), i=1, 5), j=1, 5)], [5, 5])

   print *, char(10), ' d1010: '
   do i = 1, 10

      print "(*(F9.4))", (d1010(i, j), j=1, 10)
   end do

   c1010 = s1
   c1010(1:9:2, 1) = d1010(1, 1:9:2)

   print *, char(10), 'c1010: '
   print "(*(g0))", ((abs(c1010(i, j)), " ", j=1, 10), new_line("A"), i=1, 10)

end program


      SUBROUTINE cdfchi(which,p,q,x,df,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFCHI( WHICH, P, Q, X, DF, STATUS, BOUND )
C               Cumulative Distribution Function
C               CHI-Square distribution
C
C
C                              Function
C
C
C     Calculates any one parameter of the chi-square
C     distribution given values for the others.
C
C
C                              Arguments
C
C
C     WHICH --> Integer indicating which of the next three argument
C               values is to be calculated from the others.
C               Legal range: 1..3
C               iwhich = 1 : Calculate P and Q from X and DF
C               iwhich = 2 : Calculate X from P,Q and DF
C               iwhich = 3 : Calculate DF from P,Q and X
C                    INTEGER WHICH
C
C     P <--> The integral from 0 to X of the chi-square
C            distribution.
C            Input range: [0, 1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: (0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C     X <--> Upper limit of integration of the non-central
C            chi-square distribution.
C            Input range: [0, +infinity).
C            Search range: [0,1E100]
C                    DOUBLE PRECISION X
C
C     DF <--> Degrees of freedom of the
C             chi-square distribution.
C             Input range: (0, +infinity).
C             Search range: [ 1E-100, 1E100]
C                    DOUBLE PRECISION DF
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C               10 indicates error returned from cumgam.  See
C                  references in cdfgam
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C     Formula    26.4.19   of Abramowitz  and     Stegun, Handbook  of
C     Mathematical Functions   (1966) is used   to reduce the chisqure
C     distribution to the incomplete distribution.
C
C     Computation of other parameters involve a seach for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-8)
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION zero,inf
      PARAMETER (zero=1.0D-100,inf=1.0D100)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,df,p,q,x
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ccum,cum,fx,porq,pq
      LOGICAL qhi,qleft,qporq
C     ..
C     .. External Functions ..
      DOUBLE PRECISION spmpar
      EXTERNAL spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL cumchi,dinvr,dstinv
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs
C     ..
      IF (.NOT. ((which.LT.1).OR. (which.GT.3))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 3.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
      IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60
      IF (.NOT. (p.LT.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = 1.0D0
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.1) GO TO 110
      IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100
      IF (.NOT. (q.LE.0.0D0)) GO TO 80
      bound = 0.0D0
      GO TO 90

   80 bound = 1.0D0
   90 status = -3
      RETURN

  100 CONTINUE
  110 IF (which.EQ.2) GO TO 130
      IF (.NOT. (x.LT.0.0D0)) GO TO 120
      bound = 0.0D0
      status = -4
      RETURN

  120 CONTINUE
  130 IF (which.EQ.3) GO TO 150
      IF (.NOT. (df.LE.0.0D0)) GO TO 140
      bound = 0.0D0
      status = -5
      RETURN

  140 CONTINUE
  150 IF (which.EQ.1) GO TO 190
      pq = p + q
      IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 180
      IF (.NOT. (pq.LT.0.0D0)) GO TO 160
      bound = 0.0D0
      GO TO 170

  160 bound = 1.0D0
  170 status = 3
      RETURN

  180 CONTINUE
  190 IF (which.EQ.1) GO TO 220
      qporq = p .LE. q
      IF (.NOT. (qporq)) GO TO 200
      porq = p
      GO TO 210

  200 porq = q
  210 CONTINUE
  220 IF ((1).EQ. (which)) THEN
          status = 0
          CALL cumchi(x,df,p,q)
          IF (porq.GT.1.5D0) THEN
              status = 10
              RETURN

          END IF

      ELSE IF ((2).EQ. (which)) THEN
          x = 5.0D0
          CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,x,fx,qleft,qhi)
  230     IF (.NOT. (status.EQ.1)) GO TO 270
          CALL cumchi(x,df,cum,ccum)
          IF (.NOT. (qporq)) GO TO 240
          fx = cum - p
          GO TO 250

  240     fx = ccum - q
  250     IF (.NOT. ((fx+porq).GT.1.5D0)) GO TO 260
          status = 10
          RETURN

  260     CALL dinvr(status,x,fx,qleft,qhi)
          GO TO 230

  270     IF (.NOT. (status.EQ.-1)) GO TO 300
          IF (.NOT. (qleft)) GO TO 280
          status = 1
          bound = 0.0D0
          GO TO 290

  280     status = 2
          bound = inf
  290     CONTINUE
  300     CONTINUE

      ELSE IF ((3).EQ. (which)) THEN
          df = 5.0D0
          CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,df,fx,qleft,qhi)
  310     IF (.NOT. (status.EQ.1)) GO TO 350
          CALL cumchi(x,df,cum,ccum)
          IF (.NOT. (qporq)) GO TO 320
          fx = cum - p
          GO TO 330

  320     fx = ccum - q
  330     IF (.NOT. ((fx+porq).GT.1.5D0)) GO TO 340
          status = 10
          RETURN

  340     CALL dinvr(status,df,fx,qleft,qhi)
          GO TO 310

  350     IF (.NOT. (status.EQ.-1)) GO TO 380
          IF (.NOT. (qleft)) GO TO 360
          status = 1
          bound = zero
          GO TO 370

  360     status = 2
          bound = inf
  370     CONTINUE
  380 END IF

      RETURN

      END


c orig code [ sp2_util.orig ]: John Adams
c .          check arguments to make sure calls are correct
c
      SUBROUTINE DGEOMATV(NLON,NLAT,U,V,WORK)
c
c pay special attention to subscript order
c .   nlon is first   [ u(nlon,nlat),v(nlon,nlat) ]
c
c     when invoked, this subroutine converts the nlon by nlat
c     geophysical vector field (u,v) to nlat by nlon mathematical
c     coordinates.  work is an UNSAVED work space of length at
c     least nlon*nlat
c
      IMPLICIT NONE
      INTEGER NLON,NLAT,I,J
      DOUBLE PRECISION U(NLON,NLAT),V(NLON,NLAT),WORK(*)
c
c     negate v
c
      DO J = 1,NLON
          DO I = 1,NLAT
              V(J,I) = -V(J,I)
          END DO
      END DO
c
c     traspose u,v
c
      CALL DTPLATX(NLON,NLAT,U,WORK)
      CALL DTPLATX(NLON,NLAT,V,WORK)
c
c     reverse (co)latitude subscript order
c
      CALL DCLATX(NLAT,NLON,U)
      CALL DCLATX(NLAT,NLON,V)

      RETURN
      END
c ---------------------------------------------------------
      SUBROUTINE DMATGEOV(NLAT,NLON,U,V,WORK)
c
c pay special attention to subscript order
c .   nlat is first dim  [ u(nlat,nlon), v(nlat,nlon) ]
c
c     when invoked, this subroutine converts the nlat by nlon
c     vector u & v, given in mathematical spherical coordinates, to
c     nlon by nlat vector field given in geophysical spherical
c     coordinates.  work is an UNSAVED work space of length at least
c     nlon*nlat
c
      IMPLICIT NONE
      INTEGER NLON,NLAT,I,J
      DOUBLE PRECISION U(NLAT,NLON),V(NLAT,NLON),WORK(*)
c
c     negate v
c
      DO J = 1,NLON
          DO I = 1,NLAT
              V(I,J) = -V(I,J)
          END DO
      END DO
c
c     reverse (co)latitude subscript order
c
      CALL DCLATX(NLAT,NLON,U)
      CALL DCLATX(NLAT,NLON,V)
c
c     transpose array
c
      CALL DTPLATX(NLAT,NLON,U,WORK)
      CALL DTPLATX(NLAT,NLON,V,WORK)

      RETURN
      END
c -------------------------------------------------------
      SUBROUTINE DGEOMAT(NLON,NLAT,S,WORK)
c
c pay special attention to subscript order
c .   nlon is first dim  [ s(nlon,nlat) ]
c
c     when invoked, this subroutine converts the nlon by nlat
c     scalar s, given in geophysical spherical coordinates, to
c     a nlat by nlon array given in mathematical spherical
c     coordinates.  work is an UNSAVED work space of length at
c     least nlon*nlat
c
      IMPLICIT NONE
      INTEGER NLON,NLAT
      DOUBLE PRECISION S(*),WORK(*)
c
c     traspose array
c
      CALL DTPLATX(NLON,NLAT,S,WORK)
c
c     reverse (co)latitude subscript order
c
      CALL DCLATX(NLAT,NLON,S)
      RETURN
      END
c -------------------------------------------------------------
      SUBROUTINE DMATGEO(NLAT,NLON,S,WORK)
c
c pay special attention to subscript order
c .   nlat is first dim  [ s(nlat,nlon) ]
c
c     when invoked, this subroutine converts the nlat by nlon
c     array s, given in mathematical spherical coordinates, to
c     a nlon by nlat array given in geophysical spherical
c     coordinates.  work is an UNSAVED work space of length at least
c     nlon*nlat
c
      IMPLICIT NONE
      INTEGER NLON,NLAT
      DOUBLE PRECISION S(*),WORK(*)
c
c     reverse (co)latitude subscript order
c
      CALL DCLATX(NLAT,NLON,S)
c
c     transpose array
c
      CALL DTPLATX(NLAT,NLON,S,WORK)
      RETURN
      END
c -------------------------------------------------------------
      SUBROUTINE DTPLATX(N,M,DATA,WORK)
c
c     transpose the n by m array data to a m by n array data
c     work must be at least n*m words long
c
      IMPLICIT NONE
      INTEGER N,M,I,J,IJ,JI
      DOUBLE PRECISION DATA(*),WORK(*)

      DO J = 1,M
          DO I = 1,N
              IJ = (J-1)*N + I
              WORK(IJ) = DATA(IJ)
          END DO
      END DO

      DO I = 1,N
          DO J = 1,M
              JI = (I-1)*M + J
              IJ = (J-1)*N + I
              DATA(JI) = WORK(IJ)
          END DO
      END DO

      RETURN
      END
c ----------------------------------------------------
      SUBROUTINE DCLATX(NLAT,NLON,DATA)
c
c     reverse order of latitude (colatitude) grids
c
      IMPLICIT NONE
      INTEGER NLAT,NLON,NLAT2,I,IB,J
      DOUBLE PRECISION DATA(NLAT,NLON),TEMP

      NLAT2 = NLAT/2
      DO I = 1,NLAT2
          IB = NLAT - I + 1
          DO J = 1,NLON
              TEMP = DATA(I,J)
              DATA(I,J) = DATA(IB,J)
              DATA(IB,J) = TEMP
          END DO
      END DO

      RETURN
      END
c ------------------------------------
      SUBROUTINE DCHKERR(STRING1,STRING2,IER,JER,KER,MER)
      IMPLICIT NONE

      INTEGER IER,JER,KER,MER
      CHARACTER*(*) STRING1,STRING2

      RETURN

      IF (IER.NE.0 .OR. JER.NE.0 .OR. KER.NE.0 .OR. MER.NE.0) THEN
          WRITE (*,FMT=
     +'('' ERROR: '',a,'' : '',a
     + ,'' : ier,jer,ker,mer='',4i3)') STRING1,STRING2,IER,JER,KER,MER
          STOP
      END IF
      END
c ---------------------------------------------------------
      SUBROUTINE DTRCTPR(NLAT,MWAVE,MDAB,NDAB,NT,A,B,IER)
      IMPLICIT NONE

c truncate spectral coefficients
c .   (possibly) taper the spectral coef

      INTEGER NLAT,MWAVE,MDAB,NDAB,NT,IER
      DOUBLE PRECISION A(MDAB,NDAB,NT),B(MDAB,NDAB,NT)

      DOUBLE PRECISION CON
      INTEGER NTWGT,M,N,IWAVE,JP,JW,J,K,MW2
      PARAMETER (NTWGT=500)
      DOUBLE PRECISION TWGT(NTWGT)

      IER = 0
      IF (MWAVE.EQ.0) RETURN

      MW2 = IABS(MWAVE) + 2

      DO K = 1,NT
          DO N = MW2,NLAT
              DO M = 1,N
                  A(M,N,K) = 0.0D0
                  B(M,N,K) = 0.0D0
              END DO
          END DO
      END DO

      IF (MWAVE.GT.0) RETURN

      IWAVE = IABS(MWAVE)
C perform exponential tapering

C exponent; determines fall-off rate
      JP = MAX0(IWAVE/10,1)
C coef which has wgt=exp(-1)
      JW = JP*10

      IF ((IWAVE+1).GT.NTWGT) THEN
          WRITE (*,FMT='(''taprwv: ntwgt exceeded='',2i5)') NTWGT,
     +      (IWAVE+1)
          RETURN
      END IF

      CON = 1.D0/DBLE(JW* (JW+1))
      DO J = 0,IWAVE
          TWGT(J+1) = EXP(- (DBLE(J* (J+1))*CON)**JP)
c c c    write (*,'(''taprwv: j, twgt(j)='',2i5,1x,f15.7)')
c c c*                        j, (j+1),twgt(j+1)
      END DO
C now wgt the coef by the wgts

      DO K = 1,NT
C traverse the diagonal
          DO N = IWAVE + 1,1,-1
              DO M = 1,N
                  A(M,N,K) = A(M,N,K)*TWGT(N)
                  B(M,N,K) = B(M,N,K)*TWGT(N)
              END DO
          END DO
      END DO

      RETURN
      END
c ----------------------------------------------------
      SUBROUTINE DGEOSCL(MLON,NLAT,NT,X,SCALE,NER)
      IMPLICIT NONE
      INTEGER MLON,NLAT,NT,NER
      DOUBLE PRECISION X(MLON,NLAT,NT),SCALE

      INTEGER N,ML,NL

c scale an array

      NER = 0
      IF (SCALE.EQ.1.0D0) RETURN

      DO N = 1,NT
          DO NL = 1,NLAT
              DO ML = 1,MLON
                  X(ML,NL,N) = X(ML,NL,N)*SCALE
              END DO
          END DO
      END DO

      RETURN
      END


*DECK QZVEC
      SUBROUTINE QZVEC (NM, N, A, B, ALFR, ALFI, BETA, Z)
C***BEGIN PROLOGUE  QZVEC
C***PURPOSE  The optional fourth step of the QZ algorithm for
C            generalized eigenproblems.  Accepts a matrix in
C            quasi-triangular form and another in upper triangular
C            and computes the eigenvectors of the triangular problem
C            and transforms them back to the original coordinates
C            Usually preceded by QZHES, QZIT, and QZVAL.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C3
C***TYPE      SINGLE PRECISION (QZVEC-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is the optional fourth step of the QZ algorithm
C     for solving generalized matrix eigenvalue problems,
C     SIAM J. NUMER. ANAL. 10, 241-256(1973) by MOLER and STEWART.
C
C     This subroutine accepts a pair of REAL matrices, one of them in
C     quasi-triangular form (in which each 2-by-2 block corresponds to
C     a pair of complex eigenvalues) and the other in upper triangular
C     form.  It computes the eigenvectors of the triangular problem and
C     transforms the results back to the original coordinate system.
C     It is usually preceded by  QZHES,  QZIT, and  QZVAL.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real upper quasi-triangular matrix.  A is a two-
C          dimensional REAL array, dimensioned A(NM,N).
C
C        B contains a real upper triangular matrix.  In addition,
C          location B(N,1) contains the tolerance quantity (EPSB)
C          computed and saved in  QZIT.  B is a two-dimensional REAL
C          array, dimensioned B(NM,N).
C
C        ALFR, ALFI, and BETA are one-dimensional REAL arrays with
C          components whose ratios ((ALFR+I*ALFI)/BETA) are the
C          generalized eigenvalues.  They are usually obtained from
C          QZVAL.  They are dimensioned ALFR(N), ALFI(N), and BETA(N).
C
C        Z contains the transformation matrix produced in the reductions
C          by  QZHES,  QZIT, and  QZVAL,  if performed.  If the
C          eigenvectors of the triangular problem are desired, Z must
C          contain the identity matrix.  Z is a two-dimensional REAL
C          array, dimensioned Z(NM,N).
C
C     On Output
C
C        A is unaltered.  Its subdiagonal elements provide information
C           about the storage of the complex eigenvectors.
C
C        B has been destroyed.
C
C        ALFR, ALFI, and BETA are unaltered.
C
C        Z contains the real and imaginary parts of the eigenvectors.
C          If ALFI(J) .EQ. 0.0, the J-th eigenvalue is real and
C            the J-th column of Z contains its eigenvector.
C          If ALFI(J) .NE. 0.0, the J-th eigenvalue is complex.
C            If ALFI(J) .GT. 0.0, the eigenvalue is the first of
C              a complex pair and the J-th and (J+1)-th columns
C              of Z contain its eigenvector.
C            If ALFI(J) .LT. 0.0, the eigenvalue is the second of
C              a complex pair and the (J-1)-th and J-th columns
C              of Z contain the conjugate of its eigenvector.
C          Each eigenvector is normalized so that the modulus
C          of its largest component is 1.0 .
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  QZVEC
C
      INTEGER I,J,K,M,N,EN,II,JJ,NA,NM,NN,ISW,ENM2
      REAL A(NM,*),B(NM,*),ALFR(*),ALFI(*),BETA(*),Z(NM,*)
      REAL D,Q,R,S,T,W,X,Y,DI,DR,RA,RR,SA,TI,TR,T1,T2
      REAL W1,X1,ZZ,Z1,ALFM,ALMI,ALMR,BETM,EPSB
C
C***FIRST EXECUTABLE STATEMENT  QZVEC
      EPSB = B(N,1)
      ISW = 1
C     .......... FOR EN=N STEP -1 UNTIL 1 DO -- ..........
      DO 800 NN = 1, N
         EN = N + 1 - NN
         NA = EN - 1
         IF (ISW .EQ. 2) GO TO 795
         IF (ALFI(EN) .NE. 0.0E0) GO TO 710
C     .......... REAL VECTOR ..........
         M = EN
         B(EN,EN) = 1.0E0
         IF (NA .EQ. 0) GO TO 800
         ALFM = ALFR(M)
         BETM = BETA(M)
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 700 II = 1, NA
            I = EN - II
            W = BETM * A(I,I) - ALFM * B(I,I)
            R = 0.0E0
C
            DO 610 J = M, EN
  610       R = R + (BETM * A(I,J) - ALFM * B(I,J)) * B(J,EN)
C
            IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 630
            IF (BETM * A(I,I-1) .EQ. 0.0E0) GO TO 630
            ZZ = W
            S = R
            GO TO 690
  630       M = I
            IF (ISW .EQ. 2) GO TO 640
C     .......... REAL 1-BY-1 BLOCK ..........
            T = W
            IF (W .EQ. 0.0E0) T = EPSB
            B(I,EN) = -R / T
            GO TO 700
C     .......... REAL 2-BY-2 BLOCK ..........
  640       X = BETM * A(I,I+1) - ALFM * B(I,I+1)
            Y = BETM * A(I+1,I)
            Q = W * ZZ - X * Y
            T = (X * S - ZZ * R) / Q
            B(I,EN) = T
            IF (ABS(X) .LE. ABS(ZZ)) GO TO 650
            B(I+1,EN) = (-R - W * T) / X
            GO TO 690
  650       B(I+1,EN) = (-S - Y * T) / ZZ
  690       ISW = 3 - ISW
  700    CONTINUE
C     .......... END REAL VECTOR ..........
         GO TO 800
C     .......... COMPLEX VECTOR ..........
  710    M = NA
         ALMR = ALFR(M)
         ALMI = ALFI(M)
         BETM = BETA(M)
C     .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT
C                EIGENVECTOR MATRIX IS TRIANGULAR ..........
         Y = BETM * A(EN,NA)
         B(NA,NA) = -ALMI * B(EN,EN) / Y
         B(NA,EN) = (ALMR * B(EN,EN) - BETM * A(EN,EN)) / Y
         B(EN,NA) = 0.0E0
         B(EN,EN) = 1.0E0
         ENM2 = NA - 1
         IF (ENM2 .EQ. 0) GO TO 795
C     .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- ..........
         DO 790 II = 1, ENM2
            I = NA - II
            W = BETM * A(I,I) - ALMR * B(I,I)
            W1 = -ALMI * B(I,I)
            RA = 0.0E0
            SA = 0.0E0
C
            DO 760 J = M, EN
               X = BETM * A(I,J) - ALMR * B(I,J)
               X1 = -ALMI * B(I,J)
               RA = RA + X * B(J,NA) - X1 * B(J,EN)
               SA = SA + X * B(J,EN) + X1 * B(J,NA)
  760       CONTINUE
C
            IF (I .EQ. 1 .OR. ISW .EQ. 2) GO TO 770
            IF (BETM * A(I,I-1) .EQ. 0.0E0) GO TO 770
            ZZ = W
            Z1 = W1
            R = RA
            S = SA
            ISW = 2
            GO TO 790
  770       M = I
            IF (ISW .EQ. 2) GO TO 780
C     .......... COMPLEX 1-BY-1 BLOCK ..........
            TR = -RA
            TI = -SA
  773       DR = W
            DI = W1
C     .......... COMPLEX DIVIDE (T1,T2) = (TR,TI) / (DR,DI) ..........
  775       IF (ABS(DI) .GT. ABS(DR)) GO TO 777
            RR = DI / DR
            D = DR + DI * RR
            T1 = (TR + TI * RR) / D
            T2 = (TI - TR * RR) / D
            GO TO (787,782), ISW
  777       RR = DR / DI
            D = DR * RR + DI
            T1 = (TR * RR + TI) / D
            T2 = (TI * RR - TR) / D
            GO TO (787,782), ISW
C     .......... COMPLEX 2-BY-2 BLOCK ..........
  780       X = BETM * A(I,I+1) - ALMR * B(I,I+1)
            X1 = -ALMI * B(I,I+1)
            Y = BETM * A(I+1,I)
            TR = Y * RA - W * R + W1 * S
            TI = Y * SA - W * S - W1 * R
            DR = W * ZZ - W1 * Z1 - X * Y
            DI = W * Z1 + W1 * ZZ - X1 * Y
            IF (DR .EQ. 0.0E0 .AND. DI .EQ. 0.0E0) DR = EPSB
            GO TO 775
  782       B(I+1,NA) = T1
            B(I+1,EN) = T2
            ISW = 1
            IF (ABS(Y) .GT. ABS(W) + ABS(W1)) GO TO 785
            TR = -RA - X * B(I+1,NA) + X1 * B(I+1,EN)
            TI = -SA - X * B(I+1,EN) - X1 * B(I+1,NA)
            GO TO 773
  785       T1 = (-R - ZZ * B(I+1,NA) + Z1 * B(I+1,EN)) / Y
            T2 = (-S - ZZ * B(I+1,EN) - Z1 * B(I+1,NA)) / Y
  787       B(I,NA) = T1
            B(I,EN) = T2
  790    CONTINUE
C     .......... END COMPLEX VECTOR ..........
  795    ISW = 3 - ISW
  800 CONTINUE
C     .......... END BACK SUBSTITUTION.
C                TRANSFORM TO ORIGINAL COORDINATE SYSTEM.
C                FOR J=N STEP -1 UNTIL 1 DO -- ..........
      DO 880 JJ = 1, N
         J = N + 1 - JJ
C
         DO 880 I = 1, N
            ZZ = 0.0E0
C
            DO 860 K = 1, J
  860       ZZ = ZZ + Z(I,K) * B(K,J)
C
            Z(I,J) = ZZ
  880 CONTINUE
C     .......... NORMALIZE SO THAT MODULUS OF LARGEST
C                COMPONENT OF EACH VECTOR IS 1.
C                (ISW IS 1 INITIALLY FROM BEFORE) ..........
      DO 950 J = 1, N
         D = 0.0E0
         IF (ISW .EQ. 2) GO TO 920
         IF (ALFI(J) .NE. 0.0E0) GO TO 945
C
         DO 890 I = 1, N
            IF (ABS(Z(I,J)) .GT. D) D = ABS(Z(I,J))
  890    CONTINUE
C
         DO 900 I = 1, N
  900    Z(I,J) = Z(I,J) / D
C
         GO TO 950
C
  920    DO 930 I = 1, N
            R = ABS(Z(I,J-1)) + ABS(Z(I,J))
            IF (R .NE. 0.0E0) R = R * SQRT((Z(I,J-1)/R)**2
     1                                     +(Z(I,J)/R)**2)
            IF (R .GT. D) D = R
  930    CONTINUE
C
         DO 940 I = 1, N
            Z(I,J-1) = Z(I,J-1) / D
            Z(I,J) = Z(I,J) / D
  940    CONTINUE
C
  945    ISW = 3 - ISW
  950 CONTINUE
C
      RETURN
      END


program main
    implicit none
    integer :: clock, n
    integer, allocatable :: seed(:)
    integer(4) :: i, n_tot = 100000000
    real(8), parameter :: l = 0.d0, r = 1.d0
    real(8) :: x, y
    real(8) :: integral = 0.d0

    call SYSTEM_CLOCK(clock)
    call RANDOM_SEED(size = n)
    allocate(seed(n))
    do i = 1, n
        seed(i) = clock + 37 * i
    end do
    call RANDOM_SEED(put = seed)
    do i = 1, n_tot
        call RANDOM_NUMBER(x)
        x = x * (r - l) + l
        call func(x, y)
        integral = integral + y
    end do
    integral = (r - l) / dble(n_tot) * integral
    write(*,'(f10.5)') integral
end program main

subroutine func(x, y)
    ! the function to be integrated
    implicit none
    real(8), intent(in) :: x
    real(8), intent(out) :: y

    y = x**2
end subroutine func


program test_row_compress
  use mod_orrb
  implicit none

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', lbw: ',I3,', ubw: ', I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  integer(kind=int32) :: na, lbwa, ubwa
  type(error_info) :: error
  real(kind=dp), parameter :: tol=1e-15, c=4.0
  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z
  !
  type(d_ubt), allocatable :: ubt_d
  type(z_ubt), allocatable :: ubt_z
  type(d_rc), allocatable :: swbv_d
  type(z_rc), allocatable :: swbv_z

  call initialize_errors

  print *
  print *, "--------------------------------"
  print *
  print *, "Real Row Compression Tests:"
  print *

  na=40; lbwa=7; ubwa=5
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a_d = general(ubt_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swbv_d=rc_of(ubt_d,error)
  call cpu_time(t1)
  a_d = general(swbv_d%bv,error)
  a_d = swbv_d%sw * a_d
  test_name = "Random Real Row Compression, n=40"
  call d_output_result(test_name,a0_d,a_d,lbwa, &
       swbv_d%bv%lbw, min(ubwa+lbwa,na-1),swbv_d%bv%ubw,t0,t1,c*tol,error)

  na=1; lbwa=0; ubwa=0
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a_d = general(ubt_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swbv_d=rc_of(ubt_d,error)
  call cpu_time(t1)
  a_d = general(swbv_d%bv,error)
  a_d = swbv_d%sw * a_d
  test_name = "Random Real Row Compression, n=1"
  call d_output_result(test_name,a0_d,a_d,lbwa, &
       swbv_d%bv%lbw, min(ubwa+lbwa,na-1),swbv_d%bv%ubw,t0,t1,c*tol,error)

  na=2; lbwa=1; ubwa=1
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a_d = general(ubt_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swbv_d=rc_of(ubt_d,error)
  call cpu_time(t1)
  a_d = general(swbv_d%bv,error)
  a_d = swbv_d%sw * a_d
  test_name = "Random Real Row Compression, n=2"
  call d_output_result(test_name,a0_d,a_d,lbwa, &
       swbv_d%bv%lbw, min(ubwa+lbwa,na-1),swbv_d%bv%ubw,t0,t1,c*tol,error)

  na=3; lbwa=1; ubwa=1
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a_d = general(ubt_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swbv_d=rc_of(ubt_d,error)
  call cpu_time(t1)
  a_d = general(swbv_d%bv,error)
  a_d = swbv_d%sw * a_d
  test_name = "Random Real Row Compression, n=3"
  call d_output_result(test_name,a0_d,a_d,lbwa, &
       swbv_d%bv%lbw, min(ubwa+lbwa,na-1),swbv_d%bv%ubw,t0,t1,c*tol,error)

  na=4; lbwa=2; ubwa=2
  ubt_d=d_random_ubt(na,lbwa,ubwa,error=error)
  a_d = general(ubt_d,error)
  a0_d = a_d
  call cpu_time(t0)
  swbv_d=rc_of(ubt_d,error)
  call cpu_time(t1)
  a_d = general(swbv_d%bv,error)
  a_d = swbv_d%sw * a_d
  test_name = "Random Real Row Compression, n=4"
  call d_output_result(test_name,a0_d,a_d,lbwa, &
       swbv_d%bv%lbw, min(ubwa+lbwa,na-1),swbv_d%bv%ubw,t0,t1,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Complex Row Compression Tests:"
  print *

  na=40; lbwa=7; ubwa=5
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a_z = general(ubt_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swbv_z=rc_of(ubt_z,error)
  call cpu_time(t1)
  a_z = general(swbv_z%bv,error)
  a_z = swbv_z%sw * a_z
  test_name = "Random Complex Row Compression, n=40"
  call z_output_result(test_name,a0_z,a_z,lbwa, &
       swbv_z%bv%lbw, min(ubwa+lbwa,na-1),swbv_z%bv%ubw,t0,t1,c*tol,error)

  na=1; lbwa=0; ubwa=0
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a_z = general(ubt_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swbv_z=rc_of(ubt_z,error)
  call cpu_time(t1)
  a_z = general(swbv_z%bv,error)
  a_z = swbv_z%sw * a_z
  test_name = "Random Complex Row Compression, n=1"
  call z_output_result(test_name,a0_z,a_z,lbwa, &
       swbv_z%bv%lbw, min(ubwa+lbwa,na-1),swbv_z%bv%ubw,t0,t1,c*tol,error)

  na=2; lbwa=1; ubwa=1
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a_z = general(ubt_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swbv_z=rc_of(ubt_z,error)
  call cpu_time(t1)
  a_z = general(swbv_z%bv,error)
  a_z = swbv_z%sw * a_z
  test_name = "Random Complex Row Compression, n=2"
  call z_output_result(test_name,a0_z,a_z,lbwa, &
       swbv_z%bv%lbw, min(ubwa+lbwa,na-1),swbv_z%bv%ubw,t0,t1,c*tol,error)

  na=3; lbwa=1; ubwa=1
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a_z = general(ubt_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swbv_z=rc_of(ubt_z,error)
  call cpu_time(t1)
  a_z = general(swbv_z%bv,error)
  a_z = swbv_z%sw * a_z
  test_name = "Random Complex Row Compression, n=3"
  call z_output_result(test_name,a0_z,a_z,lbwa, &
       swbv_z%bv%lbw, min(ubwa+lbwa,na-1),swbv_z%bv%ubw,t0,t1,c*tol,error)

  na=4; lbwa=2; ubwa=2
  ubt_z=z_random_ubt(na,lbwa,ubwa,error=error)
  a_z = general(ubt_z,error)
  a0_z = a_z
  call cpu_time(t0)
  swbv_z=rc_of(ubt_z,error)
  call cpu_time(t1)
  a_z = general(swbv_z%bv,error)
  a_z = swbv_z%sw * a_z
  test_name = "Random Complex Row Compression, n=4"
  call z_output_result(test_name,a0_z,a_z,lbwa, &
       swbv_z%bv%lbw, min(ubwa+lbwa,na-1),swbv_z%bv%ubw,t0,t1,c*tol,error)

contains

  subroutine d_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,lbw0,lbw1,ubw0,ubw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1, ubw0, ubw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. ubw0==ubw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, ubw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_row_compress


MODULE common_Brent
! COMMON /brent/ LEN, keytab(73), kvtab(73)

IMPLICIT NONE
INTEGER, SAVE :: LEN, keytab(73), kvtab(73)

END MODULE common_Brent

SUBROUTINE hash(key, mode, ka, found)

! Code converted using TO_F90 by Alan Miller
! Date: 2000-03-26  Time: 09:35:42

!===============BRENT'S HASHING ALGORITHM.
!               SEE CACM 16(2):105-109.

!       THIS ROUTINE WILL LOOK UP AND INSERT OR DELETE
!       INTEGER KEYS IN THE TABLE KEYTAB.  VALUES ASSOCIATED
!       WITH THE KEYS MAY BE STORED IN THE TABLE KVTAB. THE
!       ROUTINE IS DESIGNED TO BE EFFICIENT, EVEN IF THE TABLE
!       IS NEARLY FULL, PROVIDED MOST ENTRIES ARE LOOKED UP
!       SEVERAL TIMES.
!  PARAMETERS:
!  /BRENT/ COMMON BLOCK DESCRIBES:
!          LEN:    THE TABLE LENGTH.  MUST BE GIVEN AS A PRIME NUMBER
!                  BEFORE HASH IS CALLED.  NO CHECK IS MADE FOR PRIMALITY

!          KEYTAB: IS GIVEN AS A LEN-VECTOR FOR STORING THE KEYS.  IT MUST BE
!                  INITIALIZED TO ALL ZEROS BEFORE THE FIRST CALL TO HASH.

!          KVTAB:  IS USED BY BOTH HASH AND THE CALLING PROGRAM AS A LEN-VECTOR
!                  OF VALUES ASSOCIATED WITH KEYS IN THE HASH TABLE, KEYTAB.
!                  KVTAB COULD ALSO BE A POINTER VECTOR INITIALIZED TO THE
!                  INTEGERS 1,2,...LEN IF MULTIPLE VALUES ARE ASSOCIATED WITH
!                  EACH KEY.

!  (KEY, MODE, KA, FOUND):
!          KEY:    IS GIVEN AS A POSITIVE INTEGER KEY TO BE ENTERED,
!                  DELETED, OR PROBED FOR.
!                  THE VALUES 0 AND -1 ARE RESERVED FOR EMPTY SPACE
!                  OR DELETED ITEM RESPECTIVELY.

!          MODE:   IS GIVEN AS AN INDICATOR AS FOLLOWS...
!          MODE=1: MEANS LOOK UP ONLY.  IF THE KEY IS IN KEYTAB, THEN
!                  KA IS RETURNED AS THE SUBSCRIPT POINTER; OTHERWISE
!                  KA IS RETURNED 0.  THE VALUE ASSOCIATED WITH
!                  KEYTAB(KA) IS KVTAB(KA) WHEN KA IS NOT ZERO.
!          MODE=2: MEANS LOOK UP AND ENTER.  THIS IS USED TO BUILD THE TABLE.
!                  OTHERWISE THE KEY IS ENTERED AT KEYTAB(KA).
!                  KA IS RETURNED AS THE POINTER SUBSCRIPT IN EITHER CASE,
!                  OR KA=0 IF AN ENTRY IS ATTEMPTED AND THE TABLE IS FULL OR
!                  KA=0 IF KEY=0.  UPON RETURN, WHEN FOUND=.FALSE., THE CALLING
!                  PROGRAM MUST ENTER THE VALUE ASSOCIATED WITH KEY WHEN MODE=2.
!          MODE=3: MEANS LOOK UP AND DELETE.  IF THE KEY IS IN THE TABLE
!                  IT IS DELETED AND ITS FORMER ADDRESS KA IS RETURNED.
!                  IF THE KEY IS NOT THERE, KA=0 IS RETURNED.  (THE SUBROUTINE
!                  CAN BE SIMPLIFIED CONSIDERABLY IF KEYS NEVER DELETED).

!          KA:     IS RETURNED AS THE SUBSCRIPT OF KEYTAB SUCH THAT
!                  KEY=KEYTAB(KA) OR KA IS RETURNED AS ZERO IF KEY=0
!                  OR KEY IS NOT IN KEYTAB.

!          FOUND:  IS A LOGICAL FLAG RETURNED .TRUE. IF THE KEY WAS
!                  FOUND IN KEYTAB; ELSE FOUND IS RETURNED .FALSE. .

USE common_Brent
IMPLICIT NONE

INTEGER, INTENT(IN)   :: key
INTEGER, INTENT(IN)   :: mode
INTEGER, INTENT(OUT)  :: ka
LOGICAL, INTENT(OUT)  :: found

LOGICAL :: del
INTEGER :: ia, ic, iq, ir, is, ix, jq, jr, kt, len2

!---------THE COMMON STATEMENT BELOW MUST BE CHANGED TO MEET THE PROBLEM SIZE.
!         It has been replaced by saved variables in module common_brent
! COMMON /brent/ LEN, keytab(73), kvtab(73)

len2 = LEN-2
ic = -1
!--------COMPUTE ADDRESS OF FIRST PROBE(IR) AND INCREMENT(IQ).
!        ANY INDEPENDENT PSEUDO-RANDOM FUNCTIONS OF THE KEY MAY BE USED,
!        PROVIDED 0 < IQ < LEN AND 0 < IR <= LEN .
iq = MOD(ABS(key),len2) + 1
ir = MOD(ABS(key),LEN) + 1
ka = ir
!-----------LOOK IN THE TABLE.
20 kt = keytab(ka)
!----------CHECK FOR AN EMPTY SPACE, A DELETE ENTRY, OR A MATCH.
IF(kt == 0) GO TO 30
IF(kt == -1) GO TO 40
IF(kt == key) GO TO 60
ic = ic + 1
!---------COMPUTE ADDRESS OF NEXT PROBE.
ka = ka + iq
IF(ka > LEN) ka = ka - LEN
!----------SEE IF WHOLE TABLE HAS BEEN SEARCHED.
IF(ka /= ir) GO TO 20
!---------THE KEY IS NOT IN THE TABLE.
30 found = .false.
!---------RETURN WITH KA = 0 UNLES AN ENTRY HAS TO BE MADE.
IF(mode == 2 .AND. ic <= len2 .AND. key /= 0 .AND. key /= -1) GO TO 70
ka = 0
RETURN
!-----------A DELETED ENTRY HAS BEEN FOUND.
40 ia = ka
!----------COMPUTE ADDRESS OF NEXT PROBE.
50 ia = ia + iq
IF(ia > LEN) ia = ia - LEN
is = keytab(ia)
!----------CHECK FOR AN EMPTY SPACE OR A COMPLETE SCAN OF THE TABLE.
IF(is == 0 .OR. ia == ir) GO TO 30
!------------CHECK FOR A MISMATCH OR A DELETED ENTRY.
IF(is /= key .OR. is == -1) GO TO 50
!----------KEY FOUND.  MOVE IT AND THE ASSOCIAATED VALUE TO SAVE PROBES
!          ON THE NEXT SEARCH FOR THE SAME KEY.
kvtab(ka) = kvtab(ia)
keytab(ka) = is
keytab(ia) = -1
!----------THE KEY IS IN THE TABLE.
60 found = .true.
!----------DELETE IT IF MODE = 3
IF(mode == 3) keytab(ka) = -1
RETURN
!-----------LOOK FOR THE BEST WAY TO MAKE AN ENTRY.
70 IF(ic <= 0) GO TO 120
!----------SET DEL IF A DELETED ENTRY HAS BEEN FOUND.
del = kt /= 0
ia = ka
is = 0
!-----------COMPUTE THE MAXIMUM LENGTH TO SEARCH ALONG CURRENT CHAIN.
80 ix = ic - is
!-----------COMPUTE INCREMENT JQ FOR CURRENT CHAIN.
jq = MOD(ABS(keytab(ir)),len2) + 1
jr = ir
!----------LOOK ALONG THE CHAIN.
90 jr = jr + jq
IF(jr > LEN) jr = jr - LEN
kt = keytab(jr)
!----------CHECK FOR A HOLE (AN EMPTY SPACE OR DELETED ENTRY).
IF(kt == 0 .OR. kt == -1) GO TO 100
ix = ix - 1
IF(ix > 0) GO TO 90
GO TO 110
!----------SKIP IF THIS IS AN EMPTY SPACE AND A DELETED ENTRY HAS
!          ALREADY BEEN FOUND.
100 IF(del .AND. kt == 0) GO TO 110
!------------CHECK FOR A DELETED ENTRY.
IF(kt /= 0) del = .true.
!-----------SAVE LOCATION OF HOLE.
ia = jr
ka = ir
ic = ic - ix
!------------MOVE DOWN TO THE NEXT CHAIN.
110 is = is + 1
ir = ir + iq
IF(ir > LEN) ir = ir - LEN
!---------GO BACK IF A BETTER HOLE MIGHT STILL BE FOUND.
IF(ic > is) GO TO 80
!---------SKIP IF THERE IS NOTHING TO MOVE.
IF(ia == ka) GO TO 120
!---------MOVE AN OLD ENTRY AND ITS ASSOCIATED VALUE TO MAKE ROOM FOR
!         THE NEW ENTRY.
kvtab(ia) = kvtab(ka)
keytab(ia) = keytab(ka)
!---------ENTER THE NEW KEY, BUT NOT ITS ASSICIATED VALUE.
120 keytab(ka) = key

RETURN
END SUBROUTINE hash


      subroutine   newrap(
     i                    est,tlrnce,
     m                    func,newval)
c
c     + + + PURPOSE + + +
c     This subroutine uses the Newton-Raphson method to determine
c     'newval' using func (the function subprogram specified in the
c     calling statement).
c
c     Called from FURADV and FURREC
c     Author(s): E. R. Kottwitz
c     Reference in User Guide: Chapter 12
c
c     Changes:
c
c     Version: This module recoded from WEPP Version 93.06.
c     Date recoded: 07/07/93.
c     Recoded by: Charles R. Meyer.
c
c
c     + + + ARGUMENT DECLARATIONS + + +
      real      est,func,newval,tlrnce
c
c     + + + ARGUMENT DEFINITIONS + + +
c     est    - estimate of function's root coming in
c     func   - external function subprogram to be used
c     newval - function's root returned to calling subprogram
c     tlrnce - tolerance value for Newton-Raphson iterations with units
c              that are the same as the function's root
c
c     + + + LOCAL VARIABLES + + +
      integer   countr
      real      oldval
c
c     + + + LOCAL DEFINITIONS + + +
c     countr - counter of iterations used for non-convergence
c     oldval - old estimate of function's root
c
c     + + + OUTPUT FORMATS + + +
 2010 format(' SR NEWRAP did not converge in 100 iterations.  Model'/
     1       ' will continue with best estimate of parameter value.'/)
c
c     + + + END SPECIFICATIONS + + +
c
c     Initialize variables
c
      oldval = est
      countr = 1
c
c     Iteration loop
c
   20 newval = oldval-func(oldval)
      if(abs(newval-oldval).gt.tlrnce)then
        if(countr.lt.100)then
          oldval = newval
          countr = countr+1
          goto 20
        else
          write (6,2010)
        endif
      endif
c
      return
      end


      subroutine diavc(vecout,vecin,fac,diag,shift,ndim)
c
c     vecout(i)=fac*vecin(i)/(diag(i)+shift)
c
c     adapted from jeppe olsen's diavc2
c
      implicit none
      include 'stdunit.h'
      character(len=*),parameter::
     &     i_am="diavc"
      integer,parameter::
     &     ntest=00
      real(8), parameter ::
     &     thresh = 1d-10

      integer, intent(in) ::
     &     ndim
      real(8), intent(in) ::
     &     fac, shift, diag(ndim)
      real(8), intent(inout) ::
     &     vecout(ndim), vecin(ndim)
c
      integer ::
     &     i
      real(8) ::
     &     divide

      if (ntest.ge.10)then
         write(lulog,*) "thresh, shift",thresh,shift
      end if
      do i=1,ndim
        divide=diag(i)+shift
        if(abs(divide).le.thresh) divide=thresh
        vecout(i)=fac*vecin(i)/divide
      end do

      return
      end


program main
    use plantfem
    implicit none

    !type(FEMDomain_) :: soil
    !type(SeismicAnalysis_) :: seis
    type(Dictionary_) :: df
    integer(int32) :: i

    df = dict()
    call df%update("x","2 x^2 - x + 1")
    do i=-10000,10000
        call df%update(str(i/1000.0d0), polynomial(x=i/1000.0d0,params=[1.0d0, 2.0d0, -100.0d0, 1.0d0] ) )
    enddo
    call df%to_csv("test")

end program


      SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To apply a real elementary reflector H to a real m-by-n matrix
C     C, from either the left or the right. H is represented in the form
C                                        ( 1 )
C           H = I - tau * u *u',    u  = (   ),
C                                        ( v )
C     where tau is a real scalar and v is a real vector.
C
C     If tau = 0, then H is taken to be the unit matrix.
C
C     In-line code is used if H has order < 11.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SIDE    CHARACTER*1
C             Indicates whether the elementary reflector should be
C             applied from the left or from the right, as follows:
C             = 'L':  Compute H * C;
C             = 'R':  Compute C * H.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix C.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix C.  N >= 0.
C
C     V       (input) DOUBLE PRECISION array, dimension
C             (M-1), if SIDE = 'L', or
C             (N-1), if SIDE = 'R'.
C             The vector v in the representation of H.
C
C     TAU     (input) DOUBLE PRECISION
C             The scalar factor of the elementary reflector H.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix C.
C             On exit, the leading M-by-N part of this array contains
C             the matrix H * C, if SIDE = 'L', or C * H, if SIDE = 'R'.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N), if SIDE = 'L', or
C                                               (M), if SIDE = 'R'.
C             DWORK is not referenced if H has order less than 11.
C
C     METHOD
C
C     The routine applies the elementary reflector H, taking its special
C     structure into account. The multiplications by the first component
C     of u (which is 1) are avoided, to increase the efficiency.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999.
C     This is a modification of LAPACK Library routine DLARFX.
*
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, elementary reflector, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          SIDE
      INTEGER            LDC, M, N
      DOUBLE PRECISION   TAU
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   C( LDC, * ), DWORK( * ), V( * )
C     ..
C     .. Local Scalars ..
      INTEGER            J
      DOUBLE PRECISION   SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9,
     $                   V1, V2, V3, V4, V5, V6, V7, V8, V9
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER
C     ..
C     .. Executable Statements ..
C
      IF( TAU.EQ.ZERO )
     $   RETURN
      IF( LSAME( SIDE, 'L' ) ) THEN
C
C        Form  H * C, where H has order m.
C
         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
     $           170, 190 ) M
C
C        Code for general M.
C
C        w := C'*u.
C
         CALL DCOPY( N, C, LDC, DWORK, 1 )
         CALL DGEMV( 'Transpose', M-1, N, ONE, C( 2, 1 ), LDC, V, 1,
     $               ONE, DWORK, 1 )
C
C        C := C - tau * u * w'.
C
         CALL DAXPY( N, -TAU, DWORK, 1, C, LDC )
         CALL DGER( M-1, N, -TAU, V, 1, DWORK, 1, C( 2, 1 ), LDC )
         GO TO 410
   10    CONTINUE
C
C        Special code for 1 x 1 Householder.
C
         T1 = ONE - TAU
         DO 20 J = 1, N
            C( 1, J ) = T1*C( 1, J )
   20    CONTINUE
         GO TO 410
   30    CONTINUE
C
C        Special code for 2 x 2 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         DO 40 J = 1, N
            SUM = C( 1, J ) + V1*C( 2, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
   40    CONTINUE
         GO TO 410
   50    CONTINUE
C
C        Special code for 3 x 3 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         DO 60 J = 1, N
            SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
            C( 3, J ) = C( 3, J ) - SUM*T2
   60    CONTINUE
         GO TO 410
   70    CONTINUE
C
C        Special code for 4 x 4 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         DO 80 J = 1, N
            SUM =    C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) +
     $            V3*C( 4, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
            C( 3, J ) = C( 3, J ) - SUM*T2
            C( 4, J ) = C( 4, J ) - SUM*T3
   80    CONTINUE
         GO TO 410
   90    CONTINUE
C
C        Special code for 5 x 5 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         DO 100 J = 1, N
            SUM =    C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) +
     $            V3*C( 4, J ) + V4*C( 5, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
            C( 3, J ) = C( 3, J ) - SUM*T2
            C( 4, J ) = C( 4, J ) - SUM*T3
            C( 5, J ) = C( 5, J ) - SUM*T4
  100    CONTINUE
         GO TO 410
  110    CONTINUE
C
C        Special code for 6 x 6 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         DO 120 J = 1, N
            SUM =    C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) +
     $            V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
            C( 3, J ) = C( 3, J ) - SUM*T2
            C( 4, J ) = C( 4, J ) - SUM*T3
            C( 5, J ) = C( 5, J ) - SUM*T4
            C( 6, J ) = C( 6, J ) - SUM*T5
  120    CONTINUE
         GO TO 410
  130    CONTINUE
C
C        Special code for 7 x 7 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         DO 140 J = 1, N
            SUM =    C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) +
     $            V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) +
     $            V6*C( 7, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
            C( 3, J ) = C( 3, J ) - SUM*T2
            C( 4, J ) = C( 4, J ) - SUM*T3
            C( 5, J ) = C( 5, J ) - SUM*T4
            C( 6, J ) = C( 6, J ) - SUM*T5
            C( 7, J ) = C( 7, J ) - SUM*T6
  140    CONTINUE
         GO TO 410
  150    CONTINUE
C
C        Special code for 8 x 8 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         DO 160 J = 1, N
            SUM =    C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) +
     $            V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) +
     $            V6*C( 7, J ) + V7*C( 8, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
            C( 3, J ) = C( 3, J ) - SUM*T2
            C( 4, J ) = C( 4, J ) - SUM*T3
            C( 5, J ) = C( 5, J ) - SUM*T4
            C( 6, J ) = C( 6, J ) - SUM*T5
            C( 7, J ) = C( 7, J ) - SUM*T6
            C( 8, J ) = C( 8, J ) - SUM*T7
  160    CONTINUE
         GO TO 410
  170    CONTINUE
C
C        Special code for 9 x 9 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         DO 180 J = 1, N
            SUM =    C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) +
     $            V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) +
     $            V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J )
            C( 1, J ) = C( 1, J ) - SUM*TAU
            C( 2, J ) = C( 2, J ) - SUM*T1
            C( 3, J ) = C( 3, J ) - SUM*T2
            C( 4, J ) = C( 4, J ) - SUM*T3
            C( 5, J ) = C( 5, J ) - SUM*T4
            C( 6, J ) = C( 6, J ) - SUM*T5
            C( 7, J ) = C( 7, J ) - SUM*T6
            C( 8, J ) = C( 8, J ) - SUM*T7
            C( 9, J ) = C( 9, J ) - SUM*T8
  180    CONTINUE
         GO TO 410
  190    CONTINUE
C
C        Special code for 10 x 10 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         V9 = V( 9 )
         T9 = TAU*V9
         DO 200 J = 1, N
            SUM =    C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) +
     $            V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) +
     $            V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) +
     $            V9*C( 10, J )
            C(  1, J ) = C(  1, J ) - SUM*TAU
            C(  2, J ) = C(  2, J ) - SUM*T1
            C(  3, J ) = C(  3, J ) - SUM*T2
            C(  4, J ) = C(  4, J ) - SUM*T3
            C(  5, J ) = C(  5, J ) - SUM*T4
            C(  6, J ) = C(  6, J ) - SUM*T5
            C(  7, J ) = C(  7, J ) - SUM*T6
            C(  8, J ) = C(  8, J ) - SUM*T7
            C(  9, J ) = C(  9, J ) - SUM*T8
            C( 10, J ) = C( 10, J ) - SUM*T9
  200    CONTINUE
         GO TO 410
      ELSE
C
C        Form  C * H, where H has order n.
C
         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
     $           370, 390 ) N
C
C        Code for general N.
C
C        w := C * u.
C
         CALL DCOPY( M, C, 1, DWORK, 1 )
         CALL DGEMV( 'No transpose', M, N-1, ONE, C( 1, 2 ), LDC, V, 1,
     $               ONE, DWORK, 1 )
C
C        C := C - tau * w * u'.
C
         CALL DAXPY( M, -TAU, DWORK, 1, C, 1 )
         CALL DGER( M, N-1, -TAU, DWORK, 1, V, 1, C( 1, 2 ), LDC )
         GO TO 410
  210    CONTINUE
C
C        Special code for 1 x 1 Householder.
C
         T1 = ONE - TAU
         DO 220 J = 1, M
            C( J, 1 ) = T1*C( J, 1 )
  220    CONTINUE
         GO TO 410
  230    CONTINUE
C
C        Special code for 2 x 2 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         DO 240 J = 1, M
            SUM = C( J, 1 ) + V1*C( J, 2 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
  240    CONTINUE
         GO TO 410
  250    CONTINUE
C
C        Special code for 3 x 3 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         DO 260 J = 1, M
            SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
            C( J, 3 ) = C( J, 3 ) - SUM*T2
  260    CONTINUE
         GO TO 410
  270    CONTINUE
C
C        Special code for 4 x 4 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         DO 280 J = 1, M
            SUM =    C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) +
     $            V3*C( J, 4 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
            C( J, 3 ) = C( J, 3 ) - SUM*T2
            C( J, 4 ) = C( J, 4 ) - SUM*T3
  280    CONTINUE
         GO TO 410
  290    CONTINUE
C
C        Special code for 5 x 5 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         DO 300 J = 1, M
            SUM =    C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) +
     $            V3*C( J, 4 ) + V4*C( J, 5 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
            C( J, 3 ) = C( J, 3 ) - SUM*T2
            C( J, 4 ) = C( J, 4 ) - SUM*T3
            C( J, 5 ) = C( J, 5 ) - SUM*T4
  300    CONTINUE
         GO TO 410
  310    CONTINUE
C
C        Special code for 6 x 6 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         DO 320 J = 1, M
            SUM =    C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) +
     $            V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
            C( J, 3 ) = C( J, 3 ) - SUM*T2
            C( J, 4 ) = C( J, 4 ) - SUM*T3
            C( J, 5 ) = C( J, 5 ) - SUM*T4
            C( J, 6 ) = C( J, 6 ) - SUM*T5
  320    CONTINUE
         GO TO 410
  330    CONTINUE
C
C        Special code for 7 x 7 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         DO 340 J = 1, M
            SUM =    C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) +
     $            V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) +
     $            V6*C( J, 7 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
            C( J, 3 ) = C( J, 3 ) - SUM*T2
            C( J, 4 ) = C( J, 4 ) - SUM*T3
            C( J, 5 ) = C( J, 5 ) - SUM*T4
            C( J, 6 ) = C( J, 6 ) - SUM*T5
            C( J, 7 ) = C( J, 7 ) - SUM*T6
  340    CONTINUE
         GO TO 410
  350    CONTINUE
C
C        Special code for 8 x 8 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         DO 360 J = 1, M
            SUM =    C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) +
     $            V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) +
     $            V6*C( J, 7 ) + V7*C( J, 8 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
            C( J, 3 ) = C( J, 3 ) - SUM*T2
            C( J, 4 ) = C( J, 4 ) - SUM*T3
            C( J, 5 ) = C( J, 5 ) - SUM*T4
            C( J, 6 ) = C( J, 6 ) - SUM*T5
            C( J, 7 ) = C( J, 7 ) - SUM*T6
            C( J, 8 ) = C( J, 8 ) - SUM*T7
  360    CONTINUE
         GO TO 410
  370    CONTINUE
C
C        Special code for 9 x 9 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         DO 380 J = 1, M
            SUM =    C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) +
     $            V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) +
     $            V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 )
            C( J, 1 ) = C( J, 1 ) - SUM*TAU
            C( J, 2 ) = C( J, 2 ) - SUM*T1
            C( J, 3 ) = C( J, 3 ) - SUM*T2
            C( J, 4 ) = C( J, 4 ) - SUM*T3
            C( J, 5 ) = C( J, 5 ) - SUM*T4
            C( J, 6 ) = C( J, 6 ) - SUM*T5
            C( J, 7 ) = C( J, 7 ) - SUM*T6
            C( J, 8 ) = C( J, 8 ) - SUM*T7
            C( J, 9 ) = C( J, 9 ) - SUM*T8
  380    CONTINUE
         GO TO 410
  390    CONTINUE
C
C        Special code for 10 x 10 Householder.
C
         V1 = V( 1 )
         T1 = TAU*V1
         V2 = V( 2 )
         T2 = TAU*V2
         V3 = V( 3 )
         T3 = TAU*V3
         V4 = V( 4 )
         T4 = TAU*V4
         V5 = V( 5 )
         T5 = TAU*V5
         V6 = V( 6 )
         T6 = TAU*V6
         V7 = V( 7 )
         T7 = TAU*V7
         V8 = V( 8 )
         T8 = TAU*V8
         V9 = V( 9 )
         T9 = TAU*V9
         DO 400 J = 1, M
            SUM =    C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) +
     $            V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) +
     $            V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) +
     $            V9*C( J, 10 )
            C( J,  1 ) = C( J,  1 ) - SUM*TAU
            C( J,  2 ) = C( J,  2 ) - SUM*T1
            C( J,  3 ) = C( J,  3 ) - SUM*T2
            C( J,  4 ) = C( J,  4 ) - SUM*T3
            C( J,  5 ) = C( J,  5 ) - SUM*T4
            C( J,  6 ) = C( J,  6 ) - SUM*T5
            C( J,  7 ) = C( J,  7 ) - SUM*T6
            C( J,  8 ) = C( J,  8 ) - SUM*T7
            C( J,  9 ) = C( J,  9 ) - SUM*T8
            C( J, 10 ) = C( J, 10 ) - SUM*T9
  400    CONTINUE
         GO TO 410
      END IF
  410 CONTINUE
      RETURN
C
C *** Last line of MB04PY ***
      END


        SUBROUTINE ROTATE(VECTOR,ANGLE,AXIS)
*
*  Module number:
*
*  Module name: ROTATE
*
*  Keyphrase:
*  ----------
*	Rotate 3-D vector by a specfied angle about a specified axis
*
*  Description:
*  ------------
*	Take a double precsion 3-vector and rotate it by a double
*	precision angle around one axis (axis 1 = x; axis 2 = y;
*	axis 3 = z)
*
*  FORTRAN name: ROTATE.FOR
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments

*  Subroutines Called:
*  -------------------
*  CDBS:
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       May 91	    S. Hulbert      Designed and coded
*-------------------------------------------------------------------------------
*
* INPUTS:
*	angle - angle (in degrees) to rotate
*	axis - axis number: 1 = x, 2 = y, 3 = z
*
* INPUT/OUTPUT:
*	vector - three-vector to rotate
*
* OUTPUT:
*	istat - status
*
        DOUBLE PRECISION VECTOR(3)
        DOUBLE PRECISION ANGLE
        INTEGER AXIS
C
        DOUBLE PRECISION DEGRAD
        PARAMETER (DEGRAD = 57.295779513082D0)
C
C local variables
C
        INTEGER I, J
        DOUBLE PRECISION S, C, R(3,3), SUM(3)
C
C-----------------------------------------------------------------------
C
C zero rotation matrix
C
        DO 100 I = 1, 3
            DO 110 J = 1, 3
                R(I,J) = 0.0D0
110             CONTINUE
100         CONTINUE
C
        S = SIN(ANGLE/DEGRAD)
        C = COS(ANGLE/DEGRAD)
C
C set up rotation matrix for the appropriate axis
C
        IF (AXIS .EQ. 1) THEN
            R(1,1) = 1.0D0
            R(2,2) = C
            R(2,3) = -S
            R(3,2) = S
            R(3,3) = C
        ELSE IF (AXIS .EQ. 2) THEN
            R(1,1) = C
            R(1,3) = S
            R(2,2) = 1.0D0
            R(3,1) = -S
            R(3,3) = C
        ELSE
            R(1,1) = C
            R(1,2) = -S
            R(2,1) = S
            R(2,2) = C
            R(3,3) = 1.0D0
        ENDIF
C
C rotate
C
        DO 200 I = 1, 3
            SUM(I) = 0.0D0
            DO 210 J = 1,3
                SUM(I) = SUM(I) + R(J,I)*VECTOR(J)
210            CONTINUE
200        CONTINUE
C
C put rotated vector into input vector
C
        DO 300 I = 1, 3
            VECTOR(I) = SUM(I)
300        CONTINUE
C
        RETURN
        END