      SUBROUTINE TG01HX( COMPQ, COMPZ, L, N, M, P, N1, LBE, A, LDA,
     $                   E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR,
     $                   NRBLCK, RTAU, TOL, IWORK, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     Given the descriptor system (A-lambda*E,B,C) with the system
C     matrices A, E and B of the form
C
C            ( A1 X1 )        ( E1 Y1 )        ( B1 )
C        A = (       ) ,  E = (       ) ,  B = (    ) ,
C            ( 0  X2 )        ( 0  Y2 )        ( 0  )
C
C     where
C          - B is an L-by-M matrix, with B1 an N1-by-M  submatrix
C          - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix
C          - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix
C              with LBE nonzero sub-diagonals,
C     this routine reduces the pair (A1-lambda*E1,B1) to the form
C
C     Qc'*[B1 A1-lambda*E1]*diag(I,Zc) =
C
C                              ( Bc Ac-lambda*Ec      *         )
C                              (                                ) ,
C                              ( 0     0         Anc-lambda*Enc )
C
C     where:
C     1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for
C        all finite lambda and is in a staircase form with
C                           _      _          _        _
C                         ( A1,0   A1,1  ...  A1,k-1   A1,k  )
C                         (        _          _        _     )
C             ( Bc Ac ) = (  0     A2,1  ...  A2,k-1   A2,k  ) ,  (1)
C                         (              ...  _        _     )
C                         (  0       0   ...  Ak,k-1   Ak,k  )
C
C                           _          _        _
C                         ( E1,1  ...  E1,k-1   E1,k  )
C                         (            _        _     )
C               Ec      = (   0   ...  E2,k-1   E2,k  ) ,         (2)
C                         (       ...           _     )
C                         (   0   ...    0      Ek,k  )
C               _
C         where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank
C                                       _
C         matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i)
C         upper triangular matrix.
C
C      2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc
C         upper triangular; this pencil contains the uncontrollable
C         finite eigenvalues of the pencil (A1-lambda*E1).
C
C     The transformations are applied to the whole matrices A, E, B
C     and C. The left and/or right orthogonal transformations Qc and Zc
C     performed to reduce the pencil can be optionally accumulated
C     in the matrices Q and Z, respectively.
C
C     The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no
C     uncontrollable finite eigenvalues and has the same
C     transfer-function matrix as the original system (A-lambda*E,B,C).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of descriptor state equations; also the number
C             of rows of matrices A, E and B.  L >= 0.
C
C     N       (input) INTEGER
C             The dimension of the descriptor state vector; also the
C             number of columns of matrices A, E and C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of descriptor system input vector; also the
C             number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of descriptor system output; also the
C             number of rows of matrix C.  P >= 0.
C
C     N1      (input) INTEGER
C             The order of subsystem (A1-lambda*E1,B1,C1) to be reduced.
C             MIN(L,N) >= N1 >= 0.
C
C     LBE     (input) INTEGER
C             The number of nonzero sub-diagonals of submatrix E1.
C             MAX(0,N1-1) >= LBE >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the L-by-N state matrix A in the partitioned
C             form
C                      ( A1 X1 )
C                  A = (       ) ,
C                      ( 0  X2 )
C
C             where A1 is N1-by-N1.
C             On exit, the leading L-by-N part of this array contains
C             the transformed state matrix,
C
C                                  ( Ac  *   * )
C                       Qc'*A*Zc = ( 0  Anc  * ) ,
C                                  ( 0   0   * )
C
C             where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR).
C             The matrix ( Bc Ac ) is in the controllability
C             staircase form (1).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the L-by-N descriptor matrix E in the partitioned
C             form
C                      ( E1 Y1 )
C                  E = (       ) ,
C                      ( 0  Y2 )
C
C             where E1 is N1-by-N1 matrix with LBE nonzero
C             sub-diagonals.
C             On exit, the leading L-by-N part of this array contains
C             the transformed descriptor matrix
C
C                                  ( Ec  *   * )
C                       Qc'*E*Zc = ( 0  Enc  * ) ,
C                                  ( 0   0   * )
C
C             where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR).
C             Both Ec and Enc are upper triangular and Enc is
C             nonsingular.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the L-by-M input matrix B in the partitioned
C             form
C                      ( B1 )
C                  B = (    ) ,
C                      ( 0  )
C
C             where B1 is N1-by-M.
C             On exit, the leading L-by-M part of this array contains
C             the transformed input matrix
C
C                               ( Bc )
C                       Qc'*B = (    ) ,
C                               ( 0  )
C
C             where Bc is NR-by-M.
C             The matrix ( Bc Ac ) is in the controllability
C             staircase form (1).
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,L).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Zc.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,L)
C             If COMPQ = 'N': Q is not referenced.
C             If COMPQ = 'I': on entry, Q need not be set;
C                             on exit, the leading L-by-L part of this
C                             array contains the orthogonal matrix Qc,
C                             where Qc' is the product of transformations
C                             which are applied to A, E, and B on
C                             the left.
C             If COMPQ = 'U': on entry, the leading L-by-L part of this
C                             array must contain an orthogonal matrix Q;
C                             on exit, the leading L-by-L part of this
C                             array contains the orthogonal matrix
C                             Q*Qc.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N': Z is not referenced.
C             If COMPZ = 'I': on entry, Z need not be set;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix Zc,
C                             which is the product of transformations
C                             applied to A, E, and C on the right.
C             If COMPZ = 'U': on entry, the leading N-by-N part of this
C                             array must contain an orthogonal matrix Z;
C                             on exit, the leading N-by-N part of this
C                             array contains the orthogonal matrix
C                             Z*Zc.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
C
C     NR      (output) INTEGER
C             The order of the reduced matrices Ac and Ec, and the
C             number of rows of the reduced matrix Bc; also the order of
C             the controllable part of the pair (B, A-lambda*E).
C
C     NRBLCK  (output) INTEGER                      _
C             The number k, of full row rank blocks Ai,i in the
C             staircase form of the pencil (Bc Ac-lambda*Ec) (see (1)
C             and (2)).
C
C     RTAU    (output) INTEGER array, dimension (N1)
C             RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of
C                                     _
C             the full row rank block Ai,i-1 in the staircase form (1).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A-lambda*E, B). If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = L*N*EPS,  is used instead, where
C             EPS is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(N,L,2*M))
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 subroutine is based on the reduction algorithm of [1].
C
C     REFERENCES
C
C     [1] Varga, A.
C         Computation of Irreducible Generalized State-Space
C         Realizations.
C         Kybernetika, vol. 26, pp. 89-106, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N*N1**2 )  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDS05.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 1999,
C     May 2003, Nov. 2003.
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003.
C     V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion.
C     V. Sima, Apr. 2017, Mar. 2019.
C
C     KEYWORDS
C
C     Controllability, minimal realization, orthogonal canonical form,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ
      INTEGER            INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDZ, M,
     $                   N, N1, NR, NRBLCK, P
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IWORK( * ), RTAU( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ), E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            ILQ, ILZ, WITHC
      INTEGER            I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX,
     $                   ISMIN, J, K, MN, NF, NR1, RANK, TAUIM1
      DOUBLE PRECISION   C1, C2, CO, NRMA, RCOND, S1, S2, SI, SMAX,
     $                   SMAXPR, SMIN, SMINPR, SVLMAX, T, TOLZ, TT
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANGE, DNRM2
      EXTERNAL           DLAMCH, DLANGE, DNRM2, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL           DLACPY, DLAIC1, DLARF, DLARFG, DLARTG, DLASET,
     $                   DROT, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
C
C     .. Executable Statements ..
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
C
C     Test the input scalar parameters.
C
      INFO = 0
      IF( ICOMPQ.LE.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -2
      ELSE IF( L.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN
         INFO = -7
      ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN
         INFO = -8
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -10
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -12
      ELSE IF( LDB.LT.MAX( 1, L ) ) THEN
         INFO = -14
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -16
      ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN
         INFO = -18
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -20
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -24
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01HX', -INFO )
         RETURN
      END IF
C
C     Initialize Q and Z if necessary.
C
      IF( ICOMPQ.EQ.3 )
     $   CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Initialize output variables.
C
      NR = 0
      NRBLCK = 0
C
C     Quick return if possible.
C
      IF( M.EQ.0 .OR. N1.EQ.0 ) THEN
         RETURN
      END IF
C
      TOLZ   = SQRT( DLAMCH( 'Epsilon' ) )
      WITHC  = P.GT.0
      SVLMAX = ZERO
      NRMA   = DLANGE( 'F', L, N, A, LDA, DWORK )
      RCOND  = TOL
      IF ( RCOND.LE.ZERO ) THEN
C
C        Use the default tolerance in controllability determination.
C
         RCOND = DBLE( L*N )*DLAMCH( 'EPSILON' )
      END IF
C
C     Reduce E to upper triangular form if necessary.
C
      IF( LBE.GT.0 ) THEN
         DO 10 I = 1, N1-1
C
C           Generate elementary reflector H(i) to annihilate
C           E(i+1:i+lbe,i).
C
            K = MIN( LBE, N1-I ) + 1
            CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT )
            T = E(I,I)
            E(I,I) = ONE
C
C           Apply H(i) to E(i:n1,i+1:n) from the left.
C
            CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT,
     $                  E(I,I+1), LDE, DWORK )
C
C           Apply H(i) to A(i:n1,1:n) from the left.
C
            CALL DLARF( 'Left', K, N, E(I,I), 1, TT,
     $                  A(I,1), LDA, DWORK )
C
C           Apply H(i) to B(i:n1,1:m) from the left.
C
            CALL DLARF( 'Left', K, M, E(I,I), 1, TT,
     $                  B(I,1), LDB, DWORK )
            IF( ILQ ) THEN
C
C              Apply H(i) to Q(1:l,i:n1) from the right.
C
               CALL DLARF( 'Right', L, K, E(I,I), 1, TT,
     $                     Q(1,I), LDQ, DWORK )
            END IF
            E(I,I) = T
   10    CONTINUE
         CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE )
      END IF
C
      ISMIN = 1
      ISMAX = ISMIN + M
      IC = -M
      TAUIM1 = M
      NF = N1
C
   20 CONTINUE
      NRBLCK = NRBLCK + 1
      RANK = 0
      IF( NF.GT.0 ) THEN
C
C        IROW will point to the current pivot line in B,
C        ICOL+1 will point to the first active columns of A.
C
         ICOL = IC + TAUIM1
         IROW = NR
         NR1 = NR + 1
         IF( NR.GT.0 ) THEN
            CALL DLACPY( 'Full', NF, TAUIM1, A(NR1,IC+1), LDA,
     $                   B(NR1,1), LDB )
            IF( SVLMAX.EQ.ZERO )
     $          SVLMAX = NRMA
         END IF
C
C        Perform QR-decomposition with column pivoting on the current B
C        while keeping E upper triangular.
C        The current B is at first iteration B and for subsequent
C        iterations the NF-by-TAUIM1 matrix delimited by rows
C        NR + 1 to N1 and columns IC + 1 to IC + TAUIM1 of A.
C        The rank of current B is computed in RANK.
C
         IF( TAUIM1.GT.1 ) THEN
C
C           Compute column norms.
C
            DO 30 J = 1, TAUIM1
               DWORK(J) = DNRM2( NF, B(NR1,J), 1 )
               DWORK(M+J) = DWORK(J)
               IWORK(J) = J
   30       CONTINUE
         END IF
C
         MN = MIN( NF, TAUIM1 )
C
   40    CONTINUE
         IF( RANK.LT.MN ) THEN
            J = RANK + 1
            IROW = IROW + 1
C
C           Pivot if necessary.
C
            IF( J.NE.TAUIM1 ) THEN
               K = ( J - 1 ) + IDAMAX( TAUIM1-J+1, DWORK(J), 1 )
               IF( K.NE.J ) THEN
                  CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 )
                  I = IWORK(K)
                  IWORK(K) = IWORK(J)
                  IWORK(J) = I
                  DWORK(K) = DWORK(J)
                  DWORK(M+K) = DWORK(M+J)
               END IF
            END IF
C
C           Zero elements below the current diagonal element of B.
C
            DO 50 I = N1-1, IROW, -1
C
C              Rotate rows I and I+1 to zero B(I+1,J).
C
               T = B(I,J)
               CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) )
               B(I+1,J) = ZERO
               CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI )
               IF( J.LT.TAUIM1 )
     $             CALL DROT( TAUIM1-J, B(I,J+1), LDB,
     $                        B(I+1,J+1), LDB, CO, SI )
               CALL DROT( N-ICOL, A(I,ICOL+1), LDA,
     $                    A(I+1,ICOL+1), LDA, CO, SI )
               IF( ILQ ) CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI )
C
C              Rotate columns I, I+1 to zero E(I+1,I).
C
               T = E(I+1,I+1)
               CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) )
               E(I+1,I) = ZERO
               CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI )
               CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI )
               IF( ILZ ) CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI )
               IF( WITHC )
     $            CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI )
   50       CONTINUE
C
            IF( RANK.EQ.0 ) THEN
C
C              Initialize; exit if the matrix is negligible (RANK = 0).
C
               SMAX = ABS( B(NR1,1) )
               IF ( SMAX.LE.RCOND ) GO TO 80
               SMIN = SMAX
               SMAXPR = SMAX
               SMINPR = SMIN
               C1 = ONE
               C2 = ONE
            ELSE
C
C              One step of incremental condition estimation.
C
               CALL DLAIC1( IMIN, RANK, DWORK(ISMIN), SMIN,
     $                      B(NR1,J), B(IROW,J), SMINPR, S1, C1 )
               CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX,
     $                      B(NR1,J), B(IROW,J), SMAXPR, S2, C2 )
            END IF
C
C           Check the rank; finish the loop if rank loss occurs.
C
            IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
               IF( SVLMAX*RCOND.LE.SMINPR ) THEN
                  IF( SMAXPR*RCOND.LT.SMINPR ) THEN
C
C                    Finish the loop if last row.
C
                     IF( IROW.EQ.N1 ) THEN
                        RANK = RANK + 1
                        GO TO 80
                     END IF
C
C                    Update partial column norms.
C
                     DO 60 I = J + 1, TAUIM1
                        IF( DWORK(I).NE.ZERO ) THEN
                           T = ABS( B(IROW,I) )/DWORK(I)
                           T = MAX( ( ONE + T )*( ONE - T ), ZERO)
                           TT = T*( DWORK(I)/DWORK(M+I) )**2
                           IF( TT.GT.TOLZ ) THEN
                              DWORK(I) = DWORK(I)*SQRT( T )
                           ELSE
                              DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 )
                              DWORK(M+I) = DWORK(I)
                           END IF
                        END IF
   60                CONTINUE
C
                     DO 70 I = 1, RANK
                        DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1)
                        DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1)
   70                CONTINUE
C
                     DWORK(ISMIN+RANK) = C1
                     DWORK(ISMAX+RANK) = C2
                     SMIN = SMINPR
                     SMAX = SMAXPR
                     RANK = RANK + 1
                     GO TO 40
                  END IF
               END IF
            END IF
            IF( NR.GT.0 ) THEN
               CALL DLASET( 'Full', N1-IROW+1, TAUIM1-J+1, ZERO, ZERO,
     $                      B(IROW,J), LDB )
            END IF
            GO TO 80
         END IF
      END IF
C
   80 IF( RANK.GT.0 ) THEN
         RTAU(NRBLCK) = RANK
C
C        Back permute interchanged columns.
C
         IF( TAUIM1.GT.1 ) THEN
            DO 100 J = 1, TAUIM1
               IF( IWORK(J).GT.0 ) THEN
                  K = IWORK(J)
                  IWORK(J) = -K
   90             CONTINUE
                  IF( K.NE.J ) THEN
                     CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 )
                     IWORK(K) = -IWORK(K)
                     K = -IWORK(K)
                     GO TO 90
                  END IF
               END IF
  100       CONTINUE
         END IF
      END IF
      IF( NR.GT.0 )
     $   CALL DLACPY( 'Full', NF, TAUIM1, B(NR1,1), LDB,
     $                A(NR1,IC+1), LDA )
      IF( RANK.GT.0 ) THEN
         NR = NR + RANK
         NF = NF - RANK
         IC = IC + TAUIM1
         TAUIM1 = RANK
         GO TO 20
      ELSE
         NRBLCK = NRBLCK - 1
      END IF
C
      IF( NRBLCK.GT.0 ) RANK = RTAU(1)
      IF( RANK.LT.N1 )
     $   CALL DLASET( 'Full', N1-RANK, M, ZERO, ZERO, B(RANK+1,1), LDB )
C
      RETURN
C *** Last line of TG01HX ***
      END


      SUBROUTINE FLUX(F,Z,TMIN,TMAX,NSTRU)
      IMPLICIT NONE
* Returns H1 pomeron flux if NSTRU=6
* Returns H1 reggeon flux if NSTRU=7
* Returns flux for user defined structure function if NSTRU=8
* B.Cox and J. Forshaw 11/05/00
      DOUBLE PRECISION F,Z,TMIN,TMAX
      DOUBLE PRECISION alpha,B,alphap
      DOUBLE PRECISION alphar,alpharp,Br,Cr
* H1 best fits
*      PARAMETER (alpha=1.203,alphap=0.26,B=4.6)
*      PARAMETER (alphar=0.50,alpharp=0.90,Br=2.0,Cr=16.0)
* H1 parameters with no interference (best fit to H1 F2D3 using POMWIG)
      PARAMETER (alpha=1.200,alphap=0.26,B=4.6)
      PARAMETER (alphar=0.57,alpharp=0.90,Br=2.0,Cr=48.0)
      DOUBLE PRECISION V,W,X
      INTEGER NSTRU

      if (NSTRU.EQ.9) then
         V = DEXP(-(B+2.D0*alphap*DLOG(1.D0/Z))*TMIN)-
     +        DEXP(-(B+2.D0*alphap*DLOG(1.D0/Z))*TMAX)
         W = 1.D0/(B+2.D0*alphap*DLOG(1.D0/Z))
         X = 1.D0/(Z**(2.D0*alpha-1.D0))
         F = X*W*V
      elseif (NSTRU.EQ.10) then
         V = DEXP(-(Br+2.D0*alpharp*DLOG(1.D0/Z))*TMIN)-
     +        DEXP(-(Br+2.D0*alpharp*DLOG(1.D0/Z))*TMAX)
         W = 1.D0/(Br+2.D0*alpharp*DLOG(1.D0/Z))
         X = 1.D0/(Z**(2.D0*alphar-1.D0))
         F = Cr*X*W*V
      elseif (NSTRU.EQ.11) then
         V = DEXP(-(B+2.D0*alphap*DLOG(1.D0/Z))*TMIN)-
     +        DEXP(-(B+2.D0*alphap*DLOG(1.D0/Z))*TMAX)
         W = 1.D0/(B+2.D0*alphap*DLOG(1.D0/Z))
         X = 1.D0/(Z**(2.D0*alpha-1.D0))
         F = X*W*V
      else
         write(*,*) 'pomwig : NSTRU must be 9, 10 or 11 in herwig65'
         STOP
      endif
      RETURN
      END


*DECK DBESI0
      DOUBLE PRECISION FUNCTION DBESI0 (X)
C***BEGIN PROLOGUE  DBESI0
C***PURPOSE  Compute the hyperbolic Bessel function of the first kind
C            of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      DOUBLE PRECISION (BESI0-S, DBESI0-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESI0(X) calculates the double precision modified (hyperbolic)
C Bessel function of the first kind of order zero and double
C precision argument X.
C
C Series for BI0        on the interval  0.          to  9.00000E+00
C                                        with weighted error   9.51E-34
C                                         log weighted error  33.02
C                               significant figures required  33.31
C                                    decimal places required  33.65
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DBSI0E, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DBESI0
      DOUBLE PRECISION X, BI0CS(18), XMAX, XSML, Y, D1MACH,
     1  DCSEVL, DBSI0E
      LOGICAL FIRST
      SAVE BI0CS, NTI0, XSML, XMAX, FIRST
      DATA BI0CS(  1) / -.7660547252 8391449510 8189497624 3285 D-1   /
      DATA BI0CS(  2) / +.1927337953 9938082699 5240875088 1196 D+1   /
      DATA BI0CS(  3) / +.2282644586 9203013389 3702929233 0415 D+0   /
      DATA BI0CS(  4) / +.1304891466 7072904280 7933421069 1888 D-1   /
      DATA BI0CS(  5) / +.4344270900 8164874513 7868268102 6107 D-3   /
      DATA BI0CS(  6) / +.9422657686 0019346639 2317174411 8766 D-5   /
      DATA BI0CS(  7) / +.1434006289 5106910799 6209187817 9957 D-6   /
      DATA BI0CS(  8) / +.1613849069 6617490699 1541971999 4611 D-8   /
      DATA BI0CS(  9) / +.1396650044 5356696994 9509270814 2522 D-10  /
      DATA BI0CS( 10) / +.9579451725 5054453446 2752317189 3333 D-13  /
      DATA BI0CS( 11) / +.5333981859 8625021310 1510774400 0000 D-15  /
      DATA BI0CS( 12) / +.2458716088 4374707746 9678591999 9999 D-17  /
      DATA BI0CS( 13) / +.9535680890 2487700269 4434133333 3333 D-20  /
      DATA BI0CS( 14) / +.3154382039 7214273367 8933333333 3333 D-22  /
      DATA BI0CS( 15) / +.9004564101 0946374314 6666666666 6666 D-25  /
      DATA BI0CS( 16) / +.2240647369 1236700160 0000000000 0000 D-27  /
      DATA BI0CS( 17) / +.4903034603 2428373333 3333333333 3333 D-30  /
      DATA BI0CS( 18) / +.9508172606 1226666666 6666666666 6666 D-33  /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBESI0
      IF (FIRST) THEN
         NTI0 = INITDS (BI0CS, 18, 0.1*REAL(D1MACH(3)))
         XSML = SQRT(4.5D0*D1MACH(3))
         XMAX = LOG (D1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0D0) GO TO 20
C
      DBESI0 = 1.0D0
      IF (Y.GT.XSML) DBESI0 = 2.75D0 + DCSEVL (Y*Y/4.5D0-1.D0, BI0CS,
     1  NTI0)
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESI0',
     +   'ABS(X) SO BIG I0 OVERFLOWS', 2, 2)
C
      DBESI0 = EXP(Y) * DBSI0E(X)
C
      RETURN
      END


!*************************************************************************
subroutine fan_gmres(nd)
  use global_com,only: dp,nitermax,precis
  use global_dim
  implicit none
  integer,parameter :: m = 30
  integer::itertotal,iterout,n,nd,k
  complex(kind=dp)::cx(nd)
  complex(kind=dp)::cb(m+1)
  complex(kind=dp)::cy(nd,m+1),ch(m+1,m)
  complex(kind=dp)::cs(m)
  real(kind=dp)::rc(m)
  complex(kind=dp)::ctemp
  real(kind=dp)::ay0, be, bea
  real(kind=dp)::xtime,xtim
  real(kind=dp),external:: scnrm22

  print *, '.......in fan_gmres algorithm ......'
  open(unit=161,file='con_fangmres.out')
  PRINT*, "Starting iteration of solution..."
  call cpu_time(xtime)

  cx    = (0.0_dp,0.0_dp)
  ay0   = scnrm22(nd,crhs)
  itertotal = 0

!print*,"nd",nd

!************************************************************************
  do iterout = 1, nitermax
!************************************************************************
     itertotal = itertotal +1
!====================================================================
     call            convol(cx(1:nd),cy(1:nd,m+1),nd)
     cy(1:nd,m+1)  = crhs(1:nd) -cy(1:nd,m+1)
     cb(1)         = scnrm22(nd,cy(1:nd,m+1))
     be            = cb(1)/ay0
!====================================================================
     !write(*,*) 'restart', iterout,itertotal,'  truebe',be
     !write(161,*) itertotal,be
     if(be.le.precis.or.itertotal>nitermax) exit
     cy(1:nd,1) =  cy(1:nd,m+1)/cb(1)
!************************************************************************
     do n = 1, m
!************************************************************************
        itertotal = itertotal +1
!========================step1=======================================
        call convol(cy(1:nd,n),cy(1:nd,n+1),nd)
!========================step2=======================================
  	do k=1,n
           ch(k,n) = dot_product(cy(1:nd,k),cy(1:nd,n+1))
           cy(1:nd,n+1) = cy(1:nd,n+1) - cy(1:nd,k)*ch(k,n)
        enddo
        ch(n+1,n)  =  scnrm22(nd,cy(1:nd,n+1))
        if(n.lt.m)  cy(1:nd,n+1) = cy(1:nd,n+1)/ch(n+1,n)
        if(n.ne.1) then
           do k=1,n-1
              ctemp       = rc(k)*ch(k+1,n) -        cs(k) *ch(k,n)
              ch(k,n)     = rc(k)*ch(k,n)   + conjg (cs(k))*ch(k+1,n)
              ch(k+1,n)   = ctemp
           enddo
        endif
!========================step3=======================================
        call givens_loc(ch(n,n),ch(n+1,n),rc(n),cs(n))
!========================step4=======================================
        cb(n+1) =  -cs(n)*cb(n)
        cb(n)   =   rc(n)*cb(n)
        ch(n,n)   = rc(n)*ch(n,n)+ conjg (cs(n))*ch(n+1,n)
        ch(n+1,n) = (0.0_dp,0.0_dp)
!========================step5=======================================
        bea = abs(cb(n+1))/ay0
        !write(*,*) itertotal,bea
        !write(161,*) itertotal,bea
        if(n.eq.m.or.bea.le.precis) then
           call cutrisub(n, ch(1:n,1:n), cb(1:n), cb(1:n))
           cy(1:nd,m+1) = matmul(cy(1:nd,1:n),cb(1:n))
           cx = cx + cy(1:nd,m+1)
           exit
        endif
!===================================================================
     enddo   !n }
  enddo !iterout}
!===================================================================
  if(be>precis) then
     write( *,*) 'convergence is not achieved'
     write(161,*) 'convergence is not achieved'
  else
     write( *,*) 'convergence achieved'
     write(161,*) 'convergence achieved'
  endif
  call cpu_time(xtim)
  write(*, *) "gmres itr time...", xtim-xtime
  write(161,*) "gmres itr time...", xtim-xtime

!------------------------solution------------------------
  rj = cx

  close(161)

  return
end subroutine fan_gmres
!*************************************************************************

!*************************************************************************
subroutine givens_loc(z1,z2,c,s)
  use global_com,only: dp
  implicit none
  complex(kind=dp)::  z1,z2,s
  real(kind=dp)::      c,vnormz

  vnormz = sqrt ( abs(z1)**2 + abs(z2)**2)
  if (abs(z1).ne.0.) then
     c =     abs(z1)/vnormz
     s =     z2/z1* c
  else if (abs(z2).ne.0.) then
     c = 0.
     s = z2/ abs(z2)
  else
     c = 1.
     s = 0.
  endif

end subroutine givens_loc
!*************************************************************************

!*************************************************************************
function  scnrm22(nd,cy9)
  use global_com,only: dp
  implicit none
  integer nd,i
  complex(kind=dp)::  cy9(nd)
  real(kind=dp):: scnrm22

  scnrm22=0.0_dp
  do i=1,nd
     scnrm22= scnrm22+( conjg( cy9(i) )*cy9(i))
  end do
  scnrm22=sqrt(scnrm22)
  !	write(*,*) scnrm22
  !	pause

  return
end function scnrm22
!*************************************************************************

!*************************************************************************
subroutine cutrisub(n, cma, cvx, cvy)
  use global_com,only: dp
  implicit none
  integer n
  complex(kind=dp):: cma(n, n), cvx(n), cvy(n)
  integer i, j

  do i = n, 1, - 1
     cvy(i) = cvx(i)
     do j = i + 1, n
        cvy(i) = cvy(i) - cma(i, j) * cvy(j)
     enddo
     cvy(i) = cvy(i) / cma(i, i)
  enddo

end subroutine cutrisub
!*************************************************************************

!*************************************************************************
subroutine convol(cin,cout,nd)  !!!convolnear
  use global_com,only: dp,ntriangle,nipp
  use global_dim,only: zzsparse
  implicit none
  integer::nd,i,kk1,kk2
  complex(kind=dp):: cin(nd),cout(nd)

  cout  = (0.0_dp,0.0_dp)

  do i = 1, ntriangle*nipp
     kk1 = (i-1)*ntriangle*nipp+1
     kk2 = i*ntriangle*nipp
     cout(i) = dot_product(conjg(zzsparse(kk1:kk2)),cin(1:ntriangle*nipp))
  enddo

end subroutine convol
!*************************************************************************


        subroutine derivs(x,y,Ntraj,fx,fy,pe,ipot)
        implicit real*8(a-h,o-z)
        integer*4,intent(IN) :: Ntraj,ipot
        real*8,intent(IN) :: x(Ntraj),y(Ntraj)
        real*8 :: De,a,x0,y0,b,c,d,e,v,f,w,ky,xmin
        real*8,intent(OUT) :: fx(Ntraj),fy(Ntraj),pe(Ntraj)
        real*8 xe,k1,k2
!        common/pes/ipot
c   morse potential for x coordinate, Eckart potential for y direction
      	fx = 0d0
	fy = 0d0
	pe = 0d0

C
        xmin=0.3342534836
        if (ipot .eq. 1) then
        do i=1,Ntraj
        fx(i)=0.0908295*exp(-1.5d0*(x(i)-y(i)*lambda/2d0))/
     & (1d0+exp(-1.5d0*(x(i)-y(i)*lambda/2d0)))**2
     & -0.09246906195d0*sinh(0.75d0*(x(i)-y(i)*lambda/2d0))/
     & (cosh(0.75d0*(x(i)-y(i)*lambda/2d0)))**3

        fy(i)=-k2*y(i)-0.04541475d0*lambda*exp(-1.5d0*x(i)+
     & 0.75d0*y(i)*lambda)/(1d0+exp(-1.5d0*x(i)+0.75d0*y(i)*lambda))**2+
     & 0.04623453098d0*sinh(0.75d0*x(i)-0.375d0*y(i)*lambda)*lambda/
     & cosh(0.75d0*x(i)-0.375d0*y(i)*lambda)**3

       pe(i)=0.063740d0-0.060553d0/(1d0+exp(-1.5d0*(x(i)-
     & y(i)*lambda/2d0)))
     & - 0.06164604130d0/cosh(0.75d0*(x(i)-y(i)*lambda/2d0))**2+
     & k2*y(i)**2/2d0
        end do
        endif
C Harmonic
        if(ipot .eq. 2) then
	ak = 0.8d0
        do i=1,Ntraj
        fx(i)=-x(i)-ak*y(i)
        fy(i)=-y(i)-ak*x(i)
        pe(i)=x(i)**2/2d0+y(i)**2/2d0+ak*x(i)*y(i)
        enddo
        endif
C Morse for H2
      if(ipot .eq. 3) then
      De = 0.176d0
      xe=1.4d0
      ye = 1.4d0
      alpha = 1.02

      do i=1,Ntraj
       fx(i)=-2d0*De*alpha*exp(-alpha*(x(i)-xe))*
     &        (1d0-exp(-alpha*(x(i)-xe)))
       fy(i)=-2d0*De*alpha*exp(-alpha*(y(i)-ye))*
     &        (1d0-exp(-alpha*(y(i)-ye)))
       pe(i)=De*(1d0-exp(-alpha*(x(i)-xe)))**2+
     &       De*(1d0-exp(-alpha*(y(i)-ye)))**2
      enddo
      endif
C Henon-Hailes
      IF(ipot .eq. 4) THEN
      k1=1d0
      k2=1d0
      do i=1,Ntraj
      fx(i)=-k1*x(i)-2d0*x(i)*y(i)
      fy(i)=-k2*y(i)-x(i)**2+y(i)**2
      pe(i)=k1*x(i)**2/2d0+k2*y(i)**2/2d0+
     &      (x(i)**2*y(i)-y(i)**3/3d0)
      ENDDO
      ENDIF
! Coupled harmonic oscilator

      if(ipot .eq. 5) then
          do i=1,Ntraj
            fx(i)=-x(i)-0.2d0*x(i)**2
            fy(i)=-y(i)
            pe(i)=0.5d0*(x(i)**2+y(i)**2)+0.2d0*x(i)**3/3d0
          enddo
        endif

	RETURN
      END subroutine


    Program zgeevx_example

!     ZGEEVX Example Program Text

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

!     .. Use Statements ..
      Use lapack_interfaces, Only: zgeevx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: abnrm, eps, tol
      Integer :: i, ihi, ilo, info, j, lda, ldvl, ldvr, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), vl(:, :), vr(:, :), w(:), &
        work(:)
      Complex (Kind=dp) :: dummy(1)
      Real (Kind=dp), Allocatable :: rconde(:), rcondv(:), rwork(:), scale(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZGEEVX Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldvl = n
      ldvr = n
      Allocate (a(lda,n), vl(ldvl,n), vr(ldvr,n), w(n), rconde(n), rcondv(n), &
        rwork(2*n), scale(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call zgeevx('Balance', 'Vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, w, vl, ldvl, vr, ldvr, &
        ilo, ihi, scale, abnrm, rconde, rcondv, dummy, lwork, rwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+1)*n, nint(real(dummy(1))))
      Allocate (work(lwork))

!     Read the matrix A from data file

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

!     Solve the eigenvalue problem

      Call zgeevx('Balance', 'Vectors (left)', 'Vectors (right)', &
        'Both reciprocal condition numbers', n, a, lda, w, vl, ldvl, vr, ldvr, &
        ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, rwork, info)

      If (info==0) Then

!       Compute the machine precision

        eps = epsilon(1.0E0_dp)
        tol = eps*abnrm

!       Print the eigenvalues and vectors, and associated condition
!       number and bounds

        Write (nout, *)
        Write (nout, *) 'Eigenvalues'
        Write (nout, *)
        Write (nout, *) '         Eigenvalue           rcond    error'

        Do j = 1, n

!         Print information on j-th eigenvalue

          If (rconde(j)>0.0_dp) Then
            If (tol/rconde(j)<10.0_dp*eps) Then
              Write (nout, 100) j, w(j), rconde(j), '-'
            Else
              Write (nout, 110) j, w(j), rconde(j), tol/rconde(j)
            End If
          Else
            Write (nout, 100) j, w(j), rconde(j), 'Inf'
          End If

        End Do

        Write (nout, *)
        Write (nout, *) 'Eigenvectors'
        Write (nout, *)
        Write (nout, *) '         Eigenvector          rcond    error'

        Do j = 1, n

!         Print information on j-th eigenvector

          Write (nout, *)

!         Make first real part component be positive
          If (real(vr(1,j))<0.0_dp) Then
            vr(1:n, j) = -vr(1:n, j)
          End If
          If (rcondv(j)>0.0_dp) Then
            If (tol/rcondv(j)<10.0_dp*eps) Then
              Write (nout, 100) j, vr(1, j), rcondv(j), '-'
            Else
              Write (nout, 110) j, vr(1, j), rcondv(j), tol/rcondv(j)
            End If
          Else
            Write (nout, 100) j, vr(1, j), rcondv(j), 'Inf'
          End If

          Write (nout, 120) vr(2:n, j)

        End Do
        Write (nout, *)
        Write (nout, *) 'Errors below 10*machine precision are not displayed'
      Else
        Write (nout, *)
        Write (nout, 130) 'Failure in ZGEEVX. INFO =', info
      End If

100   Format (1X, I2, 1X, '(', 1P, E11.4, ',', E11.4, ')', 1X, 0P, F7.4, 4X, &
        A)
110   Format (1X, I2, 1X, '(', 1P, E11.4, ',', E11.4, ')', 1X, 0P, F7.4, 1X, &
        1P, E8.1)
120   Format (1X, 3X, '(', 1P, E11.4, ',', E11.4, ')')
130   Format (1X, A, I4)

    End Program


program problem15
  use euler
  implicit none

  print *, binomial(40_8,20_8)

end program problem15


PROGRAM CNPE2_HT_VAL
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Mech. Eng. Department"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "CNPE2_HT"
 WRITE(*,*) "Dimension  :  	2D"
 WRITE(*,*) "Atmosphere :	Homogeneous"
 WRITE(*,*) "Boundary   : 	Shift Map"
 WRITE(*,*) "Impedance  : 	Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "PE Validation program"
 WRITE(*,*) "Choose source frequency - 1 (10 Hz), 2 (100 Hz), 3 (1000 Hz)"
 WRITE(*,*) ""
 READ *,    FREQ_I
 WRITE(*,*) "Atmospheric refraction - 1 (Isothermal), 2 (+0.1), 3 (-0.1)"
 WRITE(*,*) ""
 READ*,     ATMO_I
 WRITE(*,*) ""
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Ascension Island data driver variables
 WRITE(FREQ,'(I0)') FREQ_I
 WRITE(ATMO,'(I0)') ATMO_I
 FREQ_VAL = (/ 10.0_DP, 100.0_DP, 1000.0_DP /)
 Z_VAL    = (/ CMPLX(38.79_DP,38.41_DP,KIND=DPC), &
               CMPLX(12.81_DP,11.62_DP,KIND=DPC), &
               CMPLX( 5.96_DP, 2.46_DP,KIND=DPC) /)
 ATMO_REF = (/  0.0_DP,   0.1_DP,   -0.1_DP /)
 L        = 10000_DP
 ZS       = 5.000_DP
 ZR       = 1.000_DP
 F	      = FREQ_VAL(FREQ_I)
 Z        = Z_VAL(FREQ_I)
 R        = (Z-1.0_DP)/(Z+1.0_DP)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Discretization of the Atmosphere domain
 C0     = 343.0_DP
 LMBDA0 = C0/F
 K0     = 2.0_DP*PI*F/C0
 DZ     = LMBDA0/10
 DR     = LMBDA0/10
 H      = 100*LMBDA0
 HA     = 30*LMBDA0
 N      = FLOOR(H/DZ)
 M      = FLOOR(L/DR)
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS     = MAX(1,FLOOR(ZS/DZ))
 NR     = MAX(1,FLOOR(ZR/DZ))
 NA     = FLOOR(HA/DZ)
 A      = IM/(2.0_DP*K0*DZ**2)
 KU     = 1
 KL     = 1
 NDIAG  = KU+KL+1
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Absorbing coefficient
 AS = 4.897_DP*(10**(-9))*(F**3) - &
      7.119_DP*(10**(-6))*(F**2) + &
      3.109_DP*(10**(-3))*F + &
      0.113
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Atmosphere density and wave velocity
 ALLOCATE(C(N),K(N),DK2(N),ALT(N))
 DC = ATMO_REF(ATMO_I)
 DO NZ = 1,N
  ALT(NZ) = NZ*DZ
  C(NZ)   = C0+DC*ALT(NZ)
  K(NZ)   = 2.0_DP*PI*F/C(NZ)
  IF (NZ.GT.(N-NA)) THEN
   K(NZ)  = K(NZ)+AS*IM*(NZ-N+NA)**2/NA**2
  END IF
  DK2(NZ) = K(NZ)**2-K0**2
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Terrain Boundary condition
 ALLOCATE(X(M),TERR(M),TERR1(M),TERR2(M),SLOPX(M))
 DO MX = 0,M
  X(MX)     = MX*DR
  TERR(MX)  = 0.000_DP
  TERR1(MX) = 0.000_DP
  TERR2(MX) = 0.000_DP
  SLOPX(MX) = ATAN(TERR1(MX))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Starting field
 ALLOCATE(PHI(N,M+1),PC(N,M),QC(N,M),P(N,M),Q(N,M))
 A0 = 1.3717_DP
 A2 = -0.3701_DP
 B  = 3.0_DP
 DO NZ = 1,N
  PHI(NZ,1) = SQRT(IM*K0)* &
              ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B) + &
               R*(A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Boundary condition - Finite Difference
 ALLOCATE(T(N,N),D(N,N),E(N,N),I(N,N))
 TAU1    =  4.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 TAU2    = -1.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 SIGMA1  =  4.0_DP*Z/(3.0_DP*Z-2.0_DP*IM*K0*DZ)
 SIGMA2  = -1.0_DP*Z/(3.0_DP*Z-2.0_DP*IM*K0*DZ)
 !Matrix Initialization (Dense Matrices) - T, D and E
 T(:,:)  = 0.0_DP
 DO NZ = 2,N-1
  T(NZ,NZ-1) =  1.0_DP
  T(NZ,NZ)   = -2.0_DP
  T(NZ,NZ+1) =  1.0_DP
 END DO
 T(1,1)   = -2.0_DP+SIGMA1
 T(1,2)   =  1.0_DP+SIGMA2
 T(N,N-1) =  1.0_DP+TAU2
 T(N,N)   = -2.0_DP+TAU1
 E        = DDIAG(CMPLX(ALT,0.0_DP,KIND=DPC),N)
 D        = (IM/(2.0_DP*K0))*DDIAG(DK2,N)
 I        = EYE(N)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !System - M1 and M2
 ALLOCATE(M1(N,N),M2(N,N),MB2(NDIAG,N),MB1(NDIAG,N))
 C1 = CMPLX(1.0_DP,0.0_DP,KIND=DP)
 C2 = CMPLX(0.0_DP,0.0_DP,KIND=DP)
 BETA1 = 1.0_DP/(2.0_DP*IM*K0)+DR/2.0_DP
 BETA2 = 1.0_DP/(2.0_DP*IM*K0)-DR/2.0_DP
 M1  = I+A*BETA1*T+BETA1*D
 M2  = I+A*BETA2*T+BETA2*D
 MB1 = D2B(M1,N,KL,KU)
 MB2 = D2B(M2,N,KL,KU)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 ALLOCATE(MB1T(NDIAG,N),MB2T(KL+NDIAG,N),IPIV(N),TEMP(N,1))
 CALL CPU_TIME(TI)
 DO MX = 2,M+1
  WRITE(*,*) "Step :", MX-1, "out of", M
  !Matrix updating
  MB1T                  = MB1
  MB1T(KU+1,:)          = MB1(KU+1,:)-BETA1*IM*K0*TERR2(MX-1)*ALT
  MB2T(KL+1:KL+NDIAG,:) = MB2
  MB2T(KL+KU+1,:)       = MB2(KU+1,:)-BETA2*IM*K0*TERR2(MX-1)*ALT
  !Right hand side multiplication
  CALL ZGBMV('N',N,N,KL,KU,C1,MB1T,KL+KU+1,PHI(1:N,MX-1),1,C2,TEMP(:,1),1)   !Band matrix form
  WRITE(*,*) ".... Right-hand side multiplied"
  !System solving
  CALL ZGBSV(N,KL,KU,1,MB2T,2*KL+KU+1,IPIV,TEMP,N,INFO)                      !Band matrix form
  IF (INFO.NE.0) THEN
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*,*) ".... System solved"
  !Complex and real pressure
  PHI(1:N,MX)  = TEMP(:,1)
  PC(1:N,MX-1) = EXP(IM*K0*(MX-1)*DR)*PHI(1:N,MX)/SQRT((MX-1)*DR)
  P(1:N,MX-1)  = REALPART(PC(1:N,MX-1))
  WRITE(*,*)
 END DO
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 ALLOCATE(LP(N,M),LQ(N,M),LPG(M),LQG(M))
 P0 = ABS(PC(NS,1))                   !Reference pressure (real)
 Q0 = ABS(QC(NS,1))                   !Reference corrected pressure (real)
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 10.0_DP*LOG10(ABS(PC(NZ,MX))**2/(P0**2))
   LQ(NZ,MX) = 10.0_DP*LOG10(ABS(QC(NZ,MX))**2/(Q0**2))
   IF (LP(NZ,MX).LE.-120) THEN
    LP(NZ,MX) = -120
    LQ(NZ,MX) = -120
   END IF
  END DO
 END DO
 LP0 = LP(NS,1)
 LQ0 = LQ(NS,1)
 LPG = LP(1,1:M)
 LQG = LQ(1,1:M)
 LPR = LP(NR,M)
 LQR = LQ(NR,M)
 PR  = SQRT(2.0_DP)*P0*10**(LPR/20)
 QR  = SQRT(2.0_DP)*Q0*10**(LPR/20)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Output
 OUT_EXT  = "W" // WIDE // "_A" // ATMO // "_f" // FREQ
 OUT_LPg  = "LPg_"  // TRIM(OUT_EXT) // ".dat"
 OPEN(UNIT=10,FILE=TRIM(OUT_LPg))
 DO MX = 1,M
  WRITE(10,100) X(MX), LPG(MX)
 END DO
 100 FORMAT(3(3X,F12.3))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 DEALLOCATE(PHI,PC,QC,P,Q,LP,LQ)
 WRITE(*,*) "================================================"
 WRITE(*,*) "Input file  : ", TOPO
 WRITE(*,*) "================================================"
 WRITE(*,*) "Output file : ", TRIM(OUT_LPg)
 WRITE(*,*) "              ", TRIM(OUT_TOPO)
 WRITE(*,*) "================================================"
 WRITE(*,*)
 WRITE(*,*) "System size (N x M) :", N, M
 WRITE(*,*) "Step size :", DR
 WRITE(*,*) "Main CPU time (s) :", TF-TI
 WRITE(*,*) "Real pressure at the source - P0 (Pa) :", P0
 WRITE(*,*) "Real pressure at the target - PR (Pa) :", PR
 WRITE(*,*) "SPL/TL at the target - LPR (dB) :", LPR
 WRITE(*,*)
 !-----------------------------------------------------------
 !----------------------------------------------------------
END PROGRAM CNPE2_HT_VAL


! wireframe.f90
!
! Double buffered software rendering of a 3-D wire-frame model. The model
! is loaded from a Wavefront OBJ file.
!
! Author:  Philipp Engel
! Licence: ISC
module vector
    implicit none
    real, parameter :: pi = acos(-1.0)

    public :: project
    public :: rotate_x
    public :: rotate_y
    public :: rotate_z

    type :: point2d
        real :: x, y
    end type point2d

    type :: point3d
        real :: x, y, z
    end type point3d
contains
    type(point2d) function project(v, width, height, fov, distance) result(p)
        !! Transforms a 3-D vector to a 2-D vector by using perspective projection.
        type(point3d), intent(in) :: v
        integer,       intent(in) :: width
        integer,       intent(in) :: height
        real,          intent(in) :: fov
        real,          intent(in) :: distance
        real                      :: f

        f   = fov / (distance + v%z)
        p%x = v%x * f + width / 2
        p%y = -1 * v%y * f + height / 2
    end function project

    real function rad(deg)
        !! Converts an angle from deg to rad.
        real, intent(in) :: deg

        rad = deg * pi / 180
    end function rad

    type(point3d) function rotate_x(v, angle) result(r)
        !! Rotates vector in x.
        type(point3d), intent(in) :: v
        real,          intent(in) :: angle

        r%x = v%x
        r%y = v%y * cos(angle) - v%z * sin(angle)
        r%z = v%z * sin(angle) + v%z * cos(angle)
    end function rotate_x

    type(point3d) function rotate_y(v, angle) result(r)
        !! Rotates vector in y.
        type(point3d), intent(in) :: v
        real,          intent(in) :: angle

        r%x = v%z * sin(angle) + v%x * cos(angle)
        r%y = v%y
        r%z = v%z * cos(angle) - v%x * sin(angle)
    end function rotate_y

    type(point3d) function rotate_z(v, angle) result(r)
        !! Rotates vector in z.
        type(point3d), intent(in) :: v
        real,          intent(in) :: angle

        r%x = v%x * cos(angle) - v%y * sin(angle)
        r%y = v%x * sin(angle) - v%y * cos(angle)
        r%z = v%z
    end function rotate_z
end module vector

module obj
    !! Loads and stores a 3-D object.
    use :: vector
    implicit none

    type :: face
        integer :: v1, v2
    end type face

    type(point3d), allocatable :: vertices(:)
    type(face),    allocatable :: faces(:)

    public :: load_obj_file
contains
    subroutine load_obj_file(file_name)
        !! Loads a Wavefront OBJ file.
        character(len=*), intent(in) :: file_name       !! File name.
        integer,          parameter  :: U = 10          !! Output unit.
        character(len=100)           :: buffer          !! Line buffer.
        character(len=1)             :: str             !! Temporary string.
        integer                      :: v_size, f_size  !! Array sizes.
        integer                      :: rc              !! I/O status.
        type(point3d), allocatable   :: tmp_vertices(:) !! Temporary array for vertices.
        type(face),    allocatable   :: tmp_faces(:)    !! Temporary array for faces.

        allocate (vertices(1))
        allocate (faces(1))

        open (unit=U, file=file_name, action='read', iostat=rc)

        if (rc == 0) then
            do
                read (U, '(a)', iostat=rc) buffer
                if (rc /= 0) exit

                select case (buffer(1:1))
                    case ('v')
                        ! Read vertice.
                        v_size = size(vertices)
                        allocate (tmp_vertices(v_size + 1))
                        tmp_vertices(1:v_size) = vertices

                        read (buffer, *) str, &
                                         tmp_vertices(v_size)%x, &
                                         tmp_vertices(v_size)%y, &
                                         tmp_vertices(v_size)%z

                        call move_alloc(tmp_vertices, vertices)
                    case ('f')
                        ! Read face.
                        f_size = size(faces)
                        allocate (tmp_faces(f_size + 1))
                        tmp_faces(1:f_size) = faces

                        read (buffer, *) str, &
                                         tmp_faces(f_size)%v1, &
                                         tmp_faces(f_size)%v2

                        call move_alloc(tmp_faces, faces)
                    case default
                        continue
                end select
            end do
        else
            print *, 'Reading file "', file_name, '" failed: ', rc
        end if

        close (U)

        ! Resize the arrays to their actual sizes (ugly, I know ...).
        if (allocated(tmp_vertices)) &
            deallocate (tmp_vertices)

        if (allocated(tmp_faces)) &
            deallocate (tmp_faces)

        ! Actual array sizes.
        v_size = size(vertices) - 1
        f_size = size(faces) - 1

        allocate (tmp_vertices(v_size))
        allocate (tmp_faces(f_size))

        tmp_vertices = vertices(1:v_size)
        tmp_faces    = faces(1:f_size)

        call move_alloc(tmp_vertices, vertices)
        call move_alloc(tmp_faces, faces)
    end subroutine load_obj_file
end module obj

program main
    use, intrinsic :: iso_c_binding, only: c_ptr, c_null_char, c_bool, c_ptr
    use :: xlib
    use :: obj
    use :: vector
    implicit none
    integer,          parameter :: WIDTH     = 640
    integer,          parameter :: HEIGHT    = 480
    character(len=*), parameter :: FILE_NAME = 'examples/wireframe/tie.obj'

    type(c_ptr)                :: display
    type(c_ptr)                :: gc
    type(x_color)              :: color
    type(x_event)              :: event
    type(x_gc_values)          :: values
    type(x_size_hints)         :: size_hints
    integer                    :: screen
    integer                    :: rc
    integer(kind=8)            :: root
    integer(kind=8)            :: colormap
    integer(kind=8)            :: double_buffer
    integer(kind=8)            :: black
    integer(kind=8)            :: white
    integer(kind=8)            :: window
    integer(kind=8)            :: wm_delete_window
    integer(kind=8)            :: long(5)
    type(point2d), allocatable :: transformed(:)
    real                       :: angle_x = 0.0
    real                       :: angle_y = 0.0
    real                       :: angle_z = 0.0

    interface
        subroutine usleep(useconds) bind(c)
            !! Interface to usleep in libc.
            use, intrinsic :: iso_c_binding, only: c_int32_t
            integer(c_int32_t), value :: useconds
        end subroutine
    end interface

    call load_obj_file(FILE_NAME)

    if (.not. allocated(vertices) .or. .not. allocated(faces)) &
        stop

    ! Open display.
    display  = x_open_display(c_null_char)
    screen   = x_default_screen(display)
    root     = x_default_root_window(display)
    colormap = x_default_colormap(display, screen)

    ! Define colours.
    black = x_black_pixel(display, screen)
    white = x_white_pixel(display, screen)

    rc = x_alloc_named_color(display, colormap, 'SteelBlue' // c_null_char, color, color)

    if (rc == 0) then
        print *, 'XAllocNamedColor failed to allocate "SteelBlue" colour.'
        stop
    end if

    ! Create window.
    window = x_create_simple_window(display, root, 0, 0, WIDTH, HEIGHT, 0, white, black)
    call x_store_name(display, window, 'Fortran' // c_null_char)

    wm_delete_window = x_intern_atom(display, 'WM_DELETE_WINDOW' // c_null_char, .false._c_bool)
    rc = x_set_wm_protocols(display, window, wm_delete_window, 1)

    ! Prevent resizing.
    size_hints%flags      = ior(P_MIN_SIZE, P_MAX_SIZE)
    size_hints%min_width  = WIDTH
    size_hints%min_height = HEIGHT
    size_hints%max_width  = WIDTH
    size_hints%max_height = HEIGHT

    call x_set_wm_normal_hints(display, window, size_hints)

    ! Create graphics context.
    gc = x_create_gc(display, window, 0, values)

    call x_set_background(display, gc, black)
    call x_set_foreground(display, gc, white)

    ! Create double buffer.
    double_buffer = x_create_pixmap(display, window, WIDTH, HEIGHT, 24)

    ! Show window.
    call x_select_input(display, window, ior(EXPOSURE_MASK, STRUCTURE_NOTIFY_MASK))
    call x_map_window(display, window)

    do
        rc = x_pending(display)

        if (rc > 0) then
            call x_next_event(display, event)

            select case (event%type)
                case (expose)
                    ! call draw()
                case (client_message)
                    long = transfer(event%x_client_message%data, long)

                    if (long(1) == wm_delete_window) &
                        exit
            end select
        else
            call update(angle_x, angle_y, angle_z)
            call render()

            ! angle_x = angle_x + 1.0
            angle_y = angle_y + 1.0
            ! angle_z = angle_z + 1.0

            call draw()
            call microsleep(25000)
        end if
    end do

    ! Clean up and close window.
    call x_free_colors(display, colormap, [ color%pixel ], 1, int(0, kind=8))
    call x_free_pixmap(display, double_buffer)
    call x_free_gc(display, gc)
    call x_destroy_window(display, window)
    call x_close_display(display)
contains
    subroutine microsleep(t)
        !! Wrapper for usleep.
        integer, intent(in) :: t

        call usleep(int(t, c_int32_t))
    end subroutine microsleep

    subroutine update(angle_x, angle_y, angle_z)
        !! Rotates the 3-D object.
        real, intent(in) :: angle_x
        real, intent(in) :: angle_y
        real, intent(in) :: angle_z
        type(point3d)    :: v
        integer          :: i

        if (.not. allocated(transformed)) &
            allocate (transformed(size(vertices)))

        do i = 1, size(vertices, 1)
            v = vertices(i)
            v = rotate_x(v, rad(angle_x))
            v = rotate_y(v, rad(angle_y))
            v = rotate_z(v, rad(angle_z))
            transformed(i) = project(v, WIDTH, HEIGHT, 256.0, 8.0)
        end do
    end subroutine update

    subroutine render()
        !! Renders the scene on the double buffer.
        integer :: x1, y1, x2, y2
        integer :: i

        call x_set_foreground(display, gc, black)
        call x_fill_rectangle(display, double_buffer, gc, 0, 0, WIDTH, HEIGHT)
        call x_set_foreground(display, gc, color%pixel)

        do i = 1, size(faces, 1)
            x1 = int(transformed(faces(i)%v1)%x)
            y1 = int(transformed(faces(i)%v1)%y)
            x2 = int(transformed(faces(i)%v2)%x)
            y2 = int(transformed(faces(i)%v2)%y)

            call x_draw_line(display, double_buffer, gc, x1, y1, x2, y2)
        end do
    end subroutine render

    subroutine draw()
        !! Copies double buffer to window.
        call x_copy_area(display, double_buffer, window, gc, 0, 0, WIDTH, HEIGHT, 0, 0)
    end subroutine draw
end program main


program testcap
    use defcapsol
    implicit none
    integer :: n, m, l_js, verbose, d_steps, test
    real(dp) :: h0, rho_max, Z_max, rtip, theta_deg, hcone, rcant, hsam, dcant, eps_r
    real(dp) :: C_unitless   ! finest grid spacing and simulation box size (truncation lengths)

    character*10 method_in

    real(dp), allocatable :: hess(:, :) ! grid-spacing and coordinates of each grid point

    ! Nuni = 5
    n=500
    m=500
    l_js=20
    h0=0.5_dp
    rho_max=1d6
    Z_max=1d6
    d_steps=20
    rtip=20.0
    theta_deg=15.0
    hcone=15000.0
    rcant=15000.0
    dcant=500.0
    eps_r=5.0
    hsam=10.0
    method_in='LAPACK'
    test=0
    verbose=2
    C_unitless = 0.0_dp

    allocate (Hess(0:min(m+ l_js + d_steps + 1, n+1), (n+1)*( l_js + d_steps  + m + 1)))

    CALL CapSolCyl(n,m,l_js, h0,rho_max,z_max, d_steps, rtip,theta_deg, hcone, rcant, &
    dcant, eps_r,hsam, method_in, test, verbose, C_unitless, Hess)

    deallocate (Hess)
end program testcap


C
C       $Id$
C
      FUNCTION SH3VAL (PX,PY,PZ,N,X,Y,Z,F,NR,LCELL,LNEXT,
     +                 XYZMIN,XYZDEL,RMAX,RSQ,A)
      INTEGER N, NR, LCELL(NR,NR,NR), LNEXT(N)
      REAL    PX, PY, PZ, X(N), Y(N), Z(N), F(N), XYZMIN(3),
     +        XYZDEL(3), RMAX, RSQ(N), A(9,N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       UNIV. OF NORTH TEXAS
C                                             (817) 565-2767
C                                                   10/28/87
C
C  This function returns the value Q(PX,PY,PZ) where Q is
C  the weighted sum of quadratic nodal functions defined in
C  subroutine SHQSHEP.  SH3GRD may be called to compute a
C  gradient of Q along with the value, and/or to test for
C  errors.
C
C  ON INPUT --
C
C    PX,PY,PZ = Cartesian coordinates of the point P at
C               which Q is to be evaluated.
C
C    N = Number of nodes and data values defining Q.
C        N .GE. 10.
C
C    X,Y,Z,F = Arrays of length N containing the nodes
C              and data values interpolated by Q.
C
C    NR = Number of rows, columns, and planes in the cell
C         grid.  Refer to SHSTORE3.  NR .GE. 1.
C
C    LCELL = NR by NR by NR array of nodal indices associated
C            with cells.  Refer to SHSTORE3.
C
C    LNEXT = Array of length N containing next-node indices
C            Refer to SHSTORE3.
C
C    XYZMIN,XYZDEL = Arrays of length 3 containing minimum
C                    nodal coordinates and cell dimensions
C                    respectively.  XYZDEL elements must be
C                    positive.  Refer to SHSTORE3.
C
C    RMAX = Square root of the largest element in RSQ --
C           maximum radius.
C
C    RSQ = Array of length N containing the squared radii
C          which enter into the weights defining Q.
C
C    A = 9 by N array containing the coefficients for the
C        nodal functions defining Q.
C
C  Input parameters are not altered by this function.  The
C  parameters other than PX, PY and PZ should be input unaltered
C  from their values on output from SHQSHEP.  This function
C  should not be called if a nonzero error flag was returned by
C  SHQSHEP.
C
C  ON OUTPUT --
C
C    SH3VAL = function value Q(PX,PY,PZ) unless N, NR,
C             XYZDEL, or RMAX is invalid, in which case
C             no value is returned.
C
C  MODULES REQUIRED BY SH3VAL -- NONE
C
C  INTRINSIC FUNCTIONS CALLED BY SH3VAL -- IFIX, SQRT
C
C***********************************************************
C
      XP = PX
      YP = PY
      ZP = PZ
      XMIN = XYZMIN(1)
      YMIN = XYZMIN(2)
      ZMIN = XYZMIN(3)
      DX = XYZDEL(1)
      DY = XYZDEL(2)
      DZ = XYZDEL(3)
      IF (N .LT. 10) THEN
        GO TO 30
      ELSEIF (NR .LT. 1) THEN
        GO TO 31
      ELSEIF (DX .LE. 0.) THEN
        GO TO 32
      ELSEIF (DY .LE. 0.) THEN
        GO TO 33
      ELSEIF (DZ .LE. 0.) THEN
        GO TO 34
      ELSEIF (RMAX .LT. 0.) THEN
        GO TO 35
      ENDIF
C
C  Set IMIN, IMAX, JMIN, JMAX, KMIN, and KMAX to cell indices
C  defining the range of the search for nodes whose radii
C  include P.  The cells which must be searched are those
C  intersected by (or contained in) a sphere of radius RMAX
C  centered at P.
C
      IMIN = IFIX((XP-XMIN-RMAX)/DX) + 1
      IMAX = IFIX((XP-XMIN+RMAX)/DX) + 1
      IF (IMIN .LT. 1) IMIN = 1
      IF (IMAX .GT. NR) IMAX = NR
      JMIN = IFIX((YP-YMIN-RMAX)/DY) + 1
      JMAX = IFIX((YP-YMIN+RMAX)/DY) + 1
      IF (JMIN .LT. 1) JMIN = 1
      IF (JMAX .GT. NR) JMAX = NR
      KMIN = IFIX((ZP-ZMIN-RMAX)/DZ) + 1
      KMAX = IFIX((ZP-ZMIN+RMAX)/DZ) + 1
      IF (KMIN .LT. 1) KMIN = 1
      IF (KMAX .GT. NR) KMAX = NR
C
C  The following is a test for no cells within the sphere
C  of radius RMAX.
C
      IF (IMIN .GT. IMAX  .OR.  JMIN .GT. JMAX  .OR.
     .    KMIN .GT. KMAX) GO TO 5
C
C  Accumulate weight values in SW and weighted nodal function
C  values in SWQ.  The weights are W(L) = ((R-D)+/(R*D))**2
C  for R**2 = RSQ(L) and D = distance between P and node L.
C
      SW = 0.
      SWQ = 0.
C
C  Outer loop on cells (I,J,K).
C
      DO 3 K = KMIN,KMAX
        DO 3 J = JMIN,JMAX
          DO 3 I = IMIN,IMAX
            L = LCELL(I,J,K)
            IF (L .EQ. 0) GO TO 3
C
C  Inner loop on nodes L.
C
    1       DELX = XP - X(L)
            DELY = YP - Y(L)
            DELZ = ZP - Z(L)
            DXSQ = DELX*DELX
            DYSQ = DELY*DELY
            DZSQ = DELZ*DELZ
            DS = DXSQ + DYSQ + DZSQ
            RS = RSQ(L)
            IF (DS .GE. RS) GO TO 2
            IF (DS .EQ. 0.) GO TO 4
            RDS = RS*DS
            RD = SQRT(RDS)
            W = (RS+DS-RD-RD)/RDS
            SW = SW + W
            SWQ = SWQ + W*( A(1,L)*DXSQ + A(2,L)*DELX*DELY +
     +                      A(3,L)*DYSQ + A(4,L)*DELX*DELZ +
     +                      A(5,L)*DELY*DELZ + A(6,L)*DZSQ +
     +                      A(7,L)*DELX + A(8,L)*DELY +
     +                      A(9,L)*DELZ + F(L) )
C
C  Bottom of loop on nodes in cell (I,J,K).
C
    2       LP = L
            L = LNEXT(LP)
            IF (L .NE. LP) GO TO 1
    3       CONTINUE
C
C  SW = 0 iff P is not within the radius R(L) for any node L.
C
      IF (SW .EQ. 0.) GO TO 5
      SH3VAL = SWQ/SW
      RETURN
C
C  (PX,PY,PZ) = (X(L),Y(L),Z(L))
C
    4 SH3VAL = F(L)
      RETURN
C
C  All weights are 0 at P.
C
    5 SH3VAL = 0.
      RETURN
C
C  Invalid input parameter.
C
   30 CONTINUE
      CALL SHERR (1,'SH3VAL - number of input data must be > 9',41)
      SH3VAL = 0.
      RETURN
   31 CONTINUE
      CALL SHERR (7,'SH3VAL - cell grid dimensions must be positive',
     +            46)
      SH3VAL = 0.
      RETURN
   32 CONTINUE
      CALL SHERR (10,'SH3VAL - at least two points must have different X
     + coordinates',62)
      SH3VAL = 0.
      RETURN
   33 CONTINUE
      CALL SHERR (11,'SH3VAL - at least two points must have different Y
     + coordinates',62)
      SH3VAL = 0.
      RETURN
   34 CONTINUE
      CALL SHERR (12,'SH3VAL - at least two points must have different Z
     + coordinates',62)
      SH3VAL = 0.
      RETURN
   35 CONTINUE
      CALL SHERR (14,
     +'SH3GRD - negative search radius in calculating least squares fit'
     +           ,64)
      SH3VAL = 0.
      RETURN
      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_metrz0
      use m_juDFT
c     *****************************************************
c     calculates weights for a 7-point simpson integration
c     in analogy to intgz0
c                         r.pentcheva,24.06.96,kfa
c     work array whelp eliminated
c                         s.bluegel,  BNL 9.Aug.96
c     *****************************************************
      CONTAINS
      SUBROUTINE metr_z0(
     >                   nz,
     <                   wght)

      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: nz
C     ..
C     .. Array Arguments ..
      REAL,    INTENT (OUT) :: wght(nz)
C     ..
C     .. Local Scalars ..
      INTEGER i,iz,j,iz0,jz,nsteps
      INTEGER, PARAMETER :: nz7  = 7 , nz6 = 6
      REAL,    PARAMETER :: h0 = 140.
C     ..
C     .. Local Arrays ..
!
! lagrangian integration coefficients (simpson 7 point rule: error  h**9)
!
      INTEGER, DIMENSION(7),   PARAMETER :: ih =
     +                                       (/41,216,27,272,27,216,41/)
      REAL,    DIMENSION(7,5), PARAMETER :: a = RESHAPE(
     +  (/19087.,65112.,-46461., 37504.,-20211., 6312.,-863.,
     +     -863.,25128., 46989.,-16256.,  7299.,-2088., 271.,
     +      271.,-2760., 30819., 37504., -6771., 1608.,-191.,
     +     -191., 1608., -6771., 37504., 30819.,-2760., 271.,
     +      271.,-2088.,  7299.,-16256., 46989.,25128.,-863./),(/7,5/))
C     ..
      wght(:)=0.0
      nsteps = (nz-1)/nz6
      iz0 = nz-nz6*nsteps
      DO iz = 1, iz0-1
c
c---> for iz-points, 1<iz<iz0<7, use lagrange interpolation, error: h**9
         DO jz = 1, nz7
            wght(nz+1-iz) = wght(nz+1-iz)+ a(jz,iz)/432.0
         ENDDO
      ENDDO
c---> weights for simpson integration
      iz0 = nz - iz0 + 2
      DO j=1,nsteps
         DO i=1,nz7
            wght(iz0-i) = wght(iz0-i) + ih(i)
         ENDDO
         iz0 = iz0 - nz6
      ENDDO
      IF (iz0-1.ne.1)  CALL juDFT_error("iz0><nz0",calledby="metr_z0")
      wght(:)=wght(:)/h0

      END SUBROUTINE metr_z0
      END MODULE m_metrz0


program logistic_function
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none
    real(kind=DP) :: x, x0, r
    integer :: nr_iterations, i

    call get_parameters(x0, r, nr_iterations)
    x = x0
    do i = 1, nr_iterations
        x = logistic_iteration(x, r)
        print '(I0, F15.7)', i, x
    end do

contains

    function logistic_iteration(x, r) result(y)
        implicit none
        real(kind=DP), value :: x, r
        real(kind=DP) :: y

        y = r*x*(1.0_DP - x)
    end function logistic_iteration

    subroutine get_parameters(x0, r, nr_iterations)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real(kind=DP), intent(out) :: x0, r
        integer, intent(out) :: nr_iterations
        character(len=1024) :: buffer, msg
        integer :: status

        if (command_argument_count() /= 3) then
            x0 = 0.5
            r = 3.0
            nr_iterations = 1000
        else
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) x0
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
                stop 1
            end if
            call get_command_argument(2, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) r
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
                stop 1
            end if
            call get_command_argument(3, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) nr_iterations
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
                stop 1
            end if
        end if
    end subroutine get_parameters

end program logistic_function


module matrix_ops
    use :: precision_defs, only : dp
    implicit none
    private
    public :: init_matrix, print_matrix, print_vector

contains

    subroutine init_matrix(A)
        implicit none
        real(kind=dp), dimension(:,:), intent(out) :: A
        integer :: i, j
        do j = 1, size(A, 2)
            do i = 1, size(A, 1)
                call random_number(A(i, j))
            end do
        end do
    end subroutine init_matrix

    subroutine print_matrix(A, label)
        implicit none
        real(kind=dp), dimension(:,:), intent(in) :: A
        character(len=*), optional, intent(in) :: label
        integer :: i
        character(len=40) :: format_str
        if (present(label)) then
            write (*, "(2A)") label, ":"
        end if
        write (format_str, "(A,I3,A)") "(", size(A, 2), "(F8.3))"
        do i = 1, size(A, 1)
            write (*, format_str) A(i, :)
        end do
    end subroutine print_matrix

    subroutine print_vector(v, label)
        implicit none
        real(kind=dp), dimension(:), intent(in) :: v
        character(len=*), optional, intent(in) :: label
        character(len=40) :: format_str
        if (present(label)) then
            write (*, "(2A)") label, ":"
        end if
        write (format_str, "(A,I3,A)") "(", size(v), "(F8.3))"
        write (*, format_str) v(:)
    end subroutine print_vector

end module matrix_ops


program tpk
  implicit none

  real, parameter :: overflow = 400.0
  real :: a(11), res
  integer :: i

  write(*,*) "Input eleven numbers:"
  read(*,*) a

  a = a(11:1:-1)
  do i = 1, 11
    res = f(a(i))
    write(*, "(a, f0.3, a)", advance = "no") "f(", a(i), ") = "
    if(res > overflow) then
      write(*, "(a)") "overflow!"
    else
       write(*, "(f0.3)") res
    end if
  end do

contains

real function f(x)
  real, intent(in) :: x

  f = sqrt(abs(x)) + 5.0*x**3

end function
end program


!-----------------------------------------------------------------------
! Update soil temperatures
!-----------------------------------------------------------------------
subroutine SOIL(csoil,Gsoil,ksoil)

use DRIVING, only : &
  dt                  ! Timestep (s)

use GRID, only : &
  Dzsoil,            &! Soil layer thicknesses (m)
  Nsoil               ! Number of soil layers

use STATE_VARIABLES, only : &
  Tsoil               ! Soil layer temperatures (K)

implicit none

real*8, intent(in) :: &
  csoil(Nsoil),      &! Areal heat capacity of soil (J/K/m^2)
  Gsoil,             &! Heat flux into soil (W/m^2)
  ksoil(Nsoil)        ! Thermal conductivity of soil (W/m/K)

integer*8 :: &
  k                   ! Level counter

real*8 :: &
  a(Nsoil),          &! Below-diagonal matrix elements
  b(Nsoil),          &! Diagonal matrix elements
  c(Nsoil),          &! Above-diagonal matrix elements
  dTs(Nsoil),        &! Temperature increments (k)
  Gs(Nsoil),         &! Thermal conductivity between layers (W/m^2/k)
  rhs(Nsoil)          ! Matrix equation rhs

do k = 1, Nsoil - 1
  Gs(k) = 2 / (Dzsoil(k)/ksoil(k) + Dzsoil(k+1)/ksoil(k+1))
end do
a(1) = 0
b(1) = csoil(1) + Gs(1)*dt
c(1) = - Gs(1)*dt
rhs(1) = (Gsoil - Gs(1)*(Tsoil(1) - Tsoil(2)))*dt
do k = 2, Nsoil - 1
  a(k) = c(k-1)
  b(k) = csoil(k) + (Gs(k-1) + Gs(k))*dt
  c(k) = - Gs(k)*dt
  rhs(k) = Gs(k-1)*(Tsoil(k-1) - Tsoil(k))*dt  &
           + Gs(k)*(Tsoil(k+1) - Tsoil(k))*dt
end do
k = Nsoil
Gs(k) = ksoil(k)/Dzsoil(k)
a(k) = c(k-1)
b(k) = csoil(k) + (Gs(k-1) + Gs(k))*dt
c(k) = 0
rhs(k) = Gs(k-1)*(Tsoil(k-1) - Tsoil(k))*dt
call TRIDIAG(Nsoil,Nsoil,a,b,c,rhs,dTs)
do k = 1, Nsoil
  Tsoil(k) = Tsoil(k) + dTs(k)
end do

end subroutine SOIL


      SUBROUTINE MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN,
     $                   TOL, IWORK, 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
C
C     (a)    F(delta) =  exp(A*delta) and
C
C     (b)    H(delta) =  Int[F(s) ds] from s = 0 to s = delta,
C
C     where A is a real N-by-N matrix and delta is a scalar value.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     DELTA   (input) DOUBLE PRECISION
C             The scalar value delta of the problem.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             matrix A of the problem. (Array A need not be set if
C             DELTA = 0.)
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,N).
C
C     EX      (output) DOUBLE PRECISION array, dimension (LDEX,N)
C             The leading N-by-N part of this array contains an
C             approximation to F(delta).
C
C     LDEX    INTEGER
C             The leading dimension of array EX.  LDEX >= MAX(1,N).
C
C     EXINT   (output) DOUBLE PRECISION array, dimension (LDEXIN,N)
C             The leading N-by-N part of this array contains an
C             approximation to H(delta).
C
C     LDEXIN  INTEGER
C             The leading dimension of array EXINT.  LDEXIN >= MAX(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in determining the order of the
C             Pade approximation to H(t), where t is a scale factor
C             determined by the routine. A reasonable value for TOL may
C             be SQRT(EPS), where EPS is the machine precision (see
C             LAPACK Library routine DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
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. LDWORK >= MAX(1,N*(N+1)).
C             For optimum performance LDWORK should be larger (2*N*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             > 0:  if INFO = i, the (i,i) element of the denominator of
C                   the Pade approximation is zero, so the denominator
C                   is exactly singular;
C             = N+1:  if DELTA = (delta * frobenius norm of matrix A) is
C                   probably too large to permit meaningful computation.
C                   That is, DELTA > SQRT(BIG), where BIG is a
C                   representable number near the overflow threshold of
C                   the machine (see LAPACK Library Routine DLAMCH).
C
C     METHOD
C
C     This routine uses a Pade approximation to H(t) for some small
C     value of t (where 0 < t <= delta) and then calculates F(t) from
C     H(t). Finally, the results are re-scaled to give F(delta) and
C     H(delta). For a detailed description of the implementation of this
C     algorithm see [1].
C
C     REFERENCES
C
C     [1] Benson, C.J.
C         The numerical evaluation of the matrix exponential and its
C         integral.
C         Report 82/03, Control Systems Research Group,
C         School of Electronic Engineering and Computer
C         Science, Kingston Polytechnic, January 1982.
C
C     [2] Ward, R.C.
C         Numerical computation of the matrix exponential with accuracy
C         estimate.
C         SIAM J. Numer. Anal., 14, pp. 600-610, 1977.
C
C     [3] Moler, C.B. and Van Loan, C.F.
C         Nineteen Dubious Ways to Compute the Exponential of a Matrix.
C         SIAM Rev., 20, pp. 801-836, 1978.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997.
C     Supersedes Release 2.0 routine MB05BD by C.J. Benson, Kingston
C     Polytechnic, January 1982.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Continuous-time system, matrix algebra, matrix exponential,
C     matrix operations, Pade approximation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE, ONE64, THREE, FOUR8
      PARAMETER         ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
     $                    ONE64 = 1.64D0, THREE = 3.0D0, FOUR8 = 4.8D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDEX, LDEXIN, LDWORK, N
      DOUBLE PRECISION  DELTA, TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), EX(LDEX,*), EXINT(LDEXIN,*)
C     .. Local Scalars ..
      INTEGER           I, I2IQ1, IJ, IQ, J, JSCAL, KK, L, NN
      DOUBLE PRECISION  COEFFD, COEFFN, DELSC, EPS, ERR, F2IQ1,
     $                  FNORM, FNORM2, QMAX, SMALL
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMM, DGEMV, DGESV, DLACPY,
     $                  DLASET, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, EXP, MAX, MOD, SQRT
C     .. Executable Statements ..
C
      INFO = 0
      NN = N*N
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDEX.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDEXIN.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDWORK.LT.MAX( 1, NN + N ) ) THEN
         INFO = -12
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB05ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      DWORK(1) = ONE
      IF ( N.EQ.0 )
     $   RETURN
C
      CALL DLASET( 'Full', N, N, ZERO, ZERO, EX, LDEX )
      CALL DLASET( 'Full', N, N, ZERO, ZERO, EXINT, LDEXIN )
C
      IF ( DELTA.EQ.ZERO ) THEN
         CALL DLASET( 'Upper', N, N, ZERO, ONE, EX, LDEX )
         RETURN
      END IF
C
      IF ( N.EQ.1 ) THEN
         EX(1,1) = EXP( DELTA*A(1,1) )
         IF ( A(1,1).EQ.ZERO ) THEN
            EXINT(1,1) = DELTA
         ELSE
            EXINT(1,1) = ( ( ONE/A(1,1) )*EX(1,1) ) - ( ONE/A(1,1) )
         END IF
         RETURN
      END IF
C
C     Set some machine parameters.
C
      EPS = DLAMCH( 'Epsilon' )
      SMALL = DLAMCH( 'Safe minimum' )/EPS
C
C     First calculate the Frobenius norm of A, and the scaling factor.
C
      FNORM = DELTA*DLANGE( 'Frobenius', N, N, A, LDA, DWORK )
C
      IF ( FNORM.GT.SQRT( ONE/SMALL ) ) THEN
         INFO = N + 1
         RETURN
      END IF
C
      JSCAL = 0
      DELSC = DELTA
C     WHILE ( FNORM >= HALF ) DO
   20 CONTINUE
      IF ( FNORM.GE.HALF ) THEN
         JSCAL = JSCAL + 1
         DELSC = DELSC*HALF
         FNORM = FNORM*HALF
         GO TO 20
      END IF
C     END WHILE 20
C
C     Calculate the order of the Pade approximation needed to satisfy
C     the requested relative error  TOL.
C
      FNORM2 = FNORM**2
      IQ = 1
      QMAX = FNORM/THREE
      ERR  = DELTA/DELSC*FNORM2**2/FOUR8
C     WHILE ( ERR > TOL*( 2*IQ + 3 - FNORM )/1.64 and QMAX >= EPS ) DO
   40 CONTINUE
      IF ( ERR.GT.TOL*( DBLE( 2*IQ + 3 ) - FNORM )/ONE64 ) THEN
         IQ = IQ + 1
         QMAX = QMAX*DBLE( IQ + 1 )*FNORM/DBLE( 2*IQ*( 2*IQ + 1 ) )
         IF ( QMAX.GE.EPS ) THEN
            ERR = ERR*FNORM2*DBLE( 2*IQ + 5 )/DBLE( ( 2*IQ + 3 )**2
     $                          *( 2*IQ + 4 ) )
            GO TO 40
         END IF
      END IF
C     END WHILE 40
C
C     Initialise DWORK (to contain succesive powers of A),
C                EXINT (to contain the numerator) and
C                EX    (to contain the denominator).
C
      I2IQ1 = 2*IQ + 1
      F2IQ1 = DBLE( I2IQ1 )
      COEFFD = -DBLE( IQ )/F2IQ1
      COEFFN = HALF/F2IQ1
      IJ = 1
C
      DO 80 J = 1, N
C
         DO 60 I = 1, N
            DWORK(IJ)  = DELSC*A(I,J)
            EXINT(I,J) = COEFFN*DWORK(IJ)
            EX(I,J)    = COEFFD*DWORK(IJ)
            IJ = IJ + 1
   60    CONTINUE
C
         EXINT(J,J) = EXINT(J,J) + ONE
         EX(J,J) = EX(J,J) + ONE
   80 CONTINUE
C
      DO 140 KK = 2, IQ
C
C        Calculate the next power of  A*DELSC,  and update the numerator
C        and denominator.
C
         COEFFD = -COEFFD*DBLE( IQ+1-KK )/DBLE( KK*( I2IQ1+1-KK ) )
         IF ( MOD( KK, 2 ).EQ.0 ) THEN
            COEFFN = COEFFD/DBLE( KK + 1 )
         ELSE
            COEFFN = -COEFFD/DBLE( I2IQ1 - KK )
         END IF
         IJ = 1
C
         IF ( LDWORK.GE.2*NN ) THEN
C
C           Enough space for a BLAS 3 calculation.
C
            CALL DGEMM( 'No transpose', 'No transpose', N, N, N, DELSC,
     $                  A, LDA, DWORK, N, ZERO, DWORK(NN+1), N )
            CALL DCOPY( NN, DWORK(NN+1), 1, DWORK, 1 )
C
            DO 100 J = 1, N
               CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 )
               CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 )
               IJ = IJ + N
  100       CONTINUE
C
         ELSE
C
C           Not enough space for a BLAS 3 calculation. Use BLAS 2.
C
            DO 120 J = 1, N
               CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, DWORK(IJ),
     $                     1, ZERO, DWORK(NN+1), 1 )
               CALL DCOPY( N, DWORK(NN+1), 1, DWORK(IJ), 1 )
               CALL DSCAL( N, DELSC, DWORK(IJ), 1 )
               CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 )
               CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 )
               IJ = IJ + N
  120       CONTINUE
C
         END IF
  140 CONTINUE
C
C     We now have numerator in EXINT, denominator in EX.
C
C     Solve the set of N systems of linear equations for the columns of
C     EXINT  using the LU factorization of EX.
C
      CALL DGESV( N, N, EX, LDEX, IWORK, EXINT, LDEXIN, INFO )
      IF ( INFO.NE.0 )
     $   RETURN
C
C     Now we can form EX from EXINT using the formula:
C     EX = EXINT * A  +  I
C
      DO 160 J = 1, N
         CALL DSCAL( N, DELSC, EXINT(1,J), 1 )
  160 CONTINUE
C
      CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, EXINT,
     $            LDEXIN, A, LDA, ZERO, EX, LDEX  )
C
      DO 180 J = 1, N
         EX(J,J) = EX(J,J) + ONE
  180 CONTINUE
C
C     EX  and  EXINT  have been evaluated at  DELSC,  so the results
C     must be re-scaled to give the function values at  DELTA.
C
C     EXINT(2t) = EXINT(t) * ^ EX(t) + I [
C     EX(2t) = EX(t) * EX(t)
C
C     DWORK  is used to accumulate products.
C
      DO 200 L = 1, JSCAL
         CALL DLACPY( 'Full', N, N, EXINT, LDEXIN, DWORK, N )
         CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $               DWORK, N, EX, LDEX, ONE, EXINT, LDEXIN )
         CALL DLACPY( 'Full', N, N, EX, LDEX, DWORK, N )
         CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $               DWORK, N, DWORK, N, ZERO, EX, LDEX )
  200 CONTINUE
C
      DWORK(1) = 2*NN
      RETURN
C *** Last line of MB05ND ***
      END


!>
!> @file
!>
!>  PLASMA is a software package provided by:
!>  University of Tennessee, US,
!>  University of Manchester, UK.
!>
!> @precisions normal z -> s d c
!>
!> @brief Tests PLASMA Cholesky factorization

      program test_zpotrf

      use, intrinsic :: iso_fortran_env
      use            :: iso_c_binding
      use            :: omp_lib
      use            :: plasma
      implicit none

      ! Precisions
      integer, parameter :: sp = c_float
      integer, parameter :: dp = c_double

      ! set working precision, this value is rewritten for different precisions
      integer, parameter :: wp = dp

      integer,     parameter   :: n = 2000
      complex(wp), parameter   :: zmone = -1.0
      complex(wp), allocatable :: A(:,:), Aref(:,:)
      real(wp),    allocatable :: work(:)
      integer                  :: seed(4) = [0, 0, 0, 1]
      real(wp)                 :: Anorm, error, tol
      character                :: uploLapack ='L'
      integer                  :: uploPlasma = PlasmaLower
      integer                  :: lda, infoPlasma, infoLapack, i
      logical                  :: success = .false.

      ! External functions
      real(wp), external :: dlamch, zlanhe, zlange

      tol = 50.0 * dlamch('E')
      print *, "tol:", tol

      lda = max(1,n)

      ! Allocate matrix A
      allocate(A(lda,n), stat=infoPlasma)

      ! Generate random Hermitian positive definite matrix A
      call zlarnv(1, seed, lda*n, A)
      A = A * conjg(transpose(A))
      do i = 1, n
        A(i,i) = A(i,i) + n
      end do

      allocate(Aref(lda,n), stat=infoPlasma)
      Aref = A

      !==============================================
      ! Initialize PLASMA.
      !==============================================
      call plasma_init(infoPlasma)

      !==============================================
      ! Perform Cholesky factorization.
      !==============================================
      call plasma_zpotrf(uploPlasma, n, A, lda, infoPlasma)

      !==============================================
      ! Finalise PLASMA.
      !==============================================
      call plasma_finalize(infoPlasma)

      ! Check Cholesky decomposition is correct

      ! Factorize matrix A using Cholesky
      call zpotrf(uploLapack, n, Aref, lda, infoLapack)
      print *, "zpotrf:", infoLapack

      if (infoLapack == 0) then

        ! Calculate difference A := -1*Aref+A, A := A-Aref
        ! A = A-Aref
        call zaxpy(lda*n, zmone, Aref, 1, A, 1)

        ! Calculate norms |Aref|_F, |Aref-A|_F,
        Anorm = zlanhe('F', uploLapack, n, Aref, lda, work)
        print *, "|Aref|_F:", Anorm

        error = zlange('F', n, n, A, lda, work)
        print *, "|A-Aref|_F:", error

        ! Calculate error |A-Aref|_F / |Aref|_F
        error = error/Anorm

        if (error < tol)  success = .true.

      else

        if (infoPlasma == infoLapack) then
          error   = 0.0
          success =.true.
        else
          error = 0.0
          success =.false.
        end if

      end if

      print *, "|A-Aref|_F / |Aref|_F:", error
      print *, "success:              ", success

      if (success) then
          write(*,'(a)') "  The result is CORRECT."
      else
          write(*,'(a)') "  The result is WRONG!"
      end if
      write(*,'(a)') ""

      ! Deallocate matrix Aref
      deallocate(Aref, stat=infoPlasma)

      ! Deallocate matrix A
      deallocate(A, stat=infoPlasma)

      end program test_zpotrf