      PROGRAM HYCOM_PROFILE_LOCSIG
      IMPLICIT NONE
C
C  hycom_profile_locsig_25t - Usage:  hycom_profile_locsig_25t archv.txt archs.txt [mean]
C
C                 add locally referenced potential density (sigloc)
C                 as two tracers to a HYCOM text profile file
C                 if mean is present, add a vertical mean at the end
C                 version for 25-term equation of state
C
C   archv.txt is assumed to be an HYCOM archive text profile file
C   archs.txt will be the output text profile file, with sigloc and
C   sigloc from dsiglocdt and dsiglocds as tracers
C
C  this version for "serial" Unix systems.
C
C  Alan J. Wallcraft,  Naval Research Laboratory,  December 2006.
C
      INTEGER       IARGC
      INTEGER       NARG
      CHARACTER*240 CARG
C
      CHARACTER*240 CFILEA,CFILEC,CFORMAT
      CHARACTER*240 CLINE
      LOGICAL       LMEAN
      REAL          THK,DEPTH,FLAG,alfadt,betads,ROFF
      REAL*8        THKMN,SM(5),KEMN
      INTEGER       IOS,K,KDM,KI,KK,KP
C
c------------------------------------------------------------------------
      include '../include/stmt_fns_SIGMA0_17term.h'
c------------------------------------------------------------------------
      REAL, ALLOCATABLE :: SI(:,:),P(:)
C
C     READ ARGUMENTS.
C
      NARG = IARGC()
C
      LMEAN = NARG.EQ.3
      IF     (NARG.EQ.2 .OR. LMEAN) THEN
        CALL GETARG(1,CFILEA)
        CALL GETARG(2,CFILEC)
      ELSE
        WRITE(6,*)
     +    'Usage:  hycom_profile_locsig_25t archv.txt archs.txt [mean]'
        CALL EXIT(1)
      ENDIF
C
C     OPEN ALL FILES.
C
      OPEN(UNIT=11, FILE=CFILEA, FORM='FORMATTED', STATUS='OLD',
     +     IOSTAT=IOS)
      IF     (IOS.NE.0) THEN
        WRITE(6,*) 'Error: can''t open ',TRIM(CFILEA)
        WRITE(6,*) 'ios   = ',ios
        CALL EXIT(3)
      ENDIF
      OPEN(UNIT=21, FILE=CFILEC, FORM='FORMATTED', STATUS='NEW',
     +     IOSTAT=IOS)
      IF     (IOS.NE.0) THEN
        WRITE(6,*) 'Error: can''t open ',TRIM(CFILEC)
        WRITE(6,*) 'ios   = ',ios
        CALL EXIT(5)
      ENDIF
C
C     COPY PROFILE HEADER TO OUTPUT.
C
      DO K= 1,99
        READ( 11,'(a)')      CLINE
        IF     (CLINE(1:5).EQ.'#  k ') then
          EXIT
        ENDIF
        WRITE(21,'(a)') TRIM(CLINE)
      ENDDO
C
C     READ THE ISOPYCNAL PROFILE, TO GET KDM.
C
      DO K= 1,99999
        READ(11,'(a)',IOSTAT=IOS) CLINE
        IF     (IOS.NE.0) THEN
          EXIT
        ENDIF
      ENDDO
      KDM = K-1
C
C     RE-READ THE ISOPYCNAL PROFILE.
C
      ALLOCATE( P(KDM+1), SI(KDM,7) )
C
      REWIND(11)
      DO K= 1,99
        READ( 11,'(a)') CLINE
        IF     (CLINE(1:5).EQ.'#  k ') then
          EXIT
        ENDIF
      ENDDO
      P(1) =  0.0
      DO K= 1,KDM
        READ(11,'(a)',IOSTAT=IOS) CLINE
        IF     (IOS.NE.0) THEN
          WRITE(6,*) 'Error: inconsistent input profile'
          CALL EXIT(6)
        ENDIF
        READ(CLINE,*) KI,(SI(K,KK),KK=1,5),THK,DEPTH
        P(K+1) = P(K) + THK
        IF     (THK.EQ.0.0) THEN
          DO KK= 1,5
            SI(K,KK)=SI(K-1,KK)
          ENDDO !kk
        ENDIF
      ENDDO
      CLOSE(11)
C
C     SIGLOC, AS TRACERS
C
      K=1
        SI(K,6) = sigloc(r8(SI(1,3)),
     &                   r8(SI(1,4)),
     &                   r8(9806.0*0.5*(P(1)+P(2))))
        SI(K,7) = SI(1,5)
      DO K= 2,KDM
        SI(K,6) = sigloc(r8(SI(K,3)),
     &                   r8(SI(K,4)),
     &                   r8(9806.0*0.5*(P(K)+P(K+1))))
        alfadt = dsiglocdt(r8(0.5*(SI(K-1,3)+SI(K,3))),
     &                     r8(0.5*(SI(K-1,4)+SI(K,4))),
     &                     r8(9806.0*P(K)))*
     &                         (SI(K-1,3)-SI(K,3))
        betads = dsiglocds(r8(0.5*(SI(K-1,3)+SI(K,3))),
     &                     r8(0.5*(SI(K-1,4)+SI(K,4))),
     &                     r8(9806.0*P(K)))*
     &                         (SI(K-1,4)-SI(K,4))
        SI(K,7) = SI(K-1,7)-alfadt-betads
      ENDDO
C
C     OUTPUT
C
        IF     (.NOT. LMEAN) THEN
          WRITE(CFORMAT,'(a)')
     &      '(3a)'
          WRITE(21,CFORMAT)
     &      '#  k',
     &      '    utot    vtot  p.temp    saln  p.dens',
     &      '    thkns      dpth  tracer  tracer'
C
          WRITE(CFORMAT,'(a)')
     &      '(i4,2f8.2,3f8.4,f9.3,f10.3,2f8.4)'
        ELSE
          WRITE(CFORMAT,'(a)')
     &      '(3a)'
          WRITE(21,CFORMAT)
     &      '#  k',
     &      '    utot    vtot  p.temp    saln  p.dens',
     &      '    thkns      dpth  tracer  tracer            k.e.'
C
          WRITE(CFORMAT,'(a)')
     &      '(i4,2f8.2,3f8.4,f9.3,f10.3,2f8.4,,f16.4)'
        ENDIF
C
        IF     (LMEAN) THEN
          SM(1:7) = 0.d0
          THKMN   = 0.d0
           KEMN   = 0.d0
        ENDIF
        DO K= 1,KDM
          THK = P(K+1) - P(K)
          IF     (.NOT. LMEAN) THEN
            WRITE(21,CFORMAT)
     &        K,(SI(K,KK),KK=1,5),THK,0.5*(P(K)+P(K+1)),
     &          (SI(K,KK),KK=6,7)
          ELSE !lmean
            SM(1:7) = SM(1:7) + THK*SI(K,1:7)
            THKMN   = THKMN   + THK
            KEMN    =  KEMN   + THK*(1000.0+SI(K,5))*         !density
     &                          0.5*(SI(K,1)**2 + SI(K,2)**2) !u^2+v^2
            WRITE(21,CFORMAT)
     &        K,(SI(K,KK),KK=1,5),THK,0.5*(P(K)+P(K+1)),
     &          (SI(K,KK),KK=6,7),KEMN
          ENDIF
        ENDDO !k
        IF     (LMEAN) THEN
          WRITE(CFORMAT,'(a)')
     &      '(a4,2f8.2,3f8.4,f9.3,f10.3,2f8.4,f16.4)'
          WRITE(21,CFORMAT)
     &      '#SUM',(SM(KK)/THKMN,KK=1,5),THKMN,0.5*THKMN,
     &             (SM(KK)/THKMN,KK=6,7),KEMN
        ENDIF
      CLOSE(21)
      END


!***********************************************************************
!                                                                      *
      INTEGER FUNCTION ITRIG (I1, I2, I3)
!                                                                      *
!   The  triangular delta. Input: Values of 2*J+1; Output: 1, IF J'S   *
!   form a triangle; 0, otherwise.                                     *
!                                           Last update: 09 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:48:47   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: I1
      INTEGER, INTENT(IN) :: I2
      INTEGER, INTENT(IN) :: I3
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I4
!-----------------------------------------------
!
      I4 = I2 - I3
      IF (I1>=ABS(I4) + 1 .AND. I1<=I2+I3-1) THEN
         ITRIG = 1
      ELSE
         ITRIG = 0
      ENDIF
!
      RETURN
      END FUNCTION ITRIG


      subroutine SCDCHI (CHISQ, NU, P, Q, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SCDCHI Krogh  Changes to use M77CON
c>> 1994-08-05 SCDCHI WV Snyder
c
c     Compute the Cumulative Density Function of the Chi-squared
c     distribution for parameter argument CHISQ and NU degrees of
c     freedom.  This is usually denoted P(chi**2 | nu).  This procedure
c     also computes Q(chi**2 | nu) = 1 - P(chi**2 | nu).  CHISQ and NU
c     must both be non-negative, and at most one of them may be zero.
c
      real             CHISQ, NU, P, Q
      integer IERR
c--S replaces "?": ?CDCHI, ?gami
c
      call sgami (0.5e0 * nu, 0.5e0 * chisq, p, q, ierr)
      return
      end


!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
SUBROUTINE calc_laplacianh(wk2,lap_wk)
!$ use omp_lib
use scf_data

implicit none
real(8),intent(in)  :: wk2(iwk2sta(1):iwk2end(1),iwk2sta(2):iwk2end(2),iwk2sta(3):iwk2end(3))
real(8),intent(out) :: lap_wk(iwk3sta(1):iwk3end(1),iwk3sta(2):iwk3end(2),iwk3sta(3):iwk3end(3))
real(8) :: f0,wv
real(8) :: Hinv2(3)
integer :: ix,iy,iz,ist

f0=(1.d0/Hgs(1)**2   &
   +1.d0/Hgs(2)**2   &
   +1.d0/Hgs(3)**2) * cNmat(0,Nd)
Hinv2(1:3)=1.d0/Hgs(1:3)**2

!$OMP parallel do collapse(2) &
!$OMP             firstprivate(Hinv2,f0) &
!$OMP             private(ist,iz,iy,ix,wv)
do iz=iwk3sta(3),iwk3end(3)
do iy=iwk3sta(2),iwk3end(2)

!dir$ vector nontemporal(lap_wk)
  do ix=iwk3sta(1),iwk3end(1)
    wv = 0.d0

    do ist=1,Ndh
      wv = wv + cNmat(ist,Ndh)*( (wk2(ix+ist,iy,iz) + wk2(ix-ist,iy,iz))*Hinv2(1) &
                                +(wk2(ix,iy+ist,iz) + wk2(ix,iy-ist,iz))*Hinv2(2) &
                                +(wk2(ix,iy,iz+ist) + wk2(ix,iy,iz-ist))*Hinv2(3) )
    end do

    lap_wk(ix,iy,iz) = wv + f0 * wk2(ix,iy,iz)
  end do

end do
end do

return

END SUBROUTINE calc_laplacianh


! Listado de commons utilizados, que podrían pasar a un módulo:
!   COMMON /CRIT/TC(nco),PC(nco),DCeos(nco),omg(nco)
!	COMMON /COMPONENTS/ ac(nco),b(nco),delta1(nco),rk(nco),Kij_or_K0,NTDEP
!	COMMON /MODEL/ NMODEL
!	COMMON /rule/ncomb
!	COMMON /bcross/bij(nco,nco)
!	COMMON /Tdep/ Kinf,Tstar   (escalares por ahora, pero esto cambiará)

 program calc_flash

    implicit DOUBLE PRECISION (A-H,O-Z)
    OPEN(1,FILE='flashIN.txt')
    OPEN(2,FILE='flashOUT.txt')
    read(1,*) N
    call readcase(n)
END program

subroutine readcase(n)
    implicit DOUBLE PRECISION (A-H,O-Z)
    PARAMETER (nco=10)
	dimension z(n)

	DOUBLE PRECISION Kinf
        ! pure compound physical constants
        real*8, dimension(n) :: tcn
        real*8, dimension(n) :: pcn
        real*8, dimension(n) :: omgn

        ! eos parameters
        real*8, dimension(n) :: acn  ! in bar*(L/mol)**2
        real*8, dimension(n) :: bn   ! in L/mol
        real*8, dimension(n) :: delta1n  !only required for RKPR
        real*8, dimension(n) :: k_or_mn  ! k for RKPR ; m for SRK/PR

        ! interaction parameters matrices
        real*8, dimension(n,n) :: Kij_or_K0n, Lijn
!        real*8, dimension(n,n), intent(in) :: Tstarn   (scalar in this version)

    ! interaction parameters matrices
    real*8, dimension(nco,nco) :: Kij_or_K0, Lij  ! , Tstar

    real*8, dimension(nco) :: x , y  ! composition of liquid and vapour (molar fractions)

        COMMON /CRIT/TC(nco),PC(nco),DCeos(nco),omg(nco)
	    COMMON /COMPONENTS/ ac(nco),b(nco),delta1(nco),rk_or_m(nco),Kij_or_K0,NTDEP
	    COMMON /rule/ncomb
	    COMMON /bcross/bij(nco,nco)
	    COMMON /Tdep/ Kinf,Tstar    ! (escalares por ahora, pero esto cambiará)
	    COMMON /lforin/lij

        READ(1,*) (z(j),j=1,N)
        read(1,*) T
        read(1,*) P
        read(1,*) nmodel
      if(nmodel<3)then
        call read2PcubicNC(N,1,2)
      else if(nmodel==3)then
        call readRKPRNC(N,1,2)
      end if
      WRITE (2,*)
      write (2,4) (z(i),i=1,n)
 4	FORMAT('Molar fractions: ',10F6.3)
      WRITE (2,*)
      WRITE (2,*) ' T(K)=',T
      WRITE (2,*) ' P(bar)=',P
! Passing values from commons(nco) to input arguments (n)
        TCn = tc(:n)
        PCn = pc(:n)
        OMGn= omg(:n)
        acn = ac(:n)
        bn = b(:n)
        delta1n = delta1(:n)
        k_or_mn = rk_or_m(:n)
        Kij_or_K0n = Kij_or_K0(:n, :n)
        lijn = lij(:n, :n)
      call flash(nmodel, n, z, tcn, pcn, omgn, acn, bn, k_or_mn, delta1n, &
                     Kij_or_K0n, Tstarn, Lijn, t, p, x, y, rho_x, rho_y, beta)
      WRITE (2,*)
      WRITE (2,*) 'Beta (vapor phase fraction)= ',beta
      WRITE (2,*) 'Comp',(i,i=1,N)
      WRITE (2,1) (x(j),j=1,N)
      WRITE (2,2) (y(j),j=1,N)
 1	FORMAT('  x  ', 10E12.4)
 2	FORMAT('  y  ', 10E12.4)
 end subroutine readcase

subroutine flash(model, n, z, tcn, pcn, omgn, acn, bn, k_or_mn, delta1n, &
                     Kij_or_K0n, Tstarn, Lijn, t, p, x, y, rho_x, rho_y, beta)

    implicit DOUBLE PRECISION (A-H,O-Z)
    PARAMETER (nco=10)

        ! M&M means the book by Michelsen and Mollerup, 2nd Edition (2007)

        ! eos id and  number of compounds in the system
        integer, intent(in) :: model, n
	    DOUBLE PRECISION Kinf

        ! composition of the system
        real*8, dimension(n), intent(in) :: z

        ! pure compound physical constants
        real*8, dimension(n), intent(in) :: tcn
        real*8, dimension(n), intent(in) :: pcn
        real*8, dimension(n), intent(in) :: omgn

        ! eos parameters
        real*8, dimension(n), intent(in) :: acn  ! in bar*(L/mol)**2
        real*8, dimension(n), intent(in) :: bn   ! in L/mol
        real*8, dimension(n), intent(in) :: delta1n  !only required for RKPR
        real*8, dimension(n), intent(in) :: k_or_mn  ! k for RKPR ; m for SRK/PR

        ! interaction parameters matrices
        real*8, dimension(n,n), intent(in) :: Kij_or_K0n
!        real*8, dimension(n,n), intent(in) :: Tstarn   (scalar in this version)
        real*8, dimension(n,n), intent(in) :: Lijn

        ! Temperature and Pressure for the flash
        real*8, intent(in) :: t            ! Temperature for the flash (K)
        real*8, intent(in) :: p            ! Pressure for the flash (bar)

        ! Results from flash calculation
        real*8, dimension(n), intent(out) :: x  ! composition of liquid (molar fractions)
        real*8, dimension(n), intent(out) :: y  ! composition of vapour (molar fractions)
        real*8, intent(out) :: rho_x            ! density of liquid (moles/L)
        real*8, intent(out) :: rho_y            ! density of vapour (moles/L)
        real*8, intent(out) :: beta             ! total fraction of vapour (molar base)

        ! Intermediate variables during calculation process
        real*8, dimension(n) :: PHILOGy, PHILOGx
        real*8, dimension(n) :: KFACT, LOG_K, var_K, denom, DLPHIT, DLPHIP
        real*8, dimension(n, n) :: FUGN
        real*8 :: g0, g1  ! function g valuated at beta=0 and 1, based on Wilson K factors
        real*8 :: g, dg, bmin, bmax, Vy, Vx

        real*8, dimension(nco,nco) :: Kij_or_K0  ! , Tstar
        COMMON /CRIT/TC(nco),PC(nco),DCeos(nco),omg(nco)
	    COMMON /COMPONENTS/ ac(nco),b(nco),delta1(nco),rk_or_m(nco),Kij_or_K0,NTDEP
	    COMMON /MODEL/ NMODEL
	    COMMON /rule/ncomb
	    COMMON /bcross/bij(nco,nco)
	    COMMON /Tdep/ Kinf,Tstar

! Charging the commons(nco) from input arguments (n)
        NMODEL = model
        TC(:n) = tcn
        PC(:n) = pcn
        OMG(:n)= omgn
        ac(:n) = acn
        b(:n) = bn
        delta1(:n) = delta1n
        rk_or_m(:n) = k_or_mn
        Kij_or_K0(:n, :n) = Kij_or_K0n
        Kinf = 0.0d0
        ncomb = 0  ! only  vdW combining rules and quadratic mixing rules by  the moment
        Tstar = Tstarn
	! b matrix for Classical or van der Waals combining rules:
		do i=1,n
		    do j=i,n
		        bij(i,j)=(1-lijn(i,j))*(b(i)+b(j))/2
		        bij(j,i)=bij(i,j)
		    end do
		end do
!
        !-----------------------------------------------------------
        ! This algorithm assumes that the specified T and P correspond to
        ! vapor-liquid separation predicted by the provided model (0<beta<1)

        KFACT = (PCn/P) *EXP(5.373*(1+omgn)*(1-TCn/T))
        do while (g0<0.or.g1>0)
            g0 = sum(z*KFACT) - 1.D0
            g1 = 1.D0 - sum(z/KFACT)
            if (g0<0) then
                KFACT = 1.1*KFACT  ! increased volatiliy will bring the solution from subcooled liquid into VLE
            else if (g1>0) then
                KFACT = 0.9*KFACT  ! decreased volatiliy will bring the solution from superheated vapor into VLE
            end if
        end do
        LOG_K = LOG(KFACT)
        ! now we must have  g0>0 and g1<0 and therefore 0<beta<1 (M&M page 252)
        call betalimits (n,z,KFACT,bmin,bmax)
        beta = (bmin+bmax)/2  ! first guess for beta
        ! Succesive sustitution loop starts here
        var_K=1.0
        do while (maxval(abs(var_K)) > 1.d-4)
            ! Newton starts here
            g = 1.0
            do while (abs(g)>1.d-4)
                denom = 1+beta*(KFACT-1.D0)
                g = sum(z*(KFACT-1.D0) / denom)
                dg = -sum(z*(KFACT-1.D0)**2 / denom**2)
                beta = beta - g/dg
            end do
            denom = 1+beta*(KFACT-1.D0)
            y = z * KFACT / denom
            x = y / KFACT
            ! nc,MTYP,INDIC,T,P,rn,V,PHILOG,DLPHI
            call TERMO(n,-1,1,T,P,y,Vy,PHILOGy,DLPHIP,DLPHIT,FUGN)
            call TERMO(n, 1,1,T,P,x,Vx,PHILOGx,DLPHIP,DLPHIT,FUGN)
            var_K = PHILOGx - PHILOGy - LOG_K  ! variation in LOG_K = new - old
            LOG_K = PHILOGx - PHILOGy
            KFACT = exp(LOG_K)
        end do
        rho_x = 1/Vx
        rho_y = 1/Vy
        !-----------------------------------------------------------

        print *, x
 		print *, y
 		print *, rho_x
 		print *, rho_y
 		print *, beta
    end subroutine flash

	subroutine betalimits (n,z,KFACT,bmin,bmax)

      implicit none

        integer, intent(in) :: n  ! number of compounds in the system
        real*8, dimension(n), intent(in) :: z, KFACT  ! composition of the system and K factors
        real*8, intent(out) :: bmin, bmax
        real*8, dimension(n) :: vmin, vmax
        integer :: i, in=0, ix=0

        vmin=0.d0
        vmax=1.d0
        do i=1,n
            if (KFACT(i)*z(i)>1)then
                in = in+1
                vmin(in) = (KFACT(i)*z(i)-1.d0)/(KFACT(i)-1.d0)
            else if (KFACT(i)<z(i))then
                ix = ix+1
                vmax(ix) = (1.d0-z(i))/(1.d0-KFACT(i))
            end if
        end do
        bmin = maxval(vmin)
        bmax = minval(vmax)

    end subroutine betalimits

	subroutine readRKPRNC(nc,nin,nout)
      implicit DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (nco=10,RGAS=0.08314472d0)
!  Critical constants must be given in K and bar
!  b will be in L/mol and ac in bar*(L/mol)**2
	DOUBLE PRECISION Kij(nco,nco),lij(nco,nco),Kinf
!      PARAMETER (A0=0.0017,B0=1.9681,C0=-2.7238)
!      PARAMETER (A1=-2.4407,B1=7.4513,C1=12.504)
	dimension ac(nco),b(nco),del1(nco),rk(nco),diam(nc),vc(nc)
	dimension D(6),Vceos(nc)
      CHARACTER*10 fluid(nco)
!	COMMON/names/fluid
    COMMON/CRIT/TC(nco),PC(nco),DCeos(nco),OM(nco)
	COMMON /COMPONENTS/ ac,b,del1,rk,Kij,NTDEP
!	COMMON /K12/ K12
!	COMMON/COVOL/bb1(nco)
	COMMON /rule/ncomb
	COMMON /bcross/bij(nco,nco)
	COMMON /Tdep/ Kinf,Tstar
	COMMON /lforin/lij
!  D=[0.428363,18.496215,0.338426,0.660,789.723105,2.512392]
	read(NIN,*) ncomb,NTDEP
	do i=1,nc
	READ(NIN,'(A)')fluid(i)
	READ(NIN,*)Tc(i),Pc(i),OM(i),Vceos(i),Zrat
	RT=RGAS*Tc(i)
	Zc=Pc(i)*Vceos(i)/RT
	Zcin=Zc/Zrat
	Vc(i)=Vceos(i)/Zrat
	dceos(i)=1/Vceos(i)
	READ(NIN,*)ac(i),b(i),del1(i),rk(i)
! 4	bb1(i)=b(i)
	write(nout,'(A)')fluid(i)
	write(nout,1)Tc(i),Pc(i),Vc(i),OM(i)
	write(nout,3)Zcin,Zrat,Zc,Vceos(i)
	write(nout,2)ac(i),b(i),del1(i),rk(i)
	Kij(i,i)=0.0D0
	Lij(i,i)=0.0D0857 339 1356
	IF(i.gt.1)then
		if(ncomb.lt.2)then
			READ(NIN,*) (Kij(j,i),j=1,i-1)
			if(NTDEP.ge.1)READ(NIN,*) Kinf
			if(NTDEP.eq.1)READ(NIN,*)Tstar
			READ(NIN,*) (lij(j,i),j=1,i-1)
			lij(i,1:i-1)=lij(1:i-1,i)
		end if
	ENDIF
	end do
!	if(NTDEP.eq.1)Tstar=258.0
!  if(NTDEP.eq.2)READ(NIN,*)Tstar
	write(NOUT,*)
	write(nout,*)'Tc, Pc and Vc are given in K, bar and L/mol respectively'
!	K12=Kij(1,2)
 1	FORMAT('Tc=',F9.4,'   Pc =',F9.4,'   Vc =',F8.4,'   OM =',F7.4)
 3	FORMAT('Zc=',F9.4,' Zcrat=',F9.4,' Zceos=',F8.4,' Vceos=',F7.4)
 2	FORMAT('ac=',F9.4,'    b =',F9.4,'  del1=',F8.4,'    k =',F7.4)
	write(NOUT,*)
	if(ncomb.lt.2)then
		if(NTDEP.EQ.0)then
!  		write(NOUT,*)' K12 = ',Kij(1,2)
!  		write(NOUT,*)
		else
			write(NOUT,*)' K012 = ',Kij(1,2)
			write(NOUT,*)
			write(NOUT,*)' Kinf = ',Kinf
			write(NOUT,*)
			write(NOUT,*)'Tstar = ',Tstar
			write(NOUT,*)
		end if
		write(NOUT,*)'  KIJ MATRIX'
		DO I=1,NC
		write(NOUT,6)FLUID(I),(Kij(j,i),j=1,i-1)
		END DO
		write(NOUT,*)
		write(NOUT,*)'  LIJ MATRIX'
		DO I=1,NC
		write(NOUT,6)FLUID(I),(Lij(j,i),j=1,i-1)
		END DO
	else
		if(NTDEP.EQ.0)then
			write(NOUT,*)' Kijk:     112      122'
			write(NOUT,7)K01,K02
			write(NOUT,*)
		else
			write(NOUT,*)' K0ijk:    112      122'
			write(NOUT,7)K01,K02
			write(NOUT,*)
			write(NOUT,*)'Kinfijk:   112      122'
			write(NOUT,7)Kinf1,Kinf2
			write(NOUT,*)
			write(NOUT,*)'Tstar  :   112      122'
			write(NOUT,8)Tstar1,Tstar2
			write(NOUT,*)
		end if
		if(NTDEP.EQ.2)then
			write(NOUT,*)' Cijk:     112      122'
			write(NOUT,7)C1,C2
			write(NOUT,*)
		end if
		write(NOUT,*)' Lijk:     112      122'
!  	write(NOUT,7)Lijk(1,1,2),Lijk(1,2,2)
		write(NOUT,*)
	end if
	write(NOUT,*)
	write(NOUT,*)' Combining rules:'
	if(ncomb.eq.0)then
	write(NOUT,*)' 0: Classical or van der Waals '
		do i=1,nc
		do j=i,nc
		bij(i,j)=(1-lij(i,j))*(b(i)+b(j))/2
		bij(j,i)=bij(i,j)
		end do
		end do
	else if(ncomb.eq.3)then
	else
	write(NOUT,*)' 1: Lorentz-Berthelot'
		third=1.0d0/3
		do i=1,nc
		diam(i)=b(i)**third
		end do
		do i=1,nc
		do j=i,nc
		bij(i,j)=((1-lij(i,j))*(diam(i)+diam(j))/2)**3
		bij(j,i)=bij(i,j)
		end do
		end do
	end if
 6	FORMAT(A10,4F8.5)
 7	FORMAT(9x,F7.4,2x,F7.4)
 8	FORMAT(9x,F7.2,2x,F7.2)
	end

!  Then Kij values will be called indicating the lower index first, e.g. Kij(1,3)

	subroutine aTder(ac,Tc,rk,T,a,dadT,dadT2)
      implicit DOUBLE PRECISION (A-H,O-Z)
!  Given ac,Tc and the k parameter of the RKPR correlation, as well as the actual T,
!  this subroutine calculates a(T) and its first and second derivatives with T.
	COMMON /MODEL/ NMODEL
	Tr=T/Tc
	IF(NMODEL.LE.2)THEN
		rm=rk
		a=ac*(1+rm*(1-sqrt(Tr)))**2
		dadT=ac*rm*(rm-(rm+1)/sqrt(Tr))/Tc
		dadT2=ac*rm*(rm+1)/(2*Tc**2*Tr**1.5D0)
	ELSE
		a=ac*(3/(2+Tr))**rk
		dadT=-rk*a/Tc/(2+Tr)
		dadT2=-(rk+1)*dadT/Tc/(2+Tr)
	END IF
	end

	subroutine aijTder(NTD,nc,T,aij,daijdT,daijdT2)
      implicit DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (nco=10)
	DOUBLE PRECISION Kinf,Kij0(nco,nco),Kij(nco,nco)
	dimension ai(nc),daidT(nc),daidT2(nc)
	dimension aij(nc,nc),daijdT(nc,nc),daijdT2(nc,nc)
    COMMON /CRIT/TC(nco),PC(nco),DCeos(nco),OM(nco)
	COMMON /COMPONENTS/ ac(nco),b(nco),d1(nco),rk(nco),Kij0,NTDEP
	COMMON /bcross/bij(nco,nco)
	COMMON /rule/ncomb
	COMMON /Tdep/ Kinf,Tstar
	IF(NTDEP.GE.1)THEN
		Kij=0.0D0
		Kij(1,2)=Kinf+Kij0(1,2)*exp(-T/Tstar)
		Kij(2,1)=Kij(1,2)
!  ELSE IF(NTDEP.EQ.2)THEN
!  	Kij=0.0D0
!  	Kij(1,2)=Kij0(1,2)*exp(-T/Tstar)
!  	Kij(2,1)=Kij(1,2)
	ELSE
		Kij=Kij0
	END IF
	DO i=1,nc
	call aTder(ac(i),Tc(i),rk(i),T,ai(i),daidT(i),daidT2(i))
	aij(i,i)=ai(i)
	daijdT(i,i)=daidT(i)
	daijdT2(i,i)=daidT2(i)
	IF (i.gt.1) THEN
	do j=1,i-1
	aij(j,i)=sqrt(ai(i)*ai(j))*(1-Kij(j,i))
	aij(i,j)=aij(j,i)
	if(NTD.EQ.1)then
		daijdT(j,i)=(1-Kij(j,i))*(sqrt(ai(i)/ai(j))*daidT(j)+sqrt(ai(j)/ai(i))*daidT(i))/2
		daijdT(i,j)=daijdT(j,i)
		daijdT2(j,i)=(1-Kij(j,i))*(daidT(j)*daidT(i)/sqrt(ai(i)*ai(j))  &
     		+sqrt(ai(i)/ai(j))*(daidT2(j)-daidT(j)**2/(2*ai(j)))        &
     		+sqrt(ai(j)/ai(i))*(daidT2(i)-daidT(i)**2/(2*ai(i))))/2
		daijdT2(i,j)=daijdT2(j,i)
	end if
	end do
	END IF
	END DO
	if (ncomb.eq.1) then
		DO i=1,nc-1
		DO j=i+1,nc
			barrgij=bij(i,j)/sqrt(b(i)*b(j))
			aij(i,j)=barrgij*aij(i,j)
			aij(j,i)=aij(i,j)
			daijdT(i,j)=barrgij*daijdT(i,j)
			daijdT(j,i)=daijdT(i,j)
			daijdT2(i,j)=barrgij*daijdT2(i,j)
			daijdT2(j,i)=daijdT2(i,j)
		END DO
		END DO
	end if
	IF(NTDEP.ge.1.and.NTD.EQ.1)THEN
		aux=daijdT(1,2)
		ratK=Kij(1,2)/(1-Kij(1,2))/Tstar
		daijdT(1,2)=aux+aij(1,2)*ratK
		daijdT(2,1)=daijdT(1,2)
		daijdT2(1,2)=daijdT2(1,2)+(2*aux-aij(1,2)/Tstar)*ratK
		daijdT2(2,1)=daijdT2(1,2)
	END IF
	end

	subroutine DandTnder(NTD,nco,T,rn,D,dDi,dDiT,dDij,dDdT,dDdT2)
      implicit DOUBLE PRECISION (A-H,O-Z)
!      PARAMETER (nco=2)
	dimension rn(nco),dDiT(nco)
	dimension dDi(nco),dDij(nco,nco)
	dimension aij(nco,nco),daijdT(nco,nco),daijdT2(nco,nco)
	call aijTder(NTD,nc,T,aij,daijdT,daijdT2)
	nc=nco
	D=0.0D0
	dDdT=0.0D0
	dDdT2=0.0D0
	DO i=1,nc
	aux=0.0D0
	aux2=0.0D0
	dDi(i)=0.0D0
	dDiT(i)=0.0D0
	do j=1,nc
	dDi(i)=dDi(i)+2*rn(j)*aij(i,j)
	if(NTD.EQ.1)then
		dDiT(i)=dDiT(i)+2*rn(j)*daijdT(i,j)
		aux2=aux2+rn(j)*daijdT2(i,j)
	end if
	dDij(i,j)=2*aij(i,j)
	aux=aux+rn(j)*aij(i,j)
	end do
	D=D+rn(i)*aux
	if(NTD.EQ.1)then
		dDdT=dDdT+rn(i)*dDiT(i)/2
		dDdT2=dDdT2+rn(i)*aux2
	end if
	END DO
	end

subroutine DELTAnder(nc,rn,D1m,dD1i,dD1ij)
    implicit DOUBLE PRECISION (A-H,O-Z)
    PARAMETER (nco=10)

	DOUBLE PRECISION Kij(nco,nco)

	dimension rn(nc),dD1i(nc),dD1ij(nc,nc)
	COMMON /COMPONENTS/ ac(nco),b(nco),d1(nco),rk(nco),Kij,NTDEP

	D1m=0.0D0

	DO i=1,nc
		D1m=D1m+rn(i)*d1(i)
	END DO

	TOTN = sum(rn)
	D1m=D1m/totn

  	do i=1,nc
  		dD1i(i)=(d1(i)-D1m)/totn
  		do j=1,nc
  			dD1ij(i,j)=(2.0D0*D1m-d1(i)-d1(j))/totn**2
  		end do
  	end do
	end

	subroutine Bnder(nc,rn,Bmix,dBi,dBij)
      implicit DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (nco=10)
	dimension rn(nc),dBi(nc),dBij(nc,nc),aux(nc)
	COMMON /bcross/bij(nco,nco)
	TOTN = sum(rn)
	Bmix=0.0D0
	aux=0.0D0
	DO i=1,nc
		do j=1,nc
			aux(i)=aux(i)+rn(j)*bij(i,j)
		end do
		Bmix=Bmix+rn(i)*aux(i)
	END DO
	Bmix=Bmix/totn
	DO i=1,nc
		dBi(i)=(2*aux(i)-Bmix)/totn
		do j=1,i
			dBij(i,j)=(2*bij(i,j)-dBi(i)-dBi(j))/totn
			dBij(j,i)=dBij(i,j)
		end do
	END DO
	end

	SUBROUTINE HelmRKPR(nco,NDE,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
    IMPLICIT DOUBLE PRECISION (A-H,O-Z)
    PARAMETER (RGAS=0.08314472d0)
	dimension rn(nco),Arn(nco),ArVn(nco),ArTn(nco),Arn2(nco,nco)
	dimension dBi(nco),dBij(nco,nco),dD1i(nco),dD1ij(nco,nco)
	dimension dDi(nco),dDij(nco,nco),dDiT(nco)
	dimension aij(nco,nco),daijdT(nco,nco),daijdT2(nco,nco)
	COMMON /rule/ncomb
	nc=nco
	TOTN = sum(rn)
	call DELTAnder(nc,rn,D1,dD1i,dD1ij)
	D2=(1-D1)/(1+D1)

	if(ncomb.lt.2)then
		call Bnder(nc,rn,Bmix,dBi,dBij)
		call DandTnder(NTD,nc,T,rn,D,dDi,dDiT,dDij,dDdT,dDdT2)
	end if
!  The f's and g's used here are for Ar, not F (reduced Ar)					***********
!  This requires to multiply by R all g, f and its derivatives as defined by Mollerup ****
	f=log((V+D1*Bmix)/(V+D2*Bmix))/Bmix/(D1-D2)
	g=RGAS*log(1-Bmix/V)
	fv=-1/((V+D1*Bmix)*(V+D2*Bmix))
	fB=-(f+V*fv)/Bmix
	gv=RGAS*Bmix/(V*(V-Bmix))
	fv2=(-1/(V+D1*Bmix)**2+1/(V+D2*Bmix)**2)/Bmix/(D1-D2)
	gv2=RGAS*(1/V**2-1/(V-Bmix)**2)
!  DERIVATIVES OF f WITH RESPECT TO DELTA1
	auxD2=(1+2/(1+D1)**2)
	fD1=(1/(V+D1*Bmix)+2/(V+D2*Bmix)/(1+D1)**2)-f*auxD2
	fD1=fD1/(D1-D2)
	fBD1=-(fB*auxD2+D1/(V+D1*Bmix)**2+2*D2/(V+D2*Bmix)**2/(1+D1)**2)
	fBD1=fBD1/(D1-D2)
	fVD1=-(fV*auxD2+1/(V+D1*Bmix)**2+2/(V+D2*Bmix)**2/(1+D1)**2)/(D1-D2)
	fD1D1=4*(f-1/(V+D2*Bmix))/(1+D1)**3+Bmix*(-1/(V+D1*Bmix)**2+ &
			4/(V+D2*Bmix)**2/(1+D1)**4)-2*fD1*(1+2/(1+D1)**2)
	fD1D1=fD1D1/(D1-D2)
!  Reduced Helmholtz Energy and derivatives
	Ar=-TOTN*g*T-D*f
	ArV=-TOTN*gv*T-D*fv
	ArV2=-TOTN*gv2*T-D*fv2

	AUX=RGAS*T/(V-Bmix)
	FFB=TOTN*AUX-D*fB
	FFBV=-TOTN*AUX/(V-Bmix)+D*(2*fv+V*fv2)/Bmix
	FFBB=TOTN*AUX/(V-Bmix)-D*(2*f+4*V*fv+V**2*fv2)/Bmix**2
	do i=1,nc
		Arn(i)=-g*T+FFB*dBi(i)-f*dDi(i)-D*fD1*dD1i(i)
		ArVn(i)=-gv*T+FFBV*dBi(i)-fv*dDi(i)-D*fVD1*dD1i(i)
		IF (NDE.EQ.2) THEN
			do j=1,i
				Arn2(i,j)=AUX*(dBi(i)+dBi(j))-fB*(dBi(i)*dDi(j)+dBi(j)*dDi(i))  &
		     		+FFB*dBij(i,j)+FFBB*dBi(i)*dBi(j)-f*dDij(i,j)
		      	Arn2(i,j)=Arn2(i,j)-D*fBD1*(dBi(i)*dD1i(j)+dBi(j)*dD1i(i))    &
		     		-fD1*(dDi(i)*dD1i(j)+dDi(j)*dD1i(i))        &
		     		-D*fD1*dD1ij(i,j)-D*fD1D1*dD1i(i)*dD1i(j)
				Arn2(j,i)=Arn2(i,j)
			end do
		END IF
	end do

	!  TEMPERATURE DERIVATIVES
	IF (NTD.EQ.1) THEN
		ArT=-TOTN*g-dDdT*f
		ArTV=-TOTN*gv-dDdT*fV
		ArTT=-dDdT2*f
		do i=1,nc
			ArTn(i)=-g+(TOTN*AUX/T-dDdT*fB)*dBi(i)-f*dDiT(i)-dDdT*fD1*dD1i(i)
		end do
	END IF
	continue
end

SUBROUTINE TERMO(nc,MTYP,INDIC,T,P,rn,V,PHILOG,DLPHIP, DLPHIT,FUGN)
!       MTYP        TYPE OF ROOT DESIRED (-1 vapor, 1 liquid, 0 lower Gibbs energy phase)
!       rn		    mixture mole numbers                     (input)
!       t			temperature (k)                          (input)
!       p			pressure    (bar)                        (input)
!       v			volume	    (L)			                 (output)
!       PHILOG    vector of ln(phi(i)*P)                     (output)	INDIC < 5
!       DLPHIT    t-derivative of ln(phi(i)) (const P, n)    (output)	INDIC = 2 or 4
!       DLPHIP    P-derivative of ln(phi(i)) (const T, n)    (output)	INDIC < 5
!       FUGN      comp-derivative of ln(phi(i)) (const t & P)(output)	INDIC > 2
!  ---------------------------------------------------
    implicit none

    integer, intent(in) :: nc, indic
    integer ::  mtyp
    real*8, intent(in) :: t, p
    real*8, intent(out) :: v
    real*8, dimension(nc), intent(out) :: PHILOG, DLPHIT, DLPHIP
    real*8, dimension(nc,nc), intent(out) :: FUGN
	real*8, dimension(nc) :: rn, Arn, ArVn, ArTn,DPDN
	real*8, dimension(nc,nc) :: Arn2

	integer :: maxc, i, k, igz, nder, ntemp
	real*8 :: rgas, dpv, rt, totn, z, Ar, arv, arv2, artv, dpdt
	PARAMETER (MAXC=10,RGAS=0.08314472d0)

	! dimension rn(nc),Arn(nc),ArVn(nc),ArTn(nc),Arn2(nc,nc)

!  The output PHILOG is actually the vector ln(phi(i)*P)
	NTEMP=0
    IGZ=0
    NDER=1
    IF (INDIC.GT.2) NDER=2
    IF (INDIC.EQ.2 .OR. INDIC.EQ.4) NTEMP=1
	TOTN = sum(rn)
	if(P.le.0.0d0)MTYP=1
	CALL VCALC(MTYP,NC,rn,T,P,V)
      RT = RGAS*T
      Z = V/(TOTN*RT)	! this is Z/P

 	call ArVnder(nc,NDER,NTEMP,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)

      DPV = -ArV2-RT*TOTN/V**2
	DPDT = -ArTV+TOTN*RGAS/V
      DO 60 I=1,NC
      PHILOG(I)=-LOG(Z)+Arn(I)/RT
      DPDN(I) = RT/V-ArVn(I)
      DLPHIP(I)=-DPDN(I)/DPV/RT-1.D0/P
	IF(NTEMP.EQ.0) GOTO 60
	DLPHIT(I)=(ArTn(I)-Arn(I)/T)/RT+DPDN(I)*DPDT/DPV/RT+1.D0/T
   60 CONTINUE

    62 IF(NDER.LT.2) GOTO 64
       DO 63 I=1,NC
       DO 61 K=I,NC
       FUGN(I,K)=1.D0/TOTN+(Arn2(I,K)+DPDN(I)*DPDN(K)/DPV)/RT
    61 FUGN(K,I)=FUGN(I,K)
    63 CONTINUE
    64 RETURN

      END

   subroutine PUREFUG_CALC(nc,icomp,T,P,V,phi)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (RGAS=0.08314472d0) !nc=2,
	dimension rn(nc),Arn(nc),ArVn(nc),ArTn(nc),Arn2(nc,nc)
	rn=0.0
	rn(icomp)=1.0
	RT = RGAS*T
      Z = P*V/RT
	call ArVnder(nc,0,0,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
      PHILOG=-LOG(Z)+Arn(icomp)/RT
	phi=exp(PHILOG)
	return
	END

      SUBROUTINE VCALC(ITYP,nc,rn,T,P,V)

!     ROUTINE FOR CALCULATION OF VOLUME, GIVEN PRESSURE

!     INPUT:

!     ITYP:        TYPE OF ROOT DESIRED (-1 vapor, 1 liquid, 0 lower Gibbs energy phase)
!     NC:          NO. OF COMPONENTS
!     rn:          FEED MOLES
!     T:           TEMPERATURE
!     P:           PRESSURE

!     OUTPUT:

!     V:           VOLUME

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (RGAS=0.08314472d0) ! nc=2,
	dimension rn(nc),dBi(nc),dBij(nc,nc)
	dimension Arn(nc),ArVn(nc),ArTn(nc),Arn2(nc,nc)
      LOGICAL FIRST_RUN
	NDER=0
      FIRST_RUN = .TRUE.
	TOTN = sum(rn)
	call Bcalc(nc,rn,T,B)
	CPV=B
      S3R = 1.D0/CPV
      ITER = 0

      ZETMIN = 0.D0
      ZETMAX = 1.D0-0.01*T/500	!.99D0  This is flexible for low T (V very close to B)
      IF (ITYP .GT. 0) THEN
         ZETA = .5D0
         ELSE
!..............IDEAL GAS ESTIMATE
         ZETA = MIN (.5D0,CPV*P/(TOTN*RGAS*T))
      ENDIF
  100 CONTINUE
      V = CPV/ZETA
      ITER = ITER + 1
	call ArVnder(nc,NDER,NTEMP,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
      PCALC = TOTN*RGAS*T/V - ArV
      IF (PCALC .GT. P) THEN
         ZETMAX = ZETA
         ELSE
         ZETMIN = ZETA
      ENDIF
      AT  = (Ar + V*P) /(T*RGAS) - TOTN*LOG(V)
!  AT is something close to Gr(P,T)
      DER = (ArV2*V**2+TOTN*RGAS*T)*S3R  ! this is dPdrho/B
      DEL = -(PCALC-P)/DER
      ZETA = ZETA + MAX (MIN(DEL,0.1D0),-.1D0)
      IF (ZETA .GT. ZETMAX .OR. ZETA .LT. ZETMIN)   &
           ZETA = .5D0*(ZETMAX+ZETMIN)
      IF (ABS(PCALC-P) .LT. 1D-12) GOTO 101
      IF (ABS(DEL) .GT. 1D-10) GOTO 100
 101	IF (ITYP .EQ. 0 ) THEN

! FIRST RUN WAS VAPOUR; RERUN FOR LIQUID

         IF (FIRST_RUN) THEN
            VVAP = V
            AVAP = AT
            FIRST_RUN = .FALSE.
            ZETA = 0.5D0
	      ZETMAX = 1.D0-0.01*T/500
            GOTO 100
            ELSE
            IF (AT .GT. AVAP) V = VVAP
          ENDIF
      ENDIF
      END

	SUBROUTINE ArVnder(nc,NDER,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	dimension rn(nc),Arn(nc),ArVn(nc),ArTn(nc),Arn2(nc,nc)
	COMMON /MODEL/ NMODEL
	IF(NMODEL.LE.2)THEN
!  SRK or PR
	  CALL HelmSRKPR(nc,NDER,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
	ELSE IF (NMODEL.EQ.3) THEN

		CALL HelmRKPR(nc,NDER,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
 	ELSE IF (NMODEL.EQ.4) THEN
!  	CALL HelmPCSAFT(NDER,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
 	ELSE IF (NMODEL.EQ.6) THEN
!  	CALL HelmSPHCT(NDER,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
 	ELSE IF (NMODEL.EQ.8) THEN
! 	  CALL HelmESD  (NDER,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
	ELSE	!	GC-EOS 5 (or GCA 7)
!  	CALL HelmGC(NDER,NTD,rn,V,T,Ar,ArV,ArTV,ArV2,Arn,ArVn,ArTn,Arn2)
	END IF
      END
!
	SUBROUTINE Bcalc(nc,x,T,BMIX)
!  This general subroutine provides the "co-volume" for specified composition,
!  that will be used by Evalsecond or Vcalc
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXC=10,RGAS=0.08314472d0)
	DIMENSION x(nc),dBi(nc),dBij(nc,nc)
!      DIMENSION DD(0:3,MAXC),DDT(0:3,MAXC),DTT(0:3,MAXC),DIA(MAXC),DDB(0:3,MAXC)
	COMMON /MODEL/ NMODEL
!  COMMON/covol/VX(nc)  ! ESD
!      COMMON/MOL/DC(2),D(2),DT(2),HA(2),HB(2)
!      COMMON/MIXT/VCPM,CMIX,CVYM,CVYMT,dCVYM(MAXC),dCMIX(MAXC),
!     *	dCVYMT(MAXC),d2CVYM(MAXC,MAXC),d2CMIX(MAXC,MAXC)
!      COMMON/MIXRULE/NSUB
!      COMMON/BMIX/B
!  COMMON/forB/DDB
!	COMMON/NG/NGR
	COMMON /rule/ncomb
	NG=NGR
	if(NMODEL.EQ.5.OR.NMODEL.EQ.7)then
!  	CALL PARAGC(T,nc,NG,1)
!  	PI=3.1415926536D0
!  	XLAM3=0.0d0
!  	DO 3 I=1,nc
!  	DGC=D(I)
! 3	    XLAM3=XLAM3+X(I)*DGC**3
!  	B=PI/6.D0*XLAM3/1.0D3
	else if(NMODEL.EQ.4)then
!  DD=DDB
!      CALL DIAMET(nc,T,DIA,DD,DDT,DTT,NSUB)
!          B=RGAS*(DD(3,1)*X(1)+DD(3,2)*X(2))	!S3
	else if(NMODEL.EQ.6)then
!  	CALL Mixture_Param(NSUB,NC,X,T)
!  	B=VCPM
	else if(NMODEL.EQ.8)then
!  	B=x(1)*VX(1)+x(2)*VX(2)
	else
	if(ncomb<=2)then
		call Bnder(nc,x,B,dBi,dBij)	! Bmix is used in EVALSECOND
	else
!  	call Bcubicnder(2,x,B,dBi,dBij)
	end if
	end if
	BMIX=B
      END

        !-----------------------------------------------------------
        ! This algorithm assumes that the specified T and P correspond to
        ! vapor-liquid separation predicted by the provided model (0<beta<1)

        KFACT = (PCn/P) *EXP(5.373*(1+omgn)*(1-TCn/T))
        do while (g0<0.or.g1>0)
            g0 = sum(z*KFACT) - 1.D0
            g1 = 1.D0 - sum(z/KFACT)
            if (g0<0) then
                KFACT = 1.1*KFACT  ! increased volatiliy will bring the solution from subcooled liquid into VLE
            else if (g1>0) then
                KFACT = 0.9*KFACT  ! decreased volatiliy will bring the solution from superheated vapor into VLE
            end if
        end do
        LOG_K = LOG(KFACT)
        ! now we must have  g0>0 and g1<0 and therefore 0<beta<1 (M&M page 252)
        call betalimits (n,z,KFACT,bmin,bmax)
        beta = (bmin+bmax)/2  ! first guess for beta
        ! Succesive sustitution loop starts here
        var_K=1.0
        do while (maxval(abs(var_K)) > 1.d-4)
            ! Newton starts here
            g = 1.0
            do while (abs(g)>1.d-4)
                denom = 1+beta*(KFACT-1.D0)
                g = sum(z*(KFACT-1.D0) / denom)
                dg = -sum(z*(KFACT-1.D0)**2 / denom**2)
                beta = beta - g/dg
            end do
            denom = 1+beta*(KFACT-1.D0)
            y = z * KFACT / denom
            x = y / KFACT
            ! nc,MTYP,INDIC,T,P,rn,V,PHILOG,DLPHI
            call TERMO(n,-1,1,T,P,y,Vy,PHILOGy,DLPHIP,DLPHIT,FUGN)
            call TERMO(n, 1,1,T,P,x,Vx,PHILOGx,DLPHIP,DLPHIT,FUGN)
            var_K = PHILOGx - PHILOGy - LOG_K  ! variation in LOG_K = new - old
            LOG_K = PHILOGx - PHILOGy
            KFACT = exp(LOG_K)
        end do
        rho_x = 1/Vx
        rho_y = 1/Vy
        !-----------------------------------------------------------

        print *, x
 		print *, y
 		print *, rho_x
 		print *, rho_y
 		print *, beta
    end subroutine flash

subroutine betalimits (n,z,KFACT,bmin,bmax)

      implicit none

        integer, intent(in) :: n  ! number of compounds in the system
        real*8, dimension(n), intent(in) :: z, KFACT  ! composition of the system and K factors
        real*8, intent(out) :: bmin, bmax
        real*8, dimension(n) :: vmin, vmax
        integer :: i, in=0, ix=0

        vmin=0.d0
        vmax=1.d0

        do i=1,n
            if (KFACT(i)*z(i)>1)then
                in = in+1
                vmin(in) = (KFACT(i)*z(i)-1.d0)/(KFACT(i)-1.d0)
            else if (KFACT(i)<z(i))then
                ix = ix+1
                vmax(ix) = (1.d0-z(i))/(1.d0-KFACT(i))
            end if
        end do

        bmin = maxval(vmin)
        bmax = minval(vmax)

end subroutine betalimits


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

module conv_funcs_module
USE nrtype                                 ! variable types
USE multiconst                             ! fixed parameters (lh vapzn, etc.)
implicit none
private
public::RELHM2SPHM,SPHM2RELHM,WETBULBTMP,satVapPress,vapPress,getLatentHeatValue
contains

! ----------------------------------------------------------------------
! series of functions to convert one thing to another
! (partially courtesy of Drew Slater)
! ----------------------------------------------------------------------

! ***************************************************************************************************************
! public function getLatentHeatValue: get appropriate latent heat of sublimation/vaporization for a given surface
! ***************************************************************************************************************
function getLatentHeatValue(T)
implicit none
real(dp),intent(in)   :: T                    ! temperature (K)
real(dp)              :: getLatentHeatValue   ! latent heat of sublimation/vaporization (J kg-1)
if(T > Tfreeze)then
 getLatentHeatValue = LH_vap     ! latent heat of vaporization          (J kg-1)
else
 getLatentHeatValue = LH_sub     ! latent heat of sublimation           (J kg-1)
end if
end function getLatentHeatValue

! ***************************************************************************************************************
! public function vapPress: convert specific humidity (g g-1) to vapor pressure (Pa)
! ***************************************************************************************************************
function vapPress(q,p)
implicit none
! input
real(dp),intent(in)   :: q        ! specific humidity (g g-1)
real(dp),intent(in)   :: p        ! pressure (Pa)
! output
real(dp)              :: vapPress ! vapor pressure (Pa)
! local
real(dp)              :: w        ! mixing ratio
!real(dp),parameter    :: w_ratio = 0.622_dp ! molecular weight ratio of water to dry air (-)
w = q / (1._dp - q)                ! mixing ratio (-)
vapPress = (w/(w + w_ratio))*p     ! vapor pressure (Pa)
end function vapPress

! ***************************************************************************************************************
! public subroutine satVapPress: Uses Teten's formula to compute saturated vapor pressure (Pa)
! ***************************************************************************************************************
! NOTE: temperature units are degC !!!!
! ***************************************************************************************************************
subroutine satVapPress(TC, SVP, dSVP_dT)
IMPLICIT NONE
! input
real(dp), intent(in)            :: TC       ! temperature (C)
! output
real(dp), intent(out)           :: SVP      ! saturation vapor pressure (Pa)
real(dp), intent(out)           :: dSVP_dT  ! d(SVP)/dT
! local
real(dp), parameter             :: X1 = 17.27_dp
real(dp), parameter             :: X2 = 237.30_dp
! local (use to test derivative calculations)
real(dp),parameter              :: dx = 1.e-8_dp     ! finite difference increment
logical(lgt),parameter          :: testDeriv=.false. ! flag to test the derivative
!---------------------------------------------------------------------------------------------------
! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)

SVP     = SATVPFRZ * EXP( (X1*TC)/(X2 + TC) ) ! Saturated Vapour Press (Pa)
dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2._dp)
if(testDeriv) print*, 'dSVP_dT check... ', SVP, dSVP_dT, (SATVPRESS(TC+dx) - SVP)/dx
END SUBROUTINE satVapPress

! ***************************************************************************************************************
! private function MSLP2AIRP: compute air pressure using mean sea level pressure and elevation
! ***************************************************************************************************************
! (after Shuttleworth, 1993)
!
! -- actually returns MSLP2AIRP in the same units as MSLP, because
!    ( (293.-0.0065*ELEV) / 293. )**5.256 is dimensionless
!
! ***************************************************************************************************************
FUNCTION MSLP2AIRP(MSLP, ELEV)
IMPLICIT NONE

REAL(DP), INTENT(IN)         :: MSLP      ! base pressure (Pa)
REAL(DP), INTENT(IN)         :: ELEV      ! elevation difference from base (m)

REAL(DP)                     :: MSLP2AIRP ! Air pressure (Pa)

MSLP2AIRP = MSLP * ( (293.-0.0065*ELEV) / 293. )**5.256

END FUNCTION MSLP2AIRP

! ***************************************************************************************************************
! private function RLHUM2DEWPT: compute dewpoint temperature from relative humidity
! ***************************************************************************************************************
! ---- This is done with respect to water ONLY ----
!
! All units are SI standard - i.e. Kelvin and pascals
! Based on Tetens' formula (1930)
! ***************************************************************************************************************
FUNCTION RLHUM2DEWPT(T, RLHUM)
! Compute Dewpoint temperature from Relative Humidity
IMPLICIT NONE

REAL(DP), INTENT(IN)         :: T         ! Temperature           (K)
REAL(DP), INTENT(IN)         :: RLHUM     ! Relative Humidity     (%)

REAL(DP)                     :: RLHUM2DEWPT     ! Dewpoint Temp   (K)

REAL(DP)                     :: VPSAT     ! Sat. vapour pressure at T (Pa)
REAL(DP)                     :: TDCEL     ! Dewpoint temp Celcius (C)

! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)
! W_RATIO =       0.622     ! molecular weight ratio of water to dry air (-)

VPSAT = SATVPFRZ * EXP( (17.27*(T-TFREEZE)) / (237.30 + (T-TFREEZE)) ) ! sat vapor press at grid cell (Pa)
TDCEL = 237.30 * LOG( (VPSAT/SATVPFRZ)*(RLHUM/100.) ) / &              ! dewpoint temperature         (C)
        (17.27 - LOG( (VPSAT/SATVPFRZ)*(RLHUM/100.) ) )
RLHUM2DEWPT = TDCEL + TFREEZE

END FUNCTION RLHUM2DEWPT

! ***************************************************************************************************************
! private function DEWPT2RLHUM: compute relative humidity from dewpoint temperature
! ***************************************************************************************************************
! ---- This is done with respect to water ONLY ----
!
! All units are SI standard - i.e. Kelvin and pascals
! Based on Tetens' formula (1930)
! ***************************************************************************************************************
FUNCTION DEWPT2RLHUM(T, DEWPT)
IMPLICIT NONE

REAL(DP), INTENT(IN)         :: T         ! Temperature           (K)
REAL(DP), INTENT(IN)         :: DEWPT     ! Dewpoint temp         (K)

REAL(DP)                     :: DEWPT2RLHUM ! Relative Humidity   (%)

REAL(DP)                     :: VPSAT     ! Sat. vapour pressure at T (Pa)
REAL(DP)                     :: TDCEL     ! Dewpt in celcius      (C)

! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)

TDCEL = DEWPT-TFREEZE
VPSAT = SATVPFRZ * EXP( (17.27*(T-TFREEZE)) / (237.30 + (T-TFREEZE)) )      ! Sat vapor press (Pa)
DEWPT2RLHUM = 100. * (SATVPFRZ/VPSAT) * EXP((17.27*TDCEL)/(237.30+TDCEL))   ! Relative Humidity (%)

END FUNCTION DEWPT2RLHUM

! ***************************************************************************************************************
! private function DEWPT2SPHM: compute specific humidity from dewpoint temperature
! ***************************************************************************************************************
! ---- This is done with respect to water ONLY ----
!
! All units are SI standard - i.e. Kelvin and pascals
! Based on Tetens' formula (1930)
! VPAIR is the current vapor pressure as it used dewpoint to compute staurated VP
! ***************************************************************************************************************
FUNCTION DEWPT2SPHM(DEWPT, PRESS)
IMPLICIT NONE

REAL(DP), INTENT(IN)         :: DEWPT     ! Dewpoint temp         (K)
REAL(DP), INTENT(IN)         :: PRESS     ! Pressure              (Pa)

REAL(DP)                     :: DEWPT2SPHM ! Specific Humidity    (g/g)

REAL(DP)                     :: VPAIR     ! vapour pressure at T  (Pa)
REAL(DP)                     :: TDCEL     ! Dewpt in celcius      (C)

! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)

TDCEL = DEWPT-TFREEZE
VPAIR = SATVPFRZ * EXP( (17.27*TDCEL) / (237.30 + TDCEL) )        ! Vapour Press           (Pa)
DEWPT2SPHM = (VPAIR * W_RATIO)/(PRESS - (1.-W_RATIO)*VPAIR)       ! Specific humidity (g/g)

END FUNCTION DEWPT2SPHM

! ***************************************************************************************************************
! private function DEWPT2VPAIR: compute vapor pressure of air from dewpoint temperature
! ***************************************************************************************************************
! ---- This is done with respect to water ONLY ----
!
! All units are SI standard - i.e. Kelvin and pascals
! Based on Tetens' formula (1930)
! VPAIR is the current vapor pressure as it used dewpoint to compute saturated VP
! ***************************************************************************************************************
FUNCTION DEWPT2VPAIR(DEWPT)
IMPLICIT NONE

REAL(DP), INTENT(IN)         :: DEWPT     ! Dewpoint temp         (K)
REAL(DP)                     :: TDCEL     ! Dewpt in celcius      (C)

REAL(DP)                     :: DEWPT2VPAIR ! Vapour Press  (Pa)

! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)

TDCEL = DEWPT-TFREEZE
DEWPT2VPAIR = SATVPFRZ * EXP( (17.27*TDCEL) / (237.30 + TDCEL) )   ! Vapour Press  (Pa)

END FUNCTION DEWPT2VPAIR

! ***************************************************************************************************************
! public function SPHM2RELHM: compute relative humidity from specific humidity
! ***************************************************************************************************************
! ---- This is done with respect to water ONLY ----
!
! All units are SI standard - i.e. Kelvin and pascals
! Based on Tetens' formula (1930)
! ***************************************************************************************************************
FUNCTION SPHM2RELHM(SPHM, PRESS, TAIR)
IMPLICIT NONE

REAL(DP), INTENT(IN)         :: SPHM      ! Specific Humidity (g/g)
REAL(DP), INTENT(IN)         :: PRESS     ! Pressure              (Pa)
REAL(DP), INTENT(IN)         :: TAIR      ! Air temp

REAL(DP)                     :: SPHM2RELHM ! Dewpoint Temp (K)

REAL(DP)                     :: VPSAT     ! vapour pressure at T  (Pa)
REAL(DP)                     :: TDCEL     ! Dewpt in celcius      (C)
!REAL(DP)                     :: DUM       ! Intermediate

! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)

TDCEL = TAIR-TFREEZE
VPSAT = SATVPFRZ * EXP( (17.27*TDCEL) / (237.30 + TDCEL) )       ! Vapour Press      (Pa)
SPHM2RELHM = (SPHM * PRESS)/(VPSAT * (W_RATIO + SPHM*(1.-W_RATIO)))

END FUNCTION SPHM2RELHM

! ***************************************************************************************************************
! public function RELHM2SPHM: compute specific humidity from relative humidity
! ***************************************************************************************************************
! ---- This is done with respect to water ONLY ----
!
! All units are SI standard - i.e. Kelvin and pascals
! Based on Tetens' formula (1930)
! ***************************************************************************************************************
FUNCTION RELHM2SPHM(RELHM, PRESS, TAIR)
IMPLICIT NONE

REAL(DP), INTENT(IN)         :: RELHM     ! Relative Humidity     (%)
REAL(DP), INTENT(IN)         :: PRESS     ! Pressure              (Pa)
REAL(DP), INTENT(IN)         :: TAIR      ! Air temp

REAL(DP)                     :: RELHM2SPHM ! Specific Humidity (g/g)

REAL(DP)                     :: PVP       ! Partial vapour pressure at T  (Pa)
REAL(DP)                     :: TDCEL     ! Dewpt in celcius      (C)
!REAL(DP)                     :: DUM       ! Intermediate

! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)

TDCEL = TAIR-TFREEZE
PVP = RELHM * SATVPFRZ * EXP( (17.27*TDCEL)/(237.30 + TDCEL) ) ! Partial Vapour Press (Pa)
RELHM2SPHM = (PVP * W_RATIO)/(PRESS - (1. - W_RATIO)*PVP)

END FUNCTION RELHM2SPHM

! ***************************************************************************************************************
! public function WETBULBTMP: compute wet bulb temperature based on humidity and pressure
! ***************************************************************************************************************
FUNCTION WETBULBTMP(TAIR, RELHM, PRESS)
IMPLICIT NONE
! input
REAL(DP), INTENT(IN)         :: TAIR      ! Air temp              (K)
REAL(DP), INTENT(IN)         :: RELHM     ! Relative Humidity     (-)
REAL(DP), INTENT(IN)         :: PRESS     ! Pressure              (Pa)
! output
REAL(DP)                     :: WETBULBTMP ! Wet bulb temperature (K)
! locals
REAL(DP)                     :: Tcel           ! Temperature in celcius      (C)
REAL(DP)                     :: PVP            ! Partial vapor pressure (Pa)
REAL(DP)                     :: TWcel          ! Wet bulb temperature in celcius (C)
REAL(DP),PARAMETER           :: k=6.54E-4_DP   ! normalizing factor in wet bulb estimate (C-1)
REAL(DP)                     :: Twet_trial0    ! trial value for wet bulb temperature (C)
REAL(DP)                     :: Twet_trial1    ! trial value for wet bulb temperature (C)
REAL(DP)                     :: f0,f1          ! function evaluations (C)
REAL(DP)                     :: df_dT          ! derivative (-)
REAL(DP)                     :: TWinc          ! wet bulb temperature increment (C)
INTEGER(I4B)                 :: iter           ! iterattion index
REAL(DP),PARAMETER           :: Xoff=1.E-5_DP  ! finite difference increment (C)
REAL(DP),PARAMETER           :: Xtol=1.E-8_DP  ! convergence tolerance (C)
INTEGER(I4B)                 :: maxiter=15     ! maximum number of iterations
! convert temperature to Celcius
Tcel = TAIR-TFREEZE
! compute partial vapor pressure based on temperature (Pa)
PVP = RELHM * SATVPRESS(Tcel)
! define an initial trial value for wetbulb temperature
TWcel = Tcel - 5._dp
! iterate until convergence
do iter=1,maxiter
 ! compute Twet estimates
 Twet_trial0 = Tcel - (SATVPRESS(TWcel)      - PVP)/(k*PRESS)
 Twet_trial1 = Tcel - (SATVPRESS(TWcel+Xoff) - PVP)/(k*PRESS)
 ! compute function evaluations
 f0 = Twet_trial0 - TWcel
 f1 = Twet_trial1 - (TWcel+Xoff)
 ! compute derivative and iteration increment
 df_dT = (f0 - f1)/Xoff
 TWinc = f0/df_dT
 ! compute new value of wet bulb temperature (C)
 TWcel = TWcel + TWinc
 ! check if achieved tolerance
 if(abs(f0) < Xtol) exit
 ! check convergence
 if(iter==maxiter)stop 'failed to converge in WETBULBTMP'
end do  ! (iterating)

! return value in K
WETBULBTMP = TWcel + TFREEZE

END FUNCTION WETBULBTMP

! ***************************************************************************************************************
! private function SATVPRESS: compute saturated vapor pressure (Pa)
! ***************************************************************************************************************
! Units note :              Pa = N m-2 = kg m-1 s-2
! SATVPFRZ=     610.8       ! Saturation water vapour pressure at 273.16K (Pa)
! ***************************************************************************************************************
FUNCTION SATVPRESS(TCEL)
IMPLICIT NONE
REAL(DP),INTENT(IN) :: TCEL      ! Temperature (C)
REAL(DP)            :: SATVPRESS ! Saturated vapor pressure (Pa)
SATVPRESS = SATVPFRZ * EXP( (17.27_dp*TCEL)/(237.30_dp + TCEL) ) ! Saturated Vapour Press (Pa)
END FUNCTION SATVPRESS

end module conv_funcs_module


! This is the data of LX-17 condensed phase explosive
! taken from:
! Kapila A K , Schwendeman D W , Bdzil J B , et al.
! A study of detonation diffraction in the ignition-and-growth model[J].
! Combustion Theory and Modelling, 2007, 11(5):781-822.
module material_lx17
use EOS_JWL
implicit none
integer,parameter :: material_type = 1
!-------Reactant
double precision :: a_s     = 778.10e11
double precision :: b_s     =-0.05031e11
double precision :: gamma_s = 0.8938d0
double precision :: cv_s    = 2.4870e6
double precision :: r1_s    = 11.3d0
double precision :: r2_s    = 1.13d0
double precision :: rho0_s  = 1905.d0
NAMELIST/material_lx17rtt_params/ a_s, b_s, gamma_s, cv_s, r1_s, &
                                r2_s, rho0_s

!-------Products
double precision :: a_g     = 14.81050e11
double precision :: b_g     = 0.63790e11
double precision :: gamma_g = 0.5d0
double precision :: cv_g    = 1.0e6
double precision :: r1_g    = 6.2d0
double precision :: r2_g    = 2.2d0
double precision :: rho0_g  = 1905.d0
double precision :: q_ref   = 0.069e11
NAMELIST/material_lx17pdt_params/ a_g, b_g, gamma_g, cv_g, r1_g, &
                                  r2_g, rho0_g, q_ref

double precision :: lbd_tol = 1.0e-4, z_tol = 0.2
NAMELIST/material_lx17mixt_params/ lbd_tol, z_tol

!-------Reaction
double precision :: i_r         = 4.0e12
double precision :: b_r         = 0.667d0
double precision :: a_r         = 0.22d0
double precision :: x_r         = 7.0d0
double precision :: c_r         = 0.667d0
double precision :: d_r         = 1.d0
double precision :: y_r         = 3.d0
double precision :: g1_r        = 4500.0e6
double precision :: e_r         = 0.667d0
double precision :: g_r         = 0.667d0
double precision :: z_r         = 1.d0
double precision :: g2_r        = 30.0e6
double precision :: lambda_i_r  = 0.02d0
double precision :: lambda_g1_r = 0.8d0
double precision :: lambda_g2_r = 0.8d0
NAMELIST/material_lx17rtn_params/ i_r, a_r, b_r, x_r, c_r,  &
                                  d_r, y_r, g1_r, e_r, g_r, &
                                  z_r, g2_r, lambda_i_r,    &
                                  lambda_g1_r, lambda_g2_r

logical,private :: if_initialized = .false.

contains
subroutine write_material_lx17_inp(funit)
    implicit none
    integer,intent(in) :: funit
    write(funit,NML=material_lx17rtt_params)
    write(funit,NML=material_lx17pdt_params)
    write(funit,NML=material_lx17mixt_params)
    write(funit,NML=material_lx17rtn_params)
end subroutine write_material_lx17_inp

subroutine initial_material_lx17(funit)
    implicit none
    integer,intent(in) :: funit
    if(.not.if_initialized) then
        read(funit,NML=material_lx17rtt_params)
        read(funit,NML=material_lx17pdt_params)
        read(funit,NML=material_lx17mixt_params)
        read(funit,NML=material_lx17rtn_params)
    endif
end subroutine initial_material_lx17

subroutine scale_material_lx17(rho_rv,u_rv,temp_rv,time_rv, &
                          p_rv,e_rv,l_rv,cv_rv)
    implicit none
    double precision,intent(in) :: rho_rv,u_rv,temp_rv,time_rv, &
                                p_rv,e_rv,l_rv,cv_rv

    if(.not.if_initialized) then
        !-------Reactant
        a_s     = a_s/p_rv
        b_s     = b_s/p_rv
        cv_s    = cv_s/cv_rv
        rho0_s  = rho0_s/rho_rv
        !-------Products
        a_g    = a_g/p_rv
        b_g    = b_g/p_rv
        cv_g   = cv_g/cv_rv
        rho0_g = rho0_g/rho_rv
        q_ref  = q_ref/p_rv

        !-------Reaction
        i_r  = i_r*time_rv
        g1_r = g1_r*((1.0e11/p_rv)**(-y_r))*time_rv
        g2_r = g2_r*((1.0e11/p_rv)**(-z_r))*time_rv

        print*,"scaled LX-17 parameters:"
        print*,"Reactant:",a_s,b_s,cv_s,rho0_s
        print*,"Product:",a_g,b_g,cv_g,rho0_g,q_ref
        if_initialized = .true.
    endif
end subroutine scale_material_lx17

subroutine compute_pref_mixt1_lx17(p_ref,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(inout) :: p_ref
    double precision :: pref_s,pref_g,pref_sg,rhogamma_sg
    if(lbd.lt.lbd_tol) then
        call compute_pref_eos_jwl(p_ref,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
    else if(lbd.gt.(1.d0-lbd_tol)) then
        call compute_pref_eos_jwl(p_ref,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
    else
        call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)

        pref_sg     = (1.d0-lbd)*pref_s/(rho_s*gamma_s) &
                     +       lbd*pref_g/(rho_g*gamma_g)
        rhogamma_sg = (1.d0-lbd)/(rho_s*gamma_s) &
                     +       lbd/(rho_g*gamma_g)

        p_ref       = pref_sg/rhogamma_sg
    endif
end subroutine compute_pref_mixt1_lx17

subroutine compute_pref_mixt2_lx17(p_ref,dp_ref,rho_s,rho_g,lbd,drho_s,drho_g)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(in) :: drho_s,drho_g
    double precision,intent(inout) :: p_ref,dp_ref
    double precision :: pref_s,pref_g
    double precision :: dpref_s,dpref_g
    double precision :: pref_num,rhogamma_dom
    double precision :: dpref_num,drhogamma_dom
    double precision :: lbd_s,lbd_g
    if(lbd.lt.lbd_tol) then
        call compute_dpref2_eos_jwl(dp_ref,p_ref,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
    else if(lbd.gt.(1.d0-lbd_tol)) then
        call compute_dpref2_eos_jwl(dp_ref,p_ref,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
    else
        call compute_dpref2_eos_jwl(dpref_s,pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_dpref2_eos_jwl(dpref_g,pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        lbd_s = (1.d0-lbd)
        lbd_g = lbd
        pref_num     = lbd_s*pref_s/(rho_s*gamma_s) &
                      +lbd_g*pref_g/(rho_g*gamma_g)
        rhogamma_dom = lbd_s/(rho_s*gamma_s) &
                      +lbd_g/(rho_g*gamma_g)
        p_ref        = pref_num/rhogamma_dom

        dpref_num     = (lbd_s*dpref_s*rho_s*gamma_s - lbd_s*pref_s*gamma_s)/(rho_s*gamma_s)**2*drho_s &
                       +(lbd_g*dpref_g*rho_g*gamma_g - lbd_g*pref_g*gamma_g)/(rho_g*gamma_g)**2*drho_g
        drhogamma_dom =-lbd_s*gamma_s/(rho_s*gamma_s)**2*drho_s &
                       -lbd_g*gamma_g/(rho_g*gamma_g)**2*drho_g
        dp_ref = (dpref_num*rhogamma_dom - pref_num*drhogamma_dom)/rhogamma_dom**2
    endif

end subroutine compute_pref_mixt2_lx17

subroutine compute_eref_mixt1_lx17(ei_ref,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(inout) :: ei_ref
    double precision :: eref_s,eref_g
    if(lbd.lt.lbd_tol) then
        call compute_eiref_eos_jwl(ei_ref,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
    else if(lbd.gt.(1.d0-lbd_tol)) then
        call compute_eiref_eos_jwl(eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        ei_ref = eref_g - q_ref
    else
        call compute_eiref_eos_jwl(eref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_eiref_eos_jwl(eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        ei_ref = (1.d0-lbd)*eref_s + lbd*(eref_g - q_ref)
    endif
end subroutine compute_eref_mixt1_lx17

subroutine compute_eref_mixt2_lx17(ei_ref,dei_ref,rho_s,rho_g,lbd,drho_s,drho_g)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(in) :: drho_s,drho_g
    double precision,intent(inout) :: ei_ref,dei_ref
    double precision :: eref_s,eref_g
    double precision :: deref_s,deref_g
    if(lbd.lt.lbd_tol) then
        call compute_deiref2_eos_jwl(deref_s,eref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        ei_ref  = eref_s
        dei_ref = deref_s
    else if(lbd.gt.(1.d0-lbd_tol)) then
        call compute_deiref2_eos_jwl(deref_g,eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        ei_ref  = (eref_g - q_ref)
        dei_ref = deref_g
    else
        call compute_deiref2_eos_jwl(deref_s,eref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_deiref2_eos_jwl(deref_g,eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        ei_ref  = (1.d0-lbd)*eref_s + lbd*(eref_g - q_ref)
        dei_ref = (1.d0-lbd)*deref_s*drho_s + lbd*deref_g*drho_g
    endif
end subroutine compute_eref_mixt2_lx17

subroutine compute_rhogamma_mixt1_lx17(rhogamma_mixt,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(inout) :: rhogamma_mixt
    double precision :: rhogamma_sg
    if(lbd.lt.lbd_tol) then
        rhogamma_mixt = rho_s*gamma_s
    else if(lbd.gt.(1.d0-lbd_tol)) then
        rhogamma_mixt = rho_g*gamma_g
    else
        rhogamma_sg   = (1.d0-lbd)/(rho_s*gamma_s) + lbd/(rho_g*gamma_g)
        rhogamma_mixt = 1.d0/rhogamma_sg
    endif
end subroutine compute_rhogamma_mixt1_lx17

subroutine compute_rhogamma_mixt2_lx17(rhogamma_mixt,drhogamma_mixt,rho_s,rho_g,lbd,drho_s,drho_g)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(in) :: drho_s,drho_g
    double precision,intent(inout) :: rhogamma_mixt,drhogamma_mixt
    double precision :: rhogamma_dom,drhogamma_dom
    double precision :: lbd_s,lbd_g
    if(lbd.lt.lbd_tol) then
        rhogamma_mixt  = rho_s*gamma_s
        drhogamma_mixt = gamma_s
    else if(lbd.gt.(1.d0-lbd_tol)) then
        rhogamma_mixt  = rho_g*gamma_g
        drhogamma_mixt = gamma_g
    else
        lbd_s = (1.d0-lbd)
        lbd_g = lbd
        rhogamma_dom   = lbd_s/(rho_s*gamma_s) + lbd_g/(rho_g*gamma_g)
        rhogamma_mixt  = 1.d0/rhogamma_dom
        drhogamma_dom  =-lbd_s*gamma_s/(rho_s*gamma_s)**2*drho_s &
                        -lbd_g*gamma_g/(rho_g*gamma_g)**2*drho_g
        drhogamma_mixt =-drhogamma_dom/rhogamma_dom**2
    endif
end subroutine compute_rhogamma_mixt2_lx17

subroutine compute_pressure_mixt1_lx17(p,e,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: e,rho_s,rho_g,lbd
    double precision,intent(inout) :: p
    double precision :: pref_s,pref_g,eref_s,eref_g
    double precision :: eia,eib
    double precision :: numerator,denominator
    if(lbd.lt.lbd_tol) then
        call compute_eiref_eos_jwl(eref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        p = (rho_s*gamma_s)*(e - eref_s) + pref_s
    else if(lbd.gt.(1.d0-lbd_tol)) then
        call compute_eiref_eos_jwl(eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        p = (rho_g*gamma_g)*(e - eref_g + q_ref) + pref_g
    else
        call compute_eiref_eos_jwl(eref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_eiref_eos_jwl(eref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        numerator = e                                 &
                   -(1.d0-lbd)*eref_s                 &
                   -       lbd*(eref_g - q_ref)       &
                   +(1.d0-lbd)*pref_s/(rho_s*gamma_s) &
                   +       lbd*pref_g/(rho_g*gamma_g)
        denominator = (1.d0-lbd)/(rho_s*gamma_s)+lbd/(rho_g*gamma_g)
        p = numerator/denominator
    endif
end subroutine compute_pressure_mixt1_lx17

subroutine compute_pressure_mixt2_lx17(p,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(inout) :: p
    double precision :: pref_s,pref_g,rgcv_s,rgcv_g
    double precision :: numerator,denominator
    call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
    call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
    rgcv_s      = 1.d0/(rho_s*gamma_s*cv_s)
    rgcv_g      = 1.d0/(rho_g*gamma_g*cv_g)
    numerator   = pref_s*rgcv_s - pref_g*rgcv_g
    denominator = rgcv_s - rgcv_g
    p           = numerator/denominator
end subroutine compute_pressure_mixt2_lx17

subroutine compute_pressure_mixt3_lx17(p,numerator,denominator,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(inout) :: p,numerator,denominator
    double precision :: pref_s,pref_g,rgcv_s,rgcv_g
    call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
    call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
    rgcv_s      = 1.d0/(rho_s*gamma_s*cv_s)
    rgcv_g      = 1.d0/(rho_g*gamma_g*cv_g)
    numerator   = pref_s*rgcv_s - pref_g*rgcv_g
    denominator = rgcv_s - rgcv_g
    p           = numerator/denominator
end subroutine compute_pressure_mixt3_lx17

subroutine compute_pressure_mixt4_lx17(num,dom,dnum,ddom,rho_s,rho_g,lbd,drho_s,drho_g)
    implicit none
    double precision,intent(in) :: rho_s,rho_g,lbd
    double precision,intent(in) :: drho_s,drho_g
    double precision,intent(inout) :: num,dom,dnum,ddom
    double precision :: pref_s,pref_g
    double precision :: dpref_s,dpref_g
    double precision :: rgcv_s,rgcv_g
    double precision :: drgcv_s,drgcv_g
    call compute_dpref2_eos_jwl(dpref_s,pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
    call compute_dpref2_eos_jwl(dpref_g,pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
    rgcv_s = 1.d0/(rho_s*gamma_s*cv_s)
    rgcv_g = 1.d0/(rho_g*gamma_g*cv_g)
    num    = pref_s*rgcv_s - pref_g*rgcv_g
    dom    = rgcv_s - rgcv_g

    drgcv_s =-gamma_s*cv_s/(rho_s*gamma_s*cv_s)**2
    drgcv_g =-gamma_g*cv_g/(rho_g*gamma_g*cv_g)**2
    dnum = (dpref_s*rgcv_s + pref_s*drgcv_s)*drho_s &
          -(dpref_g*rgcv_g + pref_g*drgcv_g)*drho_g
    ddom = drgcv_s*drho_s - drgcv_g*drho_g
end subroutine compute_pressure_mixt4_lx17

! compute the internal energy of reactant
subroutine compute_ei_reac_lx17(ei,p,r)
    implicit none
    double precision,intent(in) :: p,r
    double precision,intent(inout) :: ei
    double precision :: p_ref
    double precision :: ei_ref
    call compute_pref_eos_jwl(p_ref,r,a_s,b_s,r1_s,r2_s,rho0_s)
    call compute_eiref_eos_jwl(ei_ref,r,a_s,b_s,r1_s,r2_s,rho0_s)
    ei = (p - p_ref)/(r*gamma_s) + ei_ref
end subroutine compute_ei_reac_lx17

! compute the internal energy of product
subroutine compute_ei_prod_lx17(ei,p,r)
    implicit none
    double precision,intent(in) :: p,r
    double precision,intent(inout) :: ei
    double precision :: p_ref, ei_ref
    call compute_pref_eos_jwl(p_ref,r,a_g,b_g,r1_g,r2_g,rho0_g)
    call compute_eiref_eos_jwl(ei_ref,r,a_g,b_g,r1_g,r2_g,rho0_g)
    ei = (p - p_ref)/(r*gamma_g) + ei_ref - q_ref
end subroutine compute_ei_prod_lx17

! compute the internal energy of the mixture
subroutine compute_internal_energy_mixt_lx17(ei,eia,eib,p,ra,rb,lbd)
    implicit none
    double precision,intent(in) :: p,ra,rb,lbd
    double precision,intent(inout) :: ei,eia,eib
    double precision :: p_ref, ei_ref
    if(lbd.lt.lbd_tol) then
        call compute_ei_reac_lx17(eia,p,ra)
        call compute_ei_prod_lx17(eib,p,rb)
        ei = eia
    else if(lbd.gt.(1.d0-lbd_tol)) then
        call compute_ei_reac_lx17(eia,p,ra)
        call compute_ei_prod_lx17(eib,p,rb)
        ei = eib
    else
        call compute_ei_reac_lx17(eia,p,ra)
        call compute_ei_prod_lx17(eib,p,rb)
        ei = (1.d0-lbd)*eia+lbd*eib
    endif
end subroutine compute_internal_energy_mixt_lx17

! compute the sound speed of mixture
subroutine compute_sound_speed2_lx17(c2,p,rho,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: p,rho,rho_s,rho_g,lbd
    double precision,intent(inout) :: c2
    double precision :: desdp,desdrs,degdp,degdrg
    double precision :: dersdrs,dergdrg
    double precision :: pref_s,pref_g,dprsdrs,dprgdrg
    double precision :: drsdr,drgdr,dlbddr
    double precision :: dedp,dedrho
    double precision :: eia,eib
    double precision :: ss2_s,ss2_g
    if(lbd.lt.lbd_tol) then
        call compute_dedp_eos_jwl(desdp,p,rho_s,gamma_s)
        dedp  = desdp
        call compute_dedr_eos_jwl(desdrs,p,rho_s,a_s,b_s,r1_s,r2_s,rho0_s,gamma_s)
        dedrho = desdrs

        c2 = (p/rho**2-dedrho)/dedp
    else if(lbd.gt.(1.d0-lbd_tol)) then
        call compute_dedp_eos_jwl(degdp,p,rho_g,gamma_g)
        dedp  = degdp

        call compute_dedr_eos_jwl(degdrg,p,rho_g,a_g,b_g,r1_g,r2_g,rho0_g,gamma_g)

        dedrho = degdrg
        c2 = (p/rho**2-dedrho)/dedp
    else
        call compute_dedp_eos_jwl(desdp,p,rho_s,gamma_s)
        call compute_dedp_eos_jwl(degdp,p,rho_g,gamma_g)
        dedp  = (1.d0-lbd)*desdp + lbd*degdp

        call compute_dedr_eos_jwl(desdrs,p,rho_s,a_s,b_s,r1_s,r2_s,rho0_s,gamma_s)
        call compute_dedr_eos_jwl(degdrg,p,rho_g,a_g,b_g,r1_g,r2_g,rho0_g,gamma_g)

        drsdr  = rho_s**2/(rho**2*(1.d0 - lbd))
        drgdr  = rho_g**2/(rho**2*lbd)
        dedrho = (1.d0-lbd)*desdrs*drsdr + lbd*degdrg*drgdr
        c2 = (p/rho**2-dedrho)/dedp
    endif
    ! if(c2.lt.0.d0) then
    !     print*,"LX-17, negative sound speed:",c2
    !     print*,drsdr,drgdr,dedrho,dedp
    ! endif
end subroutine

subroutine compute_xi_lx17(xi,r,ra,rb,lbd)
    implicit none
    double precision,intent(in) :: r,ra,rb,lbd
    double precision,intent(inout) :: xi
    double precision :: ggs,ggg,gg
    if(lbd.lt.lbd_tol) then
        xi = 1.d0/gamma_s
    else if(lbd.gt.(1.d0-lbd_tol)) then
        xi = 1.d0/gamma_g
    else
        ggs = gamma_s + 1.d0
        ggg = gamma_g + 1.d0
        gg = ((1.d0 - lbd)*cv_s*ggs + lbd*cv_g*ggg)/((1.d0 - lbd)*cv_s + lbd*cv_g)
        xi = 1.d0/(gg - 1.d0)
    endif
    if(ISNAN(xi)) then
        print*,gg,lbd,r,ra,rb
    endif
end subroutine compute_xi_lx17

subroutine compute_temperature_mixt_lx17(t,cv,p,rho_s,rho_g,lbd)
    implicit none
    double precision,intent(in) :: p,rho_s,rho_g,lbd
    double precision,intent(inout) :: t,cv
    double precision :: t_s,t_g,pref_s,pref0_s,pref_g
    ! if(lbd.lt.lbd_tol) then
    !     call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
    !     t_s = (p - pref_s)/(rho_s*gamma_s*cv_s)
    !     t  = t_s
    !     cv = cv_s
    ! else if(lbd.gt.(1.d0-lbd_tol)) then
    !     call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
    !     t_g = (p - pref_g)/(rho_g*gamma_g*cv_g)
    !     t  = t_g
    !     cv = cv_g
    ! else
        call compute_pref_eos_jwl(pref_s,rho_s,a_s,b_s,r1_s,r2_s,rho0_s)
        call compute_pref_eos_jwl(pref_g,rho_g,a_g,b_g,r1_g,r2_g,rho0_g)
        t_s = (p - pref_s)/(rho_s*gamma_s*cv_s)
        t_g = (p - pref_g)/(rho_g*gamma_g*cv_g)
        t  = (1.d0-lbd)*t_s+lbd*t_g
        cv = (1.d0-lbd)*cv_s+lbd*cv_g
    ! endif
end subroutine compute_temperature_mixt_lx17

! compute the reaction rate of IG model
subroutine compute_source_lx17(src0, src_num,                     &
                               comm_prim, comm_prim_num,          &
                               phs_prim, phs_prim_num,            &
                               phs_cpnt_prim, phs_cpnt_prim_num)
    implicit none
    integer,intent(in) :: src_num, comm_prim_num, &
                          phs_prim_num, phs_cpnt_prim_num
    double precision,dimension(comm_prim_num),intent(in) :: comm_prim
    double precision,dimension(phs_prim_num),intent(in) :: phs_prim
    double precision,dimension(phs_cpnt_prim_num),intent(in) :: phs_cpnt_prim
    double precision,dimension(src_num),intent(inout) :: src0
    double precision :: rho,p,lbd,z
    double precision :: h0,h1,h2,hv,hp
    p   = comm_prim(5)
    z   = phs_prim(1)
    rho = phs_prim(2)
    lbd = phs_cpnt_prim(3)
    if(z.gt.z_tol) then
        call heaviside_lx17(hv,rho/rho0_s-1.d0-a_r)
        call heaviside_lx17(hp,p)
        call heaviside_lx17(h0,lambda_i_r-lbd)
        call heaviside_lx17(h1,lambda_g1_r-lbd)
        call heaviside_lx17(h2,lbd-lambda_g2_r)
        src0(1) =  (i_r*(1.d0-lbd)**b_r*(rho/rho0_s-1.d0-a_r)**x_r*h0*hv &
                  +g1_r*(1.d0-lbd)**c_r*lbd**d_r*p**y_r*h1*hp &
                  +g2_r*(1.d0-lbd)**e_r*lbd**g_r*p**z_r*h2*hp)*rho
    else
        src0(1) = 0.d0
    endif
    if(isnan(src0(1))) then
        print*,rho,z,p,lbd
        stop 'rate is a NAN'
    endif
end subroutine compute_source_lx17

subroutine heaviside_lx17(h,x)
    implicit none
    double precision,intent(in) :: x
    double precision,intent(inout) :: h
    if(x.lt.0.d0) then
        h=0.d0
    else
        h=1.d0
    endif
end subroutine heaviside_lx17

integer function getstatus_lx17(lbd)
    implicit none
    double precision,intent(in) :: lbd
    if((lbd.ge.0.d0).and.(lbd.lt.lbd_tol)) then
        getstatus_lx17 = 0
    else if((lbd.ge.lbd_tol).and.(lbd.lt.(1.d0-lbd_tol))) then
        getstatus_lx17 = 1
    else if((lbd.ge.(1.d0-lbd_tol)).and.(lbd.le.1.d0)) then
        getstatus_lx17 = 2
    else
        getstatus_lx17 = -1
    endif
end function

end module


      FUNCTION brent(ax,bx,cx,f,tol,xmin)
      INTEGER ITMAX
      REAL brent,ax,bx,cx,tol,xmin,f,CGOLD,ZEPS
      EXTERNAL f
      PARAMETER (ITMAX=100,CGOLD=.3819660,ZEPS=1.0e-10)
      INTEGER iter
      REAL a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm
      a=min(ax,cx)
      b=max(ax,cx)
      v=bx
      w=v
      x=v
      e=0.
      fx=f(x)
      fv=fx
      fw=fx
      do 11 iter=1,ITMAX
        xm=0.5*(a+b)
        tol1=tol*abs(x)+ZEPS
        tol2=2.*tol1
        if(abs(x-xm).le.(tol2-.5*(b-a))) goto 3
        if(abs(e).gt.tol1) then
          r=(x-w)*(fx-fv)
          q=(x-v)*(fx-fw)
          p=(x-v)*q-(x-w)*r
          q=2.*(q-r)
          if(q.gt.0.) p=-p
          q=abs(q)
          etemp=e
          e=d
          if(abs(p).ge.abs(.5*q*etemp).or.p.le.q*(a-x).or.p.ge.q*(b-x))
     *goto 1
          d=p/q
          u=x+d
          if(u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x)
          goto 2
        endif
1       if(x.ge.xm) then
          e=a-x
        else
          e=b-x
        endif
        d=CGOLD*e
2       if(abs(d).ge.tol1) then
          u=x+d
        else
          u=x+sign(tol1,d)
        endif
        fu=f(u)
        if(fu.le.fx) then
          if(u.ge.x) then
            a=x
          else
            b=x
          endif
          v=w
          fv=fw
          w=x
          fw=fx
          x=u
          fx=fu
        else
          if(u.lt.x) then
            a=u
          else
            b=u
          endif
          if(fu.le.fw .or. w.eq.x) then
            v=w
            fv=fw
            w=u
            fw=fu
          else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then
            v=u
            fv=fu
          endif
        endif
11    continue
      pause 'brent exceed maximum iterations'
3     xmin=x
      brent=fx
      return
      END

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


c
c subroutine dinver (a, max, n, iflag)
c
c Arguments
c
c     a (input/output) is a square matrix of dimension N.  The inverse
c       of the input matrix A is returned in A.
c
c   max (input) is the size assigned to the matrix A in the calling
c       routine.  It's needed for the dimension statement below.
c
c iflag (output) is an error flag.  iflag  =  1 if the matrix could not
c       be inverted; iflag  =  0 if it could.
c
      subroutine dinver (a, max, n, iflag)
c
      implicit none
      integer max, n, iflag
      double precision a(max,max)
      integer i, j, k
c
      iflag = 0
      i = 1
  300 if (a(i,i) .eq. 0.0d0) go to 9100
      a(i,i) = 1.0e0 / a(i,i)
      j = 1
  301 if (j .eq. i) go to 304
      a(j,i) = -a(j,i) * a(i,i)
      k = 1
  302 if (k .eq. i) go to 303
      a(j,k) = a(j,k) + a(j,i) * a(i,k)
  303 if (k .eq. n) go to 304
      k = k + 1
      go to 302
  304 if (j .eq. n) go to 305
      j = j + 1
      go to 301
  305 k = 1
  306 if (k .eq. i) go to 307
      a(i,k) = a(i,k) * a(i,i)
  307 if (k .eq. n) go to 308
      k = k + 1
      go to 306
  308 if (i .eq. n) return
      i = i+1
      go to 300
c
c Error:  zero on the diagonal.
c
 9100 iflag = 1
      return
c
      end


c
c----------------------------------------------------------------------
c
 	subroutine solarflux (iout,yyddd,nen,e,Pflx,Eflx,impress)
c
c 	Cette subroutine calcule un flux solaire a une date donnee
c 	sur une grille d'energie e.
c 	La source est :
c     	Tobiska, W.K., Revised solar extreme ultraviolet flux
c       model, JATP, (accepted) 1991. The preprint was XXVIII
c       COSPAR, The Hague, paper STP I.2-P1, 1990.
c 	Le modele Tobiska est appele, puis les energies sont re-
c 	ordonnees et le flux est interpole sur la grille d'entree.
c
c 	INPUTS
c 	iout  = numero logique du fichier de sortie (integer)
c 	impress = 1 si on imprime le flux , 0 sinon
c 	yyddd = date (integer) between 68172 - 88366: '
c 	nen   = nombre d'energies de la grille d'entree
c 	e     = grille d'entree des energies [eV]
c
c	OUTPUTS
c 	Pflx  = flux de photons sur la grille d'entree [cm-2.s-1]
c 	Eflx  = flux d'energie sur la grille d'entree [eV.cm-2.s-1]
c
 	implicit none
c
 	integer iout,yyddd,numday,nen,ien,impress
c
C 	Sorties de euv91
 	real w1nm(39),w2nm(39),wmid(39)
 	real eVinf(39),eVsup(39)
 	real eVmid(39),Eflux(39),Pflux(39)
c
c 	Sorties reordonnees
 	real w1nmor(39),w2nmor(39),wmidor(39)
 	real eVinfor(39),eVsupor(39)
 	real eVmidor(39),Efluxor(39),Pfluxor(39)
c
c 	Energies d'entree et longueur d'onde correspondantes.
 	real e(400),ondenm(400)
c 	Flux interpolle sur les energies.
 	real PflxE(400),EflxE(400)
c 	Flux interpolle sur les longueurs d'onde.
 	real PflxW(400),EflxW(400)
c 	Facteurs de normalisation sur le nombre total de photons.
 	real totin,totout,rapp
c 	Flux renvoye par le programme
 	real Pflx(400),Eflx(400)

c 	Tableau de travail.
 	integer index(39)
 	double precision eVmiddp(39)
 	real trav(400),tabx(400),taby(400),xmin,xmax,ymin,ymax
c
c 	Estime le flux solaire pour le jour requis.
 	numday = 1
 	call euv91(iout,yyddd,numday,w1nm,eVinf,w2nm,eVsup,eVmid,wmid,
     .		Pflux,Eflux,impress)
c 	Reordonne les tableaux
 	do ien=1,39
 	  eVmiddp(ien) = dble(eVmid(ien))
 	enddo
 	do ien = 1,39
 	  w1nmor (ien) = w1nm (index(ien))
 	  w2nmor (ien) = w2nm (index(ien))
 	  wmidor (ien) = wmid (index(ien))
 	  eVinfor(ien) = eVinf(index(ien))
 	  eVsupor(ien) = eVsup(index(ien))
 	  eVmidor(ien) = eVmid(index(ien))
 	  Efluxor(ien) = Eflux(index(ien))
 	  Pfluxor(ien) = Pflux(index(ien))
 	enddo
c
c 	Interpolation en lin/log du flux solaire sur les longueurs d'
c 	onde.
 	do ien=1,39
 	  tabx(ien) = wmidor(ien)
 	  taby(ien) = log10(Pfluxor(ien))
 	enddo
 	do ien = 1,nen
 	  ondenm(ien) = 1240./e(ien)
 	enddo
 	call intlin (39,tabx,taby,nen,ondenm,PflxW)
 	do ien = 1,nen
 	  PflxW(ien) = 10.**PflxW(ien)
 	enddo
c
c 	Interpolation en log/log du flux solaire sur les energies
 	do ien=1,39
 	  tabx(ien) = log10(eVmidor(ien))
 	  taby(ien) = log10(Pfluxor(ien))
 	enddo
 	do ien = 1,nen
 	  trav(ien) = log10(e(ien))
 	enddo
 	call intlin (39,tabx,taby,nen,trav,PflxE)
 	do ien = 1,nen
 	  PflxE(ien) = 10.**PflxE(ien)
 	enddo
c
c 	Quelle est la meilleure interpolation? En lin/log sur les
c 	longueurs d'onde ou en log/log sur les energies?
c 	Mystere...
 	do ien = 1,nen
 	  Pflx(ien) = PflxW(ien)
 	enddo
c
c 	Que faut-il conserver? L'energie dans chaque boite, l'energie
c 	totale, le nombre de photons dans chaque boite, le nombre
c	de photons total?
c 	Conservation du nombre de photons total:
 	totin = 0.
 	do ien = 1,39
 	  totin = totin + Pfluxor(ien)
 	enddo
 	totout = 0.
 	do ien = 1,nen
 	  totout = totout + Pflx(ien)
 	enddo
 	if (totout.ne.0.)then
 	  rapp = totin/totout
 	  write(6,*)'standard report : ',rapp
 	  write(iout,*)'standard report : ',rapp
 	  do ien = 1,nen
 	    Pflx(ien) = Pflx(ien)*rapp
 	  enddo
 	endif
c
 	write(iout,*)
 	write(iout,*)'After interpolation and normalization of the total',
     . 	 	     ' number of particles'
 	write(iout,*)'Energies [eV]'
 	write(iout,1040)(e(ien),ien=1,nen)
 	write(iout,*)'wavelength [nm]'
 	write(iout,1040)(ondenm(ien),ien=1,nen)
 	write(iout,*)'Flux [Photons.cm-2.s-1.nm-1]'
 	write(iout,1040)(Pflx(ien),ien=1,nen)
1040 	format(7(1pe10.2))
c
 	end subroutine solarflux
c
c-----------------------------------------------------------------------
c
 	subroutine euv91(iout,yyddd,numday,w1nm,eVinf,w2nm,eVsup,
     .			eVmid,wmid,Pflx,Eflx,impress)
c
c 	Re-ecrit en subroutine 07/93 (jl)
c 	PARAMETRES D'ENTREE :
c	yyddd :  Enter YYDDD date between 68172 - 88366: '
c	numday
c 	PARAMETRES DE SORTIE
c 		TABLEAUX REELS DE 39 ELEMENTS
c 	w1nm : borne inf de la boite de longueur d'onde [nm] pour le
c 		flux
c 	eVinf : borne inf de la boite d'energie [eV] pour le flux
c 	w2nm : borne sup de la boite de longueur d'onde [nm] pour le
c 		flux
c 	eVsup : borne inf de la boite d'energie [eV] pour le flux
c 	eVmid : milieu de la boite d'energie [eV].
c 	wmid  : milieu de la boite de longueur d'ondes [nm].
C	Eflx  :	energy flux vector (39) = Eflux pour eviter pb. common
C	Pflx  :	photon flux vector (39) = Pflux pour eviter pb. common
c
c	program euv91
C********1*********2*********3*********4*********5*********6*********7**
C     This program creates the solar EUV irradiance for 18-1050 A based
C     on a multiple linear regression model for solar EUV flux.
C     Reference: Tobiska, W.K., Revised solar extreme ultraviolet flux
C     model, JATP, (accepted) 1991. The preprint was XXVIII
C     COSPAR, The Hague, paper STP I.2-P1, 1990. (See accompanying file
C     EUV91.TXT)
C     Files required for model to run:
C	     euv91coef.txt	= ASCII file of model coefficients
C	     euv91index2.dat	= ASCII file of proxy values
C     The model values produced in this program include: energy and
C	photon flux for 39 EUV wavelength intervals or lines
C     Files created by running this model: fyyddd.dat (ASCII)
C      Note: DEC equipment requires IDINT function to be JINT
C
C     W. Kent Tobiska       Baseline version: 10-16-90    Rev: 4-30-91
C********1*********2*********3*********4*********5*********6*********7**
C			VARIABLES AND DEFINITIONS
C********1*********2*********3*********4*********5*********6*********7**
C	i,j,num,sign	loop and index control
C	frcnum,frcsin   decade counter
C	expont		flag for 2 digit ASCII exponent characters
C	expsin,expnum	sign and number of exponent (ASCII chars)
C	yyddd		date in YYDDD format
C	numday		number of days for calculating flux
C	fname		filename for flux data file
C	c		floating point array (12,52) of model coefficients
C	number		temporary number constructed from ASCII coef file
C	indice		floating point array (10,3750) of proxy values
C	sumflx		temporary variable for summing photon flux
C	Eflux		energy flux vector (39)
C	Pflux		photon flux vector (39)
C	date		date
C	model		model photon flux vector (52)
C	W		missing data scaling function vector (52)
C	S		missing data step function vector (4)
C	line1		character string for ASCII line
C	line2		character string for ASCII line
C	w1		beginning wavelengths vector (39) in A
C	w2		ending wavelengths vector (39) in A
C	w1nm		beginning wavelengths vector (39) in nm (JL, 93)
C	w2nm		ending wavelengths vector (39) in nm (JL, 93)
C	wave		average wavelengths vector (39)
C	itemp		temporary vector (6)
C	temp		temporary vector (6)
C	row		loop control for indices row number on a date
C	colum		loop control for indices column number on a date
C********1*********2*********3*********4*********5*********6*********7**
C	implicit	none
	include 'TRANSPORT.INC'
	integer		yyddd,i,j,numday,num
	real		c(12,52),indice(10,3750),S(4),w1(39),w2(39)
	real		date,Eflux(39),Pflux(39),wave(39)
	real		Eflx(39),Pflx(39)
	real		w1nm(39),w2nm(39),wmid(39),eVinf(39),
     .			eVsup(39),eVmid(39)
	character*10	fname
c	data		numday /1/
c	data		fname(1:1),fname(7:10) /'f','.dat'/
 	integer impress
	common	/coeff/ c,indice,date,wave,w1,w2,S,Eflux,Pflux

C********1*********2*********3*********4*********5*********6*********7**
C	Initialize variables
C********1*********2*********3*********4*********5*********6*********7**
	write (*,*) ' Reading the coefficient and indices tables'
		call rddata
c	write (*,'(A,$)') ' Enter YYDDD date between 68172 - 88366: '
c		read  (*,'(I5)') yyddd
c	write (*,'(A,I5,A,$)') ' Enter # of days including ',yyddd,': '
c		read  (*,'(I10)') numday
 	date = real(yyddd)

C********1*********2*********3*********4*********5*********6*********7**
C	Calculate the flux for each day by first determining the date
C	and proxy values for that date then calculating the flux.
C********1*********2*********3*********4*********5*********6*********7**
	do 10 i=0,numday-1
	  date = real(yyddd+i)
	  call getind
	  call flux
	  do 20 j=1,5
c	    num = jint(date*(10.**(j-5)))-jint(date*(10.**(j-6)))*10
c 	    num = idint(date*(10.**(j-5)))-idint(date*(10.**(j-6)))*10
  	    num = int(date*(10.**(j-5)))-int(date*(10.**(j-6)))*10
c	    fname(j+1:j+1) = char(num+ichar('0'))
20	  continue

C********1*********2*********3*********4*********5*********6*********7**
C	Write the results to an output file
C********1*********2*********3*********4*********5*********6*********7**

1000 	  format('  EUV 91 Energy and Photon Flux for ',i10,/)
1010 	format (5x,'Wavelength',5x,'Middle',6x,'Energy',6x,'Middle',8x,
     .    'Photon',5x,'Energy',/,58x,'flux',8x,'flux',/,
     .    7x,'[nm]',10x,'[nm]',8x,'[eV]',8x,'[eV]',9x,'[cm-2.',
     .    5x,'[eV.cm-2.',/,3x,13('-'),12x,14('-'),15x,'s-1.nm-1]',
     .    3x,'s-1.nm-1]',/)
1020 	format
     .	    (2(1F8.1,1x),1f8.1,1x,2(1F7.2,1x),1f7.2,6x,2(1p1E9.3,3x))
c
 	  if (impress.eq.1)then
	    write (iout,1000)yyddd+i
	    write (iout,1010)
 	  endif
c 	  w1 et w2 sont en angstrom. On multiplie par 10 pour avoir des
c 	  nm.
	  do 30 j=1,39
	    w1nm(j) = w1(j)/10.
	    w2nm(j) = w2(j)/10.
	    wmid(j) = wave(j)/10.
 	    eVsup(j)= 12400./w1(j)
 	    eVinf(j)= 12400./w2(j)
 	    Pflx(j) = Pflux(j)
c
c 	    wave(j) est defini par Tobiska comme le milieu de la
c 	    boite en longueur d'onde. Le flux d'energie est alors
c 	    calcule selon pflux*12400/wave. Dans ce cas, on a :
c 	    eVmid(j)= 12400./wave(j)
c 	    On peut prendre aussi comme energie pour le calcul du
c 	    flux d'energie le milieu de la boite en energie (ou un
c 	    point quelconque dans l'intervalle) :
  	    eVmid(j)=eVinf(j)+(eVsup(j)-eVinf(j))*0.5
c 	    Dans ce cas, le flux d'energie est :
 	    Eflux(j) = eVmid(j) * Pflux(j)
 	    Eflx(j) = Eflux(j)
 	    if (impress.eq.1) write(iout,1020) w1nm(j),w2nm(j),wmid(j),
     .		     eVinf(j),eVsup(j),eVmid(j),Pflux(j),Eflux(j)
30	  continue
10	continue
	end
c
c-----------------------------------------------------------------------
c
	subroutine rddata
C********1*********2*********3*********4*********5*********6*********7**
C	This subroutine reads in the coefficients and indices into the
C	common block COEFF. It may seem awkward; however, it is useful
C	to keep the coefficient and indices ASCII files in their
C	present format for easy transfer to other users.
C********1*********2*********3*********4*********5*********6*********7**
C	implicit	none
	include 'TRANSPORT.INC'
	integer		i,j,num,sign,itemp(6)
	integer		expsin,expnum,frcsin,frcnum
	real		c(12,52),indice(10,3750),S(4),temp(6),number
	real		date,Eflux(39),Pflux(39)
	real		w1(39),w2(39),wave(39)
	character*1	expont
	character*80	line1,line2
	common	/coeff/ c,indice,date,wave,w1,w2,S,Eflux,Pflux
 	real w1dat(39),w2dat(39)
C********1*********2*********3*********4*********5*********6*********7**
C	Default wavelength lines and intervals
C********1*********2*********3*********4*********5*********6*********7**
	data	    w1dat /18.62,30.02,50.52,100.54,150.10,200.02,
     1			256.32,284.15,251.10,303.31,303.78,303.31,
     2			368.07,356.01,401.14,465.22,453.00,500.00,
     3			554.37,584.33,554.37,609.76,629.73,609.76,
     4			650.30,703.36,701.00,765.15,770.41,787.71,
     5			750.01,801.00,851.00,901.00,977.02,951.00,
     6			1025.72,1031.91,1001.00/
	data	    w2dat /29.52,49.22,99.99,148.40,198.58,249.18,
     1			256.32,284.15,299.50,303.31,303.78,349.85,
     2			368.07,399.82,436.70,465.22,499.37,550.00,
     3			554.37,584.33,599.60,609.76,629.73,644.10,
     4			700.00,703.36,750.00,765.15,770.41,790.15,
     5			800.00,850.00,900.00,950.00,977.02,1000.00,
     6			1025.72,1031.91,1050.00/
c
 	do i=1,39
 	  w1(i) = w1dat(i)
 	  w2(i) = w2dat(i)
 	enddo

C********1*********2*********3*********4*********5*********6*********7**
C	Get average wavelength and read in the coefficients
C********1*********2*********3*********4*********5*********6*********7**
	do 10 i = 1,39
	  wave(i) = (w1(i)+w2(i))/2.
10	continue

	open (unit=fic_euvcoeff,
     .		file='dir.data/dir.linux/euv91coef.txt',
     .		status='old',form='formatted')
	do 20 i = 1,3
	  read(fic_euvcoeff,'(A)') line1
20	continue
	do 30 i = 1,52
	  frcnum = 0
	  frcsin = 1
	  expont = 'n'
	  expnum = 0
	  expsin = 1
	  num = 0
	  number = 0.
	  sign = 1
  	  read (fic_euvcoeff,'(2(I4,1x),I1,1x,G12.5E4,1x,A51)')
     1		itemp(1),itemp(2),itemp(3),c(4,i),line2
	  c(1,i) = dble(itemp(1))
	  c(2,i) = dble(itemp(2))
	  c(3,i) = dble(itemp(3))
	  do 40 j = 1,51
	    if (line2(j:j) .ne. ' ') then
	      if (line2(j:j) .eq. '-') then
		if (j .eq. 1) then
		  sign = -1
		else if (line2(j-1:j-1) .eq. ' ') then
		  sign = -1
		else if (expont .eq. 'y') then
		  expsin = -1
		endif
	      else if (line2(j:j) .eq. '.') then
		frcsin = -1
	        frcnum = 1
	      else if (expont .eq. 'y') then
		if (line2(j:j) .eq. '+') then
		  expsin = 1
		else if (line2(j:j) .eq. '0') then
		  continue
		else if (line2(j:j) .ne. '-') then
		  expnum = ichar(line2(j:j))-ichar('0')
		endif
	      else if (line2(j:j) .eq. 'e') then
		expont = 'y'
	      else
		if (frcsin .eq. -1) then
		  number = (ichar(line2(j:j))-ichar('0')) *
     1			(10.**(frcsin*frcnum)) + number
		  frcnum = frcnum+1
		else if (frcsin .eq. 1) then
		  number = (ichar(line2(j:j))-ichar('0')) +
     1			(10.**(frcsin*frcnum)) * number
		  frcnum = 1
	        endif
	      endif
	    else
	      c(5+num,i) = sign*number*(10.**(expsin*expnum))
	      num = num+1
	      frcnum = 0
	      frcsin = 1
	      number = 0.
	      sign = 1
	      expont = 'n'
	      expnum = 0
	      expsin = 1
	      if (num .eq. 8) goto 30
	    endif
40	  continue
30	continue
	close (unit=fic_euvcoeff)
C********1*********2*********3*********4*********5*********6*********7**
C	Read in the indices
C********1*********2*********3*********4*********5*********6*********7**
	open(unit=fic_euvindex,file='dir.data/dir.linux/euv91index2.dat'
     .		,status='old',form='formatted')
  	do 50 i = 1,2
	  read(fic_euvindex,'(A)') line1
50	continue
  	do 60 i = 1,3750
	  read (fic_euvindex,
     1 '(1x,F5.0,2(1x,G11.5E4),2(1x,F3.0),3x,F5.0,2(1x,G11.5E4),
     2   2(1x,F3.0))')temp(1),indice(2,i),indice(3,i),temp(2),temp(3),
     3	    temp(4),indice(7,i),indice(8,i),temp(5),temp(6)
	  indice( 1,i) = dble(temp(1))
	  indice( 4,i) = dble(temp(2))
	  indice( 5,i) = dble(temp(3))
	  indice( 6,i) = dble(temp(4))
	  indice( 9,i) = dble(temp(5))
	  indice(10,i) = dble(temp(6))
60	continue
	close (unit=fic_euvindex)

	return
	end
c
c-----------------------------------------------------------------------
c

	subroutine flux
C********1*********2*********3*********4*********5*********6*********7**
C	This subroutine uses the coefficients and indices in the
C	common block COEFF to calculate the EUV energy flux for a date.
C	For mid 1968 through early 1977 when neither Lyman alpha nor
C	He I 10830 were present, the model calculates the chromospheric
C	emission using F10.7 linear relationship with Lyman alpha based
C	upon Barth et al., GRL, 17, 571-574, 1990.
C********1*********2*********3*********4*********5*********6*********7**
C	implicit	none
	integer		i,j
	real		c(12,52),indice(10,3750),sumflx,Eflux(39)
	real		Pflux(39),wave(39),w1(39),w2(39)
	real		date,model(52),W(52),S(4),near0
	data		W,model,sumflx,near0 /52*1.,52*0.,0.,1.e-5/
	common	/coeff/ c,indice,date,wave,w1,w2,S,Eflux,Pflux

C********1*********2*********3*********4*********5*********6*********7**
C	Replace the missing proxies on a date with surrogate value
C********1*********2*********3*********4*********5*********6*********7**
	if ((S(1) .lt. near0).and.(S(2) .gt. near0)) S(1) = S(2)
	if  (S(1) .lt. near0) S(1) = (8.7e8)*S(3) + 1.9e11
	if  (S(2) .lt. near0) S(2) = S(1)

C********1*********2*********3*********4*********5*********6*********7**
C	Create the empirically modeled flux from Equations 3, 4, 5 in
C	JATP paper. Note that the "W" scaling function is now unused
C	and all elements are set to 1. in this version.
C********1*********2*********3*********4*********5*********6*********7**
	do 10 j=1,52
	  sumflx = 0.
	  do 20 i=1,4
	    if (i .le. 2) W(j) = (1.+c(8+i,j)*exp(-S(i)*1.e-10))*W(j)
	    if (i .gt. 2) W(j) = (1.+c(8+i,j)*exp(-S(i)*.7))*W(j)
	    sumflx = c(i+4,j)*S(i) + sumflx
20	  continue
	  model(j) = (c(4,j) + sumflx) * W(j)
10	continue
C********1*********2*********3*********4*********5*********6*********7**
C	Combine the chromospheric and coronal flux into intervals
C********1*********2*********3*********4*********5*********6*********7**
	Pflux( 1)=model( 1)
	Pflux( 2)=model( 2)+model( 3)
	Pflux( 3)=model( 4)+model( 5)
	Pflux( 4)=model( 6)+model( 7)
	Pflux( 5)=model( 8)+model( 9)
	Pflux( 6)=model(10)+model(11)
	Pflux( 7)=model(12)
	Pflux( 8)=model(13)
	Pflux( 9)=model(14)+model(15)
	Pflux(10)=model(16)
	Pflux(11)=model(17)
	Pflux(12)=model(18)
	Pflux(13)=model(19)
	Pflux(14)=model(20)+model(21)
	Pflux(15)=model(22)+model(23)
	Pflux(16)=model(24)
	Pflux(17)=model(25)+model(26)
	Pflux(18)=model(27)+model(28)
	Pflux(19)=model(29)
	Pflux(20)=model(30)
	Pflux(21)=model(31)
	Pflux(22)=model(32)
	Pflux(23)=model(33)
	Pflux(24)=model(34)+model(35)
	Pflux(25)=model(36)+model(37)
	Pflux(26)=model(38)
	Pflux(27)=model(39)
	Pflux(28)=model(40)
	Pflux(29)=model(41)
	Pflux(30)=model(42)
	Pflux(31)=model(43)+model(44)
	Pflux(32)=model(45)
	Pflux(33)=model(46)
	Pflux(34)=model(47)
	Pflux(35)=model(48)
	Pflux(36)=model(49)
	Pflux(37)=model(50)
	Pflux(38)=model(51)
	Pflux(39)=model(52)

C********1*********2*********3*********4*********5*********6*********7**
C	Make an energy flux from the photon flux
C********1*********2*********3*********4*********5*********6*********7**
	do 30 i=1,39
c 	  L'expression initiale est exprimee en unites de 10-7 Joules
c	  Eflux(i) = Pflux(i)*(12400.*1.6022e-12)/wave(i)
c 	  J'exprime un flux d'energie en eV
 	  Eflux(i) = Pflux(i)*12400./wave(i)
30	continue

	return
	end
c
c-----------------------------------------------------------------------
c

	subroutine getind
C********1*********2*********3*********4*********5*********6*********7**
C	This subroutine gets the row and column indicators for a given
C	date.
C********1*********2*********3*********4*********5*********6*********7**
C	implicit	none
	integer		i,row,colum
	real		c(12,52),indice(10,3750),Eflux(39)
	real		Pflux(39),wave(39),w1(39),w2(39),date,S(4)
	common	/coeff/ c,indice,date,wave,w1,w2,S,Eflux,Pflux

C********1*********2*********3*********4*********5*********6*********7**
C	Find the row and column numbers for indices on a given date then
C	place the proxy values for that date into "S" variable. Stop on
C	invalid date.
C********1*********2*********3*********4*********5*********6*********7**
	do 10 i=1,3750
	  if (ifix(date) .eq. ifix(indice(1,i))) then
	    row = i
	    colum = 1
	    goto 20
	  else if (ifix(date) .eq. ifix(indice(6,i))) then
	    row = i
	    colum = 6
	    goto 20
	  endif
10	continue

20	continue
	S(1)  = indice(colum+1,row)
	S(2)  = indice(colum+2,row)
	S(3)  = indice(colum+3,row)
	S(4)  = indice(colum+4,row)

	if (ifix(date) .ne. ifix(indice(colum,row))) then
	  write(*,*) ' Invalid date - program terminated'
	  stop
	endif

	return
	end


  !-----------------------------------------------------------------------------
  !
  !++ scale-les grid parameters (500m res., 17km isotropic, 22km model top)
  !
  !-----------------------------------------------------------------------------
  integer,  private, parameter :: KMAX =   40 ! # of computational cells: z
  integer,  private, parameter :: IMAX =   40 ! # of computational cells: x
  integer,  private, parameter :: JMAX =   40 ! # of computational cells: y

  integer,  private, parameter :: IBLOCK = 40 ! block size for cache blocking: x
  integer,  private, parameter :: JBLOCK = 40 ! block size for cache blocking: y

  real(RP), private, save      :: DZ        =  500.0_RP ! length in the main region [m]: z
  real(RP), private, save      :: DX        =  500.0_RP ! length in the main region [m]: x
  real(RP), private, save      :: DY        =  500.0_RP ! length in the main region [m]: y

  real(RP), private, save      :: BUFFER_DZ = 5000.0_RP ! thickness of buffer region [m]: z
  real(RP), private, save      :: BUFFER_DX =    0.0_RP ! thickness of buffer region [m]: x
  real(RP), private, save      :: BUFFER_DY =    0.0_RP ! thickness of buffer region [m]: y
  real(RP), private, save      :: BUFFFACT  =    1.1_RP ! strech factor for dx/dy/dz of buffer region

  include 'inc_index_all.h'