! fft3dwrap.f90
! 3D fast Fourier transform applied to a Gaussian function
PROGRAM fft3dwrap

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! The program calls use the C subroutine library FFTW to perform the finite Fourier transforms
  ! The details of this library are available at http://www.fftw.org/
  ! We assume that compiler flags are set such that real and integer Fortran variables
  ! have the appropriate precision to match their C counterparts

  USE, INTRINSIC :: iso_fortran_env, ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor
  USE, INTRINSIC :: iso_c_binding

  IMPLICIT NONE
  INCLUDE 'fftw3.f03'

  ! In this example the box lengths and numbers of grid points are the same in each dimension
  INTEGER :: sc2 ! half the number of grid points
  REAL    :: box ! periodic repeat distance
  REAL    :: dr  ! grid spacing in real space
  REAL    :: dk  ! grid spacing in reciprocal space

  INTEGER            :: ix, iy, iz, ioerr
  REAL, DIMENSION(3) :: r, k
  REAL               :: r_sq, k_sq, g

  INTEGER(C_INT)                                           :: sc      ! number of points for FFT
  COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(:,:,:), ALLOCATABLE :: fft_inp ! Data to be transformed (0:sc-1,0:sc-1,0:sc-1)
  COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(:,:,:), ALLOCATABLE :: fft_out ! Output data (0:sc-1,0:sc-1,0:sc-1)
  TYPE(C_PTR)                                              :: fft_plan! Plan needed for FFTW

  REAL,    PARAMETER :: pi = 4.0 * ATAN( 1.0 )
  INTEGER, PARAMETER :: out_max = 15

  NAMELIST /nml/ sc2, box

  ! Set sensible default values for testing
  sc2 = 2**6 ! Not essential to be a power of 2, but usually more efficient
  box = 6.0  ! Large enough to accommodate the chosen 3D Gaussian, for good comparison with analytical result

  ! Read parameters from namelist
  ! Comment out, or replace, this section if you don't like namelists
  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in fft3dwrap'
  END IF

  ! Write out parameters
  sc = sc2 * 2
  dr = box / REAL (sc)
  dk = (2.0 * pi) / dr / REAL(sc) ! interval in reciprocal space
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of grid points in each dimension, sc = ', sc
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Periodic repeat length (box) = ',                box
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Grid spacing in real space (dr) = ',             dr
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Grid spacing in reciprocal space (dk) = ',       dk

  ! Allocate necessary arrays
  ALLOCATE ( fft_inp(0:sc-1,0:sc-1,0:sc-1), fft_out(0:sc-1,0:sc-1,0:sc-1) )

  ! Write titles
  WRITE ( unit=output_unit, fmt='(a)'    ) 'Initial real-space Gaussian'
  WRITE ( unit=output_unit, fmt='(5a15)' ) '   ix   iy   iz', '|r|', 'Gaussian(r)', 'FFT (real)', 'FFT (imag)'

  ! Triple loop over xyz grid points (uses wraparound indexing)
  DO ix = 0, sc-1
     r(1) = REAL ( wraparound ( ix ) ) * dr
     DO iy = 0, sc-1
        r(2) = REAL ( wraparound ( iy ) ) * dr
        DO iz = 0, sc-1
           r(3) = REAL ( wraparound ( iz ) ) * dr

           r_sq = SUM ( r**2 )        ! Squared distance from origin
           g    = EXP ( - pi * r_sq ) ! Setup 3D Gaussian (decay parameter chosen to be pi)

           fft_inp(ix,iy,iz) = CMPLX ( g, 0.0 ) ! Feed into complex array for FFT

           ! Write some elements of data in same form as later output
           IF ( ix**2 + iy**2 + iz**2 <= out_max ) THEN
              WRITE ( unit=output_unit, fmt='(3i5,4f15.6)' ) ix, iy, iz, SQRT(r_sq), g, fft_inp(ix,iy,iz)
           END IF

        END DO
     END DO
  END DO
  ! End triple loop over xyz grid points

  WRITE(*,'(/)')

  ! Forward FFT

  fft_plan = fftw_plan_dft_3d ( sc, sc, sc, fft_inp, fft_out, FFTW_FORWARD, FFTW_ESTIMATE) ! Set up plan for the FFT
  CALL fftw_execute_dft  ( fft_plan, fft_inp, fft_out )                                    ! Execute FFT
  CALL fftw_destroy_plan ( fft_plan )                                                      ! Release plan

  ! Write titles
  WRITE ( unit=output_unit, fmt='(a)' ) 'Reciprocal-space transform'
  WRITE ( unit=output_unit, fmt='(5a15)' ) '   ix   iy   iz', '|k|', 'Gaussian(k)', 'FFT (real)', 'FFT (imag)'

  ! Triple loop over xyz grid points (uses wraparound indexing)
  DO ix = 0, sc-1
     k(1) = REAL ( wraparound ( ix ) ) * dk
     DO iy = 0, sc-1
        k(2) = REAL ( wraparound ( iy ) ) * dk
        DO iz = 0, sc-1
           k(3) = REAL ( wraparound ( iz ) ) * dk

           ! Write some elements of data in reciprocal space including factor of dr**3
           ! Compare with the (real) analytical expression for the transform of the Gaussian test function

           IF ( ix**2 + iy**2 + iz**2 <= out_max ) THEN
              k_sq = SUM ( k**2 )             ! Squared magnitude of wave vector
              g    = EXP ( -k_sq / 4.0 / pi ) ! Analytical transform of the Gaussian
              WRITE ( unit=output_unit, fmt='(3i5,4f15.6)') ix, iy, iz, SQRT(k_sq), g, fft_out(ix,iy,iz)*dr**3
           END IF

        END DO
     END DO
  END DO
  ! End triple loop over xyz grid points

  WRITE ( unit=output_unit, fmt='(/)')

  ! Backward Fourier transform

  fft_plan = fftw_plan_dft_3d ( sc, sc, sc, fft_out, fft_inp, FFTW_BACKWARD, FFTW_ESTIMATE) ! Set up plan for the FFT
  CALL fftw_execute_dft  ( fft_plan, fft_out, fft_inp )                                     ! Execute FFT
  CALL fftw_destroy_plan ( fft_plan )                                                       ! Release plan

  ! Write some elements of data in real space after the back transform including the normalising factor 1/sc**3
  ! Compare with the (real) input data

  ! Write titles
  WRITE ( unit=output_unit, fmt='(a)'    ) 'Back Transform to real space'
  WRITE ( unit=output_unit, fmt='(5a15)' ) '   ix   iy   iz', '|r|', 'Gaussian(r)', 'FFT (real)', 'FFT (imag)'

  ! Triple loop over xyz grid points (uses wraparound indexing)
  DO ix = 0, sc-1
     r(1) = REAL ( wraparound ( ix ) ) * dr
     DO iy = 0, sc-1
        r(2) = REAL ( wraparound ( iy ) ) * dr
        DO iz = 0, sc-1
           r(3) = REAL ( wraparound ( iz ) ) * dr

           IF ( ix**2 + iy**2 + iz**2 <= out_max ) THEN
              r_sq = SUM ( r**2 )        ! Squared distance from origin
              g    = EXP ( - pi * r_sq ) ! Original 3d Gaussian
              WRITE ( unit=output_unit, fmt='(3i5,4f15.6)' ) ix, iy, iz, SQRT(r_sq), g, fft_inp(ix,iy,iz)/REAL(sc**3)
           END IF

        END DO
     END DO
  END DO
  ! End triple loop over xyz grid points

  ! All done, deallocate arrays
  DEALLOCATE ( fft_inp, fft_out )

CONTAINS

  FUNCTION wraparound ( i ) RESULT ( w )
    IMPLICIT NONE
    INTEGER             :: w ! Returns wrapped index
    INTEGER, INTENT(in) :: i ! Index to be wrapped

    IF ( i < 0 .OR. i >= sc ) THEN ! should never happen
       WRITE ( unit=error_unit, fmt='(a,i15)') 'Indexing error', i
       STOP 'Error in fft3dwrap/wraparound'
    END IF

    IF ( i < sc2 ) THEN
       w = i
    ELSE
       w = i - sc
    END IF

  END FUNCTION wraparound

END PROGRAM fft3dwrap


<ompts:test>
<ompts:testdescription>Test which checks the omp parallel do reduction directive with all its options.</ompts:testdescription>
<ompts:ompversion>2.0</ompts:ompversion>
<ompts:directive>omp parallel do reduction</ompts:directive>
<ompts:testcode>
      INTEGER FUNCTION <ompts:testcode:functionname>par_do_reduction</ompts:testcode:functionname>()
        IMPLICIT NONE
        INTEGER sum, sum2, known_sum, i, i2,diff
        INTEGER product,known_product,int_const
        INTEGER MAX_FACTOR
        DOUBLE PRECISION dsum,dknown_sum,dt,dpt
        DOUBLE PRECISION rounding_error, ddiff
        INTEGER double_DIGITS
        LOGICAL logic_and, logic_or, logic_eqv,logic_neqv
        INTEGER bit_and, bit_or
        INTEGER exclusiv_bit_or
        INTEGER min_value, max_value
        DOUBLE PRECISION dmin, dmax
        INTEGER result
        INCLUDE "omp_testsuite.f"
        LOGICAL logics(LOOPCOUNT)
        INTEGER int_array(LOOPCOUNT)
        DOUBLE PRECISION d_array(LOOPCOUNT)
        PARAMETER (int_const=10,known_product=3628800)
        PARAMETER (double_DIGITS=20,MAX_FACTOR=10)
        PARAMETER (rounding_error=1.E-6)

        dt = 1./3.
        known_sum = (LOOPCOUNT * (LOOPCOUNT + 1)) / 2
        product = 1
        sum2 = 0
        sum = 0
        dsum = 0.
        result =0
        logic_and = .true.
        logic_or = .false.
        bit_and = 1
        bit_or = 0
        exclusiv_bit_or = 0
!$omp parallel do schedule(dynamic, 1) <ompts:check>reduction(+:sum)</ompts:check>
        DO i =1, LOOPCOUNT
          sum = sum + i
        END DO
!$omp end parallel do

        IF (known_sum .NE. sum) THEN
          result = result + 1
          WRITE(1,*) "Error in sum with integers: Result was ",
     &       sum,"instead of ", known_sum
        END IF

        diff = (LOOPCOUNT * (LOOPCOUNT + 1)) / 2

!$omp parallel do schedule(dynamic, 1) <ompts:check>reduction (-: diff)</ompts:check>
        DO i =1, LOOPCOUNT
          diff = diff - i
        END DO
!$omp end parallel do

        IF ( diff .NE. 0 ) THEN
          result = result + 1
          WRITE(1,*) "Error in difference with integers: Result was ",
     &       sum,"instead of 0."
        END IF

!... Test for doubles
        dsum =0.
        dpt = 1

        DO i=1, DOUBLE_DIGITS
          dpt= dpt * dt
        END DO
        dknown_sum = (1-dpt)/(1-dt)
!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(+:dsum)</ompts:check>
        DO i=0,DOUBLE_DIGITS-1
              dsum = dsum + dt**i
        END DO
!$omp end parallel do

        IF(dsum .NE. dknown_sum .AND.
     &    abs(dsum - dknown_sum) .GT. rounding_error ) THEN
          result = result + 1
          write(1,*) "Error in sum with doubles: Result was ",
     &      dsum,"instead of ",dknown_sum,"(Difference: ",
     &      dsum - dknown_sum,")"
        END IF
        dpt = 1

        DO i=1, DOUBLE_DIGITS
          dpt = dpt*dt
        END DO
        ddiff = ( 1-dpt)/(1-dt)

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(-:ddiff)</ompts:check>
        DO i=0, DOUBLE_DIGITS-1
          ddiff = ddiff - dt**i
        END DO
!$omp end parallel do

        IF ( ABS(ddiff) .GT. rounding_error ) THEN
          result = result + 1
          WRITE(1,*) "Error in Difference with doubles: Result was ",
     &       ddiff,"instead of 0.0"
        END IF

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(*:product)</ompts:check>
        DO i=1,MAX_FACTOR
           product = product * i
        END DO
!$omp end parallel do

        IF (known_product .NE. product) THEN
           result = result + 1
           WRITE(1,*) "Error in Product with integers: Result was ",
     &       product," instead of",known_product
        END IF

        DO i=1,LOOPCOUNT
          logics(i) = .TRUE.
        END DO

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.AND.:logic_and)</ompts:check>
        DO i=1,LOOPCOUNT
          logic_and = logic_and .AND. logics(i)
        END DO
!$omp end parallel do

        IF (.NOT. logic_and) THEN
          result = result + 1
          WRITE(1,*) "Error in logic AND part 1"
        END IF

        logic_and = .TRUE.
        logics(LOOPCOUNT/2) = .FALSE.

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.AND.:logic_and)</ompts:check>
        DO i=1,LOOPCOUNT
          logic_and = logic_and .AND. logics(i)
        END DO
!$omp end parallel do

        IF (logic_and) THEN
          result = result + 1
          WRITE(1,*) "Error in logic AND pass 2"
        END IF

        DO i=1, LOOPCOUNT
         logics(i) = .FALSE.
        END DO

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.OR.:logic_or)</ompts:check>
        DO i = 1, LOOPCOUNT
           logic_or = logic_or .or. logics(i)
        END DO
!$omp end parallel do

        IF (logic_or) THEN
          result = result + 1
          WRITE(1,*) "Error in logic OR part 1"
        END IF

        logic_or = .FALSE.
        logics(LOOPCOUNT/2) = .TRUE.

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.OR.:logic_or)</ompts:check>
        DO i=1,LOOPCOUNT
          logic_or = logic_or .OR. logics(i)
        END DO
!$omp end parallel do

        IF ( .NOT. logic_or ) THEn
          result = result + 1
          WRITE(1,*) "Error in logic OR part 2"
        END IF

!... Test logic EQV, unique in Fortran
        DO i=1, LOOPCOUNT
         logics(i) = .TRUE.
        END DO

        logic_eqv = .TRUE.

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.EQV.:logic_eqv)</ompts:check>
        DO i = 1, LOOPCOUNT
           logic_eqv = logic_eqv .EQV. logics(i)
        END DO
!$omp end parallel do

        IF (.NOT. logic_eqv) THEN
          result = result + 1
          WRITE(1,*) "Error in logic EQV part 1"
        END IF

        logic_eqv = .TRUE.
        logics(LOOPCOUNT/2) = .FALSE.

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.EQV.:logic_eqv)</ompts:check>
        DO i=1,LOOPCOUNT
           logic_eqv = logic_eqv .EQV. logics(i)
        END DO
!$omp end parallel do

        IF ( logic_eqv ) THEN
          result = result + 1
          WRITE(1,*) "Error in logic EQV part 2"
        END IF

!... Test logic NEQV, which is unique in Fortran
        DO i=1, LOOPCOUNT
         logics(i) = .FALSE.
        END DO

        logic_neqv = .FALSE.

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.NEQV.:logic_neqv)</ompts:check>
        DO i = 1, LOOPCOUNT
           logic_neqv = logic_neqv .NEQV. logics(i)
        END DO
!$omp end parallel do

        IF (logic_neqv) THEN
          result = result + 1
          WRITE(1,*) "Error in logic NEQV part 1"
        END IF

        logic_neqv = .FALSE.
        logics(LOOPCOUNT/2) = .TRUE.

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(.NEQV.:logic_neqv)</ompts:check>
        DO i=1,LOOPCOUNT
           logic_neqv = logic_neqv .neqv. logics(i)
        END DO
!$omp end parallel do

        IF ( .NOT. logic_neqv ) THEN
          result = result + 1
          WRITE(1,*) "Error in logic NEQV part 2"
        END IF

        DO i=1, LOOPCOUNT
           int_array(i) = 1
        END DO
!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(IAND:bit_and)</ompts:check>
        DO i=1, LOOPCOUNT
!... iand(I,J): Returns value resulting from boolean AND of
!... pair of bits in each of I and J.
          bit_and = IAND(bit_and,int_array(i))
        END DO
!$omp end parallel do

        IF ( bit_and .LT. 1 ) THEN
          result = result + 1
          WRITE(1,*) "Error in IAND part 1"
        END IF

        bit_and = 1
        int_array(LOOPCOUNT/2) = 0

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(IAND:bit_and)</ompts:check>
        DO i=1, LOOPCOUNT
          bit_and = IAND ( bit_and, int_array(i) )
        END DO
!$omp end parallel do

        IF( bit_and .GE. 1) THEN
          result = result + 1
          WRITE(1,*) "Error in IAND part 2"
        END IF

        DO i=1, LOOPCOUNT
          int_array(i) = 0
        END DO

!$omp parallel do schedule(dynamic,1) reduction(IOR:bit_or)
        DO i=1, LOOPCOUNT
!... Ior(I,J): Returns value resulting from boolean OR of
!... pair of bits in each of I and J.
          bit_or = IOR(bit_or, int_array(i) )
        END DO
!$omp end parallel do

        IF ( bit_or .GE. 1) THEN
          result = result + 1
          WRITE(1,*) "Error in Ior part 1"
        END IF

        bit_or = 0
        int_array(LOOPCOUNT/2) = 1
!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(IOR:bit_or)</ompts:check>
        DO i=1, LOOPCOUNT
          bit_or = IOR(bit_or, int_array(i) )
        END DO
!$omp end parallel do

        IF ( bit_or .LE. 0) then
          result = result + 1
          WRITE(1,*) "Error in Ior part 2"
        END IF

        DO i=1, LOOPCOUNT
          int_array(i) = 0
        END DO

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(IEOR:exclusiv_bit_or)</ompts:check>
        DO i = 1, LOOPCOUNT
          exclusiv_bit_or = ieor(exclusiv_bit_or, int_array(i))
        END DO
!$omp end parallel do

        IF ( exclusiv_bit_or .GE. 1) THEN
           result = result + 1
           WRITE(1,*) "Error in Ieor part 1"
        END IF

        exclusiv_bit_or = 0
        int_array(LOOPCOUNT/2) = 1

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(IEOR:exclusiv_bit_or)</ompts:check>
        DO i = 1, LOOPCOUNT
            exclusiv_bit_or = IEOR(exclusiv_bit_or, int_array(i))
        END DO
!$omp end parallel do

        IF ( exclusiv_bit_or .le. 0) then
          result = result + 1
          WRITE(1,*) "Error in Ieor part 2"
        END IF

        DO i=1,LOOPCOUNT
           int_array(i) = 10 - i
        END DO

        min_value = 65535

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(MIN:min_value)</ompts:check>
        DO i = 1, LOOPCOUNT
            min_value = MIN(min_value,int_array(i) )
        END DO
!$omp end parallel do

        IF ( min_value .GT. (10-LOOPCOUNT) )THEN
          result = result + 1
          WRITE(1,*) "Error in integer MIN"
        END IF

        DO i=1,LOOPCOUNT
           int_array(i) = i
        END DO

        max_value = -32768

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(MAX:max_value)</ompts:check>
        DO i = 1, LOOPCOUNT
            max_value = MAX(max_value,int_array(i) )
        END DO
!$omp end parallel do

        IF ( max_value .LT. LOOPCOUNT )THEN
          result = result + 1
          WRITE(1,*) "Error in integer MAX"
        END IF

!... test double min, max
        DO i=1,LOOPCOUNT
          d_array(i) = 10 - i*dt
        END DO

        dmin = 2**10
        dt = 0.5

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(MIN:dmin)</ompts:check>
        DO i = 1, LOOPCOUNT
          dmin= MIN(dmin,d_array(i) )
        END DO
!$omp end parallel do

        IF ( dmin .GT. (10-dt) )THEN
          result = result + 1
          WRITE(1,*) "Error in double MIN"
        END IF

        DO i=1,LOOPCOUNT
           d_array(i) = i * dt
        END DO

        dmax= - (2**10)

!$omp parallel do schedule(dynamic,1) <ompts:check>reduction(max:dmax)</ompts:check>
        DO i = 1, LOOPCOUNT
          dmax= max(dmax,d_array(i) )
        END DO
!$omp end parallel do

        IF ( dmax .LT. LOOPCOUNT*dt )THEN
          result = result + 1
          WRITE(1,*) "Error in double MAX"
        END IF

        IF ( result .EQ. 0 ) THEN
          <testfunctionname></testfunctionname> =  1
        ELSE
          <testfunctionname></testfunctionname> =  0
        END IF

      END FUNCTION
</ompts:testcode>
</ompts:test>


module structure
  use constants
  use variables
contains
  real(kind=8) function menc(r)

    implicit none

    real(kind=8) :: r,z  ! Project radius, height above midplane
    real(kind=8) :: fofc,phi

    real(kind=8) :: x,a,mtotal

    menc=0.0

    if(halotype.eq.0) then
       a=rs*sqrt(2*(dlog(1+c200)-c200/(1+c200)))
       mtotal=mhalo*(1+a/r200)*(1+a/r200)

       x=r/a
       menc=menc+m200*(1+a/r200)*(1+a/r200)*x*x/(1+x)/(1+x)
    end if

    if(halotype.eq.1) then
       x=r/rs

       fofc=dlog(1+c200)-c200/(1+c200)

       menc = menc+(mhalo/fofc)*(log(1+x)-x/(1+x))
    end if

    if(mbulge.gt.0.0) then
       a=fbulge*rs
       mtotal=mbulge

       x=r/a

       menc=menc+mbulge*x*x/(1+x)/(1+x)
    end if

    if(mbh.gt.0.0) menc=menc+mbh

    if(mdisc.gt.0.0) then
       a=rdisc

       x=r/a

       menc=menc+mdisc*(1-exp(-x)*(1+x))
    end if

    return

  end function menc

  real(kind=8) function mhenc(r)
    implicit none

    real(kind=8) :: r,z  ! Project radius, height above midplane
    real(kind=8) :: fofc,phi

    real(kind=8) :: x,a,mtotal

    if(halotype.eq.0) then
       a=rs*sqrt(2*(dlog(1+c200)-c200/(1+c200)))
       mtotal=mhalo*(1+a/r200)*(1+a/r200)

       x=r/a
       mhenc=mtotal*x*x/(1+x)/(1+x)
    end if

    if(halotype.eq.1) then
       x=r/rs

       fofc=dlog(1+c200)-c200/(1+c200)

       mhenc = (mhalo/fofc)*(log(1+x)-x/(1+x))
    end if

    return

  end function mhenc

  real(kind=8) function mbenc(r)
    implicit none

    real(kind=8) :: r,z  ! Project radius, height above midplane
    real(kind=8) :: fofc,phi

    real(kind=8) :: x,a,mtotal

    a=fbulge*rs
    mtotal=mbulge

    x=r/a

    mbenc=mbulge*x*x/(1+x)/(1+x)

    return

  end function mbenc

  real(kind=8) function getrvir(mvir,dvir,rhoc)
    use constants
    implicit none
    real(kind=8) :: mvir,dvir,rhoc
    getrvir=(3*mvir/(4*pi) * (1/dvir) * (1/rhoc))**(1./3.)
    return
  end function getrvir

  real(kind=8) function getmvir(vvir,dvir,rhoc)
    use constants
    implicit none
    real(kind=8) :: vvir,dvir,rhoc
    getmvir=sqrt((3./4./pi) * (1/dvir) * (1/rhoc))
    getmvir=getmvir*(vvir/sqrt(ggdt))**3.0
    return
  end function getmvir

  real(kind=8) function rhodm(r)

    implicit none

    real(kind=8) :: a,x,r,rho_scale

    if(halotype.eq.0) then
       a=rs*sqrt(2*(dlog(1+c200)-c200/(1+c200)))

       x=r/a

       rho_scale = (mhalo/2/pi/a**3)!*(1+a/r200)*(1+a/r200)

       rhodm = rho_scale/(x*(1+x)*(1+x)*(1+x))
    end if

    if(halotype.eq.1) then
       x=r/rs

       rho_scale=mhalo/(dlog(1+c200)-c200/(1+c200))

       rho_scale = rho_scale/(4.*pi*rs**3)

       rhodm = rho_scale/(x*(1+x)*(1+x))
    end if

    return

  end function rhodm

  real(kind=8) function rhobulge(r)

    implicit none

    real(kind=8) :: a,x,r,rho_scale,mtotal

    rhobulge=0.0

    if(mbulge.le.0.0) return

    a=fbulge*rs
    mtotal=mbulge

    x=r/a

    rho_scale = (mtotal/2/pi/a**3)

    rhobulge = rho_scale/(x*(1+x)*(1+x)*(1+x))

    return

  end function rhobulge

  real(kind=8) function rho(r)

    implicit none

    real(kind=8) :: r

    rho = rhodm(r)

    rho = rho + rhobulge(r)

    return

  end function rho

  real(kind=8) function dphidr(r)
    implicit none

    real(kind=8) :: r,a,mtotal

    if(halotype.eq.0) then
       a=rs*sqrt(2*(dlog(1+c200)-c200/(1+c200)))
       mtotal=m200!*(1+a/r200)*(1+a/r200)-mbulge-mbh

       dphidr = ggdt*mtotal/(r+a)/(r+a)
    end if

    if(halotype.eq.1) then
       mtotal=m200-mbulge-mbh
       dphidr = (ggdt*mtotal/rs/rs/(dlog(1+c200)-c200/(1+c200))) * (rs/r)*(dlog(1+r/rs)/(r/rs)-1./(1+r/rs))
    end if

    if(mbulge.gt.0.0) then
       a=fbulge*rs

       dphidr = dphidr+ggdt*mbulge/(r+a)/(r+a)
    end if

    if(mbh.gt.0.0) dphidr = dphidr+ggdt*mbh/r

    return

  end function dphidr

  real(kind=8) function sigma_mass(logr)
    implicit none
    real(kind=8) :: logr,r,lognum

    r=dexp(logr)

    lognum=dlog(2.d0)+2.*dlog(r)+dlog(rho(r))-0.5*dlog(r*r-radius*radius)
    sigma_mass=dexp(lognum)
    return
  end function sigma_mass

end module structure


!*****************************************************************************************
!>
!  A test of very large data sets for the 3D case.

    program bspline_stack_size_oo_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip

    implicit none

    integer :: i !! counter

    ! number of data points to test (n x n x n):
    integer,parameter :: n_start  = 90     !! initial size
    integer,parameter :: n_stop   = 1000   !! final size
    integer,parameter :: n_step   = 20     !! step size

    write(*,*) ''
    write(*,'(A10,1X,A20,1X,A30)') 'num points','size (bytes)', 'error'
    do i = n_start, n_stop, n_step
        call run_test(i)
    end do
    write(*,*) ''

    contains

    subroutine run_test(n)  !! run test for n x n x n data set

    implicit none

    integer,intent(in) :: n

    integer(ip),parameter :: kx = 4    !order
    integer(ip),parameter :: ky = 4
    integer(ip),parameter :: kz = 4
    real(wp),parameter :: tol = 1.0e-14_wp

    type(bspline_3d) :: s3
    integer(ip) :: nx,ny,nz
    real(wp),allocatable :: x(:),y(:),z(:)
    real(wp),allocatable  :: fcn_3d(:,:,:)
    real(wp) :: val,tru,err,errmax
    logical  :: fail
    integer(ip) :: i,j,k,idx,idy,idz
    integer(ip) :: iflag

    nx = n; ny = n; nz = n
    idx = 0; idy = 0; idz = 0
    fail = .false.

    allocate(x(nx))
    allocate(y(ny))
    allocate(z(nz))
    allocate(fcn_3d(nx,ny,nz))

     do concurrent (i=1:nx)
        x(i) = real(i-1,wp)/real(nx-1,wp)
     end do
     do concurrent (j=1:ny)
        y(j) = real(j-1,wp)/real(ny-1,wp)
     end do
     do concurrent (k=1:nz)
        z(k) = real(k-1,wp)/real(nz-1,wp)
     end do

     do i=1,nx
        do j=1,ny
           do k=1,nz
              fcn_3d(i,j,k) = f3(x(i),y(j),z(k))
           end do
        end do
     end do

     !initialize:
     call s3%initialize(x,y,z,fcn_3d,kx,ky,kz,iflag)

     ! free up memory (don't need anymore):
     deallocate(fcn_3d)

     if (iflag/=0) then
         write(*,*) 'Error initializing spline: '//get_status_message(iflag)
         error stop
     end if

    ! compute max error at interpolation points
     errmax = 0.0_wp
     do i=1,nx
        do j=1,ny
           do k=1,nz
                call s3%evaluate(x(i),y(j),z(k),idx,idy,idz,val,iflag)
                tru    = f3(x(i),y(j),z(k))
                err    = abs(tru-val)
                errmax = max(err,errmax)
           end do
        end do
     end do

    ! check max error against tolerance
    write(*,'(I10,1X,I20,1X,E30.16)') n, s3%size_of()*8, errmax    ! n, size, error
    if (errmax >= tol) error stop  ' ** test failed ** '

    end subroutine run_test

    pure real(wp) function f3 (x,y,z) !! 3d test function
    implicit none
    real(wp),intent(in) :: x,y,z
    real(wp) :: piov2
    piov2 = 2.0_wp*atan(1.0_wp)
    f3 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) )
    end function f3

    end program bspline_stack_size_oo_test


subroutine ff_ellipsoid(q,Rx,RzRatio,Nalf,ff,aff,M)
    !***************************************************************************
    !Subroutine to calculate the form factor of an ellipsoid
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !Rx = Major Radius of ellipsoid in Angstroms
    !RzRatio = Rz/Rx ratio for the minor axis of the ellipsoid
    !Nalf = Number of distict azimuthal angles for angular integration from 0 to pi/2
    !ff = azimuthally averaged form factor
    !aff= azimuthally averaged form factor amplitude
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i, j, Nalf
    double precision :: q(0:M-1)
    double precision :: ff(0:M-1), aff(0:M-1)
    double precision :: Rx, RzRatio, Rx2, Rz2
    double precision :: rt, ft, alf, dalf, V
    dalf=3.14159/Nalf
    Rx2=Rx*Rx
    Rz2=Rx2*RzRatio*RzRatio
    V=4*3.14159*Rx**3*RzRatio/3
    do i = 0,M-1
        ff(i)=0.0d0
        aff(i)=0.0d0
        do j = 0, Nalf-1
            alf=float(j)*dalf
            rt=dsqrt(Rx2*dsin(alf)**2+Rz2*dcos(alf)**2)
            ft=(dsin(q(i)*rt)-q(i)*rt*dcos(q(i)*rt))/(q(i)*rt)**3
            aff(i)=aff(i)+ft*dsin(alf)
            ff(i)=ff(i)+ft*ft*dsin(alf)
        end do
        aff(i)=3*V*dalf*aff(i)
        ff(i)=(3*V)**2*ff(i)*dalf
    end do

end subroutine ff_ellipsoid

subroutine ff_ellipsoid_ml(q,Rx,RzRatio,rho,Nalf,ff,aff,M,Nlayers)
    !***************************************************************************
    !Subroutine to calculate the form factor of sphere with disctribution of radii
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Array of radius and shell thicknesses of sphere in Angstroms
    !rho = Array of electron densities  of core and the shells
    !Rdist = Probablity distribution of radii
    !Nlayers = Number of shells plus the core
    !aff = amplitude of form factor
    !ff = Form factor of sphere
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i, j, k, Nalf, Nlayers
    double precision :: q(0:M-1)
    double precision :: ff(0:M-1), aff(0:M-1)
    double precision :: Rx(0:Nlayers-1), RzRatio(0:Nlayers-1), rho(0:Nlayers-1)
    double precision :: rt, ft, tRx, tRz, Rx2, Rz2, alf, dalf, V, taff
    dalf=3.14159/Nalf
    do i = 0,M-1
        ff(i)=0.0d0
        aff(i)=0.0d0
        tRx=0.0d0
        tRz=0.0d0
        do j = 0, Nalf-1
            alf=float(j)*dalf
            tRx=0.0d0
            tRz=0.0d0
            taff=0.0d0
            do k = 0, Nlayers-2
                tRx=tRx+Rx(k)
                tRz=tRz+Rx(k)*RzRatio(k)
                Rx2=tRx*tRx
                Rz2=tRz*tRz
                rt=dsqrt(Rx2*dsin(alf)**2+Rz2*dcos(alf)**2)
                ft=(rho(k)-rho(k+1))*(dsin(q(i)*rt)-q(i)*rt*dcos(q(i)*rt))/(q(i)*rt)**3
                taff=taff+ft
            end do
            aff(i)=aff(i)+taff*dsin(alf)
            ff(i)=ff(i)+taff*taff*dsin(alf)
        end do
        V=4*3.14159*tRz*tRx**2/3.0
        aff(i)=3*V*dalf*aff(i)
        ff(i)=(3*V)**2*ff(i)*dalf
    end do

end subroutine ff_ellipsoid_ml

subroutine ff_ellipsoid_ml_asaxs(q,Rx,RzRatio,rho,eirho,adensity,Nalf,fft,ffs,ffc,ffr,M,Nlayers)
    !***************************************************************************
    !Subroutine to calculate the form factor of ellipsoid with disctribution of radii
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Array of half of the length of semi major axes shell thicknesses of ellipsoid in Angstroms
    !RzRatio = Array of ratio between lengths of semi-minor axis to semi-major axis
    !rho = Array of energy dependent electron densities  of core and the shells
    !eirho = Array of energy indepdent electron densities of core and the shells
    !adensity = Array of density of the resonant element in the particle
    !Nlayers = Number of shells plus the core
    !Nalf = Number of azimuthal angle to be integrated for isotropic integration
    !fft = Total scattering from the ellipsoid particle
    !ffs = SAXS-term
    !ffc = Cross-term
    !ffr = Resonant term
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !Nlayers = No. of multilayers in the ellipsoid particles
    !***************************************************************************
    integer :: M, i, j, k, Nalf, Nlayers
    double precision :: q(0:M-1)
    double precision :: fft(0:M-1), ffs(0:M-1), ffc(0:M-1), ffr(0:M-1)
    double precision :: Rx(0:Nlayers-1), RzRatio(0:Nlayers-1)
    double complex :: rho(0:Nlayers-1)
    double precision :: eirho(0:Nlayers-1), adensity(0:Nlayers-1)
    double precision :: rt, fs, fc, fr, tRx, tRz, Rx2, Rz2, alf, dalf, V, fac
    double complex :: ft, tft
    double precision :: tfs, tfr
    dalf=3.14159/Nalf
    do i = 0,M-1
        fft(i)=0.0d0
        ffs(i)=0.0d0
        ffc(i)=0.0d0
        ffr(i)=0.0d0
        tRx=0.0d0
        tRz=0.0d0
        do j = 0, Nalf-1
            alf=float(j)*dalf
            tRx=0.0d0
            tRz=0.0d0
            tft=0.0d0
            tfs=0.0d0
            tfr=0.0d0
            do k = 0, Nlayers-2
                tRx=tRx+Rx(k)
                tRz=tRz+Rx(k)*RzRatio(k)
                Rx2=tRx*tRx
                Rz2=tRz*tRz
                V=4*3.14159*tRz*tRx**2/3.0
                rt=dsqrt(Rx2*dsin(alf)**2+Rz2*dcos(alf)**2)
                fac=3*V*(dsin(q(i)*rt)-q(i)*rt*dcos(q(i)*rt))/(q(i)*rt)**3
                ft=(rho(k)-rho(k+1))*fac
                fs=(eirho(k)-eirho(k+1))*fac
                fr=(adensity(k)-adensity(k+1))*fac
                fc=fs*fr
                tft=tft+ft
                tfs=tfs+fs
                tfr=tfr+fr
            end do
            fft(i)=fft(i)+cdabs(tft)**2*dsin(alf)
            ffs(i)=ffs(i)+tfs**2*dsin(alf)
            ffc(i)=ffc(i)+tfs*tfr*dsin(alf)
            ffr(i)=ffr(i)+tfr**2*dsin(alf)
        end do

        fft(i)=fft(i)*dalf
        ffs(i)=ffs(i)*dalf
        ffc(i)=ffc(i)*dalf
        ffr(i)=ffr(i)*dalf
    end do

end subroutine ff_ellipsoid_ml_asaxs


module linalg_test
    use fruit
    use global_defs
    implicit none

contains

    subroutine test_linalg_wrapper
        use linalg_wrapper_mod
        use matrix_mod
        real(dp) :: inp_mat(2, 2)
        real(dp) :: res_num
        real(dp) :: res_vec(2)
        real(dp) :: res_mat1(2, 2)
        real(dp) :: res_mat2(2, 2)
        real(dp), parameter :: tol = 1.E-12_dp
        real(dp), parameter :: rsq2_mat(2, 2) = reshape([rsq2, -rsq2, rsq2, rsq2], [2, 2])
        real(dp), parameter :: iden_mat(2, 2) = reshape([num1, num0, num0, num1], [2, 2])

        inp_mat = rsq2_mat

        res_num = dot(inp_mat(1, :), inp_mat(2, :))
        call assert_equals(num0, res_num, tol, 'Dot product')

        call gemm(inp_mat, inp_mat, res_mat1)
        res_mat2 = reshape([num0, -num1, num1, num0], [2, 2])
        call assert_equals(res_mat2, res_mat1, 2, 2, tol, 'Matrix multiplication')

        res_num = mat_ge_det(inp_mat)
        call assert_equals(num1, res_num, tol, 'Determinant')

        call gesvd(inp_mat, res_vec, res_mat1, res_mat2)
        call assert_equals([num1, num1], res_vec, 2, tol, 'Matrix SVD')
    end subroutine test_linalg_wrapper

end module linalg_test


*     MB04DD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 100 )
      INTEGER          LDA, LDQG
      PARAMETER        ( LDA = NMAX, LDQG = NMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOB
      INTEGER          I, ILO, INFO, J, N
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA, NMAX), DUMMY(1), QG(LDQG, NMAX+1),
     $                 SCALE(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANTR, DLAPY2
      EXTERNAL         DLANTR, DLAPY2
*     .. External Subroutines ..
      EXTERNAL         MB04DD
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * )  N, JOB
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J), J = 1,N+1 ), I = 1,N )
         CALL MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 30  I = 1, N
               WRITE (NOUT, FMT = 99995) ( A(I,J), J = 1,N )
30          CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 40  I = 1, N
               WRITE (NOUT, FMT = 99995) ( QG(I,J), J = 1,N+1 )
40          CONTINUE
            WRITE (NOUT, FMT = 99993)  ILO
            IF ( ILO.GT.1 ) THEN
                WRITE (NOUT, FMT = 99992) DLAPY2( DLANTR( 'Frobenius',
     $                 'Lower', 'No Unit', N-1, ILO-1, A(2,1), LDA,
     $                 DUMMY ), DLANTR( 'Frobenius', 'Lower', 'No Unit',
     $                 N, ILO-1, QG(1,1), LDQG, DUMMY ) )
            END IF
         END IF
      END IF
*
99999 FORMAT (' MB04DD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04DD = ',I2)
99997 FORMAT (' The balanced matrix A is ')
99996 FORMAT (/' The balanced matrix QG is ')
99995 FORMAT (20(1X,F12.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' ILO = ',I4)
99992 FORMAT (/' Norm of subdiagonal blocks: ',G7.2)
      END


! Module that do integration of S and T given the current state and timestep.

module mod_integrator
  use mod_constants
  use mod_timestep
  use mod_read_parameters
  use mod_variables

  implicit none
  private

  public :: do_timestep_T_imp, do_timestep_T_exp, do_timestep_S_imp, do_timestep_S_exp

contains

  ! Process the right term of dT*/dt*. Simplified case without convection.
  function dT_dt_imp(s)
    implicit none

    type(state), intent(in) :: s

    real(x_precision), dimension(n_cell) :: dT_dt_imp

    ! Second member of the dT/dt equation. Simplified case.
    dT_dt_imp = (s%Qplus - s%Qminus) / s%Cv

  end function dT_dt_imp

  ! Process the right term of dT*/dt*. Full expression with convection.
  function dT_dt_exp(s)
    implicit none

    type(state), intent(in) :: s

    real(x_precision), dimension(n_cell) :: dT_dt_exp

    ! Second member of the dT/dt equation.
    dT_dt_exp = dT_dt_imp(s) + s%Qadv / s%CV

  end function dT_dt_exp

  ! Process the temporal evolution of S with an implicit algorithm.
  ! For use on the stable part of the simulation.
  subroutine do_timestep_S_imp(s, dt)
    implicit none

    real(x_precision), intent(in)    :: dt
    type(state),       intent(inout) :: s

    real(x_precision), dimension(n_cell)   :: diag, x2
    real(x_precision), dimension(n_cell-1) :: diag_low, diag_up
    real(x_precision)                      :: overdx, overdx2, dtoverdx2
    integer                                :: info

    overdx    = 1._x_precision / params%dx
    overdx2   = overdx**2
    dtoverdx2 = dt*overdx2

    x2 = x_state%x**2

    ! Create the diagonals NOT VERIFIED YET
    diag     =  1._x_precision + 2._x_precision * s%nu / x2 * dtoverdx2
    diag_up  = -s%nu(2:n_cell  ) / x2(1:n_cell-1) * dtoverdx2
    diag_low = -s%nu(1:n_cell-1) / x2(2:  n_cell) * dtoverdx2

    diag(n_cell)       = 1._x_precision + s%nu(n_cell) / x2(n_cell) * dtoverdx2
    diag_low(n_cell-1) = - s%nu(n_cell-1) / x2(n_cell) * dtoverdx2

    s%S(n_cell) = s%S(n_cell) + dt * s%Mdot(n_cell) * overdx / x2(n_cell)

    ! Solving for S, this does modify s%S directly
    call dgtsv(n_cell, 1, diag_low, diag, diag_up, s%S, n_cell, info)

    if (info /= 0) then
      stop "Error in DGTSV call in subroutine do_timestep_S_imp"
    end if

  end subroutine do_timestep_S_imp

  ! Process the temporal evolution of S with an explicit algorithm.
  ! For use on the instable part of the simulation.
  subroutine do_timestep_S_exp(s, dt)
    implicit none

    real(x_precision), intent(in)    :: dt
    type(state),       intent(inout) :: s

    s%S = s%S + dt * dS_dt(s)

  end subroutine do_timestep_S_exp

  ! Process the temporal evolution of T with an explicit algorithm.
  subroutine do_timestep_T_imp(s, dt)
    implicit none

    real(x_precision), intent(in)    :: dt
    type(state),       intent(inout) :: s

    real(x_precision), dimension(n_cell) :: dtemp
    real(x_precision), dimension(n_cell) :: f0, fT
    type(state)                          :: s_deriv

    dtemp     = s%T * 1.e-3_x_precision
    s_deriv   = s
    s_deriv%T = s%T + dtemp

    call compute_variables(s_deriv)

    f0 = dT_dt_exp(s)
    fT = (dT_dt_exp(s_deriv) - f0) / dtemp

    s%T = s%T + f0 / fT * (exp(fT*dt) - 1._x_precision)

  end subroutine do_timestep_T_imp

  ! Process the temporal evolution of T with an explicit algorithm.
  subroutine do_timestep_T_exp(s, dt)
    implicit none

    real(x_precision), intent(in)    :: dt
    type(state),       intent(inout) :: s

    real(x_precision), dimension(n_cell) :: dtemp
    real(x_precision), dimension(n_cell) :: f0
    type(state)                          :: s_deriv

    dtemp     = s%T * 1.e-3_x_precision
    s_deriv   = s
    s_deriv%T = s%T + dtemp

    call compute_variables(s_deriv)

    f0 = dT_dt_exp(s)

    s%T = s%T + f0 * dt

  end subroutine do_timestep_T_exp
end module mod_integrator


!==============================================================================!
  subroutine Numerics_Mod_Inertial_Term(phi, coef, sol, dt)
!------------------------------------------------------------------------------!
!   Purpose: Dicretize inertial term in conservation equations.                !
!------------------------------------------------------------------------------!
  implicit none
!-----------------------------------[Arguments]--------------------------------!
  type(Var_Type)            :: phi
  real                      :: coef(-phi % pnt_grid % n_bnd_cells:  &
                                     phi % pnt_grid % n_cells)
  type(Solver_Type), target :: sol
  real                      :: dt
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type),   pointer :: grid
  type(Matrix_Type), pointer :: a
  real,              pointer :: b(:)
  real                       :: a0
  integer                    :: c
!==============================================================================!

  ! Take alias to grid
  grid => phi % pnt_grid
  a    => sol % a
  b    => sol % b % val

  ! Two time levels; Linear interpolation
  if(phi % td_scheme .eq. LINEAR) then
    do c = 1, grid % n_cells
      a0 = coef(c) * grid % vol(c) / dt
      a % val(a % dia(c)) = a % val(a % dia(c)) + a0
      b(c)  = b(c) + a0 * phi % o(c)
    end do
  end if

  ! Three time levels; parabolic interpolation
  if(phi % td_scheme .eq. PARABOLIC) then
    do c = 1, grid % n_cells
      a0 = coef(c) * grid % vol(c) / dt
      a % val(a % dia(c)) = a % val(a % dia(c)) + 1.5 * a0
      b(c)  = b(c) + 2.0 * a0 * phi % o(c) - 0.5 * a0 * phi % oo(c)
    end do
  end if

  end subroutine


c***********************************************************************
      subroutine qss3dHJENO2testNew(
     &  phi,
     &  lse_rhs,
     &  vel_n,
     &  ilo_phi_gb, ihi_phi_gb,
     &  jlo_phi_gb, jhi_phi_gb,
     &  klo_phi_gb, khi_phi_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dx, dy, dz)
c***********************************************************************
c { begin subroutine
      implicit none

c     _phi_gb refers to ghostbox for phi data
c     _fb refers to fill-box for grad_phi data
      integer ilo_phi_gb, ihi_phi_gb
      integer jlo_phi_gb, jhi_phi_gb
      integer klo_phi_gb, khi_phi_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real phi_x_plus
      real phi_y_plus
      real phi_z_plus
      real phi_x_minus
      real phi_y_minus
      real phi_z_minus
      real phi(ilo_phi_gb:ihi_phi_gb,
     &         jlo_phi_gb:jhi_phi_gb,
     &         klo_phi_gb:khi_phi_gb)
      real vel_n(ilo_phi_gb:ihi_phi_gb,
     &           jlo_phi_gb:jhi_phi_gb,
     &           klo_phi_gb:khi_phi_gb)
      real lse_rhs(ilo_phi_gb:ihi_phi_gb,
     &             jlo_phi_gb:jhi_phi_gb,
     &             klo_phi_gb:khi_phi_gb)
      real D1_x, D1_x_plus, D2_x, D2_x_plus, D2_x_minus
      real D1_y, D1_y_plus, D2_y, D2_y_plus, D2_y_minus
      real D1_z, D1_z_plus, D2_z, D2_z_plus, D2_z_minus
      real temp
      real dx, dy, dz
      real inv_dx, inv_dy, inv_dz
      integer i, j, k
      real half
      parameter (half=0.5d0)
      integer order_1, order_2
      parameter (order_1=1,order_2=2)
      integer x_dir, y_dir, z_dir
      parameter (x_dir=1,y_dir=2,z_dir=3)
      real vel_n_cur
      real norm_grad_phi_sq
      real zero_tol
      parameter (zero_tol=1.e-5)

c     compute inv_dx, inv_dy, and inv_dz
      inv_dx = 1.0d0/dx
      inv_dy = 1.0d0/dy
      inv_dz = 1.0d0/dz

c     { begin loop over grid
      do k=klo_fb,khi_fb
        do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

c           phi_x_plus
            D1_x = phi(i,j,k) - phi(i-1,j,k)
            D1_x_plus = phi(i+1,j,k) - phi(i,j,k)
            D2_x = phi(i+1,j,k) + phi(i-1,j,k) - 2*phi(i,j,k)
            D2_x_plus = phi(i+2,j,k) + phi(i,j,k) - 2*phi(i+1,j,k)
            D2_x_minus = phi(i-2,j,k) + phi(i,j,k) - 2*phi(i-1,j,k)

            if (abs(D2_x).lt.abs(D2_x_plus)) then
              phi_x_plus = (D1_x_plus
     &                          - half*D2_x)*inv_dx
            else
              phi_x_plus = (D1_x_plus
     &                          - half*D2_x_plus)*inv_dx
            endif

c           phi_x_minus
            if (abs(D2_x_minus).lt.abs(D2_x)) then
              phi_x_minus = (D1_x
     &                           + half*D2_x_minus)*inv_dx
            else
              phi_x_minus = (D1_x
     &                           + half*D2_x)*inv_dx
            endif

c           phi_y_plus
            D1_y = phi(i,j,k) - phi(i,j-1,k)
            D1_y_plus = phi(i,j+1,k) - phi(i,j,k)
            D2_y = phi(i,j+1,k) + phi(i,j-1,k) - 2*phi(i,j,k)
            D2_y_plus = phi(i,j+2,k) + phi(i,j,k) - 2*phi(i,j+1,k)
            D2_y_minus = phi(i,j-2,k) + phi(i,j,k) - 2*phi(i,j-1,k)

            if (abs(D2_y).lt.abs(D2_y_plus)) then
              phi_y_plus = (D1_y_plus
     &                          - half*D2_y)*inv_dy
            else
              phi_y_plus = (D1_y_plus
     &                          - half*D2_y_plus)*inv_dy
            endif

c           phi_y_minus
            if (abs(D2_y_minus).lt.abs(D2_y)) then
              phi_y_minus = (D1_y
     &                           + half*D2_y_minus)*inv_dy
            else
              phi_y_minus = (D1_y
     &                           + half*D2_y)*inv_dy
            endif

c           phi_z_plus
            D1_z = phi(i,j,k) - phi(i,j,k-1)
            D1_z_plus = phi(i,j,k+1) - phi(i,j,k)
            D2_z = phi(i,j,k+1) + phi(i,j,k-1) - 2*phi(i,j,k)
            D2_z_plus = phi(i,j,k+2) + phi(i,j,k) - 2*phi(i,j,k+1)
            D2_z_minus = phi(i,j,k-2) + phi(i,j,k) - 2*phi(i,j,k-1)

            if (abs(D2_z).lt.abs(D2_z_plus)) then
              phi_z_plus = (D1_z_plus
     &                          - half*D2_z)*inv_dz
            else
              phi_z_plus = (D1_z_plus
     &                          - half*D2_z_plus)*inv_dz
            endif

c           phi_z_minus
            if (abs(D2_z_minus).lt.abs(D2_z)) then
              phi_z_minus = (D1_z
     &                           + half*D2_z_minus)*inv_dz
            else
              phi_z_minus = (D1_z
     &                           + half*D2_z)*inv_dz
            endif

            vel_n_cur = vel_n(i,j,k)
            if (abs(vel_n_cur) .ge. zero_tol) then

c             { begin Godunov selection of grad_phi

              if (vel_n_cur .gt. 0.d0) then
                norm_grad_phi_sq = max(max(phi_x_minus,0.d0)**2,
     &                                 min(phi_x_plus,0.d0)**2 )
     &                           + max(max(phi_y_minus,0.d0)**2,
     &                                 min(phi_y_plus,0.d0)**2 )
     &                           + max(max(phi_z_minus,0.d0)**2,
     &                                 min(phi_z_plus,0.d0)**2 )
              else
                norm_grad_phi_sq = max(min(phi_x_minus,0.d0)**2,
     &                                 max(phi_x_plus,0.d0)**2 )
     &                           + max(min(phi_y_minus,0.d0)**2,
     &                                 max(phi_y_plus,0.d0)**2 )
     &                           + max(min(phi_z_minus,0.d0)**2,
     &                                 max(phi_z_plus,0.d0)**2 )
              endif

c             } end Godunov selection of grad_phi

c            lse_rhs(i,j,k) = - vel_n_cur
c             compute contribution to lse_rhs(i,j,k)
              temp = lse_rhs(i,j,k) - vel_n_cur*sqrt(norm_grad_phi_sq)
              lse_rhs(i,j,k) = temp

            endif
          enddo
        enddo
      enddo
c     } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************

c***********************************************************************
c
c  lsm3dSetVarNorm()
c
c  Arguments:
c    *_gb (in):         index range for ghostbox
c    *_fb (in):         index range for fillbox
c    index_[xyz](in):  [xyz] coordinates of local (narrow band) points
c    n*_index(in):    index range of points to loop over in index_*
c    narrow_band(in): array that marks voxels outside desired fillbox
c    mark_fb(in):     upper limit narrow band value for voxels in
c                     fillbox
c
c***********************************************************************
      subroutine qss3dSetVarNorm(
     &  mask,
     &  mask_x,
     &  mask_y,
     &  mask_z,
     &  var_a,
     &  a0,
     &  ca,
     &  ilo_gb,
     &  ihi_gb,
     &  jlo_gb,
     &  jhi_gb,
     &  klo_gb,
     &  khi_gb,
     &  ilo_fb,
     &  ihi_fb,
     &  jlo_fb,
     &  jhi_fb,
     &  klo_fb,
     &  khi_fb,
     &  dx)
c***********************************************************************
c { begin subroutine
      implicit none

      integer ilo_gb, ihi_gb
      integer jlo_gb, jhi_gb
      integer klo_gb, khi_gb
      integer ilo_fb, ihi_fb
      integer jlo_fb, jhi_fb
      integer klo_fb, khi_fb
      real mask(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real mask_x(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real mask_y(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real mask_z(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real var_a(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real dx
      real ca
      real a0
      integer i, j, k
      real h1, h2, s, C2, C1, eps_var, absgrad, x
      eps_var = 1.5 * dx
      C1 = 0.04
      C2 = 1

c       loop over included cells {
        do k=klo_fb,khi_fb
          do j=jlo_fb,jhi_fb
            do i=ilo_fb,ihi_fb
                call qssHeaviside(h1, -mask(i,j,k), eps_var)
                call qssHeaviside(h2, mask(i,j,k), eps_var)
                absgrad = mask_x(i,j,k) * mask_x(i,j,k) +
     &                     mask_y(i,j,k) * mask_y(i,j,k) +
     &                     mask_z(i,j,k) * mask_z(i,j,k)
                absgrad = SQRT(absgrad)
                x = mask(i,j,k)*mask(i,j,k) + absgrad*dx*absgrad*dx
                x = SQRT(x)
                s = mask(i,j,k)/x
                var_a(i,j,k) = h1 * a0 - s * h2 * C2 * COS(ca)*absgrad
            enddo
          enddo
        enddo
c       } end loop over grid
          return
      end
c***********************************************************************

c***********************************************************************
c
c  lsm3dSetVarCurvAdv()
c
c  Arguments:
c    *_gb (in):         index range for ghostbox
c    *_fb (in):         index range for fillbox
c    index_[xyz](in):  [xyz] coordinates of local (narrow band) points
c    n*_index(in):    index range of points to loop over in index_*
c    narrow_band(in): array that marks voxels outside desired fillbox
c    mark_fb(in):     upper limit narrow band value for voxels in
c                     fillbox
c
c***********************************************************************
      subroutine qss3dSetVarCurvAdv(
     &  mask,
     &  mask_x,
     &  mask_y,
     &  mask_z,
     &  var_b,
     &  vel_x,
     &  vel_y,
     &  vel_z,
     &  b_max_over_dx,
     &  max_U_over_dx,
     &  const_b,
     &  ilo_gb,
     &  ihi_gb,
     &  jlo_gb,
     &  jhi_gb,
     &  klo_gb,
     &  khi_gb,
     &  ilo_fb,
     &  ihi_fb,
     &  jlo_fb,
     &  jhi_fb,
     &  klo_fb,
     &  khi_fb,
     &  dx)
c***********************************************************************
c { begin subroutine
      implicit none

      integer ilo_gb, ihi_gb
      integer jlo_gb, jhi_gb
      integer klo_gb, khi_gb
      integer ilo_fb, ihi_fb
      integer jlo_fb, jhi_fb
      integer klo_fb, khi_fb
      real mask(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real mask_x(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real mask_y(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real mask_z(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real var_b(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real vel_x(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real vel_y(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real vel_z(ilo_gb:ihi_gb,
     &           jlo_gb:jhi_gb,
     &           klo_gb:khi_gb)
      real dx
      real const_b
      integer i, j, k
      real h1, h2, s, C2, C1, eps_var, x, absgrad
      real b_max_over_dx, max_U_over_dx, b_max, U_over_dX_cur
      real inv_dx, inv_dy, inv_dz

      eps_var = 1.5 * dx
      C1 = const_b
      C2 = 1

c     initialize max_U_over_dX to -1
      max_U_over_dX = -1.0d0

c     initialize b_max to -1
      b_max = -1.0d0

c     compute inv_dx, inv_dy, and inv_dz
      inv_dx = 1.0d0/dx
      inv_dy = 1.0d0/dx
      inv_dz = 1.0d0/dx

c       loop over included cells {
        do k=klo_fb,khi_fb
          do j=jlo_fb,jhi_fb
            do i=ilo_fb,ihi_fb
                call qssHeaviside(h1, -mask(i,j,k), eps_var)
                call qssHeaviside(h2, mask(i,j,k), eps_var)
                absgrad = mask_x(i,j,k) * mask_x(i,j,k) +
     &                     mask_y(i,j,k) * mask_y(i,j,k) +
     &                     mask_z(i,j,k) * mask_z(i,j,k)
                absgrad = SQRT(absgrad)
                x = mask(i,j,k)*mask(i,j,k) + absgrad*dx*absgrad*dx
                x = SQRT(x)
                s = mask(i,j,k)/x
                var_b(i,j,k) = h1*C1
c                h2*C1

                if (var_b(i,j,k) > b_max) then
                    b_max = var_b(i,j,k)
                endif

                vel_x(i,j,k) = s * C2 * mask_x(i,j,k) * h2
                vel_y(i,j,k) = s * C2 * mask_y(i,j,k) * h2
                vel_z(i,j,k) = s * C2 * mask_z(i,j,k) * h2

                U_over_dX_cur = abs(vel_x(i,j,k))*inv_dx
     &                        + abs(vel_y(i,j,k))*inv_dy
     &                        + abs(vel_z(i,j,k))*inv_dz

                if (U_over_dX_cur .gt. max_U_over_dX) then
                  max_U_over_dX = U_over_dX_cur
                endif
            enddo
          enddo
        enddo
c       } end loop over grid

          b_max_over_dx = 2 * b_max *
     &               (inv_dx*inv_dx + inv_dy*inv_dy + inv_dz*inv_dz)
          return
      end
c***********************************************************************

c***********************************************************************
      subroutine qss3dGetRHS2nd(
     &  phi,
     &  vel_n,
     &  b,
     &  vel_x, vel_y, vel_z,
     &  max_H_over_dX,
     &  lse_rhs,
     &  ilo_phi_gb, ihi_phi_gb,
     &  jlo_phi_gb, jhi_phi_gb,
     &  klo_phi_gb, khi_phi_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dx, dy, dz)
c***********************************************************************
c { begin subroutine
      implicit none

c     _phi_gb refers to ghostbox for phi data
c     _fb refers to fill-box for grad_phi data
      integer ilo_phi_gb, ihi_phi_gb
      integer jlo_phi_gb, jhi_phi_gb
      integer klo_phi_gb, khi_phi_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb

c     plus and minus upwind derivatives
      real phi_x_plus, phi_y_plus, phi_z_plus
      real phi_x_minus, phi_y_minus, phi_z_minus

c     upwinded derivatives
      real phi_x_adv, phi_y_adv, phi_z_adv

c     central difference derivatives
      real phi_x, phi_y, phi_z

c     second order central difference derivatives
      real phi_xx, phi_yy, phi_zz, phi_xy, phi_xz, phi_yz

      real curv, grad_mag2
      real phi(ilo_phi_gb:ihi_phi_gb,
     &         jlo_phi_gb:jhi_phi_gb,
     &         klo_phi_gb:khi_phi_gb)
      real vel_n(ilo_phi_gb:ihi_phi_gb,
     &           jlo_phi_gb:jhi_phi_gb,
     &           klo_phi_gb:khi_phi_gb)
      real b(ilo_phi_gb:ihi_phi_gb,
     &           jlo_phi_gb:jhi_phi_gb,
     &           klo_phi_gb:khi_phi_gb)
      real vel_x(ilo_phi_gb:ihi_phi_gb,
     &           jlo_phi_gb:jhi_phi_gb,
     &           klo_phi_gb:khi_phi_gb)
      real vel_y(ilo_phi_gb:ihi_phi_gb,
     &           jlo_phi_gb:jhi_phi_gb,
     &           klo_phi_gb:khi_phi_gb)
      real vel_z(ilo_phi_gb:ihi_phi_gb,
     &           jlo_phi_gb:jhi_phi_gb,
     &           klo_phi_gb:khi_phi_gb)
      real lse_rhs(ilo_phi_gb:ihi_phi_gb,
     &             jlo_phi_gb:jhi_phi_gb,
     &             klo_phi_gb:khi_phi_gb)
      real D1_x, D1_x_plus, D2_x, D2_x_plus, D2_x_minus
      real D1_y, D1_y_plus, D2_y, D2_y_plus, D2_y_minus
      real D1_z, D1_z_plus, D2_z, D2_z_plus, D2_z_minus

      real dx, dy, dz
      real inv_dx, inv_dy, inv_dz
      integer i, j, k
      real half
      parameter (half=0.5d0)
      integer order_1, order_2
      parameter (order_1=1,order_2=2)
      integer x_dir, y_dir, z_dir
      parameter (x_dir=1,y_dir=2,z_dir=3)
      real vel_n_cur
      real norm_grad_phi_sq
      real zero_tol
      parameter (zero_tol=1.e-5)
      real max_H_over_dX
      real H_over_dX_cur
      real max_dx_sq
      real norm_grad_phi, phi_x_cur, phi_y_cur, phi_z_cur
      real temp_norm, temp_curv, temp_vel

      real dx_factor, dy_factor, dz_factor

c     compute denominator values, for curvature term
      dx_factor = 0.5d0/dx
      dy_factor = 0.5d0/dy
      dz_factor = 0.5d0/dz

c     compute inv_dx, inv_dy, and inv_dz
      inv_dx = 1.0d0/dx
      inv_dy = 1.0d0/dy
      inv_dz = 1.0d0/dz

c     { begin loop over grid
      do k=klo_fb,khi_fb
        do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

c           phi_x_plus
            D1_x = phi(i,j,k) - phi(i-1,j,k)
            D1_x_plus = phi(i+1,j,k) - phi(i,j,k)
            D2_x = phi(i+1,j,k) + phi(i-1,j,k) - 2*phi(i,j,k)
            D2_x_plus = phi(i+2,j,k) + phi(i,j,k) - 2*phi(i+1,j,k)
            D2_x_minus = phi(i-2,j,k) + phi(i,j,k) - 2*phi(i-1,j,k)

            if (abs(D2_x).lt.abs(D2_x_plus)) then
              phi_x_plus = (D1_x_plus
     &                          - half*D2_x)*inv_dx
            else
              phi_x_plus = (D1_x_plus
     &                          - half*D2_x_plus)*inv_dx
            endif

c           phi_x_minus
            if (abs(D2_x_minus).lt.abs(D2_x)) then
              phi_x_minus = (D1_x
     &                           + half*D2_x_minus)*inv_dx
            else
              phi_x_minus = (D1_x
     &                           + half*D2_x)*inv_dx
            endif

c           phi_y_plus
            D1_y = phi(i,j,k) - phi(i,j-1,k)
            D1_y_plus = phi(i,j+1,k) - phi(i,j,k)
            D2_y = phi(i,j+1,k) + phi(i,j-1,k) - 2*phi(i,j,k)
            D2_y_plus = phi(i,j+2,k) + phi(i,j,k) - 2*phi(i,j+1,k)
            D2_y_minus = phi(i,j-2,k) + phi(i,j,k) - 2*phi(i,j-1,k)

            if (abs(D2_y).lt.abs(D2_y_plus)) then
              phi_y_plus = (D1_y_plus
     &                          - half*D2_y)*inv_dy
            else
              phi_y_plus = (D1_y_plus
     &                          - half*D2_y_plus)*inv_dy
            endif

c           phi_y_minus
            if (abs(D2_y_minus).lt.abs(D2_y)) then
              phi_y_minus = (D1_y
     &                           + half*D2_y_minus)*inv_dy
            else
              phi_y_minus = (D1_y
     &                           + half*D2_y)*inv_dy
            endif

c           phi_z_plus
            D1_z = phi(i,j,k) - phi(i,j,k-1)
            D1_z_plus = phi(i,j,k+1) - phi(i,j,k)
            D2_z = phi(i,j,k+1) + phi(i,j,k-1) - 2*phi(i,j,k)
            D2_z_plus = phi(i,j,k+2) + phi(i,j,k) - 2*phi(i,j,k+1)
            D2_z_minus = phi(i,j,k-2) + phi(i,j,k) - 2*phi(i,j,k-1)

            if (abs(D2_z).lt.abs(D2_z_plus)) then
              phi_z_plus = (D1_z_plus
     &                          - half*D2_z)*inv_dz
            else
              phi_z_plus = (D1_z_plus
     &                          - half*D2_z_plus)*inv_dz
            endif

c           phi_z_minus
            if (abs(D2_z_minus).lt.abs(D2_z)) then
              phi_z_minus = (D1_z
     &                           + half*D2_z_minus)*inv_dz
            else
              phi_z_minus = (D1_z
     &                           + half*D2_z)*inv_dz
            endif

            vel_n_cur = vel_n(i,j,k)
            if (abs(vel_n_cur) .ge. zero_tol) then

c             { begin Godunov selection of grad_phi

              if (vel_n_cur .gt. 0.d0) then
                norm_grad_phi_sq = max(max(phi_x_minus,0.d0)**2,
     &                                 min(phi_x_plus,0.d0)**2 )
     &                           + max(max(phi_y_minus,0.d0)**2,
     &                                 min(phi_y_plus,0.d0)**2 )
     &                           + max(max(phi_z_minus,0.d0)**2,
     &                                 min(phi_z_plus,0.d0)**2 )
              else
                norm_grad_phi_sq = max(min(phi_x_minus,0.d0)**2,
     &                                 max(phi_x_plus,0.d0)**2 )
     &                           + max(min(phi_y_minus,0.d0)**2,
     &                                 max(phi_y_plus,0.d0)**2 )
     &                           + max(min(phi_z_minus,0.d0)**2,
     &                                 max(phi_z_plus,0.d0)**2 )
              endif

c             } end Godunov selection of grad_phi

c             compute contribution to lse_rhs(i,j,k)
              temp_norm = - vel_n_cur*sqrt(norm_grad_phi_sq)

            endif

c           get max_H_over_dX for calculating stable dt
c           initialize max_H_over_dX to -1
            max_H_over_dX = -1.0d0

c           compute max_dx_sq
            max_dx_sq = max(dx,dy,dz)
            max_dx_sq = max(dx,dy,dz) * max(dx,dy,dz)

            phi_x_cur = max(abs(phi_x_plus),
     &                          abs(phi_x_minus))
            phi_y_cur = max(abs(phi_y_plus),
     &                          abs(phi_y_minus))
            phi_z_cur = max(abs(phi_z_plus),
     &                       abs(phi_z_minus))
            norm_grad_phi = sqrt( phi_x_cur*phi_x_cur
     &                            + phi_y_cur*phi_y_cur
     &                            + phi_z_cur*phi_z_cur + max_dx_sq )

            H_over_dX_cur = abs(vel_n(i,j,k)) / norm_grad_phi
     &                        * ( phi_x_cur*inv_dx
     &                        + phi_y_cur*inv_dy
     &                        + phi_z_cur*inv_dz )

            if (H_over_dX_cur .gt. max_H_over_dX) then
                  max_H_over_dX = H_over_dX_cur
            endif

c           compute advective term contributions
c              phi_x
              if (vel_x(i,j,k).ge.0) then
                phi_x_adv = phi_x_minus
              else
                phi_x_adv = phi_x_plus
              endif

c              phi_y
              if (vel_y(i,j,k).ge.0) then
                phi_y_adv = phi_y_minus
              else
                phi_y_adv = phi_y_plus
              endif

c              phi_z
              if (vel_z(i,j,k).ge.0) then
                phi_z_adv = phi_z_minus
              else
                phi_z_adv= phi_z_plus
              endif

            temp_vel = - ( vel_x(i,j,k)*phi_x_adv
     &                       + vel_y(i,j,k)*phi_y_adv
     &                       + vel_z(i,j,k)*phi_z_adv )

c         compute curvature term
            phi_x = (phi(i+1,j,k) - phi(i-1,j,k))*dx_factor
            phi_y = (phi(i,j+1,k) - phi(i,j-1,k))*dy_factor
            phi_z = (phi(i,j,k+1) - phi(i,j,k-1))*dz_factor

            phi_xx = (phi(i+2,j,k) + phi(i-2,j,k)
     &               - 2*phi(i,j,k))*dx_factor*dx_factor
            phi_zz = (phi(i,j,k+2) + phi(i,j,k-2)
     &               - 2*phi(i,j,k))*dz_factor*dz_factor
            phi_yy = (phi(i,j+2,k) + phi(i,j-2,k)
     &               - 2*phi(i,j,k))*dy_factor*dy_factor

            phi_xy = (phi(i+1,j+1,k) + phi(i-1,j-1,k)
     &               - phi(i-1,j+1,k) - phi(i+1,j-1,k))
     &               *dx_factor*dy_factor
            phi_xz = (phi(i+1,j,k+1) + phi(i-1,j,k-1)
     &               - phi(i-1,j,k+1) - phi(i+1,j,k-1))
     &               *dx_factor*dz_factor
            phi_yz = (phi(i,j+1,k+1) + phi(i,j-1,k-1)
     &               - phi(i,j-1,k+1) - phi(i,j+1,k-1))
     &               *dy_factor*dz_factor

c           compute squared magnitude of gradient
            grad_mag2 = phi_x * phi_x
     &                + phi_y * phi_y
     &                + phi_z * phi_z
            if (grad_mag2 .lt. zero_tol) then
              curv = 0.d0
            else
              curv = phi_xx*phi_y*phi_y
     &             +   phi_yy*phi_x*phi_x
     &             - 2*phi_xy*phi_x*phi_y
     &             +   phi_xx*phi_z*phi_z
     &             +   phi_zz*phi_x*phi_x
     &             - 2*phi_xz*phi_x*phi_z
     &             +   phi_yy*phi_z*phi_z
     &             +   phi_zz*phi_y*phi_y
     &             - 2*phi_yz*phi_y*phi_z
              curv = curv / grad_mag2
            endif

            temp_curv = b(i,j,k)*curv

	    lse_rhs(i,j,k) = temp_norm + temp_curv + temp_vel
          enddo
        enddo
      enddo
c     } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************
c***********************************************************************
c
c  lsm3dCentralGradOrder2() computes the second-order, central,
c  finite difference approximation to the gradient of phi.
c
c  Arguments:
c    phi_* (out):      components of grad(phi)
c    phi (in):         phi
c    dx, dy, dz (in):  grid spacing
c    *_gb (in):        index range for ghostbox
c    *_fb (in):        index range for fillbox
c
c***********************************************************************
      subroutine qss3dCentralGradOrder2(
     &  phi_x, phi_y, phi_z,
     &  ilo_grad_phi_gb, ihi_grad_phi_gb,
     &  jlo_grad_phi_gb, jhi_grad_phi_gb,
     &  klo_grad_phi_gb, khi_grad_phi_gb,
     &  phi,
     &  ilo_phi_gb, ihi_phi_gb,
     &  jlo_phi_gb, jhi_phi_gb,
     &  klo_phi_gb, khi_phi_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dx, dy, dz)
c***********************************************************************
c { begin subroutine
      implicit none

c     _grad_phi_gb refers to ghostbox for grad_phi data
c     _phi_gb refers to ghostbox for phi data
c     _fb refers to fill-box for grad_phi data
      integer ilo_grad_phi_gb, ihi_grad_phi_gb
      integer jlo_grad_phi_gb, jhi_grad_phi_gb
      integer klo_grad_phi_gb, khi_grad_phi_gb
      integer ilo_phi_gb, ihi_phi_gb
      integer jlo_phi_gb, jhi_phi_gb
      integer klo_phi_gb, khi_phi_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real phi_x(ilo_grad_phi_gb:ihi_grad_phi_gb,
     &           jlo_grad_phi_gb:jhi_grad_phi_gb,
     &           klo_grad_phi_gb:khi_grad_phi_gb)
      real phi_y(ilo_grad_phi_gb:ihi_grad_phi_gb,
     &           jlo_grad_phi_gb:jhi_grad_phi_gb,
     &           klo_grad_phi_gb:khi_grad_phi_gb)
      real phi_z(ilo_grad_phi_gb:ihi_grad_phi_gb,
     &           jlo_grad_phi_gb:jhi_grad_phi_gb,
     &           klo_grad_phi_gb:khi_grad_phi_gb)
      real phi(ilo_phi_gb:ihi_phi_gb,
     &         jlo_phi_gb:jhi_phi_gb,
     &         klo_phi_gb:khi_phi_gb)
      real dx, dy, dz
      integer i,j,k
      real dx_factor, dy_factor, dz_factor

c     compute denominator values
      dx_factor = 0.5d0/dx
      dy_factor = 0.5d0/dy
      dz_factor = 0.5d0/dz

c     { begin loop over grid
      do k=klo_fb,khi_fb
        do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

            phi_x(i,j,k) = (phi(i+1,j,k) - phi(i-1,j,k))*dx_factor
            phi_y(i,j,k) = (phi(i,j+1,k) - phi(i,j-1,k))*dy_factor
            phi_z(i,j,k) = (phi(i,j,k+1) - phi(i,j,k-1))*dz_factor

          enddo
        enddo
      enddo
c     } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************

c***********************************************************************
      subroutine qss3dSignedLinearExtrapolation(
     &  phi,
     &  ilo_gb, ihi_gb, jlo_gb, jhi_gb, klo_gb, khi_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  bdry_location_idx)
c***********************************************************************
c { begin subroutine
      implicit none

      integer ilo_gb, ihi_gb, jlo_gb, jhi_gb, klo_gb, khi_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      integer bdry_location_idx
      real phi(ilo_gb:ihi_gb,jlo_gb:jhi_gb,klo_gb:khi_gb)

c     local variables
      integer i,j,k
      real s, abs_diff, dist, slope
      real one
      parameter (one = 1.0d0)

      if (bdry_location_idx .eq. 0) then
c     { extrapolate data in x-direction at lower end

c       { begin k,j loop
        do k = klo_gb, khi_gb
          do j = jlo_gb, jhi_gb
            s = sign(one,phi(ilo_fb,j,k))
            abs_diff = abs(phi(ilo_fb,j,k) - phi(ilo_fb+1,j,k))
            slope = s*abs_diff
            do i = ilo_gb, ilo_fb-1
              dist = ilo_fb - i
              phi(i,j,k) = phi(ilo_fb,j,k) + slope*dist
            enddo
          enddo
        enddo
c       } end k,j loop

c     } end extrapolate data in x-direction at lower end

      elseif (bdry_location_idx .eq. 1) then
c     { extrapolate data in x-direction at upper end

c       { begin k,j loop
        do k = klo_gb, khi_gb
          do j = jlo_gb, jhi_gb
            s = sign(one,phi(ihi_fb,j,k))
            abs_diff = abs(phi(ihi_fb,j,k) - phi(ihi_fb-1,j,k))
            slope = s*abs_diff
            do i = ihi_fb+1, ihi_gb
              dist = i - ihi_fb
              phi(i,j,k) = phi(ihi_fb,j,k) + slope*dist
            enddo
          enddo
        enddo
c       } end k,j loop

c     } end extrapolate data in x-direction at upper end

      elseif (bdry_location_idx .eq. 2) then
c     { extrapolate data in y-direction at lower end

c       { begin i,k loop
        do i = ilo_gb, ihi_gb
          do k = klo_gb, khi_gb
            s = sign(one,phi(i,jlo_fb,k))
            abs_diff = abs(phi(i,jlo_fb,k) - phi(i,jlo_fb+1,k))
            slope = s*abs_diff
            do j = jlo_gb, jlo_fb-1
              dist = jlo_fb - j
              phi(i,j,k) = phi(i,jlo_fb,k) + slope*dist
            enddo
          enddo
        enddo
c       } end i,k loop

c     } end extrapolate data in y-direction at lower end

      elseif (bdry_location_idx .eq. 3) then
c     { extrapolate data in y-direction at upper end

c       { begin i,k loop
        do i = ilo_gb, ihi_gb
          do k = klo_gb, khi_gb
            s = sign(one,phi(i,jhi_fb,k))
            abs_diff = abs(phi(i,jhi_fb,k) - phi(i,jhi_fb-1,k))
            slope = s*abs_diff
            do j = jhi_fb+1, jhi_gb
              dist = j - jhi_fb
              phi(i,j,k) = phi(i,jhi_fb,k) + slope*dist
            enddo
          enddo
        enddo
c       } end i,k loop

c     } end extrapolate data in y-direction at upper end

      elseif (bdry_location_idx .eq. 4) then
c     { extrapolate data in z-direction at lower end

c       { begin i,j loop
        do i = ilo_gb, ihi_gb
          do j = jlo_gb, jhi_gb
            s = sign(one,phi(i,j,klo_fb))
            abs_diff = abs(phi(i,j,klo_fb) - phi(i,j,klo_fb+1))
            slope = s*abs_diff
            do k = klo_gb, klo_fb-1
              dist = klo_fb - k
              phi(i,j,k) = phi(i,j,klo_fb) + slope*dist
            enddo
          enddo
        enddo
c       } end i,j loop

c     } end extrapolate data in z-direction at lower end

      elseif (bdry_location_idx .eq. 5) then
c     { extrapolate data in z-direction at upper end

c       { begin i,j loop
        do i = ilo_gb, ihi_gb
          do j = jlo_gb, jhi_gb
            s = sign(one,phi(i,j,khi_fb))
            abs_diff = abs(phi(i,j,khi_fb) - phi(i,j,khi_fb-1))
            slope = s*abs_diff
            do k = khi_fb+1, khi_gb
              dist = k - khi_fb
              phi(i,j,k) = phi(i,j,khi_fb) + slope*dist
            enddo
          enddo
        enddo
c       } end i,j loop

c     } end extrapolate data in z-direction at upper end

      endif
      return
      end
c } end subroutine
c***********************************************************************


      program main

      implicit none

      double precision A( 2000, 2000 ), t( 2000 ), work( 2000*104 )
      double precision Aold( 2000, 2000 )
      double precision b( 2000 ), x( 2000 )

      double precision extern rand, fla_clock_f, dnrm2

      double precision time, bnrm

      integer m, i, j, lda, lwork, info

      print *, "input m:"
      read *, m

      print *, "m = ", m

C     Create a random m x m matrix A and copy to Aold

      do j=1,m
         do i=1,m
            A( i, j )    = rand()
            Aold( i, j ) = A( i, j )
         enddo
      enddo

C     Create a random right-hand-side vector b and copy to x

      do i=1,m
         b( i ) = rand()
         x( i ) = b( i )
      enddo

      lda = 2000
      lwork = 2000*104

      time = fla_clock_f()

C     Factor the matrix

      call dgeqrf( m, m, A, lda, t, work, lwork, info )

C     Apply Q to x (=b)

      call dormqr( "L", "T", m, 1, m, A, lda, t, x, lda, work, lwork,
     &             info )

C     Perform backward substitution

      call dtrsv( "U", "N", "N", m, a, lda, x, 1 )

      time = fla_clock_f() - time

C     Check residual

      call dgemv( "N", m, m, -1.0d0, Aold, lda, x, 1, 1.0d0, b, 1 )

C     print residual

      bnrm = dnrm2( m, b, 1 );
      print *, "norm of residual = ", bnrm
      print *, "time             = ", time
      print *, "MFLOPS           = ",
     &     4.0 / 3.0 * m * m * m / time * 1e-6

      stop
      end


      subroutine bchfac ( w, nbands, nrow, diag )
c  from  * a practical guide to splines *  by c. de boor
constructs cholesky factorization
c		      c  =  l * d * l-transpose
c  with l unit lower triangular and d diagonal, for given matrix c of
c  order  n r o w , in case  c	is (symmetric) positive semidefinite
c  and	b a n d e d , having  n b a n d s  diagonals at and below the
c  main diagonal.
c
c******  i n p u t  ******
c  nrow.....is the order of the matrix	c .
c  nbands.....indicates its bandwidth, i.e.,
c	   c(i,j) = 0 for abs(i-j) .gt. nbands .
c  w.....workarray of size (nbands,nrow)  containing the  nbands  diago-
c	 nals in its rows, with the main diagonal in row  1 . precisely,
c	 w(i,j)  contains  c(i+j-1,j), i=1,...,nbands, j=1,...,nrow.
c	   for example, the interesting entries of a seven diagonal sym-
c	 metric matrix	c  of order  9	would be stored in  w  as
c
c			11 22 33 44 55 66 77 88 99
c			21 32 43 54 65 76 87 98
c			31 42 53 64 75 86 97
c			41 52 63 74 85 96
c
c	 all other entries of  w  not identified in this way with an en-
c	 try of  c  are never referenced .
c  diag.....is a work array of length  nrow .
c
c******  o u t p u t  ******
c  w.....contains the cholesky factorization  c = l*d*l-transp, with
c	 w(1,i) containing  1/d(i,i)
c	 and  w(i,j)  containing  l(i-1+j,j), i=2,...,nbands.
c
c******  m e t h o d  ******
c   gauss elimination, adapted to the symmetry and bandedness of  c , is
c   used .
c     near zero pivots are handled in a special way. the diagonal ele-
c  ment c(n,n) = w(1,n) is saved initially in  diag(n), all n. at the n-
c  th elimination step, the current pivot element, viz.  w(1,n), is com-
c  pared with its original value, diag(n). if, as the result of prior
c  elimination steps, this element has been reduced by about a word
c  length, (i.e., if w(1,n)+diag(n) .le. diag(n)), then the pivot is de-
c  clared to be zero, and the entire n-th row is declared to be linearly
c  dependent on the preceding rows. this has the effect of producing
c   x(n) = 0  when solving  c*x = b  for  x, regardless of  b. justific-
c  ation for this is as follows. in contemplated applications of this
c  program, the given equations are the normal equations for some least-
c  squares approximation problem, diag(n) = c(n,n) gives the norm-square
c  of the n-th basis function, and, at this point,  w(1,n)  contains the
c  norm-square of the error in the least-squares approximation to the n-
c  th basis function by linear combinations of the first n-1 . having
c  w(1,n)+diag(n) .le. diag(n) signifies that the n-th function is lin-
c  early dependent to machine accuracy on the first n-1 functions, there
c  fore can safely be left out from the basis of approximating functions
c     the solution of a linear system
c			c*x = b
c   is effected by the succession of the following  t w o  calls:
c     call bchfac ( w, nbands, nrow, diag )	  , to get factorization
c     call bchslv ( w, nbands, nrow, b, x )	       , to solve for x.
c
      integer nbands,nrow,   i,imax,j,jmax,n
      real w(nbands,nrow),diag(nrow),	ratio
      if (nrow .gt. 1)			go to 9
      if (w(1,1) .gt. 0.) w(1,1) = 1./w(1,1)
					return
c					 store diagonal of  c  in  diag.
    9 do 10 n=1,nrow
   10	 diag(n) = w(1,n)
c							 factorization .
      do 20 n=1,nrow
	 if (w(1,n)+diag(n) .gt. diag(n)) go to 15
	 do 14 j=1,nbands
   14	    w(j,n) = 0.
					go to 20
   15	 w(1,n) = 1./w(1,n)
	 imax = min0(nbands-1,nrow - n)
	 if (imax .lt. 1)		go to 20
	 jmax = imax
	 do 18 i=1,imax
	    ratio = w(i+1,n)*w(1,n)
	    do 17 j=1,jmax
   17	       w(j,n+i) = w(j,n+i) - w(j+i,n)*ratio
	    jmax = jmax - 1
   18	    w(i+1,n) = ratio
   20	 continue
					return
      end


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves Brusselator equations in 3 dimensions
	! u_t = a + u^2v - (b+1)u + Du (u_{xx} + u_{yy} + u_{zz})
        ! v_t = bu - u^2v + Dv (v_{xx} + v_{yy} + v_{zz})
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  tol				=max error each timestep
	! .. Scalars ..
	!  pp				= order of the splitting method
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  dt				= timestep
	!  modescalereal	= Number to scale after backward FFT
	!  myid				= Process id
	!  ierr				= error code
	!  p_row			= number of rows for domain decomposition
	!  p_col			= number of columns for domain decomposition
	!  plotnum			= number of plot to save
	!  stat				= error indicator when reading inputfile
	! .. Arrays ..
	!  uhigh 			= approximate solution u higher order
	!  vhigh			= approximate solution v higher order
	!  ulow 			= approximate solution u lower order
	!  vlow				= approximate solution v lower order
	!  uhat 			= Fourier transform of u
	!  vhat				= Fourier transform of v
	!  savearray			= stores the realpart to save the data
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction squared
	!  ky				= fourier frequencies in y direction squared
	!  kz				= fourier frequencies in z direction squared
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!  time				= times at which save data
	!  nameconfig		= array to store filename for data to be saved
	!  dpcomm
	!  intcomm
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!  sp				see http://www.2decomp.org/ for more information
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library

	PROGRAM main
	USE decomp_2d
	USE decomp_2d_fft
	USE decomp_2d_io
	!USE MPI
	! Declare variables
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	INTEGER(kind=4), PARAMETER	 ::  Nx=64
	INTEGER(kind=4), PARAMETER 	 ::  Ny=64
	INTEGER(kind=4), PARAMETER 	 ::  Nz=64
	INTEGER(kind=4), PARAMETER       ::  nmax=10000000
	REAL(kind=8), PARAMETER		 ::  Tmax=60.0
	REAL(kind=8), PARAMETER		 ::  plotgap=0.05
	REAL(kind=8), PARAMETER	         ::&
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER		 ::  Lx=1.0,Ly=1.0,Lz=1.0
	!equation specific
	REAL(kind=8), PARAMETER		 ::  a=2.0d0
	REAL(kind=8), PARAMETER          ::  b=18.20d0
	REAL(kind=8), PARAMETER		 ::  Du=0.050d0
	REAL(kind=8), PARAMETER		 ::  Dv=0.050d0
	REAL(kind=8)		         ::  dt=0.1**3
	REAL(kind=8)	                 ::  plottime=0.0
	INTEGER(kind=4) 	         ::  plotnum=0
	COMPLEX(kind=8)		         ::  utemp, vtemp, uhatemp
	COMPLEX(kind=8), 	DIMENSION(:), ALLOCATABLE	::  kx,ky,kz
	REAL(kind=8),  	        DIMENSION(:), ALLOCATABLE	::  x,y,z
	COMPLEX(kind=8), 	DIMENSION(:,:,:), ALLOCATABLE	::  uhigh,vhigh
	REAL(kind=8),       DIMENSION(:,:,:), ALLOCATABLE	::  savefield
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE	        ::  uhat,vhat
	REAL(kind=8), 	 DIMENSION(:), ALLOCATABLE	        ::  time
	REAL(kind=8) 		::  modescalereal, myerr,allerr,mymaxv,mymaxu,maxu,maxv
	INTEGER(kind=4)		::  i,j,k,l,n,m,mm,ll,AllocateStatus,stat
	INTEGER(kind=4)		::  myid,numprocs,ierr
	TYPE(DECOMP_INFO)	::  decomp
	INTEGER(kind=4)		::  p_row=0, p_col=0
	INTEGER(kind=4)		::  start, finish,  starttot, finishtot, count_rate, ind
	CHARACTER*500		::  nameconfig
	CHARACTER*200		::  numberfile

	! splitting coeffiecents
	COMPLEX(kind=8), DIMENSION(1:6), PARAMETER	::  aa=(/&
	CMPLX(0.0442100822731214759d0 , -0.0713885293035937610d0,8),&
	CMPLX(0.157419072651724312d0  , -0.1552628290245811054d0,8),&
	CMPLX(0.260637333463417766d0  ,  0.0774417252676963806d0,8),&
	CMPLX(0.059274548196998816d0  , +0.354231218126596507d0,8),&
	CMPLX(0.353043498499040389d0  , +0.0768951336684972038d0,8),&
	CMPLX(0.125415464915697242d0  , -0.281916718734615225d0,8)/)
	COMPLEX(kind=8), DIMENSION(1:6), PARAMETER  ::  bb=(/&
	CMPLX(0.0973753110633760585d0 , -0.112390152630243038d0,8),&
	CMPLX(0.179226865237094561d0  , -0.0934263750859694959d0,8),&
	CMPLX(0.223397823699529381d0  , +0.205816527716212533d0,8),&
	CMPLX(0.223397823699529381d0  , +0.205816527716212533d0,8),&
	CMPLX(0.179226865237094561d0  , -0.0934263750859694959d0,8),&
	CMPLX(0.0973753110633760585d0 , -0.112390152630243038d0,8)/)
	COMPLEX(kind=8), DIMENSION(1:6), PARAMETER  ::  cc=(/&
	CMPLX(0.125415464915697242d0 , -0.281916718734615225d0,8),&
	CMPLX(0.353043498499040389d0 , +0.0768951336684972038d0,8),&
	CMPLX(0.059274548196998816d0 , +0.354231218126596507d0,8),&
	CMPLX(0.260637333463417766d0 , +0.0774417252676963806d0,8),&
	CMPLX(0.157419072651724312d0 , -0.1552628290245811054d0,8),&
	CMPLX(0.0442100822731214759d0 ,-0.0713885293035937610d0,8)/)
	INTEGER(kind=4)		::  pp=3
	INTEGER(kind=4)		::  ss=6
	CHARACTER*100		::  name
	name='./data/brusselator'

        plottime=plotgap
	    ! initialisation of MPI
	CALL system_clock(starttot,count_rate)
	CALL MPI_INIT(ierr)
	CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
	CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)

	CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
	! get information about domain decomposition choosen
	CALL decomp_info_init(Nx,Ny,Nz,decomp) ! physical domain
	! initialise FFT library
	CALL decomp_2d_fft_init

	ALLOCATE(Uhigh(decomp%xst(1):decomp%xen(1),&
   				   decomp%xst(2):decomp%xen(2),&
   				   decomp%xst(3):decomp%xen(3)),&
             Vhigh(decomp%xst(1):decomp%xen(1),&
                   decomp%xst(2):decomp%xen(2),&
                   decomp%xst(3):decomp%xen(3)),&
	         uhat(decomp%zst(1):decomp%zen(1),&
                  decomp%zst(2):decomp%zen(2),&
                  decomp%zst(3):decomp%zen(3)),&
             vhat(decomp%zst(1):decomp%zen(1),&
                  decomp%zst(2):decomp%zen(2),&
                  decomp%zst(3):decomp%zen(3)),&
             savefield(decomp%xst(1):decomp%xen(1),&
                       decomp%xst(2):decomp%xen(2),&
                       decomp%xst(3):decomp%xen(3)),&
		     kx(decomp%zst(1):decomp%zen(1)), &
		     ky(decomp%zst(2):decomp%zen(2)), &
		     kz(decomp%zst(3):decomp%zen(3)), &
		     x(decomp%xst(1):decomp%xen(1)),&
		     y(decomp%xst(2):decomp%xen(2)),&
		     z(decomp%xst(3):decomp%xen(3)),&
   		     time(1:nmax),&
		     stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP

	IF (myid.eq.0) THEN
		PRINT *,'allocated space'
	END IF
	CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
	modescalereal=1.0d0/REAL(Nx,KIND(0d0))
	modescalereal=modescalereal/REAL(Ny,KIND(0d0))
	modescalereal=modescalereal/REAL(Nz,KIND(0d0))
	! setup fourier frequencies and grid points
    CALL getgrid(myid,Nx,Ny,Nz,Lx,Ly,Lz,pi,name,x,y,z,kx,ky,kz,decomp)
	IF (myid.eq.0) THEN
	 PRINT *,'Setup grid and fourier frequencies'
	END IF

	!initial condition
	CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
        CALL initialdata(Nx,Ny,Nz,x,y,z,uhigh,vhigh,decomp)
	n=1
	time(n)=0.0
	plotnum=10000000
	!Write initial data to disc
        CALL savedata(Nx,Ny,Nz,plotnum,name,savefield,uhigh,vhigh,decomp)
	IF (myid.eq.0) THEN
	 PRINT *,'Got initial data, starting timestepping'
	END IF
	CALL system_clock(start,count_rate)
!main loop
	DO WHILE ((n<nmax))
	 n=n+1
     DO l=1,ss
      ! Solve first nonlinear part
      CALL nonlinear1(dt,aa(l),uhigh,vhigh,decomp)
      ! Solve second nonlinear part
      CALL nonlinear2(dt,bb(l),uhigh,vhigh,decomp)
      ! solve linear part exactly in Fourier space
      CALL linear(a,b,Du,Dv,dt,modescalereal,cc(l),kx,ky,kz,uhigh,vhigh,uhat,vhat,decomp)
      !end loop on stages for splitting method indexed by l
     END DO
     time(n)=time(n-1)+dt

  !write data
	  IF (time(n).ge.plottime) THEN
	   plotnum=plotnum+1
	   plottime=plottime+plotgap
	   IF (myid.eq.0) THEN
	    PRINT *,'time',time(n),'n',n,'plot',plotnum
	   END IF
       CALL savedata(Nx,Ny,Nz,plotnum,name,savefield,uhigh,vhigh,decomp)
! If time greater than plotting time
	  END IF
	END DO	!timestepping
	!last data output
	plotnum=plotnum+1
	plottime=plottime+plotgap
	IF ((myid.eq.0).and.(n.eq.nmax)) THEN
	 PRINT *,'time',time(n),'n',n,'plot',plotnum
	END IF
        CALL savedata(Nx,Ny,Nz,plotnum,name,savefield,uhigh,vhigh,decomp)
  	CALL system_clock(finish,count_rate)
	IF (myid.eq.0) THEN
	 PRINT *,'Finished time stepping steps:', n
	 PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),'for time stepping', &
	 REAL(finish-start)/REAL(count_rate)*numprocs
     	END IF
	CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
	 ! clean up
  	CALL decomp_2d_fft_finalize
  	CALL decomp_2d_finalize
 	DEALLOCATE(uhigh,vhigh,&
		        uhat,vhat,&
   		        kx,ky,x,y,savefield,&
   		        time,stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP

	IF (myid.eq.0) THEN
	 PRINT *,'Program execution complete'
	END IF
	CALL MPI_FINALIZE(ierr)
	CALL system_clock(finishtot,count_rate)
	IF (myid.eq.0) THEN
	 PRINT*,'Program took total',REAL(finishtot-starttot)/REAL(count_rate),'for execution', &
	 REAL(finishtot-starttot)/REAL(count_rate)*numprocs
	END IF
	END PROGRAM main


      SUBROUTINE GETDER (
     &  P, R, B,
     &  X, Y, Z,
     &  DER_X, DER_Y, DER_Z
     &)
      DOUBLE PRECISION :: P, R, B, X, Y, Z
      DOUBLE PRECISION :: DER_X, DER_Y, DER_Z

      DER_X = -P*X + P*Y
      DER_Y = -X*Z + R*X - Y
      DER_Z = +X*Y - B*Z

      END


!===============================================================================
program VRH_average
!===============================================================================
!  Compute the Voigt-Reuss-Hill average of two or more elasticity tensors.
!  Usage:
!     CIJ_VRH < [input] > [output]
!     input is: VF(i)   c11(i)   c12(i) ... c16(i)   c21(i)   ... c26(i)   ... c66(i)
!               VF(i+1) c11(i+1) c12(i) ... c16(i+1) c21(i+1) ... c26(i+1) ... c66(i+1)
!  OR
!     CIJ_VRH [.ecs file 1] [VF 1]  [.ecs file 2] [VF 2] ... [.ecs file n] [VF n]

use anisotropy_ajn, only: CIJ_VRH_n, CIJ_load

implicit none

integer,parameter :: nmax = 10000  ! Maximum number of constants to average
integer :: n,i,ii,jj
real(8) :: C(nmax,6,6),Ctemp(6,6)
real(8) :: VF(nmax),VFtemp
real(8) :: r(nmax),rtemp
character(len=250) :: arg
character(len=250)  :: file
integer :: ioerr

!  Check for correct invocation
if (modulo(command_argument_count(),2) /= 0) then
   write(0,'(a)') &
   'Usage:', &
   '   CIJ_VRH < [input] > [output]', &
   '   input is: VF(i)   c11(i)   c12(i) ... c16(i)   c21(i)   ... c26(i)   ... c66(i)   rho(i)', &
   '             VF(i+1) c11(i+1) c12(i) ... c16(i+1) c21(i+1) ... c26(i+1) ... c66(i+1) rho(i+1)', &
   'OR', &
   '   CIJ_VRH [.ecs file 1] [VF 1]  [.ecs file 2] [VF 2] ... [.ecs file n] [VF n]',&
   '   Output: 36 ecs and density'
   stop
endif

!  Loop through lines of stdin in, which each contain volume fraction, and then
!  36 elastic constants
if (command_argument_count() == 0) then
   ioerr = 0
   i = 1
   do while (ioerr == 0)
      read(*,*,iostat=ioerr) VFtemp, ((Ctemp(ii,jj),jj=1,6),ii=1,6), rtemp
      if (ioerr > 0) then
         write(0,'(a)') 'CIJ_VRH: Error: problem reading constants from stdin.'
         stop
      endif
      if (ioerr < 0) exit
      VF(i) = VFtemp
      C(i,:,:) = Ctemp
      r(i) = rtemp
      n = i
      i = i + 1
   enddo

   call CIJ_VRH_n(n,VF(1:n),C(1:n,:,:),r(1:n),Ctemp,rtemp)

   write(*,*) ((Ctemp(ii,jj),jj=1,6),ii=1,6),rtemp

!  Read the .ecs files from the command line and mix them in the proportions given
!  by every second command line argument
else
   n = command_argument_count()/2
   !  Loop over input files
   do i=1,n
      call get_command_argument(2*i-1,file)  ! Get .ecs file
      call get_command_argument(2*i,  arg)
      read(arg,*) VF(i)
      call CIJ_load(file,Ctemp,rtemp)
      C(i,:,:) = Ctemp/rtemp
      r(i) = rtemp
   enddo

   call CIJ_VRH_n(n,VF(1:n),C(1:n,:,:),r(1:n),Ctemp,rtemp)

   write(*,*) ((Ctemp(ii,jj),jj=1,6),ii=1,6),rtemp
endif

end program


! { dg-options "-fdec-math" }
! { dg-do run }
!
! Test extra math intrinsics offered by -fdec-math.
!

  subroutine cmpf(f1, f2, tolerance, str)
    implicit none
    real(4), intent(in) :: f1, f2, tolerance
    character(len=*), intent(in) :: str
    if ( abs(f2 - f1) .gt. tolerance ) then
      write (*, '(A,F12.6,F12.6)') str, f1, f2
      STOP 1
    endif
  endsubroutine

  subroutine cmpd(d1, d2, tolerance, str)
    implicit none
    real(8), intent(in) :: d1, d2, tolerance
    character(len=*), intent(in) :: str
    if ( dabs(d2 - d1) .gt. tolerance ) then
      write (*, '(A,F12.6,F12.6)') str, d1, d2
      STOP 2
    endif
  endsubroutine

implicit none

  real(4), parameter :: pi_f = (4.0_4 *  atan(1.0_4))
  real(8), parameter :: pi_d = (4.0_8 * datan(1.0_8))
  real(4), parameter :: r2d_f = 180.0_4 / pi_f
  real(8), parameter :: r2d_d = 180.0_8 / pi_d
  real(4), parameter :: d2r_f = pi_f / 180.0_4
  real(8), parameter :: d2r_d = pi_d / 180.0_8

! inputs
real(4) :: f_i1, f_i2
real(4), volatile :: xf
real(8) :: d_i1, d_i2
real(8), volatile :: xd

! expected outputs from (oe) default (oxe) expression
real(4) :: f_oe, f_oxe
real(8) :: d_oe, d_oxe

! actual outputs from (oa) default (oc) constant (ox) expression
real(4) :: f_oa, f_oc, f_ox
real(8) :: d_oa, d_oc, d_ox

! tolerance of the answer: assert |exp-act| <= tol
real(4) :: f_tol
real(8) :: d_tol

! equivalence tolerance
f_tol = 5e-5_4
d_tol = 5e-6_8

! multiplication factors to test non-constant expressions
xf = 2.0_4
xd = 2.0_8

! Input
f_i1 = 0.68032123_4
d_i1 = 0.68032123_8

! Expected
f_oe =     r2d_f*acos (f_i1)
f_oxe = xf*r2d_f*acos (f_i1)
d_oe =     r2d_d*dacos(d_i1)
d_oxe = xd*r2d_d*dacos(d_i1)

! Actual
f_oa =    acosd (f_i1)
f_oc =    acosd (0.68032123_4)
f_ox = xf*acosd (f_i1)
d_oa =    dacosd (d_i1)
d_oc =    dacosd (0.68032123_8)
d_ox = xd*dacosd (0.68032123_8)

call cmpf(f_oe,  f_oa, f_tol, "( ) acosd")
call cmpf(f_oe,  f_oc, f_tol, "(c) acosd")
call cmpf(f_oxe, f_ox, f_tol, "(x) acosd")
call cmpd(d_oe,  d_oa, d_tol, "( ) dacosd")
call cmpd(d_oe,  d_oc, d_tol, "(c) dacosd")
call cmpd(d_oxe, d_ox, d_tol, "(x) dacosd")

! Input
f_i1 = 60.0_4
d_i1 = 60.0_8

! Expected
f_oe  =    cos (d2r_f*f_i1)
f_oxe = xf*cos (d2r_f*f_i1)
d_oe  =    cos (d2r_d*d_i1)
d_oxe = xd*cos (d2r_d*d_i1)

! Actual
f_oa =     cosd (f_i1)
f_oc =     cosd (60.0_4)
f_ox = xf* cosd (f_i1)
d_oa =    dcosd (d_i1)
d_oc =    dcosd (60.0_8)
d_ox = xd* cosd (d_i1)

call cmpf(f_oe,  f_oa, f_tol, "( ) cosd")
call cmpf(f_oe,  f_oc, f_tol, "(c) cosd")
call cmpf(f_oxe, f_ox, f_tol, "(x) cosd")
call cmpd(d_oe,  d_oa, d_tol, "( ) dcosd")
call cmpd(d_oe,  d_oc, d_tol, "(c) dcosd")
call cmpd(d_oxe, d_ox, d_tol, "(x) cosd")

! Input
f_i1 = 0.79345021_4
d_i1 = 0.79345021_8

! Expected
f_oe  =    r2d_f*asin (f_i1)
f_oxe = xf*r2d_f*asin (f_i1)
d_oe  =    r2d_d*asin (d_i1)
d_oxe = xd*r2d_d*asin (d_i1)

! Actual
f_oa =     asind (f_i1)
f_oc =     asind (0.79345021_4)
f_ox = xf* asind (f_i1)
d_oa =    dasind (d_i1)
d_oc =    dasind (0.79345021_8)
d_ox = xd* asind (d_i1)

call cmpf(f_oe,  f_oa, f_tol, "( ) asind")
call cmpf(f_oe,  f_oc, f_tol, "(c) asind")
call cmpf(f_oxe, f_ox, f_tol, "(x) asind")
call cmpd(d_oe,  d_oa, d_tol, "( ) dasind")
call cmpd(d_oe,  d_oc, d_tol, "(c) dasind")
call cmpd(d_oxe, d_ox, d_tol, "(x) asind")

! Input
f_i1 = 60.0_4
d_i1 = 60.0_8

! Expected
f_oe  =    sin (d2r_f*f_i1)
f_oxe = xf*sin (d2r_f*f_i1)
d_oe  =    sin (d2r_d*d_i1)
d_oxe = xd*sin (d2r_d*d_i1)

! Actual
f_oa =     sind (f_i1)
f_oc =     sind (60.0_4)
f_ox = xf* sind (f_i1)
d_oa =    dsind (d_i1)
d_oc =    dsind (60.0_8)
d_ox = xd* sind (d_i1)

call cmpf(f_oe,  f_oa, f_tol, "( ) sind")
call cmpf(f_oe,  f_oc, f_tol, "(c) sind")
call cmpf(f_oxe, f_ox, f_tol, "(x) sind")
call cmpd(d_oe,  d_oa, d_tol, "( ) dsind")
call cmpd(d_oe,  d_oc, d_tol, "(c) dsind")
call cmpd(d_oxe, d_ox, d_tol, "(x) sind")

! Input
f_i1 = 2.679676_4
f_i2 = 1.0_4
d_i1 = 2.679676_8
d_i2 = 1.0_8

! Expected
f_oe  =    r2d_f*atan2 (f_i1, f_i2)
f_oxe = xf*r2d_f*atan2 (f_i1, f_i2)
d_oe  =    r2d_d*atan2 (d_i1, d_i2)
d_oxe = xd*r2d_d*atan2 (d_i1, d_i2)

! Actual
f_oa =     atan2d (f_i1, f_i2)
f_oc =     atan2d (2.679676_4, 1.0_4)
f_ox = xf* atan2d (f_i1, f_i2)
d_oa =    datan2d (d_i1, d_i2)
d_oc =    datan2d (2.679676_8, 1.0_8)
d_ox = xd* atan2d (d_i1, d_i2)

call cmpf(f_oe,  f_oa, f_tol, "( ) atan2d")
call cmpf(f_oe,  f_oc, f_tol, "(c) atan2d")
call cmpf(f_oxe, f_ox, f_tol, "(x) atan2d")
call cmpd(d_oe,  d_oa, d_tol, "( ) datan2d")
call cmpd(d_oe,  d_oc, d_tol, "(c) datan2d")
call cmpd(d_oxe, d_ox, d_tol, "(x) atan2d")

! Input
f_i1 = 1.5874993_4
d_i1 = 1.5874993_8

! Expected
f_oe  =    r2d_f*atan (f_i1)
f_oxe = xf*r2d_f*atan (f_i1)
d_oe  =    r2d_d*atan (d_i1)
d_oxe = xd*r2d_d*atan (d_i1)

! Actual
f_oa =     atand (f_i1)
f_oc =     atand (1.5874993_4)
f_ox = xf* atand (f_i1)
d_oa =    datand (d_i1)
d_oc =    datand (1.5874993_8)
d_ox = xd* atand (d_i1)

call cmpf(f_oe,  f_oa, f_tol, "( ) atand")
call cmpf(f_oe,  f_oc, f_tol, "(c) atand")
call cmpf(f_oxe, f_ox, f_tol, "(x) atand")
call cmpd(d_oe,  d_oa, d_tol, "( ) datand")
call cmpd(d_oe,  d_oc, d_tol, "(c) datand")
call cmpd(d_oxe, d_ox, d_tol, "(x) atand")

! Input
f_i1 = 0.6_4
d_i1 = 0.6_8

! Expected
f_oe  =    cotan (d2r_f*f_i1)
f_oxe = xf*cotan (d2r_f*f_i1)
d_oe  =    cotan (d2r_d*d_i1)
d_oxe = xd*cotan (d2r_d*d_i1)

! Actual
f_oa =     cotand (f_i1)
f_oc =     cotand (0.6_4)
f_ox = xf* cotand (f_i1)
d_oa =    dcotand (d_i1)
d_oc =    dcotand (0.6_8)
d_ox = xd* cotand (d_i1)

call cmpf(f_oe,  f_oa, f_tol, "( ) cotand")
call cmpf(f_oe,  f_oc, f_tol, "(c) cotand")
call cmpf(f_oxe, f_ox, f_tol, "(x) cotand")
call cmpd(d_oe,  d_oa, d_tol, "( ) dcotand")
call cmpd(d_oe,  d_oc, d_tol, "(c) dcotand")
call cmpd(d_oxe, d_ox, d_tol, "(x) cotand")

! Input
f_i1 = 0.6_4
d_i1 = 0.6_8

! Expected
f_oe  =     1.0_4/tan (f_i1)
f_oxe = xf* 1.0_4/tan (f_i1)
d_oe  =    1.0_8/dtan (d_i1)
d_oxe = xd*1.0_8/dtan (d_i1)

! Actual
f_oa =     cotan (f_i1)
f_oc =     cotan (0.6_4)
f_ox = xf* cotan (f_i1)
d_oa =    dcotan (d_i1)
d_oc =    dcotan (0.6_8)
d_ox = xd* cotan (d_i1)

call cmpf(f_oe,  f_oa, f_tol, "( ) cotan")
call cmpf(f_oe,  f_oc, f_tol, "(c) cotan")
call cmpf(f_oxe, f_ox, f_tol, "(x) cotan")
call cmpd(d_oe,  d_oa, d_tol, "( ) dcotan")
call cmpd(d_oe,  d_oc, d_tol, "(c) dcotan")
call cmpd(d_oxe, d_ox, d_tol, "(x) cotan")

! Input
f_i1 = 60.0_4
d_i1 = 60.0_8

! Expected
f_oe  =    tan (d2r_f*f_i1)
f_oxe = xf*tan (d2r_f*f_i1)
d_oe  =    tan (d2r_d*d_i1)
d_oxe = xd*tan (d2r_d*d_i1)

! Actual
f_oa =     tand (f_i1)
f_oc =     tand (60.0_4)
f_ox = xf* tand (f_i1)
d_oa =    dtand (d_i1)
d_oc =    dtand (60.0_8)
d_ox = xd* tand (d_i1)

call cmpf(f_oe,  f_oa, f_tol, "( ) tand")
call cmpf(f_oe,  f_oc, f_tol, "(c) tand")
call cmpf(f_oxe, f_ox, f_tol, "(x) tand")
call cmpd(d_oe,  d_oa, d_tol, "( ) dtand")
call cmpd(d_oe,  d_oc, d_tol, "(c) dtand")
call cmpd(d_oxe, d_ox, d_tol, "(x) tand")

end