C
C SPDX-License-Identifier: BSD-3-Clause
C
      SUBROUTINE BB01AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P,
     1                  A, LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX,
     2                  DWORK, LDWORK, INFO)
C
C     PURPOSE
C
C     To generate the benchmark examples for the numerical solution of
C     continuous-time algebraic Riccati equations (CAREs) of the form
C
C       0 = Q + A'X + XA - XGX
C
C     corresponding to the Hamiltonian matrix
C
C            (  A   G  )
C        H = (       T ).
C            (  Q  -A  )
C
C     A,G,Q,X are real N-by-N matrices, Q and G are symmetric and may
C     be given in factored form
C
C                   -1 T                         T
C      (I)   G = B R  B  ,           (II)   Q = C W C .
C
C     Here, C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W
C     and R are symmetric. In linear-quadratic optimal control problems,
C     usually W is positive semidefinite and R positive definite.  The
C     factorized form can be used if the CARE is solved using the
C     deflating subspaces of the extended Hamiltonian pencil
C
C                  (  A   0   B  )       (  I   0   0  )
C                  (       T     )       (             )
C        H - s K = (  Q   A   0  )  -  s (  0  -I   0  ) ,
C                  (       T     )       (             )
C                  (  0   B   R  )       (  0   0   0  )
C
C     where I and 0 denote the identity and zero matrix, respectively,
C     of appropriate dimensions.
C
C     NOTE: the formulation of the CARE and the related matrix (pencils)
C           used here does not include CAREs as they arise in robust
C           control (H_infinity optimization).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DEF     CHARACTER
C             This parameter specifies if the default parameters are
C             to be used or not.
C             = 'N' or 'n' : The parameters given in the input vectors
C                            xPAR (x = 'D', 'I', 'B', 'CH') are used.
C             = 'D' or 'd' : The default parameters for the example
C                            are used.
C             This parameter is not meaningful if NR(1) = 1.
C
C     Input/Output Parameters
C
C     NR      (input) INTEGER array, dimension (2)
C             This array determines the example for which CAREX returns
C             data. NR(1) is the group of examples.
C             NR(1) = 1 : parameter-free problems of fixed size.
C             NR(1) = 2 : parameter-dependent problems of fixed size.
C             NR(1) = 3 : parameter-free problems of scalable size.
C             NR(1) = 4 : parameter-dependent problems of scalable size.
C             NR(2) is the number of the example in group NR(1).
C             Let NEXi be the number of examples in group i. Currently,
C             NEX1 = 6, NEX2 = 9, NEX3 = 2, NEX4 = 4.
C             1 <= NR(1) <= 4;
C             1 <= NR(2) <= NEXi , where i = NR(1).
C
C     DPAR    (input/output) DOUBLE PRECISION array, dimension (7)
C             Double precision parameter vector. For explanation of the
C             parameters see [1].
C             DPAR(1)           : defines the parameters
C                                 'delta' for NR(1) = 3,
C                                 'q' for NR(1).NR(2) = 4.1,
C                                 'a' for NR(1).NR(2) = 4.2, and
C                                 'mu' for NR(1).NR(2) = 4.3.
C             DPAR(2)           : defines parameters
C                                 'r' for NR(1).NR(2) = 4.1,
C                                 'b' for NR(1).NR(2) = 4.2, and
C                                 'delta' for NR(1).NR(2) = 4.3.
C             DPAR(3)           : defines parameters
C                                 'c' for NR(1).NR(2) = 4.2 and
C                                 'kappa' for NR(1).NR(2) = 4.3.
C             DPAR(j), j=4,5,6,7: These arguments are only used to
C                                 generate Example 4.2 and define in
C                                 consecutive order the intervals
C                                 ['beta_1', 'beta_2'],
C                                 ['gamma_1', 'gamma_2'].
C             NOTE that if DEF = 'D' or 'd', the values of DPAR entries
C             on input are ignored and, on output, they are overwritten
C             with the default parameters.
C
C     IPAR    (input/output) INTEGER array, dimension (4)
C             On input, IPAR(1) determines the actual state dimension,
C             i.e., the order of the matrix A as follows, where
C             NO = NR(1).NR(2).
C             NR(1) = 1 or 2.1-2.8: IPAR(1) is ignored.
C             NO = 2.9            : IPAR(1) = 1 generates the CARE for
C                                   optimal state feedback (default);
C                                   IPAR(1) = 2 generates the Kalman
C                                   filter CARE.
C             NO = 3.1            : IPAR(1) is the number of vehicles
C                                   (parameter 'l' in the description
C                                    in [1]).
C             NO = 3.2, 4.1 or 4.2: IPAR(1) is the order of the matrix
C                                   A.
C             NO = 4.3 or 4.4     : IPAR(1) determines the dimension of
C                                   the second-order system, i.e., the
C                                   order of the stiffness matrix for
C                                   Examples 4.3 and 4.4 (parameter 'l'
C                                   in the description in [1]).
C
C             The order of the output matrix A is N = 2*IPAR(1) for
C             Example 4.3 and N = 2*IPAR(1)-1 for Examples 3.1 and 4.4.
C             NOTE that IPAR(1) is overwritten for Examples 1.1-2.8. For
C             the other examples, IPAR(1) is overwritten if the default
C             parameters are to be used.
C             On output, IPAR(1) contains the order of the matrix A.
C
C             On input, IPAR(2) is the number of colums in the matrix B
C             in (I) (in control problems, the number of inputs of the
C             system). Currently, IPAR(2) is fixed or determined by
C             IPAR(1) for all examples and thus is not referenced on
C             input.
C             On output, IPAR(2) is the number of columns of the
C             matrix B from (I).
C             NOTE that currently IPAR(2) is overwritten and that
C             rank(G) <= IPAR(2).
C
C             On input, IPAR(3) is the number of rows in the matrix C
C             in (II) (in control problems, the number of outputs of the
C             system). Currently, IPAR(3) is fixed or determined by
C             IPAR(1) for all examples and thus is not referenced on
C             input.
C             On output, IPAR(3) contains the number of rows of the
C             matrix C in (II).
C             NOTE that currently IPAR(3) is overwritten and that
C             rank(Q) <= IPAR(3).
C
C             On input, if NR(1) = NR(2) = 4, and other data file than
C             that used by default is desired, then IPAR(4) is the
C             length of the character string in CHPAR specifying the
C             file name.
C
C     BPAR    (input) BOOLEAN array, dimension (6)
C             This array defines the form of the output of the examples
C             and the storage mode of the matrices G and Q.
C             BPAR(1) = .TRUE.  : G is returned.
C             BPAR(1) = .FALSE. : G is returned in factored form, i.e.,
C                                 B and R from (I) are returned.
C             BPAR(2) = .TRUE.  : The matrix returned in array G (i.e.,
C                                 G if BPAR(1) = .TRUE. and R if
C                                 BPAR(1) = .FALSE.) is stored as full
C                                 matrix.
C             BPAR(2) = .FALSE. : The matrix returned in array G is
C                                 provided in packed storage mode.
C             BPAR(3) = .TRUE.  : If BPAR(2) = .FALSE., the matrix
C                                 returned in array G is stored in upper
C                                 packed mode, i.e., the upper triangle
C                                 of a symmetric n-by-n matrix is stored
C                                 by columns, e.g., the matrix entry
C                                 G(i,j) is stored in the array entry
C                                 G(i+j*(j-1)/2) for i <= j.
C                                 Otherwise, this entry is ignored.
C             BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix
C                                 returned in array G is stored in lower
C                                 packed mode, i.e., the lower triangle
C                                 of a symmetric n-by-n matrix is stored
C                                 by columns, e.g., the matrix entry
C                                 G(i,j) is stored in the array entry
C                                 G(i+(2*n-j)*(j-1)/2) for j <= i.
C                                 Otherwise, this entry is ignored.
C             BPAR(4) = .TRUE.  : Q is returned.
C             BPAR(4) = .FALSE. : Q is returned in factored form, i.e.,
C                                 C and W from (II) are returned.
C             BPAR(5) = .TRUE.  : The matrix returned in array Q (i.e.,
C                                 Q if BPAR(4) = .TRUE. and W if
C                                 BPAR(4) = .FALSE.) is stored as full
C                                 matrix.
C             BPAR(5) = .FALSE. : The matrix returned in array Q is
C                                 provided in packed storage mode.
C             BPAR(6) = .TRUE.  : If BPAR(5) = .FALSE., the matrix
C                                 returned in array Q is stored in upper
C                                 packed mode (see above).
C                                 Otherwise, this entry is ignored.
C             BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix
C                                 returned in array Q is stored in lower
C                                 packed mode (see above).
C                                 Otherwise, this entry is ignored.
C             NOTE that there are no default values for BPAR.  If all
C             entries are declared to be .TRUE., then matrices G and Q
C             are returned in conventional storage mode, i.e., as
C             N-by-N arrays where the array element Z(I,J) contains the
C             matrix entry Z_{i,j}.
C
C     CHPAR   (input/output) CHARACTER*255
C             On input, this is the name of a data file supplied by the
C             user.
C             In the current version, only Example 4.4 allows a
C             user-defined data file. This file must contain
C             consecutively DOUBLE PRECISION vectors mu, delta, gamma,
C             and kappa. The length of these vectors is determined by
C             the input value for IPAR(1).
C             If on entry, IPAR(1) = L, then mu and delta must each
C             contain L DOUBLE PRECISION values, and gamma and kappa
C             must each contain L-1 DOUBLE PRECISION values.
C             On output, this string contains short information about
C             the chosen example.
C
C     VEC     (output) LOGICAL array, dimension (9)
C             Flag vector which displays the availability of the output
C             data:
C             VEC(j), j=1,2,3, refer to N, M, and P, respectively, and
C             are always .TRUE.
C             VEC(4) refers to A and is always .TRUE.
C             VEC(5) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors B
C             and R from (I) are returned.
C             VEC(6) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors C
C             and W from (II) are returned.
C             VEC(7) refers to G and is always .TRUE.
C             VEC(8) refers to Q and is always .TRUE.
C             VEC(9) refers to X and is .TRUE. if the exact solution
C             matrix is available.
C             NOTE that VEC(i) = .FALSE. for i = 1 to 9 if on exit
C             INFO .NE. 0.
C
C     N       (output) INTEGER
C             The order of the matrices A, X, G if BPAR(1) = .TRUE., and
C             Q if BPAR(4) = .TRUE.
C
C     M       (output) INTEGER
C             The number of columns in the matrix B (or the dimension of
C             the control input space of the underlying dynamical
C             system).
C
C     P       (output) INTEGER
C             The number of rows in the matrix C (or the dimension of
C             the output space of the underlying dynamical system).
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array contains the
C             coefficient matrix A of the CARE.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= N.
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,M)
C             If (BPAR(1) = .FALSE.), then the leading N-by-M part of
C             this array contains the matrix B of the factored form (I)
C             of G. Otherwise, B is used as workspace.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= N.
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N)
C             If (BPAR(4) = .FALSE.), then the leading P-by-N part of
C             this array contains the matrix C of the factored form (II)
C             of Q. Otherwise, C is used as workspace.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= P, where P is the number of rows of the matrix C,
C             i.e., the output value of IPAR(3). (For all examples,
C             P <= N, where N equals the output value of the argument
C             IPAR(1), i.e., LDC >= LDA is always safe.)
C
C     G       (output) DOUBLE PRECISION array, dimension (NG)
C             If (BPAR(2) = .TRUE.)  then NG = LDG*N.
C             If (BPAR(2) = .FALSE.) then NG = N*(N+1)/2.
C             If (BPAR(1) = .TRUE.), then array G contains the
C             coefficient matrix G of the CARE.
C             If (BPAR(1) = .FALSE.), then array G contains the 'control
C             weighting matrix' R of G's factored form as in (I). (For
C             all examples, M <= N.) The symmetric matrix contained in
C             array G is stored according to BPAR(2) and BPAR(3).
C
C     LDG     INTEGER
C             If conventional storage mode is used for G, i.e.,
C             BPAR(2) = .TRUE., then G is stored like a 2-dimensional
C             array with leading dimension LDG. If packed symmetric
C             storage mode is used, then LDG is not referenced.
C             LDG >= N if BPAR(2) = .TRUE..
C
C     Q       (output) DOUBLE PRECISION array, dimension (NQ)
C             If (BPAR(5) = .TRUE.)  then NQ = LDQ*N.
C             If (BPAR(5) = .FALSE.) then NQ = N*(N+1)/2.
C             If (BPAR(4) = .TRUE.), then array Q contains the
C             coefficient matrix Q of the CARE.
C             If (BPAR(4) = .FALSE.), then array Q contains the 'output
C             weighting matrix' W of Q's factored form as in (II).
C             The symmetric matrix contained in array Q is stored
C             according to BPAR(5) and BPAR(6).
C
C     LDQ     INTEGER
C             If conventional storage mode is used for Q, i.e.,
C             BPAR(5) = .TRUE., then Q is stored like a 2-dimensional
C             array with leading dimension LDQ. If packed symmetric
C             storage mode is used, then LDQ is not referenced.
C             LDQ >= N if BPAR(5) = .TRUE..
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,IPAR(1))
C             If an exact solution is available (NR = 1.1, 1.2, 2.1,
C             2.3-2.6, 3.2), then the leading N-by-N part of this array
C             contains the solution matrix X in conventional storage
C             mode. Otherwise, X is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= 1, and
C             LDX >= N if NR = 1.1, 1.2, 2.1, 2.3-2.6, 3.2.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= N*MAX(4,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0 : successful exit;
C             < 0 : if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1 : data file could not be opened or had wrong format;
C             = 2 : division by zero;
C             = 3 : G can not be computed as in (I) due to a singular R
C                   matrix.
C
C     REFERENCES
C
C     [1] Abels, J. and Benner, P.
C         CAREX - A Collection of Benchmark Examples for Continuous-Time
C         Algebraic Riccati Equations (Version 2.0).
C         SLICOT Working Note 1999-14, November 1999. Available from
C         http://www.win.tue.nl/niconet/NIC2/reports.html.
C
C     This is an updated and extended version of
C
C     [2] Benner, P., Laub, A.J., and Mehrmann, V.
C         A Collection of Benchmark Examples for the Numerical Solution
C         of Algebraic Riccati Equations I: Continuous-Time Case.
C         Technical Report SPC 95_22, Fak. f. Mathematik,
C         TU Chemnitz-Zwickau (Germany), October 1995.
C
C     NUMERICAL ASPECTS
C
C     If the original data as taken from the literature is given via
C     matrices G and Q, but factored forms are requested as output, then
C     these factors are obtained from Cholesky or LDL' decompositions of
C     G and Q, i.e., the output data will be corrupted by roundoff
C     errors.
C
C     FURTHER COMMENTS
C
C     Some benchmark examples read data from the data files provided
C     with the collection.
C
C     CONTRIBUTOR
C
C     Peter Benner (Universitaet Bremen), November 15, 1999.
C
C     For questions concerning the collection or for the submission of
C     test examples, please send e-mail to benner@math.uni-bremen.de.
C
C     REVISIONS
C
C     V. Sima, 1999, December 23, May 2016.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
C     . # of examples available , # of examples with fixed size. .
      INTEGER          NEX1, NEX2, NEX3, NEX4, NMAX
      PARAMETER        ( NMAX = 9, NEX1 = 6, NEX2 = 9, NEX3 = 2,
     1                   NEX4 = 4 )
      DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     1                   THREE = 3.0D0, FOUR = 4.0D0,
     2                   PI = .3141592653589793D1 )
C
C     .. Scalar Arguments ..
      INTEGER          INFO, LDA, LDB, LDC, LDG, LDQ, LDWORK, LDX, M, N,
     $                 P
      CHARACTER        DEF
C
C     .. Array Arguments ..
      INTEGER          IPAR(4), NR(2)
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*),
     1                 G(*), Q(*), X(LDX,*)
      CHARACTER        CHPAR*(*)
      LOGICAL          BPAR(6), VEC(9)
C
C     .. Local Scalars ..
      INTEGER          GDIMM, I, IOS, ISYMM, J, K, L, MSYMM, NSYMM, POS,
     1                 PSYMM, QDIMM
      DOUBLE PRECISION APPIND, B1, B2, C1, C2, SUM, TEMP, TTEMP
C
C     ..Local Arrays ..
      INTEGER          MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX)
      DOUBLE PRECISION PARDEF(4,NMAX)
      CHARACTER        IDENT*4
      CHARACTER*255    NOTES(4,NMAX)
C
C     .. External Functions ..
C     . BLAS .
      DOUBLE PRECISION DDOT
      EXTERNAL         DDOT
C     . LAPACK .
      LOGICAL          LSAME
      DOUBLE PRECISION DLAPY2
      EXTERNAL         LSAME, DLAPY2
C
C     .. External Subroutines ..
C     . BLAS .
      EXTERNAL         DCOPY, DGEMV, DSCAL, DSPMV, DSPR, DSYMM, DSYRK
C     . LAPACK .
      EXTERNAL         DLASET, DPPTRF, DPPTRI, DPTTRF, DPTTRS, XERBLA
C     . SLICOT .
      EXTERNAL         MA02DD, MA02ED
C
C     .. Intrinsic Functions ..
      INTRINSIC        COS, DBLE, MAX, MIN, MOD, SQRT
C
C     .. Data Statements ..
C     . default values for dimensions .
      DATA (NEX(I), I = 1, 4) /NEX1, NEX2, NEX3, NEX4/
      DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 30/
      DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 2, 2, 3, 4, 4, 55/
      DATA (NDEF(3,I), I = 1, NEX3) /20, 64/
      DATA (NDEF(4,I), I = 1, NEX4) /21, 100, 30, 211/
      DATA (MDEF(1,I), I = 1, NEX1) /1, 1, 2, 2, 3, 3/
      DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 2, 1, 3, 1, 1, 2/
      DATA (PDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 5/
      DATA (PDEF(2,I), I = 1, NEX2) /1, 1, 2, 2, 2, 3, 2, 1, 10/
C     . default values for parameters .
      DATA (PARDEF(1,I), I = 1, NEX1) /ZERO, ZERO, ZERO, ZERO, ZERO,
     1                                 ZERO/
      DATA (PARDEF(2,I), I = 1, NEX2) /.1D-5, .1D-7, .1D7, .1D-6, ZERO,
     1                                 .1D7, .1D-5, .1D-5, .1D1/
      DATA (PARDEF(3,I), I = 1, NEX3) /ZERO, ZERO/
      DATA (PARDEF(4,I), I = 1, NEX4) /ONE, .1D-1, FOUR, ZERO/
C     . comments on examples .
      DATA (NOTES(1,I), I = 1, NEX1) /
     1'Laub 1979, Ex.1', 'Laub 1979, Ex.2: uncontrollable-unobservable d
     2ata', 'Beale/Shafai 1989: model of L-1011 aircraft', 'Bhattacharyy
     3a et al. 1983: binary distillation column', 'Patnaik et al. 1980:
     4tubular ammonia reactor', 'Davison/Gesing 1978: J-100 jet engine'/
      DATA (NOTES(2,I), I = 1, NEX2) /
     1'Arnold/Laub 1984, Ex.1: (A,B) unstabilizable as EPS -> 0', 'Arnol
     2d/Laub 1984, Ex.3: control weighting matrix singular as EPS -> 0',
     3'Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo',
     4'Bai/Qian 1994: ill-conditioned Hamiltonian for EPS -> 0', 'Laub 1
     5992: H-infinity problem, eigenvalues  +/- EPS +/- i', 'Petkov et a
     6l. 1987: increasingly badly scaled Hamiltonian as EPS -> oo', 'Cho
     7w/Kokotovic 1976: magnetic tape control system', 'Arnold/Laub 1984
     8, Ex.2: poor sep. of closed-loop spectrum as EPS -> 0', 'IFAC Benc
     9hmark Problem #90-06: LQG design for modified Boing B-767 at flutt
     1er condition'/
      DATA (NOTES(3,I), I = 1, NEX3) /
     1'Laub 1979, Ex.4: string of high speed vehicles', 'Laub 1979, Ex.5
     2: circulant matrices'/
      DATA (NOTES(4,I), I = 1, NEX4) /
     1'Laub 1979, Ex.6: ill-conditioned Riccati equation', 'Rosen/Wang 1
     2992: lq control of 1-dimensional heat flow','Hench et al. 1995: co
     3upled springs, dashpots and masses','Lang/Penzl 1994: rotating axl
     4e' /
C
C     .. Executable Statements ..
C
      INFO = 0
      DO 5 I = 1, 9
        VEC(I) = .FALSE.
    5 CONTINUE
C
      IF ((NR(1) .NE. 1) .AND. (.NOT. (LSAME(DEF,'N')
     1    .OR. LSAME(DEF,'D')))) THEN
        INFO = -1
      ELSE IF ((NR(1) .LT. 1) .OR. (NR(2) .LT. 1) .OR.
     1  (NR(1) .GT. 4) .OR. (NR(2) .GT. NEX(NR(1)))) THEN
        INFO = -2
      ELSE IF (NR(1) .GT. 2) THEN
        IF (.NOT. LSAME(DEF,'N')) IPAR(1) = NDEF(NR(1),NR(2))
        IF (NR(1) .EQ. 3) THEN
          IF (NR(2) .EQ. 1) THEN
            IPAR(2) = IPAR(1)
            IPAR(3) = IPAR(1) - 1
            IPAR(1) = 2*IPAR(1) - 1
          ELSE IF (NR(2) .EQ. 2) THEN
            IPAR(2) = IPAR(1)
            IPAR(3) = IPAR(1)
          ELSE
            IPAR(2) = 1
            IPAR(3) = 1
          END IF
        ELSE IF (NR(1) .EQ. 4) THEN
          IF (NR(2) .EQ. 3) THEN
            L = IPAR(1)
            IPAR(2) = 2
            IPAR(3) = 2*L
            IPAR(1) = 2*L
          ELSE IF (NR(2) .EQ. 4) THEN
            L = IPAR(1)
            IPAR(2) = L
            IPAR(3) = L
            IPAR(1) = 2*L-1
          ELSE
            IPAR(2) = 1
            IPAR(3) = 1
          END IF
        END IF
      ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 9) .AND.
     1         (IPAR(1) . EQ. 2)) THEN
        IPAR(1) = NDEF(NR(1),NR(2))
        IPAR(2) = MDEF(NR(1),NR(2))
        IPAR(3) = 3
      ELSE
        IPAR(1) = NDEF(NR(1),NR(2))
        IPAR(2) = MDEF(NR(1),NR(2))
        IPAR(3) = PDEF(NR(1),NR(2))
      END IF
      IF (INFO .NE. 0)  GOTO 7
C
      IF (IPAR(1) .LT. 1) THEN
        INFO = -4
      ELSE IF (IPAR(1) .GT. LDA) THEN
        INFO = -12
      ELSE IF (IPAR(1) .GT. LDB) THEN
        INFO = -14
      ELSE IF (IPAR(3) .GT. LDC) THEN
        INFO = -16
      ELSE IF (BPAR(2) .AND. (IPAR(1).GT. LDG)) THEN
        INFO = -18
      ELSE IF (BPAR(5) .AND. (IPAR(1).GT. LDQ)) THEN
        INFO = -20
      ELSE IF (LDX.LT.1) THEN
        INFO = -22
      ELSE IF ((NR(1) .EQ. 1) .AND.
     $        ((NR(2) .EQ. 1) .OR. (NR(2) .EQ.2))) THEN
        IF (IPAR(1) .GT. LDX) INFO = -22
      ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 1)) THEN
        IF (IPAR(1) .GT. LDX) INFO = -22
      ELSE IF ((NR(1) .EQ. 2) .AND. ((NR(2) .GE. 3) .AND.
     1         (NR(2) .LE. 6))) THEN
        IF (IPAR(1) .GT. LDX) INFO = -22
      ELSE IF ((NR(1) .EQ. 3) .AND. (NR(2) .EQ. 2)) THEN
        IF (IPAR(1) .GT. LDX) INFO = -22
      ELSE IF (LDWORK .LT. N*(MAX(4,N))) THEN
        INFO = -24
      END IF
C
    7 CONTINUE
      IF (INFO .NE. 0)  THEN
        CALL XERBLA( 'BB01AD', -INFO )
        RETURN
      END IF
C
      NSYMM = (IPAR(1)*(IPAR(1)+1))/2
      MSYMM = (IPAR(2)*(IPAR(2)+1))/2
      PSYMM = (IPAR(3)*(IPAR(3)+1))/2
      IF (.NOT. LSAME(DEF,'N')) DPAR(1) = PARDEF(NR(1),NR(2))
C
      CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA)
      CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB)
      CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC)
      CALL DLASET('L', MSYMM, 1, ZERO, ZERO, G, 1)
      CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1)
C
      IF (NR(1) .EQ. 1) THEN
        IF (NR(2) .EQ. 1) THEN
          A(1,2) = ONE
          B(2,1) = ONE
          Q(1)   = ONE
          Q(3)   = TWO
          IDENT  = '0101'
          CALL DLASET('A', IPAR(1), IPAR(1), ONE, TWO, X, LDX)
C
        ELSE IF (NR(2) .EQ. 2) THEN
          A(1,1) = FOUR
          A(2,1) = -.45D1
          A(1,2) = THREE
          A(2,2) = -.35D1
          CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB)
          Q(1)  = 9.0D0
          Q(2)  = 6.0D0
          Q(3)  = FOUR
          IDENT = '0101'
          TEMP  = ONE + SQRT(TWO)
          CALL DLASET('A', IPAR(1), IPAR(1), 6.0D0*TEMP, FOUR*TEMP, X,
     1                LDX)
          X(1,1) = 9.0D0*TEMP
C
        ELSE IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6)) THEN
          WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01', NR(1), '0',
     1                                          NR(2) , '.dat'
          IF ((NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4)) THEN
            IDENT = '0101'
          ELSE IF (NR(2) .EQ. 5) THEN
            IDENT = '0111'
          ELSE IF (NR(2) .EQ. 6) THEN
            IDENT = '0011'
          END IF
          OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11))
          IF (IOS .NE. 0) THEN
            INFO = 1
          ELSE
            DO 10  I = 1, IPAR(1)
              READ (1, FMT = *, IOSTAT = IOS)
     1                                 (A(I,J), J = 1, IPAR(1))
              IF (IOS .NE. 0) INFO = 1
   10       CONTINUE
            DO 20  I = 1, IPAR(1)
              READ (1, FMT = *, IOSTAT = IOS)
     1                                 (B(I,J), J = 1, IPAR(2))
              IF (IOS .NE. 0) INFO = 1
   20       CONTINUE
            IF (NR(2) .LE. 4) THEN
              DO 30  I = 1, IPAR(1)
                POS = (I-1)*IPAR(1)
                READ (1, FMT = *, IOSTAT = IOS) (DWORK(POS+J),
     1                                          J = 1,IPAR(1))
   30         CONTINUE
              IF (IOS .NE. 0) THEN
                INFO = 1
              ELSE
                CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q)
              END IF
            ELSE IF (NR(2) .EQ. 6) THEN
              DO 35  I = 1, IPAR(3)
                READ (1, FMT = *, IOSTAT = IOS)
     1                                   (C(I,J), J = 1, IPAR(1))
                IF (IOS .NE. 0) INFO = 1
   35         CONTINUE
            END IF
            CLOSE(1)
          END IF
        END IF
C
      ELSE IF (NR(1) .EQ. 2) THEN
        IF (NR(2) .EQ. 1) THEN
          A(1,1) =  ONE
          A(2,2) = -TWO
          B(1,1) = DPAR(1)
          CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC)
          IDENT  = '0011'
          IF (DPAR(1) .NE. ZERO) THEN
            TEMP   = DLAPY2(ONE, DPAR(1))
            X(1,1) = (ONE + TEMP)/DPAR(1)/DPAR(1)
            X(2,1) = ONE/(TWO + TEMP)
            X(1,2) = X(2,1)
            TTEMP  = DPAR(1)*X(1,2)
            TEMP   = (ONE - TTEMP) * (ONE + TTEMP)
            X(2,2) = TEMP / FOUR
          ELSE
            INFO = 2
          END IF
C
        ELSE IF (NR(2) .EQ. 2) THEN
          A(1,1) = -.1D0
          A(2,2) = -.2D-1
          B(1,1) =  .1D0
          B(2,1) =  .1D-2
          B(2,2) =  .1D-1
          CALL DLASET('L', MSYMM, 1, ONE, ONE, G, MSYMM)
          G(1)   = G(1) + DPAR(1)
          C(1,1) = .1D2
          C(1,2) = .1D3
          IDENT  = '0010'
C
        ELSE IF (NR(2) .EQ. 3) THEN
          A(1,2) = DPAR(1)
          B(2,1) = ONE
          IDENT  = '0111'
          IF (DPAR(1) .NE. ZERO) THEN
            TEMP   = SQRT(ONE + TWO*DPAR(1))
            CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, X, LDX)
            X(1,1) = X(1,1)/DPAR(1)
          ELSE
            INFO = 2
          END IF
C
        ELSE IF (NR(2) .EQ. 4) THEN
          TEMP = DPAR(1) + ONE
          CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, A, LDA)
          Q(1) = DPAR(1)**2
          Q(3) = Q(1)
          IDENT = '1101'
          X(1,1) = TWO*TEMP + SQRT(TWO)*(SQRT(TEMP**2 + ONE) + DPAR(1))
          X(1,1) = X(1,1)/TWO
          X(2,2) = X(1,1)
          TTEMP  = X(1,1) - TEMP
          IF (TTEMP .NE. ZERO) THEN
             X(2,1) = X(1,1) / TTEMP
             X(1,2) = X(2,1)
          ELSE
             INFO = 2
          END IF
C
        ELSE IF (NR(2) .EQ. 5) THEN
          A(1,1) = THREE - DPAR(1)
          A(2,1) = FOUR
          A(1,2) = ONE
          A(2,2) = TWO - DPAR(1)
          CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB)
          Q(1)   = FOUR*DPAR(1) - 11.0D0
          Q(2)   = TWO*DPAR(1)  - 5.0D0
          Q(3)   = TWO*DPAR(1)  - TWO
          IDENT  = '0101'
          CALL DLASET('A', IPAR(1), IPAR(1), ONE, ONE, X, LDX)
          X(1,1) = TWO
C
        ELSE IF (NR(2) .EQ. 6) THEN
          IF (DPAR(1) .NE. ZERO) THEN
            A(1,1) = DPAR(1)
            A(2,2) = DPAR(1)*TWO
            A(3,3) = DPAR(1)*THREE
C     .. set C = V ..
            TEMP   = TWO/THREE
            CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP,
     1                  C, LDC)
            CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA,
     1                 ZERO, DWORK, IPAR(1))
            CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK,
     1                 IPAR(1), ZERO, A, LDA)
C     .. G = R ! ..
            G(1) = DPAR(1)
            G(4) = DPAR(1)
            G(6) = DPAR(1)
            Q(1) = ONE/DPAR(1)
            Q(4) = ONE
            Q(6) = DPAR(1)
            IDENT = '1000'
            CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX)
            TEMP   = DPAR(1)**2
            X(1,1) = TEMP + SQRT(TEMP**2 + ONE)
            X(2,2) = TEMP*TWO + SQRT(FOUR*TEMP**2 + DPAR(1))
            X(3,3) = TEMP*THREE + DPAR(1)*SQRT(9.0D0*TEMP + ONE)
            CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX,
     1                  ZERO, DWORK, IPAR(1))
            CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK,
     1                 IPAR(1), ZERO, X, LDX)
          ELSE
            INFO = 2
          END IF
C
        ELSE IF (NR(2) .EQ. 7) THEN
          IF (DPAR(1) .NE. ZERO) THEN
            A(1,2) =  .400D0
            A(2,3) =  .345D0
            A(3,2) = -.524D0/DPAR(1)
            A(3,3) = -.465D0/DPAR(1)
            A(3,4) =  .262D0/DPAR(1)
            A(4,4) = -ONE/DPAR(1)
            B(4,1) =  ONE/DPAR(1)
            C(1,1) =  ONE
            C(2,3) =  ONE
            IDENT  = '0011'
          ELSE
            INFO = 2
          END IF
C
        ELSE IF (NR(2) .EQ. 8) THEN
          A(1,1) = -DPAR(1)
          A(2,1) = -ONE
          A(1,2) =  ONE
          A(2,2) = -DPAR(1)
          A(3,3) =  DPAR(1)
          A(4,3) = -ONE
          A(3,4) =  ONE
          A(4,4) =  DPAR(1)
          CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB)
          CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC)
          IDENT = '0011'
C
        ELSE IF (NR(2) .EQ. 9) THEN
          IF (IPAR(3) .EQ. 10) THEN
C     .. read LQR CARE ...
            WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0',
     1                                           NR(2), '1.dat'
            OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12))
            IF (IOS .NE. 0) THEN
              INFO = 1
            ELSE
              DO 36 I = 1, 27, 2
                READ (1, FMT = *, IOSTAT = IOS)
     1               ((A(I+J,I+K), K = 0, 1), J = 0, 1)
                IF (IOS .NE. 0) INFO = 1
   36         CONTINUE
              DO 37 I = 30, 44, 2
                READ (1, FMT = *, IOSTAT = IOS)
     1               ((A(I+J,I+K), K = 0, 1), J = 0, 1)
                IF (IOS .NE. 0) INFO = 1
   37         CONTINUE
              DO 38 I = 1, IPAR(1)
                READ (1, FMT = *, IOSTAT = IOS)
     1               (A(I,J), J = 46, IPAR(1))
                IF (IOS .NE. 0) INFO = 1
   38         CONTINUE
              A(29,29) = -.5301D1
              B(48,1) = .8D06
              B(51,2) = .8D06
              G(1) = .3647D03
              G(3) = .1459D02
              DO 39 I = 1,6
                READ (1, FMT = *, IOSTAT = IOS)
     1               (C(I,J), J = 1,45)
                IF (IOS .NE. 0) INFO = 1
   39         CONTINUE
              C(7,47)  = ONE
              C(8,46)  = ONE
              C(9,50)  = ONE
              C(10,49) = ONE
              Q(11) = .376D-13
              Q(20) = .120D-12
              Q(41) = .245D-11
            END IF
          ELSE
C     .. read Kalman filter CARE ..
            WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0',
     1                                           NR(2), '2.dat'
            OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12))
            IF (IOS .NE. 0) THEN
              INFO = 1
            ELSE
              DO 40 I = 1, 27, 2
                READ (1, FMT = *, IOSTAT = IOS)
     1               ((A(I+K,I+J), K = 0, 1), J = 0, 1)
                IF (IOS .NE. 0) INFO = 1
   40         CONTINUE
              DO 41 I = 30, 44, 2
                READ (1, FMT = *, IOSTAT = IOS)
     1               ((A(I+K,I+J), K = 0, 1), J = 0, 1)
                IF (IOS .NE. 0) INFO = 1
   41         CONTINUE
              DO 42 I = 1, IPAR(1)
                READ (1, FMT = *, IOSTAT = IOS)
     1               (A(J,I), J = 46, IPAR(1))
                IF (IOS .NE. 0) INFO = 1
   42         CONTINUE
              A(29,29) = -.5301D1
              DO 43 J = 1, IPAR(2)
                READ (1, FMT = *, IOSTAT = IOS)
     1                                 (B(I,J), I = 1, IPAR(1))
                IF (IOS .NE. 0) INFO = 1
   43         CONTINUE
              G(1) = .685D-5
              G(3) = .373D3
              C(1,52) = .3713
              C(1,53) = .1245D1
              C(2,48) = .8D6
              C(2,54) = ONE
              C(3,51) = .8D6
              C(3,55) = ONE
              Q(1) = .28224D5
              Q(4) = .2742D-4
              Q(6) = .6854D-3
            END IF
          END IF
          CLOSE(1)
          IDENT = '0000'
        END IF
C
      ELSE IF (NR(1) .EQ. 3) THEN
        IF (NR(2) .EQ. 1) THEN
          DO 45  I = 1, IPAR(1)
            IF (MOD(I,2) .EQ. 1) THEN
              A(I,I)       = -ONE
              B(I,(I+1)/2) =  ONE
            ELSE
              A(I,I-1) =  ONE
              A(I,I+1) = -ONE
              C(I/2,I) =  ONE
            END IF
   45     CONTINUE
          ISYMM = 1
          DO 50  I = IPAR(3), 1, -1
            Q(ISYMM) = 10.0D0
            ISYMM    = ISYMM + I
   50     CONTINUE
          IDENT = '0001'
C
        ELSE IF (NR(2) .EQ. 2) THEN
          DO 60  I = 1, IPAR(1)
            A(I,I) = -TWO
            IF (I .LT. IPAR(1)) THEN
              A(I,I+1) = ONE
              A(I+1,I) = ONE
            END IF
   60	    CONTINUE
          A(1,IPAR(1)) = ONE
          A(IPAR(1),1) = ONE
          IDENT = '1111'
          TEMP = TWO * PI / DBLE(IPAR(1))
          DO 70  I = 1, IPAR(1)
            DWORK(I)   = COS(TEMP*DBLE(I-1))
            DWORK(IPAR(1)+I) = -TWO + TWO*DWORK(I) +
     1                 SQRT(5.0D0 + FOUR*DWORK(I)*(DWORK(I) - TWO))
   70     CONTINUE
          DO 90  J = 1, IPAR(1)
            DO 80  I = 1, IPAR(1)
               DWORK(2*IPAR(1)+I) = COS(TEMP*DBLE(I-1)*DBLE(J-1))
   80       CONTINUE
            X(J,1) = DDOT(IPAR(1), DWORK(IPAR(1)+1), 1,
     1                    DWORK(2*IPAR(1)+1), 1)/DBLE(IPAR(1))
   90     CONTINUE
C         .. set up circulant solution matrix ..
          DO 100  I = 2, IPAR(1)
            CALL DCOPY(IPAR(1)-I+1, X(1,1),   1, X(I,I), 1)
            CALL DCOPY(I-1, X(IPAR(1)-I+2,1), 1, X(1,I), 1)
  100     CONTINUE
        END IF
C
      ELSE IF (NR(1) .EQ. 4) THEN
        IF (NR(2) .EQ. 1) THEN
C       .. set up remaining parameter ..
          IF (.NOT. LSAME(DEF,'N')) THEN
            DPAR(1) = ONE
            DPAR(2) = ONE
          END IF
          CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA)
          B(IPAR(1),1) = ONE
          C(1,1) = ONE
          Q(1)   = DPAR(1)
          G(1)   = DPAR(2)
          IDENT  = '0000'
C
        ELSE IF (NR(2) .EQ. 2) THEN
C         .. set up remaining parameters ..
          APPIND = DBLE(IPAR(1) + 1)
          IF (.NOT. LSAME(DEF,'N')) THEN
            DPAR(1) = PARDEF(NR(1), NR(2))
            DPAR(2) = ONE
            DPAR(3) = ONE
            DPAR(4) = .2D0
            DPAR(5) = .3D0
            DPAR(6) = .2D0
            DPAR(7) = .3D0
          END IF
C         .. set up stiffness matrix ..
          TEMP = -DPAR(1)*APPIND
          CALL DLASET('A', IPAR(1), IPAR(1), ZERO, TWO*TEMP, A, LDA)
          DO 110  I = 1, IPAR(1) - 1
            A(I+1,I) = -TEMP
            A(I,I+1) = -TEMP
  110     CONTINUE
C         .. set up Gramian, stored by diagonals ..
          TEMP = ONE/(6.0D0*APPIND)
          CALL DLASET('L', IPAR(1), 1, FOUR*TEMP, FOUR*TEMP, DWORK,
     1                IPAR(1))
          CALL DLASET('L', IPAR(1)-1, 1, TEMP, TEMP, DWORK(IPAR(1)+1),
     1                IPAR(1))
          CALL DPTTRF(IPAR(1), DWORK(1), DWORK(IPAR(1)+1), INFO)
C         .. A = (inverse of Gramian) * (stiffness matrix) ..
          CALL DPTTRS(IPAR(1), IPAR(1), DWORK(1), DWORK(IPAR(1)+1),
     1                A, LDA, INFO)
C         .. compute B, C ..
          DO 120  I = 1, IPAR(1)
            B1 = MAX(DBLE(I-1)/APPIND, DPAR(4))
            B2 = MIN(DBLE(I+1)/APPIND, DPAR(5))
            C1 = MAX(DBLE(I-1)/APPIND, DPAR(6))
            C2 = MIN(DBLE(I+1)/APPIND, DPAR(7))
            IF (B1 .GE. B2) THEN
              B(I,1) = ZERO
            ELSE
              B(I,1) = B2 - B1
              TEMP   = MIN(B2, DBLE(I)/APPIND)
              IF (B1 .LT. TEMP) THEN
                B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO
                B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP)
              END IF
              TEMP = MAX(B1, DBLE(I)/APPIND)
              IF (TEMP .LT. B2) THEN
                B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO
                B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2)
              END IF
            END IF
            IF (C1 .GE. C2) THEN
              C(1,I) = ZERO
            ELSE
              C(1,I) = C2 - C1
              TEMP   = MIN(C2, DBLE(I)/APPIND)
              IF (C1 .LT. TEMP) THEN
                C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO
                C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP)
              END IF
              TEMP = MAX(C1, DBLE(I)/APPIND)
              IF (TEMP .LT. C2) THEN
                C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO
                C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2)
              END IF
            END IF
  120     CONTINUE
          CALL DSCAL(IPAR(1), DPAR(2), B(1,1), 1)
          CALL DSCAL(IPAR(1), DPAR(3), C(1,1), LDC)
          CALL DPTTRS(IPAR(1), 1, DWORK(1), DWORK(IPAR(1)+1), B, LDB,
     1                INFO)
          IDENT = '0011'
C
        ELSE IF (NR(2) .EQ. 3) THEN
C         .. set up remaining parameters ..
          IF (.NOT. LSAME(DEF,'N')) THEN
            DPAR(1) = PARDEF(NR(1),NR(2))
            DPAR(2) = FOUR
            DPAR(3) = ONE
          END IF
          IF (DPAR(1) . NE. 0) THEN
            CALL DLASET('A', L, L, ZERO, ONE, A(1,L+1), LDA)
            TEMP  = DPAR(3) / DPAR(1)
            A(L+1,1) = -TEMP
            A(L+1,2) =  TEMP
            A(IPAR(1),L-1) =  TEMP
            A(IPAR(1),L)   = -TEMP
            TTEMP = TWO*TEMP
            DO 130  I = 2, L-1
              A(L+I,I)   = -TTEMP
              A(L+I,I+1) =  TEMP
              A(L+I,I-1) =  TEMP
  130       CONTINUE
            CALL DLASET('A', L, L, ZERO, -DPAR(2)/DPAR(1), A(L+1,L+1),
     1                  LDA)
            B(L+1,1) =  ONE / DPAR(1)
            B(IPAR(1),IPAR(2)) = -ONE / DPAR(1)
            IDENT = '0111'
          ELSE
            INFO = 2
          END IF
C
        ELSE IF (NR(2) .EQ. 4) THEN
          IF (.NOT. LSAME(DEF,'N')) THEN
             WRITE (CHPAR(1:11), '(A,I1,A,I1,A)')
     1                            'BB01', NR(1), '0', NR(2), '.dat'
             I = 11
          ELSE
             I = IPAR(4)
          END IF
          OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:I))
          IF (IOS .NE. 0) THEN
            INFO = 1
          ELSE
            READ (1, FMT = *, IOSTAT = IOS) (DWORK(I), I = 1, 4*L-2)
            IF (IOS .NE. 0)  INFO = 1
          END IF
          CLOSE(1)
          IF (INFO .EQ. 0) THEN
            CALL DLASET('A', L-1, L-1, ZERO, ONE, A(L+1,2), LDA)
            POS    = 2*L + 1
            A(1,2) = - DWORK(POS) / DWORK(1)
            DO 140  I = 2, L
              TEMP  = DWORK(POS) / DWORK(I-1)
              TTEMP = DWORK(POS) / DWORK(I)
              IF (I .GT. 2)  A(I-1,I) = TEMP
              A(I,I) = -(TEMP + TTEMP)
              IF (I .LT. L)  A(I+1,I) = TTEMP
              POS = POS + 1
  140       CONTINUE
            POS    = L
            TEMP   = DWORK(POS+1) / DWORK(1)
            A(1,1) = -TEMP
            DO 160  I = 2, L
              TTEMP  = TEMP
              TEMP   = DWORK(POS+I) / DWORK(I)
              SUM    = TTEMP - TEMP
              A(I,1) = -SUM
              A(I,I) = A(I,I) - TEMP
              DO 150  J = 2, I-2
                A(I,J) = SUM
  150         CONTINUE
              IF (I .GT. 2)  A(I,I-1) = A(I,I-1) + SUM
  160       CONTINUE
            POS      = 3*L
            A(1,L+1) = -DWORK(3*L)/DWORK(1)
            DO 170  I = 2, L
              TEMP  = DWORK(POS) / DWORK(I-1)
              TTEMP = DWORK(POS) / DWORK(I)
              IF (I .GT. 2)  A(I-1,L+I-1) = TEMP
              A(I,L+I-1) = -(TEMP + TTEMP)
              IF (I .LT. L)  A(I+1,L+I-1) = TTEMP
              POS = POS + 1
  170       CONTINUE
            B(1,1) = ONE/DWORK(1)
            DO 180  I = 1, L
              TEMP = ONE/DWORK(I)
              IF (I .GT. 1)  B(I,I)   = -TEMP
              IF (I .LT. L)  B(I+1,I) =  TEMP
  180       CONTINUE
            C(1,1) = ONE
            Q(1)   = ONE
            POS    = 2*L - 1
            ISYMM  = L + 1
            DO 190  I = 2, L
              TEMP       = DWORK(POS+I)
              TTEMP      = DWORK(POS+L+I-1)
              C(I,I)     = TEMP
              C(I,L+I-1) = TTEMP
              Q(ISYMM)   = ONE / (TEMP*TEMP + TTEMP*TTEMP)
              ISYMM      = ISYMM + L - I + 1
  190       CONTINUE
            IDENT = '0001'
          END IF
        END IF
      END IF
C
      IF (INFO .NE. 0)  GOTO 2001
C     .. set up data in required format ..
C
      IF (BPAR(1)) THEN
C     .. G is to be returned in product form ..
        GDIMM = IPAR(1)
        IF (IDENT(4:4) .EQ. '0') THEN
C       .. invert R using Cholesky factorization, store in G ..
          CALL DPPTRF('L', IPAR(2), G, INFO)
          IF (INFO .EQ. 0) THEN
            CALL DPPTRI('L', IPAR(2), G, INFO)
            IF (IDENT(1:1) .EQ. '0') THEN
C         .. B is not identity matrix ..
              DO 200  I = 1, IPAR(1)
                CALL DSPMV('L', IPAR(2), ONE, G, B(I,1), LDB, ZERO,
     1                     DWORK((I-1)*IPAR(1)+1), 1)
  200         CONTINUE
              CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1),
     1                   B(1,1), LDB, ZERO, G, 1)
              ISYMM = IPAR(1) + 1
              DO 210  I = 2, IPAR(1)
                CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1),
     1                     B(I,1), LDB, ZERO, B(1,1), LDB)
                CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, G(ISYMM), 1)
                ISYMM = ISYMM + (IPAR(1) - I + 1)
  210         CONTINUE
            END IF
          ELSE
            IF (INFO .GT. 0) THEN
              INFO = 3
              GOTO 2001
            END IF
          END IF
        ELSE
C       .. R = identity ..
          IF (IDENT(1:1) .EQ. '0') THEN
C         .. B is not identity matrix ..
            IF (IPAR(2) .EQ. 1) THEN
              CALL DLASET('L', NSYMM, 1, ZERO, ZERO, G, 1)
              CALL DSPR('L', IPAR(1), ONE, B, 1, G)
            ELSE
              CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE,
     1                    B, LDB, ZERO, DWORK, IPAR(1))
              CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), G)
            END IF
          ELSE
C         .. B = R = identity ..
            ISYMM = 1
            DO 220  I = IPAR(1), 1, -1
              G(ISYMM) = ONE
              ISYMM = ISYMM + I
  220       CONTINUE
          END IF
        END IF
      ELSE
        GDIMM = IPAR(2)
        IF (IDENT(1:1) .EQ. '1')
     1    CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB)
        IF (IDENT(4:4) .EQ. '1') THEN
          ISYMM = 1
          DO 230  I = IPAR(2), 1, -1
            G(ISYMM) = ONE
            ISYMM = ISYMM + I
  230     CONTINUE
        END IF
      END IF
C
      IF (BPAR(4)) THEN
C     .. Q is to be returned in product form ..
        QDIMM = IPAR(1)
        IF (IDENT(3:3) .EQ. '0') THEN
          IF (IDENT(2:2) .EQ. '0') THEN
C         .. C is not identity matrix ..
            DO 240  I = 1, IPAR(1)
              CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO,
     1                   DWORK((I-1)*IPAR(1)+1), 1)
  240       CONTINUE
C         .. use Q(1:IPAR(1)) as workspace and compute the first column
C            of Q in the end ..
            ISYMM = IPAR(1) + 1
            DO 250  I = 2, IPAR(1)
              CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1),
     1                   C(1,I), 1, ZERO, Q(1), 1)
              CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1)
              ISYMM = ISYMM + (IPAR(1) - I + 1)
  250       CONTINUE
            CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1),
     1                 C(1,1), 1, ZERO, Q, 1)
          END IF
        ELSE
C       .. Q = identity ..
          IF (IDENT(2:2) .EQ. '0') THEN
C         .. C is not identity matrix ..
            IF (IPAR(3) .EQ. 1) THEN
              CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1)
              CALL DSPR('L', IPAR(1), ONE, C, LDC, Q)
            ELSE
              CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC,
     1                   ZERO, DWORK, IPAR(1))
              CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q)
            END IF
          ELSE
C         .. C = Q = identity ..
            ISYMM = 1
            DO 260  I = IPAR(1), 1, -1
              Q(ISYMM) = ONE
              ISYMM    = ISYMM + I
  260       CONTINUE
          END IF
        END IF
      ELSE
        QDIMM = IPAR(3)
        IF (IDENT(2:2) .EQ. '1')
     1    CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC)
        IF (IDENT(3:3) .EQ. '1') THEN
          ISYMM = 1
          DO 270  I = IPAR(3), 1, -1
            Q(ISYMM) = ONE
            ISYMM    = ISYMM + I
  270     CONTINUE
        END IF
      END IF
C
C     .. unpack symmetric matrices if desired ..
      IF (BPAR(2)) THEN
        ISYMM = (GDIMM * (GDIMM + 1)) / 2
        CALL DCOPY(ISYMM, G, 1, DWORK, 1)
        CALL MA02DD('Unpack', 'Lower', GDIMM, G, LDG, DWORK)
        CALL MA02ED('Lower', GDIMM, G, LDG)
      ELSE IF (BPAR(3)) THEN
        CALL MA02DD('Unpack', 'Lower', GDIMM, DWORK, GDIMM, G)
        CALL MA02ED('Lower', GDIMM, DWORK, GDIMM)
        CALL MA02DD('Pack', 'Upper', GDIMM, DWORK, GDIMM, G)
      END IF
      IF (BPAR(5)) THEN
        ISYMM = (QDIMM * (QDIMM + 1)) / 2
        CALL DCOPY(ISYMM, Q, 1, DWORK, 1)
        CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK)
        CALL MA02ED('Lower', QDIMM, Q, LDQ)
      ELSE IF (BPAR(6)) THEN
        CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q)
        CALL MA02ED('Lower', QDIMM, DWORK, QDIMM)
        CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q)
      END IF
C
C     ...set VEC...
      VEC(1) = .TRUE.
      VEC(2) = .TRUE.
      VEC(3) = .TRUE.
      VEC(4) = .TRUE.
      VEC(5) = .NOT. BPAR(1)
      VEC(6) = .NOT. BPAR(4)
      VEC(7) = .TRUE.
      VEC(8) = .TRUE.
      IF (NR(1) .EQ. 1) THEN
        IF ((NR(2) .EQ. 1) .OR. (NR(2) .EQ. 2)) VEC(9) = .TRUE.
      ELSE IF (NR(1) .EQ. 2) THEN
        IF ((NR(2) .EQ. 1) .OR. ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6)))
     1     VEC(9) = .TRUE.
      ELSE IF (NR(1) .EQ. 3) THEN
        IF (NR(2) .EQ. 2) VEC(9) = .TRUE.
      END IF
      CHPAR  = NOTES(NR(1),NR(2))
      N = IPAR(1)
      M = IPAR(2)
      P = IPAR(3)
 2001 CONTINUE
      RETURN
C *** Last line of BB01AD ***
      END
