!
! This program takes a 3-d cartesian plotfile and calculates
! the actual, adiabatic, and ledoux thermodynamic gradients.
!
! The actual thermodynamic gradient is computed along the
! radial direction, constructed from gradients along
! the cartesian coordinate directions.
!
! See MAESTRO/docs/thermo_notes for details.
!

program fconv_radial

  use bl_space, only: MAX_SPACEDIM
  use bl_error_module
  use bl_types
  use bl_constants_module, only: ZERO, HALF
  use bl_IO_module
  use plotfile_module
  use multifab_module
  use network
  use eos_module
  use eos_type_module
  use omp_module

  implicit none

  ! argument variables
  character(len=256) :: pltfile, outputfile
  real(kind=dp_t) :: low_cutoff

  ! f2kcli variables
  integer :: narg, farg
  character(len=256) :: fname

  ! local variables
  type(plotfile) :: pf
  type(layout) :: la
  type(boxarray) :: ba
  type(list_box) :: bl
  type(box) :: pd
  integer :: rr
  integer, allocatable :: ref_ratio(:)
  real(kind=dp_t),dimension(MAX_SPACEDIM) :: prob_lo, prob_hi
  real(kind=dp_t) :: time
  type(multifab), allocatable :: conv_grad(:)

  integer :: uin
  integer :: dim, nlevs
  integer :: i, j, n, ii, jj, kk
  real(kind=dp_t) :: xctr, yctr, zctr ! center coordinates
  real(kind=dp_t) :: xpos, ypos, zpos, rpos ! relative to center
  real(kind=dp_t) :: xx, yy, zz ! relative to domain
  real(kind=dp_t) :: dxx, dyy, dzz, drr
  real(kind=dp_t), dimension(MAX_SPACEDIM) :: dx
  integer, dimension(MAX_SPACEDIM) :: flo, fhi, lo, hi
  real(kind=dp_t), pointer :: p(:,:,:,:), ap(:,:,:,:)
  real(kind=dp_t), allocatable :: pres(:,:,:)
  real(kind=dp_t) :: chi_rho, chi_t, nabla
  real(kind=dp_t) :: chi_X(nspec), dXdP(nspec)
  real(kind=dp_t) :: dtdxx, dtdyy, dtdzz, dtdrr
  real(kind=dp_t) :: dpdxx, dpdyy, dpdzz, dpdrr
  real(kind=dp_t) :: dxdxx(nspec), dxdyy(nspec), dxdzz(nspec), dxdrr(nspec)

  type(eos_t) :: eos_state

  integer :: dens_comp, spec_comp, temp_comp
  integer :: actl_comp, adic_comp, ledx_comp

  character(len=20) :: component_names(3)

  real(kind=dp_t), parameter :: small = 1.e-14

  ! For AMReX, disable nested parallel regions
  if (omp_get_max_threads() > 1) call omp_set_nested(.false.)

  ! Set unit for input plotfile
  uin = unit_new()

  ! defaults
  pltfile = ''
  outputfile = 'conv_radial'
  low_cutoff = 1.e4

  component_names(1) = "actual gradient"
  component_names(2) = "adiabatic gradient"
  component_names(3) = "ledoux gradient"

  ! parse the arguements
  narg = command_argument_count()

  farg = 1
  do while (farg <= narg)
     call get_command_argument(farg, value = fname)

     select case(fname)

     case ('-i', '--input')
        farg = farg + 1
        call get_command_argument(farg, value = pltfile)

     case ('-o', '--output')
        farg = farg + 1
        call get_command_argument(farg, value = outputfile)

     case ('-l', '--low_cutoff')
        farg = farg + 1
        call get_command_argument(farg, value = fname)
        read(fname,*) low_cutoff

     case default
        exit

     end select
     farg = farg + 1
  enddo

  ! sanity check
  if (pltfile == '') then
     call print_usage()
     stop
  endif

  print *, 'working on pltfile:', pltfile
  print *, 'dumping data to file: ', outputfile
  print *, 'using low density cutoff:', low_cutoff

  call network_init()
  call eos_init()

  ! build the input plotfile
  call build(pf, pltfile, uin)

  nlevs = pf%flevel
  dim = pf%dim

  dens_comp = plotfile_var_index(pf, "density")
  ! For the URCA-simple network
  spec_comp = plotfile_var_index(pf, "X(n)")
  ! For the Chamulak network
  ! spec_comp = plotfile_var_index(pf, "X(C12)")
  temp_comp = plotfile_var_index(pf, "tfromp")

  actl_comp = 1
  adic_comp = 2
  ledx_comp = 3

  if (dens_comp < 0 .or. spec_comp < 0 .or. temp_comp < 0) &
       call bl_error("Variables not found")

  allocate(ref_ratio(nlevs-1),conv_grad(nlevs))

  ! get the index bounds for the finest level
  flo(1:dim) = lwb(plotfile_get_pd_box(pf, nlevs))
  fhi(1:dim) = upb(plotfile_get_pd_box(pf, nlevs))

  ! get dx for the coarse level.
  dx = plotfile_get_dx(pf, 1)

  ! the default for the center of the star will be the geometric center
  ! of the domain
  xctr = HALF*(pf%phi(1) + pf%plo(1))
  yctr = HALF*(pf%phi(2) + pf%plo(2))
  zctr = HALF*(pf%phi(3) + pf%plo(3))

  allocate(pres(flo(1):fhi(1), flo(2):fhi(2), flo(3):fhi(3)))

  ! define the ref ratios
  do i = 1, nlevs-1
     ref_ratio(i) = pf%refrat(i,1)
  enddo

  do i = 1, pf%flevel
     do j = 1, nboxes(pf,i)
        call push_back(bl,get_box(pf,i,j))
     enddo

     call build(ba,bl)

     call layout_build_ba(la, ba, boxarray_bbox(ba))

     call destroy(bl)
     call destroy(ba)

     ! build the mutifab with 0 ghost cells and 3 components
     ! component 1: actual convective gradient
     ! component 2: adiabatic gradient condition
     ! component 3: ledoux gradient condition
     call multifab_build(conv_grad(i),la,3,0)

  enddo

  ! loop over the plotfile data starting at the first
  do i = pf%flevel, 1, -1

     ! rr is the factor between the COARSEST level grid spacing and
     ! the current level
     rr = product(pf%refrat(1:i-1,1))

     ! loop over each box at this level
     do j = 1, nboxes(pf, i)

        ! read in the data 1 patch at a time
        call fab_bind(pf, i, j)

        ! get the integer bounds of the current box, in terms of this
        ! level's index space
        lo(1:dim) = lwb(get_box(pf,i,j))
        hi(1:dim) = upb(get_box(pf,i,j))

        ! pointers to the plotfile data and the conv_grad data
        p => dataptr(pf, i, j)
        ap => dataptr(conv_grad(i), j)

        ! do a first 3D loop through the data to initialize pressure array
        ! for finite differencing in the next 3D loop
        !$OMP PARALLEL DO PRIVATE(kk, jj, ii, eos_state) &
        !$OMP SCHEDULE(DYNAMIC,1)
        do kk = lo(3), hi(3)
           do jj = lo(2), hi(2)
              do ii = lo(1), hi(1)

                 eos_state % rho = p(ii,jj,kk,dens_comp)
                 eos_state % T = p(ii,jj,kk,temp_comp)
                 eos_state % xn(:) = p(ii,jj,kk,spec_comp:spec_comp+nspec-1)

                 call eos(eos_input_rt, eos_state)

                 pres(ii,jj,kk) = eos_state % p

              enddo
           enddo
        enddo
        !$OMP END PARALLEL DO

        !$OMP PARALLEL DO PRIVATE(kk, dzz, zz, jj, dyy, yy, ii, dxx, xx) &
        !$OMP PRIVATE(eos_state, chi_rho, chi_t, chi_X, dXdP, n, nabla) &
        !$OMP PRIVATE(dtdxx, dpdxx, dxdxx) &
        !$OMP PRIVATE(dtdyy, dpdyy, dxdyy) &
        !$OMP PRIVATE(dtdzz, dpdzz, dxdzz) &
        !$OMP PRIVATE(dtdrr, dpdrr, dxdrr) &
        !$OMP PRIVATE(xpos, ypos, zpos, rpos, drr) &
        !$OMP SCHEDULE(DYNAMIC,1)
        do kk = lo(3), hi(3)
           dzz = dx(3)/rr
           zz = (kk + HALF)*dzz

           do jj = lo(2), hi(2)
              dyy = dx(2)/rr
              yy = (jj + HALF)*dyy

              do ii = lo(1), hi(1)
                 dxx = dx(1)/rr
                 xx = (ii + HALF)*dxx

                 eos_state % rho = p(ii,jj,kk,dens_comp)
                 eos_state % T = p(ii,jj,kk,temp_comp)
                 eos_state % xn(:) = p(ii,jj,kk,spec_comp:spec_comp+nspec-1)

                 call eos(eos_input_rt, eos_state)

                 ! The previous 3D loop has already stored the pressure

                 chi_rho = eos_state % rho * eos_state % dPdr / eos_state % p
                 chi_t   = eos_state % T * eos_state % dPdT / eos_state % p

                 ! calculate adiabatic gradient
                 ap(ii,jj,kk,adic_comp) = (eos_state % gam1 - chi_rho) / (eos_state % gam1 * chi_t)

                 ! calculate actual gradient
                 ! Here the derivative dt/dp will be calculated radially
                 ! by determining dt/dr and dp/dr and dividing (dt/dr)/(dp/dr)
                 ! The derivative dX/dp will be similarly computed.

                 ! calculate gradients along x
                 if (ii==lo(1)) then
                    ! forward difference
                    dtdxx = p(ii+1,jj,kk,temp_comp) - p(ii,jj,kk,temp_comp)
                    dpdxx = pres(ii+1,jj,kk) - pres(ii,jj,kk)
                    dxdxx(:) = p(ii+1,jj,kk,spec_comp:spec_comp+nspec-1) - p(ii,jj,kk,spec_comp:spec_comp+nspec-1)
                    dpdxx = dpdxx/dxx
                    dtdxx = dtdxx/dxx
                    dxdxx(:) = dxdxx(:)/dxx
                 else if (ii == hi(1)) then
                    ! backward difference
                    dtdxx = p(ii,jj,kk,temp_comp) - p(ii-1,jj,kk,temp_comp)
                    dpdxx = pres(ii,jj,kk) - pres(ii-1,jj,kk)
                    dxdxx(:) = p(ii,jj,kk,spec_comp:spec_comp+nspec-1) - p(ii-1,jj,kk,spec_comp:spec_comp+nspec-1)
                    dpdxx = dpdxx/dxx
                    dtdxx = dtdxx/dxx
                    dxdxx(:) = dxdxx(:)/dxx
                 else
                    ! centered difference
                    dtdxx = p(ii+1,jj,kk,temp_comp) - p(ii-1,jj,kk,temp_comp)
                    dpdxx = pres(ii+1,jj,kk) - pres(ii-1,jj,kk)
                    dxdxx(:) = p(ii+1,jj,kk,spec_comp:spec_comp+nspec-1) - p(ii-1,jj,kk,spec_comp:spec_comp+nspec-1)
                    dpdxx = HALF*dpdxx/dxx
                    dtdxx = HALF*dtdxx/dxx
                    dxdxx(:) = HALF*dxdxx(:)/dxx
                 endif

                 ! calculate gradients along y
                 if (jj==lo(2)) then
                    ! forward difference
                    dtdyy = p(ii,jj+1,kk,temp_comp) - p(ii,jj,kk,temp_comp)
                    dpdyy = pres(ii,jj+1,kk) - pres(ii,jj,kk)
                    dxdyy(:) = p(ii,jj+1,kk,spec_comp:spec_comp+nspec-1) - p(ii,jj,kk,spec_comp:spec_comp+nspec-1)
                    dpdyy = dpdyy/dyy
                    dtdyy = dtdyy/dyy
                    dxdyy(:) = dxdyy(:)/dyy
                 else if (jj == hi(2)) then
                    ! backward difference
                    dtdyy = p(ii,jj,kk,temp_comp) - p(ii,jj-1,kk,temp_comp)
                    dpdyy = pres(ii,jj,kk) - pres(ii,jj-1,kk)
                    dxdyy(:) = p(ii,jj,kk,spec_comp:spec_comp+nspec-1) - p(ii,jj-1,kk,spec_comp:spec_comp+nspec-1)
                    dpdyy = dpdyy/dyy
                    dtdyy = dtdyy/dyy
                    dxdyy(:) = dxdyy(:)/dyy
                 else
                    ! centered difference
                    dtdyy = p(ii,jj+1,kk,temp_comp) - p(ii,jj-1,kk,temp_comp)
                    dpdyy = pres(ii,jj+1,kk) - pres(ii,jj-1,kk)
                    dxdyy(:) = p(ii,jj+1,kk,spec_comp:spec_comp+nspec-1) - p(ii,jj-1,kk,spec_comp:spec_comp+nspec-1)
                    dpdyy = HALF*dpdyy/dyy
                    dtdyy = HALF*dtdyy/dyy
                    dxdyy(:) = HALF*dxdyy(:)/dyy
                 endif

                 ! calculate gradients along z
                 if (kk==lo(3)) then
                    ! forward difference
                    dtdzz = p(ii,jj,kk+1,temp_comp) - p(ii,jj,kk,temp_comp)
                    dpdzz = pres(ii,jj,kk+1) - pres(ii,jj,kk)
                    dxdzz(:) = p(ii,jj,kk+1,spec_comp:spec_comp+nspec-1) - p(ii,jj,kk,spec_comp:spec_comp+nspec-1)
                    dpdzz = dpdzz/dzz
                    dtdzz = dtdzz/dzz
                    dxdzz(:) = dxdzz(:)/dzz
                 else if (kk == hi(3)) then
                    ! backward difference
                    dtdzz = p(ii,jj,kk,temp_comp) - p(ii,jj,kk-1,temp_comp)
                    dpdzz = pres(ii,jj,kk) - pres(ii,jj,kk-1)
                    dxdzz(:) = p(ii,jj,kk,spec_comp:spec_comp+nspec-1) - p(ii,jj,kk-1,spec_comp:spec_comp+nspec-1)
                    dpdzz = dpdzz/dzz
                    dtdzz = dtdzz/dzz
                    dxdzz(:) = dxdzz(:)/dzz
                 else
                    ! centered difference
                    dtdzz = p(ii,jj,kk+1,temp_comp) - p(ii,jj,kk-1,temp_comp)
                    dpdzz = pres(ii,jj,kk+1) - pres(ii,jj,kk-1)
                    dxdzz(:) = p(ii,jj,kk+1,spec_comp:spec_comp+nspec-1) - p(ii,jj,kk-1,spec_comp:spec_comp+nspec-1)
                    dpdzz = HALF*dpdzz/dzz
                    dtdzz = HALF*dtdzz/dzz
                    dxdzz(:) = HALF*dxdzz(:)/dzz
                 endif

                 ! calculate position relative to center of star
                 xpos = xx - xctr
                 ypos = yy - yctr
                 zpos = zz - zctr
                 rpos = sqrt(xpos**2 + ypos**2 + zpos**2)
                 drr = sqrt(dxx**2 + dyy**2 + dzz**2)

                 ! now calculate radial gradients
                 dtdrr = dtdxx * xpos/rpos + dtdyy * ypos/rpos + dtdzz * zpos/rpos
                 dpdrr = dpdxx * xpos/rpos + dpdyy * ypos/rpos + dpdzz * zpos/rpos
                 dxdrr = dxdxx(:) * xpos/rpos + dxdyy(:) * ypos/rpos + dxdzz(:) * zpos/rpos

                 ! actual gradient
                 if (p(ii,jj,kk,dens_comp) <= low_cutoff .or. abs(dpdrr*drr) <= small) then
                    nabla = ZERO
                    dXdP  = ZERO
                 else
                    nabla = pres(ii,jj,kk) * dtdrr / (dpdrr * p(ii,jj,kk,temp_comp))
                    dXdP(:) = dxdrr(:)/dpdrr
                 endif

                 ap(ii,jj,kk,actl_comp) = nabla

                 ! calculate ledoux gradient

                 ! initialize ledoux nabla to adiabatic nabla
                 nabla = ap(ii,jj,kk,adic_comp)

                 ! add species contributions
                 chi_X(:) = eos_state % xn(:) * eos_state % dPdX(:) / (eos_state % p * chi_t)

                 do n = 1, nspec
                    if (p(ii,jj,kk,spec_comp+n-1) > ZERO) then
                       nabla = nabla - &
                            chi_X(n) * pres(ii,jj,kk) * dXdP(n) &
                            / p(ii,jj,kk,spec_comp+n-1)
                    endif
                 enddo

                 ap(ii,jj,kk,ledx_comp) = nabla

              enddo
           enddo
        enddo
        !$OMP END PARALLEL DO

        call fab_unbind(pf, i,j)

     enddo
  enddo

  pd = plotfile_get_pd_box(pf,1)
  prob_lo(1:dim) = pf%plo
  prob_hi(1:dim) = pf%phi
  time = plotfile_time(pf)

  call fabio_ml_multifab_write_d(conv_grad, ref_ratio, trim(outputfile), &
                                 component_names, pd, &
                                 prob_lo(1:dim), prob_hi(1:dim), time, &
                                 dx(1:dim))

  call destroy(pf)
  deallocate(pres)
  deallocate(ref_ratio)
  deallocate(conv_grad)

contains
  subroutine print_usage()
    implicit none

    print *, 'This program takes a 3-d cartesian plotfile and calculates'
    print *, 'the actual, adiabatic, and ledoux thermodynamic gradients.'
    print *, ''
    print *, 'The actual thermodynamic gradient is computed along the'
    print *, 'radial direction, constructed from gradients along'
    print *, 'the cartesian coordinate directions.'
    print *, ''
    print *, ' calling sequence: '
    print *, ' fconv_radial -i <inputfile> [-o <outputfile>, -l <cutoff>]'
    print *, ''
    print *, ' arguments:'
    print *, '-i | --input:'
    print *, '     specify the input plotfile used to calculate the adiabatic'
    print *, '     excess.  required.'
    print *, '-o | --output:'
    print *, '     specify the output filename for the adiabatic excess.'
    print *, '     defaults to "conv_radial"'
    print *, '-l | --low_cutoff:'
    print *, '     specifies the low density cutoff.  for densities below the'
    print *, '     low density cutoff, the actual thermal gradient is set to'
    print *, '     ZERO.  defaults to 1.e4.'
    print *, ''

  end subroutine print_usage

end program fconv_radial


c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   Wiener filter x according to spectrum a
c   (routine needed by surrogates.f)
C   author Thomas Schreiber (1998)
c===========================================================================
      function tospec(nmax,a,x,ibin)
      parameter(nx=1000000)
      dimension x(nmax), a(nmax), w(nx), w1(nx), w2(nx), iw(15)
      save w2, iw

      if(nmax.gt.nx) stop "tospec: make nx larger."
      do 10 n=1,nmax
 10      w(n)=x(n)
      call rffti1(nmax,w2,iw)
      call rfftf1(nmax,x,w1,w2,iw)
      do 20 n=1,nmax
 20      x(n)=x(n)/real(nmax)
      x(1)=x(1)*(a(1)/x(1)**2)
      do 30 i=2+ibin,(nmax+1)/2-ibin,2*ibin+1
         p=0
         do 40 ib=i-ibin,i+ibin
 40         p=p+x(2*ib-2)**2+x(2*ib-1)**2
         ab=a(2*i-2)/p
         do 30 ib=i-ibin,i+ibin
            x(2*ib-2)=x(2*ib-2)*ab
 30         x(2*ib-1)=x(2*ib-1)*ab
      if(mod(nmax,2).eq.0) x(nmax)=x(nmax)*(a(nmax)/x(nmax)**2)
      call rfftb1(nmax,x,w1,w2,iw)
      tospec=0
      do 50 n=1,nmax
 50      tospec=tospec+(x(n)-w(n))**2
      tospec=sqrt(tospec/nmax)
      end


module compute_h_mod
  use kind_params_mod
  use kernel_mod
  use argument_mod
  use grid_mod
  use field_mod
  implicit none

  private

  public invoke_compute_h
  public compute_h, compute_h_code

  type, extends(kernel_type) :: compute_h
     type(go_arg), dimension(4) :: meta_args =      &
          (/ go_arg(GO_WRITE, GO_CT, GO_POINTWISE), & ! h
             go_arg(GO_READ,  GO_CT, GO_POINTWISE), & ! p
             go_arg(GO_READ,  GO_CU, GO_POINTWISE), & ! u
             go_arg(GO_READ,  GO_CV, GO_POINTWISE)  & ! v
           /)
     !> This kernel writes only to internal points of the
     !! simulation domain.
     integer :: ITERATES_OVER = GO_INTERNAL_PTS

     !> Although the staggering of variables used in an Arakawa
     !! C grid is well defined, the way in which they are indexed is
     !! an implementation choice. This can be thought of as choosing
     !! which grid-point types have the same (i,j) index as a T
     !! point. This kernel assumes that the U,V and F points that
     !! share the same index as a given T point are those immediately
     !! to the South and West of it.
     integer :: index_offset = GO_OFFSET_SW

  contains
    procedure, nopass :: code => compute_h_code
  end type compute_h

contains

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

  subroutine invoke_compute_h(hfld, pfld, ufld, vfld)
    implicit none
    type(r2d_field), intent(inout) :: hfld
    type(r2d_field), intent(in)    :: pfld, ufld,vfld
    ! Locals
    integer :: I, J

    ! Note that we do not loop over the full extent of the field.
    ! Fields are allocated with extents (M+1,N+1).
    ! Presumably the extra row and column are needed for periodic BCs.
    ! We are updating a quantity on CT.
    ! This loop writes to h(1:M,1:N) so this looks like
    ! (using x to indicate a location that is written):
    !
    ! i=1   i=M
    !  o  o  o  o
    !  x  x  x  o   j=N
    !  x  x  x  o
    !  x  x  x  o   j=1

    ! Quantity H is defined as:
    !         H = P + 0.5(<u^2>_x + <v^2>_y)
    ! where <d>_x indicates average over field d in x direction.

    ! Original code looked like:
    !
    !     DO J=1,N
    !        DO I=1,M
    !           H(I,J) = P(I,J)+.25*(U(I+1,J)*U(I+1,J)+U(I,J)*U(I,J)     &
    !                               +V(I,J+1)*V(I,J+1)+V(I,J)*V(I,J))
    !        END DO
    !     END DO

    ! h(i,j) depends upon:
    !   p(i,j)                                : CT
    !   u(i,j), u(i+1,j)                      : CU
    !    => lateral CU neighbours of the CT pt being updated
    !   v(i,j), v(i,j+1)                      : CV
    !    => vertical CV neighbours of the CT pt being updated

    !   x-------vij+1---fi+1j+1
    !   |       |       |
    !   |       |       |
    !   uij-----Tij-----ui+1j
    !   |       |       |
    !   |       |       |
    !   fij-----vij-----fi+1j
    !   |       |       |
    !   |       |       |
    !   uij-1- -Tij-1---ui+1j-1
    !

    DO J=hfld%internal%ystart, hfld%internal%ystop, 1
       DO I=hfld%internal%xstart, hfld%internal%xstop, 1

          CALL compute_h_code(i, j, hfld%data, &
                              pfld%data, ufld%data, vfld%data)
       END DO
    END DO

  end subroutine invoke_compute_h

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

  SUBROUTINE compute_h_code(i, j, h, p, u, v)
    IMPLICIT none
    integer,  intent(in) :: I, J
    REAL(go_wp), INTENT(out), DIMENSION(:,:) :: h
    REAL(go_wp), INTENT(in),  DIMENSION(:,:) :: p, u, v

    H(I,J) = P(I,J)+.25d0*(U(I+1,J)*U(I+1,J)+U(I,J)*U(I,J) + &
                           V(I,J+1)*V(I,J+1)+V(I,J)*V(I,J))

  END SUBROUTINE compute_h_code

END MODULE compute_h_mod


C*******************
C
C	FIND ZERO CROSSING
C
	IZCNT = 0
	IL = 1
	IZ = IL
	  IF(NDATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,NDATA(IL),NDATA(IL+1)
	DO IL = 2,2047
	  IZ = IL
	  IF(NDATA(IL).EQ.0) PRINT*,'ZERO DATA',IL,NDATA(IL-1),
     1   NDATA(IL),NDATA(IL+1)
C		COUNT ALL CROSSINGS, POS TO NEG AND NEG TO POS
C	  IF(NDATA(IL)*NDATA(IL+1).LE.0) THEN
C	        IZCNT = IZCNT+1
C		S1 = NDATA(IL)
C		S2 = NDATA(IL+1)
C		ZCROSS(IZCNT) = IL + S1/(S1 - S2)
C	  ENDIF
C		COUNT ONLY POS TO NEG
	  IF(NDATA(IL).GT.0.AND.NDATA(IL+1).LE.0) THEN
	        IZCNT = IZCNT+1
		IF(IPROCESS.EQ.0) THEN
		  S1 = NDATA(IL)
		  S2 = NDATA(IL+1)
		ELSE
		  S1 = DATA(IL)
		  S2 = DATA(IL+1)
		ENDIF
		ZCROSS(IZCNT) = IL + S1/(S1 - S2)
	  ENDIF
	ENDDO
	DO N = 1,IZCNT-1
	  ZINT(N) = ZCROSS(N+1) - ZCROSS(N)
	  IF(ZINT(N).EQ.0.) PRINT*,'ZINT=0 AT ',N
	  IF(ZINT(N).EQ.0.) ZINT(N) = 1.E-6
	ENDDO
	print*,'zero crossings found',izcnt
	print*,'first 5',(zcross(kk),kk=1,5)
C


      INTEGER FUNCTION MC01SX( LB, UB, E, MANT )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the variation V of the exponents of a series of
C     non-zero floating-point numbers: a(j) = MANT(j) * beta**(E(j)),
C     where beta is the base of the machine representation of
C     floating-point numbers, i.e.,
C     V = max(E(j)) - min(E(j)), j = LB,...,UB and MANT(j) non-zero.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01GX by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION        ZERO
      PARAMETER               ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER                 LB, UB
C     .. Array Arguments ..
      INTEGER                 E(*)
      DOUBLE PRECISION        MANT(*)
C     .. Local Scalars ..
      INTEGER                 J, MAXE, MINE
C     .. Intrinsic Functions ..
      INTRINSIC               MAX, MIN
C     .. Executable Statements ..
C
      MAXE = E(LB)
      MINE = MAXE
C
      DO 20 J = LB + 1, UB
         IF ( MANT(J).NE.ZERO ) THEN
            MAXE = MAX( MAXE, E(J) )
            MINE = MIN( MINE, E(J) )
         END IF
   20 CONTINUE
C
      MC01SX = MAXE - MINE
C
      RETURN
C *** Last line of MC01SX ***
      END


! BSD 3-Clause License
!
! Copyright (c) 2020, Fabio Durastante
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
module psfun_quadrature_mod
!! This module computes the matrix-function vector product by means of the
!! approximation of \(f(A)\mathbf{x}\) based on quadrature formula, i.e.,
!! having computed the poles and the scalings of the formula solves \(N\) linear
!! systems to approximate the product.
  use psfun_base_quadrature_mod
  use psfun_d_quadrature_mod
  use psfun_z_quadrature_mod
end module psfun_quadrature_mod


program zero
double precision :: i, j
double complex :: z1, z2
i = 0.0D0
j = 0.0D0
z1 = (0.0D0,0.0D0)
z2 = (0.0D0,0.0D0)
write(*,*) 'When integers are used, we have 0^0 = ', 0**0
write(*,*) 'When double precision numbers are used, we have 0.0^0.0 = ', i**j
write(*,*) 'When complex numbers are used, we have (0.0+0.0i)^(0.0+0.0i) = ', z1**z2
end program


CS    REAL FUNCTION BESJ1(X)
      DOUBLE PRECISION FUNCTION BESJ1(X)
C--------------------------------------------------------------------
C
C This subprogram computes approximate values for Bessel functions
C   of the first kind of order zero for arguments  |X| <= XMAX
C   (see comments heading CALJY1).
C
C--------------------------------------------------------------------
      INTEGER JINT
CS    REAL
      DOUBLE PRECISION
     1   RESULT,X
C--------------------------------------------------------------------
      JINT=0
      CALL CALJY1(X,RESULT,JINT)
      BESJ1 = RESULT
      RETURN
C---------- Last card of BESJ1 ----------
      END


!	Gauss-Hermite quadrature points.  The ith point out of n.
real(kind=8) function gausspoint(i,n)
use gausstable
implicit none
integer,intent(in)::i,n
!	i is the point number and position is the table position.
!	n is the number of elements of th.
gausspoint=xgh(1,i+n*(n-1)/2)
return
end


!  matmat.f - matrix - matrix multiply,
!  simple self-scheduling version
   program main
   use mpi
   integer MAX_AROWS, MAX_ACOLS, MAX_BCOLS
   parameter (MAX_AROWS = 20, MAX_ACOLS = 1000, MAX_BCOLS = 20)
   double precision a(MAX_AROWS,MAX_ACOLS), b(MAX_ACOLS,MAX_BCOLS)
   double precision c(MAX_AROWS,MAX_BCOLS)
   double precision buffer(MAX_ACOLS), ans(MAX_BCOLS)
   double precision starttime, stoptime
   integer myid, master, numprocs, ierr, status(MPI_STATUS_SIZE)
   integer i, j, numsent, sender
   integer anstype, row, arows, acols, brows, bcols, crows, ccols
   call MPI_INIT(ierr)
   call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
   call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
   arows  = 10
   acols  = 20
   brows  = 20
   bcols  = 10
   crows  = arows
   ccols  = bcols
   master = 0
   ierr = MPE_INIT_LOG()
   if (myid .eq. 0) then
      ierr = MPE_DESCRIBE_STATE(1, 2, "Bcast", "red:vlines3")
      ierr = MPE_DESCRIBE_STATE(3, 4, "Compute","blue:gray3")
      ierr = MPE_DESCRIBE_STATE(5, 6, "Send",  "green:light_gray")
      ierr = MPE_DESCRIBE_STATE(7, 8, "Recv",  "yellow:gray")
   endif
   if (myid .eq. 0) then
!     master initializes and then dispatches
!     initialize a and b
      do i = 1,acols
         do j = 1,arows
            a(j,i) = i
         enddo
      enddo
      do i = 1,bcols
         do j = 1,brows
            b(j,i) = i
         enddo
      enddo
      numsent = 0
!     send a row of a to each other process; tag with row number
!     For simplicity, assume arows .ge. numprocs - 1
      do i = 1,numprocs-1
         do j = 1,acols
            buffer(j) = a(i,j)
         enddo
         ierr = MPE_LOG_EVENT(5, i, "send")
         call MPI_SEND(buffer, acols, MPI_DOUBLE_PRECISION, i, &
                       i, MPI_COMM_WORLD, ierr)
         ierr = MPE_LOG_EVENT(6, i, "sent")
         numsent = numsent+1
      enddo
      do i = 1,crows
         ierr = MPE_LOG_EVENT(7, i, "recv")
         call MPI_RECV(ans, ccols, MPI_DOUBLE_PRECISION, &
                       MPI_ANY_SOURCE, MPI_ANY_TAG, &
    	               MPI_COMM_WORLD, status, ierr)
         sender     = status(MPI_SOURCE)
         anstype    = status(MPI_TAG)
         ierr = MPE_LOG_EVENT(8, anstype, "recvd")
         do j = 1,ccols
            c(anstype,j) = ans(j)
         enddo
         if (numsent .lt. arows) then
            do j = 1,acols
               buffer(j) = a(numsent+1,j)
            enddo
            ierr = MPE_LOG_EVENT(5, i, "send")
            call MPI_SEND(buffer, acols, MPI_DOUBLE_PRECISION, &
                          sender, numsent+1, MPI_COMM_WORLD, ierr)
            ierr = MPE_LOG_EVENT(6, i, "sent")
            numsent = numsent+1
         else
            ierr = MPE_LOG_EVENT(5, 0, "send")
            call MPI_SEND(1.0, 1, MPI_DOUBLE_PRECISION, sender, &
                          0, MPI_COMM_WORLD, ierr)
            ierr = MPE_LOG_EVENT(6, 0, "sent")
         endif
      enddo
   else
!     slaves receive b, then compute rows of c until done message
      ierr = MPE_LOG_EVENT(1, 0, "bstart")
      do i = 1,bcols
         call MPI_BCAST(b(1,i), brows, MPI_DOUBLE_PRECISION, &
                        master, MPI_COMM_WORLD, ierr)
      enddo
      ierr = MPE_LOG_EVENT(2, 0, "bend")
      ierr = MPE_LOG_EVENT(7, i, "recv")
      do
         call MPI_RECV(buffer, acols, MPI_DOUBLE_PRECISION, master, &
                       MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
         if (status(MPI_TAG) .eq. 0) exit
         row = status(MPI_TAG)
         ierr = MPE_LOG_EVENT(8, row, "recvd")
         ierr = MPE_LOG_EVENT(3, row, "compute")
         do i = 1,bcols
            ans(i) = 0.0
            do j = 1,acols
               ans(i) = ans(i) + buffer(j)*b(j,i)
            enddo
         enddo
         ierr = MPE_LOG_EVENT(4, row, "computed")
         ierr = MPE_LOG_EVENT(5, row, "send")
         call MPI_SEND(ans, bcols, MPI_DOUBLE_PRECISION, master, &
                       row, MPI_COMM_WORLD, ierr)
         ierr = MPE_LOG_EVENT(6, row, "sent")
      enddo
   endif
   ierr = MPE_FINISH_LOG("pmatmat.log")
   call MPI_FINALIZE(ierr)
   end


program ch0509v2
    ! Using the Numeric Inquiry Functions with Integer Types
    use iso_fortran_env
    implicit none

    integer :: i
    integer(int8) :: i1
    integer(int16) :: i2
    integer(int32) :: i3
    integer(int64) :: i4

    print *, ' '
    print *, ' integer kind support'
    print *, ' kind            huge'
    print *, ' '
    print *, ' ', kind(i), ' ', huge(i)
    print *, ' ', kind(i1), ' ', huge(i1)
    print *, ' ', kind(i2), ' ', huge(i2)
    print *, ' ', kind(i3), ' ', huge(i3)
    print *, ' ', kind(i4), ' ', huge(i4)
    print *, ' '
end program


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C-------------------------------------------------------------     ************
C                                                                     ISMIN
C                                                                  ************
      INTEGER FUNCTION ISMIN(N,SX,INCX)

C        FINDS THE INDEX OF ELEMENT WITH MIN. VALUE.
C        JACK DONGARRA, LINPACK, 3/11/78.

      INTEGER I,INCX,IX,N
      REAL SX(*),SMIN

      ISMIN = 0
      IF (N .LT. 0) STOP
      IF (N .EQ. 0) RETURN
      ISMIN = 1
      IF (N .EQ. 1) RETURN
      IF (INCX .EQ. 1) GO TO 20

C        CODE FOR INCREMENT NOT EQUAL TO 1

      IX = 1
      IF (INCX .LE. 0) IX = (-N+1)*INCX + 1
      SMIN = SX(IX)
      IX = IX + INCX
      DO 10 I = 2,N,1
        IF (SX(IX) .GE. SMIN) GO TO 5
        ISMIN = I
        SMIN = SX(IX)
    5   IX = IX + INCX
   10 CONTINUE
      RETURN

C        CODE FOR INCREMENT EQUAL TO 1

   20 SMIN = SX(1)
      DO 30 I = 2,N,1
        IF (SX(I) .GE. SMIN) GO TO 30
        ISMIN = I
        SMIN = SX(I)
   30 CONTINUE
      RETURN
      END


program stock_crossover

  use mod_arrays, only: crossneg, crosspos, reverse
  use mod_io, only: read_stock

  implicit none

  character(len=4), allocatable :: symbols(:)
  character(len=:), allocatable :: time(:)
  real, allocatable :: open(:), high(:), low(:), close(:), adjclose(:), volume(:)
  integer :: fileunit, i, im, n
  integer, allocatable :: buy(:), sell(:)

  symbols = ['AAPL', 'AMZN', 'CRAY', 'CSCO', 'HPQ ',&
             'IBM ', 'INTC', 'MSFT', 'NVDA', 'ORCL']

  do n = 1, size(symbols)

    print *, 'Processing moving average crossover for ' // symbols(n)

    call read_stock('data/' // trim(symbols(n)) //  '.csv', time,&
      open, high, low, close, adjclose, volume)

    time = time(size(time):1:-1)
    adjclose = reverse(adjclose)

    buy = crosspos(adjclose, 30)
    sell = crossneg(adjclose, 30)

    open(newunit=fileunit, file=trim(symbols(n)) // '_crossover.txt')
    do i = 1, size(buy)
      write(fileunit, fmt=*) 'Buy ', time(buy(i))
    end do
    do i = 1, size(sell)
      write(fileunit, fmt=*) 'Sell ', time(sell(i))
    end do
    close(fileunit)

  end do

end program stock_crossover


module covariance
implicit none

integer, private, save :: curpos

contains

subroutine clear_cov_counter
   curpos = 0
end subroutine clear_cov_counter

subroutine store_covariance(wk,Nwk,vec,mat,N,full)
   implicit none
   integer :: i,j,N,full,Nwk
   double precision :: wk(Nwk), mat(N*(N+1)/2), vec(N)

   wk((curpos+1) : (curpos + N)) = vec

   curpos = curpos + N

   if (full == 0) then
      i=1
      do j=1,N
         wk(CURPOS+J) = DSQRT(mat(i))
         i=i+N-j+1
      end do
      curpos = curpos + N
   else
      wk((curpos + 1) : (curpos + (N*(N+1)/2))) = mat
      curpos = curpos + (N*(N+1)/2)
   end if

end subroutine store_covariance

end module covariance


!#######################################################################
      SUBROUTINE DIAG(N,A,NA,D,E)
!#######################################################################
!
! diagonalize the N by N symmetric matrix A, returning ordered
! eigenvalues in D and eigenvectors as columns of A; E is a workspace
      IMPLICIT none
      integer :: N,NA
      REAL*8 :: A(N,N),D(N),E(N)
      integer :: ierr=0

! TRED2 to tridiagonalise A, TQL2 to obtain eigenvalues and vectors,
! SORT2 to put them both in increasing order of eigenvalue
      CALL TRED2(A,N,NA,D,E)
      CALL TQL2(N,NA,D,E,A,ierr)
      if(ierr.ne.0) stop 'probleme: base d elongation'
      CALL SORT2(N,D,A,NA)

      RETURN
      END
!-----------------------------------------------------------------------
!
! ######################################################################
      SUBROUTINE TRED2(A,N,NP,D,E)
!#######################################################################
!
! this routine is copied direct from NR, except for the IMPLICIT
! statement and corresponding replacements of 0. by 0D0
!
! Householder reduction of a real, symmetric, N by N matrix A, stored in
! an NP by NP physical array.  On output, A is replaced by the
! orthogonal matrix Q effecting the transformation.  D returns the
! diagonal elements of the tridiagonal matrix, and E the off-diagonal
! elements, with E(1)=0.  Several statements, as noted in comments, can
! be omitted if only eigenvalues are to be found, in which case A
! contains no useful information on output.  Otherwise they are to be
! included.
      IMPLICIT none
      integer :: I,J,K,L,N,NP
      real*8 :: SCALE,F,G,H,HH
      REAL*8 :: A(N,N),D(N),E(N)

      DO 18 I=N,2,-1
       L=I-1
       H=0D0
       SCALE=0D0
       IF(L.GT.1) THEN
        DO 11 K=1,L
         SCALE=SCALE+ABS(A(I,K))
11      CONTINUE
        IF(SCALE.EQ.0D0) THEN
         E(I)=A(I,L)
        ELSE
         DO 12 K=1,L
          A(I,K)=A(I,K)/SCALE
          H=H+A(I,K)**2
12       CONTINUE
         F=A(I,L)
         G=-SIGN(SQRT(H),F)
         E(I)=SCALE*G
         H=H-F*G
         A(I,L)=F-G
         F=0D0
         DO 15 J=1,L
! Omit following line if finding only eigenvalues
          A(J,I)=A(I,J)/H
          G=0D0
          DO 13 K=1,J
           G=G+A(J,K)*A(I,K)
13        CONTINUE
          DO 14 K=J+1,L
           G=G+A(K,J)*A(I,K)
14        CONTINUE
          E(J)=G/H
          F=F+E(J)*A(I,J)
15       CONTINUE
         HH=F/(H+H)
         DO 17 J=1,L
          F=A(I,J)
          G=E(J)-HH*F
          E(J)=G
          DO 16 K=1,J
           A(J,K)=A(J,K)-F*E(K)-G*A(I,K)
16        CONTINUE
17       CONTINUE
        ENDIF
       ELSE
        E(I)=A(I,L)
       ENDIF
       D(I)=H
18    CONTINUE
! Omit following line if finding only eigenvalues
      D(1)=0D0
      E(1)=0D0
      DO 23 I=1,N
! Delete lines from here ...
       L=I-1
       IF(D(I).NE.0D0) THEN
        DO 21 J=1,L
         G=0D0
         DO 19 K=1,L
          G=G+A(I,K)*A(K,J)
19       CONTINUE
         DO 20 K=1,L
          A(K,J)=A(K,J)-G*A(K,I)
20       CONTINUE
21      CONTINUE
       ENDIF
! ... to here when finding only eigenvalues
       D(I)=A(I,I)
! Also delete lines from here ...
       A(I,I)=1D0
       DO 22 J=1,L
        A(I,J)=0D0
        A(J,I)=0D0
22     CONTINUE
! ... to here when finding only eigenvalues
23    CONTINUE
      RETURN
      END
!-----------------------------------------------------------------------
!
      SUBROUTINE SORT2(N,RA,V,NV)
! ######################################################################
!
! sorts an array RA of length N into ascending numerical order using the
! Heapsort algorithm, and reorders the vectors y in V(x,y)
! correspondingly; WRK is a workspace
!
! this routine is copied direct from the NR routine SORT, except for the
! IMPLICIT statement and the STOP statement, and additional code to
! reorder the vectors
!
      IMPLICIT none
      integer :: N,NV,L,I,J,K,IR
      real*8 :: RRA
      REAL*8 :: RA(N),V(N,N),WRK(N)

      IF(N.LT.1) STOP'unnatural length in SORTE'
      L=N/2+1
      IR=N
10    CONTINUE
       IF(L.GT.1) THEN
        L=L-1
        RRA=RA(L)
        DO 1 K=1,N
         WRK(K)=V(K,L)
1       CONTINUE
       ELSE
        RRA=RA(IR)
        DO 2 K=1,N
         WRK(K)=V(K,IR)
2       CONTINUE
        RA(IR)=RA(1)
        DO 3 K=1,N
         V(K,IR)=V(K,1)
3       CONTINUE
        IR=IR-1
        IF(IR.EQ.1) THEN
         RA(1)=RRA
         DO 4 K=1,N
          V(K,1)=WRK(K)
4        CONTINUE
         RETURN
        ENDIF
       ENDIF
       I=L
       J=L+L
20     IF(J.LE.IR) THEN
        IF(J.LT.IR) THEN
         IF(RA(J).LT.RA(J+1))J=J+1
        ENDIF
        IF(RRA.LT.RA(J)) THEN
         RA(I)=RA(J)
         DO 5 K=1,N
          V(K,I)=V(K,J)
5        CONTINUE
         I=J
         J=J+J
        ELSE
         J=IR+1
        ENDIF
       GO TO 20
       ENDIF
       RA(I)=RRA
       DO 6 K=1,N
        V(K,I)=WRK(K)
6      CONTINUE
      GO TO 10
      END

!#######################################################################
!#######################################################################
!
      subroutine tql2(nm,n,d,e,z,ierr)

      implicit none
      integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
      real*8 d(n),e(n),z(nm,n)
      real*8 c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
!
!     this subroutine is a translation of the algol procedure tql2,
!     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
!     wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
!
!     this subroutine finds the eigenvalues and eigenvectors
!     of a symmetric tridiagonal matrix by the ql method.
!     the eigenvectors of a full symmetric matrix can also
!     be found if  tred2  has been used to reduce this
!     full matrix to tridiagonal form.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!!         array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        d contains the diagonal elements of the input matrix.
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary.
!
!        z contains the transformation matrix produced in the
!          reduction by  tred2, if performed.  if the eigenvectors
!          of the tridiagonal matrix are desired, z must contain
!          the identity matrix.
!
!      on output
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1,2,...,ierr-1.
!
!        e has been destroyed.
!
!        z contains orthonormal eigenvectors of the symmetric
!          tridiagonal (or full) matrix.  if an error exit is made,
!          z contains the eigenvectors associated with the stored
!          eigenvalues.
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
!     ------------------------------------------------------------------
!
      ierr = 0
      if (n .eq. 1) go to 1001
!
      do 100 i = 2, n
  100 e(i-1) = e(i)
!
      f = 0.0d0
      tst1 = 0.0d0
      e(n) = 0.0d0
!
      do 240 l = 1, n
         j = 0
         h = abs(d(l)) + abs(e(l))
         if (tst1 .lt. h) tst1 = h
!     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + abs(e(m))
            if (tst2 .eq. tst1) go to 120
!     .......... e(n) is always zero, so there is no exit
!                through the bottom of the loop ..........
  110    continue
!
  120    if (m .eq. l) go to 220
  130    if (j .eq. 30) go to 1000
         j = j + 1
!     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * e(l))
         r=sqrt(p*p+1.0d0)
         d(l) = e(l) / (p + sign(r,p))
         d(l1) = e(l) * (p + sign(r,p))
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
!
         do 140 i = l2, n
  140    d(i) = d(i) - h
!
  145    f = f + h
!     .......... ql transformation ..........
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r=sqrt(p*p+e(i)*e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
!     .......... form vector ..........
            do 180 k = 1, n
               h = z(k,i+1)
               z(k,i+1) = s * z(k,i) + c * h
               z(k,i) = c * z(k,i) - s * h
  180       continue
!
  200    continue
!
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + abs(e(l))
         if (tst2 .gt. tst1) go to 130
  220    d(l) = d(l) + f
  240 continue
!     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
         i = ii - 1
         k = i
         p = d(i)
!
         do 260 j = ii, n
            if (d(j) .ge. p) go to 260
            k = j
            p = d(j)
  260    continue
!
         if (k .eq. i) go to 300
         d(k) = d(i)
         d(i) = p
!
         do 280 j = 1, n
            p = z(j,i)
            z(j,i) = z(j,k)
            z(j,k) = p
  280    continue
!
  300 continue
!
      go to 1001
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
!#######################################################################
C
C David J. Heisterberg
C The Ohio Supercomputer Center
C 1224 Kinnear Rd.
C Columbus, OH  43212-1163
C (614)292-6036
C djh@ccl.net    djh@ohstpy.bitnet    ohstpy::djh
C
C ANALYZE
C analyze the x to y fit and the fitting matrix
C
      SUBROUTINE analyz (n, x, y, w, u)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER n
      DOUBLEPRECISION x (3, n)
      DOUBLEPRECISION y (3, n)
      DOUBLEPRECISION w (n)
      DOUBLEPRECISION u (3, 3)
C
      DOUBLEPRECISION err
      DOUBLEPRECISION wnorm
      DOUBLEPRECISION urnorm (3)
      DOUBLEPRECISION ucnorm (3)
      INTEGER i, j
C
C find the mean sum of squares error
C
      err = 0.0D0
      wnorm = 0.0D0
      DO 10000 i = 1, n
        err = err + w (i) * ((y (1, i) - x (1, i)) ** 2 +
     &                       (y (2, i) - x (2, i)) ** 2 +
     &                       (y (3, i) - x (3, i)) ** 2)
        wnorm = wnorm + w (i)
10000   CONTINUE
      err = SQRT (err / wnorm)
C
C find the row and column norms of u
C
      ucnorm (1) = u (1, 1) ** 2 + u (2, 1) ** 2 + u (3, 1) ** 2
      ucnorm (2) = u (1, 2) ** 2 + u (2, 2) ** 2 + u (3, 2) ** 2
      ucnorm (3) = u (1, 3) ** 2 + u (2, 3) ** 2 + u (3, 3) ** 2
      urnorm (1) = u (1, 1) ** 2 + u (1, 2) ** 2 + u (1, 3) ** 2
      urnorm (2) = u (2, 1) ** 2 + u (2, 2) ** 2 + u (2, 3) ** 2
      urnorm (3) = u (3, 1) ** 2 + u (3, 2) ** 2 + u (3, 3) ** 2
C
C write the error and u norms
C
      WRITE (*, *)
      DO 11000 i = 1, 3
        WRITE (*, 1000) (u (i, j), j = 1, 3), urnorm (i)
11000   CONTINUE
      WRITE (*, *)
      WRITE (*, 1000) (ucnorm (j), j = 1, 3), err
C
      RETURN
C
 1000 FORMAT (1X, 3E18.10, 4X, E18.10)
C
      END
C
C CENTER
C center a molecule about its weighted centroid or other origin
C
      SUBROUTINE center (n, x, w, io, o, t)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER n
      DOUBLEPRECISION x (3, n)
      DOUBLEPRECISION w (n)
      LOGICAL io
      DOUBLEPRECISION o (3)
      DOUBLEPRECISION t (3)
C
      DOUBLEPRECISION wnorm
      INTEGER i
C
      IF (io) THEN
        t (1) = o (1)
        t (2) = o (2)
        t (3) = o (3)
      ELSE
        t (1) = 0.0D0
        t (2) = 0.0D0
        t (3) = 0.0D0
        wnorm = 0.0D0
        DO 10000 i = 1, n
          t (1) = t (1) + x (1, i) * SQRT (w (i))
          t (2) = t (2) + x (2, i) * SQRT (w (i))
          t (3) = t (3) + x (3, i) * SQRT (w (i))
          wnorm = wnorm + SQRT (w (i))
10000     CONTINUE
        t (1) = t (1) / wnorm
        t (2) = t (2) / wnorm
        t (3) = t (3) / wnorm
      ENDIF
C
      DO 10100 i = 1, n
        x (1, i) = x (1, i) - t (1)
        x (2, i) = x (2, i) - t (2)
        x (3, i) = x (3, i) - t (3)
10100   CONTINUE
C
      RETURN
      END
C
C FITEST
C rigid fit test driver
C
c$$$      PROGRAM fitest
c$$$      IMPLICIT CHARACTER (A-Z)
c$$$C
c$$$      INTEGER n
c$$$      DOUBLEPRECISION angle
c$$$      DOUBLEPRECISION pert
c$$$      PARAMETER (n = 401)
c$$$      PARAMETER (angle = 1.0D0)
c$$$      PARAMETER (pert = 0.2D0)
c$$$C
c$$$      DOUBLEPRECISION y (3, n)
c$$$      DOUBLEPRECISION x (3, n)
c$$$      DOUBLEPRECISION z (3, n)
c$$$      DOUBLEPRECISION w (n)
c$$$      DOUBLEPRECISION o (3)
c$$$      DOUBLEPRECISION q (4)
c$$$      DOUBLEPRECISION u (3, 3)
c$$$      INTEGER ierr
c$$$C
c$$$C seed the random number generator
c$$$C call ranini for vax
c$$$C
c$$$      CALL ranset (123571)
c$$$*     CALL ranini ()
c$$$C
c$$$C generate reference and test molecules and weights
c$$$C
c$$$      CALL genxyw (angle, pert, n, x, y, w)
c$$$      CALL center (n, y, w, .FALSE., o, o)
c$$$      CALL center (n, x, w, .FALSE., o, o)
c$$$      CALL identm (3, 3, u)
c$$$      CALL analyz (n, x, y, w, u)
c$$$C
c$$$C fit x to y
c$$$C
c$$$      WRITE (*, *)
c$$$      WRITE (*, *) 'fitting x to y'
c$$$      CALL qtrfit (n, x, y, w, q, u, ierr)
c$$$      CALL rotmol (n, x, z, u)
c$$$      CALL analyz (n, z, y, w, u)
c$$$C
c$$$C fit y to x
c$$$C
c$$$      WRITE (*, *)
c$$$      WRITE (*, *) 'fitting y to x'
c$$$      CALL qtrfit (n, y, x, w, q, u, ierr)
c$$$      CALL rotmol (n, y, z, u)
c$$$      CALL analyz (n, z, x, w, u)
c$$$C
c$$$      END
c$$$C
C GENROT
C Generate a left rotation matrix from a normalized rotation axis
C and cosine and sine of the rotation angle.
C
C INPUT
C   a      - rotation axis
C   cost   - cosine of rotation angle
C   sint   - sine of rotation angle
C
C OUTPUT
C   u      - the rotation matrix
C
      SUBROUTINE genrot (a, cost, sint, u)
      IMPLICIT CHARACTER (A-Z)
C
      DOUBLEPRECISION a (3)
      DOUBLEPRECISION cost, sint
      DOUBLEPRECISION u (3, 3)
C
      u (1, 1) = a (1) ** 2 + (1.0D0 - a (1) ** 2) * cost
      u (2, 1) = a (1) * a (2) * (1.0D0 - cost) + a (3) * sint
      u (3, 1) = a (1) * a (3) * (1.0D0 - cost) - a (2) * sint
C
      u (1, 2) = a (1) * a (2) * (1.0D0 - cost) - a (3) * sint
      u (2, 2) = a (2) ** 2 + (1.0D0 - a (2) ** 2) * cost
      u (3, 2) = a (2) * a (3) * (1.0D0 - cost) + a (1) * sint
C
      u (1, 3) = a (1) * a (3) * (1.0D0 - cost) + a (2) * sint
      u (2, 3) = a (2) * a (3) * (1.0D0 - cost) - a (1) * sint
      u (3, 3) = a (3) ** 2 + (1.0D0 - a (3) ** 2) * cost
C
      RETURN
      END
C
C GENXYW
C generate random reference and test molecules and weights
C
      SUBROUTINE genxyw (angle, pert, n, x, y, w)
      IMPLICIT CHARACTER (A-Z)
C
      DOUBLEPRECISION angle
      DOUBLEPRECISION pert
      INTEGER n
      DOUBLEPRECISION x (3, n)
      DOUBLEPRECISION y (3, n)
      DOUBLEPRECISION w (n)
C
      DOUBLEPRECISION u (3, 3)
      INTEGER i
C
      DOUBLEPRECISION random
      EXTERNAL random
C
      CALL ranmol (n, y)
      CALL ranrot (angle, u)
      CALL rotmol (n, y, x, u)
      CALL pertur (pert, n, x)
      CALL ranrot (angle, u)
      CALL rotmol (n, x, x, u)
C
      DO 10000 i = 1, n
        w (i) = random ()
10000   CONTINUE
C
      RETURN
      END
C
C IDENTM
C generate an identity matrix
C
      SUBROUTINE identm (n, np, u)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER n, np
      DOUBLEPRECISION u (np, n)
C
      INTEGER i, j
C
      DO 10000 j = 1, n
        DO 10010 i = 1, n
          u (i, j) = 0.0D0
10010     CONTINUE
        u (j, j) = 1.0D0
10000   CONTINUE
C
      RETURN
      END
C
C JACOBI
C Jacobi diagonalizer with sorted output.  Same calling sequence as
C EISPACK routine, but must specify nrot!
C
      SUBROUTINE jacobi (a, n, np, d, v, nrot)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER n, np, nrot
      DOUBLEPRECISION a (np, n)
      DOUBLEPRECISION d (n)
      DOUBLEPRECISION v (np, n)
C
      DOUBLEPRECISION onorm, dnorm
      DOUBLEPRECISION b, dma, q, t, c, s
      DOUBLEPRECISION atemp, vtemp, dtemp
      INTEGER i, j, k, l
C
      DO 10000 j = 1, n
        DO 10010 i = 1, n
          v (i, j) = 0.0D0
10010     CONTINUE
        v (j, j) = 1.0D0
        d (j) = a (j, j)
10000   CONTINUE
C
      DO 20000 l = 1, nrot
        dnorm = 0.0D0
        onorm = 0.0D0
        DO 20100 j = 1, n
          dnorm = dnorm + ABS (d (j))
          DO 20110 i = 1, j - 1
            onorm = onorm + ABS (a (i, j))
20110       CONTINUE
20100     CONTINUE
        IF (onorm / dnorm .LE. 0.0D0) GOTO 19999
        DO 21000 j = 2, n
          DO 21010 i = 1, j - 1
            b = a (i, j)
            IF (ABS (b) .GT. 0.0D0) THEN
              dma = d (j) - d (i)
              IF (ABS (dma) + ABS (b) .LE. ABS (dma)) THEN
                t = b / dma
              ELSE
                q = 0.5D0 * dma / b
                t = SIGN (1.0D0 / (ABS (q) + SQRT (1.0D0 + q * q)), q)
              ENDIF
              c = 1.0D0 / SQRT (t * t + 1.0D0)
              s = t * c
              a (i, j) = 0.0D0
              DO 21110 k = 1, i - 1
                atemp    = c * a (k, i) - s * a (k, j)
                a (k, j) = s * a (k, i) + c * a (k, j)
                a (k, i) = atemp
21110           CONTINUE
              DO 21120 k = i + 1, j - 1
                atemp    = c * a (i, k) - s * a (k, j)
                a (k, j) = s * a (i, k) + c * a (k, j)
                a (i, k) = atemp
21120           CONTINUE
              DO 21130 k = j + 1, n
                atemp    = c * a (i, k) - s * a (j, k)
                a (j, k) = s * a (i, k) + c * a (j, k)
                a (i, k) = atemp
21130           CONTINUE
              DO 21140 k = 1, n
                vtemp    = c * v (k, i) - s * v (k, j)
                v (k, j) = s * v (k, i) + c * v (k, j)
                v (k, i) = vtemp
21140           CONTINUE
              dtemp = c * c * d (i) + s * s * d (j) -
     &                2.0D0 * c * s * b
              d (j) = s * s * d (i) + c * c * d (j) +
     &                2.0D0 * c * s * b
              d (i) = dtemp
              ENDIF
21010       CONTINUE
21000     CONTINUE
20000   CONTINUE
19999 CONTINUE
      nrot = l
C
      DO 30000 j = 1, n - 1
        k = j
        dtemp = d (k)
        DO 30100 i = j + 1, n
          IF (d (i) .LT. dtemp) THEN
            k = i
            dtemp = d (k)
            ENDIF
30100     CONTINUE
        IF (k .GT. j) THEN
          d (k) = d (j)
          d (j) = dtemp
          DO 30200 i = 1, n
            dtemp    = v (i, k)
            v (i, k) = v (i, j)
            v (i, j) = dtemp
30200       CONTINUE
          ENDIF
30000   CONTINUE
C
      RETURN
      END
C
C PERTUR
C apply a random perturbation
C
      SUBROUTINE pertur (pert, n, x)
      IMPLICIT CHARACTER (A-Z)
C
      DOUBLEPRECISION pert
      INTEGER n
      DOUBLEPRECISION x (3, n)
C
      INTEGER i, j
C
      DOUBLEPRECISION random
      EXTERNAL random
C
      DO 10000 j = 1, 3
        DO 10010 i = 1, n
          x (j, i) = x (j, i) *
     &               (1.0D0 + 2.0D0 * pert * (0.5D0 - random ()))
10010     CONTINUE
10000   CONTINUE
C
      RETURN
      END
C
C Q2MAT
C Generate a left rotation matrix from a normalized quaternion
C
C INPUT
C   q      - normalized quaternion
C
C OUTPUT
C   u      - the rotation matrix
C
      SUBROUTINE q2mat (q, u)
      IMPLICIT NONE
C
      DOUBLEPRECISION q (0 : 3)
      DOUBLEPRECISION u (3, 3)
C
      u (1, 1) = q (0) ** 2 + q (1) ** 2 - q (2) ** 2 - q (3) ** 2
      u (2, 1) = 2.0D0 * (q (1) * q (2) - q (0) * q (3))
      u (3, 1) = 2.0D0 * (q (1) * q (3) + q (0) * q (2))
C
      u (1, 2) = 2.0D0 * (q (2) * q (1) + q (0) * q (3))
      u (2, 2) = q (0) ** 2 - q (1) ** 2 + q (2) ** 2 - q (3) ** 2
      u (3, 2) = 2.0D0 * (q (2) * q (3) - q (0) * q (1))
C
      u (1, 3) = 2.0D0 * (q (3) * q (1) - q (0) * q (2))
      u (2, 3) = 2.0D0 * (q (3) * q (2) + q (0) * q (1))
      u (3, 3) = q (0) ** 2 - q (1) ** 2 - q (2) ** 2 + q (3) ** 2
C
      RETURN
      END
C
C QTRFIT
C Find the quaternion, q, [and left rotation matrix, u] that minimizes
C
C   |qTXq - Y| ^ 2    [|uX - Y| ^ 2]
C
C This is equivalent to maximizing Re (qTXTqY).
C
C This is equivalent to finding the largest eigenvalue and corresponding
C eigenvector of the matrix
C
C   [A2   AUx  AUy  AUz ]
C   [AUx  Ux2  UxUy UzUx]
C   [AUy  UxUy Uy2  UyUz]
C   [AUz  UzUx UyUz Uz2 ]
C
C where
C
C   A2   = Xx Yx + Xy Yy + Xz Yz
C   Ux2  = Xx Yx - Xy Yy - Xz Yz
C   Uy2  = Xy Yy - Xz Yz - Xx Yx
C   Uz2  = Xz Yz - Xx Yx - Xy Yy
C   AUx  = Xz Yy - Xy Yz
C   AUy  = Xx Yz - Xz Yx
C   AUz  = Xy Yx - Xx Yy
C   UxUy = Xx Yy + Xy Yx
C   UyUz = Xy Yz + Xz Yy
C   UzUx = Xz Yx + Xx Yz
C
C The left rotation matrix, u, is obtained from q by
C
C   u = qT1q
C
C INPUT
C   n      - number of points
C   x      - test vector
C   y      - reference vector
C   w      - weight vector
C
C OUTPUT
C   q      - the best-fit quaternion
C   u      - the best-fit left rotation matrix
C   nr     - number of jacobi sweeps required
C
      SUBROUTINE qtrfit (n, x, y, w, q, u, nr)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER n
      DOUBLEPRECISION x (3, n)
      DOUBLEPRECISION y (3, n)
      DOUBLEPRECISION w (n)
      DOUBLEPRECISION q (0 : 3)
      DOUBLEPRECISION u (3, 3)
      INTEGER nr
C
      DOUBLEPRECISION xxyx, xxyy, xxyz
      DOUBLEPRECISION xyyx, xyyy, xyyz
      DOUBLEPRECISION xzyx, xzyy, xzyz
      DOUBLEPRECISION c (0 : 3, 0 : 3), v (0 : 3, 0 : 3)
      DOUBLEPRECISION d (0 : 3)
      INTEGER i
C
C generate the upper triangle of the quadratic form matrix
C
      xxyx = 0.0D0
      xxyy = 0.0D0
      xxyz = 0.0D0
      xyyx = 0.0D0
      xyyy = 0.0D0
      xyyz = 0.0D0
      xzyx = 0.0D0
      xzyy = 0.0D0
      xzyz = 0.0D0
      DO 11000 i = 1, n
        xxyx = xxyx + x (1, i) * y (1, i) * w (i)
        xxyy = xxyy + x (1, i) * y (2, i) * w (i)
        xxyz = xxyz + x (1, i) * y (3, i) * w (i)
        xyyx = xyyx + x (2, i) * y (1, i) * w (i)
        xyyy = xyyy + x (2, i) * y (2, i) * w (i)
        xyyz = xyyz + x (2, i) * y (3, i) * w (i)
        xzyx = xzyx + x (3, i) * y (1, i) * w (i)
        xzyy = xzyy + x (3, i) * y (2, i) * w (i)
        xzyz = xzyz + x (3, i) * y (3, i) * w (i)
11000   CONTINUE
C
      c (0, 0) = xxyx + xyyy + xzyz
C
      c (0, 1) = xzyy - xyyz
      c (1, 1) = xxyx - xyyy - xzyz
C
      c (0, 2) = xxyz - xzyx
      c (1, 2) = xxyy + xyyx
      c (2, 2) = xyyy - xzyz - xxyx
C
      c (0, 3) = xyyx - xxyy
      c (1, 3) = xzyx + xxyz
      c (2, 3) = xyyz + xzyy
      c (3, 3) = xzyz - xxyx - xyyy
C
C diagonalize c
C
      nr = 16
      CALL jacobi (c, 4, 4, d, v, nr)
C
C extract the desired quaternion
C
      q (0) = v (0, 3)
      q (1) = v (1, 3)
      q (2) = v (2, 3)
      q (3) = v (3, 3)
C
C generate the rotation matrix
C

      CALL q2mat (q, u)
C
      RETURN
      END
C
C RANDOM
C random number generator after Knuth
C
      DOUBLEPRECISION FUNCTION random ()
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER ntable
      INTEGER im1, im2, im3
      INTEGER ia1, ia2, ia3
      INTEGER ic1, ic2, ic3
      DOUBLEPRECISION rm1, rm2, rm3
      PARAMETER (ntable = 97)
      PARAMETER (im1 = 714025, im2 = 214326, im3 = 139968)
      PARAMETER (ia1 = 1366,   ia2 = 3613,   ia3 = 3877)
      PARAMETER (ic1 = 150889, ic2 = 45289,  ic3 = 29573)
      PARAMETER (rm1 = 1.0D0 / im1)
      PARAMETER (rm2 = 1.0D0 / im2)
      PARAMETER (rm3 = 1.0D0 / im3)
C
      INTEGER iseed0, iseed1, iseed2, iseed3
      DOUBLEPRECISION r (ntable)
      INTEGER i
C
      COMMON /rtable/ iseed0, iseed1, iseed2, iseed3, r
      SAVE /rtable/
C
      iseed1 = MOD (ia1 * iseed1 + ic1, im1)
      iseed2 = MOD (ia2 * iseed2 + ic2, im2)
      iseed3 = MOD (ia3 * iseed3 + ic3, im3)
C
      i = 1 + (ntable * iseed3) * rm3
      random = r (i)
      r (i) = (iseed1 + iseed2 * rm2) * rm1
C
      RETURN
      END
      INTEGER FUNCTION ranget ()
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER ntable
      INTEGER im1, im2, im3
      INTEGER ia1, ia2, ia3
      INTEGER ic1, ic2, ic3
      DOUBLEPRECISION rm1, rm2, rm3
      PARAMETER (ntable = 97)
      PARAMETER (im1 = 714025, im2 = 214326, im3 = 139968)
      PARAMETER (ia1 = 1366,   ia2 = 3613,   ia3 = 3877)
      PARAMETER (ic1 = 150889, ic2 = 45289,  ic3 = 29573)
      PARAMETER (rm1 = 1.0D0 / im1)
      PARAMETER (rm2 = 1.0D0 / im2)
      PARAMETER (rm3 = 1.0D0 / im3)
C
      INTEGER iseed0, iseed1, iseed2, iseed3
      DOUBLEPRECISION r (ntable)
C
      COMMON /rtable/ iseed0, iseed1, iseed2, iseed3, r
      SAVE /rtable/
C
      ranget = iseed0
C
      RETURN
      END
C
C RANINI
C seed the random number generator
C
*     SUBROUTINE ranini ()
*     IMPLICIT CHARACTER (A-Z)
C
*     INTEGER bintim (2)
C
*     CALL sys$gettim (bintim)
*     CALL ranset (IAND (bintim (1), '7FFFFFFF'X))
C
*     RETURN
*     END
C
C RANMOL
C generate a random molecule
C
      SUBROUTINE ranmol (n, x)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER n
      DOUBLEPRECISION x (3, n)
C
      INTEGER i, j
C
      DOUBLEPRECISION random
      EXTERNAL random
C
C use nested loops to get same result for scalar/vector
C
      DO 10000 j = 1, 3
        DO 10010 i = 1, n
          x (j, i) = random ()
10010     CONTINUE
10000   CONTINUE
C
      RETURN
      END
C
C RANROT
C generate a random (almost) rotation matrix
C
      SUBROUTINE ranrot (angle, u)
      IMPLICIT CHARACTER (A-Z)
C
      DOUBLEPRECISION angle
      DOUBLEPRECISION u (3, 3)
C
      DOUBLEPRECISION a (3)
      DOUBLEPRECISION anorm
      DOUBLEPRECISION theta
      DOUBLEPRECISION pi
C
      DOUBLEPRECISION random
      EXTERNAL random
C
      pi = 4.0D0 * ATAN (1.0D0)
C
      a (1) = 0.5D0 - random ()
      a (2) = 0.5D0 - random ()
      a (3) = 0.5D0 - random ()
C
      anorm = SQRT (a (1) ** 2 + a (2) ** 2 + a (3) ** 2)
      a (1) = a (1) / anorm
      a (2) = a (2) / anorm
      a (3) = a (3) / anorM
C
      theta = angle * pi * random ()
C
      CALL genrot (a, COS (theta), SIN (theta), u)
C
      RETURN
      END
      SUBROUTINE ranset (iseed)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER ntable
      INTEGER im1, im2, im3
      INTEGER ia1, ia2, ia3
      INTEGER ic1, ic2, ic3
      DOUBLEPRECISION rm1, rm2, rm3
      PARAMETER (ntable = 97)
      PARAMETER (im1 = 714025, im2 = 214326, im3 = 139968)
      PARAMETER (ia1 = 1366,   ia2 = 3613,   ia3 = 3877)
      PARAMETER (ic1 = 150889, ic2 = 45289,  ic3 = 29573)
      PARAMETER (rm1 = 1.0D0 / im1)
      PARAMETER (rm2 = 1.0D0 / im2)
      PARAMETER (rm3 = 1.0D0 / im3)
C
      INTEGER iseed
C
      INTEGER iseed0, iseed1, iseed2, iseed3
      DOUBLEPRECISION r (ntable)
      INTEGER i
C
      COMMON /rtable/ iseed0, iseed1, iseed2, iseed3, r
      SAVE /rtable/
C
      iseed0 = iseed
      iseed1 = MOD (iseed0, im1)
      iseed2 = MOD (iseed0, im2)
      iseed3 = MOD (iseed0, im3)
C
      DO 10000 i = 1, ntable
        iseed1 = MOD (ia1 * iseed1 + ic1, im1)
        iseed2 = MOD (ia2 * iseed2 + ic2, im2)
        iseed3 = MOD (ia3 * iseed3 + ic3, im3)
        r (i) = (iseed1 + iseed2 * rm2) * rm1
10000   CONTINUE
C
      RETURN
      END
C
C ROTMOL
C rotate a molecule
C
      SUBROUTINE rotmol (n, x, y, u)
      IMPLICIT CHARACTER (A-Z)
C
      INTEGER n
      DOUBLEPRECISION x (3, n)
      DOUBLEPRECISION y (3, n)
      DOUBLEPRECISION u (3, 3)
C
      DOUBLEPRECISION yx, yy, yz
      INTEGER i
C
      DO 10000 i = 1, n
        yx = u(1, 1) * x(1, i) + u(1, 2) * x(2, i) + u(1, 3) * x(3, i)
        yy = u(2, 1) * x(1, i) + u(2, 2) * x(2, i) + u(2, 3) * x(3, i)
        yz = u(3, 1) * x(1, i) + u(3, 2) * x(2, i) + u(3, 3) * x(3, i)
C
        y (1, i) = yx
        y (2, i) = yy
        y (3, i) = yz
10000   CONTINUE
C
      RETURN
      END

        SUBROUTINE LPMN(MM,M,N,X,PM,PD)
C
C       =====================================================
C       Purpose: Compute the associated Legendre functions
C                Pmn(x) and their derivatives Pmn'(x)
C       Input :  x  --- Argument of Pmn(x)
C                m  --- Order of Pmn(x),  m = 0,1,2,...,n
C                n  --- Degree of Pmn(x), n = 0,1,2,...,N
C                mm --- Physical dimension of PM and PD
C       Output:  PM(m,n) --- Pmn(x)
C                PD(m,n) --- Pmn'(x)
C       =====================================================
C
        IMPLICIT DOUBLE PRECISION (P,X)
        DIMENSION PM(0:MM,0:MM),PD(0:MM,0:MM)
        DO 10 I=0,N
        DO 10 J=0,M
           PM(J,I)=0.0D0
10         PD(J,I)=0.0D0
        PM(0,0)=1.0D0
        IF (DABS(X).EQ.1.0D0) THEN
           DO 15 I=1,N
              PM(0,I)=X**I
15            PD(0,I)=0.5D0*I*(I+1.0D0)*X**(I+1)
           DO 20 J=1,N
           DO 20 I=1,M
              IF (I.EQ.1) THEN
                 PD(I,J)=1.0D+300
              ELSE IF (I.EQ.2) THEN
                 PD(I,J)=-0.25D0*(J+2)*(J+1)*J*(J-1)*X**(J+1)
              ENDIF
20         CONTINUE
           RETURN
        ENDIF
        LS=1
        IF (DABS(X).GT.1.0D0) LS=-1
        XQ=DSQRT(LS*(1.0D0-X*X))
        XS=LS*(1.0D0-X*X)
        DO 30 I=1,M
30         PM(I,I)=-LS*(2.0D0*I-1.0D0)*XQ*PM(I-1,I-1)
        DO 35 I=0,M
35         PM(I,I+1)=(2.0D0*I+1.0D0)*X*PM(I,I)
        DO 40 I=0,M
        DO 40 J=I+2,N
           PM(I,J)=((2.0D0*J-1.0D0)*X*PM(I,J-1)-
     &             (I+J-1.0D0)*PM(I,J-2))/(J-I)
40      CONTINUE
        PD(0,0)=0.0D0
        DO 45 J=1,N
45         PD(0,J)=LS*J*(PM(0,J-1)-X*PM(0,J))/XS
        DO 50 I=1,M
        DO 50 J=I,N
           PD(I,J)=LS*I*X*PM(I,J)/XS+(J+I)
     &             *(J-I+1.0D0)/XQ*PM(I-1,J)
50      CONTINUE
        RETURN
        END


! Test program for using customized calling subroutine, use
! the Rosenbrock function from driver 1, added constants

!
! CHANGES
! 21.12.2018 - Miha Polajnar
! Initial version
!
program custom1
  use iso_fortran_env, only: rk => real64
  use l_bfgs_b_ag, only: l_bfgs_b, optim_prob_t, lbfgsb_opt_t
  implicit none
  integer, parameter :: n = 2
  integer :: i
  type :: rconst_t
    real(rk) :: a, b
  end type
  type(optim_prob_t) :: optim_prob
  type(lbfgsb_opt_t) :: lbfgsb_opt
  !
  lbfgsb_opt = lbfgsb_opt_t(iprint=-200,factr=1.e7_rk,pgtol=1.e-5_rk,&
    maxeval=500)
  !
  optim_prob%name = 'NOCEDAL EX. 17.1'
  optim_prob%n = n
  optim_prob%x = [(0._rk,i=1,n)]
  optim_prob%nbd=[(2,i=1,n)]
  allocate(optim_prob%lb(n),optim_prob%ub(n))
  optim_prob%lb = [(-5.12_rk,i=1,n)]
  optim_prob%ub = [(5.12_rk,i=1,n)]
  optim_prob%func => nocedal_ex_17_1
  optim_prob%grad => grad_nocedal_ex_17_1
  optim_prob%neqc = 1
  optim_prob%eq_const => nocedal_ex_17_1_eq_const
  optim_prob%grad_eq_const => grad_nocedal_ex_17_1_eq_const
  allocate(optim_prob%lagr(optim_prob%neqc),source=10._rk)
  allocate(optim_prob%dat,source=2._rk)
  ! Run the algorithm
  call l_bfgs_b(optim_prob,lbfgsb_opt)
contains

  real(rk) pure function nocedal_ex_17_1(x,dat)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    nocedal_ex_17_1 = x(1) + x(2)
  end function

  pure subroutine grad_nocedal_ex_17_1(x,dat,grad)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    real(rk), intent(out) :: grad(:)
    grad(1) = 1._rk
    grad(2) = 1._rk
  end subroutine

  pure subroutine nocedal_ex_17_1_eq_const(x,dat,ce)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    real(rk), intent(out) :: ce(:)
    select type(dat)
    type is (real(rk))
      ce(1) = x(1)**2 + x(2)**2 - dat
    class default
      error stop 'Nocedal EX. 17.1 wrong type.'
    end select
  end subroutine

  pure subroutine grad_nocedal_ex_17_1_eq_const(x,dat,grad)
    real(rk), intent(in) :: x(:)
    class(*), intent(in) :: dat
    real(rk), intent(out) :: grad(:,:)
    grad(1,1) = 2._rk * x(1)
    grad(1,2) = 2._rk * x(2)
  end subroutine
end program


!     pressure interpolation
subroutine r_spress(rs,ne)
  use r_common
  implicit none

  real(8) :: rs(3)
  integer,intent(in) :: ne

  real(8) :: r,s,t
  integer :: i,ntt

  r=rs(1)
  s=rs(2)
  t=rs(3)

  hp(1)=1.0d0
  hp(2)=r
  hp(3)=s
  hp(4)=t
  cpre=0.0d0
  do i=1,nump
     ntt=(ne-1)*nump+i
     cpre=cpre+prec(ntt)*hp(i)
  enddo

  return
end subroutine r_spress


      SUBROUTINE input
      USE global
      IMPLICIT NONE

!-------------------------------------------------------------------
!Input parameters
!-------------------------------------------------------------------
      LX      = 2000        ! System Length

 !--------- KAPPA INDEX ---------------------------------
      K       =  2          ! Kappa Index

 !--------- CAIRNS INDEX ---------------------------------
      ALP     = 0.2D0

      DX      = 0.2D0       ! Space grid size
      DT      = 0.1D0       ! Time grid size
      N0E     = 1D0         ! Equilibrium electron density
      N0I     = 1D0         ! Equilibrium ion  density
      VX0     = 0D0         ! Ion equilibrium velocity
      DNE     = 50D-2       ! Amplitude of perturbation in electron density
      L0E     = 2D0         ! Perturbation widht for electron
      DNI     = 50D-2       ! Amplitude of perturbation in ion density
      L0I     = 2D0         ! Perturbation widht for ion
      DNV     = 0D0         ! Amplitude of perturbation in ion velocity
      L0V     = 50D0        ! Perturbation widht for ion velocity
      TIDATA  = 10          ! time interval of data save
      NTIME   = 500000          ! Time of simulation
      TOL     = 1D-10       ! Number of itration in poisson solver
      W       = 0.7D0       ! SOR PARAMETER

      TIMAT   = 1         ! Matrix dimension
      FFTSRT  = 1           ! Starting time of data save opration
      TRES    = 1           ! Resolution of data
      NX      = aint(LX/DX)+1 ! Number of grid point

! ----------- Distribution choice ---------------------------
      DC      = 11      ! 11 = Kappa distribution
                         ! 22 = Maxwell-Boltzman distribution
                         ! 33 = Cairns distribution
!-------------------------------------------------------------

! ----------- peruturbation choice ---------------------------
      PRC      = 1        ! 1 = Gaussian perturbation
                         ! 2 = Step function perturbation
!-------------------------------------------------------------

! -------------- Data save options ---------------------------------
      CC      = 1          ! 1 = data save in vector (1 X N) formate
                           ! 2 = Data save in matrix (M X N) formate
!-------------------------------------------------------------------
! ------------------ Input parameter write -------------------------------------
! ------------------------------------------------------------------------------

      END SUBROUTINE input


      SUBROUTINE DBSABSP_AUX( APPROX, K, NPTS, SIGMA, OMEGA, EPS,
     $                        NORMD2, X, INCX, MU, DIV )
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      INTEGER            APPROX, K, NPTS, INCX, DIV
      DOUBLE PRECISION   SIGMA, NORMD2
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   OMEGA( * ), EPS( * ), X( INCX, * ), MU( * )
*     ..
*
*  Purpose
*  =======
*
*  DBSABSP_AUX() estimates the optical absorption spectra
*
*     epsilon( omega ) =
*        ||d||**2 * sum_i |x_i(1)|^2 * delta( omega - mu_i ) / mu_i**div
*
*  using the normalized eigenpairs (mu_j,x_j) of the k-by-k symmetric
*  tridiagonal matrix.
*  Here the norm is not necessarily the 2-norm.
*  The value ||d||**2 is an input argument.
*
*  No argument check is performed, i.e.,
*  all arguments are assumed to be valid.
*
*  Arguments
*  =========
*
*  APPROX  (input) INTEGER
*          Indicate how the delta function is approximated.
*          See solver.f for details.
*
*  K       (input) INTEGER
*          The number of rows and columns of the tridiagonal matrix.
*          K >= 0.
*
*  NPTS    (input) INTEGER
*          NPTS is the number of sampling points in OMEGA.
*          NPTS >= 0.
*
*  SIGMA   (input) DOUBLE PRECISION
*          Standard deviation of the Gaussian function.
*          SIGMA > 0.
*
*  OMEGA   (input) DOUBLE PRECISION array, dimension (NPTS)
*          Sampling points of omega.
*          All entries of OMEGA are nonnegative.
*
*  EPS     (output) DOUBLE PRECISION array, dimension (NPTS)
*          Sampling points of epsilon, i.e.,
*          EPS( I ) = epsilon( OMEGA( I ) ).
*
*  NORMD2  (input) DOUBLE PRECISION
*          The squared norm of the first block, d_1, of the dipole
*          vector d, i.e., ||d_1||**2.
*
*  X       (input) DOUBLE PRECISION array, dimension 1+(N-1)*INCX.
*          The first row from normalized eigenvectors of the
*          tridiagonal matrix obtained by the Lanczos process.
*
*  INCX    (input) INGEGER
*          The increment between elements of X. INCX >= 1.
*
*  MU      (input) DOUBLE PRECISION array, dimension (K)
*          The eigenvalues of the tridiagonal matrix.
*
*  DIV     (input) INTEGER
*          If DIV = 1, the delta function is divided by MU;
*          if DIV = 0, use the delta function without further dividing.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   DTMP
*     ..
*     .. External Functions ..
      EXTERNAL           APPROX_DELTA
      DOUBLE PRECISION   APPROX_DELTA
*     ..
*     .. Executable Statements ..
*
      DO J = 1, NPTS
         EPS( J ) = ZERO
      END DO
      DO I = 1, K
         IF ( MU( I ) .GT. ZERO ) THEN
            IF ( DIV .EQ. 0 ) THEN
               DTMP = NORMD2*X( 1, I )*X( 1, I )
            ELSE
               DTMP = NORMD2*X( 1, I )*X( 1, I )/MU( I )
            END IF
            DO J = 1, NPTS
               EPS( J ) = EPS( J ) + DTMP
     $              *(
     $              APPROX_DELTA( APPROX, OMEGA( J ) - MU( I ), SIGMA )
     $              -APPROX_DELTA( APPROX, OMEGA( J ) + MU( I ), SIGMA )
     $              )
            END DO
         END IF
      END DO
*
      RETURN
*
*     End of DBSABSP_AUX().
*
      END


program non_axisymmetric_potential
    use physics
    use bulirsch_stoer
    implicit none
    ! to do:
    !   figure out how to make it so I don't have to explicitly use 'accuracy.f08'
    !       within bulirsch_stoer.f08
    !       -- that would help make this a bit easier to use modularly

    ! the main things you need to set are:
    !    In physics_non_axisymmetric.f08:
    !       - precision - sets float precision (e.g. 8 = double)
    !       - energy_tol - fractional tolerance for energy conservation *each step*
    !       - eccentricity - eccentricity of the potential well
    !       - energy_initial - defines family of orbits
    !

    !   In this file:
    !       - n_bodies
    !           - will automatically start n_bodies of integration,
    !             spaced throughout the initially allowed x_values ( 0 < x_0 < x_max )
    !       - t_max
    !           - how long should the integration continue?
    !       - t_print
    !           - how often should you print?

    integer, parameter                              :: n_bodies = 100
    ! 3-position, 3-velocity
    real(kind=precision), dimension(n_bodies, 3)    :: x, v
    real(kind=precision), dimension(n_bodies)       :: mass

    real(kind=precision), parameter     :: H_big = 1./real(10**(4), kind=precision) ! large step size
    real(kind=precision)                :: t
    real(kind=precision), parameter     :: t_max   = 100.
    real(kind=precision), parameter     :: t_print = .001  ! print every t_print,

    ! defined in the physics module -- changes for each potential
    type(accuracy_state)                :: state_initial, state_final

    integer                             :: i,j,k        ! loop variables

    integer                             :: save_file_unit
    character(len=6)                    :: ith_body_str ! tmp variable used in filenames
    character(len=15)                   :: filename     ! tmp variable used in filenames
    character(len=15)                   :: data_format  ! for saving

    ! INITIALIZE

    ! initialize x_0 to a range of 0 < x_0 < x_max
    do concurrent (i=1:n_bodies)
        x(i,1) = x_max * i / (n_bodies + 1)
        x(i,2) = 0
        x(i,3) = 0
    end do

    mass = 1.

    call calc_initial_velocity(n_bodies, x, v)

    call state_initial%initialize(n_bodies, x, v, mass)

    print *, 'energy (initial): '
    print *,  state_initial%energy

    print *, '---'
    print *, 'x_max:'
    print *, x_max
    print *, 'x_0: '
    print *, x(:,1)

    print *, ''
    print *, 'v_y: '
    print *, v(:,2)

    ! ! ! BEGIN INTEGRATIONS
    data_format = "(7e13.5)"
    do i = 1,n_bodies
        print *, 'starting body: '
        print *, i
        write (ith_body_str, "(I4.4)") i
        filename = 'body_'//trim(ith_body_str)//'.dat'

        open(newunit=save_file_unit, file=filename, status='unknown')
        write(save_file_unit, *) &
            "t",achar(9),achar(9),achar(9),achar(9),&
            "x",achar(9),achar(9),achar(9),achar(9),&
            "y",achar(9),achar(9),achar(9),achar(9),&
            "z",achar(9),achar(9),achar(9),achar(9),&
            "v_x",achar(9),achar(9),achar(9),achar(9),&
            "v_y",achar(9),achar(9),achar(9),achar(9),&
            "v_z"

        t = 0.
        do j=1,int(t_max/ H_big)
            t = t + H_big
            ! bodies are uncoupled; faster if integrated separately
            call bulirsch_stoer_step(1, x(i,:), v(i,:), mass(i), H_big)

!             print *, 't = '
!             print *, j * H_big
            if (mod(j, int(t_print / H_big)).eq.0) then
                write(save_file_unit,data_format) &
                t, &
                x(i,1), &
                x(i,2), &
                x(i,3), &
                v(i,1), &
                v(i,2), &
                v(i,3)
            endif
        end do
        close(save_file_unit)
    end do

    ! ! ! CHECK FINAL RESULTS
    call state_final%initialize(n_bodies, x, v, mass)

    print *, ""
    print *, 'energy (final): '
    print *,  state_final%energy

    print *, "overall conservation:"
    print *, "energy err:"
    print *, abs( (state_final%energy - state_initial%energy) / state_initial%energy )

end program


PROGRAM test_grid
!
      USE def_constants
      USE def_variables
      USE Grid
      USE Interp_table
!      USE non_linear_solvers
!      USE properties
      IMPLICIT NONE
!
      INTEGER :: flag!, Niter, exitflag,i,j
!      REAL(pr):: T, v, p, e, cv, cp, s, c, v_l, v_v, v_l_Span,v_v_Span,&
!&           resnorm, guess_1, guess_2, T_span, v_span, e_span,helmho1
!      REAL(pr):: p2, e2, cv2, cp2, s2, c2, helmho2,Helmholtz
      REAL(pr):: p_out, T_out, c_out, x_out, a_out,res, u_in,v_in
!
!
!
!
        CALL MAKE_GRID()
!STOP
        u_in = -178470
        v_in= 0.00213858
!        u_in = -207343.3160311
!        u_in = -108327.291813182
!        v_in = 1.8626809245968707e-003
!        v_in = 1.582810157285395E-002

        CALL CO2BLLT_EQUI(p_out, T_out, c_out, x_out, a_out, res, u_in,v_in,flag)

        print*, 'p=', p_out, 'T=',T_out, 'c=',c_out,'x=',x_out,'a=', a_out,flag

!
!================================================================================
!
!               Test creation of grid in LL
!
!================================================================================
!
!print*, "In Physical domaine"
!  Do j = 1,MMM_LL
!    Do i = 1, NNN_LL
!        print*, "Number of point", j,i
!        print*, "specific volume", vvv_LL(i,j)
!        print*, "pressure", ppp_LL(i,j)
!        print*, "temperature", TTT_LL(i,j)
!        print*, "sound speed", ccc_LL(i,j)
!        print*, " "
!    ENDDO
!  ENDDO
!print*, "======================================================================"
!print*, "Transform domain"
!  DO i = 1,NNN_LL
!        print*, "X", x_mesh_LL(i)
!        print*, "Y", y_mesh_LL(i)
!  ENDDO
!print*,"========================================================================"
!print*, "Spline line"
!  DO i = 1,NNN_sat_LL
!        print*, "Y", y_mesh_sat_LL(i)
!        print*, "v liquid", v_Lsat_LL(i)
!        print*, "v pmax", v_Lpmax_LL(i)
!  ENDDO
!print*,"========================================================================"
!  DO i = 1,NNN_sat_LL
!        print*, "v meta", v_liq_meta(i),i
!  ENDDO
!print*, "====================================================================="
!print*, "spline coeff"
!DO i=1, ord_spline+1
!  DO j=1, NNN_LL-1
!       print*, "LL saturation line", spline_Lsat_LL(i,j)
!       print*, "LL Pressure line" , spline_pmax_LL(i,j)
!       print*, "LL meta" ,spline_meta_LL(i,j)
!       print*, " "
!  ENDDO
!ENDDO

!print*, "====================================================================="
!
!================================================================================
!
!               Test creation of grid in LH
!
!================================================================================
!
!print*, "In Physical domaine"
!  Do j = 1,MMM_LH
!    Do i = 1, NNN_LH
!        print*, "Number of point", j,i
!        print*, "specific volume", vvv_LH(i,j)
!        print*, "pressure", ppp_LH(i,j)
!        print*, "temperature", TTT_LH(i,j)
!        print*, "sound speed", ccc_LH(i,j)
!        print*, " "
!    ENDDO
!  ENDDO
!print*,"======================================================================"
!print*, "Transform domain"
!  DO i = 1,NNN_LH
!        print*, "X", x_mesh_LH(i)
!        print*, "Y", y_mesh_LH(i)
!  ENDDO
!print*,"========================================================================"
!print*, "Spline line"
!  DO i = 1,NNN_sat_LH
!        print*, i
!        print*, y_mesh_sat_LH(i), v_Lsat_LH(i),i
!        print*, "v vapor", v_Lsat_LH(i),i
!        print*, "v pmax", v_Lpmax_LH(i)
!        print*, " "
! ENDDO
!DO i = 1,NNN_LH
!        print*, y_mesh_LH(i),vvv_LH(i,MMM_LH),i
!ENDDO

END PROGRAM test_grid


  function determineRestMass(nuclA, nuclZ ) result(restMass)

! ====================================================================
!
! Determines the rest mass of a nucleus given its A/Z combination
!
!
! Written by CMJ, XCP-3 (04/2019)
!
! ====================================================================

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

    implicit none
    integer(int32), intent(in   ) :: nuclA
    integer(int32), intent(in   ) :: nuclZ
    real(real64) :: restMass

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

    restMass = dble(nuclZ) * 0.9382723d0 + &
         & dble(nuclA - nuclZ) * 0.9395656

    return
! ====================================================================
  end function determineRestMass


program rainflow
!  Downing and Socie, Int J Fatigue 1982

implicit none

integer, parameter :: np = 14000 ! 4096
integer, parameter :: ns = 400
double precision, parameter :: dsa = 0.005d0

integer :: ip,i,j,istart,iread
integer, dimension(ns) :: n,ncum
double precision :: junk,slope,x,y,p,Peq,m,xmean,xrange
double precision, dimension(ns) :: srange,ds
double precision, dimension(2*np) :: e

open (UNIT=48,FILE='cycles.txt',STATUS='REPLACE')
open (UNIT=49,FILE='data.txt',STATUS='OLD',ACTION='READ')

ip = 2
iread = 0
j = 0
istart = 1

read (49,*) junk,e(1)
iread = iread + 1

do                                                !  100
   read (49,*) junk,e(2)
   iread = iread + 1
   if (e(1) .ne. e(2)) then
      exit
   end if
end do                                            !  go to 100

slope = 1.d0
if (e(1) .gt. e(2)) then
   slope = -1.d0
end if

do                                                !  1
   read (49,*) junk,p
   iread = iread + 1
   if (iread .eq. np) then
      exit                                        !  go to 6
   end if
   ip = ip + 1
   slope = slope*(-1.d0)
   e(ip) = p
   do                                             !  2
      if (ip .lt. istart+1) then
         exit                                     !  go to 1
      end if
      x = slope*(e(ip) - e(ip-1))
      if (x .le. 0.d0) then                       !  go to 200
         ip = ip - 1                              !  200
         e(ip) = e(ip+1)
         slope = slope*(-1.d0)                    !  go to 2
      else if (ip .lt. istart+2) then
         exit                                     !  go to 1
      else
         y = slope*(e(ip-2) - e(ip-1))
         if (x .lt. y) then
            exit                                  !  go to 1
         else if (x .eq. y .and. &
                  istart .eq. ip-2) then
            exit                                  !  go to 1
         else if (x .gt. y .and. &
                 istart .eq. ip-2) then
            istart = istart + 1                   !  4
            exit                                  !  go to 1
         else if (x .ge. y .and. &
                  istart .ne. ip-2) then
            xrange = y                             !  5
            xmean = 0.5d0*(e(ip-1) + e(ip-2))
write (48,'(1X,2ES13.4)') xrange,xmean
            ip = ip - 2
            e(ip) = e(ip+2)
         end if                                   !  go to 2
      end if                                      !  go to 2
   end do                                         !  go to 2
end do                                            !  go to 1

do                                                !  6
   j = j + 1
   if (j .gt. istart) then
      exit                                        !  stop
   end if
   ip = ip + 1
   slope = slope*(-1.d0)
   e(ip) = e(j)
   do                                             !  7
      if (ip .lt. istart+1) then
         exit                                     !  go to 6
      end if
      x = slope*(e(ip) - e(ip-1))
      if (x .le. 0.d0) then                       !  go to 300
         ip = ip - 1                              !  300
         e(ip) = e(ip+1)
         slope = slope*(-1.d0)
      else if (ip .lt. istart+2) then
         exit                                     !  go to 6
      else
         y = slope*(e(ip-2) - e(ip-1))
         if (x .lt. y) then                       !  8
            exit                                  !  go to 6
         end if
         xrange = y
         xmean = 0.5d0*(e(ip-1) + e(ip-2))
write (48,'(1X,2ES13.4)') xrange,xmean
         ip = ip - 2
         e(ip) = e(ip+2)
      end if                                      !  go to 7
   end do                                         !  go to 7
end do                                            !  go to 6

close(49)  !  Close input file.
close(48)  !  Close output file.
!  Reopen old output file for reading and sorting.
open (UNIT=49,FILE='cycles.txt',STATUS='OLD',ACTION='READ')
open (UNIT=48,FILE='ncum.txt',STATUS='REPLACE')
open (UNIT=47,FILE='ncyc.txt',STATUS='REPLACE')

!  Set levels.
do i = 1,Ns
   srange(i) = dsa*dble(i)
   ds(i) = dsa
end do

!  Read cycles.
ncum = 0
n = 0
do
   read (49,*,IOSTAT=j) xrange,xmean
   if (j .ne. 0) then
      exit
   end if
   do i = 1,Ns
      if (abs(xrange) .gt. srange(i)) then
         ncum(i) = ncum(i) + 1
      end if
      if ((abs(xrange) .gt. srange(i) - 0.5d0*ds(i)) .and. &
          (abs(xrange) .le. srange(i) + 0.5d0*ds(i))) then
         n(i) = n(i) + 1
      end if
   end do
end do

do i = Ns,1,-1
   write(48,'(1X,ES12.3,I6)') srange(i),ncum(i)
   write(47,'(1X,ES12.3,I6)') srange(i),n(i)
end do

Peq = 0.d0
m = 10.d0
do i = 1,Ns
  Peq = Peq + (srange(i)**m)*n(i)
end do
Peq = (Peq/300.d0)**(1.d0/m)

print *,Peq

close(47)
close(48)
close(49)

end program