      SUBROUTINE SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q,
     $                   LDQ, Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI,
     $                   BETA, 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 the Cholesky factor U of the matrix X,
C
C                 T
C        X = op(U)  * op(U),
C
C     which is the solution of either the generalized
C     c-stable continuous-time Lyapunov equation
C
C             T                    T
C        op(A)  * X * op(E) + op(E)  * X * op(A)
C
C                 2        T
C        = - SCALE  * op(B)  * op(B),                                (1)
C
C     or the generalized d-stable discrete-time Lyapunov equation
C
C             T                    T
C        op(A)  * X * op(A) - op(E)  * X * op(E)
C
C                 2        T
C        = - SCALE  * op(B)  * op(B),                                (2)
C
C     without first finding X and without the need to form the matrix
C     op(B)**T * op(B).
C
C     op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N
C     matrices, op(B) is an M-by-N matrix. The resulting matrix U is an
C     N-by-N upper triangular matrix with non-negative entries on its
C     main diagonal. SCALE is an output scale factor set to avoid
C     overflow in U.
C
C     In the continuous-time case (1) the pencil A - lambda * E must be
C     c-stable (that is, all eigenvalues must have negative real parts).
C     In the discrete-time case (2) the pencil A - lambda * E must be
C     d-stable (that is, the moduli of all eigenvalues must be smaller
C     than one).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies which type of the equation is considered:
C             = 'C':  Continuous-time equation (1);
C             = 'D':  Discrete-time equation (2).
C
C     FACT    CHARACTER*1
C             Specifies whether the generalized real Schur
C             factorization of the pencil A - lambda * E is supplied
C             on entry or not:
C             = 'N':  Factorization is not supplied;
C             = 'F':  Factorization is supplied.
C
C     TRANS   CHARACTER*1
C             Specifies whether the transposed equation is to be solved
C             or not:
C             = 'N':  op(A) = A,    op(E) = E;
C             = 'T':  op(A) = A**T, op(E) = E**T.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of rows in the matrix op(B).  M >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if FACT = 'F', then the leading N-by-N upper
C             Hessenberg part of this array must contain the
C             generalized Schur factor A_s of the matrix A (see
C             definition (3) in section METHOD). A_s must be an upper
C             quasitriangular matrix. The elements below the upper
C             Hessenberg part of the array A are not referenced.
C             If FACT = 'N', then the leading N-by-N part of this
C             array must contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the generalized Schur factor A_s of the matrix A. (A_s is
C             an upper quasitriangular matrix.)
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, if FACT = 'F', then the leading N-by-N upper
C             triangular part of this array must contain the
C             generalized Schur factor E_s of the matrix E (see
C             definition (4) in section METHOD). The elements below the
C             upper triangular part of the array E are not referenced.
C             If FACT = 'N', then the leading N-by-N part of this
C             array must contain the coefficient matrix E of the
C             equation.
C             On exit, the leading N-by-N part of this array contains
C             the generalized Schur factor E_s of the matrix E. (E_s is
C             an upper triangular matrix.)
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, if FACT = 'F', then the leading N-by-N part of
C             this array must contain the orthogonal matrix Q from
C             the generalized Schur factorization (see definitions (3)
C             and (4) in section METHOD).
C             If FACT = 'N', Q need not be set on entry.
C             On exit, the leading N-by-N part of this array contains
C             the orthogonal matrix Q from the generalized Schur
C             factorization.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1,N).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             On entry, if FACT = 'F', then the leading N-by-N part of
C             this array must contain the orthogonal matrix Z from
C             the generalized Schur factorization (see definitions (3)
C             and (4) in section METHOD).
C             If FACT = 'N', Z need not be set on entry.
C             On exit, the leading N-by-N part of this array contains
C             the orthogonal matrix Z from the generalized Schur
C             factorization.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N1)
C             On entry, if TRANS = 'T', the leading N-by-M part of this
C             array must contain the matrix B and N1 >= MAX(M,N).
C             If TRANS = 'N', the leading M-by-N part of this array
C             must contain the matrix B and N1 >= N.
C             On exit, the leading N-by-N part of this array contains
C             the Cholesky factor U of the solution matrix X of the
C             problem, X = op(U)**T * op(U).
C             If M = 0 and N > 0, then U is set to zero.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             If TRANS = 'T', LDB >= MAX(1,N).
C             If TRANS = 'N', LDB >= MAX(1,M,N).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor set to avoid overflow in U.
C             0 < SCALE <= 1.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, 3, 5, 6, or 7, then
C             (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the
C             eigenvalues of the matrix pencil A - lambda * E.
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 dimension of the array DWORK.
C             LDWORK >= MAX(1,4*N,6*N-6),  if FACT = 'N';
C             LDWORK >= MAX(1,2*N,6*N-6),  if FACT = 'F'.
C             For good performance, LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the pencil A - lambda * E is (nearly) singular;
C                   perturbed values were used to solve the equation
C                   (but the reduced (quasi)triangular matrices A and E
C                   are unchanged);
C             = 2:  FACT = 'F' and the matrix contained in the upper
C                   Hessenberg part of the array A is not in upper
C                   quasitriangular form;
C             = 3:  FACT = 'F' and there is a 2-by-2 block on the main
C                   diagonal of the pencil A_s - lambda * E_s whose
C                   eigenvalues are not conjugate complex;
C             = 4:  FACT = 'N' and the pencil A - lambda * E cannot be
C                   reduced to generalized Schur form: LAPACK routine
C                   DGEGS (or DGGES) has failed to converge;
C             = 5:  DICO = 'C' and the pencil A - lambda * E is not
C                   c-stable;
C             = 6:  DICO = 'D' and the pencil A - lambda * E is not
C                   d-stable;
C             = 7:  the LAPACK routine DSYEVX utilized to factorize M3
C                   failed to converge in the discrete-time case (see
C                   section METHOD for SLICOT Library routine SG03BU).
C                   This error is unlikely to occur.
C
C     METHOD
C
C     An extension [2] of Hammarling's method [1] to generalized
C     Lyapunov equations is utilized to solve (1) or (2).
C
C     First the pencil A - lambda * E is reduced to real generalized
C     Schur form A_s - lambda * E_s by means of orthogonal
C     transformations (QZ-algorithm):
C
C        A_s = Q**T * A * Z   (upper quasitriangular)                (3)
C
C        E_s = Q**T * E * Z   (upper triangular).                    (4)
C
C     If the pencil A - lambda * E has already been factorized prior to
C     calling the routine however, then the factors A_s, E_s, Q and Z
C     may be supplied and the initial factorization omitted.
C
C     Depending on the parameters TRANS and M the N-by-N upper
C     triangular matrix B_s is defined as follows. In any case Q_B is
C     an M-by-M orthogonal matrix, which need not be accumulated.
C
C     1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix
C        from the QR-factorization
C
C           ( Q_B  O )           ( B * Z )
C           (        ) * B_s  =  (       ),
C           (  O   I )           (   O   )
C
C        where the O's are zero matrices of proper size and I is the
C        identity matrix of order N-M.
C
C     2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix
C        from the (rectangular) QR-factorization
C
C                 ( B_s )
C           Q_B * (     )  =  B * Z,
C                 (  O  )
C
C        where O is the (M-N)-by-N zero matrix.
C
C     3. If TRANS = 'T' and M < N, B_s is the upper triangular matrix
C        from the RQ-factorization
C
C                       ( Q_B  O )
C           (B_s  O ) * (        )  =  ( Q**T * B   O ).
C                       (  O   I )
C
C     4. If TRANS = 'T' and M >= N, B_s is the upper triangular matrix
C        from the (rectangular) RQ-factorization
C
C           ( B_s   O ) * Q_B  =  Q**T * B,
C
C        where O is the N-by-(M-N) zero matrix.
C
C     Assuming SCALE = 1, the transformation of A, E and B described
C     above leads to the reduced continuous-time equation
C
C                 T        T
C          op(A_s)  op(U_s)  op(U_s) op(E_s)
C
C                 T        T
C        + op(E_s)  op(U_s)  op(U_s) op(A_s)
C
C                    T
C        =  - op(B_s)  op(B_s)                                       (5)
C
C     or to the reduced discrete-time equation
C
C                 T        T
C          op(A_s)  op(U_s)  op(U_s) op(A_s)
C
C                 T        T
C        - op(E_s)  op(U_s)  op(U_s) op(E_s)
C
C                    T
C        =  - op(B_s)  op(B_s).                                      (6)
C
C     For brevity we restrict ourself to equation (5) and the case
C     TRANS = 'N'. The other three cases can be treated in a similar
C     fashion.
C
C     We use the following partitioning for the matrices A_s, E_s, B_s
C     and U_s
C
C                 ( A11   A12 )          ( E11   E12 )
C           A_s = (           ),   E_s = (           ),
C                 (   0   A22 )          (   0   E22 )
C
C                 ( B11   B12 )          ( U11   U12 )
C           B_s = (           ),   U_s = (           ).              (7)
C                 (   0   B22 )          (   0   U22 )
C
C     The size of the (1,1)-blocks is 1-by-1 (iff A_s(2,1) = 0.0) or
C     2-by-2.
C
C     We compute U11 and U12**T in three steps.
C
C     Step I:
C
C        From (5) and (7) we get the 1-by-1 or 2-by-2 equation
C
C                T      T                   T      T
C             A11  * U11  * U11 * E11  + E11  * U11  * U11 * A11
C
C                    T
C             = - B11  * B11.
C
C        For brevity, details are omitted here. See [2]. The technique
C        for computing U11 is similar to those applied to standard
C        Lyapunov equations in Hammarling's algorithm ([1], section 6).
C
C        Furthermore, the auxiliary matrices M1 and M2 defined as
C        follows
C
C                               -1      -1
C           M1 = U11 * A11 * E11   * U11
C
C                         -1      -1
C           M2 = B11 * E11   * U11
C
C        are computed in a numerically reliable way.
C
C     Step II:
C
C        The generalized Sylvester equation
C
C              T      T      T      T
C           A22  * U12  + E22  * U12  * M1  =
C
C                T           T      T      T      T
C           - B12  * M2 - A12  * U11  - E12  * U11  * M1
C
C        is solved for U12**T.
C
C     Step III:
C
C        It can be shown that
C
C              T      T                  T      T
C           A22  * U22  * U22 * E22 + E22  * U22  * U22 * A22  =
C
C                T              T
C           - B22  * B22 - y * y                                     (8)
C
C        holds, where y is defined as
C
C                  T        T      T      T      T       T
C           y = B12  - ( E12  * U11  + E22  * U12  ) * M2 .
C
C        If B22_tilde is the square triangular matrix arising from the
C        (rectangular) QR-factorization
C
C                       ( B22_tilde )     ( B22  )
C           Q_B_tilde * (           )  =  (      ),
C                       (     O     )     ( y**T )
C
C        where Q_B_tilde is an orthogonal matrix of order N, then
C
C                T              T                T
C           - B22  * B22 - y * y   =  - B22_tilde  * B22_tilde.
C
C        Replacing the right hand side in (8) by the term
C        - B22_tilde**T * B22_tilde leads to a reduced generalized
C        Lyapunov equation of lower dimension compared to (5).
C
C     The recursive application of the steps I to III yields the
C     solution U_s of the equation (5).
C
C     It remains to compute the solution matrix U of the original
C     problem (1) or (2) from the matrix U_s. To this end we transform
C     the solution back (with respect to the transformation that led
C     from (1) to (5) (from (2) to (6)) and apply the QR-factorization
C     (RQ-factorization). The upper triangular solution matrix U is
C     obtained by
C
C        Q_U * U  =  U_s * Q**T     (if TRANS = 'N')
C
C     or
C
C        U * Q_U  =  Z * U_s        (if TRANS = 'T')
C
C     where Q_U is an N-by-N orthogonal matrix. Again, the orthogonal
C     matrix Q_U need not be accumulated.
C
C     REFERENCES
C
C     [1] Hammarling, S.J.
C         Numerical solution of the stable, non-negative definite
C         Lyapunov equation.
C         IMA J. Num. Anal., 2, pp. 303-323, 1982.
C
C     [2] Penzl, T.
C         Numerical solution of generalized Lyapunov equations.
C         Advances in Comp. Math., vol. 8, pp. 33-48, 1998.
C
C     NUMERICAL ASPECTS
C
C     The number of flops required by the routine is given by the
C     following table. Note that we count a single floating point
C     arithmetic operation as one flop.
C
C                 |           FACT = 'F'                  FACT = 'N'
C        ---------+--------------------------------------------------
C         M <= N  |     (13*N**3+6*M*N**2         (211*N**3+6*M*N**2
C                 |   +6*M**2*N-2*M**3)/3        +6*M**2*N-2*M**3)/3
C                 |
C          M > N  | (11*N**3+12*M*N**2)/3     (209*N**3+12*M*N**2)/3
C
C     FURTHER COMMENTS
C
C     The Lyapunov equation may be very ill-conditioned. In particular,
C     if DICO = 'D' and the pencil A - lambda * E has a pair of almost
C     reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost
C     degenerate pair of eigenvalues, then the Lyapunov equation will be
C     ill-conditioned. Perturbed values were used to solve the equation.
C     A condition estimate can be obtained from the routine SG03AD.
C     When setting the error indicator INFO, the routine does not test
C     for near instability in the equation but only for exact
C     instability.
C
C     CONTRIBUTOR
C
C     T. Penzl, Technical University Chemnitz, Germany, Aug. 1998.
C
C     REVISIONS
C
C     Sep. 1998 (V. Sima).
C     May 1999 (V. Sima).
C     March 2002 (A. Varga).
C     Feb. 2004 (V. Sima).
C     July 2011 (V. Sima).
C
C     KEYWORDS
C
C     Lyapunov equation
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  MONE, ONE, ZERO
      PARAMETER         ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  SCALE
      INTEGER           INFO, LDA, LDB, LDE, LDQ, LDWORK, LDZ, M, N
      CHARACTER         DICO, FACT, TRANS
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*),
     $                  BETA(*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      DOUBLE PRECISION  S1, S2, SAFMIN, WI, WR1, WR2
      INTEGER           I, INFO1, MAXMN, MINGG, MINMN, MINWRK, OPTWRK
      LOGICAL           ISDISC, ISFACT, ISTRAN, LQUERY
C     .. Local Arrays ..
      DOUBLE PRECISION  E1(2,2)
      LOGICAL           BWORK(1)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLAPY2
      LOGICAL           DELCTG, LSAME
      EXTERNAL          DELCTG, DLAMCH, DLAPY2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEGS, DGEMM, DGEMV, DGEQRF, DGERQF,
     $                  DGGES, DLACPY, DLAG2, DLASET, DSCAL, DTRMM,
     $                  SG03BU, SG03BV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, INT, MAX, MIN, SIGN
C     .. Executable Statements ..
C
C     Decode input parameters.
C
      ISDISC = LSAME( DICO,  'D' )
      ISFACT = LSAME( FACT,  'F' )
      ISTRAN = LSAME( TRANS, 'T' )
      LQUERY = LDWORK.EQ.-1
C
C     Check the scalar input parameters.
C
      INFO = 0
      IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN
         INFO = -1
      ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT,  'N' ) ) ) THEN
         INFO = -2
      ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -3
      ELSEIF ( N .LT. 0 ) THEN
         INFO = -4
      ELSEIF ( M .LT. 0 ) THEN
         INFO = -5
      ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN
         INFO = -7
      ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN
         INFO = -9
      ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN
         INFO = -11
      ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN
         INFO = -13
      ELSEIF ( ( ISTRAN .AND. ( LDB .LT. MAX( 1, N ) ) ) .OR.
     $    ( .NOT.ISTRAN .AND. ( LDB .LT. MAX( 1, M, N ) ) ) ) THEN
         INFO = -15
      ELSE
C
C        Compute minimal and optimal workspace.
C
         IF (ISFACT ) THEN
            MINWRK = MAX( 1, 2*N, 6*N-6 )
         ELSE
            MINWRK = MAX( 1, 4*N, 6*N-6 )
         END IF
         MINGG = MAX( MINWRK, 8*N + 16 )
         IF( LQUERY ) THEN
            CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N,
     $                  A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA, Q, LDQ,
     $                  Z, LDZ, DWORK, -1, BWORK, INFO1 )
            MAXMN  = MAX( M, N )
            OPTWRK = MAX( MINGG, INT( DWORK(1) ), N*MAXMN )
            IF ( .NOT.ISTRAN ) THEN
               CALL DGEQRF( MAXMN, N, B, LDB, DWORK, DWORK, -1, INFO1 )
            ELSE
               CALL DGERQF( N, MAXMN, B, LDB, DWORK, DWORK, -1, INFO1 )
            END IF
            OPTWRK = MAX( OPTWRK, INT( DWORK(1) ) + N )
         ELSEIF ( LDWORK .LT. MINWRK ) THEN
            INFO = -21
         END IF
      END IF
C
      IF ( INFO .NE. 0 ) THEN
         CALL XERBLA( 'SG03BD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = OPTWRK
         RETURN
      END IF
C
      SCALE = ONE
C
C     Quick return if possible.
C
      MINMN = MIN( M, N )
      IF ( MINMN .EQ. 0 ) THEN
         IF ( N.GT.0 )
     $      CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB )
         DWORK(1) = ONE
         RETURN
      ENDIF
C
      IF ( ISFACT ) THEN
C
C        Make sure the upper Hessenberg part of A is quasitriangular.
C
         DO 20 I = 1, N-2
            IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN
               INFO = 2
               RETURN
            END IF
   20    CONTINUE
      END IF
C
      IF ( .NOT.ISFACT ) THEN
C
C        Reduce the pencil A - lambda * E to generalized Schur form.
C
C           A := Q**T * A * Z   (upper quasitriangular)
C           E := Q**T * E * Z   (upper triangular)
C
         IF ( LDWORK .LT. MINGG ) THEN
C
C           Use DGEGS for backward compatibilty with LDWORK value.
C           ( Workspace: >= MAX(1,4*N) )
C
            CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR,
     $                  ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK,
     $                  INFO1 )
         ELSE
C
C           Use DGGES. The workspace is increased to avoid an error
C           return, while it should not really be larger than above.
C           ( Workspace: >= MAX(1,8*N+16) )
C
            CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N,
     $                  A, LDA, E, LDE, I, ALPHAR, ALPHAI, BETA, Q, LDQ,
     $                  Z, LDZ, DWORK, LDWORK, BWORK, INFO1 )
         END IF
         IF ( INFO1 .NE. 0 ) THEN
            INFO = 4
            RETURN
         END IF
         OPTWRK = INT( DWORK(1) )
      ELSE
         OPTWRK = MINWRK
      END IF
C
      IF ( ISFACT ) THEN
C
C        If the matrix pencil A - lambda * E has been in generalized
C        Schur form on entry, compute its eigenvalues.
C
         SAFMIN = DLAMCH( 'Safe minimum' )
         E1(2,1) = ZERO
         I = 1
C        WHILE ( I .LE. N ) DO
   30    IF ( I .LE. N ) THEN
            IF ( ( I.EQ.N ) .OR. ( A(MIN( I+1, N ),I).EQ.ZERO ) ) THEN
               ALPHAR(I) = A(I,I)
               ALPHAI(I) = ZERO
               BETA(I) = E(I,I)
               I = I+1
            ELSE
               E1(1,1) = E(I,I)
               E1(1,2) = E(I,I+1)
               E1(2,2) = E(I+1,I+1)
               CALL DLAG2( A(I,I), LDA, E1, 2, SAFMIN, S1, S2, WR1, WR2,
     $                     WI )
               IF ( WI .EQ. ZERO ) INFO = 3
               ALPHAR(I) = WR1
               ALPHAI(I) = WI
               BETA(I) = S1
               ALPHAR(I+1) = WR2
               ALPHAI(I+1) = -WI
               BETA(I+1) = S2
               I = I+2
            END IF
         GOTO 30
         END IF
C        END WHILE 30
         IF ( INFO.NE.0 ) RETURN
      END IF
C
C     Check on the stability of the matrix pencil A - lambda * E.
C
      DO 40 I = 1, N
         IF ( ISDISC ) THEN
            IF ( DLAPY2( ALPHAR(I), ALPHAI(I) ) .GE. ABS( BETA(I) ) )
     $         THEN
               INFO = 6
               RETURN
            END IF
         ELSE
            IF ( ( ALPHAR(I).EQ.ZERO ) .OR. ( BETA(I).EQ.ZERO ) .OR.
     $         ( SIGN( ONE,ALPHAR(I) )*SIGN( ONE, BETA(I) ) .GE. ZERO) )
     $         THEN
               INFO = 5
               RETURN
            END IF
         END IF
   40 CONTINUE
C
C     Transformation of the right hand side.
C
C        B := B * Z  or  B := Q**T * B
C
C     Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2.
C
C     ( Workspace: max(1,N) )
C
      IF ( .NOT.ISTRAN ) THEN
         IF ( LDWORK .GE. N*M ) THEN
            CALL DGEMM(  'NoTranspose', 'NoTranspose', M, N, N, ONE, B,
     $                   LDB, Z, LDZ, ZERO, DWORK, M )
            CALL DLACPY( 'All', M, N, DWORK, M, B, LDB )
         ELSE
            DO 60 I = 1, M
               CALL DCOPY( N, B(I,1), LDB, DWORK, 1 )
               CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1,
     $                     ZERO, B(I,1), LDB )
 60         CONTINUE
         END IF
         IF ( M .LT. N )
     $      CALL DLASET( 'All', N-M, N, ZERO, ZERO, B(M+1,1), LDB )
      ELSE
         IF ( LDWORK .GE. N*M ) THEN
            CALL DLACPY( 'All', N, M, B, LDB, DWORK, N )
            CALL DGEMM(  'Transpose', 'NoTranspose', N, M, N, ONE, Q,
     $                   LDQ, DWORK, N, ZERO, B, LDB )
         ELSE
            DO 80 I = 1, M
               CALL DCOPY( N, B(1,I), 1, DWORK, 1 )
               CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1,
     $                     ZERO, B(1,I), 1 )
 80         CONTINUE
         END IF
         IF ( M .LT. N )
     $      CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,M+1), LDB )
      END IF
      OPTWRK = MAX( OPTWRK, N*M )
C
C     Overwrite B with the triangular matrix of its QR-factorization
C     or its RQ-factorization.
C     (The entries on the main diagonal are non-negative.)
C
C     ( Workspace: >= max(1,2*N) )
C
      IF ( .NOT.ISTRAN ) THEN
         IF ( M .GE. 2 ) THEN
            CALL DGEQRF( M, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N,
     $                   INFO1 )
            CALL DLASET( 'Lower', MAX( M, N )-1, MIN( M, N ), ZERO,
     $                   ZERO, B(2,1), LDB )
         END IF
         DO 100 I = 1, MINMN
            IF ( B(I,I) .LT. ZERO )
     $         CALL DSCAL( N+1-I, MONE, B(I,I), LDB )
  100    CONTINUE
      ELSE
         IF ( M .GE. 2 ) THEN
            CALL DGERQF( N, M, B, LDB, DWORK, DWORK(N+1), LDWORK-N,
     $                   INFO1 )
            IF ( N .GE. M ) THEN
               CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, B(N-M+2,1),
     $                      LDB )
               IF ( N .GT. M ) THEN
                  DO 120 I = M, 1, -1
                     CALL DCOPY( N, B(1,I), 1, B(1,I+N-M), 1 )
  120             CONTINUE
                  CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,1), LDB )
               END IF
            ELSE
               IF ( N .GT. 1 )
     $            CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO,
     $                         B(2,M-N+1), LDB )
               DO 140 I = 1, N
                  CALL DCOPY( N, B(1,M-N+I), 1, B(1,I), 1 )
  140          CONTINUE
               CALL DLASET( 'All', N, M-N, ZERO, ZERO, B(1,N+1), LDB )
            END IF
         ELSE
            IF ( N .NE. 1 ) THEN
               CALL DCOPY( N, B(1,1), 1, B(1,N), 1 )
               CALL DLASET( 'All', N, 1, ZERO, ZERO, B(1,1), LDB )
            END IF
         END IF
         DO 160 I = N - MINMN + 1, N
            IF ( B(I,I) .LT. ZERO )
     $         CALL DSCAL( I, MONE, B(1,I), 1 )
  160    CONTINUE
      END IF
      OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N )
C
C     Solve the reduced generalized Lyapunov equation.
C
C     ( Workspace: 6*N-6 )
C
      IF ( ISDISC ) THEN
         CALL SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK,
     $                INFO1 )
         IF ( INFO1 .NE. 0 ) THEN
            IF ( INFO1 .EQ. 1 ) INFO = 1
            IF ( INFO1 .EQ. 2 ) INFO = 3
            IF ( INFO1 .EQ. 3 ) INFO = 6
            IF ( INFO1 .EQ. 4 ) INFO = 7
            IF ( INFO  .NE. 1 )
     $         RETURN
         END IF
      ELSE
         CALL SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK,
     $                INFO1 )
         IF ( INFO1 .NE. 0 ) THEN
            IF ( INFO1 .EQ. 1 ) INFO = 1
            IF ( INFO1 .GE. 2 ) INFO = 3
            IF ( INFO1 .EQ. 3 ) INFO = 5
            IF ( INFO  .NE. 1 )
     $         RETURN
         END IF
      END IF
C
C     Transform the solution matrix back.
C
C        U := U * Q**T   or   U := Z * U
C
C     Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2.
C
C     ( Workspace: max(1,N) )
C
      IF ( .NOT.ISTRAN ) THEN
         IF ( LDWORK .GE. N*N ) THEN
            CALL DLACPY( 'All', N, N, Q, LDQ, DWORK, N )
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, N,
     $                  ONE, B, LDB, DWORK, N)
            DO 170 I = 1, N
               CALL DCOPY( N, DWORK(N*(I-1)+1), 1, B(I,1), LDB )
  170       CONTINUE
         ELSE
            DO 180 I = 1, N
               CALL DCOPY( N-I+1, B(I,I), LDB, DWORK, 1 )
               CALL DGEMV( 'NoTranspose', N, N-I+1, ONE, Q(1,I), LDQ,
     $                     DWORK, 1, ZERO, B(I,1), LDB )
  180       CONTINUE
         END IF
      ELSE
         IF ( LDWORK .GE. N*N ) THEN
            CALL DLACPY( 'All', N, N, Z, LDZ, DWORK, N )
            CALL DTRMM(  'Right', 'Upper', 'NoTranspose', 'NonUnit', N,
     $                   N, ONE, B, LDB, DWORK, N )
            CALL DLACPY( 'All', N, N, DWORK, N, B, LDB )
         ELSE
            DO 200 I = 1, N
               CALL DCOPY( I, B(1,I), 1, DWORK, 1 )
               CALL DGEMV( 'NoTranspose', N, I, ONE, Z, LDZ, DWORK, 1,
     $                     ZERO, B(1,I), 1 )
 200        CONTINUE
         END IF
      END IF
      OPTWRK = MAX( OPTWRK, N*N )
C
C     Overwrite U with the triangular matrix of its QR-factorization
C     or its RQ-factorization.
C     (The entries on the main diagonal are non-negative.)
C
C     ( Workspace: >= max(1,2*N) )
C
      IF ( .NOT.ISTRAN ) THEN
         CALL DGEQRF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 )
         IF ( N .GT. 1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB )
         DO 220 I = 1, N
            IF ( B(I,I) .LT. ZERO )
     $         CALL DSCAL( N+1-I, MONE, B(I,I), LDB )
  220    CONTINUE
      ELSE
         CALL DGERQF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 )
         IF ( N .GT. 1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB )
         DO 240 I = 1, N
            IF ( B(I,I) .LT. ZERO )
     $         CALL DSCAL( I, MONE, B(1,I), 1 )
  240    CONTINUE
      END IF
      OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N )
C
      DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) )
      RETURN
C *** Last line of SG03BD ***
      END


 implicit none

 integer :: i,n

 print*,'Give highest number n to be squared'; read*,n

 do i=1,n
   print*,i**2
 enddo

 end


!----------------------------------------------------------------------------------------------
! MODULE: ang_mom_defs
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date March, 2019
!
!> @brief Helper functions for gaussian basis set definitions and transformations.
!----------------------------------------------------------------------------------------------
module ang_mom_defs
    use global_defs
    implicit none

    private
    public :: ang_mom_parameters
    public :: amp
    public :: sphe_nums
    public :: cart_nums
    public :: matrix_sphe_to_cart_gaussian
    public :: subshell_numbers
    public :: subshell_phases

    character(len=1), parameter :: l_lett(0:11) = & ! Assumes max_l always < 11.
    &    ['s', 'p', 'd', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n']

    interface
        function subshell_numbers(ll) result(nums)
            integer, intent(in) :: ll
            integer, allocatable :: nums(:, :)
        end function

        function subshell_phases(ll) result(phase)
            use global_defs, only : dp
            integer, intent(in) :: ll
            real(dp), allocatable :: phase(:)
        end function
    end interface

    !----------------------------------------------------------------------------------------------
    ! TYPE: ang_mom_parameters
    !> @brief Holds parameters for cartesian/spherical gaussian functions.
    !
    !> @details
    !! Parameters up to a given maximum angular momentum max_l are saved at the start by calling
    !! the %init(max_l) procedure.
    !----------------------------------------------------------------------------------------------
    type ang_mom_parameters
        logical :: initialized = .false. !< Instance initialized?
        integer :: max_l !< Chosen maximum l.
        integer, allocatable :: n_cart(:) !< Number of cartesian functions.
        integer, allocatable :: n_sphe(:) !< Number of spherical functions.
        character(len=1), allocatable :: l_lett(:) !< Letter for subshells with given l.
        type(rmat), allocatable :: sphe_cart_trans(:) !< Transformation matrices from sphe to cart.
        procedure(subshell_numbers), pointer, nopass :: sphe !< Order of l, m  combinations.
        procedure(subshell_numbers), pointer, nopass :: cart !< Order of lx, ly, lz combinations.
    contains
        procedure :: init => ang_mom_parameters_init
        procedure :: subshell_transform
        procedure, nopass :: l => subshell_l
    end type ang_mom_parameters

    type(ang_mom_parameters) :: amp !< Instance of ang_mom_parameters to hold default values.

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: ang_mom_parameterers_init
    !> @brief Initialize ang_mom_parameterers instance.
    !----------------------------------------------------------------------------------------------
    subroutine ang_mom_parameters_init(self, max_l, sphe_nums_generator, cart_nums_generator)
        class(ang_mom_parameters), intent(inout) :: self
        procedure(subshell_numbers), optional :: sphe_nums_generator
        procedure(subshell_numbers), optional :: cart_nums_generator
        integer, intent(in) :: max_l
        integer :: l

        ! Deallocate if previously initialized.
        if (self%initialized) then
            deallocate(self%n_cart)
            deallocate(self%n_sphe)
            deallocate(self%l_lett)
            deallocate(self%sphe_cart_trans)
        end if

        ! Allocate arrays.
        self%max_l = max_l
        allocate(self%n_cart(0:max_l))
        allocate(self%n_sphe(0:max_l))
        allocate(self%l_lett(0:max_l))
        allocate(self%sphe_cart_trans(0:max_l))
        self%sphe => sphe_nums
        self%cart => cart_nums
        if (present(sphe_nums_generator)) self%sphe => sphe_nums_generator
        if (present(cart_nums_generator)) self%cart => cart_nums_generator

        ! Initialize arrays.
        self%n_cart = [( (l+1)*(l+2)/2, l = 0, max_l )]
        self%n_sphe = [( 2*l+1, l = 0, max_l )]
        self%l_lett = l_lett(0:max_l)
        do l = 0, max_l
            allocate(self%sphe_cart_trans(l)%c(self%n_sphe(l), self%n_cart(l)))
            self%sphe_cart_trans(l)%c = matrix_sphe_to_cart_gaussian(self%sphe(l), self%cart(l))
        end do
        self%initialized = .true.
    end subroutine ang_mom_parameters_init

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: subshell_l
    !> @brief Convert subshell letter (s/p/d...) to angular momentum number.
    !----------------------------------------------------------------------------------------------
    elemental function subshell_l(s_type) result(i)
        use string_mod, only : tolower
        character(len=1), intent(in) :: s_type
        integer :: i

        do i = 0, size(l_lett)
            if (l_lett(i) == tolower(s_type)) return
        end do
    end function subshell_l

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: subshell_transform
    !> @brief Return a matrix for reordering subshell functions
    !> @details
    !! The functions can also be multiplied by a scalar phase factor.
    !----------------------------------------------------------------------------------------------
    function subshell_transform(self, l, reorder, phase) result(trans_mat)
        class(ang_mom_parameters) :: self
        integer, intent(in) :: l
        integer, intent(in) :: reorder(:, :)
        real(dp), intent(in), optional :: phase(:)
        real(dp), allocatable :: trans_mat(:, :)
        integer, allocatable :: wrk(:, :)
        real(dp), allocatable :: wrk_phase(:)
        integer :: i, j, n

        if (size(reorder, 1) == 2) then
            n = self%n_sphe(l)
            allocate(wrk, source=self%sphe(l))
        else
            n = self%n_cart(l)
            allocate(wrk, source=self%cart(l))
        end if
        allocate(trans_mat(n, n), source=0.0_dp)
        allocate(wrk_phase(n), source=1.0_dp)
        if (present(phase)) wrk_phase = wrk_phase*phase

        do i = 1, n
            do j = 1, n
                if (any(wrk(:, i) /= reorder(:, j))) cycle
                trans_mat(j, i) = wrk_phase(j)
            end do
        end do
    end function subshell_transform

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: sphe_nums
    !> @brief Default generator function for order of spherical gaussian ang. mom. numbers.
    !----------------------------------------------------------------------------------------------
    function sphe_nums(ll) result(sphe)
        integer, intent(in) :: ll
        integer, allocatable :: sphe(:, :)
        integer :: i

        allocate(sphe(2, 2*ll+1))
        sphe(1, :) = ll
        select case(ll)
        case(0)
            sphe(2, :) = [0]
        case(1)
            sphe(2, :) = [1, -1, 0]
        case default
            sphe(2, 1) = 0
            do i = 1, ll
                sphe(2, 2*i) = i
                sphe(2, 2*i+1) = -i
            end do
        end select
    end function sphe_nums

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: cart_nums
    !> @brief Default generator function for order of cartesian gaussian ang. mom. numbers.
    !----------------------------------------------------------------------------------------------
    function cart_nums(ll) result(cart)
        integer, intent(in) :: ll
        integer, allocatable :: cart(:, :)
        integer :: i, l1, l2, l3

        allocate(cart(3, (ll+1)*(ll+2)/2))
        i = 0
        do l1 = ll, ceiling(ll/3.0), -1
            do l2 = min(ll-l1,l1), ceiling((ll-l1)/2.0), -1
                l3 = ll - l1 - l2
                i = i + 1
                cart(:, i) = [l1, l2, l3]
                if (l2 /= l3) then
                    i = i + 1
                    cart(:, i) = [l1, l3, l2]
                end if
                if (l1 /= l2) then
                    i = i + 1
                    cart(:, i) = [l2, l1, l3]
                end if
                if ((l1 /= l2) .and. (l1 /= l3) .and. (l2 /= l3)) then
                    i = i + 1
                    cart(:, i) = [l3, l1, l2]
                    i = i + 1
                    cart(:, i) = [l2, l3, l1]
                end if
                if (l1 /= l3) then
                    i = i + 1
                    cart(:, i) = [l3, l2, l1]
                end if
            end do
        end do
    end function cart_nums

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: matrix_sphe_to_cart_gaussian
    !> @brief Return a transformation matrix for converting from spherical to cartesian functions.
    !----------------------------------------------------------------------------------------------
    function matrix_sphe_to_cart_gaussian(sphe, cart) result(trans)
        integer, intent(in) :: sphe(:, :)
        integer, intent(in) :: cart(:, :)
        real(dp) :: trans(size(cart, 2), size(sphe, 2))
        integer :: i, j

        do i = 1, size(sphe, 2)
            do j = 1, size(cart, 2)
                trans(j, i) = sphe_to_cart_gaussian(sphe(1, i), sphe(2, i),                        &
                &                                   cart(1, j), cart(2, j), cart(3, j))
            end do
        end do
    end function matrix_sphe_to_cart_gaussian

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: sphe_to_cart_gaussian
    !> @brief Return a single spherical to cartesian gaussian transformation coefficient.
    !----------------------------------------------------------------------------------------------
    function sphe_to_cart_gaussian(ll, mm, lx, ly, lz) result(coeff)
        use math_mod
        integer, intent(in) :: ll
        integer, intent(in) :: mm
        integer, intent(in) :: lx
        integer, intent(in) :: ly
        integer, intent(in) :: lz
        real(dp) :: coeff
        real(dp) :: sq_lx, sq_ly, sq_lz, sq_ll, sq_lm, sq_tot
        real(dp) :: frac, sum1, sum2
        integer :: i, k, am, jj, ediff
        integer(j15) :: csum

        am = abs(mm)
        if (ll /= lx + ly + lz) then
            coeff = 0.0_dp
            return
        else if (abs(mod(lx+ly-am, 2)) == 1) then
            coeff = 0.0_dp
            return
        end if
        if (mm >= 0) then
            if (abs(mod(am-lx, 2)) == 1) then
                coeff = 0.0_dp
                return
            end if
            ediff = am - lx
        else if (mm < 0) then
            if (abs(mod(am-lx, 2)) == 0) then
                coeff = 0.0_dp
                return
            end if
            ediff = am - lx + 1
        end if
        jj = (lx + ly - am) / 2
        sq_lx = real(factorial(2*lx), kind=dp) / factorial(lx)
        sq_ly = real(factorial(2*ly), kind=dp) / factorial(ly)
        sq_lz = real(factorial(2*lz), kind=dp) / factorial(lz)
        sq_ll = real(factorial(ll), kind=dp) / factorial(2*ll)
        sq_lm = real(factorial(ll-am), kind=dp) / factorial(ll+am)
        sq_tot = sqrt(sq_lx*sq_ly*sq_lz*sq_ll*sq_lm)
        frac = 1.0_dp / 2**ll / factorial(ll)
        sum1 = 0.0_dp
        do i = 0, (ll-am)/2
            csum = binomial(ll, i) * binomial(i, jj)
            csum = csum * (-1)**i * factorial(2*ll - 2*i)
            csum = csum / factorial(ll - am - 2*i)
            sum1 = sum1 + csum
        end do
        sum2 = 0.0_dp
        do k = 0, jj
            csum = binomial(jj, k) * binomial(am, lx - 2*k)
            csum = csum * (-1)**(sign(1, mm) * (ediff + 2*k) / 2)
            sum2 = sum2 + csum
        end do
        if (mm > 0) then
            sum2 = sum2 * sqrt(2.0_dp)
        else if (mm < 0) then
            sum2 = - sum2 * sqrt(2.0_dp)
        end if
        coeff = sq_tot * frac * sum1 * sum2
    end function sphe_to_cart_gaussian

end module ang_mom_defs


! vectorspace.f90 --
!     Define a module for dealing with vector spaces in an abstract sense
!
!     The basic data type is an abstract vector, with the following
!     operations:
!     "+" - to add two vectors to get a new vector
!     "*" - to multiply a vector with a scalar
!     We can use an array of vectors as a collection: the operation ".in."
!     determines if a given vector is in that collection.
!
!     Note:
!     The multiplication does not work as I want, because I need a PASS attribute
!     and that conflicts with some restriction.
!
module vectorspaces
    implicit none

    type, abstract :: vector
    contains
        private
        procedure(addition), deferred                :: add
       ! This does not work, for some reason:
        procedure(multiplication), deferred, pass(b) :: multiply ! Note the "pass(b)" attribute!
        procedure(membership), deferred              :: is_member
        generic, public                              :: operator(+)    => add
        generic, public                              :: operator(*)    => multiply
        generic, public                              :: operator(.in.) => is_member
    end type vector

    abstract interface
        function addition( a, b )
            import :: vector

            class(vector), intent(in)  :: a, b
            class(vector), allocatable :: addition
        end function addition

        function multiplication( a, b )
            import :: vector

            real, intent(in)           :: a
            class(vector), intent(in)  :: b
            class(vector), allocatable :: multiplication
        end function multiplication

        function membership( a, b )
            import :: vector

            class(vector), intent(in)               :: a
            class(vector), intent(in), dimension(:) :: b
            logical                                 :: membership
        end function membership
    end interface
end module vectorspaces

!
! Test this with an actual implementation
!
module vectors_3d
    use vectorspaces

    type, extends(vector) :: vector_3d
        real, dimension(3) :: coords
    contains
        procedure :: add                => add_3d
        procedure, pass(b) :: multiply  => multiply_3d  !<== Note: pass(b) required!
        procedure :: is_member          => is_member_3d
    end type

    ! Define this explicitly
    !interface operator(*)
    !    module procedure multiply_3d
    !end interface

    interface assignment(=)
        module procedure assign_vector_3d
    end interface

contains
function add_3d( a, b )
    class(vector_3d), intent(in)  :: a
    class(vector), intent(in)     :: b
    class(vector), allocatable    :: add_3d

    allocate( add_3d, mold = a )

    !
    ! Clumsy, but that is a consequence of the strict typing in Fortran
    !
    select type (add_3d)
        type is (vector_3d)
            select type (b)
                type is (vector_3d)
                    add_3d%coords = a%coords + b%coords
                class default
                     add_3d%coords = [0.0, 0.0, 0.0] ! A run-time error is probably better
            end select
    end select
end function add_3d

function multiply_3d( a, b )
    real, intent(in)              :: a
    class(vector_3d), intent(in)  :: b
    class(vector), allocatable    :: multiply_3d

    allocate( multiply_3d, mold = b )

    select type (multiply_3d)
        type is (vector_3d)
            multiply_3d%coords = a * b%coords
    end select

end function multiply_3d

logical function is_member_3d( a, b )
    class(vector_3d), intent(in)               :: a
    class(vector), intent(in), dimension(:)    :: b

    integer                                    :: i

    is_member_3d = .false.

    select type (b)
        type is (vector_3d)
            do i = 1,size(b)
                if ( all( a%coords == b(i)%coords ) ) then
                    is_member_3d = .true.
                    exit
                endif
            enddo

        class default
            ! Always return false!
            is_member_3d = .false.
    end select
end function is_member_3d

! coords --
!     To print the resulting vector, use a "getter"
!
function coords( a )
    class(vector), intent(in) :: a
    real, dimension(3)        :: coords

    select type ( a )
        type is (vector_3d)
            coords = a%coords
        class default
            coords = 0.0
    end select
end function coords

! assign_vector_3d --
!     Overcome the discrepancy between vector and vector_3d
!
subroutine assign_vector_3d( a, b )
    class(vector_3d), intent(out) :: a
    class(vector), intent(in)     :: b

    select type ( b )
        type is (vector_3d)
            a%coords = b%coords
        class default
            a%coords = 0.0
    end select
end subroutine assign_vector_3d

end module vectors_3d

! Test program for the vector space modules
!
! Note:
!     To keep the program small, there is no facility to manipulate a collection
!     of vectors, but you could add that too.
!
program test_space
    use vectors_3d

    implicit none

    type(vector_3d)                :: a, b, c
    type(vector_3d), dimension(10) :: vectors

    a = vector_3d( [1.0, 1.0, 1.0] )
    b = vector_3d( [2.0, 2.0, 2.0] )
    c = vector_3d( [3.0, 3.0, 3.0] )

    vectors = vector_3d( [0.0, 0.0, 0.0] ) ! Primitive initialisation

    vectors(1) = a
    vectors(2) = b

    write(*,*) 'Is a in the collection? ', a .in. vectors
    write(*,*) 'Is c in the collection? ', c .in. vectors

    vectors(3) = a + b
    write(*,*) 'Added the sum of a and b - should be equal to c'
    write(*,*) 'Is c in the collection? ', c .in. vectors

    write(*,*) 'a + b  = ', coords(a + b)
    write(*,*) '10 * c = ', coords(10.0 * c)

end program test_space


program t
  print '(f3.1)',sqrt(9.0)
end program t


*     MB02JX EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, LMAX, MMAX, NMAX
      PARAMETER        ( KMAX = 20, LMAX = 20, MMAX = 20, NMAX = 20 )
      INTEGER          LDR, LDQ, LDTC, LDTR, LDWORK
      PARAMETER        ( LDR  = NMAX*LMAX, LDQ  = MMAX*KMAX,
     $                   LDTC = MMAX*KMAX, LDTR = KMAX,
     $                   LDWORK = ( MMAX*KMAX + NMAX*LMAX )
     $                            *( LMAX + 2*KMAX ) + 5*LMAX
     $                            + MMAX*KMAX + NMAX*LMAX )
*     .. Local Scalars ..
      CHARACTER        JOB
      INTEGER          I, INFO, J, K, L, M, N, RNK
      DOUBLE PRECISION TOL1, TOL2
*     .. Local Arrays ..
      INTEGER          JPVT(NMAX*LMAX)
      DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,NMAX*LMAX),
     $                 R(LDR,NMAX*LMAX), TC(LDTC,LMAX),
     $                 TR(LDTR,NMAX*LMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02JX
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K, L, M, N, TOL1, TOL2, JOB
      IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) K
      ELSE IF( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) L
      ELSE IF( M.LE.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( TC(I,J), J = 1,L ), I = 1,M*K )
         READ ( NIN, FMT = * ) ( ( TR(I,J), J = 1,( N - 1 )*L ),
     $                             I = 1,K )
*        Compute the required part of the QR factorization.
         CALL MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, LDQ,
     $                R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99994 ) RNK
            IF ( LSAME( JOB, 'Q' ) ) THEN
               WRITE ( NOUT, FMT = 99997 )
               DO 10  I = 1, M*K
                  WRITE ( NOUT, FMT = 99993 ) ( Q(I,J), J = 1, RNK )
   10          CONTINUE
            END IF
            WRITE ( NOUT, FMT = 99996 )
            DO 20  I = 1, N*L
               WRITE ( NOUT, FMT = 99993 ) ( R(I,J), J = 1, RNK )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            WRITE ( NOUT, FMT = 99992 ) ( JPVT(I),
     $                                    I = 1, MIN( M*K, N*L ) )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02JX EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02JX = ',I2)
99997 FORMAT (/' The factor Q is ')
99996 FORMAT (/' The factor R is ')
99995 FORMAT (/' The column permutation is ')
99994 FORMAT (/' Numerical rank ',/' RNK = ',I5)
99993 FORMAT (20(1X,F8.4))
99992 FORMAT (20(1X,I4))
99991 FORMAT (/' K is out of range.',/' K = ',I5)
99990 FORMAT (/' L is out of range.',/' L = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' N is out of range.',/' N = ',I5)
      END


!==========================================================================
elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio (sa, p)
!==========================================================================
!
!  Calculates the ratio of SA to CT changes when sea ice melts into
!  seawater with both the seawater and the sea ice temperatures being
!  almost equal to the equilibrium freezing temperature.  It is assumed
!  that a small mass of seaice melts into an infinite mass of seawater.  If
!  indeed the temperature of the seawater and the sea ice were both equal
!  to the freezing temperature, then no melting or freezing would occur; an
!  imbalance between these three temperatures is needed for freezing or
!  melting to occur (the three temperatures being (1) the seawater
!  temperature, (2) the sea ice temperature, and (3) the freezing
!  temperature.
!
!  Note that the output of this function, dSA/dCT is independent of the
!  sea ice salinity, SA_seaice.  That is, the output applies equally to
!  pure ice Ih and to sea ice with seaice salinity, SA_seaice.  This result
!  is proven in the manuscript, McDougall et al. (2013).
!
!  The output, melting_seaice_equilibrium_SA_CT_ratio, is dSA/dCT rather
!  than dCT/dSA.  This is done so that when SA = 0, the output, dSA/dCT is
!  zero whereas dCT/dSA would be infinite.
!
!  SA  =  Absolute Salinity of seawater                            [ g/kg ]
!  p   =  sea pressure at which the melting occurs                 [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  melting_seaice_equilibrium_SA_CT_ratio = the ratio dSA/dCT of SA to CT
!                            changes when sea ice melts into seawater, with
!                            the seawater and sea ice being close to the
!                            freezing temperature.             [ g/(kg K) ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_ct_freezing_exact, gsw_enthalpy_ct_exact
use gsw_mod_toolbox, only : gsw_t_freezing_exact, gsw_enthalpy_ice
use gsw_mod_toolbox, only : gsw_enthalpy_first_derivatives_ct_exact

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p

real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio

real (r8) :: ctf, h, h_ih, t_seaice, h_hat_sa, h_hat_ct

real (r8), parameter :: saturation_fraction = 0.0_r8

ctf = gsw_ct_freezing_exact(sa,p,saturation_fraction)
t_seaice = gsw_t_freezing_exact(sa,p,saturation_fraction)

h = gsw_enthalpy_ct_exact(sa,ctf,p)
h_ih = gsw_enthalpy_ice(t_seaice,p)
call gsw_enthalpy_first_derivatives_ct_exact(sa,ctf,p,h_hat_sa,h_hat_ct)

gsw_melting_seaice_equilibrium_sa_ct_ratio = sa*h_hat_ct / &
                                                 (h - h_ih - sa*h_hat_sa)

return
end function

!--------------------------------------------------------------------------


	SUBROUTINE DP_PDEC  ( grid, igx, igy, ires, idata, lendat,
     +			      qmin, scale, nbits, iret )
C************************************************************************
C* DP_PDEC								*
C*									*
C* This subroutine uses the precision specified to pack a grid into	*
C* the GEMPAK GRIB format.  The precision specifies the power of	*
C* 10 to be used in scaling the data before converting to an integer.	*
C* The minimum number of bits required to maintain the precision is	*
C* computed.  The GEMPAK GRIB packing and unpacking equations are:	*
C*									*
C*	IDATA  =  NINT ( ( GRID - QMIN ) / SCALE )			*
C*	GRID   =  QMIN  +  IDATA * SCALE				*
C*									*
C* DP_PDEC  ( GRID, IGX, IGY, IRES, IDATA, LENDAT, QMIN, SCALE, NBITS,	*
C*            IRET )							*
C*									*
C* Input parameters:							*
C*	GRID (IGX,IGY)	REAL		Grid data			*
C*	IGX		INTEGER		Number of points in x dir	*
C*	IGY		INTEGER		Number of points in y dir	*
C*	IRES		INTEGER		Precision as power of 10	*
C*									*
C* Output parameters:							*
C*	IDATA (LENDAT)	INTEGER		Packed data			*
C*	LENDAT		INTEGER		Length of packed data array	*
C*	QMIN		REAL		Minimum value of grid		*
C*	SCALE		REAL		Scaling factor			*
C*	NBITS		INTEGER		Number of bits			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-10 = NBITS invalid		*
C*					-11 = invalid data range	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 3/89						*
C* K. Brill/GSC          2/90 	Fix to find negative max on grid	*
C* S. Gilbert/NCEP       2/06   Fix to pack constant fields w/ missings *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		grid  (*)
	INTEGER		idata (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	kxky = igx * igy
C
C*	Compute the scaling factor.
C
	scale = 10. ** ires
C
C*	Read through the grid finding the minimum and maximum values.
C
	qmin = 1.0E+31
	qmax = -1.0E+31
	DO  i = 1, kxky
	    IF  ( .not. ERMISS ( grid (i) ) )  THEN
		IF  ( grid (i) .lt. qmin )  qmin = grid (i)
		IF  ( grid (i) .gt. qmax )  qmax = grid (i)
	    END IF
	END DO
C
C*	Find the data range and check that it is valid.
C
	qdif = qmax - qmin
	IF  ( qmax .eq. -1.0E+31 .AND. qmin .eq. 1.0E+31 )  THEN
	    qdif = 0.
	ELSE IF  ( qdif .lt. 0. )  THEN
	    iret = -11
	    RETURN
	END IF
	idif = NINT ( qdif * scale )
	IF  ( FLOAT ( idif ) .ne. qdif * scale )  idif = idif + 1
        IF  ( idif .eq. 0 ) idif = 2
C
C*	Find the minimum number of bits to use to store grid.
C
	nbits = 1
	DO WHILE  ( idif .ge. ( 2 ** nbits - 1 ) )
	    nbits = nbits + 1
	END DO
C
C*	Compute the number of output words and initialize the output
C*	buffer.
C
	lendat = FLOAT ( nbits * kxky ) / 32.
	IF  ( lendat * 32  .ne.  nbits * kxky )  lendat = lendat + 1
	DO  i = 1, lendat
	    idata (i) = 0
	END DO
C
C*	Add data points to output buffer.
C
	imax  = 2 ** nbits - 1
	iword = 1
	ibit  = 1
	DO  i = 1, kxky
C
C*	    Turn grid value into an integer.
C
	    IF  ( ERMISS ( grid (i) ) )  THEN
		idat = imax
	      ELSE
		gggg = grid (i) - qmin
		IF  ( gggg .lt. 0. )  gggg = 0.
		idat = NINT ( gggg * scale )
	    END IF
C
C*	    Shift bits to correct location in word.
C
	    jshft = 33 - nbits - ibit
	    idat2 = ISHFT ( idat, jshft )
	    idata (iword) = IOR ( idata (iword), idat2 )
C
C*	    Check to see if packed integer overflows into next word.
C
	    IF  ( jshft .lt. 0 )  THEN
		jshft = 32 + jshft
		idata (iword+1) = ISHFT ( idat, jshft )
	    END IF
C
C*	    Set location for next word.
C
	    ibit = ibit + nbits
	    IF  ( ibit .gt. 32 )  THEN
		ibit  = ibit - 32
		iword = iword + 1
	    END IF
	END DO
C
C*	The scale factor to be saved is really the reciprocal of the
C*	scale which was computed.
C
	scale = 1. / scale
C*
	RETURN
	END


*> \brief \b ZGEBAL
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGEBAL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          JOB
*       INTEGER            IHI, ILO, INFO, LDA, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   SCALE( * )
*       COMPLEX*16         A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGEBAL balances a general complex matrix A.  This involves, first,
*> permuting A by a similarity transformation to isolate eigenvalues
*> in the first 1 to ILO-1 and last IHI+1 to N elements on the
*> diagonal; and second, applying a diagonal similarity transformation
*> to rows and columns ILO to IHI to make the rows and columns as
*> close in norm as possible.  Both steps are optional.
*>
*> Balancing may reduce the 1-norm of the matrix, and improve the
*> accuracy of the computed eigenvalues and/or eigenvectors.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOB
*> \verbatim
*>          JOB is CHARACTER*1
*>          Specifies the operations to be performed on A:
*>          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
*>                  for i = 1,...,N;
*>          = 'P':  permute only;
*>          = 'S':  scale only;
*>          = 'B':  both permute and scale.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          On entry, the input matrix A.
*>          On exit,  A is overwritten by the balanced matrix.
*>          If JOB = 'N', A is not referenced.
*>          See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] ILO
*> \verbatim
*>          ILO is INTEGER
*> \endverbatim
*>
*> \param[out] IHI
*> \verbatim
*>          IHI is INTEGER
*>          ILO and IHI are set to INTEGER such that on exit
*>          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
*>          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*>          SCALE is DOUBLE PRECISION array, dimension (N)
*>          Details of the permutations and scaling factors applied to
*>          A.  If P(j) is the index of the row and column interchanged
*>          with row and column j and D(j) is the scaling factor
*>          applied to row and column j, then
*>          SCALE(j) = P(j)    for j = 1,...,ILO-1
*>                   = D(j)    for j = ILO,...,IHI
*>                   = P(j)    for j = IHI+1,...,N.
*>          The order in which the interchanges are made is N to IHI+1,
*>          then 1 to ILO-1.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16GEcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The permutations consist of row and column interchanges which put
*>  the matrix in the form
*>
*>             ( T1   X   Y  )
*>     P A P = (  0   B   Z  )
*>             (  0   0   T2 )
*>
*>  where T1 and T2 are upper triangular matrices whose eigenvalues lie
*>  along the diagonal.  The column indices ILO and IHI mark the starting
*>  and ending columns of the submatrix B. Balancing consists of applying
*>  a diagonal similarity transformation inv(D) * B * D to make the
*>  1-norms of each row of B and its corresponding column nearly equal.
*>  The output matrix is
*>
*>     ( T1     X*D          Y    )
*>     (  0  inv(D)*B*D  inv(D)*Z ).
*>     (  0      0           T2   )
*>
*>  Information about the permutations P and the diagonal matrix D is
*>  returned in the vector SCALE.
*>
*>  This subroutine is based on the EISPACK routine CBAL.
*>
*>  Modified by Tzu-Yi Chen, Computer Science Division, University of
*>    California at Berkeley, USA
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            IHI, ILO, INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   SCALE( * )
      COMPLEX*16         A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   SCLFAC
      PARAMETER          ( SCLFAC = 2.0D+0 )
      DOUBLE PRECISION   FACTOR
      PARAMETER          ( FACTOR = 0.95D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOCONV
      INTEGER            I, ICA, IEXC, IRA, J, K, L, M
      DOUBLE PRECISION   C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
     $                   SFMIN2
*     ..
*     .. External Functions ..
      LOGICAL            DISNAN, LSAME
      INTEGER            IZAMAX
      DOUBLE PRECISION   DLAMCH, DZNRM2
      EXTERNAL           DISNAN, LSAME, IZAMAX, DLAMCH, DZNRM2
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZDSCAL, ZSWAP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
*
*     Test the input parameters
*
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGEBAL', -INFO )
         RETURN
      END IF
*
      K = 1
      L = N
*
      IF( N.EQ.0 )
     $   GO TO 210
*
      IF( LSAME( JOB, 'N' ) ) THEN
         DO 10 I = 1, N
            SCALE( I ) = ONE
   10    CONTINUE
         GO TO 210
      END IF
*
      IF( LSAME( JOB, 'S' ) )
     $   GO TO 120
*
*     Permutation to isolate eigenvalues if possible
*
      GO TO 50
*
*     Row and column exchange.
*
   20 CONTINUE
      SCALE( M ) = J
      IF( J.EQ.M )
     $   GO TO 30
*
      CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
      CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
*
   30 CONTINUE
      GO TO ( 40, 80 )IEXC
*
*     Search for rows isolating an eigenvalue and push them down.
*
   40 CONTINUE
      IF( L.EQ.1 )
     $   GO TO 210
      L = L - 1
*
   50 CONTINUE
      DO 70 J = L, 1, -1
*
         DO 60 I = 1, L
            IF( I.EQ.J )
     $         GO TO 60
            IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE.
     $          ZERO )GO TO 70
   60    CONTINUE
*
         M = L
         IEXC = 1
         GO TO 20
   70 CONTINUE
*
      GO TO 90
*
*     Search for columns isolating an eigenvalue and push them left.
*
   80 CONTINUE
      K = K + 1
*
   90 CONTINUE
      DO 110 J = K, L
*
         DO 100 I = K, L
            IF( I.EQ.J )
     $         GO TO 100
            IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE.
     $          ZERO )GO TO 110
  100    CONTINUE
*
         M = K
         IEXC = 2
         GO TO 20
  110 CONTINUE
*
  120 CONTINUE
      DO 130 I = K, L
         SCALE( I ) = ONE
  130 CONTINUE
*
      IF( LSAME( JOB, 'P' ) )
     $   GO TO 210
*
*     Balance the submatrix in rows K to L.
*
*     Iterative loop for norm reduction
*
      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
      SFMAX1 = ONE / SFMIN1
      SFMIN2 = SFMIN1*SCLFAC
      SFMAX2 = ONE / SFMIN2
  140 CONTINUE
      NOCONV = .FALSE.
*
      DO 200 I = K, L
*
         C = DZNRM2( L-K+1, A( K, I ), 1 )
         R = DZNRM2( L-K+1, A( I, K ), LDA )
         ICA = IZAMAX( L, A( 1, I ), 1 )
         CA = ABS( A( ICA, I ) )
         IRA = IZAMAX( N-K+1, A( I, K ), LDA )
         RA = ABS( A( I, IRA+K-1 ) )
*
*        Guard against zero C or R due to underflow.
*
         IF( C.EQ.ZERO .OR. R.EQ.ZERO )
     $      GO TO 200
         G = R / SCLFAC
         F = ONE
         S = C + R
  160    CONTINUE
         IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
     $       MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
            IF( DISNAN( C+F+CA+R+G+RA ) ) THEN
*
*           Exit if NaN to avoid infinite loop
*
            INFO = -3
            CALL XERBLA( 'ZGEBAL', -INFO )
            RETURN
         END IF
         F = F*SCLFAC
         C = C*SCLFAC
         CA = CA*SCLFAC
         R = R / SCLFAC
         G = G / SCLFAC
         RA = RA / SCLFAC
         GO TO 160
*
  170    CONTINUE
         G = C / SCLFAC
  180    CONTINUE
         IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
     $       MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
         F = F / SCLFAC
         C = C / SCLFAC
         G = G / SCLFAC
         CA = CA / SCLFAC
         R = R*SCLFAC
         RA = RA*SCLFAC
         GO TO 180
*
*        Now balance.
*
  190    CONTINUE
         IF( ( C+R ).GE.FACTOR*S )
     $      GO TO 200
         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
            IF( F*SCALE( I ).LE.SFMIN1 )
     $         GO TO 200
         END IF
         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
            IF( SCALE( I ).GE.SFMAX1 / F )
     $         GO TO 200
         END IF
         G = ONE / F
         SCALE( I ) = SCALE( I )*F
         NOCONV = .TRUE.
*
         CALL ZDSCAL( N-K+1, G, A( I, K ), LDA )
         CALL ZDSCAL( L, F, A( 1, I ), 1 )
*
  200 CONTINUE
*
      IF( NOCONV )
     $   GO TO 140
*
  210 CONTINUE
      ILO = K
      IHI = L
*
      RETURN
*
*     End of ZGEBAL
*
      END


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief pressure in Pa from hydraulic potential und heigth above hz=0.0d0
!>    @param[in] init flag: 0-init, 1-normal setup
!>    @param[in] ismpl local sample index
!>    @details
!>    pressure in MPa from hydraulic potential und height above hz=0.0 \n
!>    p(surface) = 0.1 MPa \n
!>    OUTPUT in Pa\n
      SUBROUTINE omp_head2pres(init,ismpl)
        use arrays
        use mod_genrl
        use mod_genrlc
        use mod_flow
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j, k
        INTEGER init
        DOUBLE PRECISION psurf
        DOUBLE PRECISION dif
        DOUBLE PRECISION zero
        PARAMETER (zero=0.0D0)

!     presetting for dirichlet boundary conditions to avoid site effects
        CALL set_dhbc(ismpl)
        CALL set_dtbc(ismpl)
!$OMP barrier
!
        psurf = 1.0D5
!
        IF (init==0) THEN
!         initialize
!$OMP     do schedule(static) collapse(3)
          DO k = 1, k0
            DO j = 1, j0
              DO i = 1, i0
                dif = head(i,j,k,ismpl) - delza(k)
                pres(i,j,k,ismpl) = psurf
                IF (dif>zero) pres(i,j,k,ismpl) = psurf + dif*rref*grav
              END DO
            END DO
          END DO
!$OMP     end do nowait
        ELSE
!        pres and temp have already appropriate values
!$OMP     do schedule(static) collapse(3)
          DO k = 1, k0
            DO j = 1, j0
              DO i = 1, i0
                dif = head(i,j,k,ismpl) - delza(k)
                pres(i,j,k,ismpl) = psurf
! jbr: pres = (h-z)*rref*grav
                IF (dif>zero) pres(i,j,k,ismpl) = psurf + &
                  rref*dif*grav
              END DO
            END DO
          END DO
!$OMP     end do nowait
        END IF
!
        RETURN
      END


c subroutine integ.f
c
c source
c   Bevington, page 274.
c
c purpose
c   integrate the area beneath two data points
c
c usage
c   call integ (x, y, nterms, i1, x1, x2, sum)
c
c description of parameters
c   x	   - array of data points for independent variable
c   y	   - array of data points for dependent variable
c   nterms - number of terms in fitting polymonial
c   i1	   - first data point for fitting polynomial
c   x1	   - first value of x for integration
c   x2	   - final value of x for integration
c
c subroutines and function subprograms required
c   none
c
c comments
c   dimension statement valid for nterms up to 10
c
	subroutine integ (x,y,nterms,i1,x1,x2,sum)
	double precision xjk,array,a,denom,deltax,sum
	dimension x(1),y(1)
	dimension array(10,10)
c
c construct square matrix and invert
c
11	do 17 j=1,nterms
	i=j+i1-1
	deltax=x(i)-x(i1)
	xjk=1.
	do 17 k=1,nterms
	array(j,k)=xjk
17	xjk=xjk*deltax
21	call matinv (array,nterms,det)
	if (det) 31,23,31
23	imid=i1+nterms/2
	sum=sum+y(imid)*(x2-x1)
	goto 40
c
c evaluate coefficients and integrate
c
31	dx1=x1-x(i1)
	dx2=x2-x(i1)
33	do 39 j=1,nterms
	i=j+i1-1
	a=0.
	do 37 k=1,nterms
37	a=a+y(i)*array(j,k)
	denom=j
39	sum=sum+(a/denom)*(dx2**j-dx1**j)
40	return
	end


!==============================================================================!
  subroutine Turb_Mod_Calculate_Heat_Flux(turb)
!------------------------------------------------------------------------------!
!   Computes turbulent heat fluxes                                             !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type),  target :: turb
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type), pointer :: flow
  type(Grid_Type),  pointer :: grid
  type(Var_Type),   pointer :: uu, vv, ww, uv, uw, vw
  type(Var_Type),   pointer :: t, ut, vt, wt
  integer                   :: c
!==============================================================================!

  ! Take aliases
  flow => turb % pnt_flow
  grid => flow % pnt_grid
  t    => flow % t
  call Turb_Mod_Alias_Heat_Fluxes(turb, ut, vt, wt)
  call Turb_Mod_Alias_Stresses   (turb, uu, vv, ww, uv, uw, vw)

  ! Check if these are already computed somewhere, ...
  ! ... maybe this call is not needed
  call Field_Mod_Grad_Variable(flow, t)

  !-----------------------------------------!
  !   Compute the sources in the interior   !
  !-----------------------------------------!
  call Control_Mod_Turbulent_Prandtl_Number(pr_t)

  if(turb % heat_flux_model .eq. SGDH) then

    do c = 1, grid % n_cells
      pr_t = max(Turb_Mod_Prandtl_Number(turb, c), TINY)
      ut % n(c) = - turb % vis_t(c) / flow % density(c) / pr_t * t % x(c)
      vt % n(c) = - turb % vis_t(c) / flow % density(c) / pr_t * t % y(c)
      wt % n(c) = - turb % vis_t(c) / flow % density(c) / pr_t * t % z(c)
    end do

  else if(turb % heat_flux_model .eq. GGDH) then

    do c = 1, grid % n_cells
      ut % n(c) = -c_theta * turb % t_scale(c) * (uu % n(c) * t % x(c)  +  &
                                                  uv % n(c) * t % y(c)  +  &
                                                  uw % n(c) * t % z(c))
      vt % n(c) = -c_theta * turb % t_scale(c) * (uv % n(c) * t % x(c)  +  &
                                                  vv % n(c) * t % y(c)  +  &
                                                  vw % n(c) * t % z(c))
      wt % n(c) = -c_theta * turb % t_scale(c) * (uw % n(c) * t % x(c)  +  &
                                                  vw % n(c) * t % y(c)  +  &
                                                  ww % n(c) * t % z(c))
    end do

  else if(turb % heat_flux_model .eq. AFM) then
  end if

  end subroutine


module filtering
  use mod_queue
  implicit none
  real(8), parameter :: PI = 4*atan(1.0_8)

contains
  pure function filtering_(img, filter, maximum_value, fill) result(filtered)
    !!! apply filter
    !!!
    !!! inputs:
    !!!   img(integer, 3D): image array.
    !!!   filter(integer, 2D): filter.
    !!!   maximum_value(integer): max pix value.
    !!!   fill(logical, optional): if it is true, fill edge of the filtered image.
    !!! outputs:
    !!!   filterd(integer, 3D): filterd image. same size as the original image.
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    integer, intent(in) :: filter(:, :)
    logical, intent(in), optional :: fill
    integer, allocatable :: filtered(:, :, :)

    integer :: depth, height, width, d, h, w, img_shape(3), filter_shape(2), dx, dy, sum_of_filter
    integer, allocatable :: window(:, :)

    img_shape = shape(img)
    depth = img_shape(1)
    height = img_shape(2)
    width = img_shape(3)
    allocate (filtered(depth, height, width))
    filtered(:, :, :) = img(:, :, :)

    filter_shape = shape(filter)
    allocate (window(filter_shape(1), filter_shape(2)))

    dx = filter_shape(2)/2
    dy = filter_shape(1)/2
    if (sum(filter) == 0) then
      sum_of_filter = 1
    else
      sum_of_filter = sum(filter)
    end if

    do w = dx + 1, width - dx
      do h = dy + 1, height - dy
        do d = 1, depth
          window = img(d, h - dy:h + dy, w - dx:w + dx)
          filtered(d, h, w) = min(maximum_value, &
                                  max(0, &
                                      sum(window*filter)/sum_of_filter))
        end do
      end do
    end do
    if (present(fill) .and. fill) then
      call fill_edge(filtered, n_around=dx)
    end if
  end function filtering_

  pure recursive subroutine fill_edge(img, n_around)
    !!! fill edges with the same color as closest pix.
    !!!
    !!! inputs:
    !!!   img(integer, 3D): image array.
    !!!   n_around(integer): the pix of fill edge.
    implicit none
    integer, intent(inout), dimension(:, :, :) :: img
    integer, intent(in) :: n_around
    integer :: img_shape(3)
    integer :: depth, width, height, d, w, h

    img_shape = shape(img)
    depth = img_shape(1)
    height = img_shape(2)
    width = img_shape(3)

    do d = 1, depth
      if (n_around > 0) then
        do w = n_around + 1, width - n_around
          img(d, n_around, w) = img(d, n_around + 1, w)
          img(d, height - n_around + 1, w) = img(d, height - n_around, w)
        end do

        do h = n_around + 1, height - n_around
          img(d, h, n_around) = img(d, h, n_around + 1)
          img(d, h, width - n_around + 1) = img(d, h, width - n_around)
        end do

        img(d, n_around, n_around) = img(d, n_around + 1, n_around + 1)
        img(d, n_around, width - n_around + 1) = img(d, n_around + 1, width - n_around)
        img(d, height - n_around + 1, n_around) = img(d, height - n_around, n_around + 1)
        img(d, height - n_around + 1, width - n_around + 1) = img(d, height - n_around, width - n_around)

        call fill_edge(img, n_around - 1)
      end if
    end do
  end subroutine fill_edge

  pure function laplacian(img, maximum_value) result(output)
    !!! laplacian filtering (8 neighborhood)
    !!!
    !!! inputs
    !!!   img(integer, 3D): array. have pix value.
    !!!   maximum_value(integer): max value of a pix. default to 255.
    !!! outputs:
    !!!   output(integer, 3D): filterd image.
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    integer, allocatable :: output(:, :, :)
    integer, parameter, dimension(3, 3) :: filter = reshape((/1, 1, 1, &
                                                              1, -8, 1, &
                                                              1, 1, 1/), shape(filter))
    output = filtering_(img, filter, maximum_value, fill=.true.)
  end function laplacian

  pure function gaussian(img, maximum_value, n_times) result(output)
    !!! gaussian filtering (24 neighborhood)
    !!!
    !!! inputs:
    !!!   img(integer, 3D): array. have pix value.
    !!!   maximum_value(integer, optional): max value of a pix. default to 255.
    !!!   n_times(integer): number of time apply filter.
    !!! outputs:
    !!!   output(integer, 3D): filterd image.
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    integer, intent(in) :: n_times
    integer, allocatable :: output(:, :, :)

    integer, parameter, dimension(5, 5) :: filter = reshape((/1, 4, 6, 4, 1, &
                                                              4, 16, 24, 16, 4, &
                                                              6, 24, 36, 24, 6, &
                                                              4, 16, 24, 16, 4, &
                                                              1, 4, 6, 4, 1/), shape(filter))
    integer :: img_shape(3), n_time

    img_shape = shape(img)
    allocate (output(img_shape(1), img_shape(2), img_shape(3)))

    output(:, :, :) = img(:, :, :)

    do n_time = 1, n_times
      output = filtering_(output, filter, maximum_value, fill=.false.)
    end do
    call fill_edge(output, n_around=2)

  end function gaussian

  function sobel(img, maximum_value, is_canny) result(output)
    !!! sobel filter (sqrt version)
    !!!
    !!! inputs:
    !!!   img(integer, 3D): input image.
    !!!   maximum_value(integer, optional): max value of a pix. default to 255
    !!!   is_canny(logocal, optional): is used in canny adge detection
    !!! outputs:
    !!!   output(integer, 3D): filterd image
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    logical, intent(in), optional :: is_canny
    integer, allocatable :: output(:, :, :)
    real, allocatable :: edge_directions(:, :, :)
    integer, parameter, dimension(3, 3) :: kernel_x = reshape((/-1, -2, -1, &
                                                                0, 0, 0, &
                                                                1, 2, 1/), shape(kernel_x))
    integer, parameter, dimension(3, 3) :: kernel_y = reshape((/-1, 0, 1, &
                                                                -2, 0, 2, &
                                                                -1, 0, 1/), shape(kernel_y))
    integer ::depth, height, width, d, h, w, img_shape(3)
    real, allocatable :: sx(:, :, :), sy(:, :, :)

    img_shape = shape(img)
    depth = img_shape(1)
    height = img_shape(2)
    width = img_shape(3)

    allocate (output(depth, height, width))
    allocate (edge_directions(depth, height, width))
    allocate (sx(depth, height, width))
    allocate (sy(depth, height, width))

    output = 0
    edge_directions = 0.0

    do w = 2, width - 1
      do h = 2, height - 1
        do d = 1, depth
          sx(d, h, w) = sum(img(d, h - 1:h + 1, w - 1:w + 1)*kernel_x)
          sy(d, h, w) = sum(img(d, h - 1:h + 1, w - 1:w + 1)*kernel_y)
        end do
      end do
    end do

    output = min(maximum_value, max(0, int(sqrt(sx**2 + sy**2))))
    edge_directions = atan2(sy, sx)*180/PI  ! sx == 0 .and. sy == 0の処理がないけど動いている
    deallocate (sx)
    deallocate (sy)

    call fill_edge(output, 1)

    if (present(is_canny) .and. is_canny) then
      call non_maximun_supperssion(output, edge_directions)
      call hysteresis(output, maximum_value)
    end if
  end function sobel

  function canny_edge_detection(img, maximum_value) result(output)
    !!! apply canny edge detection
    !!! the method is
    !!! 1. apply gaussian filtering
    !!! 2. apply sobel filtering
    !!! 3. non-maximum supperssion
    !!! 4. edge tracking by hysteresis
    !!!
    !!! inputs:
    !!!   img(integer, 2D): image array
    !!!   maximum_value(integer): the max value of pix.
    !!! outputs:
    !!!   output(integer, 3D): edge array.
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    integer, allocatable :: output(:, :, :)

    integer, allocatable::tmp(:, :, :)
    integer :: depth, height, width, d, h, w, img_shape(3)

    img_shape = shape(img)
    depth = img_shape(1)
    height = img_shape(2)
    width = img_shape(3)
    if (depth /= 1) then
      print *, "n_layer must be 1, the n_layer is ", depth
      stop 1
    end if
    allocate (tmp(depth, height, width))
    tmp = gaussian(img, maximum_value, n_times=1)
    output = sobel(tmp, maximum_value, is_canny=.true.)
    deallocate (tmp)
  end function canny_edge_detection

  pure subroutine non_maximun_supperssion(edge_magnitudes, edge_ways)
    !!! Perform non-maximum_supperssin
    !!!
    !!! inputs:
    !!!   edge_magnitudes(integer, 2D): edge magnitude array
    !!!   edge_ways(real, 2D): edge directions array
    implicit none
    integer, intent(inout) :: edge_magnitudes(:, :, :)
    real, intent(inout):: edge_ways(:, :, :)
    integer, allocatable :: tmp_image(:, :, :)
    integer :: depth, width, height, d, w, h, img_shape(3)
    real :: way, edges(3)

    img_shape = shape(edge_magnitudes)
    depth = img_shape(1)
    height = img_shape(2)
    width = img_shape(3)

    allocate (tmp_image(depth, height, width))
    tmp_image = 0

    ! 量子化
    forall (d=1:depth, h=1:height, w=1:width, (-1*PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < PI/8)) edge_ways(d, h, w) = 0
    forall (d=1:depth, h=1:height, w=1:width, (7*PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < PI)) edge_ways(d, h, w) = 0
    forall (d=1:depth, h=1:height, w=1:width, (-1*PI <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < -7*PI/8)) edge_ways(d, h, w) = 0
    forall (d=1:depth, h=1:height, w=1:width, (PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < 3*PI/8)) edge_ways(d, h, w) = 45.0
    forall (d=1:depth, h=1:height, w=1:width, (-7*PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < -5*PI/8)) edge_ways(d, h, w) = 45.0
    forall (d=1:depth, h=1:height, w=1:width, (3*PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < 5*PI/8)) edge_ways(d, h, w) = 90.0
    forall (d=1:depth, h=1:height, w=1:width, (-5*PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < -3*PI/8)) edge_ways(d, h, w) = 90.0
    forall (d=1:depth, h=1:height, w=1:width, (5*PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < 7*PI/8)) edge_ways(d, h, w) = 135.0
    forall (d=1:depth, h=1:height, w=1:width, (-3*PI/8 <= edge_ways(d, h, w) &
                                               .and. edge_ways(d, h, w) < -1*PI/8)) edge_ways(d, h, w) = 135.0

    do w = 2, width - 1
      do h = 2, height - 1
        do d = 1, depth
          way = edge_ways(d, h, w)
          if (way == 0.0) then
            edges = edge_magnitudes(d, h, w - 1:w + 1)
          else if (way == 45.0) then
            edges = [edge_magnitudes(d, h - 1, w + 1), edge_magnitudes(d, h, w), edge_magnitudes(d, h + 1, w - 1)]
          else if (way == 90.0) then
            edges = edge_magnitudes(d, h - 1:h + 1, w)
          else
            edges = [edge_magnitudes(d, h + 1, w + 1), edge_magnitudes(d, h, w), edge_magnitudes(d, h - 1, w - 1)]
          end if

          if (edges(2) < edges(1) .or. edges(2) < edges(3)) then
            !   edge_magnitudes(h, w) = 0
            tmp_image(d, h, w) = 0
          else
            tmp_image(d, h, w) = edge_magnitudes(d, h, w)
          end if
        end do
      end do
    end do
    edge_magnitudes(:, :, :) = tmp_image
  end subroutine non_maximun_supperssion

  subroutine hysteresis(img, maximum_value)
    !!! edge tracking by hysteresis
    !!!
    !!! inputs:
    !!!   img(integer, 3D): image array.
    !!    maximum_value(integer): the max value of pix.
    implicit none
    integer, intent(inout) :: img(:, :, :)
    integer, intent(in) :: maximum_value
    type(t_queue) :: queue
    integer :: depth, height, width, d, h, w, low_threshold, high_threshold, img_shape(3), dw, dh

    low_threshold = 75
    high_threshold = 150
    img_shape = shape(img)
    depth = img_shape(1)
    height = img_shape(2)
    width = img_shape(3)

    do w = 1, width
      do h = 1, height
        do d = 1, depth
          if (img(d, h, w) < low_threshold) then
            img(d, h, w) = 0
          else if (img(d, h, w) >= high_threshold) then
            img(d, h, w) = maximum_value
            call enqueue(queue, d)
            call enqueue(queue, h)
            call enqueue(queue, w)
          end if
        end do
      end do
    end do

    do while (size_of(queue) > 0)
      d = dequeue(queue)
      h = dequeue(queue)
      w = dequeue(queue)
      do dw = -1, 1
        do dh = -1, 1
          if (dw == 0 .and. dh == 0) then
            ! center is not target
          else if (h + dh < 1 .or. h + dh > height .or. w + dw < 1 .or. w + dw > width) then
            ! the index is out of img array
          else if (img(d, h + dh, w + dw) == 0) then
            ! the pix is not edge
          else if (img(d, h + dh, w + dw) == maximum_value) then
            ! the pix is already edge
          else
            img(d, h + dh, w + dw) = maximum_value
            call enqueue(queue, d)
            call enqueue(queue, h + dh)
            call enqueue(queue, w + dw)
          end if
        end do
      end do
    end do
    img = img/maximum_value*maximum_value
  end subroutine hysteresis

  pure function bilateral(img, sigma, maximum_value, n_times) result(output)
    !!! apply bilateral filter
    !!!
    !!! inputs:
    !!!   img(integer, 3D): image array.
    !!!   sigma(real): use in gaussian distribution.
    !!!   maximum_value: the max value of pix.
    !!!   n_times: number of time apply filter.
    !!! outputs:
    !!!   output(integer, 3D): filterd image.
    implicit none
    integer, intent(in):: img(:, :, :)
    real, intent(in) :: sigma
    integer, intent(in) :: maximum_value
    integer, intent(in) :: n_times
    integer, allocatable :: output(:, :, :)
    integer :: depth, height, width, d, h, w, img_shape(3), n_time, i
    real :: gaussian_dist(0:255**2), tmp_array(25), weighted_filter(5, 5), window(5, 5), center
    real, allocatable :: tmp(:, :, :)
    real, parameter, dimension(5, 5) :: filter = reshape((/1, 4, 6, 4, 1, &
                                                           4, 16, 24, 16, 4, &
                                                           6, 24, 36, 24, 6, &
                                                           4, 16, 24, 16, 4, &
                                                           1, 4, 6, 4, 1/), shape(filter))

    img_shape = shape(img)
    depth = img_shape(1)
    height = img_shape(2)
    width = img_shape(3)
    allocate (output(depth, height, width))
    allocate (tmp(depth, height, width))

    gaussian_dist = [(exp(-(real(i)/255)**2/(2*sigma**2)), i=0, 255**2)] ! TODO make this small
    tmp = real(img)
    output(:, :, :) = tmp(:, :, :)

    do n_time = 1, n_times
      do w = 3, width - 2
        do h = 3, height - 2
          do d = 1, depth
            window = tmp(d, h - 2:h + 2, w - 2:w + 2)
            center = tmp(d, h, w)
            tmp_array = reshape(abs(window - center)**2, shape(tmp_array))
            forall (i=1:size(tmp_array)) tmp_array(i) = gaussian_dist(int(tmp_array(i)))
            tmp_array = [(gaussian_dist(int(tmp_array(i))), i=1, size(tmp_array))]
            weighted_filter = filter*reshape(tmp_array, shape(filter))
            output(d, h, w) = min(maximum_value, &
                                  max(0, &
                                      nint(sum(window*weighted_filter)/sum(weighted_filter))))
          end do
        end do
      end do
      tmp(:, :, :) = output(:, :, :)  ! write back
    end do
  end function bilateral

  pure function emboss(img, maximum_value) result(filtered_img)
    !!! apply emboss filter
    !!!
    !!! inputs:
    !!!   img(integer, 3D): image array.
    !!!   maximum_value(integer): the max value of pix.
    implicit none
    integer, intent(in) :: img(:, :, :)
    integer, intent(in) :: maximum_value

    integer, allocatable :: filtered_img(:, :, :)
    integer, parameter :: filter(3, 3) = reshape([-2, -1, 0, &
                                                  -1, 1, 1, &
                                                  0, 1, 2], shape(filter))

    filtered_img = filtering_(img, filter, maximum_value, fill=.false.)
  end function emboss
end module filtering