      SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
     $                   SNV, CSQ, SNQ )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      LOGICAL            UPPER
      DOUBLE PRECISION   A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
     $                   SNU, SNV
*     ..
*
*  Purpose
*  =======
*
*  DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
*  that if ( UPPER ) then
*
*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )
*                        ( 0  A3 )     ( x  x  )
*  and
*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )
*                        ( 0  B3 )     ( x  x  )
*
*  or if ( .NOT.UPPER ) then
*
*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )
*                        ( A2 A3 )     ( 0  x  )
*  and
*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )
*                        ( B2 B3 )     ( 0  x  )
*
*  The rows of the transformed A and B are parallel, where
*
*    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )
*        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )
*
*  Z' denotes the transpose of Z.
*
*
*  Arguments
*  =========
*
*  UPPER   (input) LOGICAL
*          = .TRUE.: the input matrices A and B are upper triangular.
*          = .FALSE.: the input matrices A and B are lower triangular.
*
*  A1      (input) DOUBLE PRECISION
*  A2      (input) DOUBLE PRECISION
*  A3      (input) DOUBLE PRECISION
*          On entry, A1, A2 and A3 are elements of the input 2-by-2
*          upper (lower) triangular matrix A.
*
*  B1      (input) DOUBLE PRECISION
*  B2      (input) DOUBLE PRECISION
*  B3      (input) DOUBLE PRECISION
*          On entry, B1, B2 and B3 are elements of the input 2-by-2
*          upper (lower) triangular matrix B.
*
*  CSU     (output) DOUBLE PRECISION
*  SNU     (output) DOUBLE PRECISION
*          The desired orthogonal matrix U.
*
*  CSV     (output) DOUBLE PRECISION
*  SNV     (output) DOUBLE PRECISION
*          The desired orthogonal matrix V.
*
*  CSQ     (output) DOUBLE PRECISION
*  SNQ     (output) DOUBLE PRECISION
*          The desired orthogonal matrix Q.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
     $                   AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
     $                   SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
     $                   VB11, VB11R, VB12, VB21, VB22, VB22R
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARTG, DLASV2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
      IF( UPPER ) THEN
*
*        Input matrices A and B are upper triangular matrices
*
*        Form matrix C = A*adj(B) = ( a b )
*                                   ( 0 d )
*
         A = A1*B3
         D = A3*B1
         B = A2*B1 - A1*B2
*
*        The SVD of real 2-by-2 triangular C
*
*         ( CSL -SNL )*( A B )*(  CSR  SNR ) = ( R 0 )
*         ( SNL  CSL ) ( 0 D ) ( -SNR  CSR )   ( 0 T )
*
         CALL DLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
*
         IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
     $        THEN
*
*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
*           and (1,2) element of |U|'*|A| and |V|'*|B|.
*
            UA11R = CSL*A1
            UA12 = CSL*A2 + SNL*A3
*
            VB11R = CSR*B1
            VB12 = CSR*B2 + SNR*B3
*
            AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
            AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
*
*           zero (1,2) elements of U'*A and V'*B
*
            IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
               IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
     $             ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
                  CALL DLARTG( -UA11R, UA12, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
            END IF
*
            CSU = CSL
            SNU = -SNL
            CSV = CSR
            SNV = -SNR
*
         ELSE
*
*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
*           and (2,2) element of |U|'*|A| and |V|'*|B|.
*
            UA21 = -SNL*A1
            UA22 = -SNL*A2 + CSL*A3
*
            VB21 = -SNR*B1
            VB22 = -SNR*B2 + CSR*B3
*
            AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
            AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
*
*           zero (2,2) elements of U'*A and V'*B, and then swap.
*
            IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
               IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
     $             ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
                  CALL DLARTG( -UA21, UA22, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
            END IF
*
            CSU = SNL
            SNU = CSL
            CSV = SNR
            SNV = CSR
*
         END IF
*
      ELSE
*
*        Input matrices A and B are lower triangular matrices
*
*        Form matrix C = A*adj(B) = ( a 0 )
*                                   ( c d )
*
         A = A1*B3
         D = A3*B1
         C = A2*B3 - A3*B2
*
*        The SVD of real 2-by-2 triangular C
*
*         ( CSL -SNL )*( A 0 )*(  CSR  SNR ) = ( R 0 )
*         ( SNL  CSL ) ( C D ) ( -SNR  CSR )   ( 0 T )
*
         CALL DLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
*
         IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
     $        THEN
*
*           Compute the (2,1) and (2,2) elements of U'*A and V'*B,
*           and (2,1) element of |U|'*|A| and |V|'*|B|.
*
            UA21 = -SNR*A1 + CSR*A2
            UA22R = CSR*A3
*
            VB21 = -SNL*B1 + CSL*B2
            VB22R = CSL*B3
*
            AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
            AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
*
*           zero (2,1) elements of U'*A and V'*B.
*
            IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
               IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
     $             ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
                  CALL DLARTG( UA22R, UA21, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
            END IF
*
            CSU = CSR
            SNU = -SNR
            CSV = CSL
            SNV = -SNL
*
         ELSE
*
*           Compute the (1,1) and (1,2) elements of U'*A and V'*B,
*           and (1,1) element of |U|'*|A| and |V|'*|B|.
*
            UA11 = CSR*A1 + SNR*A2
            UA12 = SNR*A3
*
            VB11 = CSL*B1 + SNL*B2
            VB12 = SNL*B3
*
            AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
            AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
*
*           zero (1,1) elements of U'*A and V'*B, and then swap.
*
            IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
               IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
     $             ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
                  CALL DLARTG( UA12, UA11, CSQ, SNQ, R )
               ELSE
                  CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
               END IF
            ELSE
               CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
            END IF
*
            CSU = SNR
            SNU = CSR
            CSV = SNL
            SNV = CSL
*
         END IF
*
      END IF
*
      RETURN
*
*     End of DLAGS2
*
      END


      SUBROUTINE AMGT1S (INPUT,FMAT,XYZB,INDEX)
C
C     COMPUTE F(INVERSE) FOR THIS STREAMLINE
C
      LOGICAL         TSONIC,DEBUG
      INTEGER         SLN
      REAL            MINMAC,MAXMAC,MACH
      DIMENSION       FMAT(NSTNS,NSTNS),XYZB(3,NSTNS),INDEX(1),TBL(3,3)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /SYSTEM/ SYSBUF,IOUT
      COMMON /AMGMN / MCB(7),NROW,DUM(2),REFC,SIGMA,RFREQ
      COMMON /CONDAS/ PI,TWOPI,RADEG,DEGRA,S4PISO
      COMMON /TAMG1L/ IREF,MINMAC,MAXMAC,NLINES,NSTNS,REFSTG,REFCRD,
     1                REFMAC,REFDEN,REFVEL,REFSWP,SLN,NSTNSX,STAGER,
     2                CHORD,DCBDZB,BSPACE,MACH,DEN,VEL,SWEEP,AMACH,
     3                REDF,BLSPC,AMACHR,TSONIC,XSIGN
      COMMON /AMGBUG/ DEBUG
C
C     READ STREAMLINE DATA
C
      NSTNS3 = 3*NSTNS
      CALL FREAD (INPUT,SLN,10,0)
      CALL FREAD (INPUT,XYZB,NSTNS3,0)
      IF (DEBUG) CALL BUG1 ('ACPT-SLN  ',10,SLN,10)
      IF (DEBUG) CALL BUG1 ('XYZB      ',20,XYZB,NSTNS3)
C
C     (1) COMPUTE BASIC TO LOCAL TRANSFORMATION
C         XYZB ARRAY CONTAINS X,Y,Z COORDINATES IN BASIC SYSTEM
C         FOR ALL NODES ON THE STREAMLINE LEADING EDGE TO TRAILING EDGE
C     (2) TRANSFORM BASIC X,Y,Z ON STREAMLINE TO LOCAL X,Y,Z-S
C     (3) COMPUTE FMAT(NSTNS X NSTNS)
C     (4) COMPUTE FMAT(INVERS) - USE -
C         CALL INVERS(NSTNS,FMAT,NSTNS,DUM1,0,DETERM,ISING,INDEX)
C
      XA  = XYZB(1,1)
      YA  = XYZB(2,1)
      ZA  = XYZB(3,1)
      XB  = XYZB(1,NSTNS)
      YB  = XYZB(2,NSTNS)
      ZB  = XYZB(3,NSTNS)
      XBA = XB - XA
      YBA = YB - YA
      ZBA = ZB - ZA
      AL2SQ = XBA**2 + YBA**2
      AL1SQ = AL2SQ  + ZBA**2
      AL1 = SQRT(AL1SQ)
      TBL(1,1) = XBA/AL1
      TBL(1,2) = YBA/AL1
      TBL(1,3) = ZBA/AL1
      FMAT(1,1)= 1.0
      PIC =  PI/CHORD
      CH2 = 2.0/CHORD
      DO 40 I = 2,NSTNS
      X = TBL(1,1)*(XYZB(1,I) - XYZB(1,1))
     1  + TBL(1,2)*(XYZB(2,I) - XYZB(2,1))
     2  + TBL(1,3)*(XYZB(3,I) - XYZB(3,1))
      FMAT(1,I) = 0.0
      FMAT(I,1) = 1.0
      FMAT(I,2) = CH2*X
      DO 30 J = 3,NSTNS
      AN  = J - 2
      ARG = PIC*AN*X
  30  FMAT(I,J) = SIN(ARG)
  40  CONTINUE
      IF (DEBUG) CALL BUG1 ('FMAT      ',50,FMAT,NSTNS*NSTNS)
      ISING = -1
      CALL INVERS (NSTNS,FMAT,NSTNS,DUM1,0,DETERM,ISING,INDEX)
      IF (DEBUG) CALL BUG1 ('FMAT-INV  ',60,FMAT,NSTNS*NSTNS)
      IF (ISING .EQ. 2) GO TO 70
      RETURN
C
C     ERROR MESSAGE,  SINGULAR MATRIX
C
   70 WRITE  (IOUT,80) UFM,SLN
   80 FORMAT (A23,' -AMG MODULE- SINGULAR MATRIX IN ROUTINE AMGT1S FOR',
     1     ' STREAML2, SLN =',I3, /39X,'CHECK STREAML2 BULK DATA CARD.')
      CALL MESAGE (-61,0,0)
      RETURN
      END


      function falvel(spg,dia)
c
c******************************************************************
c                                                                 *
c     Called from subroutine param.                               *
c     Returns the fall velocity for a specific c particle given   *
c     its specific gravity (spg), diameter (dia), the kinematic   *
c     viscosity of the water (kinvis), and the acceleration       *
c     of gravity (accgav).                                        *
c                                                                 *
c******************************************************************
c
c
c******************************************************************
c                                                                 *
c   Arguments                                                     *
c     spg    -                                                    *
c     dia    -                                                    *
c                                                                 *
c******************************************************************
c
      real spg, dia
c
c******************************************************************
c                                                                 *
c   Common Blocks                                                 *
c                                                                 *
c******************************************************************
c
      include 'cconsta.inc'
c
      include 'cfall.inc'
c
c******************************************************************
c                                                                 *
c   Local Variables                                               *
c     rtsid  :                                                    *
c     rey    :                                                    *
c     i      :                                                    *
c                                                                 *
c******************************************************************
c
      real rtsid, rey, falvel
      integer i
c
c ... dimensionless parameter (rtsid=cd*rey*rey) for drag coeffient
c
      rtsid = ((spg-1.0)*accgav*(dia**3)/(kinvis**2)) * (8.0/6.0)
c
c     ... compute falvel from tabled values for larger particles
c
      if (rtsid.ge.0.024) then
        rtsid = alog(rtsid)
        do 10 i = 2, 9
          if (cdre2(i).gt.rtsid) then
            rey = exp((rtsid-cdre2(i-1))/(cdre2(i)-cdre2(i-1))*(
     1          cdre(i)-cdre(i-1))+cdre(i-1))
            falvel = rey * kinvis / dia
            return
          end if
   10   continue
c
c       -- trap values which are larger than table values
c
        write (6,*) ' cdre2 out of range.  spg=', spg, '   dia=', dia
        falvel = exp(cdre(9)) * kinvis / dia
c
c     ... falvel using Stokes solution for spheres for small particles
c
      else
        falvel = ((dia**2)*(spg-1.0)*(accgav)) / (kinvis*18.0)
      end if
c
      return
c
      end


      subroutine rbf_train_b(nwp, rw, drw, drwb, wt, wtb)
      implicit none
      include 'dim.h'
      integer nwp
      real    rw  (NDIM,*),
     1        drw (NDIM,*),
     2        wt  (NDIM,*)
      real    drwb(NDIM,*),
     2        wtb (NDIM,*)

      integer i, j, n, ipvt(nwp+NDIM+1)
      real    dx, dy, ds, z(nwp+NDIM+1), rcond
      real    a(nwp+NDIM+1, nwp+NDIM+1), b(nwp+NDIM+1)

      print*,'Constructing RBF approximation'

      n      = nwp+NDIM+1
      a(:,:) = 0.0

c     construct rbf coefficient matrix
      do i=1,nwp
         a(i,i) = 0.0
         do j=i+1,nwp
            dx = rw(1,i) - rw(1,j)
            dy = rw(2,i) - rw(2,j)
            ds = sqrt(dx*dx + dy*dy)
            a(i,j) = ds*ds*log(ds)
         enddo
         a(i,nwp+1) = 1.0
         a(i,nwp+2) = rw(1,i)
         a(i,nwp+3) = rw(2,i)
      enddo

c     Copy lower diagonal part due to symmetry
      do i=1,nwp
         do j=1,i-1
            a(i,j) = a(j,i)
         enddo
      enddo

c     Extra equations due to linear polynomial
      do i=1,nwp
         a(nwp+1,i) = 1.0
         a(nwp+2,i) = rw(1,i)
         a(nwp+3,i) = rw(2,i)
      enddo

c     Perform LU Decomposition
      call dgeco(a, n, n, ipvt, rcond, z)

      write(*,'("    Condition number = ",e10.4)') 1.0/rcond

c     Solve for x-coordinate
      do i=1,nwp+3
         b(i) = wtb(1,i)
      enddo
      call dgesl(a, n, n, ipvt, b, 0)
      do i=1,nwp+3
         drwb(1,i) = b(i)
      enddo

c     Solve for y-coordinate
      do i=1,nwp+3
         b(i) = wtb(2,i)
      enddo
      call dgesl(a, n, n, ipvt, b, 0)
      do i=1,nwp+3
         drwb(2,i) = b(i)
      enddo

      return
      end


      SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW,
     $                   IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce a given state-space representation (A,B,C,D) to
C     balanced form by means of state permutations and state, input and
C     output scalings.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation, i.e. the
C             order of the original state dynamics matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the balanced state dynamics matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the balanced input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the balanced state/output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the original direct transmission matrix D.
C             On exit, the leading P-by-M part of this array contains
C             the scaled direct transmission matrix D.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     LOW     (output) INTEGER
C             The index of the lower end of the balanced submatrix of A.
C
C     IGH     (output) INTEGER
C             The index of the upper end of the balanced submatrix of A.
C
C     SCSTAT  (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the information defining the
C             similarity transformations used to permute and balance
C             the state dynamics matrix A, as returned from the LAPACK
C             library routine DGEBAL.
C
C     SCIN    (output) DOUBLE PRECISION array, dimension (M)
C             Contains the scalars used to scale the system inputs so
C             that the columns of the final matrix B have norms roughly
C             equal to the column sums of the balanced matrix A
C             (see FURTHER COMMENTS).
C             The j-th input of the balanced state-space representation
C             is SCIN(j)*(j-th column of the permuted and balanced
C             input/state matrix B).
C
C     SCOUT   (output) DOUBLE PRECISION array, dimension (P)
C             Contains the scalars used to scale the system outputs so
C             that the rows of the final matrix C have norms roughly
C             equal to the row sum of the balanced matrix A.
C             The i-th output of the balanced state-space representation
C             is SCOUT(i)*(i-th row of the permuted and balanced
C             state/ouput matrix C).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Similarity transformations are used to permute the system states
C     and balance the corresponding row and column sum norms of a
C     submatrix of the state dynamics matrix A. These operations are
C     also applied to the input/state matrix B and the system inputs
C     are then scaled (see parameter SCIN) so that the columns of the
C     final matrix B have norms roughly equal to the column sum norm of
C     the balanced matrix A (see FURTHER COMMENTS).
C     The above operations are also applied to the matrix C, and the
C     system outputs are then scaled (see parameter SCOUT) so that the
C     rows of the final matrix C have norms roughly equal to the row sum
C     norm of the balanced matrix A (see FURTHER COMMENTS).
C     Finally, the (I,J)-th element of the direct transmission matrix D
C     is scaled as
C          D(I,J) = D(I,J)*(1.0/SCIN(J))*SCOUT(I), where I = 1,2,...,P
C     and J = 1,2,...,M.
C
C     Scaling performed to balance the row/column sum norms is by
C     integer powers of the machine base so as to avoid introducing
C     rounding errors.
C
C     REFERENCES
C
C     [1] Wilkinson, J.H. and Reinsch, C.
C         Handbook for Automatic Computation, (Vol II, Linear Algebra).
C         Springer-Verlag, 1971, (contribution II/11).
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     FURTHER COMMENTS
C
C     The columns (rows) of the final matrix B (matrix C) have norms
C     'roughly' equal to the column (row) sum norm of the balanced
C     matrix A, i.e.
C        size/BASE < abssum <= size
C     where
C        BASE   = the base of the arithmetic used on the computer, which
C                 can be obtained from the LAPACK Library routine
C                 DLAMCH;
C
C        size   = column or row sum norm of the balanced matrix A;
C        abssum = column sum norm of the balanced matrix B or row sum
C                 norm of the balanced matrix C.
C
C     The routine is BASE dependent.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TB01HD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, October 1982.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Balanced form, orthogonal transformation, similarity
C     transformation, state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           IGH, INFO, LDA, LDB, LDC, LDD, LOW, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), SCIN(*), SCOUT(*), SCSTAT(*)
C     .. Local Scalars ..
      INTEGER           I, J, K, KNEW, KOLD
      DOUBLE PRECISION  ACNORM, ARNORM, SCALE
C     .. External Functions ..
      DOUBLE PRECISION  DLANGE
      EXTERNAL          DLANGE
C     .. External Subroutines ..
      EXTERNAL          DGEBAL, DSCAL, DSWAP, TB01TY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -9
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01TD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, M, P ).EQ.0 ) THEN
         LOW = 1
         IGH = N
         RETURN
      END IF
C
C     Permute states, and balance a submatrix of A.
C
      CALL DGEBAL( 'Both', N, A, LDA, LOW, IGH, SCSTAT, INFO )
C
C     Use the information in SCSTAT on state scalings and reorderings
C     to transform B and C.
C
      DO 10 K = 1, N
         KOLD = K
         IF ( ( LOW.GT.KOLD ) .OR. ( KOLD.GT.IGH ) ) THEN
            IF ( KOLD.LT.LOW ) KOLD = LOW - KOLD
            KNEW = INT( SCSTAT(KOLD) )
            IF ( KNEW.NE.KOLD ) THEN
C
C              Exchange rows KOLD and KNEW of B.
C
               CALL DSWAP( M, B(KOLD,1), LDB, B(KNEW,1), LDB )
C
C              Exchange columns KOLD and KNEW of C.
C
               CALL DSWAP( P, C(1,KOLD), 1, C(1,KNEW), 1 )
            END IF
         END IF
   10 CONTINUE
C
      IF ( IGH.NE.LOW ) THEN
C
         DO 20 K = LOW, IGH
            SCALE = SCSTAT(K)
C
C           Scale the K-th row of permuted B.
C
            CALL DSCAL( M, ONE/SCALE, B(K,1), LDB )
C
C           Scale the K-th column of permuted C.
C
            CALL DSCAL( P, SCALE, C(1,K), 1 )
   20    CONTINUE
C
      END IF
C
C     Calculate the column and row sum norms of A.
C
      ACNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK )
      ARNORM = DLANGE( 'I-norm', N, N, A, LDA, DWORK )
C
C     Scale the columns of B (i.e. inputs) to have norms roughly ACNORM.
C
      CALL TB01TY( 1, 0, 0, N, M, ACNORM, B, LDB, SCIN )
C
C     Scale the rows of C (i.e. outputs) to have norms roughly ARNORM.
C
      CALL TB01TY( 0, 0, 0, P, N, ARNORM, C, LDC, SCOUT )
C
C     Finally, apply these input and output scalings to D and set SCIN.
C
      DO 40 J = 1, M
         SCALE = SCIN(J)
C
         DO 30 I = 1, P
            D(I,J) = D(I,J)*( SCALE*SCOUT(I) )
   30    CONTINUE
C
         SCIN(J) = ONE/SCALE
   40 CONTINUE
C
      RETURN
C *** Last line of TB01TD ***
      END


      SUBROUTINE TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU,
     $                   DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the pair (A,C) to lower or upper observer Hessenberg
C     form using (and optionally accumulating) unitary state-space
C     transformations.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBU    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix U the unitary state-space transformations for
C             reducing the system, as follows:
C             = 'N':  Do not form U;
C             = 'I':  U is initialized to the unit matrix and the
C                     unitary transformation matrix U is returned;
C             = 'U':  The given matrix U is updated by the unitary
C                     transformations used in the reduction.
C
C     UPLO    CHARACTER*1
C             Indicates whether the user wishes the pair (A,C) to be
C             reduced to upper or lower observer Hessenberg form as
C             follows:
C             = 'U':  Upper observer Hessenberg form;
C             = 'L':  Lower observer Hessenberg form.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The actual state dimension, i.e. the order of the
C             matrix A.  N >= 0.
C
C     P       (input) INTEGER
C             The actual output dimension, i.e. the number of rows of
C             the matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state transition matrix A to be transformed.
C             On exit, the leading N-by-N part of this array contains
C             the transformed state transition matrix U' * A * U.
C             The annihilated elements are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C to be transformed.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C * U.
C             The annihilated elements are set to zero.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,*)
C             On entry, if JOBU = 'U', then the leading N-by-N part of
C             this array must contain a given matrix U (e.g. from a
C             previous call to another SLICOT routine), and on exit, the
C             leading N-by-N part of this array contains the product of
C             the input matrix U and the state-space transformation
C             matrix which reduces the given pair to observer Hessenberg
C             form.
C             On exit, if JOBU = 'I', then the leading N-by-N part of
C             this array contains the matrix of accumulated unitary
C             similarity transformations which reduces the given pair
C             to observer Hessenberg form.
C             If JOBU = 'N', the array U is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDU = 1 and
C             declare this array to be U(1,1) in the calling program).
C
C     LDU     INTEGER
C             The leading dimension of array U. If JOBU = 'U' or
C             JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(N,P-1))
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine computes a unitary state-space transformation U, which
C     reduces the pair (A,C) to one of the following observer Hessenberg
C     forms:
C
C                                N
C                       |*  . . . . . .  *|
C                       |.               .|
C                       |.               .|
C                       |.               .| N
C                       |*               .|
C            |U'AU|     |   .            .|
C            |----|  =  |     .          .|
C            |CU  |     |       * . . .  *|
C                       -------------------
C                       |         * . .  *|
C                       |           .    .| P
C                       |             .  .|
C                       |                *|
C
C         if UPLO = 'U', or
C
C                               N
C                      |*                |
C                      |.  .             |
C                      |.    .           | P
C                      |*  . . *         |
C            |CU  |    -------------------
C            |----|  = |*  . . . *       |
C            |U'AU|    |.          .     |
C                      |.            .   |
C                      |.               *|
C                      |.               .| N
C                      |.               .|
C                      |.               .|
C                      |*  . . . . . .  *|
C
C     if UPLO = 'L'.
C
C     If P >= N, then the matrix CU is trapezoidal and U'AU is full.
C
C     REFERENCES
C
C     [1] Van Dooren, P. and Verhaegen, M.H.G.
C         On the use of unitary state-space transformations.
C         In : Contemporary Mathematics on Linear Algebra and its Role
C         in Systems Theory, 47, AMS, Providence, 1985.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O((N + P) x N**2) operations and is
C     backward stable (see [1]).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TB01BD by M. Vanbegin, and
C     P. Van Dooren, Philips Research Laboratory, Brussels, Belgium.
C
C     REVISIONS
C
C     February 1997.
C
C     KEYWORDS
C
C     Controllability, observer Hessenberg form, orthogonal
C     transformation, unitary transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDC, LDU, N, P
      CHARACTER         JOBU, UPLO
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), C(LDC,*), DWORK(*), U(LDU,*)
C     .. Local Scalars ..
      LOGICAL           LJOBA, LJOBI, LUPLO
      INTEGER           II, J, N1, NJ, P1, PAR1, PAR2, PAR3, PAR4, PAR5,
     $                  PAR6
      DOUBLE PRECISION  DZ
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARFG, DLASET, DLATZM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LUPLO = LSAME( UPLO, 'U' )
      LJOBI = LSAME( JOBU, 'I' )
      LJOBA = LJOBI.OR.LSAME( JOBU, 'U' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -8
      ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR.
     $              LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN
         INFO = -10
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return
C
         CALL XERBLA( 'TB01ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. P.EQ.0 )
     $   RETURN
C
      P1 = P + 1
      N1 = N - 1
C
      IF ( LJOBI ) THEN
C
C        Initialize U to the identity matrix.
C
         CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
      END IF
C
C     Perform transformations involving both C and A.
C
      DO 20 J = 1, MIN( P, N1 )
         NJ = N - J
         IF ( LUPLO ) THEN
            PAR1 = P - J + 1
            PAR2 = NJ + 1
            PAR3 = 1
            PAR4 = P - J
            PAR5 = NJ
         ELSE
            PAR1 = J
            PAR2 = J
            PAR3 = J + 1
            PAR4 = P
            PAR5 = N
         END IF
C
         CALL DLARFG( NJ+1, C(PAR1,PAR2), C(PAR1,PAR3), LDC, DZ )
C
C        Update A.
C
         CALL DLATZM( 'Left', NJ+1, N, C(PAR1,PAR3), LDC, DZ, A(PAR2,1),
     $                A(PAR3,1), LDA, DWORK )
         CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ,
     $                A(1,PAR2), A(1,PAR3), LDA, DWORK )
C
         IF ( LJOBA ) THEN
C
C           Update U.
C
            CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ,
     $                   U(1,PAR2), U(1,PAR3), LDU, DWORK )
         END IF
C
         IF ( J.NE.P ) THEN
C
C           Update C.
C
            CALL DLATZM( 'Right', PAR4-PAR3+1, NJ+1, C(PAR1,PAR3), LDC,
     $                   DZ, C(PAR3,PAR2), C(PAR3,PAR3), LDC, DWORK )
         END IF
C
         DO 10 II = PAR3, PAR5
            C(PAR1,II) = ZERO
   10    CONTINUE
C
   20 CONTINUE
C
      DO 40 J = P1, N1
C
C        Perform next transformations only involving A.
C
         NJ = N - J
         IF ( LUPLO ) THEN
            PAR1 = N + P1 - J
            PAR2 = NJ + 1
            PAR3 = 1
            PAR4 = NJ
            PAR5 = 1
            PAR6 = N + P - J
         ELSE
            PAR1 = J - P
            PAR2 = J
            PAR3 = J + 1
            PAR4 = N
            PAR5 = J - P + 1
            PAR6 = N
         END IF
C
         IF ( NJ.GT.0 ) THEN
C
            CALL DLARFG( NJ+1, A(PAR1,PAR2), A(PAR1,PAR3), LDA, DZ )
C
C           Update A.
C
            CALL DLATZM( 'Left', NJ+1, N, A(PAR1,PAR3), LDA, DZ,
     $                   A(PAR2,1), A(PAR3,1), LDA, DWORK )
            CALL DLATZM( 'Right', PAR6-PAR5+1, NJ+1, A(PAR1,PAR3), LDA,
     $                    DZ, A(PAR5,PAR2), A(PAR5,PAR3), LDA, DWORK )
C
            IF ( LJOBA ) THEN
C
C              Update U.
C
               CALL DLATZM( 'Right', N, NJ+1, A(PAR1,PAR3), LDA, DZ,
     $                      U(1,PAR2), U(1,PAR3), LDU, DWORK )
            END IF
C
            DO 30 II = PAR3, PAR4
               A(PAR1,II) = ZERO
   30       CONTINUE
C
         END IF
C
   40 CONTINUE
C
      RETURN
C *** Last line of TB01ND ***
      END


c*************************************************************************
c                        DRIFT_KEPU_P3SOLVE.F
c*************************************************************************
c Returns the real root of cubic often found in solving kepler
c problem in universal variables.
c
c             Input:
c                 dt            ==>  time step (real scalar)
c                 r0            ==>  Distance between `Sun' and paritcle
c                                     (real scalar)
c                 mu            ==>  Reduced mass of system (real scalar)
c                 alpha         ==>  Twice the binding energy (real scalar)
c                 u             ==>  Vel. dot radial vector (real scalar)
c             Output:
c                 s             ==>  solution of cubic eqn for the
c                                    universal variable
c                 iflg          ==>  success flag ( = 0 if O.K.) (integer)
c
c Author:  Martin Duncan
c Date:    March 12/93
c Last revision: March 12/93

      subroutine drift_kepu_p3solve(dt,r0,mu,alpha,u,s,iflg)

c...  Inputs:
      real*8 dt,r0,mu,alpha,u

c...  Outputs:
      integer iflg
      real*8 s

c...  Internals:
      real*8 denom,a0,a1,a2,q,r,sq2,sq,p1,p2

c----
c...  Executable code

	denom = (mu - alpha*r0)/6.d0
	a2 = 0.5*u/denom
	a1 = r0/denom
	a0 =-dt/denom

	q = (a1 - a2*a2/3.d0)/3.d0
	r = (a1*a2 -3.d0*a0)/6.d0 - (a2**3)/27.d0
	sq2 = q**3 + r**2

	if( sq2 .ge. 0.d0) then
	   sq = sqrt(sq2)

	   if ((r+sq) .le. 0.d0) then
	      p1 =  -(-(r + sq))**(1.d0/3.d0)
	   else
	      p1 = (r + sq)**(1.d0/3.d0)
	   endif
	   if ((r-sq) .le. 0.d0) then
	      p2 =  -(-(r - sq))**(1.d0/3.d0)
	   else
	      p2 = (r - sq)**(1.d0/3.d0)
	   endif

	   iflg = 0
	   s = p1 + p2 - a2/3.d0

	else
	   iflg = 1
	   s = 0
	endif

        return
        end     !   drift_kepu_p3solve
c-------------------------------------------------------------------


      subroutine roujbrdf(k0,k1,k2,mu,np,rm,rp,brdfint)
c model can be found in JGR 1992 paper, Vol. 97,No D18, Page20,445-20,468
      integer mu,np
      dimension rm(-mu:mu),rp(np),brdfint(-mu:mu,np)
      real k0,k1,k2,pi,psi,cpsi
      real rm,rp,brdfint,xmus,xmuv,fi,fr,tts,ttv,f2,f1
      integer k,j
      xmus=rm(0)
      pi=atan(1.)*4.
      do 1 k=1,np
      do 2 j=1,mu
      xmuv=rm(j)
      if (j.eq.mu) then
         fi=rm(-mu)
         else
         fi=rp(k)+rm(-mu)
         endif
      fr=acos(cos(fi))
      tts=tan(acos(xmus))
      ttv=tan(acos(xmuv))
      cpsi=xmus*xmuv+sin(acos(xmus))*sin(acos(xmuv))*cos(fi)
      if (cpsi.lt.1.) then
      psi=acos(cpsi)
      else
      psi=0.
      endif
      f2=4./(3.*pi*(xmus+xmuv))*((pi/2-psi)*cpsi+sin(psi))-1./3.
      f1=0.5*((pi-fr)*cos(fr)+sin(fr))*tts*ttv-tts-ttv-sqrt(
     s   tts*tts+ttv*ttv-2*tts*ttv*cos(fr))
      f1=f1/pi
      brdfint(j,k)=k0+k1*f1+k2*f2
  2   continue
  1   continue
      return
      end


      SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK,
     $                   LWORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGGQRF computes a generalized QR factorization of an N-by-M matrix A
*  and an N-by-P matrix B:
*
*              A = Q*R,        B = Q*T*Z,
*
*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
*  matrix, and R and T assume one of the forms:
*
*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,
*                  (  0  ) N-M                         N   M-N
*                     M
*
*  where R11 is upper triangular, and
*
*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,
*                   P-N  N                           ( T21 ) P
*                                                       P
*
*  where T12 or T21 is upper triangular.
*
*  In particular, if B is square and nonsingular, the GQR factorization
*  of A and B implicitly gives the QR factorization of inv(B)*A:
*
*               inv(B)*A = Z'*(inv(T)*R)
*
*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the
*  transpose of the matrix Z.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of rows of the matrices A and B. N >= 0.
*
*  M       (input) INTEGER
*          The number of columns of the matrix A.  M >= 0.
*
*  P       (input) INTEGER
*          The number of columns of the matrix B.  P >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)
*          On entry, the N-by-M matrix A.
*          On exit, the elements on and above the diagonal of the array
*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is
*          upper triangular if N >= M); the elements below the diagonal,
*          with the array TAUA, represent the orthogonal matrix Q as a
*          product of min(N,M) elementary reflectors (see Further
*          Details).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,N).
*
*  TAUA    (output) DOUBLE PRECISION array, dimension (min(N,M))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix Q (see Further Details).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)
*          On entry, the N-by-P matrix B.
*          On exit, if N <= P, the upper triangle of the subarray
*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
*          if N > P, the elements on and above the (N-P)-th subdiagonal
*          contain the N-by-P upper trapezoidal matrix T; the remaining
*          elements, with the array TAUB, represent the orthogonal
*          matrix Z as a product of elementary reflectors (see Further
*          Details).
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= max(1,N).
*
*  TAUB    (output) DOUBLE PRECISION array, dimension (min(N,P))
*          The scalar factors of the elementary reflectors which
*          represent the orthogonal matrix Z (see Further Details).
*
*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,N,M,P).
*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
*          where NB1 is the optimal blocksize for the QR factorization
*          of an N-by-M matrix, NB2 is the optimal blocksize for the
*          RQ factorization of an N-by-P matrix, and NB3 is the optimal
*          blocksize for a call of DORMQR.
*
*          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.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  The matrix Q is represented as a product of elementary reflectors
*
*     Q = H(1) H(2) . . . H(k), where k = min(n,m).
*
*  Each H(i) has the form
*
*     H(i) = I - taua * v * v'
*
*  where taua is a real scalar, and v is a real vector with
*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
*  and taua in TAUA(i).
*  To form Q explicitly, use LAPACK subroutine DORGQR.
*  To use Q to update another matrix, use LAPACK subroutine DORMQR.
*
*  The matrix Z is represented as a product of elementary reflectors
*
*     Z = H(1) H(2) . . . H(k), where k = min(n,p).
*
*  Each H(i) has the form
*
*     H(i) = I - taub * v * v'
*
*  where taub is a real scalar, and v is a real vector with
*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
*  To form Z explicitly, use LAPACK subroutine DORGRQ.
*  To use Z to update another matrix, use LAPACK subroutine DORMRQ.
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEQRF, DGERQF, DORMQR, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
      NB2 = ILAENV( 1, 'DGERQF', ' ', N, P, -1, -1 )
      NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
      NB = MAX( NB1, NB2, NB3 )
      LWKOPT = MAX( N, M, P )*NB
      WORK( 1 ) = LWKOPT
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGQRF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     QR factorization of N-by-M matrix A: A = Q*R
*
      CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
      LOPT = WORK( 1 )
*
*     Update B := Q'*B.
*
      CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
     $             B, LDB, WORK, LWORK, INFO )
      LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
*
*     RQ factorization of N-by-P matrix B: B = T*Z.
*
      CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
      WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
*
      RETURN
*
*     End of DGGQRF
*
      END