!! generate an initial model for an arbitrary-mass, isothermal C WD
!! with an isentropic He envelope on the surface.

program init_1d

  use bl_types
  use bl_constants_module
  use bl_error_module
  use extern_probin_module, only: use_eos_coulomb
  use eos_module, only: eos_input_rt, eos, eos_init
  use eos_type_module, only: eos_t
  use network
  use fundamental_constants_module, only: Gconst
  use f2kcli

  implicit none

  integer :: i, n

  character(len=128) :: params_file

  real (kind=dp_t) :: temp_core, temp_base, delta
  real (kind=dp_t), DIMENSION(nspec) :: xn_core, xn_he

  logical :: mixed_co_wd

  real (kind=dp_t), allocatable :: xzn_hse(:), xznl(:), xznr(:)
  real (kind=dp_t), allocatable :: model_hse(:,:), M_enclosed(:)
  real (kind=dp_t), allocatable :: cs_hse(:), s_hse(:)

  real (kind=dp_t) :: rho_c, rho_c_old, mass_wd, mass_wd_old, drho_c
  real (kind=dp_t) :: rho_he, rho_he_old, mass_he, mass_he_old, drho_he

  real (kind=dp_t) :: slope_T, slope_xn(nspec)

  real (kind=dp_t) :: A, B, dAdT, dAdrho, dBdT, dBdrho
  logical :: isentropic

  real (kind=dp_t) :: test

  integer :: nx

  ! define convenient indices for the scalars
  integer, parameter :: nvar = 3 + nspec
  integer, parameter :: idens = 1, &
                        itemp = 2, &
                        ipres = 3, &
                        ispec = 4

  ! we'll get the composition indices from the network module
  integer, save :: ihe4, ic12, io16

  real (kind=dp_t), save :: xmin, xmax, dCoord

  real (kind=dp_t) :: dens_zone, temp_zone, pres_zone, entropy
  real (kind=dp_t) :: dpd, dpt, dsd, dst

  real (kind=dp_t) :: p_want, drho, dtemp, delx
  real (kind=dp_t) :: entropy_base

  real (kind=dp_t) :: g_zone

  ! TOL_HSE is the tolerance used when iterating over a zone to force
  ! it into HSE by adjusting the current density (and possibly
  ! temperature).  TOL_HSE should be very small (~ 1.e-10).
  real (kind=dp_t), parameter :: TOL_HSE = 1.d-10

  ! TOL_WD_MASS is tolerance used for getting the total WD mass equal
  ! to M_tot (defined below).  It can be reasonably small, since there
  ! will always be a central density value that can give the desired
  ! WD mass on the grid we use
  real (kind=dp_t), parameter :: TOL_WD_MASS = 1.d-4

  ! TOL_HE_MASS is the tolerance used for getting the mass of the He
  ! envelope.  This should not be too small, since the values of the
  ! He envelope mass we can achieve will depend on our grid spacing.
  real (kind=dp_t), parameter :: TOL_HE_MASS = 2.d-2

  integer, parameter :: MAX_ITER = 250

  integer :: iter, iter_mass

  integer :: icutoff, ihe_layer, ihe_entropy

  logical :: converged_hse, fluff, mass_converged

  real (kind=dp_t), dimension(nspec) :: xn

  real (kind=dp_t) :: low_density_cutoff, temp_fluff, smallx, smallt

  real (kind=dp_t) :: M_tot, M_He
  real (kind=dp_t) :: solar_mass = 1.98892d33

  character (len=256) :: outfile
  character (len=8) num, mass_wd_str, mass_he_str

  real (kind=dp_t) :: max_hse_error, dpdr, rhog

  integer :: narg

  type (eos_t) :: eos_state

  namelist /params/ nx, M_tot, M_He, delta, xmin, xmax, &
       temp_core, temp_base, mixed_co_wd, low_density_cutoff, temp_fluff, smallt

  ! determine if we specified a runtime parameters file or use the default
  narg = command_argument_count()

  if (narg == 0) then
     params_file = "_params"
  else
     call get_command_argument(1, value = params_file)
  endif

  ! define the defaults parameters for this model
  nx = 2560

  M_tot = 0.6
  M_He  = 0.2

  delta = 1.d-6

  xmin = 0_dp_t
  xmax = 1.6e9_dp_t

  temp_core = 1.d7
  temp_base = 4.d8

  mixed_co_wd = .true.

  low_density_cutoff =1.d-4
  temp_fluff = 1.d5
  smallt = 1.d5

  ! check the namelist for any changed parameters
  open(unit=11, file=trim(params_file), status="old", action="read")
  read(unit=11, nml=params)
  close(unit=11)

  ! convert the envelope and WD mass into solar masses
  M_tot = M_tot * solar_mass
  M_He = M_He * solar_mass

  ! this comes in via extern_probin_module, override the default if desired.
  use_eos_coulomb = .true.

  smallx = 1.d-10

  ! initialize the EOS and network
  call eos_init()
  call network_init()

  ! get the species indices
  ihe4 = network_species_index("helium-4")
  ic12 = network_species_index("carbon-12")
  io16 = network_species_index("oxygen-16")

  if (ihe4 < 0 .or. ic12 < 0 .or. io16 < 0) then
     call bl_error("ERROR: species not defined")
  endif

  if (mixed_co_wd) then
     xn_core(:)    = smallx
     xn_core(ic12) = 0.5_dp_t - 0.5*(nspec - 1)*smallx
     xn_core(io16) = 0.5_dp_t - 0.5*(nspec - 1)*smallx
  else
     xn_core(:)    = smallx
     xn_core(ic12) = 1.0_dp_t - (nspec - 1)*smallx
  endif

  xn_he(:)    = smallx
  xn_he(ihe4) = 1.0_dp_t - (nspec - 1)*smallx

  !----------------------------------------------------------------------------
  ! Create a 1-d uniform grid that is identical to the mesh that we are
  ! mapping onto, and then we want to force it into HSE on that mesh.
  !----------------------------------------------------------------------------

  ! allocate storage
  allocate(xzn_hse(nx))
  allocate(xznl(nx))
  allocate(xznr(nx))
  allocate(model_hse(nx,nvar))
  allocate(M_enclosed(nx))
  allocate(cs_hse(nx))
  allocate(s_hse(nx))

  ! compute the coordinates of the new gridded function
  dCoord = (xmax - xmin) / dble(nx)

  do i = 1, nx
     xznl(i) = xmin + (dble(i) - 1.0_dp_t)*dCoord
     xznr(i) = xmin + (dble(i))*dCoord
     xzn_hse(i) = 0.5_dp_t*(xznl(i) + xznr(i))
  enddo

  ! We don't know what WD central density will give the desired total
  ! mass, so we need to iterate over central density

  ! we will do a secant iteration.  rho_c_old is the 'old' guess for
  ! the central density and rho_c is the current guess.  After 2
  ! loops, we can start estimating the density required to yield our
  ! desired mass
  rho_c_old = -1.0_dp_t
  rho_c     = 1.e9_dp_t     ! 1.e9 is a reasonable starting WD central density

  ! rho_he_old is the old guess for the density to transition to He,
  ! where we will be isentropic, and rho_he is the currrent guess.
  rho_he_old = -1.0_dp_t
  rho_he     = 0.5*rho_c

  mass_converged = .false.

  do iter_mass = 1, MAX_ITER

     print *, 'mass iter = ', iter_mass, rho_c, temp_core

     fluff = .false.

     ! we start at the center of the WD and integrate outward.  Initialize
     ! the central conditions.
     eos_state%T     = temp_core
     eos_state%rho   = rho_c
     eos_state%xn(:) = xn_core(:)

     ! (t, rho) -> (p, s)
     call eos(eos_input_rt, eos_state)

     ! make the initial guess be completely uniform
     model_hse(:,idens) = eos_state%rho
     model_hse(:,itemp) = eos_state%T
     model_hse(:,ipres) = eos_state%p

     do i = 1, nspec
        model_hse(:,ispec-1+i) = eos_state%xn(i)
     enddo

     ! keep track of the mass enclosed below the current zone
     M_enclosed(1) = FOUR3RD*M_PI*(xznr(1)**3 - xznl(1)**3)*model_hse(1,idens)

     ihe_layer = -1
     ihe_entropy = -1

     !-------------------------------------------------------------------------
     ! HSE + entropy solve
     !-------------------------------------------------------------------------
     do i = 2, nx

        delx = xzn_hse(i) - xzn_hse(i-1)

        ! as the initial guess for the density, use the previous zone
        dens_zone = model_hse(i-1,idens)

        if (dens_zone > rho_he) then
           temp_zone = temp_core
           xn(:) = xn_core(:)

           isentropic = .false.

        else

           if (ihe_layer == -1) then
              ihe_layer = i
           endif

           ! determine whether we are starting the ramp up.  We will
           ! use a tanh profile, centered at (xzn_hse(ihe_layer) +
           ! FOUR*delta).  The "+ FOUR*delta" enables us to capture
           ! the leading edge of the profile.  Since rho_he is
           ! computed by considering the integral of He on the grid,
           ! shifting the profile by FOUR*delta doesn't affect the
           ! overall mass.

           test = HALF*(ONE + tanh((xzn_hse(i) - xzn_hse(ihe_layer) - FOUR*delta)/delta))

           if (test < 0.999d0) then

              ! small tanh ramp up regime
              xn(:) = xn_core(:) + HALF*(xn_he(:) - xn_core(:))* &
                   (ONE + tanh((xzn_hse(i) - xzn_hse(ihe_layer) - FOUR*delta)/delta))

              temp_zone = temp_core + HALF*(temp_base - temp_core)* &
                   (ONE + tanh((xzn_hse(i) - xzn_hse(ihe_layer) - FOUR*delta)/delta))

              isentropic = .false.

           else

              ! fully isentropic
              if (ihe_entropy == -1) then
                 ihe_entropy = i
                 temp_zone = temp_base
                 isentropic = .false.
              else
                 temp_zone = model_hse(i-1,itemp)
                 isentropic = .true.
              endif

              xn(:) = xn_he(:)

           endif

        endif

        g_zone = -Gconst*M_enclosed(i-1)/(xznl(i)*xznl(i))

        !----------------------------------------------------------------------
        ! iteration loop
        !----------------------------------------------------------------------

        ! start off the Newton loop by saying that the zone has not converged
        converged_hse = .FALSE.

        if (.not. fluff) then

           do iter = 1, MAX_ITER

              if (isentropic) then

                 p_want = model_hse(i-1,ipres) + &
                      delx*0.5_dp_t*(dens_zone + model_hse(i-1,idens))*g_zone

                 ! now we have two functions to zero:
                 !   A = p_want - p(rho,T)
                 !   B = entropy_base - s(rho,T)
                 ! We use a two dimensional Taylor expansion and find the deltas
                 ! for both density and temperature

                 eos_state%T     = temp_zone
                 eos_state%rho   = dens_zone
                 eos_state%xn(:) = xn(:)

                 ! (t, rho) -> (p, s)
                 call eos(eos_input_rt, eos_state)

                 entropy = eos_state%s
                 pres_zone = eos_state%p

                 dpt = eos_state%dpdt
                 dpd = eos_state%dpdr
                 dst = eos_state%dsdt
                 dsd = eos_state%dsdr

                 A = p_want - pres_zone
                 B = entropy_base - entropy

                 dAdT = -dpt
                 dAdrho = 0.5d0*delx*g_zone - dpd
                 dBdT = -dst
                 dBdrho = -dsd

                 dtemp = (B - (dBdrho/dAdrho)*A)/ &
                      ((dBdrho/dAdrho)*dAdT - dBdT)

                 drho = -(A + dAdT*dtemp)/dAdrho

                 dens_zone = max(0.9_dp_t*dens_zone, &
                                 min(dens_zone + drho, 1.1_dp_t*dens_zone))

                 temp_zone = max(0.9_dp_t*temp_zone, &
                                 min(temp_zone + dtemp, 1.1_dp_t*temp_zone))

                 ! check if the density falls below our minimum
                 ! cut-off -- if so, floor it
                 if (dens_zone < low_density_cutoff) then

                    dens_zone = low_density_cutoff
                    temp_zone = temp_fluff
                    converged_hse = .TRUE.
                    fluff = .TRUE.
                    exit

                 endif

                 if ( abs(drho) < TOL_HSE*dens_zone .and. &
                      abs(dtemp) < TOL_HSE*temp_zone) then
                    converged_hse = .TRUE.
                    exit
                 endif

              else
                 ! the core is isothermal, so we just need to constrain
                 ! the density and pressure to agree with the EOS and HSE

                 ! We difference HSE about the interface between the current
                 ! zone and the one just inside.
                 p_want = model_hse(i-1,ipres) + &
                      delx*0.5*(dens_zone + model_hse(i-1,idens))*g_zone

                 eos_state%T     = temp_zone
                 eos_state%rho   = dens_zone
                 eos_state%xn(:) = xn(:)

                 ! (t, rho) -> (p, s)
                 call eos(eos_input_rt, eos_state)

                 entropy = eos_state%s
                 pres_zone = eos_state%p

                 dpd = eos_state%dpdr

                 drho = (p_want - pres_zone)/(dpd - 0.5*delx*g_zone)

                 dens_zone = max(0.9*dens_zone, &
                      min(dens_zone + drho, 1.1*dens_zone))

                 if (abs(drho) < TOL_HSE*dens_zone) then
                    converged_hse = .TRUE.
                    exit
                 endif

                 if (dens_zone < low_density_cutoff) then

                    icutoff = i
                    dens_zone = low_density_cutoff
                    temp_zone = temp_fluff
                    converged_hse = .TRUE.
                    fluff = .TRUE.
                    exit

                 endif
              endif

              if (temp_zone < temp_fluff .and. isentropic) then
                 temp_zone = temp_fluff
                 isentropic = .false.
              endif

           enddo

           if (.NOT. converged_hse) then

              print *, 'Error zone', i, ' did not converge in init_1d'
              print *, dens_zone, temp_zone
              print *, p_want
              print *, drho
              call bl_error('Error: HSE non-convergence')

           endif

        else
           dens_zone = low_density_cutoff
           temp_zone = temp_fluff
        endif

        ! call the EOS one more time for this zone and then go on
        ! to the next
        eos_state%T     = temp_zone
        eos_state%rho   = dens_zone
        eos_state%xn(:) = xn(:)

        ! (t, rho) -> (p, s)
        call eos(eos_input_rt, eos_state)

        pres_zone = eos_state%p

        ! determine the entropy that we want to constrain to, if
        ! this is the first zone of the He layer
        if (i == ihe_entropy) then
           entropy_base = entropy
        endif

        ! update the thermodynamics in this zone
        model_hse(i,idens) = dens_zone
        model_hse(i,itemp) = temp_zone
        model_hse(i,ipres) = pres_zone

        model_hse(i,ispec:ispec-1+nspec) = xn(:)

        M_enclosed(i) = M_enclosed(i-1) + &
             FOUR3RD*M_PI*(xznr(i) - xznl(i))* &
             (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_hse(i,idens)

        cs_hse(i) = eos_state%cs
        s_hse(i) = eos_state%s

     enddo  ! end loop over zones

     ! compute the total mass of the He layer and C/O WD
     mass_he = FOUR3RD*M_PI*(xznr(1)**3 - xznl(1)**3)* &
          model_hse(1,idens)*model_hse(1,ispec-1+ihe4)

     mass_wd = FOUR3RD*M_PI*(xznr(1)**3 - xznl(1)**3)*model_hse(1,idens)* &
          (model_hse(1,ispec-1+ic12) + model_hse(1,ispec-1+io16))

     do i = 2, icutoff
        mass_he = mass_he + &
             FOUR3RD*M_PI*(xznr(i) - xznl(i))* &
             (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_hse(i,idens)* &
             model_hse(i,ispec-1+ihe4)

        mass_wd = mass_wd + &
             FOUR3RD*M_PI*(xznr(i) - xznl(i))* &
             (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_hse(i,idens)* &
             (model_hse(i,ispec-1+ic12) + model_hse(i,ispec-1+io16))
     enddo

     if (rho_c_old < 0.0_dp_t) then
        ! not enough iterations yet -- store the old central density and
        ! mass and pick a new value
        rho_c_old = rho_c
        mass_wd_old = mass_wd

        rho_he_old = rho_he
        mass_he_old = mass_he

        rho_c = 0.5*rho_c_old
        rho_he = 0.5*rho_he_old

     else
        ! have we converged
        if ( abs(mass_wd - M_tot)/M_tot < TOL_WD_MASS .and. &
             abs(mass_he - M_He)/M_He < TOL_HE_MASS) then
           mass_converged = .true.
           exit
        endif

        ! do a secant iteration:
        ! M_tot = M(rho_c) + dM/drho |_rho_c x drho + ...
        drho_c = (M_tot - mass_wd)/ &
             ( (mass_wd  - mass_wd_old)/(rho_c - rho_c_old) )

        rho_c_old = rho_c
        mass_wd_old = mass_wd

        rho_c = min(1.1_dp_t*rho_c_old, &
                    max((rho_c + drho_c), 0.9_dp_t*rho_c_old))

        drho_he = (M_He - mass_he)/ &
             ( (mass_he  - mass_he_old)/(rho_he - rho_he_old) )

        rho_he_old = rho_he
        mass_he_old = mass_he

        rho_he = min(1.1_dp_t*rho_he_old, &
                    max((rho_he + drho_he), 0.9_dp_t*rho_he_old))

        print *, 'current mass = ', mass_wd/solar_mass, mass_he/solar_mass

     endif

  enddo  ! end mass constraint loop

  if (.not. mass_converged) then
     print *, 'ERROR: WD mass did not converge'
     call bl_error("ERROR: mass did not converge")
  endif

  print *, 'final masses: '
  print *, ' mass WD: ', mass_wd/solar_mass
  print *, ' mass He: ', mass_He/solar_mass
  print *, ihe_layer

  ! store the model
  write(num,'(i8)') nx
  write(mass_wd_str,'(f4.2)') mass_wd/solar_mass
  write(mass_he_str,'(f5.3)') mass_He/solar_mass
  !if (mass_He/solar_mass > 0.01) then
  !   write(mass_he_str,'(f4.2)') mass_He/solar_mass
  !else
  !   write(mass_he_str,'(f6.4)') mass_He/solar_mass
  !endif

  if (mixed_co_wd) then
     outfile = "sub_chandra.M_WD-" // trim(adjustl(mass_wd_str)) // &
          ".M_He-" // trim(adjustl(mass_he_str)) // &
          ".hse.CO." // trim(adjustl(num))
  else
     outfile = "sub_chandra.M_WD-" // trim(adjustl(mass_wd_str)) // &
          ".M_He-" // trim(adjustl(mass_he_str)) // &
          ".hse.C." // trim(adjustl(num))
  endif

  open (unit=50, file=outfile, status="unknown")

  write (50,1001) "# npts = ", nx
  write (50,1001) "# num of variables = ", nvar
  write (50,1002) "# density"
  write (50,1002) "# temperature"
  write (50,1002) "# pressure"

  do n = 1, nspec
     write (50,1003) "# ", spec_names(n)
  enddo

1000 format (1x, 12(g26.16, 1x))
1001 format(a, i5)
1002 format(a)
1003 format(a,a)

  do i = 1, nx
     write (50,1000) xzn_hse(i), model_hse(i,idens), model_hse(i,itemp), model_hse(i,ipres), &
          (model_hse(i,ispec-1+n), n=1,nspec)
  enddo

  close (50)

  ! extra info
  if (mixed_co_wd) then
     outfile = "sub_chandra.M_WD-" // trim(adjustl(mass_wd_str)) // &
          ".M_He-" // trim(adjustl(mass_he_str)) // &
          ".extras.CO." // trim(adjustl(num))
  else
     outfile = "sub_chandra.M_WD-" // trim(adjustl(mass_wd_str)) // &
          ".M_He-" // trim(adjustl(mass_he_str)) // &
          ".extras.C." // trim(adjustl(num))
  endif

  open (unit=51, file=outfile, status="unknown")

  write (51,1001) "# npts = ", nx
  write (51,1002) "# cs"
  write (51,1002) "# entropy"

  do i = 1, nx
     write (51,1000) xzn_hse(i), cs_hse(i), s_hse(i)
  enddo

  close (51)

  ! compute the maximum HSE error
  max_hse_error = -1.d30

  do i = 2, nx-1
     g_zone = -Gconst*M_enclosed(i-1)/xznr(i-1)**2
     dpdr = (model_hse(i,ipres) - model_hse(i-1,ipres))/delx
     rhog = HALF*(model_hse(i,idens) + model_hse(i-1,idens))*g_zone

     print *, xzn_hse(i), g_zone*xzn_hse(i)

     if (dpdr /= ZERO .and. model_hse(i+1,idens) > low_density_cutoff) then
        max_hse_error = max(max_hse_error, abs(dpdr - rhog)/abs(dpdr))
     endif

  enddo

  print *, 'maximum HSE error = ', max_hse_error
  print *, ' '

end program init_1d


      SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*  -- Modified by R. Clint Whaley for ATLAS Fortran77 LAPACK interface,
*     1999
*
*     .. Scalar Arguments ..
      CHARACTER UPLO
      INTEGER   INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DPOTRF computes the Cholesky factorization of a real symmetric
*  positive definite matrix A.
*
*  The factorization has the form
*     A = U**T * U,  if UPLO = 'U', or
*     A = L  * L**T,  if UPLO = 'L',
*  where U is an upper triangular matrix and L is lower triangular.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
*          N-by-N upper triangular part of A contains the upper
*          triangular part of the matrix A, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading N-by-N lower triangular part of A contains the lower
*          triangular part of the matrix A, and the strictly upper
*          triangular part of A is not referenced.
*
*          On exit, if INFO = 0, the factor U or L from the Cholesky
*          factorization A = U**T*U or A = L*L**T.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, the leading minor of order i is not
*                positive definite, and the factorization could not be
*                completed.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER ATLASROWMAJOR, ATLASCOLMAJOR
      PARAMETER (ATLASROWMAJOR=101, ATLASCOLMAJOR=102)
      INTEGER ATLASNOTRANS, ATLASTRANS, ATLASCONJTRANS
      PARAMETER (ATLASNOTRANS=111, ATLASTRANS=112, ATLASCONJTRANS=113)
      INTEGER ATLASUPPER, ATLASLOWER
      PARAMETER (ATLASUPPER=121, ATLASLOWER=122)
      INTEGER ATLASNONUNIT, ATLASUNIT
      PARAMETER (ATLASNONUNIT=131, ATLASUNIT=132)
      INTEGER ATLASLEFT, ATLASRIGHT
      PARAMETER (ATLASLEFT=141, ATLASRIGHT=142)
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            IUPLO
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPOTRF', -INFO )
         RETURN
      END IF
*
      IF (UPPER) THEN
         IUPLO = ATLASUPPER
      ELSE
         IUPLO = ATLASLOWER
      ENDIF
*
      CALL ATL_F77WRAP_DPOTRF( IUPLO, N, A, LDA, INFO )
*
      RETURN
      END


! Example of an approximate stencil specification
!
! In situations where the specification language cannot exactly
! describe the pattern an approximate specification can be given as an
! upper and lower bound using the atMost and atLeast modifiers
program approx
implicit none

integer i, n
parameter (n = 3)
real a(0:n)

do i = 0, n
 != stencil readOnce, atLeast, pointed(dim=1) :: a
 != stencil readOnce, atMost, forward(depth=4, dim=1) :: a
 a(i) = a(i) + a(i+4)
end do

end program


! --------------------------------------------------------------------
! MODULE  math

!    Subroutines:
!    (1) mag2              - calulate |A|^2
!
!    Functions:
!    (1)
! TODO:
! --------------------------------------------------------------------
module math
    implicit none
    double precision, parameter :: sqrtpi = dsqrt(4.d0*atan(1.d0))
    double precision, parameter :: pi = 4.d0*atan(1.d0)
    double precision, parameter :: twopi = 2.d0 * pi
    double precision, parameter :: sqrt2 = dsqrt(2.d0)
    ! some constant
    double precision, parameter :: c0=2.99792458d8, me=9.10938d-31, mi=1836.d0*me
    double precision, parameter :: e=1.602d-19, k=8.9875d9
    double precision, parameter :: mu0=1.256637d-6, eps0=8.854187d-12
    double precision, parameter :: kb=1.380649e-23, NA=6.02214d23
    double precision, parameter :: Da=1.660539066d-27
    double precision, parameter :: mu=1d-6, nano=1.d-9, ang=1.d-10, pico=1.d-12
    double precision, parameter :: femto=1.d-15, atto=1.d-18
    double precision, parameter :: zero=0.d0, one=1.d0, two=2.d0, three=3.d0, four=4.d0
    double precision, parameter :: five=5.d0, six=6.d0, seven=7.d0, eight=8.d0, nine=9.d0
    double precision, parameter :: ten=10.d0, half=.5d0
    logical, parameter :: yes=.True., no=.False.
    logical, parameter :: on=.True., off=.False.
    contains

! --------------------------------------------------------------------
!    Purpose: |A|^2
! --------------------------------------------------------------------
    function mag2(A)
        implicit none
        double precision :: mag2, A(3)
        mag2 = dot_product(A, A)
    end function

! --------------------------------------------------------------------
!    Purpose: |A|
! --------------------------------------------------------------------
    function mag(A)
        implicit none
        double precision :: mag, A(3)
        mag = dsqrt(dot_product(A, A))
    end function

! --------------------------------------------------------------------
!    Purpose: unit vector
! --------------------------------------------------------------------
    function hat(A)
        implicit none
        double precision :: hat(3), A(3)
        hat = A / mag(A)
    end function

! --------------------------------------------------------------------
!    Purpose: randomly distribute in a sphere
!
!    input:
!          (1) r: radius of sphere
!          (2) cx, cy, cz: center of sphere in x, y, z
!          (3) dim: dimension of sphere
!    output:
!          (1) (x, y, z)
! --------------------------------------------------------------------
    function RDsphere(r, cx, cy, cz, dim)
        implicit none
        double precision :: RDsphere(3), r, a, b, c
        double precision :: cx, cy, cz
        integer :: dim
        !> 1d sphere
        if (dim == 1) then
            call random_number(a)
            a = (a - .5d0) * 2.d0 * r
            RDsphere = (/ a+cx, cy, cz /)
        end if
        !> 2d sphere
        if (dim == 2) then
            do
                call random_number(a)
                call random_number(b)
                a = (a - .5d0) * 2.d0 * r
                b = (b - .5d0) * 2.d0 * r
                if ((a**2+b**2) .le. r**2) then
                    exit
                end if
            end do
            RDsphere = (/ a+cx, b+cy, cz /)
        end if
        !> 3d sphere
        if (dim == 3) then
            do
                call random_number(a)
                call random_number(b)
                call random_number(c)
                a = (a - .5d0) * 2.d0 * r
                b = (b - .5d0) * 2.d0 * r
                c = (c - .5d0) * 2.d0 * r
                if ((a**2+b**2+c**2) .le. r**2) then
                    exit
                end if
            end do
            RDsphere = (/ a+cx, b+cy, c+cz /)
        end if
    end function RDsphere

! --------------------------------------------------------------------
!    Purpose: randomly distribute in a rectangle
!
!    input:
!          (1) Lx, Ly, Lz: size in x, y, z direction
!          (2) cx, cy, cz: center of rectangle
!          (3) dim: dimension
!    output:
!          (1) (x, y, z) of random coordinate
! --------------------------------------------------------------------
    function RDrect(Lx, Ly, Lz, cx, cy, cz, dim)
        implicit none
        integer :: dim
        double precision :: RDrect(3), Lx, Ly, Lz, x, y, z
        double precision :: cx, cy, cz
        call random_seed()
        if (dim == 1) then
            call random_number(x)
            x = (x - .5d0) * Lx
            RDrect = (/ x+cx, cy, cz /)
        end if
        if (dim == 2) then
            call random_number(x)
            call random_number(y)
            x = (x - .5d0) * Lx
            y = (y - .5d0) * Ly
            RDrect = (/ x+cx, y+cy, cz /)
        end if
        if (dim == 3) then
            call random_number(x)
            call random_number(y)
            call random_number(z)
            x = (x - .5d0) * Lx
            y = (y - .5d0) * Ly
            z = (z - .5d0) * Lz
            RDrect = (/ x+cx, y+cy, z+cz /)
        end if
    end function RDrect

! --------------------------------------------------------------------
!    Purpose: create gaussian random distribution
!
!    input:
!          (1) mu: mean
!          (2) sig: sigma, standard deviation
!    output:
!          (1) gaurand: one gaussian distribtution number
! --------------------------------------------------------------------
    function gaurand(mu, sig)
        implicit none
        double precision :: a, b, gaurand, sig, mu
        call random_number(a)
        call random_number(b)
        gaurand = sig * dsqrt(-2.d0 * log(a)) * dcos(twopi * b) + mu
    end function

! --------------------------------------------------------------------
!    Purpose: create maxwell distribution for specific dimension
!
!    input:
!          (1) mass: mass of species
!          (2) temperature: temperature of species
!          (3) dim: dimension
!    output:
!          (1) maxwell: (/ a, b, c /)
! --------------------------------------------------------------------
    function maxwell(temperature, mass, dim)
        implicit none
        integer :: dim, i
        double precision :: maxwell(3), mass, temperature
        maxwell = zero
        select case (dim)
        case(1)
            do i = 1, 1
                maxwell(i) = dsqrt(kb * temperature / mass) * gaurand(zero, one)
            end do
        case(2)
            do i = 1, 2
                maxwell(i) = dsqrt(kb * temperature / mass) * gaurand(zero, one)
            end do
        case(3)
            do i = 1, 3
                maxwell(i) = dsqrt(kb * temperature / mass) * gaurand(zero, one)
            end do
        end select
    end function maxwell

end module


!*==clantr.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a trapezoidal or triangular matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLANTR + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       REAL             FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
!                        WORK )
!
!       .. Scalar Arguments ..
!       CHARACTER          DIAG, NORM, UPLO
!       INTEGER            LDA, M, N
!       ..
!       .. Array Arguments ..
!       REAL               WORK( * )
!       COMPLEX            A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLANTR  returns the value of the one norm,  or the Frobenius norm, or
!> the  infinity norm,  or the  element of  largest absolute value  of a
!> trapezoidal or triangular matrix A.
!> \endverbatim
!>
!> \return CLANTR
!> \verbatim
!>
!>    CLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] NORM
!> \verbatim
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in CLANTR as described
!>          above.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower trapezoidal.
!>          = 'U':  Upper trapezoidal
!>          = 'L':  Lower trapezoidal
!>          Note that A is triangular instead of trapezoidal if M = N.
!> \endverbatim
!>
!> \param[in] DIAG
!> \verbatim
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A has unit diagonal.
!>          = 'N':  Non-unit diagonal
!>          = 'U':  Unit diagonal
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0, and if
!>          UPLO = 'U', M <= N.  When M = 0, CLANTR is set to zero.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0, and if
!>          UPLO = 'L', N <= M.  When N = 0, CLANTR is set to zero.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,N)
!>          The trapezoidal matrix A (A is triangular if M = N).
!>          If UPLO = 'U', the leading m by n upper trapezoidal part of
!>          the array A contains the upper trapezoidal matrix, and the
!>          strictly lower triangular part of A is not referenced.
!>          If UPLO = 'L', the leading m by n lower trapezoidal part of
!>          the array A contains the lower trapezoidal matrix, and the
!>          strictly upper triangular part of A is not referenced.  Note
!>          that when DIAG = 'U', the diagonal elements of A are not
!>          referenced and are assumed to be one.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(M,1).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (MAX(1,LWORK)),
!>          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
!>          referenced.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERauxiliary
!
!  =====================================================================
      REAL FUNCTION CLANTR(Norm,Uplo,Diag,M,N,A,Lda,Work)
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
      IMPLICIT NONE
!*--CLANTR151
!     .. Scalar Arguments ..
      CHARACTER Diag , Norm , Uplo
      INTEGER Lda , M , N
!     ..
!     .. Array Arguments ..
      REAL Work(*)
      COMPLEX A(Lda,*)
!     ..
!
! =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL udiag
      INTEGER i , j
      REAL sum , value
!     ..
!     .. Local Arrays ..
      REAL ssq(2) , colssq(2)
!     ..
!     .. External Functions ..
      LOGICAL LSAME , SISNAN
      EXTERNAL LSAME , SISNAN
!     ..
!     .. External Subroutines ..
      EXTERNAL CLASSQ , SCOMBSSQ
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
      IF ( MIN(M,N)==0 ) THEN
         value = ZERO
      ELSEIF ( LSAME(Norm,'M') ) THEN
!
!        Find max(abs(A(i,j))).
!
         IF ( LSAME(Diag,'U') ) THEN
            value = ONE
            IF ( LSAME(Uplo,'U') ) THEN
               DO j = 1 , N
                  DO i = 1 , MIN(M,j-1)
                     sum = ABS(A(i,j))
                     IF ( value<sum .OR. SISNAN(sum) ) value = sum
                  ENDDO
               ENDDO
            ELSE
               DO j = 1 , N
                  DO i = j + 1 , M
                     sum = ABS(A(i,j))
                     IF ( value<sum .OR. SISNAN(sum) ) value = sum
                  ENDDO
               ENDDO
            ENDIF
         ELSE
            value = ZERO
            IF ( LSAME(Uplo,'U') ) THEN
               DO j = 1 , N
                  DO i = 1 , MIN(M,j)
                     sum = ABS(A(i,j))
                     IF ( value<sum .OR. SISNAN(sum) ) value = sum
                  ENDDO
               ENDDO
            ELSE
               DO j = 1 , N
                  DO i = j , M
                     sum = ABS(A(i,j))
                     IF ( value<sum .OR. SISNAN(sum) ) value = sum
                  ENDDO
               ENDDO
            ENDIF
         ENDIF
      ELSEIF ( (LSAME(Norm,'O')) .OR. (Norm=='1') ) THEN
!
!        Find norm1(A).
!
         value = ZERO
         udiag = LSAME(Diag,'U')
         IF ( LSAME(Uplo,'U') ) THEN
            DO j = 1 , N
               IF ( (udiag) .AND. (j<=M) ) THEN
                  sum = ONE
                  DO i = 1 , j - 1
                     sum = sum + ABS(A(i,j))
                  ENDDO
               ELSE
                  sum = ZERO
                  DO i = 1 , MIN(M,j)
                     sum = sum + ABS(A(i,j))
                  ENDDO
               ENDIF
               IF ( value<sum .OR. SISNAN(sum) ) value = sum
            ENDDO
         ELSE
            DO j = 1 , N
               IF ( udiag ) THEN
                  sum = ONE
                  DO i = j + 1 , M
                     sum = sum + ABS(A(i,j))
                  ENDDO
               ELSE
                  sum = ZERO
                  DO i = j , M
                     sum = sum + ABS(A(i,j))
                  ENDDO
               ENDIF
               IF ( value<sum .OR. SISNAN(sum) ) value = sum
            ENDDO
         ENDIF
      ELSEIF ( LSAME(Norm,'I') ) THEN
!
!        Find normI(A).
!
         IF ( LSAME(Uplo,'U') ) THEN
            IF ( LSAME(Diag,'U') ) THEN
               DO i = 1 , M
                  Work(i) = ONE
               ENDDO
               DO j = 1 , N
                  DO i = 1 , MIN(M,j-1)
                     Work(i) = Work(i) + ABS(A(i,j))
                  ENDDO
               ENDDO
            ELSE
               DO i = 1 , M
                  Work(i) = ZERO
               ENDDO
               DO j = 1 , N
                  DO i = 1 , MIN(M,j)
                     Work(i) = Work(i) + ABS(A(i,j))
                  ENDDO
               ENDDO
            ENDIF
         ELSEIF ( LSAME(Diag,'U') ) THEN
            DO i = 1 , MIN(M,N)
               Work(i) = ONE
            ENDDO
            DO i = N + 1 , M
               Work(i) = ZERO
            ENDDO
            DO j = 1 , N
               DO i = j + 1 , M
                  Work(i) = Work(i) + ABS(A(i,j))
               ENDDO
            ENDDO
         ELSE
            DO i = 1 , M
               Work(i) = ZERO
            ENDDO
            DO j = 1 , N
               DO i = j , M
                  Work(i) = Work(i) + ABS(A(i,j))
               ENDDO
            ENDDO
         ENDIF
         value = ZERO
         DO i = 1 , M
            sum = Work(i)
            IF ( value<sum .OR. SISNAN(sum) ) value = sum
         ENDDO
      ELSEIF ( (LSAME(Norm,'F')) .OR. (LSAME(Norm,'E')) ) THEN
!
!        Find normF(A).
!        SSQ(1) is scale
!        SSQ(2) is sum-of-squares
!        For better accuracy, sum each column separately.
!
         IF ( LSAME(Uplo,'U') ) THEN
            IF ( LSAME(Diag,'U') ) THEN
               ssq(1) = ONE
               ssq(2) = MIN(M,N)
               DO j = 2 , N
                  colssq(1) = ZERO
                  colssq(2) = ONE
                  CALL CLASSQ(MIN(M,j-1),A(1,j),1,colssq(1),colssq(2))
                  CALL SCOMBSSQ(ssq,colssq)
               ENDDO
            ELSE
               ssq(1) = ZERO
               ssq(2) = ONE
               DO j = 1 , N
                  colssq(1) = ZERO
                  colssq(2) = ONE
                  CALL CLASSQ(MIN(M,j),A(1,j),1,colssq(1),colssq(2))
                  CALL SCOMBSSQ(ssq,colssq)
               ENDDO
            ENDIF
         ELSEIF ( LSAME(Diag,'U') ) THEN
            ssq(1) = ONE
            ssq(2) = MIN(M,N)
            DO j = 1 , N
               colssq(1) = ZERO
               colssq(2) = ONE
               CALL CLASSQ(M-j,A(MIN(M,j+1),j),1,colssq(1),colssq(2))
               CALL SCOMBSSQ(ssq,colssq)
            ENDDO
         ELSE
            ssq(1) = ZERO
            ssq(2) = ONE
            DO j = 1 , N
               colssq(1) = ZERO
               colssq(2) = ONE
               CALL CLASSQ(M-j+1,A(j,j),1,colssq(1),colssq(2))
               CALL SCOMBSSQ(ssq,colssq)
            ENDDO
         ENDIF
         value = ssq(1)*SQRT(ssq(2))
      ENDIF
!
      CLANTR = value
!
!     End of CLANTR
!
      END FUNCTION CLANTR


      SUBROUTINE FFTR   (A,GAMN,N,IWK)
C
C-FFTR----------S-------LIBRARY 3---------------------------------------
C
C   FUNCTION            - TO COMPUTE THE FAST FOURIER TRANSFORM OF A
C                           REAL DATA SEQUENCE.
C   USAGE               - CALL FFTR(A,GAMN,N,IWK)
C   PARAMETERS   A      - REAL VECTOR OF LENGTH N WHICH, ON INPUT,
C                           CONTAINS THE DATA TO BE TRANSFORMED. ON
C                           OUTPUT, THE FIRST N/2 COMPLEX FOURIER COEF-
C                           FICIENTS ARE STORED IN THE N LOCATIONS OF
C                           A. THE (N/2+1)TH FOURIER COEFFICIENT IS
C                           CONTAINED IN GAMN (DESCRIBED BELOW). THE
C                           REMAINING COEFFICIENTS MAY BE DETERMINED BY
C                             A(N+2-I)=COMPLEX CONJUGATE OF A(I)
C                           FOR I = 2,3,4,...,N/2.
C                GAMN   - COMPLEX VARIABLE WHICH, ON OUTPUT, CONTAINS
C                           THE (N/2+1)TH FOURIER COEFFICIENT.
C                N      - LENGTH OF DATA VECTOR A. N MUST BE A
C                           POSITIVE EVEN INTEGER.
C                IWK    - WORK STORAGE. IF N IS ANY INTEGRAL POWER OF 2,
C                           SAY N=2**M, THEN IWK MUST HAVE LENGTH M. IF
C                           N IS NOT A POWER OF 2, THEN IWK MUST HAVE
C                           LENGTH 3(F+N)+26, WHERE F IS THE NUMBER OF
C                           PRIME FACTORS IN N/2.
C   PRECISION           - SINGLE
C   REQD. IMSL ROUTINES - FFRDR2,FFTP,FFT2
C   LANGUAGE            - FORTRAN
C-----------------------------------------------------------------------
C   LATEST REVISION     - OCTOBER 5,1973
C
      DIMENSION          IWK(1),A(1),G(2),B(2),Z(2)
      COMPLEX            A,GAMN,XIMAG,ALPH,BETA,GAM,S1,ZD
      EQUIVALENCE        (GAM,G(1)),(ALPH,B(1)),(Z,AR),(Z(2),AI),(ZD,Z)
      DATA               ZERO/0.0/,HALF/0.5/,ONE/1.0/
      DATA               RPI/3.1415926535898/,IMAX/24/
      IF (N .NE. 2) GO TO 5
      ZD = A(1)
      THETA = AR
      TP = AI
      GAMN = CMPLX(THETA-TP,ZERO)
      A(1) = CMPLX(THETA+TP,ZERO)
      GO TO 9005
    5 CONTINUE
      ND2 = N/2
C                                  COMPUTE THE CENTER COEFFICIENT
      GAM = CMPLX(ZERO,ZERO)
      DO 10 I=1,ND2
         GAM = GAM + A(I)
   10 CONTINUE
      TP = G(1)-G(2)
      GAM = CMPLX(TP,ZERO)
C                                  DETERMINE THE SMALLEST M SUCH THAT
C                                  N IS LESS THAN OR EQUAL TO 2**M
      MTWO = 2
      M = 1
      DO 15 I=1,IMAX
         IF (ND2 .LE. MTWO) GO TO 20
         MTWO = MTWO+MTWO
         M = M+1
   15 CONTINUE
   20 IF (ND2 .EQ. MTWO) GO TO 25
C                                  N IS NOT A POWER OF TWO, CALL THE
C                                  PRIME FACTOR FFT.
      CALL FFTP(A,ND2,IWK,IWK,IWK)
      GO TO 30
C                                  N IS A POWER OF TWO, CALL FFT2.
   25 CALL FFT2(A,M,IWK)
      CALL FFRDR2(A,M,IWK)
   30 ALPH = A(1)
      A(1) = B(1) + B(2)
      ND4 = (ND2+1)/2
      IF (ND4 .LT. 2) GO TO 40
      NP2 = ND2 + 2
      THETA = RPI/ND2
      TP = THETA
      XIMAG = CMPLX(ZERO,ONE)
C                                  DECOMPOSE THE COMPLEX VECTOR A
C                                  INTO THE COMPONENTS OF THE TRANSFORM
C                                  OF THE INPUT DATA.
      DO 35 K = 2,ND4
         NMK = NP2 - K
         S1 = CONJG(A(NMK))
         ALPH = A(K) + S1
         BETA = XIMAG*(S1-A(K))
         S1 = CMPLX(COS(THETA),SIN(THETA))
         A(K) = (ALPH+BETA*S1)*HALF
         A(NMK) = CONJG(ALPH-BETA*S1)*HALF
         THETA = THETA + TP
   35 CONTINUE
   40 CONTINUE
      GAMN = GAM
 9005 RETURN
      END
      SUBROUTINE FFRDR2 (A,M,IWK)
C
C-FFRDR2--------S-------LIBRARY 3---------------------------------------
C
C   FUNCTION            - THIS SUBROUTINE PERMUTES A COMPLEX DATA VECTOR
C                           IN REVERSE BINARY ORDER TO NORMAL ORDER. THE
C                           ROUTINE CAN ALSO BE USED TO PERMUTE A COM-
C                           PLEX DATA VECTOR IN NORMAL ORDER TO REVERSE
C                           BINARY ORDER SINCE THE PERMUTATION IS SYM-
C                           METRIC.
C   USAGE               - CALL FFRDR2(A,M,IWK)
C   PARAMETERS   A      - COMPLEX VECTOR OF LENGTH N=2**M WHICH CONTAINS
C                           ON INPUT THE DATA TO BE PERMUTED. ON OUTPUT,
C                           A CONTAINS THE PERMUTED DATA VECTOR.
C                M      - N=2**M IS THE NUMBER OF DATA POINTS.
C                IWK    - WORK AREA VECTOR OF LENGTH M+1
C   PRECISION           - SINGLE
C   LANGUAGE            - FORTRAN
C-----------------------------------------------------------------------
C   LATEST REVISION     - MARCH 16, 1973
C
      DIMENSION          IWK(1),A(1)
      COMPLEX            A,TEMP
C
      IF(M .LE. 1) GO TO 9005
      MP = M+1
      JJ = 1
C                                  INITIALIZE WORK VECTOR
      IWK(1) = 1
      DO 5  I = 2,MP
         IWK(I) = IWK(I-1) * 2
    5 CONTINUE
      N4 = IWK(MP-2)
      IF (M .GT. 2) N8 = IWK(MP-3)
      N2 = IWK(MP-1)
      LM = N2
      NN = IWK(MP)+1
      MP = MP-4
C                                  DETERMINE INDICES AND SWITCH A*S
      J = 2
   10 JK = JJ + N2
      TEMP = A(J)
      A(J) = A(JK)
      A(JK) = TEMP
      J = J+1
      IF (JJ .GT. N4) GO TO 15
      JJ = JJ + N4
      GO TO 35
   15 JJ = JJ - N4
      IF (JJ .GT. N8) GO TO 20
      JJ = JJ + N8
      GO TO 35
   20 JJ = JJ - N8
      K = MP
   25 IF (IWK(K) .GE. JJ) GO TO 30
      JJ = JJ - IWK(K)
      K = K - 1
      GO TO 25
   30 JJ = IWK(K) + JJ
   35 IF (JJ .LE. J) GO TO 40
      K = NN - J
      JK = NN - JJ
      TEMP = A(J)
      A(J) = A(JJ)
      A(JJ) = TEMP
      TEMP = A(K)
      A(K) = A(JK)
      A(JK) = TEMP
   40 J = J + 1
C                                  CYCLE REPEATED UNTIL LIMITING NUMBER
C                                    OF CHANGES IS ACHIEVED
      IF (J .LE. LM) GO TO 10
 9005 RETURN
      END
      SUBROUTINE FFT2   (A,M,IWK)
C
C-FFT2----------S-------LIBRARY 3---------------------------------------
C
C   FUNCTION            - COMPUTE THE FAST FOURIER TRANSFORM, GIVEN A
C                           COMPLEX VECTOR OF LENGTH EQUAL TO A POWER
C                           OF TWO
C   USAGE               - CALL FFT2(A,M,IWK)
C   PARAMETERS   A      - COMPLEX VECTOR OF LENGTH N=2**M WHICH CONTAINS
C                           ON INPUT THE DATA TO BE TRANSFORMED (ASSUMED
C                           TO BE IN NORMAL ORDER). ON OUTPUT, A CON-
C                           TAINS THE FOURIER COEFFICIENTS STORED IN
C                           REVERSE BINARY ORDER.
C                M      - N = 2**M IS THE NUMBER OF DATA POINTS.
C                IWK    - WORK AREA VECTOR OF LENGTH M+1.
C   PRECISION           - SINGLE
C   LANGUAGE            - FORTRAN
C-----------------------------------------------------------------------
C   LATEST REVISION     - OCTOBER 5,1973
C
      DIMENSION          IWK(1),A(1),Z0(2),Z1(2),Z2(2),Z3(2)
      COMPLEX            A,ZA0,ZA1,ZA2,ZA3,AK2
      EQUIVALENCE        (ZA0,Z0),(ZA1,Z1),(ZA2,Z2),(ZA3,Z3),
     *                   (A0,Z0(1)),(B0,Z0(2)),(A1,Z1(1)),(B1,Z1(2)),
     *                   (A2,Z2(1)),(B2,Z2(2)),(A3,Z3(1)),(B3,Z3(2))
      DATA               SQ,SK,CK /.70710678118655,.38268343236509,
     *                            .92387953251129/
      DATA               TWOPI/6.2831853071796/,ZERO/0.0/,ONE/1.0/
C                                  SQ=SQRT2/2,SK=SIN(PI/8),CK=COS(PI/8)
C                                  TWOPI=2*PI
      MP = M+1
      N = 2**M
      IWK(1) = 1
      MM = (M/2)*2
      KN = N+1
C                                  INITIALIZE WORK VECTOR
      DO 5  I=2,MP
         IWK(I) = IWK(I-1)+IWK(I-1)
    5 CONTINUE
      RAD = TWOPI/N
      MK = M - 4
      KB = 1
      IF (MM .EQ. M) GO TO 15
      K2 = KN
      K0 = IWK(MM+1) + KB
   10 K2 = K2 - 1
      K0 = K0 - 1
      AK2 = A(K2)
      A(K2) = A(K0)-AK2
      A(K0) = A(K0)+AK2
      IF (K0 .GT. KB) GO TO 10
   15 C1 = ONE
      S1 = ZERO
      JJ = 0
      K = MM - 1
      J = 4
      IF (K .GE. 1) GO TO 30
      GO TO 9005
   20 IF (IWK(J) .GT. JJ) GO TO 25
      JJ = JJ - IWK(J)
      J = J-1
      IF (IWK(J) .GT. JJ) GO TO 25
      JJ = JJ - IWK(J)
      J = J - 1
      K = K + 2
      GO TO 20
   25 JJ = IWK(J) + JJ
      J = 4
   30 ISP = IWK(K)
      IF (JJ .EQ. 0) GO TO 40
C                                  RESET TRIGONOMETRIC PARAMETERS
      C2 = JJ * ISP * RAD
      C1 = COS(C2)
      S1 = SIN(C2)
   35 C2 = C1 * C1 - S1 * S1
      S2 = C1 * (S1 + S1)
      C3 = C2 * C1 - S2 * S1
      S3 = C2 * S1 + S2 * C1
   40 JSP = ISP + KB
C                                  DETERMINE FOURIER COEFFICIENTS
C                                    IN GROUPS OF 4
      DO 50 I=1,ISP
         K0 = JSP - I
         K1 = K0 + ISP
         K2 = K1 + ISP
         K3 = K2 + ISP
         ZA0 = A(K0)
         ZA1 = A(K1)
         ZA2 = A(K2)
         ZA3 = A(K3)
         IF (S1 .EQ. ZERO) GO TO 45
         TEMP = A1
         A1 = A1 * C1 - B1 * S1
         B1 = TEMP * S1 + B1 * C1
         TEMP = A2
         A2 = A2 * C2 - B2 * S2
         B2 = TEMP * S2 + B2 * C2
         TEMP = A3
         A3 = A3 * C3 - B3 * S3
         B3 = TEMP * S3 + B3 * C3
   45    TEMP = A0 + A2
         A2 = A0 - A2
         A0 = TEMP
         TEMP = A1 + A3
         A3 = A1 - A3
         A1 = TEMP
         TEMP = B0 + B2
         B2 = B0 - B2
         B0 = TEMP
         TEMP = B1 + B3
         B3 = B1 - B3
         B1 = TEMP
         A(K0) = CMPLX(A0+A1,B0+B1)
         A(K1) = CMPLX(A0-A1,B0-B1)
         A(K2) = CMPLX(A2-B3,B2+A3)
         A(K3) = CMPLX(A2+B3,B2-A3)
   50 CONTINUE
      IF (K .LE. 1) GO TO 55
      K = K - 2
      GO TO 30
   55 KB = K3 + ISP
C                                  CHECK FOR COMPLETION OF FINAL
C                                    ITERATION
      IF (KN .LE. KB) GO TO 9005
      IF (J .NE. 1) GO TO 60
      K = 3
      J = MK
      GO TO 20
   60 J = J - 1
      C2 = C1
      IF (J .NE. 2) GO TO 65
      C1 = C1 * CK + S1 * SK
      S1 = S1 * CK - C2 * SK
      GO TO 35
   65 C1 = (C1 - S1) * SQ
      S1 = (C2 + S1) * SQ
      GO TO 35
 9005 RETURN
      END
      SUBROUTINE FFTP(A,N,I,J,K)
      RETURN
      END


    subroutine phbor(ct,alk,ah,sal,dens,ak1,ak2,akb)
!   ------------------------------------------------
    implicit none
    double precision ct,alk,ah,sal,dens,ak1,ak2,akb
    double precision cl,tbor,ba,sa,a,b,c,fah,dfah,residu,err

    cl=(sal-0.030)/1.8050
    tbor=2.19e-5*cl*dens
    ba=tbor/alk
    sa=ct/alk
    a=(akb*(1.-ba)+ak1*(1.-sa))*1.e+5
    b=(akb*(1.-ba-sa)+ak2*(1.-sa-sa))*ak1*1.e+10
    c=(1.-ba-sa-sa)*ak1*ak2*akb*1.e+15

!   methode de newton-raphson amelioree

    ah=max(abs(c),1.+abs(b),1.+abs(a))
    fah=c+ah*(b+ah*(a+ah))
    dfah=b+ah*(a+a+3.*ah)

!   commencer par des pas doubles jusqua ce que fah<0

 1    continue
    ah=ah-2.*fah/dfah
    fah=c+ah*(b+ah*(a+ah))
    dfah=b+ah*(a+a+3.*ah)
    if(fah.gt.0.)go to 1

!   continuer par newton-raphson classique

 2    continue
    residu=-fah/dfah
    ah=ah+residu
    fah=c+ah*(b+ah*(a+ah))
    dfah=b+ah*(a+a+3.*ah)
    err=abs(residu/ah)
    if(err.gt.1.e-3)go to 2

    ah=ah*1.e-5
    return
    end


!==========================================================================
elemental function gsw_sa_from_sp (sp, p, long, lat)
!==========================================================================
!
! Calculates Absolute Salinity, SA, from Practical Salinity, SP
!
! sp     : Practical Salinity                              [unitless]
! p      : sea pressure                                    [dbar]
! long   : longitude                                       [DEG E]
! lat    : latitude                                        [DEG N]
!
! gsw_sa_from_sp   : Absolute Salinity                     [g/kg]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_saar, gsw_sa_from_sp_baltic

use gsw_mod_error_functions, only : gsw_error_code, gsw_error_limit

use gsw_mod_teos10_constants, only : gsw_ups

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sp, p, long, lat

real (r8) :: gsw_sa_from_sp

real (r8) :: saar, sa_baltic

character (*), parameter :: func_name = "gsw_sa_from_sp"

sa_baltic = gsw_sa_from_sp_baltic(sp,long,lat)

if (sa_baltic .lt. 1e10_r8) then

   gsw_sa_from_sp = sa_baltic

else

   saar = gsw_saar(p,long,lat)
   if (saar .gt. gsw_error_limit) then
      gsw_sa_from_sp = gsw_error_code(1,func_name,saar)
   else
      gsw_sa_from_sp = gsw_ups*sp*(1.0_r8 + saar)
   end if

end if

return
end function

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


! chk_maxloc_backward.f90 --
!     Check if the compiler supports the BACK argument to MAXLOC and MINLOC
!
program chk_maxloc_backward
    implicit none

    integer, dimension(10) :: array = (/ 1, 5, 3, 4, 5, 1, 2, 3, 4, 5 /)

    write( *, '(a)' ) 'Location of minimum and maximum values - with duplicates'

    write( *, '(a,i5)' ) '    Minimum (first): ', minloc(array)
    write( *, '(a,i5)' ) '    Minimum (first): ', minloc(array, back = .false.)
    write( *, '(a,i5)' ) '    Minimum (last):  ', minloc(array, back = .true.)
    write( *, '(a,i5)' ) '    Maximum (first): ', maxloc(array)
    write( *, '(a,i5)' ) '    Maximum (first): ', maxloc(array, back = .false.)
    write( *, '(a,i5)' ) '    Maximum (last):  ', maxloc(array, back = .true.)

end program chk_maxloc_backward


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
 PROGRAM GALAHAD_SORT_TESTDEC
 USE GALAHAD_SORT_double             ! double precision version
 IMPLICIT NONE
 INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
 INTEGER, PARAMETER :: n = 20
 INTEGER :: i, m, inform
 INTEGER :: INDA( n ), IA( n )
 REAL ( KIND = wp ) :: A( n )

 WRITE( 6, "( /, ' Test error returns ', / )" )

 A( 1 ) = 1.0
 CALL SORT_heapsort_build( 0, A, inform )
 WRITE( 6, "( ' inform =  ', I2 )" ) inform
 CALL SORT_heapsort_build( 1, A, inform )
 CALL SORT_heapsort_smallest( 0, A, inform )
 WRITE( 6, "( ' inform =  ', I2 )" ) inform

 A = (/ -5.0, -7.0, 2.0, 9.0, 0.0, -3.0, 3.0, 5.0, -2.0, -6.0,                 &
         8.0, 7.0, -1.0, -8.0, 10.0, -4.0, 6.0, -9.0, 1.0, 4.0 /) ! values

 WRITE( 6, "( /, ' Order real values ', / )" )
 CALL SORT_heapsort_build( n, A, inform ) !  Build the heap
 DO i = 1, n
   m = n - i + 1
   CALL SORT_heapsort_smallest( m, A, inform ) !  Reorder the variables
   WRITE( 6, "( ' The ', I2, '-th(-st) smallest value is ',                    &
  &       F5.1 ) " ) i, A( m )
 END DO

 A = (/ -5.0, -7.0, 2.0, 9.0, 0.0, -3.0, 3.0, 5.0, -2.0, -6.0,                 &
         8.0, 7.0, -1.0, -8.0, 10.0, -4.0, 6.0, -9.0, 1.0, 4.0 /) ! values
 INDA = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,                      &
           15, 16, 17, 18, 19, 20 /) ! indices

 WRITE( 6, "( /, ' Order real values ', / )" )
 CALL SORT_heapsort_build( n, A, inform, INDA ) !  Build the heap
 DO i = 1, n
   m = n - i + 1
   CALL SORT_heapsort_smallest( m, A, inform, INDA ) !  Reorder the variables
   WRITE( 6, "( ' The ', I2, '-th(-st) smallest value, a(', I2, ') is ',       &
  &       F5.1 ) " ) i, INDA( m ), A( m )
 END DO

 IA = (/ -5, -7, 2, 9, 0, -3, 3, 5, -2, -6,                                    &
         8, 7, -1, -8, 10, -4, 6, -9, 1, 4 /) ! values
 INDA = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,                      &
           15, 16, 17, 18, 19, 20 /) ! indices

 WRITE( 6, "( /, ' Order integer values ', / )" )
 CALL SORT_heapsort_build( n, IA, inform ) !  Build the heap
 DO i = 1, n
   m = n - i + 1
   CALL SORT_heapsort_smallest( m, IA, inform ) !  Reorder the variables
   WRITE( 6, "( ' The ', I2, '-th(-st) smallest value is ',                    &
  &       I3 ) " ) i, IA( m )
 END DO

 IA = (/ -5, -7, 2, 9, 0, -3, 3, 5, -2, -6,                                    &
         8, 7, -1, -8, 10, -4, 6, -9, 1, 4 /) ! values
 INDA = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,                      &
           15, 16, 17, 18, 19, 20 /) ! indices

 WRITE( 6, "( /, ' Order integer values ', / )" )
 CALL SORT_heapsort_build( n, IA, inform, INDA ) !  Build the heap
 DO i = 1, n
   m = n - i + 1
   CALL SORT_heapsort_smallest( m, IA, inform, INDA ) !  Reorder the variables
   WRITE( 6, "( ' The ', I2, '-th(-st) smallest value, a(', I2, ') is ',       &
  &       I3 ) " ) i, INDA( m ), IA( m )
 END DO
 STOP
 END PROGRAM GALAHAD_SORT_TESTDEC


program SubtractTwoMatrices
    implicit none

    INTEGER::matA(3), matB(3), matAns(3), i

    print *, "Matrix A"
    do i = 1, 3
        read *, matA(i)
    end do

    print *, "Matrix B"
    do i = 1, 3
        read *, matB(i)
    end do

!Calculation of matAns
    do i = 1, 3
        matAns(i) = matA(i) - matB(i)
    end do

    print *, "Matrix Ans"
    print *, (matAns(i), i=1, 3)
end program SubtractTwoMatrices


      PROGRAM xirbit2
C     driver for routine irbit2
      INTEGER NBIN,NTRIES
      PARAMETER(NBIN=15,NTRIES=10000)
      INTEGER i,idum,iflg,ipts,irbit2,iseed,j,n
      REAL delay(NBIN)
      iseed=111
      do 11 i=1,NBIN
        delay(i)=0.0
11    continue
      ipts=0
      do 13 i=1,NTRIES
        if (irbit2(iseed).eq.1) then
          ipts=ipts+1
          iflg=0
          do 12 j=1,NBIN
            idum=irbit2(iseed)
            if ((idum.eq.1).and.(iflg.eq.0)) then
              iflg=1
              delay(j)=delay(j)+1.0
            endif
12        continue
        endif
13    continue
      write(*,*) 'Distribution of runs of N zeros'
      write(*,'(1x,t7,a,t16,a,t38,a)') 'N','Probability','Expected'
      do 14 n=1,NBIN
        write(*,'(1x,i6,f18.6,f20.6)')
     *       n-1,delay(n)/ipts,1/(2.0**n)
14    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xirbit2.for


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my,xlower,ylower,dx,dy,q,maux,aux)
  IMPLICIT NONE

  INTEGER :: meqn, mbc, mx, my, maux
  DOUBLE PRECISION :: xlower, ylower, dx, dy
  INTEGER*8 :: cont, get_context
  INTEGER :: blockno, fc2d_clawpack5_get_block
  DOUBLE PRECISION :: q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
  DOUBLE PRECISION :: aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

  INTEGER i,j
  DOUBLE PRECISION :: xc,yc,xp,yp,zp
  DOUBLE PRECISION :: cosine_bell_sum

  DOUBLE PRECISION :: a,b

  cont = get_context()
  blockno = fc2d_clawpack5_get_block()

  a = -0.8d0
  b = 0.9d0

  DO j = 1-mbc,my+mbc
        yc = ylower + (j-0.5d0)*dy
     DO i = 1-mbc,mx+mbc
        xc = xlower + (i-0.5d0)*dx
        CALL fclaw2d_map_c2m(cont, blockno,xc,yc,xp,yp,zp)
        q(1,i,j) = cosine_bell_sum(xp,yp,zp)
        IF (meqn .EQ. 2) THEN
           !! # Set non-linear relationship between two tracers
           q(2,i,j) = a*q(1,i,j)**2 + b
        ENDIF
     ENDDO
  ENDDO

  RETURN
END SUBROUTINE clawpack5_qinit


! This test was created from E:\nosave\code\gitrepos\pclausen\problem-specifications\exercises\collatz-conjecture\canonical-data.json
! version: None
!

program collatz_conjecture_test_main
  use TesterMain
  use collatz_conjecture
  implicit none

  ! Test 1: zero steps for one
  ! UUID 1: 540a3d51-e7a6-47a5-92a3-4ad1838f0bfd
  call assert_equal(0, steps(1), "zero steps for one")
  ! Test 2: divide if even
  ! UUID 2: 3d76a0a6-ea84-444a-821a-f7857c2c1859
  call assert_equal(4, steps(16), "divide if even")
  ! Test 3: even and odd steps
  ! UUID 3: 754dea81-123c-429e-b8bc-db20b05a87b9
  call assert_equal(9, steps(12), "even and odd steps")
  ! Test 4: large number of even and odd steps
  ! UUID 4: ecfd0210-6f85-44f6-8280-f65534892ff6
  call assert_equal(152, steps(1000000), "large number of even and odd steps")
  ! Test 5: zero is an error
  ! UUID 5: 7d4750e6-def9-4b86-aec7-9f7eb44f95a3
  ! ERROR: Only positive numbers are allowed
  call assert_equal(-1, steps(0), "zero is an error")
  ! Test 6: negative value is an error
  ! UUID 6: c6c795bf-a288-45e9-86a1-841359ad426d
  ! ERROR: Only positive numbers are allowed
  call assert_equal(-1, steps(-15), "negative value is an error")

  call test_report()

end program