! solve the linear advection equation on a finite-volume grid using
! using Godunov's method (piecewise constant), piecewise linear, or
! piecewise parabolc reconstruction.
!
! u_t + a u_x = 0
!
! M. Zingale (2012-02-29)
!
! version 1.01 (2013-03-24):
!
!      bug fix in PLM slope computation -- now gets second-order for u
!      positive or negative, and a bug in the computation of the PPM
!      uminus -- we were missing the leftmost value
!
! To really test this for errors, compile as:
!
!   gfortran -g -O0 -fbacktrace -ffpe-trap=invalid,zero,overflow -finit-real=snan -Wuninitialized -o advect advect.f90
!

module grid_module
  implicit none

  type grid_t
     integer :: nx = -1
     integer :: ng = -1
     integer :: ilo = -1
     integer :: ihi = -1

     double precision :: xmin
     double precision :: xmax
     double precision :: dx

     double precision, pointer :: x(:) => Null()
  end type grid_t

  type gridvar_t
     integer :: nvar
     double precision, allocatable :: d(:)
     type(grid_t) :: gd
  end type gridvar_t

contains

  subroutine build_grid(grid, nx, ng, xmin, xmax)

    type(grid_t), intent(inout) :: grid
    integer, intent(in) :: nx
    integer, intent(in) :: ng
    double precision, intent(in) :: xmin
    double precision, intent(in) :: xmax

    integer :: i

    grid % ilo = 0
    grid % ihi = nx - 1

    grid % nx = nx
    grid % ng = ng

    grid % xmin = xmin
    grid % xmax = xmax

    grid % dx = (xmax - xmin)/nx

    allocate(grid % x(-ng:nx+ng-1))

    do i = grid % ilo - ng, grid % ihi + ng
       grid % x(i) = xmin + dble(i + 0.5d0) * grid % dx
    enddo

  end subroutine build_grid

  subroutine build_gridvar(gridvar, grid)

    type(gridvar_t), intent(inout) :: gridvar
    type(grid_t),    intent(in   ) :: grid

    if (grid%nx == -1) then
       print *, "ERROR: grid not initialized"
    endif

    ! gridvar's grid type is simply a copy of the input grid
    gridvar % gd = grid

    ! now initialize the storage for the grid data
    allocate(gridvar % d(-grid % ng:grid % nx + grid % ng-1))
    gridvar % d(:) = 0.0d0

  end subroutine build_gridvar

  subroutine destroy_grid(grid)
    type(grid_t), intent(inout) :: grid
    deallocate(grid % x)
  end subroutine destroy_grid

  subroutine destroy_gridvar(gridvar)
    type(gridvar_t), intent(inout) :: gridvar
    deallocate(gridvar % d)
  end subroutine destroy_gridvar

end module grid_module

program advect

  use grid_module

  implicit none

  ! the number of zones (nx) and number of guardcells (ng)
  integer, parameter :: nx = 64
  integer, parameter :: ng = 3

  ! the domain size
  double precision, parameter :: xmin = 0.d0
  double precision, parameter :: xmax = 1.d0

  ! the advection velocity
  double precision, parameter :: u = 1.d0

  ! the CFL number
  double precision, parameter :: C = 0.8d0

  ! initial condition type
  integer, parameter :: inittype = 2

  ! slope type (1=godunov, 2=plm, 3=ppm)
  integer, parameter :: islopetype = 2

  integer, parameter :: plmlimiter = 1

  ! maximum simulation time
  double precision, parameter :: tmax = 5.d0

  type (grid_t) :: g
  type (gridvar_t) :: a, al, ar, f, ainit

  double precision :: time, dt

  ! setup the grid and set the initial conditions
  call build_grid(g, nx, ng, xmin, xmax)

  call build_gridvar(a, g)
  call build_gridvar(ainit, g)
  call build_gridvar(al, g)
  call build_gridvar(ar, g)
  call build_gridvar(f, g)

  call init(inittype, a)
  ainit % d(:) = a % d(:)

  time = 0.d0

  call output(inittype, islopetype, plmlimiter, a, time, u)

  ! evolution loop -- construct the interface states, solve the Riemann
  ! problem, and update the solution to the new time level
  do while (time < tmax)

     call fillBC(a)

     call timestep(a, C, u, dt)
     if (time + dt > tmax) then
        dt = tmax - time
     endif

     call states(dt, u, islopetype, plmlimiter, a, al, ar)

     call riemann(u, al, ar, f)

     call update(dt, a, f)

     time = time + dt

  enddo

  call output(inittype, islopetype, plmlimiter, a, time, u)

  print *, 'N, error: ', g % nx, &
       sqrt(g % dx*sum((a % d(a % gd %ilo:a % gd % ihi) - &
                        ainit % d(a % gd % ilo:a % gd % ihi))**2))

end program advect

!============================================================================
! init: set the initial conditions
!============================================================================
subroutine init(inittype, a)

  use grid_module

  implicit none

  integer, intent(in) :: inittype
  type (gridvar_t), intent(inout) :: a

  integer :: i
  double precision, parameter :: pi = 3.14159d0

  ! loop over all the zones and set the initial conditions.  To be
  ! consistent with the finite-volume discretization, we should store
  ! the zone averages here, but, to second-order accuracy, it is
  ! sufficient to evaluate the initial conditions at the zone center.

  do i = a % gd % ilo, a % gd % ihi

     if (inittype == 1) then
        ! sin wave
        a % d(i) = sin(2.d0*pi*a % gd % x(i))

     else if (inittype == 2) then
        ! square wave
        if (a % gd % x(i) > 0.333d0 .and. a % gd % x(i) < 0.666d0) then
           a % d(i) = 1.d0
        else
           a % d(i) = 0.d0
        endif

     else if (inittype == 3) then
        ! wave packet
        a % d(i) = sin(16.d0*pi*a % gd % x(i)) * &
             exp(-36.d0*(a % gd % x(i)-0.5d0)**2)

     else if (inittype == 4) then
        ! gaussian
        a % d(i) = exp(-(a % gd % x(i) - 0.5d0)**2/0.1d0**2)

     endif

  enddo

  return
end subroutine init

!============================================================================
! output: write out the solution
!============================================================================
subroutine output(inittype, islopetype, plmlimiter, a, time, u)

  use grid_module

  implicit none

  integer, intent(in) :: inittype, islopetype, plmlimiter
  type (gridvar_t), intent(in) :: a
  double precision, intent(in) :: time, u

  character (len=4) :: time_string
  character (len=16) :: slope, init, res

  integer :: i

  if (islopetype == 1) then
     slope = "godunov"
  else if (islopetype == 2) then
     if (plmlimiter == 1) then
        slope = "plm+MC"
     else if (plmlimiter == 2) then
        slope = "plm+SBee"
     endif
  else if (islopetype == 3) then
     slope = "ppm"
  endif

  if (inittype == 1) then
     init = "sine"
  else if (inittype == 2) then
     init = "tophat"
  else if (inittype == 3) then
     init = "packet"
  else if (inittype == 4) then
     init = "gaussian"
  endif

  ! open the output file
  write (time_string, '(f4.2)') time
  write (res, '(i8)') a % gd % nx

  open(unit=10, file="advect-"//trim(slope)//"-"//trim(init)//"-nx="//trim(adjustl(res))//"-t="//time_string, status="unknown")

  write (10,*) "# advection problem: a_t + u a_x = 0"
  write (10,*) "# u = ", u
  write (10,*) "# init = ", inittype
  write (10,*) "# slope type = ", islopetype
  if (islopetype == 2) then
     write (10,*) "# plm limiter = ", plmlimiter
  endif
  write (10,*) "# time = ", time

  do i = a % gd % ilo, a % gd % ihi
     write (10,*) a % gd % x(i), a % d(i)
  enddo

  return
end subroutine output

!============================================================================
! fillBC: fill the boundary conditions
!============================================================================
subroutine fillBC(a)

  use grid_module

  implicit none

  type (gridvar_t), intent(inout) :: a

  integer :: i, ilo, ihi, ng

  ilo = a % gd % ilo
  ihi = a % gd % ihi
  ng = a % gd % ng

  ! left boundary
  do i = 1, ng
     a % d(ilo - i) = a % d(ihi + 1 - i)
  enddo

  ! right boundary
  do i = 1, ng
     a % d(ihi + i) = a % d(ilo - 1 + i)
  enddo

  return
end subroutine fillBC

!============================================================================
! timestep: compute the new timestep
!============================================================================
subroutine timestep(a, cfl, u, dt)

  use grid_module

  implicit none

  type (gridvar_t), intent(in) :: a
  double precision, intent(in) :: cfl, u
  double precision, intent(inout) :: dt

  integer :: i

  ! in the linear advection equation, the timestep is trivial
  dt = cfl * a % gd % dx/abs(u)

  return
end subroutine timestep

!============================================================================
! states: compute the interface states used in solving the Riemann problem
!============================================================================
subroutine states(dt, u, islopetype, plmlimiter, a, al, ar)

  use grid_module

  implicit none

  integer, intent(in) :: islopetype, plmlimiter
  type (gridvar_t), intent(in) :: a
  type (gridvar_t), intent(inout) :: al, ar
  double precision, intent(in) :: dt, u

  type (gridvar_t) :: slope, aminus, aplus
  double precision :: du0, dup
  double precision :: slope1, slope2

  double precision :: minmod, maxmod

  integer :: i, ilo, ihi
  double precision :: dx

  call build_gridvar(slope, a % gd)
  call build_gridvar(aminus, a % gd)
  call build_gridvar(aplus, a % gd)

  ilo = a % gd % ilo
  ihi = a % gd % ihi
  dx = a % gd % dx

  ! compute the centered difference for linear slopes
  if (islopetype == 1) then

     ! Godunov's method (piecewise constant)

     ! for each interface, we want to construct the left and right
     ! states.  Here, interface i refers to the left edge of zone i

     ! interfaces imin to imax+1 affect the data in zones [imin,imax]
     do i = ilo, ihi+1

        ! the left state on the current interface comes from zone i-1.
        al % d(i) = a % d(i-1)

        ! the right state on the current interface comes from zone i
        ar % d(i) = a % d(i)
     enddo

  else if (islopetype == 2) then

     if (plmlimiter == 1) then
        ! PLM with MC limiter

        ! interface states are found by Taylor expansion in time
        ! (through dt/2) and space (dx/2 toward the interface)

        ! for each interface, we want to construct the left and right
        ! states.  Here, interface i refers to the left edge of zone i
        do i = ilo-1, ihi+1
           slope % d(i) = minmod(minmod(2.d0*(a % d(i) - a % d(i-1))/dx, &
                                        2.d0*(a % d(i+1) - a % d(i))/dx), &
                                 0.5d0*(a % d(i+1) - a % d(i-1))/dx)
        enddo

     else if (plmlimiter == 2) then
        ! PLM with SuperBee limiter

        do i = ilo-1, ihi+1
           slope1 = minmod((a % d(i+1) - a % d(i))/dx, &
                            2.d0*(a % d(i) - a % d(i-1))/dx)

           slope2 = minmod(2.d0*(a % d(i+1) - a % d(i))/dx, &
                          (a % d(i) - a % d(i-1))/dx)

           slope % d(i) = maxmod(slope1, slope2)
        enddo

     endif

     ! interfaces ilo to ihi+1 affect the data in zones [ilo, ihi]
     do i = ilo, ihi+1

        ! the left state on the current interface comes from zone i-1.
        al % d(i) = a % d(i-1) + 0.5*dx*(1.d0 - u*(dt/dx))*slope % d(i-1)

        ! the right state on the current interface comes from zone i
        ar % d(i) = a % d(i) - 0.5*dx*(1.d0 + u*(dt/dx))*slope % d(i)

     enddo

  else if (islopetype == 3) then

     ! PPM

     ! refer to the PPM paper for equation references

     ! use a cubic interpolation polynomial to find the edge states in
     ! zone i -- aminus(i) and aplus(i).  Here we loop over
     ! interfaces.
     do i = ilo-2, ihi+1

        ! du (C&W Eq. 1.7)
        du0 = 0.5*(a % d(i+1) - a % d(i-1))
        dup = 0.5*(a % d(i+2) - a % d(i))

        ! limiting (C&W Eq. 1.8)
        if ((a % d(i+1) - a % d(i))*(a % d(i) - a % d(i-1)) > 0) then
           du0 = sign(1.0d0, du0)*min(abs(du0), &
                                      2.0*abs(a % d(i) - a % d(i-1)), &
                                      2.0*abs(a % d(i+1) - a % d(i)))
        else
           du0 = 0.0
        endif

        if ((a % d(i+2) - a % d(i+1))*(a % d(i+1) - a % d(i)) > 0) then
           dup = sign(1.0d0, dup)*min(abs(dup), &
                                      2.0*abs(a % d(i+1) - a % d(i)), &
                                      2.0*abs(a % d(i+2) - a % d(i+1)))
        else
           dup = 0.0
        endif

        ! cubic (C&W Eq. 1.6)
        aplus % d(i) = 0.5*(a % d(i) + a % d(i+1)) - (1.0/6.0)*(dup - du0)
        aminus % d(i+1) = aplus % d(i)

     enddo

     ! now limit (C&W 1.10).  Here the loop is over cells, and
     ! considers the values on either side of the center of the cell
     ! (uminus and uplus)
     do i = ilo-1, ihi+1
        if ( (aplus % d(i) - a % d(i)) * &
             (a % d(i) - aminus % d(i)) <= 0.0) then
           aminus % d(i) = a % d(i)
           aplus % d(i) = a % d(i)

        else if ( (aplus % d(i) - aminus % d(i)) * &
                  (a % d(i) - 0.5*(aminus % d(i) + aplus % d(i))) > &
                  (aplus % d(i) - aminus % d(i))**2/6.0 ) then
           aminus % d(i) = 3.0*a % d(i) - 2.0*aplus % d(i)

        else if ( -(aplus % d(i) - aminus % d(i))**2/6.0 > &
                   (aplus % d(i) - aminus % d(i)) * &
                   (a % d(i) - 0.5*(aminus % d(i) + aplus % d(i))) ) then
           aplus % d(i) = 3.0*a % d(i) - 2.0*aminus % d(i)

        endif

     enddo

     ! finally integrate under the parabola (C&W Eq. 1.12), away from
     ! the interface.  Here the loop is over interfaces.  al and ar are
     ! the left and right states at the interface.
     do i = ilo, ihi+1

        al % d(i) = aplus % d(i-1) - 0.5*u*(dt/dx)*( (aplus % d(i-1) - aminus % d(i-1)) - &
             (1.0 - (2.0/3.0)*u*(dt/dx))*6.0*(a % d(i-1) - 0.5*(aminus % d(i-1) + aplus % d(i-1))) )

        ar % d(i) = aminus % d(i) + 0.5*u*(dt/dx)*( (aplus % d(i) - aminus % d(i)) + &
             (1.0 - (2.0/3.0)*u*(dt/dx))*6.0*(a % d(i) - 0.5*(aminus % d(i) + aplus % d(i))) )

     enddo

  endif

  return
end subroutine states

!============================================================================
! riemann: solve the Riemann problem
!============================================================================
subroutine riemann(u, al, ar, f)

  use grid_module

  implicit none

  double precision, intent(in) :: u
  type (gridvar_t), intent(in) :: al, ar
  type (gridvar_t), intent(inout) :: f

  integer :: i

  ! loop over all the interfaces and solve the Riemann problem.  Here,
  ! since we are doing the linear advection eq, we just use the advection
  ! velocity to tell us which direction is upwind, and use that state

  if (u >= 0.d0) then
     do i = f % gd % ilo, f % gd % ihi+1
        f % d(i) = u * al % d(i)
     enddo

  else
     do i = f % gd % ilo, f % gd % ihi+1
        f % d(i) = u * ar % d(i)
     enddo

  endif

  return
end subroutine riemann

!============================================================================
! update: conservatively update the solution to the new time level
!============================================================================
subroutine update(dt, a, f)

  use grid_module

  implicit none

  double precision, intent(in) :: dt
  type (gridvar_t), intent(in) :: f
  type (gridvar_t), intent(inout) :: a

  integer :: i

  do i = a % gd % ilo, a % gd % ihi
     a % d(i) = a % d(i) + (dt/a % gd % dx)*(f % d(i) - f % d(i+1))
  enddo

  return
end subroutine update

!============================================================================
! various limiter functions
!============================================================================
function minmod(a,b)

  implicit none

  double precision :: a, b
  double precision :: minmod

  if (abs(a) < abs(b) .and. a*b > 0.d0) then
     minmod = a
  else if (abs(b) < abs(a) .and. a*b > 0) then
     minmod = b
  else
     minmod = 0.d0
  endif

  return
end function minmod

function maxmod(a,b)

  implicit none

  double precision :: a, b
  double precision :: maxmod

  if (abs(a) > abs(b) .and. a*b > 0.d0) then
     maxmod = a
  else if (abs(b) > abs(a) .and. a*b > 0) then
     maxmod = b
  else
     maxmod = 0.d0
  endif

  return
end function maxmod


module local_stage

  USE OMP_LIB
  use Structure
  use Matrix_op
  use bar
  !use global_stage

  implicit none

  type :: local

    double precision, dimension(:,:,:,:), allocatable :: sigma
    double precision, dimension(:,:,:,:), allocatable :: d_Ep

  end type local

  type(local) :: L

  contains

  subroutine local_stage_vp(I,Sop,sigma)

    type(Input), intent(inout) :: I
    !type(global), intent(inout) :: G
    type(Space_op), intent(inout) :: Sop
    double precision, dimension(:,:,:,:) :: sigma
    integer, dimension(4) :: siz
    double precision, dimension(Sop%comp,I%ngps,I%Nx,I%Tngpt) :: sigma_D,d_Ep,tau
    double precision, dimension(Sop%comp,I%ngps,I%Nx,I%Tngpt) :: J2_sigma,iJ2_sigma,N,nlaw

    integer :: j
    double precision, dimension(1,I%ngps,I%Nx,I%Tngpt) :: f_K

    !integer :: ind
    !integer, dimension(1,I%Nx) :: v1,v2

    !!$OMP PARALLEL

    !PRINT *, 'Hello from process: ', OMP_GET_THREAD_NUM()

    siz = (/Sop%comp,I%ngps,I%Nx,I%Tngpt/)
    L%sigma      = sigma
    sigma_D      = L%sigma - L%sigma/3

    !!$omp simd
    !do j=1,I%Tngpt
    !     sigma_D(:,:,:,j) = L%sigma(:,:,:,j) - L%sigma(:,:,:,j)/3
    !end do
    !!$omp end simd

    tau = sigma_D
    J2_sigma = reshape( sqrt(1.5*sum((tau)**2,1)), siz )

    !!$omp simd
    !do j=1,I%Tngpt
    !    iJ2_sigma(:,:,:,j) = 1/J2_sigma(:,:,:,j)
    !end do
    !!$omp end simd

    iJ2_sigma = 1/J2_sigma ! only the positive parts.
    where(J2_sigma == 0.D0) iJ2_sigma = 0.D0  !iJ2_sigma(J2_sigma==0) = 0;

    !!$omp simd
    !do j=1,I%Tngpt
    !    N(:,:,:,j) = iJ2_sigma(:,:,:,j)*tau(:,:,:,j)
    !    f_K(:,:,:,j) = J2_sigma(:,:,:,j)  - I%sigma_y
    !end do
    !!$omp end simd

    N = iJ2_sigma*tau
    f_K = J2_sigma  - I%sigma_y

    where(f_K<0.D0) f_K = 0.D0

    !stop

    !!$omp simd
    !do j=1,I%Tngpt
        !nlaw(:,:,:,j) = I%ks*(f_K(:,:,:,j)**I%np)
        !L%d_Ep(:,:,:,j)  = 3/2*(nlaw(:,:,:,j)*N(:,:,:,j))
    !end do
    !!$omp end simd

    !nlaw = I%ks*(f_K**I%np)

    nlaw = Norton_law(J2_sigma,I,Sop)
    L%d_Ep  = 3/2*(nlaw*N)

    !!$OMP END PARALLEL

  end subroutine local_stage_vp

  function Norton_law(J2_sigma,I,Sop) result(nlaw)

    implicit none
    type(Input), intent(inout) :: I
    !type(global), intent(inout) :: G
    type(Space_op), intent(inout) :: Sop
    double precision, dimension(1,I%ngps,I%Nx,I%Tngpt) :: J2_sigma,f_K,nlaw

    f_K = J2_sigma  - I%sigma_y
    where(f_K<0.D0) f_K = 0.D0
    nlaw = I%ks*(f_K**I%np)

  end function Norton_law

end module local_stage


!/* -*- Mode: F90; tab-width: 3 -*- */
! I suggest the use of an editor that follows default fortran indentation with
! spaces rather than tab characters, JJS 1/21/14

! this is indeed a useful way to define and access variables (scalar and
! arrays) from both python and fortran; however, it is not preferred practice
! for obtained an output array
! module ptmain

! 	real*8,allocatable :: pointsoln(:,:)
! 	real*8,allocatable :: interpsoln(:,:)

! contains

subroutine main(interpsolnout,m,n, inputfilename)

    use polynomial_module
    use inputs_module
    use exprparser_module
    use element_module
    use outputs_module
    use timestepper_module

    implicit none

   real*8, intent(out) :: interpsolnout(m,n)
   integer, intent(in) :: m,n
   character(*), intent(in) :: inputfilename

    integer :: i
    real*8 :: delr,endp(2)

   real*8,allocatable :: pointsoln(:,:)
   real*8,allocatable :: interpsoln(:,:)

   call readinpfile(inpobj, inputfilename)

   allocate(elementarray(inpobj%nelements))

   delr=(inpobj%maxr-inpobj%minr)/(inpobj%nelements)

   do i=1,inpobj%nelements

   endp(1)=inpobj%minr+(i-1)*delr
   endp(2)=inpobj%minr+i*delr

   if(i .eq. 1) then
       call setelementattribs(elementarray(i),endp,inpobj,1)
   else if(i .eq. inpobj%nelements) then
       call setelementattribs(elementarray(i),endp,inpobj,2)
   else
       call setelementattribs(elementarray(i),endp,inpobj)
   endif
   enddo

   if(inpobj%timeorder .eq. 0) then
       call timestepping_Implicit(inpobj,elementarray,pointsoln,interpsoln)
   else
       call timestepping_explicit(inpobj,elementarray,pointsoln,interpsoln)
   endif

   write(*,'(A)',advance='yes')
   print *,"======================================="

   ! put values in output array
   interpsolnout = interpsoln

   ! deallocate `elementarray` to prevent python crash?  JJS 1/13/21
   deallocate(elementarray)

   return
end subroutine main

! end module ptmain


subroutine LIDF_fun(TypeLIDF, na, LIDFa, LIDFb, &
        lidf)
    INTEGER, INTENT(in) :: TypeLidf, na
    REAL*8, INTENT(in) :: LIDFa, LIDFb
    REAL*8, INTENT(out) :: lidf(na)

    IF(TypeLidf == 1) THEN
        CALL dladgen(na,LIDFa,LIDFb,lidf)
    ELSEIF(TypeLidf == 2) THEN
        CALL calc_LIDF_ellipsoidal(na,LIDFa,lidf)
    ENDIF

    return
end subroutine LIDF_fun

!********************************************************************************
!*                          Campbell.f
!*
!*    Computation of the leaf angle distribution function value (freq)
!*    Ellipsoidal distribution function caracterised by the average leaf
!*    inclination angle in degree (ala)
!*    Campbell 1986
!*
!********************************************************************************
SUBROUTINE campbell(n,ala,freq)

    IMPLICIT NONE

    INTEGER*4 :: i,n
    REAL*8 :: ala,freq(n),dum
    REAL*8 :: excent,tl1(n),tl2(n),x1,x2,alpha,alpha2
    REAL*8 :: tx1(13),tx2(13)
    REAL*8 :: x12,x22,almx1,almx2,alpx1,alpx2,sum0
    DATA tx2 /0, 10, 20, 30, 40, 50, 60, 70, 80, 82, 84, 86, 88/
    DATA tx1 /10, 20, 30, 40, 50, 60, 70, 80, 82, 84, 86, 88, 90/

    DO i=1,n
    tl1(i)=tx1(i)*ATAN(1.)/45.
    tl2(i)=tx2(i)*ATAN(1.)/45.
    ENDDO
    excent=EXP(-1.6184e-5*ala**3+2.1145e-3*ala**2-1.2390e-1*ala+3.2491)
    sum0 = 0.
    DO i=1,n
    x1  = excent/(SQRT(1.+excent**2*TAN(tl1(i))**2))
    x2  = excent/(SQRT(1.+excent**2*TAN(tl2(i))**2))
    IF (excent.eq.1.) THEN
        freq(i) = ABS(COS(tl1(i))-COS(tl2(i)))
    ELSE
        alpha  = excent/SQRT(ABS(1.-excent**2))
        alpha2 = alpha**2
        x12 = x1**2
        x22 = x2**2
        IF (excent.gt.1) THEN
            alpx1 = SQRT(alpha2+x12)
            alpx2 = SQRT(alpha2+x22)
            dum   = x1*alpx1+alpha2*LOG(x1+alpx1)
            freq(i) = ABS(dum-(x2*alpx2+alpha2*LOG(x2+alpx2)))
        ELSE
            almx1 = SQRT(alpha2-x12)
            almx2 = SQRT(alpha2-x22)
            dum   = x1*almx1+alpha2*ASIN(x1/alpha)
            freq(i) = ABS(dum-(x2*almx2+alpha2*ASIN(x2/alpha)))
        ENDIF
    ENDIF
    sum0 = sum0+freq(i)
    ENDDO
    DO i=1,n
    freq(i)=freq(i)/sum0!*100.
    ENDDO

    RETURN
END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE calc_LIDF_ellipsoidal(na,alpha,freqvar)
    IMPLICIT NONE

    INTEGER*4 :: na,ia,icou,k
    REAL*8 :: opt,bemu,benu,alphadeg,alpha,freqvar(na),freq(na),pi
    !...............................................................................
    !     Call leaf angle distribution fonction
    !...............................................................................

    alphadeg=alpha

    CALL campbell(na,alphadeg,freq)
    DO ia=1,na
    freqvar(ia)=freq(ia)
    ENDDO

    RETURN
END SUBROUTINE

subroutine dladgen(na,a,b,freq)

    integer :: na
    real*8 :: a,b,freq(na),t
    real*8 :: dcum

    do i1=1,8
    t=i1*10.
    freq(i1)=dcum(a,b,t)
    end do

    do i2=9,12
    t=80.+(i2-8)*2.
    freq(i2)=dcum(a,b,t)
    end do

    freq(13)=1.

    do i=13,2,-1
    freq(i)=freq(i)-freq(i-1)
    end do

    return
end subroutine dladgen

function dcum(a,b,t)

    real*8 a,b,t,pi,rd,eps,delx,p,y,x,dx,dcum
    pi=atan(1.)*4.
    rd=pi/180.

    if (a.gt.1.) then

        dcum=1.-cos(rd*t)

    else

        eps=1.e-8
        delx=1.

        x=2*rd*t
        p=x

        do while (delx.gt.eps)
        y = a*sin(x)+.5*b*sin(2.*x)
        dx=.5*(y-x+p)
        x=x+dx
        delx=abs(dx)
        end do

        dcum=(2.*y+p)/pi

    endif

    return
end function dcum


C
C************************ LSOLVE ************************************
C
      subroutine lsolve(nequ,nterm,ia,ja,lmat,vec,pvec)
c
c  forward and backward substitution for the application
c  of the Choleski preconditioner
c
c   pvec:=(LL^T)^-1*vec (solves the system LL^T*pvec=vec)
c
      implicit none

      integer  nequ,nterm
      integer  k,n1,mm,i,j,m
cxcx  integer  ia(nequ+1),ja(nterm)
cxcx  real*8   lmat(nterm),pvec(nequ),vec(nequ)
      integer  ia(*),ja(*)
      real*8   lmat(*),pvec(*),vec(*)
      real*8   a,zero

      parameter (zero=0.d0)

      do k = 1,nequ
         pvec(k) = zero
      end do
      do k = 1,nequ
         i = ia(k)
         j = ia(k+1) - 1
         pvec(k) = (vec(k) - pvec(k))/lmat(i)
         do m = i+1,j
            pvec(ja(m)) = pvec(ja(m)) + lmat(m)*pvec(k)
         end do
      end do
      do k = 1,nequ
         n1 = nequ-k+1
         a = zero
         i = ia(n1)
         j = ia(n1+1) - 1
         do m = i,j-1
            mm = j-m+i
            a = a + lmat(mm)*pvec(ja(mm))
         end do
         pvec(n1) = (pvec(n1) - a)/lmat(i)
      end do

      return
      end


      subroutine diag(a,n,nn,w,z)
* "nn" represents the size of matrix stored in "a" whose size is "n"
* "n" should match the dimension of "a" as defined in the calling
* routine
*
* Compilation syntax:  ifort source.f diag.f -mkl
*
      DIMENSION ISUPPZ(N), IWORK(1000)
      DOUBLE PRECISION A(N,N), W(N), Z(N,N),
     $                 WORK(1000)
      ABSTOL = -1.0
      IL = 1
      IU = Nn
      LDA = N
      LDZ = N
      LWMAX = 1000

c      write(*,*)'The following matrix was considered'
c      do i=1,nn
c        write (*,'(2x,100f9.4)')(a(i,j),j=1,nn)
c      end do
*
*     Query the optimal workspace.
*
      LWORK = -1
      LIWORK = -1
      CALL DSYEVR( 'Vectors', 'All', 'Upper', Nn, A, LDA, VL, VU, IL,
     $             IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
     $             LIWORK, INFO )
      LWORK = MIN( LWMAX, INT( WORK( 1 ) ) )
      LIWORK = MIN( LWMAX, IWORK( 1 ) )
*
*     Solve eigenproblem.
*
      CALL DSYEVR( 'Vectors', 'All', 'Upper', Nn, A, LDA, VL, VU, IL,
     $             IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
     $             LIWORK, INFO )
*
*     Check for convergence.
*
      IF( INFO.GT.0 ) THEN
        WRITE(*,*)'The algorithm failed to compute eigenvalues.'
        STOP
c      ELSE
c        WRITE(*,'(/A,I2)')' The total number of eigenvalues found:', M
c        WRITE(*,'(1000F8.4)')(W(I),I=1,M)
c        WRITE(*,'(/A)')' The eigenvectors are:'
c        DO I = 1, M
c          WRITE(*,'(1000F8.4)')(Z(I,J),J=1,M)
c        END DO
      END IF
      END


c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c        ACKNOWLEDGE THE USE OF THIS PACKAGE
c         WHEN YOU PUBLISH YOUR RESULTS !!!
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c
c************* Sample main program #10 *****************
c  1d Heisenberg antiferromagnet with 15 spins
c Degeneracy check by various initial vectors
c***********************************************
c
      parameter (n=15,idim=6435,ibond=n,ic=ibond+1)
      implicit real*8 (a-h,o-z)
      dimension E(4)
      dimension elemnt(idim,ic),loc(idim,ic)
      dimension list1(idim),list2(2,0:2**15)
      dimension bondwt(ibond),ipair(2*ibond),zrtio(ibond)
      dimension wk(idim,4)
      dimension x(idim)
      dimension v(idim,3),norm(3)
c
      data bondwt/ibond*-1.0d0/
      data zrtio/ibond*1.0d0/
      data ipair/1,2, 2,3,  3,4,  4,5,  5,6,  6,7,  7,8, 8,9,
     &     9,10, 10,11, 11,12, 12,13, 13,14, 14,15, 15,1/
      nvec=1
      iv=idim/5
c
      call sz(n,idim,0.5d0,list1,list2)
c- You may alternatively use szdy or sztn for faster processing -
c      call szdy(n,idim,0.5d0,list1,list2)
c  or
c      call sztn(n,idim,0.5d0,list1,list2)
c------------------------------------------------------------
      call elm2(n,idim,ipair,bondwt,zrtio,ibond,
     &          elemnt,loc,idim,ic,list1,list2)
      k=0
c *** Two different initial conditions
      do 10 iv=91,idim,idim/3
        k=k+1
        call lnc2(elemnt,loc,idim,idim,ic,nvec,iv,E,itr,wk)
        print 100,k,e
  100    format(/' #',i2,' [Eigenvalues]  '/2x,4f14.8)
        call inv2(elemnt,loc,idim,idim,ic,iv,E(1),x,wk)
        print *,'[Eigenvector components (selected)]'
        print 120,(x(j),j=13,idim,idim/20)
  120    format(4d18.9)
        call check2(elemnt,loc,idim,idim,ic,x,wk,Hexpec)
        do 20 j=1,idim
  20     v(j,k)=x(j)
  10   continue
c *** Degeneracy check
      call orthg(idim,idim,v,norm,idgn,3)
      print 110,idgn
  110  format(/' [Degeneracy]'/i6)
      end


module mod_gs
  use mod_prec
  use mod_utility
  use mod_error_id
  implicit none
  real(kind=dp), parameter :: eta=1.414_dp
  integer(kind=int32), parameter :: orthmaxits=5

  private

  public :: extend_gs_rows, d_extend_gs_rows, z_extend_gs_rows, &
       extend_gs_columns, d_extend_gs_columns, z_extend_gs_columns

  interface extend_gs_rows
     module procedure d_extend_gs_rows, z_extend_gs_rows
  end interface extend_gs_rows

  interface extend_gs_columns
     module procedure d_extend_gs_columns, z_extend_gs_columns
  end interface extend_gs_columns

contains

  ! Error 1: failure to orthogonalize
  ! Extend a Gram-Schmidt LQ decomposition

  subroutine d_extend_gs_rows(q1, l, rho, q2, error)
    ! orthogonalize q2 against q1.  Return error = 1 if
    ! too many iterations are required.
    real(kind=dp), dimension (:,:), intent(in) :: q1
    real(kind=dp), intent(out) :: rho
    real(kind=dp), dimension(:), intent(out) :: l
    real(kind=dp), dimension(:), intent(inout) :: q2
    type(error_info), intent(inout), optional :: error
    !
    real(kind=dp), dimension(size(l)) :: x
    real(kind=dp) :: nrm1, nrm2
    integer(kind=int32) :: k
    type(routine_info), parameter :: info=info_d_extend_gs_rows
    !
    nrm1=norm2(q2)
    l = matmul(q1,q2)
    q2=q2-matmul(l,q1)
    nrm2=norm2(q2)
    rho=nrm2
    ! reorthogonalize as needed
    if (failure(error)) return
    call push_id(info, error)
    k=0
    do while (nrm1 > eta * nrm2 .and. nrm2 > 0 .and. k < orthmaxits)
       k=k+1
       x=matmul(q1,q2)
       l=l+x
       nrm1=norm2(q2)
       q2=q2-matmul(x,q1)
       nrm2=norm2(q2)
       rho=nrm2
    end do
    do while (nrm2 == 0 .and. k < orthmaxits)
       ! got the zero vector.  Orthogonalize something random.
       k=0
       call random_matrix_to(q2)
       nrm2 = 1.0_dp
       nrm1=2.0_dp*eta
       do while (nrm1 > eta*nrm2 .and. nrm2 > 0.0_dp .and. k < orthmaxits)
          k=k+1
          nrm1=norm2(q2)
          x=matmul(q1,q2)
          q2=q2-matmul(x,q1)
          nrm2=norm2(q2)
       end do
    end do
    q2=q2/nrm2
    if (k >= orthmaxits) then
       call set_error(1, info, error); return
    end if
    call pop_id(error)

  end subroutine d_extend_gs_rows

  ! Extend a Gram-Schmidt LQ decomposition
  subroutine z_extend_gs_rows(q1, l, rho, q2, error)
    ! orthogonalize q2 against q1.  Return error = 1 if
    ! too many iterations are required.
    complex(kind=dp), dimension (:,:), intent(in) :: q1
    complex(kind=dp), intent(out) :: rho
    complex(kind=dp), dimension(:), intent(out) :: l
    complex(kind=dp), dimension(:), intent(inout) :: q2
    type(error_info), intent(inout), optional :: error
    !
    complex(kind=dp), dimension(size(l)) :: x
    real(kind=dp) :: nrm1, nrm2
    integer(kind=int32) :: k
    type(routine_info), parameter :: info=info_z_extend_gs_rows
    !
    nrm1=norm2(q2)
    l = matmul(q1,conjg(q2))
    l=conjg(l)
    q2=q2-matmul(l,q1)
    nrm2=norm2(q2)
    rho=nrm2
    ! reorthogonalize as needed
    if (failure(error)) return
    call push_id(info, error)
    k=0
    do while (nrm1 > eta * nrm2 .and. nrm2 > 0 .and. k < orthmaxits)
       k=k+1
       x=matmul(q1,conjg(q2))
       x=conjg(x)
       l=l+x
       nrm1=norm2(q2)
       q2=q2-matmul(x,q1)
       nrm2=norm2(q2)
       rho=nrm2
    end do
    do while (nrm2 == 0 .and. k < orthmaxits)
       ! got the zero vector.  Orthogonalize something random.
       k=0
       call random_matrix_to(q2)
       nrm2 = 1.0_dp
       nrm1=2.0_dp*eta
       do while (nrm1 > eta*nrm2 .and. nrm2 > 0.0_dp .and. k < orthmaxits)
          k=k+1
          nrm1=norm2(q2)
          x=matmul(q1,conjg(q2))
          x=conjg(x)
          q2=q2-matmul(x,q1)
          nrm2=norm2(q2)
       end do
    end do
    q2=q2/nrm2
    if (k >= orthmaxits) then
       call set_error(1, info, error); return
    end if
    call pop_id(error)
  end subroutine z_extend_gs_rows

  ! Extend a Gram-Schmidt QL decomposition
  subroutine d_extend_gs_columns(q1, l, rho, q2, error)
    ! orthogonalize q2 against q1.  Return error = 1 if
    ! too many iterations are required.
    real(kind=dp), dimension (:,:), intent(in) :: q1
    real(kind=dp), intent(out) :: rho
    real(kind=dp), dimension(:), intent(out) :: l
    real(kind=dp), dimension(:), intent(inout) :: q2
    type(error_info), intent(inout), optional :: error
    !
    real(kind=dp), dimension(size(l)) :: x
    real(kind=dp) :: nrm1, nrm2
    integer(kind=int32) :: k
    type(routine_info), parameter :: info=info_d_extend_gs_columns
    !
    nrm1=norm2(q2)
    l = matmul(q2,q1)
    q2=q2-matmul(q1,l)
    nrm2=norm2(q2)
    rho=nrm2
    ! reorthogonalize as needed
    if (failure(error)) return
    call push_id(info, error)
    k=0
    do while (nrm1 > eta * nrm2 .and. nrm2 > 0 .and. k < orthmaxits)
       k=k+1
       x=matmul(q2,q1)
       l=l+x
       nrm1=norm2(q2)
       q2=q2-matmul(q1,x)
       nrm2=norm2(q2)
       rho=nrm2
    end do
    do while (nrm2 == 0 .and. k < orthmaxits)
       ! got the zero vector.  Orthogonalize something random.
       k=0
       call random_matrix_to(q2)
       nrm2 = 1.0_dp
       nrm1=2.0_dp*eta
       do while (nrm1 > eta*nrm2 .and. nrm2 > 0.0_dp .and. k < orthmaxits)
          k=k+1
          nrm1=norm2(q2)
          x=matmul(q2,q1)
          q2=q2-matmul(q1,x)
          nrm2=norm2(q2)
       end do
    end do
    q2=q2/nrm2
    if (k >= orthmaxits) then
       call set_error(1, info, error); return
    end if
    call pop_id(error)
  end subroutine d_extend_gs_columns

  ! Extend a Gram-Schmidt QL decomposition
  subroutine z_extend_gs_columns(q1, l, rho, q2, error)
    ! orthogonalize q2 against q1.  Return error = 1 if
    ! too many iterations are required.
    complex(kind=dp), dimension (:,:), intent(in) :: q1
    complex(kind=dp), intent(out) :: rho
    complex(kind=dp), dimension(:), intent(out) :: l
    complex(kind=dp), dimension(:), intent(inout) :: q2
    type(error_info), intent(inout), optional :: error
    !
    complex(kind=dp), dimension(size(l)) :: x
    real(kind=dp) :: nrm1, nrm2
    integer(kind=int32) :: k
    type(routine_info), parameter :: info=info_z_extend_gs_columns
    !
    nrm1=norm2(q2)
    l = matmul(conjg(q2),q1)
    l=conjg(l)
    q2=q2-matmul(q1,l)
    nrm2=norm2(q2)
    rho=nrm2
    ! reorthogonalize as needed
    if (failure(error)) return
    call push_id(info, error)
    k=0
    do while (nrm1 > eta * nrm2 .and. nrm2 > 0 .and. k < orthmaxits)
       k=k+1
       x=matmul(conjg(q2),q1)
       x=conjg(x)
       l=l+x
       nrm1=norm2(q2)
       q2=q2-matmul(q1,x)
       nrm2=norm2(q2)
       rho=nrm2
    end do
    do while (nrm2 == 0 .and. k < orthmaxits)
       ! got the zero vector.  Orthogonalize something random.
       k=0
       call random_matrix_to(q2)
       nrm2 = 1.0_dp
       nrm1=2.0_dp*eta
       do while (nrm1 > eta*nrm2 .and. nrm2 > 0.0_dp .and. k < orthmaxits)
          k=k+1
          nrm1=norm2(q2)
          x=matmul(conjg(q2),q1)
          x=conjg(x)
          q2=q2-matmul(q1,x)
          nrm2=norm2(q2)
       end do
    end do
    q2=q2/nrm2
    if (k >= orthmaxits) then
       call set_error(1, info, error); return
    end if
    call pop_id(error)
  end subroutine z_extend_gs_columns

end module mod_gs


!==========================================================================
pure function gsw_util_xinterp1 (x, y, n, x0)
!==========================================================================
!
! Linearly interpolate a real array
!
! x      : x array (must be monotonic)
! y      : y array
! n      : length of X and Y arrays
! x0     : value to be interpolated
!
! xinterp1 : Linearly interpolated value
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_util_indx

use gsw_mod_kinds

implicit none

integer, intent(in) :: n
real (r8), intent(in) :: x0
real (r8), dimension(n), intent(in) :: x, y

real (r8) :: gsw_util_xinterp1

integer :: k

real (r8) :: r

call gsw_util_indx(x,n,x0,k)
r = (x0-x(k))/(x(k+1)-x(k))
gsw_util_xinterp1 = y(k) + r*(y(k+1)-y(k))

return
end function

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


: fib ( x1 x2 -- x1 x2 x3 )
    2dup
    +
;

: showStack ( i*x -- )
    BEGIN depth ?dup WHILE
        CR

        0< IF
            0
        ELSE
            depth .
            .
        THEN
    REPEAT
;

( initial values )
1
1

( calculations )
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib
fib


  function hpa (a, e)

! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    real(real64),   intent(in   ) :: a
    real(real64),   intent(in   ) :: e
    real(real64)                  :: hpa

    real(real64) :: aln, sha, z

! ======================================================================

    aln = log(a)
    sha = 1.0663d0 - 0.0023d0*aln
    z = log(e)
    hpa = 0.0375d0*(z - 16.5d0) + sha*exp(-0.11d0*z)
    return

! ======================================================================
  end function hpa

  function udel (a)

! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    real(real64),   intent(in   ) :: a
    real(real64)                  :: udel

    real(real64) :: temp

! ======================================================================

    temp = 1.d0 + 0.003d0*a*a
    udel = 5.82d0 - 0.07d0/(temp)
    return

! ======================================================================
  end function udel

  function wdel (a)

! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    real(real64),   intent(in   ) :: a
    real(real64)                  :: wdel

    real(real64) :: aln

! ======================================================================

    aln = log(a)
    wdel = 0.056d0 + aln*(0.03d0 - 0.001d0*aln)
    return

! ======================================================================
  end function wdel

  function wha (a)

! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    real(real64),   intent(in   ) :: a
    real(real64)                  :: wha

    real(real64) :: ala

! ======================================================================

    ala = log(a)
    wha = 0.045d0 + 0.04d0*ala*sqrt(abs(ala))
    return

! ======================================================================
  end function wha


program solar_system_main
  use orbital_mech
  use plot
  implicit none
  real(dp) :: kep_el(20,10) ! Keplerian elements of the bodies of the solar system.
  type(orb_par) :: orbits(10) ! Orbits of the solar system.
  character(:), allocatable :: filename
  integer  :: i, nrec ! counter, number of records
  real(dp) :: t, dt, start, finish, rec! time, increment in time, start, finish, # steps per recording.
  real(dp), allocatable :: dummy(:), ax(:,:), max_ax(:,:), min_ax(:,:)
  real(4) :: maxrange(3), minrange(3)
  real(4) :: xrange(2), yrange(2), zrange(2)
  !type(titles), allocatable :: title(:)
  character(20) :: title(10)
  !character(:), allocatable :: title(:)

  dt = 1._dp
  start = 0._dp
  finish =  690._dp
  rec = 2._dp

  ! Read keplerian elements.
  !filename = 'kep_el.txt'
  !call read_kep_el(filename, size(orbits), 1, kep_el)

  ! Evolve keplerian elements per century.
  !call kep_el_teph(kep_el, orbits, 2451545._dp)

  ! Calculate the state vectors.
  !call state_vec(orbits,1d-6)

  ! Evolve the trajectories with time.
  open(unit = 1, file = 'solar_system.dat', status = 'replace', action = 'write', position = 'rewind')
  call integrate_orbits(orbits, start, finish, dt, rec)
  close(1)

  ! Calculating the range for the animation of inner solar system.
  nrec = nint(finish/(rec*dt)) + 1
  open(unit = 2, file = 'solar_system.dat', status = 'old', action = 'read', position = 'rewind')
  allocate(ax(15,nrec), max_ax(3,5), min_ax(3,5))
  iranges: do i = 1, nrec
    read(2,*) ax(:,i)
  end do iranges
  close(2)

  min_ax = reshape(minval(ax,dim=2), [3,5])
  max_ax = reshape(maxval(ax,dim=2), [3,5])
  minrange = minval(min_ax,dim=2)
  maxrange = maxval(max_ax,dim=2)
  xrange = [minrange(1), maxrange(1)]
  yrange = [minrange(2), maxrange(2)]
  zrange = [minrange(3), maxrange(3)]
  ! Call gnuplot.
  call system('mkdir tmp')
  call pngterm('isolar_system', plot_size=[1000,1000], font='TeX Gyre Pagella', font_size=13)
  !call range(xrange,yrange,zrange)
  call range([-1.8,1.8],[-1.8,1.8],[-0.06,0.06])
  call plt_labels('x, A.U.', 'y, A.U.', 'z, A.U.', 'Inner Solar System')
  call ticks(xticks=[-1.8,0.4,1.8],mxticks=2,yticks=[-1.8,0.4,1.8],myticks=2,zticks=[-0.06,0.02,0.06], mzticks=2)
  call grid(xticks=[1,0],yticks=[1,0],zticks=[1,0], linestyle=[(0,i=1,6)])
  call xyplane(-0.06)
  title(1) = 'Sun'
  title(2) = 'Mercury'
  title(3) = 'Venus'
  title(4) = 'Earth'
  title(5) = 'Mars'
  call adplot3d('solar_system','isolar_system',[0,nrec],1,[(i,i=1,15)],size([(i,i=1,15)])/3, title)

  ! Calculating the range for the animation of outer solar system.
  nrec = nint(finish/(rec*dt)) + 1
  open(unit = 2, file = 'solar_system.dat', status = 'old', action = 'read', position = 'rewind')
  allocate(dummy(15))
  oranges: do i = 1, nrec
    read(2,*) dummy(:),ax(:,i)
  end do oranges
  close(2)

  min_ax = reshape(minval(ax,dim=2), [3,5])
  max_ax = reshape(maxval(ax,dim=2), [3,5])
  minrange = minval(min_ax,dim=2)
  maxrange = maxval(max_ax,dim=2)
  xrange = [minrange(1), maxrange(1)]
  yrange = [minrange(2), maxrange(2)]
  zrange = [minrange(3), maxrange(3)]
  ! Call gnuplot.
  call pngterm('osolar_system', plot_size=[1000,1000], font='TeX Gyre Pagella', font_size=13)
  call range([-31.,44.0],[-33.,45.],[-15.,9.])
  call plt_labels('x, A.U.', 'y, A.U.', 'z, A.U.', 'Outer Solar System')
  call ticks(xticks=[-31.,15.,44.0],mxticks=2,yticks=[-33.,10.,47.],myticks=2,zticks=[-15.,4.,9.], mzticks=2)
  call grid(xticks=[1,0],yticks=[1,0],zticks=[1,0], linestyle=[(0,i=1,6)])
  call xyplane(-15.)
  title(6) = 'Jupiter'
  title(7) = 'Saturn'
  title(8) = 'Uranus'
  title(9) = 'Neptune'
  title(10) = 'Pluto'
  call adplot3d('solar_system','osolar_system',[0,nrec],5,[(i,i=16,30)],size([(i,i=16,30)])/3, title(6:10))

  call system('gnuplot isolar_system.gnu')
  !call system('gnuplot osolar_system.gnu')
  call system('ffmpeg -i tmp/isolar_system%d.png isolar_system.mp4')
  !call system('ffmpeg -i tmp/osolar_system%d.png osolar_system.mp4')
  call system('rm -rf tmp')

end program solar_system_main


program problem_3

use aoc_utilities

implicit none

integer :: i, iunit, n, n_lines, j, n_ones, n_zeros, k
character(len=:),allocatable :: line
logical :: status_ok
integer,dimension(:,:),allocatable :: bits
integer,dimension(:),allocatable :: most_common_bit, least_common_bit, n_ones_count, n_zeros_count
logical,dimension(:),allocatable :: keep
integer :: ox,co2

open(newunit=iunit,file='inputs/day3.txt')

n_lines = number_of_lines_in_file(iunit)
! write(*,*) 'n_lines = ', n_lines

allocate(keep(n_lines))

do i = 1, n_lines

    call read_line_from_file(iunit,line,status_ok)
    !write(*,*) line

    if (i==1) then
        n = len(line) ! number of cols
        allocate(bits(n_lines,n))
        allocate(most_common_bit(n))
        allocate(least_common_bit(n))
        allocate(n_ones_count(n))
        allocate(n_zeros_count(n))
    end if

    do j = 1, n
        read(line(j:j), '(I1)') bits(i,j) ! string to integer
    end do

end do

most_common_bit = 0
least_common_bit = 0
do i = 1, n
    n_ones = count(bits(:,i)==1)
    n_zeros = n_lines - n_ones
    if (n_ones>n_zeros) then
        most_common_bit(i) = 1
    else
        least_common_bit(i) = 1
    end if
end do

write(*,'(A,*(I1))') 'most_common_bit  (binary) = ', most_common_bit
write(*,'(A,*(I1))') 'least_common_bit (binary) = ', least_common_bit

write(*,*) '3A: ', binary_to_decimal(most_common_bit) * binary_to_decimal(least_common_bit)

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

! oxygen

keep = .true.
! write(*,*) '***',count(keep)
do i = 1, n
    n_ones  = count(keep .and. bits(:,i)==1)
    n_zeros = count(keep) - n_ones

    do j = 1, n_lines
        ! oxygen
        if (n_ones>=n_zeros) then ! keep ones with 1
            if (keep(j) .and. bits(j,i)==0) keep(j) = .false. ! remove ones with 0
        else ! keep ones with 0
            if (keep(j) .and. bits(j,i)==1) keep(j) = .false. ! remove ones with 1
        end if
    end do

end do

do i = 1, n_lines
    if (keep(i)) then
        ox = binary_to_decimal(bits(i,:))
        !write(*,'(A,*(I10))') 'oxygen:  ', ox
    end if
end do

! c02

keep = .true.
do i = 1, n
    n_ones  = count(keep .and. bits(:,i)==1)
    n_zeros = count(keep) - n_ones
    do j = 1, n_lines
        ! oxygen
        if (n_zeros<=n_ones) then ! keep ones with 1
            if (keep(j) .and. bits(j,i)==1) keep(j) = .false. ! remove ones with 1
        else ! keep ones with 0
            if (keep(j) .and. bits(j,i)==0) keep(j) = .false. ! remove ones with 0
        end if
    end do

    if (count(keep)==1) exit ! we are done I guess?

end do

do i = 1, n_lines
    if (keep(i)) then
        co2 = binary_to_decimal(bits(i,:))
        !write(*,'(A,*(I10))') 'c02:     ', co2
    end if
end do

write(*,*) '3B: ', ox * co2

contains

    function binary_to_decimal(b) result(dec)
    implicit none
    integer,dimension(:),intent(in) :: b
    integer :: dec
    integer :: j,n
    n = size(b)
    dec = sum( [( 2**(j-1) * b(n-j+1), j = 1,n )] )
    end function binary_to_decimal

end program problem_3


*     TB01UD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          LDA, LDB, LDC, LDZ
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = PMAX,
     $                   LDZ = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX, 3*MMAX, PMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, INDCON, J, M, N, NCONT, P
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), C(LDC,NMAX),
     $                 DWORK(LDWORK), TAU(NMAX), Z(LDZ,NMAX)
      INTEGER          IWORK(LIWORK), NBLK(NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB01UD, DORGQR
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, JOBZ
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
*              Find a controllable ssr for the given system.
               CALL TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC,
     $                      NCONT, INDCON, NBLK, Z, LDZ, TAU, TOL,
     $                      IWORK, DWORK, LDWORK, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NCONT
                  WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NCONT
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1,NCONT )
   20             CONTINUE
                  WRITE ( NOUT, FMT = 99994 ) ( NBLK(I), I = 1,INDCON )
                  WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NCONT
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1,M )
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99987 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1,NCONT )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99992 ) INDCON
                  IF ( LSAME( JOBZ, 'F' ) )
     $               CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK,
     $                            INFO )
                  IF ( LSAME( JOBZ, 'F' ).OR.LSAME( JOBZ, 'I' ) ) THEN
                     WRITE ( NOUT, FMT = 99991 )
                     DO 80 I = 1, N
                        WRITE ( NOUT, FMT = 99995 ) ( Z(I,J), J = 1,N )
   80                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB01UD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB01UD = ',I2)
99997 FORMAT (' The order of the controllable state-space representati',
     $       'on = ',I2)
99996 FORMAT (/' The transformed state dynamics matrix of a controllab',
     $       'le realization is ')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' and the dimensions of its diagonal blocks are ',
     $       /20(1X,I2))
99993 FORMAT (/' The transformed input/state matrix B of a controllabl',
     $       'e realization is ')
99992 FORMAT (/' The controllability index of the transformed system r',
     $       'epresentation = ',I2)
99991 FORMAT (/' The similarity transformation matrix Z is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99987 FORMAT (/' The transformed output/state matrix C of a controlla',
     $       'ble realization is ')
      END


MODULE m_closure

use m_juDFT

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!     Contains 3 subroutines that more or less check the closure:
!     closure :    checks whether the space group operations close
!     close_pt:    checks that the point group of the bravais
!                  lattice closes
!     check_close: additionally calculate the multiplication table,
!                  inverse operations and also determines the type
!                  of every operation                    mw99,gs00
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

CONTAINS

SUBROUTINE closure(mops,mrot,tau,nops,index_op,lclose)

   USE m_constants

   IMPLICIT NONE

   INTEGER, INTENT (IN)  :: mops           ! number of operations of the bravais lattice
   INTEGER, INTENT (IN)  :: nops           ! number of operations in space group
   INTEGER, INTENT (IN)  :: mrot(3,3,mops) ! refer to the operations of the
   REAL,    INTENT (IN)  :: tau(3,mops)    ! bravais lattice
   INTEGER, INTENT (IN)  :: index_op(nops) ! mapping function between space group
                                              ! op's and those of the bravais lattice
   LOGICAL, INTENT (OUT) :: lclose

   REAL    ttau(3),eps7
   INTEGER i,ii,j,jj,k,kk,mp(3,3),map(nops)

   eps7 = 1.0e-7

   ! loop over all operations
   DO jj = 1, nops
      j = index_op(jj)

      map(1:nops) = 0

      ! multiply {R_j|t_j}{R_i|t_i}
      DO ii = 1, nops
         i = index_op(ii)
         mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
         ttau = tau(:,j) + matmul( mrot(:,:,j) , tau(:,i) )
         ttau = ttau - anint( ttau - eps7 )

         ! determine which operation this is
         DO kk=1,nops
            k = index_op(kk)
            IF ( all( mp(:,:) == mrot(:,:,k) ) .AND. all( abs( ttau(:)-tau(:,k) ) < eps7 ) ) THEN
               IF ( map(ii) .eq. 0 ) THEN
                  map(ii) = kk
               ELSE
                  write(oUnit,*)'ERROR Closure: Multiplying ', jj,' with ',kk, ' and with ',map(ii)
                  write(oUnit,*) 'yields the same matrix'
                  lclose = .false.
                  RETURN
               END IF
            END IF
         END DO

         IF (map(ii).eq.0) THEN
            write(oUnit,*)'ERROR Closure:',ii,' times',jj,' leaves group'
            lclose = .false.
            RETURN
         END IF
      END DO
   END DO

   lclose = .true.

END SUBROUTINE closure

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

SUBROUTINE close_pt(nops,mrot,mtable)

   USE m_constants

   IMPLICIT NONE

   INTEGER, INTENT (IN)  :: nops,mrot(3,3,nops)
   INTEGER, INTENT (OUT) :: mtable(nops,nops)   ! table(i,j) = {R_i|0}{R_j|0}

   INTEGER              :: i,j,k,mp(3,3),map(nops)

   ! loop over all operations
   DO j = 1, nops

      map(1:nops) = 0

      ! multiply {R_j|0}{R_i|0}
      DO i = 1, nops
         mp = matmul( mrot(:,:,j) , mrot(:,:,i) )

         ! determine which operation this is
         DO k = 1, nops
            IF ( all( mp(:,:)==mrot(:,:,k) ) ) THEN
               IF ( map(i) .eq. 0 ) THEN
                  map(i) = k
               ELSE
                  WRITE (oUnit,'(" Symmetry error : multiple ops")')
                  CALL juDFT_error("close_pt: Multiple ops (Bravais)",calledby ="closure")
               END IF
            END IF
         END DO

         IF (map(i).eq.0) THEN
            WRITE(oUnit,*) 'Symmetry operations:'
            DO k = 1, nops
               WRITE(oUnit,*) 'Matrix ', k, ':'
               WRITE(oUnit,'(3i7)') mrot(:,1,k)
               WRITE(oUnit,'(3i7)') mrot(:,2,k)
               WRITE(oUnit,'(3i7)') mrot(:,3,k)
               WRITE(oUnit,*) ''
            END DO
            WRITE (oUnit,'(" Group not closed (Bravais lattice)")')
            WRITE (oUnit,'(" operation j=",i2,"  map=",12i4,:/,(21x,12i4))')  j, map(1:nops)
            WRITE(oUnit,*) ''
            WRITE(oUnit,*) 'Expected product of operations ', j, ' and ', i, ':'
            WRITE(oUnit,'(3i7)') mp(:,1)
            WRITE(oUnit,'(3i7)') mp(:,2)
            WRITE(oUnit,'(3i7)') mp(:,3)
            WRITE(oUnit,*) ''
            CALL juDFT_error("close_pt:Not closed",calledby="closure")
         END IF
      END DO
      mtable(j,1:nops) = map(1:nops)
   END DO

END SUBROUTINE close_pt

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

SUBROUTINE check_close(nops,mrot,tau,multtab,inv_op,optype)

   USE m_constants

   IMPLICIT NONE

   INTEGER, INTENT (IN)  :: nops
   INTEGER, INTENT (IN)  :: mrot(3,3,nops)
   REAL,    INTENT (IN)  :: tau(3,nops)
   INTEGER, INTENT (OUT) :: inv_op(nops)
   INTEGER, INTENT (OUT) :: multtab(nops,nops)
   INTEGER, INTENT (OUT) :: optype(nops)

   REAL    ttau(3)
   INTEGER i,j,n,k,mp(3,3),mdet,mtr

   REAL,    PARAMETER :: eps=1.0e-7
   INTEGER, PARAMETER :: cops(-1:3)=(/ 2, 3, 4, 6, 1 /)

   inv_op(1:nops) = 0

   multtab = 0

   ! loop over all operations
   DO j = 1, nops

      ! multiply {R_j|t_j}{R_i|t_i}
      DO i = 1, nops
         mp = matmul( mrot(:,:,j) , mrot(:,:,i) )
         ttau = tau(:,j) + matmul( mrot(:,:,j) , tau(:,i) )
         ttau = ttau - anint( ttau - eps )

         ! determine which operation this is
         DO k=1,nops
            IF ( all( mp(:,:) == mrot(:,:,k) ) .and. all( abs( ttau(:)-tau(:,k) ) < eps ) ) THEN
               IF ( multtab(j,i) .eq. 0 ) THEN
                  multtab(j,i) = k
                  IF (k .eq. 1) inv_op(j)=i
               ELSE
                  WRITE(oUnit,'(" Symmetry error: multiple ops")')
                  CALL juDFT_error("check_close: Multiple ops",calledby ="closure")
               END IF
            END IF
         END DO

         IF (multtab(j,i).eq.0) THEN
            WRITE (oUnit,'(" Group not closed")')
            WRITE (oUnit,'("  j , i =",2i4)') j,i
            CALL juDFT_error("check_close: Not closed",calledby="closure")
         END IF
      END DO
   END DO

   ! determine the type of each operation
   DO n = 1, nops
      mtr = mrot(1,1,n) + mrot(2,2,n) + mrot(3,3,n)
      mdet = mrot(1,1,n)*(mrot(2,2,n)*mrot(3,3,n)-mrot(3,2,n)*mrot(2,3,n)) +&
             mrot(1,2,n)*(mrot(3,1,n)*mrot(2,3,n)-mrot(2,1,n)*mrot(3,3,n)) +&
             mrot(1,3,n)*(mrot(2,1,n)*mrot(3,2,n)-mrot(3,1,n)*mrot(2,2,n))

      optype(n) = mdet*cops(mdet*mtr)

   END DO

END SUBROUTINE check_close

END MODULE m_closure


       PROGRAM KING1
C++::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C
C  This program, from [SAUL.PROGS.SOURCE]ISOXFIT and PROFILE, reads a
C  profile and then fits an surface brightness profile (broadened
C  by the seeing) consistent with a King model
C
C  All the fit is in LOG10/LOG10 and the output is converted in RAD/MAGNITUDE
C
C JLP Version of 10-10-86
C--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
	PARAMETER (IDIM=6000)
	PARAMETER (IDIM2=10000)		!For KING's model...
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RHO(IDIM2),PHI(IDIM2),RAD(IDIM2),DPHI(IDIM2)
	REAL*8 S(IDIM),YY(IDIM),K(IDIM),RAD1(IDIM),
     1	SPLINE(IDIM),LOGRAD(IDIM),
     1	XC(2),BL(2),BU(2),
     1	RADIUS(IDIM),PROF(IDIM),
     1	WK(IDIM),LOGR(IDIM),LOGPROF(IDIM)
	REAL*4 X1PLOT(IDIM),X2PLOT(IDIM),Y1PLOT(IDIM),Y2PLOT(IDIM)
	REAL*4 X3PLOT(IDIM),Y3PLOT(IDIM)
	INTEGER IWK(5)
	CHARACTER CHAR1*30,CHAR2*30,TITLE*40,ANS*1,PLOTDEV*32
	CHARACTER NAME*60,COMMENTS*80

	COMMON/KING/RHO,PHI,RAD,NINDEX,DPHI
	COMMON/KING3/W0,RTIDAL,RHO0
	COMMON/SPLINE/ SPLINE,NCAP7,K
	COMMON/NAG/ NSTART,LOGR,LOGPROF,ITERATION
10	FORMAT(A)

C  Reads the profile with 2 possible formats.
C
	PRINT *,' FORMAT :  1. (NPTS,X,Y)      2. (NPTS,X,Y,VNUMB)  ?'
	READ(5,*) IFORMT
1022	PRINT *,' NAME OF THE PROFILE ?'
	READ(5,10) NAME
	PRINT *,' CONSTANT YOU WANT TO SUBTRACT TO THE INPUT PROFILE ',
     1	' (SKY LEVEL) ?'
	READ(5,*) SKY
	PRINT *,' ZERO POINT FOR THE MAGNITUDES ? (per squared arcsecond)'
	READ(5,*) CMAG
	OPEN (9,FILE=NAME,STATUS='OLD',ERR=1022)
	READ(9,*)NPOINTS

	IF(IFORMT.EQ.1)THEN
	  DO I=1,NPOINTS
	  READ (9,*,END=11) RADIUS(I),PROF(I)
	  PROF(I)=PROF(I)-SKY
	  END DO
	ELSE
	  DO I=1,NPOINTS
	  READ (9,*,END=11) RADIUS(I),PROF(I),WORK
	  PROF(I)=PROF(I)-SKY
	  END DO
	ENDIF

	GO TO 111
11	NPOINTS=I-1
	PRINT *,' WARNING : LESS POINTS THAN EXPECTED !!!!'
111	PRINT *,NPOINTS,' POINTS RECEIVED'
	PRINT *,'PROFILE FROM ',RADIUS(1),' ARCSECONDS TO ',
     1	RADIUS(NPOINTS),' ARCSECONDS'

C Conversion in Log/Log :

      DO I=1,NPOINTS
	LOGR(I)=DLOG10(RADIUS(I))
	X1PLOT(I)=LOGR(I)
	   IF(PROF(I).LE.0.D0)THEN
	   NPOINTS=I-1
	   PRINT *,' NEGATIVE VALUES !'
	   PRINT *,' PROFILE TRONCATED AT R= ',RADIUS(I-1),' ARCSECONDS'
	   GO TO 12
	   ENDIF
        LOGPROF(I)=DLOG10(PROF(I))
	Y1PLOT(I)=-2.5D0*LOGPROF(I)+CMAG
      END DO
C
C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C
C  For a given value of W0, use least squares to find the best values of
C  RCORE and E0 to fit the data over a given range.
C
C   Enter W0 plus guesses for E0 and RCORE
C
12      WRITE (6,334)
 334  FORMAT(/' Enter sigma of the seeing: ',$)
      READ (5,*) SIGMA
C
      WRITE (6,335)
335	FORMAT(/' Enter guesses for B0 (central mag) ',
     1	'and RC (core radius): ',/,
     1	' (This guess must be good for RC in',
     1	' order to correct for the seeing effects')
	READ(5,*) B0,RCORE
	XC(1)=(CMAG-B0)/2.5
	XC(2)=DLOG10(RCORE)
	PRINT *,' XC(1),XC(2)',XC(1),XC(2)
	WRITE (6,3355)
3355	FORMAT(/,' Enter value of W0 (central potential): ',$)
	READ (5,*) W0
C
C
	WRITE (6,339)
339	FORMAT(' Enter start radius and end radius for fitting: ',$)
	READ (5,*) RSTART,RREND
	DO I=1,NPOINTS
	IF(RSTART.LE.RADIUS(I)) GO TO 22
	END DO
22	NSTART=I
	DO I=NPOINTS,1,-1
	  IF(RREND.GE.RADIUS(I)) GO TO 23
	END DO
23	NBINS=I
	PRINT *,NBINS,' POINTS FOR THE FIT IN THE PROFILE'
C
C NPTS = Number of computed points for the model
C
	PRINT *,' NUMBER OF POINTS FOR THE MODEL (310?) ?'
	READ(5,*) NPTS

C Setting up the radius array (from 1.E-2 to 1.E+3 or so)
C for the model :
	RAD(1)=0.D0
	DO I=2,NPTS
	WORK=-2.0D0 + 5.D0*FLOAT(I)/FLOAT(NPTS)
	RAD(I)=10.D0**WORK
	END DO

	PRINT *,' Calculating King model now...'
	CALL KING(NPTS)
C
	PRINT *,' MODEL CALCULATED '
	XX=RADIUS(NBINS)/RCORE
	IF(XX.GT.RTIDAL)THEN
	PRINT *,' WARNING : MAX. RADIUS (PROFILE) IS',
     1	' LARGER THAN RTIDAL (MODEL)'
	ENDIF
C
100	DO I=1,NPTS
	RAD1(I)=RAD(I)*RCORE                  ! REMEMBER: RAD = r/rcore
	END DO                                !             R = r

C Projection onto the plane of the sky
C (scaled radii)
	CALL PROJECT_ABEL(RAD1,RHO,S,NPTS)
	PRINT *,' DENSITY PROJECTED '

C
C   Discard the first few points in S which are generally bad.
C
       DO I=10,NPTS
          S(I-9)=S(I)
          RAD1(I-9)=RAD1(I)
          RAD(I-9)=RAD(I)
       END DO

       NPTS=NPTS-10    ! Also, the Abel integral leaves S(NPTS) as zero.

C Normalization of the model with the first few points :
	CNORM=(S(1)+S(2)+S(3))/3.D0

	DO I=1,NPTS
	S(I)=S(I)/CNORM
	X2PLOT(I)=DLOG10(RAD(I))
	Y2PLOT(I)=DLOG10(S(I))
	END DO
C
C Broadenning with a Hankel function
C on scaled radii
	CALL BROADEN(RAD1,S,NPTS,SIGMA)

C Possibility of displaying the broadened model
	CHAR1='LOG10(RADIUS)'
	CHAR2='LOG10(SURF. BRIGHT.)'
	TITLE=' BROADENING THE MODEL '

	PRINT *,' DO YOU WANT TO DISPLAY THE BROADENED MODEL ?(N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
	 PRINT *,' TITLE ?'
	 READ(5,10) TITLE
	   DO I=1,NPTS
	   Y3PLOT(I)=DLOG10(S(I))
	   END DO
	 PRINT *,' Plotting device: &xterm, ... ?'
         COMMENTS=' '
	 READ(5,10) PLOTDEV
	  CALL DISPLAY2(X2PLOT,Y2PLOT,1,NPTS,X2PLOT,Y3PLOT,
     1	1,NPTS,CHAR1,CHAR2,TITLE,PLOTDEV,'L','L1',NAME,COMMENTS)
	ENDIF

C Does a cubic-spline interpolation to the logarithm of S
C on RAD/RCORE
	CALL SPLINELOG_INTER(RAD,S,NPTS,SPLINE,NCAP7,K)
C
C   Now call minimization routine E04GEF (NAG).
C   M: number of points
C   N: number of parameters (here 2 : Io and Rc)
C   XC: parameters [ XC(1)=Io and XC(2)=Rc ]
C
	N=2
	LIWK=5
	LWK=IDIM
	IFAIL=1
	M=NBINS-NSTART+1
	ITERATION=0
	CALL E04GEF (M,N,XC,FSUMSQ,IWK,LIWK,WK,LWK,IFAIL)
C
	RMS=DSQRT(FSUMSQ/FLOAT(M-N))
	WRITE (6,88) FSUMSQ,RMS,ITERATION
88	FORMAT (/,' E04GEF HAS CONVERGED :',/,
     1	' FINAL SUM OF SQUARES = ',F10.3,6X,
     1	' RMS :',E12.4,/,
     1	' AFTER',I5,' ITERATIONS',/)
C
	IF(IFAIL.NE.0) THEN
	WRITE (6,77)IFAIL
77	FORMAT(' ***** WARNING ! ***** IN E04GEF  IFAIL =',I3)
	END IF
C
	WRITE (6,338)
338	FORMAT(/' And the magic numbers are: ')

	B0=-2.5D0*XC(1)+CMAG
	WRITE (6,55) B0
55	FORMAT(' B0 = ',F11.3)
	RCORE=10.D0**(XC(2))
	RRTIDAL=RTIDAL*RCORE
	WRITE (6,66) RCORE,RRTIDAL
66	FORMAT(' RCORE = ',F11.4,' RTIDAL = ',F11.4)

C******************************************************************
C Displaying the fit
C
	PRINT *,'NPTS (MODEL) =',NPTS
	PRINT *,'NPOINTS (PROFILE) =',NPOINTS
	PRINT *,'NCAP7 (KNOTS FOR SPLINE) =',NCAP7

	DO I=1,NPTS
	X2PLOT(I)=DLOG10(RAD(I))+XC(2)
	Y2PLOT(I)=-2.5D0*DLOG10(S(I))+B0
	END DO

	CHAR1='LOG10(RADIUS)'
	CHAR2='MAGNITUDE /ARCSEC**2'
	TITLE=' PROFILE AND MODEL '

	PRINT *,' DO YOU WANT TO DISPLAY THE FIT? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N')THEN
	  PRINT *,' TITLE ?'
	  READ(5,10) TITLE
	  PRINT *,' DEVICE : TEKTRO, CIFER_T5, CANON ?'
	  READ(5,10) PLOTDEV
          COMMENTS=' '
	  CALL DISPLAY2(X1PLOT,Y1PLOT,1,NPOINTS,X2PLOT,Y2PLOT,
     1	1,NPTS,CHAR1,CHAR2,TITLE,PLOTDEV,'L','L2',NAME,COMMENTS)
	ENDIF

	PRINT *,' DO YOU WANT TO STORE THE CURVE IN A FILE ? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N')THEN
	KCURVE=2
	CALL STORE_GRAPH(X1PLOT,Y1PLOT,1,NPOINTS,X2PLOT,Y2PLOT,
     1	1,NPTS,KCURVE)
	ENDIF

C********************************************************************
C Now displaying the residuals

C Computing the residuals :

	DO I=NPOINTS,1,-1
	  IF(RTIDAL.GT.RADIUS(I)) GO TO 900
	END DO
900	NMAX=I-1

	DO I=1,NMAX
	XX=X1PLOT(I)-XC(2)
	LEFT=1
	IFAIL=1
C Calling E02BCF (NAG) for the abscissa XX and getting the ordinate in YY(1)
	CALL E02BCF(NCAP7,K,SPLINE,XX,LEFT,YY,IFAIL)
	IF(IFAIL.NE.0) PRINT 45,IFAIL
45	FORMAT(' ***** WARNING ! ***** IN E02BCF  IFAIL =',I3)
	WORK=B0-2.5D0*YY(1)
	Y2PLOT(I)=Y1PLOT(I)-WORK
	END DO

	CHAR1='LOG10(RADIUS)'
	CHAR2='PROFILE - MODEL'
	TITLE=' RESIDUALS '

	PRINT *,' DO YOU WANT TO DISPLAY THE RESIDUALS ? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N')THEN
	  DO I=1,NMAX
	  Y3PLOT(I)=0.0
	  END DO
	  PRINT *,' TITLE ?'
	  READ(5,10) TITLE
	  PRINT *,' DEVICE : TEKTRO, CIFER_T5, CANON ?'
	  READ(5,10) PLOTDEV
          COMMENTS=' '
	  CALL DISPLAY2(X1PLOT,Y2PLOT,1,NMAX,X1PLOT,Y3PLOT,1,NMAX,
     1	CHAR1,CHAR2,TITLE,PLOTDEV,'L','L1',NAME,COMMENTS)
	ENDIF

	PRINT *,' DO YOU WANT TO STORE THIS CURVE IN A FILE ? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N')THEN
	KCURVE=1
	CALL STORE_GRAPH(X1PLOT,Y2PLOT,1,NMAX,X1PLOT,Y2PLOT,
     1	1,NPOINTS,KCURVE)
	ENDIF

	PRINT *,' DO YOU WANT ANOTHER TRY ? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N')GO TO 12

	CLOSE(9)
	STOP
	END
C
C_________________________________________________________________________

      SUBROUTINE LSFUN2 (M,N,XC,FVECC,FJACC,LJC)
C--------------------------------------------------------------------------
C     Subroutine to produce the function value and the first-order
C     partial derivatives of the function to be minimized by E04GEF
C
C	M: Number of points
C	N: Number of parameters
C	FVECC: Residuals
C	FJACC: Jacobian matrix
C--------------------------------------------------------------------------
	PARAMETER (IDIM=6000)
	REAL*8 XC(N),SPLINE(IDIM),FVECC(M),
     1	FJACC(M,LJC),K(IDIM),S(5),X,
     1	LOGR(IDIM),LOGPROF(IDIM)
	INTEGER M,N,IFAIL,NCAP7,LEFT,NSTART
C
	COMMON/SPLINE/SPLINE,NCAP7,K
	COMMON/NAG/NSTART,LOGR,LOGPROF,ITERATION
C
	ITERATION=ITERATION+1
      DO J=NSTART,NSTART+M-1
           X=LOGR(J)-XC(2)
C  i.e. X = LOG10( RAD/Rcore )
C Calling E02BCF (NAG):
           LEFT=0
           IFAIL=0
           CALL E02BCF(NCAP7,K,SPLINE,X,LEFT,S,IFAIL)
C
           FVECC(J-NSTART+1)=LOGPROF(J)-XC(1)-S(1)
           FJACC(J-NSTART+1,1)=-1.0D0
           FJACC(J-NSTART+1,2)=S(2)
       END DO
       RETURN
       END
C
C-------------------------------------------------------------------
	include 'jlpsub:king_model.for'
C In Project.for there is "Splinelogfit" (No common blocks)
C	include 'jlpsub:project.for'


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

program z
use ieee_arithmetic
real a,b,c
logical la(16), lb(16)
logical lfsav(5), lfset(5)

lfset = .false.
call ieee_get_halting_mode(ieee_all, lfsav)
call ieee_set_halting_mode(ieee_all, lfset)

a = huge(c)
b = ieee_next_after(a,ieee_value(a,ieee_positive_inf))
write (6,100) b, b
la(1) = b .gt. a

c = ieee_next_after(a,0.0)
write (6,100) c, c
la(2) = a .gt. c

a = 1.0
b = ieee_next_after(a,ieee_value(a,ieee_positive_inf))
write (6,100) b, b
la(3) = b .gt. a

c = ieee_next_after(a,0.0)
write (6,100) c, c
la(4) = a .gt. c

a = tiny(c)
b = ieee_next_after(a,ieee_value(a,ieee_positive_inf))
write (6,100) b, b
la(5) = b .gt. a

c = ieee_next_after(a,0.0)
write (6,100) c, c
la(6) = a .gt. c

a = 0.0
b = ieee_next_after(a,ieee_value(a,ieee_positive_inf))
write (6,100) b, b
la(7) = b .gt. a

c = ieee_next_after(a,ieee_value(a,ieee_negative_inf))
write (6,100) c, c
la(8) = a .gt. c

a = -tiny(c)
b = ieee_next_after(a,0.0)
write (6,100) b, b
la(9) = b .gt. a

c = ieee_next_after(a,ieee_value(a,ieee_negative_inf))
write (6,100) c, c
la(10) = a .gt. c

a = -1.0
b = ieee_next_after(a,0.0)
write (6,100) b, b
la(11) = b .gt. a

c = ieee_next_after(a,ieee_value(a,ieee_negative_inf))
write (6,100) c, c
la(12) = a .gt. c

a = -huge(c)
b = ieee_next_after(a,0.0)
write (6,100) b, b
la(13) = b .gt. a

c = ieee_next_after(a,ieee_value(a,ieee_negative_inf))
write (6,100) c, c
la(14) = a .gt. c

lb = .true.
call check(la,lb,14)
call ieee_set_halting_mode(ieee_all, lfsav)

100 format(e22.12,2x,z8.8)
end


MODULE points
TYPE POINT
  REAL :: X, Y
CONTAINS
PROCEDURE, PASS :: LENGTH => POINT_LENGTH
END TYPE POINT
TYPE, EXTENDS(POINT) :: POINT_3D
  REAL :: Z
CONTAINS
PROCEDURE, PASS :: LENGTH => POINT_3D_LENGTH
END TYPE POINT_3D

CONTAINS

REAL FUNCTION POINT_LENGTH(A,B)
CLASS(POINT), INTENT(IN) :: A, B
POINT_LENGTH = SQRT((A%X-B%X)**2+(A%Y-B%Y)**2)
END FUNCTION POINT_LENGTH
REAL FUNCTION POINT_3D_LENGTH(A,B)
CLASS(POINT_3D), INTENT(IN) :: A
CLASS(POINT), INTENT(IN) :: B
SELECT TYPE (B)
  CLASS IS (POINT_3D)
END SELECT
END FUNCTION point_3d_length
END MODULE points


      subroutine fpback(a,z,n,k,c,nest)
c  subroutine fpback calculates the solution of the system of
c  equations a*c = z with a a n x n upper triangular matrix
c  of bandwidth k.
c  ..
c  ..scalar arguments..
      integer n,k,nest
c  ..array arguments..
      real a(nest,k),z(n),c(n)
c  ..local scalars..
      real store
      integer i,i1,j,k1,l,m
c  ..
      k1 = k-1
      c(n) = z(n)/a(n,1)
      i = n-1
      if(i.eq.0) go to 30
      do 20 j=2,n
        store = z(i)
        i1 = k1
        if(j.le.k1) i1 = j-1
        m = i
        do 10 l=1,i1
          m = m+1
          store = store-c(m)*a(i,l+1)
  10    continue
        c(i) = store/a(i,1)
        i = i-1
  20  continue
  30  return
      end


      SUBROUTINE MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ,
     $                   Z, LDZ, RANKE, ISTAIR, TOL, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal transformations Q and Z such that the
C     transformed pencil Q'(sE-A)Z has the E matrix in column echelon
C     form, where E and A are M-by-N matrices.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBQ    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix Q the unitary row permutations, as follows:
C             = 'N':  Do not form Q;
C             = 'I':  Q is initialized to the unit matrix and the
C                     unitary row permutation matrix Q is returned;
C             = 'U':  The given matrix Q is updated by the unitary
C                     row permutations used in the reduction.
C
C     JOBZ    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the unitary column transformations, as follows:
C             = 'N':  Do not form Z;
C             = 'I':  Z is initialized to the unit matrix and the
C                     unitary transformation matrix Z is returned;
C             = 'U':  The given matrix Z is updated by the unitary
C                     transformations used in the reduction.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows in the matrices A, E and the order of
C             the matrix Q.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns in the matrices A, E and the order
C             of the matrix Z.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the A matrix of the pencil sE-A.
C             On exit, the leading M-by-N part of this array contains
C             the unitary transformed matrix Q' * A * Z.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading M-by-N part of this array must
C             contain the E matrix of the pencil sE-A, to be reduced to
C             column echelon form.
C             On exit, the leading M-by-N part of this array contains
C             the unitary transformed matrix Q' * E * Z, which is in
C             column echelon form.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,M).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
C             On entry, if JOBQ = 'U', then the leading M-by-M part of
C             this array must contain a given matrix Q (e.g. from a
C             previous call to another SLICOT routine), and on exit, the
C             leading M-by-M part of this array contains the product of
C             the input matrix Q and the row permutation matrix used to
C             transform the rows of matrix E.
C             On exit, if JOBQ = 'I', then the leading M-by-M part of
C             this array contains the matrix of accumulated unitary
C             row transformations performed.
C             If JOBQ = 'N', the array Q is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDQ = 1 and
C             declare this array to be Q(1,1) in the calling program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q. If JOBQ = 'U' or
C             JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
C             On entry, if JOBZ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Z (e.g. from a
C             previous call to another SLICOT routine), and on exit, the
C             leading N-by-N part of this array contains the product of
C             the input matrix Z and the column transformation matrix
C             used to transform the columns of matrix E.
C             On exit, if JOBZ = 'I', then the leading N-by-N part of
C             this array contains the matrix of accumulated unitary
C             column transformations performed.
C             If JOBZ = 'N', the array Z is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDZ = 1 and
C             declare this array to be Z(1,1) in the calling program).
C
C     LDZ     INTEGER
C             The leading dimension of array Z. If JOBZ = 'U' or
C             JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.
C
C     RANKE   (output) INTEGER
C             The computed rank of the unitary transformed matrix E.
C
C     ISTAIR  (output) INTEGER array, dimension (M)
C             This array contains information on the column echelon form
C             of the unitary transformed matrix E. Specifically,
C             ISTAIR(i) = +j if the first non-zero element E(i,j)
C             is a corner point and -j otherwise, for i = 1,2,...,M.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance below which matrix elements are considered
C             to be zero. If the user sets TOL to be less than (or
C             equal to) zero then the tolerance is taken as
C             EPS * MAX(ABS(E(I,J))), where EPS is the machine
C             precision (see LAPACK Library routine DLAMCH),
C             I = 1,2,...,M and J = 1,2,...,N.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(M,N))
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Given an M-by-N matrix pencil sE-A with E not necessarily regular,
C     the routine computes a unitary transformed pencil Q'(sE-A)Z such
C     that the matrix Q' * E * Z is in column echelon form (trapezoidal
C     form).  Further details can be found in [1].
C
C     [An M-by-N matrix E with rank(E) = r is said to be in column
C     echelon form if the following conditions are satisfied:
C     (a) the first (N - r) columns contain only zero elements; and
C     (b) if E(i(k),k) is the last nonzero element in column k for
C         k = N-r+1,...,N, i.e. E(i(k),k) <> 0 and E(j,k) = 0 for
C         j > i(k), then 1 <= i(N-r+1) < i(N-r+2) < ... < i(N) <= M.]
C
C     REFERENCES
C
C     [1] Beelen, Th. and Van Dooren, P.
C         An improved algorithm for the computation of Kronecker's
C         canonical form of a singular pencil.
C         Linear Algebra and Applications, 105, pp. 9-65, 1988.
C
C     NUMERICAL ASPECTS
C
C     It is shown in [1] that the algorithm is numerically backward
C     stable. The operations count is proportional to (MAX(M,N))**3.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998.
C     Based on Release 3.0 routine MB04SD modified by A. Varga,
C     German Aerospace Research Establishment, Oberpfaffenhofen,
C     Germany, Dec. 1997, to transform also the matrix A.
C
C     REVISIONS
C
C     A. Varga, DLR Oberpfaffenhofen, June 2005.
C
C     KEYWORDS
C
C     Echelon form, orthogonal transformation, staircase form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBQ, JOBZ
      INTEGER           INFO, LDA, LDE, LDQ, LDZ, M, N, RANKE
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           ISTAIR(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           LJOBQI, LJOBZI, LZERO, UPDATQ, UPDATZ
      INTEGER           I, K, KM1, L, LK, MNK, NR1
      DOUBLE PRECISION  EMX, EMXNRM, TAU, TOLER
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           IDAMAX
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARF, DLARFG, DLASET, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LJOBQI = LSAME( JOBQ, 'I' )
      UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' )
      LJOBZI = LSAME( JOBZ, 'I' )
      UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDE.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR.
     $              UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR.
     $              UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -12
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB04UD', -INFO )
         RETURN
      END IF
C
C     Initialize Q and Z to the identity matrices, if needed.
C
      IF ( LJOBQI )
     $   CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
      IF ( LJOBZI )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Quick return if possible.
C
      RANKE = MIN( M, N )
C
      IF ( RANKE.EQ.0 )
     $   RETURN
C
      TOLER = TOL
      IF ( TOLER.LE.ZERO )
     $   TOLER = DLAMCH( 'Epsilon' )*DLANGE( 'M', M, N, E, LDE, DWORK )
C
      K = N
      LZERO = .FALSE.
C
C     WHILE ( ( K > 0 ) AND ( NOT a zero submatrix encountered ) ) DO
   20 IF ( ( K.GT.0 ) .AND. ( .NOT. LZERO ) ) THEN
C
C         Intermediate form of E
C
C                     <--k--><--n-k->
C                l=1 |x....x|       |
C                    |      |       |
C                    |  Ek  |   X   |
C                    |      |       |
C            l=m-n+k |x....x|       |
C                    ----------------
C                    |      |x ... x|  }
C                    |  O   |  x x x|  }
C                    |      |    x x|  } n-k
C                    |      |      x|  }
C
C        where submatrix Ek = E[1:m-n+k;1:k].
C
C        Determine row LK in submatrix Ek with largest max-norm
C        (starting with row m-n+k).
C
         MNK = M - N + K
         EMXNRM = ZERO
         LK = MNK
C
         DO 40 L = MNK, 1, -1
            EMX = ABS( E(L,IDAMAX( K, E(L,1), LDE )) )
            IF ( EMX.GT.EMXNRM ) THEN
               EMXNRM = EMX
               LK = L
            END IF
   40    CONTINUE
C
         IF ( EMXNRM.LE.TOLER ) THEN
C
C           Set submatrix Ek to zero.
C
            CALL DLASET( 'Full', MNK, K, ZERO, ZERO, E, LDE )
            LZERO = .TRUE.
            RANKE = N - K
         ELSE
C
C           Submatrix Ek is not considered to be identically zero.
C           Check whether rows have to be interchanged.
C
            IF ( LK.NE.MNK ) THEN
C
C              Interchange rows lk and m-n+k in whole A- and E-matrix
C              and update the row transformation matrix Q, if needed.
C              (For Q, the number of elements involved is m.)
C
               CALL DSWAP( N, E(LK,1), LDE, E(MNK,1), LDE )
               CALL DSWAP( N, A(LK,1), LDA, A(MNK,1), LDA )
               IF( UPDATQ ) CALL DSWAP( M, Q(1,LK), 1, Q(1,MNK), 1 )
            END IF
C
            KM1 = K - 1
C
C           Determine a Householder transformation to annihilate
C           E(m-n+k,1:k-1) using E(m-n+k,k) as pivot.
C           Apply the transformation to the columns of A and Ek
C           (number of elements involved is m for A and m-n+k for Ek).
C           Update the column transformation matrix Z, if needed
C           (number of elements involved is n).
C
            CALL DLARFG( K, E(MNK,K), E(MNK,1), LDE, TAU )
            EMX = E(MNK,K)
            E(MNK,K) = ONE
            CALL DLARF( 'Right', MNK-1, K, E(MNK,1), LDE, TAU, E, LDE,
     $                   DWORK )
            CALL DLARF( 'Right', M, K, E(MNK,1), LDE, TAU, A, LDA,
     $                   DWORK )
            IF( UPDATZ ) CALL DLARF( 'Right', N, K, E(MNK,1), LDE, TAU,
     $                               Z, LDZ, DWORK )
            E(MNK,K) = EMX
            CALL DLASET( 'Full', 1, KM1, ZERO, ZERO, E(MNK,1), LDE )
C
            K = KM1
         END IF
         GO TO 20
      END IF
C     END WHILE 20
C
C     Initialise administration staircase form, i.e.
C     ISTAIR(i) =  j  if E(i,j) is a nonzero corner point
C               = -j  if E(i,j) is on the boundary but is no corner
C                     point.
C     Thus,
C     ISTAIR(m-k) =   n-k           for k=0,...,rank(E)-1
C                 = -(n-rank(E)+1)  for k=rank(E),...,m-1.
C
      DO 60 I = 0, RANKE - 1
         ISTAIR(M-I) = N - I
   60 CONTINUE
C
      NR1 = -(N - RANKE + 1)
C
      DO 80 I = 1, M - RANKE
         ISTAIR(I) = NR1
   80 CONTINUE
C
      RETURN
C *** Last line of MB04UD ***
      END