      SUBROUTINE SB10JD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, E,
     $                   LDE, NSYS, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To convert the descriptor state-space system
C
C     E*dx/dt = A*x + B*u
C           y = C*x + D*u
C
C     into regular state-space form
C
C      dx/dt = Ad*x + Bd*u
C          y = Cd*x + Dd*u .
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the descriptor system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 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 matrix A of the descriptor system.
C             On exit, the leading NSYS-by-NSYS part of this array
C             contains the state matrix Ad of the converted system.
C
C     LDA     INTEGER
C             The leading dimension of the 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 input matrix B of the descriptor system.
C             On exit, the leading NSYS-by-M part of this array
C             contains the input matrix Bd of the converted system.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading NP-by-N part of this array must
C             contain the output matrix C of the descriptor system.
C             On exit, the leading NP-by-NSYS part of this array
C             contains the output matrix Cd of the converted system.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading NP-by-M part of this array must
C             contain the matrix D of the descriptor system.
C             On exit, the leading NP-by-M part of this array contains
C             the matrix Dd of the converted system.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= max(1,NP).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix E of the descriptor system.
C             On exit, this array contains no useful information.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= max(1,N).
C
C     NSYS    (output) INTEGER
C             The order of the converted state-space system.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= max( 1, 2*N*N + 2*N + N*MAX( 5, N + M + NP ) ).
C             For good performance, LDWORK must generally be larger.
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             = 1:  the iteration for computing singular value
C                   decomposition did not converge.
C
C     METHOD
C
C     The routine performs the transformations described in [1].
C
C     REFERENCES
C
C     [1] Chiang, R.Y. and Safonov, M.G.
C         Robust Control Toolbox User's Guide.
C         The MathWorks Inc., Natick, Mass., 1992.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000,
C     Feb. 2001.
C
C     KEYWORDS
C
C     Descriptor systems, state-space models.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N,
     $                   NP, NSYS
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   D( LDD, * ), DWORK( * ),  E( LDE, * )
C     ..
C     .. Local Scalars ..
      INTEGER            I, IA12, IA21, IB2, IC2, INFO2, IS, ISA, IU,
     $                   IV, IWRK, J, K, LWA, LWAMAX, MINWRK, NS1
      DOUBLE PRECISION   EPS, SCALE, TOL
C     ..
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGESVD, DLACPY, DLASET, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.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, NP ) ) THEN
         INFO = -9
      ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN
         INFO = -11
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -13
      END IF
C
C     Compute workspace.
C
      MINWRK = MAX( 1, 2*N*( N + 1 ) + N*MAX( 5, N + M + NP ) )
      IF( LDWORK.LT.MINWRK ) THEN
         INFO = -16
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10JD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         NSYS = 0
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Set tol.
C
      EPS = DLAMCH( 'Epsilon' )
      TOL = SQRT( EPS )
C
C     Workspace usage.
C
      IS = 0
      IU = IS + N
      IV = IU + N*N
C
      IWRK = IV + N*N
C
C     Compute the SVD of E.
C     Additional workspace:  need   5*N; prefer larger.
C
      CALL DGESVD( 'S', 'S', N, N, E, LDE, DWORK( IS+1 ), DWORK( IU+1 ),
     $             N, DWORK( IV+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK,
     $             INFO2 )
      IF( INFO2.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
      LWAMAX = MAX( MINWRK, INT( DWORK( IWRK+1 ) + IWRK ) )
C
C     Determine the rank of E.
C
      NS1 = 0
      DO 10 I = 1, N
         IF( DWORK( IS+I ).GT.TOL ) NS1 = NS1 + 1
   10 CONTINUE
      IF( NS1.GT.0 ) THEN
C
C        Transform A.
C        Additional workspace:  need   N*max(N,M,NP).
C
         CALL DGEMM( 'T', 'N', N, N, N, ONE, DWORK( IU+1 ), N, A, LDA,
     $               ZERO, DWORK( IWRK+1 ), N )
         CALL DGEMM( 'N', 'T', N, N, N, ONE, DWORK( IWRK+1 ), N,
     $               DWORK( IV+1 ), N, ZERO, A, LDA )
C
C        Transform B.
C
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IWRK+1 ), N )
         CALL DGEMM( 'T', 'N', N, M, N, ONE, DWORK( IU+1 ), N,
     $               DWORK( IWRK+1 ), N, ZERO, B, LDB )
C
C        Transform C.
C
         CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWRK+1 ), NP )
         CALL DGEMM( 'N', 'T', NP, N, N, ONE, DWORK( IWRK+1 ), NP,
     $               DWORK( IV+1 ), N, ZERO, C, LDC )
C
         K = N - NS1
         IF( K.GT.0 ) THEN
            ISA  = IU  + K*K
            IV   = ISA + K
            IWRK = IV  + K*MAX( K, NS1 )
C
C           Compute the SVD of A22.
C           Additional workspace:  need   5*K; prefer larger.
C
            CALL DGESVD( 'S', 'S', K, K, A( NS1+1, NS1+1 ), LDA,
     $                   DWORK( ISA+1 ), DWORK( IU+1 ), K,
     $                   DWORK( IV+1 ), K, DWORK( IWRK+1 ), LDWORK-IWRK,
     $                   INFO2 )
            IF( INFO2.NE.0 ) THEN
               INFO = 1
               RETURN
            END IF
            IA12 = IWRK
            IB2  = IA12 + NS1*K
            IC2  = IB2  + K*M
C
            LWA = INT( DWORK( IWRK+1 ) ) + IWRK
            LWAMAX = MAX( LWA, LWAMAX, IC2 + K*NP )
C
C           Compute the transformed A12.
C
            CALL DGEMM( 'N', 'T', NS1, K, K, ONE, A( 1, NS1+1 ), LDA,
     $                  DWORK( IV+1 ), K, ZERO, DWORK( IA12+1 ), NS1 )
C
C           Compute CC2.
C
            CALL DGEMM( 'N', 'T', NP, K, K, ONE, C( 1, NS1+1 ), LDC,
     $                  DWORK( IV+1 ), K, ZERO, DWORK( IC2+1 ), NP )
C
C           Compute the transformed A21.
C
            IA21 = IV
            CALL DGEMM( 'T', 'N', K, NS1, K, ONE, DWORK( IU+1 ), K,
     $                  A( NS1+1, 1 ), LDA, ZERO, DWORK( IA21+1 ), K )
C
C           Compute BB2.
C
            CALL DGEMM( 'T', 'N', K, M, K, ONE, DWORK( IU+1 ), K,
     $                  B( NS1+1, 1 ), LDB, ZERO, DWORK( IB2+1 ), K )
C
C           Compute A12*pinv(A22) and CC2*pinv(A22).
C
            DO 20 J = 1, K
               SCALE = ZERO
               IF( DWORK( ISA+J ).GT.TOL ) SCALE = ONE/DWORK( ISA+J )
               CALL DSCAL( NS1, SCALE, DWORK( IA12+(J-1)*NS1+1 ), 1 )
               CALL DSCAL( NP,  SCALE, DWORK( IC2+(J-1)*NP+1 ), 1 )
  20        CONTINUE
C
C           Compute Ad.
C
            CALL DGEMM( 'N', 'N', NS1, NS1, K, -ONE, DWORK( IA12+1 ),
     $                  NS1, DWORK( IA21+1 ), K, ONE, A, LDA )
C
C           Compute Bd.
C
            CALL DGEMM( 'N', 'N', NS1, M, K, -ONE, DWORK( IA12+1 ), NS1,
     $                  DWORK( IB2+1 ), K, ONE, B, LDB )
C
C           Compute Cd.
C
            CALL DGEMM( 'N', 'N', NP, NS1, K, -ONE, DWORK( IC2+1 ), NP,
     $                  DWORK( IA21+1 ), K, ONE, C, LDC )
C
C           Compute Dd.
C
            CALL DGEMM( 'N', 'N', NP, M, K, -ONE, DWORK( IC2+1 ), NP,
     $                  DWORK( IB2+1 ), K, ONE, D, LDD )
         END IF
         DO 30 I = 1, NS1
            SCALE = ONE/SQRT( DWORK( IS+I ) )
            CALL DSCAL( NS1, SCALE, A( I, 1 ), LDA )
            CALL DSCAL( M,   SCALE, B( I, 1 ), LDB )
  30     CONTINUE
         DO 40 J = 1, NS1
            SCALE = ONE/SQRT( DWORK( IS+J ) )
            CALL DSCAL( NS1, SCALE, A( 1, J ), 1 )
            CALL DSCAL( NP,  SCALE, C( 1, J ), 1 )
  40     CONTINUE
         NSYS = NS1
      ELSE
         CALL DLASET( 'F', N,  N, ZERO, -ONE/EPS, A, LDA )
         CALL DLASET( 'F', N,  M, ZERO, ZERO, B, LDB )
         CALL DLASET( 'F', NP, N, ZERO, ZERO, C, LDC )
         NSYS = N
      END IF
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10JD ***
      END


      SUBROUTINE BD02AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A,
     1                   LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK,
     2                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To generate benchmark examples for time-invariant,
C     discrete-time dynamical systems
C
C       E x_k+1 = A x_k + B u_k
C
C           y_k = C x_k + D u_k
C
C     E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and
C     D is P-by-M. In many examples, E is the identity matrix and D is
C     the zero matrix.
C
C     This routine is an implementation of the benchmark library
C     DTDSX (Version 1.0) described in [1].
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DEF     CHARACTER*1
C             Specifies the kind of values used as parameters when
C             generating parameter-dependent and scalable examples
C             (i.e., examples with NR(1) = 2, 3, or 4):
C             = 'D':  Default values defined in [1] are used;
C             = 'N':  Values set in DPAR and IPAR are used.
C             This parameter is not referenced if NR(1) = 1.
C             Note that the scaling parameter of examples with
C             NR(1) = 3 or 4 is considered as a regular parameter in
C             this context.
C
C     Input/Output Parameters
C
C     NR      (input) INTEGER array, dimension (2)
C             Specifies the index of the desired example according
C             to [1].
C             NR(1) defines the group:
C                   1 : parameter-free problems of fixed size
C                   2 : parameter-dependent problems of fixed size
C                   3 : parameter-free problems of scalable size
C                   4 : parameter-dependent problems of scalable size
C             NR(2) defines the number of the benchmark example
C             within a certain group according to [1].
C
C     DPAR    (input/output) DOUBLE PRECISION array, dimension (7)
C             On entry, if DEF = 'N' and the desired example depends on
C             real parameters, then the array DPAR must contain the
C             values for these parameters.
C             For an explanation of the parameters see [1].
C             For Example 2.1, DPAR(1), ..., DPAR(3) define the
C             parameters 'tau', 'delta', 'K', respectively.
C             On exit, if DEF = 'D' and the desired example depends on
C             real parameters, then the array DPAR is overwritten by the
C             default values given in [1].
C
C     IPAR    (input/output) INTEGER array, dimension (1)
C             On entry, if DEF = 'N' and the desired example depends on
C             integer parameters, then the array IPAR must contain the
C             values for these parameters.
C             For an explanation of the parameters see [1].
C             For Example 3.1, IPAR(1) defines the parameter 'n'.
C             On exit, if DEF = 'D' and the desired example depends on
C             integer parameters, then the array IPAR is overwritten by
C             the default values given in [1].
C
C     VEC     (output) LOGICAL array, dimension (8)
C             Flag vector which displays the availabilty of the output
C             data:
C             VEC(1), ..., VEC(3) refer to N, M, and P, respectively,
C             and are always .TRUE..
C             VEC(4) is .TRUE. iff E is NOT the identity matrix.
C             VEC(5), ..., VEC(7) refer to A, B, and C, respectively,
C             and are always .TRUE..
C             VEC(8) is .TRUE. iff D is NOT the zero matrix.
C
C     N       (output) INTEGER
C             The actual state dimension, i.e., the order of the
C             matrices E and A.
C
C     M       (output) INTEGER
C             The number of columns in the matrices B and D.
C
C     P       (output) INTEGER
C             The number of rows in the matrices C and D.
C
C     E       (output) DOUBLE PRECISION array, dimension (LDE,N)
C             The leading N-by-N part of this array contains the
C             matrix E.
C             NOTE that this array is overwritten (by the identity
C             matrix), if VEC(4) = .FALSE..
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= N.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array contains the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= N.
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array contains the
C             matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= N.
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array contains the
C             matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= P.
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array contains the
C             matrix D.
C             NOTE that this array is overwritten (by the zero
C             matrix), if VEC(8) = .FALSE..
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= P.
C
C     NOTE    (output) CHARACTER*70
C             String containing short information about the chosen
C             example.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             NOTE that DWORK is not used in the current version
C             of BD02AD.
C
C     LDWORK  INTEGER
C             LDWORK >= 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; in particular, INFO = -3 or -4 indicates
C                   that at least one of the parameters in DPAR or
C                   IPAR, respectively, has an illegal value;
C             = 1:  data file can not be opened or has wrong format.
C
C     REFERENCES
C
C     [1]  Kressner, D., Mehrmann, V. and Penzl, T.
C          DTDSX - a Collection of Benchmark Examples for State-Space
C          Realizations of Discrete-Time Dynamical Systems.
C          SLICOT Working Note 1998-10. 1998.
C
C     NUMERICAL ASPECTS
C
C     None
C
C     CONTRIBUTOR
C
C     D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz)
C
C     For questions concerning the collection or for the submission of
C     test examples, please contact Volker Mehrmann
C     (Email: volker.mehrmann@mathematik.tu-chemnitz.de).
C
C     REVISIONS
C
C     June 1999, V. Sima.
C
C     KEYWORDS
C
C     discrete-time dynamical systems
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, THREE, FOUR
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     1                    THREE = 3.0D0, FOUR = 4.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DEF
      CHARACTER*70      NOTE
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P
C     .. Array Arguments ..
      LOGICAL           VEC(8)
      INTEGER           IPAR(*), NR(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*),
     1                  DWORK(*), E(LDE,*)
C     .. Local Scalars ..
      CHARACTER*12      DATAF
      INTEGER           I, J, STATUS
      DOUBLE PRECISION  TEMP
C     .. Local Arrays ..
      LOGICAL           VECDEF(8)
C     .. External Functions ..
C     . LAPACK .
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
C     . LAPACK .
      EXTERNAL         DLASET
C     .. Data Statements ..
C     . default values for availabities .
      DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE.,
     1             .TRUE., .TRUE., .TRUE., .FALSE./
C
C     .. Executable Statements ..
C
      INFO = 0
      DO 10  I = 1, 8
        VEC(I) = VECDEF(I)
10    CONTINUE
C
      IF (NR(1) .EQ. 1) THEN
C
        IF (NR(2) .EQ. 1) THEN
          NOTE = 'Laub 1979, Ex. 2: uncontrollable-unobservable data'
          N = 2
          M = 1
          P = 1
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          A(1,1) = FOUR
          A(2,1) = -.45D1
          A(1,2) = THREE
          A(2,2) = -.35D1
          CALL DLASET('A', N, M, -ONE, ONE, B, LDB)
          C(1,1) = 3.0D0
          C(1,2) = 2.0D0
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 2) THEN
          NOTE = 'Laub 1979, Ex. 3'
          N = 2
          M = 2
          P = 2
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          A(1,1) = .9512D0
          A(2,2) = .9048D0
          B(1,1) = .4877D1
          B(1,2) = .4877D1
          B(2,1) = -.11895D1
          B(2,2) = .3569D1
          CALL DLASET('A', P, N, ZERO, ONE, C, LDC)
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 3) THEN
          NOTE = 'Van Dooren 1981, Ex. II'
          N = 2
          M = 1
          P = 1
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          A(1,1) =  TWO
          A(2,1) =  ONE
          A(1,2) = -ONE
          A(2,2) = ZERO
          CALL DLASET('A', N, M, ZERO, ONE, B, LDB)
          CALL DLASET('A', P, N, ONE, ZERO, C, LDC)
          D(1,1) = ZERO
C
        ELSE IF (NR(2) .EQ. 4) THEN
          NOTE = 'Ionescu/Weiss 1992'
          N = 2
          M = 2
          P = 2
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          A(1,2) =  ONE
          A(2,2) = -ONE
          CALL DLASET('A', N, M, ZERO, ONE, B, LDB)
          B(2,1) =  TWO
          CALL DLASET('A', P, N, ZERO, ONE, C, LDC)
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 5) THEN
          NOTE = 'Jonckheere 1981'
          N = 2
          M = 1
          P = 2
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          A(1,2) = ONE
          CALL DLASET('A', N, M, ONE, ZERO, B, LDB)
          CALL DLASET('A', P, N, ZERO, ONE, C, LDC)
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 6) THEN
          NOTE = 'Ackerson/Fu 1970: satellite control problem'
          N = 4
          M = 2
          P = 4
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', P, N, ZERO, ONE, C, LDC)
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 7) THEN
          NOTE = 'Litkouhi 1983: system with slow and fast modes'
          N = 4
          M = 2
          P = 4
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', P, N, ZERO, ONE, C, LDC)
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 8) THEN
          NOTE = 'Lu/Lin 1993, Ex. 4.3'
          N = 4
          M = 4
          P = 4
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('U', P, N, ONE, ONE, C, LDC)
          C(1,3) = TWO
          C(1,4) = FOUR
          C(2,4) = TWO
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 9) THEN
          NOTE = 'Gajic/Shen 1993, Section 2.7.4: chemical plant'
          N = 5
          M = 2
          P = 5
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', P, N, ZERO, ONE, C, LDC)
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 10) THEN
          NOTE = 'Davison/Wang 1974'
          N = 6
          M = 2
          P = 2
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
          VEC(8) = .TRUE.
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          A(1,2) = ONE
          A(2,3) = ONE
          A(4,5) = ONE
          A(5,6) = ONE
          CALL DLASET('A', N, M, ZERO, ZERO, B, LDB)
          B(3,1) = ONE
          B(6,2) = ONE
          CALL DLASET('A', P, N, ZERO, ZERO, C, LDC)
          C(1,1) = ONE
          C(1,2) = ONE
          C(2,4) = ONE
          C(2,5) = -ONE
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
          D(1,1) = ONE
          D(2,1) = ONE
C
        ELSE IF (NR(2) .EQ. 11) THEN
          NOTE = 'Patnaik et al. 1980: tubular ammonia reactor'
          N = 9
          M = 3
          P = 2
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', P, N, ZERO, ZERO, C, LDC)
          C(1,1) = ONE
          C(2,5) = ONE
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE IF (NR(2) .EQ. 12) THEN
          NOTE = 'Smith 1969: two-stand cold rolling mill'
          N = 10
          M = 3
          P = 5
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
          VEC(8) = .TRUE.
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          CALL DLASET('A', N, N, ZERO, ONE, A(2,1), LDA)
          A(1,10) = .112D0
          CALL DLASET('A', N, M, ZERO, ZERO, B, LDB)
          B(1,1) =  .276D1
          B(1,2) = -.135D1
          B(1,3) = -.46D0
          CALL DLASET('A', P, N, ZERO, ZERO, C, LDC)
          C(1,1)  = ONE
          C(2,10) =  .894D0
          C(3,10) = -.1693D2
          C(4,10) =  .7D-1
          C(5,10) =  .398D0
          OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD02112.dat')
          IF (STATUS .NE. 0) THEN
            INFO = 1
          ELSE
            DO 110  I = 1, P
              READ (1, FMT = *, IOSTAT = STATUS) (D(I,J), J = 1, M)
              IF (STATUS .NE. 0)  INFO = 1
110         CONTINUE
          END IF
          CLOSE(1)
C
        ELSE
          INFO = -2
        END IF
C
        IF (((NR(2) .GE. 6) .AND. (NR(2) .LE. 9)) .OR.
     1       (NR(2) .EQ. 11))  THEN
C         .. loading data files
          WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD021', NR(2), '.dat'
          OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11))
          IF (STATUS .NE. 0) THEN
            INFO = 1
          ELSE
            DO 120  I = 1, N
              READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N)
              IF (STATUS .NE. 0)  INFO = 1
120         CONTINUE
            DO 130  I = 1, N
              READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M)
              IF (STATUS .NE. 0)  INFO = 1
130         CONTINUE
          END IF
          CLOSE(1)
        END IF
C
      ELSE IF (NR(1) .EQ. 2) THEN
        IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN
          INFO = -1
          RETURN
        END IF
C
        IF (NR(2) .EQ. 1) THEN
          NOTE = 'Pappas et al. 1980: process control of paper machine'
          IF (LSAME(DEF,'D')) THEN
            DPAR(1) = .1D9
            DPAR(2) = ONE
            DPAR(3) = ONE
          END IF
          IF (DPAR(1) .EQ. ZERO) INFO = -3
          N = 4
          M = 1
          P = 1
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          TEMP = DPAR(2) / DPAR(1)
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          CALL DLASET('A', N-1, N-1, ZERO, ONE, A(2,1), LDA)
          A(1,1) = ONE - TEMP
          CALL DLASET('A', N, M, ZERO, ZERO, B, LDB)
          B(1,1) = DPAR(3) * TEMP
          CALL DLASET('A', P, N, ZERO, ZERO, C, LDC)
          C(1,4) = ONE
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE
          INFO = -2
        END IF
C
      ELSE IF (NR(1) .EQ. 3) THEN
        IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN
          INFO = -1
          RETURN
        END IF
C
        IF (NR(2) .EQ. 1) THEN
          NOTE = 'Pappas et al. 1980, Ex. 3'
          IF (LSAME(DEF,'D')) IPAR(1) = 100
          IF (IPAR(1) .LT. 2) INFO = -4
          N = IPAR(1)
          M = 1
          P = N
          IF (LDE .LT. N) INFO = -10
          IF (LDA .LT. N) INFO = -12
          IF (LDB .LT. N) INFO = -14
          IF (LDC .LT. P) INFO = -16
          IF (LDD .LT. P) INFO = -18
          IF (INFO .NE. 0) RETURN
C
          CALL DLASET('A', N, N, ZERO, ONE, E, LDE)
          CALL DLASET('A', N, N, ZERO, ZERO, A, LDA)
          CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA)
          CALL DLASET('A', N, M, ZERO, ZERO, B, LDB)
          B(N,1) = ONE
          CALL DLASET('A', P, N, ZERO, ONE, C, LDC)
          CALL DLASET('A', P, M, ZERO, ZERO, D, LDD)
C
        ELSE
          INFO = -2
        END IF
C
      ELSE
        INFO = -2
      END IF
C
      RETURN
C *** Last Line of BD02AD ***
      END


C
C*    Group  Linear Solver subroutines (Code DECCON/SOLCON)
C
      SUBROUTINE DECCON(A,NROW,NCOL,MCON,M,N,IRANKC,IRANK,COND,
     *                  D,PIVOT,KRED,AH,V,IERR)
C*    Begin Prologue DECCON
      INTEGER IRANKC,IRANK,MCON
      INTEGER M,N,NROW,NCOL,KRED
      INTEGER PIVOT(NCOL)
      DOUBLE PRECISION COND
      DOUBLE PRECISION A(NROW,NCOL),AH(NCOL,NCOL)
      DOUBLE PRECISION D(NCOL),V(NCOL)
      INTEGER IERR
C     ------------------------------------------------------------
C
C*  Title
C
C*    Deccon - Constrained Least Squares QR-Decomposition
C
C*  Written by        P. Deuflhard, U. Nowak, L. Weimann
C*  Purpose           Solution of least squares problems, optionally
C                     with equality constraints.
C*  Method            Constrained Least Squares QR-Decomposition
C                     (see references below)
C*  Category          D9b1. -  Singular, overdetermined or
C                              underdetermined systems of linear
C                              equations, generalized inverses.
C                              Constrained Least Squares solution
C*  Keywords          Linear Least Square Problems, constrained,
C                     QR-decomposition, pseudo inverse.
C*  Version           1.3
C*  Revision          December 1993
C*  Latest Change     August 2006
C*  Library           CodeLib
C*  Code              Fortran 77, Double Precision
C*  Environment       Standard Fortran 77 environment on PC's,
C                     workstations and hosts.
C*  Copyright     (c) Konrad-Zuse-Zentrum fuer
C                     Informationstechnik Berlin (ZIB)
C                     Takustrasse 7, D-14195 Berlin-Dahlem
C                     phone : + 49/30/84185-0
C                     fax   : + 49/30/84185-125
C*  Contact           Lutz Weimann
C                     ZIB, Division Scientific Computing,
C                          Department Numerical Analysis and Modelling
C                     phone : + 49/30/84185-185
C                     fax   : + 49/30/84185-107
C                     e-mail: weimann@zib.de
C
C*    References:
C     ===========
C
C       /1/ P.Deuflhard, V.Apostolescu:
C           An underrelaxed Gauss-Newton method for equality
C           constrained nonlinear least squares problems.
C           Lecture Notes Control Inform. Sci. vol. 7, p.
C           22-32 (1978)
C       /2/ P.Deuflhard, W.Sautter:
C           On rank-deficient pseudoinverses.
C           J. Lin. Alg. Appl. vol. 29, p. 91-111 (1980)
C
C*    Related Programs:     SOLCON
C
C  ---------------------------------------------------------------
C
C* Licence
C    You may use or modify this code for your own non commercial
C    purposes for an unlimited time.
C    In any case you should not deliver this code without a special
C    permission of ZIB.
C    In case you intend to use the code commercially, we oblige you
C    to sign an according licence agreement with ZIB.
C
C* Warranty
C    This code has been tested up to a certain level. Defects and
C    weaknesses, which may be included in the code, do not establish
C    any warranties by ZIB. ZIB does not take over any liabilities
C    which may follow from acquisition or application of this code.
C
C* Software status
C    This code is under care of ZIB and belongs to ZIB software class 1.
C
C     ------------------------------------------------------------
C
C*    Summary:
C     ========
C     Constrained QR-decomposition of (M,N)-system  with
C     computation of pseudoinverse in case of rank-defeciency .
C     First MCON rows belong to equality constraints.
C
C     ------------------------------------------------------------
C
C*    Parameters list description (* marks inout parameters)
C     ======================================================
C
C*    Input parameters
C     ================
C
C       A(NROW,NCOL) Dble   Array holding the (M,N)-Matrix to be
C                           decomposed
C       NROW         Int    Declared number of rows of array A
C       NCOL         Int    Declared number of columns of array A and
C                           rows and columns of array AH
C       MCON         Int    Number of equality constraints (MCON.LE.N)
C                           Internally reduced if equality constraints
C                           are linearly dependent
C       M            Int    Current number of rows of matrix A
C       N            Int    Current number of columns of matrix A
C     * IRANKC       Int    Prescribed maximum pseudo-rank of
C                           constrained part of matrix A (IRANKC.LE.MCON)
C     * IRANK        Int    Prescribed maximum pseudo-rank of matrix A
C                           (IRANK.LE.N)
C     * COND         Dble   Permitted upper bound for the subcondition
C                           of the least squares part of A, .i.e.
C                           DABS(D(IRANKC+1)/D(IRANK))
C       KRED         Int    Type of operation
C                           >=0  Householder triangularization
C                                (build up pseudo-inverse,if IRANK.LT.N)
C                           < 0  Reduction of pseudo-rank of matrix A,
C                                skipping Householder triangularization,
C                                 build-up new pseudo-inverse
C
C*    Output parameters
C     =================
C
C       A(NROW,NCOL)  Dble   Array holding the (M,N)-output consisting
C                            of the transformed matrix in the upper
C                            right triangle and the performed House-
C                            holder transf. in the lower left triangle.
C     * IRANKC        Int    New pseudo-rank of constrained part of
C                            matrix A, determined so that
C                            DABS(D(1)/D(IRANKC))<1/EPMACH
C     * IRANK         Int    New pseudo-rank of matrix A, determined
C                            so that DABS(D(IRANKC+1)/D(IRANK)) < COND
C       D(IRANK)      Dble   Diagonal elements of upper triangular matr.
C       PIVOT(N)      Int    Index vector storing permutation of columns
C                            due to pivoting
C     * COND          Dble   The sub-condition number belonging to the
C                            least squares part of A.
C                            (in case of rank reduction:
C                             sub-condition number which led to
C                             rank reduction)
C                            COND=0 indicates COND=infinity
C       AH(NCOL,NCOL) Dble   In case of rank-defect used to compute the
C                            pseudo-inverse (currently used will be an
C                            (N,N)-part of this array)
C       V(N)          Dble   V(1) holds on output the sub-condition
C                            number belonging to the constrained part
C                            of A.
C       IERR          Int    Error indicator:
C                            = 0 : DECCON computations are successfull.
C                            =-2 : Numerically negative diagonal element
C                                  encountered during computation of
C                                  pseudo inverse - due to extremely bad
C                                  conditioned Matrix A. DECCON is
C                                  unable to continue rank-reduction.
C
C*    Workspace parameters
C     ====================
C
C       V(N)         Dble   Workspace array
C
C*    Subroutines called: ZIBCONST
C
C*    Machine constants used
C     ======================
C
C     EPMACH = relative machine precision
      DOUBLE PRECISION EPMACH, SMALL
C
C     ------------------------------------------------------------
C*    End Prologue
      INTRINSIC DABS,DSQRT
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.0D0)
      DOUBLE PRECISION REDUCE
      PARAMETER (REDUCE=0.05D0)
      INTEGER L1
      DOUBLE PRECISION S1
      INTEGER I,II,IRANKH,IRK1,I1,J,JD,JJ,K,K1,LEVEL,MH, IDATA
      DOUBLE PRECISION DD,D1MACH,H,HMAX,S,SH,T
C*    Begin
C     --------------------------------------------------------------
C     1 Initialization
      CALL ZIBCONST(EPMACH,SMALL)
      IF(IRANK.GT.N) IRANK = N
      IF(IRANK.GT.M) IRANK = M
C     --------------------------------------------------------------
C     1.1 Special case M=1 and N=1
      IF(M.EQ.1.AND.N.EQ.1)THEN
        PIVOT(1)=1
        D(1)=A(1,1)
        COND = ONE
        RETURN
      ENDIF
      IF(KRED.GE.0) THEN
C       ------------------------------------------------------------
C       1.1 Initialize pivot-array
        DO 11 J=1,N
          PIVOT(J)=J
11      CONTINUE
C       ------------------------------------------------------------
C       2. Constrained Householder triangularization
        JD = 1
        IRANC1 = IRANKC + 1
        MH = MCON
        IRANKH = IRANKC
        IDATA = 0
        IF(MH.EQ.0) THEN
          IRANKH = IRANK
          MH = M
          IDATA = 1
        ENDIF
        IRK1 = IRANK
        DO 2  K=1,IRK1
2000      LEVEL = 1
          IF(K.NE.N) THEN
             K1 = K+1
C            DO (Until)
20           CONTINUE
             IF(JD.NE.0) THEN
               DO 201 J=K,N
                 S = ZERO
                 DO 2011 L1=K,MH
                    S = S+A(L1,J)**2
2011             CONTINUE
                 D(J)=S
201           CONTINUE
             ENDIF
C            ------------------------------------------------------
C            2.1 Column pivoting
             S1 = D(K)
             JJ = K
             DO 21 L1=K,N
               IF(D(L1).GT.S1) THEN
                 S1=D(L1)
                 JJ = L1
               ENDIF
21           CONTINUE
             H = D(JJ)
             IF(JD.EQ.1) HMAX = H/(DMAX1(1.0D1,COND*REDUCE))
             JD = 0
             IF(H.LT.HMAX) JD = 1
             IF(.NOT.(H.GE.HMAX)) GOTO 20
C            UNTIL ( expression - negated above)
C
             IF(JJ.NE.K) THEN
C              ------------------------------------------------------
C               2.2 Column interchange
                I = PIVOT(K)
                PIVOT(K)=PIVOT(JJ)
                PIVOT(JJ)=I
                D(JJ)=D(K)
                DO 221 L1=1,M
                   S1=A(L1,JJ)
                   A(L1,JJ)=A(L1,K)
                   A(L1,K)=S1
221             CONTINUE
             ENDIF
C          endif for k.ne.n case
           ENDIF
           H = ZERO
           DO 222 L1=K,MH
              H = H+A(L1,K)**2
222        CONTINUE
           T = DSQRT(H)
C          ----------------------------------------------------------
C          2.3.0 A-priori test on pseudo-rank
           IF  ( K.EQ.1 .OR. K.EQ.IRANC1 )  DD = T/COND
           IF(T.LE.DD .OR. K.GT.IRANKH) THEN
C            ------------------------------------------------------
C             2.3.1 Rank reduction
              IRANKH = K-1
              IF  (MH.NE.MCON .OR. IDATA.EQ.1)  THEN
                 IRANK = IRANKH
                 IF (IRANKC.EQ.IRANK) THEN
                    LEVEL = 4
                 ELSE
                    LEVEL = 3
                 ENDIF
              ELSE
                 IRANKC = IRANKH
                 IF  (IRANKC.NE.MCON) THEN
                    MH = M
                    IRANKH = IRANK
                    JD = 1
                    IDATA = 1
                    GOTO 2000
                 ELSE
                   STOP 'INTERNAL ERROR OF DECCON'
                 ENDIF
              ENDIF
           ENDIF
C
           IF (LEVEL.EQ.1) THEN
C             ------------------------------------------------------
C             2.4 Householder step
              S = A(K,K)
              T = -DSIGN(T,S)
              D(K)=T
C             By updating a(k,k) at this stage the 241 and 242 loop
C             must not be modified for l1=k.
              A(K,K)=S-T
              IF(K.NE.N) THEN
                 T = ONE/(H-S*T)
                 DO 24 J=K1,N
                    S = ZERO
                    DO 241 L1=K,MH
                          S = S+A(L1,K)*A(L1,J)
241                 CONTINUE
                    S = S*T
                    S1 = -S
                    IF(S.NE.0.D0) THEN
C                      Update the sub columns
                       DO 242 L1=K,M
                          A(L1,J) = A(L1,J)+A(L1,K)*S1
242                    CONTINUE
                    ENDIF
C                   Update sub column norms
                    D(J) = D(J)-A(K,J)**2
24               CONTINUE
                 IF(K.EQ.IRANKC) THEN
                    MH = M
                    JD = 1
                    IRANKH = IRANK
                  ENDIF
                  IF (K.EQ.IRK1) LEVEL = 3
              ELSE
                 LEVEL = 4
              ENDIF
C endif Householder step
           ENDIF
C        Exit Do 2 If ...
           IF(LEVEL.GT.1) GOTO  2999
2        CONTINUE
C        ENDDO
2999     CONTINUE
      ELSE
         K = -1
         LEVEL = 3
      ENDIF
C     --------------------------------------------------------------
C     3 Rank-deficient pseudo-inverse
      IF(LEVEL.EQ.3) THEN
         IRK1 = IRANK+1
         DO 3 J=IRK1,N
            DO 31 II=1,IRANK
               I = IRK1-II
               S = A(I,J)
               IF(II.NE.1) THEN
                  SH = ZERO
                  DO 311 L1=I1,IRANK
                     SH=SH+A(I,L1)*V(L1)
311               CONTINUE
                  S = S-SH
               ENDIF
               I1 = I
               V(I)=S/D(I)
               AH(I,J)=V(I)
31          CONTINUE
            DO 32 I=IRK1,J
              S = ZERO
              DO 321 L1=1,I-1
                 S = S+AH(L1,I)*V(L1)
321           CONTINUE
              IF(I.NE.J)THEN
                 V(I)=-S/D(I)
                 AH(I,J)=-V(I)
              ENDIF
32         CONTINUE
           IF (S.GT.-ONE) THEN
              D(J)=DSQRT(S+ONE)
           ELSE
              IERR=-2
              GOTO 999
           ENDIF
3        CONTINUE
      ENDIF
C    --------------------------------------------------------------
C     9 Exit
      IF (IRANKC.NE.0) THEN
        SH = D(IRANKC)
        IF(SH.NE.ZERO) SH = DABS(D(1)/SH)
      ELSE
        SH=ZERO
      ENDIF
      V(1) = SH
      IF (K.EQ.IRANK) T = D(IRANK)
      IF (IRANKC+1.LE.IRANK .AND. T.NE.ZERO) THEN
        S = DABS(D(IRANKC+1)/T)
      ELSE
        S = ZERO
      ENDIF
      COND = S
      IERR=0
999   CONTINUE
      RETURN
      END

      SUBROUTINE SOLCON(A,NROW,NCOL,MCON,M,N,X,B,IRANKC,IRANK,
     *                  D,PIVOT,KRED,AH,V)
C*    Begin Prologue SOLCON
      DOUBLE PRECISION A(NROW,NCOL),AH(NCOL,NCOL)
      DOUBLE PRECISION X(NCOL),B(NROW),D(NCOL),V(NCOL)
      INTEGER NROW,NCOL,MCON,M,N,IRANKC,IRANK,KRED
      INTEGER PIVOT(NCOL)
C     ------------------------------------------------------------
C
C*    Summary
C     =======
C
C     Best constrained linear least squares solution of (M,N)-
C     system . First MCON rows comprise MCON equality constraints.
C     To be used in connection with subroutine DECCON
C     References:       See DECCON
C     Related Programs: DECCON
C
C*    Parameters:
C     ===========
C
C*    Input parameters (* marks inout parameters)
C     ===========================================
C
C       A(M,N), NROW, NCOL, M, N, MCON, IRANKC, IRANK,
C       D(N), PIVOT(N), AH(N,N), KRED
C                           See input- respective output-parameters
C                           description of subroutine DECCON
C     * B(M)         Dble   Right-hand side of linear system, if
C                           KRED.GE.0
C                           Right-hand side of upper linear system,
C                           if KRED.LT.0
C
C*    Output parameters
C     =================
C
C       X(N)         Dble   Best LSQ-solution of linear system
C       B(M)         Dble   Right-hand of upper trigular system
C                           (transformed right-hand side of linear
C                            system)
C
C*    Workspace parameters
C     ====================
C
C       V(N)         Dble   Workspace array
C
C     ------------------------------------------------------------
C*    End Prologue
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      INTEGER L1,L2
      INTEGER I,II,I1,IRANC1,IRK1,J,JJ,J1,MH
      DOUBLE PRECISION S,SH
C*    Begin
C     ------------------------------------------------------------
C     1 Solution for pseudo-rank zero
      IF(IRANK.EQ.0)THEN
        DO 11 L1=1,N
          X(L1)=ZERO
11      CONTINUE
        RETURN
      ENDIF
      IF  ((IRANK.LE.IRANKC).AND.(IRANK.NE.N)) THEN
        IRANC1 = IRANKC + 1
        DO 12 L1=IRANC1,N
          V(L1) = ZERO
12      CONTINUE
      ENDIF
      IF(KRED.GE.0.AND.(M.NE.1.OR.N.NE.1))THEN
C       ----------------------------------------------------------
C       2 Constrained householder transformations of right-hand side
        MH = MCON
        IF(IRANKC.EQ.0) MH = M
        DO 21 J=1,IRANK
          S = ZERO
          DO 211 L1=J,MH
            S = S+A(L1,J)*B(L1)
211       CONTINUE
          S = S/(D(J)*A(J,J))
          DO 212 L1=J,M
            B(L1)=B(L1)+A(L1,J)*S
212       CONTINUE
          IF(J.EQ.IRANKC) MH = M
21      CONTINUE
      ENDIF
C     ------------------------------------------------------------
C     3 Solution of upper triangular system
      IRK1 = IRANK+1
      DO 31 II=1,IRANK
        I = IRK1-II
        I1 = I+1
        S = B(I)
        IF(II.NE.1)THEN
          SH = ZERO
          DO 311 L1=I1,IRANK
            SH=SH+A(I,L1)*V(L1)
311       CONTINUE
          S = S-SH
        ENDIF
        V(I)=S/D(I)
31    CONTINUE
      IF((IRANK.NE.N).AND.(IRANK.NE.IRANKC)) THEN
C       ----------------------------------------------------------
C       3.2 Computation of the best constrained least squares-
C           solution
        DO 321 J=IRK1,N
          S = ZERO
          DO 3211 L1=1,J-1
            S = S+AH(L1,J)*V(L1)
3211      CONTINUE
          V(J)=-S/D(J)
321     CONTINUE
        DO 322 JJ=1,N
          J = N-JJ+1
          S = ZERO
          IF(JJ.NE.1) THEN
            DO 3221 L1=J1,N
              S=S+AH(J,L1)*V(L1)
3221        CONTINUE
          ENDIF
          IF(JJ.NE.1.AND.J.LE.IRANK) THEN
            V(J)=V(J)-S
          ELSE
            J1 = J
            V(J)=-(S+V(J))/D(J)
          ENDIF
322     CONTINUE
      ENDIF
C     ------------------------------------------------------------
C     4 Back-permutation of solution components
      DO 4 L1=1,N
        L2 = PIVOT(L1)
        X(L2) = V(L1)
4     CONTINUE
      RETURN
      END
C*    End package


        PROGRAM MAIN
        USE OMP_LIB
        IMPLICIT NONE

        INTEGER :: i, j, id, numthreads, nthreads
        INTEGER, PARAMETER :: num_steps=100000000
        INTEGER, PARAMETER :: MAX_THREADS=4
        INTEGER, PARAMETER :: CBLK=8
        REAL*8 :: pi, step, x
        REAL*8 :: start_time, run_time
        REAL*8 :: sum(0:MAX_THREADS-1,CBLK)

        step = 1.0 / num_steps

        CALL OMP_SET_NUM_THREADS(MAX_THREADS)
        start_time = omp_get_wtime()

!$OMP PARALLEL PRIVATE(id,x,numthreads)
        id = omp_get_thread_num()
        numthreads = OMP_GET_NUM_THREADS()
        sum(id,1) = 0.0

        IF (id == 0)  THEN
            nthreads = numthreads
        ENDIF

        DO i = id, num_steps-1, numthreads
           x = (i + 0.5) * step
           sum(id,1) = sum(id,1) + 4.0 / (1.0 + x * x)
        ENDDO
!$OMP END PARALLEL

        pi = 0.0
        DO i = 0, nthreads - 1
           pi = pi + sum(i,1)
        ENDDO

        pi = step * pi
        run_time = OMP_GET_WTIME() - start_time
        WRITE(*,100) pi, run_time, nthreads
100     FORMAT('pi is ',f15.8,' in ',f8.3,' secs and ',i3,' threads')

        END PROGRAM MAIN


*DCHEX
      SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB)
C***BEGIN PROLOGUE  DCHEX
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D7B
C***KEYWORDS  CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE,
C             LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  UPDATES THE CHOLESKY FACTORIZATION  A=TRANS(R)*R  OF A
C            POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL
C            PERMUTATIONS OF THE FORM  TRANS(E)*A*E  WHERE E IS A
C            PERMUTATION MATRIX.
C***DESCRIPTION
C     DCHEX UPDATES THE CHOLESKY FACTORIZATION
C                   A = TRANS(R)*R
C     OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL
C     PERMUTATIONS OF THE FORM
C                   TRANS(E)*A*E
C     WHERE E IS A PERMUTATION MATRIX.  SPECIFICALLY, GIVEN
C     AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX
C     E (WHICH IS SPECIFIED BY K, L, AND JOB), DCHEX DETERMINES
C     AN ORTHOGONAL MATRIX U SUCH THAT
C                           U*R*E = RR,
C     WHERE RR IS UPPER TRIANGULAR.  AT THE USERS OPTION, THE
C     TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z.
C     IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE
C     QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE
C     QR FACTORIZATION OF X*E, I.E. X WITH ITS COLUMNS PERMUTED.
C     FOR A LESS TERSE DESCRIPTION OF WHAT DCHEX DOES AND HOW
C     IT MAY BE APPLIED, SEE THE LINPACK GUIDE.
C     THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1)
C     OF PLANE ROTATIONS OF THE FORM
C                           (    C(I)       S(I) )
C                           (                    ) ,
C                           (    -S(I)      C(I) )
C     WHERE C(I) IS DOUBLE PRECISION.  THE ROWS THESE ROTATIONS OPERATE
C     ON ARE DESCRIBED BELOW.
C     THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED
C     BY THE VALUE OF JOB.
C     1. RIGHT CIRCULAR SHIFT (JOB = 1).
C         THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER.
C                1,...,K-1,L,K,K+1,...,L-1,L+1,...,P.
C         U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I)
C         ACTS IN THE (L-I,L-I+1)-PLANE.
C     2. LEFT CIRCULAR SHIFT (JOB = 2).
C         THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER
C                1,...,K-1,K+1,K+2,...,L,K,L+1,...,P.
C         U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I)
C         ACTS IN THE (K+I-1,K+I)-PLANE.
C     ON ENTRY
C         R      DOUBLE PRECISION(LDR,P), WHERE LDR .GE. P.
C                R CONTAINS THE UPPER TRIANGULAR FACTOR
C                THAT IS TO BE UPDATED.  ELEMENTS OF R
C                BELOW THE DIAGONAL ARE NOT REFERENCED.
C         LDR    INTEGER.
C                LDR IS THE LEADING DIMENSION OF THE ARRAY R.
C         P      INTEGER.
C                P IS THE ORDER OF THE MATRIX R.
C         K      INTEGER.
C                K IS THE FIRST COLUMN TO BE PERMUTED.
C         L      INTEGER.
C                L IS THE LAST COLUMN TO BE PERMUTED.
C                L MUST BE STRICTLY GREATER THAN K.
C         Z      DOUBLE PRECISION(LDZ,N)Z), WHERE LDZ .GE. P.
C                Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE
C                TRANSFORMATION U IS MULTIPLIED.  Z IS
C                NOT REFERENCED IF NZ = 0.
C         LDZ    INTEGER.
C                LDZ IS THE LEADING DIMENSION OF THE ARRAY Z.
C         NZ     INTEGER.
C                NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z.
C         JOB    INTEGER.
C                JOB DETERMINES THE TYPE OF PERMUTATION.
C                       JOB = 1  RIGHT CIRCULAR SHIFT.
C                       JOB = 2  LEFT CIRCULAR SHIFT.
C     ON RETURN
C         R      CONTAINS THE UPDATED FACTOR.
C         Z      CONTAINS THE UPDATED MATRIX Z.
C         C      DOUBLE PRECISION(P).
C                C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS.
C         S      DOUBLE PRECISION(P).
C                S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS.
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DROTG
C***END PROLOGUE  DCHEX

C...SCALAR ARGUMENTS
      INTEGER
     +   JOB,K,L,LDR,LDZ,NZ,P

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   C(*),R(LDR,*),S(*),Z(LDZ,*)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   T,T1
      INTEGER
     +   I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DROTG

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MAX0,MIN0

C***FIRST EXECUTABLE STATEMENT  DCHEX

      KM1 = K - 1
      KP1 = K + 1
      LMK = L - K
      LM1 = L - 1

C     PERFORM THE APPROPRIATE TASK.

      GO TO (10,130), JOB

C     RIGHT CIRCULAR SHIFT.

   10 CONTINUE

C        REORDER THE COLUMNS.

         DO 20 I = 1, L
            II = L - I + 1
            S(I) = R(II,L)
   20    CONTINUE
         DO 40 JJ = K, LM1
            J = LM1 - JJ + K
            DO 30 I = 1, J
               R(I,J+1) = R(I,J)
   30       CONTINUE
            R(J+1,J+1) = 0.0D0
   40    CONTINUE
         IF (K .EQ. 1) GO TO 60
            DO 50 I = 1, KM1
               II = L - I + 1
               R(I,K) = S(II)
   50       CONTINUE
   60    CONTINUE

C        CALCULATE THE ROTATIONS.

         T = S(1)
         DO 70 I = 1, LMK
            T1 = S(I)
            CALL DROTG(S(I+1),T,C(I),T1)
            S(I) = T1
            T = S(I+1)
   70    CONTINUE
         R(K,K) = T
         DO 90 J = KP1, P
            IL = MAX0(1,L-J+1)
            DO 80 II = IL, LMK
               I = L - II
               T = C(II)*R(I,J) + S(II)*R(I+1,J)
               R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J)
               R(I,J) = T
   80       CONTINUE
   90    CONTINUE

C        IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z.

         IF (NZ .LT. 1) GO TO 120
         DO 110 J = 1, NZ
            DO 100 II = 1, LMK
               I = L - II
               T = C(II)*Z(I,J) + S(II)*Z(I+1,J)
               Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J)
               Z(I,J) = T
  100       CONTINUE
  110    CONTINUE
  120    CONTINUE
      GO TO 260

C     LEFT CIRCULAR SHIFT

  130 CONTINUE

C        REORDER THE COLUMNS

         DO 140 I = 1, K
            II = LMK + I
            S(II) = R(I,K)
  140    CONTINUE
         DO 160 J = K, LM1
            DO 150 I = 1, J
               R(I,J) = R(I,J+1)
  150       CONTINUE
            JJ = J - KM1
            S(JJ) = R(J+1,J+1)
  160    CONTINUE
         DO 170 I = 1, K
            II = LMK + I
            R(I,L) = S(II)
  170    CONTINUE
         DO 180 I = KP1, L
            R(I,L) = 0.0D0
  180    CONTINUE

C        REDUCTION LOOP.

         DO 220 J = K, P
            IF (J .EQ. K) GO TO 200

C              APPLY THE ROTATIONS.

               IU = MIN0(J-1,L-1)
               DO 190 I = K, IU
                  II = I - K + 1
                  T = C(II)*R(I,J) + S(II)*R(I+1,J)
                  R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J)
                  R(I,J) = T
  190          CONTINUE
  200       CONTINUE
            IF (J .GE. L) GO TO 210
               JJ = J - K + 1
               T = S(JJ)
               CALL DROTG(R(J,J),T,C(JJ),S(JJ))
  210       CONTINUE
  220    CONTINUE

C        APPLY THE ROTATIONS TO Z.

         IF (NZ .LT. 1) GO TO 250
         DO 240 J = 1, NZ
            DO 230 I = K, LM1
               II = I - KM1
               T = C(II)*Z(I,J) + S(II)*Z(I+1,J)
               Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J)
               Z(I,J) = T
  230       CONTINUE
  240    CONTINUE
  250    CONTINUE
  260 CONTINUE
      RETURN
      END
*DPODI
      SUBROUTINE DPODI(A,LDA,N,DET,JOB)
C***BEGIN PROLOGUE  DPODI
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2B1B,D3B1B
C***KEYWORDS  DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE,
C             LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE
C            PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT)
C            USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC.
C***DESCRIPTION
C     DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN
C     DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW)
C     USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC.
C     ON ENTRY
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT  A  FROM DPOCO OR DPOFA
C                OR THE OUTPUT  X  FROM DQRDC.
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C        JOB     INTEGER
C                = 11   BOTH DETERMINANT AND INVERSE.
C                = 01   INVERSE ONLY.
C                = 10   DETERMINANT ONLY.
C     ON RETURN
C        A       IF DPOCO OR DPOFA WAS USED TO FACTOR  A , THEN
C                DPODI PRODUCES THE UPPER HALF OF INVERSE(A) .
C                IF DQRDC WAS USED TO DECOMPOSE  X , THEN
C                DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X)
C                WHERE TRANS(X) IS THE TRANSPOSE.
C                ELEMENTS OF  A  BELOW THE DIAGONAL ARE UNCHANGED.
C                IF THE UNITS DIGIT OF JOB IS ZERO,  A  IS UNCHANGED.
C        DET     DOUBLE PRECISION(2)
C                DETERMINANT OF  A  OR OF  TRANS(X)*X  IF REQUESTED.
C                OTHERWISE NOT REFERENCED.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                WITH  1.0 .LE. DET(1) .LT. 10.0
C                OR  DET(1) .EQ. 0.0 .
C     ERROR CONDITION
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS
C        A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED.
C        IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY
C        AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 .
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DAXPY,DSCAL
C***END PROLOGUE  DPODI

C...SCALAR ARGUMENTS
      INTEGER JOB,LDA,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION A(LDA,*),DET(*)

C...LOCAL SCALARS
      DOUBLE PRECISION S,T
      INTEGER I,J,JM1,K,KP1

C...EXTERNAL SUBROUTINES
      EXTERNAL DAXPY,DSCAL

C...INTRINSIC FUNCTIONS
      INTRINSIC MOD

C***FIRST EXECUTABLE STATEMENT  DPODI

      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         S = 10.0D0
         DO 50 I = 1, N
            DET(1) = A(I,I)**2*DET(1)
C        ...EXIT
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DET(1) .GE. 1.0D0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE

C     COMPUTE INVERSE(R)

      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         DO 100 K = 1, N
            A(K,K) = 1.0D0/A(K,K)
            T = -A(K,K)
            CALL DSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0D0
               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE

C        FORM  INVERSE(R) * TRANS(INVERSE(R))

         DO 130 J = 1, N
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = A(K,J)
               CALL DAXPY(K,T,A(1,J),1,A(1,K),1)
  110       CONTINUE
  120       CONTINUE
            T = A(J,J)
            CALL DSCAL(J,T,A(1,J),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END
*DQRDC
      SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB)
C***BEGIN PROLOGUE  DQRDC
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D5
C***KEYWORDS  DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,
C             MATRIX,ORTHOGONAL TRIANGULAR
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR FACTORI-
C            ZATION OF N BY P MATRIX X.  COLUMN PIVOTING IS OPTIONAL.
C***DESCRIPTION
C     DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR
C     FACTORIZATION OF AN N BY P MATRIX X.  COLUMN PIVOTING
C     BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE
C     PERFORMED AT THE USER'S OPTION.
C     ON ENTRY
C        X       DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N.
C                X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE
C                COMPUTED.
C        LDX     INTEGER.
C                LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C        N       INTEGER.
C                N IS THE NUMBER OF ROWS OF THE MATRIX X.
C        P       INTEGER.
C                P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C        JPVT    INTEGER(P).
C                JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION
C                OF THE PIVOT COLUMNS.  THE K-TH COLUMN X(K) OF X
C                IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE
C                VALUE OF JPVT(K).
C                   IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL
C                                      COLUMN.
C                   IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN.
C                   IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN.
C                BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS
C                ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL
C                COLUMNS TO THE END.  BOTH INITIAL AND FINAL COLUMNS
C                ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY
C                FREE COLUMNS ARE MOVED.  AT THE K-TH STAGE OF THE
C                REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN
C                IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST
C                REDUCED NORM.  JPVT IS NOT REFERENCED IF
C                JOB .EQ. 0.
C        WORK    DOUBLE PRECISION(P).
C                WORK IS A WORK ARRAY.  WORK IS NOT REFERENCED IF
C                JOB .EQ. 0.
C        JOB     INTEGER.
C                JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING.
C                IF JOB .EQ. 0, NO PIVOTING IS DONE.
C                IF JOB .NE. 0, PIVOTING IS DONE.
C     ON RETURN
C        X       X CONTAINS IN ITS UPPER TRIANGLE THE UPPER
C                TRIANGULAR MATRIX R OF THE QR FACTORIZATION.
C                BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM
C                WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION
C                CAN BE RECOVERED.  NOTE THAT IF PIVOTING HAS
C                BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT
C                OF THE ORIGINAL MATRIX X BUT THAT OF X
C                WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT.
C        QRAUX   DOUBLE PRECISION(P).
C                QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER
C                THE ORTHOGONAL PART OF THE DECOMPOSITION.
C        JPVT    JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE
C                ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO
C                THE K-TH COLUMN, IF PIVOTING WAS REQUESTED.
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DAXPY,DDOT,DNRM2,DSCAL,DSWAP
C***END PROLOGUE  DQRDC

C...SCALAR ARGUMENTS
      INTEGER
     +   JOB,LDX,N,P

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   QRAUX(*),WORK(*),X(LDX,*)
      INTEGER
     +   JPVT(*)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   MAXNRM,NRMXL,T,TT
      INTEGER
     +   J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU
      LOGICAL
     +   NEGJ,SWAPJ

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT,DNRM2
      EXTERNAL
     +   DDOT,DNRM2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DAXPY,DSCAL,DSWAP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   DABS,DMAX1,DSIGN,DSQRT,MIN0

C***FIRST EXECUTABLE STATEMENT  DQRDC

      PL = 1
      PU = 0
      IF (JOB .EQ. 0) GO TO 60

C        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
C        ACCORDING TO JPVT.

         DO 20 J = 1, P
            SWAPJ = JPVT(J) .GT. 0
            NEGJ = JPVT(J) .LT. 0
            JPVT(J) = J
            IF (NEGJ) JPVT(J) = -J
            IF (.NOT.SWAPJ) GO TO 10
               IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1)
               JPVT(J) = JPVT(PL)
               JPVT(PL) = J
               PL = PL + 1
   10       CONTINUE
   20    CONTINUE
         PU = P
         DO 50 JJ = 1, P
            J = P - JJ + 1
            IF (JPVT(J) .GE. 0) GO TO 40
               JPVT(J) = -JPVT(J)
               IF (J .EQ. PU) GO TO 30
                  CALL DSWAP(N,X(1,PU),1,X(1,J),1)
                  JP = JPVT(PU)
                  JPVT(PU) = JPVT(J)
                  JPVT(J) = JP
   30          CONTINUE
               PU = PU - 1
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE

C     COMPUTE THE NORMS OF THE FREE COLUMNS.

      IF (PU .LT. PL) GO TO 80
      DO 70 J = PL, PU
         QRAUX(J) = DNRM2(N,X(1,J),1)
         WORK(J) = QRAUX(J)
   70 CONTINUE
   80 CONTINUE

C     PERFORM THE HOUSEHOLDER REDUCTION OF X.

      LUP = MIN0(N,P)
      DO 200 L = 1, LUP
         IF (L .LT. PL .OR. L .GE. PU) GO TO 120

C           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C           INTO THE PIVOT POSITION.

            MAXNRM = 0.0D0
            MAXJ = L
            DO 100 J = L, PU
               IF (QRAUX(J) .LE. MAXNRM) GO TO 90
                  MAXNRM = QRAUX(J)
                  MAXJ = J
   90          CONTINUE
  100       CONTINUE
            IF (MAXJ .EQ. L) GO TO 110
               CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1)
               QRAUX(MAXJ) = QRAUX(L)
               WORK(MAXJ) = WORK(L)
               JP = JPVT(MAXJ)
               JPVT(MAXJ) = JPVT(L)
               JPVT(L) = JP
  110       CONTINUE
  120    CONTINUE
         QRAUX(L) = 0.0D0
         IF (L .EQ. N) GO TO 190

C           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.

            NRMXL = DNRM2(N-L+1,X(L,L),1)
            IF (NRMXL .EQ. 0.0D0) GO TO 180
               IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L))
               CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1)
               X(L,L) = 1.0D0 + X(L,L)

C              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C              UPDATING THE NORMS.

               LP1 = L + 1
               IF (P .LT. LP1) GO TO 170
               DO 160 J = LP1, P
                  T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
                  CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
                  IF (J .LT. PL .OR. J .GT. PU) GO TO 150
                  IF (QRAUX(J) .EQ. 0.0D0) GO TO 150
                     TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2
                     TT = DMAX1(TT,0.0D0)
                     T = TT
                     TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2
                     IF (TT .EQ. 1.0D0) GO TO 130
                        QRAUX(J) = QRAUX(J)*DSQRT(T)
                     GO TO 140
  130                CONTINUE
                        QRAUX(J) = DNRM2(N-L,X(L+1,J),1)
                        WORK(J) = QRAUX(J)
  140                CONTINUE
  150             CONTINUE
  160          CONTINUE
  170          CONTINUE

C              SAVE THE TRANSFORMATION.

               QRAUX(L) = X(L,L)
               X(L,L) = -NRMXL
  180       CONTINUE
  190    CONTINUE
  200 CONTINUE
      RETURN
      END
*DQRSL
      SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO)
C***BEGIN PROLOGUE  DQRSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D9,D2A1
C***KEYWORDS  DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,
C             ORTHOGONAL TRIANGULAR,SOLVE
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE
C            TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS.
C***DESCRIPTION
C     DQRSL APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE
C     TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS.
C     FOR K .LE. MIN(N,P), LET XK BE THE MATRIX
C            XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K)))
C     FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL
C     N X P MATRIX X THAT WAS INPUT TO DQRDC (IF NO PIVOTING WAS
C     DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR
C     ORIGINAL ORDER).  DQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q
C     AND AN UPPER TRIANGULAR MATRIX R SUCH THAT
C              XK = Q * (R)
C                       (0)
C     THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS
C     X AND QRAUX.
C     ON ENTRY
C        X      DOUBLE PRECISION(LDX,P).
C               X CONTAINS THE OUTPUT OF DQRDC.
C        LDX    INTEGER.
C               LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C        N      INTEGER.
C               N IS THE NUMBER OF ROWS OF THE MATRIX XK.  IT MUST
C               HAVE THE SAME VALUE AS N IN DQRDC.
C        K      INTEGER.
C               K IS THE NUMBER OF COLUMNS OF THE MATRIX XK.  K
C               MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE
C               SAME AS IN THE CALLING SEQUENCE TO DQRDC.
C        QRAUX  DOUBLE PRECISION(P).
C               QRAUX CONTAINS THE AUXILIARY OUTPUT FROM DQRDC.
C        Y      DOUBLE PRECISION(N)
C               Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED
C               BY DQRSL.
C        JOB    INTEGER.
C               JOB SPECIFIES WHAT IS TO BE COMPUTED.  JOB HAS
C               THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING
C               MEANING.
C                    IF A .NE. 0, COMPUTE QY.
C                    IF B,C,D, OR E .NE. 0, COMPUTE QTY.
C                    IF C .NE. 0, COMPUTE B.
C                    IF D .NE. 0, COMPUTE RSD.
C                    IF E .NE. 0, COMPUTE XB.
C               NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB
C               AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR
C               WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING
C               SEQUENCE.
C     ON RETURN
C        QY     DOUBLE PRECISION(N).
C               QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN
C               REQUESTED.
C        QTY    DOUBLE PRECISION(N).
C               QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS
C               BEEN REQUESTED.  HERE TRANS(Q) IS THE
C               TRANSPOSE OF THE MATRIX Q.
C        B      DOUBLE PRECISION(K)
C               B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM
C                    MINIMIZE NORM2(Y - XK*B),
C               IF ITS COMPUTATION HAS BEEN REQUESTED.  (NOTE THAT
C               IF PIVOTING WAS REQUESTED IN DQRDC, THE J-TH
C               COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J)
C               OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO DQRDC.)
C        RSD    DOUBLE PRECISION(N).
C               RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B,
C               IF ITS COMPUTATION HAS BEEN REQUESTED.  RSD IS
C               ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE
C               ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK.
C        XB     DOUBLE PRECISION(N).
C               XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B,
C               IF ITS COMPUTATION HAS BEEN REQUESTED.  XB IS ALSO
C               THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE
C               OF X.
C        INFO   INTEGER.
C               INFO IS ZERO UNLESS THE COMPUTATION OF B HAS
C               BEEN REQUESTED AND R IS EXACTLY SINGULAR.  IN
C               THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO
C               DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED.
C     THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED
C     IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE
C     CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM.
C     TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME
C     ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE.  A
C     FREQUENTLY OCCURRING EXAMPLE IS WHEN ONE WISHES TO COMPUTE
C     ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY.  IN THIS
C     CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE
C     PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE
C     COMPUTED.  THUS THE CALLING SEQUENCE
C          CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
C     WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD
C     OVERWRITING Y.  MORE GENERALLY, EACH ITEM IN THE FOLLOWING
C     LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR
C     A SINGLE CALLING SEQUENCE.
C          1. (Y,QTY,B) (RSD) (XB) (QY)
C          2. (Y,QTY,RSD) (B) (XB) (QY)
C          3. (Y,QTY,XB) (B) (RSD) (QY)
C          4. (Y,QY) (QTY,B) (RSD) (XB)
C          5. (Y,QY) (QTY,RSD) (B) (XB)
C          6. (Y,QY) (QTY,XB) (B) (RSD)
C     IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO
C     THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP.
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DAXPY,DCOPY,DDOT
C***END PROLOGUE  DQRSL

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,JOB,K,LDX,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*),
     +   Y(*)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   T,TEMP
      INTEGER
     +   I,J,JJ,JU,KP1
      LOGICAL
     +   CB,CQTY,CQY,CR,CXB

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT
      EXTERNAL
     +   DDOT

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DAXPY,DCOPY

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MIN0,MOD

C***FIRST EXECUTABLE STATEMENT  DQRSL

      INFO = 0

C     DETERMINE WHAT IS TO BE COMPUTED.

      CQY = JOB/10000 .NE. 0
      CQTY = MOD(JOB,10000) .NE. 0
      CB = MOD(JOB,1000)/100 .NE. 0
      CR = MOD(JOB,100)/10 .NE. 0
      CXB = MOD(JOB,10) .NE. 0
      JU = MIN0(K,N-1)

C     SPECIAL ACTION WHEN N=1.

      IF (JU .NE. 0) GO TO 40
         IF (CQY) QY(1) = Y(1)
         IF (CQTY) QTY(1) = Y(1)
         IF (CXB) XB(1) = Y(1)
         IF (.NOT.CB) GO TO 30
            IF (X(1,1) .NE. 0.0D0) GO TO 10
               INFO = 1
            GO TO 20
   10       CONTINUE
               B(1) = Y(1)/X(1,1)
   20       CONTINUE
   30    CONTINUE
         IF (CR) RSD(1) = 0.0D0
      GO TO 250
   40 CONTINUE

C        SET UP TO COMPUTE QY OR QTY.

         IF (CQY) CALL DCOPY(N,Y,1,QY,1)
         IF (CQTY) CALL DCOPY(N,Y,1,QTY,1)
         IF (.NOT.CQY) GO TO 70

C           COMPUTE QY.

            DO 60 JJ = 1, JU
               J = JU - JJ + 1
               IF (QRAUX(J) .EQ. 0.0D0) GO TO 50
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J)
                  CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1)
                  X(J,J) = TEMP
   50          CONTINUE
   60       CONTINUE
   70    CONTINUE
         IF (.NOT.CQTY) GO TO 100

C           COMPUTE TRANS(Q)*Y.

            DO 90 J = 1, JU
               IF (QRAUX(J) .EQ. 0.0D0) GO TO 80
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J)
                  CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1)
                  X(J,J) = TEMP
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE

C        SET UP TO COMPUTE B, RSD, OR XB.

         IF (CB) CALL DCOPY(K,QTY,1,B,1)
         KP1 = K + 1
         IF (CXB) CALL DCOPY(K,QTY,1,XB,1)
         IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1)
         IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120
            DO 110 I = KP1, N
               XB(I) = 0.0D0
  110       CONTINUE
  120    CONTINUE
         IF (.NOT.CR) GO TO 140
            DO 130 I = 1, K
               RSD(I) = 0.0D0
  130       CONTINUE
  140    CONTINUE
         IF (.NOT.CB) GO TO 190

C           COMPUTE B.

            DO 170 JJ = 1, K
               J = K - JJ + 1
               IF (X(J,J) .NE. 0.0D0) GO TO 150
                  INFO = J
C           ......EXIT
                  GO TO 180
  150          CONTINUE
               B(J) = B(J)/X(J,J)
               IF (J .EQ. 1) GO TO 160
                  T = -B(J)
                  CALL DAXPY(J-1,T,X(1,J),1,B,1)
  160          CONTINUE
  170       CONTINUE
  180       CONTINUE
  190    CONTINUE
         IF (.NOT.CR .AND. .NOT.CXB) GO TO 240

C           COMPUTE RSD OR XB AS REQUIRED.

            DO 230 JJ = 1, JU
               J = JU - JJ + 1
               IF (QRAUX(J) .EQ. 0.0D0) GO TO 220
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  IF (.NOT.CR) GO TO 200
                     T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J)
                     CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1)
  200             CONTINUE
                  IF (.NOT.CXB) GO TO 210
                     T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J)
                     CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1)
  210             CONTINUE
                  X(J,J) = TEMP
  220          CONTINUE
  230       CONTINUE
  240    CONTINUE
  250 CONTINUE
      RETURN
      END
*DTRCO
      SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB)
C***BEGIN PROLOGUE  DTRCO
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A3
C***KEYWORDS  CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,
C             MATRIX,TRIANGULAR
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR
C            MATRIX.
C***DESCRIPTION
C     DTRCO ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR
C     MATRIX.
C     ON ENTRY
C        T       DOUBLE PRECISION(LDT,N)
C                T CONTAINS THE TRIANGULAR MATRIX.  THE ZERO
C                ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND
C                THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE
C                USED TO STORE OTHER INFORMATION.
C        LDT     INTEGER
C                LDT IS THE LEADING DIMENSION OF THE ARRAY T.
C        N       INTEGER
C                N IS THE ORDER OF THE SYSTEM.
C        JOB     INTEGER
C                = 0         T  IS LOWER TRIANGULAR.
C                = NONZERO   T  IS UPPER TRIANGULAR.
C     ON RETURN
C        RCOND   DOUBLE PRECISION
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  T .
C                FOR THE SYSTEM  T*X = B , RELATIVE PERTURBATIONS
C                IN  T  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  T  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C        Z       DOUBLE PRECISION(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  T  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DASUM,DAXPY,DSCAL
C***END PROLOGUE  DTRCO

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   RCOND
      INTEGER
     +   JOB,LDT,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   T(LDT,*),Z(*)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   EK,S,SM,TNORM,W,WK,WKM,YNORM
      INTEGER
     +   I1,J,J1,J2,K,KK,L
      LOGICAL
     +   LOWER

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DASUM
      EXTERNAL
     +   DASUM

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DAXPY,DSCAL

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   DABS,DMAX1,DSIGN

C***FIRST EXECUTABLE STATEMENT  DTRCO

      LOWER = JOB .EQ. 0

C     COMPUTE 1-NORM OF T

      TNORM = 0.0D0
      DO 10 J = 1, N
         L = J
         IF (LOWER) L = N + 1 - J
         I1 = 1
         IF (LOWER) I1 = J
         TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1))
   10 CONTINUE

C     RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  T*Z = Y  AND  TRANS(T)*Y = E .
C     TRANS(T)  IS THE TRANSPOSE OF T .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF Y .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.

C     SOLVE TRANS(T)*Y = E

      EK = 1.0D0
      DO 20 J = 1, N
         Z(J) = 0.0D0
   20 CONTINUE
      DO 100 KK = 1, N
         K = KK
         IF (LOWER) K = N + 1 - KK
         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))
         IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30
            S = DABS(T(K,K))/DABS(EK-Z(K))
            CALL DSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = DABS(WK)
         SM = DABS(WKM)
         IF (T(K,K) .EQ. 0.0D0) GO TO 40
            WK = WK/T(K,K)
            WKM = WKM/T(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0D0
            WKM = 1.0D0
   50    CONTINUE
         IF (KK .EQ. N) GO TO 90
            J1 = K + 1
            IF (LOWER) J1 = 1
            J2 = N
            IF (LOWER) J2 = K - 1
            DO 60 J = J1, J2
               SM = SM + DABS(Z(J)+WKM*T(K,J))
               Z(J) = Z(J) + WK*T(K,J)
               S = S + DABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               W = WKM - WK
               WK = WKM
               DO 70 J = J1, J2
                  Z(J) = Z(J) + W*T(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)

      YNORM = 1.0D0

C     SOLVE T*Z = Y

      DO 130 KK = 1, N
         K = N + 1 - KK
         IF (LOWER) K = KK
         IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110
            S = DABS(T(K,K))/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  110    CONTINUE
         IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K)
         IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0
         I1 = 1
         IF (LOWER) I1 = K + 1
         IF (KK .GE. N) GO TO 120
            W = -Z(K)
            CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1)
  120    CONTINUE
  130 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM

      IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM
      IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END
*DTRSL
      SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO)
C***BEGIN PROLOGUE  DTRSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D2A3
C***KEYWORDS  DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE,
C             TRIANGULAR
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  SOLVES SYSTEMS OF THE FORM  T*X=B OR  TRANS(T)*X=B  WHERE T
C            IS A TRIANGULAR MATRIX OF ORDER N.
C***DESCRIPTION
C     DTRSL SOLVES SYSTEMS OF THE FORM
C                   T * X = B
C     OR
C                   TRANS(T) * X = B
C     WHERE T IS A TRIANGULAR MATRIX OF ORDER N.  HERE TRANS(T)
C     DENOTES THE TRANSPOSE OF THE MATRIX T.
C     ON ENTRY
C         T         DOUBLE PRECISION(LDT,N)
C                   T CONTAINS THE MATRIX OF THE SYSTEM.  THE ZERO
C                   ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND
C                   THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE
C                   USED TO STORE OTHER INFORMATION.
C         LDT       INTEGER
C                   LDT IS THE LEADING DIMENSION OF THE ARRAY T.
C         N         INTEGER
C                   N IS THE ORDER OF THE SYSTEM.
C         B         DOUBLE PRECISION(N).
C                   B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM.
C         JOB       INTEGER
C                   JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED.
C                   IF JOB IS
C                        00   SOLVE T*X=B, T LOWER TRIANGULAR,
C                        01   SOLVE T*X=B, T UPPER TRIANGULAR,
C                        10   SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR,
C                        11   SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR.
C     ON RETURN
C         B         B CONTAINS THE SOLUTION, IF INFO .EQ. 0.
C                   OTHERWISE B IS UNALTERED.
C         INFO      INTEGER
C                   INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR.
C                   OTHERWISE INFO CONTAINS THE INDEX OF
C                   THE FIRST ZERO DIAGONAL ELEMENT OF T.
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DAXPY,DDOT
C***END PROLOGUE  DTRSL

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,JOB,LDT,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   B(*),T(LDT,*)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP
      INTEGER
     +   CASE,J,JJ

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT
      EXTERNAL
     +   DDOT

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DAXPY

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MOD

C***FIRST EXECUTABLE STATEMENT  DTRSL

C     BEGIN BLOCK PERMITTING ...EXITS TO 150

C        CHECK FOR ZERO DIAGONAL ELEMENTS.

         DO 10 INFO = 1, N
C     ......EXIT
            IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150
   10    CONTINUE
         INFO = 0

C        DETERMINE THE TASK AND GO TO IT.

         CASE = 1
         IF (MOD(JOB,10) .NE. 0) CASE = 2
         IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2
         GO TO (20,50,80,110), CASE

C        SOLVE T*X=B FOR T LOWER TRIANGULAR

   20    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 40
            DO 30 J = 2, N
               TEMP = -B(J-1)
               CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1)
               B(J) = B(J)/T(J,J)
   30       CONTINUE
   40       CONTINUE
         GO TO 140

C        SOLVE T*X=B FOR T UPPER TRIANGULAR.

   50    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 70
            DO 60 JJ = 2, N
               J = N - JJ + 1
               TEMP = -B(J+1)
               CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1)
               B(J) = B(J)/T(J,J)
   60       CONTINUE
   70       CONTINUE
         GO TO 140

C        SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.

   80    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 100
            DO 90 JJ = 2, N
               J = N - JJ + 1
               B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1)
               B(J) = B(J)/T(J,J)
   90       CONTINUE
  100       CONTINUE
         GO TO 140

C        SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.

  110    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 130
            DO 120 J = 2, N
               B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1)
               B(J) = B(J)/T(J,J)
  120       CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END


c=======================================================================
c
c     subroutine PRmonteCarlo
c
c     Monte Carlo Simulator for the geometric Brownian motion model
c     with 1) antithetic variables and 2) control variate
c
c     Prices Vanilla and fixed strike Asian options
c
c-----------------------------------------------------------------------
      RECURSIVE DOUBLE PRECISION FUNCTION wy_mc(spot, strike, vol, rd,
     & rf, tau, phi, convention, quotation, payofftype,
     & Nsim, Nsteps, greek) RESULT(f)
c-----------------------------------------------------------------------
c
c INPUT
c   spot   : spot price (>0)                                      double
c   strike : stike price (>0)                                     double
c   vol    : annual volatility (>=0)                              double
c   rd     : domestic risk free rate (>=0)                        double
c            discounting is done as (1+r)^{-T}\n
c   rf     : foreign risk free rate or dividend rate (>=0)        double
c            discounting is done as (1+rf)^{-T}\n
c   tau    : time to maturity (in year)                           double
c   phi    : (1) Call, (-1) Put                                  integer
c   ea     : tree order (=1 or =2)                               integer
c   convention : compounded convention                           integer
c                (0) linear for less than one year,
c                (1) annually compounded,
c                (2) continuously compounded
c   quotation  : system of quotation                             integer
c                (0) domestic,
c                (1) %domestic,
c                (2) foreign,
c                (3) %foreign
c   payofftype : (0) European put/call,
c                (1) Goemetric fixed strike Asian put/call
c                (2) Arithmetic fixed strike Asian put/call
c   para1  : ?
c   para2  : ?
c   Nsim   : number of Monte Carlo simulations
c   Nsteps : number of steps ()
c   greek  : type of results cf. Results List
c
c OUTPUT
c   mc         : result of Monte Carlo simulation                double
c   info       : diagnostic argument                            integer
c
c----------------------------------------------------------------------
c
      INTEGER, PARAMETER :: Nstepsmax = 1000
      DOUBLE PRECISION, PARAMETER :: days = 365.0D0
      DOUBLE PRECISION :: spot, strike, vol, rd, rf, tau
      INTEGER :: phi, convention, quotation, payofftype, Nsim, Nsteps,
     &           greek, i, j
      DOUBLE PRECISION :: fc1, fc2, beta
      DOUBLE PRECISION :: my, volrt, delta_t, zeta,
     &                    f1, f2, geoavg1, geoavg2, ariavg1, ariavg2
      DOUBLE PRECISION, DIMENSION(0: Nstepsmax):: s1, s2

c
c     initial parameters
      beta = 1.0D0
      s1(0) = Log(spot)
      s2(0) = Log(spot)
      delta_t = tau / days / Nsteps
      my = (rd - rf - 0.5D0 * vol * vol) * delta_t
      volrt = vol * Sqrt(delta_t)
      f1 = 0.D0
      f2 = 0.D0
      fc1 = 0.D0
      fc2 = 0.D0
      ! initialize random number generator
      CALL random_seed()

      DO j = 0, Nsim
        DO i = 1, Nsteps
            CALL random_number(zeta)

            !convert uniform zeta into standard normal zeta
            zeta = wy_ncinv(zeta)

            ! simulate path and antithetic path according to Euler scheme
            s1(i) = s1(i - 1) + my + volrt * zeta
            s2(i) = s2(i - 1) + my - volrt * zeta
        ENDDO
        SELECT CASE (payofftype)
        CASE (0) !European put/call
            f1 = f1 + wy_payoff(Exp(s1(Nsteps)), strike, phi)
            f2 = f2 + wy_payoff(Exp(s2(Nsteps)), strike, phi)
        CASE (1) !Goemetric fixed strike Asian put/call
          geoavg1 = 0.0D0
          geoavg2 = 0.0D0
          DO i = 0, Nsteps
                geoavg1 = geoavg1 + s1(i)
                geoavg2 = geoavg2 + s2(i)
          ENDDO
          SELECT CASE (greek)
          CASE (0) !value
            f1 = f1 + wy_payoff(Exp(geoavg1/(Nsteps+1)), strike, phi)
            f2 = f2 + wy_payoff(Exp(geoavg2/(Nsteps+1)), strike, phi)
          CASE (1) !delta
            IF (phi*geoavg1/(Nsteps+1) .gt. phi*log(strike)) THEN
                f1 = f1 + Exp(geoavg1/(Nsteps+1))/spot
            ENDIF
            IF (phi*geoavg2/(Nsteps+1) .gt. phi*log(strike)) THEN
                f2 = f2 + Exp(geoavg2/(Nsteps+1))/spot
            ENDIF
          END SELECT
        CASE (2) !Arithmetic fixed strike Asian put/call
          geoavg1 = 0.0D0
          geoavg2 = 0.0D0
          ariavg1 = 0.0D0
          ariavg2 = 0.0D0
          DO i = 0, Nsteps
            geoavg1 = geoavg1 + s1(i)
            geoavg2 = geoavg2 + s2(i)
            ariavg1 = ariavg1 + exp(s1(i))
            ariavg2 = ariavg2 + exp(s2(i))
          ENDDO
          fc1 = fc1 + wy_payoff(Exp(geoavg1/(Nsteps+1)), strike, phi)
          fc2 = fc2 + wy_payoff(Exp(geoavg2/(Nsteps+1)), strike, phi)
          f1  = f1 + wy_payoff(ariavg1/(Nsteps+1), strike, phi)
          f2  = f2 + wy_payoff(ariavg2/(Nsteps+1), strike, phi)
        END SELECT
      ENDDO

      ! get value of option with antithetic technique
      f = 0.5D0 * (f1 + f2) / Nsim  * Exp(-rd * tau / days)
      IF (payofftype .eq. 2) THEN
        f = f + beta * (wy_Asiangeo(spot, strike, vol, rd, rf,
     &      tau / days, 0.0D0, spot, phi, convention, quotation, 0)
     &    - 0.5D0 * (fc1 + fc2) / Nsim  * Exp(-rd * tau / days))
      ENDIF
      END FUNCTION


! $UWHPSC/codes/fortran/arrayops2.f90

program arrayops2

    implicit none
    real(kind=8), dimension(3,2) :: a,b
    integer i

    a = reshape((/1,2,3,4,5,6/), (/3,2/))

    b = transpose(a)

    print *, "b = "
    do i=1,2
        print *, b(i,:)   ! i'th row
        enddo

    c = matmul(a,b)
    print *, "c = "
    do i=1,3
        print *, c(i,:)   ! i'th row
        enddo

    x = (/5,6/)
    y = matmul(a,x)
    print *, "x = ",x
    print *, "y = ",y

end program arrayops2


C******************************************************************************
C FILE: omp_reduction.f
C DESCRIPTION:
C   OpenMP Example - Combined Parallel Loop Reduction - Fortran Version
C   This example demonstrates a sum reduction within a combined parallel loop
C   construct.  Notice that default data element scoping is assumed - there
C   are no clauses specifying shared or private variables.  OpenMP will
C   automatically make loop index variables private within team threads, and
C   global variables shared.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED:
C******************************************************************************

      PROGRAM REDUCTION

      INTEGER I, N
      REAL A(100), B(100), SUM

!     Some initializations
      N = 100
      DO I = 1, N
        A(I) = I *1.0
        B(I) = A(I)
      ENDDO
      SUM = 0.0

!$OMP PARALLEL DO REDUCTION(+:SUM)
      DO I = 1, N
        SUM = SUM + (A(I) * B(I))
      ENDDO

      PRINT *, '   Sum = ', SUM
      END


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! tests kind argument for len,size,lbound,ubound,shape,maxloc,minloc (F2003)

	program p
	integer a(5,7)
        integer b(10)
	integer d(2:11,-1:81)
	integer bnd(2)
	integer bnd2(1)
	character*8 c
	integer result(39), expect(39)
	data expect /8,8,8,8,8,8,8,1,2,4,8,1,2,4,8,2,-1,2,-1,2,-1,2,-1,11,81,11,81,11,81,11,81,2,2,2,2,1,2,4,8/

	do i=1,10
	   b(i) = 10-i
	enddo
	result = 0

	result(1) = kind(len(c,kind=selected_int_kind(12)))
	result(2) = kind(size(a,1,kind=selected_int_kind(12)))
        result(3) = kind(lbound(array=a,dim=1,kind=selected_int_kind(12)))
	result(4) = kind(ubound(array=a,dim=1,kind=selected_int_kind(12)))
	result(5) = kind(shape(a,kind=selected_int_kind(12)))
	result(6) = kind(maxloc(array=b,kind=selected_int_kind(12)))
	result(7) = kind(minloc(array=b,kind=selected_int_kind(12)))

        result(8) = kind(lbound(array=d,kind=1))
        result(9) = kind(lbound(array=d,kind=2))
        result(10) = kind(lbound(array=d,kind=4))
        result(11) = kind(lbound(array=d,kind=8))

        result(12) = kind(ubound(array=d,kind=1))
        result(13) = kind(ubound(array=d,kind=2))
        result(14) = kind(ubound(array=d,kind=4))
        result(15) = kind(ubound(kind=8,array=d))

	bnd = 0
	bnd = lbound(array=d,kind=1)
	result(16) = bnd(1)
	result(17) = bnd(2)

	bnd = 0
	bnd = lbound(array=d,kind=2)
        result(18) = bnd(1)
        result(19) = bnd(2)

	bnd = 0
	bnd = lbound(array=d,kind=4)
        result(20) = bnd(1)
        result(21) = bnd(2)

	bnd = 0
	bnd = lbound(array=d,kind=8)
        result(22) = bnd(1)
        result(23) = bnd(2)

	bnd = 0
	bnd = ubound(array=d,kind=1)
        result(24) = bnd(1)
        result(25) = bnd(2)

	bnd = 0
        bnd = ubound(array=d,kind=2)
        result(26) = bnd(1)
        result(27) = bnd(2)

	bnd = 0
        bnd = ubound(array=d,kind=4)
        result(28) = bnd(1)
        result(29) = bnd(2)

	bnd = 0
        bnd = ubound(array=d,kind=8)
        result(30) = bnd(1)
        result(31) = bnd(2)

	bnd2 = 0
	bnd2 = shape(kind=1,source=bnd)
	result(32) = bnd2(1)
        bnd2 = 0
        bnd2 = shape(kind=2,source=bnd)
        result(33) = bnd2(1)
        bnd2 = 0
        bnd2 = shape(kind=4,source=bnd)
        result(34) = bnd2(1)
        bnd2 = 0
        bnd2 = shape(kind=8,source=bnd)
        result(35) = bnd2(1)

	result(36) = kind(shape(kind=1,source=bnd))
        result(37) = kind(shape(kind=2,source=bnd))
        result(38) = kind(shape(kind=4,source=bnd))
        result(39) = kind(shape(source=bnd,kind=8))

	call check(result,expect,39)

	end


program test
  integer :: a(10), r(5, 2)
  integer :: i, j

  do j = 1, 10
      a(j) = j
  end do

  r  = reshape(a, (/5, 2/))
  do i = 1, 5
    do j = 1, 2
      print *, r(i, j)
    end do
  end do
end program test