* THIS IS ITERATIVE INTEGRATION PROCEDURE
* ORIGINATES  PROBABLY FROM CERN LIBRARY
* IT SUBDIVIDES INEGRATION RANGE UNTIL REQUIRED PRECISION IS REACHED
* PRECISION IS A DIFFERENCE FROM 8 AND 16 POINT GAUSS ITEGR. RESULT
* EEPS POSITIVE TREATED AS ABSOLUTE PRECISION
* EEPS NEGATIVE TREATED AS RELATIVE PRECISION
      DOUBLE PRECISION FUNCTION GAUS(F,A,B,EEPS)
*     *************************
      IMPLICIT REAL*8(A-H,O-Z)
      EXTERNAL F
      DIMENSION W(12),X(12)
      DATA CONST /1.0D-19/
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/

C-----------------------------------------------------------------------------
C NEW INTEGRATION METHOD - constant step size (provided by fourth parameter)
C comment out following 5 lines to return to old solutions of advantages too
C-----------------------------------------------------------------------------
      RESULT=0
      EPS=0
c      CALL STEPGAUSS(F,A,B,6,RESULT,EPS)
      CALL CHANGEGAUSS(F,A,B,2,RESULT,EPS)
      GAUS=RESULT
      RETURN
C-----------------------------------------------------------------------------
C PREVIOUS INTEGRATION METHOD - step size depends on EPSSQ
C-----------------------------------------------------------------------------
      EPS=dABS(EEPS)
      DELTA=CONST*dABS(A-B)
      GAUS=0.d0
      AA=A
    5 Y=B-AA
      IF(dABS(Y) .LE. DELTA) RETURN
    2 BB=AA+Y
      C1=0.5d0*(AA+BB)
      C2=C1-AA
      S8=0.d0
      S16=0.d0
      DO 1 I=1,4
      U=X(I)*C2
    1 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      DO 3 I=5,12
      U=X(I)*C2
    3 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S8=S8*C2
      S16=S16*C2
      IF(EEPS.LT.0D0) THEN
        IF(dABS(S16-S8) .GT. EPS*dABS(S16)) GO TO 4
      ELSE
        IF(dABS(S16-S8) .GT. EPS) GO TO 4
      ENDIF
      GAUS=GAUS+S16
      AA=BB
      GO TO 5
    4 Y=0.5d0*Y
      IF(dABS(Y) .GT. DELTA) GOTO 2
      PRINT 7
      GAUS=0.d0
      RETURN
    7 FORMAT(1X,36HGAUS  ... TOO HIGH ACCURACY REQUIRED)
      END

      DOUBLE PRECISION FUNCTION GAUS2(F,A,B,EEPS)
*     *************************
      IMPLICIT REAL*8(A-H,O-Z)
      EXTERNAL F
      DIMENSION W(12),X(12)
      DATA CONST /1.0D-19/
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/

C-----------------------------------------------------------------------------
C NEW INTEGRATION METHOD - constant step size (provided by fourth parameter)
C comment out following 5 lines to return to old solutions of advantages too
C-----------------------------------------------------------------------------
      RESULT=0
      EPS=0
c      CALL STEPGAUSS2(F,A,B,6,RESULT,EPS)
      CALL CHANGEGAUSS2(F,A,B,2,RESULT,EPS)
      GAUS2=RESULT
      RETURN
C-----------------------------------------------------------------------------
C PREVIOUS INTEGRATION METHOD - step size depends on EPSSQ
C-----------------------------------------------------------------------------
      EPS=dABS(EEPS)
      DELTA=CONST*dABS(A-B)
      GAUS2=0.D0
      AA=A
    5 Y=B-AA
      IF(dABS(Y) .LE. DELTA) RETURN
    2 BB=AA+Y
      C1=0.5d0*(AA+BB)
      C2=C1-AA
      S8=0.d0
      S16=0.d0
      DO 1 I=1,4
      U=X(I)*C2
    1 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      DO 3 I=5,12
      U=X(I)*C2
    3 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S8=S8*C2
      S16=S16*C2
      IF(EEPS.LT.0D0) THEN
        IF(dABS(S16-S8) .GT. EPS*dABS(S16)) GO TO 4
      ELSE
        IF(dABS(S16-S8) .GT. EPS) GO TO 4
      ENDIF
      GAUS2=GAUS2+S16
      AA=BB
      GO TO 5
    4 Y=0.5d0*Y
      IF(dABS(Y) .GT. DELTA) GOTO 2
      PRINT 7
      GAUS2=0.D0
      RETURN
    7 FORMAT(1X,36HGAUS2 ... TOO HIGH ACCURACY REQUIRED)
      END

      DOUBLE PRECISION FUNCTION GAUS3(F,A,B,EEPS)
*     *************************
      IMPLICIT REAL*8(A-H,O-Z)
      EXTERNAL F
      DIMENSION W(12),X(12)
      DATA CONST /1.0D-19/
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/

C-----------------------------------------------------------------------------
C NEW INTEGRATION METHOD - constant step size (provided by fourth parameter)
C comment out following 5 lines to return to old solutions of advantages too
C-----------------------------------------------------------------------------
      RESULT=0
      EPS=0
c      CALL STEPGAUSS3(F,A,B,6,RESULT,EPS)
      CALL CHANGEGAUSS3(F,A,B,2,RESULT,EPS)
      GAUS3=RESULT
      RETURN
C-----------------------------------------------------------------------------
C PREVIOUS INTEGRATION METHOD - step size depends on EPSSQ
C-----------------------------------------------------------------------------
      EPS=dABS(EEPS)
      DELTA=CONST*dABS(A-B)
      GAUS3=0.D0
      AA=A
    5 Y=B-AA
      IF(dABS(Y) .LE. DELTA) RETURN
    2 BB=AA+Y
      C1=0.5d0*(AA+BB)
      C2=C1-AA
      S8=0.d0
      S16=0.d0
      DO 1 I=1,4
      U=X(I)*C2
    1 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      DO 3 I=5,12
      U=X(I)*C2
    3 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S8=S8*C2
      S16=S16*C2
      IF(EEPS.LT.0D0) THEN
        IF(dABS(S16-S8) .GT. EPS*dABS(S16)) GO TO 4
      ELSE
        IF(dABS(S16-S8) .GT. EPS) GO TO 4
      ENDIF
      GAUS3=GAUS3+S16
      AA=BB
      GO TO 5
    4 Y=0.5d0*Y
      IF(dABS(Y) .GT. DELTA) GOTO 2
      PRINT 7
      GAUS3=0.D0
      RETURN
    7 FORMAT(1X,36HGAUS3 ... TOO HIGH ACCURACY REQUIRED)
      END

C--------------------------------------------------------------------------------------------------
C--------------------------------------------------------------------------------------------------
C--------------------------------------------------------------------------------------------------
C OBSOLETE 1.13      901108  3.40 CERN PROGRAM LIBRARY OBSOLETE PAM
C          CERN OBSOLETE PROGRAMS AND SUBROUTINES PAM-FILE.
C          MANY OF THE ROUTINES ARE FOR ONE FORTRAN DIALECT ONLY.
C          THE FLAG PATCH F77 SHOULD BE USED FOR THE FORTRAN 77 VERSIONS
C          SHOULD THEY EXIST - IF NOT FORTRAN 4 WILL BE OBTAINED.
C          THE CERN LIBRARIES GENLIB AND KERNLIB ARE USUALLY REQUIRED.
C          OBSOLETE ROUTINES OF THE PROGRAM LIBRARY ARE OFTEN REQUIRED.
C
      SUBROUTINE STEPGAUSS(F,A,B,LAMBDA,RESULT,EPS)
      implicit real*8 (a-h,o-z)
      DIMENSION W(12),X(12)
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/
      RESULT=0.
      EPS=0.
      AU=A
      C=(B-A)/FLOAT(LAMBDA)
      DO 1 I = 1,LAMBDA
      FI=I
      AO=A+FI*C
      C1=0.5*(AU+AO)
      C2=C1-AU
      S8=0.
      S16=0.
      DO 2 J = 1,4
      U=X(J)*C2
    2 S8=S8+W(J)*(F(C1+U)+F(C1-U))
      DO 3 J = 5,12
      U=X(J)*C2
    3 S16=S16+W(J)*(F(C1+U)+F(C1-U))
      RESULT=RESULT+C2*S16
      EPS=EPS+ABS(C2*(S16-S8))
    1 AU=AO
      RETURN
      END

      SUBROUTINE STEPGAUSS2(F,A,B,LAMBDA,RESULT,EPS)
      implicit real*8 (a-h,o-z)
      DIMENSION W(12),X(12)
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/
      RESULT=0.
      EPS=0.
      AU=A
      C=(B-A)/FLOAT(LAMBDA)
      DO 1 I = 1,LAMBDA
      FI=I
      AO=A+FI*C
      C1=0.5*(AU+AO)
      C2=C1-AU
      S8=0.
      S16=0.
      DO 2 J = 1,4
      U=X(J)*C2
    2 S8=S8+W(J)*(F(C1+U)+F(C1-U))
      DO 3 J = 5,12
      U=X(J)*C2
    3 S16=S16+W(J)*(F(C1+U)+F(C1-U))
      RESULT=RESULT+C2*S16
      EPS=EPS+ABS(C2*(S16-S8))
    1 AU=AO
      RETURN
      END

      SUBROUTINE STEPGAUSS3(F,A,B,LAMBDA,RESULT,EPS)
      implicit real*8 (a-h,o-z)
      DIMENSION W(12),X(12)
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/
      RESULT=0.
      EPS=0.
      AU=A
      C=(B-A)/FLOAT(LAMBDA)
      DO 1 I = 1,LAMBDA
      FI=I
      AO=A+FI*C
      C1=0.5*(AU+AO)
      C2=C1-AU
      S8=0.
      S16=0.
      DO 2 J = 1,4
      U=X(J)*C2
    2 S8=S8+W(J)*(F(C1+U)+F(C1-U))
      DO 3 J = 5,12
      U=X(J)*C2
    3 S16=S16+W(J)*(F(C1+U)+F(C1-U))
      RESULT=RESULT+C2*S16
      EPS=EPS+ABS(C2*(S16-S8))
    1 AU=AO
      RETURN
      END

*******************************************************************************
* FUNCTIONS FOR CHANGE OF VARIABLES *******************************************
*******************************************************************************
      DOUBLE PRECISION FUNCTION F_CHANGE(X,F,AMS1,AMS2)
      IMPLICIT NONE
      EXTERNAL F
      DOUBLE PRECISION F
      DOUBLE PRECISION X, NEW_X
      DOUBLE PRECISION AMS1,AMS2
      DOUBLE PRECISION ALP1,ALP2,ALP
      DOUBLE PRECISION AMRX,GAMRX
      DATA AMRX/0.77/,GAMRX/1.8/

      ALP1  = ATAN((AMS1-AMRX**2)/AMRX/GAMRX) ! integration range for ALP
      ALP2  = ATAN((AMS2-AMRX**2)/AMRX/GAMRX) ! integration range for ALP
      ALP   = ALP1 + X*(ALP2-ALP1)            ! change of variables

      NEW_X = AMRX**2+AMRX*GAMRX*TAN(ALP)     ! second change of variables

      F_CHANGE = F(NEW_X)

! Jacobian for change of variables
      F_CHANGE = F_CHANGE * (ALP2-ALP1) * ((NEW_X-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)

      RETURN
      END

      DOUBLE PRECISION FUNCTION F_CHANGE2(X,F,AMS1,AMS2)
      IMPLICIT NONE
      EXTERNAL F
      DOUBLE PRECISION F
      DOUBLE PRECISION X, NEW_X
      DOUBLE PRECISION AMS1,AMS2
      DOUBLE PRECISION ALP1,ALP2,ALP
      DOUBLE PRECISION AMRX,GAMRX
      DATA AMRX/0.77/,GAMRX/1.8/

      ALP1  = ATAN((AMS1-AMRX**2)/AMRX/GAMRX) ! integration range for ALP
      ALP2  = ATAN((AMS2-AMRX**2)/AMRX/GAMRX) ! integration range for ALP
      ALP   = ALP1 + X*(ALP2-ALP1)            ! change of variables

      NEW_X = AMRX**2+AMRX*GAMRX*TAN(ALP)     ! second change of variables

      F_CHANGE2 = F(NEW_X)

! Jacobian for change of variables
      F_CHANGE2 = F_CHANGE2 * (ALP2-ALP1) * ((NEW_X-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)

      RETURN
      END

      DOUBLE PRECISION FUNCTION F_CHANGE3(X,F,AMS1,AMS2)
      IMPLICIT NONE
      EXTERNAL F
      DOUBLE PRECISION F
      DOUBLE PRECISION X, NEW_X
      DOUBLE PRECISION AMS1,AMS2
      DOUBLE PRECISION ALP1,ALP2,ALP
      DOUBLE PRECISION AMRX,GAMRX
      DATA AMRX/0.77/,GAMRX/1.8/

      ALP1  = ATAN((AMS1-AMRX**2)/AMRX/GAMRX) ! integration range for ALP
      ALP2  = ATAN((AMS2-AMRX**2)/AMRX/GAMRX) ! integration range for ALP
      ALP   = ALP1 + X*(ALP2-ALP1)            ! change of variables

      NEW_X = AMRX**2+AMRX*GAMRX*TAN(ALP)     ! second change of variables

      F_CHANGE3 = F(NEW_X)

! Jacobian for change of variables
      F_CHANGE3 = F_CHANGE3 * (ALP2-ALP1) * ((NEW_X-AMRX**2)**2+(AMRX*GAMRX)**2)/(AMRX*GAMRX)

      RETURN
      END

*******************************************************************************
* INTEGRATION WITH CHANGED VARIABLES ******************************************
*******************************************************************************
      SUBROUTINE CHANGEGAUSS(F,AMS1,AMS2,LAMBDA,RESULT,EPS)
      implicit real*8 (a-h,o-z)
      EXTERNAL F,F2
      DIMENSION W(12),X(12)
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/
      RESULT=0.
      EPS=0.

! Range is changed from [AMS1,AMS2] to [0,1]
! F, AMS1 and AMS2 are parameters of F_CHANGE
      A=0
      B=1

      AU=A
      C=(B-A)/FLOAT(LAMBDA)
      DO 1 I = 1,LAMBDA
      FI=I
      AO=A+FI*C
      C1=0.5*(AU+AO)
      C2=C1-AU
      S8=0.
      S16=0.
      DO 2 J = 1,4
      U=X(J)*C2
    2 S8=S8+W(J)*(F_CHANGE(C1+U,F,AMS1,AMS2)+F_CHANGE(C1-U,F,AMS1,AMS2))
      DO 3 J = 5,12
      U=X(J)*C2
    3 S16=S16+W(J)*(F_CHANGE(C1+U,F,AMS1,AMS2)+F_CHANGE(C1-U,F,AMS1,AMS2))
      RESULT=RESULT+C2*S16
      EPS=EPS+ABS(C2*(S16-S8))
    1 AU=AO
      RETURN
      END

      SUBROUTINE CHANGEGAUSS2(F,AMS1,AMS2,LAMBDA,RESULT,EPS)
      implicit real*8 (a-h,o-z)
      EXTERNAL F,F2
      DIMENSION W(12),X(12)
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/
      RESULT=0.
      EPS=0.

! Range is changed from [AMS1,AMS2] to [0,1]
! F, AMS1 and AMS2 are parameters of F_CHANGE
      A=0
      B=1

      AU=A
      C=(B-A)/FLOAT(LAMBDA)
      DO 1 I = 1,LAMBDA
      FI=I
      AO=A+FI*C
      C1=0.5*(AU+AO)
      C2=C1-AU
      S8=0.
      S16=0.
      DO 2 J = 1,4
      U=X(J)*C2
    2 S8=S8+W(J)*(F_CHANGE2(C1+U,F,AMS1,AMS2)+F_CHANGE2(C1-U,F,AMS1,AMS2))
      DO 3 J = 5,12
      U=X(J)*C2
    3 S16=S16+W(J)*(F_CHANGE2(C1+U,F,AMS1,AMS2)+F_CHANGE2(C1-U,F,AMS1,AMS2))
      RESULT=RESULT+C2*S16
      EPS=EPS+ABS(C2*(S16-S8))
    1 AU=AO
      RETURN
      END

      SUBROUTINE CHANGEGAUSS3(F,AMS1,AMS2,LAMBDA,RESULT,EPS)
      implicit real*8 (a-h,o-z)
      EXTERNAL F,F2
      DIMENSION W(12),X(12)
      DATA W
     1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
     2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
     3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
     4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
      DATA X
     1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
     2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
     3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
     4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/
      RESULT=0.
      EPS=0.

! Range is changed from [AMS1,AMS2] to [0,1]
! F, AMS1 and AMS2 are parameters of F_CHANGE
      A=0
      B=1

      AU=A
      C=(B-A)/FLOAT(LAMBDA)
      DO 1 I = 1,LAMBDA
      FI=I
      AO=A+FI*C
      C1=0.5*(AU+AO)
      C2=C1-AU
      S8=0.
      S16=0.
      DO 2 J = 1,4
      U=X(J)*C2
    2 S8=S8+W(J)*(F_CHANGE3(C1+U,F,AMS1,AMS2)+F_CHANGE3(C1-U,F,AMS1,AMS2))
      DO 3 J = 5,12
      U=X(J)*C2
    3 S16=S16+W(J)*(F_CHANGE3(C1+U,F,AMS1,AMS2)+F_CHANGE3(C1-U,F,AMS1,AMS2))
      RESULT=RESULT+C2*S16
      EPS=EPS+ABS(C2*(S16-S8))
    1 AU=AO
      RETURN
      END


      function atdy3(z,x,y)
      atdy3=0.5*(y**2-x**2)
      return
      end


*     MB02MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, LMAX
      PARAMETER        ( MMAX = 20, NMAX = 20, LMAX = 20 )
      INTEGER          LDC, LDX
      PARAMETER        ( LDC = MAX( MMAX,NMAX+LMAX ), LDX = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MMAX*(NMAX+LMAX) +
     $                            MAX( 3*MIN(MMAX,NMAX+LMAX) +
     $                                   MAX(MMAX,NMAX+LMAX),
     $                                 5*MIN(MMAX,NMAX+LMAX),
     $                                 3*LMAX ) )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = LMAX )
      INTEGER          LENGS
      PARAMETER        ( LENGS = MIN( MMAX, NMAX+LMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION SDEV, TOL
      INTEGER          I, INFO, IWARN, J, L, M, N, RANK
      CHARACTER*1      JOB
*     .. Local Arrays ..
      DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK), S(LENGS),
     $                 X(LDX,LMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB02MD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, L, JOB
*
      IF ( LSAME( JOB, 'R' ) ) THEN
         READ ( NIN, FMT = * ) TOL
      ELSE IF ( LSAME( JOB, 'T' ) ) THEN
         READ ( NIN, FMT = * ) RANK, SDEV
         TOL = SDEV
      ELSE IF ( LSAME( JOB, 'N' ) ) THEN
         READ ( NIN, FMT = * ) RANK, TOL
      ELSE
         READ ( NIN, FMT = * ) SDEV
         TOL = SDEV
      END IF
*
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) L
      ELSE
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M )
*        Compute the solution to the TLS problem Ax = b.
         CALL MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, IWORK,
     $                DWORK, LDWORK, IWARN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) RANK
            ELSE
               IF ( ( LSAME( JOB, 'R' ) ) .OR. ( LSAME( JOB, 'B' ) ) )
     $            WRITE ( NOUT, FMT = 99996 ) RANK
            END IF
            WRITE ( NOUT, FMT = 99995 )
            DO 40 J = 1, L
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99994 ) X(I,J)
   20          CONTINUE
               IF ( J.LT.L ) WRITE ( NOUT, FMT = 99993 )
   40       CONTINUE
            WRITE ( NOUT, FMT = 99992 ) ( S(J),J = 1, MIN( M, N+L ) )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02MD = ',I2)
99997 FORMAT (' IWARN on exit from MB02MD = ',I2,/)
99996 FORMAT (' The computed rank of the TLS approximation = ',I3,/)
99995 FORMAT (' The solution X to the TLS problem is ',/)
99994 FORMAT (1X,F8.4)
99993 FORMAT (' ')
99992 FORMAT (/' The singular values of C are ',//(1X,F8.4))
99991 FORMAT (/' N is out of range.',/' N = ',I5)
99990 FORMAT (/' M is out of range.',/' M = ',I5)
99989 FORMAT (/' L is out of range.',/' L = ',I5)
      END


module blas_z3
  use blas_kinds, only : ik, dp
  implicit none
  private :: ik, dp

  interface
    subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: transa
      character(len=1) :: transb
      integer(ik) :: m
      integer(ik) :: n
      integer(ik) :: k
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: b(ldb, *)
      complex(dp) :: beta
      complex(dp) :: c(ldc, *)
    end subroutine zgemm
  end interface
  interface
    subroutine zhemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      integer(ik) :: m
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: b(ldb, *)
      complex(dp) :: beta
      complex(dp) :: c(ldc, *)
    end subroutine zhemm
  end interface
  interface
    subroutine zher2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      integer(ik) :: n
      integer(ik) :: k
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: b(ldb, *)
      real(dp) :: beta
      complex(dp) :: c(ldc, *)
    end subroutine zher2k
  end interface
  interface
    subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      integer(ik) :: n
      integer(ik) :: k
      real(dp) :: alpha
      complex(dp) :: a(lda, *)
      real(dp) :: beta
      complex(dp) :: c(ldc, *)
    end subroutine zherk
  end interface
  interface
    subroutine zsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      integer(ik) :: m
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: b(ldb, *)
      complex(dp) :: beta
      complex(dp) :: c(ldc, *)
    end subroutine zsymm
  end interface
  interface
    subroutine zsyr2k(uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      integer(ik) :: n
      integer(ik) :: k
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: b(ldb, *)
      complex(dp) :: beta
      complex(dp) :: c(ldc, *)
    end subroutine zsyr2k
  end interface
  interface
    subroutine zsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      import :: ik, dp
      integer(ik) :: ldc
      integer(ik) :: lda
      character(len=1) :: uplo
      character(len=1) :: trans
      integer(ik) :: n
      integer(ik) :: k
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: beta
      complex(dp) :: c(ldc, *)
    end subroutine zsyrk
  end interface
  interface
    subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      import :: ik, dp
      integer(ik) :: ldb
      integer(ik) :: lda
      character(len=1) :: side
      character(len=1) :: uplo
      character(len=1) :: transa
      character(len=1) :: diag
      integer(ik) :: m
      integer(ik) :: n
      complex(dp) :: alpha
      complex(dp) :: a(lda, *)
      complex(dp) :: b(ldb, *)
    end subroutine ztrmm
  end interface
end module blas_z3


      SUBROUTINE ALPHABLENDING(result, src, dest, alpha)

      INCLUDE 'ALPHABLENDING_INC.f'

      INTEGER i
      REAL result(1:SIZE), src(1:SIZE), dest(1:SIZE), alpha

c      INCLUDE 'ALPHABLENDING_INC2.f'

      DO 10 i = 1, SIZE
          result(i) = alpha * src(i) + ( 1 - alpha ) * dest(i)
10    ENDDO

      RETURN
      END

      SUBROUTINE ALPHABLENDINGREF(result, src, dest, alpha)

      INCLUDE 'ALPHABLENDING_INC.f'

      INTEGER i
      REAL result(1:SIZE), src(1:SIZE), dest(1:SIZE), alpha

c      INCLUDE 'ALPHABLENDING_INC2.f'

      DO 10 i = 1, SIZE
          result(i) = alpha * src(i) + ( 1 - alpha ) * dest(i)
10    ENDDO

      RETURN
      END

      INTEGER FUNCTION CLOCK()

      CLOCK = 0

      RETURN
      END

      PROGRAM MAIN

      INCLUDE 'ALPHABLENDING_INC.f'

      INTEGER i, j
      INTEGER bef, af, diff
      INTEGER befRef, afRef, diffRef
      INTEGER CLOCK
      REAL  a(1:SIZE), b(1:SIZE), c(1:SIZE)
      REAL  aRef(1:SIZE), bRef(1:SIZE),
     & cRef(1:SIZE)

      LOGICAL success

      REAL alpha
      alpha = 0.5

      DO 10 i = 1, SIZE
          b(i) = i
          c(i) = i
          bRef(i) = i
          cRef(i) = i
10    ENDDO

      bef = CLOCK()
      DO 20 i = 1, 2000
          CALL ALPHABLENDING(a, b, c, alpha)
20    ENDDO
      af = CLOCK()

      befRef = CLOCK()
      DO 21 i = 1, 2000
          CALL ALPHABLENDINGREF(aRef, bRef, cRef, alpha)
21    ENDDO
      afRef = CLOCK()

      success = .TRUE.

      DO 22 i = 1, SIZE
c         IF((ABS(a(i) - aRef(i)) / aRef(i)) .GT. 0.000001) THEN
          IF(a(i) .NE. aRef(i)) THEN
             success = .FALSE.
         ENDIF
22    ENDDO

      PRINT *, 'a = ', a(1)
      PRINT *, 'aRef = ', aRef(1)
      PRINT *, 'a = ', a(2)
      PRINT *, 'aRef = ', aRef(2)

      IF(success .EQV. .TRUE.) THEN
         PRINT *, 'SUCCESS'
      ELSE
         PRINT *, 'ERROR'
      ENDIF

      diff = af - bef
      diffRef = afRef - befRef
      PRINT *, 'time: ', diff
      PRINT *, 'reference time: ', diffRef

      RETURN
      END


      subroutine lagrad
*
*
*       lagrangian radii & mean radial and tangential velocities in the
*       ---------------------------------------------------------------
*       lagrangian shells
*       -----------------
*
*
      include 'common.h'
*
      real*8 zm,zm1,zm2,vvr,vvt,zmi,vr2,vt2,r21,r22,rla
*
      integer i,j,n,im
*
*
*       determine the lagrangian radii and mean radial and tangential
*       velocities in the lagrangian shells
*
      n = nt
*
      im = 0
      zm = 0.0d0
      zm2 = 0.0d0
*
      do 10 j=1,nlagra
         vvr = 0.0d0
         vvt = 0.0d0
         zmi = flagr(j)*smt
   20    im = im + 1
         i = iname(im)
         zm = zm + body(i)
         vr2 = vr(i) * vr(i)*body(i)
         vt2 = vt(i) * vt(i)*body(i)
         vvr = vvr + vr2
         vvt = vvt + vt2
*
         if(im.eq.n) then
           vr2 = 0.0d0
           vt2 = 0.0d0
           go to 30
         endif
*
         if (zm.le.zmi) go to 20
   30    zm1 = zm - body(i)
         vvr = vvr - vr2
         vvt = vvt - vt2
         if(im.eq.1) then
           r21 = 0.d0
         else
           r21 = r(im - 1)**3
         endif
         v2rl(j) = vvr/(zm1 - zm2)
         v2tl(j) = vvt/(zm1 - zm2)
         ani(j) = 2.0d0 - v2tl(j)/v2rl(j)
         r22 = r(im)**3
         rla = (zmi - zm) * (r22 - r21)/(zm - zm1) + r22
         rlag(j) = rla**one3
         im = im - 1
         zm = zm1
         zm2  =  zm1
*
 10   continue
*
*
      return
*
      end
*
*
*
*


! Main Program !
!It will only call a subroutine to do something
Program Main
  Use math_constants
  Use hs_structure
  Use structure_function_selector
  Use hssw_structure
  Use hsay_structure
  Use hd_structure
  Use scgle
  Use nescgle
  Use general_structural_functions
  Use omp_lib
  Use quadratures
  Implicit None
  Real * 8 :: phi, Tf, swlambda
  integer :: i1
  logical :: writting_op
  Character :: writting_choice
  Write(*,*) "IMPORTANT MESSAGE:"
  Write(*,*) "This program computes the mobility of a Hard Sphere (HS) + Square-Well (SW) system"
  Write(*,*) "when quenching from an infinite temperature (HS limit) to a given temperature. It"
  Write(*,*) "requires as an input the interaction length lambda with range (1:5] of the SW part,"
  Write(*,*) "the HS density as a volume fraction (0:0.582] and the final quenching temperature (0:10]."
  Write(*,*) "Selecting any parameter outside of the expected ranges may result in the program"
  Write(*,*) "behaving unexpectedly. The mobility is saved in the folder '*/data/'.  Additionally,"
  Write(*,*) "the user can select to save all the other kinetic properties given by the theory in the"
  Write(*,*) "subfolder '*/data/kinetics/'."
  Write(*,*) "**********************************************************************************"
  Write(*,*) "Please state the value of lambda (1 : 5]"
  Read(*,*) swlambda
  Write(*,*) "lambda=",swlambda
  Write(*,*) "Please state the value of the volume fraction (0 : 0.582]"
  Read(*,*)  phi
  Write(*,*) "volume fraction=",phi
  Write(*,*) "Please state the value of the final quenching temperature (0 : 10]"
  Read(*,*)  Tf
  Write(*,*) "Final temperature=",Tf
  Write(*,*) "Do you desire to write the additional kinetic properties?"
  Write(*,*) "Please input 'y' for yes and 'n' for no"
  Read(*,*) writting_choice
  If( writting_choice == 'y' ) then
    writting_op=.true.
    Write(*,*) "Additional kinetic properties will be saved in '*/data/kinetics/'"
  else
    writting_op=.false.
    Write(*,*) "No additional kinetic properties will be saved"
  endif
  call HS_HSSW_quench_mobility_dl_convergence_no_gr(phi,Tf,swlambda,writting_op)

Contains

  Subroutine HS_HSSW_quench_mobility_dl_convergence_no_gr(phi,Tf,swlambda,writting_op)
    Implicit None
    real * 8, intent(in) :: phi, Tf,swlambda
    logical, intent(in) :: writting_op
    real * 8, dimension(:), Allocatable :: s_params_i, s_params_f
    real * 8, dimension(2**10) :: qp,qw
    real * 8 :: phi_B_l, phi_B_u,T_c,phi_c,T_sharma
    real * 8 ::  T, z, rho, D0,gam_val,ua_val,ua_writting
    integer, parameter :: knp = 2**10, tnp = 2**9, nst = 10, decim = 32

    integer, parameter :: ktnp = 12
    Real * 8, dimension(7) :: dyn_p
    real * 8, dimension(knp) :: kv, kwv, skv, lamkv,SkI,SkF,alphaku
    real * 8, dimension(knp/2) :: kv1, kwv1, kv2, kwv2
    real * 8, dimension(ktnp) :: kv_t, skv_t,lamkv_t, SkI_t, SkF_t, alphaku_t

    real * 8, dimension(4,knp) :: s_arrays
    real * 8, dimension(3,ktnp) :: s_w_arrays
    real * 8, dimension(3) :: k_quadp, k_quadp1, k_quadp2

    real * 8, dimension(3) :: quad_ch_p
    real * 8, parameter :: k_max = 40.96d0, k_max_1=4.d0, k_min = 0.d0, dt = 1.d-7
    real * 8, parameter :: kgr_max = (2**6) * 40.96d0, kgr_min = 0.d0
    real * 8 :: dk, kc, k, Dl,gam, T_up, T_low,Ts,Ta, Dl_I, Dl_F
    real * 8 :: t_val, dt_linear, db,kgr_min1, kgr_max1
    logical :: convergence
    character (len=100) :: folder,folder_kinetics,folder_mobility
    character (len=4) :: sys, k_approx, dr_approx, r_approx,sys_approx
    character (len=4) :: sys_i, sys_f, sys_approx_i, sys_approx_f
    character (len=4) :: u_char
    character (len=200) :: u_file_name
    integer :: i1,i2,i3,i4,i5,id,ikp,d,u_count,ikp_i,ikp_f
    integer, parameter :: quad_ch_np = 2**10

    real * 8, dimension(quad_ch_np) :: quad_ch_v, quad_ch_w, quad_ch_v2, quad_ch_w2
    real * 8 :: ur_min, ur_max
    integer, dimension(5) :: dyn_units
    integer, dimension(6) :: units
    Real * 8 :: du,u_val,bu,bu_p,rel_dif_b, rel_dif_bF,dr,ncoor_last
    Real * 8, parameter :: db_threshold = 5.0d-3, bF_threshold=1.d-4
    Real * 8, parameter :: dtw_wthreshold = 0.1d0, tw_wstart = 1.d-4
    Real * 8 :: tw_w_1, tw_w, u_w_1,u_w, du_w_1, dtw_w_1
    Real * 8 :: tw_w_p, u_p, dtw_w,Dl_tw,du_w
    Real * 8 :: uw, energy, press, energy_ua, press_ua
    folder= "data/"
    folder_mobility="data/"
    folder_kinetics= "data/kinetics/"
    !swlambda = 1.5d0
    d = 3
    ikp = 4
    !!!!!
    rho = 6.d0 * phi / pi

    k = 6.1d0
    z = 2.d0
    dr = 1.d-2
    d = 3
    ikp = 4
    ikp_i=2
    ikp_f=4

    Allocate (s_params_i(ikp_i))
    Allocate (s_params_f(ikp_f))

    k_quadp(1) = k_min
    k_quadp(2) = k_max
    k_quadp(3) = dble(knp)

    k_quadp1(1) = k_min
    k_quadp1(2) = k_max_1
    k_quadp1(3) = dble(knp/2)

    k_quadp2(1) = k_max_1
    k_quadp2(2) = k_max
    k_quadp2(3) = dble(knp/2)

    quad_ch_p(1) = -1.d0
    quad_ch_p(1) = 1.d0
    quad_ch_p(3) = quad_ch_np

    Write(k_approx,"(A4)") "CLCU"
    Write(dr_approx,"(A4)") "CLCU"
    Write(r_approx,"(A4)") "RECT"
    Write(sys_f,"(A4)") "HSSW"
    Write(sys_approx_f,"(A4)") "GSVW"
    Write(sys_i,"(A4)") "HS00"
    Write(sys_approx_i,"(A4)") "VW00"
    D0 = 1.d0
    dk = 1.d-2
    convergence = .false.
    !NOTA: estoy partiendo en dos intervalos la integracion
    call quad_select(k_approx,k_quadp1,kv1,kwv1)
    call quad_select(k_approx,k_quadp2,kv2,kwv2)
    call Clenshaw_Curtis_quadrature(quad_ch_np,quad_ch_v,quad_ch_w)
    Do i1=1, knp/2
      kv(i1)=kv1(i1)
      kv(i1 + (knp/2)) = kv2(i1)
      kwv(i1)=kwv1(i1)
      kwv(i1 + (knp/2)) = kwv2(i1)
    End Do
    id = 1
    kc = 2.d0 * pi * 1.305d0
    do i1=1, knp
      lamkv(i1) = lambda(kv(i1),kc)
    end do
    !Writting wave-vectors
    kv_t(1) = 2.d-1
    kv_t(2) = 4.d-1
    kv_t(3) = 6.d-1
    kv_t(4) = 8.d-1
    kv_t(5) = 1.d0
    kv_t(6) = 2.d0
    kv_t(7) = 3.d0
    kv_t(8) = 4.d0
    kv_t(9) = 5.d0
    kv_t(10) = 6.18d0
    kv_t(11) = 2 * pi
    kv_t(12) = 7.18
    do i1=1, ktnp
      lamkv_t(i1) = lambda(kv_t(i1),kc)
    end do
    s_arrays(1,:) = kv
    s_arrays(2,:) = kwv
    s_arrays(4,:) = lamkv
    s_w_arrays(1,:) = kv_t
    s_w_arrays(3,:) = lamkv_t
    !!!!!
    !Dynamic units for writting

    units(1)=101
    units(2)=103
    units(3)=104
    units(4)=105
    units(5)=106
    units(6)=107
    dyn_units(1) = units(3)
    dyn_units(2) = units(4)
    dyn_units(3) = units(5)
    dyn_units(4) = units(2)
    dyn_units(5) = units(6)

    s_params_i(1) = phi !Initial phi
    !s_params_i(2) = Ti !Initial Temperature
    !s_params_i(3) = swlambda !Initial length of square well
    !!!!
    s_params_f(1) = phi !Final phi
    s_params_f(2) = Tf !Final Temperature
    s_params_f(3) = swlambda !Final length of square well
    !!!!
    dyn_p(1) = dble (  d  )
    dyn_p(2) = dble ( nst )
    dyn_p(3) = dble ( tnp )
    dyn_p(4) = dble (decim)
    dyn_p(5) = rho
    dyn_p(6) = D0
    dyn_p(7) = dt
    !!!!
    call file_name_constructor(sys_f,s_params_f,folder_mobility,"bu",id,".dat",u_file_name)
    Open (unit = 21, file=trim(u_file_name), status="Replace")
    Write (21,*) "#u // bu // tw "

    !time identifier of kinetic files
    If (writting_op .eqv. .True.) Then
      call file_name_constructor(sys_f,s_params_f,folder_kinetics,"t_u_files",id,".dat",u_file_name)
      Open (unit = 22, file=trim(u_file_name), status="Replace")
      Write (22,*) "#u digit //  tw  // u // bu "
    endif

    Do i1 = 1, knp
      s_params_i(ikp_i) = kv(i1)
      s_params_f(ikp_f) = kv(i1)
      SkI(i1) = structure("s0",sys_i,sys_approx_i,s_params_i)
      SkF(i1) = structure("s0",sys_f,sys_approx_f,s_params_f)
    End Do
    Do i1 = 1, ktnp
      s_params_i(ikp_i) = kv_t(i1)
      s_params_f(ikp_f) = kv_t(i1)
      SkI_t(i1) = structure("s0",sys_i,sys_approx_i,s_params_i)
      SkF_t(i1) = structure("s0",sys_f,sys_approx_f,s_params_f)
    End Do
    call Calc_alphaSku(kv,SkF,D0,alphaku)
    call Calc_alphaSku(kv_t,SkF_t,D0,alphaku_t)
    Print*, "Calculating ua:"
    ua_val = calc_ua_isoch_inst_quench(SkI,SkF,alphaku,lamkv,kv,kwv,rho,d)
    Print*, "ua = ", ua_val
    skv   = sku_quench(SkI,SkF,alphaku,ua_val)
    skv_t = sku_quench(SkI_t,SkF_t,alphaku_t,ua_val)
    !Calculating initial diffussion
    If (writting_op .eqv. .True.) then
      call file_open_HSSW_quench_mobility_1(sys_i,s_params_i,folder_kinetics,id,units,0)
    End If
    s_arrays(3,:)   = SkI
    s_w_arrays(2,:) = SkI_t
    !writting_op = .True.
    Print*, "Calculating Initial state dynamics"
    call Long_t_dynamics_Dl_convergence(dyn_p,s_arrays,Dl_I,writting_op,s_w_arrays,dyn_units)
    If (writting_op .eqv. .True.) Then
      call efh_HSSW_quench_mobility(kv,skI,kwv,units,sys_i,s_params_i,sys_approx_i,Dl_I,gam_val,kc)
    End If
    If (writting_op .eqv. .True.) Then
      call file_open_HSSW_quench_mobility_1(sys_f,s_params_f,folder_kinetics,id,units,999)
    End If
    s_arrays(3,:)   = skv
    s_w_arrays(2,:) = skv_t
    Print*, "Calculating Final state dynamics"
    !call SCGLE_dynamics(dyn_p,s_arrays,Dl_F,writting_op,s_w_arrays,dyn_w_arrays,dyn_units)
    call Long_t_dynamics_Dl_convergence(dyn_p,s_arrays,Dl_F,writting_op,s_w_arrays,dyn_units)
    If (Dl_F < 1.d-6) Dl_F = 1.d-6
    If (writting_op .eqv. .True.) Then
      call efh_HSSW_quench_mobility(kv,skv,kwv,units,sys_f,s_params_f,sys_approx,Dl_F,gam_val,kc)
    End If
    gam_val = gamma(d,rho,kv,kwv,Skv,lamkv)
    Print*, "gamma=", gam_val
    !Calculating g(r;t=0) and g_a(r)
    du = 1.d-7
    u_val = 0.d0
    t_val = 0.d0
    Write (21,*) u_val, Dl_I, t_val

    flush(21)
    bu_p = Dl_I
    convergence = .false.
    u_count = 0
    tw_w_p = tw_wstart!dtw_wthreshold
    do while (convergence .eqv. .false.)
      u_val = u_val + du
      skv   = sku_quench(SkI,SkF,alphaku,u_val)
      skv_t = sku_quench(SkI_t,SkF_t,alphaku_t,u_val)
      s_arrays(3,:)   = Skv
      s_w_arrays(2,:) = Skv_t
      call Long_t_dynamics_Dl_convergence(dyn_p,s_arrays,bu,writting_op,s_w_arrays,dyn_units)
      If (bu < 1.d-6) bu = 1.d-6
      db = abs(bu_p - bu)
      dt_linear = du / bu
      t_val = t_val + dt_linear
      Write (21,*) u_val, bu, t_val
      flush(21)
      !Writting wanted times
      dtw_w = log10(t_val) - log10(tw_w_p)
      print*, dtw_w, t_val, tw_w_p
      If ( t_val > tw_wstart .and. dtw_w > dtw_wthreshold ) Then
        tw_w_1 = t_val - dt_linear
        u_w_1 = u_val - du
        If (tw_w_1 < tw_wstart) Then
          dtw_w_1  = tw_wstart - tw_w_1
          du_w_1   = bu * dtw_w_1
        Else If (dtw_w > dtw_wthreshold) Then
          dtw_w_1  = tw_w_p * ( 10**(dtw_wthreshold) ) - tw_w_1
          du_w_1   = bu * dtw_w_1
        Else
        End If
        u_w = u_w_1 + du_w_1
        skv   = sku_quench(SkI,SkF,alphaku,u_w)
        skv_t = sku_quench(SkI_t,SkF_t,alphaku_t,u_w)
        !File writting
        u_count=u_count+1
        Print*, "Calculating writting log equispaced, count:", u_count
        call file_open_HSSW_quench_mobility_1(sys_f,s_params_f,folder_kinetics,id,units,u_count)
        s_arrays(3,:)   = Skv
        s_w_arrays(2,:) = Skv_t
        call Long_t_dynamics_Dl_convergence(dyn_p,s_arrays,Dl_tw,writting_op,s_w_arrays,dyn_units)
        call efh_HSSW_quench_mobility(kv,skv,kwv,units,sys_f,s_params_f,sys_approx,Dl_tw,gam_val,kc)
        tw_w_p = tw_w_1 + dtw_w_1
        Print*, "For the values: u_w=",u_w,"tw_approx=", tw_w_p
        If (writting_op .eqv. .True.) Then
          Write (22,*) u_count, tw_w_p, u_w, Dl_tw
          flush(22)
        End if
      End If
      !Changing du and out while options
      rel_dif_b  = abs((bu_p / bu) - 1.d0)
      rel_dif_bF = abs((bu / Dl_F) - 1.d0)
      If ( rel_dif_b < db_threshold ) Then
        du = du * 2.d0
      Else
        du = du / 2.d0
      End If
      If (u_val + du >= ua_val ) convergence = .True.
      If (rel_dif_bF <= bF_threshold ) convergence = .True.
      bu_p = bu
    End Do
    Write (21,*) ua_val, Dl_F
    flush(21)
    close(21)
    If (writting_op .eqv. .True.) Then
      close(22)
    endif
  End Subroutine

  Subroutine file_open_HSSW_quench_mobility_1(sys,s_params,folder,id,units,u_count)
    Implicit None
    integer, Intent(in) :: id, u_count
    character (len=4), Intent(in) :: sys
    character (len=100), Intent(in) :: folder
    integer, dimension(:), Intent(in) :: units
    real * 8, dimension(:), Intent(in) :: s_params
    character (len=200) :: S_file_name, inf_file_name, u_file_name, g_file_name
    character (len=200) :: Fc_file_name, Fs_file_name, dyn_file_name, tau_file_name
    character(len=5) :: u_char
    Write(u_char,"(A2,I3.3)") "u_",u_count
    if (u_count==999) Write(u_char,"(A5)") "ua000"
    call file_name_constructor(sys,s_params,folder,u_char//"_s",id,".dat",S_file_name)
    call file_name_constructor(sys,s_params,folder,u_char//"_tau",id,".dat",tau_file_name)
    call file_name_constructor(sys,s_params,folder,u_char//"_Fc",id,".dat",Fc_file_name)
    call file_name_constructor(sys,s_params,folder,u_char//"_Fs",id,".dat",Fs_file_name)
    call file_name_constructor(sys,s_params,folder,u_char//"_dyn",id,".dat",dyn_file_name)
    call file_name_constructor(sys,s_params,folder,u_char//"_info",id,".inf",inf_file_name)
    open (unit=units(1), file=trim(S_file_name), status="Replace")
    open (unit=units(2), file=trim(inf_file_name), status="Replace")
    open (unit=units(3), file=trim(Fc_file_name), status="Replace")
    open (unit=units(4), file=trim(Fs_file_name), status="Replace")
    open (unit=units(5), file=trim(dyn_file_name), status="Replace")
    open (unit=units(6), file=trim(tau_file_name), status="Replace")
  End Subroutine

  Subroutine close_units(units)
    Implicit None
    Integer, Dimension(:) :: units
    Integer :: i1
    Do i1=1, size(units)
      close(units(i1))
    End Do
  End Subroutine

  Subroutine efh_HSSW_quench_mobility(kv,sk,kwv,units,sys,s_params,sys_approx,Dl,gam_val,kc)
    Implicit None
    real * 8, Dimension(:), Intent(in) :: kv, sk, kwv, s_params
    integer, Dimension(:), Intent(in) :: units
    real * 8, Intent(in) :: Dl, gam_val, kc
    character (len=4), Intent(in) :: sys, sys_approx
    call s_writting(kv,sk,kwv,units(1))
    call sys_writting(sys,s_params,sys_approx,units(2))
    call lambda_info_writting(kc,units(2))
    call dynamics_Long_t_info_writting(Dl,gam_val,units(2))
    call close_units(units)
  End Subroutine

End program


module heap_map_int_int_mod
    ! This module include
    ! double_heap_sort(key_arr, value_arr) O(NlogN)
    ! heap map
    ! 最小値を素早く返します。
    ! 最大値を素早く返したい場合
    !  1. 値の符号を変えてpush
    !  2. popやtopで取得した値は符号を元に戻すのを忘れずに。
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public:: double_heap_sort
    type, public:: heap_map_int_int
        integer(int32),private:: len
        integer(int64), allocatable,private:: key(:), val(:)
    contains
        procedure:: size => hm_size
        procedure:: remain => hm_remain
        procedure:: top => hm_top
        procedure:: push => hm_push
        procedure:: pop => hm_pop
        procedure:: to_array => hm_to_array
    end type
    interface heap_map_int_int
        module procedure init_hm, init_hm_with_len, init_hm_with_ar
    end interface
contains
    pure elemental function to_int64(num) result(ret)
        class(*), intent(in) :: num
        integer(int64):: ret

        select type (num)
            type is (integer(int64))
                ret = num
            type is (integer(int32))
                ret = int(num, int64)
            class default
                ret = 0_int64
                ret = 1_int64/ret
        end select
    end function

    function init_hm() result(hm)
        type(heap_map_int_int):: hm
        hm%len=0
        allocate(hm%key(1))
        allocate(hm%val(1))
    end function

    function init_hm_with_len(n) result(hm)
        integer(int32),intent(in):: n
        type(heap_map_int_int):: hm
        hm%len=0
        allocate(hm%key(n))
        allocate(hm%val(n))
    end function

    function init_hm_with_ar(k_ar, v_ar) result(hm)
        class(*),intent(in):: k_ar(:), v_ar(:)
        integer(int32):: i, l
        type(heap_map_int_int):: hm

        l = min(size(k_ar), size(v_ar))
        hm = heap_map_int_int(l)
        do i=1,l
            call hm%push(to_int64(k_ar(i)), to_int64(v_ar(i)))
        end do
    end function

    function hm_size(hm) result(ret)
        class(heap_map_int_int):: hm
        integer(int32):: ret

        ret = hm%len
    end function

    function hm_remain(hm) result(ret)
        class(heap_map_int_int):: hm
        logical:: ret

        ret = hm%size() > 0
    end function

    subroutine hm_push(hm,k,v)
        class(heap_map_int_int):: hm
        class(*):: k,v

        if (.not. allocated(hm%key)) then
            hm%len=0
            allocate(hm%key(1))
            allocate(hm%val(1))
        end if

        if (hm%len+1 >= size(hm%key)) call add(hm)
        hm%len=hm%len+1
        hm%key(hm%len) = to_int64(k)
        hm%val(hm%len) = to_int64(v)
        call heap_up(hm,hm%len)
    end subroutine

    subroutine hm_top(hm,k,v)
        class(heap_map_int_int):: hm
        integer(int64),intent(out):: k, v

        k=hm%key(1)
        v=hm%val(1)
    end subroutine

    subroutine hm_pop(hm,k,v)
        class(heap_map_int_int):: hm
        integer(int64),intent(out):: k, v

        k=hm%key(1)
        v=hm%val(1)
        hm%key(1) = hm%key(hm%len)
        hm%val(1) = hm%val(hm%len)
        hm%len=hm%len-1
        call heap_down(hm,1_int32)
    end subroutine

    subroutine add(hm)
        class(heap_map_int_int):: hm

        call add_array(hm%key)
        call add_array(hm%val)
    end subroutine

    subroutine add_array(ar)
        integer(int64),allocatable,intent(inout):: ar(:)
        integer(int64),allocatable:: tmp(:)
        integer(int32):: l

        l = size(ar)
        allocate(tmp(1:2*l))
        tmp(1:l) = ar(1:l)
        call move_alloc(tmp, ar)
    end subroutine

    subroutine heap_up(hm,ind)
        class(heap_map_int_int):: hm
        integer(int32),value:: ind
        integer(int32):: c

        do while(ind > 1)
            c = ind/2
            if (hm%key(ind) > hm%key(c)) return
            call kv_swap(hm, ind, c)
            ind=c
        end do
    end subroutine

    subroutine heap_down(hm,ind)
        class(heap_map_int_int):: hm
        integer(int32),value:: ind
        integer(int32):: c1,c2,c

        do while(ind*2 <= hm%len)
            c1 = ind*2; c2 = c1+1; c = c1
            if (c2 <= hm%len) c = merge(c1, c2, hm%key(c1) < hm%key(c2))
            if (hm%key(c) > hm%key(ind)) return
            call kv_swap(hm, c, ind)
            ind = c
        end do
    end subroutine

    subroutine hm_to_array(hm, k_ar, v_ar)
        class(heap_map_int_int):: hm
        integer(int64):: k_ar(hm%len), v_ar(hm%len)
        integer(int64):: i

        i=1
        do while(hm_remain(hm))
            call hm_pop(hm,k_ar(i), v_ar(i))
            i=i+1
        end do
    end subroutine

    subroutine double_heap_sort(k_ar, v_ar)
        type(heap_map_int_int):: hm
        integer(int64):: k_ar(:), v_ar(:)

        hm = heap_map_int_int(k_ar, v_ar)
        call hm_to_array(hm,k_ar,v_ar)
    end subroutine

    subroutine kv_swap(hm, i1, i2)
        type(heap_map_int_int),intent(inout):: hm
        integer(int32),intent(in):: i1,i2

        call swap(hm%key(i1),hm%key(i2))
        call swap(hm%val(i1),hm%val(i2))
    contains
        subroutine swap(x, y)
            integer(int64),intent(inout):: x,y
            x=xor(x,y)
            y=xor(x,y)
            x=xor(x,y)
        end subroutine
    end subroutine
end module


module m_lanczos

    contains

    !! use parallel Lanczos method to find the ground state
    subroutine diag_ham_lanczos(nblock, end_indx, needed, nloc, nev, max_niter, eval_tol, ham, eval, n_vec, evec)
        use m_constants, only: dp, zero, czero, mystd
        use m_control, only: nprocs , myid, master
        use m_types
        use mpi

        implicit none

        ! external variables
        integer, intent(in)       :: nblock
        integer, intent(in)       :: end_indx(2,2,nprocs)
        integer, intent(in)       :: needed(nprocs, nprocs)
        integer, intent(in)       :: nloc
        integer, intent(in)       :: nev
        integer, intent(in)       :: max_niter
        real(dp), intent(in)      :: eval_tol
        type (T_csr)              :: ham(nblock)
        real(dp), intent(out)     :: eval(nev)
        integer, intent(in)       :: n_vec
        complex(dp), intent(out)  :: evec(nloc,n_vec)

        ! local variables
        real(dp),    allocatable :: temp_vec(:)
        complex(dp), allocatable :: work_vec(:,:)
        real(dp),    allocatable :: alpha(:)
        real(dp),    allocatable :: beta(:)
        real(dp),    allocatable :: krylov_eigval(:)
        real(dp),    allocatable :: krylov_eigvec(:,:)

        integer :: curr
        integer :: prev
        integer :: temp_indx
        integer :: i,j
        integer :: nkrylov
        integer :: ierror

        real(dp) :: res

        complex(dp) :: temp1
        complex(dp) :: temp1_mpi

        allocate(temp_vec(nloc))
        allocate(work_vec(nloc,2))
        allocate(alpha(max_niter))
        allocate(beta(0:max_niter))
        allocate(krylov_eigval(max_niter))
        allocate(krylov_eigvec(max_niter,max_niter))

        temp_vec = zero
        eval     = zero
        work_vec = czero
        alpha    = zero
        beta     = zero

        call random_seed()
        call random_number(temp_vec)
        work_vec(:,1) = temp_vec - 0.5
        if (allocated(temp_vec)) deallocate(temp_vec)

        ! normalize v1
        temp1 = czero
        temp1_mpi = czero
        temp1 = dot_product(work_vec(:,1), work_vec(:,1))
        call MPI_ALLREDUCE(temp1, temp1_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
        temp1 = sqrt(real(temp1_mpi))
        work_vec(:,1) = work_vec(:,1) / temp1
        evec(:,1) = work_vec(:,1)

        curr = 1
        prev = 2
        nkrylov = 0

        do i=1,max_niter
            ! matrix-vector product
            call MPI_BARRIER(MPI_COMM_WORLD, ierror)
            work_vec(:,prev) = -beta(i-1) * work_vec(:,prev)
            call pspmv_csr(MPI_COMM_WORLD, nblock, end_indx, needed, nloc, nloc, ham, work_vec(:,curr), work_vec(:,prev))
            call MPI_BARRIER(MPI_COMM_WORLD, ierror)
            ! compute alpha_i
            temp1 = czero
            temp1_mpi = czero
            temp1 = dot_product(work_vec(:,curr), work_vec(:,prev))
            call MPI_ALLREDUCE(temp1, temp1_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
            alpha(i) = real(temp1_mpi)

            if (mod(i,10) == 0 .or. i==max_niter) then
                krylov_eigval = zero
                krylov_eigvec = zero
                call krylov_eigs(i, alpha(1:i), beta(1:i-1), krylov_eigval(1:i), krylov_eigvec(1:i,1:i))
                ! check convergence
                if (i>=nev) then
                    res = krylov_eigval(nev) - eval(nev)
                    if (myid==master) then
                        write(mystd,"(a25, i5, E10.2, a5, E10.2)")  "Lanczos iteration:  ", i, abs(res), "-->", eval_tol
                    endif
                    if (abs(res) < eval_tol) then
                        eval(1:nev) = krylov_eigval(1:nev)
                        nkrylov = i
                        EXIT
                    endif
                endif
                eval(1:nev) = krylov_eigval(1:nev)
            endif

            work_vec(:,prev) = work_vec(:,prev) - alpha(i) * work_vec(:,curr)
            ! compute beta_{i+1}
            temp1 = czero
            temp1_mpi = czero
            temp1 = dot_product(work_vec(:,prev), work_vec(:,prev))
            call MPI_ALLREDUCE(temp1, temp1_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
            beta(i) = sqrt(real(temp1_mpi))
            ! beta is too small, exit
            if (abs(beta(i)) < 1E-10) then
                krylov_eigval = zero
                krylov_eigvec = zero
                if (i>=2) then
                    call krylov_eigs(i, alpha(1:i), beta(1:i-1), krylov_eigval(1:i), krylov_eigvec(1:i,1:i))
                    eval(1:nev) = krylov_eigval(1:nev)
                else
                    eval(1) = alpha(1)
                    krylov_eigvec(1,1) = 1.0_dp
                endif
                nkrylov = i
                EXIT
            endif
            work_vec(:,prev) = work_vec(:,prev) / beta(i)
            temp_indx = curr
            curr = prev
            prev = temp_indx
        enddo

        ! build eigenvectors if wanted
        work_vec = czero
        work_vec(:,1) = evec(:,1)
        evec  = czero
        curr  = 1
        prev  = 2
        do i=1,nkrylov
            do j=1,n_vec
                evec(:,j) = evec(:,j) + krylov_eigvec(i,j) * work_vec(:,curr)
            enddo
            if (i<nkrylov) then
                call MPI_BARRIER(MPI_COMM_WORLD, ierror)
                work_vec(:,prev) = -alpha(i) * work_vec(:,curr) - beta(i-1) * work_vec(:,prev)
                call pspmv_csr(MPI_COMM_WORLD, nblock, end_indx, needed, nloc, nloc, ham, work_vec(:,curr), work_vec(:,prev))
                call MPI_BARRIER(MPI_COMM_WORLD, ierror)
                work_vec(:,prev) = work_vec(:,prev) / beta(i)
                temp_indx = curr
                curr = prev
                prev = temp_indx
            endif
        enddo

        if (allocated(work_vec))        deallocate(work_vec)
        if (allocated(alpha))           deallocate(alpha)
        if (allocated(beta))            deallocate(beta)
        if (allocated(krylov_eigval))   deallocate(krylov_eigval)
        if (allocated(krylov_eigvec))   deallocate(krylov_eigvec)

        return
    end subroutine diag_ham_lanczos

    subroutine krylov_eigs(n, alpha, beta, eval, evec)
        use m_constants, only: dp, zero
        implicit none

        ! external variables
        integer, intent(in) :: n
        real(dp), intent(in) :: alpha(n)
        real(dp), intent(in) :: beta(n-1)
        real(dp), intent(out) :: eval(n)
        real(dp), intent(out) :: evec(n,n)

        ! local variables
        real(dp), allocatable :: tmp_beta(:)
        real(dp), allocatable :: work(:)
        integer :: i
        integer :: info

        allocate(tmp_beta(n-1))
        allocate(work(max(1,2*n-2)))
        eval = alpha
        tmp_beta = beta
        work = zero
        ! init evec to identity matrix
        evec = zero
        do i=1,n
            evec(i,i) = 1.0_dp
        enddo
        call dsteqr('I', n, eval, tmp_beta, evec, n, work, info)
        if (info /= 0 ) then
            print *, "error in dster, info: ", info
            STOP
        endif

        if (allocated(tmp_beta)) deallocate(tmp_beta)
        if (allocated(work))     deallocate(work)

        return
    end subroutine krylov_eigs

    !! given a Hamiltonian H, an initial vector V1, build its Krylov space with desired dimension
    !! return the actual dimension of the Krylov space, the normalization parameter of V0, alpha and beta
    subroutine build_krylov_mp(nblock, end_indx, needed, nloc, ham, init_vec, maxn, neff, alpha, beta, norm)
        use m_constants, only: dp, zero, czero, mystd
        use m_control, only: nprocs, myid, master
        use m_types
        use mpi

        implicit none

        ! external variables
        integer, intent(in)      :: nblock
        integer, intent(in)      :: end_indx(2,2,nprocs)
        integer, intent(in)      :: needed(nprocs, nprocs)
        integer, intent(in)      :: nloc
        type (T_csr)             :: ham(nblock)
        complex(dp), intent(in)  :: init_vec(nloc)
        integer, intent(in)      :: maxn
        integer, intent(out)     :: neff
        real(dp), intent(out)    :: alpha(maxn)
        real(dp), intent(out)    :: beta(0:maxn)
        real(dp), intent(out)    :: norm

        ! local variables
        complex(dp), allocatable :: work_vec(:,:)

        integer :: curr
        integer :: prev
        integer :: temp_indx
        integer :: i
        integer :: ierror

        complex(dp) :: temp1
        complex(dp) :: temp1_mpi

        allocate(work_vec(nloc,2))

        work_vec = czero
        alpha    = zero
        beta     = zero
        neff     = 0
        norm     = zero

        work_vec(:,1) = init_vec
        ! normalize V1
        temp1 = czero
        temp1_mpi = czero
        temp1 = dot_product(work_vec(:,1), work_vec(:,1))
        call MPI_ALLREDUCE(temp1, temp1_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
        norm = real(temp1_mpi)
        !print *, norm
        temp1 = sqrt(real(temp1_mpi))
        work_vec(:,1) = work_vec(:,1) / temp1

        curr = 1
        prev = 2

        ! begin iteration
        do i=1,maxn
            if (myid == master .and. mod(i,50)==0) then
                write(mystd,"(a24, i5)")  "Krylov iteration:  ", i
            endif
            neff = i
            ! matrix-vector product
            call MPI_BARRIER(MPI_COMM_WORLD, ierror)
            work_vec(:,prev) = -beta(i-1) * work_vec(:,prev)
            call pspmv_csr(MPI_COMM_WORLD, nblock, end_indx, needed, nloc, nloc, ham, work_vec(:,curr), work_vec(:,prev))
            call MPI_BARRIER(MPI_COMM_WORLD, ierror)
            ! compute alpha_i
            temp1 = czero
            temp1_mpi = czero
            temp1 = dot_product(work_vec(:,curr), work_vec(:,prev))
            call MPI_ALLREDUCE(temp1, temp1_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
            alpha(i) = real(temp1_mpi)

            work_vec(:,prev) = work_vec(:,prev) - alpha(i) * work_vec(:,curr)
            ! compute beta_{i+1}
            temp1 = czero
            temp1_mpi = czero
            temp1 = dot_product(work_vec(:,prev), work_vec(:,prev))
            call MPI_ALLREDUCE(temp1, temp1_mpi, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD, ierror)
            beta(i) = sqrt(real(temp1_mpi))
            ! beta is too small, exit
            if (abs(beta(i)) < 1E-10) then
                EXIT
            endif
            work_vec(:,prev) = work_vec(:,prev) / beta(i)
            temp_indx = curr
            curr = prev
            prev = temp_indx
        enddo

        if (allocated(work_vec)) deallocate(work_vec)

        return
    end subroutine build_krylov_mp

    ! given alpha, beta and normalization parameter to build the spectrum function
    subroutine build_spectrum(nkrylov, alpha, beta, norm, nw, om_mesh, e_gs, gamma_final, spec)
        use m_constants, only: dp, czero, pi

        implicit none

        ! external variables
        integer, intent(in) :: nkrylov
        real(dp), intent(in) :: alpha(nkrylov)
        real(dp), intent(in) :: beta(0:nkrylov)
        real(dp), intent(in) :: norm
        integer,  intent(in) :: nw
        real(dp), intent(in) :: om_mesh(nw)
        real(dp), intent(in) :: e_gs
        real(dp), intent(in) :: gamma_final(nw)
        real(dp), intent(out) :: spec(nw)

        ! local variables
        integer :: i
        complex(dp) :: tmp_vec(nw)
        ! loop over krylov space

        tmp_vec = czero
        do i=nkrylov, 2, -1
            tmp_vec = beta(i-1)**2 / (om_mesh + dcmplx(0.0, 1.0)*gamma_final + e_gs - alpha(i) - tmp_vec)
        enddo
        tmp_vec = 1.0/(om_mesh + dcmplx(0.0,1.0) * gamma_final + e_gs - alpha(1) - tmp_vec)

        spec = -1.0/pi * aimag(tmp_vec) * norm

        return
    end subroutine build_spectrum

end module m_lanczos


C***********************************************************************
C***********************************************************************
C
C   Version:        0.3
C   Last modified:  March 6, 1995
C   Authors:        Esmond G. Ng and Barry W. Peyton
C
C   Mathematical Sciences Section, Oak Ridge National Laboratory
C
C***********************************************************************
C***********************************************************************
C*********     BLKFC2 .....  BLOCK GENERAL SPARSE CHOLESKY     *********
C***********************************************************************
C***********************************************************************
C
C   PURPOSE:
C       THIS SUBROUTINE FACTORS A SPARSE POSITIVE DEFINITE MATRIX.
C       THE COMPUTATION IS ORGANIZED AROUND KERNELS THAT PERFORM
C       SUPERNODE-TO-SUPERNODE UPDATES, I.E., BLOCK-TO-BLOCK UPDATES.
C
C   INPUT PARAMETERS:
C       NSUPER          -   NUMBER OF SUPERNODES.
C       XSUPER          -   SUPERNODE PARTITION.
C       SNODE           -   MAPS EACH COLUMN TO THE SUPERNODE CONTAINING
C                           IT.
C       SPLIT           -   SPLITTING OF SUPERNODES SO THAT THEY FIT
C                           INTO CACHE.
C       (XLINDX,LINDX)  -   ROW INDICES FOR EACH SUPERNODE (INCLUDING
C                           THE DIAGONAL ELEMENTS).
C       (XLNZ,LNZ)      -   ON INPUT, CONTAINS MATRIX TO BE FACTORED.
C       TMPSIZ          -   SIZE OF TEMPORARY WORKING STORAGE.
C       MMPYN           -   EXTERNAL ROUTINE: MATRIX-MATRIX MULTIPLY.
C       SMXPY           -   EXTERNAL ROUTINE: MATRIX-VECTOR MULTIPLY.
C
C   OUTPUT PARAMETERS:
C       LNZ             -   ON OUTPUT, CONTAINS CHOLESKY FACTOR.
C       IFLAG           -   ERROR FLAG.
C                               0: SUCCESSFUL FACTORIZATION.
C                              -1: NONPOSITIVE DIAGONAL ENCOUNTERED,
C                                  MATRIX IS NOT POSITIVE DEFINITE.
C                              -2: INSUFFICIENT WORKING STORAGE
C                                  [TEMP(*)].
C
C   WORKING PARAMETERS:
C       LINK            -   LINKS TOGETHER THE SUPERNODES IN A SUPERNODE
C                           ROW.
C       LENGTH          -   LENGTH OF THE ACTIVE PORTION OF EACH
C                           SUPERNODE.
C       INDMAP          -   VECTOR OF SIZE NEQNS INTO WHICH THE GLOBAL
C                           INDICES ARE SCATTERED.
C       RELIND          -   MAPS LOCATIONS IN THE UPDATING COLUMNS TO
C                           THE CORRESPONDING LOCATIONS IN THE UPDATED
C                           COLUMNS.  (RELIND IS GATHERED FROM INDMAP).
C       TEMP            -   REAL VECTOR FOR ACCUMULATING UPDATES.  MUST
C                           ACCOMODATE ALL COLUMNS OF A SUPERNODE.
C
C***********************************************************************
C
      SUBROUTINE  BLKFC2 (  NSUPER, XSUPER, SNODE , SPLIT , XLINDX,
     &                      LINDX , XLNZ  , LNZ   , LINK  , LENGTH,
     &                      INDMAP, RELIND, TMPSIZ, TEMP  , IFLAG ,
     &                      MMPYN , SMXPY                           )
C
C*********************************************************************
C
C       -----------
C       PARAMETERS.
C       -----------
C
        EXTERNAL            MMPYN , SMXPY
        INTEGER             XLINDX(*)     , XLNZ(*)
        INTEGER             INDMAP(*)     , LENGTH(*)     ,
     &                      LINDX(*)      , LINK(*)       ,
     &                      RELIND(*)     , SNODE(*)      ,
     &                      SPLIT(*)      , XSUPER(*)
        INTEGER             IFLAG , NSUPER, TMPSIZ
        DOUBLE PRECISION    LNZ(*)        , TEMP(*)
C
C       ----------------
C       LOCAL VARIABLES.
C       ----------------
C
        INTEGER             FJCOL , FKCOL , I     , ILEN  , ILPNT ,
     &                      INDDIF, JLEN  , JLPNT , JSUP  , JXPNT ,
     &                      KFIRST, KLAST , KLEN  , KDPNT , KLPNT ,
     &                      KSUP  , KXPNT , LJCOL , NCOLUP, NJCOLS,
     &                      NKCOLS, NXKSUP, NXTCOL, NXTSUP, STORE
C
C*********************************************************************
C
        IFLAG = 0
C
C       -----------------------------------------------------------
C       INITIALIZE EMPTY ROW LISTS IN LINK(*) AND ZERO OUT TEMP(*).
C       -----------------------------------------------------------
        DO  100  JSUP = 1, NSUPER
            LINK(JSUP) = 0
  100   CONTINUE
        DO  200  I = 1, TMPSIZ
            TEMP(I) = 0.0D+00
  200   CONTINUE
C
C       ---------------------------
C       FOR EACH SUPERNODE JSUP ...
C       ---------------------------
        DO  600  JSUP = 1, NSUPER
C
C           ------------------------------------------------
C           FJCOL  ...  FIRST COLUMN OF SUPERNODE JSUP.
C           LJCOL  ...  LAST COLUMN OF SUPERNODE JSUP.
C           NJCOLS ...  NUMBER OF COLUMNS IN SUPERNODE JSUP.
C           JLEN   ...  LENGTH OF COLUMN FJCOL.
C           JXPNT  ...  POINTER TO INDEX OF FIRST
C                       NONZERO IN COLUMN FJCOL.
C           ------------------------------------------------
            FJCOL  = XSUPER(JSUP)
            NJCOLS = XSUPER(JSUP+1) - FJCOL
            LJCOL  = FJCOL + NJCOLS - 1
            JLEN   = XLNZ(FJCOL+1) - XLNZ(FJCOL)
            JXPNT  = XLINDX(JSUP)
C
C           -----------------------------------------------------
C           SET UP INDMAP(*) TO MAP THE ENTRIES IN UPDATE COLUMNS
C           TO THEIR CORRESPONDING POSITIONS IN UPDATED COLUMNS,
C           RELATIVE THE THE BOTTOM OF EACH UPDATED COLUMN.
C           -----------------------------------------------------
            CALL  LDINDX ( JLEN, LINDX(JXPNT), INDMAP )
C
C           -----------------------------------------
C           FOR EVERY SUPERNODE KSUP IN ROW(JSUP) ...
C           -----------------------------------------
            KSUP = LINK(JSUP)
  300       IF  ( KSUP .GT. 0 )  THEN
                NXKSUP = LINK(KSUP)
C
C               -------------------------------------------------------
C               GET INFO ABOUT THE CMOD(JSUP,KSUP) UPDATE.
C
C               FKCOL  ...  FIRST COLUMN OF SUPERNODE KSUP.
C               NKCOLS ...  NUMBER OF COLUMNS IN SUPERNODE KSUP.
C               KLEN   ...  LENGTH OF ACTIVE PORTION OF COLUMN FKCOL.
C               KXPNT  ...  POINTER TO INDEX OF FIRST NONZERO IN ACTIVE
C                           PORTION OF COLUMN FJCOL.
C               -------------------------------------------------------
                FKCOL = XSUPER(KSUP)
                NKCOLS = XSUPER(KSUP+1) - FKCOL
                KLEN = LENGTH(KSUP)
                KXPNT = XLINDX(KSUP+1) - KLEN
C
C               -------------------------------------------
C               PERFORM CMOD(JSUP,KSUP), WITH SPECIAL CASES
C               HANDLED DIFFERENTLY.
C               -------------------------------------------
C
                IF  ( KLEN .NE. JLEN )  THEN
C
C                   -------------------------------------------
C                   SPARSE CMOD(JSUP,KSUP).
C
C                   NCOLUP ... NUMBER OF COLUMNS TO BE UPDATED.
C                   -------------------------------------------
C
                    DO  400  I = 0, KLEN-1
                        NXTCOL = LINDX(KXPNT+I)
                        IF  ( NXTCOL .GT. LJCOL )  GO TO 500
  400               CONTINUE
                    I = KLEN
  500               CONTINUE
                    NCOLUP = I
C
                    IF  ( NKCOLS .EQ. 1 )  THEN
C
C                       ----------------------------------------------
C                       UPDATING TARGET SUPERNODE BY TRIVIAL
C                       SUPERNODE (WITH ONE COLUMN).
C
C                       KLPNT  ...  POINTER TO FIRST NONZERO IN ACTIVE
C                                   PORTION OF COLUMN FKCOL.
C                       KDPNT  ...  POINTER TO DIAGONAL ENTRY OF
C                                   COLUMN FKCOL.
C                       ----------------------------------------------
                        KLPNT = XLNZ(FKCOL+1) - KLEN
                        KDPNT = XLNZ(FKCOL)
                        CALL  MMPYI ( KLEN, NCOLUP, LINDX(KXPNT),
     &                                LNZ(KLPNT), LNZ(KDPNT), XLNZ,
     &                                LNZ, INDMAP )
C
                    ELSE
C
C                       --------------------------------------------
C                       KFIRST ...  FIRST INDEX OF ACTIVE PORTION OF
C                                   SUPERNODE KSUP (FIRST COLUMN TO
C                                   BE UPDATED).
C                       KLAST  ...  LAST INDEX OF ACTIVE PORTION OF
C                                   SUPERNODE KSUP.
C                       --------------------------------------------
C
                        KFIRST = LINDX(KXPNT)
                        KLAST  = LINDX(KXPNT+KLEN-1)
                        INDDIF = INDMAP(KFIRST) - INDMAP(KLAST)
C
                        IF  ( INDDIF .LT. KLEN )  THEN
C
C                           ---------------------------------------
C                           DENSE CMOD(JSUP,KSUP).
C
C                           ILPNT  ...  POINTER TO FIRST NONZERO IN
C                                       COLUMN KFIRST.
C                           ILEN   ...  LENGTH OF COLUMN KFIRST.
C                           ---------------------------------------
                            ILPNT = XLNZ(KFIRST)
                            ILEN = XLNZ(KFIRST+1) - ILPNT
                            CALL  MMPY ( KLEN, NKCOLS, NCOLUP,
     &                                   SPLIT(FKCOL), XLNZ(FKCOL),
     &                                   LNZ, LNZ(ILPNT), ILEN, MMPYN  )
C
                        ELSE
C
C                           -------------------------------
C                           GENERAL SPARSE CMOD(JSUP,KSUP).
C                           COMPUTE CMOD(JSUP,KSUP) UPDATE
C                           IN WORK STORAGE.
C                           -------------------------------
                            STORE = KLEN * NCOLUP - NCOLUP *
     &                              (NCOLUP-1) / 2
                            IF  ( STORE .GT. TMPSIZ )  THEN
                                IFLAG = -2
                                RETURN
                            ENDIF
                            CALL  MMPY ( KLEN, NKCOLS, NCOLUP,
     &                                   SPLIT(FKCOL), XLNZ(FKCOL),
     &                                   LNZ, TEMP, KLEN, MMPYN  )
C                           ----------------------------------------
C                           GATHER INDICES OF KSUP RELATIVE TO JSUP.
C                           ----------------------------------------
                            CALL  IGATHR ( KLEN, LINDX(KXPNT),
     &                                     INDMAP, RELIND )
C                           --------------------------------------
C                           INCORPORATE THE CMOD(JSUP,KSUP) BLOCK
C                           UPDATE INTO THE TO APPROPRIATE COLUMNS
C                           OF L.
C                           --------------------------------------
                            CALL  ASSMB ( KLEN, NCOLUP, TEMP, RELIND,
     &                                    XLNZ(FJCOL), LNZ, JLEN )
C
                        ENDIF
C
                    ENDIF
C
                ELSE
C
C                   ----------------------------------------------
C                   DENSE CMOD(JSUP,KSUP).
C                   JSUP AND KSUP HAVE IDENTICAL STRUCTURE.
C
C                   JLPNT  ...  POINTER TO FIRST NONZERO IN COLUMN
C                               FJCOL.
C                   ----------------------------------------------
                    JLPNT = XLNZ(FJCOL)
                    CALL  MMPY ( KLEN, NKCOLS, NJCOLS, SPLIT(FKCOL),
     &                           XLNZ(FKCOL), LNZ, LNZ(JLPNT), JLEN,
     &                           MMPYN )
                    NCOLUP = NJCOLS
                    IF  ( KLEN .GT. NJCOLS )  THEN
                        NXTCOL = LINDX(JXPNT+NJCOLS)
                    ENDIF
C
                ENDIF
C
C               ------------------------------------------------
C               LINK KSUP INTO LINKED LIST OF THE NEXT SUPERNODE
C               IT WILL UPDATE AND DECREMENT KSUP'S ACTIVE
C               LENGTH.
C               ------------------------------------------------
                IF  ( KLEN .GT. NCOLUP )  THEN
                    NXTSUP = SNODE(NXTCOL)
                    LINK(KSUP) = LINK(NXTSUP)
                    LINK(NXTSUP) = KSUP
                    LENGTH(KSUP) = KLEN - NCOLUP
                ELSE
                    LENGTH(KSUP) = 0
                ENDIF
C
C               -------------------------------
C               NEXT UPDATING SUPERNODE (KSUP).
C               -------------------------------
                KSUP = NXKSUP
                GO TO 300
C
            ENDIF
C
C           ----------------------------------------------
C           APPLY PARTIAL CHOLESKY TO THE COLUMNS OF JSUP.
C           ----------------------------------------------
            CALL CHLSUP ( JLEN, NJCOLS, SPLIT(FJCOL), XLNZ(FJCOL), LNZ,
     &                    IFLAG, MMPYN, SMXPY )
            IF  ( IFLAG .NE. 0 )  THEN
                IFLAG = -1
                RETURN
            ENDIF
C
C           -----------------------------------------------
C           INSERT JSUP INTO LINKED LIST OF FIRST SUPERNODE
C           IT WILL UPDATE.
C           -----------------------------------------------
            IF  ( JLEN .GT. NJCOLS )  THEN
                NXTCOL = LINDX(JXPNT+NJCOLS)
                NXTSUP = SNODE(NXTCOL)
                LINK(JSUP) = LINK(NXTSUP)
                LINK(NXTSUP) = JSUP
                LENGTH(JSUP) = JLEN - NJCOLS
            ELSE
                LENGTH(JSUP) = 0
            ENDIF
C
  600   CONTINUE
C
        RETURN
      END


program RPT_dolo
use RPT_mod
use PhreeqcRM
implicit none

! ==============================================================================
!                           SIMULATION PARAMETERS
! ==============================================================================
integer, parameter          :: nthreads = 0
    ! number of OpenMP threads for reaction module. <= 0 implies the number of
    ! threads equals the number of processors of the computer
double precision, parameter :: maxtime = 60d3 ! 1000 MIN
double precision, parameter :: lowx = 0.0d0, upx = 0.5d0, omega = upx - lowx
    ! domain length, lower, upper bounds
double precision, parameter :: dt = 1e0_dp ! time step
integer, parameter          :: nsteps = nint(maxtime/dt)! number of time steps
integer, parameter          :: nipart = 3000, ncellv = 3000
    ! number of immobile particles and velocity field cells
double precision, parameter :: dxv = omega/dble(ncellv), dx = omega/dble(nipart)
    ! dx for velocity grid, and for calculating boundary injection
integer, parameter          :: nptot = 6000
    ! number of mobile particles
double precision, parameter :: save_dt = dt * 1e2_dp
integer, parameter          :: save_steps = nint(maxtime/(save_dt)) + 1
    ! time step for saving concentrations for plotting and number of writes to be done

! ==============================================================================
!                           PHYSICAL PARAMETERS
! ==============================================================================
double precision, parameter :: darvel = 1.2e-5_dp ! Darcy flux [m/s]
double precision, parameter :: init_porosity = 0.5d0
double precision, parameter :: init_v = darvel/init_porosity
double precision, parameter :: alpha_l = 0.005d0 ! longitudinal dispersivity
double precision, parameter :: init_D = alpha_l * init_v
double precision            :: v(ncellv) = init_v, D(ncellv) = init_D, repvol
    ! vectors for velocity and diffusion coefficients

! ==============================================================================
!                               GENERAL VARIABLES
! ==============================================================================
type(mparticle)               :: mparts(nptot) ! mobile particles
type(iparticle)               :: iparts(nipart) ! immobile particles
integer                       :: indices(nptot) ! array for easy indexing
integer, allocatable          :: alive(:), nalive(:)
    ! arrays for indexing to alive particles
integer                       :: nactive, nexit
    ! number of active mobile particles and how many exited in time step
double precision              :: Pe_grid, CFL
double precision, allocatable :: Distmat(:, :)
    ! pairwise distance matrix for mass transfers

! ==============================================================================
!                          PHREEQCRM VARIABLES
! ==============================================================================
double precision                      :: init_calcite, na_inflow, mg_inflow,&
                                         ca_inflow, cl_inflow, co2_inflow
double precision, dimension(nipart)   :: den_0, prs_0, tmp_0, sat_0, por_0, vol_0
double precision                      :: cur_time
integer                               :: i, j, m, id, status, ngrd, nsolids
integer                               :: ncomp, nchem, so_col
integer                               :: ic1(nipart, 7)
integer                               :: mask(nipart)
double precision, allocatable         :: bc_conc(:, :), comp_conc(:, :),&
                                         sout(:, :), plot_concs(:, :), plot_times(:)
integer                               :: bc1(1) ! this is for one boundary condition

Pe_grid = (dx * init_v) / init_D
CFL = (init_v * dt) / dx

! print some summary info, to begin with
print *, '====================================================================='
print *, 'Pe_grid =', Pe_grid
print *, 'CFL = ', CFL
write (*, "(' 2 * CFL < Pe_grid < 2 / CFL = ', 3(es9.2, 1x))") 2 * CFL, Pe_grid, 2 / CFL
print *, 'kappa = ', kappa
print *, 'init_v = ', init_v
print *, 'init_D = ', init_D
print *, 'MT stability condition = ', (omega / dble(min(nipart, nptot)))**2 /&
                                        (4.0d0 * kappa * init_D * dt)
print *, 'repvol = ', (omega * 1e3_dp)/ dble(nipart)
print *, '====================================================================='

cur_time = 0.0d0
nsolids = 2 ! calcite and dolomite

! calculate representative volume for immobile particles (1e3 = L/m^3)
repvol = (omega * 1e3_dp)/ dble(nipart)

! make all initial particles active
mparts%active = .false.
nactive = nptot
mparts(1 : nptot)%active = .true.
indices = (/(i, i = 1, nptot)/) ! this is for easy array-indexing of mparts

! scatter the mobile particles randomly throughout domain
call init_random_seed()
call random_number(mparts(1 : nptot)%loc)
mparts(1 : nptot)%loc = (upx - lowx) * mparts(1 : nptot)%loc + lowx
! initialize all mobile particle's bin to -999 for error catching
mparts%bin = -999

! distribute immobile particles evenly
iparts%loc = (/(dble(i) * (omega / (dble(nipart) - 1.0d0)), i = 0, nipart - 1)/)
do i = 1, nipart
    iparts(i)%concs = 0.0d0
enddo

! initial concentration of calcite [mol]
init_calcite = 0.270865d0 ! = 270.865 mol/m^3

! inflow concentration of CO2
! this is just a big number so it is saturated
co2_inflow = 10.0d0 ! this is from Leal's input file

! inflow concentrations [mol/L]
na_inflow = 0.884882d0
mg_inflow = 0.0491601d0
ca_inflow = 0.00983202d0
cl_inflow = 1.00287d0

! write the PhreeqcRM input file
call phreeqc_input(init_calcite, na_inflow, mg_inflow, ca_inflow, cl_inflow,&
                   co2_inflow)

! ==============================================================================
!                   DEFINE PHYSICAL CONDITIONS (for PHREEQCRM)
! ==============================================================================
den_0 = 1.0d0 ! Density
prs_0 = 98.6923d0 ! Pressure 98.6923 atm = 100 bar
tmp_0 = 60.0d0 ! Temperature
sat_0 = 1.0d0 ! Saturation
por_0 = init_porosity ! Porosity
vol_0 = repvol

! print chemistry mask to print detailed output (headings) for only first element
mask = 0
mask(1) = 1

id = RM_Create(nipart, nthreads)
! local database location
status = RM_LoadDatabase(id, '/usr/local/share/doc/phreeqcrm/database/phreeqc.dat')
if (status < 0) then
    print *, 'Database Load Error'
    call exit(status)
endif

! initialize all the settings for the reaction module
status = RM_OpenFiles(id)
status = RM_SetRepresentativeVolume(id, vol_0)
status = RM_SetSaturation(id, sat_0)
status = RM_SetPorosity(id, por_0)
status = RM_SetTime(id, cur_time)
status = RM_SetTimeStep(id, dt)
status = RM_SetDensity(id, den_0)
status = RM_SetTemperature(id, tmp_0)
status = RM_SetPressure(id, prs_0)
status = RM_SetSelectedOutputOn(id, 1) ! turn on selected output to get dolomite/calcite values
status = RM_SetUnitsSolution(id, 2) ! 2 = mol/L
status = RM_SetUnitsPPassemblage(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsSSassemblage(id, 1) ! 1 = mol/L of representative volume
status = RM_SetPrintChemistryMask(id, mask)
status = RM_SetPrintChemistryOn(id, 0, 0, 0)
status = RM_SetScreenOn(id, 0) ! turn off useless messages about rebalancing
status = RM_SetComponentH2O(id, 1)
    ! 0 implies that H2O is not given as a separate component--just H and O
    ! 1 is default with H2O as separate component
status = RM_RunFile(id, 1, 1, 1, 'dolomite_chem.in')

! the following isn't strictly necessary if you already know what your problem
! looks like, but it's quick and only done once.

ncomp = RM_FindComponents(id)
! get number of grid cells in model (this can change, so it needs to be checked)
ngrd = RM_GetGridCellCount(id)
if (ngrd /= nipart) then
    print *, '****** Cell count differs from particle number ******'
    call exit(status)
endif

nchem = RM_GetChemistryCellCount(id)
if (nchem /= nipart) then
    print *, '****** Chem count differs from particle number ******'
    call exit(status)
endif

! ==============================================================================
!                       INITIAL/BOUNDARY CONDITIONS
! ==============================================================================
! ===  (1) SOLUTIONS, (2) EQUILIBRIUM_PHASES, (3) EXCHANGE,
! ===  (4) SURFACE, (5) GAS_PHASE, (6) SOLID_SOLUTIONS, and (7) KINETICS

ic1 = -1
ic1(:, 1) = 1
ic1(:, 2) = 1

allocate(bc_conc(1, ncomp))
    ! must be 2D array for module--requires singleton dimension in this case
bc1 = 0 ! corresponds to solution zero in input file

status = RM_InitialPhreeqc2Module(id, ic1)
! =======================================================================

! the following commented blocks will give you the names of the components and
! headings for selected output.
! They are left here purely for reference, and will not run unless you
! instantiate the corresponding variables.

! this makes a list of the names of components
! allocate(comp_list(ncomp))
! ! print *, 'ncomp = ', ncomp
! do i = 1, ncomp
!     status = RM_GetComponent(id, i, tempname)
!     allocate(character(len_trim(tempname)) :: comp_list(i)%comp)
!     comp_list(i)%comp = trim(tempname)
!     ! print *, comp_list(i)%comp
! enddo

status = RM_RunCells(id)

! so_col = RM_GetSelectedOutputcolumncount(id)
! so_row = RM_GetSelectedOutputrowcount(id)
! allocate(sout(so_row, so_col))
! status = RM_GetSelectedOutput(id, sout)

! this makes a list of the names of selected output elements
! allocate(head_list(so_col))
! do i = 1, so_col
!     status = RM_GetSelectedOutputheading(id, i, tempname)
!     allocate(character(len_trim(tempname)) :: head_list(i)%head)
!     head_list(i)%head = trim(tempname)
!     print *, head_list(i)%head
! enddo

! get ion concentrations from the reaction module
allocate(comp_conc(nipart, ncomp))
status = RM_GetConcentrations(id, comp_conc)

! transfer the concentration array to the immobile particles
call concs_to_iparts(comp_conc, iparts, nipart)

! get the boundary condition
status = RM_InitialPhreeqc2Concentrations(id, bc_conc, 1, bc1)

! this is the injection that corresponds to the FD simulation with the same discretization
bc_conc(1, :) = ((v(1) * dt)/dx) * bc_conc(1, :)

! add the boundary condition to the boundary immobile particle
iparts(1)%concs(:) = iparts(1)%concs(:) + bc_conc(1, :)

! ==============================================================================
!               SELECTED OUTPUT (based on the PHREEQC input file)
! ==============================================================================
! == (1) pH, (2) calcite, (3) change calcite, (4) dolomite, (5), change dolomite
! ==============================================================================

! ==============================================================================
!            PLOT_CONCS (the quantities of interest for the problem)
! ==============================================================================
! == (1) pH, (2) calcite, (3) dolomite
! ==============================================================================

! ==============================================================================
!        CONCS (what is being transported and given to the reaction module)
! ==============================================================================
! dimension of concs is ntrans (# chemistry cells + 1 for boundary) x ncomp

! For this specific problem:

! If (RM_SetComponentH2O(id, 0)):
! (1) H, (2) O, (3) charge, (4) C, (5) Ca, (6) Cl, (7) Mg, (8) Na, (9) Si

! If (RM_SetComponentH2O(id, 1)):
! (1) H2O, (2) H, (3) O, (4) charge, (5) C, (6) Ca, (7) Cl, (8) Mg, (9) Na, (10) Si
! ==============================================================================

so_col = RM_GetSelectedOutputcolumncount(id)
allocate(sout(nipart, so_col))
status = RM_GetSelectedOutput(id, sout)
allocate(plot_concs(nipart, 3), plot_times(save_steps))

! find out which bins the initial particles are in
allocate (alive(nactive))
alive = (/(i, i = 1, nactive)/)
mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1 ! bin based on velocity grid

do i = 1, nptot
    mparts(i)%concs = 0.0d0
enddo

! convert concentrations on immobile particles to masses
do i = 1, ncomp
    iparts(:)%concs(i) = iparts(:)%concs(i) * repvol
enddo

! get the pairwise distance matrix
allocate(Distmat(nipart, nactive))
call build_Distmat(iparts, mparts, nactive, alive, nipart, D, dt, Distmat)

! do the immobile to mobile transfer
call immobile2mobile(iparts, mparts, nactive, alive, nipart, D, dt, ncomp, Distmat)
deallocate(Distmat, alive)

plot_concs(: , 1) = sout(:, 1)
plot_concs(: , 2) = sout(:, 2) / repvol
plot_concs(: , 3) = sout(:, 4) / repvol
plot_times = (/((i - 1) * save_dt, i = 1, save_steps)/)

! this is the file that stores what comes from plot_concs
! the header gives the shape of the full array and the number of time steps
open (unit=12, file='time_concs.txt', action='write')
write (12, *) shape(plot_concs), save_steps
write (12, *) plot_concs
close (unit=12, status='keep')

! counter for plot_times
j = 2

! time stepping loop
do m = 1, nsteps
    print *, 'step = ', m, ' of ', nsteps

    ! get indices of alive particles
    nactive = count(mparts%active)
    allocate (alive(nactive))
    alive = pack(indices, mparts%active)
    mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1 ! bin based on velocity grid

    call advect(mparts, v, dt, alive)
    call diffuse(mparts, nactive, D, dt, alive)

    ! impose reflecting/absorbing boundary conditions
    call reflectlow(mparts, lowx, alive)
    call absorbhigh(mparts, upx, alive, nactive, nexit)

    ! determine what particles are alive after transport
    deallocate (alive)
    nactive = count(mparts%active)
    allocate (alive(nactive))
    alive = pack(indices, mparts%active)
    mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1

    ! convert masses on mobile particles to concentrations
    do i = 1, ncomp
        mparts(alive)%concs(i) = mparts(alive)%concs(i) / repvol
    enddo

    allocate(Distmat(nipart, nactive))
    call build_Distmat(iparts, mparts, nactive, alive, nipart, D, dt, Distmat)
    call mobile2immobile(iparts, mparts, nactive, alive, nipart, D, dt, ncomp, Distmat)
    deallocate(Distmat)

    ! transfer the concentrations in the particles array to the PHREEQCRM concs array
    call iparts_to_concs(comp_conc, iparts, nipart)

    cur_time = cur_time + dt
    status = RM_SetTime(id, cur_time)
    status = RM_SetConcentrations(id, comp_conc)
    status = RM_RunCells(id)
    status = RM_GetConcentrations(id, comp_conc)

    call concs_to_iparts(comp_conc, iparts, nipart)

    ! apply "wraparound" boundary condition
    ! move the particles that exited the upper boundary to the lower boundary
    ! and assign them zero mass
    if (m < nsteps) then
        if (nexit > 0) then
            if (nactive + nexit > nptot) then
                print *, '****ERROR: NOT ENOUGH PARTICLES ALLOCATED****'
                call exit(status)
            endif
            nactive = count(.not. mparts%active)
            allocate (nalive(nactive))
            nalive = pack(indices, .not. mparts%active)
            mparts(nalive)%active = .true.
            do i = 1, nactive
                ! this random perturbation keeps kD tree from getting
                    ! tripped up when many new injection particles have the same location
                mparts(nalive(i))%loc = 0.0d0 + rand() * 1.0d-7
                mparts(nalive(i))%concs = 0.0d0
            enddo
            deallocate (nalive)
        endif
    endif

    ! add boundary injection to first immobile particle
    iparts(1)%concs(:) = iparts(1)%concs(:) + bc_conc(1, :)

    deallocate (alive)
    nactive = count(mparts%active)
    allocate (alive(nactive)) ! maybe preallocate to avoid repeatedly doing this
    alive = pack(indices, mparts%active)
    mparts(alive)%bin = floor(mparts(alive)%loc/dxv) + 1

    ! convert concentrations on immobile particles to masses
    do i = 1, ncomp
        iparts(:)%concs(i) = iparts(:)%concs(i) * repvol
    enddo

    allocate(Distmat(nipart, nactive))
    call build_Distmat(iparts, mparts, nactive, alive, nipart, D, dt, Distmat)
    call immobile2mobile(iparts, mparts, nactive, alive, nipart, D, dt, ncomp, Distmat)
    deallocate(Distmat)

    if (cur_time >= plot_times(j)) then
        status = RM_GetSelectedOutput(id, sout)
        plot_concs(: , 1) = sout(:, 1)
        plot_concs(: , 2) = sout(:, 2) / repvol
        plot_concs(: , 3) = sout(:, 4) / repvol
        open (unit=12, file='time_concs.txt', action='write', status='old', access='append')
        write (12, *) plot_concs
        close (unit=12, status='keep')
        j = j + 1
    endif

    deallocate (alive)

enddo

status = RM_Destroy(id)
deallocate (bc_conc, comp_conc, sout, plot_concs, plot_times)

end program RPT_dolo


!-----------------------------------------------------------------------
!     Subroutine:    calc_metrics
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          12/15/2011
!     Description:   This subroutine calculates the metric elements from
!                    the values currently stored in the background
!                    and realspace grids.
!
!                    We define our fuctions to be of the form
!                    f(rho,theta,phi) = sum{n=-ntor,ntor} sum{m=0,mpol) fmn(s) * cos(m*theta+n*N*phi)
!                    So we must chain rule to u and v where
!                    u = theta/2*pi  and  v = phi / 2*pi*N
!                    Thus
!                    df/du = df/dtheta * dtheta/du
!                    df/dv = df/dphi   * dphi/dv
!-----------------------------------------------------------------------
      SUBROUTINE calc_metrics
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY : rprec
      USE pies_background
      USE pies_realspace
      USE pies_runtime
      USE pies_profile, ONLY : torflux_norm
!-----------------------------------------------------------------------
!     Local Variables
!          ier         Error flag
!          u           Poloidal dummy index
!          v           Toroidal dummy index
!          mn          Fourier dummy index
!          factor      ratio dphi/dv
!          fmn_temp    Dummy array to hold derivative coefficients (ex. rmnc*m)
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER :: ier, u, v, mn
      REAL(rprec) :: factor,pi2
      REAL(rprec), ALLOCATABLE :: fmn_temp(:,:)
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      pi2 = 8 * ATAN(1._rprec)
      ! Get Toroidal Flux
      CALL toroidal_flux
      ! Calculate deriviatives
      ALLOCATE(fmn_temp(1:mnmax,0:k),STAT=ier)
      IF (ier /= 0) CALL handle_err(ALLOC_ERR,'FMN_TEMP (calc_metrics)',ier)
      rs = 0; zs = 0; ru=0; zu=0; rv=0; zv=0;
      FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = -rmnc(mn,0:k)*xm(mn)
      CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,ru,1,1)
      FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = -rmnc(mn,0:k)*xn(mn)*nfp
      CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,rv,1,0)
      FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = zmns(mn,0:k)*xm(mn)
      CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zu,0,0)
      FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = zmns(mn,0:k)*xn(mn)*nfp
      CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zv,0,0)
      IF (lasym) THEN
         FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = rmns(mn,0:k)*xm(mn)
         CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,ru,0,0)
         FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = rmns(mn,0:k)*xn(mn)*nfp
         CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,rv,0,0)
         FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = -zmnc(mn,0:k)*xm(mn)
         CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zu,1,0)
         FORALL(mn = 1:mnmax) fmn_temp(mn,0:k) = -zmnc(mn,0:k)*xn(mn)*nfp
         CALL mntouv(0,k,mnmax,nu,nv,xu,xv,fmn_temp,xm,xn,zv,1,0)
      END IF
      DO u=1,nu
         DO v=1,nv
            rs(1:k-1,u,v) = (rreal(2:k,u,v)-rreal(0:k-2,u,v))/(rho(2:k)-rho(0:k-2))
            zs(1:k-1,u,v) = (zreal(2:k,u,v)-zreal(0:k-2,u,v))/(rho(2:k)-rho(0:k-2))
            rs(0,u,v)     = (rreal(1,u,v) - rreal(0,u,v))/(rho(1)-rho(0))
            zs(0,u,v)     = (zreal(1,u,v) - zreal(0,u,v))/(rho(1)-rho(0))
            rs(k,u,v)     = (rreal(k,u,v) - rreal(k-1,u,v))/(rho(k)-rho(k-1))
            zs(k,u,v)     = (zreal(k,u,v) - zreal(k-1,u,v))/(rho(k)-rho(k-1))
            !rs(1:k-1,u,v) = (rreal(2:k,u,v)-rreal(0:k-2,u,v))/(torflux_norm(2:k)-torflux_norm(0:k-2))
            !zs(1:k-1,u,v) = (zreal(2:k,u,v)-zreal(0:k-2,u,v))/(torflux_norm(2:k)-torflux_norm(0:k-2))
            !rs(0,u,v)     = (rreal(1,u,v) - rreal(0,u,v))/(torflux_norm(1)-torflux_norm(0))
            !zs(0,u,v)     = (zreal(1,u,v) - zreal(0,u,v))/(torflux_norm(1)-torflux_norm(0))
            !rs(k,u,v)     = (rreal(k,u,v) - rreal(k-1,u,v))/(torflux_norm(k)-torflux_norm(k-1))
            !zs(k,u,v)     = (zreal(k,u,v) - zreal(k-1,u,v))/(torflux_norm(k)-torflux_norm(k-1))
         END DO
      END DO
      ! Calculate metric elements
      g11 = rs*rs+zs*zs
      g12 = rs*ru+zs*zu
      g13 = rs*rv+zs*zv
      g22 = ru*ru+zu*zu
      g23 = ru*rv+zu*zv
      g33 = rv*rv+zv*zv + rreal*rreal
      detg= g11*(g22*g33-g23*g23) + g12*(g23*g13-g12*g33) + g13*(g12*g23-g22*g13)
      DEALLOCATE(fmn_temp)
!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE calc_metrics