module vorticity_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use spherepack_interfaces, only: &
        scalar_synthesis, &
        vector_synthesis

    use scalar_synthesis_routines, only: &
        ScalarSynthesisUtility, &
        shsec, shses, shsgc, shsgs

    use vector_synthesis_routines, only: &
        VectorSynthesisUtility, &
        vhses, vhsec, vhsgc, vhsgs

    use type_ScalarHarmonic, only: &
        ScalarHarmonic

    use type_VectorHarmonic, only: &
        VectorHarmonic

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: vrtec, vrtes, vrtgc, vrtgs
    public :: ivrtec, ivrtes, ivrtgc, ivrtgs
    public :: vorticity_lower_utility_routine
    public :: invert_vorticity_lower_utility_routine

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp
    real(wp), parameter :: SQRT_2 = sqrt(TWO)

    ! Declare interfaces for submodule implementation
    interface
        module subroutine vrtec(nlat, nlon, isym, nt, vort, ivrt, jvrt, cr, ci, mdc, ndc, &
            wshsec, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vort(ivrt, jvrt, nt)
            integer(ip), intent(in)  :: ivrt
            integer(ip), intent(in)  :: jvrt
            real(wp),    intent(in)  :: cr(mdc, ndc, nt)
            real(wp),    intent(in)  :: ci(mdc, ndc, nt)
            integer(ip), intent(in)  :: mdc
            integer(ip), intent(in)  :: ndc
            real(wp),    intent(in)  :: wshsec(:)
            integer(ip), intent(out) :: ierror
        end subroutine vrtec

        module subroutine vrtes(nlat, nlon, isym, nt, vort, ivrt, jvrt, cr, ci, mdc, ndc, &
            wshses, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vort(ivrt, jvrt, nt)
            integer(ip), intent(in)  :: ivrt
            integer(ip), intent(in)  :: jvrt
            real(wp),    intent(in)  :: cr(mdc, ndc, nt)
            real(wp),    intent(in)  :: ci(mdc, ndc, nt)
            integer(ip), intent(in)  :: mdc
            integer(ip), intent(in)  :: ndc
            real(wp),    intent(in)  :: wshses(:)
            integer(ip), intent(out) :: ierror
        end subroutine vrtes

        module subroutine vrtgc(nlat, nlon, isym, nt, vort, ivrt, jvrt, cr, ci, mdc, ndc, &
            wshsgc, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vort(ivrt, jvrt, nt)
            integer(ip), intent(in)  :: ivrt
            integer(ip), intent(in)  :: jvrt
            real(wp),    intent(in)  :: cr(mdc, ndc, nt)
            real(wp),    intent(in)  :: ci(mdc, ndc, nt)
            integer(ip), intent(in)  :: mdc
            integer(ip), intent(in)  :: ndc
            real(wp),    intent(in)  :: wshsgc(:)
            integer(ip), intent(out) :: ierror
        end subroutine vrtgc

        module subroutine vrtgs(nlat, nlon, isym, nt, vort, ivrt, jvrt, cr, ci, mdc, ndc, &
            wshsgs, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: vort(ivrt, jvrt, nt)
            integer(ip), intent(in)  :: ivrt
            integer(ip), intent(in)  :: jvrt
            real(wp),    intent(in)  :: cr(mdc, ndc, nt)
            real(wp),    intent(in)  :: ci(mdc, ndc, nt)
            integer(ip), intent(in)  :: mdc
            integer(ip), intent(in)  :: ndc
            real(wp),    intent(in)  :: wshsgs(:)
            integer(ip), intent(out) :: ierror
        end subroutine vrtgs

        module subroutine ivrtec(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhsec, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhsec(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine ivrtec

        module subroutine ivrtes(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhses, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhses(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine ivrtes

        module subroutine ivrtgc(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhsgc, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhsgc(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine ivrtgc

        module subroutine ivrtgs(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
            wvhsgs, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: v(idvw, jdvw, nt)
            real(wp),    intent(out) :: w(idvw, jdvw, nt)
            integer(ip), intent(in)  :: idvw
            integer(ip), intent(in)  :: jdvw
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(out) :: wvhsgs(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine ivrtgs
    end interface

contains

    pure subroutine compute_coefficient_multipliers(sqnn)

        ! Dummy arguments
        real(wp), intent(out) :: sqnn(:)

        ! Local variables
        integer(ip) :: n

        sqnn = [(sqrt(real(n - 1, kind=wp) * (real(n - 1, kind=wp) + ONE)), n=1, size(sqnn))]

    end subroutine compute_coefficient_multipliers

    pure function get_perturbation(a, k) &
        result(return_value)

        ! Dummy arguments
        real(wp),    intent(in) :: a(:, :, :)
        integer(ip), intent(in) :: k
        real(wp)                :: return_value

        return_value = a(1, 1, k)/(TWO * SQRT_2)

    end function get_perturbation

    pure subroutine perform_setup_for_vorticity(nlon, a, b, cr, ci, sqnn)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: a(:, :, :)
        real(wp),    intent(out) :: b(:, :, :)
        real(wp),    intent(in)  :: cr(:, :, :)
        real(wp),    intent(in)  :: ci(:, :, :)
        real(wp),    intent(out) :: sqnn(:)

        ! Local variables
        integer(ip) :: k, n, m

        associate (&
            order_m => size(a, dim=1), &
            degree_n => size(a, dim=2), &
            number_of_syntheses => size(a, dim=3) &
            )

            ! Set coefficient multiplyers
            call compute_coefficient_multipliers(sqnn)

            ! Preset coefficients to 0.0
            a = ZERO
            b = ZERO

            ! Compute vorticity scalar coefficients for each vector field
            do k=1, number_of_syntheses

                ! Compute m=0 coefficients
                do n=2, degree_n
                    a(1, n, k) = sqnn(n) * cr(1, n, k)
                    b(1, n, k) = sqnn(n) * ci(1, n, k)
                end do

                ! Compute m > 0 coefficients
                do m=2, order_m
                    do n=m, degree_n
                        a(m, n, k) = sqnn(n) * cr(m, n, k)
                        b(m, n, k) = sqnn(n) * ci(m, n, k)
                    end do
                end do
            end do
        end associate

    end subroutine perform_setup_for_vorticity

    subroutine vorticity_lower_utility_routine(nlat, nlon, isym, nt, vort, &
        cr, ci, wavetable, synth_routine, error_flag)

        ! Dummy arguments
        integer(ip),                intent(in)  :: nlat
        integer(ip),                intent(in)  :: nlon
        integer(ip),                intent(in)  :: isym
        integer(ip),                intent(in)  :: nt
        real(wp), dimension(:,:,:), intent(out) :: vort
        real(wp), dimension(:,:,:), intent(in)  :: cr, ci
        real(wp),                   intent(in)  :: wavetable(:)
        procedure(scalar_synthesis)             :: synth_routine
        integer(ip),                intent(out) :: error_flag

        block
            real(wp)             :: sqnn(nlat)
            type(ScalarHarmonic) :: harmonic

            ! Allocate memory
            harmonic = ScalarHarmonic(nlat, nlon, nt)

            associate( &
                ivrt => size(vort, dim=1), &
                jvrt => size(vort, dim=2), &
                a => harmonic%real_component, &
                b => harmonic%imaginary_component, &
                order_m => harmonic%ORDER_M, &
                degree_n => harmonic%DEGREE_N &
                )

                call perform_setup_for_vorticity(nlon, a, b, cr, ci, sqnn)

                ! Synthesize a, b into vort
                call synth_routine(nlat, nlon, isym, nt, vort, ivrt, jvrt, &
                    a, b, order_m, degree_n, wavetable, error_flag)
            end associate

            ! Release memory
            call harmonic%destroy()
        end block

    end subroutine vorticity_lower_utility_routine

    pure subroutine perform_setup_for_inversion(isym, ityp, a, b, sqnn, pertrb, cr, ci)

        ! Dummy arguments
        integer(ip), intent(in)  :: isym
        integer(ip), intent(out) :: ityp
        real(wp),    intent(in)  :: a(:, :, :)
        real(wp),    intent(in)  :: b(:, :, :)
        real(wp),    intent(out) :: sqnn(:)
        real(wp),    intent(out) :: pertrb(:)
        real(wp),    intent(out) :: cr(:, :, :)
        real(wp),    intent(out) :: ci(:, :, :)

        ! Local variables
        integer(ip) :: k, n, m

        associate (&
            order_m => size(cr, dim=1), &
            degree_n => size(cr, dim=2), &
            number_of_syntheses => size(cr, dim=3) &
            )

            ! Preset coefficient multiplyers in vector
            call compute_coefficient_multipliers(sqnn)

            ! Preset cr, ci to 0.0
            cr = ZERO
            ci = ZERO

            ! Compute multiple vector fields coefficients
            do k=1, number_of_syntheses

                ! Set vorticity field perturbation adjustment
                pertrb(k) = get_perturbation(a, k)

                ! Compute m = 0 coefficients
                do n=2, degree_n
                    cr(1, n, k) = a(1, n, k)/sqnn(n)
                    ci(1, n, k) = b(1, n, k)/sqnn(n)
                end do

                ! Compute m > 0 coefficients
                do m=2, order_m
                    do n=m, degree_n
                        cr(m, n, k) = a(m, n, k)/sqnn(n)
                        ci(m, n, k) = b(m, n, k)/sqnn(n)
                    end do
                end do
            end do

            ! Set ityp for vector synthesis with divergence=0
            select case (isym)
                case (0)
                    ityp = 2
                case (1)
                    ityp = 5
                case (2)
                    ityp = 8
            end select
        end associate

    end subroutine perform_setup_for_inversion

    subroutine invert_vorticity_lower_utility_routine(nlat, nlon, isym, nt, &
        v, w, a, b, wavetable, perturbation, synth_routine, error_flag)

        ! Dummy arguments
        integer(ip),                intent(in)  :: nlat
        integer(ip),                intent(in)  :: nlon
        integer(ip),                intent(in)  :: isym
        integer(ip),                intent(in)  :: nt
        real(wp), dimension(:,:,:), intent(out) :: v, w
        real(wp), dimension(:,:,:), intent(in)  :: a, b
        real(wp),                   intent(in)  :: wavetable(:)
        real(wp),                   intent(out) :: perturbation(:)
        procedure(vector_synthesis)             :: synth_routine
        integer(ip),                intent(out) :: error_flag

        block
            integer(ip)          :: ityp
            real(wp)             :: sqnn(nlat)
            type(VectorHarmonic) :: harmonic

            ! Allocate memory
            harmonic = VectorHarmonic(nlat, nlon, nt)

            associate( &
                idvw => size(v, dim=1), &
                jdvw => size(w, dim=2), &
                br => harmonic%polar%real_component, &
                bi => harmonic%polar%imaginary_component, &
                cr => harmonic%azimuthal%real_component, &
                ci => harmonic%azimuthal%imaginary_component, &
                order_m => harmonic%ORDER_M, &
                degree_n => harmonic%DEGREE_N &
                )

                call perform_setup_for_inversion(isym, ityp, a, b, sqnn, perturbation, cr, ci)

                ! Vector synthesize cr, ci into divergence free vector field (v, w)
                call synth_routine(nlat, nlon, ityp, nt, v, w, idvw, jdvw, &
                    br, bi, cr, ci, order_m, degree_n, wavetable, error_flag)
            end associate

            ! Release memory
            call harmonic%destroy()
        end block

    end subroutine invert_vorticity_lower_utility_routine

end module vorticity_routines


! { dg-do compile }
!
! PR fortran/53537
! The use of WP in the ODE_DERIVATIVE interface used to be rejected because
! the symbol was imported under the original name DP.
!
! Original test case from Arjen Markus <arjen.markus@deltares.nl>

module select_precision
    integer, parameter :: dp = kind(1.0)
end module select_precision

module ode_types
    use select_precision, only: wp => dp
    implicit none
    interface
        subroutine ode_derivative(x)
            import   :: wp
            real(wp) :: x
        end subroutine ode_derivative
    end interface
end module ode_types


! { dg-do run }
! PR fortran/66864
!
program t
   implicit none
   real(8) x
   x = 2.0d0**26.5d0
   if (floor(x) /= 94906265) call abort
   if (floor(2.0d0**26.5d0)/= 94906265) call abort
   x = 777666555.6d0
   if (floor(x) /= 777666555) call abort
   if (floor(777666555.6d0) /= 777666555) call abort
   x = 2000111222.6d0
   if (floor(x) /= 2000111222) call abort
   if (floor(2000111222.6d0) /= 2000111222) call abort
end program t


! chkrandom.f90 --
!     Program to check a few properties of the random_number and
!     random_seed subroutines
!
!     Note:
!     The program must be called twice in succession
!

module random_numbers
contains
!
! Derived from the documentation of gfortran:
! A standard-conforming routine to initialise the RNG
!
! init_random_seed --
!     Reset the random number generator via the system clock or via
!     a predefined sequence
!
! Arguments:
!     use_time         (Optional) Use the system time or not
!
subroutine init_random_seed( use_time )
    implicit none
    logical, intent(in), optional :: use_time

    integer                            :: i
    integer                            :: seed_size
    integer, dimension(:), allocatable :: seed
    integer                            :: clock = 305721054

    call random_seed( size = seed_size )
    allocate( seed(seed_size) )

    call random_seed( get = seed )

    if ( use_time ) then
        call system_clock( count = clock )
    endif

    seed = clock + 37 * (/ ( i-1, i = 1,seed_size ) /)

    call random_seed( put = seed )

    deallocate( seed )
end subroutine
end module

program chkrandom
    implicit none
    real                               :: r
    real                               :: rsav
    integer                            :: seed_size
    integer, allocatable, dimension(:) :: seed_data
    integer, allocatable, dimension(:) :: seed_save
    logical                            :: exists

    call system_clock( seed_size )
    write(*,*) 'Clock: ', seed_size

    !
    ! Check:
    ! Is the sequence always the same or not?
    !
    inquire( file = 'chkrandom.sav', exist = exists )
    if ( exists ) then
        open( 10, file = 'chkrandom.sav' )
        read( 10, * ) rsav
        close( 10 )

        call random_number( r )

        if ( abs(r-rsav) < 1.0e-5 ) then
            write(*,*) 'The random number generator is initialised to the same sequence'
        else
            write(*,*) 'The random number generator uses a different sequence at each start-up'
        endif
    else

        write(*,*) 'Simple checks on random number generator'
        write(*,*) '----------------------------------------'

        call random_number( r )
        open( 10, file = 'chkrandom.sav' )
        write( 10, '(f12.8)' ) r
        close( 10 )
    endif

    !
    ! Inspect:
    ! Seed for the random number generator
    !
    call random_seed( size = seed_size )

    allocate( seed_data(seed_size), seed_save(seed_size) )
    call random_seed( get = seed_save )

    !
    ! This call might reset the RNG to a different sequence
    !
    call random_seed

    call random_seed( get = seed_data )

    write(*,*) 'Size of the seed to the random number generator:', seed_size

    write(*,*) 'Effect of call to RANDOM_SEED without arguments:'
    if ( all( seed_data == seed_save ) ) then
        write(*,*) '   RNG is reset to standard sequence'
    else
        write(*,*) '   RNG is reset to a different sequence each time'
    endif

end program


! Copyright 2017, UT-Battelle, LLC
!
! SPDX-License-Identifier: BSD-3-Clause
! License-Filename: LICENSE
program main
! --------------------------------------------------------------------------- !
! Power method for estimating the eigenvalue of maximum magnitude of
! a matrix.
!
! We don't intend for you to write your own eigensolvers; the Anasazi
! package provides them.  You should instead see this class as a surrogate
! for a ForTrilinos interface to the Tpetra package.
! --------------------------------------------------------------------------- !
#include "ForTrilinosTpetra_config.hpp"

use iso_fortran_env
use, intrinsic :: iso_c_binding

#include "ForTrilinos.h"
use forteuchos
use fortpetra

#ifdef HAVE_MPI
use mpi
#endif

implicit none

! -- Parameters
real(scalar_type), parameter :: one=1., two=2., neg_one=-1.

! -- ForTrilinos objects
type(TeuchosComm) :: comm
type(TpetraMap) :: map
type(TpetraCrsMatrix) :: A

! -- Scalars
integer :: ierr
real(scalar_type) :: lambda
integer(global_size_type) :: num_gbl_indices
integer(size_type) :: my_rank
integer(size_type) :: num_entries_in_row, max_entries_per_row, i
integer(local_ordinal_type) lcl_row, row_nnz, n
integer(local_ordinal_type) num_my_elements, col, iconv
integer(global_ordinal_type) gbl_row, id_of_first_row

! -- Arrays
integer(global_ordinal_type), allocatable :: cols(:)
real(scalar_type), allocatable :: vals(:)
! --------------------------------------------------------------------------- !

! Initialize MPI subsystem, if applicable
#ifdef HAVE_MPI
call MPI_INIT(ierr)
if (ierr /= 0) then
  stop "MPI failed to init"
endif
comm = create_TeuchosComm(MPI_COMM_WORLD)
#else
comm = create_TeuchosComm()
#endif

my_rank = comm%getRank()

! The number of rows and columns in the matrix.
num_gbl_indices = 50

map = create_TpetraMap(num_gbl_indices, comm)
FORTRILINOS_CHECK_IERR()

! Check that the map was created with the appropriate number of elements
if (map%getGlobalNumElements() /= num_gbl_indices) then
  write(error_unit, '(A,I3,A)') 'Expected ', num_gbl_indices, ' global indices'
  stop 1
end if

if (my_rank == 0) &
  write(*, *) "Creating the sparse matrix"

! Create a Tpetra sparse matrix whose rows have distribution given by the Map.

! TpetraOperator implements a function from one Tpetra(Multi)Vector to another
! Tpetra(Multi)Vector.  TpetraCrsMatrix implements TpetraOperator; its apply()
! method computes a sparse matrix-(multi)vector multiply.  It's typical for
! numerical algorithms that use Tpetra objects to be templated on the type of
! the TpetraOperator specialization.
max_entries_per_row = 3
A = create_TpetraCrsMatrix(map, max_entries_per_row, TpetraDynamicProfile)

! Fill the sparse matrix, one row at a time.
allocate(vals(3))
allocate(cols(3))
num_my_elements = int(map%getNodeNumElements(), kind=kind(num_my_elements))
fill: do lcl_row = 1, num_my_elements
  gbl_row = map%getGlobalElement(lcl_row)
  if (gbl_row == 1) then
    ! A(1, 1:2) = [2, -1]
    row_nnz = 2
    cols(1:2) = [gbl_row, gbl_row+1]
    vals(1:2) = [two, neg_one]
  else if (gbl_row == num_gbl_indices) then
    ! A(N, N-1:N) = [-1, 2]
    row_nnz = 2
    cols(1:2) = [gbl_row-1, gbl_row]
    vals(1:2) = [neg_one, two]
  else
    ! A(i, i-1:i+1) = [-1, 2, -1]
    row_nnz = 3
    cols(1:3) = [gbl_row-1, gbl_row, gbl_row+1]
    vals(1:3) = [neg_one, two, neg_one]
  end if
  call A%insertGlobalValues(gbl_row, cols(1:row_nnz), vals(1:row_nnz))
end do fill
deallocate(vals)
deallocate(cols)

! Tell the sparse matrix that we are done adding entries to it.
call A%fillComplete()

! Run the power method and report the result.
call PowerMethod(A, lambda, iconv, comm)
if (iconv > 0 .and. my_rank == 0) then
  write(*, *) "Estimated max eigenvalue: ", lambda
end if
if (abs(lambda-3.99)/3.99 >= .005) then
  write(error_unit, '(A)') 'Largest estimated eigenvalue is not correct!'
  stop 1
end if

! Now we're going to change values in the sparse matrix and run the power method
! again.  We'll increase the value of the (1,1) component of the matrix to make
! the matrix more diagonally dominant.  It should decrease the number of
! iterations required for the power method to converge. In Tpetra, if
! fillComplete() has been called, you have to call resumeFill() before you may
! change the matrix(either its values or its structure).

! Increase diagonal dominance
if (my_rank == 0) &
  write(*, *) "Increasing magnitude of A(1,1), solving again"

! Must call resumeFill() before changing the matrix, even its values.
call A%resumeFill()

id_of_first_row = 1
if (map%isNodeGlobalElement(id_of_first_row)) then
  ! Get a copy of the row with with global index 1.  Modify the diagonal entry
  ! of that row.  Submit the modified values to the matrix.
  num_entries_in_row = A%getNumEntriesInGlobalRow(id_of_first_row);
  n = int(num_entries_in_row, kind=kind(n))
  allocate(vals(n))
  allocate(cols(n))

  ! Fill vals and cols with the values resp.(global) column indices of the
  ! sparse matrix entries owned by the calling process.
  !
  ! Note that it's legal(though we don't exercise it in this example) for the
  ! row Map of the sparse matrix not to be one to one.  This means that more
  ! than one process might own entries in the first row.  In general, multiple
  ! processes might own the (1,1) entry, so that the global A(1,1) value is
  ! really the sum of all processes' values for that entry.  However, scaling
  ! the entry by a constant factor distributes across that sum, so it's OK to do
  ! so.
  call A%getGlobalRowCopy(id_of_first_row, cols, vals, num_entries_in_row)
  do i = 1, n
    if (cols(i) == id_of_first_row) then
      vals(i) = vals(i) * 10.
    end if
  end do

  ! "Replace global values" means modify the values, but not the structure of
  ! the sparse matrix.  If the specified columns aren't already populated in
  ! this row on this process, then this method throws an exception.  If you want
  ! to modify the structure(by adding new entries), you'll need to call
  ! insertGlobalValues().
  i = A%replaceGlobalValues(id_of_first_row, cols, vals)

  deallocate(vals)
  deallocate(cols)

end if

! Call fillComplete() again to signal that we are done changing the
! matrix.
call A%fillComplete()

! Run the power method again.
call PowerMethod(A, lambda, iconv, comm)
if (iconv > 0 .and. my_rank == 0) then
  write(*, *) "Estimated max eigenvalue: ", lambda
end if
if (abs(lambda-20.05555)/20.05555 >= .0001) then
  write(error_unit, '(A)') 'Largest estimated eigenvalue is not correct!'
  stop 1
end if

call A%release()
call map%release()
call comm%release()

#ifdef HAVE_MPI
! Finalize MPI must be called after releasing all handles
call MPI_FINALIZE(ierr)
#endif

contains

  subroutine PowerMethod(A, lambda, iconv, comm, verbose_in)
    ! ----------------------------------------------------------------------- !
    ! Power method for estimating the eigenvalue of maximum magnitude of
    ! a matrix.  This function returns the eigenvalue estimate.
    ! ----------------------------------------------------------------------- !
    use fortpetra
    implicit None
    integer(int_type), intent(out) :: iconv
    real(scalar_type), intent(out) :: lambda
    logical(bool_type), intent(in), optional :: verbose_in
    type(TpetraCrsMatrix), intent(in) :: A
    type(TeuchosComm), intent(in) :: comm
    ! ----------------------------------------------------------------------- !
    ! Arguments
    ! ---------
    ! A          (input) The sparse matrix
    !
    ! lambda     (output) The estimated eigenvalue of maximum magnitude
    !
    ! iconv      (output) Flag indicated whether or not the procedure
    !    converged:
    !    iconv = 0  did not converge
    !          = 1  converged based on tol1 (more stringent)
    !          = 2  converged based on tol2 (less stringent)
    !
    ! verbose_in (input, optional) Print information diagnositics
    ! ----------------------------------------------------------------------- !
    ! -- Local Parameters
    real(scalar_type), parameter :: one=1., zero=0.
    integer(size_type), parameter :: num_vecs=1
    integer(int_type), parameter :: maxit1=500, maxit2=750
    real(scalar_type), parameter :: tol1=1.e-5, tol2=1.e-2

    ! -- Local Scalars
    real(scalar_type) :: normz, residual
    integer(int_type) :: report_frequency, it
    integer(size_type) :: my_rank
    logical(bool_type) :: verbose

    ! -- Local Arrays
    real(scalar_type) :: norms(num_vecs), dots(num_vecs)

    ! -- Local ForTrilinos Objects
    type(TpetraMultiVector) :: q, z, resid
    type(TpetraMap) :: domain_map, range_map
    ! ----------------------------------------------------------------------- !

    verbose = .false.
    if (present(verbose_in)) verbose = verbose_in
    my_rank = comm%getRank()

    ! Set output only arguments
    lambda = 0.
    iconv = 0

    ! Create three vectors for iterating the power method.  Since the power
    ! method computes z = A*q, q should be in the domain of A and z should be in
    ! the range. (Obviously the power method requires that the domain and the
    ! range are equal, but it's a good idea to get into the habit of thinking
    ! whether a particular vector "belongs" in the domain or range of the
    ! matrix.)  The residual vector "resid" is of course in the range of A.
    domain_map = A%getDomainMap()
    range_map = A%getRangeMap()
    q = create_TpetraMultiVector(domain_map, num_vecs)
    z = create_TpetraMultiVector(range_map, num_vecs)
    resid = create_TpetraMultiVector(range_map, num_vecs)

    ! Fill the iteration vector z with random numbers to start.  Don't have
    ! grand expectations about the quality of our pseudorandom number generator,
    ! but it is usually good enough for eigensolvers.
    call z%randomize()

    ! lambda: Current approximation of the eigenvalue of maximum magnitude.
    ! normz: 2-norm of the current iteration vector z.
    ! residual: 2-norm of the current residual vector 'resid'.
    lambda = zero
    normz = zero
    residual = zero

    ! How often to report progress in the power method.  Reporting progress
    ! requires computing a residual, which can be expensive.  However, if you
    ! don't compute the residual often enough, you might keep iterating even
    ! after you've converged.
    report_frequency = 10

    ! Do the power method, until the method has converged or the
    ! maximum iteration count has been reached.
    iconv = 0
    iters: do it = 1, maxit2
      call z%norm2(norms)
      normz = norms(1)
      call q%scale(one / normz, z)  !  q := z / normz
      call A%apply(q, z)  !  z := A * q
      call q%dot(z, dots)
      lambda = dots(1)  !  Approx. max eigenvalue

      ! Compute and report the residual norm every report_frequency
      ! iterations, or if we've reached the maximum iteration count.
      if (mod(it-1, report_frequency) == 0 .or. it == maxit2) then
        call resid%update(one, z, -lambda, q, zero)  ! z := A*q - lambda*q
        call resid%norm2(norms)
        residual = norms(1)  ! 2-norm of the residual vector
        if (verbose .and. my_rank == 0) then
          write(*, '(A,I3,A)') "Iteration ", it, ":"
          write(*, '(A,F8.4)') "- lambda = ", lambda
          write(*, '(A,E8.2)') "- ||A*q - lambda*q||_2 = ", residual
        end if
      end if

      if (it <= maxit1) then
        if(residual < tol1) then
          iconv = 1
          exit iters
        end if
      else
        if (residual < tol2) then
          iconv = 2
          exit iters
        end if
      end if

    end do iters

    if (iconv == 0 .and. my_rank == 0) then
      write(*, *) "PowerMethod failed to converge after ", maxit2, " iterations"
    end if

    call q%release()
    call z%release()
    call resid%release()

    return

  end subroutine PowerMethod

end program main


*> \brief \b SPBTRF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SPBTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, KD, LDAB, N
*       ..
*       .. Array Arguments ..
*       REAL               AB( LDAB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SPBTRF computes the Cholesky factorization of a real symmetric
*> positive definite band matrix A.
*>
*> The factorization has the form
*>    A = U**T * U,  if UPLO = 'U', or
*>    A = L  * L**T,  if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of A is stored;
*>          = 'L':  Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KD
*> \verbatim
*>          KD is INTEGER
*>          The number of superdiagonals of the matrix A if UPLO = 'U',
*>          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*>          AB is REAL array, dimension (LDAB,N)
*>          On entry, the upper or lower triangle of the symmetric band
*>          matrix A, stored in the first KD+1 rows of the array.  The
*>          j-th column of A is stored in the j-th column of the array AB
*>          as follows:
*>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*>
*>          On exit, if INFO = 0, the triangular factor U or L from the
*>          Cholesky factorization A = U**T*U or A = L*L**T of the band
*>          matrix A, in the same storage format as A.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of the array AB.  LDAB >= KD+1.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, the leading minor of order i is not
*>                positive definite, and the factorization could not be
*>                completed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup realOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The band storage scheme is illustrated by the following example, when
*>  N = 6, KD = 2, and UPLO = 'U':
*>
*>  On entry:                       On exit:
*>
*>      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46
*>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*>
*>  Similarly, if UPLO = 'L' the format of A is as follows:
*>
*>  On entry:                       On exit:
*>
*>     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66
*>     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *
*>     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *
*>
*>  Array elements marked * are not used by the routine.
*> \endverbatim
*
*> \par Contributors:
*  ==================
*>
*>  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
*
*  =====================================================================
      SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
*     ..
*     .. Array Arguments ..
      REAL               AB( LDAB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
      INTEGER            NBMAX, LDWORK
      PARAMETER          ( NBMAX = 32, LDWORK = NBMAX+1 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I2, I3, IB, II, J, JJ, NB
*     ..
*     .. Local Arrays ..
      REAL               WORK( LDWORK, NBMAX )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      EXTERNAL           LSAME, ILAENV
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM, SPBTF2, SPOTF2, SSYRK, STRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
     $    ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SPBTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment
*
      NB = ILAENV( 1, 'SPBTRF', UPLO, N, KD, -1, -1 )
*
*     The block size must not exceed the semi-bandwidth KD, and must not
*     exceed the limit set by the size of the local array WORK.
*
      NB = MIN( NB, NBMAX )
*
      IF( NB.LE.1 .OR. NB.GT.KD ) THEN
*
*        Use unblocked code
*
         CALL SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
      ELSE
*
*        Use blocked code
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           Compute the Cholesky factorization of a symmetric band
*           matrix, given the upper triangle of the matrix in band
*           storage.
*
*           Zero the upper triangle of the work array.
*
            DO 20 J = 1, NB
               DO 10 I = 1, J - 1
                  WORK( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
*
*           Process the band matrix one diagonal block at a time.
*
            DO 70 I = 1, N, NB
               IB = MIN( NB, N-I+1 )
*
*              Factorize the diagonal block
*
               CALL SPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
               IF( II.NE.0 ) THEN
                  INFO = I + II - 1
                  GO TO 150
               END IF
               IF( I+IB.LE.N ) THEN
*
*                 Update the relevant part of the trailing submatrix.
*                 If A11 denotes the diagonal block which has just been
*                 factorized, then we need to update the remaining
*                 blocks in the diagram:
*
*                    A11   A12   A13
*                          A22   A23
*                                A33
*
*                 The numbers of rows and columns in the partitioning
*                 are IB, I2, I3 respectively. The blocks A12, A22 and
*                 A23 are empty if IB = KD. The upper triangle of A13
*                 lies outside the band.
*
                  I2 = MIN( KD-IB, N-I-IB+1 )
                  I3 = MIN( IB, N-I-KD+1 )
*
                  IF( I2.GT.0 ) THEN
*
*                    Update A12
*
                     CALL STRSM( 'Left', 'Upper', 'Transpose',
     $                           'Non-unit', IB, I2, ONE, AB( KD+1, I ),
     $                           LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
*
*                    Update A22
*
                     CALL SSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
     $                           AB( KD+1-IB, I+IB ), LDAB-1, ONE,
     $                           AB( KD+1, I+IB ), LDAB-1 )
                  END IF
*
                  IF( I3.GT.0 ) THEN
*
*                    Copy the lower triangle of A13 into the work array.
*
                     DO 40 JJ = 1, I3
                        DO 30 II = JJ, IB
                           WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
   30                   CONTINUE
   40                CONTINUE
*
*                    Update A13 (in the work array).
*
                     CALL STRSM( 'Left', 'Upper', 'Transpose',
     $                           'Non-unit', IB, I3, ONE, AB( KD+1, I ),
     $                           LDAB-1, WORK, LDWORK )
*
*                    Update A23
*
                     IF( I2.GT.0 )
     $                  CALL SGEMM( 'Transpose', 'No Transpose', I2, I3,
     $                              IB, -ONE, AB( KD+1-IB, I+IB ),
     $                              LDAB-1, WORK, LDWORK, ONE,
     $                              AB( 1+IB, I+KD ), LDAB-1 )
*
*                    Update A33
*
                     CALL SSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
     $                           WORK, LDWORK, ONE, AB( KD+1, I+KD ),
     $                           LDAB-1 )
*
*                    Copy the lower triangle of A13 back into place.
*
                     DO 60 JJ = 1, I3
                        DO 50 II = JJ, IB
                           AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
   50                   CONTINUE
   60                CONTINUE
                  END IF
               END IF
   70       CONTINUE
         ELSE
*
*           Compute the Cholesky factorization of a symmetric band
*           matrix, given the lower triangle of the matrix in band
*           storage.
*
*           Zero the lower triangle of the work array.
*
            DO 90 J = 1, NB
               DO 80 I = J + 1, NB
                  WORK( I, J ) = ZERO
   80          CONTINUE
   90       CONTINUE
*
*           Process the band matrix one diagonal block at a time.
*
            DO 140 I = 1, N, NB
               IB = MIN( NB, N-I+1 )
*
*              Factorize the diagonal block
*
               CALL SPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
               IF( II.NE.0 ) THEN
                  INFO = I + II - 1
                  GO TO 150
               END IF
               IF( I+IB.LE.N ) THEN
*
*                 Update the relevant part of the trailing submatrix.
*                 If A11 denotes the diagonal block which has just been
*                 factorized, then we need to update the remaining
*                 blocks in the diagram:
*
*                    A11
*                    A21   A22
*                    A31   A32   A33
*
*                 The numbers of rows and columns in the partitioning
*                 are IB, I2, I3 respectively. The blocks A21, A22 and
*                 A32 are empty if IB = KD. The lower triangle of A31
*                 lies outside the band.
*
                  I2 = MIN( KD-IB, N-I-IB+1 )
                  I3 = MIN( IB, N-I-KD+1 )
*
                  IF( I2.GT.0 ) THEN
*
*                    Update A21
*
                     CALL STRSM( 'Right', 'Lower', 'Transpose',
     $                           'Non-unit', I2, IB, ONE, AB( 1, I ),
     $                           LDAB-1, AB( 1+IB, I ), LDAB-1 )
*
*                    Update A22
*
                     CALL SSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
     $                           AB( 1+IB, I ), LDAB-1, ONE,
     $                           AB( 1, I+IB ), LDAB-1 )
                  END IF
*
                  IF( I3.GT.0 ) THEN
*
*                    Copy the upper triangle of A31 into the work array.
*
                     DO 110 JJ = 1, IB
                        DO 100 II = 1, MIN( JJ, I3 )
                           WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
  100                   CONTINUE
  110                CONTINUE
*
*                    Update A31 (in the work array).
*
                     CALL STRSM( 'Right', 'Lower', 'Transpose',
     $                           'Non-unit', I3, IB, ONE, AB( 1, I ),
     $                           LDAB-1, WORK, LDWORK )
*
*                    Update A32
*
                     IF( I2.GT.0 )
     $                  CALL SGEMM( 'No transpose', 'Transpose', I3, I2,
     $                              IB, -ONE, WORK, LDWORK,
     $                              AB( 1+IB, I ), LDAB-1, ONE,
     $                              AB( 1+KD-IB, I+IB ), LDAB-1 )
*
*                    Update A33
*
                     CALL SSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
     $                           WORK, LDWORK, ONE, AB( 1, I+KD ),
     $                           LDAB-1 )
*
*                    Copy the upper triangle of A31 back into place.
*
                     DO 130 JJ = 1, IB
                        DO 120 II = 1, MIN( JJ, I3 )
                           AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
  120                   CONTINUE
  130                CONTINUE
                  END IF
               END IF
  140       CONTINUE
         END IF
      END IF
      RETURN
*
  150 CONTINUE
      RETURN
*
*     End of SPBTRF
*
      END


program q1

  use mqc_gaussian

  implicit none
  character(len=:),allocatable::fileName
  type(mqc_gaussian_unformatted_matrix_file)::fileInfo
  type(mqc_matrix)::alpha_MOs,density
  integer::nAlpha,nBasis
  logical::found

  call mqc_get_command_argument(1,fileName)
  write(6,'(A14,1X,A)') 'Input file is:',fileName
  call fileInfo%load(fileName)

  call fileInfo%getArray('ALPHA MO COEFFICIENTS',alpha_MOs,foundOut=found)
  call alpha_MOs%print(6,'alpha MOs')
  nAlpha = fileInfo%getVal('nalpha')
  nBasis = fileInfo%getVal('nbasis')
  alpha_MOs = alpha_MOs%mat([0],[1,nAlpha])
  call alpha_MOs%print(6,'occupied alpha MOs')
! P = C.C*
  density = matmul(alpha_MOs,transpose(alpha_MOs))
  call density%print(6,'alpha density matrix')

end program q1


MODULE m_integrEQM

! ----------------------------------------------------------------------
! MODULE: m_integrEQM.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for numerical integration of the Equation of Motion
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	4 October 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE integr_EQM (MJDo, tsec_start, ro, vo, arc, integID, step, orbc)

! ----------------------------------------------------------------------
! SUBROUTINE: integr_EQM
! ----------------------------------------------------------------------
! Purpose:
!  Integration of Equation of Motion based on Runge-Kutta methods
! ----------------------------------------------------------------------
! Input arguments:
! - to:			Initial Epoch: Modified Julian Day (MJD) in Terrestrial Time (including the fraction of the day)
! - ro: 		Satellite position vector (m) in ICRF
! - vo: 		Satellite velocity vector (m/sec) in ICRF
! - arc:		Orbit arc lenth (seconds)
! - integID: 	Numerical integration method ID number
! 				RK7 . RKN7(6)8:	Runge-Kutta-Nystrom 7th order (default)
! 				RK4 . RK4:			Runge-Kutta 4th order
! 				RK8 . RK8(7)13:	Runge-Kutta 8th order
! - step: 		Numerical Integrator Stepsize (seconds)
!
! Output arguments:
! - orbc: 		Satellite orbit array in ICRF including the following per epoch:
!               - Modified Julian Day number in TT (including the fraction of the day)
!				- Seconds since 00h in TT
!				- Position vector (m)
!				- Velocity vector (m/sec)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	18 September 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE pod_yaml
      USE mdl_param
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: MJDo, tsec_start
      REAL (KIND = prec_d), INTENT(IN), DIMENSION(3) :: ro, vo
      REAL (KIND = prec_d), INTENT(IN) :: arc
      INTEGER (KIND = prec_int2), INTENT(IN) :: integID
      REAL (KIND = prec_d), INTENT(IN) :: step
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: orbc
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Nepochs, i, j
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      REAL (KIND = prec_d) :: lamda_h
      REAL (KIND = prec_d) :: to_sec, tmax, TT, TTo, t
      REAL (KIND = prec_d), DIMENSION(6) :: Zq
      REAL (KIND = prec_d), DIMENSION(3) :: er
      REAL (KIND = prec_d) :: mjd_0, mjd_th, mjdn
      REAL (KIND = prec_d), DIMENSION(3) :: rto, vto, rth, vth
      REAL (KIND = prec_d), DIMENSION(8) :: Zo
      REAL (KIND = prec_d), DIMENSION(6) :: yo, yn, ey
! ----------------------------------------------------------------------
      EXTERNAL integr_rk4
      EXTERNAL integr_rkn768
      EXTERNAL integr_rk87
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), DIMENSION(3) :: delta_v
	  REAL (KIND = prec_d) :: mjd_ti_pulse, mjd_tj
      INTEGER (KIND = prec_int8) :: N_PULSE_epochs, i1_pulse
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Initial Conditions
! ----------------------------------------------------------------------
! Time conversion to seconds (MJD from days to seconds)

! Initial Epoch's Fraction of the day (in seconds)
to_sec = tsec_start !to_sec = (MJDo - INT(MJDo)) * (24.D0 * 3600.D0)

! Final Epoch
tmax = to_sec + arc

! Number of epochs
Nepochs = INT(arc / ABS(step)) + 1

! ----------------------------------------------------------------------
! Dynamic allocatable array
! ----------------------------------------------------------------------
ALLOCATE (orbc(Nepochs,8), STAT = AllocateStatus)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Initial state vector into the orbit array
! ----------------------------------------------------------------------
orbc(1,1) = MJDo
orbc(1,2) = to_sec
orbc(1,3:5) = ro
orbc(1,6:8) = vo
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Numerical integration methods
! ----------------------------------------------------------------------

!print*,'integID=',integID
! ----------------------------------------------------------------------
! Runge-Kutta-Nystrom RKN7(6)-8 method
! ----------------------------------------------------------------------
If (integID == RK7) Then

! RKN7(6)-8 lamda parameter for stepsize control
lamda_h = 0.001D0

!i = 1
!Do t = to_sec , step , tmax-1

TT = to_sec
Do j = 1 , Nepochs-1

    ! Numerical integration for computation of the state vector at next epoch
    Zo(1) = orbc(j,1)
    Zo(2) = orbc(j,2)
    Zo(3:8) = orbc(j,3:8)

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

    Call integr_rkn768(Zo, step, lamda_h, Zq, er)

	! Next epoch TT (to+h)
    TT = TT + step
	! Seconds since 00h
	TTo = TT
	If (TT >= 86400.D0) Then
		TTo = TT - INT(TT / 86400.D0) * 86400.D0
	End IF
	If (TT < 0.D0) Then
		TTo = TT + (INT(ABS(TT)/86400.D0)+1) * 86400.D0
	End IF

	! MJD and Seconds
	orbc(j+1,1) = INT(MJDo) + TT / (24.0D0 * 3600.0D0)
	orbc(j+1,2) = TTo

	! State vector at the next epoch TT (to+h) in the GCRS
	orbc(j+1,3:8) = Zq

!	print *,"orbc t", orbc(j+1,1:2)
!	print *,"orbc r", orbc(j+1,3:5)

End DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Runge-Kutta RK4 method
! ----------------------------------------------------------------------
Else If (integID == RK4) Then

TT = to_sec
Do j = 1 , Nepochs-1
	! Epoch to
    mjd_0 = orbc(j,1)
    yo = orbc(j,3:8)

    ! Numerical integration for computation of the state vector at next epoch
	Call integr_rk4(mjd_0, yo, step, mjdn, yn)

	! Next epoch TT (to+h)
    TT = TT + step

	! Seconds since 00h
	TTo = TT
	If (TT >= 86400.D0) Then
		TTo = TT - INT(TT / 86400.D0) * 86400.D0
	End IF

	! MJD and Seconds
	orbc(j+1,1) = INT(MJDo) + TT / (24.0D0 * 3600.0D0)
	orbc(j+1,2) = TTo

	! State vector at the next epoch TT (to+h) in the GCRS
	orbc(j+1,3:8) = yn
End DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Runge-Kutta RK8(7)-13 method
! ----------------------------------------------------------------------
Else If (integID == RK8) Then

TT = to_sec
Do j = 1 , Nepochs-1
	! Epoch to
    mjd_0 = orbc(j,1)
    yo = orbc(j,3:8)

    ! Numerical integration for computation of the state vector at next epoch
	Call integr_rk87 (mjd_0, yo, step, mjdn, yn, ey)

	! Next epoch TT (to+h)
    TT = TT + step

	! Seconds since 00h
	TTo = TT
	If (TT >= 86400.D0) Then
		TTo = TT - INT(TT / 86400.D0) * 86400.D0
	End IF

	! MJD and Seconds
	orbc(j+1,1) = INT(MJDo) + TT / (24.0D0 * 3600.0D0)
	orbc(j+1,2) = TTo

	! State vector at the next epoch TT (to+h) in the GCRS
	orbc(j+1,3:8) = yn
End DO
! ----------------------------------------------------------------------

End If

End Subroutine

End Module


      subroutine irev_eqipib2(ctfm,ctfmp,n_a1,n_alpha,n_b1,n_beta,n_iPIb
     &2,n_ipsi,nm1_iPIb2,np1_iPIb2,octfmp,Nx,ht,hx,mass,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 mass
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_b1(Nx)
      real*8 n_beta(Nx)
      real*8 n_iPIb2(Nx)
      real*8 n_ipsi(Nx)
      real*8 nm1_iPIb2(Nx)
      real*8 np1_iPIb2(Nx)
      real*8 octfmp(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=2, Nx-1, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_iPIb2(i) + np1_iPIb2(i))
     # / ht + n_a1(i) * mass * n_ipsi(i) * n_alpha(i) * n_b1(i) ** 2 - 0
     #.1D1 * (-0.5000000000000000D0 * n_iPIb2(i) * (n_beta(i - 1) - 0.1D
     #1 * n_beta(i + 1)) / hx - 0.5000000000000000D0 * n_beta(i) * (n_iP
     #Ib2(i - 1) - 0.1D1 * n_iPIb2(i + 1)) / hx + 0.5000000000000000D0 /
     # n_a1(i) * (n_ipsi(i - 1) - 0.1D1 * n_ipsi(i + 1)) / hx * octfmp(i
     #) * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i) - 0.1D1 * (-0.2500000000
     #000000D0 / n_a1(i) ** 2 * (n_ipsi(i - 1) - 0.1D1 * n_ipsi(i + 1))
     #/ hx ** 2 * (n_a1(i - 1) - 0.1D1 * n_a1(i + 1)) * n_alpha(i) * n_b
     #1(i) ** 2 - 0.2500000000000000D0 / n_a1(i) * (n_ipsi(i - 1) - 0.1D
     #1 * n_ipsi(i + 1)) / hx ** 2 * (-0.1D1 * n_alpha(i - 1) + n_alpha(
     #i + 1)) * n_b1(i) ** 2 - 0.5000000000000000D0 / n_a1(i) * (n_ipsi(
     #i - 1) - 0.1D1 * n_ipsi(i + 1)) / hx ** 2 * (-0.1D1 * n_b1(i - 1)
     #+ n_b1(i + 1)) * n_alpha(i) * n_b1(i) - 0.1D1 / n_a1(i) * (-0.1D1
     #* n_ipsi(i - 1) + 0.2D1 * n_ipsi(i) - 0.1D1 * n_ipsi(i + 1)) / hx
     #** 2 * n_alpha(i) * n_b1(i) ** 2) / ctfmp(i) ** 2 - 0.1D1 * (0.2D1
     # * n_iPIb2(i) * n_beta(i) - 0.1D1 / n_a1(i) * n_alpha(i) * n_b1(i)
     # ** 2 * (n_ipsi(i - 1) - 0.1D1 * n_ipsi(i + 1)) / hx / ctfmp(i)) /
     # ctfm(i)
      res(i)=qb
      end do
      END


Real Function ppt(srt)
  Save
  pmass = 0.9383
  scheck = ((srt**2-2.*pmass**2)/(2.*pmass))**2 - pmass**2
  If (scheck<0) Then
     Write (99, *) 'scheck34: ', scheck
     scheck = 0.
  End If
  plab = sqrt(scheck)
  pmin = 3.
  pmax = 2100
  If ((plab<pmin) .Or. (plab>pmax)) Then
     ppt = 55.
     Return
  End If
  a = 45.6
  b = 219.0
  c = 0.410
  d = -3.41
  an = -4.23
  ppt = a + b*(plab**an) + c*(alog(plab))**2 + d*alog(plab)
  If (ppt<=0) ppt = 0.0
  Return
End Function ppt


      SUBROUTINE HORNER2(N,A,X,Y,Z)
C COMPUTE POLYNOMIAL VALUE AND DERIVATIVE
C SEE "ROUNDOFF IN POLYNOMIAL EVALUATION", W. KAHAN, 1986
C POLY: A(1) + A(2)*X + ... + A(N)*X**(N-1)
C Y: VALUE, Z: DERIVATIVE
      IMPLICIT NONE
      INTEGER I,N
      DOUBLE PRECISION A(N),X,Y,Z
      Z = 0.0D0
      Y = A(N)
      DO 10 I = N - 1,1,-1
        Z = Z*X + Y
   10 Y = Y*X + A(I)
      END


!-------------------------------------
!fftw (3.2.x versions)
!---------------------------------------------------------------------------
module fft_mod

  use parameters_IO

  implicit none

  include "fftw3.f"

  !private

  !public :: kx,ky,k2,eye,forw,back,
  !public :: init_fft

  integer*8 :: forw,back                        !as in the manual
  real(rprec), allocatable, dimension(:) :: kx
  real(rprec), allocatable, dimension(:) :: ky
  integer*8 :: planx,plany,planx2,plany2

contains

  !!-----------------------------------------------------------------------------------
  !!  object: subroutine init_fft ()
  !!-----------------------------------------------------------------------------------
  !!
  !!-----------------------------------------------------------------------------------
  subroutine fft_init()

    implicit none

    real(rprec),dimension(nx) :: inx
    real(rprec),dimension(ny) :: iny
    double complex,dimension(lhx) :: outx
    double complex,dimension(lhy) :: outy

    !formulate the fft plans (forw, n0, n1, double in, complex out, flags)
    call dfftw_plan_dft_r2c_1d(planx,nx,inx,outx,fftw_estimate)
    call dfftw_plan_dft_r2c_1d(plany,ny,iny,outy,fftw_estimate)

    call dfftw_plan_dft_c2r_1d(planx2,nx,outx,inx,fftw_estimate)
    call dfftw_plan_dft_c2r_1d(plany2,ny,outy,iny,fftw_estimate)

    call init_wavenumber()

  end subroutine fft_init

  !!-----------------------------------------------------------------------------------
  !!  object: subroutine init_wavenumber ()
  !!-----------------------------------------------------------------------------------
  !!
  !!-----------------------------------------------------------------------------------
  subroutine init_wavenumber ()

    implicit none

    integer :: jx,jy

    allocate(kx(lhx))
    allocate(ky(lhy))

    !fills kx starting from jx=0 to jx=nx/2 (the freq nx/2+1 is filled with 0 later)
    do jx=1,lhx
       kx(jx)=real(jx-1,rprec)
    enddo

    do jy=1,lhy
       ky(jy)=real(jy-1,rprec)
    enddo

    !eliminates the nyquist value to calculate a correct first derivative later
    kx(lhx)=0._rprec
    ky(lhy)=0._rprec

    !renormalization for the aspect ratio change
    kx=2._rprec*pi/lx*kx
    ky=2._rprec*pi/ly*ky

  end subroutine init_wavenumber

end module fft_mod


      SUBROUTINE FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
c     Josh Kas
c     This subroutine finds the singularities in the integrands of eq. 13
c     in
c     Single-particle Spectrum of the Degenerate Electron Gas
c     II. Numerical Results for Electrons Coupled to Plasmons
c     Phys. kondens. Materie, Bd. 6 (1967)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     In practice this routine only solves for the singularities of one
c     of the three integrands, then checks to see that the singularity
c     is within the limits of integration, and throws out singularities
c     that are not.
c     In units of the Fermi energy the equations to solve are:
c     1) +/- k*q**3 + 2*(3*k**2 - E - 2/3)*q**2 +/- 4*k*(k**2 - E)*q +
c                     [(k**2 - E)**2 - Wp**2] = 0
c     2) q**4 + 4/3*q**2 + Wp**2 - (1 - E)**2 = 0
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Input:
c     Limit1 - Lower limit of integration
c     Limit2 - Upper limit of integration
c     CPar   - Array of complex parameters passed to function
c              CPar(1) = ck/kFermi
c              CPar(2) = Energy/EFermi + i*Gamma/EFermi
c     DPPar  - Array of double precision parameters passed to function
c              DPPar(1) = Wp/EFermi
c              DPPar(2) = Gamma/EFermi
c              DPPar(3) = Energy/EFermi
c              DPPar(4) = xeg (gap energy)
c     iFcn   - Integer denoting which function is the integrand
c              iFcn = 1: solve eqs 1 and 2 for q
c              iFcn = 2: solve eq 1 for q
      COMPLEX*16 Limit1, Limit2, CPar(10)
      DOUBLE PRECISION DPPar(10)
      INTEGER iFcn
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output:
c     XSing  - Array of singularities
c     NSing  - Number of singularities
      COMPLEX*16 XSing(20)
      INTEGER NSing
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables:
c     Coef   - Coefficients of q**n of eq. to solve.
c              eq = Coef(1)*q**n + Coef(2)*q**(n-1)...
c     Sol(4) - Array of solutions to the equation.
c     XSing2 - Temp XSing
c     Test   - Used to test solution of equation.
c     Zero   - Tolerance for testing solution to eqs.
c     NSol   - Number of solutions to eq.
c     Order  - Used to order singulaties from smallest to largest
      COMPLEX*16 Coef(4), Sol(4), XSing2(4)
      DOUBLE PRECISION Test, Zero
      INTEGER NSol, Order(100)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Loop variables
      INTEGER i1
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Initialization
      NSing = 0
      Zero=1.d-4

c     Solve eq 1 for q with + sign
      Coef(1) = 4.d0*CPar(1)
      Coef(2) = 2.d0*(3.d0*CPar(1)**2 - DPPar(3) - 2.d0/3.d0)
      Coef(3) = 4.d0*CPar(1)*(CPar(1)**2 - DPPar(3))
      Coef(4) = (CPar(1)**2 - DPPar(3))**2 - DPPar(1)**2

      CALL CCubic(Coef, Sol, NSol)

c     Test solutions. If Sol is a solution and it is real
c     and it lies between Limit1 and Limit2, add it to list
c     of singularities.
      DO i1 = 1, NSol
         Test = ABS((CPar(1)+Sol(i1))**2 - DPPar(3) +
     &        SQRT(Sol(i1)**4 + 4.d0/3.d0*Sol(i1)**2 + DPPar(1)**2))
         IF(Test.lt.Zero) THEN
            IF((DBLE(Sol(i1)).ge.DBLE(Limit1)).and.
     &           (DBLE(Sol(i1)).le.DBLE(Limit2)).and.
     &           (ABS(DIMAG(Sol(i1))).le.Zero)) THEN
               NSing = NSing + 1
               XSing(NSing) = DBLE(Sol(i1))
            END IF
         END IF
      END DO

c     Now solve eq. 1 for q with - sign
      Coef(1) = -Coef(1)
      Coef(3) = -Coef(3)

      CALL CCubic(Coef, Sol, NSol)

c     Test solutions as before.
      DO i1 = 1, NSol
         Test = ABS((CPar(1)-Sol(i1))**2 - DPPar(3) -
     &        SQRT(Sol(i1)**4 + 4.d0/3.d0*Sol(i1)**2 + DPPar(1)**2))
         IF(Test.lt.Zero) THEN
            IF((DBLE(Sol(i1)).ge.DBLE(Limit1)).and.
     &           (DBLE(Sol(i1)).le.DBLE(Limit2)).and.
     &           (ABS(DIMAG(Sol(i1))).le.Zero)) THEN
               NSing = NSing + 1
               XSing(NSing) = DBLE(Sol(i1))
            END IF
         END IF
      END DO

c     If iFcn = 1 (Solving for singularities of r1(q))
      IF(iFcn.eq.1) THEN
c        Solve eq. 2 for q
         Coef(1) = 1.d0
         Coef(2) = 4.d0/3.d0
         Coef(3) = DPPar(1)**2

         CALL CQdrtc(Coef,Sol,NSol)
         DO i1 = 1, NSol
            XSing2(2*i1-1) =  DBLE(SQRT(Sol(i1)))
            XSing2(2*i1)   = -DBLE(SQRT(Sol(i1)))
         END DO

c        Test Solutions
         DO i1 = 1, 2*NSol
            IF((DBLE(XSing2(i1)).ge.DBLE(Limit1)).and.
     &           (DBLE(XSing2(i1)).le.DBLE(Limit2)).and.
     &              (ABS(DIMAG(Sol(i1))).le.Zero)) THEN
               NSing = NSing + 1
               XSing(NSing) = XSing2(i1)
            END IF
         END DO
      END IF

c     Sort singularities
      CALL QSORTI(Order,NSing,Xsing)
      DO i1 = 1, NSing
         XSing2(i1) = XSing(i1)
      END DO
      DO i1 = 1, NSing
         XSing(i1) = XSing2(Order(i1))
      END DO

      RETURN
      END


implicit none
integer :: i
print*,'enter an integer'
read*,i

if (mod(i,2) == 0) then
	call even(i)
else
	call odd(i)
end if
stop
end

subroutine even(i)
implicit none
integer :: i, j
print*, 'i= ', i, ' is even'
j = (i/2)
if (mod(j,2) == 0) then
	print*, 'and i/2 is odd'
end if
return
end

subroutine odd(i)
implicit none
integer :: i
print*,'i = ', i, ' is odd'
return
end

4670 Numerical Analysis/Class Examples/sub1.f90


subroutine compute_flux(phi, ng_p, fluxx, fluxy, ng_f, lo, hi, &
                        domlo, domhi, bc, dx) bind(C, name="compute_flux")

  implicit none

  ! includes definitions found in BC_TYPES.H
  include 'bc_types.fi'

  integer lo(2),hi(2),domlo(2),domhi(2),bc(2,2),ng_p,ng_f
  double precision   phi(lo(1)-ng_p:hi(1)+ng_p,lo(2)-ng_p:hi(2)+ng_p)
  double precision fluxx(lo(1)-ng_f:hi(1)+ng_f+1,lo(2)-ng_f:hi(2)+ng_f)
  double precision fluxy(lo(1)-ng_f:hi(1)+ng_f,lo(2)-ng_f:hi(2)+ng_f+1)
  double precision dx

  ! local variables
  integer i,j
  integer nlft, nrgt, nbot, ntop

  ! x-fluxes
  do j=lo(2),hi(2)
     do i=lo(1),hi(1)+1
        fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / dx
     end do
  end do

  ! lo-x boundary conditions
  if (lo(1) .eq. domlo(1)) then
     if (bc(1,1) .eq. EXT_DIR) then
        i = lo(1)
        do j=lo(2),hi(2)
           ! divide by 0.5*dx since the ghost cell value represents
           ! the value at the wall, not the ghost cell-center
           fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / (0.5d0*dx)
        end do
     else if (bc(1,1) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxx(lo(1),lo(2):hi(2)) = 0.d0
    end if
  end if

  ! hi-x boundary conditions
  if (hi(1) .eq. domhi(1)) then
     if (bc(1,2) .eq. EXT_DIR) then
        i = hi(1)+1
        do j=lo(2),hi(2)
           ! divide by 0.5*dx since the ghost cell value represents
           ! the value at the wall, not the ghost cell-center
           fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / (0.5d0*dx)
        end do
     else if (bc(1,2) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxx(hi(1)+1,lo(2):hi(2)) = 0.d0
    end if
  end if

  ! y-fluxes
  do j=lo(2),hi(2)+1
     do i=lo(1),hi(1)
        fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / dx
     end do
  end do

  ! lo-y boundary conditions
  if (lo(2) .eq. domlo(2)) then
     if (bc(2,1) .eq. EXT_DIR) then
        j = lo(2)
        do i=lo(1),hi(1)
           ! divide by 0.5*dx since the ghost cell value represents
           ! the value at the wall, not the ghost cell-center
           fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / (0.5d0*dx)
        end do
     else if (bc(2,1) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxy(lo(1):hi(1),lo(2)) = 0.d0
    end if
  end if

  ! hi-y boundary conditions
  if (hi(2) .eq. domhi(2)) then
     if (bc(2,2) .eq. EXT_DIR) then
        j = hi(2)+1
        do i=lo(1),hi(1)
           ! divide by 0.5*dx since the ghost cell value represents
           ! the value at the wall, not the ghost cell-center
           fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / (0.5d0*dx)
        end do
     else if (bc(2,2) .eq. FOEXTRAP) then
       ! dphi/dn = 0
       fluxy(lo(1):hi(1),hi(2)+1) = 0.d0
    end if
  end if

end subroutine compute_flux

subroutine update_phi(phiold, phinew, ng_p, fluxx, fluxy, ng_f, lo, hi, dx, dt) bind(C, name="update_phi")

  integer          :: lo(2), hi(2), ng_p, ng_f
  double precision :: phiold(lo(1)-ng_p:hi(1)+ng_p,lo(2)-ng_p:hi(2)+ng_p)
  double precision :: phinew(lo(1)-ng_p:hi(1)+ng_p,lo(2)-ng_p:hi(2)+ng_p)
  double precision ::  fluxx(lo(1)-ng_f:hi(1)+ng_f+1,lo(2)-ng_f:hi(2)+ng_f)
  double precision ::  fluxy(lo(1)-ng_f:hi(1)+ng_f,lo(2)-ng_f:hi(2)+ng_f+1)
  double precision :: dx, dt

  ! local variables
  integer i,j

  do j=lo(2),hi(2)
     do i=lo(1),hi(1)

        phinew(i,j) = phiold(i,j) + dt * &
             ( fluxx(i+1,j)-fluxx(i,j) &
              +fluxy(i,j+1)-fluxy(i,j) ) / dx

     end do
  end do

end subroutine update_phi


c. This subroutine randomly assigns the entrained ccn
c locations within m2 and m3, which are the 1st and last
c grid cells for the newly entrained blob

	subroutine assigd2(ndrop_used,nccn,m2,m3,jcell_pop,delta_x
     1  ,m1,x,BL,igrid, iseed5)

	integer*4 igrid
	parameter(idimen=5000)

	dimension jcell_pop(0:10,igrid)
        real*8 x(idimen)
	real*8 delta_x
	real*8 pjw
	integer*4 iseed5

c. initialize jcell_pop(0,j) which is the index
c. used in drop_map.f

	do j=m2,m3
	  jcell_pop(0,j-m1+1)=0
	end do

	do i=ndrop_used+1,ndrop_used+nccn

c. randomly assign x(i);
c. find corresponding j_cell for x(i)
c

 330    continue

C	  open(28,file='assigd2_100m.dat')
C	  read(28,*)rand_no
	  rand_no = RAND1(iseed5)

	  x(i)=rand_no*(m3-m2+1)*delta_x+(m2-1)*delta_x
 	  pjw=x(i)/delta_x
	  j=INT(pjw)+M1
          jcell_pop(0,j-m1+1)=jcell_pop(0,j-m1+1)+1
 	  jcell_pop(jcell_pop(0,j-m1+1),j-m1+1)=i

	  if (j.gt.m3)then
	     print *, 'j>m3 j m3 ', j, m3
	     else if (j.lt.m2)then
	       print *, 'j < m2, j m2', j, m2
	  end if

	end do

c write out the cell and index where has more than
c 2 droplet.
         n_gt3 = 0
         nis3 = 0
         nis2 = 0
         nis1 = 0

         do j = m2, m3
          if (jcell_pop(0,j-m1+1).gt.3)then
            n_gt3 = n_gt3 + 1
            else if (jcell_pop(0,j-m1+1).gt.2)then
              nis3 = nis3 + 1
              else if (jcell_pop(0,j-m1+1).gt.1)then
                nis2 = nis2 + 1
                else if (jcell_pop(0,j-m1+1).gt.0)then
                   nis1 = nis1 + 1
          end if

        end do

            write(*,*)'j has >3 drops are', n_gt3
            write(*,*)'j has 3  drops are', nis3
            write(*,*)'j has 2  drops are', nis2
            write(*,*)'j has 1  drops are', nis1

	return
	end


      subroutine reduc(nm,n,a,b,dl,ierr)
c
      integer i,j,k,n,i1,j1,nm,nn,ierr
      double precision a(nm,n),b(nm,n),dl(n)
      double precision x,y
c
c     this subroutine is a translation of the algol procedure reduc1,
c     num. math. 11, 99-110(1968) by martin and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 303-314(1971).
c
c     this subroutine reduces the generalized symmetric eigenproblem
c     ax=(lambda)bx, where b is positive definite, to the standard
c     symmetric eigenproblem using the cholesky factorization of b.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrices a and b.  if the cholesky
c          factor l of b is already available, n should be prefixed
c          with a minus sign.
c
c        a and b contain the real symmetric input matrices.  only the
c          full upper triangles of the matrices need be supplied.  if
c          n is negative, the strict lower triangle of b contains,
c          instead, the strict lower triangle of its cholesky factor l.
c
c        dl contains, if n is negative, the diagonal elements of l.
c
c     on output
c
c        a contains in its full lower triangle the full lower triangle
c          of the symmetric matrix derived from the reduction to the
c          standard form.  the strict upper triangle of a is unaltered.
c
c        b contains in its strict lower triangle the strict lower
c          triangle of its cholesky factor l.  the full upper
c          triangle of b is unaltered.
c
c        dl contains the diagonal elements of l.
c
c        ierr is set to
c          zero       for normal return,
c          7*n+1      if b is not positive definite.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      nn = iabs(n)
      if (n .lt. 0) go to 100
c     .......... form l in the arrays b and dl ..........
      do 80 i = 1, n
         i1 = i - 1
c
         do 80 j = i, n
            x = b(i,j)
            if (i .eq. 1) go to 40
c
            do 20 k = 1, i1
   20       x = x - b(i,k) * b(j,k)
c
   40       if (j .ne. i) go to 60
            if (x .le. 0.0d0) go to 1000
            y = dsqrt(x)
            dl(i) = y
            go to 80
   60       b(j,i) = x / y
   80 continue
c     .......... form the transpose of the upper triangle of inv(l)*a
c                in the lower triangle of the array a ..........
  100 do 200 i = 1, nn
         i1 = i - 1
         y = dl(i)
c
         do 200 j = i, nn
            x = a(i,j)
            if (i .eq. 1) go to 180
c
            do 160 k = 1, i1
  160       x = x - b(i,k) * a(j,k)
c
  180       a(j,i) = x / y
  200 continue
c     .......... pre-multiply by inv(l) and overwrite ..........
      do 300 j = 1, nn
         j1 = j - 1
c
         do 300 i = j, nn
            x = a(i,j)
            if (i .eq. j) go to 240
            i1 = i - 1
c
            do 220 k = j, i1
  220       x = x - a(k,j) * b(i,k)
c
  240       if (j .eq. 1) go to 280
c
            do 260 k = 1, j1
  260       x = x - a(j,k) * b(i,k)
c
  280       a(i,j) = x / dl(i)
  300 continue
c
      go to 1001
c     .......... set error -- b is not positive definite ..........
 1000 ierr = 7 * n + 1
 1001 return
      end


MODULE REAL_PRECISION ! HOMPACK90 module for 64-bit arithmetic.
INTEGER, PARAMETER :: R8 = SELECTED_REAL_KIND(13)
END MODULE REAL_PRECISION

MODULE DELAUNAYNEIGHBORS_MOD
! This module contains the REAL_PRECISION R8 data type for 64-bit arithmetic
! and interface blocks for the DELAUNAYNEIGHBORS subroutine for computing the
! umbrella neighborhood of a vertex V in the Delaunay triangulation of D
! dimensions.
USE REAL_PRECISION
PUBLIC

INTERFACE

   SUBROUTINE DELAUNAYNEIGHBORS( D, N, PTS, V, LIST, IERR, EPS, IBUDGET )
   USE REAL_PRECISION
   ! Input arguments.
   INTEGER, INTENT(IN) :: D, N
   REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:)
   INTEGER, INTENT(IN) :: V
   ! Output arguments.
   INTEGER, ALLOCATABLE, INTENT(OUT) :: LIST(:)
   INTEGER, INTENT(OUT) :: IERR
   ! Optional arguments.
   REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS
   INTEGER, INTENT(IN), OPTIONAL :: IBUDGET
   END SUBROUTINE DELAUNAYNEIGHBORS

END INTERFACE

END MODULE DELAUNAYNEIGHBORS_MOD

SUBROUTINE DELAUNAYNEIGHBORS( D, N, PTS, V, LIST, IERR, EPS, IBUDGET )
! This is a modification of the algorithm proposed in
!
! T. H. Chang, L. T. Watson, T. C.H. Lux, S. Raghvendra, B. Li, L. Xu,
! A. R. Butt, K. W. Cameron, and Y. Hong. Computing the umbrella
! neighbourhood of a vertex in the Delaunay triangulation and a single
! Voronoi cell in arbitrary dimension. In Proceedings of IEEE Southeast
! Conference 2018 (SEC 2018). IEEE, St. Petersburg, FL, 2018.
!
! for computing the umbrella neighborhood of a single vertex in R^D in
! the Delaunay triangulation.
!
! Note that this algorithm is NOT robust for degenerate or near degenerate
! data. Such inputs will result in an error.
!
! On input:
!
! D is the dimension of the space for PTS.
!
! N is the number of data points in PTS.
!
! PTS(1:D,1:N) is a real valued matrix with N columns, each containing the
!    coordinates of a single data point in R^D.
!
! V is the index in PTS of the vertex about which to construct the umbrella
!    neighborhood.
!
! LIST(:) is an unallocated ALLOCATABLE array of type INTEGER that
!    will be allocated on output, and contain the list of neighbors to vertex
!    V.
!
!
! On output:
!
! PTS has been rescaled and shifted. All the data points in PTS are now
!    contained in the unit hyperball in R^D.
!
! LIST(1:M) contains the integer indices (in PTS) of the M
!    Delaunay neighbors of PTS(:,V).
!
! IERR is an integer valued error flag. The error codes are:
!
! 00 : Succesfully computed the entire umbrella neighborhood.
! 01 : The provided vertex is a vertex of the convex hull. The umbrella
!      neighbourhood was still computed, but certain Delaunay facets
!      are still open.
!
! 10 : The dimension D must be positive.
! 11 : Too few data points to construct a triangulation (i.e., N < D+1).
! 12 : The first dimension of PTS does not agree with the dimension D.
! 13 : The second dimension of PTS does not agree with the number of data
!      points N.
! 14 : The supplied value V is not a valid index in PTS (i.e., V does not
!      satisfy 0 < V < N+1).
! 15 : The budget supplied in IBUDGET does not contain a positive
!      integer.
!
! 20 : The budget was exceeded before the algorithm could close every open
!      facet. If the dimension is high, try increasing IBUDGET. This error
!      can also be caused by degeneracies in the point spacing, which cause
!      the Delaunay triangulation to be non-unique. Consider perturbing
!      PTS by some large amount and recomputing.
!
! 30 : Two or more points in the data set PTS are too close together with
!      respect to the working precision (EPS), which would result in a
!      numerically degenerate simplex.
! 31 : All the data points in PTS lie in some lower dimensional linear
!      manifold (up to the working precision), and no valid triangulation
!      exists.
!
! 40 : D+2 or more points are cospherical up to the precision EPSL. If
!      not perturbed, this could cause an error.
!
! 50 : A memory allocation error occurred while allocating the work array
!      WORK.
! 51 : A memory related error occurred while managing the active face
!      list (AFL).
! 53 : A memory allocation error occurred while allocating the output
!      array NEIGHBOR.
!
! 60 : A value that was judged appropriate later caused LAPACK to encounter a
!      singularity. Try increasing the value of EPS.
!
!      The errors 80--83 should never occur, and likely indicate a compiler
!      bug or hardware failure.
! 80 : The LAPACK subroutine DGEQP3 has reported an illegal value.
! 81 : The LAPACK subroutine DGETRF has reported an illegal value.
! 82 : The LAPACK subroutine DGETRS has reported an illegal value.
! 83 : The LAPACK subroutine DORMQR has reported an illegal value.
!
!
! Optional arguments:
!
! EPS contains the working precision for the problem on input. By default,
!    EPS is assigned \sqrt{\mu} where \mu denotes the unit roundoff for the
!    machine. In general, any values that differ by less than EPS are judged
!    as equal, and any weights that are greater than -EPS are judged as
!    nonnegative.  EPS cannot take a value less than the default value of
!    \sqrt{\mu}. If any value less than \sqrt{\mu} is supplied, the default
!    value will be used instead automatically.
!
! IBUDGET contains the integer valued budget for performing flips while
!    iterating toward the simplex containing each interpolation point in Q.
!    This prevents DelaunayFan from falling into an infinite loop when
!    supplied with degenerate or near degenerate data.  By default,
!    IBUDGET=50000. However, for extremely high-dimensional problems and
!    pathological data sets, the default value may be insufficient.
!
!
! Subroutines and functions directly referenced from BLAS are
!      DDOT, DNRM2, DTRSM,
! and from LAPACK are
!      DGEQP3, DGETRF, DGETRS, DORMQR.
!
! Primary Author: Tyler H. Chang
! Last Update: June, 2019
USE AFL, ONLY : FACELIST
USE REAL_PRECISION
IMPLICIT NONE

! Input arguments.
INTEGER, INTENT(IN) :: D, N
REAL(KIND=R8), INTENT(INOUT) :: PTS(:,:)
INTEGER, INTENT(IN) :: V
! Output arguments.
INTEGER, ALLOCATABLE, INTENT(OUT) :: LIST(:)
INTEGER, INTENT(OUT) :: IERR
! Optional arguments.
REAL(KIND=R8), INTENT(IN), OPTIONAL:: EPS
INTEGER, INTENT(IN), OPTIONAL :: IBUDGET

! Local variables.
INTEGER :: IBUDGETL ! Local copy of IBUDGET.
INTEGER :: ITMP ! Temporary value for swapping.
INTEGER :: I, J, K ! Loop iteration variables.
INTEGER :: LWORK ! Size of WORK array (5*D).
INTEGER :: LIST_LENGTH ! Length of the neighbor list.
REAL(KIND=R8) :: CURRRAD ! Radius of the circumball.
REAL(KIND=R8) :: EPSL ! Local copy of EPS.
REAL(KIND=R8) :: MINRAD ! Smallest radius found.
REAL(KIND=R8) :: SIDE1 ! Side of the hyperplane to flip toward.
REAL(KIND=R8) :: SIDE2 ! Side of the hyperplane for a point.
LOGICAL :: HULLPT ! Track whether V is a vertex of the convex hull.

! Local arrays requiring O(d^2 + n) extra memory.
INTEGER :: IPIV(D) ! Pivot indices.
INTEGER :: SIMP(D+1) ! Current simplex.
INTEGER :: LIST_LOCAL(N-1) ! The current list of Delaunay neighbors.
REAL(KIND=R8) :: AT(D,D) ! The transpose of A, the linear coefficient matrix.
REAL(KIND=R8) :: B(D) ! The RHS of a linear system.
REAL(KIND=R8) :: CENTER(D) ! The circumcenter of a simplex.
REAL(KIND=R8) :: LQ(D,D) ! Hold LU or QR of AT.
REAL(KIND=R8) :: PLANE(D+1) ! The hyperplane containing a facet.
REAL(KIND=R8) :: TAU(D) ! Householder reflector constants.
REAL(KIND=R8), ALLOCATABLE :: WORK(:) ! Work array for DGEQP3 and DORMQR.

! Dynamic arrays of unknown size from AFL and Vector modules.
TYPE(FACELIST) :: FL

! External functions and subroutines.
REAL(KIND=R8), EXTERNAL :: DDOT ! Inner product (BLAS).
REAL(KIND=R8), EXTERNAL :: DNRM2 ! Euclidean norm (BLAS).
EXTERNAL :: DGEQP3 ! Perform a QR factorization with column pivoting (LAPACK).
EXTERNAL :: DGETRF ! Perform a LU factorization with partial pivoting (LAPACK).
EXTERNAL :: DGETRS ! Use the output of DGETRF to solve a linear system (LAPACK).
EXTERNAL :: DORMQR ! Apply householder reflectors to a matrix (LAPACK).
EXTERNAL :: DTRSM ! Perform a triangular solve (BLAS).

! Check for input size errors.
IF ( D < 1) THEN; IERR = 10; RETURN; END IF
IF ( N < D+1) THEN; IERR = 11; RETURN; END IF
IF ( SIZE(PTS,1) .NE. D) THEN; IERR = 12; RETURN; END IF
IF ( SIZE(PTS,2) .NE. N) THEN; IERR = 13; RETURN; END IF
IF (V > N .OR. V < 1) THEN; IERR = 14; RETURN; END IF

! Compute the machine precision.
EPSL = SQRT(EPSILON(1.0_R8))
! Check for the optional value EPS, and ensure that EPS is large enough.
IF (PRESENT(EPS)) THEN
   IF(EPSL < EPS) EPSL = EPS
END IF

! Set the budget.
IBUDGETL = 50000
! Check for the optional input IBUDGET, and ensure that it is valid.
IF (PRESENT(IBUDGET)) THEN
   IF (IBUDGET < 1) THEN; IERR = 15; RETURN; END IF
   IBUDGETL = IBUDGET
END IF

! Rescale the points to the unit hypersphere.
CALL RESCALE(MINRAD)
! Check for degeneracies in point spacing.
IF (MINRAD < EPSL) THEN; IERR = 30; RETURN; END IF

! Query DGEQP3 for optimal work array size (LWORK).
LWORK = -1
CALL DGEQP3(D,D,LQ,D,IPIV,TAU,B,LWORK,IERR)
LWORK = INT(B(1)) ! Compute the optimal work array size.
ALLOCATE(WORK(LWORK), STAT=IERR) ! Allocate WORK to size LWORK.
IF (IERR .NE. 0) THEN ! Check for memory allocation errors.
   IERR = 50; RETURN; END IF

! Initialize the face list (FL) and neighbor list.
FL = FACELIST(DIM=(D+1), IND=V, ISTAT=IERR)
IF (IERR .NE. 0) THEN; IERR = 51; RETURN; END IF
LIST_LENGTH = 0

! Make the first "seed" simplex.
CALL MAKEFIRSTSIMP()
IF(IERR .NE. 0) RETURN
! Add all the facets to the stack.
CALL SELECTSORTSIMP()
CALL FL%PUSHSIMP(SIMP, IERR)
IF(IERR .NE. 0) THEN; IERR = 51; RETURN; END IF
! Save the first simplex.
DO I = 2, D+1
   LIST_LENGTH = LIST_LENGTH + 1
   LIST_LOCAL(LIST_LENGTH) = SIMP(I)
END DO
! Initialize the convex hull flag.
HULLPT = .FALSE.

! Loop for filling all simplices containing the vertex with index V.
INNER : DO K = 1, IBUDGETL
   ! Get the top face off the stack, but don't delete it.
   CALL FL%TOP(SIMP, IERR)
   IF(IERR .NE. 0) THEN; IERR = 51; RETURN; END IF
   IF (SIMP(1) .EQ. 0) EXIT INNER ! Exit condition.
   ! Reconstruct the linear system for the new face.
   DO I = 1, D-1
      AT(:,I) = PTS(:,SIMP(I+1)) - PTS(:,SIMP(1))
      B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8
   END DO
   ! Compute the next simplex.
   CALL MAKESIMPLEX()
   IF (IERR .NE. 0) RETURN
   ! Check for the extrapolation condition.
   IF (SIMP(D+1) .EQ. 0) THEN
      CALL FL%POP(SIMP, IERR)
      HULLPT = .TRUE.
      IF (IERR .NE. 0) THEN; IERR = 51; RETURN; END IF
      CYCLE INNER
   END IF
   ! Sort the current simplex's indices and push all its facets to the stack.
   CALL BUBBLESORTSIMP()
   CALL FL%PUSHSIMP(SIMP, IERR)
   IF(IERR .NE. 0) THEN; IERR = 51; RETURN; END IF
   ! Save the new neighbors discovered.
   DO I = 2, D+1
      IF (ANY(LIST_LOCAL(1:LIST_LENGTH) .EQ. SIMP(I))) THEN
         CYCLE
      ELSE
         LIST_LENGTH = LIST_LENGTH + 1
         LIST_LOCAL(LIST_LENGTH) = SIMP(I)
      END IF
   END DO
END DO INNER

! Check whether V was a facet of the convex hull.
IF(HULLPT) IERR = 1
! Check for budget violation.
IF (K > IBUDGETL) THEN; IERR = 20; END IF

! Copy the fan into the output array.
ALLOCATE(LIST(LIST_LENGTH), STAT=I)
IF(I .NE. 0) THEN; IERR = 53; RETURN; END IF
LIST(:) = LIST_LOCAL(1:LIST_LENGTH)

! Free the LAPACK work array.
DEALLOCATE(WORK)

RETURN

CONTAINS ! Internal subroutines and functions.

SUBROUTINE MAKEFIRSTSIMP()
! Iteratively construct the first simplex by choosing points that
! minimize the radius of the smallest circumball. Let P_1, P_2, ..., P_K
! denote the current set of vertices for the simplex. Let P* denote the
! candidate vertex to be added to the simplex. Let CENTER denote the
! circumcenter of the simplex.  Then
!
! X = CENTER - P_1
!
! is given by the minimum norm solution to the underdetermined linear system
!
! A X = B, where
!
! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_K - P_1, P* - P_1 ] and
! B = [ <A_{1.},A_{1.}>/2, <A_{2.},A_{2.}>/2, ..., <A_{K.},A_{K.}>/2 ]^T.
!
! Then the radius of the smallest circumsphere is CURRRAD = \| X \|,
! and the next vertex is given by P_{K+1} = argmin_{P*} CURRRAD, where P*
! ranges over points in PTS that are not already a vertex of the simplex.
!
! On output, this subroutine fully populates the matrix A^T and vector B,
! and fills SIMP(:) with the indices of a valid Delaunay simplex.

! Add the first point.
SIMP(:) = 0
SIMP(1) = V
! Find the second point, i.e., the closest point to PTS(:,SIMP(1)).
MINRAD = HUGE(0.0_R8)
DO I = 1, N
   ! Skip repeated vertices.
   IF (I .EQ. SIMP(1)) CYCLE
   ! Check the diameter of the resulting circumsphere.
   CURRRAD = DNRM2(D, PTS(:,I)-PTS(:,SIMP(1)), 1)
   IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMP(2) = I; END IF
END DO
! Set up the first row of the system A X = B.
AT(:,1) = PTS(:,SIMP(2)) - PTS(:,SIMP(1))
B(1) = DDOT(D, AT(:,1), 1, AT(:,1), 1) / 2.0_R8
! Loop to collect the remaining D-1 vertices for the first simplex.
DO I = 2, D
   MINRAD = HUGE(0.0_R8) ! Re-initialize the radius for each iteration.
   ! Check each point P* in PTS.
   DO J = 1, N
      ! Check that this point is not already in the simplex.
      IF (ANY(SIMP(:) .EQ. J)) CYCLE
      ! Add P* to linear system, and compute the minimum norm solution.
      AT(:,I) = PTS(:,J) - PTS(:,SIMP(1))
      B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8
      LQ(:,1:I) = AT(:,1:I)
      ! Compute A^T P = Q R.
      CALL DGEQP3(D, I, LQ, D, IPIV, TAU, WORK, LWORK, IERR)
      IF(IERR < 0) THEN ! LAPACK illegal input error.
         IERR = 80; RETURN
      ELSE IF (ABS(LQ(I,I)) < EPSL) THEN ! A is rank-deficient.
         ! Old code below: If rank-deficient, skip this point.
         ! CYCLE
         ! Instead, raise an error, as this could result in an infinite loop.
         IERR = 40; RETURN
      END IF
      ! Set CENTER = P^T B.
      FORALL (ITMP = 1:I) CENTER(ITMP) = B(IPIV(ITMP))
      ! Get the radius using R^T Q^T X = P^T B.
      CALL DTRSM('L', 'U', 'T', 'N', I, 1, 1.0_R8, LQ, D, CENTER, D)
      CENTER(I+1:D) = 0.0_R8
      CALL DORMQR('L', 'N', D, 1, I, LQ, D, TAU, CENTER, D, WORK, LWORK, &
         IERR)
      IF(IERR < 0) THEN ! LAPACK illegal input error.
         IERR = 83; RETURN
      END IF
      ! Calculate the radius and compare it to the current minimum.
      CURRRAD = DNRM2(D, CENTER, 1)
      IF (CURRRAD < MINRAD) THEN; MINRAD = CURRRAD; SIMP(I+1) = J; END IF
   END DO
   ! Check that a point was found. If not, then all the points must lie in a
   ! lower dimensional linear manifold (error case).
   IF (SIMP(I+1) .EQ. 0) THEN; IERR = 31; RETURN; END IF
   ! If all operations were successful, add the best P* to the linear system.
   AT(:,I) = PTS(:,SIMP(I+1)) - PTS(:,SIMP(1))
   B(I) = DDOT(D, AT(:,I), 1, AT(:,I), 1) / 2.0_R8
END DO
IERR = 0 ! Set error flag to 'success' for a normal return.
RETURN
END SUBROUTINE MAKEFIRSTSIMP

SUBROUTINE MAKESIMPLEX()
! Given a Delaunay facet F and a specified side of its containing hyperplane,
! complete the simplex by adding a point from PTS on the opposite `side' of
! F. Assume SIMP(1:D) contains the vertex indices of F (corresponding to
! data points P_1, P_2, ..., P_D in PTS), and assume the matrix A(1:D-1,:)^T
! and vector B(1:D-1) are filled appropriately (similarly as in
! MAKEFIRSTSIMP()). Then for any P* (not in the hyperplane containing
! F) in PTS, let CENTER denote the circumcenter of the simplex with vertices
! P_1, P_2, ..., P_D, P*. Then
!
! X = CENTER - P_1
!
! is given by the solution to the nonsingular linear system
!
! A X = B where
!
! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1, P* - P_1 ] and
! B = [ <A_{1.},A_{1.}>/2, <A_{2.},A_{2.}>/2, ..., <A_{D.},A_{D.}>/2 ]^T.
!
! Then CENTER = X + P_1 and RADIUS = \| X \|.  P_{D+1} will be given by the
! candidate P* that satisfies both of the following:
!
! 1) Let PLANE denote the hyperplane containing F. Then P_{D+1} and
! PTS(SIMP(D+1)) must be on opposite sides of PLANE.
!
! 2) The circumball about CENTER must not contain any points in PTS in its
! interior (Delaunay property).
!
! The above are necessary and sufficient conditions for flipping the
! Delaunay simplex, given that F is indeed a Delaunay facet.
!
! On input, SIMP(1:D) should contain the vertex indices (column indices
! from PTS) of the facet F and SIMP(D+1) must contain the index of a piont
! on the current side of F (to flip away from). Upon output, SIMP(:) will
! contain the vertex indices of a Delaunay simplex on the opposite side of
! PLANE.  Also, the matrix A^T and vector B will be updated accordingly. If
! SIMP(D+1)=0, then there were no points in PTS on the appropriate side of
! F, meaning that F is a facet of the convex hull of PTS.

! Compute the hyperplane PLANE.
CALL MAKEPLANE()
IF(IERR .NE. 0) RETURN ! Check for errors.
! Compute the sign for the side of the viable points.
SIDE1 =  -1.0_R8 * DDOT(D,PLANE(1:D),1,PTS(:,SIMP(D+1)),1) + PLANE(D+1)
SIDE1 = SIGN(1.0_R8,SIDE1)
! Initialize the center, radius, and simplex.
SIMP(D+1) = 0
CENTER(:) = 0.0_R8
MINRAD = HUGE(0.0_R8)
! Loop through all points P* in PTS.
DO I = 1, N
   ! Skip all points in SIMP
   IF (ANY(SIMP(1:D) .EQ. I)) CYCLE
   ! Check whether P* is cospherical with the current minima.
   CURRRAD = DNRM2(D, PTS(:,I) - CENTER(:), 1)
   IF (ABS(CURRRAD - MINRAD) < EPSL) THEN; IERR = 40; RETURN; END IF
   ! Otherwise, check if P* is inside the current ball.
   IF (CURRRAD > MINRAD) CYCLE ! If not, skip.
   ! Check that P* is on the appropriate halfspace.
   SIDE2 = DDOT(D,PLANE(1:D),1,PTS(:,I),1) - PLANE(D+1)
   IF (SIDE1*SIDE2 < EPSL .OR. ANY(SIMP(:) .EQ. I)) CYCLE ! If not, skip.
   ! Add P* to the linear system, and solve to get shifted CENTER.
   AT(:,D) = PTS(:,I) - PTS(:,SIMP(1))
   B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8
   LQ = AT
   CENTER = B
   ! Compute A^T = LU
   CALL DGETRF(D, D, LQ, D, IPIV, IERR)
   IF (IERR < 0) THEN ! LAPACK illegal input.
      IERR = 81; RETURN
   ELSE IF (IERR > 0) THEN ! Rank-deficiency detected.
      IERR = 60; RETURN
   END IF
   ! Use A^T = LU to solve A X = B, where X = CENTER - P_1.
   CALL DGETRS('T', D, 1, LQ, D, IPIV, CENTER, D, IERR)
   IF (IERR < 0) THEN ! LAPACK illegal input.
      IERR = 82; RETURN
   END IF
   ! Update the new radius, center, and simplex.
   MINRAD = DNRM2(D, CENTER, 1)
   CENTER(:) = CENTER(:) + PTS(:,SIMP(1))
   SIMP(D+1) = I
END DO
IERR = 0 ! Reset the error flag to 'success' code.
! Check for extrapolation condition.
IF(SIMP(D+1) .EQ. 0) RETURN
! Add new point to the linear system.
AT(:,D) = PTS(:,SIMP(D+1)) - PTS(:,SIMP(1))
B(D) = DDOT(D, AT(:,D), 1, AT(:,D), 1) / 2.0_R8
RETURN
END SUBROUTINE MAKESIMPLEX

SUBROUTINE MAKEPLANE()
! Construct a hyperplane c^T x = \alpha containing the first D vertices indexed
! in SIMP(:). The plane is determined by its normal vector c and \alpha.
! Let P_1, P_2, ..., P_D be the vertices indexed in SIMP(1:D). A normal
! vector is any nonzero vector in ker A, where the matrix
!
! A^T = [ P_2 - P_1, P_3 - P_1, ..., P_D - P_1 ].
!
! Since rank A = D-1, dim ker A = 1, and ker A can be found from a QR
! factorization of A^T:  A^T P = QR, where P permutes the columns of A^T.
! Then the last column of Q is orthogonal to the range of A^T, and in ker A.
!
! Upon output, PLANE(1:D) contains the normal vector c and PLANE(D+1)
! contains \alpha defining the plane.

IF (D > 1) THEN ! Check that D-1 > 0, otherwise the plane is trivial.
   ! Compute the QR factorization.
   IPIV=0
   LQ = AT
   CALL DGEQP3(D, D-1, LQ, D, IPIV, TAU, WORK, LWORK, IERR)
   IF(IERR < 0) THEN ! LAPACK illegal input error.
      IERR = 80; RETURN
   END IF
   ! The nullspace is given by the last column of Q.
   PLANE(1:D-1) = 0.0_R8
   PLANE(D) = 1.0_R8
   CALL DORMQR('L', 'N', D, 1, D-1, LQ, D, TAU, PLANE, D, WORK, &
    LWORK, IERR)
   IF(IERR < 0) THEN ! LAPACK illegal input error.
      IERR = 83; RETURN
   END IF
   ! Calculate the constant \alpha defining the plane.
   PLANE(D+1) = DDOT(D,PLANE(1:D),1,PTS(:,SIMP(1)),1)
ELSE ! Special case where D=1.
   PLANE(1) = 1.0_R8
   PLANE(2) = PTS(1,SIMP(1))
END IF
RETURN
END SUBROUTINE MAKEPLANE

SUBROUTINE SELECTSORTSIMP()
! Sort the indices in SIMP(:), but keep SIMP(1) fixed. O(D^2) complexity.
DO I = 2, D+1
   J = MINLOC(SIMP(I:D+1),DIM=1) + I - 1
   ITMP = SIMP(J)
   SIMP(J) = SIMP(I)
   SIMP(I) = ITMP
END DO
RETURN
END SUBROUTINE SELECTSORTSIMP

SUBROUTINE BUBBLESORTSIMP()
! Sort the indices in SIMP(:), given that only SIMP(D+1) is out of place and
! SIMP(1) is fixed. O(D) complexity.
DO I = D+1, 3, -1
   IF (SIMP(I) < SIMP(I-1)) THEN
      ITMP = SIMP(I)
      SIMP(I) = SIMP(I-1)
      SIMP(I-1) = ITMP
   ELSE
      RETURN
   END IF
END DO
RETURN
END SUBROUTINE BUBBLESORTSIMP

SUBROUTINE RESCALE(MINDIST)
! Rescale and transform data to be centered at the origin with unit
! radius. This subroutine has O(n^2) complexity.
!
! On output, PTS has been rescaled and shifted. All the data
! points in PTS are centered with unit radius.
!
! MINDIST is a real number containing the (scaled) minimum distance
!    between any two data points in PTS.

! Output arguments.
REAL(KIND=R8), INTENT(OUT) :: MINDIST

! Local variables.
REAL(KIND=R8) :: PTS_CENTER(D) ! The center of the data points PTS.
REAL(KIND=R8) :: DISTANCE ! The current distance.
REAL(KIND=R8) :: SCALE ! The scale factor.

! Initialize local values.
MINDIST = HUGE(MINDIST)

! Compute barycenter of all data points.
PTS_CENTER(:) = SUM(PTS(:,:), DIM=2)/REAL(N, KIND=R8)
! Compute the minimum and maximum distances.
DO I = 1, N ! Cycle through all pairs of points.
   DO J = I + 1, N
      DISTANCE = DNRM2(D, PTS(:,I) - PTS(:,J), 1) ! Compute the distance.
      IF (DISTANCE < MINDIST) THEN ! Compare to the current minimum distance.
         MINDIST = DISTANCE
      END IF
   END DO
END DO
! Center the points.
FORALL (I = 1:N) PTS(:,I) = PTS(:,I) - PTS_CENTER(:)
! Compute the scale factor (for unit radius).
DO I = 1, N ! Cycle through all points again.
   DISTANCE = DNRM2(D, PTS(:,I), 1) ! Compute the distance from the center.
   IF (DISTANCE > SCALE) THEN ! Compare to the current radius.
      SCALE = DISTANCE
   END IF
END DO
! Scale the points to unit radius.
PTS = PTS / SCALE
MINDIST = MINDIST / SCALE
RETURN
END SUBROUTINE RESCALE

END SUBROUTINE DELAUNAYNEIGHBORS


      SUBROUTINE linmin(p,xi,n,fret)
      INTEGER n,NMAX
      REAL fret,p(n),xi(n),TOL
      PARAMETER (NMAX=50,TOL=1.e-4)
CU    USES brent,f1dim,mnbrak
      INTEGER j,ncom
      REAL ax,bx,fa,fb,fx,xmin,xx,pcom(NMAX),xicom(NMAX),brent
      COMMON /f1com/ pcom,xicom,ncom
      EXTERNAL f1dim
      ncom=n
      do 11 j=1,n
        pcom(j)=p(j)
        xicom(j)=xi(j)
11    continue
      ax=0.
      xx=1.
      call mnbrak(ax,xx,bx,fa,fx,fb,f1dim)
      fret=brent(ax,xx,bx,f1dim,TOL,xmin)
      do 12 j=1,n
        xi(j)=xmin*xi(j)
        p(j)=p(j)+xi(j)
12    continue
      return
      END

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