C*********************************************************************C
C*                                                                   *C
C*  chapman.for                                                      *C
C*                                                                   *C
C*  Written by:  David L. Huestis, Molecular Physics Laboratory      *C
C*                                                                   *C
C*  Copyright (c) 2000  SRI International                            *C
C*  All Rights Reserved                                              *C
C*                                                                   *C
C*  This software is provided on an as is basis; without any         *C
C*  warranty; without the implied warranty of merchantability or     *C
C*  fitness for a particular purpose.                                *C
C*                                                                   *C
C*********************************************************************C
C*
C*	To calculate the Chapman Function, Ch(X,chi0), the column
C*	depth of an exponential atmosphere integrated along a line
C*	from a given point to the sun, divided by the column depth for
C*	a vertical sun.
C*
C*  USAGE:
C*
C*	  z = altitude above the surface
C*	  R = radius of the planet
C*	  H = atmospheric scale height
C*
C*	  X = (R+z)/H
C*	  chi0 = solar zenith angle (in degrees)
C*
C*	  implicit real*4(a-h,o-z)
C*	  depth = atm_chapman(X,chi0)	! analytical
C*	  depth = atm_chap_num(X,chi0)	! numerical (chi0 .le. 90)
C*
C*	  implicit real*8(a-h,o-z)
C*	  depth = atm8_chapman(X,chi0)	! analytical
C*	  depth = atm8_chap_num(X,chi0)	! numerical (chi0 .le. 90)
C*
C*  PERFORMANCE:
C*
C*	Compiled and linked using Microsoft FORTRAN 5.1, and executed
C*	in MS-DOS mode under Windows 95 on a 160 MHz PC.
C*
C*    TIMING (in microseconds, typical)
C*
C*	  120	atm_chapman and atm8_chapman for X .lt. 36
C*	   25	atm_chapman and atm8_chapman for X .ge. 36
C*	  500	atm_chap_num
C*	 5000	atm8_chap_num
C*
C*    ACCURACY (maximum relative error, 0.le.chi0.le.90, 1.le.X.le.820)
C*
C*	6.0E-7	atm_chapman and atm8_chapman for X .lt. 60
C*	1.5E-7	atm_chapman and atm8_chapman for X .ge. 60
C*	6.0E-8	atm_chap_num
C*	1.E-15	atm8_chap_num (convergence test)
C*
C*    CODING
C*
C*	No claims are made that the code is optimized for speed,
C*	accuracy, or compactness.  The principal objectives were
C*
C*	  (1) Robustness with respect to argument values
C*	  (2) Rigorous mathematical derivation and error control
C*	  (3) Maximal use of "well known" mathematical functions
C*	  (4) Ease of readability and mapping of theory to coding
C*
C*	The real*8 accuracy could be improved with more accurate
C*	representations of E1(), erfc(), I0(), I1(), K0(), K1().
C*
C*	In the course of development, many representations and
C*	approximations of the Chapman Function were attempted that
C*	failed to be robustly extendable to machine-precision.
C*
C*  INTERNET ACCESS:
C*
C*	Source: http://www-mpl.sri.com/software/chapman/chapman.html
C*	Author: mailto:david.huestis@sri.com
C*	        http://www-mpl.sri.com/bios/Huestis-DL.html
C*
C*  EDIT HISTORY:
C*
C*	01/22/2000 DLH	First complete documentation
C*
C*	01/15/2000 DLH	First complete version of chapman.for
C*
C**********************************************************************
C*
C*  THEORY:
C*
C*    INTRODUCTION
C*
C*	    This computer code models the absorption of solar radiation
C*	by an atmosphere that depends exponentionally on altitude.  In
C*	specific we calculate the effective column depth of a species
C*	of local density, n(z), from a point at a given altitude, z0,
C*	to the sun at a given solar zenith angle, chi0.  Following Rees
C*	[Re89, Section 2.2] we write the column depth for chi0 .le. 90
C*	degrees as
C*
C*   (A)  N(z0,chi0) = int{z=z0,infinity}
C*	     [ n(z)/sqrt( 1 - ( sin(chi0) * (R+z0) / (R+z) ) **2 ) dz ]
C*
C*	where R is the radius of the solid planet (e.g. Earth).  For
C*	chi0 .gt. 90 degrees we write
C*
C*	  N(z0,chi0) = 2*N(zs,90) - N(z0,180-chi0)
C*
C*	where zs = (R+z0)*sin(chi0)-R is the tangent height.
C*
C*	    For an exponential atmosphere, with
C*
C*	  n(z) = n(z0) * exp(-(z-z0)/H)
C*
C*	with a constant scale height, H, the column depth can be
C*	represented by the Chapman function, Ch(X,chi0), named after
C*	the author of the first quantitative mathematical investigation
C*	[Ch31b] trough the relation
C*
C*	  N(z0,chi0) = H * n(z0) * Ch(X,chi0)
C*
C*	where X = (R+z0)/H is a dimensionless measure of the radius
C*	of curvature, with values from about 300 to 1300 on Earth.
C*
C*
C*    APPROACH
C*
C*	    We provide function entry points for very stable and
C*	reasonably efficient evaluation of Ch(X,chi0) with full
C*	single-precision accuracy (.le. 6.0E-7 relative) for a wide
C*	range of parameters.  A 15-digit-accurate double precision
C*	numerical integration routine is also provided.
C*
C*	    Below we will develop (1) a compact asymptotic expansion of
C*	good accuracy for moderately large values of X (.gt. 36) and all
C*	values of chi0, (2) an efficient numerical integral for
C*	all values of X and chi0, and (3) an explicit analytical
C*	representation, valid for all values of X and chi0, based
C*	the differential equation satisfied by Ch(X,chi0).
C*
C*	    All three of these represent new research results as well
C*	as significant computational improvements over the previous
C*	literature, much of which is cited below.
C*
C*
C*    CHANGES OF THE VARIABLE OF INTEGRATION
C*
C*	Substituting y = (R+z)/(R+z0) - 1 we find
C*
C*   (B)  Ch(X,chi0) = X * int{y=0,infinity}
C*	     [ exp(-X*y) / sqrt( 1 - ( sin(chi0) / (1+y) )**2 ) dy ]
C*
C*	The futher substitutions s = (1+y)/sin(chi0), s0 = 1/sin(chi0)
C*	give
C*
C*   (C)  Ch(X,chi0) = X*sin(chi0) * int{s=s0,infinity}
C*	     [ exp(X*(1-sin(chi0)*s)) * s / sqrt(s**2-1) ds ]
C*
C*	From this equation we can establish that
C*
C*	  Ch(X,90) = X*exp(X)*K1(X)
C*
C*	[AS64, Equations 9.6.23 and 9.6.27].  If we now substitute
C*	s = 1/sin(lambda) we obtain
C*
C*   (D)  Ch(X,chi0) = X*sin(chi0) * int{lambda=0,chi0}
C*	    [ exp(X*(1-sin(chi0)*csc(lambda))) * csc(lambda)**2 dlambda]
C*
C*	which is the same as Chapman's original formulation [Ch31b, p486,
C*	eqn (10)].  If we first expand the square root in (B)
C*
C*	  1/sqrt(1-q) = 1 + q/( sqrt(1-q)*(1+sqrt(1-q)) )
C*
C*	with q = ( sin(chi0) / (1+y) )**2 = sin(lambda)**2, we obtain
C*	a new form of (D) without numerical sigularities and simple
C*	convergence to Ch(0,chi0) = Ch(X,0) = 1
C*
C*   (E)  Ch(X,chi0) = 1 + X*sin(chi0) * int{lambda=0,chi0}
C*	    [ exp(X*(1-sin(chi0)*csc(lambda)))
C*		/ (1 + cos(lambda) ) dlambda ]
C*
C*	Alternatively, we may substitute t**2 = y + t0**2,
C*	into Equation (B), with t0**2 = 1-sin(chi0), finding
C*
C*   (F)  Ch(X,chi0) = X * int{s=t0,infinity}
C*	    [ exp(-X*(t**2-t0**2)) * f(t,chi0) dt ]
C*
C*	where
C*
C*	  f(t,chi0) = (t**2 + sin(chi0)) / sqrt(t**2+2*sin(chi0))
C*
C*	  f(t,chi0) = (t**2-t0**2+1)/sqrt(t**2-t0**2+1+sin(chi0))
C*
C*	    Below we will use Equation (F) above to develop a
C*	compact asymptotic expansion of good accuracy for moderately
C*	large values of X (.gt. 36) and all values of chi0, Equation (E)
C*	to develop an efficient numerical integral for Ch(X,chi0) for
C*	all values of X and chi0, and Equation (C) to derive an explicit
C*	analytical representation, valid for all values of X and chi0,
C*	based on the differential equation satisfied by Ch(X,chi0).
C*
C*    atm_chapman(X,chi0) and atm8_chapman(X,chi0)
C*
C*	These routines return real*4 and real*8 values of Ch(X,chi0)
C*	selecting the asymptotic expansion or differential equation
C*	approaches, depending on the value of X.  These routines also
C*	handle the case of chi0 .gt. 90 degrees.
C*
C*    atm_chap_num(X,chi0) and atm8_chap_num(X,chi0)
C*
C*	These routines return real*4 and real*8 values of Ch(X,chi0)
C*	evaluated numerically.  They are both more accurate than the
C*	corresponding atm*_chapman() functions, but take significantly
C*	more CPU time.
C*
C*
C*    ASYMPTOTIC EXPANSION
C*
C*	From Equation (F) we expand, with t0**2 = 1-sin(chi0),
C*
C*	  f(t,chi0) = sum{n=0,3} [ C(n,chi0) * (t**2-t0**2)**n ]
C*
C*	The function atm8_chap_asy(X,chi0) evaluates integrals of the
C*	form
C*
C*	  int{t=t0,infinity} [exp(-X*(t**2-t0**2))*(t**2-t0**2)**n dt]
C*
C*	in terms of incomplete gamma functions, and sums them to
C*	compute Ch(X,chi0).  For large values of X, this results in an
C*	asymptotic expansion in negative powers of X, with coefficients
C*	that are stable for all values of chi0.
C*
C*	In contrast, the asymptotic expansions of Chapman [Ch31b,
C*	p488, Equation (22) and p490, Equation (38)], Hulburt [He39],
C*	and Swider [Sw64, p777, Equation (43)] use negative powers of
C*	X*cos(chi0)**2 or X*sin(chi0), and are accurate only for
C*	small values or large values of chi0, respectively.
C*
C*	Taking only the first term in the present expansion gives the
C*	simple formula
C*
C*	  Ch(X,chi0) = sqrt(pi*X/(1+sin(chi0))) * exp(X*(1-sin(chi0)))
C*		* erfc( sqrt(X*(1-sin(chi0))) )
C*
C*	This is slightly more accurate than the semiempirical
C*	formula of Fitzmaurice [Fi64, Equation (3)], and sightly less
C*	accurate than that of Swider [Sw64, p780, Equation (52),
C*	corrected in SG69].
C*
C*
C*    NUMERICAL INTEGRATION
C*
C*	We are integrating
C*
C*   (E)  Ch(X,chi0) = 1 + X*sin(chi0) * int{lambda=0,chi0}
C*	    [ exp(X*(1-sin(chi0)*csc(lambda)))
C*		/ ( 1 + cos(lambda) ) dlambda ]
C*
C*	The integrand is numerically very smooth, and rapidly varying
C*	only near lambda = 0.  For X .ne. 0 we choose the lower limit
C*	of numerical integration such that the integrand is
C*	exponentially small, 7.0E-13 (3.0E-20 for real*8).  The domain
C*	of integration is divided into 64 equal intervals (6000 for
C*	real*8), and integrated numerically using the 9-point closed
C*	Newton-Cotes formula from Hildebrand [Hi56a, page 75, Equation
C*	(3.5.17)].
C*
C*
C*    INHOMOGENOUS DIFFERENTIAL EQUATION
C*
C*	    The function atm8_chap_deq(X,chi0) calculates Ch(X,chi0),
C*	based on Equation (C) above, using the inhomogeneous
C*	Bessel's equation as described below.  Consider the function
C*
C*	  Z(Q) = int{s=s0,infinity} [ exp(-Q*s) / sqrt(s**2-1) ds ]
C*
C*	Differentiating with respect to Q we find that
C*
C*	  Ch(X,chi0) = - Q * exp(X) * d/dQ [ Z(Q) ]
C*
C*	with Q = X*sin(chi0), s0 = 1/sin(chi0).  Differentiating
C*	inside the integral, we find that
C*
C*	  Z"(Q) + Z'(Q)/Q - Z(Q) = sqrt(s0**2-1) * exp(-Q*s0) / Q
C*
C*	giving us an inhomogeneous modified Bessel's equation of order
C*	zero.  Following Rabenstein [Ra66, pp43-45,149] the solution
C*	of this equation can be written as
C*
C*	  Z(Q) = A*I0(Q) + B*K0(Q) - sqrt(s0**2-1)
C*	         * int{t=Q,infinity} [ exp(-t*s0)
C*		   * ( I0(Q)*K0(t) - I0(t)*K0(Q) ) dt ]
C*
C*	with coefficients A and B to be determined by matching
C*	boundary conditions.
C*
C*	    Differentiating with respect to Q we obtain
C*
C*	  Ch(X,chi0) = X*sin(chi0)*exp(X)*(
C*		- A*I1(X*sin(chi0)) + B*K1(X*sin(chi0))
C*		+ cos(chi0) * int{y=X,infinity} [ exp(-y)
C*		  * ( I1(X*sin(chi0))*K0(y*sin(chi0))
C*		    + K1(X*sin(chi0))*I0(y*sin(chi0)) ) dy ] )
C*
C*	Applying the boundary condition Ch(X,0) = 1 requires that
C*	B = 0.  Similarly, the requirement that Ch(X,chi0) approach
C*	the finite value of sec(chi0) as X approaches infinity [Ch31b,
C*	p486, Equation (12)] implies A = 0.  Thus we have
C*
C*	  Ch(X,chi0) = X*sin(chi0)*cos(chi0)*exp(X)*
C*		int{y=X,infinity} [ exp(-y)
C*		  * ( I1(X*sin(chi0))*K0(y*sin(chi0))
C*		    + K1(X*sin(chi0))*I0(y*sin(chi0)) ) dy ]
C*
C*	The function atm8_chap_deq(X,chi0) evaluates this expression.
C*	Since explicit approximations are available for I1(z) and K1(z),
C*	the remaining challenge is evaluation of the integrals
C*
C*	  int{y=X,infinity} [ exp(-y) I0(y*sin(chi0)) dy ]
C*
C*	and
C*
C*	  int{y=X,infinity} [ exp(-y) K0(y*sin(chi0)) dy ]
C*
C*	which are accomplished by term-by-term integration of ascending
C*	and descending power series expansions of I0(z) and K0(z).
C*
C*  REFERENCES:
C*
C*	AS64	M. Abramowitz and I. A. Stegun, "Handbook of
C*		Mathematical Functions," NBS AMS 55 (USGPO,
C*		Washington, DC, June 1964, 9th printing, November 1970).
C*
C*	Ch31b	S. Chapman, "The Absorption and Dissociative or
C*		Ionizing Effect of Monochromatic Radiation in an
C*		Atmosphere on a Rotating Earth: Part II. Grazing
C*		Incidence," Proc. Phys. Soc. (London), _43_, 483-501
C*		(1931).
C*
C*	Fi64	J. A. Fitzmaurice, "Simplfication of the Chapman
C*		Function for Atmospheric Attenuation," Appl. Opt. _3_,
C*		640 (1964).
C*
C*	Hi56a	F. B. Hildebrand, "Introduction to Numerical
C*		Analysis," (McGraw-Hill, New York, 1956).
C*
C*	Hu39	E. O. Hulburt, "The E Region of the Ionosphere,"
C*		Phys. Rev. _55_, 639-645 (1939).
C*
C*	PFT86	W. H. Press, B. P. Flannery, S. A. Teukolsky, and
C*		W. T. Vetterling, "Numerical Recipes," (Cambridge,
C*		1986).
C*
C*	Ra66	A. L. Rabenstein, "Introduction to Ordinary
C*		Differential Equations," (Academic, NY, 1966).
C*
C*	Re89	M. H. Rees, "Physics and Chemistry of the Upper
C*		Atmosphere," (Cambridge, 1989).
C*
C*	SG69	W. Swider, Jr., and M. E. Gardner, "On the Accuracy
C*		of Chapman Function Approximations," Appl. Opt. _8_,
C*		725 (1969).
C*
C*	Sw64	W. Swider, Jr., "The Determination of the Optical
C*		Depth at Large Solar Zenith Angles," Planet. Space
C*		Sci. _12_, 761-782 (1964).
C
C  ####################################################################
C
C	Chapman function calculated by various methods
C
C	  Ch(X,chi0) = atm_chapman(X,chi0)   : real*4 entry
C	  Ch(X,chi0) = atm8_chapman(X,chi0)  : real*8 entry
C
C	Internal service routines - user should not call, except for
C	testing.
C
C	  Ch(X,chi0) = atm8_chap_asy(X,chi0) : asymptotic expansion
C	  Ch(X,chi0) = atm8_chap_deq(X,chi0) : differential equation
C	  Ch(X,chi0) = atm_chap_num(X,chi0)  : real*4 numerical integral
C	  Ch(X,chi0) = atm8_chap_num(X,chi0) : real*8 numerical integral
C
C  ####################################################################

C  ====================================================================
C
C	These are the entries for the user to call.
C
C	chi0 can range from 0 to 180 in degrees.  For chi0 .gt. 90, the
C	product X*(1-sin(chi0)) must not be too large, otherwise we
C	will get an exponential overflow.
C
C	For chi0 .le. 90 degrees, X can range from 0 to thousands
C	without overflow.
C
C  ====================================================================

	real*4 function atm_chapman( X, chi0 )
	real*8 atm8_chapman
	atm_chapman = atm8_chapman( dble(X), dble(chi0) )
	return
	end

C  ====================================================================

	real*8 function atm8_chapman( X, chi0 )
	implicit real*8(a-h,o-z)
	parameter (rad=57.2957795130823208768d0)

	if( (X .le. 0) .or. (chi0 .le. 0) .or. (chi0 .ge. 180) ) then
	  atm8_chapman = 1
	  return
	end if

	if( chi0 .gt. 90 ) then
	  chi = 180 - chi0
	else
	  chi = chi0
	end if

	if( X .lt. 36 ) then
	  atm8_chapman = atm8_chap_deq(X,chi)
	else
	  atm8_chapman = atm8_chap_asy(X,chi)
	end if

	if( chi0 .gt. 90 ) then
	  atm8_chapman = 2*exp(X*2*sin((90-chi)/(2*rad))**2)
     *		* atm8_chap_xK1(X*sin(chi/rad)) - atm8_chapman
	end if

	return
	end

C  ====================================================================
C
C	This Chapman function routine calculates
C
C	  Ch(X,chi0) = atm8_chap_asy(X,chi0)
C		     = sum{n=0,3} [C(n) * int{t=t0,infinity}
C			[ exp(-X*(t**2-t0**2) * (t**2-t0**2)**n dy ] ]
C
C	with t0**2 = 1 - sin(chi0)
C
C  ====================================================================

	real*8 function atm8_chap_asy( X, chi0 )
	implicit real*8(a-h,o-z)
	parameter (rad=57.2957795130823208768d0)
	dimension C(0:3), XI(0:3), Dn(0:3)
	common/atm8_chap_cm/Fn(0:3)

	if( (X .le. 0) .or. (chi0 .le. 0) ) then
	  do i=0,3
	    Fn(i) = 1
	  end do
	  go to 900
	end if

	sinchi = sin(chi0/rad)
	s1 = 1 + sinchi
	rx = sqrt(X)
	Y0 = rx * sqrt( 2*sin( (90-chi0)/(2*rad) )**2 )

	C(0) = 1/sqrt(s1)
	fact = C(0)/s1
	C(1) = fact * (0.5d0+sinchi)
	fact = fact/s1
	C(2) = - fact * (0.125d0+0.5d0*sinchi)
	fact = fact/s1
	C(3) = fact * (0.0625d0+0.375d0*sinchi)

	call atm8_chap_gd3( Y0, Dn )
	fact = 2*rx
	do n=0,3
	  XI(n) = fact * Dn(n)
	  fact = fact/X
	end do

	Fn(0) = C(0) * XI(0)
	do i=1,3
	  Fn(i) = Fn(i-1) + C(i)*XI(i)
	end do

900	atm8_chap_asy = Fn(3)
	return
	end

C  ====================================================================
C
C	This Chapman function routine calculates
C
C	  Ch(X,chi0) = atm8_chap_deq(X,chi0)
C		     = X * sin(chi0) * cos(chi0) * exp(X*sin(chi0))
C		       * int{y=X,infinity} [ exp(-y)*(
C			 I1(X*sin(chi0))*K0(y*sin(chi0))
C			 + K1(X*sin(chi0))*I0(y*sin(chi0)) ) dy ]
C
C  ====================================================================

	real*8 function atm8_chap_deq( X, chi0 )
	implicit real*8(a-h,o-z)
	parameter (rad=57.2957795130823208768d0)
	common/atm8_chap_cm/xI1,xK1,yI0,yK0

	if( (X .le. 0) .or. (chi0 .le. 0) ) go to 800
	alpha = X * sin(chi0/rad)

C  --------------------------------------------------------------------
C
C	This code fragment calculates
C
C	  yI0 = exp(x*(1-sin(chi0))) * cos(chi0) *
C		int{y=x,infinity} [ exp(-y) * I0(y*sin(chi0)) dy ]
C
C  --------------------------------------------------------------------

	yI0 = atm8_chap_yI0( X, chi0 )

C  --------------------------------------------------------------------
C
C	This code fragment calculates
C
C	  yK0 = exp(x*(1+sin(chi0))) x * sin(chi0) * cos(chi0) *
C		int{y=x,infinity} [ exp(-y) * K0(y*sin(chi0)) dy ]
C
C  --------------------------------------------------------------------

	yK0 = atm8_chap_yK0( X, chi0 )

C  --------------------------------------------------------------------
C
C	This code fragment calculates
C
C	  xI1 = exp(-x*sin(chi0)) * I1(x*sin(chi0))
C
C  --------------------------------------------------------------------

	xI1 = atm8_chap_xI1( alpha )

C  --------------------------------------------------------------------
C
C	This code fragment calculates
C
C	  xK1 = x*sin(chi0) * exp(x*sin(chi0)) * K1(x*sin(chi0))
C
C  --------------------------------------------------------------------

	xK1 = atm8_chap_xK1( alpha )

C  --------------------------------------------------------------------
C
C	Combine the terms
C
C  --------------------------------------------------------------------

	atm8_chap_deq = xI1*yK0 + xK1*yI0
	go to 900

800	atm8_chap_deq = 1
900	return
	end

C  ====================================================================
C
C	This Chapman function routine calculates
C
C	  Ch(X,chi0) = atm_chap_num(X,chi0) = numerical integral
C
C  ====================================================================

	real*4 function atm_chap_num(X,chi0)
	implicit real*8(a-h,o-z)
	real*4 X, chi0
	parameter (rad=57.2957795130823208768D0)
	parameter (n=65,nfact=8)
	dimension factor(0:nfact)
	data factor/14175.0D0, 23552.0D0, -3712.0D0, 41984.0D0,
     *	  -18160.0D0, 41984.0D0, -3712.0D0, 23552.0D0, 7912.0D0/

	if( (chi0 .le. 0) .or. (chi0 .gt. 90) .or. (X .le. 0) ) then
	  atm_chap_num = 1
	  return
	end if

	X8 = X
	chi0rad = chi0/rad
	sinchi = sin(chi0rad)

	alpha0 = asin( (X8/(X8+28)) * sinchi )
	delta = (chi0rad - alpha0)/(n-1)

	sum = 0

	do i=1,n
	  alpha = -(i-1)*delta + chi0rad

	  if( (i .eq. 1) .or. (X .le. 0) ) then
	    f = 1/(1+cos(alpha))
	  else if( alpha .le. 0 ) then
	    f = 0
	  else
	    f = exp(-X8*(sinchi/sin(alpha)-1) ) /(1+cos(alpha))
	  end if

	  if( (i.eq.1) .or. (i.eq.n) ) then
	    fact = factor(nfact)/2
	  else
	    fact = factor( mod(i-2,nfact)+1 )
	  end if

	  sum = sum + fact*f
	end do

	atm_chap_num = 1 + X8*sinchi*sum*delta/factor(0)
	return
	end

C  ====================================================================
C
C	This Chapman function routine calculates
C
C	  Ch(X,chi0) = atm8_chap_num(X,chi0) = numerical integral
C
C  ====================================================================

	real*8 function atm8_chap_num(X,chi0)
	implicit real*8(a-h,o-z)
	parameter (rad=57.2957795130823208768D0)
	parameter (n=601,nfact=8)
	dimension factor(0:nfact)
	data factor/14175.0D0, 23552.0D0, -3712.0D0, 41984.0D0,
     *	  -18160.0D0, 41984.0D0, -3712.0D0, 23552.0D0, 7912.0D0/

	if( (chi0 .le. 0) .or. (chi0 .gt. 90) .or. (X .le. 0) ) then
	  atm8_chap_num = 1
	  return
	end if

	chi0rad = chi0/rad
	sinchi = sin(chi0rad)

	alpha0 = asin( (X/(X+45)) * sinchi )
	delta = (chi0rad - alpha0)/(n-1)

	sum = 0

	do i=1,n
	  alpha = -(i-1)*delta + chi0rad

	  if( (i .eq. 1) .or. (X .le. 0) ) then
	    f = 1/(1+cos(alpha))
	  else if( alpha .le. 0 ) then
	    f = 0
	  else
	    f = exp(-X*(sinchi/sin(alpha)-1) ) /(1+cos(alpha))
	  end if

	  if( (i.eq.1) .or. (i.eq.n) ) then
	    fact = factor(nfact)/2
	  else
	    fact = factor( mod(i-2,nfact)+1 )
	  end if

	  sum = sum + fact*f
	end do

	atm8_chap_num = 1 + X*sinchi*sum*delta/factor(0)
	return
	end

C  ####################################################################
C
C	The following "Bessel integral" routines return various
C	combinations of integrals of Bessel functions, powers,
C	and exponentials, involving trigonometric functions of chi0.
C
C	For small values of z = X*sin(chi0) we expand
C
C	  I0(z) = sum{n=0,6} [ aI0(n) * z**(2*n) ]
C	  K0(z) = -log(z)*I0(z) + sum{n=0,6} [ aK0(n) * z**(2*n) ]
C
C	For large values of z we expand in reciprocal powers
C
C	  I0(z) = exp(z) * sum{n=0,8} [ bI0(n) * z**(-n-0.5) ]
C	  K0(z) = exp(-z) * sum{n=0,6} [ bK0(n) * z**(-n-0.5) ]
C
C	The expansion coefficients are calculated from those given
C	by Abramowitz and Stegun [AS64, pp378-9, Section 9.8] and
C	Press et al. [PFT86, pp177-8, BESSI0.FOR, BESSK0.FOR].
C
C	For small values of X*sin(chi0) we break the integral
C	into two parts (with F(z) = I0(z) or K0(z)):
C
C	  int{y=X,infinity} [ exp(-y) * F(y*sin(chi0)) dy ]
C
C	    = int{y=X,x1} [ exp(-y) * F(y*sin(chi0)) dy ]
C	      + int{y=x1,infinity} [ exp(-y) * F(y*sin(chi0)) dy ]
C
C	where x1 = 3.75/sin(chi0) for I0 and 2/sin(chi0) for K0.
C
C	In the range y=X,x1 we integrate the term-by-term using
C
C	  int{z=a,b} [ exp(-z) * z**(2*n) dz ]
C	    = Gamma(2*n+1,a) - Gamma(2*n+1,b)
C
C	and a similar but more complicated formula for
C
C	  int{z=a,b} [ log(z) * exp(-z) * z**(2*n) dz ]
C
C	In the range y=x1,infinity we use
C
C	  int{z=b,infinity} [ exp(-z) * z**(-n-0.5) dz]
C	    = Gamma(-n+0.5,b)
C
C  ####################################################################

C  ====================================================================
C
C	This Bessel integral routine calculates
C
C	  yI0 = exp(X*(1-sin(chi0))) * cos(chi0) *
C		int{y=X,infinity} [ exp(-y) * I0(y*sin(chi0)) dy ]
C
C  ====================================================================

	real*8 function atm8_chap_yI0( X, chi0 )
	implicit real*8(a-h,o-z)
	parameter (rad=57.2957795130823208768d0)
	dimension qbeta(0:8), gg(0:6)
	dimension aI0(0:6), bI0(0:8)

        data aI0/ 1.0000000D+00, 2.4999985D-01, 1.5625190D-02,
     *      4.3393973D-04, 6.8012343D-06, 6.5601736D-08,
     *      5.9239791D-10/
        data bI0/ 3.9894228D-01, 4.9822200D-02, 3.1685484D-02,
     *     -8.3090918D-02, 1.8119815D+00,-1.5259477D+01,
     *      7.3292025D+01,-1.7182223D+02, 1.5344533D+02/

	theta = (90-chi0)/(2*rad)
	sint = sin(theta)
	cost = cos(theta)
	sinchi = sin(chi0/rad)
	coschi = cos(chi0/rad)
	sc1m = 2*sint**2	! = (1-sinchi)

	alpha = X * sinchi

	if( alpha .le. 0 ) then
	  atm8_chap_yI0 = 1
	else if( alpha .lt. 3.75d0 ) then
	  x1 = 3.75d0/sinchi
	  call atm8_chap_gg06( X, x1, gg )
	  if( X .le. 1 ) then
	    rho = 1
	  else
	    rho = 1/X
	  end if
	  f = (sinchi/rho)**2
	  sum = aI0(6)*gg(6)
	  do i=5,0,-1
	    sum = sum*f + aI0(i)*gg(i)
C	    write(*,1900)i,sum,gg(i)
C1900	format(i5,1p5d14.6)
	  end do
	  call atm8_chap_gq85( x1*sc1m, qbeta )
	  sum2 = bI0(8) * qbeta(8)
	  do n=7,0,-1
	    sum2 = sum2/3.75d0 + bI0(n)*qbeta(n)
	  end do
	  atm8_chap_yI0 = exp(-alpha)*coschi*sum
     *		+ exp((X-x1)*sc1m)*sum2*cost*sqrt(2/sinchi)
	else
	  call atm8_chap_gq85( X*sc1m, qbeta )
	  sum = bI0(8) * qbeta(8)
	  do n=7,0,-1
	    sum = sum/alpha + bI0(n)*qbeta(n)
	  end do
	  atm8_chap_yI0 = sum * cost * sqrt( 2 / sinchi )
	end if
	return
	end

C  ====================================================================
C
C	This Bessel integral routine calculates
C
C	  yK0 = exp(x*(1+sin(chi0))) x * sin(chi0) * cos(chi0) *
C		int{y=x,infinity} [ exp(-y) * K0(y*sin(chi0)) dy ]
C
C  ====================================================================

	real*8 function atm8_chap_yK0( x, chi0 )
	implicit real*8(a-h,o-z)
	parameter (rad=57.2957795130823208768d0)
	dimension aI0(0:6), aK0(0:6), bK0(0:6)
	dimension gf(0:6), gg(0:6), qgamma(0:8)

        data aI0/ 1.0000000D+00, 2.4999985D-01, 1.5625190D-02,
     *      4.3393973D-04, 6.8012343D-06, 6.5601736D-08,
     *      5.9239791D-10/
        data aK0/ 1.1593152D-01, 2.7898274D-01, 2.5249154D-02,
     *      8.4587629D-04, 1.4975897D-05, 1.5045213D-07,
     *      2.2172596D-09/
        data bK0/ 1.2533141D+00,-1.5664716D-01, 8.7582720D-02,
     *     -8.4995680D-02, 9.4059520D-02,-8.0492800D-02,
     *      3.4053120D-02/

	theta = (90-chi0)/(2*rad)
	sint = sin(theta)
	cost = cos(theta)
	sinchi = sin(chi0/rad)
	sc1 = 1+sinchi
	coschi = sin(2*theta)

	alpha = X * sinchi
	gamma = X * sc1

	if( alpha .le. 0 ) then
	  atm8_chap_yK0 = 0
	else if( alpha .lt. 2 ) then
	  x1 = 2/sinchi
	  call atm8_chap_gfg06( X, x1, gf, gg )
	  if( x .le. 1 ) then
	    rho = 1
	  else
	    rho = 1/X
	  end if
	  sl = log(sinchi)
	  f = (sinchi/rho)**2
	  sum = -aI0(6)*gf(6) + (-sl*aI0(6)+aK0(6))*gg(6)
	  do i=5,0,-1
	    sum = sum*f - aI0(i)*gf(i) + (-sl*aI0(i)+aK0(i))*gg(i)
C	    write(*,1900)i,sum,gf(i),gg(i)
C1900	format(i5,1p5d14.6)
	  end do
	  call atm8_chap_gq85( x1*sc1, qgamma )
	  sum2 = bK0(6)*qgamma(6)
	  do i=5,0,-1
	    sum2 = sum2*0.5d0 + bK0(i)*qgamma(i)
C	    write(*,1900)i,sum2,bK0(i),qgamma(i)
	  end do
	  sum = sum + exp(X-x1-2)*sum2/sqrt(sinchi*sc1)
	  atm8_chap_yK0 = sum * exp(alpha) * alpha * coschi
	else
	  call atm8_chap_gq85( gamma, qgamma )
	  sum = bK0(6) * qgamma(6)
	  do i=5,0,-1
	    sum = sum/alpha + bK0(i)*qgamma(i)
	  end do
	  atm8_chap_yK0 = sum * sint * sqrt( 2 * sinchi ) * X
	end if

	return
	end

C  ####################################################################
C
C	The following "pure math" routines return various combinations
C	of Bessel functions, powers, and exponentials.
C
C  ####################################################################

C  ====================================================================
C
C	This Bessel function math routine returns
C
C	  xI1 = exp(-|z|) * I1(z)
C
C	Following Press et al [PFT86, page 178, BESSI1.FOR] and
C	Abrahamson and Stegun [AS64, page 378, 9.8.3, 9.8.4].
C
C  ====================================================================

	real*8 function atm8_chap_xI1( z )
	implicit real*8(a-h,o-z)
        dimension aI1(0:6), bI1(0:8)

        data aI1/ 5.00000000D-01, 6.2499978D-02, 2.6041897D-03,
     *      5.4244512D-05, 6.7986797D-07, 5.4830314D-09,
     *      4.1909957D-11/
        data bI1/ 3.98942280D-01,-1.4955090D-01,-5.0908781D-02,
     *      8.6379434D-02,-2.0399403D+00, 1.6929962D+01,
     *     -8.0516146D+01, 1.8642422D+02,-1.6427082D+02/

	if( z .lt. 0 ) then
	  az = -z
	else if( z .eq. 0 ) then
	  atm8_chap_xI1 = 0
	  return
	else
	  az = z
	end if
	if( az .lt. 3.75d0 ) then
	  z2 = z*z
	  sum = aI1(6)
	  do i=5,0,-1
	    sum = sum*z2 + aI1(i)
	  end do
	  atm8_chap_xI1 = z*exp(-az) * sum
	else
	  sum = bI1(8)
	  do i=7,0,-1
	    sum = sum/az + bI1(i)
	  end do
	  atm8_chap_xI1 = sum*sqrt(az)/z
	end if
	return
	end

C  ====================================================================
C
C	This Bessel function math routine returns
C
C	  xK1 = z * exp(+z) * K1(z)
C
C	Following Press et al [PFT86, page 179, BESSK1.FOR] and
C	Abrahamson and Stegun [AS64, page 379, 9.8.7, 9.8.8].
C
C  ====================================================================

	real*8 function atm8_chap_xK1( z )
	implicit real*8(a-h,o-z)
        dimension aK1(0:6), bK1(0:6)

        data aK1/ 1.00000000D+00, 3.8607860D-02,-4.2049112D-02,
     *     -2.8370152D-03,-7.4976641D-05,-1.0781641D-06,
     *     -1.1440430D-08/
        data bK1/ 1.25331414D+00, 4.6997238D-01,-1.4622480D-01,
     *      1.2034144D-01,-1.2485648D-01, 1.0419648D-01,
     *     -4.3676800D-02/

	if( z .le. 0 ) then
	  atm8_chap_xK1 = 1
	else if( z .lt. 2 ) then
	  xz = exp(z)
	  z2 = z*z
	  sum = aK1(6)
	  do i=5,0,-1
	    sum = sum*z2 + aK1(i)
	  end do
	  atm8_chap_xK1 = xz * ( sum
     *		+ z*log(z/2)*atm8_chap_xI1(z)*xz )
	else
	  sum = bk1(6)
	  do i=5,0,-1
	    sum = sum/z + bK1(i)
	  end do
	  atm8_chap_xK1 = sum*sqrt(z)
	end if

	return
	end

C  ####################################################################
C
C	The following "pure math" routines return various combinations
C	of the Error function, powers, and exponentials.
C
C  ####################################################################

C  ====================================================================
C
C	This Error function math routine returns
C
C	  xerfc(x) = exp(x**2)*erfc(x)
C
C	following Press et al. [PFT86, p164, ERFCC.FOR]
C
C  ====================================================================

	real*8 function atm8_chap_xerfc(x)
	implicit real*8(a-h,o-z)
        T=1.0D0/(1.0D0+0.5D0*x)
	atm8_chap_xerfc =
     *	  T*EXP( -1.26551223D0 +T*(1.00002368D0 +T*( .37409196D0
     *       +T*(  .09678418D0 +T*(-.18628806D0 +T*( .27886807D0
     *	     +T*(-1.13520398D0 +T*(1.48851587D0 +T*(-.82215223D0
     *	     +T*   .17087277D0) ))))))))
        RETURN
        END

C  ####################################################################
C
C	The following "pure math" routines return various combinations
C	of Exponential integrals, powers, and exponentials.
C
C  ####################################################################

C  ====================================================================
C
C	This Exponential math routine evaluates
C
C	  zxE1(x) = x*exp(x) int{y=1,infinity} [ exp(-x*y)/y dy ]
C
C	following Abramowitz and Stegun [AS64, p229;231, equations
C	5.1.11 and 5.1.56]
C
C  ====================================================================

	real*8 function atm8_chap_zxE1(x)
	implicit real*8(a-h,o-z)
	parameter (gamma = 0.5772156649015328606d0)
	dimension aE1(0:4), bE1(0:4), cEin(1:10)

	data aE1/1.0d0, 8.5733287401d0, 18.0590169730d0,
     *	    8.6347608925d0, 0.2677737343d0 /
	data bE1/1.0d0, 9.5733223454d0, 25.6329561486d0,
     *	    21.0996530827d0, 3.9584969228d0/
        data cEin/ 1.00000000D+00,-2.50000000D-01, 5.55555556D-02,
     *    -1.0416666667D-02, 1.6666666667D-03,-2.3148148148D-04,
     *     2.8344671202D-05,-3.1001984127D-06, 3.0619243582D-07,
     *    -2.7557319224D-08/

	if( x .le. 0 ) then
	  atm8_chap_zxE1 = 0
	else if( x .le. 1 ) then
	  sum = cEin(10)
	  do i=9,1,-1
	    sum = sum*x + cEin(i)
	  end do
	  atm8_chap_zxE1 = x*exp(x)*( x * sum - log(x) - gamma )
	else
	  top = aE1(4)
	  bot = bE1(4)
	  do i=3,0,-1
	    top = top/x + aE1(i)
	    bot = bot/x + bE1(i)
	  end do
	  atm8_chap_zxE1 = top/bot
	end if
	return
	end

C  ####################################################################
C
C	The following "pure math" routines return various combinations
C	of incomplete gamma functions, powers, and exponentials.
C
C  ####################################################################

C  ====================================================================
C
C	This gamma function math routine calculates
C
C	Dn(n) = int{t=z,infinity}
C		[ exp( -(t**2-z**2) ) * (t**2-z**2)**n dt ]
C
C  ====================================================================

	subroutine atm8_chap_gd3( z, Dn )
	implicit real*8(a-h,o-z)
	parameter (rpi=1.7724538509055160273d0)
	dimension Dn(0:3), xg(0:3)

	if( z .le. 0 ) then
	  Dn(0) = rpi/2
	  do i=1,3
	    Dn(i) = (i-0.5d0)*Dn(i-1)
	  end do
	  return
	end if

	z2 = z*z
	if( z .ge. 7 ) r = 1/z2

	if( z .lt. 14 ) then
	  z4 = z2*z2
	  xg(0) = rpi * atm8_chap_xerfc(z)
	  xg(1) = 0.5d0*xg(0) + z
	  xg(2) = 1.5d0*xg(1) + z*z2
	  Dn(0) = 0.5d0*xg(0)
	  Dn(1) = 0.5d0*(xg(1)-z2*xg(0))
	  Dn(2) = 0.5d0*(xg(2)-2*z2*xg(1)+z4*xg(0))
	else
	  Dn(0) = ( 1 + r*(-0.5d0 +r*(0.75d0 +r*(-1.875d0
     *		+r*6.5625d0) ) ) )/(2*z)
	  Dn(1) = ( 1 + r*(-1.0d0 +r*(2.25d0 +r*(-7.5d0
     *		+r*32.8125d0) ) ) )/(2*z)
	  Dn(2) = ( 2 + r*(-3.0d0 +r*(9.00d0 +r*(-37.5d0
     *		+r*196.875d0) ) ) )/(2*z)
	end if

	if( z .lt. 7 ) then
	  z6 = z4*z2
	  xg(3) = 2.5d0*xg(2) + z*z4
	  Dn(3) = 0.5d0*(xg(3)-3*z2*xg(2)+3*z4*xg(1)-z6*xg(0))
	else
	  Dn(3) = ( 6 + r*(-12.0d0 +r*(45.0d0 +r*(-225.0d0
     *		+r*1378.125d0) ) ) )/(2*z)
	end if

	return
	end

C  ====================================================================
C
C	This Gamma function math routine calculates
C
C	  gf06(n) = g(n,x) * int{y=x,z} [log(y) * exp(-y) * y**(2*n) dy]
C
C	and
C
C	  gg06(n) = g(n,x) * int{y=x,z} [ exp(-y) * y**(2*n) dy ]
C	          = g(n,x) * ( Gamma(2*n+1,x) - Gamma(2*n+1,z) )
C
C	for n=0,6, with g(n,x) = exp(x) * max(1,x)**(-2*n)
C
C  ====================================================================

	subroutine atm8_chap_gfg06( x, z, gf06, gg06 )
	implicit real*8 (a-h,o-z)
	parameter (gamma = 0.5772156649015328606d0)
	dimension gf06(0:6), gg06(0:6)
	dimension gh13x(13), gh13z(13), rgn(13), delta(13)
	call atm8_chap_gh13( x, x, gh13x )
	call atm8_chap_gh13( x, z, gh13z )
	if( x .le. 1 ) then
	  rho = 1
	else
	  rho = 1/x
	end if

	delta(1) = 0
	delta(2) = ( gh13x(1) - gh13z(1) ) * rho
	rgn(1) = 1
	rgn(2) = rho
	do n=2,12
	  delta(n+1) = rho*( n*delta(n) + gh13x(n) - gh13z(n) )
	  rgn(n+1) = (n*rho)*rgn(n)
	end do

	if( x .gt. 0 ) then
	  xE1_x = atm8_chap_zxE1(x)/x
	  xlog = log(x)
	end if
	if( z .gt. 0 ) then
	  xE1_z = exp(x-z)*atm8_chap_zxE1(z)/z
	  zlog = log(z)
	end if

	do k=0,6
	  n = 2*k+1
	  if( x .le. 0 ) then
	    gf06(k) = -gamma*rgn(n) + delta(n)
	  else
	    gf06(k) = xlog*gh13x(n) + rgn(n)*xE1_x + delta(n)
	  end if
	  if( z .le. 0 ) then
	    gf06(k) = gf06(k) + gamma*rgn(n)
	  else
	    gf06(k) = gf06(k) - (zlog*gh13z(n) + rgn(n)*xE1_z)
	  end if
	  gg06(k) = gh13x(n) - gh13z(n)
	end do

	return
	end

C  ====================================================================
C
C	This Gamma function math routine calculates
C
C	  gg06(n) = g(n,x) * int{y=x,z} [ exp(-y) * y**(2*n) dy ]
C	          = g(n,x) * ( Gamma(2*n+1,x) - Gamma(2*n+1,z) )
C
C	for n=0,6, with g(n,x) = exp(x) * max(1,x)**(-2*n)
C
C  ====================================================================

	subroutine atm8_chap_gg06( x, z, gg06 )
	implicit real*8 (a-h,o-z)
	dimension gg06(0:6), gh13x(13), gh13z(13)
	call atm8_chap_gh13( x, x, gh13x )
	call atm8_chap_gh13( x, z, gh13z )
	do n=0,6
	  gg06(n) = gh13x(2*n+1) - gh13z(2*n+1)
	end do
	return
	end

C  ====================================================================
C
C	This Gamma function math routine calculates
C
C	  gh13(n) = f(n,x) * int{y=z,infinity} [exp(-y) * y**(n-1) dy]
C	          = f(n,x) * Gamma(n,z)
C
C	for n=1,13, with f(n,x) = exp(x) * max(1,x)**(-n+1)
C
C  ====================================================================

	subroutine atm8_chap_gh13( x, z, gh13 )
	implicit real*8 (a-h,o-z)
	dimension gh13(13), Tab(12)

	if( z .le. 0 ) then
	  gh13(1) = 1
	  do n=1,12
	    gh13(n+1) = n*gh13(n)
	  end do
	  return
	end if

	if( x .le. 1 ) then
	  rho = 1
	else
	  rho = 1/x
	end if
	rhoz = rho * z
	exz = exp(x-z)
	Tab(12) = exp( (x-z) + 12*log(rhoz) )
	do n=11,1,-1
	  Tab(n) = Tab(n+1)/rhoz
	end do
	gh13(1) = exz
	do n=1,12
	  gh13(n+1) = rho*n*gh13(n) + Tab(n)
	end do
	return
	end

C  ====================================================================
C
C	This Gamma function math subroutine calculates
C
C	  Qn(x) = x**n * exp(x) * Gamma(-n+0.5,x), n=0,8
C	    = x**n * exp(x) * int{y=x,infinity} [exp(-y)*y**(-n-0.5)dy]
C
C	For x .lt. 2 we first calculate
C
C	  Q0(x) = sqrt(pi)*exp(x)*erfc(sqrt(x)) = exp(x)*Gamma(0.5,x)
C
C	and use upward recursion.  Else, we first calculate
C
C	  Q8(x) = x**8 * exp(x) * Gamma(-7.5,x)
C
C	following Press et al. [PFT86, pp162-63, GCF.FOR] and then
C	recur downward.  Also see Abramowitz and Stegun [AS64, 6.5].
C
C  ====================================================================

	subroutine atm8_chap_gq85( x, qn )
	implicit real*8(a-h,o-z)
	parameter (rpi=1.7724538509055160273d0)
	parameter (itmax=100,eps=3.0d-9)
	dimension qn(0:8)

	if( x .le. 0 ) then
	  qn(0) = rpi
	  do i=1,8
	    qn(i) = 0
	  end do
	  return
	end if

	rx = sqrt(x)

	if( x .lt. 2 ) then
	  qn(0) = rpi * atm8_chap_xerfc( rx )
	  do n=1,8
	    qn(n) = ( -rx*qn(n-1) + 1 ) * rx / ( n - 0.5d0 )
	  end do
	else
          GOLD=0.0d0
	  A0=1.0d0
	  A1=x
	  B0=0.0d0
	  B1=1.0d0
	  FAC=1.0d0
	  DO 11 N=1,ITMAX
	    AN= (N)
	    ANA=AN + 7.5d0
	    A0=(A1+A0*ANA)*FAC
	    B0=(B1+B0*ANA)*FAC
	    ANF=AN*FAC
	    A1=x*A0+ANF*A1
	    B1=x*B0+ANF*B1
	    FAC=1./A1
            G=B1*FAC
	    test = G*eps
	    del = G - Gold
	    if( test .lt. 0 ) test = - test
	    if( (del .ge. -test) .and. (del .le. test) ) go to 12
	    GOLD=G
11        CONTINUE
12	  qn(8) = G * rx
	  do n=8,1,-1
	    qn(n-1) = ( (-n+0.5d0)*qn(n)/rx + 1 ) / rx
	  end do
	end if

	return
	end


! Program to test the MATMUL intrinsic
program intrinsic_matmul
   implicit none
   integer, dimension(2, 3) :: a
   integer, dimension(3, 2) :: b
   integer, dimension(2) :: x
   integer, dimension(3) :: y
   integer, dimension(2, 2) :: r
   integer, dimension(3) :: v
   real, dimension (2,2) :: aa
   real, dimension (4,2) :: cc

   a = reshape((/1, 2, 2, 3, 3, 4/), (/2, 3/))
   b = reshape((/1, 2, 3, 3, 4, 5/), (/3, 2/))
   x = (/1, 2/)
   y = (/1, 2, 3/)

   r = matmul(a, b)
   if (any(r .ne. reshape((/14, 20, 26, 38/), (/2, 2/)))) call abort

   v = matmul(x, a)
   if (any(v .ne. (/5, 8, 11/))) call abort

   v(1:2) = matmul(a, y)
   if (any(v(1:2) .ne. (/14, 20/))) call abort

  aa = reshape((/ 1.0, 1.0, 0.0, 1.0/), shape(aa))
  cc = 42.
  cc(1:2,1:2) = matmul(aa, transpose(aa))
  if (any(cc(1:2,1:2) .ne. reshape((/ 1.0, 1.0, 1.0, 2.0 /), (/2,2/)))) call abort
  if (any(cc(3:4,1:2) .ne. 42.)) call abort
end program


MODULE fortranfft
contains

  SUBROUTINE generate_exp(N, exp_factors)
    ! Generates the exponential factors which are used in the subroutines
    ! bellow.
    !
    ! Inputs : N
    !
    ! Outputs : exp_factors - array of the form W[n] = exp(-2j*pi*n/N)

    implicit none

    integer, intent(in) :: N
    complex(8), dimension(0:N/2-1), intent(out) :: exp_factors

    real(8), parameter :: PI = 4*atan(1.0_8)
    complex(8), parameter :: Imag = (0.0_8, 1.0_8)

    integer :: i

    do i = 0, N/2-1
      exp_factors(i) = exp(-2*Imag*PI*i/N)
    end do

  END SUBROUTINE generate_exp

  SUBROUTINE dft(N,x,f)
    ! A direct implementation of the Discrete Fourier Transform.
    !
    ! Inputs : x - the array which we perform the DFT on.
    !          N - the number of elements in x.
    !
    ! Outputs : f - the transformed array.

    implicit none

    integer, intent(in) :: N
    complex(8), dimension(0:N-1), intent(in) :: x
    complex(8), dimension(0:N-1), intent(out) :: f

    real(8), parameter :: PI = 4*atan(1.0_8)
    complex(8), parameter :: Imag = (0.0_8, 1.0_8)

    complex(8) :: sum_exp = (0,0)
    integer :: i, j

    do i = 0, N-1
      do j = 0, N-1
        sum_exp = sum_exp + exp(-2*PI*Imag*i*j/N) * x(j)
      end do
      f(i) = sum_exp
      sum_exp = (0,0)
    end do

  END SUBROUTINE dft

  RECURSIVE SUBROUTINE fft(N,x,exp_factors,f)
    ! A Fast Fourier Transform using the Cooley-Tukey radix-2 algorithm.
    !
    ! Inputs : x - the array which we perform the DFT on.
    !          N - the number of elements in x.
    !          exp_factors - the array exponentials of the form exp(-2j*pi*n/N)
    !
    ! Outputs : f - the transformed array.

    implicit none

    integer, intent(in) :: N
    complex(8), dimension(0:N-1), intent(in) :: x
    complex(8), dimension(0:N/2-1), intent(in) :: exp_factors
    complex(8), dimension(0:N-1), intent(out) :: f

    complex(8), dimension(0:N/2-1) :: f_even, f_odd

    ! If input array has length 2 or less it returns the regular DFT.
    if (N .le. 2) then
      call dft(N,x,f)

    ! If the input array is divisible by 2, it calls itself recursively on both
    ! the even and odd elements and then adds them together.
    else if (mod(N,2) == 0) then
      call fft(N/2, x(1::2), (exp_factors(0:N/2-1))**2, f_odd)
      call fft(N/2, x(::2), (exp_factors(0:N/2-1))**2, f_even)

      f(0:N/2-1) = f_even(0:N/2-1) + f_odd(0:N/2-1) * exp_factors(0:N/2-1)
      f(N/2:) = f_even(0:N/2-1) - f_odd(0:N/2-1) * exp_factors(0:N/2-1)

    ! For robustness, even if the array is not furher divisible by 2, we return
    ! the regular DFT regardless of size.
    else
      call dft(N,x,f)
    end if

  END SUBROUTINE fft

  SUBROUTINE fft2(N,x,exp_factors,f)
    ! A 2D FFT based on the 1D case. Complexity is O(N^2 log N) as opposed to
    ! O(N^4) for the 2D DFT.
    !
    ! Inputs : x - the NxN array which we perform the DFT on.
    !          N - the length of each dimension of x.
    !          exp_factors - the array exponentials of the form exp(-2j*pi*n/N)
    !
    ! Outputs : f - the transformed array.

    implicit none

    integer, intent(in) :: N
    complex(8), dimension(0:N-1, 0:N-1), intent(in) :: x
    complex(8), dimension(0:N/2-1), intent(in) :: exp_factors
    complex(8), dimension(0:N-1, 0:N-1), intent(out) :: f

    integer :: i

    ! Creates the 2D array f, whose rows are FFTs of the rows of x.
    do i = 0, N-1
      call fft(N,x(i,:),exp_factors, f(i,:))
    end do

    ! Replaces each column in f with its fourier transform.
    do i = 0, N-1
      call fft(N,f(:,i),exp_factors, f(:,i))
    end do

  END SUBROUTINE fft2

END MODULE fortranfft


program pg20
    implicit none
    ! Section: Specification
    integer :: mml,i,j,retinfo
    double precision, allocatable :: a(:,:)
    double precision, allocatable :: ata(:,:), meye(:,:)
    integer, allocatable :: ipiv(:)
    character(len=512) :: dfmt
    ! Section: Execution
    mml = 5
    retinfo = 0
    ! Format for I/O
    write(dfmt, '(a,i0,a)') '(',mml,'f7.2)'
    !
    allocate(a(mml,mml), ata(mml,mml), meye(mml,mml), ipiv(mml))
    ! 'meye' is an Identity matrix
    meye = 0.0
    do i = 1,mml
        meye(i,i) = 1.0
    end do
    ! 'a' is now assigned values
    do i = 1,mml
        do j = 1,mml
            a(i,j) = 10*i + j
        end do
    end do
    write(*,*) 'Input:'
    write(*,dfmt) transpose(a)
    !
    call dgetrf(mml,mml,a,mml,ipiv,retinfo)
    ! call getrf(a,ipiv,retinfo)
    !
    if (retinfo /= 0) then
        write(*,*) 'The matrix is singular: dgetrf returned ', retinfo
    else
        write(*,*) 'LU Result:'
        write(*,dfmt) transpose(a)
        write(*,*)
        write(*,*) 'Pivots:'
        write(*,*) ipiv
        write(*,*)
        write(*,*) 'Identity:'
        write(*,dfmt) transpose(meye)
        call dtrmm('L','U','N','N',mml,mml,1.0d0,a,mml,meye,mml)
        call dtrmm('L','L','N','U',mml,mml,1.0d0,a,mml,meye,mml)
        write(*,*)
        write(*,*) 'After trmm:'
        write(*,dfmt) transpose(meye)
        do i = mml,1,-1
            call s_rowexch(ipiv(i),i,meye)
        end do
        write(*,*)
        write(*,*) 'After reversing pivots:'
        write(*,dfmt) transpose(meye)
    end if
    deallocate(a, ata, meye, ipiv)
    contains
        subroutine s_rowexch(row_a,row_b,m)
            implicit none
            integer, intent(in) :: row_a, row_b
            double precision, intent(inout) :: m(:,:)
            double precision, allocatable :: tmprow(:)
            allocate(tmprow(size(m,2)))
            !
            tmprow = m(row_b,:)
            m(row_b,:) = m(row_a,:)
            m(row_a,:) = tmprow
            !
            deallocate(tmprow)
        end subroutine s_rowexch
end program pg20


! { dg-do run }
! { dg-options -O2 }
! Tests the fix for PRs29507 and 31404, where elemental functions in
! initialization expressions could not be simplified with array arguments.
!
! Contributed by Steve Kargl <kargl@gcc.gnu.org >
!             and Vivek Rao <vivekrao4@yahoo.com>
!
  real, parameter :: a(2,2) = reshape ((/1.0, 2.0, 3.0, 4.0/), (/2,2/))
  real, parameter :: b(2,2) = sin (a)
  character(8), parameter :: oa(1:3)=(/'nint()  ', 'log10() ', 'sqrt()  '/)
  integer, parameter :: ob(1:3) = index(oa, '(')
  character(6), parameter :: ch(3) = (/"animal", "person", "mantee"/)
  character(1), parameter :: ch2(3) = (/"n", "r", "t"/)
  integer, parameter :: i(3) = index (ch, ch2)
  integer :: ic(1) = len_trim((/"a"/))

  if (any (reshape (b, (/4/)) .ne. (/(sin(real(k)), k = 1,4)/))) call abort ()
  if (any (ob .ne. (/5,6,5/))) call abort ()  ! Original PR29507
  if (any (i .ne. (/2,3,4/))) call abort ()
  if (ic(1) .ne. 1) call abort ()             ! Original PR31404
end


!Fortran uses the unit number to access the file with later read and write statements. Several files can be open at once, but each must have a different number. There is one thing to remember about numbering a file - you cannot use the number 6, as GNU Fortran reserves that number to refer to the screen.
program read
	implicit none
	INTEGER :: options
	INTEGER :: i
	REAL :: a, b
	REAL :: addanswer, subtractanswer
	REAL :: multiplyanswer, divisionanswer
	real, dimension(100) :: p, q
        real :: pi
  	real :: radius
  	real :: height
  	real :: area
  	real :: volume
	pi = 3.1415927
	! character type string to clear a users screen
	!print *, achar(27)//"[2J"
	!
	print *, " _____         _                     ___ ___ "
	print *, "|   __|___ ___| |_ ___ ___ ___ _____| . |  _|"
	print *, "|   __| . |  _|  _|  _| .'|   |_____|_  |_  |"
	print *, "|__|  |___|_| |_| |_| |__,|_|_|_____|___|___|"
	print *, "-------------------------------------------------|"
	print *, "1  => calculate a basic equation                 |"
	print *, "2 => Get the radius of a cylinder                |"
	print *, "-------------------------------------------------|"
	print *, " Please enter a command below: "
	read(*,*) options
	IF (options == 1) THEN
		print *, ''
		print *, '[ | ] Please input the first integer  '
		read(*,*) a
		print *, ''
		print *, '[ | ] Please input the second integer '
		read(*,*) b
		!
		addanswer = a + b
    		subtractanswer = a - b
    		multiplyanswer = a * b
    		divisionanswer = a / b
		!
		print *, "_________________________________________________________|"
                print *, "|Results : Addition, Subtraction, Multiplication, divsion|"
       	        print *, "------------------------------------------------------------------------"
    		write(*,*) a, " + ", b, " = ", addAnswer
    		write(*,*) a, " - ", b, " = ", subtractanswer
    		write(*,*) a, " * ", b, " = ", multiplyanswer
    		write(*,*) a, " / ", b, " = ", divisionanswer
		open(unit = 2, file = "output.txt")
       		!the files unit is = to 2 so i would need to make the write unit the same as 2
		print *, ''//achar(27)//'[31m '//achar(27)//'[0m'
		write(2, *) a, " + ", b, " = ", addAnswer
		write(2, *) a, " - ", b, " = ", subtractanswer
		write(2, *) a, " * ", b, " = ", multiplyanswer
       	        write(2, *) a, " / ", b, " = ", divisionanswer
		print *, "------------------------------------------------------------------------"
		close(2)
		PRINT*, "[ | ] Data written to a file |output.txt|  [ | ] "
	ELSE IF (options == 2) THEN
		print *, ''
                print *, '[ | ] Enter cylinder base radius:'
                read(*,*) radius
		print *, ''
                print *, '[ | ] Enter cylinder height:'
                read(*,*) height
                area = pi * radius**2.0
                volume = area * height
		print *, ''
		print *, ''
		print *, ''
		print *, '_______________________________________'
                print *, '[ = ] Cylinder radius      => ', radius
	        print *, '[ = ] Cylinder height      => ', height
                print *, '[ = ] Cylinder base area   => ', area
  		print *, '[ = ] Cylinder volume      =>  ', volume
	END IF
end program read


!--------------------------------------------------------------------
!
!
! PURPOSE
!
! This program solves nonlinear Klein-Gordon equation in 3 dimensions
! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*|u|^2u
! using a second order implicit-explicit time stepping scheme.
!
! The boundary conditions are u(x=-Lx*pi,y,z)=u(x=Lx*\pi,y,z),
!       u(x,y=-Ly*pi,z)=u(x,y=Ly*pi,z),u(x,y,z=-Ly*pi)=u(x,y,z=Ly*pi),
! The initial condition is u=0.5*exp(-x^2-y^2-z^2)*sin(10*x+12*y)
!
! .. Parameters ..
!  Nx                           = number of modes in x - power of 2 for FFT
!  Ny                           = number of modes in y - power of 2 for FFT
!  Nz                           = number of modes in z - power of 2 for FFT
!  Nt                           = number of timesteps to take
!  Tmax                         = maximum simulation time
!  plotgap                      = number of timesteps between plots
!  pi = 3.14159265358979323846264338327950288419716939937510d0
!  Lx                           = width of box in x direction
!  Ly                           = width of box in y direction
!  Lz                           = width of box in z direction
!  ES                           = +1 for focusing and -1 for defocusing
! .. Scalars ..
!  i                            = loop counter in x direction
!  j                            = loop counter in y direction
!  k                            = loop counter in z direction
!  n                            = loop counter for timesteps direction
!  allocatestatus       = error indicator during allocation
!  start                        = variable to record start time of program
!  finish                       = variable to record end time of program
!  count_rate           = variable for clock count rate
!  dt                           = timestep
!  modescalereal        = Number to scale after backward FFT
!  ierr                         = error code
!  plotnum                      = number of plot
!  myid                         = Process id
!  p_row                        = number of rows for domain decomposition
!  p_col                        = number of columns for domain decomposition
!  filesize                     = total filesize
!  disp                         = displacement to start writing data from
! .. Arrays ..
!  unew                         = approximate solution
!  vnew                         = Fourier transform of approximate solution
!  u                            = approximate solution
!  v                            = Fourier transform of approximate solution
!  uold                         = approximate solution
!  vold                         = Fourier transform of approximate solution
!  nonlin                       = nonlinear term, u^3
!  nonlinhat            = Fourier transform of nonlinear term, u^3
! .. Vectors ..
!  kx                           = fourier frequencies in x direction
!  ky                           = fourier frequencies in y direction
!  kz                           = fourier frequencies in z direction
!  x                            = x locations
!  y                            = y locations
!  z                            = z locations
!  time                         = times at which save data
!  en                           = total energy
!  enstr                        = strain energy
!  enpot                        = potential energy
!  enkin                        = kinetic energy
!  name_config          = array to store filename for data to be saved
!  fftfxyz                      = array to setup 2D Fourier transform
!  fftbxyz                      = array to setup 2D Fourier transform
! .. Special Structures ..
!  decomp                       = contains information on domain decomposition
!                                       see http://www.2decomp.org/ for more information
! REFERENCES
!
! ACKNOWLEDGEMENTS
!
! ACCURACY
!
! ERROR INDICATORS AND WARNINGS
!
! FURTHER COMMENTS
! Check that the initial iterate is consistent with the
! boundary conditions for the domain specified
!--------------------------------------------------------------------
! External routines required
!       getgrid.f90     -- Get initial grid of points
!       initialdata.f90 -- Get initial data
!       enercalc.f90 -- Subroutine to calculate the energy
!       savedata.f90 -- Save initial data
!       storeold.f90 -- Store old data
! External libraries required
!       2DECOMP&FFT      -- Domain decomposition and Fast Fourier Library
!                       (http://www.2decomp.org/index.html)
! MPI library

PROGRAM Kg
  use decomp_2d
  use decomp_2d_fft
  use decomp_2d_io
  !coprocessing:
  use KGadaptor_module

  implicit none
  INCLUDE 'mpif.h'
  ! Declare variables
  INTEGER(kind=4)                         :: Nx, Ny, Nz, Nt, plotgap
  REAL(kind=8), PARAMETER         :: &
       pi=3.14159265358979323846264338327950288419716939937510d0
  REAL(kind=8)                            ::  Lx,Ly,Lz,Es,dt,starttime,modescalereal
  COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE      ::  kx,ky,kz
  REAL(kind=8),    DIMENSION(:), ALLOCATABLE      ::  x,y,z
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  u,nonlin
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  v,nonlinhat
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  uold
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  vold
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  unew
  COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE::  vnew
  REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE :: savearray
  REAL(kind=8), DIMENSION(:), ALLOCATABLE ::  time,enkin,enstr,enpot,en
  INTEGER(kind=4)         ::  ierr,i,j,k,n,allocatestatus,myid,numprocs
  INTEGER(kind=4)         ::  start, finish, count_rate, plotnum
  TYPE(DECOMP_INFO)       ::  decomp
  INTEGER(kind=MPI_OFFSET_KIND) :: filesize, disp
  INTEGER(kind=4) ::  p_row=0, p_col=0
  CHARACTER*100   ::  name_config
  ! initialisation of 2DECOMP&FFT
  CALL MPI_INIT(ierr)
  CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
  CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)

  CALL readinputfile(Nx,Ny,Nz,Nt,plotgap,Lx,Ly,Lz, &
       Es,DT,starttime,myid,ierr)
  ! do automatic domain decomposition
  CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
  ! get information about domain decomposition choosen
  CALL decomp_info_init(Nx,Ny,Nz,decomp)
  ! initialise FFT library
  CALL decomp_2d_fft_init
  ALLOCATE(kx(decomp%zst(1):decomp%zen(1)),&
       ky(decomp%zst(2):decomp%zen(2)),&
       kz(decomp%zst(3):decomp%zen(3)),&
       x(decomp%xst(1):decomp%xen(1)),&
       y(decomp%xst(2):decomp%xen(2)),&
       z(decomp%xst(3):decomp%xen(3)),&
       u(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       v(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       nonlin(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       nonlinhat(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       uold(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vold(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       unew(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       vnew(decomp%zst(1):decomp%zen(1),&
       decomp%zst(2):decomp%zen(2),&
       decomp%zst(3):decomp%zen(3)),&
       savearray(decomp%xst(1):decomp%xen(1),&
       decomp%xst(2):decomp%xen(2),&
       decomp%xst(3):decomp%xen(3)),&
       time(1:1+Nt/plotgap),enkin(1:1+Nt/plotgap),&
       enstr(1:1+Nt/plotgap),enpot(1:1+Nt/plotgap),&
       en(1:1+Nt/plotgap),stat=allocatestatus)
  IF (allocatestatus .ne. 0) stop
  IF (myid.eq.0) THEN
     PRINT *,'allocated arrays'
  END IF
  ! setup fourier frequencies
  CALL getgrid(myid,Nx,Ny,Nz,Lx,Ly,Lz,pi,name_config,x,y,z,kx,ky,kz,decomp)
  IF (myid.eq.0) THEN
     PRINT *,'Setup grid and fourier frequencies'
  END IF
  CALL initialdata(Nx,Ny,Nz,x,y,z,u,uold,decomp)
  plotnum=1
  name_config = 'data/u'
  savearray=REAL(u)
! CALL savedata(Nx,Ny,Nz,plotnum,name_config,savearray,decomp)

  CALL decomp_2d_fft_3d(u,v,DECOMP_2D_FFT_FORWARD)
  CALL decomp_2d_fft_3d(uold,vold,DECOMP_2D_FFT_FORWARD)

  modescalereal=1.0d0/REAL(Nx,KIND(0d0))
  modescalereal=modescalereal/REAL(Ny,KIND(0d0))
  modescalereal=modescalereal/REAL(Nz,KIND(0d0))

  CALL enercalc(myid,Nx,Ny,Nz,dt,Es,modescalereal,&
       enkin(plotnum),enstr(plotnum),&
       enpot(plotnum),en(plotnum),&
       kx,ky,kz,nonlin,nonlinhat,&
       v,vold,u,uold,decomp)

  IF (myid.eq.0) THEN
     PRINT *,'Got initial data, starting timestepping'
  END IF
  time(plotnum)=0.0d0+starttime
  CALL system_clock(start,count_rate)

  !coprocessing:
  call coprocessorinitialize("pipeline.py", 11)

  DO n=1,Nt
     DO k=decomp%xst(3),decomp%xen(3)
        DO j=decomp%xst(2),decomp%xen(2)
           DO i=decomp%xst(1),decomp%xen(1)
              nonlin(i,j,k)=(abs(u(i,j,k))*2)*u(i,j,k)
           END DO
        END DO
     END DO
     CALL decomp_2d_fft_3d(nonlin,nonlinhat,DECOMP_2D_FFT_FORWARD)
     DO k=decomp%zst(3),decomp%zen(3)
        DO j=decomp%zst(2),decomp%zen(2)
           DO i=decomp%zst(1),decomp%zen(1)
              vnew(i,j,k)=&
                   ( 0.25*(kx(i)*kx(i) + ky(j)*ky(j)+ kz(k)*kz(k)-1.0d0)&
                   *(2.0d0*v(i,j,k)+vold(i,j,k))&
                   +(2.0d0*v(i,j,k)-vold(i,j,k))/(dt*dt)&
                   +Es*nonlinhat(i,j,k) )&
                   /(1/(dt*dt)-0.25*(kx(i)*kx(i)+ ky(j)*ky(j)+ kz(k)*kz(k)-1.0d0))
           END DO
        END DO
     END DO
     CALL decomp_2d_fft_3d(vnew,unew,DECOMP_2D_FFT_BACKWARD)
     ! normalize result
     DO k=decomp%xst(3),decomp%xen(3)
        DO j=decomp%xst(2),decomp%xen(2)
           DO i=decomp%xst(1),decomp%xen(1)
              unew(i,j,k)=unew(i,j,k)*modescalereal
           END DO
        END DO
     END DO
     IF (mod(n,plotgap)==0) THEN
        plotnum=plotnum+1
        time(plotnum)=n*dt+starttime
        IF (myid.eq.0) THEN
           PRINT *,'time',n*dt+starttime
        END IF
        CALL enercalc(myid,Nx,Ny,Nz,dt,Es,modescalereal,&
             enkin(plotnum),enstr(plotnum),&
             enpot(plotnum),en(plotnum),&
             kx,ky,kz,nonlin,nonlinhat,&
             vnew,v,unew,u,decomp)
        savearray=REAL(unew,kind(0d0))
!       CALL savedata(Nx,Ny,Nz,plotnum,name_config,savearray,decomp)
     END IF
     !coprocessing:
     call KGadaptor(Nx, Ny, Nz, decomp%xst(1), decomp%xen(1), &
                  decomp%xst(2), decomp%xen(2), decomp%xst(3), decomp%xen(3), &
                  n, n*dt+starttime, savearray)

     ! .. Update old values ..
     CALL storeold(Nx,Ny,Nz,unew,u,uold,vnew,v,vold,decomp)
  END DO
  !coprocessing:
  call coprocessorfinalize()

  CALL system_clock(finish,count_rate)
  IF (myid.eq.0) THEN
     PRINT *,'Finished time stepping'
     PRINT*,'Program took ',&
          REAL(finish-start,kind(0d0))/REAL(count_rate,kind(0d0)),&
          'for Time stepping'
     CALL saveresults(Nt,plotgap,time,en,enstr,enkin,enpot)
     ! Save times at which output was made in text format
     PRINT *,'Saved data'
  END IF
  CALL decomp_2d_fft_finalize
  CALL decomp_2d_finalize

  DEALLOCATE(kx,ky,kz,x,y,z,u,v,nonlin,nonlinhat,savearray,&
       uold,vold,unew,vnew,time,enkin,enstr,enpot,en,&
       stat=allocatestatus)
  IF (allocatestatus .ne. 0) STOP
  IF (myid.eq.0) THEN
     PRINT *,'Deallocated arrays'
     PRINT *,'Program execution complete'
  END IF
  CALL MPI_FINALIZE(ierr)

END PROGRAM Kg


module mod_monolis_shape_util
  use mod_monolis_prm

contains

  subroutine monolis_get_inverse_matrix_2d(xj, inv, det, is_fail)
    implicit none
    real(kdouble) :: xj(2,2), inv(2,2), det, detinv
    logical, optional :: is_fail

    det = xj(1,1) * xj(2,2) &
        - xj(2,1) * xj(1,2)

    if(det < 0.0d0)then
      if(present(is_fail))then
        is_fail = .true.
      else
        stop "determinant < 0.0"
      endif
    endif

    detinv = 1.0d0/det
    inv(1,1) =  xj(2,2)*detinv
    inv(1,2) = -xj(1,2)*detinv
    inv(2,1) = -xj(2,1)*detinv
    inv(2,2) =  xj(1,1)*detinv
  end subroutine monolis_get_inverse_matrix_2d

  subroutine monolis_get_inverse_matrix_3d(xj, inv, det, is_fail)
    implicit none
    real(kdouble) :: xj(3,3), inv(3,3), det, detinv
    logical, optional :: is_fail

    if(present(is_fail)) is_fail = .false.

    det = xj(1,1) * xj(2,2) * xj(3,3) &
        + xj(2,1) * xj(3,2) * xj(1,3) &
        + xj(3,1) * xj(1,2) * xj(2,3) &
        - xj(3,1) * xj(2,2) * xj(1,3) &
        - xj(2,1) * xj(1,2) * xj(3,3) &
        - xj(1,1) * xj(3,2) * xj(2,3)

    if(det < 0.0d0)then
      if(present(is_fail))then
        is_fail = .true.
      else
        stop "determinant < 0.0"
      endif
    endif

    detinv = 1.0d0/det
    inv(1,1) = detinv * ( xj(2,2)*xj(3,3) - xj(3,2)*xj(2,3))
    inv(1,2) = detinv * (-xj(1,2)*xj(3,3) + xj(3,2)*xj(1,3))
    inv(1,3) = detinv * ( xj(1,2)*xj(2,3) - xj(2,2)*xj(1,3))
    inv(2,1) = detinv * (-xj(2,1)*xj(3,3) + xj(3,1)*xj(2,3))
    inv(2,2) = detinv * ( xj(1,1)*xj(3,3) - xj(3,1)*xj(1,3))
    inv(2,3) = detinv * (-xj(1,1)*xj(2,3) + xj(2,1)*xj(1,3))
    inv(3,1) = detinv * ( xj(2,1)*xj(3,2) - xj(3,1)*xj(2,2))
    inv(3,2) = detinv * (-xj(1,1)*xj(3,2) + xj(3,1)*xj(1,2))
    inv(3,3) = detinv * ( xj(1,1)*xj(2,2) - xj(2,1)*xj(1,2))
  end subroutine monolis_get_inverse_matrix_3d

end module mod_monolis_shape_util


*dk volume_qud
      subroutine volume_qud(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
     *                      volqud)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A QUD-ELEMENT DEFINDED BY
C            4 COORDINATE NODES. THE VOLUME OF THE QUD IS DETERMINED
C            BY SUBDIVIDING IT INTO 4 TRIANGULAR ELEMENTS
C            USING THE MIDPOINT
C            AND THEN SUMMING THE VOLUME OF THE TRIANGLES.
C
C            compare volume_qud_alt_lg below
C
C     ******************************************************************
C
C     DEFINE THE STRUCTURE OF A GENERIC QUD.
C
C
C          4- - - -3    Edge 1: 1 2
C          |       |         2: 2 3
C          |       |         3: 3 4
C          1- - - -2         4: 4 1
C
C     ******************************************************************
C
C      INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x4,y4,z4) - THE COORDINATES OF THE QUD.
C
C     OUTPUT ARGUMENTS -
C
C        volqud - THE VOLUME OF THE QUD.
C
C     CHANGE HISTORY -
C
C        $Log: volume_qud.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.4   Tue Oct 19 15:13:20 1999   jtg
CPVCS    fixed form of inv3x3 call
CPVCS
CPVCS       Rev 1.3   Tue Oct 19 13:16:54 1999   jtg
CPVCS    alternate way of caluculating volume using "minimum area
CPVCS    point" (instead of midpoint) added.
CPVCS
CPVCS       Rev 1.2   Mon Apr 14 17:05:40 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.1   Mon Nov 11 20:55:52 1996   het
CPVCS    Remove the absolute value for volume.
CPVCS
CPVCS       Rev 1.0   Mon Jul 29 15:42:48 1996   dcg
CPVCS    Initial revision.
C
C
C#######################################################################
C
      implicit real*8 (a-h,o-z)
C
C#######################################################################
C
C
C     ..................................................................
C     FIND THE MEDIAN POINT FOR EACH OF THE SIX FACES AND THE HEX.
C
      x1234=(x1+x2+x3+x4)/4.0d+00
      y1234=(y1+y2+y3+y4)/4.0d+00
      z1234=(z1+z2+z3+z4)/4.0d+00

      !local_debug=0
      !if (local_debug.gt.0) then
      !  write(*,'(a,3f12.8)') 'using mid ',x1234,y1234,z1234
      !endif
C
C
C     ..................................................................
C     FIND THE VOLUME OF THE 4-TRI QUD.
C
      call volume_tri(x1234,y1234,z1234,
     *                x1,y1,z1,
     *                x2,y2,z2,
     *                voltri1)
      call volume_tri(x1234,y1234,z1234,
     *                x2,y2,z2,
     *                x3,y3,z3,
     *                voltri2)
      call volume_tri(x1234,y1234,z1234,
     *                x3,y3,z3,
     *                x4,y4,z4,
     *                voltri3)
      call volume_tri(x1234,y1234,z1234,
     *                x4,y4,z4,
     *                x1,y1,z1,
     *                voltri4)
C
C
C     ..................................................................
C     SUM THE 4 TRI VOLUMES TO THE VOLUME OF THE QUD.
C
      volqud=voltri1+voltri2+voltri3+voltri4
C
      return
      end
C#######################################################################
C=======================================================================
C#######################################################################
*dk volume_qud_alt
      subroutine volume_qud_alt_lg(x1,y1,z1,x2,y2,z2
     *                      ,x3,y3,z3,x4,y4,z4,volqud
     *                      ,x1234,y1234,z1234)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A QUD-ELEMENT DEFINDED BY
C            4 COORDINATE NODES. THE VOLUME OF THE QUD IS DETERMINED
C            BY SUBDIVIDING IT INTO 4 TRIANGULAR ELEMENTS
C            USING THE POINT WHICH MINIMIZES THE SUM OF THE AREAS
C            AND THEN SUMMING THE VOLUME OF THE TRIANGLES.
C
C            structure and arguments same as above
C            except call also returns "min-area-point" (x1234,y1234,z1234)
C
C#######################################################################
C
      implicit none
      real*8 x1,y1,z1,x2,y2,z2 ,x3,y3,z3,x4,y4,z4,volqud
     *      ,x1234,y1234,z1234

      real*8 mat(3,3),vec(3),d(3,4),s(3,4),dd(4),ds(4),ddd
     *      ,voltri
      integer i,j,local_debug,iflag
C
C#######################################################################
C
C     ..................................................................
C     FIND THE POINT WHICH MINIMIZES THE SUM OF THE AREAS
C

      d(1,1)=x2-x1
      d(2,1)=y2-y1
      d(3,1)=z2-z1
      d(1,2)=x3-x2
      d(2,2)=y3-y2
      d(3,2)=z3-z2
      d(1,3)=x4-x3
      d(2,3)=y4-y3
      d(3,3)=z4-z3
      d(1,4)=x1-x4
      d(2,4)=y1-y4
      d(3,4)=z1-z4

      s(1,1)=x2+x1
      s(2,1)=y2+y1
      s(3,1)=z2+z1
      s(1,2)=x3+x2
      s(2,2)=y3+y2
      s(3,2)=z3+z2
      s(1,3)=x4+x3
      s(2,3)=y4+y3
      s(3,3)=z4+z3
      s(1,4)=x1+x4
      s(2,4)=y1+y4
      s(3,4)=z1+z4

      ddd=0.0d+0
      do j=1,4
         dd(j)=0.0d+0
         ds(j)=0.0d+0
         do i=1,3
            dd(j)=dd(j)+d(i,j)*d(i,j)
            ds(j)=ds(j)+d(i,j)*s(i,j)
         enddo
         ddd=ddd+dd(j)
      enddo

      do i=1,3
         vec(i)=d(i,1)*ds(1)+d(i,2)*ds(2)+d(i,3)*ds(3)+d(i,4)*ds(4)
     &         -s(i,1)*dd(1)-s(i,2)*dd(2)-s(i,3)*dd(3)-s(i,4)*dd(4)
         vec(i)=vec(i)*0.5d+00
         do j=1,3
            mat(i,j)=d(i,1)*d(j,1)+d(i,2)*d(j,2)
     &              +d(i,3)*d(j,3)+d(i,4)*d(j,4)
         enddo
         mat(i,i)=mat(i,i)-ddd
      enddo

      call inv3x3(mat(1,1),mat(1,2),mat(1,3)
     &           ,mat(2,1),mat(2,2),mat(2,3)
     &           ,mat(3,1),mat(3,2),mat(3,3)
     &           ,vec(1),vec(2),vec(3)
     &           ,x1234,y1234,z1234 ,iflag)

      !local_debug=0
      !if (local_debug.gt.0) then
      !  write(*,'(a,3f12.8)') 'using alt ',x1234,y1234,z1234
      !endif

C     ..................................................................
C     NOW FIND THE VOLUME OF THE 4-TRI QUD.
C
      call volume_tri(x1234,y1234,z1234,
     &                x1,y1,z1,
     &                x2,y2,z2,
     &                volqud)
      call volume_tri(x1234,y1234,z1234,
     &                x2,y2,z2,
     &                x3,y3,z3,
     &                voltri)
      volqud=volqud+voltri
      call volume_tri(x1234,y1234,z1234,
     &                x3,y3,z3,
     &                x4,y4,z4,
     &                voltri)
      volqud=volqud+voltri
      call volume_tri(x1234,y1234,z1234,
     &                x4,y4,z4,
     &                x1,y1,z1,
     &                voltri)
      volqud=volqud+voltri
C
      return
      end
C#######################################################################


    module fft_m
        use kind_m
        implicit none
        private
        public :: fft_window
        integer , parameter :: np2 = 9, nn = 2**np2, nn_2 = nn / 2   ! 2^9 = 512
        real(kd), parameter :: pi = 4 * atan(1.0_kd), pi2 = 2 * pi
        real(kd), parameter :: pi2_n = pi2 / nn
        integer, save :: indx(nn)
        integer, private :: i_
        complex(kd), parameter :: omega(0:*) = [(exp(cmplx(0.0_kd, pi2_n * i_, kind = kd)), i_ = 0, nn - 1)]
        real(kd)   , parameter :: hann_window(*) = [(0.5_kd * (1.0_kd - cos(pi2_n * i_))  , i_ = 0, nn - 1)]
    contains
        subroutine fft_initialize()
            integer :: i, j2, k, n
            do i = 1, nn
                n = 0
                k = i - 1
                do j2 = np2 - 1, 0, -1
                    n = n + mod(k, 2) * 2**j2
                    k = k / 2
                end do
                indx(i) = n + 1 ! indx = 1..n
            end do
        end subroutine fft_initialize

        subroutine fft_window(x, y)
            real    (kd), intent(in ) :: x(:)
            complex (kd), intent(out) :: y(:)
            logical :: qfirst = .true.
            if (qfirst) then
                qfirst = .false.
                call fft_initialize()
            end if
            y = hann_window * x / nn
            call fft2(y)
        end subroutine fft_window

        subroutine fft2(fft) ! fft_2^np2
            complex (kd), intent(in out) :: fft(:)
            complex (kd) :: tmp1, tmp2, c1
            integer :: i, j, k2, m1, m2, iphase, kn2
            fft = fft(indx)
            do k2 = 1, np2
                kn2 = 2**(k2 - 1)
                do i = 1, nn, 2* kn2
                    do j = 1, kn2
                        iphase = 2**(np2 - k2)*(j - 1)
                        c1 = omega( mod(iphase, nn) )
                        m1 = i + j - 1
                        m2 = m1 + kn2
                        tmp1 =      fft(m1)
                        tmp2 = c1 * fft(m2)
                        fft(m1) = tmp1 + tmp2 ! 1 = x^2 ; x = 1 or -1
                        fft(m2) = tmp1 - tmp2
                    end do
                end do
            end do
        end subroutine fft2
    end module fft_m


PROGRAM F023

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, DIMENSION(10000) :: ABUNDANT_NUMBERS = 0

    INTEGER :: N         = 1
    INTEGER :: COUNT_VAL = 1

    INTEGER :: I, J, J_MAX, K, COUNT_BY_2, PROPER_DIVISORS_SUM

    LOGICAL :: ABUNDANT_SUM_FOUND

    DO I = 2, 28123

        PROPER_DIVISORS_SUM = 0

        J_MAX = FLOOR(REAL(I) / 2.0)

        DO J = 1, J_MAX
            IF (MOD(I, J) == 0) PROPER_DIVISORS_SUM = PROPER_DIVISORS_SUM + J;
        END DO

        IF (PROPER_DIVISORS_SUM > I) THEN
            ABUNDANT_NUMBERS(COUNT_VAL) = I
            COUNT_VAL = COUNT_VAL + 1
        END IF

        COUNT_BY_2 = FLOOR(REAL(COUNT_VAL) / 2.0)

        ABUNDANT_SUM_FOUND = .FALSE.

        DO J = 1, COUNT_BY_2

            K = J

            DO WHILE ((ABUNDANT_NUMBERS(J) + ABUNDANT_NUMBERS(K)) < I)
                K = K + 1
            END DO

            IF ((ABUNDANT_NUMBERS(J) + ABUNDANT_NUMBERS(K)) == I) THEN
                ABUNDANT_SUM_FOUND = .TRUE.
                EXIT
            END IF

        END DO

        IF (.NOT. ABUNDANT_SUM_FOUND) N = N + I

    END DO

    PRINT ('(I0)'), N

END PROGRAM F023


C++********************************************************************
C Set of routines:
C JLP_FOURIER
C
C JLP
C Version 11-07-91
C--*******************************************************************
C JLP_FOURIER
C Computes the Fourier Transform of a real image (full of zeroes...)
C
C Zero frequency is in RE(1,1), and IM(1,1)
C
C Input:
C IMAGE: Input image
C
C Output:
C RE,IM: Real and imaginary part
C
C RE(KX,KY) = Sum on IX,IY of IMAGE(IX,IY)*COS(2*PI*(IX*(KX-1)/NX+IY*(KY-1)/NY))
C IM(KX,KY) = Sum on IX,IY of IMAGE(IX,IY)*SIN(2*PI*(IX*(KX-1)/NX+IY*(KY-1)/NY))
C
C Tests: Big improvement in accuracy
C          when X0,X1,X0,Y1,PI,ANGLE,MYCOS, and MYSIN are real*8...
C          and when DCOS and DSIN are used.
C*******************************************************************
	SUBROUTINE JLP_FOURIER(IMAGE,RE,IM,NX,NY,IDIM,ISIGN)
	PARAMETER (IDIM1=512, SMALLER_VALUE=1.E-12)
	REAL IMAGE(IDIM,*),RE(IDIM,*),IM(IDIM,*)
	REAL*8 X0,Y0,X1,Y1,SIGN
	REAL*8 PI,ANGLE
	INTEGER NX,NY,ISIGN
	REAL*8 MYCOS(IDIM1),MYSIN(IDIM1)

	PI=3.14159265358979323846
	X0=2.*PI/FLOAT(NX)
	Y0=2.*PI/FLOAT(NY)
	SIGN=FLOAT(ISIGN)

C Resetting arrays to zero:
	DO KY=1,NY
	  DO KX=1,NX
	    RE(KX,KY)=0.
	    IM(KX,KY)=0.
	  END DO
	END DO

        IF(NX.EQ.NY)THEN
C When NX=NY, we have:
C RE(KX,KY) = Sum on IX,IY of IMAGE(IX,IY)*COS((2*PI/NX)*(IX*(KX-1)+IY*(KY-1)))
C IM(KX,KY) = Sum on IX,IY of IMAGE(IX,IY)*SIN((2*PI/NX)*(IX*(KX-1)+IY*(KY-1)))
C
C Cosinus and sinus:
C MYCOS(I) = COS(2*PI*(I-1)/NX)
         DO I=1,NX
	   ANGLE=X0*FLOAT(I-1)
	   MYCOS(I)=DCOS(ANGLE)
	   MYSIN(I)=DSIN(ANGLE)
         END DO

C Fourier Transform with pre-computed cosinus and sinus :
	DO IY=1,NY
	  DO IX=1,NX
	    IF(ABS(IMAGE(IX,IY)).GT.SMALLER_VALUE)THEN
	      DO KY=1,NY
	        DO KX=1,NX
                  I=(IX-1)*(KX-1)+(IY-1)*(KY-1)
                  I=MOD(I,NX)+1
                  RE(KX,KY)=RE(KX,KY)+IMAGE(IX,IY)*MYCOS(I)
                  IM(KX,KY)=IM(KX,KY)+IMAGE(IX,IY)*MYSIN(I)
	        END DO
	      END DO
	    ENDIF
	  END DO
	END DO

        ELSE

C Fourier Transform without pre-computed cosinus and sinus:
	DO IY=1,NY
	  Y1=Y0*FLOAT(IY-1)
	  DO IX=1,NX
	    X1=X0*FLOAT(IX-1)
	    IF(ABS(IMAGE(IX,IY)).GT.SMALLER_VALUE)THEN
	      DO KY=1,NY
	        DO KX=1,NX
	          ANGLE=X1*FLOAT(KX-1)+Y1*FLOAT(KY-1)
                  RE(KX,KY)=RE(KX,KY)+IMAGE(IX,IY)*DCOS(ANGLE)
                  IM(KX,KY)=IM(KX,KY)+IMAGE(IX,IY)*DSIN(ANGLE)
	        END DO
	      END DO
	    ENDIF
	  END DO
	END DO

        ENDIF

	RETURN
	END


module eratosthenes_sieve_mod
    use,intrinsic :: iso_fortran_env
    use vector_mod
    implicit none
    public
    integer(int32),private,parameter:: prec=int32
    type:: factor_pair
        integer(prec):: val
        integer(prec):: cnt
    end type
    integer(prec), allocatable:: sieve(:)
    type(vector_int32):: primes

contains
    subroutine make_sieve(n)
        ! 初期化 O(n)
        ! 1. エラトステネスの篩の表を作る。
        ! 2. 素数集合Vectorを作る。
        integer(prec),intent(in):: n
        integer(prec):: i,j

        allocate(sieve(n),source=0_prec)
        do i=2,n
            if (sieve(i)/=0) cycle
            call primes%push_back(i)
            sieve(i) = i
            do j= i*i, n, i
                if (sieve(j)==0) sieve(j) = i
            end do
        end do
    end subroutine

    function prime_factor_vec(x) result(ret)
        ! xの素因数をvectorで返す。ex) x=24 -> vector[2,2,2,3]
        !　NEED => vector構造, sieve(初期化)
        integer(prec),value:: x
        type(vector_int32):: ret

        ! if(x==1) call ret%push_back(1_prec)
        do while(x/=1)
            call ret%push_back(sieve(x))
            x=x / sieve(x)
        end do
    end function

    function factor(x) result(ret)
        ! xの素因数の集合とそのカウントをfactor_pairの配列で返す。
        ! ex) x=720 (= 2^4 * 3^2 *5^1)
        !     i | 1 2 3 (ただの添え字)
        !   val | 2 3 5 (素因数の重複なし集合)
        !   cnt | 4 2 1 (素因数の計数)
        !
        ! NEED -> vector構造, sieve(初期化), factor_pair構造
        ! i番目の素因数の値　　　 -> ret(i)%val
        ! i番目の素因数のカウント -> ret(i)%num
        ! 素因数の重複なし集合 -> ret(:)%val

        integer(prec),intent(in):: x
        integer(prec):: i,j
        type(vector_int32):: fv
        type(factor_pair),allocatable:: tmp(:), ret(:)
        fv = prime_factor_vec(x)

        if (fv%l == 0) then
            allocate(ret(0))
            return
        end if

        allocate(tmp(fv%l), source=factor_pair(0,0))
        tmp(1)%val = fv%array(1); tmp(1)%cnt = 1
        j=1
        do i=2,fv%l
            if (fv%array(i) == fv%array(i-1)) then
                tmp(j)%cnt = tmp(j)%cnt + 1
            else
                j=j+1
                tmp(j)%val = fv%array(i)
                tmp(j)%cnt = 1
            end if
        end do
        ret = tmp(1:j)
    end function

    function is_prime(x) result(ret)
        ! xが素数なら.true. そうでないなら.false.を返す
        ! 1は素数ではないので, 1 => .false.となる。
        ! NEED　-> sieve(初期化)
        integer(prec),intent(in):: x
        logical:: ret

        ret = sieve(x) == x
    end function
end module


program ch1301
    ! Quadratic Roots
    implicit none

    real :: a, b, c
    real :: term, a2
    real :: root1, root2

    print *, 'give the coefficients a, b and c'
    read *, a, b, c
    term = b*b - 4.*a*c
    a2 = a*2.
    if (term<0.) then
        print *, 'roots are complex'
    elseif (term>0.) then
        term = sqrt(term)
        root1 = (-b+term)/a2
        root2 = (-b-term)/a2
        print *, 'roots are ', root1, ' and ', root2
    else
        root1 = -b/a2
        print *, 'roots are equal, at ', root1
    end if
end program


! ---------------------------------------------------------------
! This program computes all Armstrong numbers in the range of
! 0 and 999.  An Armstrong number is a number such that the sum
! of its digits raised to the third power is equal to the number
! itself.  For example, 371 is an Armstrong number, since
! 3**3 + 7**3 + 1**3 = 371.
! ---------------------------------------------------------------

PROGRAM  ArmstrongNumber
   IMPLICIT  NONE

   INTEGER :: a, b, c                   ! the three digits
   INTEGER :: abc, a3b3c3               ! the number and its cubic sum
   INTEGER :: Count                     ! a counter

   Count = 0
   DO a = 0, 9                          ! for the left most digit
      DO b = 0, 9                       !   for the middle digit
         DO c = 0, 9                    !     for the right most digit
            abc    = a*100 + b*10 + c   !        the number
            a3b3c3 = a**3 + b**3 + c**3 !        the sum of cubes
            IF (abc == a3b3c3) THEN     !        if they are equal
               Count = Count + 1        !           count and display it
               WRITE(*,*)  'Armstrong number ', Count, ': ', abc
            END IF
         END DO
      END DO
   END DO

END PROGRAM  ArmstrongNumber


program multi_dimensional_bruteforce_mc

      !Author : Anantha Rao
      ! Reg no : 20181044
      ! 6D (x1,x2,x3,x4,x5,x6) Integral
      implicit none
      integer:: n,i,j
      real*8 :: x(6), y, func, int_mc, var, sigma, p(6)
      ! p : Dummy argument for random number generator (6 values)
      real*8 :: length, volume

      length=5.0d0 ! use one side of each dimension (0,5)
      volume=(2.0d0*length)**6  ! volume of 6D space

      open(unit=1, file="20181044_multi_brute_mc.dat")
      n=1

      ! Initiate variables

print *,"Welcome to this program.&
& This program solves mutidimensional integral using Monte-Carlo rule"

    7 int_mc=0.0d0
      var=0.0d0
      sigma=0.0d0
      write(*,10) n
      10 format("Computig for n=",i10)

      do i=1,n
        call random_number(p)
        do j=1,6
            x(j) = -length + 2.0d0*length*p(j)
        end do
        int_mc=int_mc+func(x)
        sigma=sigma+func(x)*func(x)
      end do

      int_mc = int_mc/real(n)
      sigma=sigma/real(n)
      var=sigma-int_mc*int_mc

      int_mc = volume*int_mc
      sigma=volume*sqrt(var/real(n))

      write(1,*) n, "", int_mc, "", sigma

      ! begin automation
      n=n*10
      if (n .lt. 1000000000 ) goto 7
      print*,"Done! Output stored in file 20181044_multi_brute_mc.dat"
      ! end automation

end program

real*8 function func(x)
      implicit none
      real*8::x(6), xx, yy, xy
      real*8::a,b
      a=1.0d0
      b=0.5d0

      xx= x(1)*x(1) + x(2)*x(2) + x(3)*x(3)
      yy= x(4)*x(4) + x(5)*x(5) + x(6)*x(6)
      xy= (x(1)-x(4))**2 + (x(2)-x(5))**2 + (x(3)-x(6))**2
      func=exp(-a*xx - a*yy - b*xy)

end function