      SUBROUTINE AB08NY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, NINFZ,
     $                   NR, PR, DINFZ, NKRONL, INFZ, KRONL, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To extract from the (N+P)-by-(M+N) system pencil
C                  ( B  A-lambda*I )
C                  ( D      C      )
C     an (NR+PR)-by-(M+NR) "reduced" system pencil,
C                  ( Br Ar-lambda*I ),
C                  ( Dr     Cr      )
C     having the same transmission zeros, but with Dr of full row rank.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FIRST   LOGICAL
C             Specifies if AB08NY is called first time, or it is called
C             for an already reduced system, with D of full column rank,
C             with the last M rows in upper triangular form:
C             FIRST = .TRUE.  :  first time called;
C             FIRST = .FALSE. :  not first time called.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix B, the number of columns
C             of the matrix C, and the order of the square matrix A.
C             N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrices B and D.  M >= 0.
C             M <= P, if FIRST = .FALSE.
C
C     P       (input) INTEGER
C             The number of rows of the matrices C and D.  P >= 0.
C
C     SVLMAX  (input) DOUBLE PRECISION
C             An estimate of the largest singular value of the original
C             matrix ABCD (for instance, the Frobenius norm of ABCD).
C             SVLMAX >= 0.
C
C     ABCD    (input/output) DOUBLE PRECISION array, dimension
C             (LDABCD,M+N)
C             On entry, the leading (N+P)-by-(M+N) part of this array
C             must contain the compound matrix
C                      (  B   A  ),
C                      (  D   C  )
C             where A is an N-by-N matrix, B is an N-by-M matrix,
C             C is a P-by-N matrix, and D is a P-by-M matrix.
C             If FIRST = .FALSE., then D must be a full column rank
C             matrix, with the last M rows in an upper triangular form.
C             On exit, the leading (NR+PR)-by-(M+NR) part of this array
C             contains the reduced compound matrix
C                       (  Br  Ar ),
C                       (  Dr  Cr )
C             where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix,
C             Cr is a PR-by-NR matrix, and Dr is a PR-by-M full row rank
C             left upper-trapezoidal matrix, with the first PR columns
C             in an upper triangular form.
C
C     LDABCD  INTEGER
C             The leading dimension of the array ABCD.
C             LDABCD >= MAX(1,N+P).
C
C     NINFZ   (input/output) INTEGER
C             On entry, the currently computed number of infinite zeros.
C             It should be initialized to zero on the first call.
C             NINFZ >= 0.
C             If FIRST = .FALSE., then NINFZ is not modified.
C             On exit, the number of infinite zeros.
C
C     NR      (output) INTEGER
C             The order of the reduced matrix Ar; also, the number of
C             rows of the reduced matrix Br and the number of columns of
C             the reduced matrix Cr.
C             If Dr is invertible, NR is also the number of finite Smith
C             zeros.
C
C     PR      (output) INTEGER
C             The normal rank of the transfer-function matrix of the
C             original system; also, the number of rows of the reduced
C             matrices Cr and Dr.
C
C     DINFZ   (output) INTEGER
C             The maximal multiplicity of infinite zeros.
C             DINFZ = 0 if FIRST = .FALSE. .
C
C     NKRONL  (output) INTEGER
C             The maximal dimension of left elementary Kronecker blocks.
C
C     INFZ    (output) INTEGER array, dimension (N)
C             INFZ(i) contains the number of infinite zeros of degree i,
C             where i = 1,2,...,DINFZ.
C             INFZ is not referenced if FIRST = .FALSE. .
C
C     KRONL   (output) INTEGER array, dimension (N+1)
C             KRONL(i) contains the number of left elementary Kronecker
C             blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR (or RQ) factorization with column (or row) pivoting
C             whose estimated condition number is less than 1/TOL.
C             NOTE that when SVLMAX > 0, the estimated ranks could be
C             less than those defined above (see SVLMAX).
C             If the user sets TOL to be less than or equal to zero,
C             then the tolerance is taken as (N+P)*(N+M)*EPS, where EPS
C             is the machine precision (see LAPACK Library Routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(M,P))
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 >= 1, if MIN(P, MAX(N,M)) = 0; otherwise,
C             LDWORK >= MAX( MIN(P,M) + M + MAX(2*M,N) - 1,
C                            MIN(P,N) + MAX(N + MAX( P, M), 3*P - 1 ) ).
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     REFERENCES
C
C     [1] Svaricek, F.
C         Computation of the Structural Invariants of Linear
C         Multivariable Systems with an Extended Version of the
C         Program ZEROS.
C         System & Control Letters, 6, pp. 261-266, 1985.
C
C     [2] Emami-Naeini, A. and Van Dooren, P.
C         Computation of Zeros of Linear Multivariable Systems.
C         Automatica, 18, pp. 415-430, 1982.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( (P+N)*(M+N)*N )  floating point operations.
C
C     FURTHER COMMENTS
C
C     The number of infinite zeros is computed (if FIRST = .TRUE.) as
C
C                   DINFZ
C        NINFZ =     Sum  (INFZ(i)*i .
C                    i=1
C
C     Note that each infinite zero of multiplicity k corresponds to an
C     infinite eigenvalue of multiplicity k+1.
C     The multiplicities of the infinite eigenvalues can be determined
C     from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows:
C
C                     DINFZ
C     - there are PR - Sum (INFZ(i)) simple infinite eigenvalues;
C                      i=1
C
C     - there are INFZ(i) infinite eigenvalues with multiplicity i+1,
C       for i = 1, ..., DINFZ.
C
C     The left Kronecker indices are:
C
C     [ 0  0 ...  0  | 1  1  ...  1 |  .... | NKRONL  ...  NKRONL ]
C     |<- KRONL(1) ->|<- KRONL(2) ->|       |<-  KRONL(NKRONL)  ->|
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium.
C     A. Varga, DLR Oberpfaffenhofen, Germany, May 1999.
C     Supersedes Release 3.0 routine AB08BX.
C
C     REVISIONS
C
C     A. Varga, DLR Oberpfaffenhofen, Germany, March 2002.
C     V. Sima, Dec. 2016, Jan. 2017, Feb. 2018.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, Kronecker indices, multivariable
C     system, orthogonal transformation, structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           FIRST
      INTEGER           DINFZ, INFO, LDABCD, LDWORK, M, N, NINFZ,
     $                  NKRONL, NR, P, PR
      DOUBLE PRECISION  SVLMAX, TOL
C     .. Array Arguments ..
      INTEGER           INFZ(*), IWORK(*), KRONL(*)
      DOUBLE PRECISION  ABCD(LDABCD,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LQUERY
      INTEGER           I, I1, ICOL, IRC, IROW, ITAU, JWORK, K, MN, MNR,
     $                  MNTAU, MP1, MPM, MPN, MUI, MUIM1, NBLCKS, PN,
     $                  RANK, RO, RO1, SIGMA, TAUI, WRKOPT
      DOUBLE PRECISION  RCOND
C     .. Local Arrays ..
      DOUBLE PRECISION  SVAL(3)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C     .. External Subroutines ..
      EXTERNAL          DLAPMT, DLASET, DORMQR, DORMRQ, MB03OY, MB03PY,
     $                  MB04ID, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      PN   = P + N
      MN   = M + N
      MPN  = MIN( P, N )
      MPM  = MIN( P, M )
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 .OR. (.NOT.FIRST .AND. M.GT.P ) ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -5
      ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN
         INFO = -7
      ELSE IF( NINFZ.LT.0 .OR. ( FIRST .AND. NINFZ.GT.0 ) ) THEN
         INFO = -8
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -15
      ELSE
         LQUERY = ( LDWORK.EQ.-1 )
         IF( MIN( P, MAX( N, M ) ).EQ.0 ) THEN
            JWORK = 1
         ELSE
            JWORK = MAX( MPM + M + MAX( 2*M, N ) - 1,
     $                   MPN + MAX( N + MAX( P, M) , 3*P - 1 ) )
         END IF
         IF( LQUERY ) THEN
            IF( M.GT.0 ) THEN
               CALL MB04ID( P, MPM, M-1, N, ABCD, LDABCD, ABCD, LDABCD,
     $                      DWORK, DWORK, -1, INFO )
               WRKOPT = MAX( JWORK, MPM + INT( DWORK(1) ) )
               CALL DORMQR( 'Left', 'Transpose', P, N, MPM, ABCD,
     $                      LDABCD, DWORK, ABCD, LDABCD, DWORK, -1,
     $                      INFO )
               WRKOPT = MAX( WRKOPT, MPM + INT( DWORK(1) ) )
            ELSE
               WRKOPT = JWORK
            END IF
            CALL DORMRQ( 'Right', 'Transpose', PN, N, MPN, ABCD, LDABCD,
     $                   DWORK, ABCD, LDABCD, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, MPN + INT( DWORK(1) ) )
            CALL DORMRQ( 'Left', 'NoTranspose', N, MN, MPN, ABCD,
     $                   LDABCD, DWORK, ABCD, LDABCD, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, MPN + INT( DWORK(1) ) )
         ELSE IF( LDWORK.LT.JWORK ) THEN
            INFO = -18
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB08NY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Initialize output variables.
C
      PR = P
      NR = N
C
      DINFZ  = 0
      NKRONL = 0
C
C     Quick return if possible.
C
      IF( P.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( MAX( N, M ).EQ.0 ) THEN
         PR       = 0
         NKRONL   = 1
         KRONL(1) = P
         DWORK(1) = ONE
         RETURN
      END IF
C
      WRKOPT = 1
      RCOND  = TOL
      IF( RCOND.LE.ZERO ) THEN
C
C        Use the default tolerance in rank determination.
C
         RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' )
      END IF
C
C     The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and
C     SIGMA = 0, for FIRST = .TRUE., and SIGMA = M, for FIRST = .FALSE..
C     The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column
C     rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular.
C
      IF( FIRST ) THEN
         SIGMA = 0
      ELSE
         SIGMA = M
      END IF
      RO  = P - SIGMA
      MP1 = M + 1
      MUI = 0
C
      NBLCKS = 0
      ITAU   = 1
C
   10 CONTINUE
C
C     Main reduction loop:
C
C            M   NR                  M     NR
C      NR  [ B   A ]           NR  [ B     A ]
C      PR  [ D   C ]  -->    SIGMA [ RD   C1 ]   (SIGMA = rank(D) =
C                             TAU  [ 0    C2 ]    row size of RD)
C
C                                    M   NR-MUI MUI
C                           NR-MUI [ B1   A11   A12 ]
C                     -->     MUI  [ B2   A21   A22 ]  (MUI = rank(C2) =
C                            SIGMA [ RD   C11   C12 ]   col size of LC)
C                             TAU  [ 0     0    LC  ]
C
C                                    M   NR-MUI
C                           NR-MUI [ B1   A11 ]     NR := NR - MUI
C                                  [----------]     PR := MUI + SIGMA
C                     -->     MUI  [ B2   A21 ]      D := [B2;RD]
C                            SIGMA [ RD   C11 ]      C := [A21;C11]
C
      IF ( PR.EQ.0 )
     $   GO TO 20
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      RO1  = RO
      MNR  = M + NR
C
      IF ( M.GT.0 ) THEN
C
C        Compress columns of D; first, exploit the trapezoidal shape of
C        the (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D;
C        compress the first SIGMA columns without column pivoting:
C
C              ( x x x x x )       ( x x x x x )
C              ( x x x x x )       ( 0 x x x x )
C              ( x x x x x )  - >  ( 0 0 x x x )
C              ( 0 x x x x )       ( 0 0 0 x x )
C              ( 0 0 x x x )       ( 0 0 0 x x )
C
C        where SIGMA = 3 and RO = 2.
C
         IROW = NR + 1
         IF ( SIGMA.GT.0 ) THEN
            JWORK = ITAU + SIGMA
C
C           Compress rows of D.  First, exploit the triangular shape.
C           Workspace: need   min(P,M) + M+N-1;
C                      prefer larger.
C
            CALL MB04ID( RO+SIGMA, SIGMA, SIGMA-1, MNR-SIGMA,
     $                   ABCD(IROW,1), LDABCD, ABCD(IROW,SIGMA+1),
     $                   LDABCD, DWORK(ITAU), DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
            CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO,
     $                   ABCD(IROW+1,1), LDABCD )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
         END IF
C
         IF( FIRST ) THEN
C
C           Continue with Householder with column pivoting.
C
C              ( x x x x x )       ( x x x x x )
C              ( 0 x x x x )       ( 0 x x x x )
C              ( 0 0 x x x )  ->   ( 0 0 x x x )
C              ( 0 0 0 x x )       ( 0 0 0 x x )
C              ( 0 0 0 x x )       ( 0 0 0 0 0 )
C
C           Workspace: need   min(P,M) + 3*M-1.
C           Int.work.  need   M.
C
            JWORK = ITAU + MIN( RO1, M-SIGMA )
C
            IROW = MIN( NR+SIGMA+1, PN )
            ICOL = MIN( SIGMA+1,M )
            CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, RCOND,
     $                   SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU),
     $                   DWORK(JWORK), INFO )
            WRKOPT = MAX( WRKOPT, JWORK + 3*( M-SIGMA ) - 1 )
C
C           Apply the column permutations to B and part of D.
C
            CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL),
     $                   LDABCD, IWORK )
C
            IF ( RANK.GT.0 ) THEN
C
C              Apply the Householder transformations to the submatrix C.
C              Workspace: need   min(P,M) + N.
C                         prefer min(P,M) + N*NB.
C
               CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK,
     $                      ABCD(IROW,ICOL), LDABCD, DWORK(ITAU),
     $                      ABCD(IROW,MP1),  LDABCD, DWORK(JWORK),
     $                      LDWORK-JWORK+1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
               CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO,
     $                      ZERO, ABCD(MIN( PN, IROW+1 ),ICOL), LDABCD )
               RO1 = RO1 - RANK
            END IF
         END IF
C
C        Terminate if Dr has maximal row rank.
C
         IF( RO1.EQ.0 )
     $      GO TO 30
C
      END IF
C
C     Update SIGMA.
C
      SIGMA  = PR - RO1
C
      NBLCKS = NBLCKS + 1
      TAUI   = RO1
C
      IF ( NR.LE.0 ) THEN
         PR   = SIGMA
         RANK = 0
      ELSE
C
C        Compress the columns of C using RQ factorization with row
C        pivoting, P * C = R * Q.
C        The current C is the TAUI-by-NR matrix delimited by rows
C        IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD.
C        The rank of the current C is computed in MUI.
C        Workspace: need   min(P,N) + 3*P-1.
C        Int.work.  need   P.
C
         IRC   = NR  + SIGMA
         I1    = IRC + 1
         MNTAU = MIN( TAUI, NR )
         JWORK = ITAU + MNTAU
C
         CALL MB03PY( TAUI, NR, ABCD(I1,MP1), LDABCD, RCOND, SVLMAX,
     $                RANK, SVAL, IWORK, DWORK(ITAU), DWORK(JWORK),
     $                INFO )
         WRKOPT = MAX( WRKOPT, JWORK + 3*TAUI - 1 )
C
         IF ( RANK.GT.0 ) THEN
            IROW = I1 + TAUI - RANK
C
C           Apply Q' to the first NR columns of [A; C1] from the right.
C           Workspace: need   min(P,N) +  N + SIGMA; SIGMA <= P;
C                      prefer min(P,N) + (N + SIGMA)*NB.
C
            CALL DORMRQ( 'Right', 'Transpose', IRC, NR, RANK,
     $                   ABCD(IROW,MP1), LDABCD, DWORK(MNTAU-RANK+1),
     $                   ABCD(1,MP1), LDABCD, DWORK(JWORK),
     $                   LDWORK-JWORK+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C           Apply Q to the first NR rows and M + NR columns of [ B  A ]
C           from the left.
C           Workspace: need   min(P,N) +  M + N;
C                      prefer min(P,N) + (M + N)*NB.
C
            CALL DORMRQ( 'Left', 'NoTranspose', NR, MNR, RANK,
     $                   ABCD(IROW,MP1), LDABCD, DWORK(MNTAU-RANK+1),
     $                   ABCD, LDABCD, DWORK(JWORK), LDWORK-JWORK+1,
     $                   INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
            CALL DLASET( 'Full', RANK, NR-RANK, ZERO, ZERO,
     $                   ABCD(IROW,MP1), LDABCD )
            IF ( RANK.GT.1 )
     $         CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO,
     $                      ABCD(IROW+1,MP1+NR-RANK), LDABCD )
         END IF
      END IF
C
   20 CONTINUE
      MUI = RANK
      NR  = NR    - MUI
      PR  = SIGMA + MUI
C
C     Set number of left Kronecker blocks of order (i-1)-by-i.
C
      KRONL(NBLCKS) = TAUI - MUI
C
C     Set number of infinite divisors of order i-1.
C
      IF( FIRST .AND. NBLCKS.GT.1 )
     $   INFZ(NBLCKS-1) = MUIM1 - TAUI
      MUIM1 = MUI
      RO    = MUI
C
C     Continue reduction if rank of current C is positive.
C
      IF( MUI.GT.0 )
     $   GO TO 10
C
C     Determine the maximal degree of infinite zeros and the number of
C     infinite zeros.
C
   30 CONTINUE
      IF( FIRST ) THEN
         IF( MUI.EQ.0 ) THEN
            DINFZ = MAX( 0, NBLCKS - 1 )
         ELSE
            DINFZ = NBLCKS
            INFZ(NBLCKS) = MUI
         END IF
         K = DINFZ
C
         DO 40 I = K, 1, -1
            IF( INFZ(I).NE.0 )
     $         GO TO 50
            DINFZ = DINFZ - 1
   40    CONTINUE
C
   50    CONTINUE
C
         DO 60 I = 1, DINFZ
            NINFZ = NINFZ + INFZ(I)*I
   60    CONTINUE
C
      END IF
C
C     Determine the maximal order of left elementary Kronecker blocks.
C
      NKRONL = NBLCKS
C
      DO 70 I = NBLCKS, 1, -1
         IF( KRONL(I).NE.0 )
     $      GO TO 80
         NKRONL = NKRONL - 1
   70 CONTINUE
C
   80 CONTINUE
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of AB08NY ***
      END


PROGRAM  Cubes
!  IMPLICIT   NONE

   INTEGER, PARAMETER :: Iterations = 10
   INTEGER            :: i
   REAL               :: x

   DO i = 1, Iterations
      x = i
      WRITE(*,*)  i, x, rntCube(i)
   END DO

! If contains is used then intCube(i) will not have an implicitly defined return type!
! contains
END PROGRAM  Cubes

INTEGER  FUNCTION  intCube(Number)
   IMPLICIT   NONE

   INTEGER, INTENT(IN) :: Number

   intCube = Number*Number*Number
END FUNCTION  intCube


module mod_initgrid
  use mod_param, only:pi
  use mod_types
  implicit none
  private
  public initgrid
  contains
  subroutine initgrid(inivel,n,gr,lz,dzc,dzf,zc,zf)
    !
    ! initializes the non-uniform grid in z
    !
    implicit none
    character(len=3), intent(in) :: inivel
    integer , intent(in) :: n
    real(rp), intent(in) :: gr,lz
    real(rp), intent(out), dimension(0:n+1) :: dzc,dzf,zc,zf
    real(rp) :: z0
    integer :: k
    procedure (), pointer :: gridpoint => null()
    select case(inivel)
    case('zer','log','poi','cou')
      gridpoint => gridpoint_cluster_two_end
    case('hcl','hcp')
      gridpoint => gridpoint_cluster_one_end
    case default
      gridpoint => gridpoint_cluster_two_end
    end select
    !
    ! step 1) determine coordinates of cell faces zf
    !
    do k=1,n
      z0  = (k-0.)/(1.*n)
      call gridpoint(gr,z0,zf(k))
      zf(k) = zf(k)*lz
    enddo
    zf(0) = 0.
    !
    ! step 2) determine grid spacing between faces dzf
    !
    do k=1,n
      dzf(k) = zf(k)-zf(k-1)
    enddo
    dzf(0  ) = dzf(1)
    dzf(n+1) = dzf(n)
    !
    ! step 3) determine grid spacing between centers dzc
    !
    do k=0,n
      dzc(k) = .5*(dzf(k)+dzf(k+1))
    enddo
    dzc(n+1) = dzc(n)
    !
    ! step 4) compute coordinates of cell centers zc and faces zf
    !
    zc(0)    = -dzc(0)/2.
    zf(0)    = 0.
    do k=1,n+1
      zc(k) = zc(k-1) + dzc(k-1)
      zf(k) = zf(k-1) + dzf(k)
    enddo
    return
  end subroutine initgrid
  !
  ! grid stretching functions
  ! see e.g., Fluid Flow Phenomena -- A Numerical Toolkit, by P. Orlandi
  !           Pirozzoli et al. JFM 788, 614–639 (commented)
  !
  subroutine gridpoint_cluster_two_end(alpha,z0,z)
    !
    ! clustered at the two sides
    !
    implicit none
    real(rp), intent(in) :: alpha,z0
    real(rp), intent(out) :: z
    if(alpha.ne.0.) then
      z = 0.5*(1.+tanh((z0-0.5)*alpha)/tanh(alpha/2.))
      !z = 0.5*(1.+erf( (z0-0.5)*alpha)/erf( alpha/2.))
    else
      z = z0
    endif
    return
  end subroutine gridpoint_cluster_two_end
  subroutine gridpoint_cluster_one_end(alpha,z0,z)
    !
    ! clustered at the lower side
    !
    implicit none
    real(rp), intent(in) :: alpha,z0
    real(rp), intent(out) :: z
    if(alpha.ne.0.) then
      z = 1.0*(1.+tanh((z0-1.0)*alpha)/tanh(alpha/1.))
      !z = 1.0*(1.+erf( (z0-1.0)*alpha)/erf( alpha/1.))
    else
      z = z0
    endif
    return
  end subroutine gridpoint_cluster_one_end
  subroutine gridpoint_cluster_middle(alpha,z0,z)
    !
    ! clustered in the middle
    !
    implicit none
    real(rp), intent(in) :: alpha,z0
    real(rp), intent(out) :: z
    if(alpha.ne.0.) then
      if(    z0.le.0.5) then
        z = 0.5*(1.-1.+tanh(2.*alpha*(z0-0.))/tanh(alpha))
        !z = 0.5*(1.-1.+erf( 2.*alpha*(z0-0.))/erf( alpha))
      elseif(z0.gt.0.5) then
        z = 0.5*(1.+1.+tanh(2.*alpha*(z0-1.))/tanh(alpha))
        !z = 0.5*(1.+1.+erf( 2.*alpha*(z0-1.))/erf( alpha))
      endif
    else
      z = z0
    endif
    return
  end subroutine gridpoint_cluster_middle
end module mod_initgrid


! { dg-do run }

module task_dep5_mod
contains
  subroutine matmul_depend (N, BS, A, B, C)
     implicit none
     integer :: N, BS, BM
     real, dimension(N, N) :: A, B, C
     integer :: i, j, k, ii, jj, kk
     BM = BS - 1
     do i = 1, N, BS
        do j = 1, N, BS
           do k = 1, N, BS
  !$omp task shared(A,B,C) private(ii,jj,kk) & ! I,J,K are firstprivate by default
  !$omp depend ( in: A(i:i+BM, k:k+BM), B(k:k+BM, j:j+BM) ) &
  !$omp depend ( inout: C(i:i+BM, j:j+BM) )
              do ii = i, i+BM
                 do jj = j, j+BM
                    do kk = k, k+BM
                       C(jj,ii) = C(jj,ii) + A(kk,ii) * B(jj,kk)
                    end do
                 end do
              end do
  !$omp end task
           end do
        end do
     end do
  end subroutine

  subroutine matmul_ref (N, A, B, C)
     implicit none
     integer :: N
     real, dimension(N, N) :: A, B, C
     integer :: i, j, k
     do i = 1, N
       do j = 1, N
         do k = 1, N
             C(j,i) = C(j,i) + A(k,i) * B(j,k)
         end do
       end do
     end do
  end subroutine

  subroutine check (N, A, B)
    integer :: N
    integer :: i, j
    real, parameter :: EPS = 0.000001
    real, dimension(N,N) :: A, B
    real :: diff
    do i = 1, N
      do j = 1, N
        diff = A(i, j) - B(i, j)
        if (diff > EPS .or. -diff > EPS) then
          call abort ()
        end if
      end do
    end do
  end subroutine

  subroutine init (N, A, B)
    integer :: N
    integer :: i, j, s
    real, dimension(N,N) :: A, B
    s = -1
    do i = 1, N
      do j = 1, N
        A(i, j) = i*j*s
        B(i, j) = i+j
        s = -s
      end do
    end do
  end subroutine

  subroutine zero_init (N, A, B)
    integer :: N
    integer :: i, j
    real, dimension(N,N) :: A, B
    do i = 1, N
      do j = 1, N
        A(i, j) = 0
        B(i, j) = 0
      end do
    end do
  end subroutine

end module

program main
  use task_dep5_mod
  real, dimension(32, 32) :: A, B, C, C_ref

  call init (32, A, B)
  call zero_init (32, C, C_ref)

  call matmul_depend(32, 4, A, B, C)
  call matmul_ref(32, A, B, C_ref)

  call check (32, C, C_ref)

end program


!*****************************************************************************************
!> author: Jacob Williams
!
!  Halo Orbit generation example (Earth-Moon system).
!
!@note Requires pyplot-fortran module.

    program halo_test

    use fortran_astrodynamics_toolkit
    use pyplot_module
    use halo_orbit_module

    implicit none

    real(wp),parameter :: mu_earth = 398600.436233_wp    !! \( \mu_{Earth} ~ (\mathrm{km}^3/\mathrm{s}^2) \)
    real(wp),parameter :: mu_moon  = 4902.800076_wp      !! \( \mu_{Moon}  ~ (\mathrm{km}^3/\mathrm{s}^2) \)
    real(wp),parameter :: em_distance = 384400.0_wp      !! earth-moon distance [km]

    real(wp),parameter :: A_z = 1000.0_wp   !! halo z-amplitude
    integer,parameter  :: sol_family = 1    !! 1 or 3 (family)
    real(wp),parameter :: t1 = 0.0_wp       !! tau for halo orbit

    integer,parameter  :: n  = 6            !! number of state variables
    real(wp),parameter :: t0 = 0.0_wp       !! initial time (normalized)
    real(wp),parameter :: tmax = 1000.0_wp  !! max final time (normalized)
    real(wp),parameter :: dt = 0.001_wp     !! time step (normalized)

    real(wp),parameter :: tol    = 1.0e-8_wp !! tolerance for event finding
    real(wp),parameter :: xtol   = 1.0e-6_wp !! tolerance for [[hybrd]]
    integer,parameter  :: maxfev = 1000      !! max number of function evaluations for [[hybrd]]

    !< initial state (normalized)
    real(wp),dimension(:),allocatable   :: x_crtbp,y_crtbp,z_crtbp
    real(wp),dimension(:),allocatable   :: x_vec
    real(wp),dimension(:),allocatable   :: y_vec
    real(wp),dimension(:,:),allocatable :: c_mat
    real(wp),dimension(2)   :: xy_L4,xy_L5
    real(wp),dimension(2)   :: x_vy0,vx_vzf
    real(wp),dimension(n)   :: x0
    real(wp)                :: mu    !! CRTPB parameter
    real(wp)                :: c     !! CRTPB Jacobi constant
    type(rk8_10_class)      :: prop  !! integrator
    real(wp),dimension(n)   :: xf    !! final state
    type(pyplot)            :: plt   !! for making the plot
    real(wp),dimension(6)   :: x0_km,x1
    real(wp),dimension(6)   :: x_zvc
    integer                 :: i,j,nx,ny
    real(wp)                :: x,y,gf,tf_actual
    real(wp)                :: x_L1,x_L2,x_L3
    integer                 :: info
    real(wp)                :: Az
    integer                 :: libpoint !! libration point
    real(wp)                :: period   !! halo orbit period
    integer                 :: istat

    character(len=1),dimension(4),parameter :: colors = ['r','g','b','k']  !! line colors for plots

    !for zero-velocity countours:
    real(wp),parameter  :: xmin  = -2.0_wp
    real(wp),parameter  :: xmax  = 2.0_wp
    real(wp),parameter  :: xstep = 0.01_wp
    real(wp),parameter  :: ymin  = -2.0_wp
    real(wp),parameter  :: ymax  = 2.0_wp
    real(wp),parameter  :: ystep = 0.01_wp

    ! get the halo orbit initial guess using the analytic approximation:
    libpoint = 2 ! L2 point
    call halo_to_rv(libpoint,mu_earth,mu_moon,em_distance,A_z,sol_family,t1,x0)

    call unnormalize_variables(mu_earth,mu_moon,em_distance,x_crtbp=x0,x=x0_km)

    write(*,*) ''
    write(*,*) ' initial guess in km,km/s: '
    write(*,'(*(F30.16,1X))') x0_km
    write(*,*) ''

    !compute the CRTBP parameter & Jacobi constant:
    mu = compute_crtpb_parameter(mu_earth,mu_moon)
    c  = compute_jacobi_constant(mu,x0)

    ! !*************************************************
    ! !compute the zero velocity surface for this c

    !Just get the number of elements by counting...
    i=0
    nx=0
    do
        i=i+1
        x = xmin + (i-1)*xstep
        if (x>xmax) exit
        nx = nx + 1
    end do
    j=0
    ny=0
    do
        j=j+1
        y = ymin + (j-1)*ystep
        if (y>ymax) exit
        ny = ny + 1
    end do

    !size the arrays:
    allocate(x_vec(nx))
    allocate(y_vec(ny))
    allocate(c_mat(nx,ny))

    !compute the jacobi constant for each combo:
    do i = 1, nx
        x = xmin + (i-1)*xstep
        x_vec(i) = x
        do j = 1, ny
            y = ymin + (j-1)*ystep
            if (i==1) y_vec(j) = y
            x_zvc(1:3) = [x,y,zero]
            x_zvc(4:6) = zero
            c_mat(i,j) = compute_jacobi_constant(mu,x_zvc)
        end do
    end do

    !*************************************************
    !compute the libration point locations:

    call compute_libration_points(mu,x_L1,x_L2,x_L3,xy_L4,xy_L5)

    write(*,*) ''
    write(*,*) 'mu:  ', mu
    write(*,*) 'Jacobi constant:  ', c
    write(*,*) 'x_L1:', x_L1
    write(*,*) 'x_L2:', x_L2
    write(*,*) 'x_L3:', x_L3
    write(*,*) ''
    write(*,*) 'x_moon :', 1.0_wp - mu
    write(*,*) 'x_earth:', -mu

    !*************************************************
    !integrate initial guess:

    write(*,*) ''
    write(*,*) ' Halo Initial Guess'
    write(*,*) ''
    write(*,*) 't0=',t0
    write(*,*) 'r0=',x0(1:3)
    write(*,*) 'v0=',x0(4:6)

    call prop%initialize(n,func,report,x_axis_crossing)
    call prop%integrate_to_event(t0,x0,dt,tmax,tol,tf_actual,xf,gf)

    write(*,*) ''
    write(*,*) 'tf=',tf_actual
    write(*,*) 'rf=',xf(1:3)
    write(*,*) 'vf=',xf(4:6)

    !plot the 2D trajectory, zero-velocity curves, and libration point locations:
    call plt%initialize(grid=.true.,xlabel='x',ylabel='y',&
                            title='Halo Initial Guess',legend=.false.,figsize=[10,10],&
                            use_numpy=.true.,axis_equal=.true.,mplot3d=.true.)

    !trajectory:
    call plt%add_3d_plot(x_crtbp,y_crtbp,z_crtbp,label='trajectory',linestyle='b-',linewidth=2,istat=istat)
    !bodies:
    call plt%add_3d_plot([-mu],[zero],[zero], label='B1',linestyle='bo',markersize=5,linewidth=5,istat=istat)
    call plt%add_3d_plot([1.0_wp-mu],[zero],[zero], label='B2',linestyle='ko',markersize=5,linewidth=5,istat=istat)
    !libration point locations:
    call plt%add_3d_plot([x_L1],[zero],[zero], label='L1',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    call plt%add_3d_plot([x_L2],[zero],[zero], label='L2',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    call plt%add_3d_plot([x_L3],[zero],[zero], label='L3',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    !zero-velocity curve (for this jacobi constant):
    call plt%add_contour(x_vec, y_vec, c_mat, label='zero velocity curve', &
                           linestyle='-', linewidth=2, &
                           levels=[c], color='r',istat=istat)
    call plt%savefig('halo_guess.png',pyfile='halo_guess.py',istat=istat)
    call plt%destroy()

    !-------------------------------------------
    !
    !  solve for a Halo using HYBRD
    !

    write(*,*) ''
    write(*,*) 'solve for halo...'

    !turn off integration reporting for iterations:
    call prop%destroy()
    call prop%initialize(n,func,g=x_axis_crossing)

    !initialize the plot:
    call plt%initialize(grid=.true.,xlabel='x',ylabel='y',&
                            title='Earth-Moon Halo Orbits',&
                            legend=.false.,figsize=[10,10],&
                            use_numpy=.true.,axis_equal=.true.,&
                            mplot3d=.true.)

    ! see also: http://ccar.colorado.edu/asen5050/projects/projects_2012/bezrouk/Mission%20Analysis.html

    do libpoint=1,2 ! libration point L1, L2, L3
        do i=1,10

            Az = A_z+(i-1)*1000.0_wp  ! in km
            !Az = A_z+(i-1)*10000.0_wp  ! in km  - for L3 cases

            call prop%destroy()
            call prop%initialize(n,func,g=x_axis_crossing)

            call halo_to_rv(libpoint,mu_earth,mu_moon,em_distance,&
                            Az,sol_family,t1,x0,period=period)
            if (period==zero) cycle

            write(*,*) ''
            write(*,*) ' r0=',x0(1:3)
            write(*,*) ' v0=',x0(4:6)

            if (allocated(x_crtbp)) then ! clear these for new trajectory
                deallocate(x_crtbp)
                deallocate(y_crtbp)
                deallocate(z_crtbp)
            end if

            !now, solve for a halo:
            ! [note: we could also use the STM for better derivatives here....]
            x_vy0 = [x0(1),x0(5)]
            call hybrd1(halo_fcn,2,x_vy0,vx_vzf,tol=xtol,info=info)
            write(*,*) ''
            write(*,*) ' info=',info
            write(*,*) ' Az =',Az
            write(*,*) ' x0 =',x_vy0(1)
            write(*,*) ' vy0=',x_vy0(2)
            write(*,*) ' vxf=',vx_vzf(1)
            write(*,*) ' vzf=',vx_vzf(2)

            !now plot solution:
            call prop%initialize(n,func,report,g=x_axis_crossing)
            x1    = x0
            x1(1) = x_vy0(1)  !solution from hybrd
            x1(5) = x_vy0(2)  !solution from hybrd
            !integrate one full rev (two x-axis crossings):
            call prop%integrate_to_event(t0,x1,dt,tmax,tol,tf_actual,xf,gf)  !1/2 rev
            call prop%integrate_to_event(t0,xf,dt,tmax,tol,tf_actual,x1,gf)  !1 rev

            write(*,*) 'period: ', 2.0_wp * tf_actual

            !plot the 3D trajectory:
            call plt%add_3d_plot(x_crtbp,y_crtbp,z_crtbp,label='solution',&
                                linestyle=colors(1+mod(i,size(colors)))//'-',linewidth=2,istat=istat)

        end do
    end do

    !also plot the libration point locations:
    call plt%add_3d_plot([x_L1],[zero],[zero], label='L1',linestyle='rx',markersize=4,linewidth=3,istat=istat)
    call plt%add_3d_plot([x_L2],[zero],[zero], label='L2',linestyle='rx',markersize=4,linewidth=3,istat=istat)
    !call plt%add_3d_plot([x_L3],[zero],[zero], label='L3',linestyle='rx',markersize=3,linewidth=3,istat=istat)
    !call plt%add_3d_plot([-mu],[zero],[zero], label='B1',linestyle='bo',markersize=5,linewidth=5,istat=istat)
    call plt%add_3d_plot([1.0_wp-mu],[zero],[zero], label='B2',linestyle='ko',markersize=5,linewidth=5,istat=istat)
    call plt%savefig('halos.png',pyfile='halos.py',istat=istat)
    call plt%destroy()

    contains

!**************************************************************************
    subroutine halo_fcn(n,xvec,fvec,iflag)  !! Halo function for [[hybrd1]]

    implicit none

    integer,intent(in)                :: n      !! `n=2` in this case
    real(wp),dimension(n),intent(in)  :: xvec   !! x_vy0
    real(wp),dimension(n),intent(out) :: fvec   !! [vxf,vzf]
    integer,intent(inout)             :: iflag

    real(wp) :: gf,t0
    real(wp),dimension(6) :: x,x1,xf

    real(wp),parameter :: tol = 1.0e-8_wp !! event finding tolerance

    t0   = zero    ! epoch doesn't matter for crtbp
    x    = x0      ! initial guess state
    x(1) = xvec(1) ! x0
    x(5) = xvec(2) ! vy0

    !integrate to the next x-axis crossing:
    call prop%integrate_to_event(t0,x,dt,tmax,tol,tf_actual,xf,gf)

    !want x and z-velocity at the x-axis crossing to be zero:
    fvec = [xf(4),xf(6)]

    end subroutine halo_fcn
!**************************************************************************

!**************************************************************************
    subroutine func(me,t,x,xdot)  !! CRTBP derivative function
    implicit none
    class(rk_class),intent(inout)        :: me
    real(wp),intent(in)                  :: t
    real(wp),dimension(me%n),intent(in)  :: x
    real(wp),dimension(me%n),intent(out) :: xdot

    call crtbp_derivs(mu,x,xdot)

    end subroutine func
!**************************************************************************

!**************************************************************************
    subroutine x_axis_crossing(me,t,x,g)  !! x-axis crossing event function
    implicit none
    class(rk_class),intent(inout)        :: me
    real(wp),intent(in)                  :: t
    real(wp),dimension(me%n),intent(in)  :: x
    real(wp),intent(out)                 :: g

    g = x(2)  ! y = 0 at x-z-plane crossing

    end subroutine x_axis_crossing
!**************************************************************************

!**************************************************************************
    subroutine report(me,t,x)  !! report function

    implicit none

    class(rk_class),intent(inout)       :: me
    real(wp),intent(in)                 :: t
    real(wp),dimension(me%n),intent(in) :: x

    !write(*,'(*(F30.16,1X))') t, x, compute_jacobi_constant(mu,x)

    if (allocated(x_crtbp)) then   ! uses Fortran 2008 auto LHS reallocations
        x_crtbp  = [x_crtbp, x(1)]
        y_crtbp  = [y_crtbp, x(2)]
        z_crtbp  = [z_crtbp, x(3)]
    else
        x_crtbp  = [x(1)]
        y_crtbp  = [x(2)]
        z_crtbp  = [x(3)]
    end if

    end subroutine report
!**************************************************************************

    end program halo_test
!*****************************************************************************************


C Copyright 2021 Dennis Decker Jensen
C Date: 9 May 2021
C Purpose: Prime number test
C Tectonics: gfortran --std=f95 -ffixed-form -c primetest.f
      LOGICAL FUNCTION PRIME(NUM)
         IROOT = INT(SQRT(REAL(NUM)))

         DO 10 I=2,IROOT
            IF (MOD(NUM,I).EQ.0) THEN
               PRIME=.FALSE.
               RETURN
            ENDIF
   10    CONTINUE
         PRIME=.TRUE.
      END


program matrix_clip_zero
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    implicit none
    integer, parameter :: m = 3, n = 3
    real(kind=dp), dimension(m, n) :: A = reshape([  3.0,  1.0,  4.0, &
                                                    -3.0, -0.5, -2.0, &
                                                    -0.5,  2.0, -1.0 ], [m, n])
    integer :: i

    do i = 1, m
        print *, A(i, :)
    end do
    call clip_zeros(A, 1.0_dp)
    print *, 'clipped'
    do i = 1, m
        print *, A(i, :)
    end do

contains

    subroutine clip_zeros(A, epsilon)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64
        implicit none
        real(kind=dp), dimension(:, :), intent(inout) :: A
        real(kind=dp), intent(in) :: epsilon
        where (abs(A) < epsilon)
            A = 0.0_dp
        end where
    end subroutine clip_zeros

end program matrix_clip_zero


module solvergmres_module

  implicit none

contains

  !===================================================
  subroutine findnorm(norm,v1,n)

    integer,intent(in) :: n
    real*8,intent(in) :: v1(n)
    real*8, intent(out) :: norm

    integer :: i

    norm=0.d0

    do i=1,n
       norm=norm+v1(i)*v1(i)
    enddo

    norm=sqrt(norm)

  end subroutine findnorm
  !===================================================
  subroutine innerproduct(v1dotv2,v1,v2,n)

    integer, intent(in) :: n
    real*8, intent(in) :: v1(n),v2(n)
    real*8, intent(out) :: v1dotv2

    integer :: i

    v1dotv2=0.d0

    do i=1,n
       v1dotv2=v1dotv2+v1(i)*v2(i)
    enddo

  end subroutine innerproduct
  !===================================================
  subroutine arnoldialgorithm(v1,m,n,Hmat,kspvecs,findAX,precond,lucky)

		  integer,intent(in) :: m,n
		  real*8,intent(in) :: v1(n)
		  real*8, intent(inout) :: Hmat(m+1,m)
		  real*8, intent(inout) :: kspvecs(n,m+1)
		  logical,intent(inout) :: lucky

		  external :: findAX
		  external :: precond

		  real*8 :: Avj(n)
		  real*8 :: MinvAvj(n)
		  real*8 :: wj(n)
		  real*8 :: vi(n),vj(n)
		  integer :: i,j,k

		  kspvecs(:,1)=v1
		  lucky = .false.

		  do j=1,m

	  	        vj = kspvecs(:,j)

			call findAX(Avj,vj,n)
			call precond(MinvAvj,Avj,n)

			do i=1,j
				vi = kspvecs(:,i)
				call innerproduct(Hmat(i,j),MinvAvj,vi,n)
			enddo

			wj=MinvAvj

			do i=1,j
				vi = kspvecs(:,i)
				wj=wj-Hmat(i,j)*vi
			enddo

			call findnorm(Hmat(j+1,j),wj,n)

			if(Hmat(j+1,j) > 0.d0) then
				kspvecs(:,j+1)=wj(:)/Hmat(j+1,j)
			else
				lucky=.true.
			endif
		enddo

  end subroutine arnoldialgorithm
  !===================================================
  subroutine leastsquaresminimize(y,Hmat,m,beta)

		  integer,intent(in)   :: m
		  real*8,intent(inout) :: Hmat(m+1,m)
		  real*8,intent(out)   :: y(m)
		  real*8,intent(in)    :: beta

		  real*8 :: c,s,h_up,h_down,dtr
		  real*8 :: val1,val2
		  real*8 :: beta_e1(m+1)

		  integer :: i,j

		  beta_e1(:) = 0.d0
		  beta_e1(1) = beta;

		  do i=1,m

		  	h_up   = Hmat(i,i)
			h_down = Hmat(i+1,i)

			dtr = sqrt(h_up*h_up+h_down*h_down)

			c = h_up/dtr
			s = h_down/dtr

			do j=1,m

				h_up   = Hmat(i,j)
				h_down = Hmat(i+1,j)

				Hmat(i,j)   =  c*h_up  + s*h_down
				Hmat(i+1,j) = -s*h_up  + c*h_down

			enddo

			val1 =  c*beta_e1(i)  + s*beta_e1(i+1);
			val2 = -s*beta_e1(i)  + c*beta_e1(i+1);

			beta_e1(i)   = val1
			beta_e1(i+1) = val2
		enddo

		y(m) = beta_e1(m)/Hmat(m,m)

		do i=m-1,1,-1

			y(i)=beta_e1(i)

			do j=i+1,m
				y(i)=y(i)-Hmat(i,j)*y(j)
			enddo

			y(i) = y(i)/Hmat(i,i)

		enddo

  end subroutine leastsquaresminimize
  !===================================================
  subroutine performgmres(b,x0,x,m,n,nrestarts,findAX,precond)

		  integer,intent(in) :: m,n,nrestarts
		  real*8, intent(in) :: b(n),x0(n)
		  real*8, intent(out) :: x(n)
		  external :: findAX, precond

		  integer :: i,j,k

		  real*8 :: r0(n)
		  real*8 :: Minvr0(n)
		  real*8 :: Ax0(n),Ax(n)
		  real*8 :: r(n),v1(n)
		  real*8 :: beta
		  real*8 :: y(m)

		  real*8 :: kspvectors(n,m+1)
		  real*8 :: Hmat(m+1,m)

		  real*8 :: eps

		  logical :: lucky

		  call findAX(Ax0,x0,n)
		  r0 = b-Ax0
		  call precond(Minvr0,r0,n)
		  r=Minvr0
		  x=x0

		  Hmat       = 0.d0
		  kspvectors = 0.d0
		  lucky      = .false.
		  eps        = 1e-6

		  do i=1,nrestarts

		  	call findnorm(beta,r,n)
			print *,"restart iteration:",i,"residual norm:",beta

			if(beta .le. eps) then
				exit
			endif

			v1=r/beta

  			call arnoldialgorithm(v1,m,n,Hmat,kspvectors,findAX,precond,lucky)

			if(lucky .eqv. .true.) then
				print *,"lucky condition"
				exit
			endif

  			call leastsquaresminimize(y,Hmat,m,beta)

			do j=1,m
				x=x+y(j)*kspvectors(:,j)
			enddo

			call findAX(Ax,x,n)
			r=b-Ax
			call precond(Minvr0,r,n)
			r=Minvr0
		enddo

  end subroutine performgmres
  !===================================================

end module solvergmres_module


PROGRAM PolynomialBasisMappingTest

  USE KindModule, ONLY: &
    DP, TwoPi
  USE UtilitiesModule, ONLY: &
    NodeNumber, &
    WriteVector, &
    WriteMatrix
  USE ProgramHeaderModule, ONLY: &
    nNodes, nNodesE, nNodesX, nDOF, nDOFX, &
    nDims, nDimsX
  USE QuadratureModule, ONLY: &
    InitializeQuadratures, &
    GetQuadrature
  USE PolynomialBasisModule_Lagrange, ONLY: &
    InitializePolynomialBasis_Lagrange, &
    EvalL
  USE PolynomialBasisModule_Legendre, ONLY: &
    InitializePolynomialBasis_Legendre, &
    EvalP
  USE PolynomialBasisMappingModule, ONLY: &
    InitializePolynomialBasisMapping, &
    MapNodalToModal_Radiation, &
    MapModalToNodal_Radiation

  IMPLICIT NONE

  INTEGER :: iNodeE, iNodeX1, iNodeX2, iNodeX3, iNode
  INTEGER :: iPointE, iPointX1
  INTEGER, PARAMETER :: nPointsE = 64, nPointsX1 = 64
  REAL(DP), PARAMETER :: eL = - 0.5_DP, eR = + 0.5_DP
  REAL(DP), PARAMETER :: xL = - 0.5_DP, xR = + 0.5_DP
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: U, U_2, C, C_2
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: NodesE,  WeightsE
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: NodesX1, WeightsX1
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: NodesX2, WeightsX2
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: NodesX3, WeightsX3
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: PointsE
  REAL(DP), DIMENSION(:),   ALLOCATABLE :: PointsX1
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: U_2D_L, U_2_2D_L
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: U_2D_P, U_2_2D_P

  nNodes     = 4
  nNodesE    = nNodes
  nNodesX(1) = nNodes
  nNodesX(2) = 1
  nNodesX(3) = 1
  nDOFX      = PRODUCT( nNodesX )
  nDOF       = nDOFX * nNodesE
  nDimsX     = 1
  nDims      = 2

  CALL InitializeQuadratures

  CALL InitializePolynomialBasis_Lagrange

  CALL InitializePolynomialBasis_Legendre

  ALLOCATE( U(nDOF), U_2(nDOF), C(nDOF), C_2(nDOF) )
  ALLOCATE( NodesE(nNodesE),     WeightsE(nNodesE) )
  ALLOCATE( NodesX1(nNodesX(1)), WeightsX1(nNodesX(1)) )
  ALLOCATE( NodesX2(nNodesX(2)), WeightsX2(nNodesX(2)) )
  ALLOCATE( NodesX3(nNodesX(3)), WeightsX3(nNodesX(3)) )
  ALLOCATE( U_2D_L(nPointsE,nPointsX1), U_2_2D_L(nPointsE,nPointsX1) )
  ALLOCATE( U_2D_P(nPointsE,nPointsX1), U_2_2D_P(nPointsE,nPointsX1) )

  CALL GetQuadrature( nNodesE,    NodesE,  WeightsE )
  CALL GetQuadrature( nNodesX(1), NodesX1, WeightsX1 )
  CALL GetQuadrature( nNodesX(2), NodesX2, WeightsX2 )
  CALL GetQuadrature( nNodesX(3), NodesX3, WeightsX3 )

  CALL InitializePolynomialBasisMapping &
         ( NodesE, NodesX1, NodesX2, NodesX3 )

  DO iNodeX3 = 1, nNodesX(3)
    DO iNodeX2 = 1, nNodesX(2)
      DO iNodeX1 = 1, nNodesX(1)
        DO iNodeE = 1, nNodesE

          iNode = NodeNumber( iNodeE, iNodeX1, iNodeX2, iNodeX3 )

          U(iNode) = COS( TwoPi * ( eL - NodesE(iNodeE) ) ) &
                     * SIN( TwoPi * ( xL - NodesX1(iNodeX1) ) )

        END DO
      END DO
    END DO
  END DO

  CALL MapNodalToModal_Radiation( U, C )

  ! --- Damp Higher Modal Coefficients ---

  C_2(1)      = C(1)
  C_2(2:nDOF) = 0.9_DP * C(2:nDOF)

  CALL MapModalToNodal_Radiation( U_2, C_2 )

  ALLOCATE( PointsE(nPointsE) )
  DO iPointE = 1, nPointsE
    PointsE(iPointE) &
      = eL + REAL(iPointE-1)/REAL(nPointsE-1)
  END DO

  ALLOCATE( PointsX1(nPointsX1) )
  DO iPointX1 = 1, nPointsX1
    PointsX1(iPointX1) &
      = xL + REAL(iPointX1-1)/REAL(nPointsX1-1)
  END DO

  DO iPointX1 = 1, nPointsX1
    DO iPointE = 1, nPointsE

      U_2D_L(iPointE,iPointX1) &
        = EvalL( U, PointsE(iPointE), PointsX1(iPointX1), 0.0_DP, 0.0_DP )

      U_2D_P(iPointE,iPointX1) &
        = EvalP( C, PointsE(iPointE), PointsX1(iPointX1), 0.0_DP, 0.0_DP )

      U_2_2D_L(iPointE,iPointX1) &
        = EvalL( U_2, PointsE(iPointE), PointsX1(iPointX1), 0.0_DP, 0.0_DP )

      U_2_2D_P(iPointE,iPointX1) &
        = EvalP( C_2, PointsE(iPointE), PointsX1(iPointX1), 0.0_DP, 0.0_DP )

    END DO
  END DO

  CALL WriteVector( nPointsE,  PointsE,  'E.dat' )
  CALL WriteVector( nPointsX1, PointsX1, 'X.dat' )
  CALL WriteVector( nDOF, U, 'U.dat' )
  CALL WriteVector( nDOF, C, 'C.dat' )
  CALL WriteMatrix( nPointsE, nPointsX1, U_2D_L,   'U_2D_L.dat' )
  CALL WriteMatrix( nPointsE, nPointsX1, U_2D_P,   'U_2D_P.dat' )
  CALL WriteMatrix( nPointsE, nPointsX1, U_2_2D_L, 'U_2_2D_L.dat' )
  CALL WriteMatrix( nPointsE, nPointsX1, U_2_2D_P, 'U_2_2D_P.dat' )

  DEALLOCATE( U, U_2, C, C_2 )
  DEALLOCATE( NodesE,  WeightsE )
  DEALLOCATE( NodesX1, WeightsX1 )
  DEALLOCATE( NodesX2, WeightsX2 )
  DEALLOCATE( NodesX3, WeightsX3 )
  DEALLOCATE( U_2D_L, U_2_2D_L )
  DEALLOCATE( U_2D_P, U_2_2D_P )
  DEALLOCATE( PointsE )
  DEALLOCATE( PointsX1 )

END PROGRAM PolynomialBasisMappingTest


! { dg-do run }
! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } }

  use, intrinsic :: ieee_features
  use, intrinsic :: ieee_arithmetic
  implicit none

  ! k1 and k2 will be large real kinds, if supported, and single/double
  ! otherwise
  integer, parameter :: k1 = &
    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
  integer, parameter :: k2 = &
    max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))

  interface check_equal
    procedure check_equal1, check_equal2
  end interface

  interface check_not_equal
    procedure check_not_equal1, check_not_equal2
  end interface

  interface divide
    procedure divide1, divide2
  end interface

  real(kind=k1) :: x1, x2, x3
  real(kind=k2) :: y1, y2, y3
  type(ieee_round_type) :: mode

  if (ieee_support_rounding(ieee_up, x1) .and. &
      ieee_support_rounding(ieee_down, x1) .and. &
      ieee_support_rounding(ieee_nearest, x1) .and. &
      ieee_support_rounding(ieee_to_zero, x1)) then

    x1 = 1
    x2 = 3
    x1 = divide(x1, x2, ieee_up)

    x3 = 1
    x2 = 3
    x3 = divide(x3, x2, ieee_down)
    call check_not_equal(x1, x3)
    call check_equal(x3, nearest(x1, -1._k1))
    call check_equal(x1, nearest(x3,  1._k1))

    call check_equal(1._k1/3._k1, divide(1._k1, 3._k1, ieee_nearest))
    call check_equal(-1._k1/3._k1, divide(-1._k1, 3._k1, ieee_nearest))

    call check_equal(divide(3._k1, 7._k1, ieee_to_zero), &
                    divide(3._k1, 7._k1, ieee_down))
    call check_equal(divide(-3._k1, 7._k1, ieee_to_zero), &
                    divide(-3._k1, 7._k1, ieee_up))

  end if

  if (ieee_support_rounding(ieee_up, y1) .and. &
      ieee_support_rounding(ieee_down, y1) .and. &
      ieee_support_rounding(ieee_nearest, y1) .and. &
      ieee_support_rounding(ieee_to_zero, y1)) then

    y1 = 1
    y2 = 3
    y1 = divide(y1, y2, ieee_up)

    y3 = 1
    y2 = 3
    y3 = divide(y3, y2, ieee_down)
    call check_not_equal(y1, y3)
    call check_equal(y3, nearest(y1, -1._k2))
    call check_equal(y1, nearest(y3,  1._k2))

    call check_equal(1._k2/3._k2, divide(1._k2, 3._k2, ieee_nearest))
    call check_equal(-1._k2/3._k2, divide(-1._k2, 3._k2, ieee_nearest))

    call check_equal(divide(3._k2, 7._k2, ieee_to_zero), &
                    divide(3._k2, 7._k2, ieee_down))
    call check_equal(divide(-3._k2, 7._k2, ieee_to_zero), &
                    divide(-3._k2, 7._k2, ieee_up))

  end if

contains

  real(kind=k1) function divide1 (x, y, rounding) result(res)
    use, intrinsic :: ieee_arithmetic
    real(kind=k1), intent(in) :: x, y
    type(ieee_round_type), intent(in) :: rounding
    type(ieee_round_type) :: old

    call ieee_get_rounding_mode (old)
    call ieee_set_rounding_mode (rounding)

    res = x / y

    call ieee_set_rounding_mode (old)
  end function

  real(kind=k2) function divide2 (x, y, rounding) result(res)
    use, intrinsic :: ieee_arithmetic
    real(kind=k2), intent(in) :: x, y
    type(ieee_round_type), intent(in) :: rounding
    type(ieee_round_type) :: old

    call ieee_get_rounding_mode (old)
    call ieee_set_rounding_mode (rounding)

    res = x / y

    call ieee_set_rounding_mode (old)
  end function

  subroutine check_equal1 (x, y)
    real(kind=k1), intent(in) :: x, y
    if (x /= y) then
      print *, x, y
      STOP 1
    end if
  end subroutine

  subroutine check_equal2 (x, y)
    real(kind=k2), intent(in) :: x, y
    if (x /= y) then
      print *, x, y
      STOP 2
    end if
  end subroutine

  subroutine check_not_equal1 (x, y)
    real(kind=k1), intent(in) :: x, y
    if (x == y) then
      print *, x, y
      STOP 3
    end if
  end subroutine

  subroutine check_not_equal2 (x, y)
    real(kind=k2), intent(in) :: x, y
    if (x == y) then
      print *, x, y
      STOP 4
    end if
  end subroutine

end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
MODULE monter_carlo
IMPLICIT NONE
      INTEGER (KIND=8),PARAMETER :: nx=10,ny=10,nz=10,nT=21,n_average=5000
      REAL (KIND=8),PARAMETER :: Tmin=2.0,Tmax=6.0
      INTEGER (KIND=8) :: iT,i,j,k,i_loop,im,ip,jm,jp,km,kp
      REAL    (KIND=8) :: T,delT,rdn_mtp,real_na
      REAL    (KIND=8) :: E_tmp1,E_tmp2,energy,energy_2,E_av,E_2_av,Cv,S_tmp,M,M_av

      REAL    (KIND=8),DIMENSION(0:nx+1,0:ny+1,0:nz+1) :: S

      CONTAINS

!!!=======================================================================================
!!!=======================================================================================
      SUBROUTINE average_thermal()
      IMPLICIT NONE

      CALL ini_rdm_number()

      real_na=real(nx*ny*nz)

      S(:,:,:)=0.
      S(1:nx,1:ny,1:nz)=1.

      E_av=0.  ; E_2_av=0. ; M_av=0.

      DO i_loop=1,n_average
            CALL value_thermal()
            E_av=E_av+energy
            E_2_av=E_2_av+energy_2
            M_av=M_av+M
      END DO

      E_av=E_av/real(n_average)
      E_2_av=E_2_av/real(n_average)
      M_av=M_av/real(n_average)
      Cv = real_na*(E_2_av-E_av**2.)/(T**2.)

      END SUBROUTINE average_thermal

!!!=======================================================================================
!!!=======================================================================================
      SUBROUTINE ini_rdm_number()
      IMPLICIT NONE

      INTEGER (KIND=8),DIMENSION(8) :: time
      INTEGER (KIND=8),DIMENSION(50) :: seed

      CALL DATE_AND_TIME(values=time)     ! Get the current time
      seed(1) = time(4)*(360000*time(5) + 6000*time(6) + 100*time(7) + time(8))
      CALL RANDOM_SEED(PUT=seed)

      END SUBROUTINE ini_rdm_number

!!!=======================================================================================
!!!=======================================================================================
      SUBROUTINE value_thermal()
      IMPLICIT NONE

      energy=0.

      DO i=1,nx
      ip=i+1
      im=i-1
      DO j=1,ny
      jp=j+1
      jm=j-1
      DO k=1,nz
      kp=k+1
      km=k-1

      E_tmp1=-S(i,j,k)*(S(ip,j,k)+S(im,j,k)+S(i,jp,k)+S(i,jm,k)+S(i,j,kp)+S(i,j,km))
      E_tmp2=-E_tmp1
      S_tmp=S(i,j,k)

            CALL random_number(rdn_mtp)
            IF (exp(-(E_tmp2-E_tmp1)/T) > rdn_mtp) THEN
                  S(i,j,k)=-S_tmp
                  E_tmp1=E_tmp2
            END IF
            energy=energy+E_tmp1
            M=M+S(i,j,k)
      END DO
      END DO
      END DO

      energy=energy/(2.*real_na)
      energy_2=energy**2.
      M=abs(M)/real_na

      END SUBROUTINE value_thermal

END MODULE monter_carlo

!!!=======================================================================================
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
      PROGRAM main_ising
      USE monter_carlo
      IMPLICIT NONE

      CALL system('rm CPU_result.dat')
!!!---------------------------------------------------------------------

      IF (nT==1) THEN
            delT=0.
      ELSE
            delT=(Tmax-Tmin)/real(nT-1)
      END IF

      OPEN(unit=20,file='CPU_result.dat')

      DO iT=1,nT
            WRITE(*,*)'iT = ', iT
            T=Tmin+delT*real(iT-1)
            CALL average_thermal()
            WRITE(20,*) T,E_av,M_av,Cv
            !WRITE(*,*) T,E_av,M_av,Cv
      END DO

      CLOSE(20)

!!!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

      END PROGRAM main_ising


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

PROGRAM eigs_test

    USE LA, only: EIGS
    USE OUTPUT, only: print_real_matrix

    INTEGER, PARAMETER :: d = 2

    REAL*8, dimension(d,d) :: A
    REAL*8, dimension(d,d) :: V
    REAL*8, dimension(d) :: l

    A(1,:) = (/-1.53866, -0.515838/)
    A(2,:) = (/-0.515838, -2.43973/)

    CALL EIGS(d,A,V,l)

    WRITE(*,*) "Matrix A"
    CALL print_real_matrix(d,d,A)

    WRITE(*,*) "Matrix V"
    CALL print_real_matrix(d,d,V)

    WRITE(*,*) "Vector l"
    CALL print_real_matrix(d,1,l)

END PROGRAM eigs_test


program ch0810
    ! Rank 1 Array and the Sum Intrinsic Function
    implicit none

    integer, parameter :: n = 12
    real :: total = 0., average = 0.
    real, dimension(1:n) :: rainfall = &
        [ 3.1, 2., 2.4, 2.1, 2.2, 2.2, 1.8, 2.2, 2.7, 2.9, 3.1, 3.1 ]

    total = sum(rainfall)
    average = total/n
    print *, ' Average monthly rainfall was'
    print *, average
end program


PROGRAM stress_test_nested_implied_do
  ! Test that a nested implied do loop can be used to initialize an array.
  ! Array constructors, and implicit DO loops are detailed in sec. 7.8
  ! of the Standard.
  IMPLICIT NONE
  INTEGER, PARAMETER :: n=4
  INTEGER, PARAMETER :: m=10
  INTEGER, PARAMETER :: o=2
  INTEGER, PARAMETER :: p=3
  INTEGER :: i, j, k, l

  ! 1 level of nesting
  INTEGER :: array1(n) = (/ (i, i=1, n) /)
  INTEGER :: expect1(n)
  data expect1/1, 2, 3, 4/

  ! 2 levels of nesting
  INTEGER :: array2(m) = (/ ((i, j=1, i), i=1, n ) /)
  INTEGER :: expect2(m)
  data expect2/1, 2, 2, 3, 3, 3, 4, 4, 4, 4/

  ! 3 levels of nesting
  INTEGER :: array3(m*o) = (/ (((i, j=1, i), i=1,n ), k=1, o) /)
  INTEGER :: expect3(m*o)
  data expect3/1, 2, 2, 3, 3, 3, 4, 4, 4, 4, 1, 2, 2, 3, 3, 3, 4, 4, 4, 4/

  ! 4 levels of nesting
  INTEGER :: array4(m*o*p) = (/ ((((i, j=1, i), i=1,n ), k=1, o), l=1, p) /)
  INTEGER :: expect4(m*o*p)
  data expect4/1, 2, 2, 3, 3, 3, 4, 4, 4, 4, 1, 2, 2, 3, 3, 3, 4, 4, 4, 4,&
               1, 2, 2, 3, 3, 3, 4, 4, 4, 4, 1, 2, 2, 3, 3, 3, 4, 4, 4, 4,&
               1, 2, 2, 3, 3, 3, 4, 4, 4, 4, 1, 2, 2, 3, 3, 3, 4, 4, 4, 4/

  ! 3 levels of nesting and multiple items
  INTEGER :: array5(3*m*o) = (/ (((i, i+10, i+100, j=1, i), i=1,n ), k=1, o) /)
  INTEGER :: expect5(3*m*o)
  data expect5/1, 11, 101,&
               2, 12, 102, 2, 12, 102,&
               3, 13, 103, 3, 13, 103, 3, 13, 103,&
               4, 14, 104, 4, 14, 104, 4, 14, 104, 4, 14, 104,&
               1, 11, 101,&
               2, 12, 102, 2, 12, 102,&
               3, 13, 103, 3, 13, 103, 3, 13, 103,&
               4, 14, 104, 4, 14, 104, 4, 14, 104, 4, 14, 104/

  INTEGER(KIND=1) :: i8, j8   ! TY_BINT
  INTEGER(KIND=2) :: i16, j16 ! TY_SINT
  INTEGER(KIND=4) :: i32, j32 ! TY_INT
  INTEGER(KIND=8) :: i64, j64 ! TY_INT8

  ! Different integers fitting into each other
  ! Array contents are intentionally oversized to show that a warning rather than an error is thrown

  INTEGER(KIND=1) :: array_i1_i1(6) = (/ ((256_1, j8=1_1, i8), i8=1_1, 3_1 ) /)
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 61}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 61}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 61}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 61}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 61}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 61}
  INTEGER(KIND=1) :: array_i1_i2(6) = (/ ((257_2, j16=1_2, i16), i16=1_2, 3_2 ) /)
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 68}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 68}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 68}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 68}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 68}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 68}
  INTEGER(KIND=1) :: array_i1_i4(6) = (/ ((257_4, j32=1_4, i32), i32=1_4, 3_4 ) /)
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 75}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 75}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 75}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 75}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 75}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 75}
  INTEGER(KIND=1) :: array_i1_i8(6) = (/ ((257_8, j64=1_8, i64), i64=1_8, 3_8 ) /)

  INTEGER(KIND=2) :: array_i2_i1(6) = (/ ((256_1, j8=1_1, i8), i8=1_1, 3_1 ) /)
  INTEGER(KIND=2) :: array_i2_i2(6) = (/ ((65536_2, j16=1_2, i16), i16=1_2, 3_2 ) /)
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 85}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 85}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 85}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 85}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 85}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 85}
  INTEGER(KIND=2) :: array_i2_i4(6) = (/ ((65537_4, j32=1_4, i32), i32=1_4, 3_4 ) /)
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 92}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 92}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 92}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 92}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 92}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 92}
  INTEGER(KIND=2) :: array_i2_i8(6) = (/ ((65537_8, j64=1_8, i64), i64=1_8, 3_8 ) /)

  INTEGER(KIND=4) :: array_i4_i1(6) = (/ ((256_1, j8=1_1, i8), i8=1_1, 3_1 ) /)
  INTEGER(KIND=4) :: array_i4_i2(6) = (/ ((65536_2, j16=1_2, i16), i16=1_2, 3_2 ) /)
  INTEGER(KIND=4) :: array_i4_i4(6) = (/ ((4294967296_4, j32=1_4, i32), i32=1_4, 3_4 ) /)
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 103}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 103}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 103}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 103}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 103}
  !{warning "PGF90-W-0128-Integer constant truncated to fit data type: 1" 103}
  INTEGER(KIND=4) :: array_i4_i8(6) = (/ ((4294967297_8, j64=1_8, i64), i64=1_8, 3_8 ) /)

  INTEGER(KIND=8) :: array_i8_i1(6) = (/ ((256_1, j8=1_1, i8), i8=1_1, 3_1 ) /)
  INTEGER(KIND=8) :: array_i8_i2(6) = (/ ((65536_2, j16=1_2, i16), i16=1_2, 3_2 ) /)
  INTEGER(KIND=8) :: array_i8_i4(6) = (/ ((4294967296_4, j32=1_4, i32), i32=1_4, 3_4 ) /)
  INTEGER(KIND=8) :: array_i8_i8(6) = (/ ((4294967297_8, j64=1_8, i64), i64=1_8, 3_8 ) /)

  ! Integers initializing real arrays

  REAL(KIND=4) :: array_r4_i1(6) = (/ ((256_1, j8=1_1, i8), i8=1_1, 3_1 ) /)
  REAL(KIND=4) :: array_r4_i2(6) = (/ ((65536_2, j16=1_2, i16), i16=1_2, 3_2 ) /)
  REAL(KIND=4) :: array_r4_i4(6) = (/ ((4294967296_4, j32=1_4, i32), i32=1_4, 3_4 ) /)
  REAL(KIND=4) :: array_r4_i8(6) = (/ ((4294967297_8, j64=1_8, i64), i64=1_8, 3_8 ) /)

  REAL(KIND=8) :: array_r8_i1(6) = (/ ((256_1, j8=1_1, i8), i8=1_1, 3_1 ) /)
  REAL(KIND=8) :: array_r8_i2(6) = (/ ((65536_2, j16=1_2, i16), i16=1_2, 3_2 ) /)
  REAL(KIND=8) :: array_r8_i4(6) = (/ ((4294967296_4, j32=1_4, i32), i32=1_4, 3_4 ) /)
  REAL(KIND=8) :: array_r8_i8(6) = (/ ((4294967297_8, j64=1_8, i64), i64=1_8, 3_8 ) /)

  call check(array1, expect1, n)
  call check(array2, expect2, m)
  call check(array3, expect3, m*o)
  call check(array4, expect4, m*o*p)
  call check(array5, expect5, 3*m*o)

END PROGRAM stress_test_nested_implied_do


! This routine propagates forward the inputs through a rectangular Artificial
! Neural Network, and returns the result at the output nodes.
! W(l, i, j) represents the synaptic strength from neuron j in the
! layer l-1 to neuron i in layer l. Beta(l, i) is the bias added to the signal
! in neuron i, layer l. nonlin(l) is an integer vector whose elements are 0
! if l is a linear layer, or 1 if l is a non-linear layer (tanh is then used
! as activation function). input and output are the inputs and outputs vectors,
! of size ninputs and noutputs, respectively. nperlayer is the number of
! neurons per layer and nlayers is the number of layers (note: the input
! is _NOT_ considered a layer). If the keyword Y is present, the
! neuron values are returned.
!
! Note that nmaxperlayer _MUST BE_ larger than both ninputs and noutputs!!
!
Subroutine ANN_forward(W, Beta, Nonlin, Input, Output, nlayers, &
     nmaxperlayer, nperlayer, ninputs, noutputs, y)
Implicit None
Real (Kind=8), Parameter :: a=1.7159, b=0.666666, bovera=0.388523, asq=2.94431
!Real (Kind=8), Parameter :: a=1., b=1., bovera=1., asq=1.
Integer :: nlayers, nmaxperlayer, ninputs, noutputs, i, j, k, l
Integer, Dimension(nlayers) :: Nonlin
Integer, Dimension(0:nlayers) :: nperlayer
Real (Kind=8), Dimension(nlayers, nmaxperlayer, nmaxperlayer) :: W
Real (Kind=8), Dimension(0:nlayers, nmaxperlayer) :: y
Real (Kind=8), Dimension(nlayers, nmaxperlayer) :: Beta
Real (Kind=8), Dimension(ninputs) :: Input
Real (Kind=8), Dimension(noutputs) :: Output
!
! Set input values
!
y(0, 1:ninputs)=Input(1:ninputs)
!
! Propagate forward
!
Do l=1, nlayers
!
! Do the matrix multiplications using the intrinsic F90 function
!
!   y(l, 1:nperlayer(l))=Matmul(W(l, 1:nperlayer(l), 1:nperlayer(l-1)), &
!        y(l-1, 1:nperlayer(l-1)))+Beta(l, 1:nperlayer(l))
!
! Spell out the matrix multiplications (some compilers have trouble
!    optimizing this function)
!
   Do j=1, nperlayer(l)
      y(l, j)=0.
      Do k=1, nperlayer(l-1)
         y(l, j)=y(l, j)+W(l, j, k)*y(l-1, k)
      End do
      y(l, j)=y(l, j)+Beta(l, j)
   End do
!
   If (Nonlin(l) .ne. 0) & ! It's a non-linear layer
        y(l, 1:nperlayer(l))=a*Tanh(b*y(l, 1:nperlayer(l)))
End do
!
! Network output
!
Output(1:noutputs)=y(nlayers, 1:noutputs)
!
! Done
!
Return
!
End Subroutine ANN_forward


module user_interface

	use rhs
	implicit none

	! file name : general system parameters
	character (len = 20) :: filename1, filename2, filename3

	!inital conditions

contains

	subroutine read_inputfile()

	    implicit none
	    integer :: i, j, numb_dx
        double precision :: dpg1, segmag1, dpg2, segmag2, dp_same, &
                            sum_ync, fi, delta_dp, dp1, dp2

        dpg1 = 1e-9
        segmag1 = 1.2
        dpg2 = 3e-9
        segmag2 = 1.2
        dp_same = 1.7321e-9 !the same diameter for bi-lognormal distribution

        numb_dx = 100

	    open(unit = 1234, file = "input.txt", status ="old")

	        !reading info from file
            read(1234,*)flag
	        read(1234,*)n_discrete
	        read(1234,*)mw, rho, dp0
            v0 = (pi/6)*(dp0)**3

            !allocate(nc0(n_discrete))
	        !allocate(nc(n_discrete))
	        allocate(ync(n_discrete))
            allocate(dp_dis(n_discrete)) !Huang Zhang, 2018
		    allocate(atol(n_discrete))

		    neq = n_discrete

            do i = 1, n_discrete

              dp_dis(i) = (i*v0*6.0/PI)**(1.0/3)
              if (dp_dis(i) > dp_same) then

                fi = get_lognormal(dp_dis(i)*1e+9, dpg2*1e+9, segmag2)
                dp1 = dp_dis(i)*1e+9 !nm
                dp2 = ((i+1)*v0*6.0/PI)**(1.0/3)*1e+9 !nm
                ync(i) = get_prob_lognormal(dp1, dp2, numb_dx, dpg2*1e+9, segmag2)

              else

                fi = get_lognormal(dp_dis(i)*1e+9, dpg1*1e+9, segmag1)
                dp1 = dp_dis(i)*1e+9 !nm
                dp2 = ((i+1)*v0*6.0/PI)**(1.0/3)*1e+9 !nm
                ync(i) = get_prob_lognormal(dp1, dp2, numb_dx, dpg1*1e+9, segmag1)

              end if

            end do
            !ync(1:n_discrete) = 0.0
            !ync(1) = 1.0
            sum_ync = sum(ync)

            write(*,*)'dp_dis(end) = (nm)'
            write(*, '(D12.4)') dp_dis(n_discrete)*1e+9

		    read(1234,*)N_infi_0
            read(1234,*) tf
            read(1234,*) dt
            read(1234,*) N_track_min

            atol(1:n_discrete) = 0.1*N_track_min/N_infi_0
            !rtol = 10**-(log10(N_infi_0/N_track_min) + 1)
            rtol = 10**(-(log10(N_infi_0/N_track_min) + 1))

	    close(unit = 1234)

    end subroutine read_inputfile

    function get_lognormal(x, x0, sg0)

      implicit none

      double precision :: get_lognormal
      double precision, intent (in) :: x, x0, sg0
      get_lognormal = 1/((2*PI)**0.5*x*log(sg0))* &
                      exp(-(log(x)-log(x0))**2/(2*(log(sg0))**2))
      return

    end function get_lognormal

    function get_prob_lognormal(x_begin, x_end, numb_dx, x0, sg0)

      implicit none
      integer :: i_dx
      integer, intent (in) :: numb_dx
      double precision, intent (in) :: x_begin, x_end, x0, sg0
      double precision :: get_prob_lognormal, x1, x2, dx
      dx = (x_end - x_begin)/numb_dx

      get_prob_lognormal = 0.
      x1 = x_begin
      do i_dx = 1, numb_dx

        x2 = x1 + dx
        get_prob_lognormal = get_prob_lognormal + (get_lognormal(x2, x0, sg0) + get_lognormal(x1, x0, sg0))*dx/2
        x1 = x2

      end do

      return

    end function get_prob_lognormal

end module user_interface

!program test_user_interface
!    use user_interface
!    implicit none
!
!    call read_inputfile()
!    print*, nc0
!
!end program test_user_interface


program langtons_ant
  implicit none

  integer,        parameter :: dp   = selected_real_kind(15,300)
  real(kind=dp),  parameter :: pi   = 3.1415926535897932_dp

  integer,  parameter                   :: grid_size  = 100
  integer,  dimension(:,:), allocatable :: grid
  integer,  dimension(3)                :: ant        = (/ grid_size/2, grid_size/2, 0 /)
  integer                               :: i

  allocate(grid(1:grid_size, 1:grid_size))
  grid = 1 !Grid initially white

  do
    grid(ant(1) , ant(2)) = -grid(ant(1) , ant(2))      ! Flip the color of the current square
    ant(3) = modulo(ant(3) + grid(ant(1),ant(2)),4)     ! Rotate the ant depending on the current square
    ant(1) = ant(1) + nint( sin(ant(3) * pi / 2.0_dp) ) ! Move the ant in x
    ant(2) = ant(2) + nint( cos(ant(3) * pi / 2.0_dp) ) ! Move the ant in y

    !exit if the ant is outside the grid
    if (((ant(1) < 1) .or. (ant(1) > grid_size)) .or. ((ant(2) < 1) .or. (ant(2) > grid_size))) exit

  end do

  !Print out the final grid
  open(unit=21, file="ant.dat")
  do i = 1, grid_size
    write(21,*) int(grid(:,i) + 1 / 2.0_dp)
  end do
  close(21)

  deallocate(grid)

end program langtons_ant


!==============================================================================!
  subroutine Compute_Eigenvalues(a,n,np,d,v,nrot)
!------------------------------------------------------------------------------!
  implicit none
!-----------------------------------[Locals]-----------------------------------!
  integer, parameter :: NMAX=500
  integer            :: n,np,nrot
  integer            :: i,ip,iq,j
  real               :: a(np,np),d(np),v(np,np)
  real               :: c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX)
!------------------------------------------------------------------------------!
!   Uses Jacobi algorithm to computes eigenvalues and eigenvectors of a real   !
!   symmetric matrix a, which is of size n by n, stored in a physical np by    !
!   np array. On output, elements of a above the diagonal are destroyed.       !
!   d returns the eigenvalues of a in its  rst n elements. v is a matrix with  !
!   the same logical and physical dimensions as a, whose columns contain, on   !
!   output, the normalized eigenvectors of a. nrot returns the number of       !
!   Jacobi rotations that were required.                                       !
!==============================================================================!

  do ip=1,n     ! initialize to the identity matrix.
    do iq=1,n
      v(ip,iq)=0.
    end do
    v(ip,ip)=1.
  end do

  do ip=1,n
    b(ip)=a(ip,ip) ! initialize b and d to the diagonal of a.
    d(ip)=b(ip)
    z(ip)=0.       ! this vector will accumulate terms of the form
                   ! tapq as in equation (11.1.14).
  end do

  nrot=0
  do i=1,50

    sm=0.
    do ip=1,n-1  ! sum o -diagonal elements.
      do iq=ip+1,n
        sm=sm+abs(a(ip,iq))
      end do
    end do
    if(sm.eq.0.) return  ! the normal return, which relies on quadratic
                         ! convergence to machine under ow.
    if(i.lt.4) then
      tresh=0.2*sm/n**2  ! ...on the  rst three sweeps.
    else
      tresh=0.           ! ...thereafter.
    endif

    do ip=1,n-1
      do iq=ip+1,n
        g=100.*abs(a(ip,iq))     ! after four sweeps, skip the rotation if the
                                 ! offdiagonal element is small.
        if((i.gt.4).and.(abs(d(ip))+g.eq.abs(d(ip))) &
           .and.(abs(d(iq))+g.eq.abs(d(iq)))) then
          a(ip,iq)=0.
        else if(abs(a(ip,iq)).gt.tresh) then
          h=d(iq)-d(ip)
          if(abs(h)+g.eq.abs(h)) then
            t=a(ip,iq)/h         ! t = 1/(2 theta)
          else
            theta=0.5*h/a(ip,iq) ! equation (11.1.10).
            t=1./(abs(theta)+sqrt(1.+theta**2))
            if(theta.lt.0.) t=-t
          endif
          c=1./sqrt(1+t**2)
          s=t*c
          tau=s/(1.+c)
          h=t*a(ip,iq)
          z(ip)=z(ip)-h
          z(iq)=z(iq)+h
          d(ip)=d(ip)-h
          d(iq)=d(iq)+h
          a(ip,iq)=0.
          do j=1,ip-1     ! case of rotations 1   j <p.
            g=a(j,ip)
            h=a(j,iq)
            a(j,ip)=g-s*(h+g*tau)
            a(j,iq)=h+s*(g-h*tau)
          end do
          do j=ip+1,iq-1  ! case of rotations p <j<q.
            g=a(ip,j)
            h=a(j,iq)
            a(ip,j)=g-s*(h+g*tau)
            a(j,iq)=h+s*(g-h*tau)
          end do
          do j=iq+1,n     ! case of rotations q <j   n.
            g=a(ip,j)
            h=a(iq,j)
            a(ip,j)=g-s*(h+g*tau)
            a(iq,j)=h+s*(g-h*tau)
          end do
          do j=1,n
            g=v(j,ip)
            h=v(j,iq)
            v(j,ip)=g-s*(h+g*tau)
            v(j,iq)=h+s*(g-h*tau)
          end do
          nrot=nrot+1
        endif
      end do
    end do

    do ip=1,n
      b(ip)=b(ip)+z(ip)
      d(ip)=b(ip)          ! update d with the sum of tapq, z(ip)=0.
                           ! and reinitialize z.
    end do
  end do

  write(*,*) '# Too many Jacobi iterations in Compute_Eigenvalues'

  return

  end subroutine Compute_Eigenvalues


module solv_m
use constants_m!, rp => rsp
implicit none

logical,private,save::pri_lin_eqn=.true.

contains

subroutine lin_eqns_solver(a_ij,phi,rhs,norm,ja,ia,n_iter,reduc,isol,id)
  use matrix_utils_m
  use vector_utils_m

  real(rp),dimension(:), intent(in)::a_ij
  real(rp),dimension(:), intent(inout)::phi
  real(rp),dimension(:), intent(inout)::rhs
  real(rp), intent(inout)::norm
  real(rp), intent(in)::reduc
  integer,dimension(:), intent(in)::ja,ia
  integer, intent(in)::n_iter
  integer, intent(in)::isol,id

  select case(isol)
  case(1)
    call cg_solver(a_ij,phi,rhs,norm,ja,ia,n_iter,reduc)
  case (2)
    call bicg_solver(a_ij,phi,rhs,norm,ja,ia,n_iter,reduc)
  end select
end subroutine

subroutine cg_solver(a_ij,phi,res,norm,ja,ia,n_iter,reduc)
  use constants_m
  use matrix_utils_m
  use vector_utils_m

  real(rp),dimension(:), intent(in)::a_ij
  real(rp),dimension(:), intent(inout)::phi
  real(rp),dimension(:), intent(inout)::res
  real(rp), intent(inout)::norm
  real(rp), intent(in)::reduc
  integer,dimension(:), intent(in)::ja,ia
  integer, intent(in)::n_iter

  real(rp),dimension(size(ia)-1,6)::wk
  real(rp),dimension(6)::cof
  real(rp)::norm0
  integer,parameter::p=1
  integer::i,kii,j,kij,kji,iter

  ! calculate residual vector and norm
  call csr_matvec_prod(a_ij,phi,ja,ia,wk(:,1))
  res=res-wk(:,1)
  norm=p_norm(res,p)
  norm0=norm

  ! calculate preconditioning vector: C = M^{-1}
  call preconditioner(a_ij,ja,ia,wk(:,6))

  ! cof: res_n=1 alpha=2 beta=3 s=4
  cof=0; cof(4)=large

  ! wk: res=1 p=2 z=3
  wk(:,1)=res
  wk(:,2:3)=0

  ! iterate:
  do iter=1,n_iter
    cof(1)=0

    ! solve: M z = res
    call direct_solve(a_ij,wk(:,6),wk(:,1),ja,ia,wk(:,3))

    ! beta = 1 / s
    cof(3)=one/(cof(4)+small)

    ! s = p.dot.z
    cof(4)=sum(wk(:,1)*wk(:,3))

    ! beta = beta * s
    cof(3)=cof(3)*cof(4)

    ! p = z + beta.p
    wk(:,2)=wk(:,3)+cof(3)*wk(:,2)

    ! calculate: z = A.p
    call csr_matvec_prod(a_ij,wk(:,2),ja,ia,wk(:,3))

    ! alpha = s / p.dot.z
    cof(2)=sum(wk(:,2)*wk(:,3))
    cof(2)=cof(4)/(cof(2)+small)

    ! phi = phi + alpha.p
    ! res = res - alpha.z
    ! res_n = sum |res|
    phi=phi+cof(2)*wk(:,2)
    wk(:,1)=wk(:,1)-cof(2)*wk(:,3)
    norm=p_norm(wk(:,1),p)

    ! res_n = res_n / res0_n
    cof(1)=norm/(norm0+small)
    if(cof(1)<reduc)exit
  end do
end subroutine

subroutine bicg_solver(a_ij,phi,res,norm,ja,ia,n_iter,reduc)
  use constants_m
  use matrix_utils_m
  use vector_utils_m

  real(rp),dimension(:), intent(in)::a_ij
  real(rp),dimension(:), intent(inout)::phi
  real(rp),dimension(:), intent(inout)::res
  real(rp), intent(inout)::norm
  real(rp), intent(in)::reduc
  integer,dimension(:), intent(in)::ja,ia
  integer, intent(in)::n_iter

  real(rp),dimension(size(ia)-1,6)::wk
  real(rp),dimension(6)::cof
  real(rp)::norm0
  integer,parameter::p=1
  integer::i,kii,j,kij,kji,iter,n

  n=size(ia)-1

  ! calculate residual vector and norm
  call csr_matvec_prod(a_ij,phi,ja,ia,wk(:,1))
  res=res-wk(:,1)
  norm=p_norm(res,p)
  norm0=norm

  ! calculate preconditioning vector: C = M^{-1}
  call preconditioner(a_ij,ja,ia,wk(:,6))

  ! initialise workspace scalars:
  ! res_n=1 alpha=2 beta0=3 beta=4 gam=5 omeg=6
  cof=0; cof(2:3)=1; cof(5)=1

  ! initialise workspace vectors:
  ! res=1 p=2 u=3 v=4 z=5
  wk(:,1)=res; wk(:,2:5)=0

  ! iterate:
  do iter=1,n_iter
    cof(1)=0

    ! beta = res.dot.res0
    ! omega = beta.gamma / alpha.beta0
    ! beta0 = beta
    cof(4)=sum(wk(:,1)*res)
    cof(6)=cof(4)*cof(5)/(cof(2)*cof(3)+small)
    cof(3)=cof(4)

    ! p = res + omega.(p - alpha.u)
    do i=1,n
      wk(i,2)=wk(i,1)+cof(6)*(wk(i,2)-cof(2)*wk(i,3))
    end do

    ! solve: M z = p
    call direct_solve(a_ij,wk(:,6),wk(:,2),ja,ia,wk(:,5))

    ! calculate: u = A.z
    call csr_matvec_prod(a_ij,wk(:,5),ja,ia,wk(:,3))

    ! gamma = beta / u.dot.res0
    cof(5)=sum(wk(:,3)*res)
    cof(5)=cof(4)/(cof(5)+small)

    ! phi = phi + gamma.z
    ! res = res - gamma.u
    phi=phi+cof(5)*wk(:,5)
    wk(:,1)=wk(:,1)-cof(5)*wk(:,3)

    ! solve: M z = res
    call direct_solve(a_ij,wk(:,6),wk(:,1),ja,ia,wk(:,5))

    ! calculate:  v = A.z
    call csr_matvec_prod(a_ij,wk(:,5),ja,ia,wk(:,4))

    ! alpha = v.dot.res / v.dot.v
    cof(1:2)=zero
    do i=1,n
      cof(1)=cof(1)+wk(i,4)*wk(i,1)
      cof(2)=cof(2)+(wk(i,4)+small)**2
    end do
    cof(2)=cof(1)/(cof(2)+small)

    ! phi = phi + alpha.z
    ! res = res - alpha.v
    ! res_n = sum |res|
    phi=phi+cof(2)*wk(:,5)
    wk(:,1)=wk(:,1)-cof(2)*wk(:,4)
    norm=p_norm(wk(:,1),p)

    ! res_n = res_n / res0_n
    cof(1)=norm/(norm0+small)
    if(cof(1)<reduc)exit
  end do
end subroutine

subroutine preconditioner(a_ij,ja,ia,c)
  use constants_m
  use matrix_utils_m
  use vector_utils_m

  integer,dimension(:), intent(in)::ja,ia
  real(rp),dimension(:), intent(in)::a_ij

  real(rp),dimension(:), intent(inout)::c
  real(rp)::summ
  integer::i,kii,j,kij,kji,n

  n=size(ia)-1
  do i=1,n
    kii=csr_index(i,i,ja,ia)
    summ=a_ij(kii)

    do kij=ia(i),ia(i+1)-1
      j=ja(kij)
      if(j<i)then
        kji=csr_index(j,i,ja,ia)
        summ=summ-a_ij(kij)*c(j)*a_ij(kji)
      else
        exit
      end if
    end do

    c(i)=one/(summ+small)
  end do
end subroutine

subroutine direct_solve(a_ij,c,b,ja,ia,x)
  use constants_m
  use matrix_utils_m
  use vector_utils_m

  integer,dimension(:), intent(in)::ja,ia
  real(rp),dimension(:), intent(in)::a_ij
  real(rp),dimension(:), intent(in)::c,b

  real(rp),dimension(:), intent(inout)::x
  real(rp)::cof,summ
  integer::i,kii,j,kij,kji,n

  n=size(ia)-1
  do i=1,n
    summ=b(i)

    do kij=ia(i),ia(i+1)-1
      j=ja(kij)
      if(j<i)then
        summ=summ-a_ij(kij)*x(j)
      else
        exit
      end if
    end do
    x(i)=summ*c(i)
  end do

  do i=1,n
    cof=one/(c(i)+small)
    x(i)=cof*x(i)
  end do

  do i=n,1,-1
    summ=x(i)

    do kij=ia(i+1)-1,ia(i),-1
      j=ja(kij)
      if(j>i)then
        summ=summ-a_ij(kij)*x(j)
      else
        exit
      end if
    end do
    x(i)=summ*c(i)
  end do
end subroutine

end module


	FUNCTION XPADC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE DC CHANNEL OF THE WIND X PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA R9,C9,R10,CINP /5.E8, 23.6E-12, 5.E8, 4.37E-12/
	DATA R33,C16 /2.2E+03, 1.203E-9/
	DATA R1C,R2C,CCOMP / 0., 4.64E3, .947E-6/    ! as shown on drawing
C	DATA R1C,R2C,CCOMP / 0., 5.E3, .947E-6/
	DATA R5 /22.1E3/
	DATA TWOPI /6.2831853/
C
C	C16 = 1.203E-9                             ! ADJUSTING EX
C	C9  = 23.6E-12                            ! ADJUSTING EX
C	CINP = 4.37E-12                          ! ADJUSTING EX
C
C	C16 = CVAR(1)
C	C9 = CVAR(2)
C	CINP = CVAR(3)
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C*****************   effect of compensation
C
C	EFFECT OF INPUT (211) BOARD
C
	WCC = W*CCOMP
	Z2 = CMPLX(R2C,-1./WCC)
	Y1 = 1./R5 + 1./(R1C + Z2) + CMPLX(0.,W*C16)
	CGAIN = CGAIN*(Z2/(R1C+Z2))/(1. + R33*Y1)
C*************
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	XPADC = CABS(CGAIN)
	RETURN
	END


Real Function ppk1(srt)
  Real xarray(7), earray(7)
  Save
  Data xarray/0.013, 0.025, 0.016, 0.012, 0.017, 0.029, 0.025/
  Data earray/3.67, 4.95, 5.52, 5.97, 6.05, 6.92, 7.87/
  pmass = 0.9383
  ppk1 = 0.
  If (srt<=2.63) Return
  If (srt>4.08) Then
     ppk1 = 0.025
     Return
  End If
  plab = sqrt(((srt**2-2.*pmass**2)/(2.*pmass))**2-pmass**2)
  If (plab<earray(1)) Then
     ppk1 = xarray(1)
     Return
  End If
  Do ie = 1, 7
     If (earray(ie)==plab) Then
        ppk1 = xarray(ie)
        Goto 10
     Else If (earray(ie)>plab) Then
        ymin = alog(xarray(ie-1))
        ymax = alog(xarray(ie))
        xmin = alog(earray(ie-1))
        xmax = alog(earray(ie))
        ppk1 = exp(ymin+(alog(plab)-xmin)*(ymax-ymin)/(xmax-xmin))
        Goto 10
     End If
  End Do
10 Continue
  Return
End Function ppk1


program constantsex
implicit none
real,parameter :: g = 9.81
real:: s ! displacement
real:: t ! time
real:: u ! initial speed

t = 2.0
u = 10.01

s = u*t -g*(t**2)/2
print*,"time =",t
print*, "displacement =",s
print*,"initial speed =",u
endprogram constantsex


       subroutine sort2(n, ra, rb)
c heap sort real array ra of length n to ascending order,
c and make the corresponding rearrangement to rb.
       implicit none
       integer n, l, ir, i, j
       double precision ra(*), rb(*), xa, xb
       l  = n / 2 + 1
       ir = n
c heap creation phase
c index l is decremented from its initial value down to 1
 10    continue
       if (l.gt.1) then
          l  = l - 1
          xa = ra(l)
          xb = rb(l)
c heap selection phase
c index ir is decremented from its initial value to to 1
       else
          xa = ra(ir)
          xb = rb(ir)
          ra(ir) = ra(1)
          rb(ir) = rb(1)
          ir = ir - 1
          if (ir.eq.1) then
             ra(1) = xa
             rb(1) = xb
             go to 50
          end if
       end if
c sift down xa
       i = l
       j = l + l
 20    continue
       if (j.le.ir) then
c found better low element
          if ((j.lt.ir).and.(ra(j).lt.ra(j+1))) j = j + 1
c demote xa
          if (xa.lt.ra(j)) then
             ra(i) = ra(j)
             rb(i) = rb(j)
             i = j
             j = j + j
          else
             j = ir + 1
          end if
c ends the sift-down
          go to 20
       end if
c restore xa and xb
       ra(i) = xa
       rb(i) = xb
       go to 10
c      return
 50    continue

       return
c  end subroutine sort2
       end
       integer function sort_xy(e, x, n, delta)
c
c check and sort a pair of energy/xmu data to
c ensure that energy is monotonically increasing
c
c returns 0 for data that needs no sort or rearrangement
c         1 if sorting or rearrangement were needed

       implicit none
       double precision e(*), x(*), de, delta, dm
       integer n, i, k, j
       logical sort, near

       near = .false.
       sort = .false.
cc       print*, ' in sort_xy '
c first, look for problems
       do 10 i =  1, n-1
          de = e(i+1)-e(i)
          if (de.lt.0)    sort = .true.
 10    continue
c
cc       print*, ' in sort_xy ', sort, near

c if needed, sort
       if (sort) call sort2(n, e, x)
c
c if needed, handle coincident x points
c by slightly incrementing values
       do 100 i =  1, n-1
          de = e(i+1)-e(i)
          if (abs(de).lt.delta) then
             near = .true.
             dm   = delta*10.d0
             if (i .eq. n-1.and.i.ge.2) then
                dm = max(delta,(e(i)-e(i-1))*0.01d0)
             else
                dm = max(delta,(e(i+2)-e(i))*0.01d0)
             endif
             e(i+1) =  e(i) + dm
cc             print*, ' moving energy point ', i, e(i+1)
          endif
 100    continue
       sort_xy = 0
       if (sort.or.near) sort_xy = 1
       return
       end


module maths
use hamiltonian_types
implicit none
contains

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Jacobi diagonalization of a symmetric real matrix
!----------------------------------------------------------------------
!----------------------------------------------------------------------

	subroutine jacobi(a,d,v,nrot)
		real(kind=8) :: a(:,:), d(:), v(:,:)
		integer :: nrot

		integer :: i, ip, iq, j, n
		real(kind=8) :: c, g, h, s, sm, t, tau, theta, thres, b(size(d)), z(size(d))

		n = size(d)

		v = 0.d0
		do i = 1, n
			v(i,i) = 1.d0
		enddo

		do ip = 1, n
			b(ip) = a(ip,ip)
			d(ip) = b(ip)
			z(ip) = 0.d0
		enddo

		nrot = 0

		do i = 1, 50
			sm = 0.d0
			do ip = 1, n-1
				do iq = ip+1,n
					sm = sm + abs(a(ip,iq))
				enddo
			enddo
			if (sm == 0.d0) return
			if (i < 4) then
				thres = 0.2d0 * sm / n**2
			else
				thres = 0.d0
			endif
			do ip = 1, n-1
				do iq = ip+1,n
					g = 100.d0 * abs(a(ip,iq))
					if ( (i>4) .and. (abs(d(ip))+g == abs(d(ip))) .and. (abs(d(iq))+g == abs(d(iq))) ) then
						a(ip,iq) = 0.d0
					else if (abs(a(ip,iq)) > thres ) then
						h = d(iq) - d(ip)
						if (abs(h)+g == abs(h)) then
							t = a(ip,iq) / h
						else
							theta = 0.5d0 * h / a(ip,iq)
							t = 1.d0 / (abs(theta)+sqrt(1.d0+theta**2))
							if (theta < 0.d0) t = -t
						endif
						c = 1.d0 / sqrt(1.d0+t**2)
						s = t*c
						tau = s / (1.d0+c)
						h = t * a(ip,iq)
						z(ip) = z(ip)-h
						z(iq) = z(iq)+h
						d(ip) = d(ip)-h
						d(iq) = d(iq)+h
						a(ip,iq) = 0.d0
						do j = 1, ip-1
							g = a(j,ip)
							h = a(j,iq)
							a(j,ip) = g - s*(h+g*tau)
							a(j,iq) = h + s*(g-h*tau)
						enddo
						do j = ip+1, iq-1
							g = a(ip,j)
							h = a(j,iq)
							a(ip,j) = g - s*(h+g*tau)
							a(j,iq) = h + s*(g-h*tau)
						enddo
						do j = iq+1, n
							g = a(ip,j)
							h = a(iq,j)
							a(ip,j) = g - s*(h+g*tau)
							a(iq,j) = h + s*(g-h*tau)
						enddo
						do j = 1, n
							g = v(j,ip)
							h = v(j,iq)
							v(j,ip) = g - s*(h+g*tau)
							v(j,iq) = h + s*(g-h*tau)
						enddo
						nrot = nrot+1
					endif
				enddo
			enddo
			do ip = 1, n
				b(ip) = b(ip)+z(ip)
				d(ip) = b(ip)
				z(ip) = 0.d0
			enddo
		enddo

	end subroutine jacobi

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Wigner 3-j symbol
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function w3js(j1,j2,j3,m1,m2,m3)
		integer :: m1, m2, m3, j1, j2, j3
		integer :: ia, ib, ic, id, ie, im, ig, ih, z, zmin, zmax, jsum
		real(kind=8) :: w3js, denom, cc, cc1, cc2
		complex(kind=8) :: ccc, cccc

      	w3js = 0.d0
      	if (m1+m2+m3 /= 0) goto 1000
      	ia = j1 + j2
      	if (j3 > ia) goto 1000
      	ib = j1 - j2
      	if (j3 < abs(ib)) goto 1000
      	jsum = j3 + ia
      	ic = j1 - m1
      	id = j2 - m2

      	if (abs(m1) > j1) goto 1000
			if (abs(m2) > j2) goto 1000
			if (abs(m3) > j3) goto 1000
			ie = j3 - j2 + m1
			im = j3 - j1 - m2
			zmin = max0(0,-ie,-im)
			ig = ia - j3
			ih = j2 + m2
			zmax = min0(ig,ih,ic)

			ccc = 0.d0
			denom = fact2(zmin/2) + fact2((ig-zmin)/2) + fact2((ic-zmin)/2) + fact2((ih-zmin)/2) + &
					fact2((ie+zmin)/2) + fact2((im+zmin)/2)

			if (mod(zmin,4) /= 0) then
				cccc = -1.d0
				ccc = -denom + log(cccc)
			else
				ccc = -denom
			endif

			do z = zmin+2, zmax, 2
				denom = fact2(z/2) + fact2((ig-z)/2) + fact2((ic-z)/2) + fact2((ih-z)/2) + &
					fact2((ie+z)/2) + fact2((im+z)/2)

				if (mod(z,4) /= 0) then
					ccc = ccc + log(1.d0-exp(-denom-ccc))
				else
					ccc = ccc + log(1.d0+exp(-denom-ccc))
				endif

			enddo
			cc1 = fact2(ig/2) + fact2((j3+ib)/2) + fact2((j3-ib)/2) - fact2((jsum+2)/2)
      		cc2 = fact2((j1+m1)/2) + fact2(ic/2) + fact2(ih/2) + fact2(id/2) + fact2((j3-m3)/2) + fact2((j3+m3)/2)
			ccc = ccc + 0.5d0 * (cc1 + cc2)

			if (real(ccc) < -1.d50) then
				ccc = 0.d0
			else
				ccc = exp(ccc)
			endif

			if (mod(ib-m3,4) /= 0) ccc = -ccc
			w3js = ccc
			if (abs(w3js) < 1.d-8) w3js = 0.d0
1000 		return
      end function w3js

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Initialize factorials
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine factrl
		integer :: i
		real(kind=8), parameter :: PI = 3.14159265359d0
		real(kind=8) :: fact_local

		nfac = 301
		fact_local = 1.d0
		fact2(0) = 0.d0
      	do i=1,nfac
			fact_local = fact_local * i
			if (i < 170) then
				fact2(i) = log(fact_local)
			else
				fact2(i) = 0.5d0 * log(2.d0*PI*i) + i * log(float(i)) - float(i)
			endif
		enddo
	end subroutine factrl

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Initialize factorials
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function delta(a, b)
	real(kind=8) :: a, b, delta
		delta = 0.d0
		if (a == b) delta = 1.d0
	end function delta

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Reverse of a vector
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function reverse(a)
	integer :: a(:), reverse(size(a))
	integer :: n, i
		n = size(a)
		do i = 1, n
			reverse(i) = a(n-i+1)
		enddo
	end function reverse

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Return the number of elements in a vector equal to a given number
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function where_index(a,b,n)
	integer :: n
	real(kind=8) :: where_index(n)
	real(kind=8) :: a(:), b
	integer :: i, j, n2
	logical :: found
		n2 = size(a)
		j = 1
		i = 1
		found = .false.
		do while(i <= n2 .and. .not.found)
			if (a(i) == b) then
				where_index(j) = i
				j = j + 1
				if (j > n) then
					found = .true.
				endif
			endif
			i = i + 1
		enddo
	end function where_index

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Return the number of elements in a vector equal to a given number
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine uniq(a,b)
	real(kind=8) :: a(:), b(:), dif
	integer, allocatable :: indx(:)
	integer :: i, l, n

		n = size(a)

		allocate(indx(n))

		call indexx(a,indx)

		b(1) = a(indx(1))
		l = 2
		do i = 2, n
			dif = abs(a(indx(i)) - b(l-1))
			if (dif > 1.d-9) then
				b(l) = a(indx(i))
				l = l + 1
			endif
		enddo

	end subroutine uniq

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Return the number of elements in a vector equal to a given number
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function count(a,b)
	integer :: count
	real(kind=8) :: a(:), b
	integer :: i, l, n

		n = size(a)

		l = 0
		do i = 1, n
			if (a(i) == b) then
				l = l + 1
			endif
		enddo

		count = l

	end function count

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Return the time
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function second()
	real(kind=4) :: second
	integer :: time_array(8)
	real(kind=4) :: tiempo
		call date_and_time(values=time_array)
		tiempo = time_array(5)*3600.*1000.+time_array(6)*60.*1000.+time_array(7)*1000.+time_array(8)
		second = tiempo / 1000.
	end function second

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Sort an array in ascending order returning the index array in indx
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine indexx(arr,indx)
	integer :: n,indx(:)
	real(kind=8) :: arr(:)
    integer, parameter :: M=7,NSTACK=50
    integer :: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK)
    real(kind=8) :: a

	n = size(arr)
    do j=1,n
		indx(j)=j
	enddo
    jstack=0
    l=1
    ir=n
1   if(ir-l.lt.M)then
		do j=l+1,ir
			indxt=indx(j)
			a=arr(indxt)
			do i=j-1,1,-1
				if(arr(indx(i)).le.a)goto 2
				indx(i+1)=indx(i)
			enddo
			i=0
2			indx(i+1)=indxt
		enddo
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
     else
        k=(l+ir)/2
        itemp=indx(k)
        indx(k)=indx(l+1)
        indx(l+1)=itemp
        if(arr(indx(l+1)).gt.arr(indx(ir)))then
          itemp=indx(l+1)
          indx(l+1)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l)).gt.arr(indx(ir)))then
          itemp=indx(l)
          indx(l)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l+1)).gt.arr(indx(l)))then
          itemp=indx(l+1)
          indx(l+1)=indx(l)
          indx(l)=itemp
        endif
        i=l+1
        j=ir
        indxt=indx(l)
        a=arr(indxt)
3       continue
          i=i+1
        if(arr(indx(i)).lt.a)goto 3
4       continue
          j=j-1
        if(arr(indx(j)).gt.a)goto 4
        if(j.lt.i)goto 5
        itemp=indx(i)
        indx(i)=indx(j)
        indx(j)=itemp
        goto 3
5       indx(l)=indx(j)
        indx(j)=indxt
        jstack=jstack+2
        if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx'
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      end subroutine indexx
end module maths