!!!------------------ Evaluate overlap integral for two unnormalized GTFs, a warpper of doSintactual for simplicity
real*8 function doSint(iGTF,jGTF)
integer iGTF,jGTF
real*8,external :: doSintactual
doSint=doSintactual(iGTF,jGTF,0,0,0,0,0,0)
end function
!!!------------------ Evaluate overlap integral for two unnormalized GTFs
!~p arguments are the shifts of GTF index, used by doKint, doveloint but not used by doSint
real*8 function doSintactual(iGTF,jGTF,ix1p,iy1p,iz1p,ix2p,iy2p,iz2p)
use util
use defvar
implicit real*8(a-h,o-z)
integer iGTF,jGTF,ix1p,iy1p,iz1p,ix2p,iy2p,iz2p
x1=a(b(iGTF)%center)%x
y1=a(b(iGTF)%center)%y
z1=a(b(iGTF)%center)%z
x2=a(b(jGTF)%center)%x
y2=a(b(jGTF)%center)%y
z2=a(b(jGTF)%center)%z
ee1=b(iGTF)%exp
ee2=b(jGTF)%exp
ep=ee1+ee2
sqrtep=dsqrt(ep)
px=(ee1*x1+ee2*x2)/ep
py=(ee1*y1+ee2*y2)/ep
pz=(ee1*z1+ee2*z2)/ep
expterm=dexp( -ee1*ee2*((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)/ep )
ix1=type2ix(b(iGTF)%type)+ix1p
iy1=type2iy(b(iGTF)%type)+iy1p
iz1=type2iz(b(iGTF)%type)+iz1p
ix2=type2ix(b(jGTF)%type)+ix2p
iy2=type2iy(b(jGTF)%type)+iy2p
iz2=type2iz(b(jGTF)%type)+iz2p
!chen book,P103
numx=ceiling( (ix1+ix2+1)/2D0 ) !Need to calculate n points
sx=0.0D0
do i=1,numx
	tmp=Rhm(numx,i)/sqrtep+px
	term1=(tmp-x1)**ix1
	term2=(tmp-x2)**ix2
	sx=sx+Whm(numx,i)*term1*term2
end do
sx=sx/sqrtep

numy=ceiling( (iy1+iy2+1)/2D0 )
sy=0.0D0
do i=1,numy
	tmp=Rhm(numy,i)/sqrtep+py
	term1=(tmp-y1)**iy1
	term2=(tmp-y2)**iy2
	sy=sy+Whm(numy,i)*term1*term2
end do
sy=sy/sqrtep

numz=ceiling( (iz1+iz2+1)/2D0 )
sz=0.0D0
do i=1,numz
	tmp=Rhm(numz,i)/sqrtep+pz
	term1=(tmp-z1)**iz1
	term2=(tmp-z2)**iz2
	sz=sz+Whm(numz,i)*term1*term2
end do
sz=sz/sqrtep

doSintactual=sx*sy*sz*expterm
end function
!!!------------------ Generate overlap matrix between all GTFs
!nsize should be nprims*(nprims+1)/2
subroutine genGTFSmat(GTFSmat,nsize)
use defvar
implicit real*8 (a-h,o-z)
integer nsize
real*8 GTFSmat(nsize)
!$OMP PARALLEL DO SHARED(GTFSmat) PRIVATE(ides,iGTF,jGTF) schedule(dynamic) NUM_THREADS(nthreads)
do iGTF=1,nprims
	do jGTF=iGTF,nprims
		ides=jGTF*(jGTF-1)/2+iGTF
		GTFSmat(ides)=doSint(iGTF,jGTF)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate overlap matrix between all Cartesian basis functions
!Sbas should be allocated first
!If current basis functions contain spherical ones, it must be then converted to spherical-harmonic one before any practical use
subroutine genSbas
use defvar
implicit real*8 (a-h,o-z)
Sbas=0D0
!$OMP PARALLEL DO SHARED(Sbas) PRIVATE(i,ii,j,jj) schedule(dynamic) NUM_THREADS(nthreads)
do i=1,nbasisCar
	do j=i,nbasisCar
		do ii=primstart(i),primend(i)
			do jj=primstart(j),primend(j)
				Sbas(i,j)=Sbas(i,j)+primconnorm(ii)*primconnorm(jj)*doSint(ii,jj)
			end do
		end do
		Sbas(j,i)=Sbas(i,j)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate overlap matrix between all current basis functions
subroutine genSbas_curr
use defvar
real*8,allocatable :: mattmp(:,:)
if (allocated(Sbas)) deallocate(Sbas)
allocate(Sbas(nbasisCar,nbasisCar))
if (isphergau==0) then
    call genSbas
else
    allocate(mattmp(nbasisCar,nbasisCar))
    call genSbas !Generate matrix in purely Cartesian basis
    mattmp=Sbas
    deallocate(Sbas);allocate(Sbas(nbasis,nbasis))
    call matCar2curr(mattmp,Sbas) !Transform matrix from Cartesian basis to current basis
end if
end subroutine

!!!-------- Evaluate dipole moment integral for two unnormalized GTFs, <GTF|-r|GTF>, the negative charge of electron has been considered!
!~p arguments are the shifts of GTF index as doSintactual
!xint/yint/zint correspond to dipole moment integral in X/Y/Z
subroutine dodipoleint(iGTF,jGTF,ix1p,iy1p,iz1p,ix2p,iy2p,iz2p,xint,yint,zint)
use util
use defvar
implicit real*8(a-h,o-z)
real*8 xint,yint,zint
integer iGTF,jGTF,ix1p,iy1p,iz1p,ix2p,iy2p,iz2p
x1=a(b(iGTF)%center)%x
y1=a(b(iGTF)%center)%y
z1=a(b(iGTF)%center)%z
x2=a(b(jGTF)%center)%x
y2=a(b(jGTF)%center)%y
z2=a(b(jGTF)%center)%z
ee1=b(iGTF)%exp
ee2=b(jGTF)%exp
ep=ee1+ee2
sqrtep=dsqrt(ep)
px=(ee1*x1+ee2*x2)/ep
py=(ee1*y1+ee2*y2)/ep
pz=(ee1*z1+ee2*z2)/ep
expterm=dexp( -ee1*ee2*((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)/ep )
ix1=type2ix(b(iGTF)%type)+ix1p
iy1=type2iy(b(iGTF)%type)+iy1p
iz1=type2iz(b(iGTF)%type)+iz1p
ix2=type2ix(b(jGTF)%type)+ix2p
iy2=type2iy(b(jGTF)%type)+iy2p
iz2=type2iz(b(jGTF)%type)+iz2p

!First, calculate sx,sy,sz as usual as doSint
numx=ceiling( (ix1+ix2+1)/2D0 ) !Need to calculate n points
sx=0.0D0
do i=1,numx
	tmp=Rhm(numx,i)/sqrtep+px
	term1=(tmp-x1)**ix1
	term2=(tmp-x2)**ix2
	sx=sx+Whm(numx,i)*term1*term2
end do
sx=sx/sqrtep
numy=ceiling( (iy1+iy2+1)/2D0 )
sy=0.0D0
do i=1,numy
	tmp=Rhm(numy,i)/sqrtep+py
	term1=(tmp-y1)**iy1
	term2=(tmp-y2)**iy2
	sy=sy+Whm(numy,i)*term1*term2
end do
sy=sy/sqrtep
numz=ceiling( (iz1+iz2+1)/2D0 )
sz=0.0D0
do i=1,numz
	tmp=Rhm(numz,i)/sqrtep+pz
	term1=(tmp-z1)**iz1
	term2=(tmp-z2)**iz2
	sz=sz+Whm(numz,i)*term1*term2
end do
sz=sz/sqrtep

!Second, calculate overlap integral in X,Y,Z directions but with X,Y,Z coordinate variables (relative to the original point of the whole system) to produce sxx,syy,szz
numx=ceiling( (ix1+ix2+2)/2D0 ) !Because X variable is introduced, ix1+ix2+2 is used instead of ix1+ix2+1
sxx=0.0D0
do i=1,numx
	tmp=Rhm(numx,i)/sqrtep+px !x coordinate relative to origin
	term1=(tmp-x1)**ix1
	term2=(tmp-x2)**ix2
	sxx=sxx+Whm(numx,i)*term1*term2*tmp
end do
sxx=sxx/sqrtep
numy=ceiling( (iy1+iy2+2)/2D0 )
syy=0.0D0
do i=1,numy
	tmp=Rhm(numy,i)/sqrtep+py
	term1=(tmp-y1)**iy1
	term2=(tmp-y2)**iy2
	syy=syy+Whm(numy,i)*term1*term2*tmp
end do
syy=syy/sqrtep
numz=ceiling( (iz1+iz2+2)/2D0 )
szz=0.0D0
do i=1,numz
	tmp=Rhm(numz,i)/sqrtep+pz
	term1=(tmp-z1)**iz1
	term2=(tmp-z2)**iz2
	szz=szz+Whm(numz,i)*term1*term2*tmp
end do
szz=szz/sqrtep

xint=-sxx*sy*sz*expterm
yint=-sx*syy*sz*expterm
zint=-sx*sy*szz*expterm
end subroutine
!------ A warpper of dodipoleint, used to directly get a single component of dipole moment integral. icomp=1/2/3 corresponds to X/Y/Z component
real*8 function dipintcomp(icomp,iGTF,jGTF,ix1p,iy1p,iz1p,ix2p,iy2p,iz2p)
integer icomp,iGTF,jGTF,ix1p,iy1p,iz1p,ix2p,iy2p,iz2p
real*8 xcomp,ycomp,zcomp
call dodipoleint(iGTF,jGTF,ix1p,iy1p,iz1p,ix2p,iy2p,iz2p,xcomp,ycomp,zcomp)
if (icomp==1) dipintcomp=xcomp
if (icomp==2) dipintcomp=ycomp
if (icomp==3) dipintcomp=zcomp
end function
!!!--------------- Generate dipole moment integral matrix between all GTFs <{GTF}|-r|{GTF}>
!nsize should be nprims*(nprims+1)/2
subroutine genGTFDmat(GTFdipmat,nsize)
use defvar
implicit real*8 (a-h,o-z)
integer nsize
real*8 GTFdipmat(3,nsize)
!$OMP PARALLEL DO SHARED(GTFdipmat) PRIVATE(ides,iGTF,jGTF,xdiptmp,ydiptmp,zdiptmp) schedule(dynamic) NUM_THREADS(nthreads)
do iGTF=1,nprims
	do jGTF=iGTF,nprims
		ides=jGTF*(jGTF-1)/2+iGTF
		call dodipoleint(iGTF,jGTF,0,0,0,0,0,0,xdiptmp,ydiptmp,zdiptmp)
		GTFdipmat(1,ides)=xdiptmp
		GTFdipmat(2,ides)=ydiptmp
		GTFdipmat(3,ides)=zdiptmp
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!--------------- Generate dipole moment integral matrix between all GTFs <{GTF}|-r|{GTF}>, store to "Dprim" matrix
subroutine genDprim
use defvar
implicit real*8 (a-h,o-z)
if (allocated(Dprim)) deallocate(Dprim)
allocate(Dprim(3,nprims,nprims))
!$OMP PARALLEL DO SHARED(Dprim) PRIVATE(iGTF,jGTF) schedule(dynamic) NUM_THREADS(nthreads)
do iGTF=1,nprims
	do jGTF=iGTF,nprims
		call dodipoleint(iGTF,jGTF,0,0,0,0,0,0,Dprim(1,iGTF,jGTF),Dprim(2,iGTF,jGTF),Dprim(3,iGTF,jGTF))
        Dprim(:,jGTF,iGTF)=Dprim(:,iGTF,jGTF)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!----------- Generate dipole moment integral matrix between all Cartesian basis functions, <{basis}|-r|{basis}>
!Dbas should be allocated first
!If current basis functions contain spherical ones, it must be then converted to spherical-harmonic one before any practical use
subroutine genDbas
use defvar
implicit real*8 (a-h,o-z)
Dbas=0D0
!$OMP PARALLEL DO SHARED(Dbas) PRIVATE(i,ii,j,jj,xdiptmp,ydiptmp,zdiptmp) schedule(dynamic) NUM_THREADS(nthreads)
do i=1,nbasisCar
	do j=i,nbasisCar
		do ii=primstart(i),primend(i)
			do jj=primstart(j),primend(j)
				call dodipoleint(ii,jj,0,0,0,0,0,0,xdiptmp,ydiptmp,zdiptmp)
				Dbas(1,i,j)=Dbas(1,i,j)+primconnorm(ii)*primconnorm(jj)*xdiptmp
				Dbas(2,i,j)=Dbas(2,i,j)+primconnorm(ii)*primconnorm(jj)*ydiptmp
				Dbas(3,i,j)=Dbas(3,i,j)+primconnorm(ii)*primconnorm(jj)*zdiptmp
			end do
		end do
		Dbas(:,j,i)=Dbas(:,i,j)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate dipole moment integral matrix between all current basis functions
subroutine genDbas_curr
use defvar
real*8,allocatable :: mattmp(:,:,:)
if (allocated(Dbas)) deallocate(Dbas)
allocate(Dbas(3,nbasisCar,nbasisCar))
if (isphergau==0) then
    call genDbas
else
    allocate(mattmp(3,nbasisCar,nbasisCar))
    call genDbas !Generate matrix in purely Cartesian basis
    mattmp=Dbas
    deallocate(Dbas);allocate(Dbas(3,nbasis,nbasis))
    do i=1,3
        call matCar2curr(mattmp(i,:,:),Dbas(i,:,:)) !Transform matrix from Cartesian basis to current basis
    end do
end if
end subroutine
!!!---------- Generate dipole moment integral matrix between all orbitals via unitary transformation of Dbas <{orb}|-r|{orb}>
!Dbas must be already filled. DorbA and DorbB are global arrays
subroutine genDorb
use defvar
integer i
do i=1,3
	DorbA(i,:,:)=matmul(matmul(transpose(CObasa),Dbas(i,:,:)),CObasa)
end do
if (allocated(CObasb)) then
	do i=1,3
		DorbB(i,:,:)=matmul(matmul(transpose(CObasb),Dbas(i,:,:)),CObasb)
	end do
end if
end subroutine

!!!------- Evaluate magnetic integral for two unnormalized GTFs
!The imaginary sign i is ignored. Note that the negative sign of magnetic operator is not occurred here
!Consult doVelint for the method for evaluation of <a|d/dx|b>, and TCA,6,341 for the formula of magnetic integral
subroutine doMagint(iGTF,jGTF,xcomp,ycomp,zcomp)
use defvar
implicit real*8(a-h,o-z)
integer iGTF,jGTF
real*8 xcomp,ycomp,zcomp,term(4)
ee1=b(iGTF)%exp
ee2=b(jGTF)%exp
ix1=type2ix(b(iGTF)%type)
iy1=type2iy(b(iGTF)%type)
iz1=type2iz(b(iGTF)%type)
ix2=type2ix(b(jGTF)%type)
iy2=type2iy(b(jGTF)%type)
iz2=type2iz(b(jGTF)%type)
term=0
!X component, <a|y*d/dz-z*d/dy|b>. Since <a|d/dz|b>=iz2*<a|b-1z>-2*ee2*<a|b+1z>, the term such as <a|y*d/dz|b> can be evaluated in terms of dipole integrals iz2*<a|y|b-1z>-2*ee2*<a|y|b+1z>
if(iz2>0) term(1)=   iz2*dipintcomp(2,iGTF,jGTF,0,0,0,0,0,-1) !viz. iz2*<a|y|b-1z>
          term(2)=-2*ee2*dipintcomp(2,iGTF,jGTF,0,0,0,0,0, 1)
if(iy2>0) term(3)=  -iy2*dipintcomp(3,iGTF,jGTF,0,0,0,0,-1,0)
          term(4)= 2*ee2*dipintcomp(3,iGTF,jGTF,0,0,0,0, 1,0)
xcomp=-sum(term) !Note that the result of dipintcomp has a negative sign due to the negative charge of electron, so here revise the sign
term=0
!Y component, <a|z*d/dx-x*d/dz|b>
if(ix2>0) term(1)=   ix2*dipintcomp(3,iGTF,jGTF,0,0,0,-1,0,0)
          term(2)=-2*ee2*dipintcomp(3,iGTF,jGTF,0,0,0, 1,0,0)
if(iz2>0) term(3)=  -iz2*dipintcomp(1,iGTF,jGTF,0,0,0,0,0,-1)
          term(4)= 2*ee2*dipintcomp(1,iGTF,jGTF,0,0,0,0,0, 1)
ycomp=-sum(term)
term=0
!Z component, <a|x*d/dy-y*d/dx|b>
if(iy2>0) term(1)=   iy2*dipintcomp(1,iGTF,jGTF,0,0,0,0,-1,0)
          term(2)=-2*ee2*dipintcomp(1,iGTF,jGTF,0,0,0,0, 1,0)
if(ix2>0) term(3)=  -ix2*dipintcomp(2,iGTF,jGTF,0,0,0,-1,0,0)
          term(4)= 2*ee2*dipintcomp(2,iGTF,jGTF,0,0,0, 1,0,0)
zcomp=-sum(term)
end subroutine
!!!--------------- Generate magnetic dipole moment integral matrix between all GTFs
!nsize should be nprims*(nprims+1)/2
!Beware that when using this result, (j,i) element should be set to negative value of (i,j) due to the Hermitean character of this operator!
subroutine genGTFMmat(GTFdipmat,nsize)
use defvar
implicit real*8 (a-h,o-z)
integer nsize
real*8 GTFdipmat(3,nsize)
GTFdipmat=0D0
!$OMP PARALLEL DO SHARED(GTFdipmat) PRIVATE(ides,iGTF,jGTF,xdiptmp,ydiptmp,zdiptmp) schedule(dynamic) NUM_THREADS(nthreads)
do iGTF=1,nprims
	do jGTF=iGTF+1,nprims !For iGTF=jGTF, the value must exactly zero, so don't calculate
		ides=jGTF*(jGTF-1)/2+iGTF
		call doMagint(iGTF,jGTF,xdiptmp,ydiptmp,zdiptmp)
		GTFdipmat(1,ides)=xdiptmp
		GTFdipmat(2,ides)=ydiptmp
		GTFdipmat(3,ides)=zdiptmp
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate magnetic dipole moment integral matrix between all Cartesian basis functions
!Magbas should be allocated first
!If current basis functions contain spherical ones, it must be then converted to spherical-harmonic one before any practical use
!Notice that the diagonal element of magnetic integral matrix is zero, and (i,j)=-(j,i) due to Hermitean character
subroutine genMagbas
use defvar
implicit real*8 (a-h,o-z)
Magbas=0D0
!$OMP PARALLEL DO SHARED(Magbas) PRIVATE(i,ii,j,jj,xcomp,ycomp,zcomp) schedule(dynamic) NUM_THREADS(nthreads)
do i=1,nbasisCar
	do j=i+1,nbasisCar
		do ii=primstart(i),primend(i)
			do jj=primstart(j),primend(j)
				call doMagint(ii,jj,xcomp,ycomp,zcomp)
				Magbas(1,i,j)=Magbas(1,i,j)+primconnorm(ii)*primconnorm(jj)*xcomp
				Magbas(2,i,j)=Magbas(2,i,j)+primconnorm(ii)*primconnorm(jj)*ycomp
				Magbas(3,i,j)=Magbas(3,i,j)+primconnorm(ii)*primconnorm(jj)*zcomp
			end do
		end do
		Magbas(:,j,i)=-Magbas(:,i,j)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate magnetic dipole moment integral matrix between all current basis functions
subroutine genMagbas_curr
use defvar
real*8,allocatable :: mattmp(:,:,:)
if (allocated(Magbas)) deallocate(Magbas)
allocate(Magbas(3,nbasisCar,nbasisCar))
if (isphergau==0) then
    call genMagbas
else
    allocate(mattmp(3,nbasisCar,nbasisCar))
    call genMagbas !Generate matrix in purely Cartesian basis
    mattmp=Magbas
    deallocate(Magbas);allocate(Magbas(3,nbasis,nbasis))
    do i=1,3
        call matCar2curr(mattmp(i,:,:),Magbas(i,:,:)) !Transform matrix from Cartesian basis to current basis
    end do
end if
end subroutine

!!!------- Evaluate velocity integral for two unnormalized GTFs
!There are three components. e.g. X direction: i<a|d/dx|b>. The imaginary sign i is ignored. Note that the negative sign of momentum operator is not occurred here
!One can consult p97 of Chen's book for the derivative of GTF. Namely <a|d/dx|b>=ix2*<a|b-1x>-2*ee2*<a|b+1x>
subroutine doVelint(iGTF,jGTF,xcomp,ycomp,zcomp)
use defvar
implicit real*8(a-h,o-z)
integer iGTF,jGTF
real*8 xcomp,ycomp,zcomp
ee1=b(iGTF)%exp
ee2=b(jGTF)%exp
ix1=type2ix(b(iGTF)%type)
iy1=type2iy(b(iGTF)%type)
iz1=type2iz(b(iGTF)%type)
ix2=type2ix(b(jGTF)%type)
iy2=type2iy(b(jGTF)%type)
iz2=type2iz(b(jGTF)%type)
term1=0
if(ix2>0) term1=   ix2*doSintactual(iGTF,jGTF,0,0,0,-1,0,0)
          term2=-2*ee2*doSintactual(iGTF,jGTF,0,0,0, 1,0,0)
xcomp=term1+term2
term1=0
if(iy2>0) term1=   iy2*doSintactual(iGTF,jGTF,0,0,0,0,-1,0)
          term2=-2*ee2*doSintactual(iGTF,jGTF,0,0,0,0, 1,0)
ycomp=term1+term2
term1=0
if(iz2>0) term1=   iz2*doSintactual(iGTF,jGTF,0,0,0,0,0,-1)
          term2=-2*ee2*doSintactual(iGTF,jGTF,0,0,0,0,0, 1)
zcomp=term1+term2
end subroutine
!!!--------------- Generate velocity integral matrix between all GTFs
!nsize should be nprims*(nprims+1)/2
!Beware that when using this result, (j,i) element should be set to negative value of (i,j) due to the Hermitean character of this operator!
subroutine genGTFVelmat(GTFVelmat,nsize)
use defvar
implicit real*8 (a-h,o-z)
integer nsize
real*8 GTFVelmat(3,nsize)
!$OMP PARALLEL DO SHARED(GTFVelmat) PRIVATE(ides,iGTF,jGTF,xtmp,ytmp,ztmp) schedule(dynamic) NUM_THREADS(nthreads)
do iGTF=1,nprims
	do jGTF=iGTF,nprims
		ides=jGTF*(jGTF-1)/2+iGTF
		call doVelint(iGTF,jGTF,xtmp,ytmp,ztmp)
		GTFVelmat(1,ides)=xtmp
		GTFVelmat(2,ides)=ytmp
		GTFVelmat(3,ides)=ztmp
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate velocity integral matrix between all Cartesian basis functions
!Velbas should be allocated first
!If current basis functions contain spherical ones, it must be then converted to spherical-harmonic one before any practical use
!Notice that the diagonal element of velocity integral matrix is zero, and (i,j)=-(j,i) due to Hermitean character
subroutine genVelbas
use defvar
implicit real*8 (a-h,o-z)
Velbas=0D0
!$OMP PARALLEL DO SHARED(Velbas) PRIVATE(i,ii,j,jj,xcomp,ycomp,zcomp) schedule(dynamic) NUM_THREADS(nthreads)
do i=1,nbasisCar
	do j=i+1,nbasisCar
		do ii=primstart(i),primend(i)
			do jj=primstart(j),primend(j)
				call doVelint(ii,jj,xcomp,ycomp,zcomp)
				Velbas(1,i,j)=Velbas(1,i,j)+primconnorm(ii)*primconnorm(jj)*xcomp
				Velbas(2,i,j)=Velbas(2,i,j)+primconnorm(ii)*primconnorm(jj)*ycomp
				Velbas(3,i,j)=Velbas(3,i,j)+primconnorm(ii)*primconnorm(jj)*zcomp
			end do
		end do
		Velbas(:,j,i)=-Velbas(:,i,j)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate velocity integral matrix between all current basis functions
subroutine genVelbas_curr
use defvar
real*8,allocatable :: mattmp(:,:,:)
if (allocated(Velbas)) deallocate(Velbas)
allocate(Velbas(3,nbasisCar,nbasisCar))
if (isphergau==0) then
    call genVelbas
else
    allocate(mattmp(3,nbasisCar,nbasisCar))
    call genVelbas !Generate matrix in purely Cartesian basis
    mattmp=Velbas
    deallocate(Velbas);allocate(Velbas(3,nbasis,nbasis))
    do i=1,3
        call matCar2curr(mattmp(i,:,:),Velbas(i,:,:)) !Transform matrix from Cartesian basis to current basis
    end do
end if
end subroutine

!!!------------------- Evaluate kinetic integral (i.e. -(1/2)der2 )for two unnormalized GTFs, see Chen's book, p104
real*8 function doTint(iGTF,jGTF)
use defvar
implicit real*8(a-h,o-z)
integer iGTF,jGTF
real*8 term(4)
ee1=b(iGTF)%exp
ee2=b(jGTF)%exp
ix1=type2ix(b(iGTF)%type)
iy1=type2iy(b(iGTF)%type)
iz1=type2iz(b(iGTF)%type)
ix2=type2ix(b(jGTF)%type)
iy2=type2iy(b(jGTF)%type)
iz2=type2iz(b(jGTF)%type)
term=0
if(ix1>0.and.ix2>0)  term(1)=   ix1*ix2*doSintactual(iGTF,jGTF,-1,0,0,-1,0,0)
if(ix1>0)            term(2)=-2*ee2*ix1*doSintactual(iGTF,jGTF,-1,0,0, 1,0,0)
if(ix2>0)            term(3)=-2*ee1*ix2*doSintactual(iGTF,jGTF, 1,0,0,-1,0,0)
                     term(4)= 4*ee1*ee2*doSintactual(iGTF,jGTF, 1,0,0, 1,0,0)
Tx=sum(term)
term=0
if(iy1>0.and.iy2>0)  term(1)=   iy1*iy2*doSintactual(iGTF,jGTF,0,-1,0,0,-1,0)
if(iy1>0)            term(2)=-2*ee2*iy1*doSintactual(iGTF,jGTF,0,-1,0,0, 1,0)
if(iy2>0)            term(3)=-2*ee1*iy2*doSintactual(iGTF,jGTF,0, 1,0,0,-1,0)
                     term(4)= 4*ee1*ee2*doSintactual(iGTF,jGTF,0, 1,0,0, 1,0)
Ty=sum(term)
term=0
if(iz1>0.and.iz2>0)  term(1)=   iz1*iz2*doSintactual(iGTF,jGTF,0,0,-1,0,0,-1)
if(iz1>0)            term(2)=-2*ee2*iz1*doSintactual(iGTF,jGTF,0,0,-1,0,0, 1)
if(iz2>0)            term(3)=-2*ee1*iz2*doSintactual(iGTF,jGTF,0,0, 1,0,0,-1)
                     term(4)= 4*ee1*ee2*doSintactual(iGTF,jGTF,0,0, 1,0,0, 1)
Tz=sum(term)
doTint=(Tx+Ty+Tz)/2
end function
!!!------------------ Generate kinetic energy matrix between all GTFs
!nsize should be nprims*(nprims+1)/2
subroutine genGTFTmat(GTFTmat,nsize)
use defvar
implicit real*8 (a-h,o-z)
integer nsize
real*8 GTFTmat(nsize)
!$OMP PARALLEL DO SHARED(GTFTmat) PRIVATE(ides,iGTF,jGTF) schedule(dynamic) NUM_THREADS(nthreads)
do iGTF=1,nprims
	do jGTF=iGTF,nprims
		ides=jGTF*(jGTF-1)/2+iGTF
		GTFTmat(ides)=doTint(iGTF,jGTF)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate kinetic energy matrix between all Cartesian basis functions
!Tbas should be allocated first
!If current basis functions contain spherical ones, it must be then converted to spherical-harmonic one before any practical use
subroutine genTbas
use defvar
implicit real*8 (a-h,o-z)
Tbas=0D0
!$OMP PARALLEL DO SHARED(Tbas) PRIVATE(i,ii,j,jj) schedule(dynamic) NUM_THREADS(nthreads)
do i=1,nbasisCar
	do j=i,nbasisCar
		do ii=primstart(i),primend(i)
			do jj=primstart(j),primend(j)
				Tbas(i,j)=Tbas(i,j)+primconnorm(ii)*primconnorm(jj)*doTint(ii,jj)
			end do
		end do
		Tbas(j,i)=Tbas(i,j)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------------ Generate kinetic energy matrix between all current basis functions
subroutine genTbas_curr
use defvar
real*8,allocatable :: mattmp(:,:)
if (allocated(Tbas)) deallocate(Tbas)
allocate(Tbas(nbasisCar,nbasisCar))
if (isphergau==0) then
    call genTbas
else
    allocate(mattmp(nbasisCar,nbasisCar))
    call genTbas !Generate matrix in purely Cartesian basis
    mattmp=Tbas
    deallocate(Tbas);allocate(Tbas(nbasis,nbasis))
    call matCar2curr(mattmp,Tbas) !Transform matrix from Cartesian basis to current basis
end if
end subroutine

!!!-------- Evaluate dipole, quadrupole, octopole and hexadecapole moment integral for two unnormalized GTFs, e.g. <GTF|-xz|GTF>
!The negative charge of electron has been considered!
subroutine domultipoleint(iGTF,jGTF,D,Quad,Octo,Hexde)
use util
use defvar
implicit real*8(a-h,o-z)
real*8 D(3),Quad(6),Octo(10),Hexde(15)
integer iGTF,jGTF
integer,parameter :: maxorder=4 !Maximum order of GTF with respect to a direction
real*8 sx(0:maxorder),sy(0:maxorder),sz(0:maxorder)

x1=a(b(iGTF)%center)%x
y1=a(b(iGTF)%center)%y
z1=a(b(iGTF)%center)%z
x2=a(b(jGTF)%center)%x
y2=a(b(jGTF)%center)%y
z2=a(b(jGTF)%center)%z
ee1=b(iGTF)%exp
ee2=b(jGTF)%exp
ep=ee1+ee2
sqrtep=dsqrt(ep)
px=(ee1*x1+ee2*x2)/ep
py=(ee1*y1+ee2*y2)/ep
pz=(ee1*z1+ee2*z2)/ep
expterm=dexp( -ee1*ee2*((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)/ep )
ix1=type2ix(b(iGTF)%type)
iy1=type2iy(b(iGTF)%type)
iz1=type2iz(b(iGTF)%type)
ix2=type2ix(b(jGTF)%type)
iy2=type2iy(b(jGTF)%type)
iz2=type2iz(b(jGTF)%type)

!sx(0) corresponds to the sx in subroutine doSint, sx(i) is used in order of i in x direction
sx=0
sy=0
sz=0
do iorder=0,maxorder
	numx=ceiling( (ix1+ix2+1+iorder)/2D0 ) !Need to calculate n points
	do i=1,numx
		tmp=Rhm(numx,i)/sqrtep+px
		term1=(tmp-x1)**ix1
		term2=(tmp-x2)**ix2
		sx(iorder)=sx(iorder)+Whm(numx,i)*term1*term2*tmp**iorder
	end do
    sx(iorder)=sx(iorder)

	numy=ceiling( (iy1+iy2+1+iorder)/2D0 )
	do i=1,numy
		tmp=Rhm(numy,i)/sqrtep+py
		term1=(tmp-y1)**iy1
		term2=(tmp-y2)**iy2
		sy(iorder)=sy(iorder)+Whm(numy,i)*term1*term2*tmp**iorder
	end do

	numz=ceiling( (iz1+iz2+1+iorder)/2D0 )
	do i=1,numz
		tmp=Rhm(numz,i)/sqrtep+pz
		term1=(tmp-z1)**iz1
		term2=(tmp-z2)**iz2
		sz(iorder)=sz(iorder)+Whm(numz,i)*term1*term2*tmp**iorder
	end do
end do
sx=sx/sqrtep
sy=sy/sqrtep
sz=sz/sqrtep

D(1)=-sx(1)*sy(0)*sz(0) !X
D(2)=-sx(0)*sy(1)*sz(0) !Y
D(3)=-sx(0)*sy(0)*sz(1) !Z
D=D*expterm

Quad(1)=-sx(2)*sy(0)*sz(0) !XX
Quad(2)=-sx(0)*sy(2)*sz(0) !YY
Quad(3)=-sx(0)*sy(0)*sz(2) !ZZ
Quad(4)=-sx(1)*sy(1)*sz(0) !XY
Quad(5)=-sx(0)*sy(1)*sz(1) !YZ
Quad(6)=-sx(1)*sy(0)*sz(1) !XZ
Quad=Quad*expterm

Octo(1)=-sx(3)*sy(0)*sz(0) !XXX
Octo(2)=-sx(0)*sy(3)*sz(0) !YYY
Octo(3)=-sx(0)*sy(0)*sz(3) !ZZZ
Octo(4)=-sx(0)*sy(1)*sz(2) !YZZ
Octo(5)=-sx(1)*sy(0)*sz(2) !XZZ
Octo(6)=-sx(2)*sy(0)*sz(1) !XXZ
Octo(7)=-sx(0)*sy(2)*sz(1) !YYZ
Octo(8)=-sx(2)*sy(1)*sz(0) !XXY
Octo(9)=-sx(1)*sy(2)*sz(0) !XYY
Octo(10)=-sx(1)*sy(1)*sz(1) !XYZ
Octo=Octo*expterm

Hexde(1)=-sx(4)*sy(0)*sz(0) !XXXX
Hexde(2)=-sx(0)*sy(4)*sz(0) !YYYY
Hexde(3)=-sx(0)*sy(0)*sz(4) !ZZZZ
Hexde(4)=-sx(3)*sy(1)*sz(0) !XXXY
Hexde(5)=-sx(3)*sy(0)*sz(1) !XXXZ
Hexde(6)=-sx(1)*sy(3)*sz(0) !YYYX
Hexde(7)=-sx(0)*sy(3)*sz(1) !YYYZ
Hexde(8)=-sx(1)*sy(0)*sz(3) !ZZZX
Hexde(9)=-sx(0)*sy(1)*sz(3) !ZZZY
Hexde(10)=-sx(2)*sy(2)*sz(0) !XXYY
Hexde(11)=-sx(2)*sy(0)*sz(2) !XXZZ
Hexde(12)=-sx(0)*sy(2)*sz(2) !YYZZ
Hexde(13)=-sx(2)*sy(1)*sz(1) !XXYZ
Hexde(14)=-sx(1)*sy(2)*sz(1) !YYXZ
Hexde(15)=-sx(1)*sy(1)*sz(2) !ZZXY
Hexde=Hexde*expterm
end subroutine

!!!-------- Generate electric dipole ~ Hexadecapole moment integral matrix between all GTFs, e.g. -<GTF_i|-xz|GTF_j>
subroutine genMultipoleprim
use defvar
implicit real*8 (a-h,o-z)
if (allocated(Dprim)) deallocate(Dprim)
allocate(Dprim(3,nprims,nprims))
if (allocated(Quadprim)) deallocate(Quadprim)
allocate(Quadprim(6,nprims,nprims))
if (allocated(Octoprim)) deallocate(Octoprim)
allocate(Octoprim(10,nprims,nprims))
if (allocated(Hexdeprim)) deallocate(Hexdeprim)
allocate(Hexdeprim(15,nprims,nprims))
Dprim=0D0
Quadprim=0D0
Octoprim=0D0
Hexdeprim=0D0
!$OMP PARALLEL DO SHARED(Dprim,Quadprim,Octoprim,Hexdeprim) PRIVATE(i,j) schedule(dynamic) NUM_THREADS(nthreads)
do i=1,nprims
	do j=i,nprims
        call domultipoleint(i,j,Dprim(:,i,j),Quadprim(:,i,j),Octoprim(:,i,j),Hexdeprim(:,i,j))
		Dprim(:,j,i)=Dprim(:,i,j)
		Quadprim(:,j,i)=Quadprim(:,i,j)
		Octoprim(:,j,i)=Octoprim(:,i,j)
		Hexdeprim(:,j,i)=Hexdeprim(:,i,j)
	end do
end do
!$OMP END PARALLEL DO
end subroutine

!!!-------- Generate electric dipole ~ hexadecapole moment integral matrix between all Cartesian basis functions, e.g. -<basis_i|-xz|basis_j>
!Dbas should be allocated first. First index 1~3=X,Y,Z
!Quadbas should be allocated first. First index 1~6=XX,YY,ZZ,XY,YZ,XZ
!Octobas should be allocated first. First index 1~10=XXX,YYY,ZZZ,YZZ,XZZ,XXZ,YYZ,XXY,XYY,XYZ
!Hexdebas should be allocated first. First index 1~15=XXXX,YYYY,ZZZZ,XXXY,XXXZ,YYYX,YYYZ,ZZZX,ZZZY,XXYY,XXZZ,YYZZ,XXYZ,YYXZ,ZZXY (same as Gaussian)
!If current basis functions contain spherical ones, it must be then converted to spherical-harmonic one before any practical use
subroutine genMultipolebas
use defvar
implicit real*8 (a-h,o-z)
real*8 Dtmp(3),Quadtmp(6),Octotmp(10),Hexdetmp(15)
Dbas=0D0
Quadbas=0D0
Octobas=0D0
Hexdebas=0D0
!$OMP PARALLEL DO SHARED(Dbas,Quadbas,Octobas,Hexdebas) PRIVATE(i,ii,j,jj,Dtmp,Quadtmp,Octotmp,Hexdetmp) schedule(dynamic) NUM_THREADS(nthreads)
do i=1,nbasisCar
	do j=i,nbasisCar
		do ii=primstart(i),primend(i)
			do jj=primstart(j),primend(j)
				call domultipoleint(ii,jj,Dtmp(:),Quadtmp(:),Octotmp(:),Hexdetmp(:))
                Dbas(:,i,j)=Dbas(:,i,j)+primconnorm(ii)*primconnorm(jj)*Dtmp(:)
                Quadbas(:,i,j)=Quadbas(:,i,j)+primconnorm(ii)*primconnorm(jj)*Quadtmp(:)
                Octobas(:,i,j)=Octobas(:,i,j)+primconnorm(ii)*primconnorm(jj)*Octotmp(:)
                Hexdebas(:,i,j)=Hexdebas(:,i,j)+primconnorm(ii)*primconnorm(jj)*Hexdetmp(:)
			end do
		end do
		Dbas(:,j,i)=Dbas(:,i,j)
		Quadbas(:,j,i)=Quadbas(:,i,j)
		Octobas(:,j,i)=Octobas(:,i,j)
		Hexdebas(:,j,i)=Hexdebas(:,i,j)
	end do
end do
!$OMP END PARALLEL DO
end subroutine
!!!------------- Generate electric dipole ~ hexadecapole moment integral matrix between all current basis functions
subroutine genMultipolebas_curr
use defvar
real*8,allocatable :: mattmp(:,:,:)
if (allocated(Dbas)) deallocate(Dbas)
allocate(Dbas(6,nbasisCar,nbasisCar))
if (allocated(Quadbas)) deallocate(Quadbas)
allocate(Quadbas(6,nbasisCar,nbasisCar))
if (allocated(Octobas)) deallocate(Octobas)
allocate(Octobas(10,nbasisCar,nbasisCar))
if (allocated(Hexdebas)) deallocate(Hexdebas)
allocate(Hexdebas(15,nbasisCar,nbasisCar))
if (isphergau==0) then
    call genMultipolebas
else
    allocate(mattmp(15,nbasisCar,nbasisCar))
    call genMultipolebas !Generate matrix in purely Cartesian basis
    mattmp(1:3,:,:)=Dbas(:,:,:)
    deallocate(Dbas);allocate(Dbas(3,nbasis,nbasis))
    do i=1,3
        call matCar2curr(mattmp(i,:,:),Dbas(i,:,:)) !Transform matrix from Cartesian basis to current basis
    end do
    mattmp(1:6,:,:)=Quadbas(:,:,:)
    deallocate(Quadbas);allocate(Quadbas(6,nbasis,nbasis))
    do i=1,6
        call matCar2curr(mattmp(i,:,:),Quadbas(i,:,:)) !Transform matrix from Cartesian basis to current basis
    end do
    mattmp(1:10,:,:)=Octobas(:,:,:)
    deallocate(Octobas);allocate(Octobas(10,nbasis,nbasis))
    do i=1,10
        call matCar2curr(mattmp(i,:,:),Octobas(i,:,:)) !Transform matrix from Cartesian basis to current basis
    end do
    mattmp(1:15,:,:)=Hexdebas(:,:,:)
    deallocate(Hexdebas);allocate(Hexdebas(15,nbasis,nbasis))
    do i=1,15
        call matCar2curr(mattmp(i,:,:),Hexdebas(i,:,:)) !Transform matrix from Cartesian basis to current basis
    end do
end if
end subroutine

!!!---------- Transform a matrix from Cartesian basis functions (matCar) to current basis functions (matcurr)
!Inputted matCar has dimension of nbasisCar
!Returned matcurr has dimension of nbasis
subroutine matCar2curr(matCar,matcurr)
use defvar
implicit real*8 (a-h,o-z)
real*8 conv5d6d(6,5),conv7f10f(10,7),conv9g15g(15,9),conv11h21h(21,11)
real*8 conv5d6dtr(5,6),conv7f10ftr(7,10),conv9g15gtr(9,15),conv11h21htr(11,21)
real*8 matCar(nbasisCar,nbasisCar),matcurr(nbasis,nbasis)

if (ifiletype==1.or.ifiletype==14) then !Fch or mwfn case
    call gensphcartab(1,conv5d6d,conv7f10f,conv9g15g,conv11h21h)
else if (ifiletype==9) then !Molden case
    call gensphcartab(2,conv5d6d,conv7f10f,conv9g15g,conv11h21h)
else
	write(*,*) "Error: The file type is not supported by matCar2curr!"
    read(*,*)
end if
conv5d6dtr=transpose(conv5d6d)
conv7f10ftr=transpose(conv7f10f)
conv9g15gtr=transpose(conv9g15g)
conv11h21htr=transpose(conv11h21h)

ipos5D=1
ipos6D=1
do ish=1,nshell
	ishtyp5D=shtype(ish)
	ishtyp6D=shtypeCar(ish)
	numshorb5D=shtype2nbas(ishtyp5D)
	numshorb6D=shtype2nbas(ishtyp6D)
    !write(*,*) ishtyp5D,ishtyp6D,numshorb5D,numshorb6D
	!Now contract columns of Sbas
	if (ishtyp5D>=-1) matCar(:,ipos5D:ipos5D+numshorb5D-1)=matCar(:,ipos6D:ipos6D+numshorb6D-1) !S, P, SP or other Cartesian shells
	if (ishtyp5D==-2) matCar(:,ipos5D:ipos5D+numshorb5D-1)=matmul(matCar(:,ipos6D:ipos6D+numshorb6D-1),conv5d6d)
	if (ishtyp5D==-3) matCar(:,ipos5D:ipos5D+numshorb5D-1)=matmul(matCar(:,ipos6D:ipos6D+numshorb6D-1),conv7f10f)
	if (ishtyp5D==-4) matCar(:,ipos5D:ipos5D+numshorb5D-1)=matmul(matCar(:,ipos6D:ipos6D+numshorb6D-1),conv9g15g)
	if (ishtyp5D==-5) matCar(:,ipos5D:ipos5D+numshorb5D-1)=matmul(matCar(:,ipos6D:ipos6D+numshorb6D-1),conv11h21h)
	!Now contract rows of matCar
	if (ishtyp5D>=-1) matCar(ipos5D:ipos5D+numshorb5D-1,:)=matCar(ipos6D:ipos6D+numshorb6D-1,:) !S, P, SP or other Cartesian shells
	if (ishtyp5D==-2) matCar(ipos5D:ipos5D+numshorb5D-1,:)=matmul(conv5d6dtr,matCar(ipos6D:ipos6D+numshorb6D-1,:))
	if (ishtyp5D==-3) matCar(ipos5D:ipos5D+numshorb5D-1,:)=matmul(conv7f10ftr,matCar(ipos6D:ipos6D+numshorb6D-1,:))
	if (ishtyp5D==-4) matCar(ipos5D:ipos5D+numshorb5D-1,:)=matmul(conv9g15gtr,matCar(ipos6D:ipos6D+numshorb6D-1,:))
	if (ishtyp5D==-5) matCar(ipos5D:ipos5D+numshorb5D-1,:)=matmul(conv11h21htr,matCar(ipos6D:ipos6D+numshorb6D-1,:))
	ipos5D=ipos5D+numshorb5D
	ipos6D=ipos6D+numshorb6D
end do
matcurr=matCar(1:nbasis,1:nbasis)
end subroutine


!==============================================================================!
  subroutine Grid_Mod_Calculate_Wall_Distance(grid)
!------------------------------------------------------------------------------!
!   Calculate distance from the cell center to the nearest wall.               !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer              :: b, c1, c2
  integer              :: n_wall_colors, n_cells_fraction
  integer              :: processed_cells
  integer, allocatable :: wall_colors(:)
!==============================================================================!

  !------------------------------------------------------------------!
  !   Calculate distance from the cell center to the nearest wall.   !
  !------------------------------------------------------------------!
  !     => depends on: xc,yc,zc inside and on the boundary.          !
  !     <= gives:      wall_dist                                     !
  !------------------------------------------------------------------!
  grid % wall_dist = HUGE

  call Grid_Mod_Print_Bnd_Cond_List(grid)
  print *, '#=================================================================='
  print *, '# Calculating distance from the walls                              '
  print *, '#------------------------------------------------------------------'
  print *, '# Type ordinal number(s) of wall or wall_flux boundary condition(s)'
  print *, '# from the boundary condition list (see above) separated by space. '
  print *, '# Cells'' centers distances to the nearest wall will be calculated '
  print *, '# for the listed wall boundary(s).                                 '
  print *, '# This is needed for RANS and HYBRID turbulence models.            '
  print *, '#------------------------------------------------------------------'
  call File_Mod_Read_Line(5)
  n_wall_colors = line % n_tokens
  allocate(wall_colors(n_wall_colors))
  do b = 1, n_wall_colors
    read(line % tokens(b), *) wall_colors(b)
  end do

  if( (n_wall_colors .eq. 1) .and. (wall_colors(1) .eq. 0) ) then
    grid % wall_dist = 1.0
    print *, '# Distance to the wall set to 1.0 everywhere !'
  else
    n_cells_fraction = (grid % n_bnd_cells + grid % n_cells) / 20

    processed_cells = 0

    !$omp parallel do
    do c1 = -grid % n_bnd_cells, grid % n_cells

      processed_cells = processed_cells + 1

      if(mod( (processed_cells), n_cells_fraction ) .eq. 0) then
        print '(a2, f5.0, a14)',                                  &
          ' #',                                                   &
          (100. * processed_cells                                 &
                 / (1.0*(grid % n_bnd_cells + grid % n_cells))),  &
          ' % complete...'
      end if ! each 5%

      do b = 1, n_wall_colors
        do c2 = grid % bnd_cond % color_s_cell( wall_colors(b) ),  &
                grid % bnd_cond % color_e_cell( wall_colors(b) ),  &
                -1
          grid % wall_dist(c1) =  &
            min(grid % wall_dist(c1),                     &
                Math_Mod_Distance_Squared(grid % xc(c1),  &
                                          grid % yc(c1),  &
                                          grid % zc(c1),  &
                                          grid % xc(c2),  &
                                          grid % yc(c2),  &
                                          grid % zc(c2)))
        end do
      end do
    end do
    !$omp end parallel do

    grid % wall_dist(:) = sqrt(grid % wall_dist(:))

    print *, '# Distance to the wall calculated !'
  end if

  deallocate(wall_colors)

  end subroutine


      program day04
      integer i, j, k, l, m, n(2), p, q, r
      logical rept
      n = 0

      read(*,*) i, j

c     Reset
 1    k = i
      p = 0
      q = 999999
      r = 0

c     Get the rightmost digit
      l = MOD(k, 10)

c     Get the next digit
 2    m = MOD(k/10, 10)

c     Ensure digits are decreasing
      if(m.le.l) then
c        Check for a group
         if (m.eq.l) then
c           A group of at least 2
            p = p + 1
            r = p
         else
c           Record the size of the smallest group
            if (p.ge.1) q = min(q, p)
            p = 0
         end if

         l = m
         k = k / 10
         if (k.ne.0) go to 2
      end if

 3    if (k.eq.0) then
c        All the digits were in order
         if (r.gt.0) then
c     Had some repeating digits (part one)
            n(1) = n(1) + 1
         end if
         if (q.eq.1) then
c     Had repeating digits of group size exactly 2
            n(2) = n(2) + 1
         end if
      end if

c     Next number in the sequence
      i = i + 1
      if (i.le.j) go to 1

      write(*,*) n
      stop
      end


module refurbished
  implicit none
  private

  public :: rocket, dp

  integer, parameter :: precision = 15
  integer, parameter :: range = 307
  integer, parameter :: dp = selected_real_kind(precision, range)

  real(dp), parameter :: AMBIENT_TEMPERATURE = 300.0_dp
  real(dp), parameter :: ATMOSPHERIC_PRESSURE = 101325.0_dp
  real(dp), parameter :: GRAVITY = 9.81_dp
  real(dp), parameter :: PI = 3.1415926539_dp
  real(dp), parameter :: UNIVERSAL_GAS_CONSTANT = 8314.0_dp
contains
  subroutine initialize_propellant_and_rocket_mass( &
      propellant_inner_diameter, &
      propellant_length, &
      propellant_outer_diameter, &
      propellant_density, &

      propellant_mass, &
      rocket_mass)
    real(dp), intent(in) :: propellant_inner_diameter
    real(dp), intent(in) :: propellant_length
    real(dp), intent(in) :: propellant_outer_diameter
    real(dp), intent(in) :: propellant_density
    real(dp), intent(out) :: propellant_mass
    real(dp), intent(out) :: rocket_mass

    associate( &
        id => propellant_inner_diameter, &
        od => propellant_outer_diameter, &
        l => propellant_length)
      associate(propellant_volume => PI * (od**2 - id**2) / 4.0_dp * l)
        propellant_mass = propellant_volume * propellant_density
      end associate
    end associate
    rocket_mass = 0.15_dp * propellant_mass
  end subroutine

  subroutine update_burn_rate_and_depth( &
      time_step_length, &
      burn_rate_exponent, &
      pressure, &
      reference_burn_rate, &

      burn_depth, &

      burn_rate)
    real(dp), intent(in) :: time_step_length
    real(dp), intent(in) :: burn_rate_exponent
    real(dp), intent(in) :: pressure
    real(dp), intent(in) :: reference_burn_rate
    real(dp), intent(inout) :: burn_depth
    real(dp), intent(out) :: burn_rate

    real(dp), parameter :: PASCALS_PER_PSI = 6894.76_dp
    real(dp), parameter :: REFERENCE_PRESSURE = 3000.0_dp * PASCALS_PER_PSI

    associate( &
        rbr => reference_burn_rate, &
        p => pressure, &
        p_r => REFERENCE_PRESSURE, &
        n => burn_rate_exponent)
      burn_rate = rbr * (p/p_r)**n
    end associate
    burn_depth = burn_depth + burn_rate*time_step_length
  end subroutine

  subroutine update_combustion_progress( &
      burn_depth, &
      time_step_length, &
      propellant_inner_diameter, &
      propellant_length, &
      propellant_outer_diameter, &

      burn_rate, &
      chamber_volume, &

      burning_surface_area)
    real(dp), intent(in) :: burn_depth
    real(dp), intent(in) :: time_step_length
    real(dp), intent(in) :: propellant_inner_diameter
    real(dp), intent(in) :: propellant_length
    real(dp), intent(in) :: propellant_outer_diameter
    real(dp), intent(inout) :: burn_rate
    real(dp), intent(inout) :: chamber_volume
    real(dp), intent(out) :: burning_surface_area

    associate( &
        id => propellant_inner_diameter, &
        od => propellant_outer_diameter, &
        l => propellant_length, &
        d => burn_depth)
      associate( &
          new_l => l - 2.0_dp*d, &
          new_id => id + 2.0_dp*d)
        ! cylinder burning from inside and both ends
        burning_surface_area = &
            PI * new_id * new_l &
            + PI * (od**2 - new_id**2) / 4.0_dp * 2.0_dp
        if (new_id > od .or. new_l < 0.0_dp) then
          burning_surface_area = 0.0_dp ! we hit the wall and burned out
          burn_rate = 0.0_dp ! turn off burn rate so burn distance stops increasing
        end if
      end associate
    end associate

    ! increment the interior volume of the chamber
    chamber_volume = &
        chamber_volume &
        + burn_rate*burning_surface_area*time_step_length
  end subroutine

  subroutine calculate_generation_rates( &
      heat_capacity_at_constant_pressure, &
      burn_rate, &
      propellant_density, &
      burning_surface_area, &
      flame_temperature, &

      energy_generation_rate, &
      mass_generation_rate)
    real(dp), intent(in) :: heat_capacity_at_constant_pressure
    real(dp), intent(in) :: burn_rate
    real(dp), intent(in) :: propellant_density
    real(dp), intent(in) :: burning_surface_area
    real(dp), intent(in) :: flame_temperature
    real(dp), intent(out) :: energy_generation_rate
    real(dp), intent(out) :: mass_generation_rate

    mass_generation_rate = propellant_density * burn_rate * burning_surface_area
    energy_generation_rate = &
        mass_generation_rate * heat_capacity_at_constant_pressure * flame_temperature
  end subroutine

  subroutine calculate_flow_rates( &
      flow_area, &
      heat_capacity_at_constant_pressure, &
      heat_capacity_ratio, &
      chamber_pressure, &
      specific_gas_constant, &
      chamber_temperature, &

      energy_outflow_rate, &
      mass_outflow_rate)
    real(dp), intent(in) :: flow_area
    real(dp), intent(in) :: heat_capacity_at_constant_pressure
    real(dp), intent(in) :: heat_capacity_ratio
    real(dp), intent(in) :: chamber_pressure
    real(dp), intent(in) :: specific_gas_constant
    real(dp), intent(in) :: chamber_temperature
    real(dp), intent(out) :: energy_outflow_rate
    real(dp), intent(out) :: mass_outflow_rate

    real(dp) :: critical_pressure_ratio
    real(dp) :: energy_flow_rate
    real(dp) :: f1
    real(dp) :: f2
    real(dp) :: f3
    real(dp) :: flow_direction
    real(dp) :: flow_enthalpy
    real(dp) :: flow_pressure
    real(dp) :: characteristic_velocity
    real(dp) :: flow_temperature
    real(dp) :: mass_flow_rate
    real(dp) :: pressure_ratio

    mass_outflow_rate = 0.0_dp
    energy_outflow_rate = 0.0_dp ! initially set them to zero prior to running this loop

    if (chamber_pressure.GT.ATMOSPHERIC_PRESSURE) then
      flow_direction = 1.0_dp
      flow_temperature = chamber_temperature
      flow_pressure = chamber_pressure
      flow_enthalpy = heat_capacity_at_constant_pressure * chamber_temperature
      pressure_ratio = chamber_pressure / ATMOSPHERIC_PRESSURE
    else
      flow_direction = -1.0_dp
      flow_temperature = AMBIENT_TEMPERATURE
      flow_pressure = ATMOSPHERIC_PRESSURE
      flow_enthalpy = heat_capacity_at_constant_pressure * AMBIENT_TEMPERATURE
      pressure_ratio = ATMOSPHERIC_PRESSURE / chamber_pressure
    end if

    associate( &
        cp => critical_pressure_ratio, &
        g => heat_capacity_ratio)
      cp = (2.0_dp / (g + 1.0_dp))**(g / (g - 1.0_dp))
    end associate
    if ((1.0_dp / pressure_ratio) < critical_pressure_ratio) then
      ! choked flow
      associate( &
          g => heat_capacity_ratio, &
          r => specific_gas_constant, &
          t => flow_temperature)
        characteristic_velocity = &
            sqrt( &
                (1.0_dp / g) &
                * ((g + 1.0_dp) / 2.0_dp)**((g + 1.0_dp) / (g - 1.0_dp)) &
                * r * t)
      end associate
      mass_flow_rate = flow_pressure * flow_area / characteristic_velocity
    else
      ! unchoked flow
      f1 = pressure_ratio**((heat_capacity_ratio - 1.0_dp) / heat_capacity_ratio)
      f2 = sqrt(heat_capacity_ratio * specific_gas_constant * flow_temperature / f1)
      f3 = sqrt((f1 - 1.0_dp) / (heat_capacity_ratio - 1.0_dp))
      mass_flow_rate = &
          sqrt(2.0_dp) &
          * flow_pressure &
          / pressure_ratio &
          / specific_gas_constant &
          / flow_temperature &
          * f1 &
          * f2 &
          * f3 &
          * flow_area
    end if
    energy_flow_rate = mass_flow_rate * flow_enthalpy
    mass_outflow_rate = mass_flow_rate * flow_direction
    energy_outflow_rate = energy_flow_rate * flow_direction
  end subroutine

  subroutine update_chamber_contents( &
      time_step_length, &
      energy_generation_rate, &
      energy_outflow_rate, &
      mass_generation_rate, &
      mass_outflow_rate, &

      chamber_energy, &
      chamber_mass)
    real(dp), intent(in) :: time_step_length
    real(dp), intent(in) :: energy_generation_rate
    real(dp), intent(in) :: energy_outflow_rate
    real(dp), intent(in) :: mass_generation_rate
    real(dp), intent(in) :: mass_outflow_rate
    real(dp), intent(inout) :: chamber_energy
    real(dp), intent(inout) :: chamber_mass

    chamber_mass = &
        chamber_mass &
        + (mass_generation_rate - mass_outflow_rate) * time_step_length
    chamber_energy = &
        chamber_energy &
        + (energy_generation_rate - energy_outflow_rate) * time_step_length
  end subroutine

  subroutine calculate_temperature( &
      heat_capacity_at_constant_volume, &
      chamber_energy, &
      chamber_mass, &

      chamber_temperature)
    real(dp), intent(in) :: heat_capacity_at_constant_volume
    real(dp), intent(in) :: chamber_energy
    real(dp), intent(in) :: chamber_mass
    real(dp), intent(out) :: chamber_temperature

    chamber_temperature = &
        chamber_energy / chamber_mass / heat_capacity_at_constant_volume
  end subroutine

  subroutine calculate_pressure( &
      chamber_mass, &
      specific_gas_constant, &
      chamber_temperature, &
      chamber_volume, &

      chamber_pressure)
    real(dp), intent(in) :: chamber_mass
    real(dp), intent(in) :: specific_gas_constant
    real(dp), intent(in) :: chamber_temperature
    real(dp), intent(in) :: chamber_volume
    real(dp), intent(out) :: chamber_pressure

    chamber_pressure = &
        chamber_mass * specific_gas_constant * chamber_temperature / chamber_volume
  end subroutine

  subroutine calculate_thrust( &
      altitude, &
      flow_area, &
      thrust_correction_factor, &
      chamber_pressure, &
      velocity, &

      drag, &
      net_thrust, &
      thrust)
    real(dp), intent(in) :: altitude
    real(dp), intent(in) :: flow_area
    real(dp), intent(in) :: thrust_correction_factor
    real(dp), intent(in) :: chamber_pressure
    real(dp), intent(in) :: velocity
    real(dp), intent(out) :: drag
    real(dp), intent(out) :: net_thrust
    real(dp), intent(out) :: thrust

    real(dp), parameter :: DRAG_COEFFICIENT = 1.1_dp
    real(dp), parameter :: MOLECULAR_WEIGHT_OF_AIR = 28.96_dp
    real(dp), parameter :: REFERENCE_AIR_DENSITY = 1.225_dp
    real(dp), parameter :: ROCKET_SURFACE_AREA = PI / 4.0_dp
    real(dp) :: air_density

    thrust = &
        (chamber_pressure - ATMOSPHERIC_PRESSURE) &
        * flow_area * thrust_correction_factor
    air_density = &
        REFERENCE_AIR_DENSITY &
        * exp( &
            -GRAVITY &
            * MOLECULAR_WEIGHT_OF_AIR &
            * altitude &
            / UNIVERSAL_GAS_CONSTANT &
            / AMBIENT_TEMPERATURE)
    drag = &
        -DRAG_COEFFICIENT &
        * 0.5_dp &
        * air_density &
        * velocity &
        * abs(velocity) &
        * ROCKET_SURFACE_AREA
    net_thrust = thrust + drag
  end subroutine

  subroutine update_trajectory( &
      time_step_length, &
      chamber_mass, &
      mass_generation_rate, &
      net_thrust, &
      rocket_mass, &

      altitude, &
      propellant_mass, &
      velocity, &

      acceleration)
    real(dp), intent(in) :: time_step_length
    real(dp), intent(in) :: chamber_mass
    real(dp), intent(in) :: mass_generation_rate
    real(dp), intent(in) :: net_thrust
    real(dp), intent(in) :: rocket_mass
    real(dp), intent(inout) :: altitude
    real(dp), intent(inout) :: propellant_mass
    real(dp), intent(inout) :: velocity
    real(dp), intent(out) :: acceleration

    propellant_mass = propellant_mass - mass_generation_rate*time_step_length
    acceleration = net_thrust / (propellant_mass + rocket_mass + chamber_mass) - GRAVITY
    velocity = velocity + acceleration*time_step_length
    altitude = altitude + velocity*time_step_length
  end subroutine

  function rocket( &
      time_step_length, &
      simulation_end_time, &
      heat_capacity_at_constant_pressure, &
      molecular_weight, &
      initial_temperature, &
      initial_pressure, &
      flame_temperature, &
      reference_burn_rate, &
      burn_rate_exponent, &
      propellant_inner_diameter, &
      propellant_outer_diameter, &
      propellant_length, &
      propellant_density, &
      nozzle_diameter, &
      thrust_correction_factor)
    !! this is a basic program of a single stage
    !! rocket motor flowing out of a nozzle, assuming
    !! a thrust coefficient and ignoring the complexities of
    !! what happens to thrust at low pressures, i.e. shock in the nozzle
    real(dp), intent(in) :: time_step_length
    real(dp), intent(in) :: simulation_end_time
    real(dp), intent(in) :: heat_capacity_at_constant_pressure
    real(dp), intent(in) :: molecular_weight
    real(dp), intent(in) :: initial_temperature
    real(dp), intent(in) :: initial_pressure
    real(dp), intent(in) :: flame_temperature
    real(dp), intent(in) :: reference_burn_rate
    real(dp), intent(in) :: burn_rate_exponent
    real(dp), intent(in) :: propellant_inner_diameter
    real(dp), intent(in) :: propellant_outer_diameter
    real(dp), intent(in) :: propellant_length
    real(dp), intent(in) :: propellant_density
    real(dp), intent(in) :: nozzle_diameter
    real(dp), intent(in) :: thrust_correction_factor
    real(dp), allocatable :: rocket(:,:)

    real(dp), parameter :: ONE = 1.0_dp
    real(dp), parameter :: ZERO = 0.0_dp
    real(dp) :: acceleration = ZERO
    real(dp) :: altitude = ZERO
    real(dp) :: burn_depth = ZERO
    real(dp) :: burn_rate
    real(dp) :: burning_surface_area
    real(dp) :: chamber_energy
    real(dp) :: chamber_mass
    real(dp) :: chamber_pressure
    real(dp) :: chamber_temperature
    real(dp) :: chamber_volume = ONE
    real(dp) :: drag = ZERO
    real(dp) :: energy_generation_rate
    real(dp) :: energy_outflow_rate
    real(dp) :: flow_area
    real(dp) :: propellant_mass = ZERO
    real(dp) :: heat_capacity_at_constant_volume
    real(dp) :: heat_capacity_ratio
    integer :: i
    real(dp) :: mass_generation_rate
    real(dp) :: mass_outflow_rate = ZERO
    real(dp) :: net_thrust = ZERO
    integer :: num_time_steps
    real(dp) :: rocket_mass = ZERO
    real(dp) :: specific_gas_constant
    real(dp) :: thrust = ZERO
    real(dp) :: time = ZERO
    real(dp) :: velocity = ZERO

    chamber_temperature = initial_temperature
    chamber_pressure = initial_pressure
    num_time_steps = nint(simulation_end_time / time_step_length)
    allocate(rocket(0:num_time_steps, 11))
    specific_gas_constant = UNIVERSAL_GAS_CONSTANT / molecular_weight
    heat_capacity_at_constant_volume = &
        heat_capacity_at_constant_pressure - specific_gas_constant
    heat_capacity_ratio = &
        heat_capacity_at_constant_pressure / heat_capacity_at_constant_volume
    flow_area = PI / 4.0_dp * nozzle_diameter**2
    chamber_mass = &
        chamber_pressure &
        * chamber_volume &
        / specific_gas_constant &
        / chamber_temperature
    chamber_energy = &
        chamber_mass * heat_capacity_at_constant_volume * chamber_temperature
    rocket(0,:) = [ &
        time, &
        chamber_pressure, &
        chamber_temperature, &
        mass_outflow_rate, &
        thrust, &
        drag, &
        net_thrust, &
        chamber_volume, &
        acceleration, &
        velocity, &
        altitude]

    call initialize_propellant_and_rocket_mass( &
        propellant_inner_diameter, &
        propellant_length, &
        propellant_outer_diameter, &
        propellant_density, &

        propellant_mass, &
        rocket_mass)
    do i = 1, num_time_steps
      call update_burn_rate_and_depth( &
          time_step_length, &
          burn_rate_exponent, &
          chamber_pressure, &
          reference_burn_rate, &

          burn_depth, &

          burn_rate)
      call update_combustion_progress( &
          burn_depth, &
          time_step_length, &
          propellant_inner_diameter, &
          propellant_length, &
          propellant_outer_diameter, &

          burn_rate, &
          chamber_volume, &

          burning_surface_area)
      call calculate_generation_rates( &
          heat_capacity_at_constant_pressure, &
          burn_rate, &
          propellant_density, &
          burning_surface_area, &
          flame_temperature, &

          energy_generation_rate, &
          mass_generation_rate)
      call calculate_flow_rates( &
          flow_area, &
          heat_capacity_at_constant_pressure, &
          heat_capacity_ratio, &
          chamber_pressure, &
          specific_gas_constant, &
          chamber_temperature, &

          energy_outflow_rate, &
          mass_outflow_rate)
      call update_chamber_contents( &
          time_step_length, &
          energy_generation_rate, &
          energy_outflow_rate, &
          mass_generation_rate, &
          mass_outflow_rate, &

          chamber_energy, &
          chamber_mass)
      call calculate_temperature( &
          heat_capacity_at_constant_volume, &
          chamber_energy, &
          chamber_mass, &

          chamber_temperature)
      call calculate_pressure( &
          chamber_mass, &
          specific_gas_constant, &
          chamber_temperature, &
          chamber_volume, &

          chamber_pressure)
      call calculate_thrust( &
          altitude, &
          flow_area, &
          thrust_correction_factor, &
          chamber_pressure, &
          velocity, &

          drag, &
          net_thrust, &
          thrust)
      call update_trajectory( &
          time_step_length, &
          chamber_mass, &
          mass_generation_rate, &
          net_thrust, &
          rocket_mass, &

          altitude, &
          propellant_mass, &
          velocity, &

          acceleration)
      time = time + time_step_length
      rocket(i,:) = [ &
          time, &
          chamber_pressure, &
          chamber_temperature, &
          mass_outflow_rate, &
          thrust, &
          drag, &
          net_thrust, &
          chamber_volume, &
          acceleration, &
          velocity, &
          altitude]
    end do
  end function
end module


C                                                                       MAN   10
C----------------------------------------------------------------       MAN   20
C                                                                       MAN   30
C  PROBLEM 1 - SEE COMPANION PAPER                                      MAN   40
C                                                                       MAN   50
      program prob1
      implicit real*8 (a-h, o-z)
      REAL*8 FSPACE(2000), ZETA(4), TOL(2), Z(4), U(4), ERR(4)            MAN   60
      INTEGER ISPACE(200), M(1), IPAR(11), LTOL(2)                      MAN   70
      EXTERNAL FSUB, DFSUB, GSUB, DGSUB                                 MAN   80
C                                                                       MAN   90
      WRITE (6,99999)                                                   MAN  100
C                                                                       MAN  110
C     ONE DIFFERENTIAL EQUATION OF ORDER 4.                             MAN  120
      M(1) = 4                                                          MAN  130
C     GIVE LOCATION OF BOUNDARY CONDITIONS                              MAN  140
      ZETA(1) = 1.                                                      MAN  150
      ZETA(2) = 1.                                                      MAN  160
      ZETA(3) = 2.                                                      MAN  170
      ZETA(4) = 2.                                                      MAN  180
C     SET UP PARAMETER ARRAY.                                           MAN  190
C     USE DEFAULT VALUES FOR ALL PARAMETERS EXCEPT FOR INITIAL          MAN  200
C     MESH SIZE, NO. OF TOLERANCES AND SIZES OF WORK ARRAYS             MAN  210
      DO 10 I=1,11                                                      MAN  220
        IPAR(I) = 0                                                     MAN  230
   10 CONTINUE                                                          MAN  240
      IPAR(3) = 1                                                       MAN  250
      IPAR(4) = 2                                                       MAN  260
      IPAR(5) = 2000                                                    MAN  270
      IPAR(6) = 200                                                     MAN  280
C     TWO ERROR TOLERANCES (ON U AND ITS SECOND DERIVATIVE)             MAN  290
      LTOL(1) = 1                                                       MAN  300
      LTOL(2) = 3                                                       MAN  310
      TOL(1) = 1.E-7                                                    MAN  320
      TOL(2) = 1.E-7                                                    MAN  330
C                                                                       MAN  340
      CALL COLSYS(1, M, 1d0, 2d0, ZETA, IPAR, LTOL, TOL, DUMMY,
     $     ISPACE,
     * FSPACE, IFLAG, FSUB, DFSUB, GSUB, DGSUB, DUMMY)
C                                                                       MAN  370
      IF (IFLAG.NE.1) STOP                                              MAN  380
C     CALCULATE THE ERROR AT 101 POINTS USING THE KNOWN                 MAN  390
C     EXACT SOLUTION                                                    MAN  400
      X = 1.                                                            MAN  410
      DO 20 I=1,4                                                       MAN  420
        ERR(I) = 0.                                                     MAN  430
   20 CONTINUE                                                          MAN  440
      DO 40 J=1,101                                                     MAN  450
        CALL APPSLN(X, Z, FSPACE, ISPACE)                               MAN  460
        CALL EXACT(X, U)                                                MAN  470
        DO 30 I=1,4                                                     MAN  480
          ERR(I) = AMAX1(ERR(I),ABS(U(I)-Z(I)))                         MAN  490
   30   CONTINUE                                                        MAN  500
        X = X + .01                                                     MAN  510
   40 CONTINUE                                                          MAN  520
      WRITE (6,99998) (ERR(I),I=1,4)                                    MAN  530
      STOP                                                              MAN  540
99999 FORMAT (1H1, 35H EXAMPLE OF A SIMPLE PROBLEM SETUP./10H  UNIFORML,MAN  550
     * 36HY LOADED BEAM OF VARIABLE STIFFNESS,/21H  SIMPLY SUPPORTED AT,MAN  560
     * 11H BOTH ENDS./)                                                 MAN  570
99998 FORMAT (/27H ERROR TOLERANCES SATISFIED//22H THE EXACT ERRORS ARE,MAN  580
     * /7X, 4E12.4)                                                     MAN  590
      END                                                               MAN  600


PROGRAM ApplicationDriver

  USE KindModule, ONLY: &
    DP, Zero, One, Two, Pi, TwoPi
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE ReferenceElementModuleX, ONLY: &
    InitializeReferenceElementX, &
    FinalizeReferenceElementX
  USE ReferenceElementModuleX_Lagrange, ONLY: &
    InitializeReferenceElementX_Lagrange, &
    FinalizeReferenceElementX_Lagrange
  USE EquationOfStateModule, ONLY: &
    InitializeEquationOfState, &
    FinalizeEquationOfState
  USE ProgramHeaderModule, ONLY: &
    iX_B0, iX_B1, iX_E0, iX_E1, &
    nDimsX, nDOFX
  USE GeometryComputationModule, ONLY: &
    ComputeGeometryX
  USE InitializationModule_Relativistic, ONLY: &
    InitializeFields_Relativistic
  USE Euler_SlopeLimiterModule_Relativistic_IDEAL, ONLY: &
    InitializeSlopeLimiter_Euler_Relativistic_IDEAL, &
    FinalizeSlopeLimiter_Euler_Relativistic_IDEAL, &
    ApplySlopeLimiter_Euler_Relativistic_IDEAL
  USE Euler_UtilitiesModule_Relativistic, ONLY: &
    ComputeFromConserved_Euler_Relativistic
  USE InputOutputModuleHDF, ONLY: &
    WriteFieldsHDF, &
    ReadFieldsHDF
  USE FluidFieldsModule, ONLY: &
    nCF, nPF, nAF, &
    uCF, uPF, uAF, &
    uDF
  USE GeometryFieldsModule, ONLY: &
    nGF, uGF

  IMPLICIT NONE

  INCLUDE 'mpif.h'

  CHARACTER(32) :: ProgramName
  LOGICAL       :: UseSlopeLimiter
  LOGICAL       :: UseCharacteristicLimiting
  LOGICAL       :: UseTroubledCellIndicator
  INTEGER       :: nX(3), bcX(3), nNodes
  REAL(DP)      :: xL(3), xR(3), Gamma

  LOGICAL  :: WriteGF = .FALSE., WriteFF = .TRUE.
  REAL(DP) :: Timer_Evolution

  ProgramName = 'SlopeLimiterTest'

  Gamma = 5.0_DP / 3.0_DP
  bcX = [ 2, 0, 0 ]

  nX = [ 7, 1, 1 ]
  xL = [ -1.0_DP, 0.0_DP, 0.0_DP ]
  xR = [ +1.0_DP, 1.0_DP, 1.0_DP ]

  nNodes = 2

  UseSlopeLimiter           = .TRUE.
  UseCharacteristicLimiting = .FALSE.
  UseTroubledCellIndicator  = .FALSE.

  CALL InitializeProgram &
         ( ProgramName_Option &
             = TRIM( ProgramName ), &
           nX_Option &
             = nX, &
           swX_Option &
             = [ 1, 1, 1 ], &
           bcX_Option &
             = bcX, &
           xL_Option &
             = xL, &
           xR_Option &
             = xR, &
           nNodes_Option &
             = nNodes, &
           CoordinateSystem_Option &
             = 'CARTESIAN', &
           BasicInitialization_Option &
             = .TRUE. )

  CALL InitializeReferenceElementX

  CALL InitializeReferenceElementX_Lagrange

  CALL ComputeGeometryX &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, Mass_Option = 0.0_DP )

  CALL InitializeEquationOfState &
         ( EquationOfState_Option = 'IDEAL', &
           Gamma_IDEAL_Option = Gamma )

  CALL InitializeFields_Relativistic

  CALL ComputeFromConserved_Euler_Relativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

  CALL WriteFieldsHDF &
       ( 0.0_DP, WriteGF_Option = WriteGF, WriteFF_Option = WriteFF )

  CALL InitializeFields_Relativistic

  CALL InitializeSlopeLimiter_Euler_Relativistic_IDEAL &
         ( UseSlopeLimiter_Option &
             = UseSlopeLimiter, &
           SlopeLimiterMethod_Option &
             = 'TVD', &
           BetaTVD_Option &
             = 1.75_DP, &
           BetaTVB_Option &
             = 0.00_DP, &
           SlopeTolerance_Option &
             = 0.0_DP, &
           UseCharacteristicLimiting_Option &
             = UseCharacteristicLimiting, &
           UseTroubledCellIndicator_Option &
             = UseTroubledCellIndicator, &
           LimiterThresholdParameter_Option &
             = 0.0_DP, &
           UseConservativeCorrection_Option &
             = .FALSE. )

  CALL ApplySlopeLimiter_Euler_Relativistic_IDEAL &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uDF )

  CALL ComputeFromConserved_Euler_Relativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

  CALL WriteFieldsHDF &
       ( 0.0_DP, WriteGF_Option = WriteGF, WriteFF_Option = WriteFF )

  CALL FinalizeSlopeLimiter_Euler_Relativistic_IDEAL

  CALL InitializeFields_Relativistic

  CALL InitializeSlopeLimiter_Euler_Relativistic_IDEAL &
         ( UseSlopeLimiter_Option &
             = UseSlopeLimiter, &
           SlopeLimiterMethod_Option &
             = 'WENO', &
           UseCharacteristicLimiting_Option &
             = UseCharacteristicLimiting, &
           UseTroubledCellIndicator_Option &
             = UseTroubledCellIndicator )

  CALL ApplySlopeLimiter_Euler_Relativistic_IDEAL &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uDF )

  CALL ComputeFromConserved_Euler_Relativistic &
         ( iX_B0, iX_E0, iX_B1, iX_E1, uGF, uCF, uPF, uAF )

  CALL WriteFieldsHDF &
       ( 0.0_DP, WriteGF_Option = WriteGF, WriteFF_Option = WriteFF )

  CALL FinalizeSlopeLimiter_Euler_Relativistic_IDEAL

  CALL FinalizeReferenceElementX

  CALL FinalizeReferenceElementX_Lagrange

  CALL FinalizeEquationOfState

  CALL FinalizeProgram

END PROGRAM ApplicationDriver


      SUBROUTINE ZDRSCL( N, SA, SX, INCX )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
      DOUBLE PRECISION   SA
*     ..
*     .. Array Arguments ..
      COMPLEX*16         SX( * )
*     ..
*
*  Purpose
*  =======
*
*  ZDRSCL multiplies an n-element complex vector x by the real scalar
*  1/a.  This is done without overflow or underflow as long as
*  the final result x/a does not overflow or underflow.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of components of the vector x.
*
*  SA      (input) DOUBLE PRECISION
*          The scalar a which is used to divide each component of x.
*          SA must be >= 0, or the subroutine will divide by zero.
*
*  SX      (input/output) COMPLEX*16 array, dimension
*                         (1+(N-1)*abs(INCX))
*          The n-element vector x.
*
*  INCX    (input) INTEGER
*          The increment between successive values of the vector SX.
*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            DONE
      DOUBLE PRECISION   BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, ZDSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 )
     $   RETURN
*
*     Get machine parameters
*
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
*
*     Initialize the denominator to SA and the numerator to 1.
*
      CDEN = SA
      CNUM = ONE
*
   10 CONTINUE
      CDEN1 = CDEN*SMLNUM
      CNUM1 = CNUM / BIGNUM
      IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
*
*        Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*
         MUL = SMLNUM
         DONE = .FALSE.
         CDEN = CDEN1
      ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
*
*        Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*
         MUL = BIGNUM
         DONE = .FALSE.
         CNUM = CNUM1
      ELSE
*
*        Multiply X by CNUM / CDEN and return.
*
         MUL = CNUM / CDEN
         DONE = .TRUE.
      END IF
*
*     Scale the vector X by MUL
*
      CALL ZDSCAL( N, MUL, SX, INCX )
*
      IF( .NOT.DONE )
     $   GO TO 10
*
      RETURN
*
*     End of ZDRSCL
*
      END


      double precision function DERF(X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1999-12-27 DERF Krogh Added SAVE XMAX in DERFCE.
c>> 1997-06-05 DERF Snyder Added SAVE EPS3 in DERFC
c>> 1996-04-27 DERF Krogh  Changes to use .C. and C%%.
c>> 1996-03-30 DERF Krogh  Added external statements.
C>> 1995-11-28 DERF Krogh  Converted SFTRAN to Fortran
C>> 1995-10-24 DERF Krogh  Removed blanks in numbers for C conversion.
C>> 1994-10-19 DERF Krogh  Changes to use M77CON
C>> 1991-01-14 DERF CLL Changed to use generic names: abs and sign.
C>> 1990-11-29 CLL
c>> 1989-08-16 DERF   CLL  Changes for Cray
C>> 1989-06-30 DERF CLL More digits in sqrt(PI), S.P. & D.P. more alike.
C>> 1986-03-18 DERF   Lawson  Initial code.
c--D replaces "?": ?ERF, ?ERFC, ?ERFCE, ?INITS, ?CSEVL, ?ERM1, ?ERF1,
c--&               ?ERFC1, ?ERFE1, ?ERFE2, ?ERFSP
C
C     JULY 1977 EDITION. W.FULLERTON, C3,
C     LOS ALAMOS SCIENTIFIC LAB.
C
C     REORGANIZATION OF FULLERTON'S DERF & DERFC
C     C.L.LAWSON & S.CHAN, JUNE 2 ,1983, JPL.
c     When DERFC is called with 0.5 .lt. X .le. 1.0 the original code
c     computed erfc from erfce, computing erfce from Cody's rational
c     formula whose coeffs (PS() and QS()) are only given to 18 decimal
c     digits.  For Cray D.P. of 29D precision we can do better by
c     computing DERFC as 1 - erf in this interval, since the coeffs for
c     DERF are good up to 30D.
c     With this change DERFC will also be good up to 30 or 29D for all
c     X up to XMAX, where it would underflow.
c     We compute DERFCE only for X .ge. 0.  DERFCE is computed from
c     DERF in [0, 1] and from DERFC in [1, XMAX] and so is good to
c     about 30D there.  For X > XMAX we use the Cody rational
c     approximations for DERFCE which have coeffs good only to 18D.
c     Added variable EPS3.
C     ------------------------------------------------------------------
C-- Begin mask code changes
C     MACHINE DEPENDENT VALUES ARE SET ON THE FIRST ENTRY
C     TO THIS CODE. EXAMPLES OF THESE VALUES FOLLOW:
C
C     SYSTEM         NTERF   NTERFC   NTERC2   SQEPS   XBIG   XMAX
C     ------         -----   ------   ------   -----   ----   ----
c     IEEE   S.P.      7        9       10    .34E-3   4.01    9.18
c     IEEE   D.P.     12       25       24    .15E-7   6.01   26.53
C     UNIVAC S.P.      8       11       11    .12E-3   4.26   9.29
C     UNIVAC D.P.     14       30       27    .13E-8   6.40   26.58
c     Cray   S.P.     11       21       21    .12E-6   5.66   75.30
c     Cray   D.P.     19       55       45    .10E-13  8.04   74.89
C
c     The above values are derived from the following values:
C
C     SYSTEM         R1MACH(1)   R1MACH(3)   D1MACH(1)   D1MACH(3)
C     ------         ---------   ---------   ---------   ---------
c     IEEE           2**(-126)   2**(-24)    2**(-1022)  2**(-53)
c     VAX            2**(-128)   2**(-27)    2**(-128)   2**(-56)
c     UNIVAC         2**(-129)   2**(-27)    2**(-1025)  2**(-60)
C     Cray           2**(-8190)  2**(-47)    2**(-8100)  2**(-94)
C
C-- End mask code changes
C     ------------------------------------------------------------------
      external DERF1, DERFC1
      double precision X
      double precision FAC, U, SQEPS, XBIG, Y
      double precision DERF1, DERFC1
      logical FIRST
C
      save FIRST, SQEPS, XBIG
C          FAC = 2/sqrt(PI)
      parameter(FAC = 1.12837916709551257389615890312154516D0)
      data FIRST / .TRUE. /
c
C     ------------------------------------------------------------------
C
      if (FIRST) call DERFSP(FIRST, U, SQEPS, XBIG, Y)
      Y = abs(X)
      IF (Y .LE. SQEPS) THEN
        U = FAC * X
      ELSE IF (Y .LE. 1.0D0) THEN
        U = DERF1(X)
      ELSE IF (Y .LT. XBIG) THEN
        U = sign( 0.5D0+(0.5D0 - DERFC1(Y) * exp(-Y*Y) / Y), X )
      ELSE
        U = sign ( 1.0D0,X )
      END IF
      DERF = U
      RETURN
      END
C
C
c     ------------------------------------------------------------------
      double precision function DERFC(X)
C
      external DERF1, DERFE1, DERFC1
      double precision X
      double precision EPS3, FAC, U, SQEPS, XBIG, XMAX, Y
      double precision DERF1, DERFC1, DERFE1
      logical FIRST
C
      save EPS3, FIRST, SQEPS, XBIG, XMAX
C          FAC = 2/sqrt(PI)
      parameter(FAC = 1.12837916709551257389615890312154516D0)
      data FIRST / .TRUE. /
c
      if (FIRST) call DERFSP(FIRST, EPS3, SQEPS, XBIG, XMAX)
      IF (X .LE. -XBIG) THEN
        U = 2.0D0
      ELSE
        Y = abs(X)
        IF (Y .LE. SQEPS) THEN
          U = 0.5D0 + (0.5D0 - FAC*X)
        ELSE IF (Y .LE. 1.0D0) THEN
          IF (X .LT. 0.5D0) THEN
C
C                       *** Here X is in [-1,-SQEPS] or [SQEPS,0.5]
C
            U = 0.5D0 + (0.5D0-DERF1(X))
          ELSE
C
C            .           *** Here X is in [0.5,1.0]
c            .  Following test on 1.0D-19 added 8/89 to make better use
c            .  of 28 D precision available on a Cray.  The stored
c            .  approximation for erfce is only good to about 18 D.
c            .  On machines having precision greater than 18 D we get
c            .  a more accurate value for erfc by computing U = erf
c            .  and then 0.5D0 - (0.5D0 - U).
c
            if(EPS3 .gt. 1.0D-19) then
               U = EXP(-X**2) * DERFE1(Y)
            else
               U = 0.5D0 + (0.5D0-DERF1(X))
            end if
          END IF
        ELSE IF (Y .LE. XMAX) THEN
          U = DERFC1(Y) * exp(-Y*Y) / Y
          IF (X .LT. 0.0D0) U = 2.0D0 - U
        ELSE
          U = 0.0D0
          CALL DERM1('DERFC',1,0,'X SO BIG DERFC UNDERFLOWS',
     *    'X',X,'.')
        END IF
      END IF
      DERFC = U
      RETURN
      END
C
c     ------------------------------------------------------------------
      double precision function DERFCE(X)
C
      external DERF1, DERFC1, DERFE1, DERFE2
      double precision X
      double precision CUT2, CUT3, PII, U, XMAX, Y
      double precision DERF1, DERFC1, DERFE1, DERFE2
      logical FIRST
      save FIRST, XMAX
C          PII = 1/sqrt(PI)
      parameter(PII = 0.56418958354775628694807945156077258D0)
C
c          CUT2 = 4.0
C          CUT3 = 10.**16 WILL BE SATISFACTORY FOR ALL
C          MACHINES HAVING RELATIVE PRECISION LESS
C          THAN 32 DECIMAL PLACES AND OVERFLOW LIMIT
C          GREATER THAN 10.**32
      parameter(CUT2 = 4.0D0, CUT3 = 1.0D16)
      data FIRST / .TRUE. /
c
      if (FIRST) call DERFSP(FIRST, U, Y, Y, XMAX)
      Y = X
      IF (X .LT.0.0D0) THEN
        CALL DERM1('DERFCE',1,0,'X MUST BE .GE. ZERO',
     *             'X',X,'.')
        U = 0.0D0
      ELSE IF (X .LT. 1.0D0) THEN
        U = EXP(Y*Y)*(0.5D0 + (0.5D0-DERF1(X)))
      ELSE IF (X .LT. XMAX) THEN
        U = DERFC1(Y) / X
      ELSE IF ( X .lt. CUT2) then
        U = DERFE1(Y)
      ELSE IF (X .LT. CUT3) THEN
        U = DERFE2(Y)
      ELSE
        U = PII / X
      END IF
      DERFCE = U
      RETURN
      END
C
C
      subroutine DERFSP(FIRST, EPS3, SQEPS, XBIG, XMAX)
c                           PROCEDURE (SET PARAMETERS)
      external D1MACH
      double precision EPS3, SQEPS, XBIG, XMAX
      logical FIRST
      double precision EPS3I,D1MACH,SQEPSI,SQRTPI,XBIGI,XMAXI
      logical FIRSTI
      parameter(SQRTPI = 1.77245385090551602729816748334114518D0)
      save EPS3I, FIRSTI, SQEPSI, XBIGI, XMAXI
      data FIRSTI / .true. /
c
      if (FIRSTI) then
         FIRSTI = .false.
C
         EPS3I = D1MACH(3)
         SQEPSI = sqrt (2.0D0*EPS3I)
         XBIGI = sqrt (-log(SQRTPI*EPS3I))
         XMAXI = sqrt (-log(SQRTPI*D1MACH(1)) )
         XMAXI = XMAXI - 0.5D0*log(XMAXI)/XMAXI - 0.01D0
       end if
      EPS3 = EPS3I
      SQEPS = SQEPSI
      XBIG = XBIGI
      XMAX = XMAXI
c     PRINT*,'SQEPS = ',SQEPS, SQEPSI
c     PRINT*,'XBIG = ',XBIG, XBIGI
c     PRINT*,'XMAX = ',XMAX, XMAXI
      FIRST = .false.
      return
      end
C
C
      double precision function DERF1(X)
c                         PROCEDURE (DERF(X) FOR ABS(X) .LE. 1)
      external D1MACH, DCSEVL
      double precision X
      double precision D1MACH, DCSEVL, ERFCS(21)
      integer NTERF
      save NTERF
C
C SERIES FOR ERF        ON THE INTERVAL  0.          TO  1.00000D+00
C                                        WITH WEIGHTED ERROR   1.28D-32
C                                         LOG WEIGHTED ERROR  31.89
C                               SIGNIFICANT FIGURES REQUIRED  31.05
C                                    DECIMAL PLACES REQUIRED  32.55
C
c++ Save data by elements if ~.C.
      DATA ERFCS(1) /   -.49046121234691808039984544033376D-1 /
      DATA ERFCS(2) /   -.14226120510371364237824741899631D+0 /
      DATA ERFCS(3) /   +.10035582187599795575754676712933D-1 /
      DATA ERFCS(4) /   -.57687646997674847650827025509167D-3 /
      DATA ERFCS(5) /   +.27419931252196061034422160791471D-4 /
      DATA ERFCS(6) /   -.11043175507344507604135381295905D-5 /
      DATA ERFCS(7) /   +.38488755420345036949961311498174D-7 /
      DATA ERFCS(8) /   -.11808582533875466969631751801581D-8 /
      DATA ERFCS(9) /   +.32334215826050909646402930953354D-10 /
      DATA ERFCS(10) /  -.79910159470045487581607374708595D-12 /
      DATA ERFCS(11) /  +.17990725113961455611967245486634D-13 /
      DATA ERFCS(12) /  -.37186354878186926382316828209493D-15 /
      DATA ERFCS(13) /  +.71035990037142529711689908394666D-17 /
      DATA ERFCS(14) /  -.12612455119155225832495424853333D-18 /
      DATA ERFCS(15) /  +.20916406941769294369170500266666D-20 /
      DATA ERFCS(16) /  -.32539731029314072982364160000000D-22 /
      DATA ERFCS(17) /  +.47668672097976748332373333333333D-24 /
      DATA ERFCS(18) /  -.65980120782851343155199999999999D-26 /
      DATA ERFCS(19) /  +.86550114699637626197333333333333D-28 /
      DATA ERFCS(20) /  -.10788925177498064213333333333333D-29 /
      DATA ERFCS(21) /  +.12811883993017002666666666666666D-31 /
c
      DATA NTERF / 0 /
c
      if (NTERF .eq. 0) call DINITS(ERFCS, 21, 0.1D0*D1MACH(3), NTERF)
c
      DERF1 = X + X * DCSEVL ( 2.0D0 * X * X - 1.0D0, ERFCS, NTERF )
      RETURN
      END
C
C
      double precision function DERFC1(Y)
C        *(exp(-Y*Y) / Y) =  PROCEDURE (DERFC(Y) FOR 1 .LT. Y .LT. XMAX)
C                *(1 / X) = PROCEDURE (DERFCE(X) FOR 1 .LT. X .LT. XMAX)
      external D1MACH, DCSEVL
      double precision Y
      integer NTERC2, NTERFC
      double precision D1MACH, DCSEVL, ERFCCS(59), ERC2CS(49), ETA, YSQ
      save NTERC2, NTERFC
C
C
C SERIES FOR ERC2       ON THE INTERVAL  2.50000D-01 TO  1.00000D+00
C                                        WITH WEIGHTED ERROR   2.67D-32
C                                         LOG WEIGHTED ERROR  31.57
C                               SIGNIFICANT FIGURES REQUIRED  30.31
C                                    DECIMAL PLACES REQUIRED  32.42
C
c++ Save data by elements if ~.C.
      DATA ERC2CS(1) /   -.6960134660230950112739150826197D-1 /
      DATA ERC2CS(2) /   -.4110133936262089348982212084666D-1 /
      DATA ERC2CS(3) /   +.3914495866689626881561143705244D-2 /
      DATA ERC2CS(4) /   -.4906395650548979161280935450774D-3 /
      DATA ERC2CS(5) /   +.7157479001377036380760894141825D-4 /
      DATA ERC2CS(6) /   -.1153071634131232833808232847912D-4 /
      DATA ERC2CS(7) /   +.1994670590201997635052314867709D-5 /
      DATA ERC2CS(8) /   -.3642666471599222873936118430711D-6 /
      DATA ERC2CS(9) /   +.6944372610005012589931277214633D-7 /
      DATA ERC2CS(10) /  -.1371220902104366019534605141210D-7 /
      DATA ERC2CS(11) /  +.2788389661007137131963860348087D-8 /
      DATA ERC2CS(12) /  -.5814164724331161551864791050316D-9 /
      DATA ERC2CS(13) /  +.1238920491752753181180168817950D-9 /
      DATA ERC2CS(14) /  -.2690639145306743432390424937889D-10 /
      DATA ERC2CS(15) /  +.5942614350847910982444709683840D-11 /
      DATA ERC2CS(16) /  -.1332386735758119579287754420570D-11 /
      DATA ERC2CS(17) /  +.3028046806177132017173697243304D-12 /
      DATA ERC2CS(18) /  -.6966648814941032588795867588954D-13 /
      DATA ERC2CS(19) /  +.1620854541053922969812893227628D-13 /
      DATA ERC2CS(20) /  -.3809934465250491999876913057729D-14 /
      DATA ERC2CS(21) /  +.9040487815978831149368971012975D-15 /
      DATA ERC2CS(22) /  -.2164006195089607347809812047003D-15 /
      DATA ERC2CS(23) /  +.5222102233995854984607980244172D-16 /
      DATA ERC2CS(24) /  -.1269729602364555336372415527780D-16 /
      DATA ERC2CS(25) /  +.3109145504276197583836227412951D-17 /
      DATA ERC2CS(26) /  -.7663762920320385524009566714811D-18 /
      DATA ERC2CS(27) /  +.1900819251362745202536929733290D-18 /
      DATA ERC2CS(28) /  -.4742207279069039545225655999965D-19 /
      DATA ERC2CS(29) /  +.1189649200076528382880683078451D-19 /
      DATA ERC2CS(30) /  -.3000035590325780256845271313066D-20 /
      DATA ERC2CS(31) /  +.7602993453043246173019385277098D-21 /
      DATA ERC2CS(32) /  -.1935909447606872881569811049130D-21 /
      DATA ERC2CS(33) /  +.4951399124773337881000042386773D-22 /
      DATA ERC2CS(34) /  -.1271807481336371879608621989888D-22 /
      DATA ERC2CS(35) /  +.3280049600469513043315841652053D-23 /
      DATA ERC2CS(36) /  -.8492320176822896568924792422399D-24 /
      DATA ERC2CS(37) /  +.2206917892807560223519879987199D-24 /
      DATA ERC2CS(38) /  -.5755617245696528498312819507199D-25 /
      DATA ERC2CS(39) /  +.1506191533639234250354144051199D-25 /
      DATA ERC2CS(40) /  -.3954502959018796953104285695999D-26 /
      DATA ERC2CS(41) /  +.1041529704151500979984645051733D-26 /
      DATA ERC2CS(42) /  -.2751487795278765079450178901333D-27 /
      DATA ERC2CS(43) /  +.7290058205497557408997703680000D-28 /
      DATA ERC2CS(44) /  -.1936939645915947804077501098666D-28 /
      DATA ERC2CS(45) /  +.5160357112051487298370054826666D-29 /
      DATA ERC2CS(46) /  -.1378419322193094099389644800000D-29 /
      DATA ERC2CS(47) /  +.3691326793107069042251093333333D-30 /
      DATA ERC2CS(48) /  -.9909389590624365420653226666666D-31 /
      DATA ERC2CS(49) /  +.2666491705195388413323946666666D-31 /
C
C SERIES FOR ERFC       ON THE INTERVAL  0.          TO  2.50000D-01
C                                        WITH WEIGHTED ERROR   1.53D-31
C                                         LOG WEIGHTED ERROR  30.82
C                               SIGNIFICANT FIGURES REQUIRED  29.47
C                                    DECIMAL PLACES REQUIRED  31.70
C
c++ Save data by elements if ~.C.
      DATA ERFCCS(1) /   +.715179310202924774503697709496D-1 /
      DATA ERFCCS(2) /   -.265324343376067157558893386681D-1 /
      DATA ERFCCS(3) /   +.171115397792085588332699194606D-2 /
      DATA ERFCCS(4) /   -.163751663458517884163746404749D-3 /
      DATA ERFCCS(5) /   +.198712935005520364995974806758D-4 /
      DATA ERFCCS(6) /   -.284371241276655508750175183152D-5 /
      DATA ERFCCS(7) /   +.460616130896313036969379968464D-6 /
      DATA ERFCCS(8) /   -.822775302587920842057766536366D-7 /
      DATA ERFCCS(9) /   +.159214187277090112989358340826D-7 /
      DATA ERFCCS(10) /  -.329507136225284321486631665072D-8 /
      DATA ERFCCS(11) /  +.722343976040055546581261153890D-9 /
      DATA ERFCCS(12) /  -.166485581339872959344695966886D-9 /
      DATA ERFCCS(13) /  +.401039258823766482077671768814D-10 /
      DATA ERFCCS(14) /  -.100481621442573113272170176283D-10 /
      DATA ERFCCS(15) /  +.260827591330033380859341009439D-11 /
      DATA ERFCCS(16) /  -.699111056040402486557697812476D-12 /
      DATA ERFCCS(17) /  +.192949233326170708624205749803D-12 /
      DATA ERFCCS(18) /  -.547013118875433106490125085271D-13 /
      DATA ERFCCS(19) /  +.158966330976269744839084032762D-13 /
      DATA ERFCCS(20) /  -.472689398019755483920369584290D-14 /
      DATA ERFCCS(21) /  +.143587337678498478672873997840D-14 /
      DATA ERFCCS(22) /  -.444951056181735839417250062829D-15 /
      DATA ERFCCS(23) /  +.140481088476823343737305537466D-15 /
      DATA ERFCCS(24) /  -.451381838776421089625963281623D-16 /
      DATA ERFCCS(25) /  +.147452154104513307787018713262D-16 /
      DATA ERFCCS(26) /  -.489262140694577615436841552532D-17 /
      DATA ERFCCS(27) /  +.164761214141064673895301522827D-17 /
      DATA ERFCCS(28) /  -.562681717632940809299928521323D-18 /
      DATA ERFCCS(29) /  +.194744338223207851429197867821D-18 /
      DATA ERFCCS(30) /  -.682630564294842072956664144723D-19 /
      DATA ERFCCS(31) /  +.242198888729864924018301125438D-19 /
      DATA ERFCCS(32) /  -.869341413350307042563800861857D-20 /
      DATA ERFCCS(33) /  +.315518034622808557122363401262D-20 /
      DATA ERFCCS(34) /  -.115737232404960874261239486742D-20 /
      DATA ERFCCS(35) /  +.428894716160565394623737097442D-21 /
      DATA ERFCCS(36) /  -.160503074205761685005737770964D-21 /
      DATA ERFCCS(37) /  +.606329875745380264495069923027D-22 /
      DATA ERFCCS(38) /  -.231140425169795849098840801367D-22 /
      DATA ERFCCS(39) /  +.888877854066188552554702955697D-23 /
      DATA ERFCCS(40) /  -.344726057665137652230718495566D-23 /
      DATA ERFCCS(41) /  +.134786546020696506827582774181D-23 /
      DATA ERFCCS(42) /  -.531179407112502173645873201807D-24 /
      DATA ERFCCS(43) /  +.210934105861978316828954734537D-24 /
      DATA ERFCCS(44) /  -.843836558792378911598133256738D-25 /
      DATA ERFCCS(45) /  +.339998252494520890627359576337D-25 /
      DATA ERFCCS(46) /  -.137945238807324209002238377110D-25 /
      DATA ERFCCS(47) /  +.563449031183325261513392634811D-26 /
      DATA ERFCCS(48) /  -.231649043447706544823427752700D-26 /
      DATA ERFCCS(49) /  +.958446284460181015263158381226D-27 /
      DATA ERFCCS(50) /  -.399072288033010972624224850193D-27 /
      DATA ERFCCS(51) /  +.167212922594447736017228709669D-27 /
      DATA ERFCCS(52) /  -.704599152276601385638803782587D-28 /
      DATA ERFCCS(53) /  +.297976840286420635412357989444D-28 /
      DATA ERFCCS(54) /  -.126252246646061929722422632994D-28 /
      DATA ERFCCS(55) /  +.539543870454248793985299653154D-29 /
      DATA ERFCCS(56) /  -.238099288253145918675346190062D-29 /
      DATA ERFCCS(57) /  +.109905283010276157359726683750D-29 /
      DATA ERFCCS(58) /  -.486771374164496572732518677435D-30 /
      DATA ERFCCS(59) /  +.152587726411035756763200828211D-30 /
c
      DATA NTERC2 / 0 /
c
      if (NTERC2 .eq. 0) then
         ETA = 0.1D0 * D1MACH(3)
         call DINITS (ERC2CS, 49, ETA, NTERC2)
         call DINITS (ERFCCS, 59, ETA, NTERFC)
      end if
      YSQ = Y * Y
      IF (YSQ .LE. 4.0D0) THEN
         DERFC1 = 0.5D0+DCSEVL((8.0D0/YSQ-5.0D0)/3.0D0,ERC2CS,NTERC2)
      ELSE
        DERFC1 = 0.5D0+DCSEVL(8.0D0/YSQ-1.0D0,ERFCCS,NTERFC)
      END IF
      RETURN
      END
C
C
      double precision function DERFE1(Y)
c                         PROCEDURE (DERFCE(Y) FOR 15/32 .LE. Y .LE. 4)
      double precision Y
      double precision PS(9), PSUM, QS(10), QSUM
      DATA PS/
     *  1.00000000000036828D+0,
     *  1.87051017604560834D+0,
     *  1.74642369370058320D+0,
     *  1.02438464807598001D+0,
     *  4.07413180167223764D-1,
     *  1.11870870991098165D-1,
     *  2.07045775788719818D-2,
     *  2.37133372752999036D-3,
     *  1.29992515945788642D-4/
C
      DATA QS/
     *  1.00000000000000000D+0,
     *  2.99888934314798253D+0,
     *  4.13030795287321183D+0,
     *  3.43830153103630866D+0,
     *  1.91273588328781533D+0,
     *  7.40352738163508723D-1,
     *  2.00387662412610424D-1,
     *  3.68131014202168126D-2,
     *  4.20307996290648223D-3,
     *  2.30405728794132537D-4/
C
      PSUM=PS(1)+Y*(PS(2)+Y*(PS(3)+Y*(PS(4)+Y*(PS(5)+Y*(PS(6)
     *  +Y*(PS(7)+Y*(PS(8)+Y*PS(9))))))))
      QSUM=QS(1)+Y*(QS(2)+Y*(QS(3)+Y*(QS(4)+Y*(QS(5)+Y*(QS(6)
     *  +Y*(QS(7)+Y*(QS(8)+Y*(QS(9)+Y*QS(10)))))))))
      DERFE1=PSUM/QSUM
      RETURN
      END
C
C
      double precision function DERFE2(Y)
C                         PROCEDURE (DERFCE(Y) FOR 4 .LE. Y .LE. 10**16)
      double precision Y
      double precision PL(6), PII, PSUM, QL(6), QSUM, YSQ
C          PII = 1/sqrt(PI)
      parameter(PII = 0.56418958354775628694807945156077258D0)
      DATA PL/
     * -2.82094791773876911D-1,
     * -6.88752606824337911D+0,
     * -5.38632485753818598D+1,
     * -1.54309751654255924D+2,
     * -1.30749393763753716D+2,
     * -6.98670450907125305D+0/
C
      DATA QL/
     *  1.00000000000000000D+0,
     *  2.59156442057350244D+1,
     *  2.26063711030173368D+2,
     *  8.02050727433854173D+2,
     *  1.09991209268230208D+3,
     *  4.28227932949102556D+2/
C
      YSQ=1.D0/Y/Y
      PSUM=PL(1)+YSQ*(PL(2)+YSQ*(PL(3)+YSQ*(PL(4)+YSQ*(PL(5)
     *  +YSQ*PL(6)))))
      QSUM=QL(1)+YSQ*(QL(2)+YSQ*(QL(3)+YSQ*(QL(4)+YSQ*(QL(5)
     *  +YSQ*QL(6)))))
      DERFE2=(PII+YSQ*PSUM/QSUM)/Y
      RETURN
      END


	subroutine realcon( r, buf, n)

c Convert REAL*4 to N-character output format in BUF.
c  Uses Fixed-point format unless not enough characters available.

	logical neg
        character*(*) buf
        CHARACTER*80  RUNTIME

c  intitialize to "**..*"
	do i=1,n
	  buf(i:i) = '*'
	enddo

	ra = r
	neg = .FALSE.
	if (r.lt. 0.) then
	  neg = .TRUE.
	  ra = -r
	endif
	if (r.eq.0.) ra=1.
	rlog = alog10( ra)

	if (rlog.ge.0) then	! |r| >= 1.0
	  is = ifix(rlog+1.)	! # digits to left of "."
	  if (neg) is = is+1	! one for "-"
	  id = n-is-1		! # digits to right of "."
	  if (id.lt.0) then	! can't use F format
	    if (rlog.eq.0.) rlog = 1.
	    ie = alog10(rlog)+1	! "E+yy"
	    id = n-4-ie		! # digits between "x." and "E+yy"
	    if (neg) id = id-1	! "-"
	    if (id.lt.0) return
            WRITE (RUNTIME,9020) n, id, ie
            WRITE (BUF(1:n), RUNTIME) r
	  else
            WRITE (RUNTIME,9010) n, id
            WRITE (BUF(1:n), RUNTIME) r
	  endif

	else			! |r| < 1.0
	  id = n-2		! # digits to right of "."
	  if (neg) id = id-1	! one for "-"
	  idm = ifix(-rlog)+1	! minimum # required
	  if (id.lt.idm) then	! can't use F format
	    rlog = -rlog        ! if r=2.e-10, then 10>rlog>9 after this line.
	    if (rlog.eq.0.) then
                rlog = 1.
            else                ! so need to add 1 to make ie come out right.
                if (rlog .ne. aint(rlog) )  rlog = rlog + 1.0
            end if
	    ie = alog10(rlog)+1	! "E-yy"
	    id = n-4-ie		! # digits between "x." and "E-yy"
	    if (neg) id = id-1	! "-"
	    if (id.lt.0) return
            WRITE (RUNTIME,9020) n, id, ie
            WRITE (BUF(1:n), RUNTIME) r
	  else
            WRITE (RUNTIME,9010) n, id
            WRITE (BUF(1:n), RUNTIME) r
	  endif

	endif
	return

9010    FORMAT( '(F',   I3.3, '.', I3.3, ')' )
9020    FORMAT( '(1PE', I3.3, '.', I3.3,'E', I3.3, ')' )
	end


      subroutine majz(n,np,nt,y,s,z,ys,zs,diag,index)
c
c     mise a jour de ({z}(i),zs(i), i=1,np).
c     {z}(i)=[b](i-1)*{s}(i), [b](i) est definie par ({y}(j),{s}(j),{z}(j)
c     , j=1,i) et {diag}.
c     zs(i)=<z>(i)*{s}(i)
c
      implicit double precision (a-h,o-z)
      dimension     y(nt,n),s(nt,n),z(nt,n),ys(nt),zs(nt),diag(n)
      integer  index(nt)
c
      l=index(1)
      do 100 jj=1,n
         z(l,jj)=diag(jj)*s(l,jj)
100   continue
c
      zs(l)=0
      do 110 jj=1,n
         zs(l)=zs(l)+z(l,jj)*s(l,jj)
110   continue
c
c
      if(np.eq.1) return
c
      do 200 i=2,np
         l=index(i)
         do 210 jj=1,n
            z(l,jj)=diag(jj)*s(l,jj)
210      continue
         do 220 j=1,i-1
            psy=0
            psz=0
            jl=index(j)
            do 230 jj=1,n
               psy=psy+y(jl,jj)*s(l,jj)
               psz=psz+z(jl,jj)*s(l,jj)
230         continue
            do 240 jj=1,n
               z(l,jj)=z(l,jj)+psy*y(jl,jj)/ys(jl)-psz*z(jl,jj)
     &                 /zs(jl)
240         continue
220      continue
c
         zs(l)=0
         do 250 jj=1,n
            zs(l)=zs(l)+z(l,jj)*s(l,jj)
250      continue
200   continue
c
      return
      end