module LatticeFFT
  use Utils
  implicit none

  interface FFT3D
     module procedure CubicFFT, CubicMassiveFFT
  end interface

#include "configure.h"

  !!constants
  !!define the FFT direction
  integer(IB),parameter::FFT_FORWARD = -1
  integer(IB),parameter::FFT_BACKWARD=-FFT_FORWARD

  integer(IB)::fft_ind_re=1
  integer(IB)::fft_ind_im=2
  !!work space
  complex(DLC),dimension(n)::FFT_eit
  real(dl),dimension(n)::fft_sin,fft_cos,fft_sinhalf,fft_coshalf,fft_effkdx, fft_effk2dx2
  real(dl),dimension(fft_numk)::fft_vol

  logical::fft_initialized = .false.

contains

  subroutine FFT_Init()
    integer(IB) i,j,k,id
    real(dl)::keff,w
    fft_initialized = .true.
    !$omp parallel do
    do i=1,N
       fft_cos(i)=cos(const_2pi*(i-1)*FFT_FORWARD/n)
       fft_sin(i)=sin(const_2pi*(i-1)*FFT_FORWARD/n)
       fft_eit(i)=cmplx(fft_cos(i),fft_sin(i))
       fft_coshalf(i) = cos(const_pi*(i-1)*FFT_FORWARD/n)
       fft_sinhalf(i) = sin(const_pi*(i-1)*FFT_FORWARD/n)
#if USE_STANDARD_WAVENUMBER
       !! stop "By default this feature is switched off"
       if(i.le.n/2+1)then
          fft_effkdx(i) = const_2pi*(i-1)*FFT_BACKWARD/n
       else
          fft_effkdx(i) = const_2pi*(i-1-n)*FFT_BACKWARD/n
       endif
#elif DIS_SCHEME ==  LATTICEEASY
       if(i.le.n/2+1) then
          fft_effkdx(i) = -2.*fft_sinhalf(i)
       else
          fft_effkdx(i) = 2.*fft_sinhalf(i)
       endif
#elif DIS_SCHEME == HLATTICE1
       fft_effkdx(i) = -fft_sin(i)
#elif DIS_SCHEME == HLATTICE2
       fft_effkdx(i) = -fft_sin(i)/3.*(4.-fft_cos(i))
#else
       stop "Discretization scheme not defined in configure.h"
#endif

       fft_effk2dx2(i) = fft_effkdx(i)**2
    enddo
    !$omp end parallel do

#if MATCH_CONFIGURATION_SPACE_FLUC
    if(fft_cutoff_ind.lt.n/2) then
       write(*,*) "Since V2.0 a cutoff k is used."
       write(*,*) "with a cut off there is no way to match the configuration space fluctuation to the Fourier space integral (<f^2>=\int |f_k|^2 vol(k) d \ln k)"
       stop
    endif
    fft_vol = 0._dl
    !$omp parallel do reduction(+:fft_vol) private(i,j,k,id,keff,w) default(shared)
    LOOP
    keff=fft_absk_ind(i,j,k)
    id = nint(keff)
    if(id.gt.0 .and. id.le.fft_numk)fft_vol(id) = fft_vol(id) + 1.
    ENDLOOP
    !$omp end parallel do
#else
    do i=1,fft_numk
       fft_vol(i) = const_pi * 4.* real(i,dl)**2
    enddo
#endif

  end subroutine FFT_Init

  subroutine fft_conj_pair(i,i1,i2)
    integer(IB),intent(in)::i
    integer(IB),intent(out)::i1,i2
    i1=bit_reverse_array(i)
    i2=bit_reverse_array(fft_conj_index(i))
  end subroutine fft_conj_pair

  function fft_nabla2dx2(i,j,k) !!return -k_{eff}^2*(dx^2)
    integer(IB) i,j,k
    real(dl) fft_nabla2dx2
    fft_nabla2dx2 = - fft_effk2dx2(i) - fft_effk2dx2(j) - fft_effk2dx2(k)
  end function fft_nabla2dx2

  function fft_absk_ind(i,j,k) !! return |k_eff| in unit of 2\pi/L;
    integer(IB) i,j,k
    real(dl) fft_absk_ind
    real(dl),parameter::c = (n/const_2pi)
    if(fft_rawk_index_abs(i).gt.fft_cutoff_ind .or. fft_rawk_index_abs(j) .gt. fft_cutoff_ind .or. fft_rawk_index_abs(k) .gt. fft_cutoff_ind)then
       fft_absk_ind = 0. !!ignore this mode
       return
    endif
    fft_absk_ind = c * sqrt(- fft_nabla2dx2(i,j,k) )
  end function fft_absk_ind

  Subroutine CubicFFT(ref,imf,direction)
    real(dl),dimension(:,:,:,:),intent(inout)::ref,imf
    integer(IB),intent(in)::direction
    integer(IB) mmax,istep,m,i,j,k,indx,j1,k1
    if(.not. fft_initialized) call fft_init()
    if(size(ref,2).ne.N .or. size(ref,3).ne. n .or. size(ref,4).ne.N) stop "CubicFFT: wrong size of input array"
    if(size(imf,2).ne.N .or. size(imf,3).ne. n .or. size(imf,4).ne.N) stop "CubicFFT: wrong size of input array"
    !!FFT in x and y direction
    !$omp parallel do private(k) default(shared)
    do k=1,N
       call FFT_2D(ref(:,1:n,1:n,k),imf(:,1:n,1:n,k),direction)
    enddo
    !$omp end parallel do

    mmax=1
    indx=Nby2
    !!shared memory, output is scrambled format (i,j,k)-> bit_reverse_array(i),bit_reverse_array(j),bit_reverse_array(k)
    if(direction.eq.FFT_FORWARD)then
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             !$omp parallel do
             do i=m+1,N,istep
                call FFT_xstep(ref,imf,i,mmax,m,indx)
             enddo
             !$omp end parallel do
          enddo
          mmax=istep
          indx=indx/2
       enddo
    else
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             !$omp parallel do
             do i=m+1,N,istep
                call FFT_xstep_backward(ref,imf,i,mmax,m,indx)
             enddo
             !$omp end parallel do
          enddo
          mmax=istep
          indx=indx/2
       enddo
    endif
    if(direction.ne.FFT_FORWARD)then
       ref(fft_ind_re,:,:,:) = ref(fft_ind_re,:,:,:)/ncube !! FFTW does not do this
       imf(fft_ind_im,:,:,:) = imf(fft_ind_im,:,:,:)/ncube
    endif
  End Subroutine CubicFFT

  Subroutine FFT_RandomGaussian(ref,imf,repk,impk,realspace)
    !! Set up random Gaussian ref and imf in configuration space, if realspace is omitted or set to be true. If realspace is set to be false, the result will be in scrambled momentum space.
    !!repk is the power spectrum of ref at 2pi/L, 4pi/L, ..., 2*fft_num/L
    !!impk is the power spectrum of imf at 2pi/L, 4pi/L, ..., 2*fft_num/L

    real(dl),intent(in):: repk(fft_numk),impk(fft_numk)
    real(dl),dimension(:,:,:,:)::ref,imf
    real(dl) refk(fft_numk),imfk(fft_numk)
    integer(IB) i,j,k,i1,j1,k1,i2,j2,k2
    logical,optional,intent(in)::realspace
    if(.not. fft_initialized) call fft_init()
    if(any(repk.lt.0.) .or. any(impk.lt.0.)) stop "Error in FFT_randomGaussian :negative power spectrum."
    if(size(ref,2).ne.N .or. size(ref,3).ne. n .or. size(ref,4).ne.N) stop "CubicFFT: wrong size of input array"
    if(size(imf,2).ne.N .or. size(imf,3).ne. n .or. size(imf,4).ne.N) stop "CubicFFT: wrong size of input array"
    if(all(repk.eq.0.d0) .and. all(impk.eq.0.d0))then
       ref(fft_ind_re,:,:,:)= 0._dl
       imf(fft_ind_im,:,:,:)=0._dl
       return
    endif

    refk=sqrt(repk)
    imfk=sqrt(impk)
#define KSPACE_OPERATION assign_grid_value(i,j,k,i1,j1,k1,i2,j2,k2)
#include "headfiles/fft_scan_kspace.h"
    if(present(realspace))then
       if(realspace)then
          call CubicFFT(ref,imf,FFT_BACKWARD)
       endif
    else
       call CubicFFT(ref,imf,FFT_BACKWARD)
    endif

  contains

    subroutine assign_grid_value(i,j,k,i1,j1,k1,i2,j2,k2)
      integer(IB) loc,i,j,k,i1,j1,k1,i2,j2,k2
      complex(DLC) tmp1,tmp2
      loc=nint(fft_absk_ind(i,j,k))
      if(loc.ge.1)then
         if(i2.gt.0)then
            tmp1 = Gaussian_cmplx()
            tmp2 = Gaussian_cmplx()
         else
            tmp1 = Gaussian_Random()
            tmp2 = cmplx(0._dl, Gaussian_Random())
         endif
         tmp1=tmp1*refk(loc)
         tmp2=tmp2*imfk(loc)
      else
         tmp1=0.
         tmp2=0.
      endif
      ref(fft_ind_re,i1,j1,k1)=real(tmp1)+real(tmp2)
      imf(fft_ind_im,i1,j1,k1)=aimag(tmp1)+aimag(tmp2)
      if(i2.gt.0)then
         ref(fft_ind_re,i2,j2,k2)=real(tmp1)-real(tmp2)
         imf(fft_ind_im,i2,j2,k2)=-aimag(tmp1)+aimag(tmp2)
      endif
    end subroutine assign_grid_value
  End Subroutine FFT_RandomGaussian

  subroutine FFT_GetPowerSpectrum(ref,imf,repk,impk)
    real(dl),dimension(:,:,:,:)::ref,imf
    real(DL)::repk(fft_numk),impk(fft_numk)
    real(dl) mult(fft_numk),absk,w,re2,im2
    integer(IB) i,j,k,i1,j1,k1,i2,j2,k2
    if(.not. fft_initialized) call fft_init()
    mult=0.
    repk=0.
    impk=0.
#define KSPACE_OPERATION add_power(i,j,k,i1,j1,k1,i2,j2,k2,repk,impk,mult)
#define REDUCTION_VARS repk,impk,mult
#include "headfiles/fft_scan_kspace.h"
    do i=1,fft_numk
       if(mult(i).gt.0.)then
          repk(i)=repk(i)/mult(i)
          impk(i)=impk(i)/mult(i)
       endif
    enddo
  contains
    subroutine add_power(i,j,k,i1,j1,k1,i2,j2,k2,repk,impk,mult)
      integer(IB) loc,i,j,k,i1,j1,k1,i2,j2,k2
      real(dl),dimension(fft_numk)::repk,impk,mult
      loc=nint(fft_absk_ind(i,j,k))
      if(loc.ge.1)then
         if(i2.gt.0)then
            mult(loc)=mult(loc)+4.
            repk(loc)=repk(loc)+(ref(fft_ind_re,i1,j1,k1)+ref(fft_ind_re,i2,j2,k2))**2 + (imf(fft_ind_im,i1,j1,k1)-imf(fft_ind_im,i2,j2,k2))**2
            impk(loc)=impk(loc)+(ref(fft_ind_re,i1,j1,k1)-ref(fft_ind_re,i2,j2,k2))**2 + (imf(fft_ind_im,i1,j1,k1)+imf(fft_ind_im,i2,j2,k2))**2
         else
            mult(loc)=mult(loc)+2.
            repk(loc)=repk(loc)+ref(fft_ind_re,i1,j1,k1)**2*2.
            impk(loc)=impk(loc)+imf(fft_ind_im,i1,j1,k1)**2*2.
         endif
      endif
    end subroutine add_power
  end subroutine FFT_GetPowerSpectrum

  subroutine FFT_1D(ref,imf,direction)
    real(dl),dimension(:,:)::ref,imf
    integer(IB),intent(in)::direction
    integer(IB) mmax,istep,m,i,j,indx
    real(dl) retmp,imtmp
    mmax=1
    indx=Nby2
    if(direction.eq.FFT_FORWARD)then
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp=fft_cos(m*indx+1)*ref(fft_ind_re,bit_reverse_array(i+mmax)) - fft_sin(m*indx+1)*imf(fft_ind_im,bit_reverse_array(i+mmax))
                imtmp=fft_sin(m*indx+1)*ref(fft_ind_re,bit_reverse_array(i+mmax)) + fft_cos(m*indx+1)*imf(fft_ind_im,bit_reverse_array(i+mmax))
                ref(fft_ind_re,bit_reverse_array(i+mmax))=ref(fft_ind_re,bit_reverse_array(i))-retmp
                imf(fft_ind_im,bit_reverse_array(i+mmax))=imf(fft_ind_im,bit_reverse_array(i))-imtmp
                ref(fft_ind_re,bit_reverse_array(i))=ref(fft_ind_re,bit_reverse_array(i))+retmp
                imf(fft_ind_im,bit_reverse_array(i))=imf(fft_ind_im,bit_reverse_array(i))+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    else
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp=fft_cos(m*indx+1)*ref(fft_ind_re,i+mmax)+fft_sin(m*indx+1)*imf(fft_ind_im,i+mmax)
                imtmp=-fft_sin(m*indx+1)*ref(fft_ind_re,i+mmax)+fft_cos(m*indx+1)*imf(fft_ind_im,i+mmax)
                ref(fft_ind_re,i+mmax)=ref(fft_ind_re,i)-retmp
                imf(fft_ind_im,i+mmax)=imf(fft_ind_im,i)-imtmp
                ref(fft_ind_re,i)=ref(fft_ind_re,i)+retmp
                imf(fft_ind_im,i)=imf(fft_ind_im,i)+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    endif
  end subroutine FFT_1D

  subroutine FFT_2D(ref,imf,direction)
    real(dl),dimension(:,:,:)::ref,imf
    integer(IB),intent(in)::direction
    integer(IB) mmax,istep,m,i,j,indx
    real(dl) retmp(N),imtmp(N)
    do i=1,N
       call FFT_1D(ref(:,:,i),imf(:,:,i),direction)
    enddo
    mmax=1
    indx=Nby2
    if(direction.eq.FFT_FORWARD)then
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp=fft_cos(m*indx+1)*ref(fft_ind_re,1:N,bit_reverse_array(i+mmax))-fft_sin(m*indx+1)*imf(fft_ind_im,1:N,bit_reverse_array(i+mmax))
                imtmp=fft_sin(m*indx+1)*ref(fft_ind_re,1:N,bit_reverse_array(i+mmax))+fft_cos(m*indx+1)*imf(fft_ind_im,1:N,bit_reverse_array(i+mmax))
                ref(fft_ind_re,1:N,bit_reverse_array(i+mmax))=ref(fft_ind_re,1:N,bit_reverse_array(i))-retmp
                imf(fft_ind_im,1:N,bit_reverse_array(i+mmax))=imf(fft_ind_im,1:N,bit_reverse_array(i))-imtmp
                ref(fft_ind_re,1:N,bit_reverse_array(i))=ref(fft_ind_re,1:N,bit_reverse_array(i))+retmp
                imf(fft_ind_im,1:N,bit_reverse_array(i))=imf(fft_ind_im,1:N,bit_reverse_array(i))+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    else
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp = fft_cos(m*indx+1)*ref(fft_ind_re,1:N,i+mmax) + fft_sin(m*indx+1)*imf(fft_ind_im,1:N,i+mmax)
                imtmp = -fft_sin(m*indx+1)*ref(fft_ind_re,1:N,i+mmax) + fft_cos(m*indx+1)*imf(fft_ind_im,1:N,i+mmax)
                ref(fft_ind_re,1:N,i+mmax)=ref(fft_ind_re,1:N,i)-retmp
                imf(fft_ind_im,1:N,i+mmax)=imf(fft_ind_im,1:N,i)-imtmp
                ref(fft_ind_re,1:N,i)=ref(fft_ind_re,1:N,i)+retmp
                imf(fft_ind_im,1:N,i)=imf(fft_ind_im,1:N,i)+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    endif
  end subroutine FFT_2D

  !!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine FFT_xstep(ref,imf,i,mmax,m,indx)
    integer(IB) i,mmax,m,indx
    real(dl),dimension(:,:,:,:)::ref,imf
    real(dl):: retmp(N,N),imtmp(N,N)
    retmp=fft_cos(m*indx+1)*ref(fft_ind_re,1:N,1:N,bit_reverse_array(i+mmax))-fft_sin(m*indx+1)*imf(fft_ind_im,1:N,1:N,bit_reverse_array(i+mmax))
    imtmp=fft_sin(m*indx+1)*ref(fft_ind_re,1:N,1:N,bit_reverse_array(i+mmax))+fft_cos(m*indx+1)*imf(fft_ind_im,1:N,1:N,bit_reverse_array(i+mmax))
    ref(fft_ind_re,1:N,1:N,bit_reverse_array(i+mmax))=ref(fft_ind_re,1:N,1:N,bit_reverse_array(i))-retmp
    imf(fft_ind_im,1:N,1:N,bit_reverse_array(i+mmax))=imf(fft_ind_im,1:N,1:N,bit_reverse_array(i))-imtmp
    ref(fft_ind_re,1:N,1:N,bit_reverse_array(i))=ref(fft_ind_re,1:N,1:N,bit_reverse_array(i))+retmp
    imf(fft_ind_im,1:N,1:N,bit_reverse_array(i))=imf(fft_ind_im,1:N,1:N,bit_reverse_array(i))+imtmp
  end subroutine FFT_xstep

  subroutine FFT_xstep_backward(ref,imf,i,mmax,m,indx)
    integer(IB) i,mmax,m,indx
    real(dl),dimension(:,:,:,:)::ref,imf
    real(dl):: retmp(N,N),imtmp(N,N)
    retmp=fft_cos(m*indx+1)* ref(fft_ind_re,1:N,1:N,i+mmax)+fft_sin(m*indx+1)* imf(fft_ind_im,1:N,1:N,i+mmax)
    imtmp=-fft_sin(m*indx+1)* ref(fft_ind_re,1:N,1:N,i+mmax)+fft_cos(m*indx+1)* imf(fft_ind_im,1:N,1:N,i+mmax)
    ref(fft_ind_re,1:N,1:N,i+mmax)=ref(fft_ind_re,1:N,1:N,i)-retmp
    imf(fft_ind_im,1:N,1:N,i+mmax)=imf(fft_ind_im,1:N,1:N,i)-imtmp
    ref(fft_ind_re,1:N,1:N,i)=ref(fft_ind_re,1:N,1:N,i)+retmp
    imf(fft_ind_im,1:N,1:N,i)=imf(fft_ind_im,1:N,1:N,i)+imtmp
  end subroutine FFT_xstep_backward

!!******************** massive FFT *****************************

  Subroutine CubicMassiveFFT(msize,ref,imf,direction)
    real(dl),dimension(:,:,:,:),intent(inout)::ref,imf
    integer(IB),intent(in)::direction,msize
    integer(IB) mmax,istep,m,i,j,k,indx,j1,k1
    if(.not. fft_initialized) call fft_init()
    if(size(ref,2).ne.N .or. size(ref,3).ne. n .or. size(ref,4).ne.N .or. size(ref,1) .ne. msize .or. size(imf,1).ne.msize .or. size(imf,2).ne.N .or. size(imf,3).ne. n .or. size(imf,4).ne.N ) stop "CubicMassiveFFT: wrong size of input array"
    !!FFT in x and y direction

    !$omp parallel do private(k) default(shared)
    do k=1,N
       call mfft_2D(msize,ref(:,1:N,1:N,k),imf(:,1:n,1:n,k),direction)
    enddo
    !$omp end parallel do
    mmax=1
    indx=Nby2
    !!shared memory, output is scrambled format (i,j,k)-> bit_reverse_array(i),bit_reverse_array(j),bit_reverse_array(k)
    if(direction.eq.FFT_FORWARD)then
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             !$omp parallel do
             do i=m+1,N,istep
                call mfft_xstep(msize,ref,imf,i,mmax,m,indx)
             enddo
             !$omp end parallel do
          enddo
          mmax=istep
          indx=indx/2
       enddo
    else
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             !$omp parallel do
             do i=m+1,N,istep
                call mfft_xstep_backward(msize,ref,imf,i,mmax,m,indx)
             enddo
             !$omp end parallel do
          enddo
          mmax=istep
          indx=indx/2
       enddo
    endif
    if(direction.ne.FFT_FORWARD)then
       ref(:,:,:,:) = ref(:,:,:,:)/ncube !! FFTW does not do this
       imf(:,:,:,:) = imf(:,:,:,:)/ncube
    endif
  End Subroutine CubicMassiveFFT

  subroutine mFFT_1D(msize,ref,imf,direction)
    integer(IB) msize
    real(dl),dimension(:,:)::ref,imf
    integer(IB),intent(in)::direction
    integer(IB) mmax,istep,m,i,j,indx
    real(dl) retmp(msize),imtmp(msize)
    mmax=1
    indx=Nby2
    if(direction.eq.FFT_FORWARD)then
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp=fft_cos(m*indx+1)*ref(:,bit_reverse_array(i+mmax)) - fft_sin(m*indx+1)*imf(:,bit_reverse_array(i+mmax))
                imtmp=fft_sin(m*indx+1)*ref(:,bit_reverse_array(i+mmax)) + fft_cos(m*indx+1)*imf(:,bit_reverse_array(i+mmax))
                ref(:,bit_reverse_array(i+mmax))=ref(:,bit_reverse_array(i))-retmp
                imf(:,bit_reverse_array(i+mmax))=imf(:,bit_reverse_array(i))-imtmp
                ref(:,bit_reverse_array(i))=ref(:,bit_reverse_array(i))+retmp
                imf(:,bit_reverse_array(i))=imf(:,bit_reverse_array(i))+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    else
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp=fft_cos(m*indx+1)*ref(:,i+mmax)+fft_sin(m*indx+1)*imf(:,i+mmax)
                imtmp=-fft_sin(m*indx+1)*ref(:,i+mmax)+fft_cos(m*indx+1)*imf(:,i+mmax)
                ref(:,i+mmax)=ref(:,i)-retmp
                imf(:,i+mmax)=imf(:,i)-imtmp
                ref(:,i)=ref(:,i)+retmp
                imf(:,i)=imf(:,i)+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    endif
  end subroutine MFFT_1D

  subroutine mFFT_2D(msize,ref,imf,direction)
    integer(IB):: msize
    real(dl),dimension(:,:,:)::ref,imf
    integer(IB),intent(in)::direction
    integer(IB) mmax,istep,m,i,j,indx
    real(dl) retmp(msize,N),imtmp(msize,N)
    do i=1,N
       call mFFT_1D(msize,ref(:,:,i),imf(:,:,i),direction)
    enddo

    mmax=1
    indx=Nby2
    if(direction.eq.FFT_FORWARD)then
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp=fft_cos(m*indx+1)*ref(:,1:N,bit_reverse_array(i+mmax))-fft_sin(m*indx+1)*imf(:,1:N,bit_reverse_array(i+mmax))
                imtmp=fft_sin(m*indx+1)*ref(:,1:N,bit_reverse_array(i+mmax))+fft_cos(m*indx+1)*imf(:,1:N,bit_reverse_array(i+mmax))
                ref(:,1:N,bit_reverse_array(i+mmax))=ref(:,1:N,bit_reverse_array(i))-retmp
                imf(:,1:N,bit_reverse_array(i+mmax))=imf(:,1:N,bit_reverse_array(i))-imtmp
                ref(:,1:N,bit_reverse_array(i))=ref(:,1:N,bit_reverse_array(i))+retmp
                imf(:,1:N,bit_reverse_array(i))=imf(:,1:N,bit_reverse_array(i))+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    else
       do while(N.gt.mmax)
          istep=2*mmax
          do m=0,mmax-1
             do i=m+1,N,istep
                retmp = fft_cos(m*indx+1)*ref(:,1:N,i+mmax) + fft_sin(m*indx+1)*imf(:,1:N,i+mmax)
                imtmp = -fft_sin(m*indx+1)*ref(:,1:N,i+mmax) + fft_cos(m*indx+1)*imf(:,1:N,i+mmax)
                ref(:,1:N,i+mmax)=ref(:,1:N,i)-retmp
                imf(:,1:N,i+mmax)=imf(:,1:N,i)-imtmp
                ref(:,1:N,i)=ref(:,1:N,i)+retmp
                imf(:,1:N,i)=imf(:,1:N,i)+imtmp
             enddo
          enddo
          mmax=istep
          indx=indx/2
       enddo
    endif
  end subroutine MFFT_2D

  !!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  subroutine mfft_xstep(msize,ref,imf,i,mmax,m,indx)
    integer(IB) msize
    integer(IB) i,mmax,m,indx
    real(dl),dimension(:,:,:,:)::ref,imf
    real(dl):: retmp(msize,N,N),imtmp(msize,N,N)
    retmp=fft_cos(m*indx+1)*ref(:,1:N,1:N,bit_reverse_array(i+mmax))-fft_sin(m*indx+1)*imf(:,1:N,1:N,bit_reverse_array(i+mmax))
    imtmp=fft_sin(m*indx+1)*ref(:,1:N,1:N,bit_reverse_array(i+mmax))+fft_cos(m*indx+1)*imf(:,1:N,1:N,bit_reverse_array(i+mmax))
    ref(:,1:N,1:N,bit_reverse_array(i+mmax))=ref(:,1:N,1:N,bit_reverse_array(i))-retmp
    imf(:,1:N,1:N,bit_reverse_array(i+mmax))=imf(:,1:N,1:N,bit_reverse_array(i))-imtmp
    ref(:,1:N,1:N,bit_reverse_array(i))=ref(:,1:N,1:N,bit_reverse_array(i))+retmp
    imf(:,1:N,1:N,bit_reverse_array(i))=imf(:,1:N,1:N,bit_reverse_array(i))+imtmp
  end subroutine mfft_xstep

  subroutine mfft_xstep_backward(msize,ref,imf,i,mmax,m,indx)
    integer(IB) msize
    integer(IB) i,mmax,m,indx
    real(dl),dimension(:,:,:,:)::ref,imf
    real(dl):: retmp(msize,N,N),imtmp(msize,N,N)
    retmp=fft_cos(m*indx+1)* ref(:,1:N,1:N,i+mmax)+fft_sin(m*indx+1)* imf(:,1:N,1:N,i+mmax)
    imtmp=-fft_sin(m*indx+1)* ref(:,1:N,1:N,i+mmax)+fft_cos(m*indx+1)* imf(:,1:N,1:N,i+mmax)
    ref(:,1:N,1:N,i+mmax)=ref(:,1:N,1:N,i)-retmp
    imf(:,1:N,1:N,i+mmax)=imf(:,1:N,1:N,i)-imtmp
    ref(:,1:N,1:N,i)=ref(:,1:N,1:N,i)+retmp
    imf(:,1:N,1:N,i)=imf(:,1:N,1:N,i)+imtmp
  end subroutine Mfft_xstep_backward

!!the input h and p should be in Fourier space,
!!this subroutine removes the scalar and vector component in h and p
!!and it gets the power spectrum of TT part in h and p
!!output_option can be: UNCHANGED (keep h and p unchanged), OUTPUT_TT (remove the scalar and vector part in h and p), OUTPUT_ADAPTIVE (perform a coordinate transformation x^i -> x^i - zeta^i; change h, and write zeta^i into p; In this case the original data stored in p is lost. You have to reload p from checkpoint file).
  subroutine fft_get_TT_power(h,p,hpk,ppk,output_option)
    integer(IB)::output_option
    real(dl) h(6,n,n,n),p(6,n,n,n),hpk(fft_numk),ppk(fft_numk),mult(fft_numk)
    integer(IB) i,j,k,i1,j1,k1,i2,j2,k2
    hpk = 0._dl
    ppk = 0._dl
    mult = 0._dl
#define KSPACE_OPERATION add_TT_power(i,j,k,i1,j1,k1,i2,j2,k2,hpk,ppk,mult)
#define REDUCTION_VARS hpk,ppk,mult
#include "headfiles/fft_scan_kspace.h"
    do i=1,fft_numk
       if(mult(i).gt.0)then
          hpk(i) = hpk(i)/mult(i)
          ppk(i) = ppk(i)/mult(i)
       endif
    enddo
    contains
      subroutine add_TT_power(i,j,k,i1,j1,k1,i2,j2,k2,hpk,ppk,mult)
        integer(IB) i,j,k,i1,j1,k1,i2,j2,k2,loc
        real(dl) hpk(fft_numk),ppk(fft_numk),mult(fft_numk)
        complex(dlc) two_hk(6), two_pk(6),lambda(2),A(3),Ap(3),trh1(3),trh2(3)
        real(dl) ksq, didj(6)
        ksq = fft_effk2dx2(i)+fft_effk2dx2(j)+fft_effk2dx2(k)
        if(ksq.le.(1.e-8/ncube))then
           if(output_option .eq. OUTPUT_TT)then
              h(:,i1,j1,k1) = 0.
              p(:,i1,j1,k1)=0.
              if(i2.gt.0)then
                 h(:,i2,j2,k2) = 0.
                 p(:,i2,j2,k2)=0.
              endif
           elseif(output_option .eq. OUTPUT_ADAPTIVE)then
              p(:,i1,j1,k1)=0.
              if(i2.gt.0) p(:,i2,j2,k2)=0.
           endif
           return
        endif
        loc = nint(fft_absk_ind(i,j,k))
        if(loc.le.0 .and. output_option.eq. UNCHANGED) return
        if(i2.gt.0)then
           two_hk = cmplx(h(:,i1,j1,k1)+h(:,i2,j2,k2),p(:,i1,j1,k1)-p(:,i2,j2,k2))
           two_pk = cmplx(p(:,i1,j1,k1)+p(:,i2,j2,k2), -h(:,i1,j1,k1)+h(:,i2,j2,k2))
           if(loc.gt.0)mult(loc) = mult(loc)+4.
        else
           two_hk = h(:,i1,j1,k1)*const_sqrt2
           two_pk = p(:,i1,j1,k1)*const_sqrt2 !!here I am actually calculating sqrt(2)*h_k and sqrt(2)*p_k, the extra factor sqrt(2)**2 will be cancelled by the weight
           if(loc.gt.0)mult(loc) = mult(loc) + 2.
        endif
        !!remove the trace
        trh1 = sum(two_hk(1:3))/3.
        two_hk(1:3) = two_hk(1:3) - trh1
        two_pk(1:3) = two_pk(1:3) - sum(two_pk(1:3))/3.
        !!remove the other scalar part
        didj= (/ fft_effk2dx2(i), fft_effk2dx2(j), fft_effk2dx2(k), &
             fft_effkdx(j)*fft_effkdx(k), fft_effkdx(i)*fft_effkdx(k), fft_effkdx(i)* fft_effkdx(j) /)
        lambda = 1.5/ksq**2 * (/ sum(didj(1:3)*two_hk(1:3))+2.*sum(didj(4:6)*two_hk(4:6)), sum(didj(1:3)*two_pk(1:3))+2.*sum(didj(4:6)*two_pk(4:6)) /)
        two_hk = two_hk - lambda(1) * didj
        two_pk = two_pk - lambda(2) * didj
        trh2 =  sum(two_hk(1:3))/3.
        two_hk(1:3) = two_hk(1:3) - trh2
        two_pk(1:3) = two_pk(1:3) - sum(two_pk(1:3))/3.

        !!remove the vector part
        A(1) = (fft_effkdx(i) * two_hk(1) + fft_effkdx(j) * two_hk(6) + fft_effkdx(k) * two_hk(5))/ksq
        A(2) = (fft_effkdx(i) * two_hk(6) + fft_effkdx(j) * two_hk(2) + fft_effkdx(k) * two_hk(4))/ksq
        A(3) = (fft_effkdx(i) * two_hk(5) + fft_effkdx(j) * two_hk(4) + fft_effkdx(k) * two_hk(3))/ksq
        two_hk = two_hk - (/ 2.*fft_effkdx(i) * A(1), 2.*fft_effkdx(j) * A(2), 2.*fft_effkdx(k) *A(3), &
             fft_effkdx(j)*A(3) + fft_effkdx(k)*A(2), fft_effkdx(i) * A(3)+ fft_effkdx(k)*A(1) , &
             fft_effkdx(i)*A(2) + fft_effkdx(j)*A(1) /)

        Ap(1) = (fft_effkdx(i) * two_pk(1) + fft_effkdx(j) * two_pk(6) + fft_effkdx(k) * two_pk(5))/ksq
        Ap(2) = (fft_effkdx(i) * two_pk(6) + fft_effkdx(j) * two_pk(2) + fft_effkdx(k) * two_pk(4))/ksq
        Ap(3) = (fft_effkdx(i) * two_pk(5) + fft_effkdx(j) * two_pk(4) + fft_effkdx(k) * two_pk(3))/ksq
        two_pk = two_pk - (/ 2.*fft_effkdx(i) * Ap(1), 2.*fft_effkdx(j) * Ap(2), 2.*fft_effkdx(k) *Ap(3), &
             fft_effkdx(j)*Ap(3) + fft_effkdx(k)*Ap(2), fft_effkdx(i) * Ap(3)+fft_effkdx(k)*Ap(1) , &
             fft_effkdx(i)*Ap(2) + fft_effkdx(j)*Ap(1) /)

        !! now add the TT power
        if(loc.gt.0)then
           hpk(loc) = hpk(loc) + sum(two_hk(1:3)*conjg(two_hk(1:3))) + 2.* sum(two_hk(4:6)*conjg(two_hk(4:6)))
           ppk(loc) = ppk(loc) + sum(two_pk(1:3)*conjg(two_pk(1:3))) + 2.* sum(two_pk(4:6)*conjg(two_pk(4:6)))
        endif
        select case(output_option)
        case(UNCHANGED)
           return
        case(OUTPUT_TT)
           if(i2.gt.0)then
              h(:,i1,j1,k1) = (real(two_hk)-aimag(two_pk))/2.
              p(:,i1,j1,k1) = (aimag(two_hk)+real(two_pk))/2.
              h(:,i2,j2,k2) = (real(two_hk)+aimag(two_pk))/2.
              p(:,i2,j2,k2) = (-aimag(two_hk)+real(two_pk))/2.
           else
              h(:,i1,j1,k1) = (real(two_hk)-aimag(two_pk))/const_sqrt2
              p(:,i1,j1,k1) = (aimag(two_hk)+real(two_pk))/const_sqrt2
           endif
        case(OUTPUT_ADAPTIVE)
           two_hk(1:3) = two_hk(1:3)+ trh1 + trh2 !!restore the trace (physical mode)
           two_pk (1:3) = (A + (/ fft_effkdx(i), fft_effkdx(j), fft_effkdx(k) /) * lambda(1))/cmplx(0._dl,1._dl)
           if(i2.gt.0)then
              h(:,i1,j1,k1) = (real(two_hk)-aimag(two_pk))/2.
              p(:,i1,j1,k1) = (aimag(two_hk)+real(two_pk))/2.
              h(:,i2,j2,k2) = (real(two_hk)+aimag(two_pk))/2.
              p(:,i2,j2,k2) = (-aimag(two_hk)+real(two_pk))/2.
           else
              h(:,i1,j1,k1) = (real(two_hk)-aimag(two_pk))/const_sqrt2
              p(:,i1,j1,k1) = (aimag(two_hk)+real(two_pk))/const_sqrt2
           endif
        case default
           stop "unknown output option in fft_remove_scalar_vector"
        end select
      end subroutine add_TT_power
    end subroutine fft_get_TT_power

end module LatticeFFT


module sim_tensor_mod
use output_mod
implicit none

private ! Private by default
public :: dPdF_calc, P9_2_sigma6
public :: scont22, scont42, dcont44, dcont42
public :: openprod, openprod_a, openprod_b
public :: invert_v9, determinant_v9, transpose_v9
public :: voigt9, voigt4, matrix, matrix4
public :: stran_v9, stress_v9, stran_v6, stress_v6
public :: v9x9, v6x6, minsym9x9, m1_m3_mul

!Tensor modulue convention used for index notation
integer, parameter, dimension(3)  :: norm = (/1,2,3/)         !Normal components
integer, parameter, dimension(3)  :: shr1 = (/4,7,5/)         !Upper shear components
integer, parameter, dimension(3)  :: shr2 = (/8,6,9/)         !Lower shear components
integer, parameter, dimension(6)  :: first= (/1,2,3,4,7,5/)   !Normal + upper shear components
integer, parameter, dimension(9)  :: ind1 = (/1, 2, 3, 1, 2, 3, 1, 2, 3/)
integer, parameter, dimension(9)  :: ind2 = (/1, 2, 3, 2, 3, 1, 3, 1, 2/)

!Standard tensors
double precision, parameter, dimension(9)   :: I2 = (/1.d0, 1.d0, 1.d0, 0.d0, 0.d0, 0.d0, 0.d0, 0.d0, 0.d0/)

    contains

!! ==================== Tensor functions ====================

!Given ddsdde, calculate P9 and dPdF
subroutine dPdF_calc(P9, dPdF, stress, ddsdde, F9)
implicit none
    double precision, intent(in)    :: stress(6), ddsdde(6,6), F9(9)
    double precision, intent(out)   :: P9(9), dPdF(9,9)
    double precision                :: Finv(9), Finvt(9), detF, tmp9(9), tmp99a(9,9), tmp99b(9,9)

    Finv    = invert_v9(F9)
    Finvt   = transpose_v9(Finv)
    detF    = determinant_v9(F9)
    tmp9    = stress_v9(stress) ! 9-component sigma
    P9      = detF*scont22(tmp9, Finvt)
    !P9      = detF*scont22(stress_v9(stress), Finvt)
    tmp99a  = openprod_a(I2,Finv)
    tmp99b  = v9x9(ddsdde)
    tmp99a  = dcont44(tmp99a, tmp99b)
    tmp99b  = openprod_a(I2, Finvt)
    dPdF    = detF*dcont44(tmp99a, tmp99b) - openprod_b(P9, Finv)
    !dPdF    = detF*dcont44(dcont44(openprod_a(I2,Finv), v9x9(ddsdde)), openprod_a(I2, Finvt)) - openprod_b(P9, Finv)
end subroutine dPdF_calc

!Given P9 and F9, calculate sigma6
function P9_2_sigma6(P9, F9) result(sigma6)
implicit none
    double precision    :: P9(9), F9(9), sigma6(6)
    double precision    :: tmp9(9)
    tmp9 = transpose_v9(F9)     ! F transpose
    tmp9 = scont22(P9, tmp9)    ! tau
    sigma6 = stress_v6(tmp9)/determinant_v9(F9)
end function

!Single contraction between 2 2nd order 9-voigt tensors
function scont22(a2, b2)
implicit none
    double precision :: a2(9), b2(9), scont22(9)
    double precision :: am(3,3), bm(3,3)
    am = matrix(a2)
    bm = matrix(b2)
    am = matmul(am,bm)
    scont22 = voigt9(am)
    !scont22 = voigt9(matmul(matrix(a2), matrix(b2)))
end function scont22

!Single contraction between a 4th order tensor [9x9] (last index) and 2nd order tensor [9] (first index)
function scont42(a4, b2)
implicit none
    double precision :: a4(9,9), b2(9), scont42(9,9)
    double precision :: aM(3,3,3,3), bM(3,3), scontM(3,3,3,3)
    integer :: k1,k2,k3,k4

    aM = matrix4(a4)
    bM = matrix(b2)
    do k1=1,3
        do k2=1,3
            do k3=1,3
                do k4=1,3
                    scontM(k1,k2,k3,k4) = sum(aM(k1,k2,k3,:)*bM(:,k4))
                enddo
            enddo
        enddo
    enddo
    scont42 = voigt4(scontM)
end function

!Double contraction between two 4th order tensors
function dcont44(a4,b4) result(c4)
implicit none
    double precision :: a4(9,9), b4(9,9), c4(9,9)
    c4 = matmul(a4,b4)
end function

!Double contraction between a 4th and a 2nd order tensor
function dcont42(a4,b2) result(c2)
implicit none
    double precision :: a4(9,9), b2(9), c2(9)
    c2 = matmul(a4,b2)
end function

!Open product between 2 2nd order tensors [9]
function openprod(a2,b2) result(ab)
implicit none
    double precision :: a2(9), b2(9), ab(9,9)
    integer :: k1, k2
    ! This could be replaced by matmul?
    do k1=1,9
        do k2 = 1,9
            ab(k1,k2) = a2(k1)*b2(k2)
        enddo
    enddo
end function openprod

!Open product "above" between 2 2nd order tensors
function openprod_a(b,c) result(a)
implicit none
    double precision :: b(9), c(9), a(9,9)
    ! Copied from tensor module, op_a_V9
    ! Derived from matlab program derive_expr
    a(1,1)=b(1)*c(1); a(1,2)=b(4)*c(4); a(1,3)=b(7)*c(7);
    a(1,4)=b(1)*c(4); a(1,5)=b(4)*c(7); a(1,6)=b(7)*c(1);
    a(1,7)=b(1)*c(7); a(1,8)=b(4)*c(1); a(1,9)=b(7)*c(4);
    a(2,1)=b(8)*c(8); a(2,2)=b(2)*c(2); a(2,3)=b(5)*c(5);
    a(2,4)=b(8)*c(2); a(2,5)=b(2)*c(5); a(2,6)=b(5)*c(8);
    a(2,7)=b(8)*c(5); a(2,8)=b(2)*c(8); a(2,9)=b(5)*c(2);
    a(3,1)=b(6)*c(6); a(3,2)=b(9)*c(9); a(3,3)=b(3)*c(3);
    a(3,4)=b(6)*c(9); a(3,5)=b(9)*c(3); a(3,6)=b(3)*c(6);
    a(3,7)=b(6)*c(3); a(3,8)=b(9)*c(6); a(3,9)=b(3)*c(9);
    a(4,1)=b(1)*c(8); a(4,2)=b(4)*c(2); a(4,3)=b(7)*c(5);
    a(4,4)=b(1)*c(2); a(4,5)=b(4)*c(5); a(4,6)=b(7)*c(8);
    a(4,7)=b(1)*c(5); a(4,8)=b(4)*c(8); a(4,9)=b(7)*c(2);
    a(5,1)=b(8)*c(6); a(5,2)=b(2)*c(9); a(5,3)=b(5)*c(3);
    a(5,4)=b(8)*c(9); a(5,5)=b(2)*c(3); a(5,6)=b(5)*c(6);
    a(5,7)=b(8)*c(3); a(5,8)=b(2)*c(6); a(5,9)=b(5)*c(9);
    a(6,1)=b(6)*c(1); a(6,2)=b(9)*c(4); a(6,3)=b(3)*c(7);
    a(6,4)=b(6)*c(4); a(6,5)=b(9)*c(7); a(6,6)=b(3)*c(1);
    a(6,7)=b(6)*c(7); a(6,8)=b(9)*c(1); a(6,9)=b(3)*c(4);
    a(7,1)=b(1)*c(6); a(7,2)=b(4)*c(9); a(7,3)=b(7)*c(3);
    a(7,4)=b(1)*c(9); a(7,5)=b(4)*c(3); a(7,6)=b(7)*c(6);
    a(7,7)=b(1)*c(3); a(7,8)=b(4)*c(6); a(7,9)=b(7)*c(9);
    a(8,1)=b(8)*c(1); a(8,2)=b(2)*c(4); a(8,3)=b(5)*c(7);
    a(8,4)=b(8)*c(4); a(8,5)=b(2)*c(7); a(8,6)=b(5)*c(1);
    a(8,7)=b(8)*c(7); a(8,8)=b(2)*c(1); a(8,9)=b(5)*c(4);
    a(9,1)=b(6)*c(8); a(9,2)=b(9)*c(2); a(9,3)=b(3)*c(5);
    a(9,4)=b(6)*c(2); a(9,5)=b(9)*c(5); a(9,6)=b(3)*c(8);
    a(9,7)=b(6)*c(5); a(9,8)=b(9)*c(8); a(9,9)=b(3)*c(2);
end function

!Open product "below" between 2 2nd order tensors
function openprod_b(b,c) result(a)
implicit none
    double precision :: b(9), c(9), a(9,9)
    ! Copied from tensor module, op_b_V9
    ! Derived from matlab program derive_expr
    a(1,1)=b(1)*c(1);a(1,2)=b(4)*c(4);a(1,3)=b(7)*c(7);
    a(1,4)=b(4)*c(1);a(1,5)=b(7)*c(4);a(1,6)=b(1)*c(7);
    a(1,7)=b(7)*c(1);a(1,8)=b(1)*c(4);a(1,9)=b(4)*c(7);
    a(2,1)=b(8)*c(8);a(2,2)=b(2)*c(2);a(2,3)=b(5)*c(5);
    a(2,4)=b(2)*c(8);a(2,5)=b(5)*c(2);a(2,6)=b(8)*c(5);
    a(2,7)=b(5)*c(8);a(2,8)=b(8)*c(2);a(2,9)=b(2)*c(5);
    a(3,1)=b(6)*c(6);a(3,2)=b(9)*c(9);a(3,3)=b(3)*c(3);
    a(3,4)=b(9)*c(6);a(3,5)=b(3)*c(9);a(3,6)=b(6)*c(3);
    a(3,7)=b(3)*c(6);a(3,8)=b(6)*c(9);a(3,9)=b(9)*c(3);
    a(4,1)=b(1)*c(8);a(4,2)=b(4)*c(2);a(4,3)=b(7)*c(5);
    a(4,4)=b(4)*c(8);a(4,5)=b(7)*c(2);a(4,6)=b(1)*c(5);
    a(4,7)=b(7)*c(8);a(4,8)=b(1)*c(2);a(4,9)=b(4)*c(5);
    a(5,1)=b(8)*c(6);a(5,2)=b(2)*c(9);a(5,3)=b(5)*c(3);
    a(5,4)=b(2)*c(6);a(5,5)=b(5)*c(9);a(5,6)=b(8)*c(3);
    a(5,7)=b(5)*c(6);a(5,8)=b(8)*c(9);a(5,9)=b(2)*c(3);
    a(6,1)=b(6)*c(1);a(6,2)=b(9)*c(4);a(6,3)=b(3)*c(7);
    a(6,4)=b(9)*c(1);a(6,5)=b(3)*c(4);a(6,6)=b(6)*c(7);
    a(6,7)=b(3)*c(1);a(6,8)=b(6)*c(4);a(6,9)=b(9)*c(7);
    a(7,1)=b(1)*c(6);a(7,2)=b(4)*c(9);a(7,3)=b(7)*c(3);
    a(7,4)=b(4)*c(6);a(7,5)=b(7)*c(9);a(7,6)=b(1)*c(3);
    a(7,7)=b(7)*c(6);a(7,8)=b(1)*c(9);a(7,9)=b(4)*c(3);
    a(8,1)=b(8)*c(1);a(8,2)=b(2)*c(4);a(8,3)=b(5)*c(7);
    a(8,4)=b(2)*c(1);a(8,5)=b(5)*c(4);a(8,6)=b(8)*c(7);
    a(8,7)=b(5)*c(1);a(8,8)=b(8)*c(4);a(8,9)=b(2)*c(7);
    a(9,1)=b(6)*c(8);a(9,2)=b(9)*c(2);a(9,3)=b(3)*c(5);
    a(9,4)=b(9)*c(8);a(9,5)=b(3)*c(2);a(9,6)=b(6)*c(5);
    a(9,7)=b(3)*c(8);a(9,8)=b(6)*c(2);a(9,9)=b(9)*c(5);
end function

!Invert a 9 component voigt 2nd order tensor
function invert_v9(A) result (inv_A)
implicit none
    double precision :: A(9), inv_A(9),det_A
    !Code mostly copied from Tensor module, inv_v9
    det_A = determinant_v9(A)

    if (abs(det_A)<1.0d-25) then
        call write_output('Matrix close to being singular in inv_v9', 'warning', 'atp')
        det_A=1.d-15
    endif

    inv_A(1)=(-A(5)*A(9)+A(2)*A(3))/det_A
    inv_A(4)=( A(7)*A(9)-A(4)*A(3))/det_A
    inv_A(7)=( A(5)*A(4)-A(2)*A(7))/det_A

    inv_A(8)=( A(5)*A(6)-A(8)*A(3))/det_A
    inv_A(2)=(-A(7)*A(6)+A(1)*A(3))/det_A
    inv_A(5)=(-A(5)*A(1)+A(8)*A(7))/det_A

    inv_A(6)=(-A(2)*A(6)+A(8)*A(9))/det_A
    inv_A(9)=( A(4)*A(6)-A(1)*A(9))/det_A
    inv_A(3)=( A(2)*A(1)-A(8)*A(4))/det_A

end function invert_v9

!Calculate determinant of 9-component voigt 2nd order tensor
function determinant_v9(A) result (detA)
implicit none
    double precision :: A(9), detA
    detA=-A(7)*A(2)*A(6)+A(4)*A(5)*A(6)+  &
          A(7)*A(8)*A(9)-A(1)*A(5)*A(9)-  &
          A(4)*A(8)*A(3)+A(1)*A(2)*A(3)
end function determinant_v9

!Take transpose of 9-component voigt 2nd order tensor
function transpose_v9(v9) result (v9t)
implicit none
    double precision :: v9(9), v9t(9)
    v9t(norm) = v9(norm)
    v9t(shr1) = v9(shr2)
    v9t(shr2) = v9(shr1)
end function transpose_v9

!! ==================== Conversion functions ====================
!Convert 3x3 matrix to 9 voigt
function voigt9(matrix)
implicit none
    double precision :: voigt9(9), matrix(3,3)
    integer :: k1
    do k1=1,9
        voigt9(k1) = matrix(ind1(k1), ind2(k1))
    enddo

end function voigt9

!Convert 3x3x3x3 matrix to 9x9 voigt (4th order tensor)
function voigt4(matrix)
implicit none
    double precision :: voigt4(9,9), matrix(3,3,3,3)
    integer          :: k1, k2

    do k1 = 1,9
        do k2 = 1,9
            voigt4(k1,k2) = matrix(ind1(k1),ind2(k1),ind1(k2),ind2(k2))
        enddo
    enddo
end function voigt4

!Convert 9 voigt to 3x3 matrix
function matrix(voigt9)
implicit none
    double precision :: matrix(3,3), voigt9(9)
    integer          :: k1
    do k1 = 1,9
        matrix(ind1(k1), ind2(k1)) = voigt9(k1)
    enddo

end function matrix

!Convert 9x9 voigt to 3x3x3x3 matrix
function matrix4(voigt4)
implicit none
    double precision :: voigt4(9,9), matrix4(3,3,3,3)
    integer          :: k1, k2

    do k1 = 1,9
        do k2 = 1,9
            matrix4(ind1(k1),ind2(k1),ind1(k2),ind2(k2)) = voigt4(k1,k2)
        enddo
    enddo

end function matrix4

!Convert strain in 6 voigt (Abaqus convention) to strain in 9 voigt (Tensor module convention)
function stran_v9(v6) result(v9)
implicit none
    double precision :: v9(9), v6(6)
    v9(norm) = v6(1:3)
    v9(shr1) = v6(4:6)/2.d0
    v9(shr2) = v6(4:6)/2.d0
end function

!Convert strain in 9 voigt (Tensor module convention) to strain in 6 voigt (Abaqus convention)
function stran_v6(v9) result(v6)
implicit none
    double precision :: v9(9), v6(6)
    v6(1:3) = v9(norm)
    v6(4:6) = v9(shr1)+v9(shr2)
end function

!Convert stress in 6 voigt (Abaqus convention) to stress in 9 voigt (Tensor module convention)
function stress_v9(v6) result(v9)
implicit none
    double precision :: v9(9), v6(6)
    v9(first) = v6
    v9(shr2)  = v6(4:6)
end function

!Convert stress in 9 voigt (Tensor module convention) to stress in 6 voigt (Abaqus convention)
function stress_v6(v9) result(v6)
implicit none
    double precision :: v6(6), v9(9)
    v6(1:3) = v9(norm)
    v6(4:6) = (v9(shr1) + v9(shr2))/2.d0
end function

!Convert 6x6 voigt to 9x9 voigt (Abaqus to Tensor module index convention)
!Assume dsde with double shear components for e6
function v9x9(v6) result(v9)
implicit none
    double precision v9(9,9), v6(6,6)

    v9(norm,norm) = v6(1:3, 1:3)
    v9(shr1,norm) = v6(4:6, 1:3)
    v9(shr2,norm) = v6(4:6, 1:3)

    v9(norm,shr1) = v6(1:3, 4:6)
    v9(shr1,shr1) = v6(4:6, 4:6)
    v9(shr2,shr1) = v6(4:6, 4:6)

    v9(norm,shr2) = v6(1:3, 4:6)
    v9(shr1,shr2) = v6(4:6, 4:6)
    v9(shr2,shr2) = v6(4:6, 4:6)

end function

!Convert 9x9 voigt to 6x6 voigt (Tensor module to abaqus index convention)
!Assume dsde with double shear components for e6
function v6x6(v9) result(v6)
implicit none
    double precision v6(6,6), v9(9,9)
    v9 = minsym9x9(v9)
    v6 = v9(first,first)
end function v6x6

!Make a 9x9 voigt minor symmetric
function minsym9x9(b) result (a)
implicit none
    double precision, intent(in) :: b(9,9)
    double precision:: a(9,9)
    a = b

    a(:, shr1) = (a(:, shr1) + a(:, shr2))/2.d0  !Symmetrize columns
    a(:, shr2) = a(:, shr1)

    a(shr1, :) = (a(shr1, :) + a(shr2, :))/2.d0  !Symmetrize rows
    a(shr2, :) = a(shr1,:)

end function

!! ==================== matrix functions ====================
function m1_m3_mul(m1,m3) result(mout)
implicit none
    double precision :: m1(:), m3(:,:,:)
    double precision :: mout(size(m3,dim=2), size(m3,dim=3))
    integer          :: k1, k2
    do k1=1,size(m3,dim=2)
        do k2=1,size(m3,dim=3)
            mout(k1,k2) = sum(m1*m3(:,k1,k2))
        enddo
    enddo
end function m1_m3_mul

end module


MODULE m_bravaissymm
  use m_juDFT
  !********************************************************************
  !     determines the point group of the bravais lattice given the
  !     lattice vectors. the idea is to determine all the lattice
  !     vectors that have the same length as a_{1,2,3}, and then use
  !     these to determine the possible rotation matrices.
  !     these rotation matrices are in lattice coordinates.    mw 12-99
  !********************************************************************
CONTAINS
  SUBROUTINE bravais_symm(cell,nops,mrot)

    USE m_types_cell
    USE m_constants

    IMPLICIT NONE

    !==> Arguments
    TYPE(t_cell),INTENT(in) :: cell
    INTEGER, INTENT(OUT) :: nops, mrot(:,:,:)    ! point group operations

    !==> Locals
    REAL    amet(3,3),b1,b2,b3,d1,d2,d3,dmax,dt
    INTEGER i,k,k1,k2,k3,m1,m2,m3,n1,n2,n3
    INTEGER irot(3,3)

    INTEGER,PARAMETER::neig12=12! max. number of lattice vectors with same length
    ! (max occurs for close-packed fcc: 12)
    INTEGER lv1(3,neig12),lv2(3,neig12),lv3(3,neig12)

    REAL, PARAMETER :: eps=1.0e-7

    !---> distances for the lattice vectors
    d1 = cell%aamat(1,1)
    d2 = cell%aamat(2,2)
    d3 = cell%aamat(3,3)
    b1 = ( cell%bmat(1,1) )**2 + ( cell%bmat(1,2) )**2 + ( cell%bmat(1,3) )**2
    b2 = ( cell%bmat(2,1) )**2 + ( cell%bmat(2,2) )**2 + ( cell%bmat(2,3) )**2
    b3 = ( cell%bmat(3,1) )**2 + ( cell%bmat(3,2) )**2 + ( cell%bmat(3,3) )**2

    !---> determine the cutoffs along each direction a_i:
    dmax = max( d1,d2,d3)

    m1 = nint( dmax * b1 )
    m2 = nint( dmax * b2 )
    m3 = nint( dmax * b3 )

    !Hmm, do not really understand the code below, but IMHO these are the maximal values of entries in mrot...
    m1=1
    m2=1
    m3=1

    !---->loop over all possible lattice vectors to find those with the
    !---->length, i.e., ones that could be rotations
    n1 = 1
    n2 = 1
    n3 = 1

    lv1(1:3,1) = (/ 1,0,0 /)
    lv2(1:3,1) = (/ 0,1,0 /)
    lv3(1:3,1) = (/ 0,0,1 /)

    DO k3=-m3,m3
       DO k2=-m2,m2
          DO k1=-m1,m1

             dt = distance2(k1,k2,k3)

             !---->    check if the same length
             IF ( abs( dt - d1 ) < eps ) THEN
                IF (.not.( k1==1 .and. k2==0 .and. k3==0 ) ) THEN
                   n1 = n1+1
                   IF(n1>neig12)  CALL juDFT_error("n1>neig12", calledby ="bravais_symm")
                   lv1(1,n1) = k1
                   lv1(2,n1) = k2
                   lv1(3,n1) = k3
                ENDIF
             ENDIF

             IF ( abs( dt - d2 ) < eps ) THEN
                IF (.not.( k1==0 .and. k2==1 .and. k3==0 ) ) THEN
                   n2 = n2+1
                   IF(n2>neig12)  CALL juDFT_error("n2>neig12",calledby="bravais_symm")
                   lv2(1,n2) = k1
                   lv2(2,n2) = k2
                   lv2(3,n2) = k3
                ENDIF
             ENDIF

             IF ( abs( dt - d3 ) < eps ) THEN
                IF (.not.( k1==0 .and. k2==0 .and. k3==1 ) ) THEN
                   n3 = n3+1
                   IF(n3>neig12)  CALL juDFT_error("n3>neig12",calledby="bravais_symm")
                   lv3(1,n3) = k1
                   lv3(2,n3) = k2
                   lv3(3,n3) = k3
                ENDIF
             ENDIF

          ENDDO
       ENDDO
    ENDDO

    !---> the possible rotation matrices are given by the matrix of
    !---> column vectors of lv_{1,2,3}
    nops = 0
    DO k3 = 1,n3
       DO k2 = 1,n2
          DO k1 = 1,n1

             !--->          check whether determinant is +/-1 (needs to be for rotation)
             IF ( abs(mdet(k1,k2,k3)) .NE. 1 ) CYCLE

             !--->          check whether this maintains lengths correctly
             !--->          if M is the metric, then must have R^T M R = M
             irot = reshape( (/ lv1(:,k1),lv2(:,k2),lv3(:,k3) /) , (/ 3,3 /) )
             IF ( any( abs(matmul( transpose(irot), matmul(cell%aamat,irot) ) - cell%aamat) > eps ) ) CYCLE

             nops = nops + 1
             IF ( nops > SIZE(mrot,3) )  CALL juDFT_error("nop > size(mrot)", calledby="bravais_symm")
             mrot(:,:,nops) = irot

          ENDDO
       ENDDO
    ENDDO

    WRITE (oUnit,'(//," Point group of the Bravais lattice has ",i2," operations")') nops

    RETURN

  CONTAINS   ! INTERNAL routines

    REAL FUNCTION distance2(l1,l2,l3)
      !*********************************************************************
      !     calculates the magnitude square for a vector (l1,l2,l3) given in
      !     lattice units
      !*********************************************************************
      IMPLICIT NONE

      INTEGER, INTENT(IN) :: l1,l2,l3

      distance2 = l1*(l1*cell%aamat(1,1) + 2*l2*cell%aamat(2,1)) + l2*(l2*cell%aamat(2,2) + 2*l3*cell%aamat(3,2)) + l3*(l3*cell%aamat(3,3) + 2*l1*cell%aamat(1,3))

      RETURN
    END FUNCTION distance2

    INTEGER FUNCTION mdet(k1,k2,k3)
      !*********************************************************************
      !     determines the determinant for possible rotation matrix
      !     ( lv1(:,k1) ; lv2(:,k2) ; lv3(:,k3) )
      !*********************************************************************
      IMPLICIT NONE

      INTEGER, INTENT(IN) :: k1,k2,k3

      mdet = lv1(1,k1)*( lv2(2,k2)*lv3(3,k3) - lv2(3,k2)*lv3(2,k3) ) + lv1(2,k1)*( lv2(3,k2)*lv3(1,k3) - lv2(1,k2)*lv3(3,k3) ) + lv1(3,k1)*( lv2(1,k2)*lv3(2,k3) - lv2(2,k2)*lv3(1,k3) )

      RETURN
    END FUNCTION mdet

  END SUBROUTINE bravais_symm
END MODULE m_bravaissymm


      function angler(delx,dely)
C     function      angler    01/06/75
      rd=180./3.141593
      if(delx) 1,2,3
    3 z=abs(dely/delx)
      if(dely.ge.0.)goto 5
      th=360.-atan(z)*rd
      go to 8
    5 th=atan(z)*rd
      go to 8
    2 if(dely) 6,8,7
    6 th=270.
      go to 8
    7 th=90.
      go to 8
    1 z=abs(dely/delx)
      if(dely.gt.0.)goto 10
      th=180.+atan(z)*rd
      go to 8
   10 th=180.-atan(z)*rd
    8 angler=th
      return
      end


        SUBROUTINE ZCLORD(PASS,CCR5,GRAT,SCLAMP,BINIDS,CARPOS,
     *     YDEFS,FGWC,CAP,ORDER,ISTAT)
*
*  Module number:
*
*  Module name: ZCLORD
*
*  Keyphrase:
*  ----------
*       Compute spectral order.
*  Description:
*  ------------
*       This routine reads the spectral order coefficients from
*       table CCR5 and computes the spectral order.
*       For first order gratings the spectral order is set to 1
*       For 'ECH-A' and 'ECH-B' it is computed by:
*                                    b*A*sin((C-carpos)/B)
*               order = NINT( -----------------------------------)
*                               ydef - a - d*A*sin((C-carpos)/B)
*
*       where:
*               NINT is the nearest integer
*               A,B,C are CAP_A, CAP_B, and CAP_C in table ccr5
*               a,b,d are LIT_A, LIT_B, and LIT_C in table ccr5
*               carpos is the carrousel position
*               ydef is the y-deflection adjusted for the proper
*                       aperture (LSA: 128 added to it, SC1: 128
*                       subtracted from the y-deflection)
*
*  FORTRAN name: zclord.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       ccr5                    I       Spectral order constant table
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       zrccr5
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       May 89  D. Lindler      Designed and coded
*	1.1	Oct 90	S. Hulbert	Fixed ydef correction to LSA
*	1.2	Sep 91	S. Hulbert	Implemented PASS flag
*-------------------------------------------------------------------------------
*
* INPUTS:
*       pass - integer variable set to 1 on first call, -1 on last
*       ccr5 - name of spectral order constant table
*       grat - grating mode (character*3)
*       sclamp - spectral cal lamp on (0 - no, 1 or 2)
*       binids - substep bin ids (integer vector)
*       carpos - carrousel position
*       ydefs - ydeflections (integer vector)
*       fwgc  - Flag indicating global wavelength coefficients
*
* OUTPUTS:
*       cap - values of CAP_A and CAP_C
*       order - integer order number
*       istat - error status
*
*------------------------------------------------------------------------------
        INTEGER PASS
        CHARACTER*64 CCR5
        CHARACTER*5 GRAT
        INTEGER SCLAMP,BINIDS(7),YDEFS(7),ORDER,ISTAT,CARPOS
        CHARACTER*12 FGWC
        DOUBLE PRECISION CAP(2)
C
C LOCAL VARIABLES
C
        INTEGER FIRST
        PARAMETER (FIRST = 1)
        INTEGER LAST
        PARAMETER (LAST = -1)
C
        DOUBLE PRECISION LITA,LITB,LITD,CAPA,CAPB,CAPC,ASINX,YD
C
C----------------------------------------------------------------------------
C
C Read coefficients on first call
C
        IF(PASS.EQ.FIRST)THEN
           CALL ZRCCR5(CCR5,GRAT,CAPA,LITA,CAPB,LITB,CAPC,LITD,
     *          ISTAT)
           IF(ISTAT.NE.0)GO TO 999
           CAP(1)=CAPA
           CAP(2)=CAPC
        ENDIF
C
C Only compute order for echelles
C
        IF( (GRAT.EQ.'ECH-A').OR.(GRAT.EQ.'ECH-B'))THEN
C
C COMPUTE ORDER
C
           YD=YDEFS(1)
           IF (SCLAMP.EQ.1) YD=YD-128
           IF ((SCLAMP .EQ. 0) .AND. (BINIDS(1) .EQ. 2))
     &          YD = YD + 128
           ASINX = CAPA*SIN((CAPC-CARPOS)/CAPB)
C
C     THE FOLLOWING LINE OF CODE USED TO READ AS:
C
C           ORDER = LITB*ASINX / (YD-LITA-LITD*ASINX)
C
C THIS BUG HAD BEEN INTRODUCED TO ALLOW THE CCCR5 TABLE
C TO BE READ AND THE CORRECT WAVELENGTHS TO BE CALCULATED
C FOR A SET OF TEST DATA! THIS BUG IS NOW CORRECTED.
C
           ORDER = LITB*ASINX / (YD-LITA-LITD*ASINX) + 0.5
        ELSE
C
C FIRST ORDER GRATING
C
           ORDER=1
        ENDIF
        ISTAT=0
999     RETURN
        END


function flin ( n, jsearch, l, f, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc )

!*****************************************************************************80
!
!! FLIN is the function of one variable to be minimized by MINNY.
!
!  Discussion:
!
!    F(X) is a scalar function of a vector argument X.
!
!    A minimizer of F(X) is sought along a line or parabola.
!
!    This function has been modified, by removing the occurrence of a
!    common block, so that it looks more like a "normal" function that does
!    not rely so strongly on peculiarities of FORTRAN.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 July 2016
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of variables.
!
!    Input, integer ( kind = 4 ) JSEARCH, indicates the kind of search.
!    If J is a legal column index, linear search in direction of V(*,JSEARCH).
!    Otherwise, then the search is parabolic, based on X, Q0 and Q1.
!
!    Input, real ( kind = 8 ) L, is the parameter determining the particular
!    point at which F is to be evaluated.
!    For a linear search, L is the step size.
!    For a quadratic search, L is a parameter which specifies
!    a point in the plane of X, Q0 and Q1.
!
!    Input, external F, is the name of the function to be minimized.
!    The function should have the form
!      function f(x,n)
!      integer ( kind = 4 ) n
!      real ( kind = 8 ) f
!      real ( kind = 8 ) x(n)
!    and accepts X and N as input, returning in F the function value.
!
!    Input, real ( kind = 8 ) X(N), the base point of the search.
!
!    Input/output, integer ( kind = 4 ) NF, the function evaluation counter.
!
!    Input, real ( kind = 8 ) V(N,N), a matrix whose columns constitute
!    search directions.
!
!    Input, real ( kind = 8 ) Q0(N), Q1(N), two auxiliary points used to
!    determine the plane when a quadratic search is performed.
!
!    Input, real ( kind = 8 ) QD0, QD1, values needed to compute the
!    coefficients QA, QB, QC.
!
!    Output, real ( kind = 8 ) QA, QB, QC, coefficients used to combine
!    Q0, X, and A1 if a quadratic search is used.
!
!    Output, real ( kind = 8 ) FLIN, the value of the function at the
!    minimizing point.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ), external :: f
  real ( kind = 8 ) flin
  integer ( kind = 4 ) i
  integer ( kind = 4 ) jsearch
  real ( kind = 8 ) l
  integer ( kind = 4 ) nf
  real ( kind = 8 ) q0(n)
  real ( kind = 8 ) q1(n)
  real ( kind = 8 ) qa
  real ( kind = 8 ) qb
  real ( kind = 8 ) qc
  real ( kind = 8 ) qd0
  real ( kind = 8 ) qd1
  real ( kind = 8 ) t(n)
  real ( kind = 8 ) v(n,n)
  real ( kind = 8 ) x(n)
!
!  The search is linear.
!
  if ( 1 <= jsearch ) then

    t(1:n) = x(1:n) + l * v(1:n,jsearch)
!
!  The search is along a parabolic space curve.
!
  else

    qa =                 l * ( l - qd1 ) /       ( qd0 + qd1 ) / qd0
    qb = - ( l + qd0 ) *     ( l - qd1 ) / qd1                 / qd0
    qc =   ( l + qd0 ) * l               / qd1 / ( qd0 + qd1 )

    t(1:n) = qa * q0(1:n) + qb * x(1:n) + qc * q1(1:n)

  end if
!
!  The function evaluation counter NF is incremented.
!
  nf = nf + 1
!
!  Evaluate the function.
!
  flin = f ( t, n )

  return
end
subroutine minfit ( n, tol, a, q )

!*****************************************************************************80
!
!! MINFIT computes the singular value decomposition of an N by N array.
!
!  Discussion:
!
!    This is an improved version of the EISPACK routine MINFIT
!    restricted to the case M = N and P = 0.
!
!    The singular values of the array A are returned in Q.  A is
!    overwritten with the orthogonal matrix V such that U * diag(Q) = A * V,
!    where U is another orthogonal matrix.
!
!    Thanks to Andreas Zuend for pointing out a potential for overflow in
!    the computation z = sqrt ( f*f + 1 ), 22 March 2012.
!
!    Thanks to Martin Horvat for correcting the initial assignment of S,
!    and for moving the line "L=I" back within the loop, 25 June 2013.
!
!    Thanks to Martin Horvat for moving the assignment "X=MAX(X,Y)"
!    into the loop, 29 October 2013.
!
!    Further modifications to this function were made, to remove the use
!    of statement labels, so that the function looks more like a "normal"
!    function that relies much less on the peculiarities of FORTRAN,
!    27 July 2016.
!
!    Removed argument M.  A must be dimensions (N,N).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 July 2016
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!    James Wilkinson, Christian Reinsch,
!    Handbook for Automatic Computation,
!    Volume II, Linear Algebra, Part 2,
!    Springer Verlag, 1971.
!
!    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow, Yasuhiko Ikebe,
!    Virginia Klema, Cleve Moler,
!    Matrix Eigensystem Routines, EISPACK Guide,
!    Lecture Notes in Computer Science, Volume 6,
!    Springer Verlag, 1976,
!    ISBN13: 978-3540075462,
!    LC: QA193.M37.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the matrix A.
!
!    Input, real ( kind = 8 ) TOL, a tolerance which determines when a vector
!    (a column or part of a column of the matrix) may be considered
!    "essentially" equal to zero.
!
!    Input/output, real ( kind = 8 ) A(N,N).  On input, an N by N array whose
!    singular value decomposition is desired.  On output, the
!    SVD orthogonal matrix factor V.
!
!    Input/output, real ( kind = 8 ) Q(N), the singular values.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) c
  real ( kind = 8 ) e(n)
  real ( kind = 8 ) eps
  real ( kind = 8 ) f
  real ( kind = 8 ) g
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kk
  integer ( kind = 4 ) kt
  integer ( kind = 4 ), parameter :: kt_max = 30
  integer ( kind = 4 ) l
  integer ( kind = 4 ) l2
  integer ( kind = 4 ) ll2
  real ( kind = 8 ) q(n)
  real ( kind = 8 ) r8_hypot
  real ( kind = 8 ) s
  logical skip
  real ( kind = 8 ) temp
  real ( kind = 8 ) tol
  real ( kind = 8 ) x
  real ( kind = 8 ) y
  real ( kind = 8 ) z
!
!  Householder's reduction to bidiagonal form.
!
  if ( n == 1 ) then
    q(1) = a(1,1)
    a(1,1) = 1.0D+00
    return
  end if

  eps = epsilon ( eps )
  g = 0.0D+00
  x = 0.0D+00

  do i = 1, n

    e(i) = g
    l = i + 1

    s = sum ( a(i:n,i) ** 2 )

    g = 0.0D+00

    if ( tol <= s ) then

      f = a(i,i)

      g = sqrt ( s )
      if ( 0.0D+00 <= f ) then
        g = - g
      end if

      h = f * g - s
      a(i,i) = f - g

      do j = l, n

        f = dot_product ( a(i:n,i), a(i:n,j) ) / h

        a(i:n,j) = a(i:n,j) + f * a(i:n,i)

      end do

    end if

    q(i) = g

    s = sum ( a(i,l:n) ** 2 )

    g = 0.0D+00

    if ( tol <= s ) then

      if ( i /= n ) then
        f = a(i,i+1)
      end if

      g = sqrt ( s )
      if ( 0.0D+00 <= f ) then
        g = - g
      end if

      h = f * g - s

      if ( i /= n ) then

        a(i,i+1) = f - g
        e(l:n) = a(i,l:n) / h

        do j = l, n

          s = dot_product ( a(j,l:n), a(i,l:n) )

          a(j,l:n) = a(j,l:n) + s * e(l:n)

        end do

      end if

    end if

    y = abs ( q(i) ) + abs ( e(i) )

    x = max ( x, y )

  end do
!
!  Accumulation of right-hand transformations.
!
  a(n,n) = 1.0D+00
  g = e(n)
  l = n

  do i = n - 1, 1, -1

    if ( g /= 0.0D+00 ) then

      h = a(i,i+1) * g

      a(l:n,i) = a(i,l:n) / h

      do j = l, n

        s = dot_product ( a(i,l:n), a(l:n,j) )

        a(l:n,j) = a(l:n,j) + s * a(l:n,i)

      end do

    end if

    a(i,l:n) = 0.0D+00
    a(l:n,i) = 0.0D+00
    a(i,i) = 1.0D+00

    g = e(i)

    l = i

  end do
!
!  Diagonalization of the bidiagonal form.
!
  eps = eps * x

  do k = n, 1, -1

    kt = 0

    do

      kt = kt + 1

      if ( kt_max < kt ) then
        e(k) = 0.0D+00
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'MINFIT - Fatal error!'
        write ( *, '(a)' ) '  The QR algorithm failed to converge.'
        stop 1
      end if

      skip = .false.

      do l2 = k, 1, -1

        l = l2

        if ( abs ( e(l) ) <= eps ) then
          skip = .true.
          exit
        end if

        if ( l /= 1 ) then
          if ( abs ( q(l-1) ) <= eps ) then
            exit
          end if
        end if

      end do
!
!  Cancellation of E(L) if 1 < L.
!
      if ( .not. skip ) then

        c = 0.0D+00
        s = 1.0D+00

        do i = l, k

          f = s * e(i)
          e(i) = c * e(i)
          if ( abs ( f ) <= eps ) then
            exit
          end if
          g = q(i)
!
!  q(i) = h = sqrt(g*g + f*f).
!
          h = r8_hypot ( f, g )

          q(i) = h

          if ( h == 0.0D+00 ) then
            g = 1.0D+00
            h = 1.0D+00
          end if

          c =   g / h
          s = - f / h

        end do

      end if
!
!  Test for convergence for this index K.
!
      z = q(k)

      if ( l == k ) then
        if ( z < 0.0D+00 ) then
          q(k) = - z
          a(1:n,k) = - a(1:n,k)
        end if
        exit
      end if
!
!  Shift from bottom 2*2 minor.
!
      x = q(l)
      y = q(k-1)
      g = e(k-1)
      h = e(k)
      f = ( ( y - z ) * ( y + z ) + ( g - h ) * ( g + h ) ) &
        / ( 2.0D+00 * h * y )

      g = r8_hypot ( f, 1.0D+00 )

      if ( f < 0.0D+00 ) then
        temp = f - g
      else
        temp = f + g
      end if

      f = ( ( x - z ) * ( x + z ) + h * ( y / temp - h ) ) / x
!
!  Next QR transformation.
!
      c = 1.0D+00
      s = 1.0D+00

      do i = l + 1, k

        g = e(i)
        y = q(i)
        h = s * g
        g = g * c

        z = r8_hypot ( f, h )

        e(i-1) = z

        if ( z == 0.0D+00 ) then
          f = 1.0D+00
          z = 1.0D+00
        end if

        c = f / z
        s = h / z
        f =   x * c + g * s
        g = - x * s + g * c
        h = y * s
        y = y * c

        do j = 1, n
          x = a(j,i-1)
          z = a(j,i)
          a(j,i-1) = x * c + z * s
          a(j,i) = - x * s + z * c
        end do

        z = r8_hypot ( f, h )

        q(i-1) = z

        if ( z == 0.0D+00 ) then
          f = 1.0D+00
          z = 1.0D+00
        end if

        c = f / z
        s = h / z
        f =   c * g + s * y
        x = - s * g + c * y

      end do

      e(l) = 0.0D+00
      e(k) = f
      q(k) = x

    end do

  end do

  return
end
subroutine minny ( n, jsearch, nits, d2, x1, f1, fk, f, x, t, h, v, q0, q1, &
  nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 )

!*****************************************************************************80
!
!! MINNY minimizes a scalar function of N variables along a line.
!
!  Discussion:
!
!    MINNY minimizes F along the line from X in the direction V(*,J) unless
!    J is less than 1, when a quadratic search is made in the plane
!    defined by Q0, Q1 and X.
!
!    If FK = true, then F1 is FLIN(X1).  Otherwise X1 and F1 are ignored
!    on entry unless final FX is greater than F1.
!
!    This function was modified by removing the common blocks
!    and the use of labeled statements, 28 July 2016.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 July 2016
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of variables.
!
!    Input, integer ( kind = 4 ) JSEARCH, indicates the kind of search.
!    If JSEARCH is a legal column index, linear search in direction of V(*,J).
!    Otherwise, the search is parabolic, based on X, Q0 and Q1.
!
!    Input, integer ( kind = 4 ) NITS, the maximum number of times the interval
!    may be halved to retry the calculation.
!
!    Input/output, real ( kind = 8 ) D2, is either zero, or an approximation to
!    the value of (1/2) times the second derivative of F.
!
!    Input/output, real ( kind = 8 ) X1, on entry, an estimate of the
!    distance from X to the minimum along V(*,J), or, if J = 0, a curve.
!    On output, the distance between X and the minimizer that was found.
!
!    Input/output, real ( kind = 8 ) F1, ?
!
!    Input, logical FK; if FK is TRUE, then on input F1 contains
!    the value FLIN(X1).
!
!    Input, external real ( kind = 8 ) F, is the name of the function to
!    be minimized.  The function should have the form
!      function f(x,n)
!      integer ( kind = 4 ) n
!      real ( kind = 8 ) f
!      real ( kind = 8 ) x(n)
!    and accepts X and N as input, returning in F the function value.
!
!    Input/output, real ( kind = 8 ) X(N), ?
!
!    Input, real ( kind = 8 ) T, ?
!
!    Input, real ( kind = 8 ) H, ?
!
!    Input, real ( kind = 8 ) V(N,N), a matrix whose columns are direction
!    vectors along which the function may be minimized.
!
!    Input, real ( kind = 8 ) Q0(N), an auxiliary point used to define
!    a curve through X.
!
!    Input, real ( kind = 8 ) Q1(N), an auxiliary point used to define
!    a curve through X.
!
!    Input/output, integer ( kind = 4 ) NL, the number of linear searches.
!
!    Input/output, integer ( kind = 4 ) NF, the number of function evaluations.
!
!    Input, real ( kind = 8 ) DMIN, an estimate for the smallest eigenvalue.
!
!    Input, real ( kind = 8 ) LDT, the length of the step.
!
!    Input/output, real ( kind = 8 ) FX, the value of F(X,N).
!
!    Input/output, real ( kind = 8 ) QA, QB, QC, ?
!
!    Input, real ( kind = 8 ) QD0, QD1, ?.
!
  implicit none

  real ( kind = 8 ) d1
  real ( kind = 8 ) d2
  real ( kind = 8 ) dmin
  logical dz
  real ( kind = 8 ), external :: f
  real ( kind = 8 ) f0
  real ( kind = 8 ) f1
  real ( kind = 8 ) f2
  logical fk
  real ( kind = 8 ) flin
  real ( kind = 8 ) fm
  real ( kind = 8 ) fx
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) jsearch
  integer ( kind = 4 ) k
  real ( kind = 8 ) ldt
  real ( kind = 8 ) m2
  real ( kind = 8 ) m4
  real ( kind = 8 ) machep
  integer ( kind = 4 ) n
  integer ( kind = 4 ) nf
  integer ( kind = 4 ) nits
  integer ( kind = 4 ) nl
  logical ok
  real ( kind = 8 ) q0(n)
  real ( kind = 8 ) q1(n)
  real ( kind = 8 ) qa
  real ( kind = 8 ) qb
  real ( kind = 8 ) qc
  real ( kind = 8 ) qd0
  real ( kind = 8 ) qd1
  real ( kind = 8 ) s
  real ( kind = 8 ) sf1
  real ( kind = 8 ) small
  real ( kind = 8 ) sx1
  real ( kind = 8 ) t
  real ( kind = 8 ) t2
  real ( kind = 8 ) temp
  real ( kind = 8 ) v(n,n)
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) x1
  real ( kind = 8 ) x2
  real ( kind = 8 ) xm

  machep = epsilon ( machep )
  small = machep ** 2
  m2 = sqrt ( machep )
  m4 = sqrt ( m2 )
  sf1 = f1
  sx1 = x1
  k = 0
  xm = 0.0D+00
  fm = fx
  f0 = fx
  dz = ( d2 < machep )
!
!  Find the step size.
!
  s = sqrt ( sum ( x(1:n) ** 2 ) )

  if ( dz ) then
    temp = dmin
  else
    temp = d2
  end if

  t2 = m4 * sqrt ( abs ( fx ) / temp + s * ldt ) + m2 * ldt
  s = m4 * s + t
  if ( dz .and. s < t2 ) then
    t2 = s
  end if

  t2 = max ( t2, small )
  t2 = min ( t2, 0.01D+00 * h )

  if ( fk .and. f1 <= fm ) then
    xm = x1
    fm = f1
  end if

  if ( .not. fk .or. abs ( x1 ) < t2 ) then

    if ( 0.0D+00 <= x1 ) then
      temp = 1.0D+00
    else
      temp = - 1.0D+00
    end if

    x1 = temp * t2
    f1 = flin ( n, jsearch, x1, f, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc )

  end if

  if ( f1 <= fm ) then
    xm = x1
    fm = f1
  end if
!
!  Evaluate FLIN at another point and estimate the second derivative.
!
  do

    if ( dz ) then

      if ( f1 <= f0 ) then
        x2 = 2.0D+00 * x1
      else
        x2 = - x1
      end if

      f2 = flin ( n, jsearch, x2, f, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc )

      if ( f2 <= fm ) then
        xm = x2
        fm = f2
      end if

      d2 = ( x2 * ( f1 - f0 ) - x1 * ( f2 - f0 ) ) &
        / ( ( x1 * x2 ) * ( x1 - x2 ) )

    end if
!
!  Estimate the first derivative at 0.
!
    d1 = ( f1 - f0 ) / x1 - x1 * d2
    dz = .true.
!
!  Predict the minimum.
!
    if ( d2 <= small ) then

      if ( 0.0D+00 <= d1 ) then
        x2 = - h
      else
        x2 = h
      end if

    else

      x2 = ( - 0.5D+00 * d1 ) / d2

    end if

    if ( h < abs ( x2 ) ) then

      if ( x2 <= 0.0D+00 ) then
        x2 = - h
      else
        x2 = h
      end if

    end if
!
!  Evaluate F at the predicted minimum.
!
    ok = .true.

    do

      f2 = flin ( n, jsearch, x2, f, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc )

      if ( nits <= k .or. f2 <= f0 ) then
        exit
      end if

      k = k + 1

      if ( f0 < f1 .and. 0.0D+00 < x1 * x2 ) then
        ok = .false.
        exit
      end if

      x2 = 0.5D+00 * x2

    end do

    if ( ok ) then
      exit
    end if

  end do
!
!  Increment the one-dimensional search counter.
!
  nl = nl + 1

  if ( fm < f2 ) then
    x2 = xm
  else
    fm = f2
  end if
!
!  Get a new estimate of the second derivative.
!
  if ( small < abs ( x2 * ( x2 - x1 ) ) ) then
    d2 = ( x2 * ( f1 - f0 ) - x1 * ( fm - f0 ) ) / ( ( x1 * x2 ) * ( x1 - x2 ) )
  else
    if ( 0 < k ) then
      d2 = 0.0D+00
    end if
  end if

  d2 = max ( d2, small )

  x1 = x2
  fx = fm

  if ( sf1 < fx ) then
    fx = sf1
    x1 = sx1
  end if
!
!  Update X for linear but not parabolic search.
!
  if ( 1 <= jsearch ) then

    x(1:n) = x(1:n) + x1 * v(1:n,jsearch)

  end if

  return
end
function praxis ( t0, h0, n, prin, x, f )

!*****************************************************************************80
!
!! PRAXIS seeks an N-dimensional minimizer X of a scalar function F(X).
!
!  Discussion:
!
!    PRAXIS returns the minimum of the function F(X,N) of N variables
!    using the principal axis method.  The gradient of the function is
!    not required.
!
!    The approximating quadratic form is
!
!      Q(x') = F(x,n) + (1/2) * (x'-x)' * A * (x'-x)
!
!    where X is the best estimate of the minimum and
!
!      A = inverse(V') * D * inverse(V)
!
!    V(*,*) is the matrix of search directions;
!    D(*) is the array of second differences.
!
!    If F(X) has continuous second derivatives near X0, then A will tend
!    to the hessian of F at X0 as X approaches X0.
!
!    Thanks to Andreas Zuend for pointing out an error in the form of the
!    call to the routine r8mat_print (), 22 March 2012.
!
!    This function was modified by eliminating the use of labeled statements,
!    and removing the common blocks, 28 July 2016.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    28 July 2016
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) T0, is a tolerance.  PRAXIS attempts to return
!    praxis = f(x) such that if X0 is the true local minimum near X, then
!    norm ( x - x0 ) < T0 + sqrt ( EPSILON ( X ) ) * norm ( X ),
!    where EPSILON ( X ) is the machine precision for X.
!
!    Input, real ( kind = 8 ) H0, is the maximum step size.  H0 should be
!    set to about the maximum distance from the initial guess to the minimum.
!    If H0 is set too large or too small, the initial rate of
!    convergence may be slow.
!
!    Input, integer ( kind = 4 ) N, the number of variables.
!
!    Input, integer ( kind = 4 ) PRIN, controls printing intermediate results.
!    0, nothing is printed.
!    1, F is printed after every n+1 or n+2 linear minimizations.
!       final X is printed, but intermediate X is printed only
!       if N is at most 4.
!    2, the scale factors and the principal values of the approximating
!       quadratic form are also printed.
!    3, X is also printed after every few linear minimizations.
!    4, the principal vectors of the approximating quadratic form are
!       also printed.
!
!    Input/output, real ( kind = 8 ) X(N), is an array containing on entry a
!    guess of the point of minimum, on return the estimated point of minimum.
!
!    Input, external real ( kind = 8 ) F, is the name of the function to be
!    minimized.  The function should have the form
!      function f(x,n)
!      integer ( kind = 4 ) n
!      real ( kind = 8 ) f
!      real ( kind = 8 ) x(n)
!    and accepts X and N as input, returning in F the function value.
!
!    Output, real ( kind = 8 ) PRAXIS, the function value at the minimizer.
!
!  Local parameters:
!
!    Local, real ( kind = 8 ) DMIN, an estimate for the smallest eigenvalue.
!
!    Local, real ( kind = 8 ) FX, the value of F(X,N).
!
!    Local, logical ILLC, is TRUE if the system is ill-conditioned.
!
!    Local, real ( kind = 8 ) LDT, the length of the step.
!
!    Local, integer ( kind = 4 ) NF, the number of function evaluations.
!
!    Local, integer ( kind = 4 ) NL, the number of linear searches.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) d(n)
  real ( kind = 8 ) d2
  real ( kind = 8 ) df
  real ( kind = 8 ) dmin
  real ( kind = 8 ) dn
  real ( kind = 8 ) dni
  real ( kind = 8 ), external :: f
  real ( kind = 8 ) f1
  logical fk
  real ( kind = 8 ) fx
  real ( kind = 8 ) h
  real ( kind = 8 ) h0
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ii
  logical illc
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jsearch
  integer ( kind = 4 ) k
  integer ( kind = 4 ) k2
  integer ( kind = 4 ) kl
  integer ( kind = 4 ) kt
  integer ( kind = 4 ) ktm
  real ( kind = 8 ) large
  real ( kind = 8 ) ldfac
  real ( kind = 8 ) lds
  real ( kind = 8 ) ldt
  real ( kind = 8 ) m2
  real ( kind = 8 ) m4
  real ( kind = 8 ) machep
  integer ( kind = 4 ) nits
  integer ( kind = 4 ) nl
  integer ( kind = 4 ) nf
  real ( kind = 8 ) praxis
  integer ( kind = 4 ) prin
  real ( kind = 8 ) q0(n)
  real ( kind = 8 ) q1(n)
  real ( kind = 8 ) qa
  real ( kind = 8 ) qb
  real ( kind = 8 ) qc
  real ( kind = 8 ) qd0
  real ( kind = 8 ) qd1
  real ( kind = 8 ) qf1
  real ( kind = 8 ) r
  real ( kind = 8 ) r8_uniform_01
  real ( kind = 8 ) s
  real ( kind = 8 ) scbd
  integer ( kind = 4 ) seed
  real ( kind = 8 ) sf
  real ( kind = 8 ) sl
  real ( kind = 8 ) small
  real ( kind = 8 ) t
  real ( kind = 8 ) t0
  real ( kind = 8 ) t2
  real ( kind = 8 ) v(n,n)
  real ( kind = 8 ) value
  real ( kind = 8 ) vlarge
  real ( kind = 8 ) vsmall
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) y(n)
  real ( kind = 8 ) z(n)
!
!  Initialization.
!
  machep = epsilon ( machep )
  small = machep * machep
  vsmall = small * small
  large = 1.0D+00 / small
  vlarge = 1.0D+00 / vsmall
  m2 = sqrt ( machep )
  m4 = sqrt ( m2 )
  seed = 123456789
!
!  Heuristic numbers:
!
!  If the axes may be badly scaled (which is to be avoided if
!  possible), then set SCBD = 10.  Otherwise set SCBD = 1.
!
!  If the problem is known to be ill-conditioned, initialize ILLC = true.
!
!  KTM is the number of iterations without improvement before the
!  algorithm terminates.  KTM = 4 is very cautious; usually KTM = 1
!  is satisfactory.
!
  scbd = 1.0D+00
  illc = .false.
  ktm = 1

  if ( illc ) then
    ldfac = 0.1D+00
  else
    ldfac = 0.01D+00
  end if

  kt = 0
  nl = 0
  nf = 1
  fx = f ( x, n )
  qf1 = fx
  t = small + abs ( t0 )
  t2 = t
  dmin = small
  h = h0
  h = max ( h, 100.0D+00 * t )
  ldt = h
!
!  The initial set of search directions V is the identity matrix.
!
  v(1:n,1:n) = 0.0D+00
  do i = 1, n
    v(i,i) = 1.0D+00
  end do

  d(1:n) = 0.0D+00
  qa = 0.0D+00
  qb = 0.0D+00
  qc = 0.0D+00
  qd0 = 0.0D+00
  qd1 = 0.0D+00
  q0(1:n) = x(1:n)
  q1(1:n) = x(1:n)

  if ( 0 < prin ) then
    call print2 ( n, x, prin, fx, nf, nl )
  end if
!
!  The main loop starts here.
!
  do

    sf = d(1)
    d(1) = 0.0D+00
!
!  Minimize along the first direction V(*,1).
!
    jsearch = 1
    nits = 2
    d2 = d(1)
    s = 0.0D+00
    value = fx
    fk = .false.

    call minny ( n, jsearch, nits, d2, s, value, fk, f, x, t, &
      h, v, q0, q1, nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 )

    d(1) = d2

    if ( s <= 0.0D+00 ) then
      v(1:n,1) = - v(1:n,1)
    end if

    if ( sf <= 0.9D+00 * d(1) .or. d(1) <= 0.9D+00 * sf ) then
      d(2:n) = 0.0D+00
    end if
!
!  The inner loop starts here.
!
    do k = 2, n

      y(1:n) = x(1:n)

      sf = fx

      if ( 0 < kt ) then
        illc = .true.
      end if

      do

        kl = k
        df = 0.0D+00
!
!  A random step follows, to avoid resolution valleys.
!
        if ( illc ) then

          do i = 1, n
            r = r8_uniform_01 ( seed )
!           call random_number ( harvest = r )
            s = ( 0.1D+00 * ldt + t2 * 10.0D+00 ** kt ) * ( r - 0.5D+00 )
            z(i) = s
            x(1:n) = x(1:n) + s * v(1:n,i)
          end do

          fx = f ( x, n )
          nf = nf + 1

        end if
!
!  Minimize along the "non-conjugate" directions V(*,K),...,V(*,N).
!
        do k2 = k, n

          sl = fx

          jsearch = k2
          nits = 2
          d2 = d(k2)
          s = 0.0D+00
          value = fx
          fk = .false.

          call minny ( n, jsearch, nits, d2, s, value, fk, f, x, t, &
            h, v, q0, q1, nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 )

          d(k2) = d2

          if ( illc ) then
            s = d(k2) * ( ( s + z(k2) ) ** 2 )
          else
            s = sl - fx
          end if

          if ( df <= s ) then
            df = s
            kl = k2
          end if

        end do
!
!  If there was not much improvement on the first try, set
!  ILLC = true and start the inner loop again.
!
        if ( illc ) then
          exit
        end if

        if ( abs ( 100.0D+00 * machep * fx ) <= df ) then
          exit
        end if

        illc = .true.

      end do

      if ( k == 2 .and. 1 < prin ) then
        call r8vec_print ( n, d, '  The second difference array:' )
      end if
!
!  Minimize along the "conjugate" directions V(*,1),...,V(*,K-1).
!
      do k2 = 1, k - 1

        jsearch = k2
        nits = 2
        d2 = d(k2)
        s = 0.0D+00
        value = fx
        fk = .false.

        call minny ( n, jsearch, nits, d2, s, value, fk, f, x, t, &
          h, v, q0, q1, nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 )

        d(k2) = d2

      end do

      f1 = fx
      fx = sf
      lds = 0.0D+00

      do i = 1, n
        sl = x(i)
        x(i) = y(i)
        sl = sl - y(i)
        y(i) = sl
        lds = lds + sl ** 2
      end do

      lds = sqrt ( lds )
!
!  Discard direction V(*,kl).
!
!  If no random step was taken, V(*,KL) is the "non-conjugate"
!  direction along which the greatest improvement was made.
!
      if ( small < lds ) then

        do j = kl - 1, k, -1
          v(1:n,j+1) = v(1:n,j)
          d(j+1) = d(j)
        end do

        d(k) = 0.0D+00

        v(1:n,k) = y(1:n) / lds
!
!  Minimize along the new "conjugate" direction V(*,k), which is
!  the normalized vector:  (new x) - (old x).
!
        jsearch = k
        nits = 4
        d2 = d(k)
        value = f1
        fk = .true.

        call minny ( n, jsearch, nits, d2, lds, value, fk, f, x, t, &
          h, v, q0, q1, nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 )

        d(k) = d2

        if ( lds <= 0.0D+00 ) then
          lds = - lds
          v(1:n,k) = - v(1:n,k)
        end if

      end if

      ldt = ldfac * ldt
      ldt = max ( ldt, lds )

      if ( 0 < prin ) then
        call print2 ( n, x, prin, fx, nf, nl )
      end if

      t2 = m2 * sqrt ( sum ( x(1:n) ** 2 ) ) + t
!
!  See whether the length of the step taken since starting the
!  inner loop exceeds half the tolerance.
!
      if ( 0.5D+00 * t2 < ldt ) then
        kt = - 1
      end if

      kt = kt + 1

      if ( ktm < kt ) then

        if ( 0 < prin ) then
          call r8vec_print ( n, x, '  X:' )
        end if

        praxis = fx

        return

      end if

    end do
!
!  The inner loop ends here.
!
!  Try quadratic extrapolation in case we are in a curved valley.
!
    call quad ( n, f, x, t, h, v, q0, q1, nl, nf, dmin, ldt, fx, qf1, &
      qa, qb, qc, qd0, qd1 )

    d(1:n) = 1.0D+00 / sqrt ( d(1:n) )

    dn = maxval ( d(1:n) )

    if ( 3 < prin ) then
      call r8mat_print ( n, n, v, '  The new direction vectors:' )
    end if

    do j = 1, n
      v(1:n,j) = ( d(j) / dn ) * v(1:n,j)
    end do
!
!  Scale the axes to try to reduce the condition number.
!
    if ( 1.0D+00 < scbd ) then

      do i = 1, n
        z(i) = max ( m4, sqrt ( sum ( v(i,1:n) ** 2 ) ) )
      end do

      s = minval ( z(1:n) )

      do i = 1, n

        sl = s / z(i)
        z(i) = 1.0D+00 / sl

        if ( scbd < z(i) ) then
          sl = 1.0D+00 / scbd
          z(i) = scbd
        end if

        v(i,1:n) = sl * v(i,1:n)

      end do

    end if
!
!  Calculate a new set of orthogonal directions before repeating
!  the main loop.
!
!  Transpose V for MINFIT:
!
    v(1:n,1:n) = transpose ( v(1:n,1:n) )
!
!  Call MINFIT to find the singular value decomposition of V.
!
!  This gives the principal values and principal directions of the
!  approximating quadratic form without squaring the condition number.
!
    call minfit ( n, vsmall, v, d )
!
!  Unscale the axes.
!
    if ( 1.0D+00 < scbd ) then

      do i = 1, n
        v(i,1:n) = z(i) * v(i,1:n)
      end do

      do i = 1, n

        s = sqrt ( sum ( v(1:n,i) ** 2 ) )
        d(i) = s * d(i)
        v(1:n,i) = v(1:n,i) / s

      end do

    end if

    do i = 1, n

      dni = dn * d(i)

      if ( large < dni ) then
        d(i) = vsmall
      else if ( dni < small ) then
        d(i) = vlarge
      else
        d(i) = 1.0D+00 / dni ** 2
      end if

    end do
!
!  Sort the singular values and singular vectors.
!
    call svsort ( n, d, v )
!
!  Determine the smallest eigenvalue.
!
    dmin = max ( d(n), small )
!
!  The ratio of the smallest to largest eigenvalue determines whether
!  the system is ill conditioned.
!
    if ( dmin < m2 * d(1) ) then
      illc = .true.
    else
      illc = .false.
    end if

    if ( 1 < prin ) then

      if ( 1.0D+00 < scbd ) then
        call r8vec_print ( n, z, '  The scale factors:' )
      end if

      call r8vec_print ( n, d, '  Principal values of the quadratic form:' )

    end if

    if ( 3 < prin ) then
      call r8mat_print ( n, n, v, '  The principal axes:' )
    end if
!
!  The main loop ends here.
!
  end do

  if ( 0 < prin ) then
    call r8vec_print ( n, x, '  X:' )
  end if

  praxis = fx

  return
end
subroutine print2 ( n, x, prin, fx, nf, nl )

!*****************************************************************************80
!
!! PRINT2 prints certain data about the progress of the iteration.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 May 2006
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of variables.
!
!    Input, real ( kind = 8 ) X(N), the current estimate of the minimizer.
!
!    Input, integer ( kind = 4 ) PRIN, the user-specifed print level.
!    0, nothing is printed.
!    1, F is printed after every n+1 or n+2 linear minimizations.
!       final X is printed, but intermediate X is printed only
!       if N is at most 4.
!    2, the scale factors and the principal values of the approximating
!       quadratic form are also printed.
!    3, X is also printed after every few linear minimizations.
!    4, the principal vectors of the approximating quadratic form are
!       also printed.
!
!    Input, real ( kind = 8 ) FX, the smallest value of F(X) found so far.
!
!    Input, integer ( kind = 4 ) NF, the number of function evaluations.
!
!    Input, integer ( kind = 4 ) NL, the number of linear searches.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) fx
  integer ( kind = 4 ) nf
  integer ( kind = 4 ) nl
  integer ( kind = 4 ) prin
  real ( kind = 8 ) x(n)

  write ( *, '(a)' ) ' '
  write ( *, '(a,i8)' ) '  Linear searches      ', nl
  write ( *, '(a,i8)' ) '  Function evaluations ', nf

  if ( n <= 4 .or. 2 < prin ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'X:'
    write ( *, '(5g14.6)' ) x(1:n)
  end if

  write ( *, '(a)' ) ' '
  write ( *, '(a,g14.6)' ) '  The function value FX: ', fx

  return
end
subroutine quad ( n, f, x, t, h, v, q0, q1, nl, nf, dmin, ldt, fx, qf1, &
  qa, qb, qc, qd0, qd1 )

!*****************************************************************************80
!
!! QUAD seeks to minimize the scalar function F along a particular curve.
!
!  Discussion:
!
!    The minimizer to be sought is required to lie on a curve defined
!    by Q0, Q1 and X.
!
!    This function was modified by removing the common blocks,
!    28 July 2016.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    30 July 2016
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of variables.
!
!    Input, external real ( kind = 8 ) F, is the name of the function to
!    be minimized.  The function should have the form
!      function f(x,n)
!      integer ( kind = 4 ) n
!      real ( kind = 8 ) f
!      real ( kind = 8 ) x(n)
!    and accepts X and N as input, returning in F the function value.
!
!    Input/output, real ( kind = 8 ) X(N), ?
!
!    Input, real ( kind = 8 ) T, ?
!
!    Input, real ( kind = 8 ) H, ?
!
!    Input, real ( kind = 8 ) V(N,N), the matrix of search directions.
!
!    Input/output, real ( kind = 8 ) Q0(N), Q1(N), auxiliary points used to \
!    define a curve through X.
!
!    Input/output, integer ( kind = 4 ) NL, the number of linear searches.
!
!    Input/output, integer ( kind = 4 ) NF, the number of function evaluations.
!
!    Input, real ( kind = 8 ) DMIN, an estimate for the smallest eigenvalue.
!
!    Input, real ( kind = 8 ) LDT, the length of the step.
!
!    Input/output, real ( kind = 8 ) FX, the value of F(X,N).
!
!    Input/output, real ( kind = 8 ) QF1, QA, QB, QC, QD0, QD1 ?
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) dmin
  real ( kind = 8 ), external :: f
  logical fk
  real ( kind = 8 ) fx
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) jsearch
  real ( kind = 8 ) l
  real ( kind = 8 ) ldt
  integer ( kind = 4 ) nf
  integer ( kind = 4 ) nits
  integer ( kind = 4 ) nl
  real ( kind = 8 ) q0(n)
  real ( kind = 8 ) q1(n)
  real ( kind = 8 ) qa
  real ( kind = 8 ) qb
  real ( kind = 8 ) qc
  real ( kind = 8 ) qd0
  real ( kind = 8 ) qd1
  real ( kind = 8 ) qf1
  real ( kind = 8 ) s
  real ( kind = 8 ) t
  real ( kind = 8 ) temp
  real ( kind = 8 ) v(n,n)
  real ( kind = 8 ) value
  real ( kind = 8 ) x(n)

  temp = fx
  fx   = qf1
  qf1  = temp

  call r8vec_swap ( n, x, q1 )

  qd1 = sqrt ( sum ( ( x(1:n) - q1(1:n) ) ** 2 ) )

  l = qd1
  s = 0.0D+00

  if ( qd0 <= 0.0D+00 .or. qd1 <= 0.0D+00 .or. nl < 3 * n * n ) then

    fx = qf1
    qa = 0.0D+00
    qb = 0.0D+00
    qc = 1.0D+00

  else

    jsearch = -1
    nits = 2
    value = qf1
    fk = .true.

    call minny ( n, jsearch, nits, s, l, value, fk, f, x, t, &
      h, v, q0, q1, nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 )

    qa =                 l * ( l - qd1 )       / ( qd0 + qd1 ) / qd0
    qb = - ( l + qd0 )     * ( l - qd1 ) / qd1                 / qd0
    qc =   ( l + qd0 ) * l               / qd1 / ( qd0 + qd1 )

  end if

  qd0 = qd1

  do i = 1, n
    s = q0(i)
    q0(i) = x(i)
    x(i) = qa * s + qb * x(i) + qc * q1(i)
  end do

  return
end
function r8_hypot ( x, y )

!*****************************************************************************80
!
!! R8_HYPOT returns the value of sqrt ( X^2 + Y^2).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 March 2012
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X, Y, the arguments.
!
!    Output, real ( kind = 8 ) R8_HYPOT, the value of sqrt ( X^2 + Y^2 ).
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) c
  real ( kind = 8 ) r8_hypot
  real ( kind = 8 ) x
  real ( kind = 8 ) y

  if ( abs ( x ) < abs ( y ) ) then
    a = abs ( y )
    b = abs ( x )
  else
    a = abs ( x )
    b = abs ( y )
  end if
!
!  A contains the larger value.
!
  if ( a == 0.0D+00 ) then
    c = 0.0D+00
  else
    c = a * sqrt ( 1.0D+00 + ( b / a ) ** 2 )
  end if

  r8_hypot = c

  return
end
function r8_uniform_01 ( seed )

!*****************************************************************************80
!
!! R8_UNIFORM_01 returns a unit pseudorandom R8.
!
!  Discussion:
!
!    An R8 is a real ( kind = 8 ) value.
!
!    For now, the input quantity SEED is an integer variable.
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r8_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R8_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    05 July 2006
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley Interscience, page 95, 1998.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which should
!    NOT be 0. On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) k
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R8_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop 1
  end if

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + i4_huge
  end if

  r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10

  return
end
subroutine r8mat_print ( m, n, a, title )

!*****************************************************************************80
!
!! R8MAT_PRINT prints an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows in A.
!
!    Input, integer ( kind = 4 ) N, the number of columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = * ) title

  call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

  return
end
subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

!*****************************************************************************80
!
!! R8MAT_PRINT_SOME prints some of an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 March 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
!
!    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
!
!    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
!
!    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ), parameter :: incx = 5
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = 14 ) ctemp(incx)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i2hi
  integer ( kind = 4 ) i2lo
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) inc
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j2
  integer ( kind = 4 ) j2hi
  integer ( kind = 4 ) j2lo
  integer ( kind = 4 ) jhi
  integer ( kind = 4 ) jlo
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )

  do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

    j2hi = j2lo + incx - 1
    j2hi = min ( j2hi, n )
    j2hi = min ( j2hi, jhi )

    inc = j2hi + 1 - j2lo

    write ( *, '(a)' ) ' '

    do j = j2lo, j2hi
      j2 = j + 1 - j2lo
      write ( ctemp(j2), '(i8,6x)' ) j
    end do

    write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
    write ( *, '(a)' ) '  Row'
    write ( *, '(a)' ) ' '

    i2lo = max ( ilo, 1 )
    i2hi = min ( ihi, m )

    do i = i2lo, i2hi

      do j2 = 1, inc

        j = j2lo - 1 + j2

        if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
          write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
        else
          write ( ctemp(j2), '(g14.6)' ) a(i,j)
        end if

      end do

      write ( *, '(i5,1x,5a14)' ) i, ( ctemp(j), j = 1, inc )

    end do

  end do

  return
end
subroutine r8vec_print ( n, a, title )

!*****************************************************************************80
!
!! R8VEC_PRINT prints an R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 August 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of components of the vector.
!
!    Input, real ( kind = 8 ) A(N), the vector to be printed.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  integer ( kind = 4 ) i
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )
  write ( *, '(a)' ) ' '
  do i = 1, n
    write ( *, '(2x,i8,2x,g16.8)' ) i, a(i)
  end do

  return
end
subroutine r8vec_swap ( n, a1, a2 )

!*****************************************************************************80
!
!! R8VEC_SWAP swaps the entries of two R8VECs.
!
!  Discussion:
!
!    An R8VEC is a vector of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    04 December 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the arrays.
!
!    Input/output, real ( kind = 8 ) A1(N), A2(N), the vectors to swap.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a1(n)
  real ( kind = 8 ) a2(n)
  real ( kind = 8 ) a3(n)

  a3(1:n) = a1(1:n)
  a1(1:n) = a2(1:n)
  a2(1:n) = a3(1:n)

  return
end
subroutine svsort ( n, d, v )

!*****************************************************************************80
!
!! SVSORT descending sorts singular values D and adjusts V.
!
!  Discussion:
!
!    A simple bubble sort is used on D.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    25 February 2002
!
!  Author:
!
!    Original FORTRAN77 version by Richard Brent.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Richard Brent,
!    Algorithms for Minimization with Derivatives,
!    Prentice Hall, 1973,
!    Reprinted by Dover, 2002.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the length of D, and the order of V.
!
!    Input/output, real ( kind = 8 ) D(N), the vector to be sorted.
!    On output, the entries of D are in descending order.
!
!    Input/output, real ( kind = 8 ) V(N,N), an N by N array to be adjusted
!    as D is sorted.  In particular, if the value that was in D(I) on input is
!    moved to D(J) on output, then the input column V(*,I) is moved to
!    the output column V(*,J).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) d(n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j2
  integer ( kind = 4 ) j3
  real ( kind = 8 ) t
  real ( kind = 8 ) v(n,n)

  do j = 1, n - 1

    j3 = j;
    do j2 = j + 1, n
      if ( d(j3) < d(j2) ) then
        j3 = j2
      end if
    end do

    t     = d(j)
    d(j)  = d(j3)
    d(j3) = t

    do i = 1, n
      t       = v(i,j)
      v(i,j)  = v(i,j3)
      v(i,j3) = t
    end do

  end do

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


SUBROUTINE Intplt3d(x,l,n,d,dm,idx,coe,ier)

!*************************************************
!  This routine computes an interpolation indices
!  and coefficients using bi-linear interpolation.
!
!  HISTORY: JAN. 2004 by YUANFU XIE.
!*************************************************

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: l(3),n(3)
  REAL,    INTENT(IN) :: x(3),d(3),dm(2,3)

  INTEGER, INTENT(OUT) :: idx(3),ier
  REAL,    INTENT(OUT) :: coe(3)

  ! Local variables:
  INTEGER :: i

  ier = 0
  ! Check in box?
  DO i=1,3
     IF (x(i) .LT. dm(1,i)) ier = -i
     IF (x(i) .GT. dm(2,i)) ier = i
  ENDDO

  ! Indices:
  idx = (x-dm(1,1:3))/d

  ! Coefficients:
  coe = (x-idx*d-dm(1,1:3))/d

  idx = idx+1

END SUBROUTINE Intplt3d