!!  Create a 1-d hydrostatic, isoentropic atmosphere given the temperature,
!!  composition, and base density.  This version allows for an entropy
!!  decrease below a height base_height, to make the lower region
!!  convectively stable.
!!
!!  The model is placed into HSE by the following differencing:
!!
!!   (1/dr) [ <P>_i - <P>_{i-1} ] = (1/2) [ <rho>_i + <rho>_{i-1} ] g
!!
!!   We can take <P>_base and <rho>_base as given, and use the above
!!   to find all others.
!!
!!   This will be iterated over in tandem with the EOS call,
!!   P(i-1) = P_eos(rho(i-1), T(i-1), X(i-1)
!!

program init_1d

  use bl_types
  use bl_constants_module
  use bl_error_module
  use eos_module, only: eos_input_rt, eos, eos_init
  use eos_type_module, only: eos_t
  use extern_probin_module, only: use_eos_coulomb
  use network, only : nspec, network_species_index, spec_names, network_init

  implicit none

  integer :: i, n

  character(len=128) :: params_file

  real (kind=dp_t) :: temp_base, dens_base
  real (kind=dp_t), DIMENSION(nspec) :: xn_base

  real (kind=dp_t), allocatable :: xzn_hse(:)
  real (kind=dp_t), allocatable :: model_hse(:,:)

  real :: A, B

  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 from the network module
  integer :: ic12, io16, iash

  real (kind=dp_t) :: 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), allocatable :: entropy_store(:), entropy_want(:)

  real (kind=dp_t) :: g_zone

  real (kind=dp_t), parameter :: TOL = 1.e-10

  integer, parameter :: MAX_ITER = 250

  integer :: iter

  logical :: converged_hse, fluff

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

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

  real (kind=dp_t) :: entropy_jump, entropy_end, base_height

  logical :: do_coulomb

  integer :: index_base

  real (kind=dp_t) :: slope

  logical :: isentropic

  character (len=256) :: outfile
  character (len=8) :: num

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

  integer :: narg

  type (eos_t) :: eos_state

  namelist /params/ nx, xmin, xmax, base_height, entropy_jump, entropy_end, &
       dens_base, temp_base, g_zone, low_density_cutoff, temp_fluff, do_coulomb

  ! 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 = 640

  xmin = 0_dp_t
  xmax = 3.6d8

  base_height = 1.d8

  entropy_jump = 3.d0
  entropy_end  = 6.d0

  dens_base = 2.6d9
  temp_base = 7.d8

  g_zone = -1.5d10

  low_density_cutoff = 1.d-4
  temp_fluff = 1.d7

  ! 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)

  ! EOS stuff
  smallx = 1.d-10

  ! this comes in from extern_probin_module -- override here if desired
  use_eos_coulomb = do_coulomb

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

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

  ! ash can be either Mg24 or 'ash', depending on the network
  iash = network_species_index("magnesium-24")
  if (iash < 0) then
     iash = network_species_index("ash")
  endif

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

  xn_base(ic12) = 0.3_dp_t
  xn_base(io16) = 0.7_dp_t
  xn_base(iash) = 0.0_dp_t

!-----------------------------------------------------------------------------
! 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(model_hse(nx,nvar))
  allocate(entropy_want(nx))
  allocate(entropy_store(nx))

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

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

  index_base = -1

! find the index of the base height
  do i = 1, nx
     if (xzn_hse(i) >= base_height) then
        index_base = i
        exit
     endif
  enddo

  if (index_base == -1) then
     print *, 'ERROR: base_height not found on grid'
     call bl_error('ERROR: invalid base_height')
  endif

!-----------------------------------------------------------------------------
! put the model onto our new uniform grid
!-----------------------------------------------------------------------------

  fluff = .false.

  ! all the material above base_height will have constant entropy
  eos_state%T     = temp_base
  eos_state%rho   = dens_base
  eos_state%xn(:) = xn_base(:)

  print *, eos_state%T, eos_state%rho, eos_state%xn(:)

  call eos(eos_input_rt, eos_state)

  ! make the inital 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

  entropy = eos_state%s

  ! set the desired entropy profile
  do i = index_base, nx

     ! entropy is constant
     entropy_want(i) = entropy
     entropy_store(i) = entropy_want(i)
  enddo

  slope = (entropy/entropy_jump - entropy/entropy_end)/ &
       (xzn_hse(index_base) - xzn_hse(1))

  do i = index_base-1, 1, -1

     ! entropy gradient
     entropy_want(i) = slope*(xzn_hse(i) - xzn_hse(index_base-1)) + entropy/entropy_jump
     entropy_store(i) = entropy_want(i)
  enddo

!-----------------------------------------------------------------------------
! HSE + entropy solve
!-----------------------------------------------------------------------------

! the HSE state will be done putting creating an isentropic state until
! the temperature goes below temp_fluff -- then we will do isothermal.
! also, once the density goes below low_density_cutoff, we stop HSE

  isentropic = .true.

  !---------------------------------------------------------------------------
  ! integrate up
  !---------------------------------------------------------------------------
  do i = index_base+1, nx

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

     ! as the initial guess for the temperature and density, use the previous
     ! zone
     dens_zone = model_hse(i-1,idens)
     temp_zone = model_hse(i-1,itemp)
     xn(:) = model_hse(i,ispec:nvar)

     !-----------------------------------------------------------------------
     ! 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

              ! get the pressure we want from the HSE equation, just the
              ! zone below the current.  Note, we are using an average of
              ! the density of the two zones as an approximation of the
              ! interface value -- this means that we need to iterate for
              ! find the density and pressure that are consistent

              ! furthermore, we need to get the entropy that we need,
              ! which will come from adjusting the temperature in
              ! addition to the density.

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

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

              ! now we know the pressure and the entropy that we want, so we
              ! need to find the temperature and density through a two
              ! dimensional root find

              ! (t, rho) -> (p, s)
              eos_state%T     = temp_zone
              eos_state%rho   = dens_zone
              eos_state%xn(:) = xn(:)

              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_want(i) - entropy

              dtemp = ((dsd/(dpd-0.5*delx*g_zone))*A - B)/ &
                   (dsd*dpt/(dpd -0.5*delx*g_zone) - dst)

              drho = (A - dpt*dtemp)/(dpd - 0.5*delx*g_zone)

              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 (A < TOL .and. B < ETOL) then
              if (abs(drho) < TOL*dens_zone .and. abs(dtemp) < TOL*temp_zone) then
                 converged_hse = .TRUE.
                 exit
              endif

           else

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

              temp_zone = temp_fluff

              ! (t, rho) -> (p)
              eos_state%T     = temp_zone
              eos_state%rho   = dens_zone
              eos_state%xn(:) = xn(:)

              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*dens_zone) then
                 converged_hse = .TRUE.
                 exit
              endif

              if (dens_zone < low_density_cutoff) then

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

              endif

           endif

        enddo

        if (.NOT. converged_hse) then

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

        endif

        if (temp_zone < temp_fluff) then
           temp_zone = temp_fluff
           isentropic = .false.
        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
     ! (t, rho) -> (p)
     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     eos_state%xn(:) = xn(:)

     call eos(eos_input_rt, eos_state)

     pres_zone = eos_state%p

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

     ! to make this process converge faster, set the density in the next zone to
     ! the density in this zone
     ! model_hse(i+1,idens) = dens_zone

  enddo

  !---------------------------------------------------------------------------
  ! integrate down
  !---------------------------------------------------------------------------
  do i = index_base-1, 1, -1

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

     ! as the initial guess for the temperature and density, use the previous
     ! zone
     dens_zone = model_hse(i+1,idens)
     temp_zone = model_hse(i+1,itemp)
     xn(:) = model_hse(i,ispec:nvar)

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

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

     do iter = 1, MAX_ITER

        ! get the pressure we want from the HSE equation, just the
        ! zone below the current.  Note, we are using an average of
        ! the density of the two zones as an approximation of the
        ! interface value -- this means that we need to iterate for
        ! find the density and pressure that are consistent

        ! furthermore, we need to get the entropy that we need,
        ! which will come from adjusting the temperature in
        ! addition to the density.

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

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

        ! now we know the pressure and the entropy that we want, so we
        ! need to find the temperature and density through a two
        ! dimensional root find
        ! (t, rho) -> (p, s)
        eos_state%T     = temp_zone
        eos_state%rho   = dens_zone
        eos_state%xn(:) = xn(:)

        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_want(i) - entropy

        dtemp = ((dsd/(dpd+0.5*delx*g_zone))*A - B)/ &
             (dsd*dpt/(dpd +0.5*delx*g_zone) - dst)

        drho = (A - dpt*dtemp)/(dpd + 0.5*delx*g_zone)

        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))

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

     enddo

     if (.NOT. converged_hse) then

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

     endif

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

     call eos(eos_input_rt, eos_state)

     pres_zone = eos_state%p

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

  enddo

  write(num,'(i8)') nx
  outfile = "model.hse." // trim(adjustl(num))

  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

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

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

     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 *, ' '

  close (unit=50)

end program init_1d


      REAL             FUNCTION SREXP (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-07-16 SREXP Krogh  Change -1.0 to -1.E0.
C>> 1998-10-29 SREXP Krogh  Moved external statement up for mangle.
C>> 1994-10-20 SREXP Krogh  Changes to use M77CON
C>> 1994-05-20 SREXP WVS JPL Make SP and DP alike using CHGTYP
C>> 1993-05-06 SREXP WVS JPL Convert from NSWC to Math 77
c--S replaces "?": ?REXP
C ----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION EXP(X) - 1
c ----------------------------------------------------------------------
      REAL             X, EXMIN, ROUND, Z
      REAL             A0, A1, A2, A3, A4, B1, B2, B3, B4
      REAL             C1, C2, C3, C4, C5
      REAL             P1, P2, Q1, Q2, Q3, Q4
      EXTERNAL R1MACH
      REAL             R1MACH
C     EXMIN is the smallest number such that EXP(EXMIN) - 1 > -1.
C     ROUND is the smallest number such that ROUND + 1 > 1.
      SAVE EXMIN, ROUND
c --------------------------
C     CI = 1/FACTORIAL(I + 2)
c --------------------------
      PARAMETER (C1 = 1.0E0/6.0E0)
      PARAMETER (C2 = 1.0E0/24.0E0)
      PARAMETER (C3 = 1.0E0/120.0E0)
      PARAMETER (C4 = 1.0E0/720.0E0)
      PARAMETER (C5 = 1.0E0/5040.0E0)
c --------------------------
      DATA EXMIN /1.0E0/
      DATA A0/ .248015873015873015873016E-04/,
     *     A1/-.344452080605731005808147E-05/,
     *     A2/ .206664230430046597475413E-06/,
     *     A3/-.447300111094328162971036E-08/,
     *     A4/ .114734027080634968083920E-11/
      DATA B1/-.249994190011341852652396E+00/,
     *     B2/ .249987228833107957725728E-01/,
     *     B3/-.119037506846942249362528E-02/,
     *     B4/ .228908693387350391768682E-04/
c --------------------------
      DATA P1/ .914041914819518E-09/, P2/ .238082361044469E-01/,
     *     Q1/-.499999999085958E+00/, Q2/ .107141568980644E+00/,
     *     Q3/-.119041179760821E-01/, Q4/ .595130811860248E-03/
c ----------------------
      IF (EXMIN .GT. 0.0E0) THEN
         ROUND = R1MACH(4)
         EXMIN = LOG(ROUND)
      END IF
      IF (ABS(X) .LE. 0.15E0) THEN
         IF (ROUND .LT. 1.0E-14) THEN
C
C           Z IS A MINIMAX APPROXIMATION OF THE SERIES
C
C                C6 + C7*X + C8*X**2 + ....
C
C           THIS APPROXIMATION IS ACCURATE TO WITHIN
C           1 UNIT OF THE 23-RD SIGNIFICANT DIGIT.
C           THE RESULTING VALUE FOR SREXP IS ACCURATE TO
C           WITHIN 1 UNIT OF THE 33-RD SIGNIFICANT
C           DIGIT.
C
            Z = ((((A4*X + A3)*X + A2)*X + A1)*X + A0) /
     *          ((((B4*X + B3)*X + B2)*X + B1)*X + 1.E0)
            SREXP = X * (((((((Z*X + C5)*X + C4)*X + C3)*X + C2)*X +
     *                  C1)*X + 0.5E0)*X + 1.E0)
            RETURN
         END IF
         SREXP = X*(((P2*X + P1)*X + 1.0E0)/((((Q4*X + Q3)*X + Q2)*X +
     *           Q1)*X + 1.0E0))
         RETURN
      END IF
C
      IF (X .GE. 0.E0) THEN
         Z = EXP(X)
         SREXP = Z*(0.5E0 + (0.5E0 - 1.E0/Z))
         RETURN
      END IF
      IF (X .GE. EXMIN) THEN
         SREXP = (EXP(X) - 0.5E0) - 0.5E0
         RETURN
      END IF
      SREXP = -1.E0
      RETURN
      END


      SUBROUTINE DPBCO(ABD,LDA,N,M,RCOND,Z,INFO)                        00000010
      INTEGER LDA,N,M,INFO                                              00000020
      DOUBLE PRECISION ABD(LDA,1),Z(1)                                  00000030
      DOUBLE PRECISION RCOND                                            00000040
C                                                                       00000050
C     DPBCO FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE      00000060
C     MATRIX STORED IN BAND FORM AND ESTIMATES THE CONDITION OF THE     00000070
C     MATRIX.                                                           00000080
C                                                                       00000090
C     IF  RCOND  IS NOT NEEDED, DPBFA IS SLIGHTLY FASTER.               00000100
C     TO SOLVE  A*X = B , FOLLOW DPBCO BY DPBSL.                        00000110
C     TO COMPUTE  INVERSE(A)*C , FOLLOW DPBCO BY DPBSL.                 00000120
C     TO COMPUTE  DETERMINANT(A) , FOLLOW DPBCO BY DPBDI.               00000130
C                                                                       00000140
C     ON ENTRY                                                          00000150
C                                                                       00000160
C        ABD     DOUBLE PRECISION(LDA, N)                               00000170
C                THE MATRIX TO BE FACTORED.  THE COLUMNS OF THE UPPER   00000180
C                TRIANGLE ARE STORED IN THE COLUMNS OF ABD AND THE      00000190
C                DIAGONALS OF THE UPPER TRIANGLE ARE STORED IN THE      00000200
C                ROWS OF ABD .  SEE THE COMMENTS BELOW FOR DETAILS.     00000210
C                                                                       00000220
C        LDA     INTEGER                                                00000230
C                THE LEADING DIMENSION OF THE ARRAY  ABD .              00000240
C                LDA MUST BE .GE. M + 1 .                               00000250
C                                                                       00000260
C        N       INTEGER                                                00000270
C                THE ORDER OF THE MATRIX  A .                           00000280
C                                                                       00000290
C        M       INTEGER                                                00000300
C                THE NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.       00000310
C                0 .LE. M .LT. N .                                      00000320
C                                                                       00000330
C     ON RETURN                                                         00000340
C                                                                       00000350
C        ABD     AN UPPER TRIANGULAR MATRIX  R , STORED IN BAND         00000360
C                FORM, SO THAT  A = TRANS(R)*R .                        00000370
C                IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.   00000380
C                                                                       00000390
C        RCOND   DOUBLE PRECISION                                       00000400
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .        00000410
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS       00000420
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE             00000430
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND . 00000440
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION     00000450
C                           1.0 + RCOND .EQ. 1.0                        00000460
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING           00000470
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF         00000480
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE          00000490
C                UNDERFLOWS.  IF INFO .NE. 0 , RCOND IS UNCHANGED.      00000500
C                                                                       00000510
C        Z       DOUBLE PRECISION(N)                                    00000520
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.  00000530
C                IF  A  IS SINGULAR TO WORKING PRECISION, THEN  Z  IS   00000540
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT           00000550
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .                    00000560
C                IF  INFO .NE. 0 , Z  IS UNCHANGED.                     00000570
C                                                                       00000580
C        INFO    INTEGER                                                00000590
C                = 0  FOR NORMAL RETURN.                                00000600
C                = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR    00000610
C                     OF ORDER  K  IS NOT POSITIVE DEFINITE.            00000620
C                                                                       00000630
C     BAND STORAGE                                                      00000640
C                                                                       00000650
C           IF  A  IS A SYMMETRIC POSITIVE DEFINITE BAND MATRIX,        00000660
C           THE FOLLOWING PROGRAM SEGMENT WILL SET UP THE INPUT.        00000670
C                                                                       00000680
C                   M = (BAND WIDTH ABOVE DIAGONAL)                     00000690
C                   DO 20 J = 1, N                                      00000700
C                      I1 = MAX0(1, J-M)                                00000710
C                      DO 10 I = I1, J                                  00000720
C                         K = I-J+M+1                                   00000730
C                         ABD(K,J) = A(I,J)                             00000740
C                10    CONTINUE                                         00000750
C                20 CONTINUE                                            00000760
C                                                                       00000770
C           THIS USES  M + 1  ROWS OF  A , EXCEPT FOR THE  M BY M       00000780
C           UPPER LEFT TRIANGLE, WHICH IS IGNORED.                      00000790
C                                                                       00000800
C     EXAMPLE..  IF THE ORIGINAL MATRIX IS                              00000810
C                                                                       00000820
C           11 12 13  0  0  0                                           00000830
C           12 22 23 24  0  0                                           00000840
C           13 23 33 34 35  0                                           00000850
C            0 24 34 44 45 46                                           00000860
C            0  0 35 45 55 56                                           00000870
C            0  0  0 46 56 66                                           00000880
C                                                                       00000890
C     THEN  N = 6 , M = 2  AND  ABD  SHOULD CONTAIN                     00000900
C                                                                       00000910
C            *  * 13 24 35 46                                           00000920
C            * 12 23 34 45 56                                           00000930
C           11 22 33 44 55 66                                           00000940
C                                                                       00000950
C     LINPACK.  THIS VERSION DATED 08/14/78 .                           00000960
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.      00000970
C                                                                       00000980
C     SUBROUTINES AND FUNCTIONS                                         00000990
C                                                                       00001000
C     LINPACK DPBFA                                                     00001010
C     BLAS DAXPY,DDOT,DSCAL,DASUM                                       00001020
C     FORTRAN DABS,DMAX1,MAX0,MIN0,DREAL,DSIGN                          00001030
C                                                                       00001040
C     INTERNAL VARIABLES                                                00001050
C                                                                       00001060
      DOUBLE PRECISION DDOT,EK,T,WK,WKM                                 00001070
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM                           00001080
      INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU                             00001090
C                                                                       00001100
C                                                                       00001110
C     FIND NORM OF A                                                    00001120
C                                                                       00001130
      DO 30 J = 1, N                                                    00001140
         L = MIN0(J,M+1)                                                00001150
         MU = MAX0(M+2-J,1)                                             00001160
         Z(J) = DASUM(L,ABD(MU,J),1)                                    00001170
         K = J - L                                                      00001180
         IF (M .LT. MU) GO TO 20                                        00001190
         DO 10 I = MU, M                                                00001200
            K = K + 1                                                   00001210
            Z(K) = Z(K) + DABS(ABD(I,J))                                00001220
   10    CONTINUE                                                       00001230
   20    CONTINUE                                                       00001240
   30 CONTINUE                                                          00001250
      ANORM = 0.0D0                                                     00001260
      DO 40 J = 1, N                                                    00001270
         ANORM = DMAX1(ANORM,Z(J))                                      00001280
   40 CONTINUE                                                          00001290
C                                                                       00001300
C     FACTOR                                                            00001310
C                                                                       00001320
      CALL DPBFA(ABD,LDA,N,M,INFO)                                      00001330
      IF (INFO .NE. 0) GO TO 180                                        00001340
C                                                                       00001350
C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .           00001360
C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .      00001370
C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL        00001380
C        GROWTH IN THE ELEMENTS OF W  WHERE  TRANS(R)*W = E .           00001390
C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.         00001400
C                                                                       00001410
C        SOLVE TRANS(R)*W = E                                           00001420
C                                                                       00001430
         EK = 1.0D0                                                     00001440
         DO 50 J = 1, N                                                 00001450
            Z(J) = 0.0D0                                                00001460
   50    CONTINUE                                                       00001470
         DO 110 K = 1, N                                                00001480
            IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))                   00001490
            IF (DABS(EK-Z(K)) .LE. ABD(M+1,K)) GO TO 60                 00001500
               S = ABD(M+1,K)/DABS(EK-Z(K))                             00001510
               CALL DSCAL(N,S,Z,1)                                      00001520
               EK = S*EK                                                00001530
   60       CONTINUE                                                    00001540
            WK = EK - Z(K)                                              00001550
            WKM = -EK - Z(K)                                            00001560
            S = DABS(WK)                                                00001570
            SM = DABS(WKM)                                              00001580
            WK = WK/ABD(M+1,K)                                          00001590
            WKM = WKM/ABD(M+1,K)                                        00001600
            KP1 = K + 1                                                 00001610
            J2 = MIN0(K+M,N)                                            00001620
            I = M + 1                                                   00001630
            IF (KP1 .GT. J2) GO TO 100                                  00001640
               DO 70 J = KP1, J2                                        00001650
                  I = I - 1                                             00001660
                  SM = SM + DABS(Z(J)+WKM*ABD(I,J))                     00001670
                  Z(J) = Z(J) + WK*ABD(I,J)                             00001680
                  S = S + DABS(Z(J))                                    00001690
   70          CONTINUE                                                 00001700
               IF (S .GE. SM) GO TO 90                                  00001710
                  T = WKM - WK                                          00001720
                  WK = WKM                                              00001730
                  I = M + 1                                             00001740
                  DO 80 J = KP1, J2                                     00001750
                     I = I - 1                                          00001760
                     Z(J) = Z(J) + T*ABD(I,J)                           00001770
   80             CONTINUE                                              00001780
   90          CONTINUE                                                 00001790
  100       CONTINUE                                                    00001800
            Z(K) = WK                                                   00001810
  110    CONTINUE                                                       00001820
         S = 1.0D0/DASUM(N,Z,1)                                         00001830
         CALL DSCAL(N,S,Z,1)                                            00001840
C                                                                       00001850
C        SOLVE  R*Y = W                                                 00001860
C                                                                       00001870
         DO 130 KB = 1, N                                               00001880
            K = N + 1 - KB                                              00001890
            IF (DABS(Z(K)) .LE. ABD(M+1,K)) GO TO 120                   00001900
               S = ABD(M+1,K)/DABS(Z(K))                                00001910
               CALL DSCAL(N,S,Z,1)                                      00001920
  120       CONTINUE                                                    00001930
            Z(K) = Z(K)/ABD(M+1,K)                                      00001940
            LM = MIN0(K-1,M)                                            00001950
            LA = M + 1 - LM                                             00001960
            LB = K - LM                                                 00001970
            T = -Z(K)                                                   00001980
            CALL DAXPY(LM,T,ABD(LA,K),1,Z(LB),1)                        00001990
  130    CONTINUE                                                       00002000
         S = 1.0D0/DASUM(N,Z,1)                                         00002010
         CALL DSCAL(N,S,Z,1)                                            00002020
C                                                                       00002030
         YNORM = 1.0D0                                                  00002040
C                                                                       00002050
C        SOLVE TRANS(R)*V = Y                                           00002060
C                                                                       00002070
         DO 150 K = 1, N                                                00002080
            LM = MIN0(K-1,M)                                            00002090
            LA = M + 1 - LM                                             00002100
            LB = K - LM                                                 00002110
            Z(K) = Z(K) - DDOT(LM,ABD(LA,K),1,Z(LB),1)                  00002120
            IF (DABS(Z(K)) .LE. ABD(M+1,K)) GO TO 140                   00002130
               S = ABD(M+1,K)/DABS(Z(K))                                00002140
               CALL DSCAL(N,S,Z,1)                                      00002150
               YNORM = S*YNORM                                          00002160
  140       CONTINUE                                                    00002170
            Z(K) = Z(K)/ABD(M+1,K)                                      00002180
  150    CONTINUE                                                       00002190
         S = 1.0D0/DASUM(N,Z,1)                                         00002200
         CALL DSCAL(N,S,Z,1)                                            00002210
         YNORM = S*YNORM                                                00002220
C                                                                       00002230
C        SOLVE  R*Z = W                                                 00002240
C                                                                       00002250
         DO 170 KB = 1, N                                               00002260
            K = N + 1 - KB                                              00002270
            IF (DABS(Z(K)) .LE. ABD(M+1,K)) GO TO 160                   00002280
               S = ABD(M+1,K)/DABS(Z(K))                                00002290
               CALL DSCAL(N,S,Z,1)                                      00002300
               YNORM = S*YNORM                                          00002310
  160       CONTINUE                                                    00002320
            Z(K) = Z(K)/ABD(M+1,K)                                      00002330
            LM = MIN0(K-1,M)                                            00002340
            LA = M + 1 - LM                                             00002350
            LB = K - LM                                                 00002360
            T = -Z(K)                                                   00002370
            CALL DAXPY(LM,T,ABD(LA,K),1,Z(LB),1)                        00002380
  170    CONTINUE                                                       00002390
C        MAKE ZNORM = 1.0                                               00002400
         S = 1.0D0/DASUM(N,Z,1)                                         00002410
         CALL DSCAL(N,S,Z,1)                                            00002420
         YNORM = S*YNORM                                                00002430
C                                                                       00002440
         IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM                      00002450
         IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0                            00002460
  180 CONTINUE                                                          00002470
      RETURN                                                            00002480
      END                                                               00002490


*> \brief \b DLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using the double-shift/single-shift QR algorithm.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAHQR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
*                          ILOZ, IHIZ, Z, LDZ, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
*       LOGICAL            WANTT, WANTZ
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    DLAHQR is an auxiliary routine called by DHSEQR to update the
*>    eigenvalues and Schur decomposition already computed by DHSEQR, by
*>    dealing with the Hessenberg submatrix in rows and columns ILO to
*>    IHI.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] WANTT
*> \verbatim
*>          WANTT is LOGICAL
*>          = .TRUE. : the full Schur form T is required;
*>          = .FALSE.: only eigenvalues are required.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*>          WANTZ is LOGICAL
*>          = .TRUE. : the matrix of Schur vectors Z is required;
*>          = .FALSE.: Schur vectors are not required.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix H.  N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*>          ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*>          IHI is INTEGER
*>          It is assumed that H is already upper quasi-triangular in
*>          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
*>          ILO = 1). DLAHQR works primarily with the Hessenberg
*>          submatrix in rows and columns ILO to IHI, but applies
*>          transformations to all of H if WANTT is .TRUE..
*>          1 <= ILO <= max(1,IHI); IHI <= N.
*> \endverbatim
*>
*> \param[in,out] H
*> \verbatim
*>          H is DOUBLE PRECISION array, dimension (LDH,N)
*>          On entry, the upper Hessenberg matrix H.
*>          On exit, if INFO is zero and if WANTT is .TRUE., H is upper
*>          quasi-triangular in rows and columns ILO:IHI, with any
*>          2-by-2 diagonal blocks in standard form. If INFO is zero
*>          and WANTT is .FALSE., the contents of H are unspecified on
*>          exit.  The output state of H if INFO is nonzero is given
*>          below under the description of INFO.
*> \endverbatim
*>
*> \param[in] LDH
*> \verbatim
*>          LDH is INTEGER
*>          The leading dimension of the array H. LDH >= max(1,N).
*> \endverbatim
*>
*> \param[out] WR
*> \verbatim
*>          WR is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] WI
*> \verbatim
*>          WI is DOUBLE PRECISION array, dimension (N)
*>          The real and imaginary parts, respectively, of the computed
*>          eigenvalues ILO to IHI are stored in the corresponding
*>          elements of WR and WI. If two eigenvalues are computed as a
*>          complex conjugate pair, they are stored in consecutive
*>          elements of WR and WI, say the i-th and (i+1)th, with
*>          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
*>          eigenvalues are stored in the same order as on the diagonal
*>          of the Schur form returned in H, with WR(i) = H(i,i), and, if
*>          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
*>          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
*> \endverbatim
*>
*> \param[in] ILOZ
*> \verbatim
*>          ILOZ is INTEGER
*> \endverbatim
*>
*> \param[in] IHIZ
*> \verbatim
*>          IHIZ is INTEGER
*>          Specify the rows of Z to which transformations must be
*>          applied if WANTZ is .TRUE..
*>          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*>          Z is DOUBLE PRECISION array, dimension (LDZ,N)
*>          If WANTZ is .TRUE., on entry Z must contain the current
*>          matrix Z of transformations accumulated by DHSEQR, and on
*>          exit Z has been updated; transformations are applied only to
*>          the submatrix Z(ILOZ:IHIZ,ILO:IHI).
*>          If WANTZ is .FALSE., Z is not referenced.
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*>          LDZ is INTEGER
*>          The leading dimension of the array Z. LDZ >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>           = 0:  successful exit
*>           > 0:  If INFO = i, DLAHQR failed to compute all the
*>                  eigenvalues ILO to IHI in a total of 30 iterations
*>                  per eigenvalue; elements i+1:ihi of WR and WI
*>                  contain those eigenvalues which have been
*>                  successfully computed.
*>
*>                  If INFO > 0 and WANTT is .FALSE., then on exit,
*>                  the remaining unconverged eigenvalues are the
*>                  eigenvalues of the upper Hessenberg matrix rows
*>                  and columns ILO through INFO of the final, output
*>                  value of H.
*>
*>                  If INFO > 0 and WANTT is .TRUE., then on exit
*>          (*)       (initial value of H)*U  = U*(final value of H)
*>                  where U is an orthogonal matrix.    The final
*>                  value of H is upper Hessenberg and triangular in
*>                  rows and columns INFO+1 through IHI.
*>
*>                  If INFO > 0 and WANTZ is .TRUE., then on exit
*>                      (final value of Z)  = (initial value of Z)*U
*>                  where U is the orthogonal matrix in (*)
*>                  (regardless of the value of WANTT.)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>     02-96 Based on modifications by
*>     David Day, Sandia National Laboratory, USA
*>
*>     12-04 Further modifications by
*>     Ralph Byers, University of Kansas, USA
*>     This is a modified version of DLAHQR from LAPACK version 3.0.
*>     It is (1) more robust against overflow and underflow and
*>     (2) adopts the more conservative Ahues & Tisseur stopping
*>     criterion (LAWN 122, 1997).
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
     $                   ILOZ, IHIZ, Z, LDZ, INFO )
*
*  -- 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
*
*     .. Scalar Arguments ..
      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
      LOGICAL            WANTT, WANTZ
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
*     ..
*
*  =========================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 )
      DOUBLE PRECISION   DAT1, DAT2
      PARAMETER          ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
     $                   H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
     $                   SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
     $                   ULP, V2, V3
      INTEGER            I, I1, I2, ITS, ITMAX, J, K, L, M, NH, NR, NZ
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   V( 3 )
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DLABAD, DLANV2, DLARFG, DROT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
      IF( ILO.EQ.IHI ) THEN
         WR( ILO ) = H( ILO, ILO )
         WI( ILO ) = ZERO
         RETURN
      END IF
*
*     ==== clear out the trash ====
      DO 10 J = ILO, IHI - 3
         H( J+2, J ) = ZERO
         H( J+3, J ) = ZERO
   10 CONTINUE
      IF( ILO.LE.IHI-2 )
     $   H( IHI, IHI-2 ) = ZERO
*
      NH = IHI - ILO + 1
      NZ = IHIZ - ILOZ + 1
*
*     Set machine-dependent constants for the stopping criterion.
*
      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
      SAFMAX = ONE / SAFMIN
      CALL DLABAD( SAFMIN, SAFMAX )
      ULP = DLAMCH( 'PRECISION' )
      SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
*
*     I1 and I2 are the indices of the first row and last column of H
*     to which transformations must be applied. If eigenvalues only are
*     being computed, I1 and I2 are set inside the main loop.
*
      IF( WANTT ) THEN
         I1 = 1
         I2 = N
      END IF
*
*     ITMAX is the total number of QR iterations allowed.
*
      ITMAX = 30 * MAX( 10, NH )
*
*     The main loop begins here. I is the loop index and decreases from
*     IHI to ILO in steps of 1 or 2. Each iteration of the loop works
*     with the active submatrix in rows and columns L to I.
*     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
*     H(L,L-1) is negligible so that the matrix splits.
*
      I = IHI
   20 CONTINUE
      L = ILO
      IF( I.LT.ILO )
     $   GO TO 160
*
*     Perform QR iterations on rows and columns ILO to I until a
*     submatrix of order 1 or 2 splits off at the bottom because a
*     subdiagonal element has become negligible.
*
      DO 140 ITS = 0, ITMAX
*
*        Look for a single small subdiagonal element.
*
         DO 30 K = I, L + 1, -1
            IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
     $         GO TO 40
            TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
            IF( TST.EQ.ZERO ) THEN
               IF( K-2.GE.ILO )
     $            TST = TST + ABS( H( K-1, K-2 ) )
               IF( K+1.LE.IHI )
     $            TST = TST + ABS( H( K+1, K ) )
            END IF
*           ==== The following is a conservative small subdiagonal
*           .    deflation  criterion due to Ahues & Tisseur (LAWN 122,
*           .    1997). It has better mathematical foundation and
*           .    improves accuracy in some cases.  ====
            IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
               AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
               BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
               AA = MAX( ABS( H( K, K ) ),
     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
               BB = MIN( ABS( H( K, K ) ),
     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
               S = AA + AB
               IF( BA*( AB / S ).LE.MAX( SMLNUM,
     $             ULP*( BB*( AA / S ) ) ) )GO TO 40
            END IF
   30    CONTINUE
   40    CONTINUE
         L = K
         IF( L.GT.ILO ) THEN
*
*           H(L,L-1) is negligible
*
            H( L, L-1 ) = ZERO
         END IF
*
*        Exit from loop if a submatrix of order 1 or 2 has split off.
*
         IF( L.GE.I-1 )
     $      GO TO 150
*
*        Now the active submatrix is in rows and columns L to I. If
*        eigenvalues only are being computed, only the active submatrix
*        need be transformed.
*
         IF( .NOT.WANTT ) THEN
            I1 = L
            I2 = I
         END IF
*
         IF( ITS.EQ.10 ) THEN
*
*           Exceptional shift.
*
            S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) )
            H11 = DAT1*S + H( L, L )
            H12 = DAT2*S
            H21 = S
            H22 = H11
         ELSE IF( ITS.EQ.20 ) THEN
*
*           Exceptional shift.
*
            S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
            H11 = DAT1*S + H( I, I )
            H12 = DAT2*S
            H21 = S
            H22 = H11
         ELSE
*
*           Prepare to use Francis' double shift
*           (i.e. 2nd degree generalized Rayleigh quotient)
*
            H11 = H( I-1, I-1 )
            H21 = H( I, I-1 )
            H12 = H( I-1, I )
            H22 = H( I, I )
         END IF
         S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
         IF( S.EQ.ZERO ) THEN
            RT1R = ZERO
            RT1I = ZERO
            RT2R = ZERO
            RT2I = ZERO
         ELSE
            H11 = H11 / S
            H21 = H21 / S
            H12 = H12 / S
            H22 = H22 / S
            TR = ( H11+H22 ) / TWO
            DET = ( H11-TR )*( H22-TR ) - H12*H21
            RTDISC = SQRT( ABS( DET ) )
            IF( DET.GE.ZERO ) THEN
*
*              ==== complex conjugate shifts ====
*
               RT1R = TR*S
               RT2R = RT1R
               RT1I = RTDISC*S
               RT2I = -RT1I
            ELSE
*
*              ==== real shifts (use only one of them)  ====
*
               RT1R = TR + RTDISC
               RT2R = TR - RTDISC
               IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
                  RT1R = RT1R*S
                  RT2R = RT1R
               ELSE
                  RT2R = RT2R*S
                  RT1R = RT2R
               END IF
               RT1I = ZERO
               RT2I = ZERO
            END IF
         END IF
*
*        Look for two consecutive small subdiagonal elements.
*
         DO 50 M = I - 2, L, -1
*           Determine the effect of starting the double-shift QR
*           iteration at row M, and see if this would make H(M,M-1)
*           negligible.  (The following uses scaling to avoid
*           overflows and most underflows.)
*
            H21S = H( M+1, M )
            S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
            H21S = H( M+1, M ) / S
            V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
     $               ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
            V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
            V( 3 ) = H21S*H( M+2, M+1 )
            S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
            V( 1 ) = V( 1 ) / S
            V( 2 ) = V( 2 ) / S
            V( 3 ) = V( 3 ) / S
            IF( M.EQ.L )
     $         GO TO 60
            IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
     $          ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
     $          M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
   50    CONTINUE
   60    CONTINUE
*
*        Double-shift QR step
*
         DO 130 K = M, I - 1
*
*           The first iteration of this loop determines a reflection G
*           from the vector V and applies it from left and right to H,
*           thus creating a nonzero bulge below the subdiagonal.
*
*           Each subsequent iteration determines a reflection G to
*           restore the Hessenberg form in the (K-1)th column, and thus
*           chases the bulge one step toward the bottom of the active
*           submatrix. NR is the order of G.
*
            NR = MIN( 3, I-K+1 )
            IF( K.GT.M )
     $         CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
            CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
            IF( K.GT.M ) THEN
               H( K, K-1 ) = V( 1 )
               H( K+1, K-1 ) = ZERO
               IF( K.LT.I-1 )
     $            H( K+2, K-1 ) = ZERO
            ELSE IF( M.GT.L ) THEN
*               ==== Use the following instead of
*               .    H( K, K-1 ) = -H( K, K-1 ) to
*               .    avoid a bug when v(2) and v(3)
*               .    underflow. ====
               H( K, K-1 ) = H( K, K-1 )*( ONE-T1 )
            END IF
            V2 = V( 2 )
            T2 = T1*V2
            IF( NR.EQ.3 ) THEN
               V3 = V( 3 )
               T3 = T1*V3
*
*              Apply G from the left to transform the rows of the matrix
*              in columns K to I2.
*
               DO 70 J = K, I2
                  SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
                  H( K, J ) = H( K, J ) - SUM*T1
                  H( K+1, J ) = H( K+1, J ) - SUM*T2
                  H( K+2, J ) = H( K+2, J ) - SUM*T3
   70          CONTINUE
*
*              Apply G from the right to transform the columns of the
*              matrix in rows I1 to min(K+3,I).
*
               DO 80 J = I1, MIN( K+3, I )
                  SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
                  H( J, K ) = H( J, K ) - SUM*T1
                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
                  H( J, K+2 ) = H( J, K+2 ) - SUM*T3
   80          CONTINUE
*
               IF( WANTZ ) THEN
*
*                 Accumulate transformations in the matrix Z
*
                  DO 90 J = ILOZ, IHIZ
                     SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
                     Z( J, K ) = Z( J, K ) - SUM*T1
                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
                     Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
   90             CONTINUE
               END IF
            ELSE IF( NR.EQ.2 ) THEN
*
*              Apply G from the left to transform the rows of the matrix
*              in columns K to I2.
*
               DO 100 J = K, I2
                  SUM = H( K, J ) + V2*H( K+1, J )
                  H( K, J ) = H( K, J ) - SUM*T1
                  H( K+1, J ) = H( K+1, J ) - SUM*T2
  100          CONTINUE
*
*              Apply G from the right to transform the columns of the
*              matrix in rows I1 to min(K+3,I).
*
               DO 110 J = I1, I
                  SUM = H( J, K ) + V2*H( J, K+1 )
                  H( J, K ) = H( J, K ) - SUM*T1
                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
  110          CONTINUE
*
               IF( WANTZ ) THEN
*
*                 Accumulate transformations in the matrix Z
*
                  DO 120 J = ILOZ, IHIZ
                     SUM = Z( J, K ) + V2*Z( J, K+1 )
                     Z( J, K ) = Z( J, K ) - SUM*T1
                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
  120             CONTINUE
               END IF
            END IF
  130    CONTINUE
*
  140 CONTINUE
*
*     Failure to converge in remaining number of iterations
*
      INFO = I
      RETURN
*
  150 CONTINUE
*
      IF( L.EQ.I ) THEN
*
*        H(I,I-1) is negligible: one eigenvalue has converged.
*
         WR( I ) = H( I, I )
         WI( I ) = ZERO
      ELSE IF( L.EQ.I-1 ) THEN
*
*        H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
*
*        Transform the 2-by-2 submatrix to standard Schur form,
*        and compute and store the eigenvalues.
*
         CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
     $                H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
     $                CS, SN )
*
         IF( WANTT ) THEN
*
*           Apply the transformation to the rest of H.
*
            IF( I2.GT.I )
     $         CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
     $                    CS, SN )
            CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
         END IF
         IF( WANTZ ) THEN
*
*           Apply the transformation to Z.
*
            CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
         END IF
      END IF
*
*     return to start of the main loop with new value of I.
*
      I = L - 1
      GO TO 20
*
  160 CONTINUE
      RETURN
*
*     End of DLAHQR
*
      END


! -*- mode: F90; mode: font-lock -*-
! ------------------------------------------------------------------------------
! $Id$
! ------------------------------------------------------------------------------
! Module functions
! ------------------------------------------------------------------------------
! Code area 9: general
! ------------------------------------------------------------------------------

!!****h* Conquest/functions *
!!  NAME
!!   functions
!!  PURPOSE
!!   Collects mathematical and other useful functions in one module
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   2016/02/09
!!  MODIFICATION HISTORY
!!   2019/11/12 08:13 dave
!!    Adding sort routines
!!  SOURCE
!!
module functions

  implicit none

  !!***

contains

  ! -----------------------------------------------------------
  ! Function erfc
  ! -----------------------------------------------------------

  !!****f* DiagModle/erfc *
  !!
  !!  NAME
  !!   erfc
  !!  USAGE
  !!   erfc(x)
  !!  PURPOSE
  !!   Calculated the complementary error function to rounding-error
  !!   based on erfc() in ewald_module
  !!   accuracy
  !!  INPUTS
  !!   real(double) :: x, argument of complementary error function
  !!  AUTHOR
  !!   Iain Chapman/Lianeng Tong
  !!  CREATION DATE
  !!   2001 sometime/2010/07/26
  !!  MODIFICATION HISTORY
  !!   2016/02/09 08:14 dave
  !!    Moved to functions module from DiagModule
  !!  SOURCE
  !!
  real(double) function erfc_cq(x)

    use datatypes
    use numbers,  only: RD_ERR, one, zero, half, two
    use GenComms, only: cq_abort

    implicit none

    real(double), parameter :: erfc_delta = 1.0e-12_double, &
         erfc_gln = 0.5723649429247447e0_double, &
         erfc_fpmax = 1.e30_double
    integer, parameter:: erfc_iterations = 10000

    real(double), intent(in) :: x

    ! local variables
    real(double) :: y, y2
    real(double) :: ap, sum, del
    real(double) :: an, b, c, d
    integer :: i

    if(x < zero) then
       y = -x
    else
       y = x
    end if
    ! This expects y^2
    y2 = y*y
    if(y<RD_ERR) then
       erfc_cq = one
       return
    end if
    if (y2 < 2.25_double) then
       ap = half
       sum = two
       del = sum
       do i = 1, erfc_iterations
          ap = ap + 1.0_double
          del = del * y2 / ap
          sum = sum + del
          if (abs(del) < abs(sum) * erfc_delta) exit
       end do
       erfc_cq = one - sum * exp(-y2 + half * log(y2) - erfc_gln)
    else
       b = y2 + half
       c = erfc_fpmax
       d = one / b
       sum = d
       do i = 1, erfc_iterations
          an = - i * (i - half)
          b = b + two
          d = an * d + b
          c = b + an / c
          d = one / d
          del = d * c
          sum = sum * del
          if (abs(del - one) < erfc_delta) exit
       end do
       erfc_cq = sum * exp(-y2 + half * log(y2) - erfc_gln)
    end if
    if (x < zero) erfc_cq = two - erfc_cq
    return
  end function erfc_cq
  !!***

!!****f* functions/j0 *
!!
!!  NAME
!!   j0
!!  USAGE
!!
!!  PURPOSE
!!   Calculates 0th-order Bessel function
!! INPUTS
!!   x
!! OUTPUTS
!!
!!  USES
!!
!!  AUTHOR
!!   N. Watanabe (Mizuho) with TM, DRB
!!  CREATION DATE
!!   2014
!!  MODIFICATION HISTORY
!!   2015/11/09 17:28 dave
!!    - Moved into pseudo_tm_module
!!   2016/02/09 08:23 dave
!!    Moved into functions module
!!  SOURCE
!!
  function j0( x )

    use datatypes
    use numbers, only: very_small, one_sixth, one

    implicit none

    real(double) :: x
    real(double) :: j0

    if( x<very_small ) then
       j0 = one - one_sixth*x*x
    else
       j0 = sin(x)/x
    endif
  end function j0
!!***

!!****f* functions/j1 *
!!
!!  NAME
!!   j1
!!  USAGE
!!
!!  PURPOSE
!!   1st order bessel function with provision for very small numbers
!!  INPUTS
!!
!!
!!  USES
!!
!!  AUTHOR
!!   NW (Mizuho) with TM and DRB
!!  CREATION DATE
!!   Mid 2014
!!  MODIFICATION HISTORY
!!   2016/02/09 08:24 dave
!!    Moved to functions module
!!  SOURCE
!!
  function j1x( x )

    use datatypes
    use numbers

    implicit none

    real(double) :: x
    real(double) :: j1x

    if( x<very_small ) then
       j1x = one_third - one/30.0_double*x*x
    else
       j1x = (sin(x)-x*cos(x))/(x*x*x)
    endif
  end function j1x
!!***

  !!****f* functions/heapsort_integer_index *
  !!
  !!  NAME
  !!   heapsort_integer_index
  !!  USAGE
  !!
  !!  PURPOSE
  !!   Heap sort for an integer array returning sorted index (not in-place)
  !!   Note that this may appear subtly different to standard implementations
  !!   Arrays starting at 1 have different parent/child formulae to arrays
  !!   starting at 0.  Contains the sift_down routine.
  !!  INPUTS
  !!
  !!
  !!  USES
  !!
  !!  AUTHOR
  !!   David Bowler
  !!  CREATION DATE
  !!   2019/11/12
  !!  MODIFICATION HISTORY
  !!  SOURCE
  !!
  subroutine heapsort_integer_index(n_arr,array,arr_index,reverse)

    ! Passed variables
    integer :: n_arr
    integer, OPTIONAL :: reverse
    integer, dimension(n_arr) :: array
    integer, dimension(n_arr) :: arr_index, tmp_index

    ! Local variables
    integer :: i, temp

    ! Set up index
    do i=1,n_arr
       arr_index(i) = i
    end do
    if(n_arr==1) return
    ! Create heap
    do i = n_arr/2, 1, -1
       call sift_down_integer_index(i, n_arr)
    end do
    ! Sort array
    do i=n_arr, 2, -1
       temp = arr_index(1)
       arr_index(1) = arr_index(i)
       arr_index(i) = temp
       call sift_down_integer_index(1, i-1)
    end do
    if(present(reverse)) then
       if(reverse==1) then
          do i=1,n_arr
             tmp_index(n_arr-i+1) = arr_index(i)
          end do
          arr_index = tmp_index
       end if
    end if
    return

  contains

    ! Note that we inherit access to array and arr_index while this is contained
    ! in the original routine
    subroutine sift_down_integer_index(start,end)

      ! Passed variables
      integer :: start, end

      ! Local variables
      integer :: child, root, temp

      root = start
      ! Left child is i*2
      child = root*2
      do while(child<=end)
         ! Right child is i*2 + 1
         if(child+1<=end) then
            if(array(arr_index(child))<array(arr_index(child+1))) child = child+1
         end if
         if(array(arr_index(root))<array(arr_index(child))) then
            temp = arr_index(child)
            arr_index(child) = arr_index(root)
            arr_index(root) = temp
            root = child
            child = root*2
         else
            return
         end if
      end do
      return
    end subroutine sift_down_integer_index

  end subroutine heapsort_integer_index

  !!****f* functions/heapsort_real_index *
  !!
  !!  NAME
  !!   heapsort_real_index
  !!  USAGE
  !!
  !!  PURPOSE
  !!   Heap sort for an integer array returning sorted index (not in-place)
  !!   Note that this may appear subtly different to standard implementations
  !!   Arrays starting at 1 have different parent/child formulae to arrays
  !!   starting at 0.  Contains the sift_down routine.
  !!
  !!   Contains optional flag to signal descending rather than ascending order
  !!  INPUTS
  !!
  !!
  !!  USES
  !!
  !!  AUTHOR
  !!   David Bowler
  !!  CREATION DATE
  !!   2019/11/12
  !!  MODIFICATION HISTORY
  !!   2020/01/24 08:05 dave
  !!    Corrected type of temp to integer
  !!  SOURCE
  !!
  subroutine heapsort_real_index(n_arr,array,arr_index,reverse)

    use datatypes

    implicit none

    ! Passed variables
    integer :: n_arr
    integer, OPTIONAL :: reverse
    real(double), dimension(n_arr) :: array
    integer, dimension(n_arr) :: arr_index, tmp_index

    ! Local variables
    integer :: i, temp

    ! Set up index
    do i=1,n_arr
       arr_index(i) = i
    end do
    if(n_arr==1) return
    ! Create heap
    do i = n_arr/2, 1, -1
       call sift_down_real_index(i, n_arr)
    end do
    ! Sort array
    do i=n_arr, 2, -1
       temp = arr_index(1)
       arr_index(1) = arr_index(i)
       arr_index(i) = temp
       call sift_down_real_index(1, i-1)
    end do
    ! Reverse order (descending) if required
    if(present(reverse)) then
       if(reverse==1) then
          do i=1,n_arr
             tmp_index(n_arr-i+1) = arr_index(i)
          end do
          arr_index = tmp_index
       end if
    end if
    return

  contains

    ! Note that we inherit access to array and arr_index while this is contained
    ! in the original routine
    subroutine sift_down_real_index(start,end)

      use datatypes

      implicit none

      ! Passed variables
      integer :: start, end

      ! Local variables
      integer :: child, root, temp

      root = start
      ! Left child is i*2
      child = root*2
      do while(child<=end)
         ! Right child is i*2 + 1
         if(child+1<=end) then
            if(array(arr_index(child))<array(arr_index(child+1))) child = child+1
         end if
         if(array(arr_index(root))<array(arr_index(child))) then
            temp = arr_index(child)
            arr_index(child) = arr_index(root)
            arr_index(root) = temp
            root = child
            child = root*2
         else
            return
         end if
      end do
      return
    end subroutine sift_down_real_index

  end subroutine heapsort_real_index

end module functions


module reducedgrid_mod

! Module for transforming between reg (or gaussian) lat/lon
! grid to a reduced grid with a variable number on longitudes
! per latitude.  The number of longitudes is chosen so that
! the zonal grid spacing is approximately the same as at the equator.
! The reduced grid has approximately 33% fewer grid points.
! FFT interpolation is used to transform
! to/from the reduced and full grids (using fftpack).

! reducedgrid_init: call first to initialize reduced grid data type.
! regtoreduced: transform data on full grid to reduced grid.
! reducedtoreg: inverse transform, reduced to full grid.
! reducedgrid_destroy: deallocate memory.

! Jeff Whitaker <jeffrey.s.whitaker@noaa.gov>
! 20100217

use kinds, only: r_kind,r_single
implicit none

private
public :: reducedgrid_init, reducedgrid_destroy, reducedtoreg, &
          regtoreduced

! number of lons on full grid.
integer,public :: nlonsfull
! number of lats on full grid.
integer,public :: nlatsfull
! latitudes on full grid
real(r_single), allocatable, public, dimension(:) :: latsfull
! number of lons for each latitude on reduced grid
integer, allocatable, public, dimension(:) :: lonsperlat
! total number of points on reduced grid.
integer,public :: nptsred
! lons and lats on reduced grid
real(r_single), allocatable, public, dimension(:) :: lonsred, latsred
logical, public :: is_initialized = .false.
! private data (fft work arrays)
real, allocatable, dimension(:) :: fftwork1
real, allocatable, dimension(:,:) :: fftwork2

contains

subroutine reducedgrid_init(nlons,nlats,lats)
 ! nlonsfull is (integer) number of lons on full grid.
 ! nlatsfull is (integer) number of lons on full grid.
 ! latsfull is a real array (size nlatsfull) containing latitudes
 ! of full grid in radians.
 integer, intent(in) :: nlons, nlats
 real(r_kind), intent(in) :: lats(nlats)
 integer nlonsred, nlat, nlon, n
 real(r_single) coslat, pi
 pi = 4.*atan(1.0)
 nlonsfull = nlons
 nlatsfull = nlats
 allocate(latsfull(nlatsfull))
 allocate(lonsperlat(nlatsfull))
 latsfull(:) = lats(:)
 nptsred = 0
 do nlat=1,nlatsfull
    coslat = cos(latsfull(nlat))
    nlon = ceiling(nlonsfull*coslat)
    lonsperlat(nlat) = nlon
    nptsred = nptsred + nlon
 enddo
 allocate(lonsred(nptsred))
 allocate(latsred(nptsred))
 n = 0
 allocate(fftwork1(2*nlonsfull+15))
 allocate(fftwork2(2*nlonsfull+15,nlatsfull))
 do nlat=1,nlatsfull
    nlonsred = lonsperlat(nlat)
    do nlon=1,nlonsred
       n = n + 1
       lonsred(n) = 2.*pi*float(nlon-1)/float(nlonsred)
       latsred(n) = latsfull(nlat)
    enddo
    call fftpack_rffti(nlonsred, fftwork2(1,nlat))
 enddo
 call fftpack_rffti(nlonsfull, fftwork1)
 is_initialized = .true.
end subroutine reducedgrid_init

subroutine reducedgrid_destroy()
 if (allocated(lonsperlat)) deallocate(lonsperlat)
 if (allocated(latsfull)) deallocate(latsfull)
 if (allocated(latsred)) deallocate(latsred)
 if (allocated(lonsred)) deallocate(lonsred)
 if (allocated(fftwork1)) deallocate(fftwork1)
 if (allocated(fftwork2)) deallocate(fftwork2)
 is_initialized = .false.
end subroutine reducedgrid_destroy

subroutine regtoreduced(datareg,datared)
 ! interpolate from regular (full) to reduced grid.
 ! datareg (size nlonsfull*nlatsfull) has data on
 ! full grid.
 ! datared (size nptspred) is returned with data on
 ! reduced grid.
 real(r_kind), intent(in), dimension(nlonsfull*nlatsfull):: datareg
 real(r_single), intent(out), dimension(nptsred) :: datared
 integer nlon, nlat, n, nlonsred
 real datareg_lon(nlonsfull)
 real fftwork(2*nlonsfull+15)

 n = 0
 do nlat=1,nlatsfull
    nlonsred = lonsperlat(nlat)
    datareg_lon(1:nlonsfull) = datareg((nlat-1)*nlonsfull+1:nlat*nlonsfull)
    fftwork = fftwork1
    call fftpack_rfftf(nlonsfull,datareg_lon,fftwork)
    fftwork = fftwork2(:,nlat)
    call fftpack_rfftb(nlonsred,datareg_lon,fftwork)
    do nlon=1,nlonsred
       n = n + 1
       datared(n) = datareg_lon(nlon)/real(nlonsfull)
    enddo
 enddo

end subroutine regtoreduced

subroutine reducedtoreg(datared,datareg)
 ! interpolate from reduced to regular (full) grid.
 ! datared (size nptspred) is data on reduced grid.
 ! datareg (size nlonsfull*nlatsfull) is returned with
 ! data on full grid.
 real(r_kind), intent(out), dimension(nlonsfull*nlatsfull) :: datareg
 real(r_single), intent(in), dimension(nptsred) :: datared
 integer nlon, nlat, nlonsred, n
 real datared_lon(nlonsfull)
 real fftwork(2*nlonsfull+15)

 n = 0
 do nlat=1,nlatsfull
    nlonsred = lonsperlat(nlat)
    datared_lon=0.
    do nlon=1,nlonsred
       n = n + 1
       datared_lon(nlon) = datared(n)
    enddo
    fftwork = fftwork2(:,nlat)
    call fftpack_rfftf(nlonsred,datared_lon,fftwork)
    fftwork = fftwork1
    call fftpack_rfftb(nlonsfull,datared_lon,fftwork)
    datareg((nlat-1)*nlonsfull+1:nlat*nlonsfull) = &
    datared_lon(1:nlonsfull)/real(nlonsred)
 enddo

end subroutine reducedtoreg

end module reducedgrid_mod


      SUBROUTINE HARMON(YR,YI,N,X,Y,Z)
        USE param
      IMPLICIT REAL*8(A-H,O-Z)
      INTEGER J,JJ,L,M
      COMPLEX*16 YY(LMX2)
      DIMENSION YR(LMX*(LMX+1)/2,N),YI(LMX*(LMX+1)/2,N)
      DIMENSION X(1),Y(1),Z(1)
      DIMENSION A(3)
      DO 1 I=1,N
      A(1)=X(I)
      A(2)=Y(I)
      A(3)=Z(I)
      CALL YLM(A,LMAX,YY)
!
      JJ=0
      J=0
      DO 2 L=0,LMAX
        DO 2 M=-L,L
          J=J+1
          IF(M.GE.0) THEN
            JJ=JJ+1
             YR(JJ,I)=Dble(YY(J))
             YI(JJ,I)=aIMAG(YY(J))
          ENDIF
    2 CONTINUE
    1 CONTINUE
      RETURN
      END


module def_gate
  implicit none
  complex(8), parameter :: zu=(1.0d0,0.0d0)
  complex(8), parameter :: zi=(0.0d0,1.0d0)
  complex(8), parameter :: zz=(0.0d0,0.0d0)
  complex(8) :: mm(4,4), tcmm(4,4)
  complex(8) :: px(2,2), py(2,2), pz(2,2), p0(2,2)
  complex(8) :: pxx(4,4), pyy(4,4), pzz(4,4)
  real(8) :: pi
  integer :: lo(2)=(/2,2/)
  integer :: lo2(2)=(/4,4/)
  integer :: lo3(2)=(/8,8/)
contains
  !
  subroutine set_mat
    pi = acos(-1.0d0)
    !
    px(1,1:2)=(/ zz,  zu /)
    px(2,1:2)=(/ zu,  zz /)
    !
    py(1,1:2)=(/ zz, -zi /)
    py(2,1:2)=(/ zi,  zz /)
    !
    pz(1,1:2)=(/ zu,  zz /)
    pz(2,1:2)=(/ zz, -zu /)
    !
    p0(1,1:2)=(/zu, zz/)
    p0(2,1:2)=(/zz, zu/)
    !
    mm(1,:)=(/zu, zi, zz, zz/)
    mm(2,:)=(/zz, zz, zi, zu/)
    mm(3,:)=(/zz, zz, zi,-zu/)
    mm(4,:)=(/zu,-zi, zz, zz/)
    mm = mm/sqrt(2.0d0)
    !
    tcmm = transpose(conjg(mm))
    !
    pxx = f_tens_prod(px,lo,px,lo)
    pyy = f_tens_prod(py,lo,py,lo)
    pzz = f_tens_prod(pz,lo,pz,lo)
    !
  end subroutine set_mat
  !
  function f_rz(th) result(mat)
    real(8), intent(in) :: th
    complex(8) :: mat(2,2)
    mat = p0*cos(th/2.0d0) + zi * pz *sin(th/2.0d0)
  end function f_rz
  !
  function f_ry(th) result(mat)
    real(8), intent(in) :: th
    complex(8) :: mat(2,2)
    mat = p0*cos(th/2.0d0) + zi * py *sin(th/2.0d0)
  end function f_ry
  !
  function f_su2(th) result(mat)
    real(8) :: th(3)
    complex(8) :: mat(2,2)
    mat = matmul(matmul(f_rz(th(3)),f_ry(th(2))),f_rz(th(1)))
  end function f_su2
  !
  function f_su2_sub(th) result(mat)
    real(8) :: th(3)
    complex(8) :: mat(2,2)
    mat(1,:) = (/exp(zi/2*(th(1)+th(3)))*cos(th(2)/2), exp(zi/2*(-th(1)+th(3)))*sin(th(2)/2)/)
    mat(2,:) = (/-exp(zi/2*(th(1)-th(3)))*sin(th(2)/2), exp(-zi/2*(th(1)+th(3)))*cos(th(2)/2)/)
  end function f_su2_sub
  !
  function f_tens_prod(mat1,l1,mat2,l2) result(mat)
    integer :: l1(2), l2(2)
    complex(8) :: mat1(l1(1),l1(2)), mat2(l2(1),l2(1))
    complex(8) :: mat(l1(1)*l2(1),l1(2)*l2(2))
    integer :: i1,j1,j2,j
    !$omp parallel do private(j1,j2,i1)
    do j = 1, l1(2)*l2(2)
      j1 = (j-1) / l2(2) + 1
      j2 = j - l2(2)*(j1-1)
      do i1 = 1, l1(1)
        mat(l1(2)*(i1-1)+1:l1(2)*i1,j) = mat1(i1,j1)*mat2(:,j2)
      end do
    end do
  end function f_tens_prod
  !
  function f_so4(th) result(mat)
    real(8) :: th(6)
    complex(8) :: mat(4,4),su2(2,2),su2_2(2,2)
    su2 = f_su2(th(1:3))
    su2_2 = f_su2(th(4:6))
    mat = matmul(tcmm,matmul(f_tens_prod(su2,lo,su2_2,lo),mm))
  end function f_so4
  !
end module def_gate


c     =====================================================
       subroutine qinit(meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q,maux,aux)
c     =====================================================
c
c     # Set initial conditions for q.
c     # Acoustics with smooth radially symmetric profile to test accuracy
c
       implicit double precision (a-h,o-z)
       dimension q(meqn, 1-mbc:mx+mbc, 1-mbc:my+mbc)
c
       pi = 4.d0*datan(1.d0)
       width = 0.15d0

       do 20 i=1,mx
          xcell = xlower - 0.5d0 + (i-0.5d0)*dx

          do 20 j=1,my
             ycell = ylower - 1.0d0+ (j-0.5d0)*dy
             r = dsqrt((xcell)**2 + (ycell)**2)

             if (dabs(r-0.3d0) .le. width) then
                 pressure = 3.d0 + dcos(pi*(r-0.5d0)/width)
               else
                 pressure = 0.d0
               endif
             q(1,i,j) = pressure
             q(2,i,j) = 0.d0
             q(3,i,j) = 0.d0
  20         continue
       return
       end


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYWAUX
C...Calculates real and imaginary parts of the auxiliary functions W1
C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
C...der Bij, Nucl. Phys. B297 (1988) 221.

      SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pydat1'

      ASINH(X)=LOG(X+SQRT(X**2+1D0))
      ACOSH(X)=LOG(X+SQRT(X**2-1D0))

      IF(EPS.LT.0D0) THEN
        IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
        IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
        WIM=0D0
      ELSEIF(EPS.LT.1D0) THEN
        IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
        IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
        IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
        IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
      ELSE
        IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
        IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
        WIM=0D0
      ENDIF

      RETURN
      END


	real function ap2kp(ap)

	real ap,xap(28)
	data xap/0.,2.,3.,4.,5.,6.,7.,9.,12.,15.,18.,22.,27.,32.,
     &		39.,48.,56.,67.,80.,94.,111.,132.,154.,179.,207.,
     &		236.,300.,400./

	i=1
	do while (ap.gt.xap(i))
	  i=i+1
	enddo
	i=max(i-1,1)
	dkp=(ap-xap(i))/(xap(i+1)-xap(i))
	ap2kp=(i-1+dkp)/3.

	return
	end


    MODULE cdf_aux_mod
! .. Use Statements ..
      USE biomath_constants_mod
      USE biomath_interface_mod
      USE zero_finder
! ..
! .. Default Accessibility ..
      PUBLIC
! ..
! .. Private Statements ..
      PRIVATE :: bdf, bpnonc, bprob, immense, large, r_immense, sdf, &
        spnonc, sprob
! ..
! .. Parameters ..
      REAL (dpkind), PARAMETER :: bdf = 1.0E10_dpkind
      REAL (dpkind), PARAMETER :: bpnonc = 1.0E4_dpkind
      REAL (dpkind), PARAMETER :: immense = 1.0E100_dpkind
      REAL (dpkind), PARAMETER :: large = 1.0E10_dpkind
      REAL (dpkind), PARAMETER :: r_immense = 1.0E-100_dpkind
      REAL (dpkind), PARAMETER :: sdf = 1.0E-3_dpkind
      REAL (dpkind), PARAMETER :: spnonc = zero
      REAL (dpkind), PARAMETER :: sprob = 1.0E-10_dpkind
      REAL (dpkind), PARAMETER :: bprob = one - sprob
! ..
! .. Generic Interface Blocks ..
      INTERFACE in_range
        MODULE PROCEDURE dbl_in_range, int_in_range
      END INTERFACE
! ..
! .. Derived Type Declarations ..
! .. Local Structures
! Each parameter has this associated fields:
!   * name
!   * no_check: for this value of 'which'
!   * low_bound: minimum value for the parameter
!   * high_bound: high value for the parameter
      TYPE :: one_parameter
        CHARACTER (31) :: name
        INTEGER :: no_check
        REAL (dpkind) :: low_bound
        REAL (dpkind) :: high_bound
      END TYPE one_parameter
      TYPE :: the_distribution
        CHARACTER (31) :: name
        INTEGER :: max_which
        INTEGER :: nparam
        TYPE (one_parameter) :: parameters(6)
      END TYPE the_distribution
! ..
! .. Dependents ..
      TYPE (the_distribution), PARAMETER :: the_beta = the_distribution( &
        'cdf_beta',4,6,(/one_parameter('cum',1,zero,one), &
        one_parameter('ccum',1,zero,one),one_parameter('x',2,zero,one), &
        one_parameter('cx',2,zero,one),one_parameter('a',3,sprob,bdf), &
        one_parameter('b',4,sprob,bdf)/))
      TYPE (the_distribution), PARAMETER :: the_binomial = &
        the_distribution('cdf_binomial',4,6,(/one_parameter('cum',1,zero, &
        bprob),one_parameter('ccum',1,sprob,one), &
        one_parameter('s',2,zero,large),one_parameter('n',3,zero,large), &
        one_parameter('pr',4,zero,one),one_parameter('cpr',4,zero,one)/))
      TYPE (the_distribution), PARAMETER :: the_chi_square = &
        the_distribution('cdf_chi_square',3,4,(/one_parameter('cum',1, &
        zero,bprob),one_parameter('ccum',1,sprob,one), &
        one_parameter('x',2,zero,immense),one_parameter('df',3,sdf,bdf), &
        one_parameter(' ',0,zero,zero),one_parameter(' ',0,zero,zero)/))
      TYPE (the_distribution), PARAMETER :: the_dummy_binomial = &
        the_distribution('cdf_binomial',0,2,(/one_parameter('pr',0,zero, &
        half),one_parameter('cpr',0,zero,half),one_parameter(' ',0,zero, &
        zero),one_parameter(' ',0,zero,zero),one_parameter(' ',0,zero, &
        zero),one_parameter(' ',0,zero,zero)/))
      TYPE (the_distribution), PARAMETER :: the_f = the_distribution( &
        'cdf_f',2,5,(/one_parameter('cum',1,zero,bprob), &
        one_parameter('ccum',1,sprob,one),one_parameter('f',2,zero, &
        immense),one_parameter('dfn',3,sdf,bdf), &
        one_parameter('dfd',4,sdf,bdf),one_parameter(' ',0,zero,zero)/))
      TYPE (the_distribution), PARAMETER :: the_gamma = the_distribution( &
        'cdf_gamma',4,5,(/one_parameter('cum',1,zero,bprob), &
        one_parameter('ccum',1,sprob,one),one_parameter('x',2,zero, &
        immense),one_parameter('shape',3,sprob,immense), &
        one_parameter('scale',4,sprob,immense),one_parameter(' ',0,zero, &
        zero)/))
      TYPE (the_distribution), PARAMETER :: the_negative_binomial = &
        the_distribution('cdf_negative_binomial',4,6, &
        (/one_parameter('cum',1,zero,bprob),one_parameter('ccum',1,sprob, &
        one),one_parameter('f',2,zero,large),one_parameter('s',3,zero, &
        large),one_parameter('pr',4,zero,one),one_parameter('cpr',4,zero, &
        one)/))
      TYPE (the_distribution), PARAMETER :: the_non_central_chi_square = &
        the_distribution('cdf_nc_chisq',4,5,(/one_parameter('cum',1,zero, &
        bprob),one_parameter('ccum',1,sprob,one), &
        one_parameter('x',2,zero,immense),one_parameter('df',3,sdf,bdf), &
        one_parameter('pnonc',4,spnonc,bpnonc),one_parameter(' ',0,zero, &
        zero)/))
      TYPE (the_distribution), PARAMETER :: the_non_central_f = &
        the_distribution('cdf_nc_f',3,6,(/one_parameter('cum',1,zero, &
        bprob),one_parameter('ccum',1,sprob,one), &
        one_parameter('f',2,zero,immense),one_parameter('dfn',3,sdf,bdf), &
        one_parameter('dfd',4,sdf,bdf),one_parameter('pnonc',5,spnonc, &
        bpnonc)/))
      TYPE (the_distribution), PARAMETER :: the_non_central_t = &
        the_distribution('cdf_non_central_t',4,5, &
        (/one_parameter('cum',1,sprob,bprob),one_parameter('ccum',1,sprob &
        ,bprob),one_parameter('t',2,-immense,immense), &
        one_parameter('df',3,sdf,bdf),one_parameter('pnonc',4,spnonc, &
        bpnonc),one_parameter(' ',0,zero,zero)/))
      TYPE (the_distribution), PARAMETER :: the_normal = the_distribution &
        ('cdf_normal',4,5,(/one_parameter('cum',1,sprob,bprob), &
        one_parameter('ccum',1,sprob,bprob),one_parameter('x',2,-immense, &
        immense),one_parameter('mean',3,-immense,immense), &
        one_parameter('sd',4,sprob,immense),one_parameter(' ',0,zero,zero &
        )/))
      TYPE (the_distribution), PARAMETER :: the_poisson = &
        the_distribution('cdf_poisson',3,4,(/one_parameter('cum',1,zero, &
        bprob),one_parameter('ccum',1,sprob,one), &
        one_parameter('s',2,zero,immense),one_parameter('lambda',3,sprob, &
        immense),one_parameter(' ',0,zero,zero), &
        one_parameter(' ',0,zero,zero)/))
      TYPE (the_distribution), PARAMETER :: the_t = the_distribution( &
        'cdf_t',3,4,(/one_parameter('cum',1,sprob,bprob), &
        one_parameter('ccum',1,sprob,bprob),one_parameter('t',2,-immense, &
        immense),one_parameter('df',3,sdf,bdf),one_parameter(' ',0,zero, &
        zero),one_parameter(' ',0,zero,zero)/))
! ..
    CONTAINS

!*********************************************************************

      FUNCTION add_to_one(x,y,routine_name,x_name,y_name,bad_status, &
          status)
!------------------------------------------------------------------------
! The sum of complementary parameters x and y MUST be 1.0
! (or very close to one.)

! If sum is 1.0, then function returns .TRUE.

! If it is NOT, then:
!   * if STATUS is present (the caller routine had status in its
!     argument list), then status is set to bad_status and the function
!     returns .FALSE.  The user MUST check the status after the return
!     from this function to make sure that x+y is indeed 1.0
!   * if STATUS is NOT present, in order to prevent following nonsensical
!     computations, the application BREAKS here with an error message.
!------------------------------------------------------------------------
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: x, y
        INTEGER, INTENT (IN) :: bad_status
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        CHARACTER (*), INTENT (IN) :: routine_name, x_name, y_name
! ..
! .. Function Return Value ..
        LOGICAL :: add_to_one
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, EPSILON, PRESENT
! ..
        IF (ABS(((x+y)-half)-half)>three*EPSILON(one)) THEN
          add_to_one = .FALSE.
          IF (PRESENT(status)) THEN
            status = bad_status
          ELSE
            WRITE (*,90000) routine_name, x_name, y_name, x_name, x, &
              y_name, y
90000       FORMAT (' Error in routine: ',A/A,' + ',A, &
              ' must add to one'/'Value of ',A,' is: ',G15.8/'Value of ', &
              A,' is: ',G15.8/'Program aborting'/)
            STOP 'Error in cdf routine -- see output'
          END IF
        ELSE
          add_to_one = .TRUE.
        END IF

        RETURN

      END FUNCTION add_to_one

!*********************************************************************

      SUBROUTINE cdf_finalize_status(local,status)
!------------------------------------------------------------------------
! This routine should be called at the end of EACH root finding in the
! cdf_ routines.  It mainly sets the status of the zero finding.
! Again, the user is URGED to check the return value of this routine.
!------------------------------------------------------------------------
! .. Scalar Arguments ..
        INTEGER, INTENT (OUT) :: status
! ..
! .. Structure Arguments ..
        TYPE (zf_locals), INTENT (IN) :: local
! ..
! .. Local Scalars ..
        REAL (dpkind) :: left_end, right_end
        INTEGER :: zf_status
        LOGICAL :: crash_hi, crash_left
! ..
        CALL final_zf_state(local,zf_status,crash_left,crash_hi,left_end, &
          right_end)

        IF (zf_status==0) THEN
          status = 0
        ELSE
          IF (crash_left) THEN
! The root was set in zero_finder to: x=left_bound
            status = -50
          ELSE
! The root was set in zero_finder to: x=right_bound
            status = 50
          END IF
        END IF

        RETURN

      END SUBROUTINE cdf_finalize_status

!*********************************************************************

      SUBROUTINE cdf_set_zero_finder(distrib,which,local)
! Called before solving a problem.
! Sets the bounds for the parameter to be found.
! The bounds are in the structure distrib, corresponding to the
! "which-th" parameter
! .. Parameters ..
        REAL (dpkind), PARAMETER :: absstp = half
        REAL (dpkind), PARAMETER :: atol = 1.0E-50_dpkind
        REAL (dpkind), PARAMETER :: relstp = half
        REAL (dpkind), PARAMETER :: reltol = 1.0E-8_dpkind
        REAL (dpkind), PARAMETER :: stpmul = five
! ..
! .. Scalar Arguments ..
        INTEGER, INTENT (IN) :: which
! ..
! .. Structure Arguments ..
        TYPE (the_distribution), INTENT (IN) :: distrib
        TYPE (zf_locals), INTENT (OUT) :: local
! ..
        CALL set_zero_finder(low_limit=distrib%parameters(which) &
          %low_bound,hi_limit=distrib%parameters(which)%high_bound, &
          abs_step=absstp,rel_step=relstp,step_multiplier=stpmul, &
          abs_tol=atol,rel_tol=reltol,local=local)

      END SUBROUTINE cdf_set_zero_finder

!*********************************************************************

      SUBROUTINE check_complements(x,y,routine_name,x_name,y_name, &
          local_x,local_y,set_values,bad_status,status)
! At least one of the optional parameters x and y must be defined in
! the caller.
! If NONE is defined, the program STOPS.
! If ONE parameter is defined:
!   * if:   set_values is FALSE, return to the caller
!     else: set the non-defined parameter to 1 minus the value of the
!          defined parameter.
! If BOTH parameters are defined:
!   * if   : set_values is FALSE, return to the caller
!     else : set local_x=x and local_y=y
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: local_x, local_y
        REAL (dpkind), OPTIONAL, INTENT (IN) :: x, y
        INTEGER, INTENT (IN) :: bad_status
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL :: set_values
        CHARACTER (*), INTENT (IN) :: routine_name, x_name, y_name
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Scalars ..
        INTEGER :: count
! ..
        count = 0

        IF (PRESENT(x)) count = count + 1
        IF (PRESENT(y)) count = count + 1

        SELECT CASE (count)

        CASE (0)

! None of the complementary parameters are present in the call

          IF (PRESENT(status)) THEN
            status = bad_status
          ELSE
            WRITE (*,90000) routine_name, x_name, y_name
            STOP 'Complement error -- see output'
          END IF

90000     FORMAT (' In routine: ',A/' Neither argument: ',A,' or: ',A, &
            ' is present'/' At least one is required'/ &
            ' Program aborting')

        CASE (1)

          IF ( .NOT. set_values) RETURN

          IF (PRESENT(x)) THEN
            local_x = x
            local_y = one - x
          ELSE
            local_y = y
            local_x = one - y
          END IF

        CASE (2)

          IF ( .NOT. set_values) RETURN

          local_x = x
          local_y = y

        END SELECT

        RETURN

      END SUBROUTINE check_complements

!*********************************************************************

      FUNCTION dbl_in_range(value,lo,hi,routine_name,arg_name,bad_status, &
          status)
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: hi, lo, value
        INTEGER, INTENT (IN) :: bad_status
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        CHARACTER (*) :: arg_name, routine_name
! ..
! .. Local Scalars ..
        LOGICAL :: has_status
! ..
! .. Function Return Value ..
        LOGICAL :: dbl_in_range
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        dbl_in_range = .TRUE.
        has_status = PRESENT(status)

        IF (value>hi) THEN
          dbl_in_range = .FALSE.
          IF (has_status) THEN
            status = bad_status
            RETURN
          ELSE
            WRITE (*,90000) routine_name, arg_name, arg_name, value, hi
90000       FORMAT (' Input argument out of range in routine: ', &
              A/' Argument: ',A,' above upper bound'/' The value of ',A, &
              ' is: ',G15.8/' The upper bound on the value is: ', &
              G15.8/' The program is aborting')
            STOP 'Bound error on cdf routine -- see output'
          END IF
        END IF

        IF (value<lo) THEN
          dbl_in_range = .FALSE.
          IF (has_status) THEN
            status = bad_status
            RETURN
          ELSE
            WRITE (*,90100) routine_name, arg_name, arg_name, value, lo
90100       FORMAT (' Input argument out of range in routine: ', &
              A/' Argument: ',A,' below lower bound'/' The value of ',A, &
              ' is: ',G15.8/' The lower bound on the value is: ', &
              G15.8/' The program is aborting')
            STOP 'Bound error on cdf routine -- see output'
          END IF
        END IF

      END FUNCTION dbl_in_range

!*********************************************************************

      FUNCTION int_in_range(value,lo,hi,routine_name,arg_name,bad_status, &
          status)
! .. Scalar Arguments ..
        INTEGER, INTENT (IN) :: bad_status, hi, lo, value
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        CHARACTER (*), INTENT (IN) :: arg_name, routine_name
! ..
! .. Local Scalars ..
        LOGICAL :: has_status
! ..
! .. Function Return Value ..
        LOGICAL :: int_in_range
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        int_in_range = .TRUE.
        has_status = PRESENT(status)

        IF (value>hi) THEN
          IF (has_status) THEN
            int_in_range = .FALSE.
            status = bad_status
            RETURN
          ELSE
            WRITE (*,*) ' Input argument error in: ', routine_name
            WRITE (*,*) ' Argument ', arg_name, ' above upper bound'
            WRITE (*,*) arg_name, ' value: ', value
            WRITE (*,*) ' Upper bound: ', hi
            STOP &
              'Stop: uncaught bound error on cdf routine -- see output'
          END IF
        END IF

        IF (value<lo) THEN
          IF (has_status) THEN
            int_in_range = .FALSE.
            status = bad_status
            RETURN
          ELSE
            WRITE (*,*) ' Input argument error in: ', routine_name
            WRITE (*,*) ' Argument ', arg_name, ' below lower bound'
            WRITE (*,*) arg_name, ' value: ', value
            WRITE (*,*) ' Lower bound: ', lo
            STOP &
              'Stop: uncaught bound error on cdf routine -- see output'
          END IF
        END IF

        RETURN

      END FUNCTION int_in_range

!*********************************************************************

      SUBROUTINE validate_parameters(distrib,which,params,status)
!        Generic subroutine which performs validation for
!        ALL the parameters of ALL distributions.
! .. Local Scalars ..
        INTEGER :: i, nparam
        CHARACTER (31) :: tn1, tn2
! ..
! .. Structure Arguments ..
        TYPE (the_distribution) :: distrib
! ..
! .. Scalar Arguments ..
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER :: which
! ..
! .. Array Arguments ..
        REAL (dpkind), INTENT (IN) :: params(6)
! ..
        nparam = distrib%nparam

! Check for which to be within limits

        tn1 = 'which'

        IF ( .NOT. in_range(value=which,lo=1,hi=distrib%max_which, &
          routine_name=distrib%name,arg_name=tn1,bad_status=-1, &
          status=status)) RETURN

! If the unknown is not cdf (which=1), check that cum and ccum add to one

        IF (which/=1) THEN
          tn1 = 'cum'
          tn2 = 'ccum'
          IF ( .NOT. add_to_one(params(1),params( &
            2),distrib%name,tn1,tn2,3,status)) RETURN
        END IF

        DO i = 1, nparam

          IF (which/=distrib%parameters(i)%no_check) THEN
            IF ( .NOT. in_range(value=params(i),lo=distrib%parameters( &
              i)%low_bound,hi=distrib%parameters( &
              i)%high_bound,routine_name=distrib%name, &
              arg_name=distrib%parameters(i)%name,bad_status=-(i+ &
              1),status=status)) RETURN
          END IF

        END DO

      END SUBROUTINE validate_parameters

!*********************************************************************

      SUBROUTINE which_miss(which,routine_name,arg_name)
! .. Scalar Arguments ..
        INTEGER, INTENT (IN) :: which
        CHARACTER (*), INTENT (IN) :: arg_name, routine_name
! ..
        WRITE (*,90000) routine_name, which, arg_name, arg_name

90000   FORMAT (' In routine: ',A/' which has value: ',I0, &
          ' indicating that ',A,'is to be calculated'/'But argument: ',A, &
          ' is missing'/'The program is aborting')

        STOP 'Which missing_arg error - see output'

        RETURN

      END SUBROUTINE which_miss

!*********************************************************************

    END MODULE cdf_aux_mod


      SUBROUTINE memcof(data,n,m,xms,d)
      INTEGER m,n,MMAX,NMAX
      REAL xms,d(m),data(n)
      PARAMETER (MMAX=60,NMAX=2000)
      INTEGER i,j,k
      REAL denom,p,pneum,wk1(NMAX),wk2(NMAX),wkm(MMAX)
      if (m.gt.MMAX.or.n.gt.NMAX) pause 'workspace too small in memcof'
      p=0.
      do 11 j=1,n
        p=p+data(j)**2
11    continue
      xms=p/n
      wk1(1)=data(1)
      wk2(n-1)=data(n)
      do 12 j=2,n-1
        wk1(j)=data(j)
        wk2(j-1)=data(j)
12    continue
      do 17 k=1,m
        pneum=0.
        denom=0.
        do 13 j=1,n-k
          pneum=pneum+wk1(j)*wk2(j)
          denom=denom+wk1(j)**2+wk2(j)**2
13      continue
        d(k)=2.*pneum/denom
        xms=xms*(1.-d(k)**2)
        do 14 i=1,k-1
          d(i)=wkm(i)-d(k)*wkm(k-i)
14      continue
        if(k.eq.m)return
        do 15 i=1,k
          wkm(i)=d(i)
15      continue
        do 16 j=1,n-k-1
          wk1(j)=wk1(j)-wkm(k)*wk2(j)
          wk2(j)=wk2(j+1)-wkm(k)*wk1(j+1)
16      continue
17    continue
      pause 'never get here in memcof'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/memcof.for