! extends MESA constants and updates them to CODATA 2010 values

module constants_def
    use const_def

    implicit none

    ! mathematical constants
    real(dp), parameter :: twopi            = 2.0_dp*pi
    real(dp), parameter :: threepi          = 3.0_dp*pi
    real(dp), parameter :: fourpi           = 4.0_dp*pi
    real(dp), parameter :: onethird         = one_third
    real(dp), parameter :: twothird         = two_thirds
    real(dp), parameter :: fivethird        = 5.0_dp*onethird
    real(dp), parameter :: seventhird       = 7.0_dp*onethird
    real(dp), parameter :: threepisquare    = (3.0_dp*pi**2)

    ! physical and astronomical constants, in cgs units
    real(dp), save :: boltzmann        ! = 1.3806488e-16_dp
    real(dp), save :: avogadro         ! = 6.02214129e23_dp
    real(dp), save :: clight2                  ! = clight**2
    real(dp), save :: sigma_SB                 ! = 5.670400e-5
    real(dp), save :: arad                         ! = sigma_SB*4.0/clight
    real(dp), save :: finestructure        ! = 7.2973525698e-3_dp
    real(dp), save :: Gnewton                  ! = 6.67384e-8_dp
    real(dp), save :: Mneutron                 ! = 1.674927351e-24_dp
    real(dp), save :: Mproton                  ! = 1.672621777e-24_dp
    real(dp), save :: si_charge                ! = 1.602176565e-19_dp
    real(dp), save :: electroncharge       ! = si_charge*clight*0.1_dp
    real(dp), save :: Melectron                ! = 9.10938291e-28_dp
    real(dp), save :: Mmuon                        ! = 1.883531475e-25_dp
    real(dp), save :: theta_weak               ! = 0.2223_dp

    ! astronomical constants -- see http://ssd.jpl.nasa.gov/?constants
    real(dp), save :: julian_day               ! = 86400_dp
    real(dp), save :: julian_year          ! = 365.25_dp * julian_day
    real(dp), save :: GMsun                        ! = 1.32712440018e26_dp

    ! some conversion factors
    real(dp), save :: fm_to_cm         ! = 1.0e-13_dp
    real(dp), save :: ergs_to_mev          ! = 1.0_dp/mev_to_ergs
    real(dp), save :: cm_to_fm                 ! = 1.0_dp/fm_to_cm

    ! atomic units (length in Bohr radii for hydrogen, energy in Rydberg)
    real(dp), save :: a_Bohr                       ! = hbar**2/Melectron/electroncharge**2
    real(dp), save :: Rydberg                  ! = 0.5_dp*electroncharge**2/a_Bohr

    ! nuclear units (c = 1, hbar = 197 MeV fm; energy is expressed in MeV, length in fm)
    real(dp), save :: hbarc_n              ! = hbar*clight/mev_to_ergs/fm_to_cm
    real(dp), save :: mass_n                       ! = mev_to_ergs/clight2
    real(dp), save :: length_n                 ! = fm_to_cm
    real(dp), save :: density_n                ! = 1.0_dp/fm_to_cm**3
    real(dp), save :: pressure_n               ! = mev_to_ergs*density_n
    real(dp), save :: temperature_n        ! = mev_to_ergs/boltzmann
    real(dp), save :: Mn_n                         ! = Mneutron*clight2*ergs_to_mev
    real(dp), save :: Mp_n                         ! = Mproton*clight2*ergs_to_mev
    real(dp), save :: Me_n                         ! = Melectron*clight2*ergs_to_mev
    real(dp), save :: amu_n                        ! = amu*clight2*ergs_to_mev

    ! gravitational units (G = c = 1; unit of mass is Msun)
    real(dp), save :: mass_g                       ! = Msun
    real(dp), save :: potential_g          ! = clight2
    real(dp), save :: length_g                 ! = Gnewton*mass_g/potential_g
    real(dp), save :: density_g                ! = mass_g/length_g**3
    real(dp), save :: pressure_g               ! = density_g*potential_g
    real(dp), save :: time_g                       ! = length_g/clight

contains

    subroutine initialize_constants

        boltzmann           = 1.3806488e-16_dp
        avogadro            = 6.02214129e23_dp
        clight              = 2.99792458e10_dp
        clight2             = clight**2
        sigma_SB            = 5.670400e-5
        arad                = sigma_SB*4.0/clight
        amu                 = 1.660538921e-24_dp
        hbar                = 1.054571726e-27_dp
        finestructure       = 7.2973525698e-3_dp
        Gnewton             = 6.67384e-8_dp
        Mneutron            = 1.674927351e-24_dp
        Mproton             = 1.672621777e-24_dp
        si_charge           = 1.602176565e-19_dp
        electroncharge      = si_charge*clight*0.1_dp
        Melectron           = 9.10938291e-28_dp
        Mmuon               = 1.883531475e-25_dp
        theta_weak          = 0.2223_dp

        julian_day          = 86400_dp
        julian_year         = 365.25_dp * julian_day
        GMsun               = 1.32712440018e26_dp
        Msun                = GMsun/Gnewton

        mev_to_ergs         = 1.602176565e-6_dp
        fm_to_cm            = 1.0e-13_dp
        ergs_to_mev         = 1.0_dp/mev_to_ergs
        cm_to_fm            = 1.0_dp/fm_to_cm

        a_Bohr              = hbar**2/Melectron/electroncharge**2
        Rydberg             = 0.5_dp*electroncharge**2/a_Bohr

        hbarc_n             = hbar*clight/mev_to_ergs/fm_to_cm
        mass_n              = mev_to_ergs/clight2
        length_n            = fm_to_cm
        density_n           = 1.0_dp/fm_to_cm**3
        pressure_n          = mev_to_ergs*density_n
        temperature_n       = mev_to_ergs/boltzmann
        Mn_n                = Mneutron*clight2*ergs_to_mev
        Mp_n                = Mproton*clight2*ergs_to_mev
        Me_n                = Melectron*clight2*ergs_to_mev
        amu_n               = amu*clight2*ergs_to_mev

        mass_g              = Msun
        potential_g         = clight2
        length_g            = Gnewton*mass_g/potential_g
        density_g           = mass_g/length_g**3
        pressure_g          = density_g*potential_g
        time_g              = length_g/clight

        standard_cgrav = Gnewton
        ! gravitational constant (g^-1 cm^3 s^-2)
        planck_h = hbar*2.0*pi
        ! Planck's constant (erg s)
        qe = electroncharge
        ! electron charge (esu == (g cm^3 s^-2)^(1/2))
        avo = avogadro
        ! Avogadro's constant (mole^-1)
        kerg = boltzmann
        ! Boltzmann's constant (erg K^-1)
        boltzm = kerg
        cgas = boltzm*avo !ideal gas constant; erg/K
        kev = 8.617385d-5
        ! converts temp to ev (ev K^-1)

        mn = Mneutron! neutron mass (g)
        mp = Mproton ! proton mass (g)
        me = Melectron ! (was 9.1093897d-28) electron mass (g)
        rbohr = a_Bohr ! Bohr radius (cm)
        fine = finestructure ! fine structure constant
        ev2erg = 1.602176487d-12 ! electron volt (erg)
        hion = Rydberg/ev2erg ! hydrogen ionization energy (eV)
        mev_amu = mev_to_ergs/amu
        Qconv = mev_to_ergs*avo

        boltz_sigma = sigma_SB
        ! boltzmann's sigma = a*c/4 (erg cm^-2 K^-4 s^-1)
        crad = arad
        ! = radiation density constant, a (erg cm^-3 K^-4); Prad = crad * T^4 / 3
        ! approx = 7.5657e-15

        ssol = boltz_sigma
        asol = crad
        weinlam = planck_h*clight/(kerg * 4.965114232d0)
        weinfre = 2.821439372d0*kerg/planck_h
        rhonuc = 2.342d14 ! density of nucleus (g cm^3)

        ! solar age, L, and R values from Bahcall et al, ApJ 618 (2005) 1049-1056.
        msol = Msun  ! solar mass (g)  <<< gravitational mass, not baryonic
        rsol = 6.9598d10 ! solar radius (cm)
        lsol = 3.8418d33  ! solar luminosity (erg s^-1)
        agesol = 4.57d9  ! solar age (years)
        Rsun = rsol
        Lsun = lsol
        Msun33 = msol*1d-33
        Rsun11 = rsol*1d-11
        Lsun33 = lsol*1d-33
        ly = 9.460528d17 ! light year (cm)
        pc = 3.261633d0 * ly ! parsec (cm)
        secyer = 3.1558149984d7 ! seconds per year

        m_earth = 5.9764d27 ! earth mass (g)
        ! = 3.004424e-6 Msun
        r_earth = 6.37d8 ! earth radius (cm)
        au = 1.495978921d13 ! astronomical unit (cm)

        m_jupiter = 1.8986d30 ! jupiter mass (g)
        ! = 0.954454d-3 Msun
        r_jupiter = 6.9911d9 ! jupiter mean radius (cm)
        semimajor_axis_jupiter = 7.7857d13 ! jupiter semimajor axis (cm)

    end subroutine initialize_constants

end module constants_def


*     MC01VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
*     .. Local Scalars ..
      DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE
      INTEGER          INFO
*     .. External Subroutines ..
      EXTERNAL         MC01VD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) A, B, C
*     Solve the quadratic equation A*x**2 + B*x + C = 0.
      CALL MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO )
*
      IF ( INFO.NE.0 ) THEN
         WRITE ( NOUT, FMT = 99998 ) INFO
      ELSE
         WRITE ( NOUT, FMT = 99997 )
         WRITE ( NOUT, FMT = 99996 ) Z1RE, Z1IM, Z2RE, Z2IM
      END IF
*
      STOP
*
99999 FORMAT (' MC01VD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01VD = ',I2)
99997 FORMAT (' The roots of the quadratic equation are ')
99996 FORMAT (/' x = ',F8.4,2X,SP,F8.4,'*j',SS,/' x = ',F8.4,2X,SP,F8.4,
     $       '*j')
      END


PROGRAM F027

    ! Copyright 2021 Melwyn Francis Carlo
    ! FILE REFERENCE: http://www.naturalnumbers.org/primes.html

    IMPLICIT NONE

    INTEGER :: PRIME_NUM
    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/003/PrimeNumbers_Upto_1000000"

    INTEGER, DIMENSION(1000) :: PRIMES_LIST

    INTEGER :: A       = -999
    INTEGER :: B_COUNT =    0

    INTEGER :: A_MAX   = 0
    INTEGER :: B_MAX   = 0
    INTEGER :: N_MAX   = 0

    INTEGER :: I = 1

    INTEGER :: B, N, J, MAX_PRIME

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    DO WHILE (I /= 1000)
        READ(2, *, END=10) PRIME_NUM
        IF (PRIME_NUM < 1000) B_COUNT = B_COUNT + 1
        PRIMES_LIST(I) = PRIME_NUM
        I = I + 1
    END DO

    10 CLOSE(2)

    DO WHILE (A < 1000)

        B = 1
        DO WHILE (B < B_COUNT)

            N = 1
            J = 1
            MAX_PRIME = (N * N) + (A * N) + PRIMES_LIST(B)

            DO WHILE (J < 1000)

                IF (PRIMES_LIST(J) > MAX_PRIME) EXIT

                IF (MAX_PRIME == PRIMES_LIST(J)) THEN
                    N = N + 1
                    J = 1
                    MAX_PRIME = (N * N) + (A * N) + PRIMES_LIST(B)
                    CYCLE
                END IF

                J = J + 1

            END DO

            IF (N > N_MAX) THEN
                N_MAX = N
                A_MAX = A
                B_MAX = PRIMES_LIST(B)
            END IF

            B = B + 1

        END DO

        A = A + 1

    END DO

    PRINT ('(I0)'), A_MAX * B_MAX

END PROGRAM F027


!-------------------------------------------------------------------------------
subroutine chgm ( a, b, x, hg )

!*****************************************************************************80
!
!! CHGM computes the confluent hypergeometric function M(a,b,x).
!
!  Licensing:
!
!    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!    they give permission to incorporate this routine into a user program
!    provided that the copyright is acknowledged.
!
!  Modified:
!
!    27 July 2012
!
!  Author:
!
!    Shanjie Zhang, Jianming Jin
!
!  Reference:
!
!    Shanjie Zhang, Jianming Jin,
!    Computation of Special functions,
!    Wiley, 1996,
!    ISBN: 0-471-11963-6,
!    LC: QA351.C45.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, B, parameters.
!
!    Input, real ( kind = 8 ) X, the argument.
!
!    Output, real ( kind = 8 ) HG, the value of M(a,b,x).
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) a0
  real ( kind = 8 ) a1
  !real ( kind = 8 ) aa
  real ( kind = 8 ) b
  real ( kind = 8 ) hg
  real ( kind = 8 ) hg1
  real ( kind = 8 ) hg2
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) la
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n
  integer ( kind = 4 ) nl
  real ( kind = 8 ) pi
  real ( kind = 8 ) r
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) rg
  real ( kind = 8 ) sum1
  real ( kind = 8 ) sum2
  real ( kind = 8 ) ta
  real ( kind = 8 ) tb
  real ( kind = 8 ) tba
  real ( kind = 8 ) x
  real ( kind = 8 ) x0
  real ( kind = 8 ) xg
  real ( kind = 8 ) y0
  real ( kind = 8 ) y1

  pi = 3.141592653589793D+00
  a0 = a
  a1 = a
  x0 = x
  hg = 0.0D+00

  if ( b == 0.0D+00 .or. b == - abs ( int ( b ) ) ) then
    hg = 1.0D+300
  else if ( a == 0.0D+00 .or. x == 0.0D+00 ) then
    hg = 1.0D+00
  else if ( a == -1.0D+00 ) then
    hg = 1.0D+00 - x / b
  else if ( a == b ) then
    hg = exp ( x )
  else if ( a - b == 1.0D+00 ) then
    hg = ( 1.0D+00 + x / b ) * exp ( x )
  else if ( a == 1.0D+00 .and. b == 2.0D+00 ) then
    hg = ( exp ( x ) - 1.0D+00 ) / x
  else if ( a == int ( a ) .and. a < 0.0D+00 ) then
    m = int ( - a )
    r = 1.0D+00
    hg = 1.0D+00
    do k = 1, m
      r = r * ( a + k - 1.0D+00 ) / k / ( b + k - 1.0D+00 ) * x
      hg = hg + r
    end do
  end if

  if ( hg /= 0.0D+00 ) then
    return
  end if

  if ( x < 0.0D+00 ) then
    a = b - a
    a0 = a
    x = abs ( x )
  end if

  if ( a < 2.0D+00 ) then
    nl = 0
  end if

  if ( 2.0D+00 <= a ) then
    nl = 1
    la = int ( a )
    a = a - la - 1.0D+00
  end if

  do n = 0, nl

    if ( 2.0D+00 <= a0 ) then
      a = a + 1.0D+00
    end if

    if ( x <= 30.0D+00 + abs ( b ) .or. a < 0.0D+00 ) then

      hg = 1.0D+00
      rg = 1.0D+00
      do j = 1, 500
        rg = rg * ( a + j - 1.0D+00 ) &
          / ( j * ( b + j - 1.0D+00 ) ) * x
        hg = hg + rg
        if ( abs ( rg / hg ) < 1.0D-15 ) then
          exit
        end if
      end do

    else

      ta = gamma(a)
      tb = gamma(b)
      xg = b - a
      tba = gamma(xg)
      sum1 = 1.0D+00
      sum2 = 1.0D+00
      r1 = 1.0D+00
      r2 = 1.0D+00
      do i = 1, 8
        r1 = - r1 * ( a + i - 1.0D+00 ) * ( a - b + i ) / ( x * i )
        r2 = - r2 * ( b - a + i - 1.0D+00 ) * ( a - i ) / ( x * i )
        sum1 = sum1 + r1
        sum2 = sum2 + r2
      end do
      hg1 = tb / tba * x ** ( - a ) * cos ( pi * a ) * sum1
      hg2 = tb / ta * exp ( x ) * x ** ( a - b ) * sum2
      hg = hg1 + hg2

    end if

    if ( n == 0 ) then
      y0 = hg
    else if ( n == 1 ) then
      y1 = hg
    end if

  end do

  if ( 2.0D+00 <= a0 ) then
    do i = 1, la - 1
      hg = ( ( 2.0D+00 * a - b + x ) * y1 + ( b - a ) * y0 ) / a
      y0 = y1
      y1 = hg
      a = a + 1.0D+00
    end do
  end if

  if ( x0 < 0.0D+00 ) then
    hg = hg * exp ( x0 )
  end if

  a = a1
  x = x0

  return
end


      SUBROUTINE DCPDRV (C,NC,D,ND)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 DCPDRV Krogh   Declared all vars.
C>> 1994-10-20 DCPDRV Krogh  Changes to use M77CON
C>> 1987-12-09 DCPDRV Lawson  Initial code.
c--D replaces "?": ?CPDRV
      INTEGER NC, ND, J, K
      DOUBLE PRECISION C(*),D(*),D1,D2,FAC,ZERO,HALF,TWO
      DATA ZERO,HALF,TWO/ 0.D0, .5D0, 2.D0 /
C
C     INTEGRATION OF FINITE CHEBYSHEV SERIES
C     C.L.LAWSON, JPL, 1973 JULY 19
C
C     (C(I),I=1,2)       SCALE FACTORS .
C     C(I+2),I=1,NC+1    COEFS OF CHEBY SERIES .
C     NC                 DEGREE OF CHEBY SERIES .
C     (D(I),I=1,2)       OUTPUT..  SCALE FACTORS .
C     (D(I+2),I=1,ND+1)  OUTPUT..  COEFS DEFINING DIFFERENTIATED
C                                  SERIES .
C     ND                 OUTPUT..  DEGREE OF SERIES
C
      IF (NC .LT. 0) THEN
        CALL IERM1('DCPDRV',1,0,'REQUIRE NC .GE. 0','NC',NC,'.')
      ELSE
        D(1)=C(1)
        D(2)=C(2)
        IF (NC .EQ. 0) THEN
          ND=0
          D(3)=ZERO
          RETURN
        END IF
        D2=ZERO
        ND=NC-1
        IF(ND .NE. 0) THEN
          D1=ZERO
          FAC=2*NC
          DO 20 J=1,ND
            D(ND+4-J)= FAC*C(ND+5-J) + D2
            D2=D1
            D1=D(ND+4-J)
   20       FAC=FAC-TWO
        END IF
        D(3)=C(4) + D2*HALF
        DO 40 K=1,NC
   40     D(K+2)=D(K+2)/D(2)
      END IF
      RETURN
      END


	REAL FUNCTION TCRVALUE(ALPHA,N)
	USE MSIMSL
C
C-Description-----------------------------------------------------------
	IMPLICIT NONE
C
C  Function:
C	Calculate the critical t value tn such that pr[t>tn]=alpha
C	where t has a t distribution with n degrees of freedom.
C  Usage:
C	PS program
C  Arguments:
C   i	ALPHA		(real*4)
C   i	N		(real*4)
C  Notes:
C   .	This routine was written by Dale Plummer
C   .	Designed by Dr. William Dupont
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
	REAL ALPHA
	REAL N
C
C  Functions
C
	REAL G,ZCRVALUE
	EXTERNAL G
C
C  Locals
C
	REAL T,N0
C
C  Common to pass values to the function g.
C
	REAL GALPHA
	REAL GN
	COMMON /GCOM/GALPHA,GN

	REAL*4 EPS, ERRABS, ERRREL, ETA
	INTEGER*4 ITMAX, NROOT

C-Code------------------------------------------------------------------
C
	ERRABS=1.0E-5
	EPS=1.0E-5
	ERRREL=1.0E-5
	ETA=1.0E-2
	ITMAX=100
	NROOT=1
C
C    Copy values to common so they can be used in the G function.
C
	GALPHA=ALPHA
	GN=N
C
C    Use secant method.
C
	N0=ZCRVALUE(ALPHA)
	CALL ZERO(G,N0,0.00001,T)
	TCRVALUE=T
C
C    Solve the equation G(x)=0.

CCC	XGUESS(1)=ZCRVALUE(ALPHA)
CCC	CALL ZREAL(G,ERRABS,ERRREL,EPS,ETA,NROOT,ITMAX,
CCC     .			   XGUESS,XVECT,INFO)
C
C    If convergence was not reached then INFO(1) will be greater than
C    ITMAX.  Check for that here.  Force a divide by zero error that will
C    signal an error to the calling (Visual Basic) program.
C
CCC	IF (INFO(1).GT.ITMAX) THEN
CCC		NROOT=NROOT/0.0
CCC		RETURN
CCC	END IF
C
C	The result is in XVECT(1).
C
CCC	TCRVALUE=XVECT(1)
C
C    Return.
C
	RETURN
	END


subroutine laguer_sp(a,x,its)
  use mo_kind,   only : i4, sp, spc
  use mo_nrutil, only : nrerror, poly, poly_term

  implicit none

  integer(i4),                intent(out)   :: its
  complex(spc),               intent(inout) :: x
  complex(spc), dimension(:), intent(in)    :: a
  real(sp),     parameter                   :: eps=epsilon(1.0_sp)
  integer(i4),  parameter                   :: mr=8,mt=10,maxit=mt*mr
  integer(i4)                               :: iter,m
  real(sp)                                  :: abx,abp,abm,err
  complex(spc)                              :: dx,x1,f,g,h,sq,gp,gm,g2
  complex(spc), dimension(size(a))          :: b,d
  real(sp),     dimension(mr)               :: frac = &
       (/ 0.5_sp,0.25_sp,0.75_sp,0.13_sp,0.38_sp,0.62_sp,0.88_sp,1.0_sp /)

  m=size(a)-1
  do iter=1,maxit
     its=iter
     abx=abs(x)
     b(m+1:1:-1)=poly_term(a(m+1:1:-1),x)
     d(m:1:-1)=poly_term(b(m+1:2:-1),x)
     f=poly(x,d(2:m))
     err=eps*poly(abx,abs(b(1:m+1)))
     if (abs(b(1)) <= err) return
     g=d(1)/b(1)
     g2=g*g
     h=g2-2.0_sp*f/b(1)
     sq=sqrt((m-1)*(m*h-g2))
     gp=g+sq
     gm=g-sq
     abp=abs(gp)
     abm=abs(gm)
     if (abp < abm) gp=gm
     if (max(abp,abm) > 0.0_sp) then
        dx=m/gp
     else
        dx=exp(cmplx(log(1.0_sp+abx),iter,kind=spc))
     end if
     x1=x-dx
     if (x == x1) return
     if (mod(iter,mt) /= 0) then
        x=x1
     else
        x=x-dx*frac(iter/mt)
     end if
  end do
  call nrerror('laguer: too many iterations')
end subroutine laguer_sp

subroutine laguer_dp(a,x,its)
  use mo_kind,   only : i4, dp, dpc
  use mo_nrutil, only : nrerror, poly, poly_term

  implicit none

  integer(i4),                intent(out)   :: its
  complex(dpc),               intent(inout) :: x
  complex(dpc), dimension(:), intent(in)    :: a
  real(dp),     parameter                   :: eps=epsilon(1.0_dp)
  integer(i4),  parameter                   :: mr=8,mt=10,maxit=mt*mr
  integer(i4)                               :: iter,m
  real(dp)                                  :: abx,abp,abm,err
  complex(dpc)                              :: dx,x1,f,g,h,sq,gp,gm,g2
  complex(dpc), dimension(size(a))          :: b,d
  real(dp),     dimension(mr)               :: frac = &
       (/ 0.5_dp,0.25_dp,0.75_dp,0.13_dp,0.38_dp,0.62_dp,0.88_dp,1.0_dp /)

  m=size(a)-1
  do iter=1,maxit
     its=iter
     abx=abs(x)
     b(m+1:1:-1) = poly_term(a(m+1:1:-1),x)
     d(m:1:-1)   = poly_term(b(m+1:2:-1),x)
     f           = poly(x,d(2:m))
     err=eps*poly(abx,abs(b(1:m+1)))
     if (abs(b(1)) <= err) return
     g=d(1)/b(1)
     g2=g*g
     h=g2-2.0_dp*f/b(1)
     sq=sqrt((m-1)*(m*h-g2))
     gp=g+sq
     gm=g-sq
     abp=abs(gp)
     abm=abs(gm)
     if (abp < abm) gp=gm
     if (max(abp,abm) > 0.0_dp) then
        dx=m/gp
     else
        dx=exp(cmplx(log(1.0_dp+abx),iter,kind=dpc))
     end if
     x1=x-dx
     if (x == x1) return
     if (mod(iter,mt) /= 0) then
        x=x1
     else
        x=x-dx*frac(iter/mt)
     end if
  end do
  call nrerror('laguer: too many iterations')
end subroutine laguer_dp


      MODULE GEOMETRY	!Limited scope.
       CHARACTER*(*) SQUAWK(-3:2)	!Holds a schedule of complaints.
       PARAMETER (SQUAWK = (/		!According to what might go wrong.
     3  "No circles: points are more than 2R apart.",
     2  "Innumerable circles: co-incident points, R > 0.",
     1  "One 'circle', centred on the co-incident points. R is zero!",
     o  "No circles! R is negative!",
     1  "One circle: points are 2R apart.",
     2  "Two circles."/))		!This last is the hoped-for state.
      CONTAINS	!Now for the action.
       SUBROUTINE BUBBLE(P,R,N)	!Finds circles of radius R passing through two points.
        COMPLEX P(2)	!The two points. Results returned here.
        REAL R		!The specified radius.
        INTEGER N	!Indicates how many centres are valid.
        COMPLEX MID,DP	!Geometrical assistants.
         DP = (P(2) - P(1))/2	!Or, the other way around.
         D = ABS(DP)		!Half the separation is useful.
         IF (R.LT.0) THEN	!Is the specified radius silly?
           N =  0			!Yes. No circles, then.
         ELSE IF (D.EQ.0) THEN	!Any distance between the points?
           IF (R.EQ.0) THEN		!No. Zero radius?
             N = -1				!Yes. So a degenerate "circle" of zero radius.
            ELSE			!A negative radius being tested for above,
             N = -2				!A swirl of circles around the midpoint.
           END IF		!So much for co-incident points.
         ELSE IF (D.GT.R) THEN	!Points too far apart?
           N = -3			!A circle of radius R can't reach them.
         ELSE IF (D.EQ.R) THEN	!Maximum separation for R?
           N = 1			!Yes. The two circles lie atop each other.
           P(1) = (P(1) + P(2))/2	!Both centres are on the midpoint, but N = 1.
         ELSE			!Finally, the ordinary case.
           N = 2			!Two circles.
           MID = (P(1) + P(2))/2	!Midway between the two points.
           D = SQRT((R/D)**2 - 1)	!Rescale vector DP.
           P = MID + DP*CMPLX(0,(/+D,-D/))	!Array (0,+D), (0,-D)
         END IF				!P(1) = DP*CMPLX(0,+D) and P(2) = DP*CMPLX(0,-D)
       END SUBROUTINE BUBBLE	!Careful! P and N are modified.
      END MODULE GEOMETRY	!Not much.

      PROGRAM POKE	!A tester.
      USE GEOMETRY	!Useful to I. Newton.
      COMPLEX P(2)		!A pair of points.
      REAL PP(4)		!Also a pair.
      EQUIVALENCE (P,PP)	!Since free-format input likes (x,y), not x,y
      REAL R			!This is not complex.
      INTEGER MSG,IN		!I/O unit numbers.
      MSG = 6			!Standard output.
      OPEN (MSG, RECL = 120)	!For "formatted" files, this length is in characters.
      IN = 10			!For the disc file holding the test data.
      WRITE (MSG,1)		!Announce.
    1 FORMAT ("Given two points and a radius, find the centres "
     1 "of circles of that radius passing through those points.")

      OPEN (IN,FILE="Circle.csv", STATUS = "OLD", ACTION="READ")	!Have data, will compute.
   10 READ (IN,*,END = 20) PP,R		!Get two points and a radius.
      WRITE (MSG,*)			!Set off.
      WRITE (MSG,*) P,R			!Show the input.
      CALL BUBBLE(P,R,N)		!Calculate.
      WRITE (MSG,*) P(1:N),SQUAWK(N)	!Show results.
      GO TO 10				!Try it again.

   20 CLOSE(IN)		!Finihed with input.
      END	!Finished.


module funcs
use, intrinsic:: iso_fortran_env, only: sp=>real32, dp=>real64
implicit none (type, external)

interface addtwo
procedure addtwo_s, addtwo_d, addtwo_i
end interface addtwo

contains

elemental real(sp) function addtwo_s(x) result(y)
real(sp), intent(in) :: x

y = x + 2
end function addtwo_s

elemental real(dp) function addtwo_d(x) result(y)
real(dp), intent(in) :: x

y = x + 2
end function addtwo_d

elemental integer function addtwo_i(x) result(y)
integer, intent(in) :: x

y = x + 2
end function addtwo_i

end module funcs

program test2

use funcs
implicit none (type, external)

real(sp) :: twos = 2._sp
real(dp) :: twod = 2._dp
integer :: twoi = 2

print *, addtwo(twos), addtwo(twod), addtwo(twoi)

end program


! test_quasirandom.f90 --
!     Simple test of the quasi-random points generator
!
!     The algorithm is based on:
!     "The Unreasonable Effectiveness of Quasirandom Sequences" by Martin Roberts,
!     http://extremelearning.com.au/unreasonable-effectiveness-of-quasirandom-sequences/
!
!     TODO:
!     Support for points on a circle, disk, sphere or ball
!     Integration
!

! test_quasirandom
!     Simple test program
!
program test_quasirandom
    use quasirandom

    implicit none

    integer, parameter :: dp = kind(1.0d0)

    type(quasirandom_generator) :: q, qcircle, qdisk, qsphere, qball

    real, dimension(1)          :: coords
    real, dimension(2)          :: coords2
    real, dimension(3)          :: coords3
    real                        :: radius2

    real(kind=dp), dimension(1) :: dcoords
    real(kind=dp), dimension(2) :: dcoords2
    real(kind=dp), dimension(3) :: dcoords3
    real(kind=dp)               :: dradius2

    integer                     :: i, points_in, points_off, points_x, points_y, points_z

    write( *, * ) 'SINGLE-PRECISION VERSION'
    write( *, * ) '------------------------'

    call q%init( 1 )

    write( *, * ) 'Quasirandom points on the interval [0,1]:'
    do i = 1,10
        call q%next( coords )
        write( *, * ) i, coords
    enddo

    call q%init( 3 )

    write( *, * ) 'Quasirandom points on the unit cube [0,1]^3:'
    do i = 1,10
        call q%next( coords3 )
        write( *, * ) i, coords3
    enddo

    !
    ! Test the special forms:
    ! - For circle and sphere:
    !   - the length of the vector should be one
    !   - the number of points with x > 0.7 should be roughly equal to
    !     the number of points with y > 0.7
    ! - For disk and ball:
    !   - the number of points with distance to the origin less than 0.5
    !     should roughly be 1/4 and 1/8 of the total
    !   - the number of points with x > 0.7 should be roughly equal to
    !     the number of points with y > 0.7 and to the number of points
    !     with z > 0.7
    !
    write( *, * ) 'Quasirandom points on a circle:'

    points_off = 0
    points_x   = 0
    points_y   = 0
    call qcircle%init( quasi_circle )
    do i = 1,1000
        call qcircle%next( coords2 )
        radius2 = sum( coords2 ** 2 )
        if ( abs(radius2 - 1.0) > 1.0e-6 ) then
            points_off = points_off + 1
        endif
        if ( coords2(1) > 0.7 ) then
            points_x = points_x  + 1
        endif
        if ( coords2(2) > 0.7 ) then
            points_y = points_y  + 1
        endif
    enddo

    write( *, * ) 'Number of points off the circle:  ', points_off
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y

    write( *, * ) 'Quasirandom points on a disk:'
    points_in  = 0
    points_x   = 0
    points_y   = 0
    call qdisk%init( quasi_disk )
    do i = 1,1000
        call qdisk%next( coords2 )
        radius2 = sum( coords2 ** 2 )
        if ( radius2 < 0.25 ) then
            points_in = points_in + 1
        endif
        if ( coords2(1) > 0.7 ) then
            points_x = points_x  + 1
        endif
        if ( coords2(2) > 0.7 ) then
            points_y = points_y  + 1
        endif
    enddo

    write( *, * ) 'Number of points inner part of disk:  ', points_in, ' - expected: ', 1000/4
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y

    !
    ! Sphere and ball
    !
    write( *, * ) 'Quasirandom points on a sphere:'

    points_off = 0
    points_x   = 0
    points_y   = 0
    points_z   = 0
    call qsphere%init( quasi_sphere )
    do i = 1,1000
        call qsphere%next( coords3 )
        radius2 = sum( coords3 ** 2 )
        if ( abs(radius2 - 1.0) > 1.0e-6 ) then
            points_off = points_off + 1
        endif
        if ( coords3(1) > 0.7 ) then
            points_x = points_x  + 1
        endif
        if ( coords3(2) > 0.7 ) then
            points_y = points_y  + 1
        endif
        if ( coords3(3) > 0.7 ) then
            points_z = points_z  + 1
        endif
    enddo

    write( *, * ) 'Number of points off the sphere:  ', points_off
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y
    write( *, * ) 'Number of points above of z = 0.7:', points_z

    write( *, * ) 'Quasirandom points on a ball:'
    points_in  = 0
    points_x   = 0
    points_y   = 0
    points_z   = 0
    call qball%init( quasi_ball )
    do i = 1,1000
        call qball%next( coords3 )
        radius2 = sum( coords3 ** 2 )
        if ( radius2 < 0.25 ) then
            points_in = points_in + 1
        endif
        if ( coords3(1) > 0.7 ) then
            points_x = points_x  + 1
        endif
        if ( coords3(2) > 0.7 ) then
            points_y = points_y  + 1
        endif
        if ( coords3(3) > 0.7 ) then
            points_z = points_z  + 1
        endif
    enddo

    write( *, * ) 'Number of points inner part of ball:  ', points_in, ' - expected: ', 1000/8
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y
    write( *, * ) 'Number of points above of z = 0.7:', points_z

    !
    ! "Just" a copy of the previous code
    !
    write( *, * ) ''
    write( *, * ) 'DOUBLE-PRECISION VERSION'
    write( *, * ) '------------------------'

    call q%init( 1 )

    write( *, * ) 'Quasirandom points on the interval [0,1]:'
    do i = 1,10
        call q%next( dcoords )
        write( *, * ) i, dcoords
    enddo

    call q%init( 3 )

    write( *, * ) 'Quasirandom points on the unit cube [0,1]^3:'
    do i = 1,10
        call q%next( dcoords3 )
        write( *, * ) i, dcoords3
    enddo

    !
    ! Test the special forms:
    ! - For circle and sphere:
    !   - the length of the vector should be one
    !   - the number of points with x > 0.7 should be roughly equal to
    !     the number of points with y > 0.7
    ! - For disk and ball:
    !   - the number of points with distance to the origin less than 0.5
    !     should roughly be 1/4 and 1/8 of the total
    !   - the number of points with x > 0.7 should be roughly equal to
    !     the number of points with y > 0.7 and to the number of points
    !     with z > 0.7
    !
    write( *, * ) 'Quasirandom points on a circle:'

    points_off = 0
    points_x   = 0
    points_y   = 0
    call qcircle%init( quasi_circle )
    do i = 1,1000
        call qcircle%next( dcoords2 )
        dradius2 = sum( dcoords2 ** 2 )
        if ( abs(dradius2 - 1.0_dp) > 1.0e-12_dp ) then
            points_off = points_off + 1
        endif
        if ( dcoords2(1) > 0.7_dp ) then
            points_x = points_x  + 1
        endif
        if ( dcoords2(2) > 0.7_dp ) then
            points_y = points_y  + 1
        endif
    enddo

    write( *, * ) 'Number of points off the circle:  ', points_off
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y

    write( *, * ) 'Quasirandom points on a disk:'
    points_in  = 0
    points_x   = 0
    points_y   = 0
    call qdisk%init( quasi_disk )
    do i = 1,1000
        call qdisk%next( dcoords2 )
        dradius2 = sum( dcoords2 ** 2 )
        if ( dradius2 < 0.25_dp ) then
            points_in = points_in + 1
        endif
        if ( dcoords2(1) > 0.7_dp ) then
            points_x = points_x  + 1
        endif
        if ( dcoords2(2) > 0.7_dp ) then
            points_y = points_y  + 1
        endif
    enddo

    write( *, * ) 'Number of points inner part of disk:  ', points_in, ' - expected: ', 1000/4
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y

    !
    ! Sphere and ball
    !
    write( *, * ) 'Quasirandom points on a sphere:'

    points_off = 0
    points_x   = 0
    points_y   = 0
    points_z   = 0
    call qsphere%init( quasi_sphere )
    do i = 1,1000
        call qsphere%next( dcoords3 )
        dradius2 = sum( dcoords3 ** 2 )
        if ( abs(dradius2 - 1.0_dp) > 1.0e-12_dp ) then
            points_off = points_off + 1
        endif
        if ( dcoords3(1) > 0.7_dp ) then
            points_x = points_x  + 1
        endif
        if ( dcoords3(2) > 0.7_dp ) then
            points_y = points_y  + 1
        endif
        if ( dcoords3(3) > 0.7_dp ) then
            points_z = points_z  + 1
        endif
    enddo

    write( *, * ) 'Number of points off the sphere:  ', points_off
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y
    write( *, * ) 'Number of points above of z = 0.7:', points_z

    write( *, * ) 'Quasirandom points on a ball:'
    points_in  = 0
    points_x   = 0
    points_y   = 0
    points_z   = 0
    call qball%init( quasi_ball )
    do i = 1,1000
        call qball%next( dcoords3 )
        dradius2 = sum( dcoords3 ** 2 )
        if ( dradius2 < 0.25_dp ) then
            points_in = points_in + 1
        endif
        if ( dcoords3(1) > 0.7_dp ) then
            points_x = points_x  + 1
        endif
        if ( dcoords3(2) > 0.7_dp ) then
            points_y = points_y  + 1
        endif
        if ( dcoords3(3) > 0.7_dp ) then
            points_z = points_z  + 1
        endif
    enddo

    write( *, * ) 'Number of points inner part of ball:  ', points_in, ' - expected: ', 1000/8
    write( *, * ) 'Number of points right of x = 0.7:', points_x
    write( *, * ) 'Number of points above of y = 0.7:', points_y
    write( *, * ) 'Number of points above of z = 0.7:', points_z
end program test_quasirandom


C******************** START FILE FLIN1_Z.FOR ; GROUP SIGS2 ********************
C==============================================================================
C
C  FLIN1_Z
C   INTERPOLATE ON A 1D ARRAY
C
      SUBROUTINE FLIN1_Z(X,F,N,VTR,XMIN,XMAX,XLR,NX,IWARN)
c
c Interpolates the table VTR(NX) to find the value at x.
c If XLR>0, then the X grid is equally spaced on a logarithmic scale:
c
c   X(i) = XMIN * (exp(XLR)) ** ( (i-1)/(NX-1) )
c
c   So X(i) ranges from XMIN to XMIN*exp(XLR), and XLR=log(xmax/xmin).
c
c For XLR<=0, the X grid is equally spaced on a linear scale from
c XMIN to XMAX.
C
C Modified 7/26/00 (PCR) - vectorized.
C
C============
C idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER n,nx,it,iwarn,ix,ixp1
C============
C idecl:  explicitize implicit REAL declarations:
      REAL*8 f,vtr,x,xmin,xmax,xlr,zx,zy,zzx,zlogx
C============
      DIMENSION VTR(NX)
      DIMENSION X(N)
      DIMENSION F(N)
C
C  INTERPOLATE TO X  LOGARITHMIC SPACING IN X
C     LINEAR IF XLR .LE. 0.0
C
      integer idebug
      common/flint_debug/ idebug
C
      iwarn=0
C
      do 70 it=1,n
C
         ZX=X(it)
C
         if(zx .lt. xmin) then
            zzx=0.0D0
         else

            IF(XLR.GT.0.0D0) THEN
               ZLOGX=log(ZX/XMIN)
               ZZX=1.0D0+ZLOGX/XLR * (NX-1)
            ELSE
               ZZX=1.0D0+(ZX-XMIN)/(XMAX-XMIN) * (NX-1)
            ENDIF

         endif
C
         IX=ZZX
C
C  CHECK FOR POINT OUT OF BOUNDS OF ARRAY
         IF(IX.GE.1) GO TO 10
C
         IF(ZX.LT.(XMIN - 5.0D-7)) THEN
            IWARN=1
         ENDIF
         IX=1
         ZZX=1.0D0
C
 10      CONTINUE
C
         IF(IX.LT.NX) GO TO 30
C
         IF(ZX.GT.(XMAX + 5.0D-7)) THEN
            IWARN=1
         ENDIF
         IX=NX-1
         ZZX=NX
C
C---------------------------
C  OK
C
 30      CONTINUE
C
         IXP1=IX+1
         ZZX=ZZX-IX
C
C  INTERPOLATE
C
         F(it)=(1.0D0-ZZX)*VTR(IX)+ZZX*VTR(IXP1)
c
         if(idebug.eq.99) then
            write(6,*) 'flin1_z:  zx=',zx,' ix=',ix
            write(6,*) '  vtr(ix:ixp1) = ',vtr(ix:ixp1)
            write(6,*) '  it,F(it)=',it,F(it)
         endif
C
 70   continue
C
      idebug=0  ! clear debug flag
C
      END
C
C******************** END FILE FLIN1.FOR ; GROUP SIGS2 ************************
! 26Jul2000 fgtok -s r8_precision.sub "r8con.csh conversion"


      SUBROUTINE SROTMG( D1, D2, X1, Y1, PARAM )
*
*  -- Automatically Tuned Linear Algebra Software (ATLAS)
*     (C) Copyright 2000 All Rights Reserved
*
*  -- ATLAS routine -- F77 Interface -- Version 3.9.24 -- December 25, 2000
*
*  Author         : Antoine P. Petitet
*  Originally developed at the University of Tennessee,
*  Innovative Computing Laboratory,  Knoxville TN, 37996-1301, USA.
*
*  ---------------------------------------------------------------------
*
*  -- Copyright notice and Licensing terms:
*
*  Redistribution  and  use in  source and binary forms, with or without
*  modification, are  permitted provided  that the following  conditions
*  are met:
*
*  1. Redistributions  of  source  code  must retain the above copyright
*     notice, this list of conditions and the following disclaimer.
*  2. Redistributions in binary form must reproduce  the above copyright
*     notice,  this list of conditions, and the  following disclaimer in
*     the documentation and/or other materials provided with the distri-
*     bution.
*  3. The name of the University,  the ATLAS group,  or the names of its
*     contributors  may not be used to endorse or promote products deri-
*     ved from this software without specific written permission.
*
*  -- Disclaimer:
*
*  THIS  SOFTWARE  IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
*  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,  INCLUDING,  BUT NOT
*  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
*  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY
*  OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,  INDIRECT, INCIDENTAL, SPE-
*  CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
*  TO,  PROCUREMENT  OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
*  OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEO-
*  RY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  (IN-
*  CLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
*  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*  ---------------------------------------------------------------------
*
*     .. Scalar Arguments ..
      REAL               D1, D2, X1, Y1
*     ..
*     .. Array Arguments ..
      REAL               PARAM( * )
*     ..
*
*  Purpose
*  =======
*
*  SROTMG constructs the modified-Givens plane rotation.  The input sca-
*  lars d1, d2, x1 and y1 define a 2-vector [a1 a2]' such that
*
*     [ a1 ]   [ d1^{1/2}  0      ] [ x1 ]
*     [ a2 ] = [   0     d2^{1/2} ] [ y1 ].
*
*  This subroutine determines the modified Givens rotation matrix H that
*  transforms y1 and thus a2 to zero. A representation of this matrix is
*  stored in the output array PARAM.
*
*  Arguments
*  =========
*
*  D1      (input/output)                REAL
*          On entry, D1 specifies the scalar d1.
*
*  D2      (input/output)                REAL
*          On entry, D2 specifies the scalar d2.
*
*  X1      (input/output)                REAL
*          On entry, X1 specifies the scalar x1.
*
*  Y1      (input)                       REAL
*          On entry, Y1 specifies the scalar y1. Unchanged on exit.
*
*  PARAM   (output)                      REAL array
*          On entry, PARAM is an array of dimension at least 5. On exit,
*          the entries of this array have the following meaning:
*
*          if PARAM( 1 ) = 1,
*             h_12 = 1, h_21 = -1, PARAM( 2 ) = h_11, PARAM( 5 ) = h_22,
*             and the other entries of PARAM are left unchanged;
*          else if PARAM( 1 ) = 0,
*             h_11 = 1, h_22 =  1, PARAM( 3 ) = h_21, PARAM( 4 ) = h_12,
*             and the other entries of PARAM are left unchanged;
*          else if PARAM( 1 ) = -1, (case of re-scaling)
*             PARAM( 2 ) = h_11, PARAM( 3 ) = h_21,
*             PARAM( 4 ) = h_12, PARAM( 5 ) = h_22;
*          else if PARAM( 1 ) = -2,
*             H = I, and the other entries of PARAM are left unchanged;
*          end if
*
*  Further Details
*  ===============
*
*  For further information on the Level 1 BLAS specification, see:
*
*  ``A Proposal for Standard Linear Algebra Subprograms''  by R. Hanson,
*  F. Krogh and C. Lawson, ACM SIGNUM Newsl., 8(16), 1973,
*
*  ``Basic Linear Algebra Subprograms for Fortran Usage''  by C. Lawson,
*  R. Hanson, D. Kincaid and F. Krogh,  ACM Transactions on Mathematical
*  Software, 5(3) pp 308-323, 1979.
*
*  For further information on the Level 2 BLAS specification, see:
*
*  ``An  Extended Set of  FORTRAN  Basic Linear Algebra Subprograms'' by
*  J. Dongarra,  J. Du Croz,  S. Hammarling and R. Hanson,  ACM Transac-
*  tions on Mathematical Software, 14(1) pp 1-17, 1988.
*
*  ``Algorithm 656: An extended Set of Basic Linear Algebra Subprograms:
*  Model Implementation and Test Programs''  by J. Dongarra, J. Du Croz,
*  S. Hammarling and R. Hanson,  ACM  Transactions on Mathematical Soft-
*  ware, 14(1) pp 18-32, 1988.
*
*  For further information on the Level 3 BLAS specification, see:
*
*  ``A Set of Level 3 Basic Linear Algebra Subprograms'' by J. Dongarra,
*  J. Du Croz, I. Duff and S. Hammarling, ACM Transactions on Mathemati-
*  cal Software, 16(1), pp 1-17, 1990.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_SROTMG
*     ..
*     .. Executable Statements ..
*
      CALL ATL_F77WRAP_SROTMG( D1, D2, X1, Y1, PARAM )
*
      RETURN
*
*     End of SROTMG
*
      END


      SUBROUTINE cdfgam(which,p,q,x,shape,scale,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFGAM( WHICH, P, Q, X, SHAPE, SCALE, STATUS, BOUND )
C               Cumulative Distribution Function
C                         GAMma Distribution
C
C
C                              Function
C
C
C     Calculates any one parameter of the gamma
C     distribution given values for the others.
C
C
C                              Arguments
C
C
C     WHICH --> Integer indicating which of the next four argument
C               values is to be calculated from the others.
C               Legal range: 1..4
C               iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE
C               iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE
C               iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE
C               iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE
C                    INTEGER WHICH
C
C     P <--> The integral from 0 to X of the gamma density.
C            Input range: [0,1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: (0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C
C     X <--> The upper limit of integration of the gamma density.
C            Input range: [0, +infinity).
C            Search range: [0,1E300]
C                    DOUBLE PRECISION X
C
C     SHAPE <--> The shape parameter of the gamma density.
C                Input range: (0, +infinity).
C                Search range: [1E-300,1E300]
C                  DOUBLE PRECISION SHAPE
C
C
C     SCALE <--> The scale parameter of the gamma density.
C                Input range: (0, +infinity).
C                Search range: (1E-300,1E300]
C                   DOUBLE PRECISION SCALE
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C                10 if the gamma or inverse gamma routine cannot
C                   compute the answer.  Usually happens only for
C                   X and SHAPE very large (gt 1E10 or more)
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C     Cumulative distribution function (P) is calculated directly by
C     the code associated with:
C
C     DiDinato, A. R. and Morris, A. H. Computation of the  incomplete
C     gamma function  ratios  and their  inverse.   ACM  Trans.  Math.
C     Softw. 12 (1986), 377-393.
C
C     Computation of other parameters involve a seach for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C
C                              Note
C
C
C
C     The gamma density is proportional to
C       T**(SHAPE - 1) * EXP(- SCALE * T)
C
C                              History
C
C     Routine modified by Scilab group 1998, because of an undefined
C     variable. See below comments "CSS".

C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-13)
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION zero,inf
      PARAMETER (zero=1.0D-300,inf=1.0D300)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,p,q,scale,shape,x
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION xx
      DOUBLE PRECISION fx,xscale,cum,ccum,pq,porq
      INTEGER ierr
      LOGICAL qhi,qleft,qporq
C     ..
C     .. External Functions ..
      DOUBLE PRECISION spmpar
      EXTERNAL spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL gaminv,dinvr,dstinv,cumgam
C     ..
C     .. Executable Statements ..
C
C     Check arguments
C
      IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 4.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
C
C     P
C
      IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60
      IF (.NOT. (p.LT.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = 1.0d0
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.1) GO TO 110
C
C     Q
C
      IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100
      IF (.NOT. (q.LE.0.0D0)) GO TO 80
      bound = 0.0D0
      GO TO 90

   80 bound = 1.0D0
   90 status = -3
      RETURN

  100 CONTINUE
  110 IF (which.EQ.2) GO TO 130
C
C     X
C
      IF (.NOT. (x.LT.0.0D0)) GO TO 120
      bound = 0.0D0
      status = -4
      RETURN

  120 CONTINUE
  130 IF (which.EQ.3) GO TO 150
C
C     SHAPE
C
      IF (.NOT. (shape.LE.0.0D0)) GO TO 140
      bound = 0.0D0
      status = -5
      RETURN

  140 CONTINUE
  150 IF (which.EQ.4) GO TO 170
C
C     SCALE
C
      IF (.NOT. (scale.LE.0.0D0)) GO TO 160
      bound = 0.0D0
      status = -6
      RETURN

  160 CONTINUE
  170 IF (which.EQ.1) GO TO 210
C
C     P + Q
C
      pq = p + q
      IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 200
      IF (.NOT. (pq.LT.0.0D0)) GO TO 180
      bound = 0.0D0
      GO TO 190

  180 bound = 1.0D0
  190 status = 3
      RETURN

  200 CONTINUE
  210 IF (which.EQ.1) GO TO 240
C
C     Select the minimum of P or Q
C
      qporq = p .LE. q
      IF (.NOT. (qporq)) GO TO 220
      porq = p
      GO TO 230

  220 porq = q
  230 CONTINUE
C
C     Calculate ANSWERS
C
  240 IF ((1).EQ. (which)) THEN
C
C     Calculating P
C
          status = 0
          xscale = x*scale
          CALL cumgam(xscale,shape,p,q)
CSS   Next line changed by Scilab group. porq undefined here
CSS       IF (porq.GT.1.5D0) status = 10
          IF (p.GT.1.5D0) status = 10

      ELSE IF ((2).EQ. (which)) THEN
C
C     Computing X
C
          CALL gaminv(shape,xx,-1.0D0,p,q,ierr)
          IF (ierr.LT.0.0D0) THEN
              status = 10
              RETURN

          ELSE
              x = xx/scale
              status = 0
          END IF

      ELSE IF ((3).EQ. (which)) THEN
C
C     Computing SHAPE
C
          shape = 5.0D0
          xscale = x*scale
          CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,shape,fx,qleft,qhi)
  250     IF (.NOT. (status.EQ.1)) GO TO 290
          CALL cumgam(xscale,shape,cum,ccum)
          IF (.NOT. (qporq)) GO TO 260
          fx = cum - p
          GO TO 270

  260     fx = ccum - q
  270     IF (.NOT. ((qporq.AND. (cum.GT.1.5D0)).OR.
     +        ((.NOT.qporq).AND. (ccum.GT.1.5D0)))) GO TO 280
          status = 10
          RETURN

  280     CALL dinvr(status,shape,fx,qleft,qhi)
          GO TO 250

  290     IF (.NOT. (status.EQ.-1)) GO TO 320
          IF (.NOT. (qleft)) GO TO 300
          status = 1
          bound = zero
          GO TO 310

  300     status = 2
          bound = inf
  310     CONTINUE
  320     CONTINUE

      ELSE IF ((4).EQ. (which)) THEN
C
C     Computing SCALE
C
          CALL gaminv(shape,xx,-1.0D0,p,q,ierr)
          IF (ierr.LT.0.0D0) THEN
              status = 10
              RETURN

          ELSE
              scale = xx/x
              status = 0
          END IF

      END IF

      RETURN

      END


! ============================ Module Description ===========================
! etdrk4_mod Implementation of ETDRK4 by Cox & Mathews. Contains subroutines:
!   1. etdrk4      - ETDRK4 timestepping code
!   2. initETDC    - initializes ETD coefficients
! ===========================================================================

module etdrk4_mod

    use tools_mod,  only: dp, tic, toc
    use phi_mod,    only: phi
    implicit none

    contains

    ! =======================================================================
    ! ETDRK4   Implements ETDRK4 Numerical Time Integrator
    !
    ! Arguments
    !
    !   L       (input) COMPLEX*16 array, dimension(N)
    !           vector cooresponding to PDE linear operator
    !
    !   N       (input) SUBROUTINE:
    !           cooresponds to PDE nonlinear operator. Must be of the form:
    !               subroutine N(t,y_in,N_out)
    !                   real(dp),    intent(in)  :: t
    !                   complex(dp), intent(in)  :: y_in(:)
    !                   complex(dp), intent(out) :: N_out(:)
    !               end subroutine N
    !
    !   y_in    (input) COMPLEX*16 array, dimension (N)
    !           Initial condition.
    !
    !   y_out   (output) COMPLEX*16 array, dimension (N)
    !           Initial condition.
    !
    !   times   (output) DOUBLE array, dimension(4)
    !           times(1:2) = [cputime,clocktime] for timestepping loop
    !           times(3:4) = [cputime,clocktime] for initializing coefficients,
    ! =======================================================================

    subroutine etdrk4(L,N,tspan,y_in,Nt,y_out,times)

        ! Arguments
        complex(dp), intent(in)     :: L(:)
        real(dp),    intent(in)     :: tspan(2)
        complex(dp), intent(in)     :: y_in(:)
        integer,         intent(in) :: Nt
        complex(dp), intent(out)    :: y_out(size(y_in))
        real(dp),    intent(out)    :: times(4)
        ! define interface subroutine function N
        interface
            subroutine N(t,yh_in, N_out, thread_id)
            import :: dp
            complex(dp), intent(in)  :: t
            complex(dp), intent(in)  :: yh_in(:)
            complex(dp), intent(out) :: N_out(:)
            integer, intent(in), optional :: thread_id
            end subroutine N
        end interface

        ! Local Variables
        integer :: i,nL
        real(dp) :: h
        complex(dp) :: t
        complex(dp), allocatable :: y(:)
        complex(dp), allocatable, dimension(:) :: E, E2, A123, b1, b23, b4, Nv, Na, Nb, Nc, a, b, c

        ! Initialize Variables
        nL = size(L)
        allocate(E(nL), E2(nL), A123(nL), b1(nL), b23(nL), b4(nL), Nv(nL), Na(nL), Nb(nL), Nc(nL), a(nL), b(nL), c(nL))
        y = y_in
        ! Set stepsize
        h = (tspan(2)-tspan(1))/(real(Nt,8))
        t = tspan(1)
        ! initialize ETD coefficients
        call tic()
        call initETDC(L,h,E, E2, A123, b1, b23, b4)
        call toc(times(3:4))
        ! timestepping loop
        call tic
        do i=1,Nt
            call N(t,y,Nv);
            a  = E2*y + 0.5_dp*A123*Nv;
            call N(t+h/2.0_dp, a, Na);
            b  = E2*y + 0.5_dp*A123*Na;
            call N(t+h/2.0_dp, b, Nb);
            c  = E2*a + A123*(Nb - 0.5*Nv);
            call N(t+h, c, Nc);
            y  = E*y + b1*Nv + b23*(Na + Nb) + b4*Nc;
            t = t + h;
        enddo
        call toc(times(1:2))
        y_out = y

    end subroutine etdrk4

    ! =======================================================================
    ! INITETDC   Initializes ETD coefficients for ETDRK4 scheme.
    !
    ! Arguments
    !
    !   L   (input) COMPLEX*16 array, dimension(N)
    !       vector/scaler cooresponding to PDE linear operator
    !
    !   h   (input) DOUBLE
    !       timestep
    !
    !   E, E2, A, b1, b23, b4   (output) COMPLEX*16 array, dimension(N,N)
    !                           coefficients for ETDRK4
    ! =======================================================================

    subroutine initETDC(L,h,E, E2, A, b1, b23, b4)

        ! Arguments
        complex(dp), intent(in) :: L(:)
        real(dp),    intent(in) :: h
        complex(dp), dimension(:), intent(out) :: E, E2, A, b1, b23, b4

        ! Local Variables
        complex(dp), allocatable :: P(:,:)
        allocate(P(4,size(L)))

        ! Initialize Coefficients
        call phi(h/2.0_dp * L,1,P(1:2,:))
            E2  = p(1,:)
            A   = h*p(2,:)
        call phi(h * L,3,P)
            E   = P(1,:)
            b1  = h*(4.0_dp*P(4,:) - 3.0_dp*P(3,:) + P(2,:))
            b23 = h*(-4.0_dp*P(4,:) + 2.0_dp*P(3,:))
            b4  = h*(4.0_dp*P(4,:) - P(3,:))
        deallocate(P)

    end subroutine initETDC

end module etdrk4_mod


C$Procedure      IDENT (Return the 3x3 identity matrix)

      SUBROUTINE IDENT ( MATRIX )

C$ Abstract
C
C    This routine returns the 3x3 identity matrix.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C
C$ Declarations

      IMPLICIT NONE
      DOUBLE PRECISION      MATRIX ( 3, 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MATRIX     O   is the 3x3 identity matrix
C
C$ Detailed_Input
C
C     None.
C
C$ Detailed_Output
C
C     MATRIX     is the 3x3 Identity matrix.  That is MATRIX is
C                the following
C                  _                       _
C                 |  1.0D0   0.0D0   0.0D0  |
C                 |  0.0D0   1.0D0   0.0D0  |
C                 |  0.0D0   0.0D0   1.0D0  |
C                  -                       -
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Particulars
C
C     This is a utility routine for obtaining the 3x3 identity matrix
C     so that you may avoid having to write the loop or assignments
C     needed to get the matrix.
C
C$ Examples
C
C     Suppose that you need to construct the matrix sum
C
C        I + OMEGA
C
C     where OMEGA is some matrix you have already computed.
C
C     The code fragment below shows how you could accomplish this
C     with this routine.
C
C        First get the Identity matrix
C
C        DOUBLE PRECISION      I ( 3, 3 )
C
C        CALL IDENT( I  )
C        CALL VSUMG( I, OMEGA, 9, SUM )
C
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 5-FEB-1996 (WLT)
C
C
C-&

C$ Index_Entries
C
C     Get the 3x3 identity matrix
C
C-&

      MATRIX ( 1, 1 ) = 1.0D0
      MATRIX ( 2, 1 ) = 0.0D0
      MATRIX ( 3, 1 ) = 0.0D0

      MATRIX ( 1, 2 ) = 0.0D0
      MATRIX ( 2, 2 ) = 1.0D0
      MATRIX ( 3, 2 ) = 0.0D0

      MATRIX ( 1, 3 ) = 0.0D0
      MATRIX ( 2, 3 ) = 0.0D0
      MATRIX ( 3, 3 ) = 1.0D0

      RETURN
      END


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

! Longest Collatz sequence
!
! The following iterative sequence is defined for the set of positive integers:
!
!    n  > n/2 (n is even)
!    n  > 3n + 1 (n is odd)
!
! Using the rule above and starting with 13, we generate the following sequence:
!
!    13 > 40 > 20 > 10 > 5 > 16 > 8 > 4 > 2 > 1
!
! It can be seen that this sequence (starting at 13 and finishing at 1) contains
! 10  terms. Although it has not been proved yet (Collatz Problem), it is
! thought that all starting numbers finish at 1.
!
! Which starting number, under one million, produces the longest chain?
!
! NOTE: Once the chain starts the terms are allowed to go above one million.
module MPEProblem14

    implicit none
    private

    type, public :: TPEProblem14
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 14. Longest Collatz sequence.'

        write (*, '(A, I)') 'Chain 1: ', chain1()
    end subroutine

    function chain1
        integer :: chain1
        integer :: index
        integer :: value
        integer :: max

        ! initial values
        chain1 = 0
        index  = 0
        value  = 0
        max    = 0

        do index = 1, 1000000
            value = get_length(index)

            if (value .gt. max) then
                max    = value
                chain1 = index
            end if
        end do
    end function

    function get_length(number)
        integer, intent(in) :: number

        integer :: get_length
        integer*8 :: value

        ! initial value
        get_length = 1
        value      = number

        do while (value .gt. 1)
            if (mod(value, 2) .eq. 0) then
                value = value / 2
            else
                value = (value * 3) + 1
            end if

            get_length = get_length + 1
        end do
    end function
end module


program force_calculation
 implicit none
 integer::i,j,n =108
 real(8)::rx(200),ry(200),rz(200),boxl,sigsq,epslon,rxij,ryij,rzij,rijsq,sr2,sr6,sr12,rcutoffsq,rcutoff,v,sig,kb,a
 real(8)::fxij,fyij,fzij,fpr,fx(200),fy(200),fz(200)
 !real(8),allocatable::a(:,:)!,fx(:),fy(:),fz(:)

 dimension a(200,200)
 open(1,file='argon.init')
 do  i=1,n
  read(1,*) (a(i,j),j=1,3)
  rx(i) =a(i,1)
  ry(i) =a(i,2)
  rz(i) =a(i,3)

 end do

 boxl =17.158d0
 sig = 3.405d0
 sigsq = sig * sig
 kb = 1.38E-23
 epslon = 120.0d0 !* kb

 rcutoff = 0.50d0 * boxl
 rcutoffsq = rcutoff * rcutoff

 do i=1,n
  rx(i) = rx(i) - (boxl * anint(rx(i)/boxl))
  ry(i) = ry(i) - (boxl * anint(ry(i)/boxl))
  rz(i) = rz(i) - (boxl * anint(rz(i)/boxl))
 end do

 do i=1,n
  fx(i)=0.0d0; fy(i)=0.0d0; fz(i)=0.0d0
 end do

 v=0.0d0
 do i=1,n-1
  do j=i+1,n
   rxij = rx(i) - rx(j)
   ryij = ry(i) - ry(j)
   rzij = rz(i) - rz(j)

   rxij = rxij - (boxl * anint(rxij/boxl))
   ryij = ryij - (boxl * anint(ryij/boxl))
   rzij = rzij - (boxl * anint(rzij/boxl))

   rijsq = rxij**2 + ryij**2 + rzij**2
   sr2 = sigsq/rijsq
   sr6 = sr2 * sr2 * sr2
   sr12 = sr6 * sr6
    if(rijsq<rcutoffsq) then

     fpr = (48.0d0 * epslon * (sr12 - (0.5d0*sr6)))/rijsq
     fxij = fpr * rxij
     fyij = fpr * ryij
     fzij = fpr * rzij

     fx(i) = fx(i) + fxij
     fy(i) = fy(i) + fyij
     fz(i) = fz(i) + fzij
     fx(j) = fx(j) - fxij
     fy(j) = fy(j) - fyij
     fz(j) = fz(j) - fzij
    end if
   end do

 write(12,*)fx(i),fy(i),fz(i)
 end do

end program force_calculation


 	FUNCTION PR_PKDD  ( pspd )
C************************************************************************
C* PR_PKDD								*
C*									*
C* This function computes DRCT from PSPD.  PSPD is in the form DDFFF	*
C* where DD is the wind direction in tens of degrees, and FFF is	*
C* either the wind speed or wind speed plus 500, depending on the	*
C* units digit of direction rounded to the nearest 5 degrees.  The	*
C* following equation is used:						*
C*									*
C*                DRCT = 5. *  INT ( PSPD / 500. )			*
C*									*
C* REAL PR_PKDD  ( PSPD )						*
C*									*
C* Input parameters:							*
C*	PSPD		REAL		Packed speed and direction	*
C*									*
C* Output parameters:							*
C*	PR_PKDD		REAL		Wind direction in degrees	*
C**									*
C* Log:									*
C* I. Graffman/CSC	 8/83	Original source code			*
C* I. Graffman/RDS	12/87	Correction				*
C* G. Huffman/GSC	 8/88	Documentation and rounding fix		*
C* M. desJardins/GSFC	 9/88	Changed NINT to INT			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( pspd ) )  THEN
	    PR_PKDD = RMISSD
C
C*      The factor of 5 accounts for encoding the units digit of
C*	direction (to the nearest 5 degrees) in the hundreds digit of
C*	speed.
C
	  ELSE
	    PR_PKDD = 5. * INT ( pspd / 500. )
	    IF  ( PR_PKDD .ge. 360. )  PR_PKDD = PR_PKDD - 360.
	END IF
C*
	RETURN
	END


Function gmre(x)
  Implicit Double Precision (A-H, O-Z)
  Save
  z = x
  If (x>3.0D0) Goto 10
  z = x + 3.D0
  10 gmre = 0.5D0*dlog(2.D0*3.14159265D0/z) + z*dlog(z) - z + dlog(1.D0+1.D0/12.D0/z+1.D0/288.D0/z**2-139.D0/51840.D0/z**3-571.D0/2488320.D0/z**4)
  If (z==x) Goto 20
  gmre = gmre - dlog(z-1.D0) - dlog(z-2.D0) - dlog(z-3.D0)
  20 Continue
  Return
End Function gmre


!************************************************************************
!  This program is part of the
!        OpenMP Source Code Repository
!
!        http://www.pcg.ull.es/ompscr/
!        e-mail: ompscr@etsii.ull.es
!
!   Copyright (c) 2004, OmpSCR Group
!   All rights reserved.
!
!   Redistribution and use in source and binary forms, with or without modification,
!   are permitted provided that the following conditions are met:
!     * Redistributions of source code must retain the above copyright notice,
!       this list of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice,
!       this list of conditions and the following disclaimer in the documentation
!       and/or other materials provided with the distribution.
!     * Neither the name of the University of La Laguna nor the names of its contributors
!       may be used to endorse or promote products derived from this software without
!       specific prior written permission.
!
!   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
!   AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
!   WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
!   IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
!   INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
!   BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
!   OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
!   WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!   ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY
!   OF SUCH DAMAGE.
!
!  FILE:              f_jacobi08.f90
!  VERSION:           1.1
!  DATE:              Oct 2004
!  AUTHORS:           Author:       Joseph Robicheaux, Kuck and Associates, Inc. (KAI), 1998
!                     Modified:     Sanjiv Shah,       Kuck and Associates, Inc. (KAI), 1998
!                     This version: Dieter an Mey,     Aachen University (RWTH), 1999 - 2003
!                                   anmey@rz.rwth-aachen.de
!                                   http://www.rwth-aachen.de/People/D.an.Mey.html
!  COMMENTS TO:       ompscr@etsii.ull.es
!  DESCRIPTION:       program to solve a finite difference discretization of Helmholtz equation :
!                     (d2/dx2)u + (d2/dy2)u - alpha u = f using Jacobi iterative method.
!  COMMENTS:          OpenMP version 8: 1 PR outside the iteration loop, 2-fold unrolling,
!                                        software pipelining, 2 barriers per iteration
!                     Directives are used in this code to achieve paralleism.
!                     All do loops are parallized with default 'static' scheduling.
!  REFERENCES:        http://www.rz.rwth-aachen.de/computing/hpc/prog/par/openmp/jacobi.html
!  BASIC PRAGMAS:     parallel do
!  USAGE:             ./f_jacobi08.par 1000 1000 0.8 1.0 1000
!  INPUT:             n - grid dimension in x direction
!                     m - grid dimension in y direction
!                     alpha - Helmholtz constant (always greater than 0.0)
!                     tol   - error tolerance for iterative solver
!                     relax - Successice over relaxation parameter
!                     mits  - Maximum iterations for iterative solver
!  OUTPUT:            Residual and error
!                     u(n,m) - Dependent variable (solutions)
!                     f(n,m) - Right hand side function
!  FILE FORMATS:      -
!  RESTRICTIONS:      An excesive grid dimension might cause a runtime error
!                     if memory is not enough.
!  REVISION HISTORY:
!**************************************************************************

      program main
      USE oscrCommon_f
      USE omp_lib
      implicit none

integer, parameter  :: NUM_ARGS      = 6
integer, parameter  :: NUM_TIMERS    = 1

      integer n,m,mits, kreps,nreps
      double precision tol,relax,alpha
      integer nthreads, minthreads, maxthreads

      common /idat/ n,m,mits
      common /fdat/ tol,alpha,relax
!
! Read info
!
      character(len=38),dimension(NUM_ARGS) :: argNames = (/'Grid dimension: X dir =               ', &
                                                            'Grid dimension: Y dir =               ', &
                                                            'Helmhotlz constant =                  ', &
                                                            'Successive over-relaxation parameter =', &
                                                            'error tolerance for iterative solver =', &
                                                            'Maximum iterations for solver =       '/)
      character(len=4),dimension(NUM_ARGS) :: defaultValues = (/ '1000', '1000', '0.8 ', '1.0 ', '1e-7', '1000'/)
      character(len=8),dimension(NUM_TIMERS) :: timerNames = (/ 'EXE_TIME' /)

      nthreads = omp_get_max_threads()
      call OSCR_init( nthreads,                                              &
             "Jacobi solver for the Helmholtz equation.",                    &
             '',                                                             &
             NUM_ARGS,                                                       &
             argNames,                                                       &
             defaultValues,                                                  &
             NUM_TIMERS,                                                     &
             NUM_TIMERS,                                                     &
             timerNames )

! 1. GET PARAMETERS
      n = OSCR_getarg_integer(1)
      m = OSCR_getarg_integer(2)
      alpha = OSCR_getarg_doubleprecision(3)
      relax = OSCR_getarg_doubleprecision(4)
      tol = OSCR_getarg_doubleprecision(5)
      mits = OSCR_getarg_integer(6)

!
! Calls a driver routine
!
      call driver

      stop
      end

      subroutine driver
!************************************************************
! Subroutine driver ()
! This is where the arrays are allocated and initialzed.
!
! Working varaibles/arrays
!     dx  - grid spacing in x direction
!     dy  - grid spacing in y direction
!************************************************************

      USE oscrCommon_f
      implicit none

      integer n,m,mits
      double precision tol,relax,alpha, dt

      common /idat/ n,m,mits
      common /fdat/tol,alpha,relax

      double precision u(n,m),f(n,m),dx,dy
      double precision mflops, maxmflops

! Initialize data

      call initialize (n,m,alpha,dx,dy,u,f)

! Solve Helmholtz equation

      call OSCR_timer_start(1)
      call jacobi (n,m,dx,dy,alpha,relax,u,f,tol,mits)
      call OSCR_timer_stop(1)
      dt = OSCR_timer_read(1)
      call OSCR_report()

      mflops = float(mits)*float(m-2)*float(n-2)*13.0d0*0.000001d0 / dt
      write (*,'(a,f12.6)') 'elapsed time usage', dt
      write (*,'(a,f12.6)') 'MFlop/s            ', mflops

! Check error between exact solution

      call error_check (n,m,alpha,dx,dy,u,f)

      return
      end

      subroutine initialize (n,m,alpha,dx,dy,u,f)
!*****************************************************
! Initializes data
! Assumes exact solution is u(x,y) = (1-x^2)*(1-y^2)
!
!*****************************************************
      implicit none

      integer n,m
      double precision u(n,m),f(n,m),dx,dy,alpha

      integer i,j, xx,yy
      double precision PI
      parameter (PI=3.1415926)

      dx = 2.0 / (n-1)
      dy = 2.0 / (m-1)

! Initilize initial condition and RHS

!$omp parallel do private(xx,yy,i,j)
      do j = 1,m
         do i = 1,n
            xx = -1.0 + dx * dble(i-1)        ! -1 < x < 1
            yy = -1.0 + dy * dble(j-1)        ! -1 < y < 1
            u(i,j) = 0.0
            f(i,j) = -alpha *(1.0-xx*xx)*(1.0-yy*yy) &
     &           - 2.0*(1.0-xx*xx)-2.0*(1.0-yy*yy)
         enddo
      enddo

      return
      end

      subroutine error_check (n,m,alpha,dx,dy,u,f)
      implicit none
!***********************************************************
! Checks error between numerical and exact solution
!
!***********************************************************

      integer n,m
      double precision u(n,m),f(n,m),dx,dy,alpha

      integer i,j
      double precision xx,yy,temp,error

      dx = 2.0 / (n-1)
      dy = 2.0 / (m-1)
      error = 0.0

!$omp parallel do private(xx,yy,i,j,temp) reduction(+:error)
      do j = 1,m
         do i = 1,n
            xx = -1.0d0 + dx * dble(i-1)
            yy = -1.0d0 + dy * dble(j-1)
            temp  = u(i,j) - (1.0-xx*xx)*(1.0-yy*yy)
            error = error + temp*temp
         enddo
      enddo

      error = sqrt(error)/dble(n*m)

      print *, 'Solution Error : ',error

      return
      end

      subroutine jacobi (n,m,dx,dy,alpha,omega,u,f,tol,maxit)

      ! use omp_lib

      implicit none
      integer n,m,maxit
      double precision dx,dy,f(n,m),u(n,m),alpha, tol,omega

      integer i,j,k,k_priv
      double precision error, error1,error2,resid, ax,ay,b
      double precision error_priv, uold(n,m)

      ax = 1.0/(dx*dx) ! X-direction coef
      ay = 1.0/(dy*dy) ! Y-direction coef
      b  = -2.0/(dx*dx)-2.0/(dy*dy) - alpha ! Central coeff

      do j=1,m, m-1
         do i=1,n
            uold(i,j) = u(i,j)
         enddo
      enddo
      do j=2,m-1
         do i=1,n,n-1
            uold(i,j) = u(i,j)
         enddo
      enddo

!$omp parallel private(resid, k_priv,error_priv)
      k_priv = 1
      error_priv = 10.0d0 * tol
      do
         if (k_priv.gt.maxit .or. error_priv.le.tol) exit

!$omp    single
         error1 = 0.0d0
!$omp    end single nowait

!$omp    do
         do j=1,m
            do i=1,n
               uold(i,j) = u(i,j)
            enddo
         enddo
!$omp    end do   ! implicit barrier

!$omp    do reduction(+:error1)
         do j = 2,m-1
            do i = 2,n-1
               resid = (ax*(uold(i-1,j) + uold(i+1,j)) &
     &                + ay*(uold(i,j-1) + uold(i,j+1)) &
     &                 + b * uold(i,j) - f(i,j))/b
               u(i,j) = uold(i,j) - omega * resid
               error1 = error1 + resid*resid
            end do
         enddo
!$omp    end do   ! implicit barrier

         k_priv = k_priv + 1
         error_priv = sqrt(error1)/dble(n*m)

         if (k_priv.gt.maxit .or. error_priv.le.tol) exit

!$omp    single
         error2 = 0.0d0
!$omp    end single nowait
!$omp    do
         do j=1,m
            do i=1,n
               uold(i,j) = u(i,j)
            enddo
         enddo
!$omp    end do   ! implicit barrier

!$omp    do reduction(+:error2)
         do j = 2,m-1
            do i = 2,n-1
               resid = (ax*(uold(i-1,j) + uold(i+1,j)) &
     &                + ay*(uold(i,j-1) + uold(i,j+1)) &
     &                 + b * uold(i,j) - f(i,j))/b
               u(i,j) = uold(i,j) - omega * resid
               error2 = error2 + resid*resid
            end do
         enddo
!$omp    end do   ! implicit barrier

         k_priv = k_priv + 1
         error_priv = sqrt(error2)/dble(n*m)

      end do                     ! End iteration loop
!$omp barrier   ! don't miss this barrier
!$omp single
      k = k_priv
      error = error_priv
!$omp end single
!$omp end parallel

      print *, 'Total Number of Iterations ', k
      print *, 'Residual                   ', error

      return
      end


| This example shows how to do input and some numeric munging.
|
| It implements the "3N+1" sequences:

with~ ~util

: about quote *
	This program computes and displays several 3N+1 sequences.  Starting values
	for the sequences are input by the user.  Terms in a sequence are printed in
	turn, until there are no more terms.  After a sequence has been displayed,
	the number of terms in that sequence is reported to the user.

	Type 'play' to start.
* type cr ;

: seeyou cr ." Thanks for playing!" cr bye ;

: getstart ( -- n )
	cr ." Enter the starting value (ESC or ENTER to quit): "
	scratch 20 accept dup 0if seeyou ;then
	scratch swap >single 0if
		cr ." The value '" type ." ', is not a valid number" getstart
	then
	dup 0 <if
		drop cr ." Please input only positive integers, thank you" getstart
	then
	;

variable total
: doseq ( n -- )
	total ++
	dup .
	1- 0; 1+
	dup 1 and if
		| odd
		3 * 1+
	else
		2/
		| even
	then
	doseq
	;
: printseq ( n -- )
	total off
	dup cr ." The 3N+1 sequence starting with " . ." :" cr
	doseq
	cr ." Total in sequence: " total ?
	;
about
: play getstart printseq play ;


      SUBROUTINE splint(xa, ya, y2a, n, x, y)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER     :: n
      REAL(rprec) :: xa(n), ya(n), y2a(n), x, y
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: zero = 0, c1o6 = 1._dp/6._dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: klo, khi, i, k
      REAL(rprec) :: h, a, a2, b, b2, h2, y26lo, y26hi
C-----------------------------------------------
!
!       SPLINE INTERPOLATION ROUTINE (Numerical Recipes, pg. 89)
!       XA: ordered array of length N of ordinates at which function YA=F(XA)
!           is tabulated
!       YA: array of length N , = F(XA)
!       Y2A: array of second derivatives at XA points
!       computed from call to SPLINE
!       X : value at which Y = F(X) is to be computed from splines
!       YP = dY/dX at X
!       NDIM: dimension of X, Y, YP arrays

      klo = 1
      khi = n
      DO WHILE(khi - klo .gt. 1)
         k = (khi + klo)/2
         IF (xa(k) .gt. x) THEN
            khi = k
         ELSE
            klo = k
         ENDIF
      END DO

      h = xa(khi) - xa(klo)
      a = xa(khi) - x
      b = x - xa(klo)
      h2 = h*h
      a2 = a*a
      b2 = b*b
      y26lo = c1o6*y2a(klo)
      y26hi = c1o6*y2a(khi)
      y     = (a*(ya(klo)+(a2-h2)*y26lo)+b*(ya(khi)+(b2-h2)*y26hi))/h

      END SUBROUTINE splint


      FUNCTION BESSY(N,X)
      IF(N.LT.2)PAUSE 'bad argument N in BESSY'
      TOX=2./X
      BY=BESSY1(X)
      BYM=BESSY0(X)
      DO 11 J=1,N-1
        BYP=J*TOX*BY-BYM
        BYM=BY
        BY=BYP
11    CONTINUE
      BESSY=BY
      RETURN
      END