c-------------------------------------------------------
C THIS PROGRAM THE GLOBAL SOLUTIONS FOR TWO-TEMPERATURE
C ADAF USING SHOOTING METHOD. THE EQUATIONS ARE FROM MANMOTO ET AL.
C 1997 APJ, WITH THE FOLLOWING MODIFICATIONS:
C
C 1)THE MASS ACCRETION RATE IS THE FUNCTION OF RADIUS
C 2)IN THE ENERGY EQUATION OF ELECTRONS, THE VISOCUS DISSIPATION
C   IS ALSO INCLUDED, THE PARAMETER IS ``DELTA''

	IMPLICIT REAL*8(A-H,O-Z)
	dimension y(4),dy(4),w(16)
	dimension r(1000),ddhh(1000),sum(9000),sigma(1000)
	double precision m,mui,mue,mbsl4
	common alfa,beta,dotm0,rout,p0,gamai,ru,
     $          sl0,m,mui,mue,delta,rtran
	open(41,file='x.dat')
	open(42,file='hottem.dat')
	open(14,file='hot.dat')

	ru=9.2d-14
	mmm=0

c --------------------------------
c here, ru is k/M_mu
c---------------------------------
c	print *,'Adiabatic index gamma:'
c	read(*,*) gamai
        gamai=1.5d0

c	print *,'Black hole mass (in Solar masses):'
c	read(*,*) m
	m=1.2d2

	mui=1.24d0
	mue=1.13d0

c ratio of gas to total pressure
c	print *,'beta:'
c	read(*,*) beta
	beta=0.9d0

c	print *,'alpha:'
c	read(*,*) alfa
	alfa=0.1d0

c Fraction of turbulent dissipation that directly heats electrons
c	print *,'delta:'
c	read(*,*) delta
	delta=0.1d0

	dotme=3.44d-15*m
c  dotme is the Eddington accretion rate

c	print *,'Mdot_out (Eddington units):'
c	read(*,*) dotm0
c	dotm0=dotme*dotm0
	dotm0=6.4d-3*dotme
c dotm0 is the accretion rate at the outer boundary

c	print *,'R_out (units of R_S):'
c	read(*,*) rout
	rout=225.d0
c rout is the outer boundary

c	print *,'p_wind ("strength of wind"):'
c	read(*,*) pp0
	p0=0.0d0
	pp0=0.8d0
c  pp0 describes the strength of the outflow
	sint=0.d0

c	print *,' '
c	print *,'Boundary conditions:'
c	print *,'====================='
c	print *,'T_i (ion temperature):'
c	read(*,*) ti
	ti=1.21d+9

c	print *,'T_e (electron temperature):'
c	read(*,*) te
	te=6.12d+8

	cs=sqrt(ru/beta*(ti/mui+te/mue))

c	print *,'v_R/c_s (radial velocity/sound speed):'
c	read(*,*) vcs
	vcs=0.5d0

c you need to adjust the boundary conditions ti, te, and vcs (the ratio
c between the radial velocity and local sound speed) to get a solution
c	print*,'sl0=? (eigenvalue of the problem)'
c	read(*,*) sl0  --nice value=3.286--
	sl0=3.286
c sl0 is the eignevalue of the problem

c Test if code is receiving its input correctly ***
c	print *,gamai,m,beta
c	print *,alfa,delta,dotm0
c	print *,rout,pp0,ti
c	print *,te,vcs,sl0

	I=2
c Added! ***
	y(1)=rout
c	y(1)=600.d0
	rtran=y(1)*1.001d0
	y(2)=-cs*vcs
	y(3)=te
	y(4)=ti

	sk=1./sqrt(y(1))/(y(1)-2.)
	sout=-alfa*y(1)*cs*cs/y(2)+sl0
	omiga=sout/y(1)/y(1)
	omik=sk

	print*,'# omiga/omigak=',omiga/omik,sout,100/y(1)/y(1)/sk
	if(omiga/omik.gt.1.) then
	   print*,'# omiga/omigak > 1!!!', omiga/omik
       	   print*,'# I must let vcs increase!'
	   stop
	endif

          k2=0
	inform=i+10
c------------------------
        tau=0.d0
	y0=rtran
c-------------------------

 222      if(k2.lt.160) hh=-1.d+1
	  if(k2.ge.160) hh=-1.d0
          if(k2.ge.500) hh=-1.d-1

	hh=-y(1)/100.d0

        call mers(4,inform,hh,1.d-4,y,dy,w,qn,qd,tau,sint)

	cs=sqrt(ru/beta*(y(4)/mui+y(3)/mue))
	cs2=cs*cs
	omik=1./sqrt(y(1))/(y(1)-2.)
	slk=omik*y(1)*y(1)
	dlnok=-.5/y(1)-1./(y(1)-2.)
	ssll=-alfa*cs2*y(1)/y(2)+sl0
	omiga=ssll/y(1)/y(1)
c	rho=-dotm0*(y(1)/rout)**p0/4./3.1416/y(1)/cs*omik/y(2)
 	rho=-dotm0*exp(sint)/4./3.1416/y(1)/cs*omik/y(2)
	tau=tau+rho*(y0-y(1))*3.65d16/m
        y0=y(1)

	    ww=-alfa/y(2)*cs2
            w1=-ww/y(2)
            w2=ww/(y(3)/mue+y(4)/mui)
            w3=ww/y(1)-2.*omiga
            rdomiga=w1*dy(2)+w2*(dy(3)/mue+dy(4)/mui)+w3
            if(rdomiga.gt.0.) then
            print*,rdomiga,'# $$$$$$$$$$$$$$$'
            print*,'# FAILED!!!'
c           stop
            endif
	dh=cs/omik
        tao=dh*rho*3.65d16/m
        tao=tao/0.4d0
	dotmr=-4.*3.14*dh*rho*y(1)*y(2)/dotme

c now tao is in units of cgs
        poten=ssll*ssll/2./y(1)/y(1)-1./(y(1)-2.)
        Be=0.5*y(2)*y(2)+1.5/0.5*ru*y(3)+2.5*ru*y(4)+
     $          ssll*ssll/2./y(1)/y(1)-1./(y(1)-2.)

c the following calculates the advection factor

        a1=-1./y(2)
        a2=-1./2./(y(3)/mue+y(4)/mui)
c       a3=dlnok-1./y(1)
        a3=dlnok+(p0-1.)/y(1)
        rhodr=a1*dy(2)+a2*(1./mui*dy(4)+1./mue*dy(3))+a3
        setae=1.686d-10*y(3)
        setai=9.181d-14*y(4)
        qadv=rho*y(2)*ru*(dy(4)/mui/(gamai-1.)-y(4)/mui*rhodr)

	ate=1./setae*((3.*mbsl4(3,1.d0/setae)+mbsl4(1,1.d0/setae))/
     $       4./mbsl4(2,1.d0/setae)-1.d0)
	qadve=rho*y(2)*ru*(ate/mue*dy(3)-mue*y(3)*rhodr)
c qadve denotes the advection of electrons

        qie2=4./4.*37.85d0/m*rho*rho*(y(4)-y(3))*(sqrt(2./3.1416)+sqrt(
     $          setai+setae))/(setai+setae)**1.5d0

        qadv1=rho*y(2)*ru*dy(4)/mui/(gamai-1.)
        qadv2=rho*y(2)*ru*y(4)/mui*rhodr

        qvis=qadv+qie2
        advec=qadv/qvis
	advec2=(qadv+qadve)/qvis

        compy=4.*tao*1.686d-10*y(3)
	pgas=rho*6.d+5/m/m*1.38d-16/1.67d-24*(y(3)+y(4))
	bb=sqrt((1.-beta)/beta*pgas*8.*3.1416)

c--------------------------------------------------------------------------
c the following calculate the case of s is NOT equal to 0., i.e., outflow's case

	if(advec.lt.0.) p0=0.d0
 	if(advec.gt.0.) p0=advec*pp0

c the following calculate the integration for 's'
c sint denotes the integration for 's'

	if(k2.eq.0) p0=0.d0
	sint=sint+p0/y(1)*hh

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

	if(k2.eq.0) then
	seta=2.3536744d0
        ate=2.73821d0+0.12773*(setae-seta)-0.0901154*(setae-seta)**2.d0
     $      +0.0227991*(setae-seta)**3.d0-0.00219443*(setae-seta)**4.d0
     $      +7.07116d-5*(setae-seta)**5.d0

c	ate=1./setae*((3.*mbsl4(3,1.d0/setae)+mbsl4(1,1.d0/setae))/
c     $       4./mbsl4(2,1.d0/setae)-1.d0)

	qadve=rho*y(2)*ru*(ate/mue*dy(3)-mue*y(3)*rhodr)
	endif

          k2=k2+1

          if(abs(k2/10-k2/10.).lt.1.d-5.or.k2.eq.1) then

	  aaa=sqrt((4.+1.33*alfa*alfa)/(8./3.))
	  outflow=-rho*4.*3.14*y(1)*cs/omik*y(2)/dotme/0.05

c Modified the standard output ***
	    write(*,*) y(1),-y(2)/cs/aaa,log10(y(3))
     $	        ,log10(y(4)),advec,advec2,cs,dh,qn,tau,log10(slk)
     $		,log10(ssll),bb
c    $		log10(m*rho/1.01d-63*6.77d-12**3.d0/m**3.d0)
c the number density above is in cgs units
 	    write(41,6) log10(y(1)/2.d0),-y(2),
     $		log10(y(3)),log10(y(4)),log10(slk),log10(ssll)
     $          ,log10(tao),bb,-8.d+8/(y(1)/y(2)/0.203*m)/bb/bb
c    $		,log10(tao),bb,log10(rho*6.1749d+5/m/m/1.67d-24/mue)
     $		,compy,advec,qn*y(1)*y(1)*dh*1.d+18
c    $		,log10(rho*6.1749d+5/m/m/1.67d-24/mue),advec,be
c    $          ,dotmr,advec,be

	write(42,*) y(1),dh,qn,tau

c the last quantity -8.d+8/(y(1)/y(2)/0.203*m)/bb/bb, is the coolong Lolentz
c factor of the electrons.
7	format(3e12.4)
6	format(12e12.4)
5	format(6e11.3)

         endif

	if(y(1).lt.1.6.and.mmm.eq.0) then
c	print*,y,rho

           y(4)=3./16./ru*y(2)*y(2)
           y(3)=y(4)
           y(2)=y(2)/4.d0
           inform=12
           mmm=1
           print*,y
           pause
        endif

c----------------------------------------------------------
c the follwoing code calculate the luminosity emitted by
c the hot disk
c----------------------------------------------------------

         r(k2)=y(1)
         ddhh(k2)=cs/omik
         rho=-dotm/4./3.1416/y(1)/cs*omik/y(2)
         sum(k2)=qn*8.87d-27*m*m*m

         if(y(1).ge.2.2d0) goto 222

         sumlum=0.d0

         do 11 i=2,k2-1

         sigma(i)=3.1416*((r(i-1)+r(i))**2.d0/4.d0-(r(i)+r(i+1))
     $          **2.d0/4.d0)
         sumlum=sumlum+sigma(i)*2.*ddhh(i)*sum(i)/2.d0*2.d0
c in the above formula, a factor '/2.d0' should be present. This is because
c  what we observe is only half of the total emitted radiation: no!!!!

         Eddlum=1.3d+38*1.d+6*m*5.59d-61/m/2.03d-1*m
 11      continue
         write(*,*) '# The total luminosity is:',sumlum/eddlum,
     $		sumlum/(5.59d-61/m/2.03d-1*m)
c *** added
     	 write(*,*) '# Run finished'

	  if(y(1).ge.2.2d0) goto 222

	end

	subroutine dery(n,y,dy,qn,qd,tau,sint)
	implicit real*8(a-h,o-z)
	double precision m,mui,mue,numax,mbsl4
c ** hangproof
	double precision bessel1,bessel2,bessel3,bessel4
	dimension y(4),dy(4)
	common alfa,beta,dotm0,rout,p0,gamai,ru,
     $          sl0,m,mui,mue,delta,rtran
c ------------------------------------
c y(1): r;  y(2): v; y(3):te, y(4):ti    |
c ------------------------------------

	if(y(3).lt.0..or.y(4).lt.0.)  then
c	print*,y(3),y(4)
c	stop
	goto 232
	endif

	omik=1./sqrt(y(1))/(y(1)-2.)
	dlnok=-1./2.d0/y(1)-1./(y(1)-2.)
	cs2=ru/beta*(y(3)/mue+y(4)/mui)
	ssll=-alfa*cs2*y(1)/y(2)+sl0

	if(ssll.lt.0.) then
	print*,'# ssll < 0 '
	stop
	endif

	omiga=ssll/y(1)/y(1)

c	rho=-dotm/4./3.1416/y(1)/sqrt(cs2)*omik/y(2)
c	rho=-dotm0*(y(1)/rout)**p0/4./3.1416/y(1)/sqrt(cs2)*omik/y(2)
 	rho=-dotm0*exp(sint)/4./3.1416/y(1)/sqrt(cs2)*omik/y(2)

        p=rho*cs2
	cs=sqrt(cs2)
	h=cs/omik

	ww=-alfa/y(2)*cs2
        w1=-ww/y(2)
        w2=ww/(y(3)/mue+y(4)/mui)
        w3=ww/y(1)-2.*omiga

	a1=-1./y(2)
	a2=-1./2./(y(3)/mue+y(4)/mui)
c	a3=dlnok-1./y(1)
	a3=dlnok+(p0-1.)/y(1)

	deltap=1.-delta
c note that in the following the viscous dissipation
c heat electron is considered
	b1=rho*y(2)*ru*a1*y(4)/mui-alfa*p*w1*deltap
	b2=-alfa*p*w2*deltap/mue+rho*y(2)*ru*a2*y(4)/mui/mue
	b3=b2*mue/mui-1./(gamai-1.)*rho*y(2)*ru/mui

c--------------------------------
	setae=1.686d-10*y(3)
	setai=9.181d-14*y(4)

	if(1./setai.gt.7.d2) then
        qie=4./4.*37.85d0/m*rho*rho*(y(4)-y(3))*(sqrt(2./3.1416)+sqrt(
     $          setai+setae))/(setai+setae)**1.5d0
        else

        bel=1.d0*(setae+setai)/setae/setai
c ** hangproof
c	print *, 'R=',y(1)
	bessel3=mbsl4(1,bel)
c	print *, 'Bessel3=',bessel3
	bessel2=mbsl4(2,1.d0/setai)
c	print *, 'Bessel2=',bessel2
	bessel1=mbsl4(2,1.d0/setae)
c	print *, 'Bessel1=',bessel1
	bessel4=mbsl4(0,bel)
c	print *, 'Bessel4=',bessel4
c	differ=abs(rold-y(1))
c	if (differ .le. 1e-7 .AND. differ .ne. 0.) goto 17
c	rold=y(1)
        qie=2.366*20.d0/m*rho*rho*(y(4)-y(3))/bessel1
     $          /bessel2*((2.*(setae+setai)**2.d0+1.)/
     $          (setae+setai)*bessel3+2.*bessel4)
c	print *, 'qie=',qie

        endif

c---------------------------------
 	b4=qie+alfa*p*w3*deltap-rho*y(2)*ru*a3*y(4)/mui

	ppp=rho*y(2)*ru/mue
	c1=a1*y(3)-alfa*delta*p*w1/ppp

	ate=1./setae*((3.*mbsl4(3,1.d0/setae)+mbsl4(1,1.d0/setae))/
     $       4./mbsl4(2,1.d0/setae)-1.d0)

	c2=a2*y(3)/mue-ate-alfa*delta*p*w2/mue/ppp
	c3=a2*y(3)/mui-alfa*delta*p*w2/mui/ppp

c now we calculate c_4, i.e., the radiation rate.
c at first, we transfer the units of all the physical quantities
c from c=G=M=1 units into cgs units.

	rhorho=rho*6.1749d+5/m/m
	hh=h/6.77d-12*m

c the first, the breamsstrahlung radiation

	if(setae.lt.1.) then
	fseta=4.*sqrt(2.*setae/3.1416)/3.1416*(1.+1.781*setae**1.34d0)
     $		+1.73*setae**1.5d0*(1.+1.1*setae+setae*setae
     $		-1.25*setae**2.5d0)
	else
	fseta=9.d0*setae/2./3.1416*(log(1.123*setae+0.48)+1.5)+2.3*setae*
     $		(log(1.123*setae)+1.28)
	endif

	qbr=5.3d+25*rhorho*rhorho*fseta/mue/mue

c	goto 232

c the other two radiation mechanisms, i.e., synchrotron and comptonization
c are all related with the frequency, so we must calculat them in a integration
c as follows. This integration is based on the fomular eq.(41) in Manmoto
c et al. 1997, ApJ, 489, with the integartion variaty nu---> log10(nu), signed
c as tt.

	numax=log10(6.d+10*y(3))

c in the above, '2' is added in 2005.09.14; in the below, 13.--->14 also
c the uppler limit of frequency in the integration is determined
c by the bremsstrahlung emission: h \nu = k T
c ** changed first argument of simp2 from 12d0 to 90, following Renyi's suggestion
c	print*,setae
c ** hangproof
	print *, 'R=',y(1)
	call simp2(9.d0,numax,1.d-2,sum,setae,setai,rhorho,hh,qbr)
c	print*,setae
c	pause

c now take into account the Compton cooling due to the soft photons
c from the outside SSD.
c currently the units are cm.g.s, except rtran and r

        rr=y(1)/6.77d-12*m
	sup=10.d0*rtran/6.77d-12*m
	slow=rtran/6.77d-12*m
c       call simp(slow,sup,10,ssd,hh,rr,tau,rhorho,setae)

c the above 'ssd' denotes the cooling rate due to the Comptonization of
c the  soft photon emitted by SSD from r_tr to 10.**r_tr
c the amplification factor has been included since it is a function
c of the blackbody temperature, i.e., R.
c -------- 2003, June 14-------------

	if(log10(y(1)/2.).gt.1.5.and.sum/ssd.lt.6.d-1) then
c	print*,'sum/ssd=',sum/ssd,ssd,sum
c	pause
	endif

c in the following, the factor '2' (in SSD) is because the disk is two-sided
        qrad=sum*1.d0+ssd*0.d0

c transfer qrad to the dissipation rate per volum
	qneg=qrad/2./hh
	qn=qneg

c then transfer it from cgs units to the c=G=M=1 units

	qneg=qn*8.87d-27*m*m*m

	c4=(qneg-qie)/rho/y(2)/ru*mue-a3*y(3)+alfa*delta*w3*p/ppp

	q1=cs2

	d1=y(2)+q1*a1
	d2=q1*a2/mue+1.5/beta*ru/mue

c	d2=q1*a2/mue+1.0/beta*ru/mue

	d3=d2*mue/mui
	d4=(omiga*omiga-omik*omik)*y(1)-q1*a3

	dd=c1*d2*b3+d1*b2*c3+c2*d3*b1-b1*d2*c3-c2*d1*b3-b2*d3*c1
	dd1=c4*d2*b3+d4*b2*c3+c2*d3*b4-b4*d2*c3-c2*d4*b3-b2*d3*c4
	dd2=c1*d4*b3+d1*b4*c3+c4*d3*b1-b1*d4*c3-d1*c4*b3-b4*d3*c1
	dd3=c1*d2*b4+d1*b2*c4+c2*d4*b1-b1*d2*c4-d1*c2*b4-b2*d4*c1

	dy(1)=1.d0
	dy(2)=dd1/dd
	dy(3)=dd2/dd
	dy(4)=dd3/dd
	if(dy(4).gt.0..or.dy(3).gt.0.) then
	endif

232	return
	end

	subroutine simp(a,b,n,s,hh,r,tau,rhorho,setae)
        implicit real*8(a-h,o-z)
        h=(b-a)/float(2*n)
        s=0.5*(f(a,hh,r,tau,rhorho,setae)-f(b,hh,r,tau,rhorho,setae))
        do 1 i=1,n
1       s=s+2.*f(a+float(2*i-1)*h,hh,r,tau,rhorho,setae)
     $          +f(a+2.*h*float(i),hh,r,tau,rhorho,setae)
        s=(b-a)*s/float(3*n)
        return
        end

        function f(x0,hh,r,tau,rhorho,setae)
c here small 'r' denotes the location in ADAF
        implicit real*8(a-h,o-z)
	dimension repr(100),reph(100),emis(100),tau2(200)
        double precision msun,m,mui,mue
	common alfa,beta,dotm0,rout,p0,gamai,ru,
     $          sl0,m,mui,mue,delta,rtran

        msun=1.989d33
        g=6.67d-8
        pi=3.1416d0
	rg=g*m*1.d6*msun/9.d20

	r0=r
        x=x0
c now r0 is r in units of cm.g.s

        dotm=dotm0/3.44d-15/m*1.39d18*m*1.d6

c       fvis=3./8./pi*g*m*1.d6*msun/x**3.d0*dotm*(1.-rtran*rg/x)
 	fvis=3./8./pi*g*m*1.d6*msun/x**3.d0*dotm

c now consider the reprocessing effect
c all the related quantites such as the location in ADAF, height
c and emissivity are started with 'rep'
c 'n' is the number of the integration zone of ADAF
c reph(i), repr(i): the height and radius of a point in ADAF

	repn=10

	if(kkrep.eq.0) then
	do 103 i=1,repn
	read(14,*) repr(i),reph(i),emis(i),tau2(i)
c emis is in units of cm.g.s

	repr(i)=repr(i)*rg
	reph(i)=reph(i)*rg
103	continue
	kkrep=1
	endif

	frep=0.d0
	do 50 i=1,repn-1
c	ff1=reph(i)/2.*pi/(reph(i)*reph(i)/4.+(x-repr(i))**2.d0)**1.5

	ff1=reph(i)/2.*pi/(reph(i)*reph(i)/4.+repr(i)*repr(i)
     $          *sin(22.5/57.)*sin(22.5/57.)+(x-repr(i))**2.d0)**1.5

	ff2=reph(i)*pi/(reph(i)*reph(i)/4.+repr(i)*repr(i)+x*x)**1.5
	ff3=reph(i)/2.*pi/(reph(i)*reph(i)/4.+(repr(i)+x)**2.d0)**1.5

	if(tau2(i).gt.300.d0) then
	frep=frep
	else
	frep=frep+0.8d0*emis(i)*(ff1+ff2+ff3)
     $		*(repr(i)-repr(i+1))*repr(i)*reph(i)*exp(-tau2(i)*1.)
	endif

c11111111111111
c frep: corresponds to fvis, the flux produce per unit area due to
c the reprocessing of the central X-ray source
c here 0.8 is the assumed approximated value of the albedo rate,
c and this approximation is not bad

50	continue

c       fff1=hh/4./(hh*hh/4.+(x-r0)**2.d0)**1.5d0

	fff1=hh/4./(hh*hh/4.+(r0*sin(22.5/57.))**2.d0+
     $          (x-r0)**2.d0)**1.5d0

        fff2=hh/2./(x*x+r0*r0+hh*hh/4.)**1.5d0
        fff3=hh/4./(hh*hh/4.+(x+r0)**2.d0)**1.5d0

c compared to teh code of calculating the spectrum, 'pi' is
c absent in the above formula. This is due to the difference
c of spectrum and flux. Integration of bnu over nu is sigmaT**4/pi!!

c the following calculate the amplification factor
c the formular comes from Luo & Liang (1994; eqs. 11 & 12), or equivalently,
c from Dermer et al. 1991 (eqs. 16 & 17) note there is a slight difference
        taoes=0.4*rhorho*hh
        delt=sqrt(9./4.+pi*pi/12./taoes/(taoes+2./3.)/setae)-1.5d0
c	delt=sqrt(9./4.+pi*pi/12./(taoes+2./3.d0)/(taoes+2./3.)/setae)-1.5d0
c note: can't use delta!!!!
c        sigmarep=5.67d-5
        ts=((frep+fvis)/5.67d-5)**0.25d0
c ts: the black boby temperature of the SSD
        te2=setae/1.686d-10
        ampl=(1.-(1.275*ts/te2)**(delt-1.d0))/(delt-1.)

        f=ampl*(fff1+fff2+fff3)/exp(tau)*x*(frep+fvis)

c	print*,'fvis=',fvis,frep,ampl,fff2*x
c	pause

        return
        end

	function fct(tt,setae,setai,rhorho,hh,qbr)
        implicit real*8(a-h,o-z)
        double precision m,nu,kapa,mui,mue,mbsl4,
     $		mgam2,jm
	common alfa,beta,dotm0,rout,p0,gamai,ru,
     $          sl0,m,mui,mue,delta,rtran
c nu denotes the frequency(transfered into tt),
c te for the electron temperature
c all the quan. are in cgs units

        nu=10.d0**tt
        te=setae/1.686d-10
        ti=setai/9.18d-14

	bnu=1.47d-47*nu*nu*nu/(exp(4.8d-11*nu/te)-1.d0)
c ----------------------------

        if(2.08d+10/nu*te.lt.1.d0) then
        gaunt=sqrt(3./3.1416d0*4.8d-11/nu/te)
        else
        gaunt=4.8d-11/te*sqrt(3.)/3.1416*log(4./1.781*2.08d10*te/nu)
        endif

        qiabr=qbr*gaunt*exp(-4.8d-11*nu/te)

c now the synchrotron emission
        xx=5.29d-12*nu/setae/setae/sqrt(rhorho)/sqrt((1.-beta)/beta)
     $          /sqrt(ti/mui+te/mue)

        fxx=4.0505/xx**(1./6.d0)*(1.+0.4d0/xx**0.25d0+
     $          0.5316d0/sqrt(xx))*exp(-1.8899d0*xx**0.33333333333d0)

        fk2=mbsl4(2,1.d0/setae)

c       qiasy=4.43d-6*4.*3.1416*rhorho/1.67*nu*fxx/fk2
	qiasy=33.33482155d-6*rhorho*nu*fxx/fk2/mue
c	qiasy=0.d0

c -----------------------------
        qianu=qiabr+qiasy

        kapa=qianu/4./3.1416/bnu

        taonux=sqrt(3.1416)/2.*kapa*hh
c here, taonux denotes taonu star

	if(taonux.gt.1.d-5) then
        fnu=2.*3.1416d0/sqrt(3.d0)*bnu*
     $          (1.-dexp(-2.d0*sqrt(3.)*taonux))
        else
        fnu=2.*3.1416d0/sqrt(3.d0)*bnu*(2.*sqrt(3.)*taonux-
     $          6.*taonux*taonux+4.*sqrt(3.)*taonux**3.d0)
        endif

        fnu=2.*3.1416d0/sqrt(3.d0)*bnu*(1.-exp(-2.*sqrt(3.)*taonux))
c now, the comptonization

	a=1.+4.*setae+16.d0*setae*setae
 	taoes1=0.8d0*rhorho*hh

	if(taoes1.gt.4.0) then
	taoes=taoes1
	else
	a1=0.552d0
	a2=0.713d0
	a3=0.182d0
	a4=0.315d0
	taoese=a1*taoes1**a2*setae**(-a3/taoes1**a4)
	if(taoese.gt.taoes1) taoes=taoes1
	if(taoese.le.taoes1) taoes=(taoese+taoes1)/2.
	endif

c	taoes=taoes1

        s=taoes+taoes*taoes
        etamax=3.d0*2.084d+10*te/nu
        if(etamax.gt.1.) then
        jm=log(etamax)/log(a)
        else
        print*,'# etamax < 1 !!!',etamax,te,nu
        stop
        jm=0.d0
        endif

        eta=exp(s*(a-1.d0))*(1.-mgam2(jm+1.,a*s))+etamax*mgam2(jm+1.,s)

        fct=eta*2.*fnu*nu*log(10.d0)

        end

	function mgam2(a,x)
	implicit real*8(a-h,o-z)
	DOUBLE PRECISION MGAM2,A,X
	DOUBLE PRECISION MGAM1,P,Q,D,S,S1,P0,Q0,P1,Q1,QQ
	IF((A.LE.0.0).OR.(X.LT.0.0)) THEN
	IF(A.LE.0.0) THEN
	WRITE(*,*) 'ERR** A <= 0!'
	stop
	ENDIF
	IF(X.LT.0.0) THEN
	WRITE(*,*) 'ERR * * X < 0!'
	stop
	ENDIF
	MGAM2=-1.0
	ENDIF
	IF(X+1.0.EQ.1.0) THEN
	MGAM2=0.0
	RETURN
	ENDIF
	IF(X.GT.1.0D+35) THEN
	MGAM2=1.0
	RETURN
	ENDIF
	Q=LOG(X)
	Q=A*Q
	QQ=EXP(Q)
	IF(X.LT.1.0+A) THEN
	P=A
	D=1.0/A
	S=D
	DO 10 N=1,100
	P=1.0+P
	D=D*X/P
	S=S+D
	IF(ABS(D).LT.ABS(S)*1.0D-7) THEN
	S=S*EXP(-X)*QQ/MGAM1(A)
	MGAM2=S
	RETURN
	ENDIF
10	CONTINUE
	ELSE
	S=1.0/X
	P0=0.0
	P1=1.0
	Q0=1.0
	Q1=X
	DO 20 N=1,100
	P0=P1+(N-A)*P0
	Q0=Q1+(N-A)*Q0
	P=X*P0+N*P1
	Q=X*Q0+N*Q1
	IF(ABS(Q)+1.0.NE.1.0) THEN
	S1=P/Q
	P1=P
	Q1=Q
	IF(ABS((S1-S)/S1).LT.1.0D-7) THEN
	S=S1*EXP(-X)*QQ/MGAM1(A)
	MGAM2=1.0-S
	RETURN
	ENDIF
	S=S1
	ENDIF
	P1=P
	Q1=Q
20 	CONTINUE
	ENDIF
	WRITE(*,*) 'A TOO LARGE'
	S=1.0-S*EXP(-X)*QQ/MGAM1(A)
	MGAM2=S
	RETURN
	END

	FUNCTION MGAM1(X)
	DOUBLE PRECISION MGAM1,X
	DOUBLE PRECISION Y,T,S,U,A(11)
	DATA A/0.0000677106,-0.0003442342,0.0015397681,-0.0024467480,
     $	0.0109736958,-0.0002109075,0.0742379071,0.0815782188,
     $	0.4118402518,
     $	0.4227843370,1.0/
	IF(X.LE.0.) THEN
	WRITE(*,*) 'ERR * * X< 0!'
	MGAM1=-1.0
	RETURN
	ENDIF
	Y=X
	IF(Y.LE.1.0) THEN
	T=1.0/(Y*(Y+1.0))
	Y=Y+2.0
	ELSE IF(Y.LE.2.0) THEN
	T=1.0/Y
	Y=Y+1.0
	ELSE IF(Y.LE.3.0) THEN
	T=1.0
	ELSE
	T=1.0
10 	IF(Y.GT.3.0) THEN
	Y=Y-1.0
	T=T*Y
	GOTO 10
	ENDIF
	ENDIF
	S=A(1)
	U=Y-2.0
	DO 20 I=1,10
20	S=S*U+A(I+1)
	S=S*T
	MGAM1=S
	RETURN
	END

	function fct3(x,a)
	implicit real*8(a-h,o-z)
	fct3=x**(a-1.)*exp(-x)
	end

	SUBROUTINE SIMP3(A,B,EPS,SUM,aa)
        implicit real*8(a-h,o-z)
        DIMENSION F(2,30),FM(2,30),E(2,30),KRTN(30)
        SUM=0.d0
        T=1.d0
        ABSA=1.0
        EST=1.d0
        DA=B-A
        FA=FCT3(A,aa)
        FB=FCT3(B,aa)
        FP=4.0*FCT3(0.5*(A+B),aa)
        X=A
        L=0
 1      K=1
        L=L+1
        T=T*1.7
        DX=DA/3.0
        SX=DX/6.0
        FM1=4.0*FCT3(X+0.5*DX,aa)
        F1=FCT3(X+DX,aa)
	FM(1,L)=FP
        F(1,L)=FCT3(X+2.0*DX,aa)
        FM(2,L)=4.0*FCT3(X+2.5*DX,aa)
        F(2,L)=FB
        E1=SX*(FA+FM1+F1)
        E(1,L)=SX*(F1+FP+F(1,L))
        E(2,L)=SX*(F(1,L)+FM(2,L)+FB)
        S=E1+E(1,L)+E(2,L)
        ABSA=ABSA-ABS(EST)+ABS(E1)+ABS(E(1,L))+ABS(E(2,L))
        IF(EST.EQ.1.0) GOTO 5
        IF(T*ABS(EST-S).LE.EPS*ABSA) GOTO 2
        IF(L.LT.30) GOTO 5
2       SUM=SUM+S
3       L=L-1
        T=T/1.7
        K=KRTN(L)
        DX=DX*3.0
        IF(K.EQ.3) IF(L-1) 6,6,3
        EST=E(K,L)
        FP=FM(K,L)
        FA=FB
        FB=F(K,L)
        K=K+1
        X=X+DA
4       DA=DX
        KRTN(L)=K
        GOTO 1
5       EST=E1
        FP=FM1
        FB=F1
        GOTO 4
6       RETURN
	END

	SUBROUTINE SIMP2(A,B,EPS,SUM,setae,setai,rhorho,hh,qbr)
	implicit real*8(a-h,o-z)
	DIMENSION F(2,30),FM(2,30),E(2,30),KRTN(30)

	SUM=0.d0
	T=1.d0
	ABSA=1.0
	EST=1.d0
	DA=B-A
	FB=FCT(B,setae,setai,rhorho,hh,qbr)
	FP=4.0*FCT(0.5*(A+B),setae,setai,rhorho,hh,qbr)
	X=A
	L=0
 1	K=1
	L=L+1
	T=T*1.7
	DX=DA/3.0
	SX=DX/6.0
	FM1=4.0*FCT(X+0.5*DX,setae,setai,rhorho,hh,qbr)
	F1=FCT(X+DX,setae,setai,rhorho,hh,qbr)
	FM(1,L)=FP
	F(1,L)=FCT(X+2.0*DX,setae,setai,rhorho,hh,qbr)
	FM(2,L)=4.0*FCT(X+2.5*DX,setae,setai,rhorho,hh,qbr)
	F(2,L)=FB
	E1=SX*(FA+FM1+F1)
	E(1,L)=SX*(F1+FP+F(1,L))
	E(2,L)=SX*(F(1,L)+FM(2,L)+FB)
	S=E1+E(1,L)+E(2,L)
	ABSA=ABSA-ABS(EST)+ABS(E1)+ABS(E(1,L))+ABS(E(2,L))
	IF(EST.EQ.1.0) GOTO 5
	IF(T*ABS(EST-S).LE.EPS*ABSA) GOTO 2
	IF(L.LT.30) GOTO 5
2	SUM=SUM+S
3	L=L-1
	T=T/1.7
	K=KRTN(L)
	DX=DX*3.0
	IF(K.EQ.3) IF(L-1) 6,6,3
	EST=E(K,L)
	FP=FM(K,L)
	FA=FB
	FB=F(K,L)
	K=K+1
	X=X+DA
4	DA=DX
	KRTN(L)=K
	GOTO 1
5	EST=E1
	FP=FM1
	FB=F1
	GOTO 4
6	RETURN
	END

	subroutine mers(n,inform,h,eps,y,dy,w,qn,qd,tau,sint)
        implicit real*8(a-h,o-z)
        dimension y(1),dy(1),w(4,1),a(4),b(4),c(4)
        data a(1),a(2),a(3),a(4)/0.3333333333,0.16666666667,0.375,2.0/,
     $    b(1),b(2),b(3),b(4)/1.d0,0.444444444444,0.9375d0,8.d0/,
     $    c(1),c(2),c(3),c(4)/0.d0,0.25d0,-0.2d0,-1.125d0/

c ** Lines of code added to avoid the hanging of the code are labelled with HANGPROOF
c	rold=y(1)

        l=0
        k=w(3,1)
        if(inform.ge.10) goto 14
        ht=h/w(3,1)
        if(inform.ge.3) goto 3
        epsl=0.0781250*eps
 1      do 2 j=1,n
        w(3,j)=y(j)
 2      w(4,j)=dy(j)
  3     do 5 i=1,4
        do 4 j=1,n
        y(j)=y(j)+ht*a(i)*(dy(j)-w(2,j))
        w(2,j)=b(i)*(dy(j)+c(i)*w(1,j))
 4      if(i.eq.3) w(1,j)=dy(j)-0.22222222220*w(1,j)
 5      call dery(n,y,dy,qn,qd,tau,sint)
	if(sig.eq.-1.) goto 17
        i=1
        do 9 j=1,n
        r=0.16666666670*ht*(dy(j)-w(2,j))
        y(j)=y(j)+r
        goto (7,6,9),inform
  6     if(y(j).ne.0.0) r=r/y(j)
 7      if(abs(r*0.2).gt.eps) if(y(1)-(0.125*ht+y(1))) 12,8,12
 8      if(abs(r).gt.epsl) i=3
 9      continue
        if(i.ne.l-l/2*2) goto 15
        k=k/2
        l=1+l/2
        ht=ht*2
 10     call dery(n,y,dy,qn,qd,tau,sint)

c	** hangproof
c	differ=abs(rold-y(1))
c	print *, y(1), differ
c	if (differ .le. 1e-7 .AND. differ .ne. 0.) goto 17
c	rold=y(1)

        if(sig.eq.-1.) goto 17
        do 11 j=1,n
        w(1,j)=dy(j)
 11     w(2,j)=0.0
        if(l.ne.k) goto 1
        w(3,1)=k
17	inform=2
         return
 12     ht=0.5*ht

	cshu=cshu+1
        if(cshu.gt.150.) then
         inform=3
         print*,'###########################'
        endif

        l=l+l
        k=k+k
        do 13 j=1,n
        y(j)=w(3,j)
        dy(j)=w(4,j)
        w(1,j)=dy(j)
 13     w(2,j)=0.
        goto 3
 14     inform=inform-10
        k=1
 15     l=l+1
        goto 10
        end

	function cc(x)
	double precision c(7)
	data c/1.25331414,-0.07832358,0.02189568,-0.01062446,
     $          0.00587872,-0.0025154,0.00053208/
	p=c(7)
	do 100 i=6,1,-1
 100	p=p*x+c(i)
	cc=p
	return
	end

	function ddd(x)
	double precision d(7)
	data d/1.25331414,0.23498619,-0.0365562,0.01504268,
     $          -0.00780353,0.00325614,-0.00068245/
        p=d(7)
	do 101 i=6,1,-1
 101    p=p*x+d(i)
        ddd=p
        return
        end

	function mbsl4(n,x)
	double precision mbsl4,x,mbsl3
	double precision y,p,b0,b1,a(7),b(7),c(7),d(7)
	data a/-0.57721566,0.4227842,0.23069756,0.0348859,
     $		0.00262698,0.0001075,0.0000074/
	data b/1.0,0.15443144,-0.67278579,-0.18156897,
     $		-0.01919402,-0.00110404,-0.00004686/
 	data c/1.25331414,-0.07832358,0.02189568,-0.01062446,
     $		0.00587872,-0.0025154,0.00053208/
	data d/1.25331414,0.23498619,-0.0365562,0.01504268,
     $		-0.00780353,0.00325614,-0.00068245/
	if(n.lt.0) n=-n
	if(x.lt.0.) x=-x
	if(x+1.0.eq.1.) then
	mbsl4=1.d+35
	return
	endif
	if(n.ne.1) then
	if(x.le.2.) then
	y=x*x/4.
	p=a(7)
	do 10 i=6,1,-1
 10	 p=p*y+a(i)
	p=p-mbsl3(0,x)*log(x/2.)
	else
	y=2.0/x
	p=c(7)
	do 20 i=6,1,-1
 20	p=p*y+c(i)
	p=p*exp(-x)/sqrt(x)
	endif
	endif
	if(n.eq.0) then
	mbsl4=p
	return
	endif
	b0=p
	if(x.le.2.0) then
	y=x*x/4.
	p=b(7)
	do 30 i=6,1,-1
 30	p=p*y+b(i)
	p=p/x+mbsl3(1,x)*log(x/2.)
	else
	y=2./x
	p=d(7)
	do 40 i=6,1,-1
 40	p=p*y+d(i)
 	p=p*exp(-x)/sqrt(x)
	endif
	if(n.eq.1) then
	mbsl4=p
	return
	endif
	b1=p
	y=2./x
	do 50 i=1,n-1
	p=b0+i*y*b1
	b0=b1
	b1=p
 50	continue
	mbsl4=p
	return
	end

C THIS PROGRAM IS TO CALCULATE THE MODIFIED BASEL FUNCTION OF THE FIRST KIND
C IT IS CORRECT!!!!!!!!!!!!!!!
	function mbsl3(n,x)
	double precision mbsl3,x
	double precision t,y,p,b0,b1,q,a(7),b(7),c(9),d(9)
	data a/1.0, 3.5156229,3.0899424,1.2067492,
     $		0.2659732,0.0360768,0.0045813/
	data b/0.5,0.87890594,0.51498869,0.15084934,0.02658773,
     $		0.00301532,0.00032411/
	data c/0.39894228,0.01328592,0.00225319,-0.00157565,
     $		0.00916281,-0.02057706,0.02635537,-0.01647663,0.00392377/
	data d/0.39894228,-0.03988024,-0.00362018,0.00163801,
     $		-0.01031555,0.02282967,-0.02895312,0.01787654,-0.00420059/

	if(n.lt.0) n=-n
	t=abs(x)
	if (n.ne.1) then
	 if(t.lt.3.75) then
	   y=(x/3.75)*(x/3.75)
	   p=a(7)
	   do 10 i=6,1,-1
  10	   p=p*y+a(i)
	 else
	   y=3.75/t
	   p=c(9)
	   do 20 i=8,1,-1
 20	   p=p*y+c(i)
	   p=p*exp(t)/sqrt(t)
	 endif
	endif
	if(n.eq.0) then
	 mbsl3=p
	 return
	endif
	q=p
	if(t.lt.3.75) then
	y=(x/3.75)**2.d0
	p=b(7)
	do 30 i=6,1,-1
 30	p=p*y+b(i)
	p=p*t
	else
	y=3.75/t
	p=d(9)
	do 40 i=8,1,-1
 40	p=p*y+d(i)
	p=p*exp(t)/sqrt(t)
	endif
	if(x.lt.0.0) p=-p
	if(n.eq.1) then
	mbsl3=p
	return
	endif
	if(x+1.0.eq.1.0) then
	mbsl3=0.0
	return
	endif
	y=2.0/t
	t=0.0
	b1=1.0
	b0=0.0
	m=sqrt(40.0*n)
	m=m+n
	m=m+m
	do 50 i=m,1,-1
	p=b0+i*y*b1
	b0=b1
	b1=p
	if(abs(b1).gt.1.d+10) then
	t=t*1.d-10
	b0=b0*1.d-10
	b1=b1*1.d-10
	endif
	if(i.eq.n) t=b0
 50	continue
	p=t*q/b1
	if((x.lt.0.0).and.(mod(n,2).eq.1)) p=-p
	mbsl3=p
	return
	end


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
! Copyright Universite de Pau et des Pays de l'Adour and CNRS, France.
! Contributors: Dimitri Komatitsch, dimitri DOT komatitsch aT univ-pau DOT fr
!               Nicolas Le Goff, nicolas DOT legoff aT univ-pau DOT fr
!               Roland Martin, roland DOT martin aT univ-pau DOT fr
!               Christina Morency, cmorency aT princeton DOT edu
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! 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 2 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, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine compute_forces_poro_viscous_damping()

! viscous damping

  use constants, only: CUSTOM_REAL,NGLLX,NGLLZ,ZERO,USE_PORO_VISCOUS_DAMPING

  use specfem_par, only: nspec,it,SIMULATION_TYPE,SAVE_FORWARD, &
                         ATTENUATION_PORO_FLUID_PART, &
                         ibool,kmato,ispec_is_poroelastic, &
                         accels_poroelastic, &
                         accelw_poroelastic, &
                         velocw_poroelastic, &
                         porosity,tortuosity,permeability,poroelastcoef, &
                         jacobian,wxgll,wzgll, &
                         rx_viscous,rz_viscous,theta_e,theta_s, &
                         b_viscodampx,b_viscodampz

  implicit none

  ! local variables
  integer :: ispec,i,j,iglob

  double precision, dimension(3):: bl_relaxed_viscoelastic,bl_unrelaxed_elastic
  double precision :: eta_f,phi,tort
  double precision :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
  double precision :: viscodampx,viscodampz
  double precision :: visc_x,visc_z

  ! checks if anything to do
  if (.not. USE_PORO_VISCOUS_DAMPING) return

  ! loop over spectral elements
  do ispec = 1,nspec

    eta_f = poroelastcoef(2,2,kmato(ispec))

    if (ispec_is_poroelastic(ispec) .and. eta_f > 0.d0) then
      phi = porosity(kmato(ispec))
      tort = tortuosity(kmato(ispec))

      permlxx = permeability(1,kmato(ispec))
      permlxz = permeability(2,kmato(ispec))
      permlzz = permeability(3,kmato(ispec))

      ! calcul of the inverse of k
      detk = permlxx*permlzz - permlxz*permlxz

      if (detk /= ZERO) then
        invpermlxx = permlzz/detk
        invpermlxz = -permlxz/detk
        invpermlzz = permlxx/detk
      else
        stop 'Permeability matrix is not invertible'
      endif

      if (ATTENUATION_PORO_FLUID_PART) then
        ! viscous attenuation is implemented following the memory variable formulation of
        ! J. M. Carcione Wave fields in real media: wave propagation in anisotropic,
        ! anelastic and porous media, Elsevier, p. 304-305, 2007
        bl_relaxed_viscoelastic(1) = eta_f*invpermlxx*theta_e/theta_s
        bl_relaxed_viscoelastic(2) = eta_f*invpermlxz*theta_e/theta_s
        bl_relaxed_viscoelastic(3) = eta_f*invpermlzz*theta_e/theta_s
      else
        ! relaxed viscous coef
        bl_unrelaxed_elastic(1) = eta_f*invpermlxx
        bl_unrelaxed_elastic(2) = eta_f*invpermlxz
        bl_unrelaxed_elastic(3) = eta_f*invpermlzz
      endif

      do j = 1,NGLLZ
        do i = 1,NGLLX
          iglob = ibool(i,j,ispec)

          ! computes the viscous damping term
          if (ATTENUATION_PORO_FLUID_PART) then
            ! with the unrelaxed viscous coef and add memory variable
            viscodampx = velocw_poroelastic(1,iglob)*bl_relaxed_viscoelastic(1) &
                       + velocw_poroelastic(2,iglob)*bl_relaxed_viscoelastic(2) - rx_viscous(i,j,ispec)
            viscodampz = velocw_poroelastic(1,iglob)*bl_relaxed_viscoelastic(2) &
                       + velocw_poroelastic(2,iglob)*bl_relaxed_viscoelastic(3) - rz_viscous(i,j,ispec)
          else
            ! no viscous attenuation
            viscodampx = velocw_poroelastic(1,iglob)*bl_unrelaxed_elastic(1) &
                       + velocw_poroelastic(2,iglob)*bl_unrelaxed_elastic(2)
            viscodampz = velocw_poroelastic(1,iglob)*bl_unrelaxed_elastic(2) &
                       + velocw_poroelastic(2,iglob)*bl_unrelaxed_elastic(3)
          endif

          ! viscous term eta_f k^-1 dot(w)
          visc_x = wxgll(i) * wzgll(j) * jacobian(i,j,ispec) * viscodampx
          visc_z = wxgll(i) * wzgll(j) * jacobian(i,j,ispec) * viscodampz

          ! solid contribution
          ! adds term + phi/tort eta_f k^-1 dot(w)
          accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + phi/tort * visc_x
          accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + phi/tort * visc_z

          ! fluid contribution
          ! add - eta_f k^-1 dot(w)
          accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - visc_x
          accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - visc_z

          ! reconstructed/backward wavefield
          ! viscous damping contribution
          if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
            ! stores contribution
            b_viscodampx(i,j,ispec) = visc_x
            b_viscodampz(i,j,ispec) = visc_z
          endif

        enddo
      enddo

    endif ! end of test if poroelastic element

  enddo ! end of loop over all spectral elements

  ! saves viscous contribution to disk
  if (SAVE_FORWARD .and. SIMULATION_TYPE == 1) then
    ! writes damping contributions to file
    write(23,rec=it) b_viscodampx(:,:,:)
    write(24,rec=it) b_viscodampz(:,:,:)
  endif

  end subroutine compute_forces_poro_viscous_damping

!
!-------------------------------------------------------------------------------------
!

  subroutine compute_forces_poro_viscous_damping_backward()

! viscous damping

  use constants, only: CUSTOM_REAL,NGLLX,NGLLZ,ZERO,USE_PORO_VISCOUS_DAMPING

  use specfem_par, only: nspec,NSTEP,it,SIMULATION_TYPE, &
                         ibool,kmato,ispec_is_poroelastic, &
                         b_accels_poroelastic, &
                         b_accelw_poroelastic, &
                         porosity,tortuosity,poroelastcoef, &
                         b_viscodampx,b_viscodampz

  implicit none

  ! local variables
  integer :: ispec,i,j,iglob

  double precision :: eta_f,phi,tort
  double precision :: visc_x,visc_z

  ! checks if anything to do
  if (.not. USE_PORO_VISCOUS_DAMPING) return
  if (SIMULATION_TYPE /= 3) return

  ! reads in viscous contributions for reconstructed/backward wavefield
  read(23,rec=NSTEP-it+1) b_viscodampx(:,:,:)
  read(24,rec=NSTEP-it+1) b_viscodampz(:,:,:)

  ! loop over spectral elements
  do ispec = 1,nspec

    eta_f = poroelastcoef(2,2,kmato(ispec))

    if (ispec_is_poroelastic(ispec) .and. eta_f > 0.d0) then

      phi = porosity(kmato(ispec))
      tort = tortuosity(kmato(ispec))

      do j = 1,NGLLZ
        do i = 1,NGLLX
          iglob = ibool(i,j,ispec)

          ! reconstructed/backward wavefield
          ! viscous damping contribution
          ! kernels simulation uses previously stored contributions
          visc_x = b_viscodampx(i,j,ispec)
          visc_z = b_viscodampz(i,j,ispec)

          ! solid
          b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + phi/tort * visc_x
          b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + phi/tort * visc_z
          ! fluid
          b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - visc_x
          b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - visc_z

        enddo
      enddo

    endif ! end of test if poroelastic element

  enddo ! end of loop over all spectral elements

  end subroutine compute_forces_poro_viscous_damping_backward


MODULE header_file
!
! replacement for the old fortran77 include file with common blocks
! here we declare some shared memory variables such as position and momenta arrays
! they are now allocatable, with the size being determined through the input file

IMPLICIT NONE
PUBLIC
SAVE

INTEGER, PARAMETER :: double = SELECTED_REAL_KIND(15,99)

INTEGER, PARAMETER :: EQN_NUMBER = 4 ! number of right hand side equations to be solved
INTEGER, PARAMETER :: NUMPROPS   = 21 ! number of properties used in block averaging scheme

REAL(kind = double), PARAMETER :: PI = 3.141592654D0
REAL(kind = double), PARAMETER :: PI2 = 2.0D0*PI
REAL(kind = double), PARAMETER :: BETA = 10.0D0

REAL(kind = double), DIMENSION(2,2) :: EFC, ECF
REAL(kind = double), DIMENSION(NUMPROPS) :: BLOCKTOTAL,BLOCKAVG,PROPERTY

REAL(kind = double), ALLOCATABLE, DIMENSION(:) :: X, Y
REAL(kind = double), ALLOCATABLE, DIMENSION(:) :: PX, PY
REAL(kind = double), ALLOCATABLE, DIMENSION(:) :: MASS

INTEGER, ALLOCATABLE, DIMENSION(:) :: NI, NJ, MAP
INTEGER, ALLOCATABLE, DIMENSION(:) :: HEAD, LIST

REAL(kind = double) :: DENSITY, SIGMA, EPS, DT, VOLUME,TIME
REAL(kind = double) :: ZETA,SIGSQ, EPSIG8, DIFF_MN, M_RATIO, N_RATIO
REAL(kind = double) :: FORCE_MN_FACT, RCUT,SHEAR,DELTA,GAMMA
REAL(kind = double) :: RCUT_INNER,SPLINE_R2,SPLINE_R3,RCUT_INNER_SQ
REAL(kind = double) :: CUTSQ,TREQ,ALEN,BLEN,TIME_STRAIN,DEGFREE
REAL(kind = double) :: SOFT_N,H_LUCY,EFACT_LUCY,FORCE_FACT_LUCY
REAL(kind = double) :: TKIN,PRESSURE,PV_KIN,PV_POT,PXX,PYY,PXY,PKXX,PKYY,PKXY

INTEGER :: NTS, N_POWER, M_POWER, ISTART, ISUB, MOVWRITE, N_POWER_SUB1, M_POWER_SUB1
INTEGER :: NEQ,N,NPAIRS,MAXPAIR,IPOT_TYPE,SS_POWER
INTEGER :: NCELLX,NCELLY,NCELL,MAPSIZE,ITHERM
INTEGER :: LATTICE_TYPE,ITIME

CHARACTER(7) :: XYZ_FILE_STAT

NAMELIST /input_deck/N, NTS, ISTART,IPOT_TYPE,N_POWER,M_POWER,RCUT, &
                    & TREQ,DENSITY,SHEAR,SIGMA, EPS,SS_POWER,ITHERM,&
                    & DT,LATTICE_TYPE,ISTART,ISUB,MOVWRITE

END MODULE header_file


! ==============================================================================
! Riemann solver in the transverse direction for the acoustics equations.
! Split asdq into down-going flux bmasdq and up-going flux bpasdq.
! ==============================================================================

subroutine rpt2_ptwise(ixy, imp, num_eqn, num_aux, num_waves, q_l, q_r,      &
                       aux_l, aux_r, asdq, bmasdq, bpasdq)

    implicit none

    ! Input
    integer, intent(in) :: num_eqn, num_aux, num_waves, ixy, imp
    real(kind=8), intent(in) :: q_l(num_eqn), q_r(num_eqn)
    real(kind=8), intent(in) :: aux_l(num_aux, 3), aux_r(num_aux, 3)
    real(kind=8), intent(in out) :: asdq(num_eqn)

    ! Output
    real(kind=8), intent(in out) :: bmasdq(num_eqn), bpasdq(num_eqn)

    ! Locals
    integer :: normal_index, transverse_index
    real(kind=8) :: a(2)

    ! Common block
    ! density, bulk modulus, and sound speed, and impedence of medium:
    real(kind=8) :: rho, bulk, cc, zz
    common /cparam/ rho, bulk, cc, zz

    if (ixy == 1) then
        normal_index = 2
        transverse_index = 3
    else
        normal_index = 3
        transverse_index = 2
    endif

    a(1) = (-asdq(1) + zz * asdq(transverse_index)) / (2.d0 * zz)
    a(2) = ( asdq(1) + zz * asdq(transverse_index)) / (2.d0 * zz)

    ! Down-going flux difference bmasdq is the product of -c * wave
    bmasdq(1) = cc * a(1) * zz
    bmasdq(normal_index) = 0.d0
    bmasdq(transverse_index) = -cc * a(1)

    ! Up-going flux difference bpasdq is the product of c * wave
    bpasdq(1) = cc * a(2) * zz
    bpasdq(normal_index) = 0.d0
    bpasdq(transverse_index) = cc * a(2)

end subroutine rpt2_ptwise


!##############################################
!##########Compile Instructions###############
!"chmod +x config.sh"
!"./config.sh"
!
!###########Execution######################
!"./cpflow_1D.exe"
!
!##############################################

program cpflow1D

use module_parameters
use module_grid
use module_solver

IMPLICIT NONE

        INTEGER		    ::I,K
	REAL(8)	            ::UMAX,UAVG,UTAU1,UTAU2
	REAL(8),ALLOCATABLE ::YHAD(:),YPAD(:),A(:),B(:)
	REAL(8),ALLOCATABLE ::U(:),U1(:),DYN_VIS_TUR(:),MIX_LEN(:),LEN_ZERO(:),TKIN_VISN(:),TKIN_VISS(:),LD(:),MD(:),UD(:),D(:)
	REAL(8)	::A1,A2,ERROR
        CHARACTER(len=100)::excommand

        !CASE SELECTION
        CHARACTER(len=15):: OUTPUTFILE
        REAL(8)          ::VW, H, DPDX
        INTEGER:: NUM_CASE
        NUM_CASE=1

        !managing filenames
         if (NUM_CASE < 10) then
                  write (OUTPUTFILE, "(A6,I1,A8)") "Case_0",NUM_CASE,"_sim.dat"
        else
                  write (OUTPUTFILE, "(A5,I2,A8)") "Case_",NUM_CASE,"_sim.dat"
        endif
        CALL case_select(NUM_CASE,VW, H, DPDX)

        print *, "The case selected is CASE NUMBER ",NUM_CASE
        print *, "Here, the values of VW, H, DPDX are ",VW, H, DPDX, "respectively."
        print *, "The data generated will be saved to file ", OUTPUTFILE

	ALLOCATE(YPAD(N),YHAD(N),U(N),U1(N),DYN_VIS_TUR(N),MIX_LEN(N),LEN_ZERO(N),A(N),B(N))
	ALLOCATE(TKIN_VISN(N),TKIN_VISS(N),LD(N),MD(N),UD(N),D(N))
	U=0.0d0
	!TKIN_VIS is the turbulent kinematic viscosity
	!YPAD is the y coordinates of the mesh
	!YHAD(n) is the distance between YPAD(n) & YPAD(n-1)
	!UMAX= MAX VEL IN THE FLOW
	!UAVG= AVG VEL IN THE FLOW

	CALL sGrid_Generator(H,N,ALPHA,YPAD,YHAD)		!Stretched grid generator
        OPEN(12,file='GRID.dat')
        WRITE(12,*) '# GRID: NUMBER OF POINTS: ',N,' STRETCHING COEFFICIENT ALPHA: ',ALPHA
        WRITE(12,*) "#I        YPAD              YHAD"
	DO I=1,N
	   WRITE(12,11)I,YPAD(I),YHAD(I)
	ENDDO
	11 FORMAT(I3,2x,2(F16.8,2x))
	!DEALLOCATE(YPAD,YHAD)
	CLOSE(12)

        print *, "Copying Generated GRID.dat to the directory Simulated_Data "
        call system('cp GRID.dat ../Simulated_Data/GRID.dat')
        print *, "Copied Successfully "

	CALL SOLVE_CP(U,ERROR,U1,VW,H,N,LD,MD,UD,D,YPAD,YHAD,ALPHA,DPDX,DYN_VIS,KIN_VIS,RHO,CONV_CRIT,OUTPUTFILE)
	CLOSE(77)

        !Data Management
        print *, "Copying Generated simulation data to the directory Simulated_Data "
        excommand="cp "//OUTPUTFILE//" ../Simulated_Data/"//OUTPUTFILE
        !print *, trim(excommand)
        call system(trim(excommand))
        print *, "Copied Successfully "

        !Plotting
        excommand="python plot_case.py --file "//OUTPUTFILE
        if (PLOT=='Y') then
        print *, "Creating Plots"
        print *, trim(excommand)
        call system(trim(excommand))
        else
        print *, "Auto Plotting Disabled"

        end if

        DEALLOCATE(YPAD,YHAD,U,U1,DYN_VIS_TUR,MIX_LEN,LEN_ZERO,A,B)
	DEALLOCATE(TKIN_VISN,TKIN_VISS,LD,MD,UD,D)

end program


!	Covariances of products of elements of latent vector and of elements of latent vector with normal
!	distribution with mean mean and  covariance cov.
function cubicnormal(cov,mean)
implicit none
real(kind=8),intent(in)::cov(:,:),mean(:)
real(kind=8)::cubicnormal(size(mean),size(mean),size(mean))
!	Counters
integer::col,row,row2
do row=1,size(mean)
	do col=1,row
		do row2=1,size(mean)
			cubicnormal(row,col,row2)=mean(col)*cov(row,row2)+mean(row)*cov(col,row2)

		end do
	end do
end do
return
end function cubicnormal


      program matadd
      integer m
      integer n
      parameter (m = 402, n = 160)
      integer i, j
      real a(m, n), b(m, n), c(m, n)

      do i=1,m
         do j=1,n
            b(i,j) = i
            c(i,j) = j
         end do
      end do

      do i=1,m
         do j=1,n
            a(i,j) = b(i,j) + c(i,j)
         end do
      end do

      end


!! Convenient definitions of numerical constants.  This should not
!! be considered an exhaustive list of such constants.
module bl_constants_module

  use bl_types
  use bl_fort_module
  implicit none

  real(kind = bl_real), parameter :: ZERO    =  0.0_bl_real
  real(kind = bl_real), parameter :: ONE     =  1.0_bl_real
  real(kind = bl_real), parameter :: TWO     =  2.0_bl_real
  real(kind = bl_real), parameter :: THREE   =  3.0_bl_real
  real(kind = bl_real), parameter :: FOUR    =  4.0_bl_real
  real(kind = bl_real), parameter :: FIVE    =  5.0_bl_real
  real(kind = bl_real), parameter :: SIX     =  6.0_bl_real
  real(kind = bl_real), parameter :: SEVEN   =  7.0_bl_real
  real(kind = bl_real), parameter :: EIGHT   =  8.0_bl_real
  real(kind = bl_real), parameter :: NINE    =  9.0_bl_real
  real(kind = bl_real), parameter :: TEN     = 10.0_bl_real

  real(kind = bl_real), parameter :: ELEVEN  = 11.0_bl_real
  real(kind = bl_real), parameter :: TWELVE  = 12.0_bl_real
  real(kind = bl_real), parameter :: FIFTEEN = 15.0_bl_real
  real(kind = bl_real), parameter :: SIXTEEN = 16.0_bl_real

  real(kind = bl_real), parameter :: HALF    = 0.5_bl_real
  real(kind = bl_real), parameter :: THIRD   = ONE/THREE
  real(kind = bl_real), parameter :: FOURTH  = 0.25_bl_real
  real(kind = bl_real), parameter :: FIFTH   = ONE/FIVE
  real(kind = bl_real), parameter :: SIXTH   = ONE/SIX
  real(kind = bl_real), parameter :: SEVENTH = ONE/SEVEN
  real(kind = bl_real), parameter :: EIGHTH  = 0.125_bl_real
  real(kind = bl_real), parameter :: NINETH  = ONE/NINE
  real(kind = bl_real), parameter :: TENTH   = 0.10_bl_real
  real(kind = bl_real), parameter :: TWELFTH = ONE/TWELVE

  real(kind = bl_real), parameter :: TWO3RD    = TWO/THREE
  real(kind = bl_real), parameter :: FOUR3RD   = FOUR/THREE
  real(kind = bl_real), parameter :: FIVE3RD   = FIVE/THREE
  real(kind = bl_real), parameter :: FIVE6TH   = FIVE/SIX

  real(kind = bl_real), parameter :: THREE4TH  = 0.75_bl_real

  real(kind = bl_real), parameter :: FIVE12TH = FIVE/TWELVE
  real(kind = bl_real), parameter :: SEVEN12TH = SEVEN/TWELVE

  real(kind = bl_real), parameter :: FIVE32ND = FIVE/32.0_bl_real

  !! Pi
  real(kind = bl_real), parameter :: M_PI    = &
       3.141592653589793238462643383279502884197_bl_real
  real(kind = bl_real), parameter :: M_SQRT_PI  = &
       1.772453850905516027298167483341145182798_bl_real

  !! Roots
  real(kind = bl_real), parameter :: M_SQRT_2  = &
       1.414213562373095048801688724209698078570_bl_real

end module bl_constants_module

module amrex_constants_module
  use bl_constants_module
  implicit none
end module amrex_constants_module


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module defining all constants and conversions for
!> different units to be used throughout the code.
!>
!> All constants used within the code will be contained in this module.
!> This module will contain Neighbor Indexing for all operations.
!> This module will also provide functionality to convert between units of
!> similar types (i.e. Kelvin to Celsius, or inches to centimeters).
!> Functionality may be added to do complex or multiple unit conversion
!> in one subroutine call. (Unsure if this will work).
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE Constants_Conversion
USE IntrType
IMPLICIT NONE
PRIVATE

PUBLIC :: K_to_C
PUBLIC :: C_to_K
PUBLIC :: F_to_C
PUBLIC :: C_to_F
PUBLIC :: F_to_K
PUBLIC :: K_to_F
PUBLIC :: tempTo_K
PUBLIC :: tempTo_C
PUBLIC :: tempTo_F
PUBLIC :: tempTo_R
PUBLIC :: convertTemp

!> Parameters for commonly used constants
REAL(SRK),PUBLIC,PARAMETER ::    ZERO=0.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::     ONE=1.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::     TWO=2.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::   THREE=3.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::    FOUR=4.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::    FIVE=5.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::     SIX=6.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::   SEVEN=7.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::   EIGHT=8.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::    NINE=9.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::     TEN=10.000000000000000_SRK !16 digits
REAL(SRK),PUBLIC,PARAMETER ::    HALF=0.500000000000000_SRK !16 digits
!> Useful fractions of PI
REAL(SRK),PUBLIC,PARAMETER ::   QTRPI=ATAN(ONE)
REAL(SRK),PUBLIC,PARAMETER ::  HALFPI=TWO*QTRPI
REAL(SRK),PUBLIC,PARAMETER ::      PI=TWO*HALFPI
REAL(SRK),PUBLIC,PARAMETER :: SIXTHPI=PI/6._SRK
REAL(SRK),PUBLIC,PARAMETER :: THIRDPI=TWO*SIXTHPI
REAL(SRK),PUBLIC,PARAMETER ::   TWOPI=TWO*PI
REAL(SRK),PUBLIC,PARAMETER ::  FOURPI=TWO*TWOPI
REAL(SRK),PUBLIC,PARAMETER ::     RPI=ONE/PI
REAL(SRK),PUBLIC,PARAMETER ::  RTWOPI=ONE/TWOPI
REAL(SRK),PUBLIC,PARAMETER :: RFOURPI=ONE/FOURPI

!> Convert from radians to degrees
REAL(SRK),PUBLIC,PARAMETER :: rad2degrees=180.0_SRK/PI
!> Convert from degrees to radians
REAL(SRK),PUBLIC,PARAMETER :: degrees2rad=PI/180.0_SRK

!> Avogadro's Number; source: https://physics.nist.gov/cgi-bin/cuu/Value?na
REAL(SRK),PUBLIC,PARAMETER :: NA=6.022140857E+23_SRK

!> Gravity (m/s^2); source: https://en.wikipedia.org/wiki/Gravity_of_Earth
REAL(SRK),PUBLIC,PARAMETER :: GRAV=9.80665_SRK

! Area conversion
!> Conversion factor from barns to cm**2
REAL(SRK),PUBLIC,PARAMETER :: barn2cm=1.0E-24_SRK
!> Conversion factor from cm**2 to barns
REAL(SRK),PUBLIC,PARAMETER :: cm2barn=1.0E24_SRK

!> Conversions for metric units for all combinations from pico to tera.
REAL(SRK),PUBLIC,PARAMETER ::   tera2base=1.000000000000000E+12_SRK
REAL(SRK),PUBLIC,PARAMETER ::   giga2base=1.000000000000000E+09_SRK
REAL(SRK),PUBLIC,PARAMETER ::   mega2base=1.000000000000000E+06_SRK
REAL(SRK),PUBLIC,PARAMETER ::   kilo2base=1.000000000000000E+03_SRK
REAL(SRK),PUBLIC,PARAMETER ::  centi2base=1.000000000000000E-02_SRK
REAL(SRK),PUBLIC,PARAMETER ::  milli2base=1.000000000000000E-03_SRK
REAL(SRK),PUBLIC,PARAMETER ::  micro2base=1.000000000000000E-06_SRK
REAL(SRK),PUBLIC,PARAMETER ::   nano2base=1.000000000000000E-09_SRK
REAL(SRK),PUBLIC,PARAMETER ::   pico2base=1.000000000000000E-12_SRK
REAL(SRK),PUBLIC,PARAMETER ::   base2tera=ONE/tera2base
REAL(SRK),PUBLIC,PARAMETER ::   base2giga=ONE/giga2base
REAL(SRK),PUBLIC,PARAMETER ::   base2mega=ONE/mega2base
REAL(SRK),PUBLIC,PARAMETER ::   base2kilo=ONE/kilo2base
REAL(SRK),PUBLIC,PARAMETER ::  base2centi=ONE/centi2base
REAL(SRK),PUBLIC,PARAMETER ::  base2milli=ONE/milli2base
REAL(SRK),PUBLIC,PARAMETER ::  base2micro=ONE/micro2base
REAL(SRK),PUBLIC,PARAMETER ::   base2nano=ONE/nano2base
REAL(SRK),PUBLIC,PARAMETER ::   base2pico=ONE/pico2base
REAL(SRK),PUBLIC,PARAMETER ::   tera2giga=tera2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::   tera2mega=tera2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::   tera2kilo=tera2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER ::  tera2centi=tera2base*base2centi
REAL(SRK),PUBLIC,PARAMETER ::  tera2milli=tera2base*base2milli
REAL(SRK),PUBLIC,PARAMETER ::  tera2micro=tera2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::   tera2nano=tera2base*base2nano
REAL(SRK),PUBLIC,PARAMETER ::   tera2pico=tera2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::   giga2tera=giga2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::   giga2mega=giga2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::   giga2kilo=giga2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER ::  giga2centi=giga2base*base2centi
REAL(SRK),PUBLIC,PARAMETER ::  giga2milli=giga2base*base2milli
REAL(SRK),PUBLIC,PARAMETER ::  giga2micro=giga2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::   giga2nano=giga2base*base2nano
REAL(SRK),PUBLIC,PARAMETER ::   giga2pico=giga2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::   mega2tera=mega2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::   mega2giga=mega2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::   mega2kilo=mega2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER ::  mega2centi=mega2base*base2centi
REAL(SRK),PUBLIC,PARAMETER ::  mega2milli=mega2base*base2milli
REAL(SRK),PUBLIC,PARAMETER ::  mega2micro=mega2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::   mega2nano=mega2base*base2nano
REAL(SRK),PUBLIC,PARAMETER ::   mega2pico=mega2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::   kilo2tera=kilo2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::   kilo2giga=kilo2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::   kilo2mega=kilo2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::  kilo2centi=kilo2base*base2centi
REAL(SRK),PUBLIC,PARAMETER ::  kilo2milli=kilo2base*base2milli
REAL(SRK),PUBLIC,PARAMETER ::  kilo2micro=kilo2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::   kilo2nano=kilo2base*base2nano
REAL(SRK),PUBLIC,PARAMETER ::   kilo2pico=kilo2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::  centi2tera=centi2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::  centi2giga=centi2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::  centi2mega=centi2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::  centi2kilo=centi2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER :: centi2milli=centi2base*base2milli
REAL(SRK),PUBLIC,PARAMETER :: centi2micro=centi2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::  centi2nano=centi2base*base2nano
REAL(SRK),PUBLIC,PARAMETER ::  centi2pico=centi2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::  milli2tera=milli2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::  milli2giga=milli2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::  milli2mega=milli2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::  milli2kilo=milli2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER :: milli2centi=milli2base*base2centi
REAL(SRK),PUBLIC,PARAMETER :: milli2micro=milli2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::  milli2nano=milli2base*base2nano
REAL(SRK),PUBLIC,PARAMETER ::  milli2pico=milli2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::  micro2tera=micro2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::  micro2giga=micro2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::  micro2mega=micro2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::  micro2kilo=micro2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER :: micro2centi=micro2base*base2centi
REAL(SRK),PUBLIC,PARAMETER :: micro2milli=micro2base*base2milli
REAL(SRK),PUBLIC,PARAMETER ::  micro2nano=micro2base*base2nano
REAL(SRK),PUBLIC,PARAMETER ::  micro2pico=micro2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::   nano2tera=nano2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::   nano2giga=nano2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::   nano2mega=nano2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::   nano2kilo=nano2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER ::  nano2centi=nano2base*base2centi
REAL(SRK),PUBLIC,PARAMETER ::  nano2milli=nano2base*base2milli
REAL(SRK),PUBLIC,PARAMETER ::  nano2micro=nano2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::   nano2pico=nano2base*base2pico
REAL(SRK),PUBLIC,PARAMETER ::   pico2tera=pico2base*base2tera
REAL(SRK),PUBLIC,PARAMETER ::   pico2giga=pico2base*base2giga
REAL(SRK),PUBLIC,PARAMETER ::   pico2mega=pico2base*base2mega
REAL(SRK),PUBLIC,PARAMETER ::   pico2kilo=pico2base*base2kilo
REAL(SRK),PUBLIC,PARAMETER ::  pico2centi=pico2base*base2centi
REAL(SRK),PUBLIC,PARAMETER ::  pico2milli=pico2base*base2milli
REAL(SRK),PUBLIC,PARAMETER ::  pico2micro=pico2base*base2micro
REAL(SRK),PUBLIC,PARAMETER ::   pico2nano=pico2base*base2nano

!Pressure Conversions
!> Conversion factor from MPa to psia
REAL(SRK),PUBLIC,PARAMETER :: MPa2PSIA=145.0_SRK+377.0_SRK/9990.0_SRK
!> Conversion factor from psia to MPa
REAL(SRK),PUBLIC,PARAMETER :: PSIA2MPa=ONE/MPa2PSIA
!> Conversion factor from bar to MPa
REAL(SRK),PUBLIC,PARAMETER :: Bar2MPa=0.1_SRK
!> Conversion factor from MPa to bar
REAL(SRK),PUBLIC,PARAMETER :: MPa2Bar=ONE/Bar2MPa
!> Conversion factor from MPa to Pa
REAL(SRK),PUBLIC,PARAMETER :: MPa2Pa=mega2base
!> Conversion factor from Pa to MPa
REAL(SRK),PUBLIC,PARAMETER :: Pa2MPa=base2mega

!Mass conversions
!> Conversion factor from kg to g
REAL(SRK),PUBLIC,PARAMETER :: kg2g=kilo2base
!> Conversion factor from g to kg
REAL(SRK),PUBLIC,PARAMETER :: g2kg=base2kilo
!> Conversion factor from g to mg
REAL(SRK),PUBLIC,PARAMETER :: g2mg=base2milli
!> Conversion factor from mg to g
REAL(SRK),PUBLIC,PARAMETER :: mg2g=milli2base
!> Conversion factor from kg to lbm
REAL(SRK),PUBLIC,PARAMETER :: kg2lb=2.2046226218488_SRK
!> Conversion factor from lbm to kg
REAL(SRK),PUBLIC,PARAMETER :: lb2kg=ONE/kg2lb

!Energy conversions
!> Conversion factor from eV to J
REAL(SRK),PUBLIC,PARAMETER :: eV2J=1.602176487e-19_SRK
!> Conversion factor from J to eV
REAL(SRK),PUBLIC,PARAMETER :: J2eV=ONE/eV2J
!> Conversion factor from BTU to kJ
REAL(SRK),PUBLIC,PARAMETER :: BTU2kJ=1.05505585262_SRK
!> Conversion factor from kJ to BTU
REAL(SRK),PUBLIC,PARAMETER :: kJ2BTU=ONE/BTU2kJ

!Time conversions
!> Conversion factor from min to s
REAL(SRK),PUBLIC,PARAMETER :: min2s=60.0_SRK
!> Conversion factor from hr to min
REAL(SRK),PUBLIC,PARAMETER :: hr2min=60.0_SRK
!> Conversion factor from day to hr
REAL(SRK),PUBLIC,PARAMETER :: day2hr=24.0_SRK
!> Conversion factor from year to day
REAL(SRK),PUBLIC,PARAMETER :: yr2day=365.25_SRK
!> Conversion factor from hr to sec
REAL(SRK),PUBLIC,PARAMETER :: hr2s=hr2min*min2s
!> Conversion factor from day to sec
REAL(SRK),PUBLIC,PARAMETER :: day2s=day2hr*hr2s
!> Conversion factor from year to sec
REAL(SRK),PUBLIC,PARAMETER :: yr2s=yr2day*day2s
!> Conversion factor from day to min
REAL(SRK),PUBLIC,PARAMETER :: day2min=day2hr*hr2min
!> Conversion factor from year to min
REAL(SRK),PUBLIC,PARAMETER :: yr2min=yr2day*day2min
!> Conversion factor from year to hr
REAL(SRK),PUBLIC,PARAMETER :: yr2hr=yr2day*day2hr
!> Conversion factor from s to min
REAL(SRK),PUBLIC,PARAMETER :: s2min=ONE/min2s
!> Conversion factor from min to hr
REAL(SRK),PUBLIC,PARAMETER :: min2hr=ONE/hr2min
!> Conversion factor from hr to day
REAL(SRK),PUBLIC,PARAMETER :: hr2day=ONE/day2hr
!> Conversion factor from day to year
REAL(SRK),PUBLIC,PARAMETER :: day2yr=ONE/yr2day
!> Conversion factor from s to hr
REAL(SRK),PUBLIC,PARAMETER :: s2hr=ONE/hr2s
!> Conversion factor from s to day
REAL(SRK),PUBLIC,PARAMETER :: s2day=ONE/day2s
!> Conversion factor from s to year
REAL(SRK),PUBLIC,PARAMETER :: s2yr=ONE/yr2s
!> Conversion factor from min to day
REAL(SRK),PUBLIC,PARAMETER :: min2day=ONE/day2min
!> Conversion factor from min to year
REAL(SRK),PUBLIC,PARAMETER :: min2yr=ONE/yr2min
!> Conversion factor from hr to year
REAL(SRK),PUBLIC,PARAMETER :: hr2yr=ONE/yr2hr

!Length conversions
!> Conversion factor from m to cm
REAL(SRK),PUBLIC,PARAMETER :: m2cm=base2centi
!> Conversion factor from cm to m
REAL(SRK),PUBLIC,PARAMETER :: cm2m=centi2base
!> Conversion factor from ft to cm
REAL(SRK),PUBLIC,PARAMETER :: ft2cm=30.48_SRK
!> Conversion factor from cm to ft
REAL(SRK),PUBLIC,PARAMETER :: cm2ft=ONE/ft2cm
!> Conversion factor from in to cm
REAL(SRK),PUBLIC,PARAMETER :: in2cm=2.54_SRK
!> Conversion factor from cm to in
REAL(SRK),PUBLIC,PARAMETER :: cm2in=ONE/in2cm

!Temperature conversions
!> Additive Conversion factor from Celsius to Kelvin
REAL(SRK),PUBLIC,PARAMETER :: C2K=273.15_SRK
!> Multiplicative Conversion factor from Rankine to Kelvin
REAL(SRK),PUBLIC,PARAMETER :: R2K=5.0_SRK/9.0_SRK
!> Additive Conversion factor from Fahrenheit to Rankine
REAL(SRK),PUBLIC,PARAMETER :: F2R=459.67_SRK

!> May be used for comparing real numbers relating to geometry
!> Tolerance is 0.0001 cm
REAL(SRK),PUBLIC,PARAMETER :: TOL_GEOM_cm=0.0001_SRK
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Kelvin to Celsius
!> @param in_temp the temperature input as Kelvin
!> @return out_temp the temperature converted to Celsius
!>
ELEMENTAL FUNCTION K_to_C(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=in_temp-273.15_SRK

ENDFUNCTION K_to_C
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Celsius to Kelvin
!> @param in_temp the temperature input as Celsius
!> @return out_temp the temperature converted to Kelvin
!>
ELEMENTAL FUNCTION C_to_K(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=in_temp+273.15_SRK

ENDFUNCTION C_to_K
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Fahrenheit to Celsius
!> @param in_temp the temperature input as Fahrenheit
!> @return out_temp the temperature converted to Celsius
!>
ELEMENTAL FUNCTION F_to_C(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=(in_temp-32.0_SRK)*5.0_SRK/9.0_SRK

ENDFUNCTION F_to_C
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Celsius to Fahrenheit
!> @param in_temp the temperature input as Celsius
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION C_to_F(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=in_temp*9.0_SRK/5.0_SRK+32.0_SRK

ENDFUNCTION C_to_F
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Fahrenheit to Kelvin
!> @param in_temp the temperature input as Fahrenheit
!> @return out_temp the temperature converted to Kelvin
!>
ELEMENTAL FUNCTION F_to_K(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=C_to_K(F_to_C(in_temp))

ENDFUNCTION F_to_K
!
!-------------------------------------------------------------------------------
!> @brief converts temperature from Kelvin to Fahrenheit
!> @param in_temp the temperature input as Kelvin
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION K_to_F(in_temp) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  REAL(SRK) :: out_temp

  out_temp=C_to_F(K_to_C(in_temp))

ENDFUNCTION K_to_F
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Kelvin from Celsius, Rankine, or Fahrenheit,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Kelvin
!>
ELEMENTAL FUNCTION tempTo_K(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('C')
    out_temp = C_to_K(in_temp)
  CASE('R')
    out_temp = in_temp * R2K
  CASE('F')
    out_temp = F_to_K(in_temp)
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_K
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Celsius from Kelvin, Rankine, or Fahrenheit,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Celsius
!>
ELEMENTAL FUNCTION tempTo_C(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('K')
    out_temp = K_to_C(in_temp)
  CASE('R')
    out_temp = in_temp * R2K - C2K
  CASE('F')
    out_temp = F_to_C(in_temp)
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_C
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Fahrenheit from Celsius, Rankine, or Kelvin,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION tempTo_F(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('K')
    out_temp=K_to_F(in_temp)
  CASE('R')
    out_temp = in_temp - F2R
  CASE('C')
    out_temp = C_to_F(in_temp)
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_F
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to Rankine from Celsius, Kelvin, or Fahrenheit,
!> if any other unit is presented in_temp is simply returned
!> @param in_temp the temperature input as the specified units
!> @param units character indicating the units of in_temp
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION tempTo_R(in_temp,units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: units
  REAL(SRK) :: out_temp

  SELECTCASE(units)
  CASE('K')
    out_temp = in_temp / R2K
  CASE('F')
    out_temp = in_temp + F2R
  CASE('C')
    out_temp = C_to_K(in_temp) / R2K
  CASE DEFAULT
    out_temp = in_temp
  ENDSELECT

ENDFUNCTION tempTo_R
!
!-------------------------------------------------------------------------------
!> @brief converts temperature to a given unit from the provided unit. Celsius(C),
!> Fahrenheit(F), Kelvin(K), and Rankine(R) are the only valid units
!> @param in_temp the temperature input as the specified units
!> @param in_units character indicating the units of in_temp
!> @param out_units character indicating the units of out_temp
!> @return out_temp the temperature converted to Fahrenheit
!>
ELEMENTAL FUNCTION convertTemp(in_temp,in_units,out_units) RESULT(out_temp)
  REAL(SRK),INTENT(IN) :: in_temp
  CHARACTER(LEN=1),INTENT(IN) :: in_units
  CHARACTER(LEN=1),INTENT(IN) :: out_units
  REAL(SRK) :: out_temp

  SELECTCASE(out_units)
  CASE('K')
    out_temp = tempTo_K(in_temp,in_units)
  CASE('C')
    out_temp = tempTo_C(in_temp,in_units)
  CASE('F')
    out_temp = tempTo_F(in_temp,in_units)
  CASE('R')
    out_temp = tempTo_R(in_temp,in_units)
  ENDSELECT

ENDFUNCTION convertTemp
!
ENDMODULE Constants_Conversion


c     program DRDRANU
c>> 1996-05-28 DRDRANU Krogh Added external statement.
c>> 1994-10-19 DRDRANU  Krogh  Changes to use M77CON
c>> 1992-03-13 DRDRANU  CLL
c>> 1987-12-09 DRDRANU  Lawson  Initial Code.
c
c     Driver to demonstrate use of DRANU to generate random numbers
c     from the uniform distribution on [0.0, 1.0].
c     Program computes histogram for N numbers
c     ------------------------------------------------------------------
c--D replaces "?": DR?RANU, ?RANU, ?STAT1, ?STAT2
c     ------------------------------------------------------------------
      integer N, NCELLS
      parameter(N = 10000, NCELLS = 10+2)
      external DRANU
      double precision DRANU, STATS(5), YTAB(1), Y1, Y2
      integer I, IHIST(NCELLS)
      data Y1, Y2 / 0.0D0, 1.0D0 /
c     ------------------------------------------------------------------
      STATS(1) = 0.0D0
      do 20 I = 1, N
c                          Get random number
         YTAB(1) = DRANU( )
c                          Accumulate statistics and histogram.
c
        call DSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
  20  continue
c                          Print the statistics and histogram.
c
      write(*,'(13x,a//)') 'Uniform random numbers from DRANU'
      call DSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


program test

        implicit none
        integer     ::   a(10000,10000),b(10000,10000),c(10000,10000)
        real        :: start, endtime
        integer     :: i,j
        a=1
        b=1
        do i=1,10000
           do j=1,10000
           a(i,j)=i+j
           b(i,j)=2*i+j
           enddo
        enddo
        call cpu_time(start)
        do i=1,100
           c=a*b
        enddo
        call cpu_time(endtime)
        print *,'c=a*b used',endtime-start,' s'

        call cpu_time(start)
        do i=1,100
           do j=1,10000
           c(:,j)=b(:,j)*a(:,j)
           enddo
        enddo
        call cpu_time(endtime)
        print *,'c(:,i)=a(:,i)*b(:,i)',endtime-start,' s'

        call cpu_time(start)
        do i=1,100
           do j=1,10000
           c(j,:)=b(j,:)*a(j,:)
           enddo
        enddo
        call cpu_time(endtime)
        print *,'c(i,:)=a(i,:)*b(i,:)',endtime-start,' s'

end program test


    ! ------------------------------------------------------------------
    !                       FastSelect method
    !
    ! Given VALUES list of numbers, rearrange the elements of VALUES
    ! such that the element at index K has rank K (holds its same
    ! location as if all of VALUES were sorted). Symmetrically rearrange
    ! array INDICES to keep track of prior indices.
    !
    ! This algorithm uses the same conceptual approach as Floyd-Rivest,
    ! but instead of standard-deviation based selection of bounds for
    ! recursion, a rank-based method is used to pick the subset of
    ! values that is searched. This simplifies the code and improves
    ! interpretability, while achieving the same tunable performance.
    !
    ! Arguments:
    !
    !   VALUES   --  A 1D array of real numbers.
    !   INDICES  --  A 1D array of original indices for elements of VALUES.
    !   K        --  A positive integer for the rank index about which
    !                VALUES should be rearranged.
    ! Optional:
    !
    !   DIVISOR  --  A positive integer >= 2 that represents the
    !                division factor used for large VALUES arrays.
    !   MAX_SIZE --  An integer >= DIVISOR that represents the largest
    !                sized VALUES for which the worst-case pivot value
    !                selection is tolerable. A worst-case pivot causes
    !                O( SIZE(VALUES)^2 ) runtime. This value should be
    !                determined heuristically based on compute hardware.
    !
    ! Output:
    !
    !   The elements of the array VALUES are rearranged such that the
    !   element at position VALUES(K) is in the same location it would
    !   be if all of VALUES were in sorted order. Also known as,
    !   VALUES(K) has rank K.
    !
    RECURSIVE SUBROUTINE ARGSELECT(VALUES, K, INDICES, DIVISOR, MAX_SIZE, RECURSING)
      USE ISO_FORTRAN_ENV, ONLY: RT => REAL32
      ! Arguments
      REAL(KIND=RT), INTENT(IN), DIMENSION(:) :: VALUES
      INTEGER, INTENT(IN) :: K
      INTEGER, INTENT(OUT), DIMENSION(SIZE(VALUES)) :: INDICES
      INTEGER, INTENT(IN), OPTIONAL :: DIVISOR, MAX_SIZE
      LOGICAL, INTENT(IN), OPTIONAL :: RECURSING
      ! Locals
      INTEGER :: LEFT, RIGHT, L, R, MS, D
      REAL(KIND=RT) :: P
      ! Initialize the divisor (for making subsets).
      IF (PRESENT(DIVISOR)) THEN ; D = DIVISOR
      ELSE IF (SIZE(INDICES) .GE. 8388608) THEN ; D = 32 ! 2**5 ! 2**23
      ELSE IF (SIZE(INDICES) .GE. 1048576) THEN ; D = 8  ! 2**3 ! 2**20
      ELSE                                      ; D = 4  ! 2**2
      END IF
      ! Initialize the max size (before subsets are created).
      IF (PRESENT(MAX_SIZE)) THEN ; MS = MAX_SIZE
      ELSE                        ; MS = 1024 ! 2**10
      END IF
      ! When not recursing, set the INDICES to default values.
      IF (.NOT. PRESENT(RECURSING)) THEN
         FORALL(D=1:SIZE(VALUES)) INDICES(D) = D
      END IF
      ! Initialize LEFT and RIGHT to be the entire array.
      LEFT = 1
      RIGHT = SIZE(INDICES)
      ! Loop until done finding the K-th element.
      DO WHILE (LEFT .LT. RIGHT)
         ! Use SELECT recursively to improve the quality of the
         ! selected pivot value for large arrays.
         IF (RIGHT - LEFT .GT. MS) THEN
            ! Compute how many elements should be left and right of K
            ! to maintain the same percentile in a subset.
            L = K - K / D
            R = L + (SIZE(INDICES) / D)
            ! Perform fast select on an array a fraction of the size about K.
            CALL ARGSELECT(VALUES(:), K - L + 1, INDICES(L:R), DIVISOR, MAX_SIZE, RECURSING=.TRUE.)
         END IF
         ! Pick a partition element at position K.
         P = VALUES(INDICES(K))
         L = LEFT
         R = RIGHT
         ! Move the partition element to the front of the list.
         CALL SWAP_INT(INDICES(LEFT), INDICES(K))
         ! Pre-swap the left and right elements (temporarily putting a
         ! larger element on the left) before starting the partition loop.
         IF (VALUES(INDICES(RIGHT)) .GT. P) THEN
            CALL SWAP_INT(INDICES(LEFT), INDICES(RIGHT))
         END IF
         ! Now partition the elements about the pivot value "P".
         DO WHILE (L .LT. R)
            CALL SWAP_INT(INDICES(L), INDICES(R))
            L = L + 1
            R = R - 1
            DO WHILE (VALUES(INDICES(L)) .LT. P) ; L = L + 1 ; END DO
            DO WHILE (VALUES(INDICES(R)) .GT. P) ; R = R - 1 ; END DO
         END DO
         ! Place the pivot element back into its appropriate place.
         IF (VALUES(INDICES(LEFT)) .EQ. P) THEN
            CALL SWAP_INT(INDICES(LEFT), INDICES(R))
         ELSE
            R = R + 1
            CALL SWAP_INT(INDICES(R), INDICES(RIGHT))
         END IF
         ! adjust left and right towards the boundaries of the subset
         ! containing the (k - left + 1)th smallest element
         IF (R .LE. K) LEFT = R + 1
         IF (K .LE. R) RIGHT = R - 1
      END DO

    CONTAINS

      SUBROUTINE SWAP_INT(V1, V2)
        INTEGER, INTENT(INOUT) :: V1, V2
        INTEGER :: TEMP
        TEMP = V1
        V1 = V2
        V2 = TEMP
      END SUBROUTINE SWAP_INT

    END SUBROUTINE ARGSELECT


MODULE MergeVectorsMod

  ! Merge two vectors x, y into z (duplicates are removed)
  ! x and y are assumed to be monotonically increasing

  IMPLICIT NONE

  INTEGER :: ix, iy, iz

  INTERFACE MergeVectors
     MODULE PROCEDURE MergeVectors_sngl
  END INTERFACE MergeVectors

CONTAINS
  SUBROUTINE MergeVectors_sngl( x, Nx, y, Ny, z, Nz )
    INTEGER, INTENT( IN  ) :: Nx, Ny
    INTEGER, INTENT( OUT ) :: Nz
    REAL,    INTENT( IN  ) :: x( Nx ), y( Ny )
    REAL,    INTENT( OUT ) :: z( * )

    ix = 1
    iy = 1
    iz = 1

    ! Loop to successively take values from vector x or y

    DO WHILE ( ix <= Nx .OR. iy <= Ny )

       IF      ( iy > Ny ) THEN             ! No more in vector y, take from x
          z( iz ) = x( ix )
          ix      = ix + 1
          iz      = iz + 1
       ELSE IF ( ix > Nx ) THEN             ! No more in vector x, take from y
          z( iz ) = y( iy )
          iy      = iy + 1
          iz      = iz + 1
       ELSE IF ( x( ix ) <= y( iy ) ) THEN  ! Vector x has the next largest
          z( iz ) = x( ix )
          ix      = ix + 1
          iz      = iz + 1
       ELSE                                 ! Vector y has the next largest
          z( iz ) = y( iy )
          iz      = iz + 1
          iy      = iy + 1
       END IF

       ! Check that we didn't just add a duplicate
       IF ( iz > 2 ) THEN
          ! following is a test for approximately equal values; not a very good test
          IF ( ABS( z( iz - 1 ) - z( iz - 2 ) ) < 100. * EPSILON( z ) ) THEN
             iz = iz - 1
          END IF
       END IF
    END DO

    Nz = iz - 1

  END SUBROUTINE MergeVectors_sngl

END MODULE MergeVectorsMod


#:include 'fytest.fypp'

#:block TEST_SUITE('full')
  use mymath
  implicit none

  integer :: special_value = 5
  integer, parameter :: paramarray(3) = [9, -4, 3]

#:contains

  #:block TEST_SUITE_INIT
    special_value = 1
  #:endblock TEST_SUITE_INIT

  #:block TEST('5')
    @:ASSERT(factorial(5) == 120)
  #:endblock TEST

  #:block TEST('1')
    @:ASSERT(factorial(1) == 0)
  #:endblock TEST

  #:block TEST_FIXTURE('special_cases',&
      & ITERATORS=[('param1', 'paramarray'), ('param2', 'paramarray')])

    integer :: param1, param2
    integer :: special_result

  #:contains

    subroutine initializer_helper()
      special_result = 1
    end subroutine initializer_helper

    #:block TEST_FIXTURE_INIT
      call initializer_helper()
    #:endblock TEST_FIXTURE_INIT

    #:block TEST_FIXTURE_FINAL
      call finalizer_helper()
    #:endblock TEST_FIXTURE_FINAL

    subroutine finalizer_helper()
      continue
    end subroutine finalizer_helper

    #:block TEST('factorial_special_1')
      @:ASSERT(factorial(special_value) == special_result)
    #:endblock TEST

    #:block TEST('factorial_special_0')
      @:ASSERT(factorial(0) == special_result)
    #:endblock TEST

  #:endblock TEST_FIXTURE

  #:block TEST('6')
    @:ASSERT(factorial(6) == 720)
  #:endblock TEST

#:endblock TEST_SUITE

#:block TEST_DRIVER()
#:endblock TEST_DRIVER