use sim
implicit none

type(SeismicAnalysis_) :: seismic
type(FEMDomain_),target :: cube,original
type(IO_) :: f,response,history_A,history_V,history_U,input_wave
type(Math_) :: math
real(real64),allocatable :: disp_z(:,:)
real(real64) :: wave(200,2),T,Duration,dt
integer(int32) :: i,j,cases,stack_id,num_of_cases

num_of_cases = 4

! create Domain
call cube%create(meshtype="Cube3D",x_num=4,y_num=4,z_num=20)
call cube%resize(x=1.0d0,y=1.0d0,z=5.0d0)
call cube%move(z=-5.0d0)

! create Wave
T = 0.300d0
Duration = T * 10.0d0 ! sec.
dt = Duration/dble(size(wave,1))!/10.0d0

wave(:,:) = 0.0d0
do i=1,size(wave,1)
    wave(i,1) = dt*dble(i)
    wave(i,2) = sin(2.0d0*math%pi/T*wave(i,1) )
enddo
call input_wave%open("input_wave.txt" )
call input_wave%write(wave )
call input_wave%close()
original = cube

! set domain
seismic%femdomain => cube
! set wave
seismic%wave = wave
seismic%dt = dt
! run simulation
call seismic%init()
!call seismic%fixDisplacement(z_max = -4.99d0,direction="x")
call seismic%fixDisplacement(z_max = -4.99d0,direction="y")
call seismic%fixDisplacement(z_max = -4.99d0,direction="z")
call seismic%fixDisplacement(y_max = 0.0d0,direction="y")
call seismic%fixDisplacement(y_min = 1.0d0,direction="y")
call seismic%fixDisplacement(direction="z")
call seismic%femdomain%vtk("mesh_init" )
call seismic%loadWave(z_max=-4.50d0,direction="x",wavetype=WAVE_ACCEL)

seismic%Density(:)      = 17000.0d0 !(N/m/m/m)
seismic%PoissonRatio(:) = 0.330d0
seismic%YoungModulus(:) = 25372853.0 !(N/m/m) Vs=121 m/s

!seismic%alpha = 0.0d0
seismic%a = 0.0d0
seismic%v = 0.0d0
seismic%u = 0.0d0

do i=1,199
    !seismic%beta = 0.0d0
    call history_A%open("history_A"//str(i)//".txt","w")
    call history_V%open("history_V"//str(i)//".txt","w")
    call history_U%open("history_U"//str(i)//".txt","w")

    call seismic%run(timestep=[i,i+1],AccelLimit=10.0d0**8)

    do j=1,seismic%femdomain%nn()
        if(seismic%femdomain%position_x(j)/=0.0d0) cycle
        if(seismic%femdomain%position_y(j)/=0.0d0) cycle
        write(history_A%fh,*) real(dble(i)*dt),&
        seismic%femdomain%position_z(j), real(seismic%A( (j-1)*3 + 1  ))
    enddo
    do j=1,seismic%femdomain%nn()
        if(seismic%femdomain%position_x(j)/=0.0d0) cycle
        if(seismic%femdomain%position_y(j)/=0.0d0) cycle
        write(history_V%fh,*) real(dble(i)*dt),&
        seismic%femdomain%position_z(j), real(seismic%V( (j-1)*3 + 1  ))
    enddo
    do j=1,seismic%femdomain%nn()
        if(seismic%femdomain%position_x(j)/=0.0d0) cycle
        if(seismic%femdomain%position_y(j)/=0.0d0) cycle
        write(history_U%fh,*) real(dble(i)*dt),&
        seismic%femdomain%position_z(j), real(seismic%U( (j-1)*3 + 1  ))
    enddo

    call history_A%close()
    call history_V%close()
    call history_U%close()
enddo
!print *, maxval(seismic%U)
seismic%femdomain%mesh%nodcoord = seismic%femdomain%mesh%nodcoord + (10.0d0**0)*&
    reshape(seismic%a, seismic%femdomain%nn(),seismic%femdomain%nd() )
call seismic%femdomain%vtk("result")
!call response%open("T_A"//str(cases)//".txt")
!call response%write(T,seismic%maxA(1))
!call response%close()

end


!***********************************************************************
!   Copyright (c) 2019 D. de Vries
!   Original Copyright (c) 2000 Mark Drela
!
!   This file is part of XFoil.
!
!   XFoil 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.
!
!   XFoil 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 XFoil.  If not, see <https://www.gnu.org/licenses/>.
!***********************************************************************

module s_xoper
contains
    ! mhinge was originally in xoper between cpdump and vpar
    ! It was moved here to avoid a circular dependency.
    subroutine mhinge
        use m_xgdes, only : getxyf
        use m_spline, only : seval, sinvrt
        use i_xfoil
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Local variables
        !
        real :: botp, bots, botx, boty, dx, dy, frac, pmid, topp, tops, topx, topy, xmid, ymid
        integer :: i
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !----------------------------------------------------
        !     Calculates the hinge moment of the flap about
        !     (XOF,YOF) by integrating surface pressures.
        !----------------------------------------------------
        !
        if (.not.LFLap) then
            !
            call getxyf(X, XP, Y, YP, S, N, tops, bots, XOF, YOF)
            LFLap = .true.
            !
        else
            !
            !------ find top and bottom y at hinge x location
            tops = XOF
            bots = S(N) - XOF
            call sinvrt(tops, XOF, X, XP, S, N)
            call sinvrt(bots, XOF, X, XP, S, N)
            !
        endif
        !
        topx = seval(tops, X, XP, S, N)
        topy = seval(tops, Y, YP, S, N)
        botx = seval(bots, X, XP, S, N)
        boty = seval(bots, Y, YP, S, N)
        !
        !
        HMOm = 0.
        HFX = 0.
        HFY = 0.
        !
        !---- integrate pressures on top and bottom sides of flap
        do i = 2, N
            if (S(i - 1)<tops .or. S(i)>bots) then
                !
                dx = X(i) - X(i - 1)
                dy = Y(i) - Y(i - 1)
                xmid = 0.5 * (X(i) + X(i - 1)) - XOF
                ymid = 0.5 * (Y(i) + Y(i - 1)) - YOF
                if (LVIsc) then
                    pmid = 0.5 * (CPV(i) + CPV(i - 1))
                else
                    pmid = 0.5 * (CPI(i) + CPI(i - 1))
                endif
                HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
                HFX = HFX - pmid * dy
                HFY = HFY + pmid * dx
            endif
        enddo
        !
        !---- find S(I)..S(I-1) interval containing s=TOPS
        do i = 2, N
            if (S(i)>tops) exit
        enddo
        !
        !---- add on top surface chunk TOPS..S(I-1),  missed in the DO 20 loop.
        dx = topx - X(i - 1)
        dy = topy - Y(i - 1)
        xmid = 0.5 * (topx + X(i - 1)) - XOF
        ymid = 0.5 * (topy + Y(i - 1)) - YOF
        if (S(i)/=S(i - 1)) then
            frac = (tops - S(i - 1)) / (S(i) - S(i - 1))
        else
            frac = 0.
        endif
        if (LVIsc) then
            topp = CPV(i) * frac + CPV(i - 1) * (1.0 - frac)
            pmid = 0.5 * (topp + CPV(i - 1))
        else
            topp = CPI(i) * frac + CPI(i - 1) * (1.0 - frac)
            pmid = 0.5 * (topp + CPI(i - 1))
        endif
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- add on inside flap surface contribution from hinge to top surface
        dx = XOF - topx
        dy = YOF - topy
        xmid = 0.5 * (topx + XOF) - XOF
        ymid = 0.5 * (topy + YOF) - YOF
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- find S(I)..S(I-1) interval containing s=BOTS
        do i = N, 2, -1
            if (S(i - 1)<bots) exit
        enddo
        !
        !---- add on bottom surface chunk BOTS..S(I),  missed in the DO 20 loop.
        dx = X(i) - botx
        dy = Y(i) - boty
        xmid = 0.5 * (botx + X(i)) - XOF
        ymid = 0.5 * (boty + Y(i)) - YOF
        if (S(i)/=S(i - 1)) then
            frac = (bots - S(i - 1)) / (S(i) - S(i - 1))
        else
            frac = 0.
        endif
        if (LVIsc) then
            botp = CPV(i) * frac + CPV(i - 1) * (1.0 - frac)
            pmid = 0.5 * (botp + CPV(i))
        else
            botp = CPI(i) * frac + CPI(i - 1) * (1.0 - frac)
            pmid = 0.5 * (botp + CPI(i))
        endif
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- add on inside flap surface contribution from hinge to bottom surface
        dx = botx - XOF
        dy = boty - YOF
        xmid = 0.5 * (botx + XOF) - XOF
        ymid = 0.5 * (boty + YOF) - YOF
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- add on TE base thickness contribution
        dx = X(1) - X(N)
        dy = Y(1) - Y(N)
        xmid = 0.5 * (X(1) + X(N)) - XOF
        ymid = 0.5 * (Y(1) + Y(N)) - YOF
        if (LVIsc) then
            pmid = 0.5 * (CPV(1) + CPV(N))
        else
            pmid = 0.5 * (CPI(1) + CPI(N))
        endif
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
    end subroutine mhinge
    !*==VPAR.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
    ! MHINGE
end module s_xoper


      subroutine runCY_00li1i2i3i4(k,l,i1,i2,i3,i4,Xtwiddle,Gtwiddle,
     . Shat7,N0)
      implicit none
C---  Expression for extension of Eq. 5.60c
C---  Calculates C00li1i2i3i4, requires C00lli1i2i3
C---  Small terms of order Xtwiddle(0,k)*Ciiiiii,Xtwiddle(0,0)*Ciiiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,i1,i2,i3,i4,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7(np,z6max,-2:0)

      if (  (i1.eq.l) .or. (i2.eq.l) .or. (i3.eq.l) .or. (i4.eq.l)
     . .or. (i1.eq.0) .or. (i2.eq.0) .or. (i3.eq.0) .or. (i4.eq.0)) then
      return
      endif

      do ep=-2,0
      Cv(czziiiii(z5(l,i1,i2,i3,i4))+N0,ep)=
     .(-2d0*Gtwiddle(k,i1)*Cv(czziiiii(z5(l,l,i2,i3,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i2)*Cv(czziiiii(z5(l,l,i1,i3,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i3)*Cv(czziiiii(z5(l,l,i1,i2,i4))+N0,ep)
     . -2d0*Gtwiddle(k,i4)*Cv(czziiiii(z5(l,l,i1,i2,i3))+N0,ep)
     . +Gtwiddle(k,1)*Shat7(1,z6(l,l,i1,i2,i3,i4),ep)
     . +Gtwiddle(k,2)*Shat7(2,z6(l,l,i1,i2,i3,i4),ep)
     . +Xtwiddle(k,0)*Cv(ciiiiii(z6(l,l,i1,i2,i3,i4))+N0,ep)
     . -Xtwiddle(0,0)*Cv(ciiiiiii(z7(k,l,l,i1,i2,i3,i4))+N0,ep))
     . /(4d0*Gtwiddle(k,l))

      enddo

      return
      end


*     MB02ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX, NMAX
      PARAMETER        ( KMAX = 20, NMAX = 20 )
      INTEGER          LDB, LDT, LDWORK
      PARAMETER        ( LDB = KMAX*NMAX, LDT = KMAX*NMAX,
     $                   LDWORK = NMAX*KMAX*KMAX + ( NMAX+2 )*KMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, K, M, N, NRHS
      CHARACTER        TYPET
*     .. Local Arrays ..
*     The arrays B and T are dimensioned for both TYPET = 'R' and
*     TYPET = 'C'.
*     NRHS is assumed to be not larger than KMAX*NMAX.
      DOUBLE PRECISION B(LDB, KMAX*NMAX), DWORK(LDWORK),
     $                 T(LDT, KMAX*NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02ED
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, NRHS, TYPET
      M = N*K
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         IF ( K.LE.0 .OR. K.GT.KMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) K
         ELSE
            IF ( NRHS.LE.0 .OR. NRHS.GT.KMAX*NMAX ) THEN
               WRITE ( NOUT, FMT = 99992 ) NRHS
            ELSE
               IF ( LSAME( TYPET, 'R' ) ) THEN
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
               ELSE
                  READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,K ), I = 1,M )
               END IF
               IF ( LSAME( TYPET, 'R' ) ) THEN
                  READ (NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,
     $                                   NRHS )
               ELSE
                  READ (NIN, FMT = * ) ( ( B(I,J), J = 1,NRHS ), I = 1,
     $                                   M )
               END IF
*              Compute the solution of X T = B or T X = B.
               CALL MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK,
     $                      LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF ( LSAME( TYPET, 'R' ) ) THEN
                     WRITE ( NOUT, FMT = 99997 )
                     DO 10  I = 1, NRHS
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   10                CONTINUE
                  ELSE
                     WRITE ( NOUT, FMT = 99996 )
                     DO 20  I = 1, M
                        WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,
     $                                                NRHS )
   20                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02ED EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02ED = ',I2)
99997 FORMAT (' The solution of X*T = B is ')
99996 FORMAT (' The solution of T*X = B is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' K is out of range.',/' K = ',I5)
99992 FORMAT (/' NRHS is out of range.',/' NRHS = ',I5)
      END


!     A SOLVER FOR THE CHEMICAL MASTER EQUATION
!     BY USING THE KRYLOV-FSP-SSA ALGORITHM
MODULE KRYLOVSOLVER
  USE STATESPACE
CONTAINS
  !=====================INTERFACE FOR KRYLOV-FSP-SSA ALGORITHM
  SUBROUTINE CME_SOLVE(MODEL, T, FSP_IN, FSP_OUT, FSPTOL, EXP_TOL, VERBOSITY)
    IMPLICIT NONE
    !------------------------------------------------INPUT/OUTPUT PARAMETERS
    !     THE UNDERLYING MODEL
    TYPE (CME_MODEL), INTENT(IN) :: MODEL
    !     TIME ELAPSED FOR THE CME SOLUTION
    DOUBLE PRECISION, INTENT(IN) :: T
    !     HASH TABLE OF THE FSP
    TYPE(FINITE_STATE_PROJECTION) :: FSP_IN
    !     TOLERANCE OF THE KRYLOV-FSP-SSA ALGORITHM
    DOUBLE PRECISION, INTENT(IN) :: FSPTOL
    !     TOLERANCE OF THE LOCAL EXPONENTIAL APPROXIMATION
    DOUBLE PRECISION, INTENT(IN) :: EXP_TOL
    !     HASH TABLE OF THE FSP
    TYPE(FINITE_STATE_PROJECTION) :: FSP_OUT
    !-----------------------------------------VERBOSITY AND ERROR FLAG
    INTEGER, INTENT(IN), OPTIONAL :: VERBOSITY
    INTEGER :: ITRACE, IFLAG
    !-------------------------------------APPLY THE KRYLOV-FSP-SSA ALGORITHM
    IF (PRESENT(VERBOSITY)) THEN
       ITRACE = VERBOSITY
    ELSE
       ITRACE = 0
    ENDIF

    PRINT*, 'CALLING DGEXPV_FSP'
    CALL DGEXPV_FSP(MODEL, T, FSP_IN%VECTOR, FSP_OUT, FSP_OUT%VECTOR, &
         FSPTOL, EXP_TOL, ITRACE, IFLAG)

  END SUBROUTINE CME_SOLVE

  !===============================================KRYLOV-FSP-SSA ALGORITHM
  SUBROUTINE DGEXPV_FSP(MODEL, T, V, FSP, W, FSPTOL, KRYTOL, ITRACE, IFLAG)
    IMPLICIT NONE

    INTEGER :: NFULL
    PARAMETER(NFULL = NMAX)

    INTEGER :: M_MAX, M_MIN
    PARAMETER(M_MAX = 100, M_MIN = 10)
    !     WORKSPACE
    INTEGER :: LWSP, LIWSP
    PARAMETER(LWSP = NFULL * (M_MAX + 2) + 5 * (M_MAX + 2)**2 + 7, LIWSP = NFULL)
    DOUBLE PRECISION :: WSP(LWSP)
    INTEGER :: IWSP(LIWSP)

    !     THE UNDERLYING MODEL
    TYPE(CME_MODEL) :: MODEL
    !     TIME ELAPSED FOR THE CME SOLUTION
    DOUBLE PRECISION, INTENT(IN) :: T
    !     INPUT PROBABILITY VECTOR
    DOUBLE PRECISION, INTENT(IN) :: V(:)
    !     OUTPUT PROBABILITY VECTOR
    DOUBLE PRECISION, INTENT(OUT) :: W(:)
    !     TOLERANCE OF THE KRYLOV-FSP-SSA ALGORITHM
    DOUBLE PRECISION, INTENT(IN) :: FSPTOL
    !     TOLERANCE OF THE LOCAL KRYLOV ERROR
    DOUBLE PRECISION :: KRYTOL

    TYPE(FINITE_STATE_PROJECTION) :: FSP
    !
    INTEGER :: ITRACE
    !
    INTEGER :: IFLAG

    !-------------------------PARAMETERS FOR THE STEPSIZE CONTROL OF EXPOKIT
    !     MAXIMUM ALLOWABLE NUMBER OF INTEGRATION STEPS;
    !     0 MEANS AN INFINITE NUMBER OF STEPS
    INTEGER, PARAMETER :: MXSTEP = 0

    INTEGER, PARAMETER :: MXREJECT = 0         !     MAXIMUM ALLOWABLE NUMBER OF REJECTIONS AT EACH STEP;
    !     0 MEANS AN INFINITE NUMBER OF REJECTIONS

    INTEGER, PARAMETER :: IDEG = 6         !     THE PADE APPROXIMATION OF TYPE (IDEG,IDEG) IS USED AS AN
    !     APPROXIMATION TO EXP(H); THE VALUE 0 SWITCHES TO THE UNIFORM
    !     RATIONAL CHEBYSHEV APPROXIMATION OF TYPE (14,14)
    DOUBLE PRECISION, PARAMETER :: DELTA = 1.2D0 !     LOCAL TRUNCATION ERROR `SAFETY FACTOR'
    !     STEPSIZE `SHRINKING FACTOR'
    DOUBLE PRECISION, PARAMETER :: GAMMA = 0.9D0

    !--------------------------------------------PARAMETERS OF THE ALGORITHM
    INTEGER :: N, M
    DOUBLE PRECISION :: ANORM, WTMP(NFULL)
    INTEGER :: I, J, K1, MH, MX, IV, IH, J1V, NS, IFREE, LFREE, IEXPH
    INTEGER :: IREJECT, IBRKFLAG, MBRKDWN, NMULT, NREJECT, NEXPH
    INTEGER :: NSCALE, NSTEP
    DOUBLE PRECISION :: SGN, T_OUT, TBRKDWN, STEP_MIN, STEP_MAX, ERR_LOC
    DOUBLE PRECISION :: S_ERROR, X_ERROR, T_NOW, T_NEW, T_STEP, T_OLD
    DOUBLE PRECISION :: XM, BETA, BREAK_TOL, P1, P2, P3, EPS, RNDOFF
    DOUBLE PRECISION :: VNORM, AVNORM, HJ1J, HIJ, HUMP, SQR1
    INTRINSIC :: AINT, ABS, DBLE, LOG10, MAX, MIN, NINT, SIGN
    DOUBLE PRECISION :: DDOT, DNRM2, DASUM

    DOUBLE PRECISION :: HTMP((M_MAX + 2) * (M_MAX + 2))

    ! FOR THE KRYLOV DIMENSION ADAPTIVITY,
    DOUBLE PRECISION :: K_FACTOR, ORDER
    LOGICAL :: M_CHANGED, ORDEROLD, KESTOLD
    INTEGER :: M_NEW, M_OLD, IMREJECT, JOLD, IH_OLD
    REAL :: COST1, COST2
    DOUBLE PRECISION :: OMEGA, OMEGA_OLD, T_OPT
    DOUBLE PRECISION :: HNORM, NOM
    INTEGER :: NNZ, M_START, M_OPT
    INTEGER :: QIOP

    ! FOR THE FSP ADAPTIVITY
    INTEGER :: N_NOW, IEXPAND
    DOUBLE PRECISION :: WSUM, T_RATIO
    LOGICAL :: DROP(NFULL)
    DOUBLE PRECISION :: ERROR, ERROROLD, TAU_OLD, TFSP
    DOUBLE PRECISION :: FSPORDER
    INTEGER :: IREJECTFSP, ISTART
    DOUBLE PRECISION :: T_SSA
    DOUBLE PRECISION :: WSUM_OLD
    DOUBLE PRECISION :: DROPTOL, DSUM

    !------------------------------------CHECK AND INITIALIZE THE PARAMETERS
    !     ASSUME ||A||=1, USUALLY IT IS UNKNOWN
    ANORM = 1.0D0
    CALL MATRIX_STARTER(FSP, MODEL)

    DO I = 1, 5
       CALL ONESTEP_EXTENDER(FSP, MODEL)
    ENDDO
    !     INITIALIZE THE KRYLOV DIMENSION AND ORTHOGONALIZATION LENGTH
    M = M_MIN
    QIOP = 2
    ISTART = 1
    N = NFULL

    !     CHECK THE RESTRICTIONS ON THE INPUT PARAMETERS
    IFLAG = 0
    IF (LWSP<(N * (M + 2) + 5 * (M + 2)**2 + IDEG + 1))  IFLAG = -1
    IF (LIWSP<(M + 2))                       IFLAG = -2
    IF ((M>=N).OR.(M<=0))                 IFLAG = -3
    IF (IFLAG.NE.0) THEN
       PRINT*, 'BAD SIZES (IN INPUT OF DGEXPV), IFLAG = ', IFLAG
       STOP
    END IF

    !     INITIALIZE THE PARAMETERS
    IBRKFLAG = 0
    NMULT = 0
    NREJECT = 0
    NEXPH = 0
    NSCALE = 0
    T_OUT = ABS(T)
    TBRKDWN = 0.0D0
    STEP_MIN = T_OUT
    STEP_MAX = 0.0D0
    NSTEP = 0
    S_ERROR = 0.0D0
    X_ERROR = 0.0D0
    T_NOW = 0.0D0
    T_NEW = 0.0D0
    P1 = 4.0D0 / 3.0D0
1   P2 = P1 - 1.0D0
    P3 = P2 + P2 + P2
    EPS = ABS(P3 - 1.0D0)
    IF (EPS==0.0D0) GO TO 1
    IF (KRYTOL<=EPS)   KRYTOL = SQRT(EPS)
    RNDOFF = EPS * ANORM
    BREAK_TOL = 1.0D-07
    SGN = SIGN(1.0D0, T)

    CALL DCOPY(FSP%SIZE, V, 1, W, 1)
    BETA = DNRM2(FSP%SIZE, W, 1)
    VNORM = BETA
    HUMP = BETA

    !     OBTAIN THE VERY FIRST STEPSIZE
    SQR1 = SQRT(0.1D0)
    XM = 1.0D0 / DBLE(M)
    P1 = KRYTOL * (((M + 1) / 2.72D0)**(M + 1)) * SQRT(2.0D0 * 3.14D0 * (M + 1))
    T_NEW = (1.0D0 / ANORM) * (P1 / (4.0D0 * BETA * ANORM))**XM
    P1 = 10.0D0**(NINT(LOG10(T_NEW) - SQR1) - 1)
    T_NEW = AINT(T_NEW / P1 + 0.55D0) * P1

    !     INITIALIZE THE FSP PARAMETERS
    N_NOW = FSP%SIZE
    IEXPAND = 0
    WSUM_OLD = 1.0D0
    IREJECTFSP = 0
    DROPTOL = 1.0D-8

    NNZ = (MODEL%NREACTIONS + 1) * FSP%SIZE

    !     PARAMETERS FOR THE KRYLOV SUBSPACE ADAPTIVITY,
    !     BASED ON NIESEN AND WRIGHT
    IMREJECT = 0
    JOLD = 1
    M_NEW = M
    ORDEROLD = .TRUE.
    KESTOLD = .TRUE.

100 IF (T_NOW >= T_OUT) GOTO 500
    !     FIND THE REAL STEPSIZE
    T_STEP = MIN(T_OUT - T_NOW, T_NEW)
    !     COMPUTE THE ARNOLDI MATRICES H_M AND V_M
    N = N_NOW
    M = MIN(N - 1, M_NEW)
    MBRKDWN = M
    !     FIND POINTERS INTO THE WORKSPACE
    K1 = 2
    MH = M + 2
    IV = 1
    IH = IV + N * (M + 1) + N
    IFREE = IH + MH * MH
    LFREE = LWSP - IFREE + 1

    NSTEP = NSTEP + 1

    P1 = 1.0D0 / BETA
    DO I = 1, N
       WSP(IV + I - 1) = P1 * W(I)
    ENDDO
    DO I = 1, MH * MH
       WSP(IH + I - 1) = 0.0D0
    ENDDO

    IREJECT = 0
    !     START THE STOPWATCH
    IF (ITRACE.NE.0) THEN
       PRINT*, 'BEGINNING IOP...'
    ENDIF
101 CONTINUE
    J1V = IV + JOLD * N
    DO 200 J = JOLD, M
       NMULT = NMULT + 1
       CALL FMATVEC(WSP(J1V - N), WSP(J1V), FSP%MATRIX)
       IF (QIOP>0)    ISTART = MAX(1, J - QIOP + 1)
       DO I = ISTART, J
          HIJ = DDOT(N, WSP(IV + (I - 1) * N), 1, WSP(J1V), 1)
          CALL DAXPY(N, -HIJ, WSP(IV + (I - 1) * N), 1, WSP(J1V), 1)
          WSP(IH + (J - 1) * MH + I - 1) = HIJ
       ENDDO
       HJ1J = DNRM2(N, WSP(J1V), 1)
       !           IF A `HAPPY BREAKDOWN' OCCURS, GO STRAIGHTFORWARD AT THE END
       IF (HJ1J<=BREAK_TOL) THEN
          K1 = 0
          IBRKFLAG = 1
          MBRKDWN = J
          TBRKDWN = T_NOW
          T_STEP = T_OUT - T_NOW
          GO TO 300
       END IF
       WSP(IH + (J - 1) * MH + J) = HJ1J
       CALL DSCAL(N, 1.0D0 / HJ1J, WSP(J1V), 1)
       J1V = J1V + N
200    CONTINUE
       NMULT = NMULT + 1
       CALL FMATVEC(WSP(J1V - N), WSP(J1V), FSP%MATRIX)
       AVNORM = DNRM2(N, WSP(J1V), 1)
       !     SET 1 FOR THE 2-CORRECTED SCHEME
300    CONTINUE
       WSP(IH + M * MH + M + 1) = 1.0D0
401    CONTINUE

       !     COMPUTE W=BETA*V*EXP(T_STEP*H)*E1...
       NEXPH = NEXPH + 1
       MX = MBRKDWN + K1
       IF (IDEG.NE.0) THEN
          !           BY THE IRREDUCIBLE RATIONAL PADE APPROXIMATION...
          CALL DGPADMNORM(IDEG, MX, SGN * T_STEP, WSP(IH), MH, &
               WSP(IFREE), LFREE, IWSP, IEXPH, NS, IFLAG, HNORM)
          IEXPH = IFREE + IEXPH - 1
          NSCALE = NSCALE + NS
       ELSE
          !           OR THE UNIFORM RATIONAL CHEBYSHEV APPROXIMATION
          IEXPH = IFREE
          DO I = 1, MX
             WSP(IEXPH + I - 1) = 0.0D0
          ENDDO
          WSP(IEXPH) = 1.0D0
          CALL DGCHBV(MX, SGN * T_STEP, WSP(IH), MH, &
               WSP(IEXPH), WSP(IFREE + MX))
       ENDIF
402    CONTINUE
       !     ESTIMATE THE ERROR
       IF (K1==0) THEN
          ERR_LOC = KRYTOL
       ELSE
          P1 = ABS(WSP(IEXPH + M)) * BETA
          P2 = ABS(WSP(IEXPH + M + 1)) * BETA * AVNORM
          IF (P1>10.0D0 * P2) THEN
             ERR_LOC = P2
             XM = 1.0D0 / DBLE(M)
          ELSE IF (P1>P2) THEN
             ERR_LOC = (P1 * P2) / (P1 - P2)
             XM = 1.0D0 / DBLE(M)
          ELSE
             ERR_LOC = P1
             XM = 1.0D0 / DBLE(M - 1)
          END IF
       ENDIF
       !     REDUCE THE STEPSIZE IF THE ERROR IS OUT OF BOUND
       IF (ISNAN(ERR_LOC)) THEN
          T_STEP = T_STEP / 5.0D0
          GO TO 401
       ENDIF

       !     FIND THE RATIO OF ERROR PER UNIT STEP
       OMEGA_OLD = OMEGA
       OMEGA = ERR_LOC / (KRYTOL * T_STEP)
       !     ESTIMATE THE ORDER
       IF ((M==M_OLD).AND.(T_STEP.NE.T_OLD).AND.(IREJECT>=1)) THEN
          ORDER = MAX(1.0D0, LOG(OMEGA / OMEGA_OLD) / LOG(T_STEP / T_OLD))
          ORDEROLD = .FALSE.
       ELSE IF (ORDEROLD.OR.IREJECT==0) THEN
          ORDER = DBLE(M) / 4.0D0
          ORDEROLD = .TRUE.
       ELSE
          ORDEROLD = .TRUE.
       ENDIF
       !     ESTIMATE KAPPA
       IF ((M.NE.M_OLD).AND.(T_STEP==T_OLD).AND.(IREJECT>=1)) THEN
          K_FACTOR = MAX(1.1D0, (OMEGA / OMEGA_OLD)**(1.0D0 / (M_OLD - M)))
          KESTOLD = .FALSE.
       ELSE IF (KESTOLD .OR. IREJECT==0) THEN
          KESTOLD = .TRUE.
          K_FACTOR = 2.0D0
       ELSE
          KESTOLD = .TRUE.
       ENDIF
       !     RECORD THE OLD STEP SIZE AND KRYLOV DIMENSION
       T_OLD = T_STEP
       M_OLD = M
       !     SUGGEST NEW STEP SIZE AND KRYLOV DIMENSION
       IF ((M==M_MAX).AND.(OMEGA>DELTA).OR.(IMREJECT>4)) THEN
          T_NEW = MIN(T_OUT - T_NOW, &
               MAX(T_STEP / 5.0D0, &
               MIN(5.0D0 * T_STEP, &
               GAMMA * T_STEP * OMEGA**(-1.0D0 / ORDER))))
          P1 = 10.0D0**(NINT(LOG10(T_NEW) - SQR1) - 1)
          T_NEW = AINT(T_NEW / P1) * P1
          M_CHANGED = .FALSE.
       ELSE
          !           COMPUTE OPTIONS FOR THE NEW STEP SIZE AND KRYLOV DIMENSION
          T_OPT = MIN(T_OUT - T_NOW, &
               MAX(T_STEP / 5.0D0, &
               MIN(5.0D0 * T_STEP, &
               GAMMA * T_STEP * OMEGA**(-1.0D0 / ORDER))))
          M_OPT = MIN(MAX(M_MIN, 3 * M / 4, &
               M + CEILING(LOG(OMEGA) / LOG(K_FACTOR))), &
               M_MAX, &
               CEILING(4.0D0 * M / 3.0D0) + 1)

          !           ESTIMATE COSTS
          COST1 = KRYLOV_COST(T_NOW, T_OUT, T_OPT, M, N, HNORM)
          COST2 = KRYLOV_COST(T_NOW, T_OUT, T_STEP, M_OPT, N, HNORM)

          IF (COST1<=COST2) THEN
             T_NEW = T_OPT
             P1 = 10.0D0**(NINT(LOG10(T_NEW) - SQR1) - 1)
             T_NEW = AINT(T_NEW / P1) * P1
             M_NEW = M
             M_CHANGED = .FALSE.
          ELSE
             M_NEW = M_OPT
             T_NEW = T_STEP
             M_CHANGED = .TRUE.
          ENDIF
       ENDIF
       !     IF THE KRYLOV STEP ERROR IS NOT ACCEPTABLE, REJECT THE STEPSIZE
       IF ((K1.NE.0).AND.(OMEGA>DELTA).AND.&
            (MXREJECT==0.OR.IREJECT<MXREJECT)) THEN
          IF (.NOT.M_CHANGED) THEN
             !                 CHOOSE TO CHANGE STEP SIZE
             T_STEP = MIN(T_OUT - T_NOW, &
                  MAX(T_STEP / 5.0D0, &
                  MIN(5.0D0 * T_STEP, T_NEW)))
             P1 = 10.0D0**(NINT(LOG10(T_STEP) - SQR1) - 1)
             T_STEP = AINT(T_STEP / P1 + 0.55D0) * P1
             IF (ITRACE.NE.0) THEN
                PRINT*, 'T_STEP =', T_OLD
                PRINT*, 'ERR_LOC =', ERR_LOC
                PRINT*, 'ERR_REQUIRED =', DELTA * T_OLD * KRYTOL
                PRINT*, 'STEPSIZE REJECTED, DOWN TO:', T_STEP
             ENDIF
             IREJECT = IREJECT + 1
             NREJECT = NREJECT + 1
             IF ((MXREJECT.NE.0).AND.(IREJECT>MXREJECT)) THEN
                PRINT*, 'FAILURE IN DGEXPV: ---'
                PRINT*, 'THE REQUESTED TOLERANCE IS TOO HIGH.'
                PRINT*, 'RERUN WITH A SMALLER VALUE.'
                IFLAG = 2
                RETURN
             ENDIF
             GO TO 401
          ELSE
             !                 CHOOSE TO CHANGE DIMENSION
             NREJECT = NREJECT + 1
             IMREJECT = IMREJECT + 1
             M = M_NEW
             HTMP(1:IFREE - IH + 1) = WSP(IH:IFREE)
             IH_OLD = IH
             MBRKDWN = M
             K1 = 2
             MH = M + 2
             IV = 1
             IH = IV + N * (M + 1) + N
             IFREE = IH + MH * MH
             LFREE = LWSP - IFREE + 1
             T_STEP = MIN(T_OUT - T_NOW, T_NEW)
             DO I = 1, MH * MH
                WSP(IH + I - 1) = 0.0D0
             ENDDO
             !                 COPY THE HESSENBERG MATRIX
             DO J = 1, M_OLD
                DO I = 1, J + 1
                   WSP(IH + (J - 1) * (M + 2) + I - 1) = &
                        HTMP(1 + (J - 1) * (M_OLD + 2) + I - 1)
                ENDDO
             ENDDO
             !                 ONLY DO ARNOLDI FROM THE M_OLD-TH COLUMN
             JOLD = M_OLD
             IF (ITRACE.NE.0) THEN
                PRINT*, 'ERR_LOC =', ERR_LOC
                PRINT*, 'ERR_REQUIRED =', DELTA * T_OLD * KRYTOL
                PRINT*, 'DIMENSION CHANGED INTO M =', M
             ENDIF
             GO TO 101
          ENDIF
       ENDIF
       IMREJECT = 0
       JOLD = 1
       IF (ERR_LOC<1.0D-16) T_NEW = MAX(T_NEW, 2.0D0 * T_STEP)
       MX = MBRKDWN + MAX(0, K1 - 1)
       IREJECTFSP = 0

       ! ENSURE THE FSP-LIKE CRITERIA
       DO
          !     FIND W = BETA*V*EXP(T*H)*E1
          CALL DGEMV('N', N, MX, BETA, WSP(IV), N, WSP(IEXPH), 1, 0.0D0, W, 1)

          !     ENSURE FSP NON-NEGATIVITY AND COMPUTE THE PROBABILITY SUM
          DO I = 1, FSP%SIZE
             IF (W(I)<0.0D0)      W(I) = 0.0D0
          ENDDO
          WSUM = DASUM(FSP%SIZE, W, 1)

          PRINT*, "WSUM= ", WSUM

          ERROR = WSUM_OLD - WSUM
          T_RATIO = (T_NOW + T_STEP) / T_OUT

          !     ENSURE FSP-LIKE CRITERIA...
          IF (WSUM >= (1.0D0 - FERRORBOUND(T_NOW + T_STEP))) THEN
             EXIT
          ELSE
             IEXPAND = 1
             IREJECTFSP = IREJECTFSP + 1

             !           IF THE FSP HAS BEEN REJECTED TOO MANY TIMES, JUMPT TO SSA
             !           LOOP TO EXPAND THE STATE SPACE
             IF (IREJECTFSP>=5) THEN
                W(1:N) = BETA * WSP(IV:IV + N - 1)
                NSTEP = NSTEP - 1
                T_SSA = T_NEW
                GO TO 404
             ELSEIF (IREJECTFSP==1) THEN
                FSPORDER = 2
             ELSE
                FSPORDER = LOG(ERROR / ERROROLD) / &
                     LOG(T_STEP / TAU_OLD) - 1.0D0
             ENDIF

             !           REDUCE THE TIME STEP
             TFSP = GAMMA * T_STEP * (FSPTOL * T_STEP / (ERROR * T_OUT))**&
                  (1.0D0 / (FSPORDER))
             ERROROLD = ERROR
             TAU_OLD = T_STEP

             T_STEP = MIN(T_OUT - T_NOW, &
                  MAX(T_STEP / 5.0D0, MIN(0.9D0 * T_STEP, TFSP)))
             P1 = 10.0D0**(NINT(LOG10(T_STEP) - SQR1) - 1)
             T_STEP = AINT(T_STEP / P1 + 0.55D0) * P1

             NEXPH = NEXPH + 1
             CALL DGPADM(IDEG, MX, SGN * T_STEP, WSP(IH), MH, &
                  WSP(IFREE), LFREE, IWSP, IEXPH, NS, IFLAG)
             IEXPH = IFREE + IEXPH - 1
             NSCALE = NSCALE + NS
          ENDIF
       ENDDO

       !     UPDATE THE TIME COVERED
       T_NOW = T_NOW + T_STEP
       WSUM_OLD = WSUM

       !     DISPLAY INFORMATION ABOUT THE LAST SUCCESSFUL TIME STEP
       IF (ITRACE.NE.0) CALL PRINT_STATS

       !     IF THE INTEGRATION IS AT THE END TIME POINT, THEN THE ALGORITHM
       !     IS FINISHED
       IF (T_NOW>=T_OUT) GO TO 500

       !     REDUCE THE STATE SPACE TO ONLY SUBSTANTIAL STATES
       IF (NSTEP > 1 .AND. IEXPAND /= 1) THEN
          DSUM = WSUM - (1.0D0 - FERRORBOUND(T_NOW))
          IF (DSUM>0.0D0) CALL DROP_STATES(W, FSP, MODEL, DSUM, FMATVEC)
       ENDIF

       !-------------------------------------------STATE SPACE EXPANSION BY SSA
       !-----------------------------IN THE CASE WHERE THE STEPSIZE WAS REDUCED
404    CONTINUE

       IF ((IEXPAND==1).AND.(T_NOW<T_OUT)) THEN

          IF (NSTEP==1) T_NEW = T_STEP
          T_SSA = MIN(T_NEW, T_OUT - T_NOW)

          IF (ITRACE.NE.0) THEN
             PRINT*, 'CALLING SSA'
          ENDIF

          ! EXTEND THE STATE SPACE BY SSA AND 1-STEP REACHABILITY
          CALL SSA_EXTENDER(T_SSA, FSP, MODEL)
          CALL ONESTEP_EXTENDER(FSP, MODEL)

          IF (N_NOW>NFULL) N_NOW = NFULL
          IEXPAND = 0

       ENDIF

       !     ESTIMATE THE NUMBER OF NONZERO ENTRIES IN CURRENT FSP MATRIX
       NNZ = (MODEL%NREACTIONS + 1) * FSP%SIZE
       !     ESTIMATE OTHER PARAMETERS
       N_NOW = FSP%SIZE
       BETA = DNRM2(N_NOW, W, 1)
       HUMP = MAX(HUMP, BETA)
       ERR_LOC = MAX(ERR_LOC, RNDOFF)
       STEP_MIN = MIN(STEP_MIN, T_STEP)
       STEP_MAX = MAX(STEP_MAX, T_STEP)
       S_ERROR = S_ERROR + ERR_LOC
       X_ERROR = MAX(X_ERROR, ERR_LOC)
       P1 = 10.0D0**(NINT(LOG10(T_NEW) - SQR1) - 1)
       T_NEW = AINT(T_NEW / P1 + 0.55D0) * P1
       !     RETURN TO THE BEGINNING FOR THE NEXT TIME STEP
       IF ((MXSTEP==0).OR.(NSTEP<MXSTEP)) GO TO 100
       IFLAG = 1

       !-------------------------------------------OUTPUT IMPORTANT INFORMATION
500    CONTINUE
       !     IN IWSP
       IWSP(1) = NMULT
       IWSP(2) = NEXPH
       IWSP(3) = NSCALE
       IWSP(4) = NSTEP
       IWSP(5) = NREJECT
       IWSP(6) = IBRKFLAG
       IWSP(7) = MBRKDWN
       !     IN WSP
       WSP(1) = STEP_MIN
       WSP(2) = STEP_MAX
       WSP(3) = 0.0D0
       WSP(4) = 0.0D0
       WSP(5) = X_ERROR
       WSP(6) = S_ERROR
       WSP(7) = TBRKDWN
       WSP(8) = SGN * T_NOW
       WSP(9) = HUMP / VNORM
       WSP(10) = BETA / VNORM
     CONTAINS

       !===========================COMPUTE THE MATRIX-VECTOR PRODUCT IN THE CME
       SUBROUTINE FMATVEC(X, Y, MATRIX)
         IMPLICIT NONE
         !------------------------------------------------INPUT/OUTPUT PARAMETERS
         !     VECTOR X
         DOUBLE PRECISION :: X(*)
         !     VECTOR Y=A*X, WHERE A IS THE FSP MATRIX
         DOUBLE PRECISION :: Y(*)
         !     CURRENT FSP MATRIX
         TYPE(FSP_MATRIX) :: MATRIX
         !--------------------------------------------PARAMETERS OF THE ALGORITHM
         INTEGER :: I, J, K, N, BW
         !----------------------------------------------------------COMPUTE Y=A*X
         !     FIND THE SIZE OF THE MATRIX
         N = MATRIX%SIZE
         BW = SIZE(MATRIX%ADJ, DIM = 1)
         !     INITIALIZE VECTOR Y
         DO I = 1, N
            Y(I) = 0.0D0
         ENDDO

         !     COMPUTE Y=A*X
         DO I = 1, N
            DO J = 1, BW
               K = MATRIX%ADJ(J, I)
               IF (K>=1) THEN
                  Y(K) = Y(K) + MATRIX%OFFDIAG(J, I) * X(I)
               ENDIF
            ENDDO
            Y(I) = Y(I) - MATRIX%DIAG(I) * X(I)
         ENDDO
       END SUBROUTINE FMATVEC

       DOUBLE PRECISION FUNCTION FERRORBOUND(TX)
         IMPLICIT NONE
         !-------------------------------------------------------INPUT PARAMETERS
         !     A TIME INTERVAL
         DOUBLE PRECISION, INTENT(IN) :: TX
         !-----------------COMPUTE THE FSP ERROR TOLERANCE FOR THIS TIME INTERVAL
         FERRORBOUND = TX * FSPTOL / T_OUT
       END FUNCTION FERRORBOUND

       DOUBLE PRECISION FUNCTION KRYLOV_COST(T_NOW, T_OUT, TAU, M, N, HNORM)
         ! ESTIMATE THE COST OF THE KRYLOV APPROXIMATION ASSOCIATED WITH A PARTICULAR CHOICE OF STEPSIZE AND BASIS SIZE.
         ! T_NOW: CURRENT TIME
         ! T_OUT: FINAL TIME
         ! TAU: STEPSIZE
         ! M: KRYLOV BASIS SIZE
         ! N: SOLUTION VECTOR LENGTH
         ! HNORM: NORM OF THE HESSENBERG MATRIX COMPUTED FROM THE LAST TIME STEP
         IMPLICIT NONE

         INTEGER, INTENT(IN) :: M, N
         DOUBLE PRECISION, INTENT(IN) :: TAU, HNORM, T_NOW, T_OUT
         DOUBLE PRECISION :: NOM

         NOM = 25.0D0 / 3.0D0 + &
              MAX(0, 2 + INT(LOG(TAU * HNORM) / LOG(2.0D0)))
         KRYLOV_COST = NINT((T_OUT - T_NOW) / TAU) * &
              (2 * (M + 1) * NNZ + &
              (5 * M + 4 * QIOP * M + 2 * QIOP - 2 * QIOP * QIOP + 7) * N + &
              2 * NOM * (M + 2) * (M + 2) * (M + 2))

       END FUNCTION KRYLOV_COST

       SUBROUTINE PRINT_STATS
         IMPLICIT NONE

         PRINT*, 'TIMESTEP', NSTEP, '-------------------------------'
         PRINT*, 'FSP SIZE         =', FSP%SIZE
         PRINT*, 'STEP_SIZE        =', T_STEP
         PRINT*, 'NEXT_STEP        =', T_NEW
         PRINT*, 'T_NOW            =', T_NOW
         PRINT*, 'KRYLOV DIMENSION =', M

       END SUBROUTINE PRINT_STATS

     END SUBROUTINE DGEXPV_FSP

   END MODULE KRYLOVSOLVER


C     LAST UPDATE
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE gauss
      IMPLICIT NONE
C
C Purpose: Generate gaussian profiles
C
C
      INCLUDE 'COMMON.FOR'
C
C Calls   7: APLOT  , DAWRT  , ERRMSG , FILL   , GETCHN , GETHDR
C            OPNFIL
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    PI,TEMP,XSQ,ZERO,SIGMA
      INTEGER ICLO,JOP,IRC,IMEM,KREC
      INTEGER ISPEC1,LSPEC1,MEM1,IFFR1,ILFR1,INCR1,IFINC1
      INTEGER ISPEC2,LSPEC2,MEM2,IFFR2,ILFR2,INCR2,IFINC2
      INTEGER ISPEC3,LSPEC3,MEM3,IFFR3,ILFR3,INCR3,IFINC3
      INTEGER IHFMX1,IFRMX1,NCHAN1,NFRAM1
      INTEGER IHFMX2,IFRMX2,NCHAN2,NFRAM2
      INTEGER IHFMX3,IFRMX3,NCHAN3,NFRAM3
      INTEGER JCH1,JCH2,I,J,K,NCHAN4
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM1,HFNAM2,HFNAM3,OFNAM
C
C ICLO   : Close file indicator
C JOP    : Open file indicator
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMX1 : Nos. of frames in sequence
C IHFMX1 : Nos. of header file in sequence
C ISPEC1 : First header file in sequence
C LSPEC1 : Last header file in sequence
C MEM1   : Positional or calibration data indicator
C IFFR1  : First frame in sequence
C ILFR1  : Last frame in sequence
C INCR1  : Header file increment
C IFINC1 : Frame increment
C HFNAM1 : Header filename
C IFRMX2 : Nos. of frames in sequence
C IHFMX2 : Nos. of header file in sequence
C ISPEC2 : First header file in sequence
C LSPEC2 : Last header file in sequence
C MEM2   : Positional or calibration data indicator
C IFFR2  : First frame in sequence
C ILFR2  : Last frame in sequence
C INCR2  : Header file increment
C IFINC2 : Frame increment
C HFNAM2 : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C KREC   : Output file record
C IMEM   : Output memory dataset
C NCHAN  : Nos of data points in spectrum 1
C NCHAN2 : Nos of data points in spectrum 2
C NFRAME : Nos of time frames
C
      DATA  IMEM/1/
      DATA  PI/3.141592654/
C
C-----------------------------------------------------------------------
10    ICLO=0
      JOP=0
      KREC=0
C
      write (iprint,*) 'Sigma (halfwidth) data: '
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM1,ISPEC1,LSPEC1,INCR1,MEM1,
     &             IFFR1,ILFR1,IFINC1,IHFMX1,IFRMX1,NCHAN1,IRC)
      IF (IRC.NE.0) GOTO 999
C
      write (iprint,*) 'Channels for centre of gaussian'
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM2,ISPEC2,LSPEC2,INCR2,MEM2,
     &             IFFR2,ILFR2,IFINC2,IHFMX2,IFRMX2,NCHAN2,IRC)
      IF (IRC.NE.0) GOTO 10

      write (iprint,*) 'Integrated intensities'
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM3,ISPEC3,LSPEC3,INCR3,MEM3,
     &             IFFR3,ILFR3,IFINC3,IHFMX3,IFRMX3,NCHAN3,IRC)
      IF (IRC.NE.0) GOTO 10
C
      NCHAN4=512
      CALL GETCHN (ITERM,IPRINT,NCHAN4,JCH1,JCH2,IRC)
      IF (IRC.NE.0) GOTO 10
C
C========READ THE sigma, centre channel & intensity files
C
      CALL OPNFIL (JUNIT,HFNAM1,ISPEC1,MEM1,IFFR1,ILFR1,NCHAN1,
     &             NFRAM1,IRC)
      IF (IRC.NE.0) GOTO 50
      CALL OPNFIL (KUNIT,HFNAM2,ISPEC2,MEM2,IFFR2,ILFR2,NCHAN2,
     &                NFRAM2,IRC)
      IF (IRC.NE.0) GOTO 50
      CALL OPNFIL (LUNIT,HFNAM3,ISPEC3,MEM3,IFFR3,ILFR3,NCHAN3,
     &                NFRAM3,IRC)
      IF (IRC.NE.0) GOTO 50
C
C========READ CALIBRATION FILES FOR BUFFER AND DATA
C
      READ (JUNIT,REC=IFFR1) (SP1(K),K=1,NCHAN1)
      READ (KUNIT,REC=IFFR2) (SP2(K),K=1,NCHAN2)
      READ (LUNIT,REC=IFFR3) (SP3(K),K=1,NCHAN3)

      DO 40 I=1,NCHAN1
         SIGMA=SP1(I)
         ZERO=SP2(I)
         TEMP=1.0/((SIGMA)*SQRT(PI))
         DO 30 J=1,NCHAN4
            XSQ=(REAL(J)-ZERO)*(REAL(J)-ZERO)
            SP4(J)=TEMP*EXP(-XSQ/(SIGMA*SIGMA))*SP3(I)
 30      CONTINUE
C
         KREC=KREC+1
         IF (NCHAN1.EQ.1) CALL APLOT (ITERM,IPRINT,SP4,NCHAN4)
         IF (KREC.GE.NCHAN1) ICLO=1
         IF (KREC.EQ.1) THEN
            CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
            IF (IRC.NE.0) GOTO 50
         ENDIF
         CALL DAWRT (MUNIT,OFNAM,IMEM,NCHAN4,NCHAN1,HEAD1,HEAD2,
     1        SP4,KREC,JOP,ICLO,IRC)
         IF (IRC.NE.0) GOTO 50
 40   CONTINUE

 50   CLOSE (UNIT=JUNIT)
      CLOSE (UNIT=KUNIT)
      CLOSE (UNIT=LUNIT)
      GOTO 10
999   RETURN
      END


module Mod_nsi_Statistics
contains
subroutine nsi_CalculateStatistics(a)

    !-----------------------------------------------------------------------
    !
    ! This routine computes the Statistics: Time Average Velocity, Time average Pressure,
    ! RMS Velocity, RMS Pressure and Turbulence Intesity
    !
    !-----------------------------------------------------------------------

   use typre
   use Mod_NavierStokes
   use Mod_Mesh

   implicit none
   class(NavierStokesProblem) :: a

   integer(ip)                :: idime,ipoin,ndime,npoin

   !Only if they need to be computed
   if (a%npp_stepi(24) == 0) return
   if (a%ctime < a%StatisticsStartTime) return

   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNdime(ndime)
   a%StatisticsCumulativeTime = a%StatisticsCumulativeTime + a%dtime

   a%timav(:,:,2) = a%timav(:,:,2) + a%veloc(:,:,1)*a%dtime
   a%timav(:,:,1) = a%timav(:,:,2)/a%StatisticsCumulativeTime
   a%timav(:,:,4) = a%timav(:,:,4) + abs(a%veloc(:,:,1))*a%dtime
   a%timav(:,:,5) = a%timav(:,:,4)/a%StatisticsCumulativeTime
   a%timav(:,:,3) = a%timav(:,:,3) + a%veloc(:,:,1)*a%veloc(:,:,1)*a%dtime

   a%timap(:,2) = a%timap(:,2) + a%press(:,1)*a%dtime
   a%timap(:,1) = a%timap(:,2)/a%StatisticsCumulativeTime
   a%timap(:,3) = a%timap(:,3) + a%press(:,1)*a%press(:,1)*a%dtime

   a%TimaTractions(:,:,2) = a%TimaTractions(:,:,2) + a%btraction(:,:)*a%dtime
   a%TimaTractions(:,:,1) = a%TimaTractions(:,:,2)/a%StatisticsCumulativeTime

end subroutine nsi_CalculateStatistics

subroutine nsi_FinalStatistics(a)
   !Calculate Root Mean Square of Velocity (rmsv) and Pressure (rmsp)
   use typre
   use Mod_NavierStokes

   implicit none
   class(NavierStokesProblem) :: a

   integer(ip)             :: idime,ipoin,ndime,npoin
   real(rp)                :: rmsnorm,velnorm

!    !Only if they need to be computed

   if (a%npp_stepi(24) == 0) return

   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNdime(ndime)

   a%rmsp(:) = 0.0_rp
   a%rmsv(:,:) = 0.0_rp

    do ipoin = 1,npoin

       a%rmsp(ipoin) = a%rmsp(ipoin)+ a%timap(ipoin,3)+ (a%timap(ipoin,1)*a%timap(ipoin,1)*a%StatisticsCumulativeTime) - (2*a%timap(ipoin,1)*a%timap(ipoin,2))
       a%rmsp(ipoin) = a%rmsp(ipoin)/a%StatisticsCumulativeTime
       if (a%rmsp(ipoin) > 0.0_rp) then
         a%rmsp(ipoin) = sqrt(a%rmsp(ipoin))
       else
         a%rmsp(ipoin) = 0.0_rp
       endif

       rmsnorm = 0.0_rp
       velnorm = 0.0_rp

       do idime=1,ndime

          a%rmsv(idime,ipoin) = a%rmsv(idime,ipoin)+a%timav(idime,ipoin,3)+a%timav(idime,ipoin,1)*a%timav(idime,ipoin,1)*a%StatisticsCumulativeTime-2*a%timav(idime,ipoin,1)*a%timav(idime,ipoin,2)
          a%rmsv(idime,ipoin) = a%rmsv(idime,ipoin)/a%StatisticsCumulativeTime

          if (a%rmsv(idime,ipoin) > 0.0_rp) then
            a%rmsv(idime,ipoin) = sqrt(a%rmsv(idime,ipoin))
          else
            a%rmsv(idime,ipoin) = 0.0_rp
          endif
          velnorm = velnorm + a%timav(idime,ipoin,5)*a%timav(idime,ipoin,5)
          rmsnorm = rmsnorm + a%rmsv(idime,ipoin)*a%rmsv(idime,ipoin)

       end do

       !Calculate the Turbulence Intensity (turbi = Urms/Umean)
       rmsnorm = rmsnorm/ndime
       rmsnorm = sqrt(rmsnorm)
       velnorm = sqrt(velnorm)

       if(velnorm>epsilon(0.0_rp)) then
          a%turbi(ipoin)=rmsnorm/velnorm
       else
          a%turbi(ipoin)=0.0_rp
       end if

    end do

 end subroutine

end module


*----------------------------------------------------------------------*
      subroutine normalize_guess(
     &     ff_v,irecv,ff_mvp,irecmvp,ff_met,irecmet,
     &     use_s,iopt,nopt,opti_info)
*----------------------------------------------------------------------*
*
*     Normalizes a trial vector and scales the coreesponding
*     matrix vector product (and metric vector product) accordingly.
*
*     matthias, mar 2013
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'def_filinf.h'
      include 'def_file_array.h'
      include 'def_optimize_info.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     irecv, irecmvp, irecmet, iopt, nopt
      logical ::
     &     use_s(nopt)
      type(filinf) ::
     &     ff_v
      type(file_array) ::
     &     ff_mvp(nopt), ff_met(nopt)
      type(optimize_info), intent(in) ::
     &     opti_info

      integer ::
     &     ifree, nwfpar(nopt), ioff, jopt
      real(8) ::
     &     xnrm
      real(8), pointer ::
     &     xbuf1(:), xbuf2(:)

      real(8), external ::
     &     ddot, da_ddot

      if (ntest.ge.100) then
        write(lulog,*) '-------------------------'
        write(lulog,*) ' normalize_guess at work '
        write(lulog,*) '-------------------------'
      end if

      nwfpar(1:nopt) = opti_info%nwfpar(1:nopt)

      ifree = mem_setmark('normalize_guess')
      ifree = mem_alloc_real(xbuf1,maxval(nwfpar(1:nopt)),'xbuf1')
      ifree = mem_alloc_real(xbuf2,nwfpar(iopt),'xbuf2')
      if (use_s(iopt)) then
        call vec_from_da(ff_v,irecv,xbuf1,nwfpar(iopt))
        call vec_from_da(ff_met(iopt)%fhand,irecmet,xbuf2,nwfpar(iopt))
        xnrm = ddot(nwfpar(iopt),xbuf1,1,xbuf2,1)
      else
        xnrm = da_ddot(ff_v,irecv,
     &                 ff_v,irecv,
     &                 nwfpar(iopt),
     &                 xbuf1,xbuf2,
     &                 nwfpar(iopt))
      end if
      xnrm = sqrt(xnrm)

      ! zero norm: this may happen for multi-component vectors (nopt>1)
      ! the current handling is a bit unclear (why is the routine called
      ! for fixed iopt then)??
      if (xnrm.gt.1d-12) then

        if (ntest.ge.100)
     &     write(lulog,*) 'Normalizing root with norm ',xnrm

        call da_sccpvec(ff_v,irecv,
     &                ff_v,irecv,
     &                1d0/xnrm,nwfpar(iopt),
     &                xbuf1,nwfpar(iopt))
        do jopt = 1, nopt
          call da_sccpvec(ff_mvp(jopt)%fhand,irecmvp,
     &                    ff_mvp(jopt)%fhand,irecmvp,
     &                    1d0/xnrm,nwfpar(jopt),
     &                    xbuf1,nwfpar(jopt))
          if (use_s(jopt))
     &       call da_sccpvec(ff_met(jopt)%fhand,irecmet,
     &                  ff_met(jopt)%fhand,irecmet,
     &                  1d0/xnrm,nwfpar(jopt),
     &                  xbuf1,nwfpar(jopt))
        end do

      end if
      ifree = mem_flushmark()

      return

      end


c=======================================================================
c
c     subroutine calepsmean
c
c     Calibrates Kato sensitivity parameter with mean method
c
c-----------------------------------------------------------------------
      SUBROUTINE calepsmean(n, cov, epskgr, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       p : integer, number of variables (p>=1).
c       cov : double array of dimension p by p, covariance matrix.
c
c     OUTPUT:
c       epskgr : double, Kato eps-group parameter.
c       info   :   = 0 successful exit                        integer
c                        -1 ncup != ncdown
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     I/O
      INTEGER n, info
      DOUBLE PRECISION cov(*), epskgr
c
c     local variable
      INTEGER i
c
c     initialisation
      info = 0
      epskgr = 0.0
c
      DO i=1,n
      	epskgr = epskgr + cov((i-1)*n+i)
      ENDDO
      epskgr = epskgr /n
c
      RETURN
      END


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level directory of this distribution.

module params
  ! Set parameters that define the scattering problem
  ! This file specifies a Gaussian wavepacket incident on the following
  ! potential:
  !   V(x) = oo, x = 0
  !   V(x) = \delta(x - a), x > 0
  use progvars

  implicit none

  private
  public psi0, psik, ek, assign_params

  ! Problem-specific variables
  real(dp) :: gamma, a, m
  real(dp) :: x_0, k_0, d_x, d_k
  integer(8) :: x_stdev, k_stdev

  contains

    subroutine assign_params
      implicit none

      ! Assign output parameters
      output_dir = "./output/"
      ak_out = "ak.dat"
      ek_out = "ek.dat"
      psit_out = "psit.dat"
      psi0_out = "psi0.dat"
      psik_out = "psik.dat"
      x_out = "x_range.dat"
      k_out = "k_range.dat"
      t_out = "t_range.dat"

      output_grid = .False.
      output_psi0 = .True.
      output_psik = .False.
      output_ak = .True.
      output_ek = .False.
      output_psixt = .True.

      ! Assign potential parameters
      gamma = 20.0_dp
      a = 1.0_dp
      m = 1.0_dp

      ! Assign wavepacket parameters
      d_k = 0.4_dp * pi / a
      d_x = 1.0_dp / d_k
      k_0 = -1.4_dp * pi / a

      x_stdev = 4.0_dp
      k_stdev = 4.0_dp

      x_0 = a + x_stdev * d_x

      ! Assign grid and propagation parameters
      x_min = 0.0_dp
      x_max = x_0 + x_stdev * d_x
      n_x = 5e2

      k_min = k_0 - k_stdev * d_k
      k_max = k_0 + k_stdev * d_k
      n_k = 1e2

      t_min = 0.0_dp
      t_max = 5.0_dp
      n_t = 5e2

    end subroutine assign_params

    complex(dp) function psi0(x) result(val)
      ! Initial wavefunction
      implicit none

      real(dp), intent(in) :: x

      real(dp) :: norm

      norm = (pi * d_x**2) ** (-1.0_dp/4)
      val = norm * exp(-0.5_dp * ((x - x_0) / d_x)**2) * exp(j * k_0 * x)

    end function psi0

    complex(dp) function psik(x, k) result(val)
      ! Momentum-normalized continuum eigenstates
      implicit none

      real(dp), intent(in) :: x, k
      real(dp) :: c_left, c_right, ka, delta

      c_right = sqrt(2.0_dp / pi)
      ka = k * a
      delta = atan(ka * tan(ka) / (ka + gamma * tan(ka)))
      c_left = sin(delta) / sin(ka) * c_right

      val = 0
      if (0 .le. x .and. x .le. a) then
         val = c_left * sin(k * x)
      else if (x .ge. a) then
         val = c_right * sin(k * (x - a) + delta)
      end if

    end function psik

    real(dp) function ek(k) result(val)
      ! Free particle energy
      implicit none

      real(dp), intent(in) :: k

      val = k**2 / (2.0_dp * m)
    end function ek

end module params