      SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU,
     $                   RANK, SVAL, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute (optionally) a rank-revealing RQ factorization of a
C     real general M-by-N matrix  A,  which may be rank-deficient,
C     and estimate its effective rank using incremental condition
C     estimation.
C
C     The routine uses an RQ factorization with row pivoting:
C        P * A = R * Q,  where  R = [ R11 R12 ],
C                                   [  0  R22 ]
C     with R22 defined as the largest trailing submatrix whose estimated
C     condition number is less than 1/RCOND.  The order of R22, RANK,
C     is the effective rank of A.
C
C     MB03PD  does not perform any scaling of the matrix A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBRQ   CHARACTER*1
C             = 'R':  Perform an RQ factorization with row pivoting;
C             = 'N':  Do not perform the RQ factorization (but assume
C                     that it has been done outside).
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             ( LDA, N )
C             On entry with JOBRQ = 'R', the leading M-by-N part of this
C             array must contain the given matrix A.
C             On exit with JOBRQ = 'R',
C             if M <= N, the upper triangle of the subarray
C             A(1:M,N-M+1:N) contains the M-by-M upper triangular
C             matrix R;
C             if M >= N, the elements on and above the (M-N)-th
C             subdiagonal contain the M-by-N upper trapezoidal matrix R;
C             the remaining elements, with the array TAU, represent the
C             orthogonal matrix Q as a product of min(M,N) elementary
C             reflectors (see METHOD).
C             On entry and on exit with JOBRQ = 'N',
C             if M <= N, the upper triangle of the subarray
C             A(1:M,N-M+1:N) must contain the M-by-M upper triangular
C             matrix R;
C             if M >= N, the elements on and above the (M-N)-th
C             subdiagonal must contain the M-by-N upper trapezoidal
C             matrix R;
C             the remaining elements are not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     JPVT    (input/output) INTEGER array, dimension ( M )
C             On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row
C             of A is a final row, otherwise it is a free row. Before
C             the RQ factorization of A, all final rows are permuted
C             to the trailing positions; only the remaining free rows
C             are moved as a result of row pivoting during the
C             factorization.  For rank determination it is preferable
C             that all rows be free.
C             On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th
C             row of P*A was the k-th row of A.
C             Array JPVT is not referenced when JOBRQ = 'N'.
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest trailing triangular
C             submatrix R22 in the RQ factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             RCOND >= 0.
C             NOTE that when SVLMAX > 0, the estimated rank could be
C             less than that defined above (see SVLMAX).
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix B, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of B
C             (for instance, the Frobenius norm of B).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     TAU     (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) )
C             On exit with JOBRQ = 'R', the leading min(M,N) elements of
C             TAU contain the scalar factors of the elementary
C             reflectors.
C             Array TAU is not referenced when JOBRQ = 'N'.
C
C     RANK    (output) INTEGER
C             The effective (estimated) rank of A, i.e. the order of
C             the submatrix R22.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R:
C             SVAL(1): largest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(2): smallest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N),
C                      if RANK < MIN( M, N ), or of
C                      R(M-RANK+1:M,N-RANK+1:N), otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the trailing rows were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(M-RANK+1:M,N-RANK+1:N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
C             where LDWORK = max( 1, 3*M ),           if JOBRQ = 'R';
C                   LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = 'N'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine computes or uses an RQ factorization with row
C     pivoting of A,  P * A = R * Q,  with  R  defined above, and then
C     finds the largest trailing submatrix whose estimated condition
C     number is less than 1/RCOND, taking the possible positive value of
C     SVLMAX into account.  This is performed using an adaptation of the
C     LAPACK incremental condition estimation scheme and a slightly
C     modified rank decision test.
C
C     The matrix Q is represented as a product of elementary reflectors
C
C        Q = H(1) H(2) . . . H(k), where k = min(m,n).
C
C     Each H(i) has the form
C
C        H = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit
C     in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
C
C     The matrix P is represented in jpvt as follows: If
C        jpvt(j) = i
C     then the jth row of P is the ith canonical unit vector.
C
C     REFERENCES
C
C     [1] Bischof, C.H. and P. Tang.
C         Generalizing Incremental Condition Estimation.
C         LAPACK Working Notes 32, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-132,
C         May 1991.
C
C     [2] Bischof, C.H. and P. Tang.
C         Robust Incremental Condition Estimation.
C         LAPACK Working Notes 33, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-133,
C         May 1991.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
C
C     REVISIONS
C
C     Nov. 1997
C
C     KEYWORDS
C
C     Eigenvalue problem, matrix operations, orthogonal transformation,
C     singular values.
C
C    ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          JOBRQ
      INTEGER            INFO, LDA, M, N, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * )
C     .. Local Scalars ..
      LOGICAL            LJOBRQ
      INTEGER            I, ISMAX, ISMIN, JWORK, MN
      DOUBLE PRECISION   C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLAIC1, MB04GD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      LJOBRQ = LSAME( JOBRQ, 'R' )
      MN = MIN( M, N )
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( .NOT.LJOBRQ .AND. .NOT.LSAME( JOBRQ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -5
      ELSE IF( RCOND.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -8
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MN.EQ.0 ) THEN
         RANK = 0
         SVAL( 1 ) = ZERO
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
         RETURN
      END IF
C
      IF ( LJOBRQ ) THEN
C
C        Compute RQ factorization with row pivoting of A:
C           P * A = R * Q
C        Workspace 3*M. Details of Householder rotations stored in TAU.
C
         CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO )
      END IF
C
C     Determine RANK using incremental condition estimation.
C        Workspace 3*min(M,N).
C
      SMAX = ABS( A( M, N ) )
      IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN
         RANK = 0
         SVAL( 1 ) = SMAX
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
      ELSE
         ISMIN = MN
         ISMAX = 2*MN
         JWORK = ISMAX + 1
         DWORK( ISMIN ) = ONE
         DWORK( ISMAX ) = ONE
         RANK = 1
         SMIN = SMAX
         SMINPR = SMIN
C
   10    CONTINUE
         IF( RANK.LT.MN ) THEN
            CALL DCOPY ( RANK, A( M-RANK, N-RANK+1 ), LDA,
     $                   DWORK( JWORK ), 1 )
            CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN,
     $                   DWORK( JWORK ), A( M-RANK, N-RANK ), SMINPR,
     $                   S1, C1 )
            CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX,
     $                   DWORK( JWORK ), A( M-RANK, N-RANK ), SMAXPR,
     $                   S2, C2 )
C
            IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
               IF( SVLMAX*RCOND.LE.SMINPR ) THEN
                  IF( SMAXPR*RCOND.LE.SMINPR ) THEN
                     DO 20 I = 1, RANK
                        DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 )
                        DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 )
   20                CONTINUE
                     ISMIN = ISMIN - 1
                     ISMAX = ISMAX - 1
                     DWORK( ISMIN ) = C1
                     DWORK( ISMAX ) = C2
                     SMIN = SMINPR
                     SMAX = SMAXPR
                     RANK = RANK + 1
                     GO TO 10
                  END IF
               END IF
            END IF
         END IF
         SVAL( 1 ) = SMAX
         SVAL( 2 ) = SMIN
         SVAL( 3 ) = SMINPR
      END IF
C
      RETURN
C *** Last line of MB03PD ***
      END


      SUBROUTINE STPBS0(X,NCODE,BJ0,BY0)
C     SUBROUTINE  BES0.  J AND Y BESSEL FUNCTIONS OF ORDER ZERO
C     E. ALBANO, ORGN 3721, EXT 1022, OCT. 1967
C     COMPUTES J0(X)  IF X IS GREATER THAN -3.
C     COMPUTES Y0(X)  IF (X IS GREATER THAN E AND NCODE = 1 ),
C           WHERE
      INTEGER NAME(2)
      DATA NAME /4HSTPB,4HS0  /
      E=0.00001
C                 REF. US DEPT OF COMMERCE HANDBOOK (AMS 55)  PG. 369
      A=ABS(X)
      IF(A-3.) 10,10,100
   10 Z=X*X/9.
      BJ0=1.+Z*(-2.2499997+Z*(1.2656208+Z*(-0.3163866+Z*(0.0444479
     1    +Z*(-0.0039444+Z* 0.00021)))))
      IF(NCODE-1)  15,20,15
   15 RETURN
   20 IF(X-E) 200,25,25
   25 BY0=0.63661977*BJ0*(ALOG(X)-.69314718)+.36746691+Z*(0.60559366+Z*
     1    (-0.74350384+Z*(0.25300117+Z*(-0.04261214+Z*(0.00427916
     2    -0.00024846*Z)))))
      RETURN
  100 IF(X   ) 250,250,110
  110 U=1./SQRT(X)
      Z=3./X
      W=0.79788456+Z*(-0.00000077+Z*(-0.0055274+Z*(-0.00009512+Z*
     1  (0.00137237+Z*(-0.00072805+0.00014476*Z)))))
      T=X-0.78539816+Z*(-0.04166397+Z*(-0.00003954+Z*(0.00262573+Z*
     1  (-0.00054125+Z*(-0.00029333+0.00013558*Z)))))
      UW=U*W
      BJ0=UW*COS(T)
      IF(NCODE-1) 15,120,15
  120 BY0=UW*SIN(T)
 1000 RETURN
  200 CONTINUE
  250 CONTINUE
      CALL MESAGE(-7,0,NAME)
      GO TO 1000
      END


      SUBROUTINE AB09IY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NV, PV,
     $                   NW, MW, ALPHAC, ALPHAO, A, LDA, B, LDB, C, LDC,
     $                   AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV,
     $                   AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW,
     $                   SCALEC, SCALEO, S, LDS, R, LDR,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute for given state-space representations
C     (A,B,C,0), (AV,BV,CV,DV), and (AW,BW,CW,DW) of the
C     transfer-function matrices G, V and W, respectively,
C     the Cholesky factors of the frequency-weighted
C     controllability and observability Grammians corresponding
C     to a frequency-weighted model reduction problem.
C     G, V and W must be stable transfer-function matrices with
C     the state matrices A, AV, and AW in real Schur form.
C     It is assumed that the state space realizations (AV,BV,CV,DV)
C     and (AW,BW,CW,DW) are minimal. In case of possible pole-zero
C     cancellations in forming V*G and/or G*W, the parameters for the
C     choice of frequency-weighted Grammians ALPHAO and/or ALPHAC,
C     respectively, must be different from 1.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the systems as follows:
C             = 'C':  G, V and W are continuous-time systems;
C             = 'D':  G, V and W are discrete-time systems.
C
C     JOBC    CHARACTER*1
C             Specifies the choice of frequency-weighted controllability
C             Grammian as follows:
C             = 'S': choice corresponding to a combination method [4]
C                    of the approaches of Enns [1] and Lin-Chiu [2,3];
C             = 'E': choice corresponding to the stability enhanced
C                    modified combination method of [4].
C
C     JOBO    CHARACTER*1
C             Specifies the choice of frequency-weighted observability
C             Grammian as follows:
C             = 'S': choice corresponding to a combination method [4]
C                    of the approaches of Enns [1] and Lin-Chiu [2,3];
C             = 'E': choice corresponding to the stability enhanced
C                    modified combination method of [4].
C
C     WEIGHT  CHARACTER*1
C             Specifies the type of frequency weighting, as follows:
C             = 'N':  no weightings are used (V = I, W = I);
C             = 'L':  only left weighting V is used (W = I);
C             = 'R':  only right weighting W is used (V = I);
C             = 'B':  both left and right weightings V and W are used.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation of G, i.e.,
C             the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B and
C             the number of rows of the matrices CW and DW.  M >= 0.
C             M represents the dimension of the input vector of the
C             system with the transfer-function matrix G and
C             also the dimension of the output vector of the system
C             with the transfer-function matrix W.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C and the
C             number of columns of the matrices BV and DV.  P >= 0.
C             P represents the dimension of the output vector of the
C             system with the transfer-function matrix G and
C             also the dimension of the input vector of the system
C             with the transfer-function matrix V.
C
C     NV      (input) INTEGER
C             The order of the matrix AV. Also the number of rows of
C             the matrix BV and the number of columns of the matrix CV.
C             NV represents the dimension of the state vector of the
C             system with the transfer-function matrix V.  NV >= 0.
C
C     PV      (input) INTEGER
C             The number of rows of the matrices CV and DV.  PV >= 0.
C             PV represents the dimension of the output vector of the
C             system with the transfer-function matrix V.
C
C     NW      (input) INTEGER
C             The order of the matrix AW. Also the number of rows of
C             the matrix BW and the number of columns of the matrix CW.
C             NW represents the dimension of the state vector of the
C             system with the transfer-function matrix W.  NW >= 0.
C
C     MW      (input) INTEGER
C             The number of columns of the matrices BW and DW.  MW >= 0.
C             MW represents the dimension of the input vector of the
C             system with the transfer-function matrix W.
C
C     ALPHAC  (input) DOUBLE PRECISION
C             Combination method parameter for defining the
C             frequency-weighted controllability Grammian (see METHOD);
C             ABS(ALPHAC) <= 1.
C
C     ALPHAO  (input) DOUBLE PRECISION
C             Combination method parameter for defining the
C             frequency-weighted observability Grammian (see METHOD);
C             ABS(ALPHAO) <= 1.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must
C             contain the state matrix A (of the system with the
C             transfer-function matrix G) in a real Schur form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input/state matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             state/output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     AV      (input) DOUBLE PRECISION array, dimension (LDAV,NV)
C             If WEIGHT = 'L' or 'B', the leading NV-by-NV part of this
C             array must contain the state matrix AV (of the system with
C             the transfer-function matrix V) in a real Schur form.
C             AV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDAV    INTEGER
C             The leading dimension of array AV.
C             LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
C             LDAV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     BV      (input) DOUBLE PRECISION array, dimension (LDBV,P)
C             If WEIGHT = 'L' or 'B', the leading NV-by-P part of this
C             array must contain the input matrix BV of the system with
C             the transfer-function matrix V.
C             BV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDBV    INTEGER
C             The leading dimension of array BV.
C             LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B';
C             LDBV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     CV      (input) DOUBLE PRECISION array, dimension (LDCV,NV)
C             If WEIGHT = 'L' or 'B', the leading PV-by-NV part of this
C             array must contain the output matrix CV of the system with
C             the transfer-function matrix V.
C             CV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDCV    INTEGER
C             The leading dimension of array CV.
C             LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B';
C             LDCV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     DV      (input) DOUBLE PRECISION array, dimension (LDDV,P)
C             If WEIGHT = 'L' or 'B', the leading PV-by-P part of this
C             array must contain the feedthrough matrix DV of the system
C             with the transfer-function matrix V.
C             DV is not referenced if WEIGHT = 'R' or 'N'.
C
C     LDDV    INTEGER
C             The leading dimension of array DV.
C             LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B';
C             LDDV >= 1,         if WEIGHT = 'R' or 'N'.
C
C     AW      (input) DOUBLE PRECISION array, dimension (LDAW,NW)
C             If WEIGHT = 'R' or 'B', the leading NW-by-NW part of this
C             array must contain the state matrix AW (of the system with
C             the transfer-function matrix W) in a real Schur form.
C             AW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDAW    INTEGER
C             The leading dimension of array AW.
C             LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
C             LDAW >= 1,         if WEIGHT = 'L' or 'N'.
C
C     BW      (input) DOUBLE PRECISION array, dimension (LDBW,MW)
C             If WEIGHT = 'R' or 'B', the leading NW-by-MW part of this
C             array must contain the input matrix BW of the system with
C             the transfer-function matrix W.
C             BW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDBW    INTEGER
C             The leading dimension of array BW.
C             LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B';
C             LDBW >= 1,         if WEIGHT = 'L' or 'N'.
C
C     CW      (input) DOUBLE PRECISION array, dimension (LDCW,NW)
C             If WEIGHT = 'R' or 'B', the leading M-by-NW part of this
C             array must contain the output matrix CW of the system with
C             the transfer-function matrix W.
C             CW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDCW    INTEGER
C             The leading dimension of array CW.
C             LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B';
C             LDCW >= 1,        if WEIGHT = 'L' or 'N'.
C
C     DW      (input) DOUBLE PRECISION array, dimension (LDDW,MW)
C             If WEIGHT = 'R' or 'B', the leading M-by-MW part of this
C             array must contain the feedthrough matrix DW of the system
C             with the transfer-function matrix W.
C             DW is not referenced if WEIGHT = 'L' or 'N'.
C
C     LDDW    INTEGER
C             The leading dimension of array DW.
C             LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B';
C             LDDW >= 1,        if WEIGHT = 'L' or 'N'.
C
C     SCALEC  (output) DOUBLE PRECISION
C             Scaling factor for the controllability Grammian in (1)
C             or (3). See METHOD.
C
C     SCALEO  (output) DOUBLE PRECISION
C             Scaling factor for the observability Grammian in (2)
C             or (4). See METHOD.
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor S of the frequency-weighted
C             cotrollability Grammian P = S*S'. See METHOD.
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,N).
C
C     R       (output) DOUBLE PRECISION array, dimension (LDR,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor R of the frequency-weighted
C             observability Grammian Q = R'*R. See METHOD.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, LLEFT, LRIGHT ),
C             where
C             LLEFT  = (N+NV)*(N+NV+MAX(N+NV,PV)+5)
C                              if WEIGHT = 'L' or 'B' and PV > 0;
C             LLEFT  = N*(P+5) if WEIGHT = 'R' or 'N' or  PV = 0;
C             LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5)
C                              if WEIGHT = 'R' or 'B' and MW > 0;
C             LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or  MW = 0.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the state matrices A and/or AV are not stable or
C                   not in a real Schur form;
C             = 2:  if the state matrices A and/or AW are not stable or
C                   not in a real Schur form;
C             = 3:  eigenvalues computation failure.
C
C     METHOD
C
C     Let Pi = Si*Si' and Qo = Ro'*Ro be the Cholesky factored
C     controllability and observability Grammians satisfying
C     in the continuous-time case
C
C            Ai*Pi + Pi*Ai' +  scalec^2*Bi*Bi' = 0,       (1)
C
C            Ao'*Qo + Qo*Ao +  scaleo^2*Co'*Co = 0,       (2)
C
C     and in the discrete-time case
C
C            Ai*Pi*Ai' - Pi +  scalec^2*Bi*Bi' = 0,       (3)
C
C            Ao'*Qo*Ao - Qo +  scaleo^2*Co'*Co = 0,       (4)
C
C     where
C
C           Ai = ( A  B*Cw ) ,   Bi = ( B*Dw ) ,
C                ( 0   Aw  )          (  Bw  )
C
C           Ao = (  A   0  ) ,   Co = ( Dv*C  Cv ) .
C                ( Bv*C Av )
C
C     Consider the partitioned Grammians
C
C           Pi = ( P11  P12 )   and    Qo = ( Q11  Q12 ) ,
C                ( P12' P22 )               ( Q12' Q22 )
C
C     where P11 and Q11 are the leading N-by-N parts of Pi and Qo,
C     respectively, and let P0 and Q0 be non-negative definite matrices
C     defined in the combination method [4]
C                                        -1
C            P0 = P11 - ALPHAC**2*P12*P22 *P21 ,
C                                        -1
C            Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21.
C
C     The frequency-weighted controllability and observability
C     Grammians, P and Q, respectively, are defined as follows:
C     P = P0 if JOBC = 'S' (standard combination method [4]);
C     P = P1 >= P0 if JOBC = 'E', where P1 is the controllability
C     Grammian defined to enforce stability for a modified combination
C     method of [4];
C     Q = Q0 if JOBO = 'S' (standard combination method [4]);
C     Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability
C     Grammian defined to enforce stability for a modified combination
C     method of [4].
C
C     If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of
C     Grammians corresponds to the method of Enns [1], while if
C     ALPHAC = ALPHAO = 1, the choice of Grammians corresponds to the
C     method of Lin and Chiu [2,3].
C
C     The routine computes directly the Cholesky factors S and R
C     such that P = S*S' and Q = R'*R according to formulas
C     developed in [4]. No matrix inversions are involved.
C
C     REFERENCES
C
C     [1] Enns, D.
C         Model reduction with balanced realizations: An error bound
C         and a frequency weighted generalization.
C         Proc. CDC, Las Vegas, pp. 127-132, 1984.
C
C     [2] Lin, C.-A. and Chiu, T.-Y.
C         Model reduction via frequency-weighted balanced realization.
C         Control Theory and Advanced Technology, vol. 8,
C         pp. 341-351, 1992.
C
C     [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G.
C         New results on frequency weighted balanced reduction
C         technique.
C         Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995.
C
C     [4] Varga, A. and Anderson, B.D.O.
C         Square-root balancing-free methods for the frequency-weighted
C         balancing related model reduction.
C         (report in preparation)
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000.
C     D. Sima, University of Bucharest, August 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000.
C
C     REVISIONS
C
C     A. Varga, Australian National University, Canberra, November 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000.
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2001.
C
C     KEYWORDS
C
C     Frequency weighting, model reduction, multivariable system,
C     state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOBC, JOBO, WEIGHT
      INTEGER          INFO, LDA, LDAV, LDAW, LDB, LDBV, LDBW,
     $                 LDC, LDCV, LDCW, LDDV, LDDW, LDR, LDS, LDWORK,
     $                 M, MW, N, NV, NW, P, PV
      DOUBLE PRECISION ALPHAC, ALPHAO, SCALEC, SCALEO
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*),
     $                 B(LDB,*), BV(LDBV,*), BW(LDBW,*),
     $                 C(LDC,*), CV(LDCV,*), CW(LDCW,*),
     $                           DV(LDDV,*), DW(LDDW,*),
     $                 DWORK(*), R(LDR,*),   S(LDS,*)
C     .. Local Scalars ..
      LOGICAL          DISCR, FRWGHT, LEFTW, RIGHTW
      INTEGER          I, IERR, J, KAW, KTAU, KU, KW, LDU, LW, MBBAR,
     $                 NNV, NNW, PCBAR
      DOUBLE PRECISION T, TOL, WORK
C     .. Local Arrays ..
      DOUBLE PRECISION DUM(1)
C     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL         DCOPY, DGEMM, DLACPY, DLASET, DSCAL, DSYEV,
     $                 MB01WD, MB04ND, MB04OD, SB03OU, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        ABS, DBLE, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      DISCR  = LSAME( DICO,   'D' )
      LEFTW  = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' )
      RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' )
      FRWGHT = LEFTW .OR. RIGHTW
C
      INFO = 0
      LW   = 1
      NNV  = N + NV
      NNW  = N + NW
      IF( LEFTW .AND. PV.GT.0 ) THEN
         LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) )
      ELSE
         LW = MAX( LW, N*( P + 5 ) )
      END IF
      IF( RIGHTW .AND. MW.GT.0 ) THEN
         LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) )
      ELSE
         LW = MAX( LW, N*( M + 5 ) )
      END IF
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) )
     $     THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) )
     $     THEN
         INFO = -3
      ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( P.LT.0 ) THEN
         INFO = -7
      ELSE IF( NV.LT.0 ) THEN
         INFO = -8
      ELSE IF( PV.LT.0 ) THEN
         INFO = -9
      ELSE IF( NW.LT.0 ) THEN
         INFO = -10
      ELSE IF( MW.LT.0 ) THEN
         INFO = -11
      ELSE IF( ABS( ALPHAC ).GT.ONE  ) THEN
         INFO = -12
      ELSE IF( ABS( ALPHAO ).GT.ONE  ) THEN
         INFO = -13
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -19
      ELSE IF( LDAV.LT.1 .OR. ( LEFTW  .AND. LDAV.LT.NV ) ) THEN
         INFO = -21
      ELSE IF( LDBV.LT.1 .OR. ( LEFTW  .AND. LDBV.LT.NV ) ) THEN
         INFO = -23
      ELSE IF( LDCV.LT.1 .OR. ( LEFTW  .AND. LDCV.LT.PV ) ) THEN
         INFO = -25
      ELSE IF( LDDV.LT.1 .OR. ( LEFTW  .AND. LDDV.LT.PV ) ) THEN
         INFO = -27
      ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN
         INFO = -29
      ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN
         INFO = -31
      ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M  ) ) THEN
         INFO = -33
      ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M  ) ) THEN
         INFO = -35
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -39
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -41
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -43
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09IY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      SCALEC = ONE
      SCALEO = ONE
      IF( MIN( N, M, P ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      WORK = 1
      IF( LEFTW .AND. PV.GT.0 ) THEN
C
C        Build the extended permuted matrices
C
C           Ao = ( Av  Bv*C ) ,   Co = ( Cv Dv*C ) .
C                ( 0     A  )
C
         KAW = 1
         KU  = KAW + NNV*NNV
         LDU = MAX( NNV, PV )
         CALL DLACPY( 'Full', NV, NV, AV, LDAV, DWORK(KAW), NNV )
         CALL DLASET( 'Full', N, NV, ZERO, ZERO, DWORK(KAW+NV), NNV )
         CALL DGEMM( 'No-transpose', 'No-transpose', NV, N, P, ONE,
     $               BV, LDBV, C, LDC, ZERO, DWORK(KAW+NNV*NV), NNV )
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW+NNV*NV+NV), NNV )
C
         CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KU), LDU  )
         CALL DGEMM( 'No-transpose', 'No-transpose', PV, N, P, ONE,
     $               DV, LDDV, C, LDC, ZERO, DWORK(KU+LDU*NV), LDU )
C
C        Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro,
C        the continuous-time Lyapunov equation (if DICO = 'C')
C
C            Ao'*Qo + Qo*Ao  +  scaleo^2*Co'*Co = 0,
C
C        or the discrete-time Lyapunov equation (if DICO = 'D')
C
C            Ao'*Qo*Ao - Qo +  scaleo^2*Co'*Co = 0.
C
C        Workspace:  need   (N+NV)*(N+NV+MAX(N+NV,PV)+5);
C                           prefer larger.
C
         KTAU = KU + LDU*NNV
         KW   = KTAU + NNV
C
         CALL SB03OU( DISCR, .FALSE., NNV, PV, DWORK(KAW), NNV,
     $                DWORK(KU), LDU, DWORK(KTAU), DWORK(KU), LDU,
     $                SCALEO, DWORK(KW), LDWORK-KW+1, IERR )
C
         IF( IERR.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
         WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
C
C        Partition Ro as Ro = ( R11 R12 ) and compute R such that
C                             (  0  R22 )
C
C        R'*R = R22'*R22 + (1-ALPHAO**2)*R12'*R12.
C
         KW = KU + LDU*NV + NV
         CALL DLACPY( 'Upper', N, N, DWORK(KW), LDU, R, LDR )
         IF( ALPHAO.NE.ZERO ) THEN
            T = SQRT( ONE - ALPHAO*ALPHAO )
            DO 10 J = KU + LDU*NV, KU + LDU*(NNV-1), LDU
               CALL DSCAL( NV, T, DWORK(J), 1 )
   10       CONTINUE
         END IF
         IF( ALPHAO.LT.ONE .AND. NV.GT.0 ) THEN
            KTAU = 1
            CALL MB04OD( 'Full', N, 0, NV, R, LDR, DWORK(KU+LDU*NV),
     $                   LDU, DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) )
C
            DO 30 J = 1, N
               DWORK(J) = R(J,J)
               DO 20 I = 1, J
                  IF ( DWORK(I).LT.ZERO ) R(I,J) = -R(I,J)
   20          CONTINUE
   30       CONTINUE
C
         END IF
C
         IF( LSAME( JOBO, 'E' ) .AND. ALPHAO.LT.ONE ) THEN
C
C           Form Y = -A'*(R'*R)-(R'*R)*A if DICO = 'C', or
C                Y = -A'*(R'*R)*A+(R'*R) if DICO = 'D'.
C
            CALL DLACPY( 'Upper', N, N, R, LDR, DWORK(KU), N )
            CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', N,
     $                   -ONE, ZERO, R, LDR, DWORK(KAW+NNV*NV+NV), NNV,
     $                   DWORK(KU), N, IERR )
C
C           Compute the eigendecomposition of Y as Y = Z*Sigma*Z'.
C
            KU = N + 1
            CALL DSYEV( 'Vectors', 'Upper', N, R, LDR, DWORK, DWORK(KU),
     $                  LDWORK-N, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = 3
               RETURN
            END IF
            WORK = MAX( WORK, DWORK(KU) + DBLE( N ) )
C
C           Partition Sigma = (Sigma1,Sigma2), such that
C           Sigma1 <= 0, Sigma2 > 0.
C           Partition correspondingly Z = [Z1 Z2].
C
            TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) )
     $            * DLAMCH( 'Epsilon')
C                _
C           Form C = [ sqrt(Sigma2)*Z2' ]
C
            PCBAR = 0
            DO 40 J = 1, N
               IF( DWORK(J).GT.TOL ) THEN
                  CALL DSCAL( N, SQRT( DWORK(J) ), R(1,J), 1 )
                  CALL DCOPY( N, R(1,J), 1, DWORK(KU+PCBAR), N )
                  PCBAR = PCBAR + 1
               END IF
   40       CONTINUE
C
C           Solve for the Cholesky factor R of Q, Q = R'*R,
C           the continuous-time Lyapunov equation (if DICO = 'C')
C                                      _  _
C                   A'*Q + Q*A  +  t^2*C'*C = 0,
C
C           or the discrete-time Lyapunov equation (if DICO = 'D')
C                                      _  _
C                   A'*Q*A - Q  +  t^2*C'*C = 0.
C
C           Workspace:  need   N*(N + 6);
C                              prefer larger.
C
            KTAU = KU + N*N
            KW   = KTAU + N
C
            CALL SB03OU( DISCR, .FALSE., N, PCBAR, A, LDA, DWORK(KU), N,
     $                   DWORK(KTAU), R, LDR, T, DWORK(KW), LDWORK-KW+1,
     $                   IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 1
               RETURN
            END IF
            SCALEO = SCALEO*T
            WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
         END IF
C
      ELSE
C
C        Solve for the Cholesky factor R of Q, Q = R'*R,
C        the continuous-time Lyapunov equation (if DICO = 'C')
C
C            A'*Q + Q*A  +  scaleo^2*C'*C = 0,
C
C        or the discrete-time Lyapunov equation (if DICO = 'D')
C
C            A'*Q*A - Q +  scaleo^2*C'*C = 0.
C
C        Workspace:  need   N*(P + 5);
C                           prefer larger.
C
         KU   = 1
         KTAU = KU + P*N
         KW   = KTAU + N
C
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P )
         CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P,
     $                DWORK(KTAU), R, LDR, SCALEO, DWORK(KW),
     $                LDWORK-KW+1, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
         WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
      END IF
C
      IF( RIGHTW .AND. MW.GT.0 ) THEN
C
C        Build the extended matrices
C
C           Ai = ( A  B*Cw ) ,   Bi = ( B*Dw ) .
C                ( 0   Aw  )          (  Bw  )
C
         KAW = 1
         KU  = KAW + NNW*NNW
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), NNW )
         CALL DLASET( 'Full', NW, N, ZERO, ZERO, DWORK(KAW+N), NNW )
         CALL DGEMM( 'No-transpose', 'No-transpose', N, NW, M, ONE,
     $               B, LDB, CW, LDCW, ZERO, DWORK(KAW+NNW*N), NNW )
         CALL DLACPY( 'Full', NW, NW, AW, LDAW,
     $                DWORK(KAW+NNW*N+N), NNW )
C
         CALL DGEMM( 'No-transpose', 'No-transpose', N, MW, M, ONE,
     $               B, LDB, DW, LDDW, ZERO, DWORK(KU), NNW  )
         CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KU+N), NNW )
C
C        Solve for the Cholesky factor Si of Pi, Pi = Si*Si',
C        the continuous-time Lyapunov equation (if DICO = 'C')
C
C            Ai*Pi + Pi*Ai' +  scalec^2*Bi*Bi' = 0,
C
C        or the discrete-time Lyapunov equation (if DICO = 'D')
C
C            Ai*Pi*Ai' - Pi +  scalec^2*Bi*Bi' = 0.
C
C        Workspace:  need   (N+NW)*(N+NW+MAX(N+NW,MW)+5);
C                           prefer larger.
C
         KTAU = KU + NNW*MAX( NNW, MW )
         KW   = KTAU + NNW
C
         CALL SB03OU( DISCR, .TRUE., NNW, MW, DWORK(KAW), NNW,
     $                DWORK(KU), NNW, DWORK(KTAU), DWORK(KU), NNW,
     $                SCALEC, DWORK(KW), LDWORK-KW+1, IERR )
C
         IF( IERR.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
         WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
C
C        Partition Si as Si = ( S11 S12 ) and compute S such that
C                             (  0  S22 )
C
C        S*S' = S11*S11' + (1-ALPHAC**2)*S12*S12'.
C
         CALL DLACPY( 'Upper', N, N, DWORK(KU), NNW, S, LDS )
         IF( ALPHAC.NE.ZERO ) THEN
            T = SQRT( ONE - ALPHAC*ALPHAC )
            DO 50 J = KU + NNW*N, KU + NNW*(NNW-1), NNW
               CALL DSCAL( N, T, DWORK(J), 1 )
   50       CONTINUE
         END IF
         IF( ALPHAC.LT.ONE .AND. NW.GT.0 ) THEN
            KTAU = N*NNW + 1
            KW   = KTAU  + N
            CALL MB04ND( 'Full', N, 0, NW, S, LDS, DWORK(KU+NNW*N), NNW,
     $                   DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) )
C
            DO 70 J = 1, N
               IF ( S(J,J).LT.ZERO ) THEN
                  DO 60 I = 1, J
                     S(I,J) = -S(I,J)
   60             CONTINUE
               END IF
   70       CONTINUE
         END IF
C
         IF( LSAME( JOBC, 'E' ) .AND. ALPHAC.LT.ONE ) THEN
C
C           Form X = -A*(S*S')-(S*S')*A' if DICO = 'C', or
C                X = -A*(S*S')*A'+(S*S') if DICO = 'D'.
C
            CALL DLACPY( 'Upper', N, N, S, LDS, DWORK(KU), N )
            CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', N,
     $                   -ONE, ZERO, S, LDS, DWORK(KAW), NNW, DWORK(KU),
     $                   N, IERR )
C
C           Compute the eigendecomposition of X as X = Z*Sigma*Z'.
C
            KU = N + 1
            CALL DSYEV( 'Vectors', 'Upper', N, S, LDS, DWORK, DWORK(KU),
     $                  LDWORK-N, IERR )
            IF( IERR.GT.0 ) THEN
               INFO = 3
               RETURN
            END IF
            WORK = MAX( WORK, DWORK(KU) + DBLE( N ) )
C
C           Partition Sigma = (Sigma1,Sigma2), such that
C           Sigma1 =< 0, Sigma2 > 0.
C           Partition correspondingly Z = [Z1 Z2].
C
            TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) )
     $            * DLAMCH( 'Epsilon')
C                _
C           Form B = [ Z2*sqrt(Sigma2) ]
C
            MBBAR = 0
            I = KU
            DO 80 J = 1, N
               IF( DWORK(J).GT.TOL ) THEN
                  MBBAR = MBBAR + 1
                  CALL DSCAL( N, SQRT( DWORK(J) ), S(1,J), 1 )
                  CALL DCOPY( N, S(1,J), 1, DWORK(I), 1 )
                  I = I + N
               END IF
   80       CONTINUE
C
C           Solve for the Cholesky factor S of P, P = S*S',
C           the continuous-time Lyapunov equation (if DICO = 'C')
C                                      _ _
C                   A*P + P*A'  +  t^2*B*B' = 0,
C
C           or the discrete-time Lyapunov equation (if DICO = 'D')
C                                      _ _
C                   A*P*A' - P  +  t^2*B*B' = 0.
C
C           Workspace:  need   maximum N*(N + 6);
C                              prefer larger.
C
            KTAU = KU + MBBAR*N
            KW   = KTAU + N
C
            CALL SB03OU( DISCR, .TRUE., N, MBBAR, A, LDA, DWORK(KU), N,
     $                   DWORK(KTAU), S, LDS, T, DWORK(KW), LDWORK-KW+1,
     $                   IERR )
            IF( IERR.NE.0 ) THEN
               INFO = 2
               RETURN
            END IF
            SCALEC = SCALEC*T
            WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
         END IF
C
      ELSE
C
C        Solve for the Cholesky factor S of P, P = S*S',
C        the continuous-time Lyapunov equation (if DICO = 'C')
C
C            A*P + P*A' +  scalec^2*B*B' = 0,
C
C        or the discrete-time Lyapunov equation (if DICO = 'D')
C
C            A*P*A' - P +  scalec^2*B*B' = 0.
C
C        Workspace:  need   N*(M+5);
C                           prefer larger.
C
         KU   = 1
         KTAU = KU + N*M
         KW   = KTAU + N
C
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N )
         CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N,
     $                DWORK(KTAU), S, LDS, SCALEC, DWORK(KW),
     $                LDWORK-KW+1, IERR )
         IF( IERR.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
         WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) )
      END IF
C
C     Save optimal workspace.
C
      DWORK(1) = WORK
C
      RETURN
C *** Last line of AB09IY ***
      END


! { dg-do run }
! PR fortran/49010
! MOD/MODULO sign of zero.

! We wish to provide the following guarantees:

! MOD(A, P): The result has the sign of A and a magnitude less than
! that of P.

! MODULO(A, P): The result has the sign of P and a magnitude less than
! that of P.

! Here we test only with constant arguments (evaluated with
! mpfr_fmod), as we don't want to cause failures on targets with a
! crappy libm. But, a target where fmod follows C99 Annex F is
! fine. Also, targets where GCC inline expands fmod (such as x86(-64))
! are also fine.
program mod_sign0_1
  implicit none
  real :: r, t

  r = mod (4., 2.)
  t = sign (1., r)
  if (t < 0.) STOP 1

  r = modulo (4., 2.)
  t = sign (1., r)
  if (t < 0.) STOP 2

  r = mod (-4., 2.)
  t = sign (1., r)
  if (t > 0.) STOP 3

  r = modulo (-4., 2.)
  t = sign (1., r)
  if (t < 0.) STOP 4

  r = mod (4., -2.)
  t = sign (1., r)
  if (t < 0.) STOP 5

  r = modulo (4., -2.)
  t = sign (1., r)
  if (t > 0.) STOP 6

  r = mod (-4., -2.)
  t = sign (1., r)
  if (t > 0.) STOP 7

  r = modulo (-4., -2.)
  t = sign (1., r)
  if (t > 0.) STOP 8

end program mod_sign0_1


module functions_mod
    implicit none

    private
    public :: func

contains

    function simple_func(x) result(f) bind(C)
        use, intrinsic :: iso_c_binding
        implicit none
        real(kind=c_double), value :: x
        real(kind=c_double) :: f

        f = 2.0*x**3
    end function simple_func

    function func(x, params) result(f) bind(C)
        use, intrinsic :: iso_c_binding
        implicit none
        real(kind=c_double), value :: x
        real(kind=c_double), dimension(3) :: params
        real(kind=c_double) :: f

        f = params(1)*x**2 + params(2)*x + params(3)
!        print '(E25.15, A, E25.15)', x, ' -> ', f
    end function func

end module functions_mod


program kaprekar
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, parameter :: nr_digits = 4
    integer, dimension(:), allocatable :: digits
    integer :: number, prev_number, small, large, istat

    number = get_argument()
    allocate(digits(nr_digits), stat=istat)
    if (istat /= 0) then
        write (error_unit, '(A)') 'Error: can not allocate array'
        stop 5
    end if
    prev_number = 0
    do while (number /= prev_number)
        call number2digits(number, digits)
        call sort_digits(digits)
        small = digits2number(digits)
        large = reverse_digits2number(digits)
        prev_number = number
        number = large - small
    end do
    print '(I0)', number

contains

    integer function get_argument() result(number)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        character(len=80) :: buffer
        integer :: istat, first_digit, n, i
        logical :: okay

        if (command_argument_count() /= 1) then
            write (error_unit, '(A)') &
                'Error: expecting a single number as argument'
            stop 1
        end if
        call get_command_argument(1, buffer)
        read (buffer, '(I10)', iostat=istat) number
        if (istat /= 0) then
            write (error_unit, '(A)') &
                'Error: expecting as integer as argument'
            stop 2
        end if
        if (number < 1 .or.  number > 9999) then
            write (error_unit, '(A)') &
                'Error: argument should be between 1 and 9999'
            stop 3
        endif
        okay = .false.
        first_digit = mod(number, 10)
        n = number/10
        do i = 2, 4
            if (first_digit /= mod(n, 10)) then
                okay = .true.
            exit
            end if
            n = n/10
        end do
        if (.not.  okay) then
            write (error_unit, '(A)') &
                'Error: number must have at least two distinct digits'
            stop 4
        end if

    end function get_argument

    subroutine number2digits(number, digits)
        implicit none
        integer, value :: number
        integer, dimension(:), intent(inout) :: digits
        integer :: i

        do i = 1, size(digits)
            digits(i) = mod(number, 10)
            number = number/10
        end do

    end subroutine number2digits

    integer function digits2number(digits) result(number)
        implicit none
        integer, dimension(:), intent(in) :: digits
        integer :: factor, i

        number = 0
        factor = 1
        do i = 1, size(digits)
            number = number + factor*digits(i)
            factor = factor*10
        end do

    end function digits2number

    integer function reverse_digits2number(digits) result(number)
        implicit none
        integer, dimension(:), intent(in) :: digits
        integer :: factor, i

        number = 0
        factor = 1
        do i = size(digits), 1, -1
            number = number + factor*digits(i)
            factor = factor*10
        end do

    end function reverse_digits2number

    subroutine sort_digits(digits)
        implicit none
        integer, dimension(:), intent(inout) :: digits
        integer :: i, j, index, tmp

        do i = 1, size(digits)
            index = i
            do j = i + 1, size(digits)
                if (digits(index) < digits(j)) &
                    index = j
            end do
            tmp = digits(index)
            digits(index) = digits(i)
            digits(i) = tmp
        end do

    end subroutine sort_digits

end program kaprekar


program bit_operations
    use, intrinsic :: iso_fortran_env, only : I4 => INT32
    use :: bitmanip_mod, only : bit_repr
    implicit none
    integer(kind=I4) :: a, pos, length, shift

    a = 0
    print '(A, I0)', 'bit size: ', bit_size(a)
    do pos = 0, 10, 2
        a = ibset(a, pos)
        print '(A, I2, 2A)', 'set ', pos, ': ', bit_repr(a)
    end do
    do pos = 10, 0, -2
        a = ibclr(a, pos)
        print '(A, I2, 2A)', 'set ', pos, ': ', bit_repr(a)
    end do
    a = 170
    print '(2A)', 'original: ', bit_repr(a)
    do pos = 0, 4
        do length = 2, 4
            print '(2(A, I0), 2A)', 'pos: : ', pos, ', len: ',  length, &
                ': ', bit_repr(ibits(a, pos, length))
        end do
    end do
    a = 15
    print '(2A)', 'original: ', bit_repr(a)
    do shift = 1, 5
        print '(2A)', 'shift: ', bit_repr(shiftr(a, shift))
    end do
    a = 15
    print '(2A)', 'original: ', bit_repr(a)
    do shift = 1, 5
        print '(2A)', 'shift: ', bit_repr(shiftl(a, shift))
    end do
end program bit_operations


program array3
implicit none
integer,parameter :: imax =11
real,dimension (imax) :: x
real                  :: average,sum
integer               ::i
print*, "enter","imax", "numbers"

sum =0.0
	do i = 1,imax
		read*, x(i)
			sum = sum + x(i)
	end do
average = sum /imax
print*, "the average is ", average
print*, "the numbers are"
print*,x

end program array3


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!
! Tests subscripted pointer expressions that point to non-contiguous array
! sections.

program main
  integer, pointer :: p1(:), p2(:)
  integer, target :: a(20)
  integer :: expect(8) = [3, 5, 7, 9, 11, 13, 15, 17]
  integer :: j
  a = [(j,j=1,20)]
  p1 => a(::2)
  p2(1:8) => p1(2:9)
  if (all(p2 .eq. expect)) then
    print *, 'PASS'
  else
    print *, 'FAIL'
  endif
end program main


program gemv_test
    use :: util_mod
    implicit none
    integer, parameter :: rows = 3, cols = 2
    integer :: i
    real, dimension(rows, cols) :: A = reshape( [ (real(i), i=1, rows*cols) ], [ rows, cols ])
    real, dimension(cols) :: v = [ 1.0, 2.0 ]
    real, dimension(rows) :: u
    character(len=12) :: fmt_str = '(*(F6.1))'

    call print_matrix(A, 'A', fmt_str)
    call print_vector(v, 'v', fmt_str)
    call sgemv('n', rows, cols, 1.0, A, rows, v, 1, 0.0, u, 1)
    call print_vector(u, 'u', fmt_str)

end program gemv_test


c  File: drSTGrec.[f|for] contains drSTGrec, STGfcn.
      program DRSTGREC
c>> 2001-07-16 DRSTGREC Krogh Added exponent 0 to some constants.
c>> 2001-05-24 DRSTGREC Krogh Minor change for making .f90 version.
c>> 2001-05-22 DRSTGREC Krogh Minor change for making .f90 version.
c>> 1997-07-01 DRSTGREC Krogh Reversed subscripts in B (CLL suggestion)
c>> 1997-06-19 DRSTGREC Krogh Minor changes to get proper C conversion.
c>> 1997-06-18 DRSTGREC CLL Added Bdry and MB to arg list of ?TGREC.
c              Also ZFILL has extended interpretation.
c>> 1996-03-04 DRSTGREC CLL
c>> 1996-02-02 DRSTGREC CLL
c>> 1995-09-26 DRSTGREC CLL Editing for inclusion into MATH77.
c>> 1991-11-20 DRSTGREC CLL  Minor editing. Adding use of ?SORTP.
c     C. L. LAWSON, JPL, 1977 MAR 2, CHANGED APR 7
c     C.L.L., 1979 MAR 3. MINOR CHANGES.
c
c     PORTABLE DEMONSTRATION DRIVER FOR SUBROUTINES THAT
c     CONSTRUCT A TRIANGULAR GRID AND THEN DO LOOK-UP AND INTERPOLATION
c     USING THE GRID.  THE INTERPOLATED SURFACE HAS C1 CONTINUITY.
c     ------------------------------------------------------------------
c  The amount of output by this program is controlled by a set of
c  logical variables.
c
c  PRTMAX  Print summary of max and RMS errors over the rectangular
c          grid.
c  PRTT  Call STGPRG to print the initial X() and Y() data, the
c        pointers in TRIANG() defining the triangular grid, and the
c        pointers in Bdry() identifying the boundary of the triangular
c        grid.
c  PRTR  Print true and computed values and errors at all nodes of the
c        rectangular grid.
c  PRTTPD  Print the true and computed values of partial derivatives,
c          and the errors at all of the initial (x,y) points.
c     ------------------------------------------------------------------
c     THE CALL RELATIONSHIPS ARE AS FOLLOWS..
c
c     DRSTGREC           DEMONSTRATION DRIVER.
c        STGGRD          CONSTRUCT TRIANGULAR GRID
c           ?SORTP       Sorting.   From the JPL Math77 library.
c           STGANG       COMPUTE PSEUDOANGLES
c           ?TRSET       **     THESE FOUR SUBRS ARE USED TO STORE AND
c           STGGET       **     FETCH POINTERS IN THE ARRAY TRIANG()
c           ?TRPUT       **     THAT DEFINES THE TRIANGULAR GRID.
c           ?TRSIZ       **
c           ?TRADJ       TEST AND MODIFY TRIANGULAR GRID
c             ?TRSET
c             STGGET
c             ?TRPUT
c        STGPRG          print DESCRIPTION OF TRIANGULAR GRID
c           STGGET
c        STGFCN          PROVIDE VALUES OF TEST functionS.
c        STGPD           ESTIMATE PARTIAL DERIVATIVES AT GRID POINTS
c           STGGET
c           ?TRMOR       FIND MORE PTS FOR PARTIAL DERIV ESTIMATION.
c              STGGET
c           ?TRLS        WEIGHT,SCALE,STABILIZE,SOLVE FOR LOCAL L.S. FIT
c              ?ROTG     SETUP FOR GIVENS ROTATION. FROM THE BLAS.
c              ?ROT      APPLY GIVENS ROTATION. FROM THE BLAS.
c        STGREC          BUILD RECTANGULAR GRID OF INTERPOLATED VALUES.
c           ?TRFI        Lookup and interpolation in triangular grid.
c              ?TRFND       LOOK-UP IN TRIANGULAR GRID
c                 STGGET
c              ?TRC0        C0 INTERPOLATION IN A TRIANGLE
c              ?TRC1        C1 INTERPOLATION IN A TRIANGLE
c     ------------------------------------------------------------------
c
c     REMARKS ON DIMENSIONS..
c
c          IN TERMS OF THE PARAMETERS MP, MT, MB, MX, AND MY,
c     THE REQUIRED DIMENSIONS ARE..
c     real             ZGRD(MX,MY), DZGRD(MX,MY,2)
c     real             X(MP),Y(MP),Z(MP),DZ(2,MP),W(MP),XYLIM(4)
c     real             DZZ(2),ERRDZ(2)
c     real             DZTRUE(2,MP)
c     integer  IP(MP), TRIANG(MT), Bdry(4,MB)
c
c     (NOTE THAT SOME OF THESE DECLARED VARIABLES ARE ONLY
c      USED IN THIS DEMO DRIVER ITSELF AND ARE NOT ESSENTIAL
c      FOR THE GENERAL USE OF THE SUBROUTINES BEING DEMONSTRATED.)
c
c         MP DENOTES THE MAX NO. OF DATA POINTS TO BE HANDLED.
c          THE MAX NO. OF TRIANGLES CANNOT EXCEED 2*MP.  SINCE WE
c     STORE 6 POINTERS PER TRIANGLE IT FOLLOWS THAT MT CAN BE
c     SET AS         MT = (12*MP)
c          MB MUST BE LARGER BY 1 THAN THE MAX NO. OF BOUNDARY PTS
c     IN ANY SUBSET OF THE GIVEN SET OF (X,Y) DATA.   THE EXPECTED
c     NO. OF BNDRY PTS IN A RANDOM SAMPLE OF PTS FROM A UNIFORM
c     DISTRIBUTION ON DISC IS ABOUT  3.3 * (CUBE ROOT OF MP).
c     TWICE THIS EXPECTED VALUE PROVIDES AN ADEQUATE BOUND FOR
c     MOST CASES.  SETTING MB = MP+1 WOULD BE ABSOLUTELY SAFE
c     BUT LARGER THAN NECESSARY IN MOST CASES.
c          SETTING MB OR MT TOO SMALL WILL BE DETECTED AS ERROR
c     CONDITIONS  BY THE SUBROUTINES.
c          MX AND MY GIVE THE DIMENSIONS OF THE RECTANGULAR GRID ONTO
c     WHICH VALUES WILL BE INTERPOLATED UNDER CONTROL OF STGREC.
c     ------------------------------------------------------------------
c--S replaces "?": DR?TGREC, ?TGGRD, ?TGPRG, ?TGFCN, ?TGPD, ?TGREC
c--&               ?TGGET,   ?TGANG
c     ------------------------------------------------------------------
      integer mb, mp, mt, mx, my
      parameter(mb= 16, mp= 28, mt= 336, mx= 5, my= 5)
      integer Bdry(4,mb), i, INFO(3), IP(mp), j, k, kf, kount
      integer ncont, np, nt, nx, ny, TRIANG(mt), filmod
      real             delx, dely, DZ(2,mp), DZGRD(mx,my,2)
      real             DZTRUE(2,mp), DZZ(2)
      real             err, ERRDZ(2), errm, ERRMDZ(2)
      real             rms, RMSDZ(2), sum1, SUM2(2)
      real             W(mp), X(mp), xx, XYLIM(4),Y(mp), yy
      real             Z(mp), zero, zfill, ZGRD(mx,my), zz
        parameter(zero = 0.0e0)
      logical   PRTMAX, PRTT, PRTR, PRTTPD, skip, WANTPD
      character title*75
      character       line1*56,       line2*19
      data PRTMAX, PRTT,PRTR,PRTTPD/.true., .true., .false., .false./
      data line1, line2/
     * '  ------------------------------------------------------',
     *                             '-------------------'/
      data X /
     *-0.76059E0,-0.02286E0,-0.44790E0, 0.15068E0,-0.87287E0,-0.23390E0,
     * 0.06093E0,-0.84142E0,-0.69173E0,-0.56613E0,-0.42243E0,-0.17249E0,
     *-0.06484E0, 0.48286E0,-0.88784E0, 0.10277E0, 0.69087E0,-0.84292E0,
     * 0.08784E0,-0.95068E0, 0.02496E0, 0.94973E0, 0.04588E0,-0.51667E0,
     *-0.77561E0, 0.90000E0,-0.70830E0,-0.40500E0 /
      data Y /
     *-0.31421E0, 0.75657E0, 0.14321E0, 0.42353E0,-0.62983E0, 0.12326E0,
     * 0.34054E0,-0.55144E0, 0.34158E0,-0.67143E0, 0.43087E0, 0.96081E0,
     *-0.68130E0, 0.12095E0,-0.10663E0, 0.29219E0, 0.31028E0, 0.12934E0,
     * 0.10709E0,-0.42307E0, 0.49895E0, 0.68597E0,-0.78215E0,-0.12362E0,
     *-0.88827E0,-0.60000E0,-0.88620E0, 0.08600E0 /
      data XYLIM / -1.0e0, +1.0e0, -1.0e0, +1.0e0 /
      data np, nx, ny / mp, mx, my /
      data wantpd / .true. /
c     ------------------------------------------------------------------
      write(*,'(a/a/)') ' Program DRSTGREC.  Demo driver for STGREC,',
     * '         STGGRD, STGPD, etc.'
      call STGGRD(X,Y,NP,IP,W,TRIANG,MT,Bdry,MB,NT, INFO)
      if (INFO(1) .NE. 0) then
         write(*,'(a,i5)')
     *      ' Error return from STGGRD. INFO(1) =', INFO(1)
         stop
      endif
      if(PRTT) call STGPRG(X,Y,NP,TRIANG,Bdry,INFO(2),NT)
c
      do 200 KF= 0, 4
         do 20 I=1,NP
               call STGFCN(KF,X(I),Y(I),
     *            title, Z(I),DZTRUE(1,I),DZTRUE(2,I))
   20    continue
         write(*,'(/a,a/a/a,a)')
     *   line1,line2,   title,   line1,line2
         call STGPD(X,Y,Z,DZ,NP, TRIANG, NT, IP)
         if (PRTTPD) then
            write(*,'(/a,a//a,a/41x,a/)')
     *      ' PARTIAL DERIVS ESTIMATED BY STGPD AT THE GIVEN',
     *      ' DATA POINTS',
     *      '    I       X       Y       Z            ',
     *      'DZ1        DZTRUE1    ERR1',
     *      'DZ2        DZTRUE2    ERR2'
            do 50 I=1,NP
              do 40 J=1,2
                 ERRDZ(J) = DZ(J,I) - DZTRUE(J,I)
   40         continue
              write(*,'(1X,I4,3F8.4,2F15.6,E10.2/29x,2F15.6,E10.2)')
     *           I,X(I),Y(I),Z(I),(DZ(J,I), DZTRUE(J,I),
     *           ERRDZ(J), J=1,2)
   50       continue
         end if
c
         do 110 NCONT = 0, 1
         do 100 filmod = 0,1
              if(filmod .eq. 0) then
                 zfill = zero
              else
                 zfill = 999.0e0
              endif
         call STGREC(X,Y,Z,DZ,NP,TRIANG,NT, Bdry, MB, XYLIM,NX,NY,
     *                  ZFILL,ZGRD,MX,MY, NCONT, WANTPD,DZGRD)
c
         if (PRTR .or. PRTMAX) then
            write(*,'(//5x,a,i1,a)')
     *       ' Using a C',ncont,' interpolation method.'
            if(zfill .eq. zero) then
                 write(*,'(5x,a/5x,a)')
     *       ' Assigning EXTRAPOLATED VALUES to points outside',
     *       ' the convex hull of the given data.'
              else
                 write(*,'(5x,a,f7.1,a/5x,a)')
     *       ' Assigning the value ',ZFILL,' to points outside',
     *       ' the convex hull of the given data.'
            endif

            if(PRTR) then
            write(*,'(/5x,a/7x,a//a,a/20x,a/20x,a/)')
     *       ' VALUES AND PARTIAL DERIVATIVES INTERPOLATED AT',
     *       ' LATTICE POINTS OF A RECTANGULAR GRID.',
     *       '   I   J     X     Y',
     *       '    Z_INTERP     Z_TRUE     Z_ERR',
     *       '  DZ1_INTERP   DZ1_TRUE   DZ1_ERR',
     *       '  DZ2_INTERP   DZ2_TRUE   DZ2_ERR'
            endif

            DELX =  (XYLIM(2)-XYLIM(1))/(NX-1)
            DELY =  (XYLIM(4)-XYLIM(3))/(NY-1)
            XX = XYLIM(1)
            SUM1 = 0.0e0
            SUM2(1) = 0.0e0
            SUM2(2) = 0.0e0
            KOUNT = 0
            ERRM = 0.0e0
            ERRMDZ(1) = 0.0e0
            ERRMDZ(2) = 0.0e0
            SKIP = .true.
            do 80 I=1,NX
               YY = XYLIM(3)
               do 70 J=1,NY
                  call STGFCN(KF,  XX,YY, title, ZZ, DZZ(1), DZZ(2) )
                  if (ZGRD(I,J) .NE. ZFILL) then
                     ERR = ZGRD(I,J) - ZZ
                     if (ERRM .LT. ABS(ERR)) ERRM = ABS(ERR)
                     SUM1 = SUM1 + ERR**2
                     KOUNT = KOUNT + 1
                     do 60 K=1,2
                        ERRDZ(K)= DZGRD(I,J,K) - DZZ(K)
                        if (ERRMDZ(K) .LT. ABS(ERRDZ(K)))
     *                        ERRMDZ(K) = ABS(ERRDZ(K))
                        SUM2(K) = SUM2(K) + ERRDZ(K)**2
   60                continue
                     if(PRTR) then
                     write(*,
     *  '(1X,2I4,2F6.2,2F11.6,E10.2/21x,2F11.6,E10.2/21x,2F11.6,E10.2)')
     *                  I,J,XX,YY,
     *                  ZGRD(I,J), zz, err,
     *                  DZGRD(I,J,1), DZZ(1), errdz(1),
     *                  DZGRD(I,J,2), DZZ(2), errdz(2)
                     endif
                     skip = .true.
                  else
                     if(PRTR) then
                        if(skip) then
                           write(*,*) ' '
                           skip = .false.
                        endif
                     endif
                  end if
                     YY = YY+DELY
   70          continue
               XX = XX + DELX
   80       continue
            RMS = SQRT(SUM1 / KOUNT)
            do 90 K=1,2
               RMSDZ(K) = SQRT(SUM2(K) / KOUNT)
   90       continue
            if(PRTMAX) then
            write(*, '(/9x,a43/1x,3g17.6//9x,a43/1x,3g17.6/)')
     *        'MAX ERR Z       MAX ERR ZX       MAX ERR ZY',
     *         errm, errmdz(1), errmdz(2),
     *        'RMS ERR Z       RMS ERR ZX       RMS ERR ZY',
     *         RMS, rmsdz(1), rmsdz(2)
            endif
         end if
  100    continue
  110    continue
  200 continue
      end
c     ==================================================================
      subroutine STGFCN  (KF,X,Y, TITLE, Z,ZX,ZY)
c>> 1995-09-26 CLL Editing for inclusion into MATH77.
c     C.L.Lawson, JPL, 1976 Dec 10.  Edited comments 1979 Mar 3.
c     This subr evaluates a function and its first partial derivs as
c     selected by KF.  KF can be from 0 to 4.
c     Input is KF, X, and Y.  Output is TITLE, Z, ZX, and ZY.
c     ------------------------------------------------------------------
c--S replaces "?": ?TRANG
c     ------------------------------------------------------------------
      integer KF
      real             X,Y,Z,ZX,ZY
      character title*75
      character title1(0:4)*56, title2(0:4)*19
      integer i
      data (title1(i),title2(i),i=0,4) /
     * '  CONSTANT FUNCTION     Z = 2', ' ',
     * '  LINEAR FUNCTION       Z = ( 1 + 2*X + 3*Y ) / 6', ' ',
     * '  QUADRATIC FUNCTION    Z = ( -1 + 2*X - 3*Y + 4*X**2 - ',
     *                             'X*Y + 9*Y**2 ) / 10',
     * '  CUBIC FUNCTION    Z = ( 9*X**3 - 2*(X**2)*Y + 3*X*Y**2',
     *                             ' - 4 * Y**3 ) / 10',
     * '  EXPONENTIAL FUNCTION   Z = EXP( -2 * (X**2 + Y**2) )', ' '/
c     ------------------------------------------------------------------
      title = title1(kf) // title2(kf)
       if(kf .eq. 0) then
c                                  KF=0  CONSTANT FCN.
         Z=2.0e0
         ZX=0.0e0
         ZY=0.0e0
       elseif(kf .eq. 1) then
c                                  KF=1  LINEAR FCN.
         Z=(1.0e0 + 2.0e0*X + 3.0e0*Y) / 6.0e0
         ZX=2.0e0/6.0e0
         ZY=3.0e0/6.0e0
       elseif(kf .eq. 2) then
c                                  KF=2  QUADRATIC FCN.
         Z=(-1.0e0 + 2.0e0*X - 3.0e0*Y +4.0e0*X**2 -X*Y + 9.0e0*Y**2)*
     *       0.1e0
         ZX =(2.0e0 + 8.0e0*X -Y)* 0.1e0
         ZY =(-3.0e0 -X + 18.0e0*Y)* 0.1e0
       elseif(kf .eq. 3) then
c                                  KF=3  CUBIC FCN.
         Z=(9.0e0*X**3 - 2.0e0*(X**2)*Y + 3.0e0*X*Y**2 - 4.0e0*Y**3)*
     *       0.1e0
         ZX=(27.0e0*X**2 - 4.0e0*X*Y + 3.0e0*Y**2)* 0.1e0
         ZY=(-2.0e0*X**2 + 6.0e0*X*Y - 12.0e0*Y**2)* 0.1e0
       elseif(kf .eq. 4) then
c                                  KF=4  EXPONENTIAL FCN.
         Z=  EXP(-(X**2 + Y**2) * 2.0e0)
c
c              NOTE THAT THE INFLECTION POINT OF THIS FCN IN ANY
c              RADIAL DIRECTION FROM THE ORIGIN IS AT R = .5
c
         ZX= -4.0e0*X*Z
         ZY= -4.0e0*Y*Z
       endif
      return
      end


!! This would generally be supplied by the user

SUBROUTINE  rpn2qad_flux(meqn,maux,idir,iface,q,auxvec, &
                  auxvec_edge,flux)

    IMPLICIT NONE

    INTEGER meqn,maux,idir, iface
    DOUBLE PRECISION q(meqn), flux(meqn)
    DOUBLE PRECISION auxvec(maux), auxvec_edge(maux)

    DOUBLE PRECISION urot
    INTEGER m

!!  # Get cell-centered velocity projected to face
!!  # 'iface' (in 0,1,2,3)
    urot = auxvec(2+iface)

!!  #  f(q) = (n dot u)*q
    DO m = 1,meqn
!!      # Don't multiply by edgelength (scaling is done elsewhere)
        flux(m) = urot*q(m)
    ENDDO

END SUBROUTINE rpn2qad_flux

SUBROUTINE  rpn2qad_zero(meqn,maux, idir, iface, q, &
                         auxvec, auxvec_edge,flux)
    IMPLICIT NONE

    INTEGER meqn,maux,idir, iface
    DOUBLE PRECISION q(meqn), flux(meqn)
    DOUBLE PRECISION auxvec(maux), auxvec_edge(maux)
    INTEGER m

    DO m = 1,meqn
        flux(m) = 0
    END DO

END  SUBROUTINE RPN2QAD_ZERO


!
!          Example for CottonCandy
!
!              Author: XCell(Shin Hyeon Kyu)
!          Date: 2021.08.27
!

program example_01
    use CottonCandy
    Open(19, FILE="example_01.dat", status="NEW")
    call Integral(f1, 19, 10000, 5)  ! Integral
    Close(19)

    contains
    function f1(x) result(y)
        Real :: x, y
        y = x ** x
    end function f1
end program example_01


*> \brief \b SLAPY2 returns sqrt(x2+y2).
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLAPY2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       REAL             FUNCTION SLAPY2( X, Y )
*
*       .. Scalar Arguments ..
*       REAL               X, Y
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*> overflow.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] X
*> \verbatim
*>          X is REAL
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is REAL
*>          X and Y specify the values x and y.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date June 2017
*
*> \ingroup OTHERauxiliary
*
*  =====================================================================
      REAL             FUNCTION SLAPY2( X, Y )
*
*  -- LAPACK auxiliary routine (version 3.7.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     June 2017
*
*     .. Scalar Arguments ..
      REAL               X, Y
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
      REAL               ONE
      PARAMETER          ( ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      REAL               W, XABS, YABS, Z
      LOGICAL            X_IS_NAN, Y_IS_NAN
*     ..
*     .. External Functions ..
      LOGICAL            SISNAN
      EXTERNAL           SISNAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     ..
*     .. Executable Statements ..
*
      X_IS_NAN = SISNAN( X )
      Y_IS_NAN = SISNAN( Y )
      IF ( X_IS_NAN ) SLAPY2 = X
      IF ( Y_IS_NAN ) SLAPY2 = Y
*
      IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN
         XABS = ABS( X )
         YABS = ABS( Y )
         W = MAX( XABS, YABS )
         Z = MIN( XABS, YABS )
         IF( Z.EQ.ZERO ) THEN
            SLAPY2 = W
         ELSE
            SLAPY2 = W*SQRT( ONE+( Z / W )**2 )
         END IF
      END IF
      RETURN
*
*     End of SLAPY2
*
      END


      FUNCTION erf(xx)

      REAL*8 erf,xx
      REAL x
CU    USES gammp
      REAL gammp
      x=xx
      if(x.lt.0.)then
        erf=-gammp(.5,x**2)
      else
        erf=gammp(.5,x**2)
      endif
      return
      END

      FUNCTION gammp(a,x)

      REAL a,gammp,x
CU    USES gcf,gser
      REAL gammcf,gamser,gln
      if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammp'
      if(x.lt.a+1.)then
        call gser(gamser,a,x,gln)
        gammp=gamser
      else
        call gcf(gammcf,a,x,gln)
        gammp=1.-gammcf
      endif
      return
      END

      FUNCTION gammln(xx)

      REAL gammln,xx
      INTEGER j
      DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      do 11 j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
11    continue
      gammln=tmp+log(stp*ser/x)
      return
      END

      SUBROUTINE gcf(gammcf,a,x,gln)

      INTEGER ITMAX
      REAL a,gammcf,gln,x,EPS,FPMIN
      PARAMETER (ITMAX=100,EPS=3.e-7,FPMIN=1.e-30)
CU    USES gammln
      INTEGER i
      REAL an,b,c,d,del,h,gammln
      gln=gammln(a)
      b=x+1.-a
      c=1./FPMIN
      d=1./b
      h=d
      do 11 i=1,ITMAX
        an=-i*(i-a)
        b=b+2.
        d=an*d+b
        if(abs(d).lt.FPMIN)d=FPMIN
        c=b+an/c
        if(abs(c).lt.FPMIN)c=FPMIN
        d=1./d
        del=d*c
        h=h*del
        if(abs(del-1.).lt.EPS)goto 1
11    continue
      pause 'a too large, ITMAX too small in gcf'
1     gammcf=exp(-x+a*log(x)-gln)*h
      return
      END

      SUBROUTINE gser(gamser,a,x,gln)

      INTEGER ITMAX
      REAL a,gamser,gln,x,EPS
      PARAMETER (ITMAX=100,EPS=3.e-7)
CU    USES gammln
      INTEGER n
      REAL ap,del,sum,gammln
      gln=gammln(a)
      if(x.le.0.)then
        if(x.lt.0.)pause 'x < 0 in gser'
        gamser=0.
        return
      endif
      ap=a
      sum=1./a
      del=sum
      do 11 n=1,ITMAX
        ap=ap+1.
        del=del*x/ap
        sum=sum+del
        if(abs(del).lt.abs(sum)*EPS)goto 1
11    continue
      pause 'a too large, ITMAX too small in gser'
1     gamser=sum*exp(-x+a*log(x)-gln)
      return
      END

C  (C) Copr. 1986-92 Numerical Recipes Software 5&40.


! Recursive Fortran 95 quicksort routine
! sorts real numbers into ascending numerical order
! Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03
! Based on algorithm from Cormen et al., Introduction to Algorithms,
! 1997 printing

! Made F conformant by Walt Brainerd
!
!Updated 2016 Tue
!The RealQsort now uses real*8 instead of real.
!
! Dec 2016 KRA, added integer version
!

module mQuickSort

implicit none
public :: RealQsortC
private :: RealPartition
public :: IntQsortC
private :: IntPartition

interface  IntPartition
  module procedure IntPartition_real,IntPartition_complex,IntPartition_int
end interface
interface IntQsortC
  module procedure IntQsortC_complex, IntQsortC_real, IntQsortC_int
end interface

contains
recursive subroutine RealQsortC(A)
  real*8, intent(in out), dimension(:) :: A
  integer :: iq

  if(size(A) > 1) then
     call RealPartition(A, iq)
     call RealQsortC(A(:iq-1))
     call RealQsortC(A(iq:))
  endif
end subroutine RealQsortC

subroutine RealPartition(A, marker)
  real*8, intent(in out), dimension(:) :: A
  integer, intent(out) :: marker
  integer :: i, j
  real*8 :: temp
  real*8 :: x      ! pivot point
  x = A(1)
  i= 0
  j= size(A) + 1

  do
     j = j-1
     do
        if (A(j) <= x) exit
        j = j-1
     end do
     i = i+1
     do
        if (A(i) >= x) exit
        i = i+1
     end do
     if (i < j) then
        ! exchange A(i) and A(j)
        temp = A(i)
        A(i) = A(j)
        A(j) = temp
     elseif (i == j) then
        marker = i+1
        return
     else
        marker = i
        return
     endif
  end do

end subroutine RealPartition

recursive subroutine IntQsortC_int(SortInts,Secondarys)
  integer, intent(inout), dimension(:) :: SortInts
  integer, intent(inout), dimension(:) :: Secondarys
  integer                              :: iq

  if(size(SortInts) > 1) then
     call IntPartition(SortInts,Secondarys, iq)
     call IntQsortC(SortInts(:iq-1),Secondarys(:iq-1))
     call IntQsortC(SortInts(iq:),Secondarys(iq:))
  endif
end subroutine IntQsortC_int
recursive subroutine IntQsortC_real(SortInts,Secondarys)
  integer, intent(inout), dimension(:) :: SortInts
  real*8, intent(inout), dimension(:) :: Secondarys
  integer                              :: iq

  if(size(SortInts) > 1) then
     call IntPartition(SortInts,Secondarys, iq)
     call IntQsortC(SortInts(:iq-1),Secondarys(:iq-1))
     call IntQsortC(SortInts(iq:),Secondarys(iq:))
  endif
end subroutine IntQsortC_real

recursive subroutine IntQsortC_complex(SortInts,Secondarys)
  integer, intent(inout), dimension(:) :: SortInts
  complex*16, intent(inout), dimension(:) :: Secondarys
  integer                              :: iq

  if(size(SortInts) > 1) then
     call IntPartition(SortInts,Secondarys, iq)
     call IntQsortC(SortInts(:iq-1),Secondarys(:iq-1))
     call IntQsortC(SortInts(iq:),Secondarys(iq:))
  endif
end subroutine IntQsortC_complex

subroutine IntPartition_int(SortInts, Secondarys,marker)
  integer, intent(inout), dimension(:) :: SortInts
  integer, intent(inout), dimension(:)  :: Secondarys
  integer, intent(out) :: marker
  integer :: i, j
  integer :: temp
  real*8  :: rtemp
  integer :: x      ! pivot point
  x = SortInts(1)
  i= 0
  j= size(SortInts) + 1
  do
     j = j-1
     do
        if (SortInts(j) <= x) exit
        j = j-1
     end do
     i = i+1
     do
        if (SortInts(i) >= x) exit
        i = i+1
     end do
     if (i < j) then
        ! exchange A(i) and A(j)
        temp = SortInts(i)
        SortInts(i) = SortInts(j)
        SortInts(j) = temp
        rtemp=Secondarys(i)
        Secondarys(i)=Secondarys(j)
        Secondarys(j)=rtemp
     elseif (i == j) then
        marker = i+1
        return
     else
        marker = i
        return
     endif
  end do

end subroutine IntPartition_int
subroutine IntPartition_real(SortInts, Secondarys,marker)
  integer, intent(inout), dimension(:) :: SortInts
  real*8, intent(inout), dimension(:)  :: Secondarys
  integer, intent(out) :: marker
  integer :: i, j
  integer :: temp
  real*8  :: rtemp
  integer :: x      ! pivot point
  x = SortInts(1)
  i= 0
  j= size(SortInts) + 1
  do
     j = j-1
     do
        if (SortInts(j) <= x) exit
        j = j-1
     end do
     i = i+1
     do
        if (SortInts(i) >= x) exit
        i = i+1
     end do
     if (i < j) then
        ! exchange A(i) and A(j)
        temp = SortInts(i)
        SortInts(i) = SortInts(j)
        SortInts(j) = temp
        rtemp=Secondarys(i)
        Secondarys(i)=Secondarys(j)
        Secondarys(j)=rtemp
     elseif (i == j) then
        marker = i+1
        return
     else
        marker = i
        return
     endif
  end do

end subroutine IntPartition_real

subroutine IntPartition_complex(SortInts, Secondarys,marker)
  integer, intent(inout), dimension(:) :: SortInts
  complex*16, intent(inout), dimension(:)  :: Secondarys
  integer, intent(out) :: marker
  integer :: i, j
  integer :: temp
  complex*16  :: rtemp
  integer :: x      ! pivot point
  x = SortInts(1)
  i= 0
  j= size(SortInts) + 1
  do
     j = j-1
     do
        if (SortInts(j) <= x) exit
        j = j-1
     end do
     i = i+1
     do
        if (SortInts(i) >= x) exit
        i = i+1
     end do
     if (i < j) then
        ! exchange A(i) and A(j)
        temp = SortInts(i)
        SortInts(i) = SortInts(j)
        SortInts(j) = temp
        rtemp=Secondarys(i)
        Secondarys(i)=Secondarys(j)
        Secondarys(j)=rtemp
     elseif (i == j) then
        marker = i+1
        return
     else
        marker = i
        return
     endif
  end do

end subroutine IntPartition_complex

end module mQuickSort


module intrinic_mass
  use numeric_kinds
  implicit none
  private

  private :: intrin_spher_grid_func, intrin_spher_grid

  public ::  intrin_spher,intrin_radii

  real (kind=dp),private, dimension(6) :: intrin_spher_grid_func_global
  character (len=512), public :: orblib_filename
contains

  function intrin_spher_grid_func(dimen,coordinates)  result(answ)
    integer (kind=i4b), intent(in):: dimen
    real (kind=dp), intent (in), dimension(2) :: coordinates
    real (kind=dp) :: answ,c

    real (kind=dp) :: sth, cth
    real (kind=dp) :: sph, cph
    real (kind=dp) :: P ,Q,sigma,r0,r1,rho0

    real (kind=dp) :: angular_part,res,term1,term2,rad1,rad2

    ! These come from the Global parameter
    P      = intrin_spher_grid_func_global(1)
    Q      = intrin_spher_grid_func_global(2)
    sigma  = intrin_spher_grid_func_global(3)
    r0     = intrin_spher_grid_func_global(4)
    r1     = intrin_spher_grid_func_global(5)
    rho0   = intrin_spher_grid_func_global(6)

    sth=sin(coordinates(1))
    cth=cos(coordinates(1))
    sph=sin(coordinates(2))
    cph=cos(coordinates(2))

    c=sqrt(2.)*sigma/sqrt(  (cph**2. + (sph/p)**2. )*sth*sth + (cth/q)**2.)

    term1 =  r0 * exp(-(r0/c)**2) - 0.5*c*sqrt(pi_d)*derf( r0/c)
    term2 =  r1 * exp(-(r1/c)**2) - 0.5*c*sqrt(pi_d)*derf( r1/c)

    answ = 0.5 * rho0 *c * c * ( term1 - term2 ) * sth

    ! the orbit library folds the 8 symmetries into one octant:
    answ = answ *8.0_dp

  end function intrin_spher_grid_func

!!! calculate multi-dimensional integrals !!!
  subroutine intrin_spher_grid(low,up,res)
    integer (kind=i4b) ,parameter:: dim = 2
    real (kind=dp), intent(in), dimension(dim) :: low,up
    interface
       function integrand(dimen,coordinates)  result(answ)
         use numeric_kinds
         implicit none
         integer (kind=i4b), intent(in):: dimen
         real (kind=dp), intent (in), dimension(dimen) :: coordinates
         real (kind=dp) :: answ
       end function integrand
    end interface
    real (kind=dp), intent(out) :: res
    real (kind=dp), dimension(dim) :: lowL,upL
    logical :: diffcoord
    integer (kind=i4b) :: ii, intgsign
    real (kind=dp) :: dum
    ! definitions that are required for the integrator
    integer (kind=i4b) :: minpts,maxpts,ifail
    integer (kind=i4b) ::lenwrk
    real (kind=dp):: acc,eps
    real (kind=dp), dimension(:), allocatable:: wrkstr
    !
    minpts=1
    maxpts=100000*dim
    lenwrk=(dim+2)*(1+maxpts/(2**dim+2*dim*dim+2*dim+1))
    ifail=1
    eps = 1.0e-8
    allocate(wrkstr(lenwrk))
    ! check integration limits
    lowL=low
    upL=up
    diffcoord=.true.
    intgsign=1
    do ii=1,dim
       if(lowL(ii) == upL(ii)) then
          print*,"lower and upper limit are equal"
          diffcoord=.false.
       end if
       if(lowL(ii)>upL(ii)) then
          print*,"changing order of integration"
          dum=lowL(ii)
          lowL(ii)=upL(ii)
          upL(ii)=dum
          intgsign=-intgsign
       end if
    end do
    if(diffcoord) then
       call d01fcf(dim,lowL,upL,minpts,maxpts,intrin_spher_grid_func,eps,acc,&
            lenwrk,wrkstr,res,ifail)
       res=intgsign*res
    else
       res=0.0e0
    end if
    if (ifail /= 0 ) print*,ifail,res,acc
    if (ifail /= 0 .and. ifail /= 2) stop "integrator failed"
  end subroutine intrin_spher_grid

  subroutine intrin_spher()
    use initial_parameters , only : totalmass,ngauss_mge,qobs
    use triaxpotent        , only : pintr, qintr,sigintr_km,dens
    real (kind=dp),dimension(:),allocatable :: quad_lr
    real (kind=dp),dimension(:),allocatable  :: quad_lth
    real (kind=dp),dimension(:),allocatable  :: quad_lph
    real (kind=dp),dimension(:,:,:),allocatable  :: quad_grid
    real (kind=dp),dimension(2) :: low,up
    integer (kind=i4b) :: i,j,k,l,quad_nr,quad_nth,quad_nph,quad_mom
    integer (kind=i4b) :: norbits,ni1,ni2,ni3,ndith
    character (len=512) :: mass_qgrid_filename
    real (kind=dp) :: res

    open (unit=27,file=orblib_filename,action="read", &
         status="old",form="unformatted",position="rewind")
    read (unit=27) norbits,ni1,ni2,ni3,ndith
    read (unit=27) quad_mom,quad_nph,quad_nth,quad_nr

    print*, quad_mom,quad_nr, quad_nth,quad_nph
    ! remember that N bins have N+1 boundaries
    allocate (quad_grid(quad_nph,quad_nth,quad_nr))
    allocate (quad_lr (quad_nr +1))
    allocate (quad_lth(quad_nth+1))
    allocate (quad_lph(quad_nph+1))

    read (unit=27) quad_lr (:)
    read (unit=27) quad_lth(:)
    read (unit=27) quad_lph(:)
    close(unit=27)

    print*,quad_lth
    print*,quad_lph

    quad_grid(:,:,:)=0.0_dp

    do i=1,quad_nr
       do j=1,quad_nth
          do k=1,quad_nph
             do l=1,ngauss_mge
                intrin_spher_grid_func_global(1) = pintr(l)      ! P
                intrin_spher_grid_func_global(2) = qintr(l)      ! Q
                intrin_spher_grid_func_global(3) = sigintr_km(l) ! sigma
                intrin_spher_grid_func_global(4) = quad_lr(i)    ! r0
                intrin_spher_grid_func_global(5) = quad_lr(i+1)  ! r1
                intrin_spher_grid_func_global(6) = dens(l)       ! rho0
                low    = (/ quad_lth(j  ),quad_lph(k  ) /)
                up     = (/ quad_lth(j+1),quad_lph(k+1) /)

                call intrin_spher_grid(low,up,res)

                quad_grid(k,j,i)=quad_grid(k,j,i)+res
             end do
          end do
       end do
    end do

    print*,"procent of the Mass inside the projected grid"
    print*,sum(quad_grid(:,:,:))/totalmass*100.0_dp

    quad_grid(:,:,:) = quad_grid(:,:,:)/totalmass

    print*,"Give the filename of the output mass_qgrid file"
    read (unit=*, fmt="(a512)"), mass_qgrid_filename
    print*," Writing ", mass_qgrid_filename
    open (unit=28,file=mass_qgrid_filename,action="write", &
         status="new")
    write (unit=28,fmt=*) size(quad_lph)-1,size(quad_lth)-1,size(quad_lr)-1
    write (unit=28,fmt=*) quad_grid(:,:,:)
    close (unit=28)

  end subroutine intrin_spher

  subroutine intrin_radii()
    use initial_parameters , only : totalmass,ngauss_mge,qobs, &
             rlogmin,rlogmax,nener,orbit_dithering
    use triaxpotent        , only : pintr, qintr,sigintr_km, &
                              dens
    real (kind=dp),dimension(nener/orbit_dithering +1) :: quad_lr
    real (kind=dp),dimension(2)  :: quad_lth
    real (kind=dp),dimension(2)  :: quad_lph
    real (kind=dp),dimension(10000) :: radmass
    real (kind=dp),dimension(2) :: low,up
    integer (kind=i4b) :: i,j,k,l,quad_nr,quad_nth,quad_nph
    integer (kind=i4b) :: norbits,ni1,ni2,ni3,ndith,nr
    character (len=512) :: mass_radmass_filename
    real (kind=dp) :: res

    nr=nener/orbit_dithering
    if (nr > size(radmass) ) stop 'increase arraysize radmass'
    print*,nr
    do i=1,nr
       quad_lr(i)=10.0_dp**(rLogMin + (rLogMax-rLogMin) * (i-2.0)/(nr-1.0))
    end do
    quad_lr(1)=0.0

    quad_lr(nr+1)=10.0_dp**rlogmax*100.0

    quad_lth(1)=0.00
    quad_lph(1)=0.00

    quad_lth(2)=pio2_d
    quad_lph(2)=pio2_d

    do i=1,nr
       do j=1,1
          do k=1,1
             do l=1,ngauss_mge
                intrin_spher_grid_func_global(1) = pintr(l)      ! P
                intrin_spher_grid_func_global(2) = qintr(l)      ! Q
                intrin_spher_grid_func_global(3) = sigintr_km(l) ! sigma
                intrin_spher_grid_func_global(4) = quad_lr(i)    ! r0
                intrin_spher_grid_func_global(5) = quad_lr(i+1)  ! r1
                intrin_spher_grid_func_global(6) = dens(l)       ! rho0
                low    = (/ quad_lth(j  ),quad_lph(k  ) /)
                up     = (/ quad_lth(j+1),quad_lph(k+1) /)

                call intrin_spher_grid(low,up,res)
                print*,i,l,res/totalmass*100.0_dp
                radmass(i)=radmass(i)+res
             end do
          end do
       end do
    end do

    print*,"procent of the Mass inside the radial shells"
    print*,sum(radmass(:))/totalmass*100.0_dp
    radmass(:) = radmass(:)/totalmass
    print*,"radmass"
    print*,radmass(1:nener/orbit_dithering)

    print*,"Give the filename of the output mass file"
    read (unit=*, fmt="(a512)"), mass_radmass_filename
    print*," Writing ", mass_radmass_filename
    open (unit=28,file=mass_radmass_filename,action="write", &
         status="new")
    write (unit=28,fmt=*) nener/orbit_dithering
    write (unit=28,fmt=*) radmass(1:nener/orbit_dithering )
    close (unit=28)

  end subroutine intrin_radii

end module intrinic_mass

program triaxmass
  use intrinic_mass
  use initial_parameters
  use triaxpotent
  use numeric_kinds
  implicit none

  call iniparam()

  print*,"Give the filename of the orbit library"
  read (unit=*, fmt="(a512)"), orblib_filename

  call tp_setup()

  call intrin_radii()
  call intrin_spher()

 end program Triaxmass


subroutine rad_simple_smoke

!	Simple Interactive Radiation for Smoke-cloud GCSS WG1 case

use vars
use params
use rad, only: qrad
implicit none

real lwp(nx,ny), fr(nx,ny), f0, xk, fr1, dtrad, coef, coef1
integer i,j,k

if(.not.dolongwave) return

f0 = 60 ! W/m2
xk = 20.

fr(:,:) = f0
lwp(:,:) = 0.
radlwdn(:) =0.
radqrlw(:) =0.

radlwdn(nz) = f0 * nx*ny

do k = nzm,1,-1
  coef1 = rho(k)*dz*adz(k)
  coef = 1./(coef1 * cp)
  do j=1,ny
  do i=1,nx
    lwp(i,j) = lwp(i,j) + qv(i,j,k)*coef1
    fr1 = f0 * exp(-xk * lwp(i,j))
    dtrad = -(fr(i,j) - fr1) * coef
    fr(i,j) = fr1
    t(i,j,k) = t(i,j,k) + dtrad * dtn
    radlwdn(k) = radlwdn(k) + fr1
    radqrlw(k) = radqrlw(k) + dtrad
    qrad(i,j,k) = dtrad
  end do
  end do
end do

end


      SUBROUTINE DEFORM(IPAIR,ECC0,ECC)
*
*
*       Deformation of elliptic orbit.
*       ------------------------------
*
      INCLUDE 'common6.h'
*
*
*       Evaluate square regularized velocity.
      V20 = 0.0
      DO 10 K = 1,4
          V20 = V20 + UDOT(K,IPAIR)**2
   10 CONTINUE
*
*       Form KS coordinate & velocity scaling factors at peri or apocentre.
      I = N + IPAIR
      SEMI = -0.5*BODY(I)/H(IPAIR)
      IF (R(IPAIR).LT.SEMI) THEN
          EFAC = (1.0 - ECC)/(1.0 - ECC0)
          RNEW = SEMI*(1.0 - ECC)
      ELSE
          EFAC = (1.0 + ECC)/(1.0 + ECC0)
          RNEW = SEMI*(1.0 + ECC)
          RNEW = EFAC*R(IPAIR)
      END IF
      C1 = SQRT(EFAC)
      V2 = 0.5*(BODY(I) + H(IPAIR)*RNEW)
      IF(V2.LE.0.D0)THEN
         C2 = 1.0D-06
      ELSE
         C2 = SQRT(V2/V20)
      ENDIF
*
*       Re-scale KS variables at constant energy to new eccentricity (ECC).
      R(IPAIR) = 0.0D0
*       Retain sign of radial velocity for unperturbed KS (apo or peri).
      TDOT2(IPAIR) = 0.0D0
      DO 20 K = 1,4
          U(K,IPAIR) = C1*U(K,IPAIR)
          UDOT(K,IPAIR) = C2*UDOT(K,IPAIR)
          U0(K,IPAIR) = U(K,IPAIR)
          R(IPAIR) = R(IPAIR) + U(K,IPAIR)**2
          TDOT2(IPAIR) = TDOT2(IPAIR) + 2.0*U(K,IPAIR)*UDOT(K,IPAIR)
   20 CONTINUE
*
*       Re-initialize KS polynomials for perturbed motion.
      T0(2*IPAIR-1) = TIME
      IF (LIST(1,2*IPAIR-1).GT.0) THEN
          CALL RESOLV(IPAIR,1)
          CALL KSPOLY(IPAIR,1)
      ELSE
*       Determine new interval for unperturbed motion (>= TK).
          TK = TWOPI*SEMI*SQRT(SEMI/BODY(I))
          CALL TPERT(IPAIR,GMIN,DT)
*       Adopt c.m. step instead if integer argument exceeds 10**9.
          IF (DT.LT.2.0E+09*TK) THEN
              K = 1 + INT(0.5D0*DT/TK)
*       Restrict Kepler period to c.m. step (case of very wide orbit).
              STEP(2*IPAIR-1) = FLOAT(K)*MIN(TK,STEP(I))
          ELSE
              STEP(2*IPAIR-1) = STEP(I)
          END IF
      END IF
*
      RETURN
*
      END


module eventrate
    use OMP_LIB
    use quadrature
    use constants
    use crosssection
    use distributions
    use main

    implicit none
    real(kind=8) :: qglobal(128)
    real(kind=8) :: ve, v0, vesc
    contains

    function deventrate(q)

        implicit none
        real(kind=8) :: dEventRate
        real(kind=8) :: q

        real(kind=8) :: mchi, muT, mnuc
        real(kind=8) :: Nt
        real(kind=8) :: rhochi

        integer :: ind, tid
        real(kind=8) :: vmin, vmax
        real(kind=8) :: relerror

        tid = 1
        ! Don't delete the following line; it's an openMP command, not a comment.
        !$  tid = omp_get_thread_num() + 1
        qglobal(tid) = q

        Mchi = wimp%mass
        Mnuc = nuc_target%mass * mN
        muT = Mchi * Mnuc / (Mchi + Mnuc)
        ve = vearth * kilometerpersecond
        v0 = vscale * kilometerpersecond
        vesc = vescape * kilometerpersecond
        Nt = nuc_target%Nt
        rhochi = wimp%localdensity / centimeter**3d0
        vmin = q/(2d0*muT)
        relerror = quadrature_relerr
        vmax = vesc + ve
        !if (vmin > vmax) then
        !    deventrate = 0d0
        !    return
        !end if

        select case(quadrature_type)
          case(1)
            call gaus8_threadsafe(spectraintegrand1d, vmin, vmax, &
                relerror, deventrate, ind, tid )
          case(2)
            deventrate = gaussquad(spectraintegrand1d, gaussorder, vmin, vmax, tid)
          case default
            stop "Invalid quadrature option."
        end select

        dEventRate = ntscale * kilogramday * Nt * (rhochi/Mchi) &
            * dEventRate

    end function deventrate

    function spectraintegrand1d(vv, tid)
        ! The purpose of this function is to create a callable func for the
        ! adaptive integral routine. Other functions in this program use
        ! (the good practice of) explicit data dependency. An exception
        ! was made for this fuction for compatibility with the adaptive
        ! integration routine used to integrate the event rate spectra.

        implicit none
        real(kind=8) :: vv, qq
        real(kind=8) :: spectraintegrand1d
        integer tid

        qq = qglobal(tid)

        spectraintegrand1d = diffCrossSection(vv, qq) &
            * sshm(vv,ve,v0,vesc) * vv**2

    end function

end module eventrate


      SUBROUTINE surface(rc, rs, zs, zc, xm, xn, mnmax)
      USE vacmod
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER mnmax
      REAL(rprec), DIMENSION(mnmax) :: rc, rs, zs, zc, xm, xn
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
      INTEGER :: i, mn, m, n, n1
      REAL(rprec), ALLOCATABLE, DIMENSION(:) ::
     1   ruu, ruv, rvv, zuu, zuv, zvv, cosmn1, sinmn1
C-----------------------------------------------
!
!       THIS ROUTINE COMPUTES THE SURFACE VALUES OF R,Z AND DERIVATIVES
!
!
!       Compute R & Z (and their derivatives) on surface
!
!       R = SUM [RC(m,n)*COS(mu - nv) + RS(m,n)*SIN(mu - nv)]
!       Z = SUM [ZS(m,n)*SIN(mu - nv) + ZC(m,n)*COS(mu - nv)]
!
!       NOTE: u, v here are actual angles (0, 2pi), NOT the normalized
!             variables used in PKM paper
!
      ALLOCATE (ruu(nuv2), ruv(nuv2), rvv(nuv2), zuu(nuv2), zuv(nuv2),
     1          zvv(nuv2), cosmn1(nuv2), sinmn1(nuv2), stat = i)
      IF (i .ne. 0) STOP 'Allocation error in SURFACE'

      r1b = 0;   rub = 0;   rvb = 0;  ruu = 0; ruv = 0; rvv = 0
      z1b = 0;   zub = 0;   zvb = 0;  zuu = 0; zuv = 0; zvv = 0
      DO mn = 1, mnmax
         m = NINT(xm(mn))
         n = NINT(xn(mn)/(nfper))
         n1 = ABS(n)
         cosmn1(:) = cosu1(:,m)*cosv1(:,n1) + csign(n)*sinu1(:,m)*
     1               sinv1(:,n1)
         sinmn1(:) = sinu1(:,m)*cosv1(:,n1) - csign(n)*cosu1(:,m)*
     1               sinv1(:,n1)
         DO i = 1, nuv2
            r1b(i) = r1b(i) + rc(mn) * cosmn1(i)
            rub(i) = rub(i) - xm(mn) * rc(mn) * sinmn1(i)
            rvb(i) = rvb(i) + xn(mn) * rc(mn) * sinmn1(i)
            z1b(i) = z1b(i) + zs(mn) * sinmn1(i)
            zub(i) = zub(i) + xm(mn) * zs(mn) * cosmn1(i)
            zvb(i) = zvb(i) - xn(mn) * zs(mn) * cosmn1(i)
            ruu(i) = ruu(i) - xm(mn)*xm(mn)*rc(mn) * cosmn1(i)
            ruv(i) = ruv(i) + xm(mn)*xn(mn)*rc(mn) * cosmn1(i)
            rvv(i) = rvv(i) - xn(mn)*xn(mn)*rc(mn) * cosmn1(i)
            zuu(i) = zuu(i) - xm(mn)*xm(mn)*zs(mn) * sinmn1(i)
            zuv(i) = zuv(i) + xm(mn)*xn(mn)*zs(mn) * sinmn1(i)
            zvv(i) = zvv(i) - xn(mn)*xn(mn)*zs(mn) * sinmn1(i)
         END DO

         IF (.not.lasym) CYCLE

         DO i = 1, nuv2
            r1b(i) = r1b(i) + rs(mn) * sinmn1(i)
            rub(i) = rub(i) + xm(mn) * rs(mn) * cosmn1(i)
            rvb(i) = rvb(i) - xn(mn) * rs(mn) * cosmn1(i)
            z1b(i) = z1b(i) + zc(mn) * cosmn1(i)
            zub(i) = zub(i) - xm(mn) * zc(mn) * sinmn1(i)
            zvb(i) = zvb(i) + xn(mn) * zc(mn) * sinmn1(i)
            ruu(i) = ruu(i) - xm(mn)*xm(mn)*rs(mn) * sinmn1(i)
            ruv(i) = ruv(i) + xm(mn)*xn(mn)*rs(mn) * sinmn1(i)
            rvv(i) = rvv(i) - xn(mn)*xn(mn)*rs(mn) * sinmn1(i)
            zuu(i) = zuu(i) - xm(mn)*xm(mn)*zc(mn) * cosmn1(i)
            zuv(i) = zuv(i) + xm(mn)*xn(mn)*zc(mn) * cosmn1(i)
            zvv(i) = zvv(i) - xn(mn)*xn(mn)*zc(mn) * cosmn1(i)
         END DO
      END DO

!
!     COMPUTE METRIC COEFFICIENTS GIJ_B AND SURFACE NORMAL COMPONENTS
!     [SNR, SNV, SNZ] = NP*[Xu cross Xv]
!
!     NOTE: These should be multiplied by -signgs to point OUTWARD from vacuum INTO plasma
!           for either handed-ness of the coordinate system
!
!           Eq. 2.4 in PKM has wrong sign for a left-handed coordinate system
!
!     NOTE: guv = .5*np guv_b; gvv = np*np* gvv_b, where GUV, GVV are the
!           REAL metric elements. CAP(A), etc. defined in Eq. (2.13) of PKM paper
!
!           AUU == NP*CAP(A) = .5*Xuu dot [Xu cross Xv] * NP
!
!           AUV == 2*NP*CAP(B) =  Xuv dot [Xu cross Xv] * NP
!
!           AVV == NP*CAP(C) = .5*Xvv dot [Xu cross Xv] * NP
!
      DO i = 1,nuv2
        guu_b(i) = rub(i)*rub(i) + zub(i)*zub(i)
        guv_b(i) = (rub(i)*rvb(i)+ zub(i)*zvb(i))*onp*2
        gvv_b(i) = (rvb(i)*rvb(i)+ zvb(i)*zvb(i)+(r1b(i)*r1b(i)))*onp2
        rzb2(i) = r1b(i)*r1b(i) + z1b(i)*z1b(i)
        snr(i) = signgs*r1b(i)*zub(i)
        snv(i) = signgs*(rub(i)*zvb(i) - rvb(i)*zub(i))
        snz(i) =-signgs*r1b(i)*rub(i)
        drv(i) = -(r1b(i)*snr(i) + z1b(i)*snz(i))
        auu(i) = p5*(snr(i)*ruu(i) + snz(i)*zuu(i))
        auv(i) = (snr(i)*ruv(i) + snv(i)*rub(i) + snz(i)*zuv(i))*onp
        avv(i) = (snv(i)*rvb(i) + p5*(snr(i)*(rvv(i) - r1b(i))
     1                          +     snz(i)* zvv(i)))*onp2
      END DO

      IF (.not.lasym) THEN
         DO i = 1 + nv, nuv2 - nv
            rzb2(imirr(i)) = rzb2(i)
            r1b(imirr(i))  = r1b(i)
            z1b(imirr(i))  =-z1b(i)
         END DO
      END IF

      DO i = 1,nuv
        rcosuv(i) = r1b(i)*cosuv(i)
        rsinuv(i) = r1b(i)*sinuv(i)
      END DO

      DEALLOCATE (ruu, ruv, rvv, zuu, zuv, zvv, cosmn1, sinmn1, stat=i)

      END SUBROUTINE surface


      FUNCTION BESSI(N,X)
      PARAMETER(IACC=40,BIGNO=1.0E10,BIGNI=1.0E-10)
      IF (N.LT.2) PAUSE 'bad argument N in BESSI'
      TOX=2.0/X
      BIP=0.0
      BI=1.0
      BESSI=0.
      M=2*((N+INT(SQRT(FLOAT(IACC*N)))))
      DO 11 J=M,1,-1
        BIM=BIP+FLOAT(J)*TOX*BI
        BIP=BI
        BI=BIM
        IF (ABS(BI).GT.BIGNO) THEN
          BESSI=BESSI*BIGNI
          BI=BI*BIGNI
          BIP=BIP*BIGNI
        ENDIF
        IF (J.EQ.N) BESSI=BIP
11    CONTINUE
      BESSI=BESSI*BESSI0(X)/BI
      RETURN
      END