      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     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
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 (3)
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     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     1999, December 23 (V. Sima).
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(3), NR(2)
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*),
     1                 G(*), Q(*), X(LDX,*)
      CHARACTER        CHPAR*255
      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, 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 IF (NR(2) .LE. 6) THEN
            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')) WRITE (CHPAR(1:11), '(A,I1,A,I1,A)')
     1                               'BB01', NR(1), '0', NR(2), '.dat'
          OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11))
          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


      SUBROUTINE qrdcmp(a,n,np,c,d,sing)
      INTEGER n,np
      REAL a(np,np),c(n),d(n)
      LOGICAL sing
      INTEGER i,j,k
      REAL scale,sigma,sum,tau
      sing=.false.
      do 17 k=1,n-1
        scale=0.
        do 11 i=k,n
          scale=max(scale,abs(a(i,k)))
11      continue
        if(scale.eq.0.)then
          sing=.true.
          c(k)=0.
          d(k)=0.
        else
          do 12 i=k,n
            a(i,k)=a(i,k)/scale
12        continue
          sum=0.
          do 13 i=k,n
            sum=sum+a(i,k)**2
13        continue
          sigma=sign(sqrt(sum),a(k,k))
          a(k,k)=a(k,k)+sigma
          c(k)=sigma*a(k,k)
          d(k)=-scale*sigma
          do 16 j=k+1,n
            sum=0.
            do 14 i=k,n
              sum=sum+a(i,k)*a(i,j)
14          continue
            tau=sum/c(k)
            do 15 i=k,n
              a(i,j)=a(i,j)-tau*a(i,k)
15          continue
16        continue
        endif
17    continue
      d(n)=a(n,n)
      if(d(n).eq.0.)sing=.true.
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/qrdcmp.for


! vim: set ft=fortran sw=4 ts=4 :

! mandelbrot.f95
! Calculate Mandelbrot sets
!

module mandelbrot
    !use iso_fortran_env, only: int16

    implicit none
    private
    public :: create, create_omp

    real, parameter :: r_max = 2.0

contains

    ! calculate loop count for a (complex) pixel
    integer function pixel_value (z, n_max)

        complex, intent( in ) :: z
        integer, optional, intent( in ) :: n_max

        complex :: z1
        integer :: n, n_end

        if ( present(n_max) ) then
            n_end = n_max
        else
            n_end = 255
        end if
        z1 = 0

        do n = n_end, 0, -1
            if (abs(z1) > r_max) then
                pixel_value = n
                !write (*, *) n
                return
            end if
            z1 = z1**2 + z
        end do

        pixel_value = 0

    end function pixel_value

    ! calculate RGB for pixel value
    pure function calc_rgb(n)
        integer, intent(in) :: n
        integer, dimension(3) :: calc_rgb

        calc_rgb = [5 * mod(n, 15), 32 * mod(n, 7), 8 * mod(n, 31)]

    end function calc_rgb

    ! generate mandelbrot set (OpenMP version)
    function create_omp(width, height, x_center, y_center, pixel_size) result(img)
        use image

        !integer, dimension(:,:,:), allocatable :: image
        type(ImageRGB) :: img
        integer, intent( in ) :: width, height
        real, intent( in ) :: x_center, y_center
        real, intent( in ) :: pixel_size

        integer :: x, y
        complex :: offset, coord

        img = ImageRGB(width, height)

        offset = cmplx(x_center - 0.5*pixel_size*width, &
            y_center + 0.5*pixel_size*height)

        !$omp parallel do private(y, x, coord)
        do y = 1, height
            do x = 1, width
                coord = offset + cmplx(x*pixel_size, -y*pixel_size)
                call img % set(x, y, calc_rgb(pixel_value(coord, 255)))
            end do
        end do
        !$omp end parallel do

    end function create_omp

    ! generate mandelbrot set
    function create(width, height, x_center, y_center, pixel_size) result(img)
        use image

        !integer, dimension(:,:,:), allocatable :: image
        type(ImageRGB) :: img
        integer, intent( in ) :: width, height
        real, intent( in ) :: x_center, y_center
        real, intent( in ) :: pixel_size

        integer :: x, y
        complex :: offset, coord

        img = ImageRGB(width, height)

        offset = cmplx(x_center - 0.5*pixel_size*width, &
            y_center + 0.5*pixel_size*height)

        do y = 1, height
            do x = 1, width
                coord = offset + cmplx(x*pixel_size, -y*pixel_size)
                call img % set(x, y, calc_rgb(pixel_value(coord, 255)))
            end do
        end do

    end function create

end module mandelbrot


subroutine regcoil_svd_scan

  use regcoil_variables
  use stel_kinds

  implicit none

  integer :: iflag, tic, toc, countrate
  real(dp), dimension(:), allocatable :: singular_values, U_transpose_times_RHS
  real(dp), dimension(:,:), allocatable :: svd_matrix, U, VT
  real(dp) :: factor
  integer :: ilambda, itheta, izeta, index, n_singular_values

  ! Variables needed by LAPACK:
  integer :: INFO, LWORK, M, N, LDA, LDU, LDVT
  real(dp), dimension(:), allocatable :: WORK
  integer, dimension(:), allocatable :: IWORK
  character :: JOBZ

  if (allocated(lambda)) deallocate(lambda)
  ! Nescoil seems to require keeping at least 2 singular values in a svd scan. We will do the same to keep the number
  ! of solutions the same as nescoil.
  nlambda = num_basis_functions-1
  allocate(lambda(nlambda))
  lambda=0

  if (allocated(svd_matrix)) deallocate(svd_matrix)
  allocate(svd_matrix(ntheta_plasma*nzeta_plasma, num_basis_functions), stat=iflag)
  if (iflag .ne. 0) stop 'svd_scan Allocation error 16!'

  print *,"Beginning SVD."
  call system_clock(tic,countrate)

  if (num_basis_functions > ntheta_plasma*nzeta_plasma) then
     print *,"Error! The svd scan is only designed to work when num_basis_functions <= ntheta_plasma*nzeta_plasma"
     stop
  end if

  index=0
  do itheta=1,ntheta_plasma
     do izeta = 1,nzeta_plasma
        !index = index+1
        index = (izeta-1)*ntheta_plasma + itheta
        factor = sqrt(norm_normal_plasma(itheta,izeta))
        RHS(index) = -(Bnormal_from_plasma_current(itheta,izeta) + Bnormal_from_net_coil_currents(itheta,izeta))*factor
        svd_matrix(index,:) = g(index,:) / factor
     end do
  end do

  !JOBZ='A'  ! Compute ALL of the singular vectors.
  JOBZ='S'  ! Compute only the first min(M,N) singular vectors, which is N in our case.
  M = ntheta_plasma*nzeta_plasma
  N = num_basis_functions
  LDA = M
  LDU = M
  LDVT = N
  ! This next formula comes from the LAPACK documentation at the end of the file.
  LWORK = max( 3*min(M,N) + max(max(M,N),7*min(M,N)), &
       3*min(M,N) + max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)), &
       min(M,N)*(6+4*min(M,N))+max(M,N))

  if (allocated(WORK)) deallocate(WORK)
  allocate(WORK(LWORK),stat=iflag)
  if (iflag .ne. 0) stop 'svd_scan Allocation error 18!'

  if (allocated(IWORK)) deallocate(IWORK)
  allocate(IWORK(8*min(M,N)),stat=iflag)
  if (iflag .ne. 0) stop 'svd_scan Allocation error 19!'

  n_singular_values = min(M,N)

  if (allocated(singular_values)) deallocate(singular_values)
  allocate(singular_values(n_singular_values),stat=iflag)
  if (iflag .ne. 0) stop 'svd_scan Allocation error 20!'

  if (allocated(U)) deallocate(U)
  allocate(U(M,N),stat=iflag) ! If all singular vectors were computed, U would be M*M. But here we only compute the first N singular vectors,
  ! so U is M*N.
  if (iflag .ne. 0) stop 'svd_scan Allocation error 21!'

  if (allocated(VT)) deallocate(VT)
  allocate(VT(N,N),stat=iflag)
  if (iflag .ne. 0) stop 'svd_scan Allocation error 22!'

  ! Call LAPACK to do the SVD:
  ! Note that svd_matrix is destroyed by LAPACK!
  call DGESDD(JOBZ, M, N, svd_matrix, LDA, singular_values, U, LDU, &
       VT, LDVT, WORK, LWORK, IWORK, INFO)

  if (INFO==0) then
     print *,"SVD (DGESDD) successful."
     if (n_singular_values<5) then
        print *,"Singular values:",singular_values
     else
        print *,"First 5 singular values:",singular_values(1:5)
        print *,"Last 5 singular values:", &
             singular_values(n_singular_values-4:n_singular_values)
     end if
  else if (INFO>0) then
     print *,"Error in SVD (DGESDD): Did not converge."
  else
     print *,"Error in SVD (DGESDD): Argument",INFO," was invalid."
  end if

  call system_clock(toc)
  print *,"Took ",real(toc-tic)/countrate," sec."

  call system_clock(tic)

  if (allocated(U_transpose_times_RHS)) deallocate(U_transpose_times_RHS)
  allocate(U_transpose_times_RHS(num_basis_functions),stat=iflag)
  if (iflag .ne. 0) stop 'svd_scan Allocation error 23!'
  U_transpose_times_RHS = matmul(transpose(U),RHS)
  call system_clock(toc)
  print *,"matmul: ",real(toc-tic)/countrate," sec."

  !solution = 0
  ! Add the contribution from the ilambda-th singular vectors and singular value:
  solution = solution + VT(1,:) * (1/singular_values(1)) * U_transpose_times_RHS(1)
  do ilambda = nlambda,1,-1
     print "(a,es10.3,a,i3,a,i3,a)"," Solving system for lambda=",lambda(ilambda)," (",ilambda," of ",nlambda,")"

     ! Add the contribution from the ilambda-th singular vectors and singular value:
     !solution = solution + VT(ilambda,:) * (1/singular_values(ilambda)) * U_transpose_times_RHS(ilambda)
     ! Go in reverse order, like NESCOIL
     index = num_basis_functions-ilambda+1
     print *,"index=",index
     solution = solution + VT(index,:) * (1/singular_values(index)) * U_transpose_times_RHS(index)

     call regcoil_diagnostics(ilambda)

  end do

end subroutine regcoil_svd_scan

    ! Here is the LAPACK documentation for the relevant SVD subroutine:

!!$*       SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
!!$*                          LWORK, IWORK, INFO )
!!$*
!!$*       .. Scalar Arguments ..
!!$*       CHARACTER          JOBZ
!!$*       INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
!!$*       ..
!!$*       .. Array Arguments ..
!!$*       INTEGER            IWORK( * )
!!$*       DOUBLE PRECISION   A( LDA, * ), S( * ), U( LDU, * ),
!!$*      $                   VT( LDVT, * ), WORK( * )
!!$*       ..
!!$*
!!$*
!!$*> \par Purpose:
!!$*  =============
!!$*>
!!$*> \verbatim
!!$*>
!!$*> DGESDD computes the singular value decomposition (SVD) of a real
!!$*> M-by-N matrix A, optionally computing the left and right singular
!!$*> vectors.  If singular vectors are desired, it uses a
!!$*> divide-and-conquer algorithm.
!!$*>
!!$*> The SVD is written
!!$*>
!!$*>      A = U * SIGMA * transpose(V)
!!$*>
!!$*> where SIGMA is an M-by-N matrix which is zero except for its
!!$*> min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
!!$*> V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
!!$*> are the singular values of A; they are real and non-negative, and
!!$*> are returned in descending order.  The first min(m,n) columns of
!!$*> U and V are the left and right singular vectors of A.
!!$*>
!!$*> Note that the routine returns VT = V**T, not V.
!!$*>
!!$*> The divide and conquer algorithm makes very mild assumptions about
!!$*> floating point arithmetic. It will work on machines with a guard
!!$*> digit in add/subtract, or on those binary machines without guard
!!$*> digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
!!$*> Cray-2. It could conceivably fail on hexadecimal or decimal machines
!!$*> without guard digits, but we know of none.
!!$*> \endverbatim
!!$*
!!$*  Arguments:
!!$*  ==========
!!$*
!!$*> \param[in] JOBZ
!!$*> \verbatim
!!$*>          JOBZ is CHARACTER*1
!!$*>          Specifies options for computing all or part of the matrix U:
!!$*>          = 'A':  all M columns of U and all N rows of V**T are
!!$*>                  returned in the arrays U and VT;
!!$*>          = 'S':  the first min(M,N) columns of U and the first
!!$*>                  min(M,N) rows of V**T are returned in the arrays U
!!$*>                  and VT;
!!$*>          = 'O':  If M >= N, the first N columns of U are overwritten
!!$*>                  on the array A and all rows of V**T are returned in
!!$*>                  the array VT;
!!$*>                  otherwise, all columns of U are returned in the
!!$*>                  array U and the first M rows of V**T are overwritten
!!$*>                  in the array A;
!!$*>          = 'N':  no columns of U or rows of V**T are computed.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] M
!!$*> \verbatim
!!$*>          M is INTEGER
!!$*>          The number of rows of the input matrix A.  M >= 0.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] N
!!$*> \verbatim
!!$*>          N is INTEGER
!!$*>          The number of columns of the input matrix A.  N >= 0.
!!$*> \endverbatim
!!$*>
!!$*> \param[in,out] A
!!$*> \verbatim
!!$*>          A is DOUBLE PRECISION array, dimension (LDA,N)
!!$*>          On entry, the M-by-N matrix A.
!!$*>          On exit,
!!$*>          if JOBZ = 'O',  A is overwritten with the first N columns
!!$*>                          of U (the left singular vectors, stored
!!$*>                          columnwise) if M >= N;
!!$*>                          A is overwritten with the first M rows
!!$*>                          of V**T (the right singular vectors, stored
!!$*>                          rowwise) otherwise.
!!$*>          if JOBZ .ne. 'O', the contents of A are destroyed.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] LDA
!!$*> \verbatim
!!$*>          LDA is INTEGER
!!$*>          The leading dimension of the array A.  LDA >= max(1,M).
!!$*> \endverbatim
!!$*>
!!$*> \param[out] S
!!$*> \verbatim
!!$*>          S is DOUBLE PRECISION array, dimension (min(M,N))
!!$*>          The singular values of A, sorted so that S(i) >= S(i+1).
!!$*> \endverbatim
!!$*>
!!$*> \param[out] U
!!$*> \verbatim
!!$*>          U is DOUBLE PRECISION array, dimension (LDU,UCOL)
!!$*>          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
!!$*>          UCOL = min(M,N) if JOBZ = 'S'.
!!$*>          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
!!$*>          orthogonal matrix U;
!!$*>          if JOBZ = 'S', U contains the first min(M,N) columns of U
!!$*>          (the left singular vectors, stored columnwise);
!!$*>          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] LDU
!!$*> \verbatim
!!$*>          LDU is INTEGER
!!$*>          The leading dimension of the array U.  LDU >= 1; if
!!$*>          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
!!$*> \endverbatim
!!$*>
!!$*> \param[out] VT
!!$*> \verbatim
!!$*>          VT is DOUBLE PRECISION array, dimension (LDVT,N)
!!$*>          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
!!$*>          N-by-N orthogonal matrix V**T;
!!$*>          if JOBZ = 'S', VT contains the first min(M,N) rows of
!!$*>          V**T (the right singular vectors, stored rowwise);
!!$*>          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
!!$*> \endverbatim
!!$*>
!!$*> \param[in] LDVT
!!$*> \verbatim
!!$*>          LDVT is INTEGER
!!$*>          The leading dimension of the array VT.  LDVT >= 1; if
!!$*>          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
!!$*>          if JOBZ = 'S', LDVT >= min(M,N).
!!$*> \endverbatim
!!$*>
!!$*> \param[out] WORK
!!$*> \verbatim
!!$*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!!$*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
!!$*> \endverbatim
!!$*>
!!$*> \param[in] LWORK
!!$*> \verbatim
!!$*>          LWORK is INTEGER
!!$*>          The dimension of the array WORK. LWORK >= 1.
!!$*>          If JOBZ = 'N',
!!$*>            LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).
!!$*>          If JOBZ = 'O',
!!$*>            LWORK >= 3*min(M,N) +
!!$*>                     max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
!!$*>          If JOBZ = 'S' or 'A'
!!$*>            LWORK >= min(M,N)*(6+4*min(M,N))+max(M,N)
!!$*>          For good performance, LWORK should generally be larger.
!!$*>          If LWORK = -1 but other input arguments are legal, WORK(1)
!!$*>          returns the optimal LWORK.
!!$*> \endverbatim
!!$*>
!!$*> \param[out] IWORK
!!$*> \verbatim
!!$*>          IWORK is INTEGER array, dimension (8*min(M,N))
!!$*> \endverbatim
!!$*>
!!$*> \param[out] INFO
!!$*> \verbatim
!!$*>          INFO is INTEGER
!!$*>          = 0:  successful exit.
!!$*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!!$*>          > 0:  DBDSDC did not converge, updating process failed.
!!$*> \endverbatim


C  Compute FFT of profile in array y(nmax), and return amplitude and phase
C  in arrays amp(nh) and pha(nh).  Note that nh=nmax/2, and that the DC term
C  is returned in c(0), fundamental in c(1), ..., Nyquist freq in c(nh).

	subroutine cprof(y,nmax,amp,pha)

        integer nh
	real*8 y(nmax),amp(nmax/2),pha(nmax/2)
	complex c(0:nmax/2),temp(nmax)

        nh=nmax/2

	do 10 i=1,nh
10	 temp(i)=cmplx(y(2*i-1),y(2*i))
	call ffft_cdft(temp,nmax,1,1)
	c(0)=temp(1)
	do 20 i=1,nh
	 c(i)=temp(i+1)
	 amp(i)=cabs(c(i))
	 pha(i)=0.
20	if(amp(i).gt.0.) pha(i)=aimag(clog(c(i)))
	return
	end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine ffft_cdft(d,npts,isign,ireal)

C  Fourier transform of length npts=2**k, performed in place.
C  Input data in array d, treated as complex if ireal=0, and as real if ireal=1.
C  In either case the transform values are returned in array d, treated as
C  complex. The DC term is d(1), and d(npts/2+1) is the term at the Nyquist
C  frequency.  The basic algorithm is the same as Norm Brenner's FOUR1, and
C  uses radix-2 transforms.

C  J. H. Taylor, Princeton University.

        integer npts
	complex d(npts),t,w,wstep,tt,uu
        real*8 pi
	parameter (pi=3.141592653589793)

C  Shuffle the data to bit-reversed order.

	imax=npts/(ireal+1)
	irev=1
	do 5 i=1,imax
	if(i.ge.irev) go to 2
	t=d(i)
	d(i)=d(irev)
	d(irev)=t
2	mmax=imax/2
3	if(irev.le.mmax) go to 5
	irev=irev-mmax
	mmax=mmax/2
	if(mmax.ge.1) go to 3
5	irev=irev+mmax

C  The radix-2 transform begins here.

	api=isign*pi/2.
	mmax=1
6	istep=2*mmax
	wstep=cmplx(-2.*sin(api/mmax)**2,sin(2.*api/mmax))
	w=1.
	do 9 m=1,mmax

C  This in the inner-most loop -- optimization here is important!
	do 8 i=m,imax,istep
	t=w*d(i+mmax)
	d(i+mmax)=d(i)-t
8	d(i)=d(i)+t

9	w=w*(1.+wstep)
	mmax=istep
	if(mmax.lt.imax) go to 6

	if(ireal.eq.0) return

C  Now complete the last stage of a doubled-up real transform.

	jmax=imax/2 + 1
	wstep=cmplx(-2.*sin(isign*pi/npts)**2,sin(isign*pi/imax))
	w=1.0
	d(imax+1)=d(1)

	do 10 j=1,jmax
	uu=cmplx(real(d(j))+real(d(2+imax-j)),aimag(d(j)) -
     +    aimag(d(2+imax-j)))
	tt=w*cmplx(aimag(d(j))+aimag(d(2+imax-j)),-real(d(j)) +
     +    real(d(2+imax-j)))
	d(j)=uu+tt
	d(2+imax-j)=conjg(uu-tt)
10	w=w*(1.+wstep)

	return
	end


      REAL FUNCTION GLON(I)
C
C THIS FUNCTION RETURNS THE LONGITUDE OF THE REGULAR
C GRID IN RADIANS
C
C CALLED BY: ANLYTC, ERRANL, FORCE, INIT, INPUT
C CALLS:
C
C REVISIONS:
C 7-13-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C GRID INDEX (LONGITUDE)
      INTEGER I
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C----- Executable Statements -------------------------------------------
C
      GLON = (2.0*PI)/REAL(NLON)*REAL(I-1)
      RETURN
C
      END


	program rumor_spreading

	! Rumor spreading model (SIHR)

	! The model consists on a set of particles in one of the 4 possible states :
	! I - ignorants
	! S - spreaders
	! H - hiberantors
	! R - stiflers

	! Particles evolve according to a master equation obtained under mean-field approximation.
	! The program runs a MC method using a Gillespie algorithm

	implicit none

	integer N								! total number of particles
	double precision ign, spr, hib, sti 				! fraction of particles in each state
	double precision t, tmax, t_trans, t_prev, dt 			! time variables and time-step between measures
	double precision k							! average degree of the network
	double precision u, dran_u 						! random number generator
	double precision lambda, beta, delta, xi, eta, alpha		! transition probabilities
	double precision rate1,rate2,rate3,rate4				! transition rates
	double precision rate5,rate6,rate7,rate8,rate			! and more transition rates

	! Parameters
	!lambda = 0.8d0
	!beta = 0.2d0
	!delta = 0.5d0
	!xi = 0.0d0
	!eta = 0.5d0
	!alpha = 0.5d0

	! Nekovee
	lambda = 0.09d0
	beta = 0.0d0
	delta = 0.9d0
	xi = 0.5d0
	eta = 0.0d0
	alpha = 0.5d0

	! SIR
	!lambda = 0.6d0
	!beta = 0.0d0
	!delta = 0.0d0
	!xi = 0.0d0
	!eta = 0.0d0
	!alpha = 0.5d0

	! Homeopathy
	!lambda = 5.5d0
	!beta = 1d0
	!delta = 0.5d0
	!xi = 7d0
	!eta = 9d0
	!alpha = 0.5d0

	t = 0.0d0
	tmax = 10000000.0d0
	dt = 100.0d0
	k = 100d0
	N = 1000000

	! Initial conditions
	ign = dble(N-1)/N
	spr = 1.0d0/N
	hib = 0.0d0
	sti = 0.0d0
	call dran_ini(481992)

	! open the output files
	open(unit=21,file='crit_thresh',status='replace',action='write')
	! write(21,*) "time      ignorants      spreaders      hibernators	stiflers"
	write(21,*) t, ",", ign,",", spr,",", hib,",", sti

	! Gillespie algorithm
	t_prev = 0.d0
	do while (t .lt. tmax)
	  rate1 = lambda*k*ign*spr
	  rate2 = beta*k*ign*spr
	  rate3 = delta*spr
	  rate4 = xi*hib
	  rate5 = eta*k*spr*hib
	  rate6 = alpha*k*spr*spr
	  rate7 = alpha*k*spr*hib
	  rate8 = alpha*k*spr*sti
	  rate = rate1+rate2+rate3+rate4+rate5+rate6+rate7+rate8

	  t_trans = -dlog(dran_u())/rate
	  t = t+t_trans
	  u = dran_u()*rate

	  if (u < rate1) then
	    ign = ign-1.d0/N
	    spr = spr+1.d0/N
	  elseif (u < rate1+rate2) then
	    ign = ign-1.d0/N
	    sti = sti+1.d0/N
	  elseif (u < rate1+rate2+rate3) then
	    spr = spr-1.d0/N
	    hib = hib+1.d0/N
	  elseif (u < rate1+rate2+rate3+rate4+rate5) then
	    hib = hib-1.d0/N
	    spr = spr+1.d0/N
	  else
	    spr = spr-1.d0/N
	    sti = sti+1.d0/N
	  endif
	  if (t-t_prev > dt) then
	    write(21,*) t, ",", ign,",", spr,",", hib,",", sti
	    t_prev = t
	  endif

	enddo
	close(21)
	end program rumor_spreading


C$Procedure      SAELGV ( Semi-axes of ellipse from generating vectors )

      SUBROUTINE SAELGV ( VEC1, VEC2, SMAJOR, SMINOR )

C$ Abstract
C
C     Find semi-axis vectors of an ellipse generated by two arbitrary
C     three-dimensional vectors.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ELLIPSES
C
C$ Keywords
C
C     ELLIPSE
C     GEOMETRY
C     MATH
C
C$ Declarations

      DOUBLE PRECISION      VEC1   ( 3 )
      DOUBLE PRECISION      VEC2   ( 3 )
      DOUBLE PRECISION      SMAJOR ( 3 )
      DOUBLE PRECISION      SMINOR ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     VEC1,
C     VEC2       I   Two vectors used to generate an ellipse.
C     SMAJOR     O   Semi-major axis of ellipse.
C     SMINOR     O   Semi-minor axis of ellipse.
C
C$ Detailed_Input
C
C     VEC1,
C     VEC2           are two vectors that define an ellipse.
C                    The ellipse is the set of points in 3-space
C
C                       CENTER  +  cos(theta) VEC1  +  sin(theta) VEC2
C
C                    where theta is in the interval ( -pi, pi ] and
C                    CENTER is an arbitrary point at which the ellipse
C                    is centered.  An ellipse's semi-axes are
C                    independent of its center, so the vector CENTER
C                    shown above is not an input to this routine.
C
C                    VEC2 and VEC1 need not be linearly independent;
C                    degenerate input ellipses are allowed.
C
C$ Detailed_Output
C
C     SMAJOR
C     SMINOR         are semi-major and semi-minor axes of the ellipse,
C                    respectively.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If one or more semi-axes of the ellipse is found to be the
C         zero vector, the input ellipse is degenerate.  This case is
C         not treated as an error; the calling program must determine
C         whether the semi-axes are suitable for the program's intended
C         use.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Two linearly independent but not necessarily orthogonal vectors
C     VEC1 and VEC2 can define an ellipse centered at the origin:  the
C     ellipse is the set of points in 3-space
C
C        CENTER  +  cos(theta) VEC1  +  sin(theta) VEC2
C
C     where theta is in the interval (-pi, pi] and CENTER is an
C     arbitrary point at which the ellipse is centered.
C
C     This routine finds vectors that constitute semi-axes of an
C     ellipse that is defined, except for the location of its center,
C     by VEC1 and VEC2.  The semi-major axis is a vector of largest
C     possible magnitude in the set
C
C        cos(theta) VEC1  +  sin(theta) VEC2
C
C     There are two such vectors; they are additive inverses of each
C     other. The semi-minor axis is an analogous vector of smallest
C     possible magnitude.  The semi-major and semi-minor axes are
C     orthogonal to each other.  If SMAJOR and SMINOR are choices of
C     semi-major and semi-minor axes, then the input ellipse can also
C     be represented as the set of points
C
C        CENTER  +  cos(theta) SMAJOR  +  sin(theta) SMINOR
C
C     where theta is in the interval (-pi, pi].
C
C     The capability of finding the axes of an ellipse is useful in
C     finding the image of an ellipse under a linear transformation.
C     Finding this image is useful for determining the orthogonal and
C     gnomonic projections of an ellipse, and also for finding the limb
C     and terminator of an ellipsoidal body.
C
C$ Examples
C
C     1)  An example using inputs that can be readily checked by
C         hand calculation.
C
C            Let
C
C               VEC1 = ( 1.D0,  1.D0,  1.D0 )
C               VEC2 = ( 1.D0, -1.D0,  1.D0 )
C
C           The subroutine call
C
C              CALL SAELGV ( VEC1, VEC2, SMAJOR, SMINOR )
C
C           returns
C
C              SMAJOR = ( -1.414213562373095D0,
C                          0.0D0,
C                         -1.414213562373095D0 )
C           and
C
C              SMINOR = ( -2.4037033579794549D-17
C                          1.414213562373095D0,
C                         -2.4037033579794549D-17 )
C
C
C     2)   This example is taken from the code of the SPICELIB routine
C          PJELPL, which finds the orthogonal projection of an ellipse
C          onto a plane.  The code listed below is the portion used to
C          find the semi-axes of the projected ellipse.
C
C             C
C             C     Project vectors defining axes of ellipse onto plane.
C             C
C                   CALL VPERP ( VEC1,   NORMAL,  PROJ1  )
C                   CALL VPERP ( VEC2,   NORMAL,  PROJ2  )
C
C                      .
C                      .
C                      .
C
C                   CALL SAELGV ( PROJ1,  PROJ2,  SMAJOR,  SMINOR )
C
C
C          The call to SAELGV determines the required semi-axes.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1]  Calculus, Vol. II.  Tom Apostol.  John Wiley & Sons, 1969.
C          See Chapter 5, `Eigenvalues of Operators Acting on Euclidean
C          Spaces'.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.1.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL calls.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB) (WLT)
C
C-&

C$ Index_Entries
C
C     semi-axes of ellipse from generating vectors
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL calls.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM

      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      C      ( 2, 2 )
      DOUBLE PRECISION      EIGVAL ( 2, 2 )
      DOUBLE PRECISION      S      ( 2, 2 )
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      TMPVC1 ( 3 )
      DOUBLE PRECISION      TMPVC2 ( 3 )

      INTEGER               I
      INTEGER               MAJOR
      INTEGER               MINOR

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'SAELGV' )
      END IF

C
C        Let the notation
C
C           < a, b >
C
C        indicate the inner product of the vectors a and b.
C
C        The semi-major and semi-minor axes of the input ellipse are
C        vectors of maximum and minimum norm in the set
C
C           cos(x) VEC1  +  sin(x) VEC2
C
C        where x is in the interval (-pi, pi].
C
C        The square of the norm of a vector in this set is
C
C                                                2
C               || cos(x) VEC1  +  sin(x) VEC2 ||
C
C
C           =   < cos(x)VEC1 + sin(x)VEC2,  cos(x)VEC1 + sin(x)VEC2 > ;
C
C        this last expression can be written as the matrix product
C
C            T
C           X  S  X,                                                 (1)
C
C        where X is the unit vector
C
C           +-      -+
C           | cos(x) |
C           |        |
C           | sin(x) |
C           +-      -+
C
C        and S is the symmetric matrix
C
C           +-                                -+
C           | < VEC1, VEC1 >    < VEC1, VEC2 > |
C           |                                  |.
C           | < VEC1, VEC2 >    < VEC2, VEC2 > |
C           +-                                -+
C
C        Because the 2x2 matrix above is symmetric, there exists a
C        rotation matrix that allows us to diagonalize it:
C
C            T
C           C  S  C  =  D,
C
C        where D is a diagonal matrix.  Since rotation matrices are
C        orthogonal, we have
C
C            T
C           C  C  =  I.
C
C        If the unit vector U is defined by
C
C                T
C           U = C X,
C
C        then
C
C            T             T  T         T               T
C           X  S  X  =  ( U  C  )  C D C   ( C U )  =  U  D  U.
C
C        So, letting
C
C           +-   -+
C           |  u  |
C           |     |  =  U,
C           |  v  |
C           +-   -+
C
C        we may re-write the original quadratic expression (1) as
C
C           +-     -+    +-        -+    +-   -+
C           | u   v |    | D1    0  |    |  u  |,
C           +-     -+    |          |    |     |
C                        |          |    |  v  |
C                        | 0     D2 |    +-   -+
C                        +-        -+
C        or
C
C               2            2
C           D1 u    +    D2 v,
C
C        where the diagonal matrix above is D.  The eigenvalues D1 and
C        D2 are non-negative because they are eigenvalues of a positive
C        semi-definite matrix of the form
C
C            T
C           M  M.
C
C        We may require that
C
C           D1  >  D2;
C               -
C
C        then the maximum and minimum values of
C
C               2            2
C           D1 u    +    D2 v                                        (2)
C
C        are D1 and D2 respectively.  These values are the squares
C        of the lengths of the semi-major and semi-minor axes of the
C        ellipse, since the expression (2) is the square of the norm
C        of the point
C
C           cos(x) VEC1  + sin(x) VEC2.
C
C        Now we must find some eigenvectors.  Since the extrema of (2)
C        occur when
C
C                +-   -+                     +-   -+
C                |  1  |                     |  0  |
C           U =  |     |       or       U =  |     |,
C                |  0  |                     |  1  |
C                +-   -+                     +-   -+
C
C        and since
C
C           X = C U,
C
C        we conclude that the extrema occur when X = C1 or X = C2, where
C        C1 and C2 are the first and second columns of C.  Looking at
C        the definition of X, we see that the extrema occur when
C
C           cos(x) = C1(1)
C           sin(x) = C1(2)
C
C        and when
C
C           cos(x) = C2(1),
C           sin(x) = C2(2)
C
C        So the semi-major and semi-minor axes of the ellipse are
C
C           C(1,1) VEC1  +  C(2,1) VEC2
C
C        and
C
C           C(1,2) VEC1  +  C(2,2) VEC2
C
C        (the negatives of these vectors are also semi-axes).
C
C
C     Copy the input vectors.
C
      CALL MOVED ( VEC1, 3, TMPVC1 )
      CALL MOVED ( VEC2, 3, TMPVC2 )

C
C     Scale the vectors to try to prevent arithmetic unpleasantness.
C     We avoid using the quotient 1/SCALE, as this value may overflow.
C     No need to go further if SCALE turns out to be zero.
C
      SCALE = MAX (  VNORM ( TMPVC1 ),   VNORM ( TMPVC2 )  )

      IF ( SCALE .EQ. 0.D0 ) THEN

         CALL CLEARD ( 3, SMAJOR )
         CALL CLEARD ( 3, SMINOR )

         CALL CHKOUT ( 'SAELGV' )
         RETURN

      END IF

      DO I = 1, 3
         TMPVC1(I) = TMPVC1(I) / SCALE
         TMPVC2(I) = TMPVC2(I) / SCALE
      END DO

C
C     Compute S and diagonalize it:
C
      S(1,1) = VDOT ( TMPVC1, TMPVC1 )
      S(2,1) = VDOT ( TMPVC1, TMPVC2 )
      S(1,2) = S(2,1)
      S(2,2) = VDOT ( TMPVC2, TMPVC2 )

      CALL DIAGS2 ( S, EIGVAL, C )

C
C     Find the semi-axes.
C
      IF (   DABS( EIGVAL(1,1) )  .GE.  DABS( EIGVAL(2,2) )   )  THEN
C
C        The first eigenvector ( first column of C ) corresponds
C        to the semi-major axis of the ellipse.
C
         MAJOR = 1
         MINOR = 2

      ELSE
C
C        The second eigenvector corresponds to the semi-major axis.
C
         MAJOR = 2
         MINOR = 1

      END IF

      CALL VLCOM ( C(1,MAJOR), TMPVC1, C(2,MAJOR), TMPVC2, SMAJOR )
      CALL VLCOM ( C(1,MINOR), TMPVC1, C(2,MINOR), TMPVC2, SMINOR )

C
C     Undo the initial scaling.
C
      CALL VSCLIP ( SCALE, SMAJOR )
      CALL VSCLIP ( SCALE, SMINOR )

      CALL CHKOUT ( 'SAELGV' )
      RETURN
      END


    Program zggev3_example

!     ZGGEV3 Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen, &
        nagf_sort_cmplxvec_rank_rearrange, nagf_sort_realvec_rank
      Use lapack_interfaces, Only: zggev3
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Integer :: i, ifail, info, j, k, lda, ldb, ldvr, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), alpha(:), b(:, :), beta(:), &
        temp(:), vr(:, :), work(:)
      Complex (Kind=dp) :: dummy(1, 1)
      Real (Kind=dp), Allocatable :: rwork(:)
      Integer, Allocatable :: irank(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, all, conjg, epsilon, maxloc, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZGGEV3 Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvr = n
      Allocate (a(lda,n), alpha(n), b(ldb,n), beta(n), vr(ldvr,n), rwork(8*n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call zggev3('No left vectors', 'Vectors (right)', n, a, lda, b, ldb, &
        alpha, beta, dummy, 1, vr, ldvr, dummy, lwork, rwork, info)

      lwork = nint(real(dummy(1,1)))
      Allocate (work(lwork))

!     Read in the matrices A and B

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Solve the generalized eigenvalue problem

      Call zggev3('No left vectors', 'Vectors (right)', n, a, lda, b, ldb, &
        alpha, beta, dummy, 1, vr, ldvr, work, lwork, rwork, info)

      If (info>0) Then
        Write (nout, *)
        Write (nout, 100) 'Failure in ZGGEV3. INFO =', info
      Else If (all(abs(beta(1:n))>epsilon(1.0E0_dp))) Then
!       Re-normalize the eigenvectors, largest absolute element real
        Do i = 1, n
          rwork(1:n) = abs(vr(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(vr(k,i))/rwork(k)/dznrm2(n, vr(1,i), 1)
          vr(1:n, i) = vr(1:n, i)*scal
        End Do
        alpha(1:n) = alpha(1:n)/beta(1:n)

!       Reorder eigenvalues by descending absolute value
        rwork(1:n) = abs(alpha(1:n))
        Allocate (irank(n), temp(n))
        ifail = 0
        Call nagf_sort_realvec_rank(rwork, 1, n, 'Descending', irank, ifail)
        Call nagf_sort_cmplxvec_rank_rearrange(alpha, 1, n, irank, ifail)

!       Reorder eigenvectors accordingly
        Do j = 1, n
          temp(1:n) = vr(j, 1:n)
          Call nagf_sort_cmplxvec_rank_rearrange(temp, 1, n, irank, ifail)
          vr(j, 1:n) = temp(1:n)
        End Do

        ifail = 0
        Call nagf_file_print_matrix_complex_gen('Gen', ' ', 1, n, alpha, 1, &
          'Eigenvalues:', ifail)
        Write (nout, *)
        Flush (nout)
        Call nagf_file_print_matrix_complex_gen('Gen', ' ', n, n, vr, ldvr, &
          'Right Eigenvectors (columns):', ifail)
      Else
        Write (nout, *) 'Some of the eigenvalues are infinite.'
        Write (nout, *)
        Flush (nout)
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('Gen', ' ', 1, n, alpha, 1, &
          'Alpha', ifail)
        Call nagf_file_print_matrix_complex_gen('Gen', ' ', 1, n, beta, 1, &
          'Beta', ifail)
      End If

100   Format (1X, A, I4)
    End Program


subroutine face_value(phi, phi_uf, phi_vf, dx, dy, nx, ny, xi, xf)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(inout), dimension(nx,xi-1:xf+1):: phi
real(kind=dp), intent(out), dimension(nx-1,xi-1:xf+1):: phi_uf
real(kind=dp), intent(out), dimension(nx,xi-1:xf+1):: phi_vf
real(kind=dp), dimension(nx), intent(in):: dx
real(kind=dp), dimension(ny), intent(in):: dy
integer:: i, j
real(kind=dp) :: fe_area, fn_area
! Calculate the residual r = f - Au, where u is the guessed value
! Input
! u      Matrix for variables
! f      Right Hand Side
! hx     grid spacing in x direction
! hy     grid spacing in y direction
!
! Output
! r      Residual

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Modified: Feb 11, 2013

! Calculate boundary values by linear extrapolation
!
do j = xi-1,xf+1

    phi(1,j) = (15.0d0*phi(2,j) - 10.0d0*phi(3,j) + 3.0d0*phi(4,j))/8.0d0
    phi(nx,j) = (15.0d0*phi(nx-1,j) - 10.0d0*phi(nx-2,j) + 3.0d0*phi(nx-3,j))/8.0d0

end do

if (xi .eq. 2) then

do i = 2,nx-1

      phi(i,1) = (15.0d0*phi(i,2) - 10.0d0*phi(i,3) + 3.0d0*phi(i,4))/8.0d0
!      phi(i,1) = phi(i,2)

end do

else if (xf .eq. ny-1) then

do i = 2,nx-1

      phi(i,ny) = (15.0d0*phi(i,ny-1) - 10.0d0*phi(i,ny-2) + 3.0d0*phi(i,ny-3))/8.0d0
!     phi(i,ny) = phi(i,ny-1)

end do

end if

!phi(1,:) = phi(2,:)
!phi(nx,:) = phi(nx-1,:)
!phi(:,1) = phi(:,2)
!phi(:,ny) = phi(:,ny-1)

call exchange_data(phi, nx, xi, xf)

do j = xi,xf

     do i = 2,nx-1

            fe_area = dx(i+1)/(dx(i+1)+dx(i))
            phi_uf(i,j) = fe_area*phi(i,j) + (1.0d0-fe_area)*phi(i+1,j)

      end do

end do

phi_uf(1,:) = phi(1,:)
!phi_uf(1,:) = phi_uf(2,:)
!phi_uf(nx-1,:) = phi_uf(nx-2,:)

do j = xi,xf

    do i = 2,nx-1

            fn_area = dy(j+1)/(dy(j+1)+dy(j))
            phi_vf(i,j) = fn_area*phi(i,j) + (1.0d0-fn_area)*phi(i,j+1)

    end do

end do

if (xi .eq. 2) then

phi_vf(1:nx,1) = phi(1:nx,1)
!phi_vf(1:nx,1) = phi_vf(1:nx,2)

end if

if (xf .eq. ny-1) then

phi_vf(1:nx,ny-1) = phi(1:nx,ny)
!phi_vf(1:nx,ny-1) = phi_vf(1:nx,ny-2)

end if

call exchange_data(phi_uf, nx-1, xi, xf)
call exchange_data(phi_vf, nx, xi, xf)

end subroutine