PROGRAM LA_SPBSVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_PBSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: EQU
   INTEGER :: I, J, K, INFO, N, NRHS, KD
   REAL(WP) :: RCOND
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), X(:,:), AF(:,:)
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), S(:), FERR(:), BERR(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'SPBSVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, KD, NRHS
   PRINT *, 'N = ', N, ' NRHS = ', NRHS
   ALLOCATE ( A(KD+1,N), AA(KD+1,N), B(N,NRHS), BB(N,NRHS), X(N,NRHS), AF(KD+1,N), &
              S(N), FERR(NRHS), BERR(NRHS) )
!
      AA = HUGE(1.0_WP)
      DO I = 1, KD+1
        READ (NIN, *) (AA(I, J), J = KD-I+2, N)
      ENDDO
!     DO J = 1, NRHS
!        BB(:,J) = SUM( AA, DIM=2)*J
!     ENDDO
      B = 0.0_WP
      DO K = 1, NRHS
         DO I = 1, N
            DO J = MAX(1,-N+I+KD+1), KD
!              PRINT *, K, I, J, I-J+KD+1, AA(J,I-J+KD+1)
               BB(I,K) = AA(J,I-J+KD+1) + BB(I,K)
            ENDDO
            DO J = MAX(1,KD+2-I), KD+1
               BB(I,K) = AA(J,I) + BB(I,K)
!              PRINT *, K, I, J, AA(J,I)
            ENDDO
         ENDDO
         BB(:,K) = BB(:,K)*K
      ENDDO
   A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, KD+1
        WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) AA(I,1:N)
      ENDDO
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) BB(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_SPBSVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX( A, B, X, INFO=INFO )'
   A=AA; B=BB
   CALL LA_PBSVX( A, B, X, INFO=INFO )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PBSVX, INFO = ', INFO
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX( A, B(1:N,1), X(1:N,1), RCOND=RCOND, INFO=INFO )'
   A=AA; B=BB
   CALL LA_PBSVX( A, B(1:N,1), X(1:N,1), RCOND=RCOND, INFO=INFO )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PBSVX, INFO = ', INFO
   WRITE (NOUT,FMT) X(:,1)
   WRITE(NOUT,*) 'RCOND = ', RCOND
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX( A, B, X )'
   A=AA; B=BB
   CALL LA_PBSVX( A, B, X )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PBSVX:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX(A, B(1:N,1), X(1:N,1) )'
   A=AA; B=BB
   CALL LA_PBSVX(A, B(1:N,1), X(1:N,1) )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PBSVX:'
   WRITE (NOUT,FMT) X(:,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX(A, B, X, ''L'', RCOND=RCOND)'
   B=BB; A = HUGE(1.0_WP)
   DO I = 1, KD+1
      A(I,1:N-I+1) = AA(KD+2-I,I:N)
      WRITE (NOUT,*) 'I = ', I; WRITE (NOUT,FMT) A(I,1:N)
   ENDDO
   CALL LA_PBSVX( A, B, X, 'L', RCOND=RCOND)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PBSVX:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*) 'RCOND = ', RCOND
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX( A, B(1:N,1), X(1:N,1), ''L'', RCOND=RCOND )'
   B=BB; A = HUGE(1.0_WP)
   DO I = 1, KD+1; A(I,1:N-I+1) = AA(KD+2-I,I:N); ENDDO
   CALL LA_PBSVX( A, B(1:N,1), X(1:N,1), 'L', RCOND=RCOND )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PBSVX:'
   WRITE (NOUT,FMT) X(1:N,1)
   WRITE(NOUT,*) 'RCOND = ', RCOND
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX(A(:,:), B(1:N-1,:), X, INFO =INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PBSVX( A(:,:), B(1:N-1,:), X, INFO=INFO)
   WRITE(NOUT,*)' INFO = ', INFO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX( A(4:4), B(1:N,1), X(1:N,1), INFO=INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PBSVX( A(4:4,:), B(1:N,1), X(1:N,1), INFO=INFO )
   WRITE(NOUT,*)'   B - the RHS vector.'
   WRITE (NOUT,FMT) B(1:N,1)
   WRITE(NOUT,*)' INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX(A, B, X, FACT=''F'', INFO =INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PBSVX( A, B, X, FACT='F', INFO=INFO)
   WRITE(NOUT,*)'   INFO = ', INFO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PBSVX( A, B(1:N,1), X(1:N,1), FACT=''4'', INFO=INFO )'
   A=AA; B=BB; X=HUGE(1.0_WP)
   CALL LA_PBSVX( A, B(1:N,1), X(1:N,1), FACT='4', INFO=INFO )
   WRITE(NOUT,*)'   INFO = ', INFO
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A, B, X, ''U'', AF, ''N'', EQU, S, FERR, BERR, RCOND, INFO)'
   A=AA; B=BB; X=HUGE(1.0_WP); EQU = 'N'
   CALL LA_PBSVX(A, B, X, 'U', AF, 'N', EQU, S, FERR, BERR, RCOND, INFO)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX, INFO = ', INFO
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_PPSVX(A, B(1:N,1), X(1:N,1), ''U'', AF, ''N'', EQU, S, ', &
                 'FERR, BERR, RCOND, INFO) '
   A=AA; B=BB; X=HUGE(1.0_WP); EQU = 'N'
   CALL LA_PBSVX(A, B(1:N,1), X(1:N,1), 'U', AF, 'N', EQU, S, FERR(1), BERR(1), RCOND, INFO)
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_PPSVX, INFO = ', INFO
   WRITE (NOUT,FMT) X(1:N,1)
!
END PROGRAM LA_SPBSVX_ET_EXAMPLE


! test_tl_ad.f90
!
!> Tests for the Tangent Linear (TL) and Adjoint (AD) model versions
!> of MAOOAM.
!
!> @copyright
!> 2016 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!

PROGRAM test_tl_ad
  USE params, only:ndim,dt,t_trans
  USE aotensor_def, only: init_aotensor
  USE integrator, only: init_integrator,step
  USE tl_ad_tensor, only: init_tltensor, init_adtensor
  USE tl_ad_integrator, only: init_tl_ad_integrator,tl_step,ad_step
  IMPLICIT NONE

  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: y0_IC,y0,y0prime,dy0,dy0_bis
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: y1,y1prime
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: dy,dy_bis
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: dy1,dy1_tl,dy1_bis_tl,dy1_ad,dy1_bis_ad
  REAL(KIND=8) :: t=0.D0
  REAL(KIND=8) :: norm1,norm2,gasdev
  INTEGER :: i,idum1,n

  ! Compute the tensors

  CALL init_aotensor
  CALL init_tltensor
  CALL init_adtensor

  CALL init_integrator  ! Initialize the model integrator
  CALL init_tl_ad_integrator  ! Initialize the TL & AD integrator

  ALLOCATE(y0_IC(0:ndim),dy(0:ndim),y0(0:ndim),y0prime(0:ndim)&
       &,y1(0:ndim))!, STAT=AllocStat)
  ALLOCATE(y1prime(0:ndim),dy0(0:ndim),dy0_bis(0:ndim))!, STAT&
       ! &=AllocStat)
  ALLOCATE(dy1(0:ndim),dy1_tl(0:ndim),dy_bis(0:ndim)&
       &,dy1_bis_tl(0:ndim),dy1_ad(0:ndim),dy1_bis_ad(0:ndim))!, STAT&
       ! &=AllocStat)

  ! Test Taylor property for the Tangent Linear.
  ! lim(\lambda->0) M(x+\lambda dx) - M(x) / M'(\lambda dx) = 1

  idum1=-1254

  y0_IC(0)=1.D0

  ! Set all values to random.

  DO i=1,ndim
     y0_IC(i)=0.01*gasdev(idum1)
  ENDDO

  ! Evolve during transient period

  ! PRINT*, 'Random values:',y0_IC(0:ndim)
  DO WHILE (t<t_trans)
     CALL step(y0_IC,t,dt,y0)
     y0_IC=y0
  END DO
  PRINT*, 'Initial values:',y0_IC(0:ndim)

  ! Test 1: Taylor test
  ! Integrate the original model by one step, integrate with perturbed
  ! IC, and test if the difference approximates the TL

  DO n=0,6
     ! Small perturbation.
     dy=2.D0**(-n)/sqrt(real(ndim))
     dy(0)=0.D0
     PRINT*, "Perturbation size:",dot_product(dy,dy)

     y0 = y0_IC*1
     y0prime = y0 + dy
     CALL step(y0,t,dt,y1)
     CALL step(y0prime,t,dt,y1prime)

     dy1 = y1prime - y1

     dy0 = dy*1
     CALL tl_step(dy0,y0_IC,t,dt,dy1_tl)

     ! Don't forget to set 0'th component to 0...
     dy1(0)=0.D0
     dy1_tl(0)=0.D0

     PRINT*, "Resulting difference in trajectory: (epsilon ~ 2^-",n,")"
     PRINT*, "diff:    ",dot_product(dy1,dy1)
     PRINT*, "tl:      ",dot_product(dy1_tl,dy1_tl)
     PRINT*, "ratio:   ",dot_product(dy1,dy1)/dot_product(dy1_tl,dy1_tl)
  END DO

  ! Test 2: Adjoint Identity: <M(TL).x,y> = <x,M(AD).y>

  DO i=1,100
     ! Any perturbation.
     DO n=1,ndim
        dy(n)=gasdev(idum1)
     END DO
     dy(0)=0.D0

     DO n=1,ndim
        dy_bis(n)=gasdev(idum1)
     END DO
     dy_bis(0)=0.D0

     ! Calculate M(TL).x in dy1_tl
     dy0 = dy*1
     CALL tl_step(dy0,y0_IC,t,dt,dy1_tl)

     ! Calculate M(AD).x in dy1_ad
     CALL ad_step(dy0,y0_IC,t,dt,dy1_ad)

     ! Calculate M(TL).y in dy1_bis_tl
     CALL tl_step(dy0_bis,y0_IC,t,dt,dy1_bis_tl)

     ! Calculate M(AD).y in dy1_bis_ad
     CALL ad_step(dy0_bis,y0_IC,t,dt,dy1_bis_ad)

     ! Calculate norm <M(TL).x,y>
     norm1 = dot_product(dy1_tl,dy0_bis)
     ! Calculate norm <x,M(AD).y>
     norm2 = dot_product(dy0,dy1_bis_ad)

     PRINT*, "<M(TL).x,y> = ", norm1
     PRINT*, "<x,M(AD).y> = ", norm2
     PRINT*, "Ratio       = ", norm1/norm2

     ! Calculate norm <M(TL).y,x>
     norm1 = dot_product(dy1_bis_tl,dy0)
     ! Calculate norm <y,M(AD).x>
     norm2 = dot_product(dy0_bis,dy1_ad)

     PRINT*, "<M(TL).y,x> = ", norm1
     PRINT*, "<y,M(AD).x> = ", norm2
     PRINT*, "Ratio       = ", norm1/norm2
  END DO

END PROGRAM test_tl_ad

FUNCTION gasdev(idum)
  INTEGER :: idum
  REAL(KIND=8) ::  gasdev,ran2
  !    USES ran2
  INTEGER :: iset
  REAL(KIND=8) :: fac,gset,rsq,v1,v2
  SAVE iset,gset
  DATA iset/0/
  if (idum.lt.0) iset=0
  if (iset.eq.0) then
1    v1=2.D0*ran2(idum)-1.
     v2=2.D0*ran2(idum)-1.
     rsq=v1**2+v2**2
     if (rsq.ge.1.D0.or.rsq.eq.0.D0) goto 1
     fac=sqrt(-2.*log(rsq)/rsq)
     gset=v1*fac
     gasdev=v2*fac
     iset=1
  else
     gasdev=gset
     iset=0
  endif
  return
END FUNCTION gasdev

FUNCTION ran2(idum)
  INTEGER :: idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV
  REAL(KIND=8) :: ran2,AM,EPS,RNMX
  PARAMETER (IM1=2147483563,IM2=2147483399,AM=1.D0/IM1,IMM1=IM1-1&
       &,IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2&
       &=3791,NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2D-7,RNMX=1.D0-EPS)
  INTEGER :: idum2,j,k,iv(NTAB),iy
  SAVE iv,iy,idum2
  DATA idum2/123456789/, iv/NTAB*0/, iy/0/
  if (idum.le.0) then
     idum=max(-idum,1)
     idum2=idum
     do j=NTAB+8,1,-1
        k=idum/IQ1
        idum=IA1*(idum-k*IQ1)-k*IR1
        if (idum.lt.0) idum=idum+IM1
        if (j.le.NTAB) iv(j)=idum
     enddo
     iy=iv(1)
  endif
  k=idum/IQ1
  idum=IA1*(idum-k*IQ1)-k*IR1
  if (idum.lt.0) idum=idum+IM1
  k=idum2/IQ2
  idum2=IA2*(idum2-k*IQ2)-k*IR2
  if (idum2.lt.0) idum2=idum2+IM2
  j=1+iy/NDIV
  iy=iv(j)-idum2
  iv(j)=idum
  if (iy.lt.1) iy=iy+IMM1
  ran2=min(AM*iy,RNMX)
  return
END FUNCTION ran2


      SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To apply a special similarity transformation to a system given as
C     a triple (A,B,C),
C
C        A <-- P * A * P,  B <-- P * B,  C <-- C * P,
C
C     where P is a matrix with 1 on the secondary diagonal, and with 0
C     in the other entries.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A, the number of rows of matrix B
C             and the number of columns of matrix C.
C             N represents the dimension of the state vector.  N >= 0.
C
C     M       (input) INTEGER.
C             The number of columns of matrix B.
C             M represents the dimension of input vector.  M >= 0.
C
C     P       (input) INTEGER.
C             The number of rows of matrix C.
C             P represents the dimension of output vector.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the system state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the transformed matrix P*A*P.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the system input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed matrix P*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,N) if M > 0.
C             LDB >= 1        if M = 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the system output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*P.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The rows and/or columns of the matrices of the triplet (A,B,C)
C     are swapped in a special way.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998.
C
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004.
C
C     KEYWORDS
C
C     Matrix algebra, matrix operations, similarity transformation.
C
C  *********************************************************************
C
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, M, N, P
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
C     ..
C     .. Local Scalars ..
      INTEGER            J, NBY2
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSWAP, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MOD
C     ..
C     .. Executable Statements ..
C
C     Test the scalar input arguments.
C
      INFO  = 0
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -9
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01YD', -INFO )
         RETURN
      END IF
C
      IF( N.LE.1 )
     $   RETURN
C
C     Transform the matrix A.
C
      NBY2 = N/2
C
      DO 10 J = 1, NBY2
         CALL DSWAP( N, A( 1, J ), -1, A( 1, N-J+1 ), 1 )
   10 CONTINUE
C
      IF( MOD( N, 2 ).NE.0 .AND. N.GT.2 )
     $   CALL DSWAP( NBY2, A( NBY2+2, NBY2+1 ), -1, A( 1, NBY2+1 ), 1 )
C
      IF( M.GT.0 ) THEN
C
C        Transform the matrix B.
C
         DO 20 J = 1, NBY2
            CALL DSWAP( M, B( J, 1 ), LDB, B( N-J+1, 1 ), LDB )
   20    CONTINUE
C
      END IF
C
      IF( P.GT.0 ) THEN
C
C        Transform the matrix C.
C
         DO 30 J = 1, NBY2
            CALL DSWAP( P, C( 1, J ), 1, C( 1, N-J+1 ), 1 )
   30    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of TB01YD ***
      END


      subroutine  vanca_full
     *    (u1,u2,p,f1,f2,fp,
     *    a,kcola,klda,b1,b2,kcolb,kldb,nu,np,
     *    kmbd,kvert,kmid,knpr,nmbd)
************************************************************************
c
c one iteration of vanka smother (block gauss-seidel) on the system
c
c    A  0  B1 | U1    F1
c    0  A  B2 | U2  = F2
c    D1 D2 0  | PR    FP
c
c Steps:
c loop over all elements
c   compute local residuum ff
c   extract local matrix aa
c   solve for xx= aa^(-1) ff
c   update global solution vector (u1,u2,p)=(u1,u2,p)+ rlxsm*xx
c end loop
c
c This version will be able to solve the real full system of the form
c
c    A1 A2 B1 | U1    F1
c    A3 A4 B2 | U2  = F2
c    D1 D2 0  | PR    FP
c
c once we have full coupling and even if coupled with additional
c equations as
c
      implicit none

c common blocks

      include 'cout.inc'

      include 'cbasictria.inc'
      include 'ctria.inc'

      include 'cinidat.inc'

c parameters

      double precision u1(*),u2(*),p(*)
      double precision f1(*),f2(*),fp(*)
      real a(*),b1(*),b2(*)
      integer kcola(*),klda(*),kcolb(*),kldb(*)
      integer kmbd(*),kvert(nnve,*),kmid(nnve,*),knpr(*)
      integer nu,np,nmbd

c *** local arrays for informations about one element

      integer nnld
      parameter(nnld=2*4+1)
      double precision aa(nnld,nnld),ff(nnld)
      integer ipiv(nnld)
      integer iu(4)
      logical bdbc(4),bnbc(4)

c local variables

      integer iel,imid,ia1,ia2,ia,ib,ib1,ib2,info
      integer ii,jj,i,j,k,jp,jp1,jp2,iu1,iu2,ipr,nn
      double precision ffp,pjp,aoff,a1,a2,aux1,aux2,aux

c-----------------------------------------------------------------------
c pointers to the solution components in the local vector
      iu1=0
      iu2=iu1+4
      ipr=iu2+4
c total number of unknowns on each element
      nn=nnld

c=======================================================================
c     block gauss-seidel on schur complement
c=======================================================================
c *** loop over all elements
c
      do iel=1,nel

c get the local numbering and the BC info for dirichlet nodes
        do ii=1,4
          imid=kmid(ii,iel)
          i=imid-nvt
          iu(ii)=i
          if (knpr(imid).eq.0)  then
            bdbc(ii)=.false.
          else
            bdbc(ii)=.true.
          endif
        enddo

c compute the local residuum ff=f-Ax
c * get the local rhs
        ff(ipr+1)=fp(iel)
        do ii=1,4
          i=iu(ii)
          ff(iu1+ii)=f1(i)
          ff(iu2+ii)=f2(i)
        enddo

C * compute ff=ff - A x for the local unknowns
        do ii=1,4
          i=iu(ii)
          ia1=klda(i)
          ia2=klda(i+1)-1
          do ia=ia1,ia2
            j=kcola(ia)
            aux=dble(a(ia))
            ff(1,iu1+ii)=ff(1,iu1+ii)-aux*u1(j)
            ff(1,iu2+ii)=ff(1,iu2+ii)-aux*u2(j)
          enddo
          ib1=kldb(i)
          ib2=kldb(i+1)-1
          do ib=ib1,ib2
            k=kcolb(ib)
            aux1=dble(b1(ib))
            aux2=dble(b2(ib))
            if(iel.eq.k) ff(1,ipr+1)=ff(1,ipr+1)-aux1*u1(i)-aux2*u2(i)
            if(bdbc(ii)) aux1=0d0
            if(bdbc(ii)) aux2=0d0
            ff(1,iu1+ii)=ff(1,iu1+ii)-aux1*p(k)
            ff(1,iu2+ii)=ff(1,iu2+ii)-aux2*p(k)
          enddo
        enddo

c extract the local matrix into one array aa(nn,nn)
        aa(ipr+1,ipr+1)=0d0
        do ii=1,4
          i=iu(ii)
          do jj=1,4
            j=iu(jj)
            aa(iu1+ii,iu1+jj)=0d0
            aa(iu2+ii,iu2+jj)=0d0
            aa(iu1+ii,iu2+jj)=0d0
            aa(iu2+ii,iu1+jj)=0d0
            ia1=klda(i)
            ia2=klda(i+1)-1
            do ia=ia1,ia2
              if(j.eq.kcola(ia)) then
                aux=dble(a(ia))
                aa(iu1+ii,iu1+jj)=aux
                aa(iu2+ii,iu2+jj)=aux
              endif
            enddo
          enddo
          ib1=kldb(i)
          ib2=kldb(i+1)-1
          do ib=ib1,ib2
            k=kcolb(ib)
            aux1=dble(b1(ib))
            aux2=dble(b2(ib))
            if(iel.eq.k) then
              aa(ipr+1,iu1+ii)=aux1
              aa(ipr+1,iu2+ii)=aux2
              if(bdbc(ii)) aux1=0d0
              if(bdbc(ii)) aux2=0d0
              aa(iu1+ii,ipr+1)=aux1
              aa(iu2+ii,ipr+1)=aux2
            endif
          enddo
        enddo

c solve the local system aa xx = ff using lapack
        call DGETRF( nn, nn, aa, nn, ipiv, info )
        if(info.ne.0) print *,'ERROR: LAPACK(DGETRF) LU decomposition'
        call DGETRS('N', nn, 1, aa, nn, ipiv, ff, nn, info )
        if(info.ne.0) print *,'ERROR: LAPACK(DGETRS) back substitution'

c global update/correction (u1,u2,p)=(u1,u2,p) + rlxsm*xx
        do ii=1,4
          i=iu(ii)
          u1(i)=u1(i)+rlxsm*ff(1,iu1+ii)
          u2(i)=u2(i)+rlxsm*ff(1,iu2+ii)
        enddo
        p(iel)=p(iel)+rlxsm*ff(1,ipr+1)

      enddo ! over all elements

      end

*=======================================================================
*=======================================================================

      subroutine  vanca_diag
     *    (u1,u2,p,f1,f2,fp,
     *    a,kcola,klda,b1,b2,kcolb,kldb,nu,np,
     *    kmbd,kvert,kmid,knpr,nmbd)
************************************************************************
c
c one iteration of vanka smother (block gauss-seidel) on the system
c
c    A  0  B1 | U1    F1
c    0  A  B2 | U2  = F2
c    D1 D2 0  | PR    FP
c
c Steps:
c loop over all elements
c   compute local residuum ff
c   extract local matrix aa with only the diagonal part of the block A
c   solve for xx= aa^(-1) ff
c   update global solution vector (u1,u2,p)=(u1,u2,p)+ rlxsm*xx
c end loop
c
c
c
      implicit none

c common blocks

      include 'cout.inc'

      include 'cbasictria.inc'
      include 'ctria.inc'

      include 'cinidat.inc'

c parameters

      double precision u1(*),u2(*),p(*)
      double precision f1(*),f2(*),fp(*)
      real a(*),b1(*),b2(*)
      integer kcola(*),klda(*),kcolb(*),kldb(*)
      integer kmbd(*),kvert(nnve,*),kmid(nnve,*),knpr(*)
      integer nu,np,nmbd

c *** local arrays for informations about one element

      integer nnld
      parameter(nnld=2*4)
      double precision aa(nnld),bb(nnld),dd(nnld)
      double precision xx(nnld+1), ff(nnld+1)
      integer ipiv(nnld)
      integer iu(4)
      logical bdbc(4),bnbc(4)

c local variables

      integer iel,imid,ia1,ia2,ia,ib,ib1,ib2,info
      integer ii,jj,i,j,k,jp,jp1,jp2,iu1,iu2,ipr,nn
      double precision ffp,pjp,aoff,a1,a2,aux1,aux2,aux

c-----------------------------------------------------------------------
      iu1=0
      iu2=iu1+4
      ipr=iu2+4
      nn=nnld
c=======================================================================
c     block gauss-seidel on schur complement
c=======================================================================
c *** loop over all elements
c
      do iel=1,nel

c get the local numbering and the BC info for dirichlet nodes
        do ii=1,4
          imid=kmid(ii,iel)
          i=imid-nvt
          iu(ii)=i
          if (knpr(imid).eq.0)  then
            bdbc(ii)=.false.
          else
            bdbc(ii)=.true.
          endif
        enddo

c compute the local residuum
        ff(ipr+1)=fp(iel)
        do ii=1,4
          i=iu(ii)
          ff(iu1+ii)=f1(i)
          ff(iu2+ii)=f2(i)

          ia=klda(i)
          aux=1d0/dble(a(ia))
          aa(iu1+ii)=aux
          aa(iu2+ii)=aux

          ia1=klda(i)
          ia2=klda(i+1)-1
          do ia=ia1,ia2
            j=kcola(ia)
            aux=dble(a(ia))
            ff(iu1+ii)=ff(iu1+ii)-aux*u1(j)
            ff(iu2+ii)=ff(iu2+ii)-aux*u2(j)
          enddo

          ib1=kldb(i)
          ib2=kldb(i+1)-1
          do ib=ib1,ib2
            k=kcolb(ib)
            aux1=dble(b1(ib))
            aux2=dble(b2(ib))
            if(iel.eq.k) then
              ff(ipr+1)=ff(ipr+1)-aux1*u1(i)-aux2*u2(i)
              dd(iu1+ii)=aux1
              dd(iu2+ii)=aux2
              if(.not.bdbc(ii)) then
                bb(iu1+ii)=aux1
                bb(iu2+ii)=aux2
                else
                bb(iu1+ii)=0d0
                bb(iu2+ii)=0d0
              endif
            endif
            if(.not.bdbc(ii)) then
              ff(iu1+ii)=ff(iu1+ii)-aux1*p(k)
              ff(iu2+ii)=ff(iu2+ii)-aux2*p(k)
            endif
          enddo
        enddo

c solve the local system aa(nn,nn) xx = ff of the form
c
c     |aa 0  bb|
c     |0  aa bb| xx = ff
c     |dd dd 0 |
c
c by schur complement method
c
        aux1=0d0
        aux2=0d0
        do ii=1,8
          aux1=aux1+dd(ii)*ff(ii)*aa(ii)
          aux2=aux2+dd(ii)*bb(ii)*aa(ii)
        enddo
        xx(ipr+1)=(aux1-ff(ipr+1))/aux2
        do ii=1,8
          xx(ii)=(ff(ii)-bb(ii)*xx(ipr+1))*aa(ii)
        enddo

c global update (u1,u2,p)=(u1,u2,p) + rlxsm*xx
        do ii=1,4
          i=iu(ii)
          u1(i)=u1(i)+rlxsm*xx(iu1+ii)
          u2(i)=u2(i)+rlxsm*xx(iu2+ii)
        enddo
        p(iel)=p(iel)+rlxsm*xx(ipr+1)

      enddo ! over all elements

      end

C


      SUBROUTINE T2DINT(BUFIN,NSAMPS,ST,SIT,BUFOUT,MSAMPS,SD,SID,SCRBUF,
     *  vtp, nvtp )
!     T2DINT CONVERTS A TIME TRACE (BUFIN) INTO A DEPTH TRACE (BUFOUT) USING
!  INTERVAL VELOCITIES.  The output trace is uniformly sampled by sid.
!
!  ARGUMENTS:
!   BUFIN  - THE ARRAY OF TIME DOMAIN DATA TO BE TRANSFORMED.
!   NSAMPS - THE INTEGER NUMBER OF SAMPLES IN ARRAY BUFIN.  THE LENGTH OF THE
!            THE INPUT DATA.
!   ST     - THE START TIME OF BUFIN.  THE TIME IN SECONDS ASSOCIATED WITH THE
!            FIRST INPUT SAMPLE, BUFIN(1).
!   SIT    - SAMPLE INTERVAL IN TIME.  THE TIME UNITS, IN SECONDS, BETWEEN
!            SUCCESSIVE SAMPLES IN BUFIN.
!   BUFOUT - AN ARRAY TO RECEIVED THE TRANSFORMED TRACE.  THE DEPTH DOMAIN TRACE
!            THE OUTPUT ARRAY.  MUST BE DIFFERENT FROM BUFIN.
!   MSAMPS - THE NUMBER OF OUTPUT SAMPLES.  T2D WILL ONLY STORE MSAMPS SAMPLES
!            IN THE OUTPUT ARRAY.
!   SD     - START DEPTH.  THE DEPTH OF THE FIRST OUTPUT SAMPLE (BUFOUT(1)).
!   SID    - SAMPLE INTERVAL IN THE DEPTH DOMAIN.  THE  DISTANCE BETWEEN
!            SUCCESSIVE OUTPUT SAMPLES.
!   SCRBUF - A SCRATCH ARRAY OF LENGTH NSAMPS.
!   vtp    - The array of interval velocity-time pairs to use in conversion.
!            The first interval contains all times up to the first vtp time.
!   nvtp   - The number of words in the vtp array.
!
!   (C) ???????
!      PAUL HENKART, October 1990
!
      DIMENSION BUFIN(1),BUFOUT(1),SCRBUF(1),vtp(1)
!
!    METHOD:
!    1)  CALCULATE A DEPTH FOR EVERY TIME SAMPLE.
!    2)  Work through the output depths one-by-one and look for the
!        first input depth greater or equal to it.
!
!****
!****  fill scrbuf with the depth of every output sample
!****
      j = 1
      DO 100 I = 1, NSAMPS
         T = ST+SIT*FLOAT(I-1)
   10    IF( t .LE. vtp(j+1) ) THEN
             IF( j .EQ. 1 ) THEN
                 scrbuf(i) = vtp(1) * t
                 depth = scrbuf(i)
                 time = t
             ELSE
                 scrbuf(i) = depth + (t - time) * vtp(j)
             ENDIF
         ELSE
             depth = scrbuf(i-1)
             time = st + sit * FLOAT(i-2)
             j = j + 2
             GOTO 10
         ENDIF
!          print *,' i=',i,' depth=',scrbuf(i),' j=',j,' vtp=',vtp(j),
!     *       ' time=',time,' t=',t
  100 CONTINUE
!
!    FIND THE CLOSEST DEPTH IN THE CONVERTED DEPTH ARRAY FOR EVERY
!    OUTPUT DEPTH SAMPLE.  THE OUTPUT DEPTH ARRAY IS A UNIFORMLY SAMPLED
!    ARRAY BUT THE CONVERTED (TIME) ARRAY IS NOT.  USE WHATEVER CONVERTED
!    ARRAY POINT THAT IS CLOSEST, THUS ALLOWING THE SAME POINT TO APPEAR
!    IN THE OUTPUT ARRAY OR SKIPPING SOME.
!
      INDXT=1                                                           ! THE INDEX TO THE CONVERTED TIME ARRAY
      INDXD=0                                                           ! THE INDEX TO THE OUTPUT DEPTH ARRAY
!
  110 INDXD=INDXD+1
      IF(INDXD.GT.MSAMPS) RETURN
      DEPTH=SD+(INDXD-1)*SID                                            ! CALCULATE THE NEXT DEPTH VALUE
  120 IF( DEPTH .LT. SCRBUF(INDXT) ) THEN
          IF( DEPTH .LT. SCRBUF(INDXT-1) ) THEN
!****         the depth wanted is before the one we're at, so back up
              INDXT=INDXT-1
              IF(INDXT.GT.0) GO TO 120
              BUFOUT(INDXD)=0.                                                  ! THE OUTPUT IS BEFORE THE INPUT!
              INDXT=1
          ELSE
!****         the depth is between this one and the prior one, use the prior one
              BUFOUT(INDXD)=BUFIN(INDXT-1)
          ENDIF
!         print *,' 130 dep=',depth,' indxd=',indxd,' indxt=',indxt,
!     &        ' scr=',scrbuf(indxt)
          GO TO 110
       ENDIF
!****
!**** if the depth is after this one, go to the next one
      IF( DEPTH .EQ. SCRBUF(INDXT) ) THEN
!***      the depth is the same as this one, use it!
          BUFOUT(INDXD)=BUFIN(INDXT)
!          print *,' 200 dep=',depth,' indxd=',indxd,' indxt=',indxt,
!     &        ' scr=',scrbuf(indxt),' buf=',bufout(indxd)
          GO TO 110
      ENDIF
!****
!****  set up to try the next time sample
  300 INDXT=INDXT+1
      IF(INDXT.LE.NSAMPS) GO TO 120
      DO I=INDXD,MSAMPS
  310    BUFOUT(I)=0.
      ENDDO
      RETURN
      END


! ==========================================================================
!
! Basic VMC/DMC code for educational purposes.
! This file: system-specific subroutines for H2 molecule
!
! Copyright (C) 2014 Jindrich Kolorenc
!
! The software is released under MIT/X11 license.
!
! ==========================================================================

module qmc_input
  use types_const, only: dp, missing
  implicit none
  private

  public :: sys_dim
  public :: t_walker, t_sys
  public :: init_sys
  public :: EL_drift, psiT2

  ! logically, this should go to t_sys, but I really want to keep static arrays
  ! in t_walker, which enforces this to be a global constant
  integer, parameter :: sys_dim=6       ! dimension of walker

  type t_walker
     real(dp), dimension(sys_dim) :: r  ! position
     real(dp), dimension(sys_dim) :: vD ! drift velocity
     real(dp) :: EL                     ! local energy
     real(dp) :: psiT                   ! trial wave function
     real(dp) :: psiTsq                 ! square of trial wavefunction
     real(dp) :: wt=1.0_dp              ! DMC weight
     integer :: sgn=1                   ! sign of trial wavefunction at r
     integer :: age=0                   ! how many times rejected by det. bal.
  end type t_walker

  type t_sys
     character(11) :: id="H2 molecule"  ! identification of the system
     real(dp) :: R=1.4_dp               ! proton-proton distance
     real(dp) :: b=4.0_dp               ! denominator in the ee-cusp term
  end type t_sys

  interface EL_drift
     !module procedure EL_drift_HeitlerLondon
     module procedure EL_drift_HeitlerLondonJastrow
  end interface EL_drift

  interface psiT2
     !module procedure psiT2_HeitlerLondon
     module procedure psiT2_HeitlerLondonJastrow
  end interface psiT2

contains

  subroutine init_sys(sys,words)
    ! {{{ initialize the system and wave-function parameters
    use cfparser, only: t_words, readsection, readvalue, clear
    type(t_sys), intent(inout) :: sys
    type(t_words), intent(in) :: words
    type(t_words) :: syswords

    if ( .not.readsection(words,syswords,"system") ) then
       print *, "Missing section 'system' in the input file."
       stop
    end if

    if ( .not.readvalue(syswords,sys%R,"R") ) call missing("R")
    call clear(syswords)

    write(unit=*,fmt='(1x,a)') "system:"
    write(unit=*,fmt='(3x,a)') sys%id
    write(unit=*,fmt='(3x,a,f8.4)') "proton-proton distance [R]:", sys%R
    write(unit=*,fmt=*)
    ! }}}
  end subroutine init_sys

  pure subroutine EL_drift_HeitlerLondon(sys,wlkr)
    ! {{{ local energy, drift velocity, wave-function squared
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    real(dp), dimension(3) :: r1, r2
    real(dp) :: rho1, r1a, r1b, rho2, r2a, r2b, r12
    real(dp) :: phiA1B2, phiA2B1, psi
    r1=wlkr%r(1:3)
    r2=wlkr%r(4:6)
    rho1=r1(1)**2+r1(2)**2
    r1a=sqrt(rho1+(r1(3)-sys%R)**2)
    r1b=sqrt(rho1+r1(3)**2)
    rho2=r2(1)**2+r2(2)**2
    r2a=sqrt(rho2+(r2(3)-sys%R)**2)
    r2b=sqrt(rho2+r2(3)**2)
    r12=sqrt(sum((r1-r2)**2))
    phiA1B2=exp(-r1a-r2b)
    phiA2B1=exp(-r2a-r1b)
    psi=phiA1B2+phiA2B1
    wlkr%psiT=psi
    wlkr%psiTsq=psi**2
    wlkr%EL=-1.0_dp-((1.0_dp/r1b+1.0_dp/r2a)*phiA1B2 &
         +(1.0_dp/r1a+1.0_dp/r2b)*phiA2B1)/psi+1.0_dp/r12+1.0_dp/sys%R
    wlkr%vD(1:2)=-phiA1B2*r1(1:2)/r1a-phiA2B1*r1(1:2)/r1b
    wlkr%vD(3)=-phiA1B2*(r1(3)-sys%R)/r1a-phiA2B1*r1(3)/r1b
    wlkr%vD(4:5)=-phiA1B2*r2(1:2)/r2b-phiA2B1*r2(1:2)/r2a
    wlkr%vD(6)=-phiA1B2*r2(3)/r2b-phiA2B1*(r2(3)-sys%R)/r2a
    wlkr%vD=wlkr%vD/psi
    wlkr%sgn=1
    ! }}}
  end subroutine EL_drift_HeitlerLondon

  pure subroutine psiT2_HeitlerLondon(sys,wlkr)
    ! {{{ trial wave-function squared
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    real(dp), dimension(3) :: r1, r2
    real(dp) :: rho1, r1a, r1b, rho2, r2a, r2b
    real(dp) :: phiA1B2, phiA2B1, psi
    r1=wlkr%r(1:3)
    r2=wlkr%r(4:6)
    rho1=r1(1)**2+r1(2)**2
    r1a=sqrt(rho1+(r1(3)-sys%R)**2)
    r1b=sqrt(rho1+r1(3)**2)
    rho2=r2(1)**2+r2(2)**2
    r2a=sqrt(rho2+(r2(3)-sys%R)**2)
    r2b=sqrt(rho2+r2(3)**2)
    phiA1B2=exp(-r1a-r2b)
    phiA2B1=exp(-r2a-r1b)
    psi=phiA1B2+phiA2B1
    wlkr%psiT=psi
    wlkr%psiTsq=psi**2
    wlkr%sgn=1
    ! }}}
  end subroutine psiT2_HeitlerLondon

  pure subroutine EL_drift_HeitlerLondonJastrow(sys,wlkr)
    ! {{{ local energy, drift velocity, wave-function squared
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    type(t_walker) :: wlkrHL
    real(dp), dimension(3) :: r12, grad1J
    real(dp) :: r12l, f, J, lap1J
    wlkrHL=wlkr
    call EL_drift_HeitlerLondon(sys,wlkrHL)
    r12=wlkr%r(1:3)-wlkr%r(4:6)
    r12l=sqrt(sum(r12**2))
    f=1.0_dp/(2.0_dp+sys%b*r12l)
    J=r12l*f
    grad1J=2.0_dp*r12/r12l*f**2
    !lap1J=-4.0_dp*sys%b*f**3
    lap1J=8.0_dp*f**3/r12l
    wlkr%psiT=exp(J)*wlkrHL%psiT
    wlkr%psiTsq=wlkr%psiT**2
    wlkr%EL=wlkrHL%EL - sum(grad1J**2) - lap1J &
         - sum(grad1J*(wlkrHL%vD(1:3)-wlkrHL%vD(4:6)))
    wlkr%vD(1:3)=wlkrHL%vd(1:3)+grad1J
    wlkr%vD(4:6)=wlkrHL%vd(4:6)-grad1J
    wlkr%sgn=wlkrHL%sgn
    ! }}}
  end subroutine EL_drift_HeitlerLondonJastrow

  pure subroutine psiT2_HeitlerLondonJastrow(sys,wlkr)
    ! {{{ trial wave-function squared
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    type(t_walker) :: wlkrHL
    real(dp), dimension(3) :: r12
    real(dp) :: r12l, f, J
    wlkrHL=wlkr
    call EL_drift_HeitlerLondon(sys,wlkrHL)
    r12=wlkr%r(1:3)-wlkr%r(4:6)
    r12l=sqrt(sum(r12**2))
    f=1.0_dp/(2.0_dp+sys%b*r12l)
    J=r12l*f
    wlkr%psiT=exp(J)*wlkrHL%psiT
    wlkr%psiTsq=wlkr%psiT**2
    wlkr%sgn=wlkrHL%sgn
    ! }}}
  end subroutine psiT2_HeitlerLondonJastrow

  pure subroutine EL_drift_HeitlerLondonJastrow_nogood(sys,wlkr)
    ! {{{ local energy, drift velocity, wave-function squared
    !     the Jastrow factor takes care only of the e-e cusp but there
    !     are still some e-nucleus divergencies
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    real(dp), dimension(3) :: r1, r2
    real(dp), dimension(3) :: r120, r1a0, r1b0, r2a0, r2b0
    real(dp) :: rho1, r1a, r1b, rho2, r2a, r2b, r12
    real(dp) :: phiA, phiB, psi, f
    r1=wlkr%r(1:3)
    r2=wlkr%r(4:6)
    !
    r1a0=r1
    r1b0=r1
    r1a0(3)=r1(3)-sys%R
    rho1=r1(1)**2+r1(2)**2
    r1a=sqrt(rho1+r1a0(3)**2)
    r1b=sqrt(rho1+r1(3)**2)
    r1a0=r1a0/r1a
    r1b0=r1b0/r1b
    !
    r2a0=r2
    r2b0=r2
    r2a0(3)=r2(3)-sys%R
    rho2=r2(1)**2+r2(2)**2
    r2a=sqrt(rho2+r2a0(3)**2)
    r2b=sqrt(rho2+r2(3)**2)
    r2a0=r2a0/r2a
    r2b0=r2b0/r2b
    !
    r120=r1-r2
    r12=sqrt(sum(r120**2))
    r120=r120/r12
    f=1.0_dp/(2.0_dp+r12)
    !
    phiA=exp(-r1a-r2b) * (1.0_dp+r12/2.0_dp)
    phiB=exp(-r2a-r1b) * (1.0_dp+r12/2.0_dp)
    psi=phiA+phiB
    wlkr%psiTsq=psi**2
    wlkr%sgn=1
    !
    wlkr%EL=-1.0_dp + ( &
         ( f*(sum(r120*(r1a0-r2b0))+1) - 1.0_dp/r1b - 1.0_dp/r2a )*phiA + &
         ( f*(sum(r120*(r1b0-r2a0))+1) - 1.0_dp/r1a - 1.0_dp/r2b )*phiB &
         )/psi + 1.0_dp/sys%R
    wlkr%vD(1:3)= ( f*r120 - r1a0)*phiA + ( f*r120 - r1b0)*phiB
    wlkr%vD(4:6)= (-f*r120 - r2b0)*phiA + (-f*r120 - r2a0)*phiB
    wlkr%vD=wlkr%vD/psi
    ! }}}
  end subroutine EL_drift_HeitlerLondonJastrow_nogood

  pure subroutine psiT2_HeitlerLondonJastrow_nogood(sys,wlkr)
    ! {{{ trial wave-function squared
    type(t_sys), intent(in) :: sys
    type(t_walker), intent(inout) :: wlkr
    real(dp), dimension(3) :: r1, r2
    real(dp) :: rho1, r1a, r1b, rho2, r2a, r2b, r12
    real(dp) :: phiA1B2, phiA2B1, psi
    r1=wlkr%r(1:3)
    r2=wlkr%r(4:6)
    rho1=r1(1)**2+r1(2)**2
    r1a=sqrt(rho1+(r1(3)-sys%R)**2)
    r1b=sqrt(rho1+r1(3)**2)
    rho2=r2(1)**2+r2(2)**2
    r2a=sqrt(rho2+(r2(3)-sys%R)**2)
    r2b=sqrt(rho2+r2(3)**2)
    r12=sqrt(sum((r1-r2)**2))
    phiA1B2=exp(-r1a-r2b)
    phiA2B1=exp(-r2a-r1b)
    psi=( phiA1B2+phiA2B1 ) * (1.0_dp+r12/2.0_dp)
    wlkr%psiTsq=psi**2
    wlkr%sgn=1
    ! }}}
  end subroutine psiT2_HeitlerLondonJastrow_nogood

end module qmc_input

! Local variables:
! folded-file: t
! End:


!! MODULO CON VARIABLES Y ARREGLOS DIMENSIONALES !!

module arrays

    implicit none

    real(kind = 8), allocatable, dimension (:) :: x
    real(kind = 8), allocatable, dimension (:) :: Phi, Phi_aux, numeric_Phi, dPhi
    real(kind = 8), allocatable, dimension (:) :: Psi, Psi_aux, numeric_Psi, dPsi
    real(kind = 8), allocatable, dimension (:) :: Pi, Pi_aux, numeric_Pi, dPi
    real(kind = 8), allocatable, dimension (:) :: Lmode, Rmode
    real(kind = 8), allocatable, dimension (:) :: alpha, dalpha
    real(kind = 8), allocatable, dimension (:) :: beta, dbeta
    real(kind = 8), allocatable, dimension (:) :: gamma, dgamma
    real(kind = 8), allocatable, dimension (:) :: gamma_rr, dgamma_rr
    real(kind = 8), allocatable, dimension (:) :: constriction

end module arrays


      SUBROUTINE BUMP
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      COMMON/S0/R(5,16000),T(5,16000),R1(5,16000),T1(5,16000),DIST,K,L
      COMMON/S6/BUMP0(4),BUMPR(4),BUMPT(4),BRO0,BTETA0,BRRM,BAMAX,
     1BWIDTH,BGAP,BBBM,IBUMP
c      COMMON VMAX,GAP,SIV,ER0(4),ET0(4),ER1(4),ET1(4),DERDR(4),DETDT(4),BS0(4),DBSDR(4),DBSDT(4),BBM,DBM,
c     2RO0,TETA0,RRM,AAM,AMAX,WIDTH,POTINT,POTEX,EN,   DERDT(4),DETDR(4),EP,ITEST
      PI=3.141593
      BAAM=112.5*PI/180.
      IF(IBUMP.EQ.-1) BAA=BAAM+PI
      IF(IBUMP.EQ.-1) BTE=BTETA0+PI
      SINA=DSIN(BTE-T(K,L))
      COSA=DCOS(BTE-T(K,L))
      SINO=DSIN(BAA-BTE)
      COSO=DCOS(BAA-BTE)
      AAA=BRO0*SINO-R(K,L)*DSIN(BAA-T(K,L))
      BBB=-BRO0*COSO+R(K,L)*DCOS(BAA-T(K,L))
      ECA=DATAN(AAA/BBB)
      RRMP2=AAA*AAA+BBB*BBB
      DDD=DSQRT(RRMP2)
      BDIST=DDD-(BRRM+BWIDTH*.5)
      GGG=(2.*ECA+BAMAX)*BRRM/BGAP+1.
      HHH=(2.*ECA-BAMAX)*BRRM/BGAP-1.
      FFF=(DTANH(GGG)-DTANH(HHH))*.5
      HH=BDIST*40.-1.
      GG=BDIST*40.+1.
      PP=DCOSH(BDIST*10.)
      QQ=DSINH(BDIST*10.)
      FF=(.6*(DTANH(GG)-DTANH(HH))-.15/PP)/.764
      SIBUMP=DBLE(FLOAT(IBUMP))
      BUMP0(K)=BBBM*FF*FFF*SIBUMP
      DECADR=BRO0*SINA/RRMP2
      DECADT=R(K,L)*(R(K,L)-BRO0*COSA)/RRMP2
      U1=DCOSH(GGG)
      U2=DCOSH(HHH)
      UU=BRRM*(1./U1/U1-1./U2/U2)/BGAP
      DFFFDR=DECADR*UU
      DFFFDT=DECADT*UU
      DIDR=(R(K,L)-BRO0*COSA)/DDD
      DIDT=-R(K,L)*BRO0*SINA/DDD
      V1=DCOSH(GG)
      V2=DCOSH(HH)
      VV=((1./V1/V1-1./V2/V2)*24.+QQ/PP/PP*1.5)/.764
      DFFDR=DIDR*VV
      DFFDT=DIDT*VV
      BUMPR(K)=BBBM*(FF*DFFFDR+FFF*DFFDR)*SIBUMP
      BUMPT(K)=BBBM*(FF*DFFFDT+FFF*DFFDT)*SIBUMP
      RETURN
      END


module state_rate_interface
  !! Encapsulate the time rate of change of the state variables that are defined as
  !! state_t components.  These rate variables are used in the main program,
  !! where a state_rate_t object gets multiplied by the time step:
  !! motor%d_dt(state)*dt
  use kind_parameters, only : rkind
  implicit none

  private

  type, public :: state_rate_t
    private
    real(rkind) mass_rate_       !! chamber mass increase per unit time
    real(rkind) energy_rate_     !! chamber internal energy increase per unit time
    real(rkind) burn_depth_rate_ !! surface-normal burn depth increase per unit time
    real(rkind) time_rate_       !! time increase per unit time (always 1)
  contains
    procedure, private :: multiply
    generic :: operator(*) => multiply
  end type

  interface state_rate_t
    module procedure new_rate
  end interface

  interface

    pure module function new_rate(time_rate, mass_rate, energy_rate, burn_depth_rate)
      !! result is a newly constructured state_rate_t object
      implicit none
      real(rkind), intent(in) :: time_rate, mass_rate, energy_rate, burn_depth_rate
      type(state_rate_t) new_rate
    end function

    pure module function multiply(this, rhs) result(this_x_rhs)
      !! result has components computed from multiply each rhs component by dt
      use state_interface, only : state_t
      implicit none
      class(state_rate_t), intent(in) :: this
      real(rkind), intent(in) :: rhs
      type(state_t) this_x_rhs
    end function

  end interface

end module state_rate_interface


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine mean_field_pot
  use global_variables
  implicit none
  integer :: ix,iy

  do ix=0,Nx
    v_e(ix) = sum(v_en(:,ix)*rho_n(:))*dr
  end do

  do iy=0,NR
    v_n(iy) = sum(v_ne(:,iy)*rho(:))*dx + v0_n(iy)
  end do

  return
end subroutine mean_field_pot


*     SB16CD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDD, LDDC, LDF, LDG
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                 LDD = PMAX, LDDC = MMAX, LDF = MMAX, LDG = NMAX )
      INTEGER          LDWORK, LIWORK, MPMAX
      PARAMETER        ( LIWORK = 2*NMAX, MPMAX = MAX( MMAX, PMAX ) )
      PARAMETER        ( LDWORK = 2*NMAX*NMAX +
     $                            MAX( 2*NMAX*NMAX + 5*NMAX,
     $                                 NMAX*( NMAX + MAX( NMAX, MPMAX )
     $                                      + MIN( NMAX, MPMAX ) + 6 ) )
     $                 )
      CHARACTER        DICO, JOBCF, JOBD, JOBMR, ORDSEL
      INTEGER          I, INFO, IWARN, J, M, N, NCR, P
      DOUBLE PRECISION TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 D(LDD,MMAX), DWORK(LDWORK),
     $                 F(LDF,NMAX), G(LDG,PMAX), HSV(NMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Subroutines ..
      EXTERNAL         SB16CD
*     .. 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 = * ) N, M, P, NCR, TOL,
     $                      DICO, JOBD, JOBMR, JOBCF, ORDSEL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,N ), I = 1,M )
               READ ( NIN, FMT = * ) ( ( G(I,J), J = 1,P ), I = 1,N )
*              Find a reduced ssr for (A,B,C,D).
               CALL SB16CD( DICO, JOBD, JOBMR, JOBCF, ORDSEL, N, M, P,
     $                      NCR, A, LDA, B, LDB, C, LDC, D, LDD, F, LDF,
     $                      G, LDG, HSV, TOL, IWORK, DWORK, LDWORK,
     $                      IWARN, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NCR
                  WRITE ( NOUT, FMT = 99987 )
                  WRITE ( NOUT, FMT = 99995 ) ( HSV(J), J = 1,N )
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCR )
   20             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NCR
                     WRITE ( NOUT, FMT = 99995 ) ( G(I,J), J = 1,P )
   40             CONTINUE
                  IF( NCR.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, M
                     WRITE ( NOUT, FMT = 99995 ) ( F(I,J), J = 1,NCR )
   60             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB16CD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB16CD = ',I2)
99997 FORMAT (' The order of reduced controller = ',I2)
99996 FORMAT (/' The reduced controller state dynamics matrix Ac is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The reduced controller input/state matrix Bc is ')
99992 FORMAT (/' The reduced controller state/output matrix Cc is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The frequency-weighted Hankel singular values are:')
      END


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine blts ( ldmx, ldmy, ldmz,
     >                  nx, ny, nz, l,
     >                  omega,
     >                  v, tv,
     >                  ldz, ldy, ldx, d,
     >                  ist, iend, jstp, jendp )

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   compute the regular-sparse, block lower triangular solution:
c
c                     v <-- ( L-inv ) * v
c
c---------------------------------------------------------------------

      implicit none

c---------------------------------------------------------------------
c  input parameters
c---------------------------------------------------------------------
      integer ldmx, ldmy, ldmz
      integer nx, ny, nz
      integer l, ist, iend, jstp, jendp
      double precision  omega
c---------------------------------------------------------------------
c   To improve cache performance, second two dimensions padded by 1
c   for even number sizes only.  Only needed in v.
c---------------------------------------------------------------------
      double precision  v( 5, ldmx/2*2+1, ldmy/2*2+1, *),
     >        tv( 5, ldmx/2*2+1, ldmy),
     >        ldz( 5, 5, ldmx/2*2+1, ldmy),
     >        ldy( 5, 5, ldmx/2*2+1, ldmy),
     >        ldx( 5, 5, ldmx/2*2+1, ldmy),
     >        d( 5, 5, ldmx/2*2+1, ldmy)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m, n
      double precision  tmp, tmp1
      double precision  tmat(5,5)

c---------------------------------------------------------------------
c  For all points on a hyper-plane (l)
c---------------------------------------------------------------------
      do j = jstp, jendp
      	 k = l - j
         do i = ist, iend

            do m = 1, 5

                  tv( m, i, j ) =  v( m, i, j, k )
     >    - omega * (  ldz( m, 1, i, j ) * v( 1, i, j, k-1 )
     >               + ldz( m, 2, i, j ) * v( 2, i, j, k-1 )
     >               + ldz( m, 3, i, j ) * v( 3, i, j, k-1 )
     >               + ldz( m, 4, i, j ) * v( 4, i, j, k-1 )
     >               + ldz( m, 5, i, j ) * v( 5, i, j, k-1 )  )

            end do

            do m = 1, 5

                  tv( m, i, j ) =  tv( m, i, j )
     > - omega * ( ldy( m, 1, i, j ) * v( 1, i, j-1, k )
     >           + ldx( m, 1, i, j ) * v( 1, i-1, j, k )
     >           + ldy( m, 2, i, j ) * v( 2, i, j-1, k )
     >           + ldx( m, 2, i, j ) * v( 2, i-1, j, k )
     >           + ldy( m, 3, i, j ) * v( 3, i, j-1, k )
     >           + ldx( m, 3, i, j ) * v( 3, i-1, j, k )
     >           + ldy( m, 4, i, j ) * v( 4, i, j-1, k )
     >           + ldx( m, 4, i, j ) * v( 4, i-1, j, k )
     >           + ldy( m, 5, i, j ) * v( 5, i, j-1, k )
     >           + ldx( m, 5, i, j ) * v( 5, i-1, j, k ) )

            end do

c---------------------------------------------------------------------
c   diagonal block inversion
c
c   forward elimination
c---------------------------------------------------------------------
            do m = 1, 5
               tmat( m, 1 ) = d( m, 1, i, j )
               tmat( m, 2 ) = d( m, 2, i, j )
               tmat( m, 3 ) = d( m, 3, i, j )
               tmat( m, 4 ) = d( m, 4, i, j )
               tmat( m, 5 ) = d( m, 5, i, j )
            end do

            tmp1 = 1.0d+00 / tmat( 1, 1 )
            tmp = tmp1 * tmat( 2, 1 )
            tmat( 2, 2 ) =  tmat( 2, 2 )
     >           - tmp * tmat( 1, 2 )
            tmat( 2, 3 ) =  tmat( 2, 3 )
     >           - tmp * tmat( 1, 3 )
            tmat( 2, 4 ) =  tmat( 2, 4 )
     >           - tmp * tmat( 1, 4 )
            tmat( 2, 5 ) =  tmat( 2, 5 )
     >           - tmp * tmat( 1, 5 )
            tv( 2, i, j ) = tv( 2, i, j )
     >        - tv( 1, i, j ) * tmp

            tmp = tmp1 * tmat( 3, 1 )
            tmat( 3, 2 ) =  tmat( 3, 2 )
     >           - tmp * tmat( 1, 2 )
            tmat( 3, 3 ) =  tmat( 3, 3 )
     >           - tmp * tmat( 1, 3 )
            tmat( 3, 4 ) =  tmat( 3, 4 )
     >           - tmp * tmat( 1, 4 )
            tmat( 3, 5 ) =  tmat( 3, 5 )
     >           - tmp * tmat( 1, 5 )
            tv( 3, i, j ) = tv( 3, i, j )
     >        - tv( 1, i, j ) * tmp

            tmp = tmp1 * tmat( 4, 1 )
            tmat( 4, 2 ) =  tmat( 4, 2 )
     >           - tmp * tmat( 1, 2 )
            tmat( 4, 3 ) =  tmat( 4, 3 )
     >           - tmp * tmat( 1, 3 )
            tmat( 4, 4 ) =  tmat( 4, 4 )
     >           - tmp * tmat( 1, 4 )
            tmat( 4, 5 ) =  tmat( 4, 5 )
     >           - tmp * tmat( 1, 5 )
            tv( 4, i, j ) = tv( 4, i, j )
     >        - tv( 1, i, j ) * tmp

            tmp = tmp1 * tmat( 5, 1 )
            tmat( 5, 2 ) =  tmat( 5, 2 )
     >           - tmp * tmat( 1, 2 )
            tmat( 5, 3 ) =  tmat( 5, 3 )
     >           - tmp * tmat( 1, 3 )
            tmat( 5, 4 ) =  tmat( 5, 4 )
     >           - tmp * tmat( 1, 4 )
            tmat( 5, 5 ) =  tmat( 5, 5 )
     >           - tmp * tmat( 1, 5 )
            tv( 5, i, j ) = tv( 5, i, j )
     >        - tv( 1, i, j ) * tmp

            tmp1 = 1.0d+00 / tmat( 2, 2 )
            tmp = tmp1 * tmat( 3, 2 )
            tmat( 3, 3 ) =  tmat( 3, 3 )
     >           - tmp * tmat( 2, 3 )
            tmat( 3, 4 ) =  tmat( 3, 4 )
     >           - tmp * tmat( 2, 4 )
            tmat( 3, 5 ) =  tmat( 3, 5 )
     >           - tmp * tmat( 2, 5 )
            tv( 3, i, j ) = tv( 3, i, j )
     >        - tv( 2, i, j ) * tmp

            tmp = tmp1 * tmat( 4, 2 )
            tmat( 4, 3 ) =  tmat( 4, 3 )
     >           - tmp * tmat( 2, 3 )
            tmat( 4, 4 ) =  tmat( 4, 4 )
     >           - tmp * tmat( 2, 4 )
            tmat( 4, 5 ) =  tmat( 4, 5 )
     >           - tmp * tmat( 2, 5 )
            tv( 4, i, j ) = tv( 4, i, j )
     >        - tv( 2, i, j ) * tmp

            tmp = tmp1 * tmat( 5, 2 )
            tmat( 5, 3 ) =  tmat( 5, 3 )
     >           - tmp * tmat( 2, 3 )
            tmat( 5, 4 ) =  tmat( 5, 4 )
     >           - tmp * tmat( 2, 4 )
            tmat( 5, 5 ) =  tmat( 5, 5 )
     >           - tmp * tmat( 2, 5 )
            tv( 5, i, j ) = tv( 5, i, j )
     >        - tv( 2, i, j ) * tmp

            tmp1 = 1.0d+00 / tmat( 3, 3 )
            tmp = tmp1 * tmat( 4, 3 )
            tmat( 4, 4 ) =  tmat( 4, 4 )
     >           - tmp * tmat( 3, 4 )
            tmat( 4, 5 ) =  tmat( 4, 5 )
     >           - tmp * tmat( 3, 5 )
            tv( 4, i, j ) = tv( 4, i, j )
     >        - tv( 3, i, j ) * tmp

            tmp = tmp1 * tmat( 5, 3 )
            tmat( 5, 4 ) =  tmat( 5, 4 )
     >           - tmp * tmat( 3, 4 )
            tmat( 5, 5 ) =  tmat( 5, 5 )
     >           - tmp * tmat( 3, 5 )
            tv( 5, i, j ) = tv( 5, i, j )
     >        - tv( 3, i, j ) * tmp

            tmp1 = 1.0d+00 / tmat( 4, 4 )
            tmp = tmp1 * tmat( 5, 4 )
            tmat( 5, 5 ) =  tmat( 5, 5 )
     >           - tmp * tmat( 4, 5 )
            tv( 5, i, j ) = tv( 5, i, j )
     >        - tv( 4, i, j ) * tmp

c---------------------------------------------------------------------
c   back substitution
c---------------------------------------------------------------------
            v( 5, i, j, k ) = tv( 5, i, j )
     >                      / tmat( 5, 5 )

            tv( 4, i, j ) = tv( 4, i, j )
     >           - tmat( 4, 5 ) * v( 5, i, j, k )
            v( 4, i, j, k ) = tv( 4, i, j )
     >                      / tmat( 4, 4 )

            tv( 3, i, j ) = tv( 3, i, j )
     >           - tmat( 3, 4 ) * v( 4, i, j, k )
     >           - tmat( 3, 5 ) * v( 5, i, j, k )
            v( 3, i, j, k ) = tv( 3, i, j )
     >                      / tmat( 3, 3 )

            tv( 2, i, j ) = tv( 2, i, j )
     >           - tmat( 2, 3 ) * v( 3, i, j, k )
     >           - tmat( 2, 4 ) * v( 4, i, j, k )
     >           - tmat( 2, 5 ) * v( 5, i, j, k )
            v( 2, i, j, k ) = tv( 2, i, j )
     >                      / tmat( 2, 2 )

            tv( 1, i, j ) = tv( 1, i, j )
     >           - tmat( 1, 2 ) * v( 2, i, j, k )
     >           - tmat( 1, 3 ) * v( 3, i, j, k )
     >           - tmat( 1, 4 ) * v( 4, i, j, k )
     >           - tmat( 1, 5 ) * v( 5, i, j, k )
            v( 1, i, j, k ) = tv( 1, i, j )
     >                      / tmat( 1, 1 )

         end do
      end do

      return
      end


!********************************************************************************
!* This file is part of:
!* BAFFLE (https://github.com/ATHannington/BAFFLE)
!* BAFFLE: BAsic Fortran FLuids Engine
!*
!* BAFFLE:
!* Copyright (C) 2017 Andrew Hannington (ath4@st-andrews.ac.uk)
!*
!* This software is a derivative of work by Bert Vandenbroucke
!* (bert.vandenbroucke@gmail.com)
!* Find more work by Bert Vandenbroucke at: (https://github.com/bwvdnbro)
!*
!* BAFFLE is a free software: you can redistribute it and/or modify it under the
!* terms of the GNU Affero General Public License
!* as published by the Free Software Foundation, either version 3 of the License, or
!* (at your option) any later version.
!*
!* BAFFLE is distributed in the hope that it will
!* be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!* GNU Affero General Public License for more details.
!*
!* You should have received a copy of the GNU Affero General Public License
!* along with BAFFLE. If not, see
!* <http://www.gnu.org/licenses/>.
!********************************************************************************

!********************************************************************************
!* @file extrapolate_subroutine_3D.f90
!*
!* @Extrapolates primitive variables of cells from centre to cell edge for second
!* order functionality. 3D Version: Fortran 90 version.
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!===============================================================================
!# Subroutine to extrapolate density, velocity components, and pressure from
!# gradients calculated in "get gradients subroutine". Extrapolates the variable
!# to cell interface (face of cell with neighbour) and moves the variable forward
!# by half a timestep. This follows the equation:
!#
!# W_t + A(W)*W_x + B(W)*W_y + C(W)*W_z = 0
!#
!# Where:
!#
!# W=(/rho,ux,uy,uz,p/)
!#
!# W_t = Del/del(t) [W] etc.
!#
!# A(w)=(/(ux,rho,       0, 0,   0),
!#	  (0,  ux,       0, 0,1/rho),
!#	  (0,  0,        ux,0,   0),
!#	  (0,  0,        0, ux,  0),
!#	  (0,rho*(cs**2),0, 0,   ux)/)
!# B(w)=(/(uy,rho,  0,         0,   0),
!#	  (0,  uy,  0,         0,   0),
!#	  (0,  0,   uy        ,0,1/rho),
!#	  (0,  0,   0,         uy,  0),
!#	  (0,  0, rho*(cs**2), 0,   uy)/)
!# C(w)=(/(uz,rho,0,    0,         0),
!#	  (0,  uz,0,    0,         0),
!#	  (0,  0, uz,   0,         0),
!#	  (0,  0, 0,    uz,      1/rho),
!#	  (0,  0, 0,rho*(cs**2),   uz)/)
!#
!# Which leads to the half timestep extrapolation of:
!#
!# Delta[W] = -1.d0*(A(W)*W_x + B(W)*W_y + C(W)*W_z)*(Delta[t])/2.d0
!#
!===============================================================================
subroutine extrapolate (xyz,i,j,k,d1,u1vec,p1,d2,u2vec,p2,&
			& dL,uLvec,pL,dR,uRvec,pR,time)
	use constants
	implicit none

		Real*8, intent(in) :: time
		character(len=1), intent(in) :: xyz				!Axis indicator
		Integer, intent (in) :: i,j,k					!Indices of cell being analysed
		Real*8,intent(in):: d1,p1,d2,p2					!Density and pressure values in, for left and right
		Real*8, dimension(3),intent(in) :: u1vec,u2vec			!Velocity vector in, for left and right
		Real*8,intent(out):: dL,pL,dR,pR				!extrapolated pressure and density at cell face, left and right
		Real*8, dimension(3),intent(out) :: uLvec,uRvec			!Extrapolated velocity at cell face, left and right
		Integer :: iL,iR,jL,jR,kL,kR					!Left and right values of i,j,k

!	Cells format: 	cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)

	If (xyz=="x") then
!===============================================================================
!#####				X-Axis Analysis				   #####
!===============================================================================
	! Set dummy left and right indices
	!	(x-axis):
		iL=i
		iR=i+1
		jL=j
		jR=j
		kL=k
		kR=k

		call extrapolate_calc (xyz,iL,iR,jL,jR,kL,kR,&
			& d1,u1vec,p1,d2,u2vec,p2,&
			& dL,uLvec,pL,dR,uRvec,pR, &
			& time)

	else if (xyz=="y") then
!===============================================================================
!#####				Y-axis Analysis				   #####
!===============================================================================
!	! Set dummy left and right indices
!	!	(y-axis):
		iL=i
		iR=i
		jL=j
		jR=j+1
		kL=k
		kR=k

		call extrapolate_calc (xyz,iL,iR,jL,jR,kL,kR,&
			& d1,u1vec,p1,d2,u2vec,p2,&
			& dL,uLvec,pL,dR,uRvec,pR, &
			& time)

	else if (xyz=="z") then
!===============================================================================
!#####				Z-Axis Analysis				   #####
!===============================================================================
!	 Set dummy left and right indices
!		(z-axis):
		iL=i
		iR=i
		jL=j
		jR=j
		kL=k
		kR=k+1

		call extrapolate_calc (xyz,iL,iR,jL,jR,kL,kR,&
			& d1,u1vec,p1,d2,u2vec,p2,&
			& dL,uLvec,pL,dR,uRvec,pR, &
			& time)

	else
		Print*,"Axis indicator failure [@Extrapolate]! Program will Abort!"
		STOP
	endif

end subroutine extrapolate
!===============================================================================
!# Generalised subroutine to perform the extrapolation calculation. Only performs
!# spatial extrapolation on axis being analysed, and performs total temporal
!# extrapolation from above (main header) formulae.
!===============================================================================
subroutine extrapolate_calc (xyz,iL,iR,jL,jR,kL,kR,&
			& d1,u1vec,p1,d2,u2vec,p2,&
			& dLsol,uLvec,pLsol,dRsol,uRvec,pRsol, &
			& time)
	use constants
	implicit none

		Real*8, intent(in) :: time					!Current code time
		INTEGER,intent(in) :: iL,iR,jL,jR,kL,kR				!Left and right indices
		Character(len=1), intent(in) :: xyz

		Real*8,intent(in):: d1,p1,d2,p2					!Density and pressure values in, for left and right
		Real*8, dimension(3),intent(in) :: u1vec,u2vec			!Velocity vector in, for left and right
		Real*8,intent(out):: dLsol,pLsol,dRsol,pRsol			!extrapolated pressure and density at cell face, left and right
		Real*8, dimension(3),intent(out) :: uLvec,uRvec			!Extrapolated velocity at cell face, left and right

		Real*8 :: xL,xR,yL,yR,zL,zR					!cell position for left and right cell, for given axis direction
		Real*8 :: dL,uxL,uyL,uzL,pL					!Left cell quantities. This cell will be the cell under analysis
		Real*8 :: dR,uxR,uyR,uzR,pR					!Right cell quantities.

		Real*8 :: grad_d_x_L,grad_d_y_L,grad_d_z_L, &			!Left Density gradients on each axis
			& grad_d_x_R,grad_d_y_R,grad_d_z_R			!Right Density gradients on each axis

		Real*8 :: grad_ux_x_L,grad_uy_x_L,grad_uz_x_L, &		!Left velocity gradients for each component on each axis
			& grad_ux_y_L,grad_uy_y_L,grad_uz_y_L, &
			& grad_ux_z_L,grad_uy_z_L,grad_uz_z_L
		Real*8 :: grad_ux_x_R,grad_uy_x_R,grad_uz_x_R, &		!Right velocity gradients for each component on each axis
			& grad_ux_y_R,grad_uy_y_R,grad_uz_y_R, &
			& grad_ux_z_R,grad_uy_z_R,grad_uz_z_R

		Real*8 :: grad_p_x_L,grad_p_y_L,grad_p_z_L, &			!Left pressure gradients on each axis
			& grad_p_x_R,grad_p_y_R,grad_p_z_R			!Right pressure gradients on each axis

		Real*8 :: d_extrap_L,ux_extrap_L,uy_extrap_L,uz_extrap_L,p_extrap_L, &
			& d_extrap_R,ux_extrap_R,uy_extrap_R,uz_extrap_R,p_extrap_R	!Exratoplated variables, left and right

		Real*8 :: Delx,Dely,Delz					!Cell-to-cell distance	on each axis

		Real*8 :: cs_L, cs_R						!Sound speed in left and rigt cell cs=Sqrt(gamma*(p/rho))

		Real*8, dimension(5)	:: W_L, W_x_L, W_y_L, W_z_L, &		!Left and right W vectors, and spatial derivatives
					&  W_R, W_x_R, W_y_R, W_z_R

		Real*8, dimension (5,5)	:: AMat_L, BMat_L, CMat_L, &		!Left and right A,B,C matrices
					 & AMat_R, BMat_R, CMat_R
		Integer :: h							!Counter for do loop
		Character(len=4) :: error_loc					!Error location identifier string

!	Cells format: 	cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z, &
!						& grad_ux_x,grad_uy_x,grad_uz_x, &
!						& grad_ux_y,grad_uy_y,grad_uz_y, &
!						& grad_ux_z,grad_uy_z,grad_uz_z, &
!						& grad_p_x,grad_p_y,grad_p_z /)

!-------------------------------------------------------------------------------
!# Set variable values from cells being analysed:
!-------------------------------------------------------------------------------
!	Set variables from cells to be used:
!		Left values:
!		x=:
	xL=cells(iL,jL,kL,xn)
!		y=:
	yL=cells(iL,jL,kL,yn)
!		z=:
	zL=cells(iL,jL,kL,zn)

!	Density:
	dL=d1

!	Pressure:
	pL=p1

!	Velocity components:
	uxL = u1vec(1)
	uyL = u1vec(2)
	uzL = u1vec(3)

!Left Density gradients on each axis:
	grad_d_x_L=cells(iL,jL,kL,gdxn)
	grad_d_y_L=cells(iL,jL,kL,gdyn)
	grad_d_z_L=cells(iL,jL,kL,gdzn)

!Left velocity gradients for each component on each axis:
	grad_ux_x_L=cells(iL,jL,kL,guxxn)
	grad_uy_x_L=cells(iL,jL,kL,guyxn)
	grad_uz_x_L=cells(iL,jL,kL,guzxn)

	grad_ux_y_L=cells(iL,jL,kL,guxyn)
	grad_uy_y_L=cells(iL,jL,kL,guyyn)
	grad_uz_y_L=cells(iL,jL,kL,guzyn)

	grad_ux_z_L=cells(iL,jL,kL,guxzn)
	grad_uy_z_L=cells(iL,jL,kL,guyzn)
	grad_uz_z_L=cells(iL,jL,kL,guzzn)

!Left pressure gradients on each axis:
	grad_p_x_L=cells(iL,jL,kL,gpxn)
	grad_p_y_L=cells(iL,jL,kL,gpyn)
	grad_p_z_L=cells(iL,jL,kL,gpzn)

!-------------------------------------------------------------------------------
!	Set variables from cells to be used:
!		Right values:
!		x=:
	xR=cells(iR,jR,kR,xn)
!		y=:
	yR=cells(iR,jR,kR,yn)
!		z=:
	zR=cells(iR,jR,kR,zn)

!	Density:
	dR=d2

!	Pressure:
	pR=p2

!	Velocity components:
	uxR = u2vec(1)
	uyR = u2vec(2)
	uzR = u2vec(3)

!Left Density gradients on each axis:
	grad_d_x_R=cells(iR,jR,kR,gdxn)
	grad_d_y_R=cells(iR,jR,kR,gdyn)
	grad_d_z_R=cells(iR,jR,kR,gdzn)

!Left velocity gradients for each component on each axis:
	grad_ux_x_R=cells(iR,jR,kR,guxxn)
	grad_uy_x_R=cells(iR,jR,kR,guyxn)
	grad_uz_x_R=cells(iR,jR,kR,guzxn)

	grad_ux_y_R=cells(iR,jR,kR,guxyn)
	grad_uy_y_R=cells(iR,jR,kR,guyyn)
	grad_uz_y_R=cells(iR,jR,kR,guzyn)

	grad_ux_z_R=cells(iR,jR,kR,guxzn)
	grad_uy_z_R=cells(iR,jR,kR,guyzn)
	grad_uz_z_R=cells(iR,jR,kR,guzzn)

!Left pressure gradients on each axis:
	grad_p_x_R=cells(iR,jR,kR,gpxn)
	grad_p_y_R=cells(iR,jR,kR,gpyn)
	grad_p_z_R=cells(iR,jR,kR,gpzn)

!-------------------------------------------------------------------------------
!# Sets extrapolation direction for relevant axis being analysed. Thus, centre
!# to relevant cell face on given axis, distance is calculated for extrapolation.
!-------------------------------------------------------------------------------
	If (xyz=="x") then
		Delx=DABS((xR-xL)/2.d0)
		Dely=0.d0
		Delz=0.d0
	else if (xyz=="y") then
		Delx=0.d0
		Dely=DABS((yR-yL)/2.d0)
		Delz=0.d0
	else if (xyz=="z") then
		Delx=0.d0
		Dely=0.d0
		Delz=DABS((zR-zL)/2.d0)
	else
		Print*,"Axis indicator failure [@Extrapolate_calc]! Program will Abort!"
		STOP
	endif

	If (xyz=="x") then
!-------------------------------------------------------------------------------
!# 			x-axis Extrapolation
!-------------------------------------------------------------------------------
!	Extrapolate values of pressure, density, and velocity:
!		Left Cell:
		d_extrap_L = dL + Delx*grad_d_x_L
		ux_extrap_L = uxL + Delx*grad_ux_x_L
		uy_extrap_L = uyL + Delx*grad_uy_x_L
		uz_extrap_L = uzL + Delx*grad_uz_x_L
		p_extrap_L = pL + Delx*grad_p_x_L
!		Right Cell:
		d_extrap_R = dR - Delx*grad_d_x_R
		ux_extrap_R = uxR - Delx*grad_ux_x_R
		uy_extrap_R = uyR - Delx*grad_uy_x_R
		uz_extrap_R = uzR - Delx*grad_uz_x_R
		p_extrap_R = pR - Delx*grad_p_x_R
	else if (xyz=="y") then
!-------------------------------------------------------------------------------
!# 			y-axis Extrapolation
!-------------------------------------------------------------------------------
!	Extrapolate values of pressure, density, and velocity:
!		Left Cell:
		d_extrap_L = dL + Dely*grad_d_y_L
		ux_extrap_L = uxL + Dely*grad_ux_y_L
		uy_extrap_L = uyL + Dely*grad_uy_y_L
		uz_extrap_L = uzL + Dely*grad_uz_y_L
		p_extrap_L = pL + Dely*grad_p_y_L
!		Right Cell:
		d_extrap_R = dR - Dely*grad_d_y_R
		ux_extrap_R = uxR - Dely*grad_ux_y_R
		uy_extrap_R = uyR - Dely*grad_uy_y_R
		uz_extrap_R = uzR - Dely*grad_uz_y_R
		p_extrap_R = pR - Dely*grad_p_y_R
	else if (xyz=="z") then
!-------------------------------------------------------------------------------
!# 			z-axis Extrapolation
!-------------------------------------------------------------------------------
!	Extrapolate values of pressure, density, and velocity:
!		Left Cell:
		d_extrap_L = dL + Delz*grad_d_z_L
		ux_extrap_L = uxL + Delz*grad_ux_z_L
		uy_extrap_L = uyL + Delz*grad_uy_z_L
		uz_extrap_L = uzL + Delz*grad_uz_z_L
		p_extrap_L = pL + Delz*grad_p_z_L
!		Right Cell:
		d_extrap_R = dR - Delz*grad_d_z_R
		ux_extrap_R = uxR - Delz*grad_ux_z_R
		uy_extrap_R = uyR - Delz*grad_uy_z_R
		uz_extrap_R = uzR - Delz*grad_uz_z_R
		p_extrap_R = pR - Delz*grad_p_z_R
	else
		Print*,"Axis indicator failure [@Extrapolate_calc]! Program will Abort!"
		STOP
	endif

!	Check for unphysical values:
	error_loc="extr"

!	call error_sub(0,error_loc,NcXr,NcYr,NcZr,gam,1.d0,1.d0,cellVol,p_extrap_L,p_extrap_R,d_extrap_L,d_extrap_R,iL,jL,kL,time)

!-------------------------------------------------------------------------------
!# 			Setup A, B, C matrices, and W vectors:
!-------------------------------------------------------------------------------
! LEFT and RIGHT W vectors
	W_L(1:5) = (/d_extrap_L,ux_extrap_L,uy_extrap_L,uz_extrap_L,p_extrap_L/)
	W_R(1:5) = (/d_extrap_R,ux_extrap_R,uy_extrap_R,uz_extrap_R,p_extrap_R/)
! LEFT and RIGHT W vector spatial derivatives:
	!Left cell:
	W_x_L(1:5) = (/grad_d_x_L,grad_ux_x_L,grad_uy_x_L,grad_uz_x_L,grad_p_x_L/)
	W_y_L(1:5) = (/grad_d_y_L,grad_ux_y_L,grad_uy_y_L,grad_uz_y_L,grad_p_y_L/)
	W_z_L(1:5) = (/grad_d_z_L,grad_ux_z_L,grad_uy_z_L,grad_uz_z_L,grad_p_z_L/)

	!Right cell:
	W_x_R(1:5) = (/grad_d_x_R,grad_ux_x_R,grad_uy_x_R,grad_uz_x_R,grad_p_x_R/)
	W_y_R(1:5) = (/grad_d_y_R,grad_ux_y_R,grad_uy_y_R,grad_uz_y_R,grad_p_y_R/)
	W_z_R(1:5) = (/grad_d_z_R,grad_ux_z_R,grad_uy_z_R,grad_uz_z_R,grad_p_z_R/)

! Left A matrix:
	AMat_L(1:5,1:5) = transpose(reshape( &						!Transpose and reshape takes the list as written, turns it into a matrix of the shape given by shape(AMat_L),
			  & (/uxL,dL,0.d0,0.d0,0.d0, &					! and transposes so the matrix output is of the format in the comments above and as written roughly here.
			  & 0.d0,uxL,0.d0,0.d0,(1.d0/dL), &
			  & 0.d0,0.d0,uxL,0.d0,0.d0, &
			  & 0.d0,0.d0,0.d0,uxL,0.d0, &
			  & 0.d0,gam*pL,0.d0,0.d0,uxL/),shape(AMat_L)))
! RIGHT A matrix:
	AMat_R(1:5,1:5) = transpose(reshape( &
			  & (/uxR,dR,0.d0,0.d0,0.d0, &
			  & 0.d0,uxR,0.d0,0.d0,(1.d0/dR), &
			  & 0.d0,0.d0,uxR,0.d0,0.d0, &
			  & 0.d0,0.d0,0.d0,uxR,0.d0, &
			  & 0.d0,gam*pR,0.d0,0.d0,uxR/),shape(AMat_R)))
! Left B matrix:
	BMat_L(1:5,1:5) = transpose(reshape( &
			  & (/uyL,dL,0.d0,0.d0,0.d0, &
			  & 0.d0,uyL,0.d0,0.d0,0.d0, &
			  & 0.d0,0.d0,uyL,0.d0,(1.d0/dL), &
			  & 0.d0,0.d0,0.d0,uyL,0.d0, &
			  & 0.d0,0.d0,gam*pL,0.d0,uyL/),shape(BMat_L)))
! RIGHT B matrix:
	BMat_R(1:5,1:5) = transpose(reshape( &
			  & (/uyR,dR,0.d0,0.d0,0.d0, &
			  & 0.d0,uyR,0.d0,0.d0,0.d0, &
			  & 0.d0,0.d0,uyR,0.d0,(1.d0/dR), &
			  & 0.d0,0.d0,0.d0,uyR,0.d0, &
			  & 0.d0,0.d0,gam*pR,0.d0,uyR/),shape(BMat_R)))
! Left C matrix:
	CMat_L(1:5,1:5) = transpose(reshape( &
			  & (/uzL,dL,0.d0,0.d0,0.d0, &
			  & 0.d0,uzL,0.d0,0.d0,0.d0, &
			  & 0.d0,0.d0,uzL,0.d0,0.d0, &
			  & 0.d0,0.d0,0.d0,uzL,(1.d0/dL), &
			  & 0.d0,0.d0,0.d0,gam*pL,uzL/),shape(CMat_L)))
! Left C matrix:
	CMat_R(1:5,1:5) = transpose(reshape( &
			  & (/uzR,dR,0.d0,0.d0,0.d0, &
			  & 0.d0,uzR,0.d0,0.d0,0.d0, &
			  & 0.d0,0.d0,uzR,0.d0,0.d0, &
			  & 0.d0,0.d0,0.d0,uzR,(1.d0/dR), &
			  & 0.d0,0.d0,0.d0,gam*pR,uzR/),shape(CMat_R)))

!-------------------------------------------------------------------------------
!# 			Predict forward by one half-timestep:
!-------------------------------------------------------------------------------
! LEFT predictions of quantities by half-timestep:

	h=1
	Do while (h<=5)								!Scrolls over each row updating each seperately. This allows for the dot_product function to be used.
		W_L(h) = W_L(h) - delta_t*0.5d0*( &
			& (AMat_L(h,1)*W_x_L(1)+AMat_L(h,2)*W_x_L(2) + &
			& AMat_L(h,3)*W_x_L(3)+AMat_L(h,4)*W_x_L(4) + &
			& AMat_L(h,5)*W_x_L(5)) + &
			& (BMat_L(h,1)*W_y_L(1)+BMat_L(h,2)*W_y_L(2) + &
			& BMat_L(h,3)*W_y_L(3)+BMat_L(h,4)*W_y_L(4) + &
			& BMat_L(h,3)*W_y_L(3)) + &
			& (CMat_L(h,1)*W_z_L(1)+CMat_L(h,2)*W_z_L(2) + &
			& CMat_L(h,3)*W_z_L(3)+CMat_L(h,4)*W_z_L(4) + &
			& CMat_L(h,5)*W_z_L(5)))

!		W_L(h) = W_L(h) - delta_t*0.5d0*(&
!			& dot_product(AMat_L(h,1:5),W_x_L(1:5)) + &
!			& dot_product(BMat_L(h,1:5),W_y_L(1:5)) + &
!			& dot_product(CMat_L(h,1:5),W_z_L(1:5)))
		h=h+1
	enddo

! RIGHT predictions of quantities by half-timestep:
	h=1
	Do while (h<=5)
		W_R(h) = W_R(h) - delta_t*0.5d0*( &
			& (AMat_R(h,1)*W_x_R(1)+AMat_R(h,2)*W_x_R(2) + &
			& AMat_R(h,3)*W_x_R(3)+AMat_R(h,4)*W_x_R(4) + &
			& AMat_R(h,5)*W_x_R(5)) + &
			& (BMat_R(h,1)*W_y_R(1)+BMat_R(h,2)*W_y_R(2) + &
			& BMat_R(h,3)*W_y_R(3)+BMat_R(h,4)*W_y_R(4) + &
			& BMat_R(h,5)*W_y_R(5)) + &
			& (CMat_R(h,1)*W_z_R(1)+CMat_R(h,2)*W_z_R(2) + &
			& CMat_R(h,3)*W_z_R(3)+CMat_R(h,4)*W_z_R(4) + &
			& CMat_R(h,5)*W_z_R(5)))

!		W_R(h) = W_R(h) - delta_t*0.5d0*(&
!			& dot_product(AMat_R(h,1:5),W_x_R(1:5)) + &
!			& dot_product(BMat_R(h,1:5),W_y_R(1:5)) + &
!			& dot_product(CMat_R(h,1:5),W_z_R(1:5)))
		h=h+1
	enddo

!-------------------------------------------------------------------------------
!#				Update cells:
!-------------------------------------------------------------------------------

!		Left values:
!			Rho=:
		dLsol = W_L(1)
!			Velocity:
		uLvec(1:3) = (/W_L(2),W_L(3),W_L(4)/)
!			Pressure (p)=:
		pLsol = W_L(5)
!
!		Right values:
!			Rho=:
		dRsol = W_R(1)
!			Velocity:
		uRvec(1:3) = (/W_R(2),W_R(3),W_R(4)/)
!			Pressure (p)=:
		pRsol = W_R(5)

!	Check for unphysical values:
	error_loc="extr"
	call error_sub(0,error_loc,NcXr,NcYr,NcZr,gam,1.d0,1.d0,cellVol,W_L(5),W_R(5),W_L(1),W_R(1),iL,jL,kL,time)

end subroutine extrapolate_calc


      SUBROUTINE JULCAL(MONTH,IDAY,IYEAR,JDAY)
!     JULCAL CALCULATES AND RETURNS THE CALENDAR DATE GIVEN THE JULIAN DAY AND
!  YEAR.  LEAP YEARS ARE ACCOUNTED FOR.
!
!  ARGUMENTS:
!    MONTH  - THE MONTH OF THE YEAR CALCULATED (AND RETURNED) BY JULCAL.
!    IDAY   - THE DAY OF THE MONTH CALCULATED (AND RETURNED) BY JULCAL.
!    IYEAR  - THE YEAR OF THE JULIAN DAY TO BE CONVERTED.
!    JDAY   - THE JULIAN DAY TO BE CONVERTED.
!
!  CONVERTED FROM THE IBM1800 SYSTEM BY PAUL HENKART, SCRIPPS INSTITUTION OF
!  OCEANOGRAPHY, 28 OCTOBER 1980
!
      DIMENSION MTHDY(12)
      DATA MTHDY/31,28,31,30,31,30,31,31,30,31,30,31/
!
      ISUM=0
!
!     CHECK FOR LEAP YEAR
!
!      IF(IYEAR-IYEAR/4*4)2,1,2
      IF(IYEAR-IYEAR/4*4 .EQ. 0 ) MTHDY(2)=29
!
!     SUM DAYS/ MONTH
!
2     DO 3 I=1,12
      ISUM=ISUM+MTHDY(I)
      ii = i
!
!     COMPARE AGAINST JULIAN DAY
!
!      IF(ISUM-JDAY) 3,4,4
      IF(ISUM-JDAY .GE. 0 ) GOTO 4
3     CONTINUE
!
!     JULIAN DAY FALLS WITHIN MONTH I, SO SUBTRACT OUT MONTH I FOR DATE
!
4     MONTH=II
      IDAY=JDAY+MTHDY(II)-ISUM
!
!     RESET LEAP YEAR COUNT
!
      MTHDY(2)=28
      RETURN
      END


C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Birkbeck College. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Birkbeck College are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 1993 Oliver Smart & Birkbeck College, All rights reserved    *
C * (c) 1996 Oliver Smart & Birkbeck College, All rights reserved    *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date	Author		Modification
C 12/93	O.S. Smart	Original public release in HOLE suite beta1.0
C 05/94 O.S. Smart      s/r MATI22 added
C
C
C contains small s/r's concerned with vectors
      SUBROUTINE CROSS(F,G,H)
      IMPLICIT NONE
      REAL
     1        F(3),
     1        G(3),
     1        H(3)
      H(1) = F(2)*G(3) - F(3)*G(2)
      H(2) = F(3)*G(1) - F(1)*G(3)
      H(3) = F(1)*G(2) - F(2)*G(1)
      RETURN
      END
C
      REAL FUNCTION CROSSF(F,G,I1)
      IMPLICIT NONE
      REAL
     1        F(3),
     1        G(3)
      INTEGER
     1	      I1,
     1	      I2,
     1	      I3
      I2 = (I1 + 1) - 3*INT(I1/3)
      I3 = (I2 + 1) - 3*INT(I2/3)
      CROSSF = F(I2)*G(I3) - F(I3)*G(I2)
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION dCROS2(F,G,I1)
      IMPLICIT NONE
      DOUBLE PRECISION
     1        F(3),
     1        G(3)
      INTEGER
     1        I1,
     1        I2,
     1        I3
      I2 = (I1 + 1) - 3*INT(I1/3)
      I3 = (I2 + 1) - 3*INT(I2/3)
      dCROS2 = F(I2)*G(I3) - F(I3)*G(I2)
      RETURN
      END
C
      SUBROUTINE dCROSS(F,G,H)
      IMPLICIT NONE
      DOUBLE PRECISION
     1        F(3),
     1        G(3),
     1        H(3)
      H(1) = F(2)*G(3) - F(3)*G(2)
      H(2) = F(3)*G(1) - F(1)*G(3)
      H(3) = F(1)*G(2) - F(2)*G(1)
      RETURN
      END
C
      SUBROUTINE DOT(F,G,H)
      IMPLICIT NONE
      REAL
     1      F(3),
     1      G(3),
     1      H
      H = F(1)*G(1) + F(2)*G(2) + F(3)*G(3)
      RETURN
      END
C
      SUBROUTINE dDOT(F,G,H)
      IMPLICIT NONE
      DOUBLE PRECISION
     1      F(3),
     1      G(3),
     1      H
      H = F(1)*G(1) + F(2)*G(2) + F(3)*G(3)
      RETURN
      END
C
      SUBROUTINE DET3( MAT3, DET)
      IMPLICIT NONE
C work out the determinant of a 3*3 matrix MAT3
      REAL			MAT3(3,3), DET

      DET = MAT3(1,1)*(MAT3(2,2)*MAT3(3,3)-MAT3(2,3)*MAT3(3,2))
     &     - MAT3(1,2)*(MAT3(2,1)*MAT3(3,3)-MAT3(2,3)*MAT3(3,1))
     &     + MAT3(1,3)*(MAT3(2,1)*MAT3(3,2)-MAT3(2,2)*MAT3(3,1))
      RETURN
      END
C
      SUBROUTINE dUVECT(F,UF,LENF)
      IMPLICIT NONE
C returns unit vector in direction F & its length
      DOUBLE PRECISION
     1           F(3),
     1           UF(3),
     1           LENF
      INTEGER    I

      CALL dDOT(F,F,LENF)
      LENF = SQRT(LENF)

      DO 10 I = 1,3
	UF(I) = F(I)/LENF
10    CONTINUE

      RETURN
      END
C
      SUBROUTINE dUVEC2(F)
      IMPLICIT NONE
C returns unit vector in direction F
      DOUBLE PRECISION
     1           F(3),
     1		 LENF
      INTEGER    I

      CALL dDOT(F,F,LENF)
      LENF = SQRT(LENF)

      DO 10 I = 1,3
	F(I) = F(I)/LENF
10    CONTINUE

      RETURN
      END
C
      SUBROUTINE UVECT(F,UF,LENF)
      IMPLICIT NONE
C returns unit vector in direction F & its length
      REAL
     1      	 F(3),
     1     	 UF(3),
     1     	 LENF
      INTEGER 	 I

      CALL DOT(F,F,LENF)
      LENF = SQRT(LENF)

      DO 10 I = 1,3
        UF(I) = F(I)/LENF
10    CONTINUE

      RETURN
      END
C
      SUBROUTINE dUVECT2(F)
      IMPLICIT NONE
C returns unit vector in direction F
      DOUBLE PRECISION
     1           F(3),
     1           LENF
      INTEGER    I

      CALL dDOT(F,F,LENF)
      LENF = SQRT(LENF)

      DO 10 I = 1,3
        F(I) = F(I)/LENF
10    CONTINUE

      RETURN
      END

      SUBROUTINE UVECT2(F)
      IMPLICIT NONE
C returns unit vector in direction F
      REAL
     1      	 F(3),
     1     	 LENF
      INTEGER 	 I

      CALL DOT(F,F,LENF)
      LENF = SQRT(LENF)

      DO 10 I = 1,3
        F(I) = F(I)/LENF
10    CONTINUE

      RETURN
      END

      SUBROUTINE MATI22( MAT, NOUT, LERR)
      IMPLICIT NONE
C this s/r inverts a 2*2 matrix
C (c) May 1994 Oliver Smart
      DOUBLE PRECISION 			MAT(2,2), SWAP, DET
C if a matrix with a determinant of zero is supplied
C then an error is written to nout and lerr is returned true
      INTEGER				NOUT
      LOGICAL				LERR

C end of decs **************************

C work out determinant
      DET = MAT(1,1)*MAT(2,2) - MAT(1,2)*MAT(2,1)
      IF (DET.EQ.0.) THEN
        WRITE( NOUT, '(A/A/2F12.5/2F12.5)')
     &' ERROR detected in s/r MATI22 (invert a 2*2 matrix)',
     &' Supplied with matrix having a determinant of zero: ',
     & MAT
        LERR = .TRUE.
        GOTO 55555
      ENDIF

C swap left hand diagonal
      SWAP = MAT(1,1)/DET
      MAT(1,1) = MAT(2,2)/DET
      MAT(2,2) = SWAP

C change sign of right
      MAT(2,1) = -MAT(2,1)/DET
      MAT(1,2) = -MAT(1,2)/DET

55555 RETURN
      END


!-------------------------------------------------------------------
!  spinglass_qa.f: quantum annealing by the path-integral monte carlo method
!
!       by tanaka tomoya, Kobe University.
!-------------------------------------------------------------------

program qa
  use field_m
  use constants_m
  use calc_energ_m
  implicit none

  !=========parameter　declarelation========
  !---------parameter for spinglass and general---------
  ! i : 汎用イテレーター, tmp : 汎用一時変数, count : 汎用カウンタ
  integer(DI) :: i, tmp, count
  ! tau : モンテカルロステップ数
  integer(DI) :: tau
  ! n : 1スライスにおけるサイト数
  integer(SI) :: n
  !x:サイトのx座標, y:サイトのy座標
  integer(SI) :: x, y
  ! spin_old(i,:,:): i番目のトロッタースライスの遷移前の状態
  ! spin_new(i,:,:): i番目のトロッタースライスの遷移後の状態
  integer(SI), allocatable, dimension(:,:,:) :: spin_old, spin_new
  ! energ_old(i,:) : i番目のスライスの遷移前のエネルギー
  ! energ_new(i,:) : i番目のスライスの遷移後のエネルギー
  real(DR), allocatable :: energ_old(:), energ_new(:)
  ! energ_old_qa : 遷移前の合計エネルギー, energ_new_qa : 遷移後の合計エネルギ-
  ! energ_delta : 遷移前から遷移後のエネルギー差
  real(DR) :: energ_old_qa, energ_new_qa, energ_delta
  ! j_couple : カップリング
  real(DR), dimension(:,:,:,:), allocatable :: j_couple
  ! p: 反転させる確率, p_base : p>p_baseであるときに反転させる
  real(DR) :: prob, prob_base
  ! site_x, site_y : 反転させるサイトのx座標, y座標
  integer(SI) :: site_x, site_y

  !--------parameter for qa--------
  ! qa_step : 量子アニーリングステップ数, sa_step : 古典アニーリングステップ数
  integer(DI) :: qa_step
  ! j_tilda : トロッタースライスごとの相互作用におけるカップリング
  real(DR) :: j_tilda
  ! gamma : アニーリング係数
  real(DR) :: gamma, gamma_init
  ! beta : 逆温度
  real(DR) :: beta
  ! m : トロッター数, k : 各スライス
  integer(SI) :: m, k

  !======== initialize ========
  !-------- initialize for io-------
  ! open file
  open(IN, file = "SG_complex.dat", status = 'old')
  open(OUT, file = "../grapher/qa_step.dat", status = 'old', position = "append")

  !-------- parameter for qa(rf. roman martonak et al.)------
  !read m
  print *, 'm(dont set square number for plot)[default :10]'
  !read(*,*) m
  m = 10

  ! set beta
  beta = 10_DR
  ! set gamma_init
  gamma_init = 3_DR

  !-------- parameter set for  spinglass------
  ! set n
  read(IN,*) n

  !-------- parameter set for qa------

  !set initial gamma
  !gamma = gamma_init
  gamma = gamma_init
  ! set qa_step
  qa_step = 1000000 / (n*n)

  print *, 'beta:', beta
  print *, 'initial_gamma:', gamma_init
  print *, 'qa_step:', qa_step

  !-------- initialize --------
  ! set random seed
  call rnd_seed

  ! allocat memorye
  allocate(j_couple(n,n,n,n))
  allocate(spin_old(n,n,m))
  allocate(spin_new(n,n,m))
  allocate(energ_old(m))
  allocate(energ_new(m))

  ! initialize spin of all slice
  call init_sg(spin_old, m, n)

  ! initialize coupling
  call init_coupling(j_couple, n)

  !initialize output file for animation
  tau = -1
  do k = 1, m
    call spndat(tau, spin_old, energ_old, k, m, n)
  end do

  ! initialize energ
  j_tilda = -1 / (2 * beta) * log(tanh(beta * gamma / m))
  energ_old_qa = energ_qa(j_couple, spin_old, j_tilda, m, n)

  !======== Quantumn Annealing ========
  do tau = 1, qa_step
    if(tau > 1) then
      ! remove TMF_term
      energ_old_qa = energ_old_qa - TMF_term(spin_old, j_tilda, m, n)
      ! calculate j_tilda
      j_tilda = -1 / (2 * beta) * log(tanh(beta * gamma / m))
      ! add TMF_term
      energ_old_qa = energ_old_qa + TMF_term(spin_old, j_tilda, m, n)
    end if
    ! calculate energ_old_qa based on j_tilda
    energ_old_qa = energ_qa(j_couple, spin_old, j_tilda, m, n)

    ! mc on each slice
    do k = 1, m
      do x = 1,n
        do y = 1,n
          ! select reversed site
          call choose(site_x, site_y, n)

          ! reverse spin
          call reverse_spin(site_x, site_y, spin_old, spin_new, k, m, n)

          energ_delta = delta_qa(j_couple, spin_new, j_tilda, site_x, site_y, k, m, n)
          energ_new_qa = energ_old_qa + energ_delta

          ! calculate p
          if (energ_delta <= 0) then
            prob = 1
          else
            prob = exp(-(beta) * energ_delta)
          end if

          ! update sg based on probability p
          call random_number(prob_base)

          if (prob >= prob_base) then
            spin_old = spin_new
            energ_old_qa = energ_new_qa
          end if
        end do
      end do
    end do

    count = 0
    if(mod(tau, DIV) == 0) then

      do k =  1, m
        energ_old(k) = energ_sa(j_couple, spin_old, k, m, n)
      end do
      print *, "j_tilda : ", j_tilda
      print *, "qa_step : ", tau
      do k = 1, m
        if (k < m .and. abs(energ_old(k) - energ_old(k + 1)) .le. EPS*1e-4) then
          count = count + 1
        end if
        print *, beta, gamma, energ_old(k)
        call spndat(tau / DIV, spin_old, energ_old, k, m, n)
      end do

    end if

    if(count .ge. m - 1) then
      exit
    end if

    !update gamma
    gamma = gamma_init*0.995**tau

  end do

  open(1000, file = "result.dat", status = "old", position = "append")
  write(1000, '(f12.5)') minval(energ_old)
  close(1000)

  write(OUT, '(a, i0)') 'qa_step=', tau/DIV
  deallocate(j_couple)
  deallocate(spin_old, spin_new)
  deallocate(energ_old, energ_new)
  close(OUT)

end program qa


C
C $Id: tdprpi.f,v 1.5 2008-07-27 00:17:33 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE TDPRPI (XI2D,YI2D,XIPA,YIPA)
C
C This routine, given the projected coordinates of a point (XI2D,YI2D),
C returns, in XIPA and YIPA, the X and Y coordinates of the point, in
C the parallelogram defined by the last call to TDPARA, that projected
C into (XI2D,YI2D).
C
C The variables in the following common block define the mapping from
C 3-space to 2-space.
C
        COMMON /TDCOM1/ IH,IT,XM,YM,ZM,XO,YO,ZO,XT,YT,ZT,OE,XE,YE,ZE
        COMMON /TDCOM1/ A1,B1,C1,D1,E1,A2,B2,C2,D2,E2,A3,B3,C3,D3,E3
        COMMON /TDCOM1/ IS,FV,VL,VR,VB,VT,WL,WR,WB,WT
        SAVE   /TDCOM1/
C
C The variables in the following common block define the parallelogram.
C
        COMMON /TDCOM2/ XACP,YACP,ZACP,XCDX,YCDX,ZCDX,XCDY,YCDY,ZCDY
        SAVE   /TDCOM2/
C
C Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
        CALL TDBLDA
C
C Check for an uncleared prior error.
C
        IF (ICFELL('TDPRPI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C What's involved is just algebra.
C
        F2=E2-XI2D
        F3=E3-YI2D
C
        A12=A2-F2*A1/E1
        B12=B2-F2*B1/E1
        C12=C2-F2*C1/E1
C
        A13=A3-F3*A1/E1
        B13=B3-F3*B1/E1
        C13=C3-F3*C1/E1
C
        P1=A12*XCDX+B12*YCDX+C12*ZCDX
        Q1=A12*XCDY+B12*YCDY+C12*ZCDY
        R1=A12*(XACP-XE)+B12*(YACP-YE)+C12*(ZACP-ZE)
C
        P2=A13*XCDX+B13*YCDX+C13*ZCDX
        Q2=A13*XCDY+B13*YCDY+C13*ZCDY
        R2=A13*(XACP-XE)+B13*(YACP-YE)+C13*(ZACP-ZE)
C
        XIPA=(Q1*R2-Q2*R1)/(P1*Q2-P2*Q1)
        YIPA=(P2*R1-P1*R2)/(P1*Q2-P2*Q1)
C
C Done.
C
        RETURN
C
      END


program datastructures
    use, intrinsic :: iso_fortran_env
    use primes
    use sha1Module
    use rsaModule
    implicit none

    print *, "isPrime(67)"
    print *, isPrime(67_int8)

    print *, "primesUpTo(255)"
    print *, primesUpTo(255_int32)

    print *, "message"
    print *, SHA1("message")

    print *, ""
    print *, SHA1("")

    print *, 0_int64
    print *, SHA1(0_int64)

    print *, 700_int64
    print *, SHA1(700_int64)

    print *, rsaGenerateKeys()
 end program datastructures


PROGRAM test
  use mzprojection, only : mzprojection_ensemble_of_time_series, &
                           mzprojection_long_time_series
  implicit none
  integer, parameter ::    nrec = 10001 ! Total record number
  integer, parameter ::    ista = 2000  ! Start record number for sampling
  integer, parameter :: nperiod = 500   ! Length of a sample
  integer, parameter ::  nshift = 1     ! Length of time shift while sampling
  real(kind=8) :: delta_t               ! Time step size

  real(kind=8) :: time(0:nrec-1)
  complex(kind=8), dimension(0:nrec-1) :: u_raw, dudt_raw, f_raw, s_raw, r_raw
  complex(kind=8) :: omega, memoryf(0:nperiod-1)
  complex(kind=8), dimension(0:nperiod-1) :: uu, ududt, fdudt, rr, rdudt, ru, fu, ff
  real(kind=8) :: temp(1:7)
  complex(kind=8), parameter :: ci = (0.d0, 1.d0)
  integer :: irec, iperiod
  !integer, parameter :: nsample = (nrec-ista-nperiod)/nshift + 1
  !complex(kind=8), dimension(0:nsample-1,0:nperiod-1) :: u, dudt, f, s, r
  !integer :: isample

    != Read sample data =
    open(10,file="../sample_data/sample_time_series.dat",status="old",action="read")
      read(10,*)
      read(10,*)
      read(10,*)
      read(10,*)
      read(10,*)
      do irec = 0, nrec-1
        read(10,"(99g17.7e3)") temp(1:7)
            time(irec) = temp(1)
           u_raw(irec) = temp(2) + ci * temp(3)
        dudt_raw(irec) = temp(4) + ci * temp(5)
           f_raw(irec) = temp(6) + ci * temp(7)
      end do
    close(10)

    != Evaluate Mori-Zwanzig projection of f(t) on u(t) =
    delta_t = time(1) - time(0)
    call mzprojection_long_time_series(             &
             nrec, ista, nperiod, nshift, delta_t,  &
             u_raw, dudt_raw, f_raw,                &
             omega, memoryf, s_raw, r_raw,          &
             uu, ududt, fdudt, rr, rdudt, ru, fu, ff)

    !!= Evaluate Mori-Zwanzig projection of f(t) on u(t) =
    !delta_t = time(1) - time(0)
    !do iperiod = 0, nperiod-1
    !  do isample = 0, nsample-1
    !    irec = ista + nshift * isample + iperiod
    !    u(isample,iperiod) = u_raw(irec)
    !    dudt(isample,iperiod) = dudt_raw(irec)
    !    f(isample,iperiod) = f_raw(irec)
    !  end do
    !end do
    !call mzprojection_ensemble_of_time_series(      &
    !         nsample, nperiod, delta_t,             &
    !         u, dudt, f,                            &
    !         omega, memoryf, s, r,                  &
    !         uu, ududt, fdudt, rr, rdudt, ru, fu, ff)

    != Output results =
    open(10,file="./out_timeevolution.dat")
      do irec = 0, nrec-1
        write(10,"(99g17.7e3)") time(irec),         &
             dble(u_raw(irec)), aimag(u_raw(irec)), & ! u(t)
             dble(dudt_raw(irec)), aimag(dudt_raw(irec)), & ! du/dt(t)
             dble(f_raw(irec)), aimag(f_raw(irec)), & ! f = Omega*u(t) + s(t) + r(t)
             dble(omega*u_raw(irec)), aimag(omega*u_raw(irec)), & ! omega*u(t)
             dble(s_raw(irec)), aimag(s_raw(irec)), & ! Memory term s(t) = - int Gamma(s)*u(t-s) ds
             dble(r_raw(irec)), aimag(r_raw(irec))    ! Noise term r(t)
      end do
    close(10)
    open(10,file="./out_correlation.dat")
      do iperiod = 0, nperiod-1
        write(10,"(99g17.7e3)") time(iperiod),      &
             dble(uu(iperiod)), aimag(uu(iperiod)), & ! <u(t)u*>
             dble(fu(iperiod)), aimag(fu(iperiod)), & ! <f(t)u*>
             dble(ududt(iperiod)), aimag(ududt(iperiod)), & ! <u(t)du*dt>
             dble(fdudt(iperiod)), aimag(fdudt(iperiod))    ! <f(t)du*dt>
      end do
    close(10)
    open(10,file="./out_check_memoryfunc.dat")
      do iperiod = 0, nperiod-1
        write(10,"(99g17.7e3)") time(iperiod),      &
             dble(memoryf(iperiod)), aimag(memoryf(iperiod)),   & ! Memory function Gamma(t)
             dble(rr(iperiod)/uu(0)), aimag(rr(iperiod)/uu(0)), & ! <r(t)r*>/<uu*>
             dble(rdudt(iperiod)/uu(0)), aimag(rdudt(iperiod)/uu(0)) ! <r(t)dudt*>/<uu*>
      end do
    close(10)
    open(10,file="./out_check_r.dat")
      do iperiod = 0, nperiod-1
        write(10,"(99g17.7e3)") time(iperiod),      &
             dble(rr(iperiod)), aimag(rr(iperiod)), & ! <r(t)r*>
             dble(ru(iperiod)/sqrt(rr(0)*uu(0))), aimag(ru(iperiod)/sqrt(rr(0)*uu(0))), & ! <r(t)u*> normalized
             dble(fu(iperiod)/sqrt(ff(0)*uu(0))), aimag(fu(iperiod)/sqrt(ff(0)*uu(0)))    ! <f(t)u*> normalized
      end do
    close(10)

    write(*,*) omega

END PROGRAM test


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompDrivingForce.f90
    !> \brief   Compute the driving force of all pure condensed phases.
    !> \author  M.H.A. Piro
    !> \date    Apr. 26, 2012
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   04/26/2012      M.H.A. Piro         Original code
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the driving force of all pure condensed phases in
    !! the database.  The driving force is defined as the difference between the standard molar Gibbs energy of
    !! a pure condensed phase and the corresponding value computed from the element potentials.  This value is
    !! used to determine whether a pure condensed phase should be added to the system.  For a more thorough
    !! explanation of the chemical significance of the driving force, refer to the following literature:
    !!
    !! H.L. Lukas, S.G. Fries, B. Sundman, Computational Thermodynamics - The Calphad Method, Cambridge
    !! University Press, New York, 2007.
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[out]  iMaxDrivingForce    An integer scalar representing the index of the pure condensed phase
    !!                                   with the maximum driving force.  A value of zero is returned by default.
    !> \param[out]  dMaxDrivingForce    A double real scalar representing the maximum driving force of all pure
    !!                                   condensed phases.  A value of zero is returned by default.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompDrivingForce(iMaxDrivingForce,dMaxDrivingForce)

    USE ModuleThermo
    USE ModuleGEMSolver

    implicit none

    integer :: i, j, iMaxDrivingForce
    real(8) :: dTemp, dMaxDrivingForce

    ! Initialize variables:
    iMaxDrivingForce = 0
    dMaxDrivingForce = 0D0

    ! Loop through all pure condensed phases:
    do i = nSpeciesPhase(nSolnPhasesSys) + 1, nSpecies - nDummySpecies

        ! Compute the chemical potential of this phase as defined by the element potentials:
        dTemp = 0D0
        do j = 1, nElements
            dTemp = dTemp + dElementPotential(j) * dStoichSpecies(i,j)
        end do

        ! Compute the driving force:
        dTemp = dStdGibbsEnergy(i) - dTemp

        ! Normalize per gram-atom:
        dTemp = dTemp / dSpeciesTotalAtoms(i)

        ! Check for most negative value:
        if (dTemp < dMaxDrivingForce) then
            iMaxDrivingForce = i
            dMaxDrivingForce = dTemp
        end if

    end do

    return

end subroutine CompDrivingForce


      subroutine mdot_integral(current_time,isource,istart,iend)
!***********************************************************************
! Copyright 2010 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!**********************************************************************
!
! PURPOSE
!
! To compute the solute that has been introduced into the system by
! integrating the mdor source data.
!
!**********************************************************************
!
! Initial implementation: 22-Nov-10, Programmer: Zora Dash
!
!**********************************************************************

      use commdot, only : n_sources, time_mdot, mdot, end_no_mdot,
     2     mdot_total, mdot_out_file, mdot_out_unit
      use comparttr, only : kdecay

      implicit none

      integer open_file
      integer isource
      integer istart
      integer iend
      integer arraylen
      real*8 current_time
      real*8 time_in
      real*8 :: last_time = 0.
      real*8 tau_in
      real*8 tau_out
      real*8 result
      real*8 integrate_curve
      real*8 r1, r2
      real*8, allocatable :: mdot_last(:,:)

      save last_time, mdot_last

   !****************Begin executable statements here ******************

      if (.not. allocated(mdot_total)) then
         mdot_out_unit = open_file(mdot_out_file, 1, 'unknown')
         if (kdecay .ne. 0.) then
            allocate (mdot_total(n_sources + 1, 2))
            allocate (mdot_last(n_sources + 1, 2))
            write (mdot_out_unit, 200)
         else
            allocate (mdot_total(n_sources + 1, 1))
            allocate (mdot_last(n_sources + 1, 1))
            write (mdot_out_unit, 100)
         end if
         mdot_last = 0.
      end if

!   FOR each source
      if (isource .eq. 1) then
         write (mdot_out_unit, 110) current_time
         mdot_total = 0.
      end if
      arraylen = iend - istart + 1
      tau_in = 0.
      tau_out = current_time
      result = integrate_curve(tau_in, tau_out, current_time,
     2     arraylen, time_mdot(istart:iend), mdot(istart:iend),
     3     0.d0)
      mdot_total(isource, 1) = result
      mdot_total(n_sources + 1, 1) = mdot_total(n_sources + 1, 1) +
     2     mdot_total(isource, 1)
      r1 = mdot_total(isource, 1) - mdot_last(isource, 1)
      if (kdecay .ne. 0.) then
         result = integrate_curve(tau_in, tau_out, current_time,
     2        arraylen, time_mdot(istart:iend), mdot(istart:iend),
     3        kdecay)
         mdot_total(isource, 2) = mdot_total(isource, 1) - result
         mdot_total(n_sources + 1, 2) = mdot_total(n_sources + 1, 2)
     2        + mdot_total(isource, 2)
         r2 = mdot_total(isource, 2) - mdot_last(isource, 2)
         write (mdot_out_unit, 220) isource, r1,
     2        mdot_total(isource, 1), r2, mdot_total(isource, 2), result
      else
         write (mdot_out_unit, 120) isource, r1, mdot_total(isource, 1)
      end if
      if (isource .eq. n_sources) then
         r1 = mdot_total(n_sources + 1, 1) - mdot_last(n_sources + 1, 1)
         if (kdecay .ne. 0.) then
            r2 = mdot_total(n_sources + 1, 2) -
     2           mdot_last(n_sources + 1, 2)
            result = mdot_total(n_sources + 1, 1) -
     2           mdot_total(n_sources + 1, 2)
            write (mdot_out_unit, 230) r1, mdot_total(n_sources + 1, 1),
     2           r2, mdot_total(n_sources + 1, 2), result
         else
            write (mdot_out_unit, 130) r1, mdot_total(n_sources + 1, 1)
         end if
         mdot_last = mdot_total
      end if

 100  format ('variables = "Source #" "Moles Input" "Cumulative Moles"')
 110  format ('zone t = "Time = ', g16.9, 'days"')
 120  format (9x, i7, 2(2x, g16.9))
 130  format ('text t = "Total ', 2(2x, g16.9), '"')
 200  format ('variables = "Source" "Moles Input" "Cumulative Moles" ',
     2    '"Moles Decayed" "Cumulative Decayed" "Cumulative UnDecayed"')
 220  format (9x, i7, 5(2x, g16.9))
 230  format ('text t = "Total ', 5(2x, g16.9), '"')

      end subroutine mdot_integral