      SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
     $                   RSCALE, WORK, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            IHI, ILO, INFO, LDA, LDB, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), LSCALE( * ),
     $                   RSCALE( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  DGGBAL balances a pair of general real matrices (A,B).  This
*  involves, first, permuting A and B by similarity transformations to
*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
*  elements on the diagonal; and second, applying a diagonal similarity
*  transformation to rows and columns ILO to IHI to make the rows
*  and columns as close in norm as possible. Both steps are optional.
*
*  Balancing may reduce the 1-norm of the matrices, and improve the
*  accuracy of the computed eigenvalues and/or eigenvectors in the
*  generalized eigenvalue problem A*x = lambda*B*x.
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          Specifies the operations to be performed on A and B:
*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
*                  and RSCALE(I) = 1.0 for i = 1,...,N.
*          = 'P':  permute only;
*          = 'S':  scale only;
*          = 'B':  both permute and scale.
*
*  N       (input) INTEGER
*          The order of the matrices A and B.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the input matrix A.
*          On exit,  A is overwritten by the balanced matrix.
*          If JOB = 'N', A is not referenced.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,N).
*
*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
*          On entry, the input matrix B.
*          On exit,  B is overwritten by the balanced matrix.
*          If JOB = 'N', B is not referenced.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= max(1,N).
*
*  ILO     (output) INTEGER
*  IHI     (output) INTEGER
*          ILO and IHI are set to integers such that on exit
*          A(i,j) = 0 and B(i,j) = 0 if i > j and
*          j = 1,...,ILO-1 or i = IHI+1,...,N.
*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
*
*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
*          Details of the permutations and scaling factors applied
*          to the left side of A and B.  If P(j) is the index of the
*          row interchanged with row j, and D(j)
*          is the scaling factor applied to row j, then
*            LSCALE(j) = P(j)    for J = 1,...,ILO-1
*                      = D(j)    for J = ILO,...,IHI
*                      = P(j)    for J = IHI+1,...,N.
*          The order in which the interchanges are made is N to IHI+1,
*          then 1 to ILO-1.
*
*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
*          Details of the permutations and scaling factors applied
*          to the right side of A and B.  If P(j) is the index of the
*          column interchanged with column j, and D(j)
*          is the scaling factor applied to column j, then
*            LSCALE(j) = P(j)    for J = 1,...,ILO-1
*                      = D(j)    for J = ILO,...,IHI
*                      = P(j)    for J = IHI+1,...,N.
*          The order in which the interchanges are made is N to IHI+1,
*          then 1 to ILO-1.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  See R.C. WARD, Balancing the generalized eigenvalue problem,
*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   THREE, SCLFAC
      PARAMETER          ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
     $                   K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
     $                   M, NR, NRP2
      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
     $                   COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
     $                   SFMIN, SUM, T, TA, TB, TC
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX
      DOUBLE PRECISION   DDOT, DLAMCH
      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DSCAL, DSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGGBAL', -INFO )
         RETURN
      END IF
*
      K = 1
      L = N
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( LSAME( JOB, 'N' ) ) THEN
         ILO = 1
         IHI = N
         DO 10 I = 1, N
            LSCALE( I ) = ONE
            RSCALE( I ) = ONE
   10    CONTINUE
         RETURN
      END IF
*
      IF( K.EQ.L ) THEN
         ILO = 1
         IHI = 1
         LSCALE( 1 ) = ONE
         RSCALE( 1 ) = ONE
         RETURN
      END IF
*
      IF( LSAME( JOB, 'S' ) )
     $   GO TO 190
*
      GO TO 30
*
*     Permute the matrices A and B to isolate the eigenvalues.
*
*     Find row with one nonzero in columns 1 through L
*
   20 CONTINUE
      L = LM1
      IF( L.NE.1 )
     $   GO TO 30
*
      RSCALE( 1 ) = 1
      LSCALE( 1 ) = 1
      GO TO 190
*
   30 CONTINUE
      LM1 = L - 1
      DO 80 I = L, 1, -1
         DO 40 J = 1, LM1
            JP1 = J + 1
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 50
   40    CONTINUE
         J = L
         GO TO 70
*
   50    CONTINUE
         DO 60 J = JP1, L
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 80
   60    CONTINUE
         J = JP1 - 1
*
   70    CONTINUE
         M = L
         IFLOW = 1
         GO TO 160
   80 CONTINUE
      GO TO 100
*
*     Find column with one nonzero in rows K through N
*
   90 CONTINUE
      K = K + 1
*
  100 CONTINUE
      DO 150 J = K, L
         DO 110 I = K, LM1
            IP1 = I + 1
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 120
  110    CONTINUE
         I = L
         GO TO 140
  120    CONTINUE
         DO 130 I = IP1, L
            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
     $         GO TO 150
  130    CONTINUE
         I = IP1 - 1
  140    CONTINUE
         M = K
         IFLOW = 2
         GO TO 160
  150 CONTINUE
      GO TO 190
*
*     Permute rows M and I
*
  160 CONTINUE
      LSCALE( M ) = I
      IF( I.EQ.M )
     $   GO TO 170
      CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
      CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
*
*     Permute columns M and J
*
  170 CONTINUE
      RSCALE( M ) = J
      IF( J.EQ.M )
     $   GO TO 180
      CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
      CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
*
  180 CONTINUE
      GO TO ( 20, 90 )IFLOW
*
  190 CONTINUE
      ILO = K
      IHI = L
*
      IF( ILO.EQ.IHI )
     $   RETURN
*
      IF( LSAME( JOB, 'P' ) )
     $   RETURN
*
*     Balance the submatrix in rows ILO to IHI.
*
      NR = IHI - ILO + 1
      DO 200 I = ILO, IHI
         RSCALE( I ) = ZERO
         LSCALE( I ) = ZERO
*
         WORK( I ) = ZERO
         WORK( I+N ) = ZERO
         WORK( I+2*N ) = ZERO
         WORK( I+3*N ) = ZERO
         WORK( I+4*N ) = ZERO
         WORK( I+5*N ) = ZERO
  200 CONTINUE
*
*     Compute right side vector in resulting linear equations
*
      BASL = LOG10( SCLFAC )
      DO 240 I = ILO, IHI
         DO 230 J = ILO, IHI
            TB = B( I, J )
            TA = A( I, J )
            IF( TA.EQ.ZERO )
     $         GO TO 210
            TA = LOG10( ABS( TA ) ) / BASL
  210       CONTINUE
            IF( TB.EQ.ZERO )
     $         GO TO 220
            TB = LOG10( ABS( TB ) ) / BASL
  220       CONTINUE
            WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
            WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
  230    CONTINUE
  240 CONTINUE
*
      COEF = ONE / DBLE( 2*NR )
      COEF2 = COEF*COEF
      COEF5 = HALF*COEF2
      NRP2 = NR + 2
      BETA = ZERO
      IT = 1
*
*     Start generalized conjugate gradient iteration
*
  250 CONTINUE
*
      GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
     $        DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
*
      EW = ZERO
      EWC = ZERO
      DO 260 I = ILO, IHI
         EW = EW + WORK( I+4*N )
         EWC = EWC + WORK( I+5*N )
  260 CONTINUE
*
      GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
      IF( GAMMA.EQ.ZERO )
     $   GO TO 350
      IF( IT.NE.1 )
     $   BETA = GAMMA / PGAMMA
      T = COEF5*( EWC-THREE*EW )
      TC = COEF5*( EW-THREE*EWC )
*
      CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
      CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
*
      CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
      CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
*
      DO 270 I = ILO, IHI
         WORK( I ) = WORK( I ) + TC
         WORK( I+N ) = WORK( I+N ) + T
  270 CONTINUE
*
*     Apply matrix to vector
*
      DO 300 I = ILO, IHI
         KOUNT = 0
         SUM = ZERO
         DO 290 J = ILO, IHI
            IF( A( I, J ).EQ.ZERO )
     $         GO TO 280
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( J )
  280       CONTINUE
            IF( B( I, J ).EQ.ZERO )
     $         GO TO 290
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( J )
  290    CONTINUE
         WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
  300 CONTINUE
*
      DO 330 J = ILO, IHI
         KOUNT = 0
         SUM = ZERO
         DO 320 I = ILO, IHI
            IF( A( I, J ).EQ.ZERO )
     $         GO TO 310
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( I+N )
  310       CONTINUE
            IF( B( I, J ).EQ.ZERO )
     $         GO TO 320
            KOUNT = KOUNT + 1
            SUM = SUM + WORK( I+N )
  320    CONTINUE
         WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
  330 CONTINUE
*
      SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
     $      DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
      ALPHA = GAMMA / SUM
*
*     Determine correction to current iteration
*
      CMAX = ZERO
      DO 340 I = ILO, IHI
         COR = ALPHA*WORK( I+N )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         LSCALE( I ) = LSCALE( I ) + COR
         COR = ALPHA*WORK( I )
         IF( ABS( COR ).GT.CMAX )
     $      CMAX = ABS( COR )
         RSCALE( I ) = RSCALE( I ) + COR
  340 CONTINUE
      IF( CMAX.LT.HALF )
     $   GO TO 350
*
      CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
      CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
*
      PGAMMA = GAMMA
      IT = IT + 1
      IF( IT.LE.NRP2 )
     $   GO TO 250
*
*     End generalized conjugate gradient iteration
*
  350 CONTINUE
      SFMIN = DLAMCH( 'S' )
      SFMAX = ONE / SFMIN
      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
      LSFMAX = INT( LOG10( SFMAX ) / BASL )
      DO 360 I = ILO, IHI
         IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA )
         RAB = ABS( A( I, IRAB+ILO-1 ) )
         IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDA )
         RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
         LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
         IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
         LSCALE( I ) = SCLFAC**IR
         ICAB = IDAMAX( IHI, A( 1, I ), 1 )
         CAB = ABS( A( ICAB, I ) )
         ICAB = IDAMAX( IHI, B( 1, I ), 1 )
         CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
         LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
         JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
         RSCALE( I ) = SCLFAC**JC
  360 CONTINUE
*
*     Row scaling of matrices A and B
*
      DO 370 I = ILO, IHI
         CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
         CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
  370 CONTINUE
*
*     Column scaling of matrices A and B
*
      DO 380 J = ILO, IHI
         CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
         CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
  380 CONTINUE
*
      RETURN
*
*     End of DGGBAL
*
      END


   PROGRAM mean_entropy
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::n=5

   INTEGER (KIND=8):: i
   REAL    (KIND=8):: Ra_av,Rb_av,Rd_av,Kad,Kab
   REAL    (KIND=8):: Ra_dev,Rb_dev,Rd_dev
   REAL    (KIND=8),DIMENSION(n):: Ra,Rb,Rd

!!!=======================================================================================
!!!=======================================================================================
   OPEN(unit=11,file='entropy.dat')
   OPEN(unit=12,file='entropy_av.dat')
   OPEN(unit=13,file='S_av.dat')

!!! Tinh gia tri trung binh
   Ra_av=0. ; Rb_av=0. ; Rd_av=0.

   DO i=1,n
      READ(11,*)Kad,Kab,Ra(i),Rb(i),Rd(i)
      Ra_av=Ra_av+Ra(i)
      Rb_av=Rb_av+Rb(i)
      Rd_av=Rd_av+Rd(i)
   END DO

   Ra_av=Ra_av/n ; Rb_av=Rb_av/n ; Rd_av=Rd_av/n

!!! Tinh standard deviation
   Ra_dev=0.
   DO i=1,n
      Ra_dev=Ra_dev+(Ra(i)-Ra_av)**2.
   END DO
   Ra_dev=sqrt(Ra_dev/n)

   Rb_dev=0.
   DO i=1,n
      Rb_dev=Rb_dev+(Rb(i)-Rb_av)**2.
   END DO
   Rb_dev=sqrt(Rb_dev/n)

   Rd_dev=0.
   DO i=1,n
      Rd_dev=Rd_dev+(Rd(i)-Rd_av)**2.
   END DO
   Rd_dev=sqrt(Rd_dev/n)

   WRITE(12,*)Kad,Kab,Ra_av,Rb_av,Rd_av
   WRITE(13,*)Ra_av,Ra_dev,Rb_av,Rb_dev,Rd_av,Rd_dev

   CLOSE(11)
   CLOSE(12)
   CLOSE(13)

   END PROGRAM mean_entropy


    Program dgtsvx_example

!     DGTSVX Example Program Text

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

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgtsvx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: rcond
      Integer :: i, ifail, info, ldb, ldx, n, nrhs
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: b(:, :), berr(:), d(:), df(:), dl(:), &
        dlf(:), du(:), du2(:), duf(:), ferr(:), work(:), x(:, :)
      Integer, Allocatable :: ipiv(:), iwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'DGTSVX Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, nrhs
      ldb = n
      ldx = n
      Allocate (b(ldb,nrhs), berr(nrhs), d(n), df(n), dl(n-1), dlf(n-1), &
        du(n-1), du2(n-2), duf(n-1), ferr(nrhs), work(3*n), x(ldx,nrhs), &
        ipiv(n), iwork(n))

!     Read the tridiagonal matrix A from data file

      Read (nin, *) du(1:n-1)
      Read (nin, *) d(1:n)
      Read (nin, *) dl(1:n-1)

!     Read the right hand matrix B

      Read (nin, *)(b(i,1:nrhs), i=1, n)

!     Solve the equations AX = B

      Call dgtsvx('No factors', 'No transpose', n, nrhs, dl, d, du, dlf, df, &
        duf, du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)

      If ((info==0) .Or. (info==n+1)) Then

!       Print solution, error bounds and condition number

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, nrhs, x, ldx, &
          'Solution(s)', ifail)

        Write (nout, *)
        Write (nout, *) 'Backward errors (machine-dependent)'
        Write (nout, 100) berr(1:nrhs)
        Write (nout, *)
        Write (nout, *) 'Estimated forward error bounds (machine-dependent)'
        Write (nout, 100) ferr(1:nrhs)
        Write (nout, *)
        Write (nout, *) 'Estimate of reciprocal condition number'
        Write (nout, 100) rcond

        If (info==n+1) Then
          Write (nout, *)
          Write (nout, *) 'The matrix A is singular to working precision'
        End If
      Else
        Write (nout, 110) 'The (', info, ',', info, ')', &
          ' element of the factor U is zero'
      End If

100   Format ((3X,1P,7E11.1))
110   Format (1X, A, I3, A, I3, A, A)
    End Program


module poisson_mod

    use precision_mod, only: wp
    use source_mod, only: source_term

    implicit none
    private

    public :: wp, source_term
    public :: Lattice, init_Lattice

    ! D1Q3 Model Parameters
    integer, parameter :: e(3) = [0,1,-1]
    real(wp), parameter :: w(3) = [2._wp/3._wp,1._wp/6._wp,1._wp/6._wp]
    real(wp), parameter :: wbar(3) = [0._wp,0.5_wp,0.5_wp]
    real(wp), parameter :: alpha = 1._wp/3._wp ! Speed of sound squared $c_\mathrm{s}^2$

    real(wp), parameter :: coef = 1._wp/(1._wp - w(1)) ! coefficient in macroscopic value sum, see Eq. (2.5)

!>  Derived type to encapsulate the lattice Boltzmann algorithm
!
    type :: Lattice
        real(wp) :: interval(2)
        integer :: nx
        real(wp) :: dx, dt, diff, omega
        real(wp), allocatable :: f(:,:,:)
        integer :: old, new
        class(source_term), pointer :: src
    contains
        procedure :: collide_and_stream
        procedure :: get_macroscopic_values
        procedure :: prep_next_step
        procedure :: output

        ! Non-equilibrium extrapolation
        procedure :: set_left_neem
        procedure :: set_right_neem

        ! Non-equilibrium bounceback
        ! procedure :: set_left_neeb
        ! procedure :: set_right_neeb

        ! Inamuro's boundary condition
        procedure :: set_left_inamuro
        procedure :: set_right_inamuro
    end type

contains

    function init_Lattice(ab,nx,uinit,omega,src) result(this)
        real(wp), intent(in), optional :: ab(2)
        integer, intent(in) :: nx
        real(wp), intent(in) :: uinit(nx)
        real(wp), intent(in) :: omega
        class(source_term), intent(in), pointer :: src

        type(Lattice) :: this

        real(wp) :: ab_(2), dx, tau
        integer :: i

        ! Set interval
        ab_ = [0.0_wp,1.0_wp] ! default interval
        if (present(ab)) ab_ = ab
        this%interval = ab_

        ! Set number of lattice sites
        this%nx = nx

        ! Set spatial and time step
        this%dx = (ab_(2) - ab_(1))/real(nx-1,wp)
        this%dt = this%dx

        ! Set relaxation time and diffusivity
        this%omega = omega
        tau = 1.0_wp/omega
        this%diff = alpha*(0.5_wp - tau)*this%dt ! Not the same as in standard LBM!

        ! Set flags
        this%old = 1
        this%new = 2

        ! Allocate space
        allocate(this%f(0:nx+1,3,2))

        ! Initialize to equilibrium values
        do i = 1, nx
            this%f(i,1,this%old) = (w(1) - 1._wp)*uinit(i)
            this%f(i,2,this%old) = w(2)*uinit(i)
            this%f(i,3,this%old) = w(3)*uinit(i)
        end do

        ! Associate source term functor
        this%src => src

    end function

    subroutine collide_and_stream(this,uout)
        class(Lattice), intent(inout) :: this
        real(wp), intent(out), optional ::uout(this%nx)
        real(wp) :: one_minus_omega, feq(3), u, source, x
        integer :: i

        associate(f => this%f, nx => this%nx, new => this%new, old => this%old, &
            dt => this%dt, omega => this%omega, D => this%diff)

        one_minus_omega = 1._wp - omega

        spatial_loop: do i = 1, this%nx
            ! Macroscopic value, Eq. (2.5)
            u = coef*(f(i,2,old) + f(i,3,old))
            if (present(uout)) uout(i) = u

            ! Equilibirum distribution
            feq(1) = (w(1) - 1._wp)*u
            feq(2) = w(2)*u
            feq(3) = w(3)*u

            ! Evaluate source term
            x = this%interval(1) + (i-1)*this%dx
            source = this%src%eval(u,x)

            ! Collide and stream
            f(i,1,new)   = one_minus_omega*f(i,1,old) + omega*feq(1)    ! wbar(1) = 0
            f(i+1,2,new) = one_minus_omega*f(i,2,old) + omega*feq(2) + dt*wbar(2)*D*source
            f(i-1,3,new) = one_minus_omega*f(i,3,old) + omega*feq(3) + dt*wbar(3)*D*source
        end do spatial_loop

        ! Perform bounceback by default
        f(1,2,new) = f(0,3,new)
        f(nx,3,new) = f(nx+1,2,new)

        end associate

    end subroutine

!>  Sets a left Dirichlet boundary condition using the
!   non-equilibrium extrapolation method.
!
    subroutine set_left_neem(this,value)
        class(Lattice), intent(inout) :: this
        real(wp), intent(in) :: value
        real(wp) :: u
        u = coef*sum(this%f(2,2:3,this%old))
        this%f(1,1,this%new)  = (w(1) - 1._wp)*value + (this%f(2,1,this%new) - (w(1) - 1._wp)*u)
        this%f(1,2,this%new)  = w(2)*value + (this%f(2,2,this%new) - w(2)*u)
        this%f(1,3,this%new)  = w(3)*value + (this%f(2,3,this%new) - w(3)*u)
    end subroutine

!>  Sets a right Dirichlet boundary condition using the
!   non-equilibrium extrapolation method.
!
    subroutine set_right_neem(this,value)
        class(Lattice), intent(inout) :: this
        real(wp), intent(in) :: value
        real(wp) :: u
        u = coef*sum(this%f(this%nx-1,2:3,this%old))
        this%f(this%nx,1,this%new) = (w(1) - 1._wp)*value + (this%f(this%nx-1,3,this%new) - (w(1) - 1._wp)*u)
        this%f(this%nx,2,this%new) = w(2)*value + (this%f(this%nx-1,2,this%new) - w(2)*u)
        this%f(this%nx,3,this%new) = w(3)*value + (this%f(this%nx-1,3,this%new) - w(3)*u)
    end subroutine

    subroutine set_left_inamuro(this,value)
        class(Lattice), intent(inout) :: this
        real(wp), intent(in) :: value
        this%f(1,2,this%new)  = value*(1.0_wp-w(1)) - this%f(1,3,this%new)
    end subroutine

    subroutine set_right_inamuro(this,value)
        class(Lattice), intent(inout) :: this
        real(wp), intent(in) :: value
        this%f(this%nx,3,this%new) = value*(1.0_wp-w(1)) - this%f(this%nx,2,this%new)
    end subroutine

!>  Swaps flags between old and new arrays.
!
!   This routine must be called at the end of the time loop!
!
    subroutine prep_next_step(this)
        class(Lattice), intent(inout) :: this
        integer :: temp
        temp = this%old
        this%old = this%new
        this%new = temp
    end subroutine

!>  Calculates the physical quantity $u$ (macroscopic value)
!   according to Eq. (2.5) in the paper by Chai and Shi (2008).
!
    subroutine get_macroscopic_values(this,u)
        class(Lattice), intent(in) :: this
        real(wp), intent(out) :: u(this%nx)
        u(:) = coef*sum(this%f(1:this%nx,2:3,this%old),dim=2)
    end subroutine

    subroutine output(this,fname)
        class(Lattice), intent(in) :: this
        character(len=*), intent(in) :: fname

        integer :: iunit, i
        real(wp) :: x(this%nx), u(this%nx)

        call this%get_macroscopic_values(u)

        x = [(this%interval(1) + (i-1)*this%dx,i=1,this%nx)]

        open(newunit=iunit,file=fname)

        do i = 1, this%nx
            write(iunit,*) x(i), u(i)
        end do

        close(iunit)
    end subroutine

end module


program P1010
    implicit none
    integer :: cases, i
    integer :: west, east, j, k
    integer, dimension(30, 30) :: count
    do i = 1, 30
        count(1, i) = i
    end do
    read *, cases
    do i = 1, cases
        read *, west, east
        do j = 2, west
            count(j, j - 1) = 0
            do k = j, east
                count(j, k) = count(j - 1, k - 1) + count(j, k - 1)
            end do
        end do
        write (*, '(I0)') count(west, east)
    end do
end program P1010


!** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!** See https://llvm.org/LICENSE.txt for license information.
!** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

program mmul
  integer, parameter :: n = 4
  real(kind = 8), dimension(1:n, 1:n) :: a, b, c
  real(kind = 8), dimension(n * n) :: expected
  data expected / -256.0, -256.0, -256.0, -256.0, &
                  -256.0, -256.0, -256.0, -256.0, &
                  -256.0, -256.0, -256.0, -256.0, &
                  -256.0, -256.0, -256.0, -256.0 /

  a = 1.0
  b = -1.0
  c = 2.0
  call do_matmul(a, b, c, n)
  call checkd(reshape(c, (/ n * n /)), expected, n * n)

contains

  subroutine do_matmul(a, b, c, n)
    integer, intent(in) :: n
    real(kind = 8), dimension(:, :), intent(in) :: a, b
    real(kind = 8), dimension(:, :), intent(inout) :: c

    c(1:n, 1:n) = matmul(matmul(matmul(a(1:n, 1:n), b(1:n, 1:n)), matmul(a(1:n, 1:n), b(1:n, 1:n))), b(1:n, 1:n))
  end subroutine

end program mmul


program Nqueens
  implicit none

  integer, parameter :: n = 8  ! size of board
  integer :: file = 1, rank = 1, queens = 0
  integer :: i
  logical :: board(n,n) = .false.

  do while (queens < n)
    board(file, rank) = .true.
    if(is_safe(board, file, rank)) then
      queens = queens + 1
      file = 1
      rank = rank + 1
    else
      board(file, rank) = .false.
      file = file + 1
      do while(file > n)
         rank = rank - 1
         if (rank < 1) then
           write(*, "(a,i0)") "No solution for n = ", n
           stop
         end if
         do i = 1, n
           if (board(i, rank)) then
             file = i
             board(file, rank) = .false.
             queens = queens - 1
             file = i + 1
             exit
           end if
         end do
       end do
    end if
  end do

  call Printboard(board)

contains

function is_safe(board, file, rank)
  logical :: is_safe
  logical, intent(in) :: board(:,:)
  integer, intent(in) :: file, rank
  integer :: i, f, r

  is_safe = .true.
  do i = rank-1, 1, -1
    if(board(file, i)) then
      is_safe = .false.
      return
    end if
  end do

  f = file - 1
  r = rank - 1
  do while(f > 0 .and. r > 0)
    if(board(f, r)) then
      is_safe = .false.
      return
    end if
    f = f - 1
    r = r - 1
  end do

  f = file + 1
  r = rank - 1
  do while(f <= n .and. r > 0)
    if(board(f, r)) then
      is_safe = .false.
      return
    end if
    f = f + 1
    r = r - 1
  end do
end function

subroutine Printboard(board)
  logical, intent(in) :: board(:,:)
  character(n*4+1) :: line
  integer :: f, r

  write(*, "(a, i0)") "n = ", n
  line = repeat("+---", n) // "+"
  do r = 1, n
    write(*, "(a)") line
    do f = 1, n
      write(*, "(a)", advance="no") "|"
      if(board(f, r)) then
        write(*, "(a)", advance="no") " Q "
      else if(mod(f+r, 2) == 0) then
        write(*, "(a)", advance="no") "   "
      else
        write(*, "(a)", advance="no") "###"
      end if
    end do
    write(*, "(a)") "|"
  end do
  write(*, "(a)") line
end subroutine
end program


program pg
    implicit none   ! always use implicit none, unless you know why
                    ! you don't want to...
    !
    ! Section: Specification
    !
    integer                       :: mml,i,retinfo  ! scalars
    double precision, allocatable :: a(:,:) ! a is a "deferred shape" array
    double precision, allocatable :: ata(:,:),meye(:,:)
    integer         , allocatable :: ipiv(:)
    character(len=512)            :: dfmt   ! string
    !
    ! Section: Execution
    !
    mml = 12
    retinfo = 0
    !
    ! Format for I/O
    !
    write(dfmt, '(a,i0,a)') '(' , mml , 'f7.2)'  ! a => character , i0 => minimum digits required for integer
    !
    ! Allocate memory
    !
    allocate( a(mml,mml)    &
        &   , ata(mml,mml)  &
        &   , meye(mml,mml) &
        &   , ipiv(mml)     &
        &   )
    !
    ! Assign all elements of meye to 0
    !
    meye = 0.0d0
    !
    ! Assign all elements on the diagonal of meye to 1.0
    !
    do i = 1,mml
        mEye(i,i) = 1.0d0
    end do
    !
    ! Output the matrix: meye
    !
    write(*,*) 'Identity matrix meye:'
    write(*,*)
    write(*,dfmt) TRANSPOSE(meye)
    !
    ! Deallocate memory
    !
    deallocate( a, ata, meye, ipiv)
end program pg


module asflowf_cube_to_vtk

    use asflowf_crystal, only : write_xyz
    use asflowf_cube, only : cube
    use asflowf_constants

    implicit none

    contains

    subroutine cube_to_vtk(cube_file_in, vtk_file_out)

        integer :: i, j, k
        integer :: ngridx, ngridy, ngridz

        type(cube) :: cube_i

        real(kind=dp) :: cell_volume, cell_volume_per_unit, tmp, tmp_vec(3)
        real(kind=dp) :: a, b, c, x, y, z, total_electron

        ! character, allocatable :: cube_file_in
        !character(len=128), intent(in) :: cube_file_in, vtk_file_out
        character(len=*), intent(in) :: cube_file_in, vtk_file_out

        ! read cube file

        write(*, *) "On getting the command line argument:"
        if ( cube_file_in == "" .or. vtk_file_out == "") then
            write(*, *) "You should provide the name for the input cube file and output vtk file!"
            stop
        else
            write(*, *) "The input cube file name is: ", cube_file_in
            write(*, *) "The output vtk file name is: ", vtk_file_out
        end if

        call cube_i%read_cube_file(cube_file_in)

        write(*, *) "Successfully read the cube file!"

        ! value in cube file are \rho(r)_of_electrons in unit of e/Bohr^3
        ! namely number of electrons each Borh^3
        ! so we have to convert it to e/Angstrom^3, through divide it by bohr_to_angstrom**3

        call cross_3(cube_i%cube_crystal%cell(1, :), cube_i%cube_crystal%cell(2, :), tmp_vec)

        call dot_3(tmp_vec, cube_i%cube_crystal%cell(3, :), cell_volume)

        ngridx = cube_i%ngridx
        ngridy = cube_i%ngridy
        ngridz = cube_i%ngridz

        cell_volume_per_unit = cell_volume / ngridx / ngridy / ngridz

        total_electron = sum(cube_i%data) * cell_volume_per_unit / bohr_to_angstrom**3

        write(*, *) "-----------------------------------------------------------------"
        write(*, *) "                 Out put collected information                   "
        write(*, *) "-----------------------------------------------------------------"
        write(*, *) "ngridx: ", ngridx
        write(*, *) "ngridy: ", ngridy
        write(*, *) "ngridz: ", ngridz
        write(*, *) "cell volume: ", cell_volume
        write(*, *) "total number of electrons: ", total_electron
        write(*, *) "-----------------------------------------------------------------"

        call dot_3(cube_i%cube_crystal%cell(1, :), cube_i%cube_crystal%cell(1, :), a)
        a = sqrt(a)
        call dot_3(cube_i%cube_crystal%cell(2, :), cube_i%cube_crystal%cell(2, :), b)
        b = sqrt(b)
        call dot_3(cube_i%cube_crystal%cell(3, :), cube_i%cube_crystal%cell(3, :), c)
        c = sqrt(c)

        !write(*, *) a, b ,c

        ! output data to vtk file
        open(11, file=vtk_file_out, status="replace", action="write")
        write(11, "(A)") "# vtk DataFile Version 5.1"
        write(11, "(A)") cube_file_in
        write(11, "(A)") "ASCII"
        write(11, "(A)") "DATASET STRUCTURED_POINTS"
        write(11, "(A, 3I10)") "DIMENSIONS ", ngridx, ngridy, ngridz
        write(11, "(A, 3F15.6)") "SPACING", a/ngridx, b/ngridy, c/ngridz

        !write(11, "(A, I10, A)") "POINTS ", ngridx * ngridy * ngridz, ' float'
        !do i = 1, ngridx
        !    do j = 1, ngridy
        !        do k = 1, ngridz
        !            !x = real(i-1) / real(ngridx) * a
        !            !y = real(j-1) / real(ngridy) * b
        !            !z = real(k-1) / real(ngridz) * c
        !            x = real(i) / real(ngridx) * a
        !            y = real(j) / real(ngridy) * b
        !            z = real(k) / real(ngridz) * c
        !            write(11, *) x, y, z
        !        end do
        !    end do
        !end do

        ! write grid point values:
        write(11, "(A, I10)") 'POINT_DATA ', ngridx * ngridy * ngridz
        write(11, "(A)") 'SCALARS CON float 1'
        write(11, "(A)") 'LOOKUP_TABLE default'
        do k = 1, ngridz
            do j = 1, ngridy
                do i = 1, ngridx
                    write(11, *) cube_i%data(i, j, k)
                end do
            end do
        end do
        close(11)
        ! output the total structure
        call write_xyz(cube_i%cube_crystal, "cube-structure.xyz")
    end subroutine cube_to_vtk

    subroutine cross_3(x, y, z)
        implicit none
        real(kind=dp), dimension(3), intent(in) :: x, y
        real(kind=dp), dimension(3), intent(out) :: z

        z(1) = x(2) * y(3) - x(3) * y(2)
        z(2) = x(3) * y(1) - x(1) * y(3)
        z(3) = x(1) * y(2) - x(2) * y(1)
    end subroutine

    subroutine dot_3(x, y, z)
        implicit none
        real(kind=dp), dimension(3), intent(in) :: x, y
        real(kind=dp), intent(out) :: z
        z = x(1) * y(1) + x(2) * y(2) + x(3) * y(3)
    end subroutine dot_3
end module asflowf_cube_to_vtk


SUBROUTINE solve_band(pb,work,loads)
!
! This subroutine performs Gaussian forward and back-substitution
! on the reduced unsymmetric band matrix pb.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::pb(:,:),work(:,:)
 REAL(iwp),INTENT(OUT)::loads(0:)
 INTEGER::iwp1,n,n1,i,iv,l,iq,iv1
 REAL(iwp)::s,pt5=0.5_iwp
 iwp1=(UBOUND(pb,2)-1)/2+1
 n=UBOUND(pb,1)
 iq=2*iwp1-1
 n1=n-1
 DO iv=1,n1
   i=INT(work(iwp1,iv)+pt5)
   IF(i/=iv)THEN
     s=loads(iv)
     loads(iv)=loads(i)
     loads(i)=s
   END IF
   l=iv+iwp1-1
   IF(l>n)l=n
   iv1=iv+1
   DO i=iv1,l
     loads(i)=loads(i)-work(i-iv,iv)*loads(iv)
   END DO
 END DO
 loads(n)=loads(n)/pb(n,1)
 iv=n-1
 DO WHILE(iv/=0)
   s=loads(iv)
   l=iq
   IF(iv+l-1>n)l=n-iv+1
   DO i=2,l
     s=s-pb(iv,i)*loads(iv+i-1)
     loads(iv)=s/pb(iv,1)
   END DO
 iv=iv-1
 END DO
RETURN
END SUBROUTINE solve_band


! fortran program to verify trignometric identities

program trig
    implicit none

    integer :: i
    integer, PARAMETER :: n = 100
    real(KIND=8), DIMENSION(0:n) :: x, sinx, cosx, secx, tanx, cscx, cotx, sin2x
    real, PARAMETER :: pi = 2*asin(1.0)
    real :: increment = 2 * pi/(real(n))

    !do i = 0,n
        !x(i) = i*increment
    !end do

    x(0:n) = [(i*increment, i = 0,n)] ! An alternate way to define the array

    sinx = SIN(x)
    cosx = COS(x)
    tanx = TAN(x)
    secx = 1.0/cosx
    cscx = 1.0/sinx
    cotx = 1.0/tanx
    sin2x = sinx**2 ! this is square of sinx

    10 format("The sine of ", f10.4, " is : ", f10.4)
    20 format("The square of sine of ", f10.4, " is : ", f10.4)
    30 format("The cosine of ", f10.4, " is : ", f10.4)

    open(unit=1, file = 'plot.txt')
    15 format(f10.4, 4x, f10.4, 4x, f10.4)

    do i = 0,n
        !print 10, (x(i)/pi) * 180, sinx(i)
        !print 30, (x(i)/pi) * 180, cosx(i)
        write(unit=1, fmt = 15) (x(i)/pi) * 180, secx(i), cscx(i)
    end do

    close(unit=1)

end program trig


program AoS
  USE IFPORT
  use iso_fortran_env, only : real32, real64
  implicit none

  type charge
     real(real32) :: x,y,z,q ! Coordinates and value of the charge
  end type charge

  type(charge), allocatable :: charges(:)
  real(real32), allocatable :: potential(:)
  integer, parameter :: m = 2048, n_trials = 10
  integer :: i,j
  real(real32) :: Rx, Ry, Rz
  real(real64) :: end_time, start_time

  allocate(charges(m), potential(m*m))

  call srand(12345)

  do i = 1, m
     charges(i)%x = rand()
     charges(i)%y = rand()
     charges(i)%z = rand()
     charges(i)%q = rand()
  end do

  do i = 1, n_trials
     potential = 0.0
     call cpu_time(start_time)
     do j = 1, m*m
        Rx = real(mod(j,m))
        Ry = real(j/m)
        Rz = 0.0
        potential(j) = calculate_electric_potential(charges, Rx, Ry, Rz)
     end do
     call cpu_time(end_time)
     write(*,*) 'Trial ',i,' test ',potential(100), 'time ', end_time - start_time
  end do

contains

  function calculate_electric_potential(charges, Rx, Ry, Rz) result(phi)
    implicit none

    real(real32), intent(in) :: Rx, Ry, Rz
    type(charge),allocatable,intent(in) :: charges(:)
    real(real32) :: dx,dy,dz
    real(real32) :: phi
    integer :: i

    phi = 0.0

    do i = 1, size(charges)
       dx = charges(i)%x - Rx
       dy = charges(i)%y - Ry
       dz = charges(i)%z - Rz
       phi = phi - charges(i)%q / sqrt(dx**2 + dy**2 + dz**2)
    end do

  end function calculate_electric_potential

end program AoS


 Program DiasMes

! leyendo el mes y el año responde los días que tiene el mes

!

implicit none

 integer ::  anio , dias

 character ( len=15) :: mes

 character ( len =1) :: d

 dias = 0

 write(*,*) " Ingrese el mes en minúscula : "

 read(*,*) mes

 write(*,*) " Ingrese el año : "

 read(*,*) anio

 select case ( mes )

     case ("enero")

           dias = 31

     case ("febrero")

        IF ( mod(anio,4)== 0) THEN

             dias = 29

        ELSE

             dias = 28

        END IF

     case ("marzo")

             dias = 31

     case ("abril")

             dias = 30

     case ("mayo")

             dias = 31

     case ("junio")

             dias = 30

     case ("julio")

             dias = 31

     case ("agosto")

             dias = 31

     case ("setiembre")

             dias = 30

     case ("octubre")

             dias = 31

     case ("noviembre")

             dias = 30

     case ("diciembre")

              dias = 31

     case default

           write(*,*) "no reoconozco ese mes = ", mes

 end select

  write(*,*) "el número de dias de  ", mes , " de " , anio,  "  es " , dias

  write(*,*) " the end "

 end program DiasMes


      SUBROUTINE qsimp(func,a,b,s)
      INTEGER JMAX
      REAL a,b,func,s,EPS
      EXTERNAL func
      PARAMETER (EPS=1.e-6, JMAX=20)
CU    USES trapzd
      INTEGER j
      REAL os,ost,st
      ost=-1.e30
      os= -1.e30
      do 11 j=1,JMAX
        call trapzd(func,a,b,st,j)
        s=(4.*st-ost)/3.
        if (abs(s-os).lt.EPS*abs(os)) return
        if (s.eq.0..and.os.eq.0..and.j.gt.6) return
        os=s
        ost=st
11    continue
      pause 'too many steps in qsimp'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/qsimp.for


c     program DRSMLC01
c>> 2001-05-22 DRSMLC01 Krogh Minor change for making .f90 version.
c>> 1996-07-08 DRSMLC01 Krogh  Minor format change for C conversion.
c>> 1994-11-02 DRSMLC01 Krogh  Changes to use M77CON
c>> 1994-09-13 DRSMLC01 CLL
c>> 1992-05-13 CLL
c>> 1992-04-15 CLL
c>> 1992-01-21 CLL
c>> 1991-06-10 CLL
c>> 1992-01-16 CLL
c>> 1990-07-12 CLL
c     Demo driver for SMLC01.  Also uses SCKDER to check gradient.
c     Minimization with linear constraints.
c     The constraints are Ax .le. b with equality required in the first
c     two rows.
c     ------------------------------------------------------------------
c--S replaces "?": DR?MLC01, ?MLC01, ?XLOGX, ?CKDER
c     ------------------------------------------------------------------
      external SXLOGX
      integer MMAX, NMAX, LIW, LW
      parameter(MMAX = 3, NMAX = 4)
      parameter(LIW = 4 + MMAX + 2*NMAX)
      parameter(LW  = 3 + MMAX + NMAX*(16 + NMAX))
      integer I, IMAX, IPRINT, IW(LIW), J, JMAX
      integer M, MEQ, MODE, MXEVAL, N
      logical HAVEG
      real             A(MMAX, NMAX), ACC, B(MMAX), FVAL(1), GRAD(NMAX)
      real             GDUMMY(NMAX), TEST(NMAX), TSTMAX, W(LW)
      real             X(NMAX), XL(NMAX), XU(NMAX)
      data M, MEQ, N / 3, 2, 4 /
      data ACC, IPRINT, MXEVAL / 0.0E0, 3, 0 /
      data ((A(I,J),J=1,4),I=1,3) / 1.0E0,  1.0E0, 1.0E0, 1.0E0 ,
     *                              1.0E0, -1.0E0, 0.0E0, 0.0E0,
     *                              0.0E0, -1.0E0, 1.0E0, 0.0E0 /
      data (B(I),I=1,3) / 1.0E0, 0.25E0, -0.1E0 /
      data (XL(J),J=1,4) / 4*1.0E-6 /
      data (XU(J),J=1,4) / 4*1.0E0 /
      data (X(J),J=1,4) / 0.7e0, 0.6e0, 0.5e0, 0.4e0 /
c     ------------------------------------------------------------------
      print*,
     * 'Program DRSMLC01..  Demo driver for SMLC01.  Also uses SCKDER.'
c
c                    Using SCKDER to check the gradient calculation.
c
      MODE = 1
      call SXLOGX( N, X, FVAL(1), GRAD, HAVEG)
   10 continue
      call SCKDER(MODE, 1, N, X, FVAL, GRAD, 1, TEST, IMAX, JMAX,TSTMAX)
         call SXLOGX( N, X, FVAL(1), GDUMMY, HAVEG)
      if(MODE .eq. 2) go to 10
      print'(/'' Using SCKDER to check the gradient calculation.'')'
      print'(/11x,''X(J) ='',5g11.3:/(17x,5g11.3))',(X(J),J=1,N)
      print'(11x,''FVAL ='',5g11.3)',FVAL(1)
      print'(7x,''Gradient ='',5g11.3:/(17x,5g11.3))',(GRAD(J),J=1,N)
      print'(9x,''TEST() ='',5g11.3/(17x,5g11.3))',(TEST(J),J=1,N)
      print'(11x,''JMAX ='',i3,'',          TSTMAX ='',g11.3)',JMAX,
     *     TSTMAX
c
c                Using SMLC01 to solve the minimization problem.
c
      print'(/'' Using SMLC01 to solve the minimization problem.'')'
      call SMLC01 (SXLOGX, N, M, MEQ, A, MMAX, B, XL, XU, X, ACC,
     *             IPRINT, MXEVAL, IW, LIW, W, LW)
      stop
      end
c     ==================================================================
      subroutine SXLOGX( N, X, F, G, HAVEG)
c     ------------------------------------------------------------------
      integer I, N
      real             F, G(N), X(N)
      logical HAVEG
c     ------------------------------------------------------------------
      HAVEG = .true.
      F = 0.0E0
      do 10 I = 1,N
         F = F + X(I) * log(X(I))
         G(I) = 1.0E0 + log(X(I))
   10 continue
      return
      end


      PROGRAM xrk4
C     driver for routine rk4
      INTEGER N
      PARAMETER(N=4)
      INTEGER i,j
      REAL bessj,bessj0,bessj1
      REAL h,x,y(N),dydx(N),yout(N)
      EXTERNAL derivs
      x=1.0
      y(1)=bessj0(x)
      y(2)=bessj1(x)
      y(3)=bessj(2,x)
      y(4)=bessj(3,x)
      call derivs(x,y,dydx)
      write(*,'(/1x,a,t19,a,t31,a,t43,a,t55,a)')
     *     'Bessel Function:','J0','J1','J3','J4'
      do 11 i=1,5
        h=0.2*i
        call rk4(y,dydx,N,x,h,yout,derivs)
        write(*,'(/1x,a,f6.2)') 'For a step size of:',h
        write(*,'(1x,a10,4f12.6)') 'RK4:',(yout(j),j=1,4)
        write(*,'(1x,a10,4f12.6)') 'Actual:',bessj0(x+h),
     *       bessj1(x+h),bessj(2,x+h),bessj(3,x+h)
11    continue
      END
      SUBROUTINE derivs(x,y,dydx)
      REAL x,y(*),dydx(*)
      dydx(1)=-y(2)
      dydx(2)=y(1)-(1.0/x)*y(2)
      dydx(3)=y(2)-(2.0/x)*y(3)
      dydx(4)=y(3)-(3.0/x)*y(4)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xrk4.for


program mean_mask
  use stdlib_stats, only: mean
  implicit none
  real :: y(1:2, 1:3) = reshape([1., 2., 3., 4., 5., 6.], [2, 3])

  print*, mean(y, y > 2.)
  print*, mean(y, 1, y > 2.)
  print*, mean(y, 2, y > 2.)
end program mean_mask


	SUBROUTINE GR_STAT  ( z, kx, ky, imin, jmin, imax, jmax,
     +			      rmin, rmax, ravg, rdev, iret )
C************************************************************************
C* GR_STAT								*
C*									*
C* This subroutine computes grid statistics.				*
C* 									*
C* GR_STAT  ( Z, KX, KY, IMIN, JMIN, IMAX, JMAX, RMIN, RMAX, 		*
C*            RAVG, RDEV, IRET )					*
C*									*
C* Input parameters:							*
C*	Z  (KX,KY)	REAL		Data array			*
C*	KX		INTEGER		Number of points in x dir	*
C*	KY		INTEGER		Number of points in y dir	*
C*	IMIN		INTEGER		Lower left corner of subgrid	*
C*	JMIN		INTEGER		Lower left corner of subgrid	*
C*	IMAX		INTEGER		Upper right corner of subgrid	*
C*	JMAX		INTEGER		Upper right corner of subgrid	*
C*									*
C* Output parameters:							*
C*	RMIN		REAL		Minimum data value		*
C*	RMAX		REAL		Maximum data value		*
C*	RAVG		REAL		Average data value		*
C*	RDEV		REAL		Standard deviation		*
C* 	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -8 = no data in range		*
C*					 -9 = invalid subset area	*
C**									*
C* Log:									*
C* G. Chatters/RDS	 6/82						*
C* M. Vilardo/RDS	11/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	12/84	Converted from GEMPLT for GEMPAK	*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C* G. Huffman/USRA	 7/89	Use REAL*8 to avoid precision errors	*
C* K. Brill              5/90   Return distinct RMIN, RMAX for 0 < n < 4*
C* M. desJardins/GSFC	10/90	Return missing values for no data	*
C* S. Chiswell/Unidata	11/06	use double precision gpt		*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	REAL		z ( kx, ky )
C*
	DOUBLE PRECISION	sum, sumsq, var, gpt
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Check values given for imin, imax, jmin, jmax.
C
	IF  ( ( imin .lt. 1 ) .or. ( imax .gt. kx ) .or.
     +	      ( imin .gt. imax ) .or. ( jmin .lt. 1 ) .or.
     +	      ( jmax .gt. ky ) .or. ( jmin .gt. jmax ) )  THEN
	    iret = -9
	    RETURN
	END IF
C
C*	Initialize variables for computing average and standard
C*	deviation.
C
	sum    = 0.0
	sumsq  = 0.0
	nsum   = 0
	rmax   = RMISSD
	rmin   = RMISSD
C
C*	Read through all the data in the subgrid.
C
	DO  i = imin, imax
	    DO  j = jmin, jmax
		IF  ( .not. ERMISS ( z (i,j) ) )  THEN
		    gpt = z (i,j)
		    IF  ( nsum .eq. 0 )  THEN
			sum   = gpt
			sumsq = gpt * gpt
			nsum  = 1
			rmax  = z (i,j)
			rmin  = z (i,j)
		      ELSE
			sum   = sum + gpt
			sumsq = sumsq + gpt * gpt
			nsum  = nsum + 1
			IF  ( z (i,j) .gt. rmax )  rmax = z (i,j)
			IF  ( z (i,j) .lt. rmin )  rmin = z (i,j)
		    END IF
		END IF
	    END DO
	END DO
C
C*	Check for at least four points and that data has some range
C*      before computing standard deviation.
C
	IF  ( ( nsum .ge. 4 ) .and. ( rmin .lt. rmax ) )  THEN
	    ravg  = sum / nsum
	    var   = sumsq / nsum - ( sum / nsum ) ** 2
	    IF  ( var .lt. 0. )  THEN
		rdev = 0.0
		iret = -8
	      ELSE
		rdev  = SQRT ( var )
	    END IF
	  ELSE IF ( nsum .gt. 0 ) THEN
	    ravg  = 0.0
	    rdev  = 0.0
	  ELSE
	    iret = -8
	END IF
C*
	RETURN
	END


module nf_activation

  ! A collection of activation functions and their derivatives.

  implicit none

  private

  public :: activation_function
  public :: elu, elu_prime
  public :: exponential
  public :: gaussian, gaussian_prime
  public :: relu, relu_prime
  public :: sigmoid, sigmoid_prime
  public :: softplus, softplus_prime
  public :: step, step_prime
  public :: tanhf, tanh_prime

  interface
    pure function activation_function(x)
      real, intent(in) :: x(:)
      real :: activation_function(size(x))
    end function activation_function
  end interface

contains

  pure function elu(x, alpha) result(res)
    ! Exponential Linear Unit (ELU) activation function.
    real, intent(in) :: x(:)
    real, intent(in) :: alpha
    real :: res(size(x))
    where (x >= 0)
      res = x
    elsewhere
      res = alpha * (exp(x) - 1)
    end where
  end function elu

  pure function elu_prime(x, alpha) result(res)
    ! First derivative of the Exponential Linear Unit (ELU)
    ! activation function.
    real, intent(in) :: x(:)
    real, intent(in) :: alpha
    real :: res(size(x))
    where (x >= 0)
      res = 1
    elsewhere
      res = alpha * exp(x)
    end where
  end function elu_prime

  pure function exponential(x) result(res)
    ! Exponential activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = exp(x)
  end function exponential

  pure function gaussian(x) result(res)
    ! Gaussian activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = exp(-x**2)
  end function gaussian

  pure function gaussian_prime(x) result(res)
    ! First derivative of the Gaussian activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = -2 * x * gaussian(x)
  end function gaussian_prime

  pure function relu(x) result(res)
    !! Rectified Linear Unit (ReLU) activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = max(0., x)
  end function relu

  pure function relu_prime(x) result(res)
    ! First derivative of the Rectified Linear Unit (ReLU) activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    where (x > 0)
      res = 1
    elsewhere
      res = 0
    end where
  end function relu_prime

  pure function sigmoid(x) result(res)
    ! Sigmoid activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = 1 / (1 + exp(-x))
  endfunction sigmoid

  pure function sigmoid_prime(x) result(res)
    ! First derivative of the sigmoid activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = sigmoid(x) * (1 - sigmoid(x))
  end function sigmoid_prime

  pure function softplus(x) result(res)
    ! Softplus activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = log(exp(x) + 1)
  end function softplus

  pure function softplus_prime(x) result(res)
    ! First derivative of the softplus activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = exp(x) / (exp(x) + 1)
  end function softplus_prime

  pure function step(x) result(res)
    ! Step activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    where (x > 0)
      res = 1
    elsewhere
      res = 0
    end where
  end function step

  pure function step_prime(x) result(res)
    ! First derivative of the step activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = 0
  end function step_prime

  pure function tanhf(x) result(res)
    ! Tangent hyperbolic activation function.
    ! Same as the intrinsic tanh, but must be
    ! defined here so that we can use procedure
    ! pointer with it.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = tanh(x)
  end function tanhf

  pure function tanh_prime(x) result(res)
    ! First derivative of the tanh activation function.
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = 1 - tanh(x)**2
  end function tanh_prime

end module nf_activation


      subroutine DCOV2( A, MDIM, N, IP, VAR, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-02-13 DCOV2  Krogh   Fixed a comment.
c>> 1996-03-30 DCOV2  Krogh   Added external statement.
C>> 1994-11-11 DCOV2  Krogh   Declared all vars.
C>> 1994-10-20 DCOV2  Krogh  Changes to use M77CON
C>> 1989-10-20 DCOV2  CLL
C>> 1987-11-24 DCOV2  Lawson  Initial code.
c--D replaces "?": ?COV2, ?DOT, ?SWAP
C     Computes upper triangle of covariance matrix,
c     beginning with the triangular matrix, and permutation record, and
c     data error variance computed by _HFTI.
c     Thus, given a matrix, A, represented by the upper triangular
c     matrix in A(), and the permutation record in IP(), and the data
c     error variance, VAR, we compute the upper triangle of the
c     symmetric matrix, C = VAR * ((A**t)*A)**(-1).
C     Adapted from PROG2 in L & H book.
c     ------------------------------------------------------------------
c     Subprograms referenced directly: DDOT, DSWAP, IERM1
c     Other subprograms needed: ERMSG, IERV1, ERFIN, AMACH
c     ------------------------------------------------------------------
c                 Subroutine Arguments
c
c     A(,) [inout] On entry, contains the upper triangular matrix, A,
c                  in standard, not packed, storage.  This matrix could
c                  have been produced by _HFTI.  On return, contains the
c                  upper triangle of the symmetric unscaled covariance
c                  matrix.  Elements below the diagonal in A(,) will
c                  not be referenced.
c     MDIM [in]    First dimension of A(,).  Require MDIM .ge. N.
c     N [in]       Order of the matrix in A(,)
c     IP() [in]    Permutation record produced by _HFTI.
c     VAR  [in]    Estimate of variance of data error.
c     IERR [out]   Set to 0 if ok.  Set to J > 0 if the (J,J) element
c                  of the given matrix is zero.  In this latter case
c                  the covariance matrix cannot be computed and the
c                  contents of A(,) on return will be meaningless.
C     ------------------------------------------------------------------
c          This code was originally developed by Charles L. Lawson and
c     Richard J. Hanson at Jet Propulsion Laboratory in 1973.  The
c     original code was described and listed in the book,
c
c                  Solving Least Squares Problems
c                  C. L. Lawson and R. J. Hanson
c                  Prentice-Hall, 1974
c
c     Feb, 1985, C. L. Lawson & S. Y. Chan, JPL.  Adapted code from the
c     Lawson & Hanson book to Fortran 77 for use in the JPL MATH77
c     library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for intrinsic functions.
c     Adding calls to BLAS and MATH77 error processing subrs in some
c     program units.
C     1989-10-20 CLL Moved integer declaration earlier to avoid warning
c     msg from Cray compiler.
C     ------------------------------------------------------------------
      external DDOT
      integer I, IERR, J, N, MDIM, K, IP1, KP1
      integer IP(N)
      double precision A(MDIM,N), DDOT, ONE, TMP, VAR, ZERO
C
      parameter(ZERO = 0.0D0, ONE = 1.0D0)
C     ------------------------------------------------------------------
C     Replace upper triangular matrix U by its inverse, Inv(U)
c
      do 40 J = 1,N
         if(A(J,J) .eq. ZERO) then
            call IERM1('DCOV2',1,0,'Jth diagonal elt is zero',
     *      'J',J,'.')
            IERR = J
            return
         end if
         A(J,J) = ONE / A(J,J)
   40 continue

      do 62 I = 1,N-1
         do 60 J = I+1,N
            A(I,J) = -A(J,J) * DDOT(J-I,A(I,I),MDIM,A(I,J),1)
   60    continue
   62 continue
C
C     Replace Inv(U) by upper triangle of Inv(u) * Trans(Inv(U))
c     multiplied by VAR.
c
      do 92 I = 1,N
         do 90 J = I,N
            A(I,J) = VAR * DDOT(N-J+1,A(I,J),MDIM,A(J,J),MDIM)
   90    continue
   92 continue
C                                 Permute rows & columns
      do 150 I = N-1, 1, -1
         if (IP(I) .ne. I) then
            K = IP(I)
            TMP = A(I,I)
            A(I,I) = A(K,K)
            A(K,K) = TMP
            if (I .gt. 1) THEN
              CALL DSWAP(I-1,A(1,I),1,A(1,K),1)
            end if
            IP1 = I + 1
            if (IP1 .lt. K) THEN
              CALL DSWAP(K-I-1,A(I,IP1),MDIM,A(IP1,K),1)
            end if
            KP1 = K + 1
            if (KP1 .le. N) THEN
              CALL DSWAP(N-K,A(I,KP1),MDIM,A(K,KP1),MDIM)
            end if
         end if
  150                     continue
      IERR = 0
      end


program tsunami

  ! This version solves the non-linear 1-d shallow water equations:
  !
  !     du/dt + u du/dx = - g dh/dx
  !
  !     du/dt + u du/dx = - g dh/dx
  !
  ! The initial conditions and the finite difference calculation
  ! are abstracted as external procedures.

  use iso_fortran_env, only: int32, real32
  use mod_diff, only: diff => diff_centered
  use mod_initial, only: set_gaussian

  implicit none

  integer(int32) :: n

  integer(int32), parameter :: grid_size = 100 ! grid size in x
  integer(int32), parameter :: num_time_steps = 5000 ! number of time steps

  real(real32), parameter :: dt = 0.02 ! time step [s]
  real(real32), parameter :: dx = 1 ! grid spacing [m]
  real(real32), parameter :: g = 9.8 ! gravitational acceleration [m/s^2]
  real(real32), parameter :: hmean = 10 ! mean water depth [m]

  real(real32) :: h(grid_size), u(grid_size)

  integer(int32), parameter :: icenter = 25
  real(real32), parameter :: decay = 0.02

  ! check input parameter values
  if (grid_size <= 0) stop 'grid_size must be > 0'
  if (dt <= 0) stop 'time step dt must be > 0'
  if (dx <= 0) stop 'grid spacing dx must be > 0'

  ! initialize water height to a Gaussian blob
  call set_gaussian(h, icenter, decay)

  ! initialize water velocity to zero
  u = 0

  ! write initial state to screen
  print *, 0, h

  time_loop: do n = 1, num_time_steps

    ! compute u at next time step
    u = u - (u * diff(u) + g * diff(h)) / dx * dt

    ! compute h at next time step
    h = h - diff(u * (hmean + h)) / dx * dt

    ! write current state to screen
    print *, n, h

  end do time_loop

end program tsunami


C$Procedure      VADDG ( Vector addition, general dimension )

      SUBROUTINE VADDG ( V1, V2, NDIM, VOUT )

C$ Abstract
C
C     Add two vectors of arbitrary dimension.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C
C$ Declarations

      INTEGER             NDIM
      DOUBLE PRECISION    V1   ( NDIM )
      DOUBLE PRECISION    V2   ( NDIM )
      DOUBLE PRECISION    VOUT ( NDIM )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V1         I   First vector to be added.
C     V2         I   Second vector to be added.
C     NDIM       I   Dimension of V1, V2, and VOUT.
C     VOUT       O   Sum vector, V1 + V2.
C
C$ Detailed_Input
C
C     V1      This may be any double precision vector of arbitrary
C             dimension.
C
C     V2      Likewise.
C
C     NDIM    is the dimension of V1, V2 and VOUT.
C
C$ Detailed_Output
C
C     VOUT   This is vector sum of V1 and V2.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine simply performs addition between components of V1
C     and V2.  No checking is performed to determine whether floating
C     point overflow has occurred.
C
C$ Examples
C
C     The following table shows the output VOUT as a function of the
C     the input V1 and V2 from the subroutine VADD.
C
C        V1                  V2                 NDIM   VOUT
C        ---------------------------------------------------------------
C        (1.0, 2.0, 3.0)     (4.0, 5.0, 6.0)    3      (5.0,  7.0,  9.0)
C        (1D-7,1D23)         (1D24, 1D23)       2      (1D24, 2D23)
C
C$ Restrictions
C
C     The user is required to determine that the magnitude each
C     component of the vectors is within the appropriate range so as
C     not to cause floating point overflow.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.2, 07-NOV-2003 (EDW)
C
C        Corrected a mistake in the second example's value
C        for VOUT, i.e. replaced (1D24, 2D23, 0.0) with
C        (1D24, 2D23).
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     n-dimensional vector addition
C
C-&

      INTEGER I
C
      DO I = 1, NDIM
         VOUT(I) = V1(I) + V2(I)
      END DO

      RETURN
      END


PROGRAM main
USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY : DFP=>real64, I4B=>int32
USE AutoDiff_Module
IMPLICIT NONE

PROCEDURE( func ), POINTER :: f => NULL()
f => func

WRITE( *, * ) Derivative( f=f, x=1.0_DFP )

CONTAINS
  PURE FUNCTION func( x ) RESULT( Ans )
    REAL( DFP ), INTENT( IN ) :: x
    REAL( DFP ) :: Ans
    Ans = x**2
  END FUNCTION func
END PROGRAM main


!===== Subroutine for generating a flatted vector for the
!===== two mass triangle topology, here P1^2 ne 0 and P2^2=0
      subroutine gen_kflat_2mtri(p,n,P1,P2,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'utoolscc.f'
      integer n,nu
      double precision p(mxpart,4),P1(4),P2(4)
      double precision po(mxpart,4)
      double precision P1sq,P1dP2

      po(:,:)=p(:,:)
      P1sq=P1(4)**2-P1(3)**2-P1(2)**2-P1(1)**2

      P1dP2=2d0*(P1(4)*P2(4)-P1(3)*P2(3)-P1(2)*P2(2)-P1(1)*P2(1))

      do nu=1,4
         po(n+1,nu)=P1(nu)-P1sq/P1dP2*P2(nu)
      enddo
      if (utoolscc) then
        call spinoruorz(n+1,po,zb,za)
      else
        call spinoruorz(n+1,po,za,zb)
      endif

      return
      end

!===== Subroutine for generating a flatted vector for the
!===== three mass triangle topology, here P1^2 ne 0 and P2^2 ne 0
!===== also return gamma (with the positive sign)
      subroutine gen_kflat_3mtri(p,n,P1,P2,za,zb,gamma)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'utoolscc.f'
      integer n,nu
      double precision p(mxpart,4),P1(4),P2(4)
      double precision po(mxpart,4)
      double precision P1sq,P1dP2,P2sq,gamma

      po(:,:)=p(:,:)
      P1sq=P1(4)**2-P1(3)**2-P1(2)**2-P1(1)**2
      P2sq=P2(4)**2-P2(3)**2-P2(2)**2-P2(1)**2

      P1dP2=(P1(4)*P2(4)-P1(3)*P2(3)-P1(2)*P2(2)-P1(1)*P2(1))

      gamma=P1dP2+dsqrt(P1dP2**2-P1sq*P2sq)

      do nu=1,4
         po(n+1,nu)=P1(nu)-P1sq/gamma*P2(nu)
         po(n+1,nu)=po(n+1,nu)/(one-P1sq*P2sq/gamma**2)
         po(n+2,nu)=P2(nu)-P2sq/gamma*P1(nu)
         po(n+2,nu)=po(n+2,nu)/(one-P1sq*P2sq/gamma**2)
      enddo
      if (utoolscc) then
        call spinoruorz(n+2,po,zb,za)
      else
        call spinoruorz(n+2,po,za,zb)
      endif

      return
      end


      subroutine small_strain_elastic_lamina2D(matData,F,stre,cc)

      implicit none

      integer          i, j

      double precision matData(*), F(2,*), stre(*), cc(4,*),
     *                 E1, E2, nu12, nu21, G12, alpha, eps(3), fact,
     *                 Q11, Q22, Q12, Q66, m, m2, m4, n, n2, n4, m2n2,
     *                 m3n, mn3, Qxx, Qyy, Qxy, Qxs, Qys, Qss,
     *                 r1d2, r1, r2, r4

      data r1d2, r1, r2, r4 / 0.5d0, 1.d0, 2.d0, 4.d0 /

      E1    = matData(1)
      E2    = matData(2)
      nu12  = matData(3)
      nu21  = E2 / E1 * nu12
      G12   = matData(5)
      alpha = matData(6) * acos(-r1) / 180.d0

c     strain tensor

      eps(1) = F(1,1) - r1
      eps(2) = F(2,2) - r1
      eps(3) = r1d2 * (F(1,2) + F(2,1))

c     tangent tensor

      fact = r1 / (r1 - nu12*nu21)

      Q11  = fact * E1
      Q22  = fact * E2
      Q12  = nu21 * Q11
      Q66  = G12

      m    = cos(alpha)
      n    = sin(alpha)

      m2   = m * m
      m4   = m2 * m2
      n2   = n * n
      n4   = n2 * n2
      m2n2 = m2 * n2
      mn3  = m * n * n2
      m3n  = m * n * m2

      Qxx  = m4 * Q11 + n4 * Q22 + (m2n2+m2n2) * Q12 + r4*m2n2 * Q66
      Qyy  = n4 * Q11 + m4 * Q22 + (m2n2+m2n2) * Q12 + r4*m2n2 * Q66
      Qxy  = m2n2 * (Q11 + Q22) + (m4 + n4) * Q12 - r4*m2n2 * Q66
      Qxs  = m3n * Q11 - mn3 * Q22 + (mn3-m3n) * (Q12 + Q66 + Q66)
      Qys  = mn3 * Q11 - m3n * Q22 + (m3n-mn3) * (Q12 + Q66 + Q66)
      Qss  = m2n2 * (Q11 + Q22 - Q12 - Q12) + (m4-m2n2-m2n2+n4) * Q66

      cc(1,1) = Qxx
      cc(1,2) = Qxy
      cc(1,3) = Qxs
      cc(2,1) = Qxy
      cc(2,2) = Qyy
      cc(2,3) = Qys
      cc(3,1) = Qxs
      cc(3,2) = Qys
      cc(3,3) = Qss

c     stress

      stre(1) = cc(1,1)*eps(1) + cc(1,2)*eps(2) + r2*cc(1,3)*eps(3)
      stre(2) = cc(2,1)*eps(1) + cc(2,2)*eps(2) + r2*cc(2,3)*eps(3)
      stre(3) = cc(3,1)*eps(1) + cc(3,2)*eps(2) + r2*cc(3,3)*eps(3)

      return

      end


SUBROUTINE glob_to_axial(axial,global,coord)
!
! This subroutine transforms the global end reactions
! into an axial force for rod elements (2- or 3-d).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::global(:),coord(:,:)
 REAL(iwp),INTENT(OUT)::axial
 REAL(iwp)::add,ell,zero=0.0_iwp
 INTEGER::ndim,i
 ndim=UBOUND(coord,2)
 add=zero
 DO i=1,ndim
   add=add+(coord(2,i)-coord(1,i))**2
 END DO
 ell=SQRT(add)
 axial=zero
 DO i=1,ndim
   axial=axial+(coord(2,i)-coord(1,i))/ell*global(ndim+i)
 END DO
RETURN
END SUBROUTINE glob_to_axial


! File: spanlib.f90
!
! This file is part of the SpanLib library.
! Copyright (C) 2006  Stephane Raynaud
! Contact: stephane dot raynaud at gmail dot com
!
! This library is free software; you can redistribute it and/or
! modify it under the terms of the GNU Lesser General Public
! License as published by the Free Software Foundation; either
! version 2.1 of the License, or (at your option) any later version.

! This library 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
! Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public
! License along with this library; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

module spanlib

!	interface spanlib_interface
!		module procedure sl_pca, sl_pcarec, sl_mssa, sl_mssarec, sl_phasecomp, sl_diasym
!	end interface

contains

	! ############################################################
	! ############################################################
	! ## PCA PART ################################################
	! ############################################################
	! ############################################################

	subroutine sl_pca(ff, nkeep, xeof, pc, ev, weights, useteof)

	! Title:
	!	Principal Component Analysis
	!
	! Description:
	!	Perform a decomposition of space-time field in a set of
	!	Empirical Orthogonal Functions (EOFs) and Principal components (PCs).
	!	The input data set can be optionally weighted in space.
	!	By default, the analysis computes  "temporal" (T) or classical
	!	spatial (S) EOFs depending on if the space dimension is greater
	!	than the time dimension. This default behavior can be overridden.
	!
	! Necessary arguments:
	!	- ff:			Space-time array
	!
	! Optional arguments:
	!	- nkeep:		Maximum number of modes to keep in outputs
	!	- xeof:		Space-mode array of EOFs
	!	- pc:			Time-mode array of PCs
	!	- ev:			Mode array of eigen values (variances)
	!	- weights:	Space array of weights
	!	- useteof:	To force the use of T or S EOFs [0 = T, 1 = S, -1 = default]
	!
	! Dependencies:
	!	sl_diasym

	! Declarations
	! ============

	implicit none

	! External
	! --------
	real,    intent(in)                        :: ff(:,:)
	integer, intent(in),	optional              :: nkeep
	real,    intent(out),optional, allocatable :: pc(:,:), xeof(:,:), ev(:)
	real,    intent(in),	optional              :: weights(:)
	integer, intent(in),	optional              :: useteof

	! Internal
	! --------
	integer           :: ii,ij,nn,ns,nt
	real, allocatable :: cov(:,:)
	real, allocatable :: wff(:,:), ww(:), zeof(:,:), zff(:,:)
	real, allocatable :: eig(:)
	integer           :: zuseteof = -1, znkeep, znkeepmax=100, i,j

	! Setups
	! ======

	! Sizes
	! -----
	ns=size(ff,1)
	nt=size(ff,2)
	if(present(nkeep))then
		znkeep = nkeep
	else
		znkeep = minval(ubound(ff))
	end if
	if(znkeep>50)then
		print*,'[pca] You want to keep a nomber of PCs greater than 50!'
		return
	end if
	if(not(present(xeof)).and.not(present(pc)).and.not(present(ev)))then
		print*,'[pca] Nothing to do. Quit.'
		return
	end if

	! By default, T-EOF decompostion if ns > nt
	! -----------------------------------------
	if(present(useteof))zuseteof = useteof
	if(zuseteof.ne.0.and.zuseteof.ne.1)then
		if(ns>nt)then
			zuseteof=1
		else
			zuseteof=0
		endif
	endif

	! Remove the mean
	! ---------------
	allocate(zff(ns,nt))
	zff = ff - spread(sum(ff,dim=2)/real(nt), ncopies=nt, dim=2)

	! Default weights = 1.
	! --------------------
	allocate(ww(ns))
	allocate(wff(ns,nt))
	ww = 1.
	if(present(weights))then
		ww(:) = weights * real(ns) / sum(weights)
		where(ww==0.)
			ww = 1.
		end where
		do i = 1, nt
			wff(:,i) = zff(:,i) * sqrt(ww)
		end do
	else
		wff = zff
	end if

	! EOF decomposition
	! =================

	if(zuseteof==1)then

		! T-EOF case
		! ----------

		! Covariance
		allocate(cov(nt,nt))
		allocate(eig(nt))
		do i=1,nt
			do j=1,i
				cov(i,j) = dot_product(wff(:,i),wff(:,j))
				cov(j,i) = cov(i,j)
			end do
		end do
		cov = cov / float(ns)
		deallocate(wff)

		! Diagonalising (cov: input=cov, output=eof)
		call sl_diasym(cov,eig)

		! Back to S-EOFs
		if(present(pc).or.present(xeof))then
			allocate(zeof(ns,nkeep))
			zeof = matmul(zff, cov(:,nt:nt-nkeep+1:-1))
			deallocate(cov)
			do i = 1, nkeep
				zeof(:,i) = zeof(:,i) / sqrt(dot_product(ww(:), zeof(:,i)**2))
			end do
			if(not(present(pc)))then
				deallocate(ww)
			end if
		else
			deallocate(cov)
		end if

		! Eigenvalues
		! -----------
		if(present(ev))then
			if(not(allocated(ev))) allocate(ev(nkeep))
			ev = eig(nt:nt-nkeep+1:-1)
		end if

	else

		! S-EOF case (classical)
		! ----------------------

		! Covariance
		allocate(cov(ns,ns))
		allocate(eig(ns))
		do i=1,ns
			do j=1,i
				cov(i,j) = dot_product(wff(i,:), wff(j,:))
				cov(j,i) = cov(i,j)
			end do
		end do
		cov = cov / float(nt)
		deallocate(wff)

		! Diagonalisation (cov: input=cov, output=eof)
		call sl_diasym(cov,eig)

		! Formatting S-EOFs
		if(present(xeof).or.present(pc))then
			allocate(zeof(ns,nkeep))
			do i = 1, nkeep
!				zeof(:,i) = cov(:,ns:ns-nkeep+1:-1) / sqrt(ww(:,1:nkeep))
				zeof(:,i) = cov(:,ns-i+1) / sqrt(ww(:))
			end do
		end if
	   deallocate(cov)

		! Eigenvalues
		! -----------
		if(present(ev))then
			if(not(allocated(ev))) allocate(ev(nkeep))
			ev = eig(ns:ns-nkeep+1:-1)
		end if

	end if

	! Free eof array
	! --------------
	if(present(xeof))then
		if(not(allocated(xeof))) allocate(xeof(ns,nkeep))
		xeof = zeof
		if(not(present(pc))) deallocate(zeof)
	end if

	! Finally get PCs
	! ===============
	if(present(pc))then
		if(not(allocated(pc))) allocate(pc(nt,nkeep))
		if(present(weights))then
			do i=1, nt
				zff(:,i) = zff(:,i) * ww(:)
			end do
		end if
		pc = matmul( transpose(zff), zeof)
		do i = 1, nkeep
			pc(:,i) = pc(:,i) / dot_product(zeof(:,i)**2, ww(:))
		end do
	end if

	end subroutine sl_pca

	subroutine sl_pcarec(xeof, pc, ffrec, istart, iend)

	! Title:
	!	Reconstruction of a set of PCA components
	!
	! Description:
	!	Perform a reconstruction using a set of components previously
	!	computed with a PCA. All the reconstructed components are summed.
	!	A reconstructed component is simply the "product" of an EOF
	!	by its PC. The sum of all reconstructed component is the original field.
	!
	! Necessary arguments:
	!	- xeof:		Space-mode array of EOFs
	!	- pc:		Time-mode array of PCs
	!	- ffrec:	Space-time array of the reconstructed field
	!
	! Optional arguments:
	!	- istart:	Index of the first component to use
	!	- iend:		Index of the last component to use

	implicit none

	! Declarations
	! ============

	! External
	! --------
	real,	intent(in)				:: xeof(:,:), pc(:,:)
	real,	intent(out),allocatable	:: ffrec(:,:)
	integer,intent(in),	optional	:: istart, iend

	! Internal
	! --------
	integer 				:: nkept, itmp, zistart=1, ziend, nt, ns, i
	real, allocatable	:: zpc(:,:)

	! Setup
	! =====
	nkept = size(xeof,2)
	if(present(istart))zistart=istart
	if(present(iend))then
		ziend=iend
	else
		ziend=nkept
	end if
	if(zistart.lt.1.or.zistart.gt.nkept)then
		zistart=1
		print*,'[pcarec] istart lower than 1 => set to 1'
	end if
	if(ziend.lt.1.or.ziend.gt.nkept)then
		ziend=nkept
		print*,'[pcarec] iend greater than the number of avalaible modes => reduced to',iend
	end if
	if(zistart>ziend)then
		itmp=ziend
		ziend=zistart
		zistart=itmp
		print*,'[pcarec] istart > iend => inversion'
	end if
	ns = size(xeof,1)
	nt = size(pc,1)

	! Computation
	! ===========
	if(not(allocated(ffrec)))allocate(ffrec(ns, nt))
	ffrec = 0.
	if(nt<ns) then
		do i = 1, nt
			ffrec(:, i) = ffrec(:, i) + &
				&	matmul(xeof(:, zistart:ziend), pc(i, zistart:ziend))
		end do
	else
		allocate(zpc(ziend-zistart+1, nt))
		zpc = transpose(pc(:, zistart:ziend))
		do i = 1, ns
			ffrec(i, :) = ffrec(i, :) + &
				&	matmul(xeof(i, zistart:ziend), zpc)
		end do
	end if

!	Obsolete formulation using too much memory
!	ffrec = matmul( xeof(:, zistart:ziend), transpose(pc(:, zistart:ziend)) )

	end subroutine sl_pcarec

  !############################################################
  !############################################################
  !## MSSA PART ###############################################
  !############################################################
  !############################################################

	subroutine sl_mssa(ff, nwindow, nkeep, steof, stpc, ev)

	! Title:
	!	Multi-channel Singular Spectrum Analysis
	!
	! Description:
	!	Perform a decomposition of space-time field in a set of
	!	space-time Empirical Orthogonal Functions (EOFs) and
	!	time Principal components (PCs), according to a window
	!	parameter.
	!
	! Necessary arguments:
	!	- ff:      Space-time array
	!	- nwindow: Window size
	!	- nkeep:   Maximum number of modes to keep in outputs
	!
	! Optional arguments:
	!	- steof: SpaceXwindow-mode array of EOFs
	!	- stpc:  Time-mode array of PCs
	!	- ev:    Mode array of eigen values (variances)
	!
	! Dependencies:
	!	sl_diasym

	implicit none

	! Declarations
	! ============

	! External
	! --------
	real,   intent(in)									:: ff(:,:)
	integer,intent(in)									:: nwindow, nkeep
	real,	  intent(out), optional, allocatable	:: steof(:,:), stpc(:,:), ev(:)

	! Internal
	! --------
	real, allocatable :: cov(:,:), eig(:), trff(:,:), zff(:,:), zsteof(:,:)
	real :: wsteof
	integer :: nchan, nsteof, nt
	integer :: iw, iw1, iw2, i1, i2, im, ic1, ic2

	! Setup
	! =====

	! Sizes
	! -----
	nchan = size(ff,1)
	nsteof = nchan * nwindow
	nt = size(ff,2)

	! Remove the mean
	! ---------------
	allocate(zff(nchan, nt))
	zff = ff - spread(sum(ff,dim=2)/real(nt), ncopies=nt, dim=2)

	! Set the block-Toeplitz covariance matrix
	! ========================================
	allocate(cov(nsteof, nsteof))
	do ic1 = 1, nchan
		do ic2 = 1, nchan
			do iw2 = 1, nwindow
				do iw1 = 1, iw2
					i1 = (ic1-1) * nwindow + iw1
					i2 = (ic2-1) * nwindow + iw2
					iw = iw2 - iw1 + 1
					cov(i1,i2) = &
						& dot_product(zff(ic1, 1  : nt-iw+1), &
						&			 zff(ic2, iw : nt	 )) / real(nt-iw+1)
					cov(i2,i1) = cov(i1,i2)
				end do
			end do
		end do
	end do

	! Diagonalisation
	! ===============
	allocate(eig(nsteof))
	call sl_diasym(cov,eig)

	! Get ST-EOFs and eigenvalues
	! ===========================
	if(present(steof).or.present(stpc))then
		allocate(zsteof(nsteof, nkeep))
		zsteof = cov(:, nsteof : nsteof-nkeep+1 : -1)
		deallocate(cov)
		if(present(steof))then
			if(not(allocated(steof))) allocate(steof(nsteof, nkeep))
			steof = zsteof
			deallocate(zsteof)
		end if
	end if

	! Eigen values
	! ------------
	if(present(ev))then
		if(not(allocated(ev))) allocate(ev(nkeep))
		ev = eig(nsteof : nsteof-nkeep+1 : -1)
	end if
	deallocate(eig)

	! Get ST-PCs
	! ==========
	if(present(stpc))then
		if(not(allocated(stpc))) allocate(stpc(nt-nwindow+1, nkeep))
		allocate(trff(nt, nchan))
		trff = transpose(zff)
		do im = 1, nkeep
			wsteof = sum(steof(:,im)**2)
			do iw = 1, nwindow
				stpc(:, im)  =  stpc(:, im) + matmul( &
					& trff ( iw : iw+nt-nwindow, :), &
					& steof( iw : iw+(nchan-1)*nwindow : nwindow , im ) ) / wsteof
			end do
		end do
	end if

  end subroutine sl_mssa

	subroutine sl_mssarec(steof, stpc, nwindow, ffrec, istart, iend)

	! Title:
	!	Reconstruction of a set of MSSA components
	!
	! Description:
	!	Same as for the reconstruction of PCA components, but for MSSA.
	!
	! Necessary arguments:
	!	- steof:   SpaceXwindow-mode array of EOFs
	!	- stpc:    Time-mode array of PCs
	!	- nwindow: Window size
	!	- ffrec:   Space-time array of the reconstructed field
	!
	! Optional arguments:
	!	- istart: Index of the first component to use
	!	- iend:   Index of the last component to use

	implicit none

	! Declarations
	! ============

	! External
	! --------
	real,	intent(in)					:: steof(:,:), stpc(:,:)
	real,	intent(out), allocatable	:: ffrec(:,:)
	integer,intent(in)					:: nwindow
	integer,intent(in), optional		:: istart, iend

	! Internal
	! --------
	integer :: ntpc, nchan, nt, ic, im, iw, nkept, itmp, zistart=1, ziend
	real, allocatable :: reof(:), epc(:,:)

	! Setup
	! =====

	! Sizes
	! -----
	ntpc  = size(stpc, 1)
	nt    = ntpc+nwindow-1
	nchan = size(steof, 1)/nwindow
	nkept = size(steof, 2)
	allocate(reof(nwindow))
	allocate(epc(nwindow, ntpc-nwindow+1))
	if(not(allocated(ffrec))) allocate(ffrec(nchan, nt))
	ffrec = 0.

	! Range
	! -----
	if(present(istart))zistart=istart
	if(present(iend))then
		ziend=iend
	else
		ziend=nkept
	end if
	if(zistart.lt.1.or.zistart.gt.nkept)then
		zistart = 1
		print*,'[mssarec] istart lower than 1 => set to 1'
	end if
	if(ziend.lt.1.or.ziend.gt.nkept)then
		ziend = nkept
		print*,'[mssarec] iend greater than the number of avalaible modes => reduced to',iend
	end if
	if(zistart>ziend)then
		itmp    = ziend
		ziend   = zistart
		zistart = itmp
		print*,'[mssarec] istart > iend => inversion'
	end if

	! Computation
	! ===========
	do im = zistart, ziend ! sum over the selection of modes

		! (ntpc-nwindow+1) length slices
		do iw = 1, nwindow
			epc(iw,:) = stpc(iw : iw+ntpc-nwindow, im)
		end do

		do ic = 1, nchan ! sum over the channels (= space or PCs from simple PCA)

			! reversed eof
			reof = steof(nwindow+(ic-1)*nwindow : 1+(ic-1)*nwindow : -1, im)

			! * middle * [nwindow length projections]
			ffrec(ic, nwindow : ntpc) =  ffrec(ic, nwindow : ntpc) + &
				& matmul(reof, epc) / real(nwindow)

		  do iw = 1, nwindow-1

			 ! * beginning * [iw length projections]
			 ffrec(ic, iw) = ffrec(ic, iw) + &
				  & dot_product( reof(nwindow-iw+1:nwindow),  stpc(1		:iw,   im) ) / real(iw)
!
			 ! * end * [iw length projections]
			 ffrec(ic, nt-iw+1) = ffrec(ic, nt-iw+1) + &
				  & dot_product( reof(1		   :iw),	   stpc(ntpc-iw+1:ntpc, im) ) / real(iw)

			end do

		end do

	end do

	end subroutine sl_mssarec

  ! ############################################################
  ! ############################################################
  ! ## TOOLS PART ##############################################
  ! ############################################################
  ! ############################################################

	subroutine sl_phasecomp(ffrec, np, phases, weights, offset, firstphase)

	! Title:
	!	Phase composites
	!
	! Description:
	!	Performs phase composites of S-T oscillatory field.
	!	This field is typically a reconstructed pair of MSSA modes.
	!	Composites are evaluated according to an index defined by the
	!	first PC of the input field and its derivative.
	!	Space weights can be optionally used to compute the PC.
	!	A minimal normalized amplitude can be also used: when the
	!	index is under value, data are not used to compute phases.
	!	It is also possible so specify the angle of the first phase
	!	in the 360 degrees phase diagram circle: zero means the
	!	the first phase conincides with the maximmum.
	!
	!
	! Necessary arguments:
	!	- ffrec: Space-time array
	!	- np:    Number of requested phases over the 360 degrees cycle (default = 8)
	!
	! Optional arguments:
	!	- weights:    Space array of weights
	!	- offset:     Minimal normalized amplitude of the index (default = 0.)
	!	- firstphase: Value in degrees of the first phase (default = 0)
	!
	! Dependencies:
	!	sl_pca

	implicit none

	! Declarations
	! ============

	! External
	! --------
	integer, intent(in)	:: np
	real,	intent(in)   :: ffrec(:,:)
	real,	intent(in), optional :: weights(:)
	real,	intent(in), optional :: offset, firstphase
	real,	intent(out), allocatable   :: phases(:, :)

	! Internal
	! --------
	real, allocatable :: xeof(:,:), pc(:,:)
	real :: dpc(size(ffrec,2)), amp(size(ffrec,2))
	integer :: nt, iphase
	real :: angles(np), projection(size(ffrec,2))
	real :: pi, deltarad, pcos, psin, zoffset, zfirstphase
	logical :: select_amplitude(size(ffrec,2)), select_phase(size(ffrec,2))
	integer :: itime(size(ffrec,2)), nsel, i, ns
	integer, allocatable :: isel(:)

	! Setup
	! =====
	nt = size(ffrec,2)
	pi = acos(-1.)
	itime = (/ (i, i=1, nt) /)
	ns = size(ffrec, 1)
	if(present(offset))then
		zoffset=offset
	else
		zoffset=0.
	end if

	! Find the first PC and its derivative
	! ====================================
	call sl_pca(ffrec, 1, pc=pc, weights=weights)
	pc = pc * sqrt(real(nt)/sum(pc**2))
	dpc = 0.5 * (eoshift(pc(:,1), 1, pc(nt,1)) - eoshift(pc(:,1), -1, pc(1,1)))
	dpc((/1,nt/)) = dpc((/1,nt/)) * 2.
	dpc = dpc * sqrt(real(nt)/sum(dpc**2))
	amp = sqrt(pc(:,1)**2 + dpc**2)

	! Compute the maps
	! ================

	! Define the marks
	! ----------------
	deltarad = 2 * pi / real(np)
	if(present(firstphase))then
		zfirstphase = modulo(firstphase * 2 * pi / 360., 2 * pi)
	else
	   zfirstphase = 0.
	end if
	angles = (/ (real(iphase), iphase=0,np-1) /) * deltarad + zfirstphase

	! Compute the phase maps
	! ----------------------
	if(not(allocated(phases))) allocate(phases(ns, np))
	phases = 0.
	select_amplitude = amp >= zoffset
	do iphase = 1, np
		pcos = cos(angles(iphase))
		psin = sin(angles(iphase))
		projection =  (pc(:,1)*pcos+dpc*psin) / amp
		select_phase = ( projection >= cos(0.5*deltarad) ) .and. select_amplitude
		if(any(select_phase))then
			nsel = count(select_phase)
			allocate(isel(nsel))
			isel = pack(itime, select_phase)
			phases(:,iphase) = sum(ffrec(:,isel), dim=2) / real(nsel)
			deallocate(isel)
		end if
	end do

	end subroutine sl_phasecomp

  subroutine sl_diasym(a,eig)

	! Title:
	!	Diagonalisation of a symetric matrix
	!
	! Description:
	!	A simple interface to the ssyev diagonalisation subroutine from LAPACK.
	!
	! Necessary arguments:
	!	- a:		Input = symetric matrix, output = EOFs
	!	- eig:	Eigen values
	!
	! Dependencies:
	!	ssyev(LAPACK)

	implicit none

	! Declaratiions
	! =============

	! External
	! --------
	real, intent(inout) 			::  a(:,:)
	real, intent(out), allocatable	:: eig(:)

	! Internal
	! --------
	integer :: n,lwork,inf
	real, allocatable :: work(:)

	! Sizes
	! -----

	! Data set
	n=size(a,1)
	allocate(eig(n))

	! Working array [other values of lwork: (N+2)*N, n*(3+n/2)]
	lwork=1+ 6*N + 2*N**2
	allocate(work(lwork))

	! Diagonalisation
	! ---------------
	call ssyev('V','U',n,a,n,eig,work,lwork,inf)

	end subroutine sl_diasym

end module spanlib


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
c
      program testfft
C      USE NUFFTModule
      implicit none
c
c --- local variables
c
      integer i,ier,iflag,j,k1,mx,ms,nj
      parameter (mx=10 000)
      real*4 xj(mx), sk(mx)
      real*4 eps,pi
      real*8 err
      parameter (pi=3.141592653589793238462643383279502884197e0)
      complex*8 cj(mx),cj0(mx),cj1(mx)
      complex*8 fk0(mx),fk1(mx)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
      ms = 90
      nj = 128
      do k1 = -nj/2, (nj-1)/2
         j = k1+nj/2+1
         xj(j) = pi * cos(-pi*j/nj)
         cj(j) = cmplx( sin(pi*j/nj), cos(pi*j/nj))
c         print*,xj(j),cj(j)
      enddo
c
c     --------------------------------------------------
c     start tests
c     --------------------------------------------------
c

		call nufft_ffte(1)

      iflag = 1
      print*,' Start 1D testing: ', ' nj =',nj, ' ms =',ms
      do i = 1,5
         if (i.eq.1) eps=1e-3
         if (i.eq.2) eps=1e-4
         if (i.eq.3) eps=1e-5
         if (i.eq.4) eps=1e-6
         if (i.eq.5) eps=1e-7
c extended/quad precision tests
c         if (i.eq.5) eps=1d-20
c         if (i.eq.6) eps=1d-24
c         if (i.eq.7) eps=1d-28
c         if (i.eq.8) eps=1d-32
	 print*,' '
  	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 1D Type1 method
c     -----------------------
c
		iflag = -1
         call dirft1d1f(nj,xj,cj,iflag, ms,fk0)
         call nufft1d1ff90_ffte(nj,xj,cj,iflag,eps, ms,fk1,ier)
         call errcompf(fk0,fk1,ms,err)
         print *,' ier = ',ier
         print *,' type 1 error = ',err
c
c     -----------------------
c     call 1D Type2 method
c     -----------------------
c
         call dirft1d2f(nj,xj,cj0,iflag, ms,fk0,ier)
         call nufft1d2ff90_ffte(nj,xj,cj1,iflag, eps, ms,fk0,ier)
         call errcompf(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 2 error = ',err
c
c     -----------------------
c     call 1D Type3 method
c     -----------------------
         do k1 = 1, ms
            sk(k1) = 48*cos(k1*pi/ms)
         enddo
         call dirft1d3f(nj,xj,cj,iflag, ms,sk,fk0)
         call nufft1d3ff90_ffte(nj,xj,cj,iflag,eps, ms,sk,fk1,ier)
         call errcompf(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 3 error = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcompf(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex*8 fk0(n), fk1(n)
      real *8 salg,ealg,err
c
      ealg = 0e0
      salg = 0e0

      do k = 1, n
         ealg = ealg + REAL(cabs(fk1(k)-fk0(k)))**2
         salg = salg + REAL(cabs(fk0(k)))**2
C         print *,fk1(k),fk0(k)
      enddo
C      print *,'ealg,salg:',ealg,salg
      err =sqrt(ealg/salg)
      return
      end


program do_factorials
    implicit none
    integer, parameter :: MAX_N = 10
    integer :: i

    do i = 1, MAX_N
        print *, i, factorial(i)
    end do

contains

    function factorial(n) result(fac)
        implicit none
        integer, intent(in) :: n
        integer :: fac
        integer :: i

        fac = 1
        do i = 2, n
            fac = fac*i
        end do
    end function factorial

end program do_factorials


PROGRAM A4Q1
!--
! Finds the number of weakly increasing/decreasing sequences given an array.
!--
IMPLICIT NONE
INTEGER, DIMENSION (:), ALLOCATABLE :: a
INTEGER :: k, check

PRINT *, 'Finds the number of weakly increasing/decreasing sequences given the specified array.'
DO
    PRINT *, 'Enter the size of the array: k (or 0 to stop).'
    READ *, k
    IF (K .eq. 0) STOP
    IF (k .lt. 0) THEN
      	PRINT *, 'k must be a positive nonzero number. Try again.'
    ELSE
      	ALLOCATE(a(k), STAT=check)
        IF (check .ne. 0) THEN
          	PRINT "(1X, 'Allocation unseccessful for an array of size:', I3)", k
        ELSE
			PRINT "(1X, 'enter the values of all', I3, ' elements')", k
        	READ *, a
        	PRINT "(1X, 'accepted: ', 15I5)", a
            PRINT *, 'result: ', CountSeq(a, k)
            DEALLOCATE(a)
        END IF
    END IF
END DO

CONTAINS
INTEGER FUNCTION CountSeq(a,k)
    INTEGER, DIMENSION (1:k), INTENT(IN) :: a
	INTEGER, INTENT(IN) :: k
    INTEGER :: c, i, direction
    ! direction:
    ! 1 => increasing
    ! -1 => decreasing

    direction = 0
    c = 0
    IF (k .eq. 1) THEN
      	CountSeq = 0
	ELSE
		DO i = 1,(k - 1)
    		IF (a(i) .lt. a(i+1) .and. direction .lt. 1) THEN
      			direction = 1
      			c = c + 1
    		ELSE IF (a(i) .gt. a(i+1) .and. direction .gt. -1) THEN
      			direction = -1
       			c = c + 1
    		END IF
    	END DO
    END IF
	CountSeq = c

END FUNCTION CountSeq
END PROGRAM A4Q1