      SUBROUTINE SB16CD( DICO, JOBD, JOBMR, JOBCF, ORDSEL, N, M, P, NCR,
     $                   A, LDA, B, LDB, C, LDC, D, LDD, F, LDF, G, LDG,
     $                   HSV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute, for a given open-loop model (A,B,C,D), and for
C     given state feedback gain F and full observer gain G,
C     such that A+B*F and A+G*C are stable, a reduced order
C     controller model (Ac,Bc,Cc) using a coprime factorization
C     based controller reduction approach. For reduction of
C     coprime factors, a stability enforcing frequency-weighted
C     model reduction is performed using either the square-root or
C     the balancing-free square-root versions of the Balance & Truncate
C     (B&T) model reduction method.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the open-loop system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not a non-zero matrix D appears
C             in the given state space model, as follows:
C             = 'D':  D is present;
C             = 'Z':  D is assumed a zero matrix.
C
C     JOBMR   CHARACTER*1
C             Specifies the model reduction approach to be used
C             as follows:
C             = 'B':  use the square-root B&T method;
C             = 'F':  use the balancing-free square-root B&T method.
C
C     JOBCF   CHARACTER*1
C             Specifies whether left or right coprime factorization
C             of the controller is to be used as follows:
C             = 'L':  use left coprime factorization;
C             = 'R':  use right coprime factorization.
C
C     ORDSEL  CHARACTER*1
C             Specifies the order selection method as follows:
C             = 'F':  the resulting controller order NCR is fixed;
C             = 'A':  the resulting controller order NCR is
C                     automatically determined on basis of the given
C                     tolerance TOL.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation, i.e.
C             the order of the matrix A.  N >= 0.
C             N also represents the order of the original state-feedback
C             controller.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     NCR     (input/output) INTEGER
C             On entry with ORDSEL = 'F', NCR is the desired order of
C             the resulting reduced order controller.  0 <= NCR <= N.
C             On exit, if INFO = 0, NCR is the order of the resulting
C             reduced order controller. NCR is set as follows:
C             if ORDSEL = 'F', NCR is equal to MIN(NCR,NCRMIN), where
C             NCR is the desired order on entry, and NCRMIN is the
C             number of Hankel-singular values greater than N*EPS*S1,
C             where EPS is the machine precision (see LAPACK Library
C             Routine DLAMCH) and S1 is the largest Hankel singular
C             value (computed in HSV(1)); NCR can be further reduced
C             to ensure HSV(NCR) > HSV(NCR+1);
C             if ORDSEL = 'A', NCR is equal to the number of Hankel
C             singular values greater than MAX(TOL,N*EPS*S1).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, if INFO = 0, the leading NCR-by-NCR part of this
C             array contains the state dynamics matrix Ac of the reduced
C             controller.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the open-loop system input/state matrix B.
C             On exit, this array is overwritten with a NCR-by-M
C             B&T approximation of the matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the open-loop system state/output matrix C.
C             On exit, this array is overwritten with a P-by-NCR
C             B&T approximation of the matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, if JOBD = 'D', the leading P-by-M part of this
C             array must contain the system direct input/output
C             transmission matrix D.
C             The array D is not referenced if JOBD = 'Z'.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P), if JOBD = 'D';
C             LDD >= 1,        if JOBD = 'Z'.
C
C     F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
C             On entry, the leading M-by-N part of this array must
C             contain a stabilizing state feedback matrix.
C             On exit, if INFO = 0, the leading M-by-NCR part of this
C             array contains the output/state matrix Cc of the reduced
C             controller.
C
C     LDF     INTEGER
C             The leading dimension of array F.  LDF >= MAX(1,M).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,P)
C             On entry, the leading N-by-P part of this array must
C             contain a stabilizing observer gain matrix.
C             On exit, if INFO = 0, the leading NCR-by-P part of this
C             array contains the input/state matrix Bc of the reduced
C             controller.
C
C     LDG     INTEGER
C             The leading dimension of array G.  LDG >= MAX(1,N).
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, HSV contains the N frequency-weighted
C             Hankel singular values ordered decreasingly (see METHOD).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If ORDSEL = 'A', TOL contains the tolerance for
C             determining the order of reduced controller.
C             The recommended value is TOL = c*S1, where c is a constant
C             in the interval [0.00001,0.001], and S1 is the largest
C             Hankel singular value (computed in HSV(1)).
C             The value TOL = N*EPS*S1 is used by default if
C             TOL <= 0 on entry, where EPS is the machine precision
C             (see LAPACK Library Routine DLAMCH).
C             If ORDSEL = 'F', the value of TOL is ignored.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK = 0,   if JOBMR = 'B';
C             LIWORK = N,   if JOBMR = 'F'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX(M,P),
C                                    N*(N + MAX(N,MP) + MIN(N,MP) + 6)),
C             where     MP = M, if JOBCF = 'L';
C                       MP = P, if JOBCF = 'R'.
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  with ORDSEL = 'F', the selected order NCR is
C                   greater than the order of a minimal realization
C                   of the controller;
C             = 2:  with ORDSEL = 'F', the selected order NCR
C                   corresponds to repeated singular values, which are
C                   neither all included nor all excluded from the
C                   reduced controller. In this case, the resulting NCR
C                   is set automatically to the largest value such that
C                   HSV(NCR) > HSV(NCR+1).
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:  eigenvalue computation failure;
C             = 2:  the matrix A+G*C is not stable;
C             = 3:  the matrix A+B*F is not stable;
C             = 4:  the Lyapunov equation for computing the
C                   observability Grammian is (nearly) singular;
C             = 5:  the Lyapunov equation for computing the
C                   controllability Grammian is (nearly) singular;
C             = 6:  the computation of Hankel singular values failed.
C
C     METHOD
C
C     Let be the linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(t) + Du(t),                             (1)
C
C     where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
C     for a discrete-time system, and let Go(d) be the open-loop
C     transfer-function matrix
C                          -1
C          Go(d) = C*(d*I-A) *B + D .
C
C     Let F and G be the state feedback and observer gain matrices,
C     respectively, chosen such that A+BF and A+GC are stable matrices.
C     The controller has a transfer-function matrix K(d) given by
C                                       -1
C          K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G .
C
C     The closed-loop transfer function matrix is given by
C                                    -1
C          Gcl(d) = Go(d)(I+K(d)Go(d)) .
C
C     K(d) can be expressed as a left coprime factorization (LCF)
C                         -1
C          K(d) = M_left(d) *N_left(d),
C
C     or as a right coprime factorization (RCF)
C                                     -1
C          K(d) = N_right(d)*M_right(d) ,
C
C     where M_left(d), N_left(d), N_right(d), and M_right(d) are
C     stable transfer-function matrices.
C
C     The subroutine SB16CD determines the matrices of a reduced
C     controller
C
C          d[z(t)] = Ac*z(t) + Bc*y(t)
C          u(t)    = Cc*z(t),                                   (2)
C
C     with the transfer-function matrix Kr, using the following
C     stability enforcing approach proposed in [1]:
C
C     (1) If JOBCF = 'L', the frequency-weighted approximation problem
C         is solved
C
C         min||[M_left(d)-M_leftr(d)  N_left(d)-N_leftr(d)][-Y(d)]|| ,
C                                                          [ X(d)]
C         where
C                              -1
C               G(d) = Y(d)*X(d)
C
C         is a RCF of the open-loop system transfer-function matrix.
C         The B&T model reduction technique is used in conjunction
C         with the method proposed in [1].
C
C     (2) If JOBCF = 'R', the frequency-weighted approximation problem
C         is solved
C
C         min || [ -U(d) V(d) ] [ N_right(d)-N_rightr(d) ] || ,
C                               [ M_right(d)-M_rightr(d) ]
C         where
C                         -1
C               G(d) = V(d) *U(d)
C
C         is a LCF of the open-loop system transfer-function matrix.
C         The B&T model reduction technique is used in conjunction
C         with the method proposed in [1].
C
C     If ORDSEL = 'A', the order of the controller is determined by
C     computing the number of Hankel singular values greater than
C     the given tolerance TOL. The Hankel singular values are
C     the square roots of the eigenvalues of the product of
C     two frequency-weighted Grammians P and Q, defined as follows.
C
C     If JOBCF = 'L', then P is the controllability Grammian of a system
C     of the form (A+BF,B,*,*), and Q is the observability Grammian of a
C     system of the form (A+GC,*,F,*). This choice corresponds to an
C     input frequency-weighted order reduction of left coprime
C     factors [1].
C
C     If JOBCF = 'R', then P is the controllability Grammian of a system
C     of the form (A+BF,G,*,*), and Q is the observability Grammian of a
C     system of the form (A+GC,*,C,*). This choice corresponds to an
C     output frequency-weighted order reduction of right coprime
C     factors [1].
C
C     For the computation of truncation matrices, the B&T approach
C     is used in conjunction with accuracy enhancing techniques.
C     If JOBMR = 'B', the square-root B&T method of [2,4] is used.
C     If JOBMR = 'F', the balancing-free square-root version of the
C     B&T method [3,4] is used.
C
C     REFERENCES
C
C     [1] Liu, Y., Anderson, B.D.O. and Ly, O.L.
C         Coprime factorization controller reduction with Bezout
C         identity induced frequency weighting.
C         Automatica, vol. 26, pp. 233-249, 1990.
C
C     [2] Tombs, M.S. and Postlethwaite I.
C         Truncated balanced realization of stable, non-minimal
C         state-space systems.
C         Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
C
C     [3] Varga, A.
C         Efficient minimal realization procedure based on balancing.
C         Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991,
C         A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2,
C         pp. 42-46, 1991.
C
C     [4] Varga, A.
C         Coprime factors model reduction method based on square-root
C         balancing-free techniques.
C         System Analysis, Modelling and Simulation, Vol. 11,
C         pp. 303-311, 1993.
C
C     NUMERICAL ASPECTS
C
C     The implemented methods rely on accuracy enhancing square-root or
C     balancing-free square-root techniques.
C                                         3
C     The algorithms require less than 30N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000.
C     D. Sima, University of Bucharest, October 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000.
C
C     REVISIONS
C
C     A. Varga, Australian National University, Canberra, November 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 2001.
C
C     KEYWORDS
C
C     Controller reduction, coprime factorization, frequency weighting,
C     multivariable system, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, JOBCF, JOBD, JOBMR, ORDSEL
      INTEGER           INFO, IWARN, LDA, LDB, LDC, LDD,
     $                  LDF, LDG, LDWORK, M, N, NCR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), F(LDF,*), G(LDG,*), HSV(*)
C     .. Local Scalars ..
      LOGICAL           BAL, DISCR, FIXORD, LEFT, WITHD
      INTEGER           IERR, KT, KTI, KW, LW, MP, NMR, WRKOPT
      DOUBLE PRECISION  SCALEC, SCALEO
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          AB09IX, DGEMM, DLACPY, SB16CY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO   = 0
      IWARN  = 0
      DISCR  = LSAME( DICO,   'D' )
      WITHD  = LSAME( JOBD,   'D' )
      BAL    = LSAME( JOBMR,  'B' )
      LEFT   = LSAME( JOBCF,  'L' )
      FIXORD = LSAME( ORDSEL, 'F' )
      IF( LEFT ) THEN
         MP = M
      ELSE
         MP = P
      END IF
      LW = 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX( M, P ),
     $                  N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( WITHD  .OR. LSAME( JOBD,   'Z' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( BAL    .OR. LSAME( JOBMR,  'F' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT. ( LEFT   .OR. LSAME( JOBCF,  'R' ) ) ) THEN
         INFO = -4
      ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( M.LT.0 ) THEN
         INFO = -7
      ELSE IF( P.LT.0 ) THEN
         INFO = -8
      ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN
         INFO = -9
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN
         INFO = -17
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -19
      ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -21
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -26
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB16CD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 .OR.
     $    ( FIXORD .AND. NCR.EQ.0 ) ) THEN
         NCR = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Allocate working storage.
C
      KT  = 1
      KTI = KT  + N*N
      KW  = KTI + N*N
C
C     Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors Su and Ru
C     of the frequency-weighted controllability and observability
C     Grammians, respectively.
C
C     Workspace:   need 2*N*N + MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)),
C                                                        if JOBCF = 'L';
C                       2*N*N + MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)),
C                                                        if JOBCF = 'R'.
C                  prefer larger.
C
      CALL SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC,
     $             F, LDF, G, LDG, SCALEC, SCALEO, DWORK(KTI), N,
     $             DWORK(KT), N, DWORK(KW), LDWORK-KW+1, INFO )
C
      IF( INFO.NE.0 )
     $   RETURN
      WRKOPT = INT( DWORK(KW) ) + KW - 1
C
C     Compute a B&T approximation (Ar,Br,Cr) of (A,B,C) and
C     the corresponding truncation matrices TI and T.
C
C     Real workspace:  need   2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) );
C                      prefer larger.
C     Integer workspace:  0,  if JOBMR = 'B';
C                         N,  if JOBMR = 'F'.
C
      CALL AB09IX( DICO, JOBMR, 'NotSchur', ORDSEL, N, M, P, NCR,
     $             SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD,
     $             DWORK(KTI), N, DWORK(KT), N, NMR, HSV, TOL, TOL,
     $             IWORK, DWORK(KW), LDWORK-KW+1, IWARN, IERR )
      IF( IERR.NE.0 ) THEN
         INFO = 6
         RETURN
      END IF
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Compute reduced gains Bc = Gr = TI*G and Cc = Fr = F*T.
C     Workspace:  need   N*(2*N+MAX(M,P)).
C
      CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KW), N )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, P, N, ONE,
     $            DWORK(KTI), N, DWORK(KW), N, ZERO, G, LDG )
C
      CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KW), M )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NCR, N, ONE,
     $            DWORK(KW), M, DWORK(KT), N, ZERO, F, LDF )
C
C     Form the reduced controller state matrix,
C     Ac = Ar + Br*Fr + Gr*Cr + Gr*D*Fr = Ar + Br*Fr + Gr*(Cr+D*Fr) .
C
C     Workspace:    need  P*N.
C
      CALL DLACPY( 'Full', P, NCR, C, LDC, DWORK, P )
      IF( WITHD) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NCR, M,
     $                       ONE, D, LDD, F, LDF, ONE, DWORK, P )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, P, ONE, G,
     $            LDG, DWORK, P, ONE, A, LDA )
      CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, M, ONE, B,
     $            LDB, F, LDF, ONE, A, LDA )
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SB16CD ***
      END


module grain_interface
  !! Encapsulate the grain geometry and material properties
  use kind_parameters, only : rkind
  implicit none

  private

  type, public :: grain_t
    !! Encapsulate propellent abstraction as a friend of grain_t
    private
    real(rkind) id_, od_, length_, rho_solid_
  contains
    procedure :: define, surface_area, volume, rho_solid, burned_out
  end type

  interface

    module subroutine define(this, input_file)
      implicit none
      class(grain_t), intent(out) :: this
      character(len=*), intent(in) :: input_file
    end subroutine

    pure module function burned_out(this, burn_depth)
      implicit none
      class(grain_t), intent(in) :: this
      real(rkind), intent(in) :: burn_depth
      logical burned_out
    end function

    pure module function rho_solid(this)
      implicit none
      class(grain_t), intent(in) :: this
      real(rkind) rho_solid
    end function

    pure module function surface_area(this, burn_depth)
      use universal_constants, only : pi
      implicit none
      class(grain_t), intent(in) :: this
      real(rkind), intent(in) :: burn_depth
      real(rkind) surface_area
    end function

    elemental module function volume(this, burn_depth)
      use universal_constants, only : pi
      implicit none
      class(grain_t), intent(in) :: this
      real(rkind), intent(in) :: burn_depth
      real(rkind) volume
    end function

  end interface

end module grain_interface


      SUBROUTINE DAGEMV( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y,
     $                   INCY )
*
*  -- PBLAS auxiliary routine (version 2.0) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     April 1, 1998
*
*     .. Scalar Arguments ..
      CHARACTER*1        TRANS
      INTEGER            INCX, INCY, LDA, M, N
      DOUBLE PRECISION   ALPHA, BETA
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  DAGEMV performs one of the matrix-vector operations
*
*     y := abs( alpha )*abs( A )*abs( x )+ abs( beta*y ),
*
*     or
*
*     y := abs( alpha )*abs( A' )*abs( x ) + abs( beta*y ),
*
*  where  alpha  and  beta  are real scalars, y is a real vector, x is a
*  vector and A is an m by n matrix.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          On entry,  TRANS  specifies the  operation to be performed as
*          follows:
*
*             TRANS = 'N' or 'n':
*                y := abs( alpha )*abs( A )*abs( x )+ abs( beta*y )
*
*             TRANS = 'T' or 't':
*                y := abs( alpha )*abs( A' )*abs( x ) + abs( beta*y )
*
*             TRANS = 'C' or 'c':
*                y := abs( alpha )*abs( A' )*abs( x ) + abs( beta*y )
*
*  M       (input) INTEGER
*          On entry, M  specifies the number of rows of the matrix  A. M
*          must be at least zero.
*
*  N       (input) INTEGER
*          On entry, N  specifies the number of columns of the matrix A.
*          N must be at least zero.
*
*  ALPHA   (input) DOUBLE PRECISION
*          On entry, ALPHA specifies the real scalar alpha.
*
*  A       (input) DOUBLE PRECISION array of dimension ( LDA, n ).
*          On entry, A  is an array of dimension ( LDA, N ). The leading
*          m by n part of the array  A  must contain the matrix of coef-
*          ficients.
*
*  LDA     (input) INTEGER
*          On entry, LDA specifies the leading dimension of the array A.
*          LDA must be at least max( 1, M ).
*
*  X       (input) DOUBLE PRECISION array of dimension at least
*          ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' and  at
*          least ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.  Before entry,
*          the incremented array X must contain the vector x.
*
*  INCX    (input) INTEGER
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero.
*
*  BETA    (input) DOUBLE PRECISION
*          On entry,  BETA  specifies the real scalar beta. When BETA is
*          supplied as zero then Y need not be set on input.
*
*  Y       (input/output) DOUBLE PRECISION array of dimension at least
*          ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' and  at
*          least ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.  Before  entry
*          with BETA non-zero, the incremented array  Y must contain the
*          vector y. On exit, the incremented array  Y is overwritten by
*          the updated vector y.
*
*  INCY    (input) INTEGER
*          On entry, INCY specifies the increment for the elements of Y.
*          INCY must not be zero.
*
*  -- Written on April 1, 1998 by
*     Antoine Petitet, University  of  Tennessee, Knoxville 37996, USA.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
      DOUBLE PRECISION   ABSX, TALPHA, TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( .NOT.LSAME( TRANS, 'N' ) .AND.
     $    .NOT.LSAME( TRANS, 'T' ) .AND.
     $    .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = 1
      ELSE IF( M.LT.0 ) THEN
         INFO = 2
      ELSE IF( N.LT.0 ) THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 ) THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 ) THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DAGEMV', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
     $    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
*     up the start points in  X  and  Y.
*
      IF( LSAME( TRANS, 'N' ) ) THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 ) THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 ) THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
*     First form  y := abs( beta*y ).
*
      IF( INCY.EQ.1 ) THEN
         IF( BETA.EQ.ZERO ) THEN
            DO 10, I = 1, LENY
               Y( I ) = ZERO
   10       CONTINUE
         ELSE IF( BETA.EQ.ONE ) THEN
            DO 20, I = 1, LENY
               Y( I ) = ABS( Y( I ) )
   20       CONTINUE
         ELSE
            DO 30, I = 1, LENY
               Y( I ) = ABS( BETA * Y( I ) )
   30       CONTINUE
         END IF
      ELSE
         IY = KY
         IF( BETA.EQ.ZERO ) THEN
            DO 40, I = 1, LENY
               Y( IY ) = ZERO
               IY      = IY + INCY
   40       CONTINUE
         ELSE IF( BETA.EQ.ONE ) THEN
            DO 50, I = 1, LENY
               Y( IY ) = ABS( Y( IY ) )
               IY      = IY + INCY
   50       CONTINUE
         ELSE
            DO 60, I = 1, LENY
               Y( IY ) = ABS( BETA * Y( IY ) )
               IY      = IY + INCY
   60       CONTINUE
         END IF
      END IF
*
      IF( ALPHA.EQ.ZERO )
     $   RETURN
*
      TALPHA = ABS( ALPHA )
*
      IF( LSAME( TRANS, 'N' ) ) THEN
*
*        Form  y := abs( alpha ) * abs( A ) * abs( x ) + y.
*
         JX = KX
         IF( INCY.EQ.1 ) THEN
            DO 80, J = 1, N
               ABSX = ABS( X( JX ) )
               IF( ABSX.NE.ZERO ) THEN
                  TEMP = TALPHA * ABSX
                  DO 70, I = 1, M
                     Y( I ) = Y( I ) + TEMP * ABS( A( I, J ) )
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         ELSE
            DO 100, J = 1, N
               ABSX = ABS( X( JX ) )
               IF( ABSX.NE.ZERO ) THEN
                  TEMP = TALPHA * ABSX
                  IY   = KY
                  DO 90, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP * ABS( A( I, J ) )
                     IY      = IY      + INCY
   90             CONTINUE
               END IF
               JX = JX + INCX
  100       CONTINUE
         END IF
*
      ELSE
*
*        Form  y := abs( alpha ) * abs( A' ) * abs( x ) + y.
*
         JY = KY
         IF( INCX.EQ.1 ) THEN
            DO 120, J = 1, N
               TEMP = ZERO
               DO 110, I = 1, M
                  TEMP = TEMP + ABS( A( I, J ) * X( I ) )
  110          CONTINUE
               Y( JY ) = Y( JY ) + TALPHA * TEMP
               JY      = JY      + INCY
  120       CONTINUE
         ELSE
            DO 140, J = 1, N
               TEMP = ZERO
               IX   = KX
               DO 130, I = 1, M
                  TEMP = TEMP + ABS( A( I, J ) * X( IX ) )
                  IX   = IX   + INCX
  130          CONTINUE
               Y( JY ) = Y( JY ) + TALPHA * TEMP
               JY      = JY      + INCY
  140       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of DAGEMV
*
      END


PROGRAM F032

    ! CopyrIght 2021 MeLwyn FrancIs CarLo

    IMPLICIT NONE

    CHARACTER (LEN=10) :: TEMP_STR_1, TEMP_STR_2
    CHARACTER (LEN=20) :: TEMP_STR_3

    LOGICAL :: DUPLICATE_FOUND

    INTEGER, DIMENSION(1000) :: PRODUCTS_LIST = 0

    INTEGER :: SUM_VAL   = 0
    INTEGER :: COUNT_VAL = 1

    INTEGER :: I, J, K, L, PRODUCT_VAL, PRODUCT_LENGTH, TOTAL_LENGTH

    DO I = 1, 9999

        WRITE(TEMP_STR_1, '(I0)') I

        IF (INDEX(TEMP_STR_1, '0') /= 0) CYCLE

        DUPLICATE_FOUND = .FALSE.

        DO J = 1, LEN_TRIM(TEMP_STR_1)

            DO K = 1, LEN_TRIM(TEMP_STR_1)

                IF (J == K) CYCLE

                IF (TEMP_STR_1(J:J) == TEMP_STR_1(K:K)) THEN
                    DUPLICATE_FOUND = .TRUE.
                    EXIT
                END IF

            END DO

            IF (DUPLICATE_FOUND) EXIT

        END DO

        IF (DUPLICATE_FOUND) CYCLE

        DO J = 1, 9999

            WRITE(TEMP_STR_2, '(I0)') J

            IF (INDEX(TEMP_STR_2, '0') /= 0) CYCLE

            DUPLICATE_FOUND = .FALSE.

            DO K = 1, LEN_TRIM(TEMP_STR_2)

                DO L = 1, LEN_TRIM(TEMP_STR_2)

                    IF (K == L) CYCLE

                    IF (TEMP_STR_2(K:K) == TEMP_STR_2(L:L)) THEN
                        DUPLICATE_FOUND = .TRUE.
                        EXIT
                    END IF

                END DO

                IF (DUPLICATE_FOUND) EXIT

            END DO

            IF (DUPLICATE_FOUND) CYCLE

            DUPLICATE_FOUND = .FALSE.

            DO K = 1, LEN_TRIM(TEMP_STR_2)

                IF (INDEX(TEMP_STR_1, TEMP_STR_2(K:K)) /= 0) THEN
                    DUPLICATE_FOUND = .TRUE.
                    EXIT
                END IF

            END DO

            IF (DUPLICATE_FOUND) CYCLE

            PRODUCT_VAL = I * J
            PRODUCT_LENGTH = INT(LOG10(FLOAT(PRODUCT_VAL))) + 1

            WRITE(TEMP_STR_3, '(I0)') PRODUCT_VAL

            IF (INDEX(TEMP_STR_3, '0') /= 0) CYCLE

            TOTAL_LENGTH = PRODUCT_LENGTH                                      &
                         + LEN_TRIM(TEMP_STR_1)                                &
                         + LEN_TRIM(TEMP_STR_2)

            IF (TOTAL_LENGTH > 9) EXIT

            IF (TOTAL_LENGTH /= 9) CYCLE

            DUPLICATE_FOUND = .FALSE.

            DO K = 1, LEN_TRIM(TEMP_STR_3)

                DO L = 1, LEN_TRIM(TEMP_STR_3)

                    IF (K == L) CYCLE

                    IF (TEMP_STR_3(K:K) == TEMP_STR_3(L:L)) THEN
                        DUPLICATE_FOUND = .TRUE.
                        EXIT
                    END IF

                END DO

                IF (DUPLICATE_FOUND) EXIT

            END DO

            IF (DUPLICATE_FOUND) CYCLE

            DUPLICATE_FOUND = .FALSE.

            DO K = 1, PRODUCT_LENGTH

                IF (INDEX(TEMP_STR_1, TEMP_STR_3(K:K)) /= 0                    &
               .OR. INDEX(TEMP_STR_2, TEMP_STR_3(K:K)) /= 0) THEN

                    DUPLICATE_FOUND = .TRUE.
                    EXIT

                END IF

            END DO

            IF (DUPLICATE_FOUND) CYCLE

            PRODUCTS_LIST(COUNT_VAL) = PRODUCT_VAL

            COUNT_VAL = COUNT_VAL + 1

        END DO

    END DO

    DO I = 1, COUNT_VAL
        DO J = 1, COUNT_VAL
            IF (I == J) CYCLE
            IF (PRODUCTS_LIST(I) == PRODUCTS_LIST(J)) PRODUCTS_LIST(J) = 0
        END DO
    END DO

    DO I = 1, COUNT_VAL
        SUM_VAL = SUM_VAL + PRODUCTS_LIST(I)
    END DO

    PRINT ('(I0)'), SUM_VAL

END PROGRAM F032


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testMatrixTypesParallel
#include "UnitTest.h"
USE ISO_FORTRAN_ENV
USE ISO_C_BINDING
USE UnitTest
USE IntrType
USE ExceptionHandler
USE trilinos_interfaces
USE ParameterLists
USE ParallelEnv
USE VectorTypes
USE MatrixTypes

#ifdef FUTILITY_HAVE_PETSC
#include <petscversion.h>
#if (((PETSC_VERSION_MAJOR>=3) && (PETSC_VERSION_MINOR>6)) || (PETSC_VERSION_MAJOR>=4))
USE PETSCMAT
#endif
#endif

IMPLICIT NONE

#ifdef FUTILITY_HAVE_PETSC
#include <petscversion.h>
#if (((PETSC_VERSION_MAJOR>=3) && (PETSC_VERSION_MINOR>=6)) || (PETSC_VERSION_MAJOR>=4))
#include <petsc/finclude/petsc.h>
#else
#include <finclude/petsc.h>
#endif
#undef IS
PetscErrorCode  :: ierr
#else
#ifdef HAVE_MPI
#include <mpif.h>
INTEGER :: ierr
#endif
#endif
TYPE(ExceptionHandlerType),TARGET :: e

CREATE_TEST('Test Matrix Types Parallel')

#ifdef HAVE_MPI
CALL MPI_Init(ierr)
#endif
#ifdef FUTILITY_HAVE_PETSC
CALL PetscInitialize(PETSC_NULL_CHARACTER,ierr)
#endif

!Configure exception handler for test
CALL e%setStopOnError(.FALSE.)
CALL e%setQuietMode(.TRUE.)
CALL eParams%addSurrogate(e)
CALL eMatrixType%addSurrogate(e)

REGISTER_SUBTEST("PETSc Matrix",testPetscMatrix)
REGISTER_SUBTEST("Distributed Banded Matrix",testDistrBandMatrix)
REGISTER_SUBTEST("Distributed Block-Banded Matrix",testDistrBlockBandMatrix)

#ifdef FUTILITY_HAVE_PETSC
CALL PetscFinalize(ierr)
#endif
#ifdef HAVE_MPI
CALL MPI_Finalize(ierr)
#endif
FINALIZE_TEST()

CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE testDistrBandMatrix()
#ifdef HAVE_MPI
  IMPLICIT NONE

  TYPE(ParamType) :: pList,optListMat,distVecPList
  INTEGER(SIK) :: rank,nproc,mpierr,i,j
  CLASS(DistributedMatrixType),ALLOCATABLE :: thisMatrix
  TYPE(NativeDistributedVectorType),ALLOCATABLE :: distrVec1, distrVec2
  REAL(SRK),ALLOCATABLE :: dummyvec(:),dummyvec2(:)
  LOGICAL(SBK) :: bool

  CALL MPI_Comm_rank(PE_COMM_WORLD,rank,mpierr)
  CALL MPI_Comm_size(PE_COMM_WORLD,nproc,mpierr)

  ASSERT(nproc==2, 'nproc valid')
!Test for distributed banded matrices
  ALLOCATE(DistributedBandedMatrixType :: thisMatrix)

  COMPONENT_TEST("distBand%clear")
  SELECTTYPE(thisMatrix)
    TYPE IS(DistributedBandedMatrixType)
    !test clear
    !make matrix w/out using untested init
    thisMatrix%isInit=.TRUE.
    thisMatrix%n=10
    thisMatrix%m=15
    thisMatrix%nnz=4
    thisMatrix%isCreated=.TRUE.
    thisMatrix%isAssembled=.FALSE.
    thisMatrix%comm=33
    ALLOCATE(thisMatrix%chunks(2))
    ALLOCATE(thisMatrix%iOffsets(3))
    ALLOCATE(thisMatrix%jOffsets(3))
  ENDSELECT
  CALL thisMatrix%clear()
  SELECT TYPE(thisMatrix)
  TYPE IS(DistributedBandedMatrixType)
    bool = (thisMatrix%isInit == .FALSE. &
        .AND.(thisMatrix%n == 0) &
        .AND.(thisMatrix%m == 0) &
        .AND.(thisMatrix%nLocal == 0) &
        .AND.(thisMatrix%isCreated == .FALSE.) &
        .AND.(thisMatrix%isAssembled == .FALSE.) &
        .AND.(thisMatrix%comm == MPI_COMM_NULL) &
        .AND.(thisMatrix%m == 0) &
        .AND.(.NOT.ALLOCATED(thisMatrix%chunks)) &
        .AND.(.NOT.ALLOCATED(thisMatrix%jOffsets)) &
        .AND.(.NOT.ALLOCATED(thisMatrix%iOffsets)))
    ASSERT(bool, 'DistributedBandedMatrixType%clear()')
  END SELECT

  !check init
  COMPONENT_TEST("distrBand%init")
  CALL pList%clear()
  CALL pList%add('MatrixType->n',10_SNK)
  CALL pList%add('MatrixType->m',15_SNK)
  CALL pList%add('MatrixType->nnz',9_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)

  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList)
  SELECT TYPE(thisMatrix)
  TYPE IS(DistributedBandedMatrixType)
    bool = (( thisMatrix%isInit).AND.(thisMatrix%n == 10)) &
        .AND.((thisMatrix%m == 15).AND.(thisMatrix%nnz == 9))
    ASSERT(bool, 'banded%init(...)')
    IF(rank == 0) THEN
      bool = (ALLOCATED(thisMatrix%iTmp) .AND. &
              ALLOCATED(thisMatrix%jTmp) .AND. &
              ALLOCATED(thisMatrix%elemTmp) .AND. &
              ALL(thisMatrix%jOffsets .EQ. (/0_SIK,8_SIK,15_SIK/)) .AND. &
              ALL(thisMatrix%iOffsets .EQ. (/0_SIK,5_SIK,10_SIK/)) .AND. &
              thisMatrix%nLocal == 0 .AND. &
              .NOT.ALLOCATED(thisMatrix%chunks))
      ASSERT(bool, 'banded%init')
    ELSE
      bool = (ALLOCATED(thisMatrix%iTmp) .AND. &
              ALLOCATED(thisMatrix%jTmp) .AND. &
              ALLOCATED(thisMatrix%elemTmp) .AND. &
              thisMatrix%nLocal == 0 .AND. &
              ALL(thisMatrix%jOffsets .EQ. (/0_SIK,8_SIK,15_SIK/)) .AND. &
              ALL(thisMatrix%iOffsets .EQ. (/0_SIK,5_SIK,10_SIK/)) .AND. &
              .NOT.ALLOCATED(thisMatrix%chunks))
      ASSERT(bool, 'banded%init')
    ENDIF
  ENDSELECT
  CALL thisMatrix%clear()

  !test with double init (isInit==true on 2nd try)
  CALL thisMatrix%init(pList)
  SELECTTYPE(thisMatrix)
    TYPE IS(DistributedBandedMatrixType); thisMatrix%m=1
  ENDSELECT
  CALL thisMatrix%init(pList)
  SELECTTYPE(thisMatrix)
    TYPE IS(DistributedBandedMatrixType)
      bool = thisMatrix%m == 1
      ASSERT(bool, 'banded%init(...)')
  ENDSELECT
  CALL thisMatrix%clear()
  !test with n<1
  CALL pList%clear()
  CALL pList%add('MatrixType->n',-1_SNK)
  CALL pList%add('MatrixType->m',10_SNK)
  CALL pList%add('MatrixType->nnz',9_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList) !expect exception
  bool = .NOT.thisMatrix%isInit
  ASSERT(bool, 'banded%init(...)')
  CALL thisMatrix%clear()
  !test with m<1
  CALL pList%clear()
  CALL pList%add('MatrixType->n',10_SNK)
  CALL pList%add('MatrixType->m',-1_SNK)
  CALL pList%add('MatrixType->nnz',3_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList) !expect exception
  bool = .NOT.thisMatrix%isInit
  ASSERT(bool, 'banded%init(...)')
  CALL thisMatrix%clear()
  !test with nnz<1
  CALL pList%clear()
  CALL pList%add('MatrixType->n',10_SNK)
  CALL pList%add('MatrixType->m',15_SNK)
  CALL pList%add('MatrixType->nnz',-1_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList) !expect exception
  bool = .NOT.thisMatrix%isInit
  ASSERT(bool, 'banded%init(...)')
  CALL thisMatrix%clear()

  !check set
  COMPONENT_TEST("distBand%set")
  !test normal use case (split diagonal)
  !want to build:
  ![3 0 7 0 0]
  ![0 4 0 8 0]
  ![1 0 5 0 9]
  ![0 2 0 6 0]
  CALL pList%clear()
  CALL pList%add('MatrixType->n',4_SNK)
  CALL pList%add('MatrixType->m',5_SNK)
  CALL pList%add('MatrixType->nnz',9_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList)
  CALL thisMatrix%set(3,1,1._SRK)
  CALL thisMatrix%set(4,2,2._SRK)
  CALL thisMatrix%set(1,1,3._SRK)
  CALL thisMatrix%set(2,2,4._SRK)
  CALL thisMatrix%set(3,3,5._SRK)
  CALL thisMatrix%set(4,4,6._SRK)
  CALL thisMatrix%set(1,3,7._SRK)
  CALL thisMatrix%set(2,4,8._SRK)
  CALL thisMatrix%set(3,5,9._SRK)
  CALL thisMatrix%assemble()
  SELECTTYPE(thisMatrix)
  TYPE IS(DistributedBandedMatrixType)
    IF(rank == 0) THEN
      bool = SIZE(thisMatrix%chunks) == 2
      bool = SIZE(thisMatrix%chunks(1)%bandIdx) == 2
      bool = bool .AND. SIZE(thisMatrix%chunks(1)%bands(1)%elem) == 2
      bool = bool .AND. thisMatrix%chunks(1)%bands(1)%elem(1) == 3
      bool = bool .AND. thisMatrix%chunks(1)%bands(1)%elem(2) == 4
      bool = bool .AND. SIZE(thisMatrix%chunks(1)%bands(2)%elem) == 1
      bool = bool .AND. thisMatrix%chunks(1)%bands(2)%elem(1) == 7
      bool = SIZE(thisMatrix%chunks(2)%bandIdx) == 2
      bool = bool .AND. SIZE(thisMatrix%chunks(2)%bands(1)%elem) == 2
      bool = bool .AND. thisMatrix%chunks(2)%bands(1)%elem(1) == 1
      bool = bool .AND. thisMatrix%chunks(2)%bands(1)%elem(2) == 2
      bool = bool .AND. SIZE(thisMatrix%chunks(2)%bands(2)%elem) == 1
      bool = bool .AND. thisMatrix%chunks(2)%bands(2)%elem(1) == 5
      ASSERT(bool, 'banded%set(...)')
    ELSE
      bool = SIZE(thisMatrix%chunks) == 2
      bool = SIZE(thisMatrix%chunks(1)%bandIdx) == 1
      bool = bool .AND. SIZE(thisMatrix%chunks(1)%bands(1)%elem) == 1
      bool = bool .AND. thisMatrix%chunks(1)%bands(1)%elem(1) == 8
      bool = SIZE(thisMatrix%chunks(2)%bandIdx) == 2
      bool = bool .AND. SIZE(thisMatrix%chunks(2)%bands(1)%elem) == 1
      bool = bool .AND. thisMatrix%chunks(2)%bands(1)%elem(1) == 6
      bool = bool .AND. SIZE(thisMatrix%chunks(2)%bands(2)%elem) == 1
      bool = bool .AND. thisMatrix%chunks(2)%bands(2)%elem(1) == 9
      ASSERT(bool, 'banded%set(...)')
    ENDIF
  ENDSELECT
  CALL thisMatrix%clear()

  !check get functionality
  COMPONENT_TEST("distBand%get")
  ![3 0 7 0 0]
  ![0 4 0 8 0]
  ![1 0 5 0 9]
  ![0 2 0 6 0]
  CALL thisMatrix%clear()
  CALL pList%clear()
  CALL pList%add('MatrixType->n',4_SNK)
  CALL pList%add('MatrixType->m',5_SNK)
  CALL pList%add('MatrixType->nnz',9_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList)
  CALL thisMatrix%set(3,1,1._SRK)
  CALL thisMatrix%set(4,2,2._SRK)
  CALL thisMatrix%set(1,1,3._SRK)
  CALL thisMatrix%set(2,2,4._SRK)
  CALL thisMatrix%set(3,3,5._SRK)
  CALL thisMatrix%set(4,4,6._SRK)
  CALL thisMatrix%set(1,3,7._SRK)
  CALL thisMatrix%set(2,4,8._SRK)
  CALL thisMatrix%set(3,5,9._SRK)
  CALL thisMatrix%assemble()
  IF(ALLOCATED(dummyvec)) DEALLOCATE(dummyvec)
  ALLOCATE(dummyvec(8))
  IF(ALLOCATED(dummyvec2)) DEALLOCATE(dummyvec2)
  ALLOCATE(dummyvec2(8))
  dummyvec=0.0_SRK
  IF (rank==0) THEN
    CALL thisMatrix%get(1,1,dummyvec(1))
    CALL thisMatrix%get(1,2,dummyvec(2))
    CALL thisMatrix%get(1,3,dummyvec(3))
    CALL thisMatrix%get(2,2,dummyvec(4))
    CALL thisMatrix%get(3,1,dummyvec(5))
    CALL thisMatrix%get(3,2,dummyvec(6))
    CALL thisMatrix%get(3,3,dummyvec(7))
    CALL thisMatrix%get(4,2,dummyvec(8))
    dummyvec2 = (/3.0,0.0,7.0,4.0,1.0,0.0,5.0,2.0/)
    ASSERT(ALL(dummyvec(1:8) .EQ. dummyvec2(1:8)), 'banded%get(...)')
  ELSE
    CALL thisMatrix%get(2,4,dummyvec(1))
    CALL thisMatrix%get(2,5,dummyvec(2))
    CALL thisMatrix%get(3,5,dummyvec(3))
    CALL thisMatrix%get(4,4,dummyvec(4))
    CALL thisMatrix%get(4,5,dummyvec(5))
    dummyvec2(1:5) = (/8.0,0.0,9.0,6.0,0.0/)
    ASSERT(ALL(dummyvec(1:5) .EQ. dummyvec2(1:5)), 'banded%get(...)')
  ENDIF
  DEALLOCATE(dummyvec2)

  IF(ALLOCATED(dummyvec)) DEALLOCATE(dummyvec)
  CALL thisMatrix%clear()

  !check zero_entries functionality
  COMPONENT_TEST("distBand%zero")
  CALL thisMatrix%clear()
  CALL pList%clear()
  CALL pList%add('MatrixType->n',4_SNK)
  CALL pList%add('MatrixType->m',5_SNK)
  CALL pList%add('MatrixType->nnz',7_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList)
  CALL thisMatrix%set(1,1,1._SRK)
  CALL thisMatrix%set(1,2,2._SRK)
  CALL thisMatrix%set(2,2,3._SRK)
  CALL thisMatrix%set(2,3,4._SRK)
  CALL thisMatrix%set(3,3,5._SRK)
  CALL thisMatrix%set(3,4,6._SRK)
  CALL thisMatrix%set(4,4,7._SRK)
  CALL thisMatrix%assemble()
  CALL thisMatrix%zeroentries()
  SELECTTYPE(thisMatrix)
  TYPE IS(DistributedBandedMatrixType)
    ! The rank1 chunk1 will not be initialized, so skip
    IF(rank==0) THEN
      DO i=1,SIZE(thisMatrix%chunks(1)%bands)
        DO j=1,SIZE(thisMatrix%chunks(1)%bands(i)%elem)
          bool=(thisMatrix%chunks(1)%bands(i)%elem(j) .APPROXEQ. 0.0_SRK)
          ASSERT(bool,"banded%zero()")
        ENDDO
      ENDDO
    ENDIF
    DO i=1,SIZE(thisMatrix%chunks(2)%bands)
      DO j=1,SIZE(thisMatrix%chunks(2)%bands(i)%elem)
        bool=(thisMatrix%chunks(2)%bands(i)%elem(j) .APPROXEQ. 0.0_SRK)
        ASSERT(bool,"banded%zero()")
      ENDDO
    ENDDO
  ENDSELECT
  CALL thisMatrix%clear()

  !check matvec functionality
  COMPONENT_TEST("distBand%matvec")
  ![1 2 0 0]
  ![0 3 0 0]
  ![0 0 5 6]
  ![0 9 0 7]

  CALL thisMatrix%clear()
  CALL pList%clear()
  CALL pList%add('MatrixType->n',4_SNK)
  CALL pList%add('MatrixType->m',4_SNK)
  CALL pList%add('MatrixType->nnz',7_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList)
  CALL thisMatrix%set(1,1,1._SRK)
  CALL thisMatrix%set(1,2,2._SRK)
  CALL thisMatrix%set(2,2,3._SRK)
  CALL thisMatrix%set(3,3,5._SRK)
  CALL thisMatrix%set(3,4,6._SRK)
  CALL thisMatrix%set(4,4,7._SRK)
  CALL thisMatrix%set(4,2,9._SRK)
  CALL thisMatrix%assemble()
  IF(ALLOCATED(distrVec1)) DEALLOCATE(distrVec1)
  IF(ALLOCATED(distrVec2)) DEALLOCATE(distrVec2)
  ALLOCATE(NativeDistributedVectorType :: distrVec1)
  ALLOCATE(NativeDistributedVectorType :: distrVec2)

  CALL distVecPList%clear()
  CALL distVecPList%add('VectorType->n',4)
  CALL distVecPList%add('VectorType->MPI_Comm_ID',PE_COMM_WORLD)
  CALL distrVec1%init(distVecPList)
  CALL distrVec2%init(distVecPList)
  CALL distVecPList%clear()

  ! Check zero vector
  distrVec1%b = 0.0_SRK
  distrVec2%b = 0.0_SRK

  CALL BLAS_matvec(THISMATRIX=thisMatrix,X=distrVec1,Y=distrVec2,ALPHA=1.0_SRK,BETA=0.0_SRK)
  DO i=1,2
    bool = ALL(ABS(distrVec2%b) < 1E-6)
    ASSERT(bool, 'banded%matvec(...)')
  ENDDO
  ! Check for non-trivial vector
  IF (rank == 0) THEN
    distrVec1%b = (/1._SRK,2._SRK/)
  ELSE
    distrVec1%b = (/3._SRK,4._SRK/)
  ENDIF
  CALL BLAS_matvec(THISMATRIX=thisMatrix,X=distrVec1,Y=distrVec2,alpha=1.0_SRK,beta=0.0_SRK)
  IF (rank == 0) THEN
    bool = distrVec2%b(1) == 5._SRK
    ASSERT(bool, 'banded%matvec(...)')
    bool = distrVec2%b(2) == 6._SRK
    ASSERT(bool, 'banded%matvec(...)')
  ELSE
    bool = distrVec2%b(3) == 39._SRK
    ASSERT(bool, 'banded%matvec(...)')
    bool = distrVec2%b(4) == 46._SRK
    ASSERT(bool, 'banded%matvec(...)')
  ENDIF
  DEALLOCATE(thisMatrix)

  CALL pList%clear()
#endif
ENDSUBROUTINE testDistrBandMatrix

SUBROUTINE testPetscMatrix()
#ifdef FUTILITY_HAVE_PETSC
  TYPE(ParamType) :: pList
  INTEGER(SIK) :: rank,nproc,mpierr
  CLASS(DistributedMatrixType),ALLOCATABLE :: thisMatrix
  REAL(SRK) :: val

  CALL MPI_Comm_rank(PE_COMM_WORLD,rank,mpierr)
  CALL MPI_Comm_size(PE_COMM_WORLD,nproc,mpierr)

  ASSERT(nproc==2, 'nproc valid')
  ALLOCATE(PETScMatrixType::thisMatrix)

  COMPONENT_TEST("petsc%init")
  ! Create matrix that looks like this
  ! 1 0 2 0
  ! 0 3 0 4
  ! 0 0 5 0
  ! 6 7 0 0
  ! Rank 0 owns rows 1 and 2
  ! Rank 1 owns rows 3 and 4

  CALL pList%clear()
  CALL pList%add('MatrixType->n',4_SNK)
  CALL pList%add('MatrixType->nLocal',2_SNK)
  CALL pList%add('MatrixType->nnz',2_SNK)
  CALL pList%add('MatrixType->onz',2_SNK)
  CALL pList%add('MatrixType->matType',SPARSE)
  CALL pList%add('MatrixType->isSym',.FALSE.)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL thisMatrix%init(pList)
  CALL pList%clear()
  !Perform test of init function
  ASSERT(thisMatrix%isInit, "init")
  ASSERT(thisMatrix%n==4, "global size")

  ! Test setting/getting single elements at a time
  COMPONENT_TEST("petsc%set")
  CALL thisMatrix%set(1,1,1._SRK)
  CALL thisMatrix%set(1,3,2._SRK)
  CALL thisMatrix%set(2,2,3._SRK)
  CALL thisMatrix%set(2,4,4._SRK)
  CALL thisMatrix%set(3,3,5._SRK)
  CALL thisMatrix%set(4,1,6._SRK)
  CALL thisMatrix%set(4,2,7._SRK)

  IF(rank==0) THEN
    CALL thisMatrix%get(1,1,val)
    ASSERT(val .APPROXEQ. 1._SRK, "getOne")
    CALL thisMatrix%get(1,3,val)
    ASSERT(val .APPROXEQ. 2._SRK, "getOne")
    CALL thisMatrix%get(2,2,val)
    ASSERT(val .APPROXEQ. 3._SRK, "getOne")
    CALL thisMatrix%get(2,4,val)
    ASSERT(val .APPROXEQ. 4._SRK, "getOne")
  ELSE
    CALL thisMatrix%get(3,3,val)
    ASSERT(val .APPROXEQ. 5._SRK, "getOne")
    CALL thisMatrix%get(4,1,val)
    ASSERT(val .APPROXEQ. 6._SRK, "getOne")
    CALL thisMatrix%get(4,2,val)
    ASSERT(val .APPROXEQ. 7._SRK, "getOne")
  ENDIF

  ! Test setting row all at once
  COMPONENT_TEST("petsc%setRow")
  CALL thisMatrix%setRow(1,[1, 3],[10._SRK, 11._SRK])
  CALL thisMatrix%setRow(2,[2, 4],[12._SRK, 13._SRK])
  CALL thisMatrix%setRow(3,[3],[14._SRK])
  CALL thisMatrix%setRow(4,[1, 2],[15._SRK, 16._SRK])

  IF(rank==0) THEN
    CALL thisMatrix%get(1,1,val)
    ASSERT(val .APPROXEQ. 10._SRK, "getOne")
    CALL thisMatrix%get(1,3,val)
    ASSERT(val .APPROXEQ. 11._SRK, "getOne")
    CALL thisMatrix%get(2,2,val)
    ASSERT(val .APPROXEQ. 12._SRK, "getOne")
    CALL thisMatrix%get(2,4,val)
    ASSERT(val .APPROXEQ. 13._SRK, "getOne")
  ELSE
    CALL thisMatrix%get(3,3,val)
    ASSERT(val .APPROXEQ. 14._SRK, "getOne")
    CALL thisMatrix%get(4,1,val)
    ASSERT(val .APPROXEQ. 15._SRK, "getOne")
    CALL thisMatrix%get(4,2,val)
    ASSERT(val .APPROXEQ. 16._SRK, "getOne")
  ENDIF
  CALL thisMatrix%clear()
#endif
ENDSUBROUTINE testPetscMatrix

SUBROUTINE testDistrBlockBandMatrix()
#ifdef HAVE_MPI
  IMPLICIT NONE
  TYPE(ParamType) :: pList,optListMat,distVecPList
  INTEGER(SIK) :: rank,nproc,mpierr
  TYPE(DistributedBlockBandedMatrixType),ALLOCATABLE :: thisMatrix
  TYPE(NativeDistributedVectorType),ALLOCATABLE :: distrvec1,distrvec2
  LOGICAL(SBK) :: bool

  CALL MPI_Comm_rank(PE_COMM_WORLD,rank,mpierr)
  CALL MPI_Comm_size(PE_COMM_WORLD,nproc,mpierr)

  ASSERT(nproc==2, 'nproc valid')
!Test for distributed block banded matrices
  ALLOCATE(DistributedBlockBandedMatrixType :: thisMatrix)

  !check init
  COMPONENT_TEST("distBlockBand%init")
  CALL pList%clear()
  CALL pList%add('MatrixType->n',12_SNK)
  CALL pList%add('MatrixType->nnz',9_SNK)
  CALl pList%add('MatrixType->blockSize',3_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)

  CALL pList%validate(pList)
  CALL thisMatrix%init(pList)
  bool = (( thisMatrix%isInit).AND.(thisMatrix%n == 12))
  ASSERT(bool, 'banded%init(...)')
  IF(rank == 0) THEN
    bool = (ALLOCATED(thisMatrix%blocks) .AND. &
            SIZE(thisMatrix%blocks)==2   .AND. &
            thisMatrix%blockOffset==0    .AND. &
            thisMatrix%nLocalBlocks==2   .AND. &
            thisMatrix%blockMask==.FALSE.)
    ASSERT(bool, 'banded%init')
  ELSE
    bool = (ALLOCATED(thisMatrix%blocks) .AND. &
            SIZE(thisMatrix%blocks)==2   .AND. &
            thisMatrix%blockOffset==2    .AND. &
            thisMatrix%nLocalBlocks==2   .AND. &
            thisMatrix%blockMask==.FALSE.)
    ASSERT(bool, 'banded%init')
  ENDIF

  CALL thisMatrix%clear()

  !check matvec functionality
  COMPONENT_TEST("distBlockBand%matvec")
  ![1 2 0 0 0 0]
  ![0 3 0 0 0 0]
  ![0 0 5 6 0 0]
  ![0 9 0 7 0 0]
  ![0 0 0 0 1 0]
  ![0 0 0 0 0 1]

  CALL pList%clear()
  CALL pList%add('MatrixType->n',6_SNK)
  CALL plist%add('MatrixType->blockSize',2_SNK)
  CALL pList%add('MatrixType->nnz',10_SNK)
  CALL pList%add('MatrixType->MPI_COMM_ID',PE_COMM_WORLD)
  CALL pList%validate(pList,optListMat)
  CALL thisMatrix%init(pList)

  CALL thisMatrix%set(1,1,1._SRK)
  CALL thisMatrix%set(1,2,2._SRK)
  CALL thisMatrix%set(2,2,3._SRK)
  CALL thisMatrix%set(3,3,5._SRK)
  CALL thisMatrix%set(3,4,6._SRK)
  CALL thisMatrix%set(4,4,7._SRK)
  CALL thisMatrix%set(4,2,9._SRK)
  CALL thisMatrix%set(5,5,1._SRK)
  CALL thisMatrix%set(6,6,1._SRK)
  CALL thisMatrix%assemble()
  IF(ALLOCATED(distrVec1)) DEALLOCATE(distrVec1)
  IF(ALLOCATED(distrVec2)) DEALLOCATE(distrVec2)
  ALLOCATE(NativeDistributedVectorType :: distrVec1)
  ALLOCATE(NativeDistributedVectorType :: distrVec2)

  CALL distVecPList%clear()
  CALL distVecPList%add('VectorType->n',6)
  CALL distVecPList%add('VectorType->chunkSize',2)
  CALL distVecPList%add('VectorType->MPI_Comm_ID',PE_COMM_WORLD)
  CALL distrVec1%init(distVecPList)
  CALL distrVec2%init(distVecPList)
  CALL distVecPList%clear()

  ! Check zero vector
  distrVec1%b = 0.0_SRK
  distrVec2%b = 0.0_SRK

  CALL BLAS_matvec(THISMATRIX=thisMatrix,X=distrVec1,Y=distrVec2,ALPHA=1.0_SRK,beta=0.0_SRK)
  bool = ALL(ABS(distrVec2%b) < 1E-6)
  ASSERT(bool, 'banded%matvec(...)')

  ! Check for non-trivial vector
  IF (rank == 0) THEN
    distrVec1%b = (/1._SRK,2._SRK,3._SRK,4._SRK/)
  ELSE
    distrVec1%b = (/1.0_SRK,1.0_SRK/)
  ENDIF

  CALL BLAS_matvec(THISMATRIX=thisMatrix,X=distrVec1,Y=distrVec2,alpha=1.0_SRK,beta=0.0_SRK)
  IF (rank == 0) THEN
    bool = distrVec2%b(1) == 5._SRK
    ASSERT(bool, 'banded%matvec(...)')
    bool = distrVec2%b(2) == 6._SRK
    ASSERT(bool, 'banded%matvec(...)')
    bool = distrVec2%b(3) == 39._SRK
    ASSERT(bool, 'banded%matvec(...)')
    bool = distrVec2%b(4) == 46._SRK
    ASSERT(bool, 'banded%matvec(...)')
  ELSE
    ASSERT(ALL(ABS(distrVec2%b-1) < 1E-6),'banded%matvec(...)')
  ENDIF

  DEALLOCATE(thisMatrix)
  CALL pList%clear()
#endif
ENDSUBROUTINE testDistrBlockBandMatrix
ENDPROGRAM testMatrixTypesParallel


*DECK ELMHES
      SUBROUTINE ELMHES (NM, N, LOW, IGH, A, INT)
C***BEGIN PROLOGUE  ELMHES
C***PURPOSE  Reduce a real general matrix to upper Hessenberg form
C            using stabilized elementary similarity transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B2
C***TYPE      SINGLE PRECISION (ELMHES-S, COMHES-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure ELMHES,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     Given a REAL GENERAL matrix, this subroutine
C     reduces a submatrix situated in rows and columns
C     LOW through IGH to upper Hessenberg form by
C     stabilized elementary similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix, A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        A contains the input matrix.  A is a two-dimensional REAL
C          array, dimensioned A(NM,N).
C
C     On OUTPUT
C
C        A contains the upper Hessenberg matrix.  The multipliers which
C          were used in the reduction are stored in the remaining
C          triangle under the Hessenberg matrix.
C
C        INT contains information on the rows and columns interchanged
C          in the reduction.  Only elements LOW through IGH are used.
C          INT is a one-dimensional INTEGER array, dimensioned INT(IGH).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ELMHES
C
      INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1
      REAL A(NM,*)
      REAL X,Y
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  ELMHES
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         MM1 = M - 1
         X = 0.0E0
         I = M
C
         DO 100 J = M, IGH
            IF (ABS(A(J,MM1)) .LE. ABS(X)) GO TO 100
            X = A(J,MM1)
            I = J
  100    CONTINUE
C
         INT(M) = I
         IF (I .EQ. M) GO TO 130
C    .......... INTERCHANGE ROWS AND COLUMNS OF A ..........
         DO 110 J = MM1, N
            Y = A(I,J)
            A(I,J) = A(M,J)
            A(M,J) = Y
  110    CONTINUE
C
         DO 120 J = 1, IGH
            Y = A(J,I)
            A(J,I) = A(J,M)
            A(J,M) = Y
  120    CONTINUE
C    .......... END INTERCHANGE ..........
  130    IF (X .EQ. 0.0E0) GO TO 180
         MP1 = M + 1
C
         DO 160 I = MP1, IGH
            Y = A(I,MM1)
            IF (Y .EQ. 0.0E0) GO TO 160
            Y = Y / X
            A(I,MM1) = Y
C
            DO 140 J = M, N
  140       A(I,J) = A(I,J) - Y * A(M,J)
C
            DO 150 J = 1, IGH
  150       A(J,M) = A(J,M) + Y * A(J,I)
C
  160    CONTINUE
C
  180 CONTINUE
C
  200 RETURN
      END


!Program to test NEAREST intrinsic function.

program test_nearest
  real s, r, x, y, inf, max
  integer i, infi, maxi
  equivalence (s,i)
  equivalence (inf,infi)
  equivalence (max,maxi)

  r = 2.0
  s = 3.0
  call test_n (s, r)

  i = z'00800000'
  call test_n (s, r)

  i = z'007fffff'
  call test_n (s, r)

  i = z'00800100'
  call test_n (s, r)

  s = 0
  x = nearest(s, r)
  y = nearest(s, -r)
  if (.not. (x .gt. s .and. y .lt. s )) call abort()

! ??? This is pretty sketchy, but passes on most targets.
  infi = z'7f800000'
  maxi = z'7f7fffff'

  call test_up(max, inf)
  call test_up(-inf, -max)
  call test_down(inf, max)
  call test_down(-max, -inf)

! ??? Here we require the F2003 IEEE_ARITHMETIC module to
! determine if denormals are supported.  If they are, then
! nearest(0,1) is the minimum denormal.  If they are not,
! then it's the minimum normalized number, TINY.  This fails
! much more often than the infinity test above, so it's
! disabled for now.

! call test_up(0, min)
! call test_up(-min, 0)
! call test_down(0, -min)
! call test_down(min, 0)
end

subroutine test_up(s, e)
  real s, e, x

  x = nearest(s, 1.0)
  if (x .ne. e) call abort()
end

subroutine test_down(s, e)
  real s, e, x

  x = nearest(s, -1.0)
  if (x .ne. e) call abort()
end

subroutine test_n(s1, r)
  real r, s1, x

  x = nearest(s1, r)
  if (nearest(x, -r) .ne. s1) call abort()
  x = nearest(s1, -r)
  if (nearest(x, r) .ne. s1) call abort()

  s1 = -s1
  x = nearest(s1, r)
  if (nearest(x, -r) .ne. s1) call abort()
  x = nearest(s1, -r)
  if (nearest(x, r) .ne. s1) call abort()
end


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

module piecewise_linear_function

! this module may be used to deal with piecewise linear functions.
! this may be useful to make boxcars, ramps, triangles, trapezoids ...
! the function is assumed to jump to zero at the endpoints.

    use constants

    implicit none

    type, public :: t_plf

      ! these coordinates define the function
        real, allocatable, dimension(:,:)  :: f

      ! number of points
        integer               :: n = 0

    end type

    public plf_make, plf_integrate, plf_destroy, plf_span
    private trapezoid_area
    public ip_cos, ip_linear, ip_zero_one

    interface plf_make
        module procedure plf_make_from_args
        module procedure plf_make_from_arrays
    end interface

    interface plf_taper_array
        module procedure plf_taper_array_r
        module procedure plf_taper_array_c
    end interface

  contains

    pure subroutine plf_make_from_args( s, x1,y1, x2,y2, x3,y3, x4,y4 )
      ! make 2-4 point plf

        real,intent(in) :: x1,y1, x2,y2
        real,intent(in),optional :: x3,y3, x4,y4
        type(t_plf),intent(inout) :: s

        call plf_destroy( s )
        allocate( s%f(2,4) )

        s%f(1,1)=x1; s%f(1,2)=x2;
        s%f(2,1)=y1; s%f(2,2)=y2;
        s%n = 2

        if (present(x3) .and. present(y3)) then
            s%f(1,3)=x3;
            s%f(2,3)=y3;
            s%n = 3
        end if

        if (present(x4) .and. present(y4)) then
            s%f(1,4)=x4
            s%f(2,4)=y4
            s%n = 4
        end if

    end subroutine

    pure subroutine plf_make_from_arrays( s, x, y )

        type(t_plf),intent(inout) :: s
        real, dimension(:), intent(in) :: x, y
        integer :: n

        call plf_destroy( s )

        n = min(size(x),size(y))
        allocate( s%f(2,n) )
        s%f(1,:) = x(1:n)
        s%f(2,:) = y(1:n)
        s%n = n

    end subroutine

    pure subroutine plf_destroy( s )
         type(t_plf),intent(inout) :: s

        if (allocated(s%f)) deallocate( s%f )

    end subroutine

    pure function plf_defined( s )
        type(t_plf),intent(in) :: s
        logical :: plf_defined
        plf_defined = allocated(s%f)

    end function

    pure subroutine plf_copy( s, d )
        type(t_plf),intent(in) :: s
        type(t_plf),intent(inout) :: d

        call plf_destroy( d )
        allocate( d%f(2,s%n) )
        d%f(:,:s%n) = s%f(:,:s%n)
        d%n = s%n

    end subroutine

    pure function plf_span( s )
        type(t_plf), intent(in) :: s
        real, dimension(2) :: plf_span

        if (allocated(s%f)) then
            plf_span(1) = s%f(1,1)
            plf_span(2) = s%f(1,s%n)
        else
            plf_span = (/0.,-1./)
        end if

    end function

    pure function plf_integrate( s, a, b ) result(area)

      ! get area between x=a and x=b

        type(t_plf), intent(in) :: s
        real, intent(in)        :: a,b
        real                    :: area
        real                    :: x0,x1,y0,y1
        integer                 :: i

        area = 0.
        if (.not. allocated( s%f )) return
        if (b .le. s%f(1,1)) return
        if (a .ge. s%f(1,s%n)) return
        do i=1,s%n-1
            if (a .ge. s%f(1,i+1)) cycle
            if (b .le. s%f(1,i)) return
            x0 = max( a, s%f(1,i) )
            x1 = min( b, s%f(1,i+1) )
            y0 = s%f(2,i)
            if (x0 .ne. s%f(1,i)) y0 = ip_linear( s%f(1,i), s%f(2,i), s%f(1,i+1), s%f(2,i+1), a)
            y1 = s%f(2,i+1)
            if (x1 .ne. s%f(1,i+1)) y1 = ip_linear( s%f(1,i), s%f(2,i), s%f(1,i+1), s%f(2,i+1), b)
            area = area+trapezoid_area( x0,y0, x1,y1 )
        end do

    end function

    pure subroutine plf_integrate_and_centroid( s, a, b, area, centroid )

      ! get area between x=a and x=b

        type(t_plf), intent(in) :: s
        real, intent(in)        :: a,b
        real,intent(out)        :: area, centroid
        real                    :: x0,x1,y0,y1, c, areathis
        integer                 :: i

        area = 0.
        centroid = (a+b)/2.
        c = 0.
        if (.not. allocated( s%f )) return
        if (b .le. s%f(1,1)) return
        if (a .ge. s%f(1,s%n)) return
        do i=1,s%n-1
            if (a .ge. s%f(1,i+1)) cycle
            if (b .le. s%f(1,i)) exit
            x0 = max( a, s%f(1,i) )
            x1 = min( b, s%f(1,i+1) )
            y0 = s%f(2,i)
            if (x0 .ne. s%f(1,i)) y0 = ip_linear( s%f(1,i), s%f(2,i), s%f(1,i+1), s%f(2,i+1), a)
            y1 = s%f(2,i+1)
            if (x1 .ne. s%f(1,i+1)) y1 = ip_linear( s%f(1,i), s%f(2,i), s%f(1,i+1), s%f(2,i+1), b)
            areathis = trapezoid_area( x0,y0, x1,y1 )
            c = c + areathis * trapezoid_centroid( x0,y0, x1,y1 )
            area = area + areathis
        end do
        centroid = c/area
    end subroutine

    subroutine plf_taper_array_r( s, array, span, dx, ip_method )

        type(t_plf), intent(in) :: s
        integer, dimension(2), intent(in) :: span
        real, dimension(span(1):), intent(inout) :: array
        real, intent(in) :: dx
        interface
            pure function ip_method( x0,y0, x1,y1, xi ) result(yi)
                real, intent(in) :: x0,y0,x1,y1,xi
                real :: yi
            end function
        end interface

        integer :: ibeg, iend, i, j, ibegatleast

        ibeg = floor(s%f(1,1)/dx)

      ! fill zeroes before start of plf
        if (span(1) <= ibeg) then
            array(span(1):min(ibeg,span(2))) = 0.
        end if

      ! interpolate linear ramps
        ibegatleast = span(1)
        do i=1,s%n-1
            ibeg = max(floor(s%f(1,i)/dx)+1,span(1),ibegatleast)
            iend = min(floor(s%f(1,i+1)/dx),span(2))
            if (ibeg <= iend) then
                forall (j=ibeg:iend)
                    array(j) = array(j) * ip_method( s%f(1,i), s%f(2,i), &
                                               s%f(1,i+1), s%f(2,i+1), j*dx )
                end forall
            end if
            ibegatleast = iend+1
        end do

      ! fill zeroes until end
        iend = floor(s%f(1,s%n)/dx)+1
        if (span(2) >= iend) then
            array(max(iend,span(1)):span(2)) = 0.
        end if

    end subroutine

    subroutine plf_taper_array_c( s, array, span, dx, ip_method )

        type(t_plf), intent(in) :: s
        integer, dimension(2), intent(in) :: span
        complex, dimension(span(1):), intent(inout) :: array
        real, intent(in) :: dx
        interface
            pure function ip_method( x0,y0, x1,y1, xi ) result(yi)
                real, intent(in) :: x0,y0,x1,y1,xi
                real :: yi
            end function
        end interface

        integer :: ibeg, iend, i, j, ibegatleast

        ibeg = floor(s%f(1,1)/dx)

      ! fill zeroes before start of plf
        if (span(1) <= ibeg) then
            array(span(1):min(ibeg,span(2))) = 0.
        end if

      ! interpolate linear ramps
        ibegatleast = span(1)
        do i=1,s%n-1
            ibeg = max(floor(s%f(1,i)/dx)+1,span(1),ibegatleast)
            iend = min(floor(s%f(1,i+1)/dx),span(2))
            if (ibeg <= iend) then
                forall (j=ibeg:iend)
                    array(j) = array(j) * ip_method( s%f(1,i), s%f(2,i), &
                                               s%f(1,i+1), s%f(2,i+1), j*dx )
                end forall
            end if
            ibegatleast = iend+1
        end do

      ! fill zeroes until end
        iend = floor(s%f(1,s%n)/dx)+1
        if (span(2) >= iend) then
            array(max(iend,span(1)):span(2)) = 0.
        end if

    end subroutine

    pure function trapezoid_centroid( x0,y0, x1,y1 ) result(x)
        real, intent(in) :: x0,y0,x1,y1
        real :: x
      ! returns center of mass of trapezoid
        if (y0+y1 == 0.) then
            x = (x0+x1)/2.
        else
            x = (x0*(2.*y0+y1)+x1*(y0+2.*y1))/(3.*(y0+y1))
        end if
    end function

    pure function trapezoid_area( x0,y0, x1,y1 ) result(a)
        real, intent(in) :: x0,y0,x1,y1
        real :: a
        a = (y0+y1)*(x1-x0)/2.
    end function

    pure function ip_linear( x0,y0, x1,y1, xi ) result(yi)
        real, intent(in) :: x0,y0,x1,y1,xi
        real :: yi
        yi = y0+(y1-y0)/(x1-x0)*(xi-x0)
    end function

    pure function ip_cos( x0,y0, x1,y1, xi ) result(yi)
        real, intent(in) :: x0,y0,x1,y1,xi
        real :: yi
        if (y1/=y0) then
            yi = y0+(y1-y0)*(0.5-0.5*cos( (xi-x0)/(x1-x0)*pi) )
        else
            yi = y0
        end if
    end function

    pure function ip_zero_one( x0,y0, x1,y1, xi ) result(yi)
        real, intent(in) :: x0,y0,x1,y1,xi
        real :: yi
        if ((y0 == 0.) .and. (y1 == 0.)) then
            yi = 0.     + 0.*(x0+x1+xi)  ! zero ! (to get rid of compiler warnings)
        else
            yi = 1.
        end if

    end function

end module


! PR tree-optimization/84117
! { dg-do compile }
! { dg-options "-O3 -ftrapv" }
  FUNCTION pw_integral_aa ( cc ) RESULT ( integral_value )
    COMPLEX(KIND=8), DIMENSION(:), POINTER :: cc
    integral_value = accurate_sum ( CONJG ( cc (:) ) * cc (:) )
  END FUNCTION pw_integral_aa


      program testHours

      implicit none

      integer            :: i

      integer            :: iyear,imonth
      integer            :: iday, idoy
      real(kind=8)       :: hours
      integer            :: byear    = 1000
      logical            :: useLeaps = .true.

      real(kind=8)       :: HS_hours_since_baseyear
      real(kind=8)       :: HoursSince
      real(kind=8)       :: hours2

      INTERFACE
        subroutine HS_Get_YMDH(HoursSince,byear,useLeaps,iyear,imonth,iday,hours,idoy)
          real(kind=8),intent(in)       :: HoursSince
          integer     ,intent(in)       :: byear
          logical     ,intent(in)       :: useLeaps
          integer     ,intent(out)      :: iyear
          integer     ,intent(out)      :: imonth
          integer     ,intent(out)      :: iday
          real(kind=8),intent(out)      :: hours
          integer     ,intent(out)      :: idoy
        end subroutine
      END INTERFACE

      ! Check against calculator on
      ! http://www.7is7.com/otto/datediff.html
      ! Use the Proleptic Gregorian calendar
      ! https://en.wikipedia.org/wiki/Proleptic_Gregorian_calendar

      !DO i = 1,876576  ! # of hours in a normal century
      !DO i = 1,1884648  ! # of hours from 1800 to 2015
      DO i = 1,8897303  ! # of hours from 1000 to 2015
        HoursSince = real(i,kind=8)
        call HS_Get_YMDH(HoursSince,byear,useLeaps,iyear,imonth,iday,hours,idoy)
        hours2 = HS_hours_since_baseyear(iyear,imonth,iday,hours,byear,useLeaps)
        write(*,*)"     ",HoursSince,byear,useLeaps,iyear,imonth,iday,hours,idoy,hours2
        IF(abs(HoursSince-hours2).gt.0.01)THEN
          write(*,*)"ERROR",HoursSince,byear,useLeaps,iyear,imonth,iday,hours,idoy,hours2
        ENDIF
      ENDDO

      end program testHours


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! 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 and documentation.

! 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.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE INVERT_FF_MAT ( CALLING_SUBR, MAT_A_NAME, A, NROWS, INFO )

! Invert symmetric matrix A which is stored in full format. The return has the inverse of the matrix in array A

      USE PENTIUM_II_KIND, ONLY       :  DOUBLE, LONG
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  INVERT_FF_MAT_BEGEND
      USE LAPACK_SYM_MAT_INV

      USE INVERT_FF_MAT_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'INVERT_FF_MAT'
      CHARACTER(LEN=*), INTENT(IN )   :: CALLING_SUBR      ! Name of subr that called this subr
      CHARACTER(LEN=*), INTENT(IN )   :: MAT_A_NAME        ! Name of input matrix to be inverted

      INTEGER(LONG)   , INTENT(IN)    :: NROWS             ! Row/col size of input matrix A
      INTEGER(LONG)   , INTENT(OUT)   :: INFO              ! Output from LAPACK routines to do factorization of Lapack band matrix
                                                           !   0:  successful exit
                                                           ! < 0:  if INFO = -i, the i-th argument had an illegal value
                                                           ! > 0:  if INFO =  i, the leading minor of order i is not pos definite
      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG)   , PARAMETER     :: SUBR_BEGEND = INVERT_FF_MAT_BEGEND

      REAL(DOUBLE)    , INTENT(INOUT) :: A(NROWS,NROWS)    ! Matrix to invert. Inverted matrix returned in A

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! In DPOTRF A has the matrix to invert as input and the triangular factor of A coming out. In DPOTRI A has the tria factor of the
! matrix to invert going in and the inverse of the matrix coming out

      CALL DPOTRF ( 'U', NROWS, A, NROWS, INFO )           ! Factor A

      IF (INFO > 0) THEN                                ! Error factoring A

         WRITE(ERR,994) MAT_A_NAME, INFO, CALLING_SUBR
         WRITE(F06,994) MAT_A_NAME, INFO, CALLING_SUBR

      ELSE

         CALL DPOTRI ( 'U', NROWS, A, NROWS, INFO )     ! No error factoring A so invert

         IF (INFO > 0) THEN                             ! Error inverting A

            WRITE(ERR,995) MAT_A_NAME, INFO, CALLING_SUBR
            WRITE(F06,995) MAT_A_NAME, INFO, CALLING_SUBR

         ELSE                                           ! Matrix inverted OK so set lower triangle of A based on symmetry

            DO I=1,NROWS
               DO J=1,I-1
                  A(I,J) = A(J,I)
               ENDDO
            ENDDO

         ENDIF

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  994 FORMAT(' *ERROR   994: THE FACTORIZATION OF MATRIX NAMED "',A,'" COULD NOT BE COMPLETED BY LAPACK SUBR DPOTRF '              &
                    ,/,14X,' A SINGULARITY WAS FOUND IN ROW ',I8,'. THIS SUBR WAS CALLED BY SUBR ',A)

  995 FORMAT(' *ERROR   995: INVERSION OF MATRIX ',A,' COULD NOT BE COMPLETED BY LAPACK SUBR DPOTRI '                              &
                    ,/,14X,' THE DIAG TERM IN ROW ',I8,' OF THE TRIANG FACTOR OF THE MATRIX IS 0. THIS SUBR WAS CALLED BY SUBR ',A)

98764 format(32767(1es14.6))

98765 format(32767a14)

! **********************************************************************************************************************************

      END SUBROUTINE INVERT_FF_MAT


program types_04
implicit none
real :: r, x
integer :: i
r = 1.5
i = 2

x = i*i
x = r*r
x = i*r
x = r*i

x = i+i
x = r+r
x = r+i
x = i+r

x = i-i
x = r-r
x = r-i
x = i-r

x = i/i
x = r/r
x = i/r
x = r/i
end program


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! 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 and documentation.

! 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.
! _______________________________________________________________________________________________________

! End MIT license text.

      MODULE CONSTANTS_GAUSS

! Real parameters used in subroutine ORDER for Gaussian integration

      USE PENTIUM_II_KIND, ONLY       :  DOUBLE

      IMPLICIT NONE

      SAVE

      REAL(DOUBLE), PARAMETER         :: SSV(29) = (/ 0.577350269189626D0, & ! SSV( 1)
                                                      0.774596669241483D0, & ! SSV( 2)
                                                      0.000000000000000D0, & ! SSV( 3)
                                                      0.861136311594053D0, & ! SSV( 4)
                                                      0.339981043584856D0, & ! SSV( 5)
                                                      0.906179845938664D0, & ! SSV( 6)
                                                      0.538469310105683D0, & ! SSV( 7)
                                                      0.000000000000000D0, & ! SSV( 8)
                                                      0.932469514203152D0, & ! SSV( 9)
                                                      0.661209386466265D0, & ! SSV(10)
                                                      0.238619186083197D0, & ! SSV(11)
                                                      0.949107912342759D0, & ! SSV(12)
                                                      0.741531185599394D0, & ! SSV(13)
                                                      0.405845151377397D0, & ! SSV(14)
                                                      0.000000000000000D0, & ! SSV(15)
                                                      0.960289856497536D0, & ! SSV(16)
                                                      0.796666477413627D0, & ! SSV(17)
                                                      0.525532409916329D0, & ! SSV(18)
                                                      0.183434642495650D0, & ! SSV(19)
                                                      0.968160239507626D0, & ! SSV(20)
                                                      0.836031107326636D0, & ! SSV(21)
                                                      0.613371432700590D0, & ! SSV(22)
                                                      0.324253423403809D0, & ! SSV(23)
                                                      0.000000000000000D0, & ! SSV(24)
                                                      0.973906528517172D0, & ! SSV(25)
                                                      0.865063366688985D0, & ! SSV(26)
                                                      0.679409568299024D0, & ! SSV(27)
                                                      0.433395394129247D0, & ! SSV(28)
                                                      0.148874338981631D0 /) ! SSV(29)

      REAL(DOUBLE), PARAMETER         :: HHV(29) = (/ 1.000000000000000D0, & ! HHV( 1)
                                                      0.555555555555556D0, & ! HHV( 2)
                                                      0.888888888888889D0, & ! HHV( 3)
                                                      0.347854845137454D0, & ! HHV( 4)
                                                      0.652145154862546D0, & ! HHV( 5)
                                                      0.236926885056189D0, & ! HHV( 6)
                                                      0.478628670499366D0, & ! HHV( 7)
                                                      0.568888888888889D0, & ! HHV( 8)
                                                      0.171324492379170D0, & ! HHV( 9)
                                                      0.360761573048139D0, & ! HHV(10)
                                                      0.467913934572691D0, & ! HHV(11)
                                                      0.129484966168870D0, & ! HHV(12)
                                                      0.279705391489277D0, & ! HHV(13)
                                                      0.381830050505119D0, & ! HHV(14)
                                                      0.417959183673469D0, & ! HHV(15)
                                                      0.101228536290376D0, & ! HHV(16)
                                                      0.222381034453374D0, & ! HHV(17)
                                                      0.313706645877887D0, & ! HHV(18)
                                                      0.362683783378362D0, & ! HHV(19)
                                                      0.081274388361574D0, & ! HHV(20)
                                                      0.180648160694857D0, & ! HHV(21)
                                                      0.260610696402935D0, & ! HHV(22)
                                                      0.312347077040003D0, & ! HHV(23)
                                                      0.330239355001260D0, & ! HHV(24)
                                                      0.066671344308688D0, & ! HHV(25)
                                                      0.149451349150581D0, & ! HHV(26)
                                                      0.219086362515982D0, & ! HHV(27)
                                                      0.269266719309996D0, & ! HHV(28)
                                                      0.295524224714753D0 /) ! HHV(29)

      END MODULE CONSTANTS_GAUSS


! pr 15149
! verify the random number generator is functional
      program test_random
      implicit none
      real :: r(5) = 0.0

      call random_number(r)
      if (all (r .eq. 0)) call abort
      end program


      double complex function fmtfull(s12,s34,s56,mtsq)
      implicit none
      include 'scale.f'
      double precision mtsq,s12,s34,s56,Del12,Del34,Del56,Del3
      double complex qlI3,bdiff

C     Implementation of BDKW Nucl Phys. 513, 3 (1998)
C     Eqn. (B.15) upgraded so that is gives the full mass
C     dependence.
      Del12=s12-s34-s56
      Del34=s34-s12-s56
      Del56=s56-s12-s34
      Del3=s12*Del12+s34*Del34+s56*Del56

      fmtfull=
     . Dcmplx((3d0*s12*s56*s34*Del34/Del3**2-(s12*s56-mtsq*del34)/Del3))
     . *(-qlI3(s12,s34,s56,mtsq,mtsq,mtsq,musq,0))
     . +Dcmplx((3d0*s56*Del56/Del3**2-0.5d0/Del3)*s12)
     . *bdiff(s34,s12,mtsq)
     . +Dcmplx((3d0*s12*Del12/Del3**2-0.5d0/Del3)*s56)
     . *bdiff(s34,s56,mtsq)
     . -Dcmplx(0.5d0*Del34/Del3)
      end


      PROGRAM min_delNabc
      IMPLICIT NONE

      INTEGER (KIND=8),PARAMETER::n_line=2601
      INTEGER (KIND=8):: i
      REAL    (KIND=8):: Naa_av,Nbb_av,Nab_av,Jbb_av,Jab_av
      REAL    (KIND=8):: compt,delNabc_av,delJbb,delJab

      REAL (KIND=8),DIMENSION(n_line) :: Jbb,Jab,FNaa,FNbb,FNab,delNabc,cost

!!!=======================================================================================
!!!=======================================================================================
      OPEN(unit=12,file='average_thermal.dat')
      OPEN(unit=13,file='average_thermal_min.dat')
      OPEN(unit=14,file='average_thermal_plot.dat')

      compt=0. ; Jbb_av=0.; Jab_av=0. ; delNabc_av=0.

      DO i=1,n_line
            READ(12,*)Jbb(i),Jab(i),Naa_av,Nbb_av,Nab_av,FNaa(i),FNbb(i),FNab(i),delNabc(i)

            cost(i)=delNabc(i)/(FNaa(i)+FNbb(i)+FNab(i))/2.

            !IF (cost(i)<1.) THEN
            IF (delNabc(i)<1.) THEN
                  !WRITE(13,'(F8.4,3X,F8.4,4X,F16.4,3X,F8.4)') &
                  !Jbb(i),Jab(i),delNabc(i),cost(i)
                  !WRITE(*,'(F8.4,3X,F8.4,4X,F16.4,3X,F8.4)') &
                  !Jbb(i),Jab(i),delNabc(i),cost(i)

                  WRITE(13,'(F8.4,3X,F8.4,4X,F16.4)') &
                  Jbb(i),Jab(i),delNabc(i)
                  WRITE(*,'(F8.4,3X,F8.4,4X,F16.4)') &
                  Jbb(i),Jab(i),delNabc(i)

                  compt=compt+1.
                  Jbb_av=Jbb_av+Jbb(i)
                  Jab_av=Jab_av+Jab(i)
                  delNabc_av=delNabc_av+delNabc(i)

            END IF

            WRITE(14,'(F8.4,3X,F8.4,4X,F16.4)') &
                  Jbb(i),Jab(i),delNabc(i)

      END DO

      Jbb_av=Jbb_av/compt
      Jab_av=Jab_av/compt
      delNabc_av=delNabc_av/compt

!!!=======================================================================================
!!! Tinh delJbb, delJab

      delJbb=0. ; delJab=0.
      DO i=1,n_line
            !IF (cost(i)<1.) THEN
            IF (delNabc(i)<1.) THEN
                  delJbb=delJbb+(Jbb(i)-Jbb_av)**2.
                  delJab=delJab+(Jab(i)-Jab_av)**2.
            END IF

      END DO

      delJbb=sqrt(delJbb/compt)
      delJab=sqrt(delJab/compt)

      WRITE(13,*)'Jbb_av:',Jbb_av,'Jab_av:',Jab_av,'delJbb:',delJbb,'delJab:',delJab,'delNabc_av:',delNabc_av
      WRITE(*,*)'Jbb_av:',Jbb_av,'Jab_av:',Jab_av,'delJbb:',delJbb,'delJab:',delJab,'delNabc_av:',delNabc_av

      CLOSE(12)
      CLOSE(13)
      CLOSE(14)

!!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      END PROGRAM min_delNabc


!> @ingroup quick_sort_flat_gen
!>
!> @brief
!> Run a flat three way quick sort on a vector of integer values.
!>
!> @details
!> Run the specified on a vector of integer values to sort them in the specified order.The vector of intergers map is permuted in the same way that the vector vec is permuted to be sorted. It is important that map be at least as long as vec.
!>
!> @param vec
!> The vector integer values to be sorted.
!>
!> @param map
!> Vector of intergers which is permuted in the same way that vec is permuted. If map is a vector of values 1 to N, where N is the length of vec, than, map is the map from vec's original value to vec's final value after the sort.
!>
!> @param ord
!> A logical function which describes the ordering used. The function must take two integer arguments and return true if and only if the first argument must proceed the second argument in the order.
!>
!> @note
!> This flat quick sort works by maintaning a psudo stack.  As the the subroutine runs vec splices of vec are broken into two groups based on comparison to a pivot chosen based on the average value of the first and last element of of the slice.  The same process is then applied to the larger of the two slices.  After a slice is sorted the next smallest slice of vec is sorted.
!>
!> Example ignoring the interchange sort     4 3 7 9 1 2
!> i    pivot    lower     upper
!> 1    3        1         6                |2 1 7 9 3 4|
!> 2    5        3         6                 2 1|4 3 9 7]
!> 3    8        5         6                 2 1 4 3|7 9|
!> 2    4        3         4                 2 1|3 4|7 9
!> 1    1        1         2                |1 2|3 4 7 9
!>
!> The alogorithm of the flat quick sort is harder to follow than the more conventional flat quick sort; however, it saves system resoruces.  Also on systems with limitations on stack sizes a flat quick sort allows sorting of larger lists.  The natural limit is the value of the vector levels.  This can cause a failure in some cases.
!>
!> @note
!> Some credit for this implimentation must go to Darel Flex's implimentation that can be found here.
!e
!> @warning
!> Error will occur if max_interchange_sort_size is less than one.
!>>
!> @warning
!> The argument types and counts of ord are not checked within this subroutine.
!>
!> @warning
!> The length of map is not checked within this subroutine. If the length of vec is larger than the length of map, than this subroutine may attempt to access elements outside of map.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014
subroutine quick_sort_flat_gen_map_int(vec,map,ord)
  ! Arguments
  integer, intent(inout) :: vec(:)
  integer, intent(inout) :: map(:)
  procedure(logical) :: ord

  ! Parameters
  integer, parameter :: stack_levels = 300

  ! Variables
  integer :: idx
  integer :: low
  integer :: high
  integer :: lower(stack_levels)
  integer :: upper(stack_levels)
  integer :: pivot
  integer :: swap_value

  ! Initilize the stack
  idx = 1
  lower(idx) = 1
  upper(idx) = size(vec,1) + 1

  ! Main loop
  do while(idx >= 1)
     ! Sort the slice of vec between lower(idx) and upper(idx)
     low = lower(idx)
     high = upper(idx) - 1

     if (low < high) then
        pivot = (vec(high) + vec(low)) / 2
        do while(low < high)

           if (high - low < max_interchange_sort_size) then
              ! Run interchange sort on small vectors
              if (low < high) call interchange_sort_gen_map_int(vec(low:high),map(low:high),ord)
              idx = idx - 1
           else
              ! Run quick sort on large vectors
              ! This pivot helps avoid n^2 behavior, expect in expontially growning and shrinking (reverse) sorted lists and lists of indentical elements.
              pivot = (vec(high) + vec(low)) / 2
              do
                 ! This loop finds elements on the wrong side of the pivot and swaps until no such elements are left.
                 ! Consider running these in parallel

                 ! Find the first element below the pivot that must be above the pivot.
                 do while(low <= high)
                    if (ord(vec(low),pivot)) exit
                    low = low + 1
                 end do

                 ! Find the first element above the pivot that must be below the pivot.
                 do while (high > lower(idx))
                    if (ord(pivot,vec(high))) exit
                    high = high - 1
                 end do

                 if (high > low) then
                    !If vec(low) must follow vec(high) than swap their values.
                    #SWAP<vec(low)><vec(high)>#
                    low = low + 1
                    high = high - 1
                 else
                    ! If vec(low) does not have to follow vec(high) than exit.
                    ! There may be a way to rewrite to remove this if.
                    if (low == upper(idx)) then
                       high = low
                       low = low - 1
                    else
                       high = low + 1
                    end if
                    exit
                 end if
              end do

              ! Split splice based on pivot, making sure to throw the smaller splice on the higher end of the stack
              if (upper(idx) - high < low - lower(idx)) then
                 upper(idx + 1) = upper(idx)
                 lower(idx + 1) = high
                 upper(idx) = low
              else
                 upper(idx + 1) = low
                 lower(idx + 1) = lower(idx)
                 lower(idx) = high
              end if
              idx = idx + 1
           end if
        end do
     end if
  end do
end subroutine quick_sort_flat_gen_map_int


SUBROUTINE src2d(maxmx,maxmy,meqn,mbc,mx,my, &
    xlower,ylower,dx,dy,q,maux,aux,t,dt)
    IMPLICIT NONE

    INTEGER maxmx, maxmy, meqn, mbc, mx, my, maux
    DOUBLE PRECISION xlower, ylower, dx, dy, t, dt

    DOUBLE PRECISION  q(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc,meqn)
    DOUBLE PRECISION  aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc,maux)

    DOUBLE PRECISION :: grav, dry_tolerance, sea_level
    COMMON /common_swe/ grav, dry_tolerance, sea_level

    DOUBLE PRECISION :: alpha, breaking
    COMMON /common_dispersive/ alpha, breaking

    INTEGER i
    DOUBLE PRECISION hl, hc, hr, dxzb, dxh, dxeta, dx2
    DOUBLE PRECISION bathy

    DOUBLE PRECISION sgn_soln(1-mbc:mx+mbc), disp, xc, wall
    double precision wall_distance

    if (breaking .lt. 0) then
        return
    endif

    CALL sgn(meqn,mbc,mx,xlower,dx,q,maux,aux,sgn_soln)

    dx2 = 2.d0*dx

    DO i = 1,mx    !! Avoid problems at the wall?
        !! xc = xlower + (i-0.5)*dx

        do j = 1,my
            hr = q(i+1,j,1)
            hc = q(i,j,1)
            hl = q(i-1,j,1)

            dxzb = aux(i,j,2)            !! Gradient of the bathymetry
            dxh = (hr - hl)/dx2
            dxeta = dxh + dxzb

            !!if (.true.) then
            if (abs(dxeta) .le. breaking .and. hc .ge. dry_tolerance) then
              disp = hc*(grav/alpha*dxeta - sgn_soln(i))
              q(i,j,2) = q(i,j,2) + dt*disp
          endif
      end do

  ENDDO

!!  sum(2) = 0
!!  do i = 1,mx
!!      sum(2) = sum(2) + q(2,i)*dx
!!  end do

!!  write(6,100) 'Before   : ', sum(1)
!!  write(6,100) 'After    : ', sum(2)
!!  if (sum(1) .ne. 0) then
!!    write(6,110) 'Diff (%) : ', 100*abs(sum(1)-sum(2))/abs(sum(1))
!!  else
!!    write(6,110) 'Diff (%) : ', abs(sum(1)-sum(2))
!!  endif
!!  write(6,*)
!!
!!100 format(A12,E24.16)
!!110 format(A12,F8.2)

    RETURN
    END SUBROUTINE src2d


C    SUBROUTINE H12 (MDE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
C    C. L. LAWSON AND R.J. HANSON, JET PROPULSION LABORATORY, 1973 JUN 12
C    TO APPEAR IN 'SOLVING LEAST SQUARES PROBLEMS'.
C
C    CONSTRUCTION AND/OR APPLICATION OF A SINGLE HOUSEHOLDER
C    TRANSFORMATION.  Q=I+U*(U**T)/B
C
C    MDE= 1 OR 2  TO SELECT ALGORITHM H1 OR H2
C    LPIVOT IS THE INDEX OF THE PIVOT ELEMENT
C    L1, M IF L1.LE.M THE TRANSFORMATION WILL BE CONSTRUCTED TO
C          ZERO ELEMENTS INDEXED FROM L1 THRU M.  IF L1.GT.M
C          THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C    U(), IUE, UP  ON ENTRY TO H1 U() CONTAINS THE PIVOT VECTOR.
C                  IUE IS THE STORAAGE INCREMENT BETWEEN ELEMENTS.
C                  ON EXIT FROM H1 U() AND UP CONTAIN QUANTITIES
C                  DEFINING THE VECTOR U OF THE HOUSEHOLDER
C                  TRANSFORMATION.  ON ENTRY TO H2 U() AND UP
C                  SHOULD CONTAIN QUANTITIES PREVIOUSLY COMPUTED
C                  BY H1.  THESE WILL NOT BE MODIFIED BY H2.
C    C()   ON ENTRY TO H1 OR H2 C() CONTAINS A MATRIX WHICH WILL BE
C          REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER
C          TRANSFORMATION IS TO BE APPLIED. ON EXIT C() CONTAINS
C          THE SET OF TRANSFORMED VECTORS.
C    ICE()  STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
C    ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
C    NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED.  IF NCV.LE.0
C           NO OPERATIONS WILL BE DONE ON C().
C
      SUBROUTINE H12 (MDE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
      DIMENSION U(IUE,M), C(1)
      DOUBLE PRECISION SM, B
      ONE=1.
C
      IF (0.GE.LPIVOT.OR.LPIVOT.GE.L1.OR.L1.GT.M) RETURN
      CL=ABS(U(1,LPIVOT))
      IF (MDE.EQ.2) GO TO 60
C
C  *******************CONSTRUCT THE TRANSFORMATION****************
C
         DO 10 J=L1,M
 10      CL=AMAX1(ABS(U(1,J)),CL)
      IF (CL) 130,130,20
 20   CLINV=ONE/CL
      SM=(DBLE(U(1,LPIVOT))*CLINV)**2
         DO 30 J=L1,M
 30      SM=SM+(DBLE(U(1,J))*CLINV)**2
C
C      CONVERT  PREC SM TO SNGL PREC SM1
C
      SM1=SM
      CL=CL*SQRT(SM1)
      IF (U(1,LPIVOT)) 50,50,40
 40   CL=-CL
 50   UP=U(1,LPIVOT)-CL
      U(1,LPIVOT)=CL
      GO TO 70
C
C **************APPLY THE TRANSFORMATION I+U*(U**T)/B TO C***************
C
 60   IF (CL) 130,130,70
 70   IF (NCV.LE.0) RETURN
      B=DBLE(UP)*U(1,LPIVOT)
C
C   B MUST BE NONPOSITIVE HERE. IF B=0. THEN RETURN.
C
      IF (B) 80,130,130
 80   B=ONE/B
      I2=1-ICV+ICE*(LPIVOT-1)
      INCR=ICE*(L1-LPIVOT)
          DO 120 J=1,NCV
          I2=I2+ICV
          I3=I2+INCR
          I4=I3
          SM=C(I2)*DBLE(UP)
                DO 90 I=L1,M
                SM=SM+C(I3)*DBLE(U(1,I))
 90             I3=I3+ICE
          IF (SM) 100,120,100
 100      SM=SM*B
          C(I2)=C(I2)+SM*DBLE(UP)
                DO 110 I=L1,M
                C(I4)=C(I4)+SM*DBLE(U(1,I))
 110            I4=I4+ICE
 120      CONTINUE
 130  RETURN
      END