module wavepack

    use wavepack_kinds, only: rk
    use chisqr, only: cdfchi
    implicit none
    private

    public :: wavelet, wave_signif, rk

contains

    !****************************************************************************
    !
    ! wavepack:  routines to compute the wavelet transform of a time series,
    !            and significance levels.
    !
    ! written by:   christopher torrence and gilbert p. compo
    !
    ! available from:  http://paos.colorado.edu/research/wavelets/
    !
    ! requires the following packages:   cfftpack, chisqr
    !
    ! notes:
    !
    !  (1) all routines are written in single precision (double precision),
    !      except for chisqr, which requires double precision input.
    !      single precision should be sufficient for most applications.
    !
    !  (2) the cfftpack and chisqr routines were not written by us,
    !      and no guarentees are made as to their reliability or efficiency.
    !
    !  (3) no provision is made for output to files or to graphics packages.
    !      the user is expected to call these routines from within
    !      their own programs. see sample program "wavetest.f".
    !
    !  (4) little error checking is done. check your input carefully.
    !      the programs are not completely ansi compatible, so use caution.
    !
    !  (5) time series are currently limited to 65535 points.
    !
    !
    ! reference: torrence, c. and g. p. compo, 1998: a practical guide to
    !            wavelet analysis. bull. amer. meteor. soc., 79, 61-78.
    !
    ! notice: please acknowledge the use of this software in any publications:
    !    ``wavelet software was provided by c. torrence and g. compo,
    !      and is available at url: http://paos.colorado.edu/research/wavelets/''.
    !
    !  copyright (c) 1998, christopher torrence
    ! this software may be used, copied, or redistributed as long as it is not
    ! sold and this copyright notice is reproduced on each copy made.  this
    ! routine is provided as is without any express or implied warranties
    ! whatsoever.
    !
    !
    ! modified: november 1999 by arjan van dijk to include implicit none and
    !           to convert all routines to double precision.
    !****************************************************************************

    !****************************************************************************
    ! wavelet: computes the wavelet transform of a time series,
    !          with appropriate parameters.
    !
    !
    ! inputs:
    !
    !  n [int] = the number of points in "y".
    !
    !  y [double precision] = the time series of length "n".
    !
    !  dt [double precision] = amount of time between each y value, i.e. the sampling time.
    !
    !  mother [int] = an integer giving the mother wavelet to use.
    !                   0='morlet'
    !                   1='paul'
    !                   2='dog' (derivative of gaussian)
    !               if (mother<0 or >2) then default is 'morlet'.
    !
    !  param [double precision] = mother wavelet parameter. if <0 then default is used.
    !            for 'morlet' this is k0 (wavenumber), default is 6.
    !            for 'paul' this is m (order), default is 4.
    !            for 'dog' this is m (m-th derivative), default is 2.
    !
    !
    !  s0 [double precision] = the smallest scale of the wavelet.  typically = 2*dt.
    !         note: for accurate reconstruction and variance computation
    !             set s0=dt for morlet; s0=dt/4 for paul
    !
    !  dj [double precision] = the spacing between discrete scales. typically = 0.25.
    !         a smaller # will give better scale resolution, but be slower.
    !
    !  jtot [int] = the # of scales.
    !             scales range from s0 up to s0*2^[(jtot-1)*dj],
    !             typically jtot=1+(log2(n dt/s0))/dj
    !
    !  npad [int] = the total number of points (including padding) to
    !             use for the wavelet transform. typically this is some
    !             power of 2. it must be greater or equal to "n".
    !             if npad>n, then zeroes are padded onto the end
    !             of the time series.
    !
    !
    ! outputs:
    !
    !  wave [dcmplx(n,jtot)] = 2d array of the real & imaginary parts
    !                 of the wavelet transform, versus time & scale.
    !                 cabs(wave) gives the wavelet amplitude,
    !                 atan2(aimag(wave),dble(wave)) gives wavelet phase.
    !                 the wavelet power spectrum is cabs(wave)**2.
    !
    !  scale [double precision(jtot)] = the wavelet scales that were used.
    !
    !  period [double precision(jtot)] = the "fourier" periods (in time units) corresponding
    !            to "scale".
    !
    !  coi [double precision(n)] = the e-folding factor used for the cone of influence.
    !
    !
    ! requires:   wave_function, cfftpack
    !
    !  copyright (c) 1998, christopher torrence and gilbert p. compo
    ! this software may be used, copied, or redistributed as long as it is not
    ! sold and this copyright notice is reproduced on each copy made.  this
    ! routine is provided as is without any express or implied warranties
    ! whatsoever.

    subroutine wavelet(n, y, dt, mother, param, s0, dj, jtot, npad, wave, scale, period, coi)
        implicit none

        integer n, mother, jtot, npad
        real(rk) :: y(n), dt, param, s0, dj, scale(jtot), period(jtot), coi(n)
        double complex wave(n, jtot)

        integer i, j, k, nk
        real(rk) :: ymean, freq1, pi, period1, coi1

!** initialize work arrays
        parameter(nk=65535)
        real(rk) :: wsave(4*nk + 15), kwave(nk)
        double complex yfft(nk), daughter(nk)

        pi = 4._rk*atan(1._rk)

        if (npad < n) then
            print *, '**wavelet: "npad" must be greater than or equal to "n"'
            return
        end if

        if ((mother < 0) .or. (mother > 2)) mother = 0

!** find the time-series mean & remove it
        ymean = 0._rk
        do i = 1, n
            ymean = ymean + y(i)
        end do
        ymean = ymean/n
        do i = 1, n
            yfft(i) = y(i) - ymean
        end do

!** if desired, pad with extra zeroes
        do i = n + 1, npad
            yfft(i) = 0._rk
        end do

!** find the fft of the time series [eqn(3)]
        call cffti(npad, wsave)
        call cfftf(npad, yfft, wsave)
        do k = 1, npad
            yfft(k) = yfft(k)/npad
        end do

!** construct the wavenumber array [eqn(5)]
        freq1 = 2._rk*pi/(dble(npad)*dt)
        kwave(1) = 0._rk
        do i = 2, npad/2 + 1
            kwave(i) = (dble(i) - 1._rk)*freq1
        end do
        do i = npad/2 + 2, npad
            kwave(i) = -kwave(npad - i + 2)
        end do

!**----- main wavelet loop
!      print '(a8,2a12,/,5x,27("-"))','j','scale','period'
        do j = 1, jtot
            scale(j) = s0*(2._rk**(dble(j - 1)*dj))
            call wave_function(npad, dt, mother, param, scale(j), kwave, period1, coi1, daughter)
            period(j) = period1
!**    multiply the daughter by the time-series fft
            do k = 1, npad
                daughter(k) = daughter(k)*yfft(k)
            end do
!**    inverse fft [eqn(4)]
            call cfftb(npad, daughter, wsave)
!**    store the wavelet transform, discard zero-padding at end
            do i = 1, n
                wave(i, j) = daughter(i)
            end do
!        print '(i8,2f12.3)',j,scale(j),period(j)
        end do
!**----- end loop

!** construct the cone of influence
        do i = 1, (n + 1)/2
            coi(i) = coi1*dt*(dble(i) - 1._rk)
            coi(n - i + 1) = coi(i)
        end do

        return
    end subroutine wavelet

!****************************************************************************
! wave_function: computes the daughter wavelets for a particular
!              wavelet function, with appropriate parameters.
!
!
! inputs:
!
!  nk [int] = the number of points in "kwave"
!
!  dt [double precision] = amount of time between each y value, i.e. the sampling time.
!
!  mother [int] = an integer giving the mother wavelet to use.
!                   0='morlet'
!                   1='paul'
!                   2='dog' (derivative of gaussian)
!
!  param [double precision] = mother wavelet parameter. if <0 then default is used.
!            for 'morlet' this is k0 (wavenumber), default is 6.
!            for 'paul' this is m (order), default is 4.
!            for 'dog' this is m (m-th derivative), default is 2.
!
!  scale1 [double precision] = the wavelet scale used to construct the daughter.
!
!  kwave [double precision(n)] = vector of wavenumbers, used to construct daughter.
!
!
! outputs:
!
!  period1 [double precision] = the "fourier" period (in time units) that corresponds
!            to "scale1".
!
!  coi1 [double precision] = the e-folding factor used for the cone of influence.
!
!  daughter [dcmplx(nk)] = real & imaginary parts of the wavelet function
!                    at "scale1" and "kwave".
!
!
! requires:   factorial, chisqr
!
!
! reference: tables 1 & 2 in
!            torrence, c. and g. p. compo, 1998: a practical guide to
!            wavelet analysis. bull. amer. meteor. soc., 79, 61-78.
!
!  copyright (c) 1998, christopher torrence and gilbert p. compo
! this software may be used, copied, or redistributed as long as it is not
! sold and this copyright notice is reproduced on each copy made.  this
! routine is provided as is without any express or implied warranties
! whatsoever.

    subroutine wave_function(nk, dt, mother, param, scale1, kwave, period1, coi1, daughter)
        implicit none

        integer nk, mother
        real(rk) :: dt, kwave(nk), param, scale1, period1, coi1
        double complex daughter(nk), norm

        real(rk) :: expnt, sk, pi, fourier_factor
        integer k, m, factorial
        real(rk) :: gamma

        pi = 4._rk*atan(1._rk)

        if (mother == 0) then
!*******************************************   morlet wavelet
            if (param < 0) param = 6._rk
            norm = sqrt(2._rk*pi*scale1/dt)*(pi**(-0.25_rk))
            do k = 1, nk/2 + 1
                expnt = -0.5_rk*(scale1*kwave(k) - param)**2
                daughter(k) = dcmplx(norm*exp(expnt))
            end do
            do k = nk/2 + 2, nk
                daughter(k) = dcmplx(0._rk)
            end do
            fourier_factor = (4._rk*pi)/(param + sqrt(2._rk + param**2))
            period1 = scale1*fourier_factor
            coi1 = fourier_factor/sqrt(2._rk)
        else if (mother == 1) then
!*******************************************   paul wavelet
            if (param < 0) param = 4._rk
            m = int(param)
            norm = sqrt(2._rk*pi*scale1/dt)*(2._rk**m/sqrt(dble(m*factorial(2*m - 1))))
            do k = 1, nk/2 + 1
                expnt = -scale1*kwave(k)
                daughter(k) = dcmplx(norm*(scale1*kwave(k))**m*exp(expnt))
            end do
            do k = nk/2 + 2, nk
                daughter(k) = dcmplx(0._rk)
            end do
            fourier_factor = (4._rk*pi)/(2._rk*m + 1._rk)
            period1 = scale1*fourier_factor
            coi1 = fourier_factor*sqrt(2._rk)
        else if (mother == 2) then
!*******************************************   dog wavelet
            if (param < 0) param = 2._rk
            m = int(param)
            norm = sqrt(2._rk*pi*scale1/dt)*sqrt(1._rk/gamma(m + 0.5_rk))
            norm = -norm*(dcmplx(0._rk, 1._rk)**m)
            do k = 1, nk
                sk = scale1*kwave(k)
                daughter(k) = norm*(sk**m)*exp(-0.5_rk*sk**2)
            end do
            fourier_factor = 2._rk*pi*sqrt(2._rk/(2._rk*m + 1._rk))
            period1 = scale1*fourier_factor
            coi1 = fourier_factor/sqrt(2._rk)
        else
            stop
        end if
        return
    end subroutine wave_function

!****************************************************************************
! factorial: compute the factorial (n!) of an integer n
!  copyright (c) 1998, christopher torrence
    function factorial(n)
        implicit none
        integer factorial, n, i

        factorial = 1
        do i = 1, n
            factorial = factorial*i
        end do
    end function factorial

!****************************************************************************
! wave_signif: computes the significance levels for a wavelet transform.
!
!
! inputs:
!
!  isigtest [int] = 0, 1, or 2.
!
!          if 0, then just do a regular chi-square test,
!              i.e. eqn (18) from torrence & compo.
!          if 1, then do a "time-average" test, i.e. eqn (23).
!              in this case, dof(j) should be set to na, the number
!              of local wavelet spectra that were averaged together
!              at each scale. for the global wavelet spectrum,
!              this would be dof(j)=n-scale(j),
!              where n is the number of points in your time series.
!          if 2, then do a "scale-average" test, i.e. eqns (25)-(28).
!              in this case, "dof(1)" and "dof(2)" should be set to the
!              smallest (s1) and largest (s2) scales that were averaged
!              together, respectively.
!              e.g. if you scale-averaged scales between 2 and 8,
!                   then dof(1)=2.0 and dof(2)=8.0
!
!
!  n [int] = the number of points in "y".
!
!  y [double precision] = the time series of length "n".
!
!  dt [double precision] = amount of time between each y value, i.e. the sampling time.
!
!  mother [int] = an integer giving the mother wavelet to use.
!                   0='morlet'
!                   1='paul'
!                   2='dog' (derivative of gaussian)
!
!  param [double precision] = mother wavelet parameter.
!
!  s0 [double precision] = the smallest scale of the wavelet.
!
!  dj [double precision] = the spacing between discrete scales.
!
!  jtot [int] = the # of scales.
!
!  scale [double precision(jtot)] = the wavelet scales that were used.
!
!  period [double precision(jtot)] = the "fourier" periods corresponding to "scale".
!
!  lag1 [double precision] = lag 1 autocorrelation, used for signif levels.
!              default is 0.0, which corresponds to white-noise.
!
!  siglvl [double precision] = significance level to use. default is 0.05 (the "5%" level)
!
!  dof [double precision(jtot)] = degrees-of-freedom for signif test.
!     if sigtest=0, then the input dof is ignored.
!     if sigtest=1, then dof(j) = na, the number of times averaged together.
!     if sigtest=2, then dof(1)=s1, dof(2)=s2, the range of scales averaged.
!
!
! outputs:
!
!  dof [double precision(jtot)] = degrees-of-freedom that were actually used.
!     if sigtest=0, then dof(j) = 2 (or 1 for the 'dog')
!     if sigtest=1, then dof(j) = degrees-of-freedom versus scale.
!     if sigtest=2, then dof(1)=degrees-of-freedom, dof(2...jtot)=0.0
!
!  fft_theor [double precision(jtot)] = theoretical red-noise spectrum vs scale.
!     if sigtest=2, then fft_theor(1) = the average spectrum from s1-->s2
!                   fft_theor(2...jtot) = 0.0
!
!  signif [double precision(jtot)] = significance levels vs scale.
!     if sigtest=2, then signif(1) = the significance level
!                   signif(2...jtot) = 0.0
!
!  ymean [double precision] = the mean of the time series.
!
!  variance [double precision] = the variance of the time series.
!
!  cdelta [double precision] = the constant "cdelta" for the mother wavelet (table 2).
!
!  psi0[double precision] = the constant 'psi(0)' for the mother wavelet (table 2)
!
! requires:   chisqr
!
!  copyright (c) 1998, christopher torrence and gilbert p. compo
! this software may be used, copied, or redistributed as long as it is not
! sold and this copyright notice is reproduced on each copy made.  this
! routine is provided as is without any express or implied warranties
! whatsoever.

    subroutine wave_signif(isigtest, n, y, dt, mother, param, dj, jtot, scale, period, &
                           lag1, siglvl, dof, fft_theor, signif, ymean, variance, cdelta, psi0)
        implicit none

        integer isigtest, n, mother, jtot
        real(rk) :: y(n), dt, param, dj, scale(jtot), period(jtot)
        real(rk) :: lag1, siglvl, dof(jtot), fft_theor(jtot), signif(jtot)
        real(rk) :: ymean, variance, cdelta, psi0

        integer i, j, m, status, javg1, javg2, navg
        real(rk) :: pi, freq1, dofmin, gammafac, dj0, savg, smid
        real(rk) :: fft_theor1
        real(rk) :: chisqr, p, q, bound

        pi = acos(-1._rk)

        if (siglvl <= 0.) siglvl = 0.05_rk
        if (lag1 <= 0._rk) lag1 = 0._rk

        cdelta = -1._rk
        gammafac = -1._rk
        dj0 = -1._rk
        psi0 = -1._rk

        if (mother == 0) then
!*******************************************   morlet wavelet
            dofmin = 2._rk
            if (param == 6._rk) then
                cdelta = 0.776_rk
                gammafac = 2.32_rk
                dj0 = 0.60_rk
                psi0 = pi**(-0.25_rk)
            end if
        else if (mother == 1) then
!*******************************************   paul wavelet
            m = int(param)
            dofmin = 2._rk
            if (m == 4) then
                cdelta = 1.132_rk
                gammafac = 1.17_rk
                dj0 = 1.5_rk
                psi0 = 1.079_rk
            end if
        else if (mother == 2) then
!*******************************************   dog wavelet
            m = int(param)
            dofmin = 1._rk
            if (m == 2) then
                cdelta = 3.541_rk
                gammafac = 1.43_rk
                dj0 = 1.4_rk
                psi0 = 0.867_rk
            else if (m == 6) then
                cdelta = 1.966_rk
                gammafac = 1.37_rk
                dj0 = 0.97_rk
                psi0 = 0.884_rk
            end if
        else
            stop
        end if

!** find the time-series variance
        ymean = 0._rk
        do i = 1, n
            ymean = ymean + y(i)
        end do
        ymean = ymean/n
        variance = 0._rk
        do i = 1, n
            variance = variance + (y(i) - ymean)**2
        end do
        variance = variance/(dble(n))
!** construct theoretical red(white)-noise power spectrum [eqn(16)]
! - 1._rk)
        do j = 1, jtot
            freq1 = dt/period(j)
            fft_theor(j) = variance*(1._rk - lag1**2)/(1._rk - 2._rk*lag1*cos(freq1*2._rk*pi) + lag1**2)
        end do

        q = dble(siglvl)
        p = 1_rk - q

        if (isigtest == 0) then
!*******************************************   no smoothing, dof=dofmin
!   see eqn(18)
            do j = 1, jtot
                dof(j) = dofmin
                call cdfchi(2, p, q, chisqr, dble(dofmin), status, bound)
                signif(j) = fft_theor(j)*chisqr/dofmin
            end do
        else if (isigtest == 1) then
!***********************************   time-averaged, dof depend on scale
            if (gammafac <= 0._rk) then
                print *, '**wave_signif: "gammafac" undefined for this wavelet'
                return
            end if
            do j = 1, jtot
                if (dof(j) < 1.) dof(j) = 1._rk
!   see eqn(23)
                dof(j) = dofmin*sqrt(1._rk + (dof(j)*dt/gammafac/scale(j))**2)
                if (dof(j) < dofmin) dof(j) = dofmin
                call cdfchi(2, p, q, chisqr, dble(dof(j)), status, bound)
                signif(j) = fft_theor(j)*chisqr/dof(j)
            end do
        else if (isigtest == 2) then
!***********************************   scale-averaged, dof depend on scale
            if (cdelta <= 0.) then
                print *, '**wave_signif: "cdelta" and "dj0" '//'undefined for this wavelet'
                return
            end if
            javg1 = 0
            javg2 = 0
            do j = 1, jtot
                if ((scale(j) >= dof(1)) .and. (javg1 == 0)) javg1 = j
                if (scale(j) <= dof(2)) javg2 = j
            end do
            if ((javg1 == 0) .or. (javg2 == 0) .or. (javg1 > javg2)) then
                print *, '**wave_signif: scales in "dof(1)" & "dof(2)" '//'are out of range.'
                return
            end if
            navg = javg2 - javg1 + 1
!   see eqn(25)
            savg = 0._rk
            do j = javg1, javg2
                savg = savg + 1._rk/scale(j)
            end do
            savg = 1._rk/savg
!   see eqn(27)
            fft_theor1 = 0._rk
            do j = javg1, javg2
                fft_theor1 = fft_theor1 + fft_theor(j)/scale(j)
            end do
            fft_theor(1) = savg*fft_theor1
!   see eqn(28)
            smid = exp(0.5_rk*(log(scale(javg1)) + log(scale(javg2))))
            dof(1) = (dofmin*navg*savg/smid)*sqrt(1 + (navg*dj/dj0)**2)
!   see eqn(26)
            call cdfchi(2, p, q, chisqr, dble(dof(1)), status, bound)
            signif(1) = (dj*dt/cdelta/savg)*fft_theor(1)*chisqr/dof(1)
            do j = 2, jtot
                dof(j) = 0._rk
                fft_theor(j) = 0._rk
                signif(j) = 0._rk
            end do
        else
            stop
        end if

    end subroutine wave_signif

end module wavepack


! grid generation
module grid_generation
implicit none
contains

subroutine init_grid
use globals
use process
use boundary_cond
use utilities
use diff_nc_op
use surf_normals
use input_output
integer :: i1(3), i2(3), i3(3), i4(3), bc(3), i, j, k, l
real :: m(9), x, y, z
logical :: err

if (sync) call barrier
if (master) print *, clock(), 'Grid generation'

! create rectangular mesh with double nodes at the fault
xx = 0.0
i1 = i1node
i2 = i2node
do i = i1(1), i2(1); xx(i,:,:,1) = dx(1) * (i + nnoff(1) - 1); end do
do i = i1(2), i2(2); xx(:,i,:,2) = dx(2) * (i + nnoff(2) - 1); end do
do i = i1(3), i2(3); xx(:,:,i,3) = dx(3) * (i + nnoff(3) - 1); end do
i1 = max(i1core, irup + 1)
select case (faultnormal(2:2))
case ('x'); do i = i1(1), i2(1); xx(i,:,:,1) = dx(1) * (i + nnoff(1) - 2); end do
case ('y'); do i = i1(2), i2(2); xx(:,i,:,2) = dx(2) * (i + nnoff(2) - 2); end do
case ('z'); do i = i1(3), i2(3); xx(:,:,i,3) = dx(3) * (i + nnoff(3) - 2); end do
end select

! read grid
call field_io('<', 'x', xx(:,:,:,1))
call field_io('<', 'y', xx(:,:,:,2))
call field_io('<', 'z', xx(:,:,:,3))

! add random noise except at boundaries and in pml
if (gridnoise > 0.0) then
    call random_number(w1)
    w1 = sqrt(sum(dx * dx)) * gridnoise * (w1 - 0.5)
    i1 = i1pml + 1
    i2 = i2pml - 1
    call set_halo(w1(:,:,:,1), 0.0, i1, i2)
    call set_halo(w1(:,:,:,2), 0.0, i1, i2)
    call set_halo(w1(:,:,:,3), 0.0, i1, i2)
    i1 = i1bc + 1
    i2 = i2bc - 1
    call set_halo(w1(:,:,:,1), 0.0, i1, i2)
    call set_halo(w1(:,:,:,2), 0.0, i1, i2)
    call set_halo(w1(:,:,:,3), 0.0, i1, i2)
    i1 = max(i1core, irup)
    i2 = min(i2core, irup + 1)
    select case (faultnormal(2:2))
    case ('x'); w1(i1(1):i2(1),:,:,:) = 0.0
    case ('y'); w1(:,i1(2):i2(2),:,:) = 0.0
    case ('z'); w1(:,:,i1(3):i2(3),:) = 0.0
    end select
    xx = xx + w1
end if

! grid expansion
if (rexpand > 1.0) then
    i1 = n1expand - nnoff
    i2 = nn - n2expand + 1 - nnoff
    i3 = i1node
    i4 = i2node
    do j = i3(1), min(i4(1), i1(1))
        i = i1(1) - j
        xx(j,:,:,1) = xx(j,:,:,1) + &
            dx(1) * (i + 1 - (rexpand ** (i + 1) - 1) / (rexpand - 1))
    end do
    do j = max(i3(1), i2(1)), i4(1)
        i = j - i2(1)
        xx(j,:,:,1) = xx(j,:,:,1) - &
            dx(1) * (i + 1 - (rexpand ** (i + 1) - 1) / (rexpand - 1))
    end do
    do k = i3(2), min(i4(2), i1(2))
        i = i1(2) - k
        xx(:,k,:,2) = xx(:,k,:,2) + &
            dx(2) * (i + 1 - (rexpand ** (i + 1) - 1) / (rexpand - 1))
    end do
    do k = max(i3(2), i2(2)), i4(2)
        i = k - i2(2)
        xx(:,k,:,2) = xx(:,k,:,2) - &
            dx(2) * (i + 1 - (rexpand ** (i + 1) - 1) / (rexpand - 1))
    end do
    do l = i3(3), min(i4(3), i1(3))
        i = i1(3) - l
        xx(:,:,l,3) = xx(:,:,l,3) + &
            dx(3) * (i + 1 - (rexpand ** (i + 1) - 1) / (rexpand - 1))
    end do
    do l = max(i3(3), i2(3)), i4(3)
        i = l - i2(3)
        xx(:,:,l,3) = xx(:,:,l,3) - &
            dx(3) * (i + 1 - (rexpand ** (i + 1) - 1) / (rexpand - 1))
    end do
end if

! affine grid transformation
m = affine
!$omp parallel do schedule(static) private(j, k, l)
do l = 1, nm(3)
do k = 1, nm(2)
do j = 1, nm(1)
    x = m(1) * xx(j,k,l,1) + m(2) * xx(j,k,l,2) + m(3) * xx(j,k,l,3)
    y = m(4) * xx(j,k,l,1) + m(5) * xx(j,k,l,2) + m(6) * xx(j,k,l,3)
    z = m(7) * xx(j,k,l,1) + m(8) * xx(j,k,l,2) + m(9) * xx(j,k,l,3)
    xx(j,k,l,1) = x
    xx(j,k,l,2) = y
    xx(j,k,l,3) = z
end do
end do
end do
!$omp end parallel do

! fill halo, bc=4 means copy into halo, need this for nhat
bc = 4
i1 = i1bc - 1
i2 = i2bc + 1
!call vector_swap_halo(xx, nhalo) ! this should be handled in field_io now
call vector_bc(xx, bc, bc, i1, i2)

! cell centers
call average(w1(:,:,:,1), xx(:,:,:,1), i1cell, i2cell, 1)
call average(w1(:,:,:,2), xx(:,:,:,2), i1cell, i2cell, 1)
call average(w1(:,:,:,3), xx(:,:,:,3), i1cell, i2cell, 1)
call set_halo(w1(:,:,:,1), 0.0, i1cell, i2cell)
call set_halo(w1(:,:,:,2), 0.0, i1cell, i2cell)
call set_halo(w1(:,:,:,3), 0.0, i1cell, i2cell)

! output
call field_io('>', 'x', xx(:,:,:,1))
call field_io('>', 'y', xx(:,:,:,2))
call field_io('>', 'z', xx(:,:,:,3))
call field_io('>', 'xc', w1(:,:,:,1))
call field_io('>', 'yc', w1(:,:,:,2))
call field_io('>', 'zc', w1(:,:,:,3))

! boundary surface normals
!j = nm(1)
!k = nm(2)
!l = nm(3)
!if (bc1(1) == 10) then
!    allocate (pn1(1,k,l,3), gn1(1,k,l,3))
!    pn1 = 0.0
!    gn1 = 0.0
!    i1 = i1node
!    i2 = i2node
!    i2(1) = i1(1)
!    call nodenormals(pn1, xx, dx, i1, i2, 1)
!    i1 = i1cell
!    i2 = i2cell
!    i2(1) = i1(1)
!    call cellnormals(gn1, xx, dx, i1, i2, 1)
!    if (nl3(1) < npml) then
!        root = (/0, -1, -1/)
!        call rbroadcast4(pn1, root)
!        call rbroadcast4(gn1, root)
!    end if
!end if
!if (bc2(1) == 10) then
!    allocate (pn4(1,k,l,3), gn4(1,k,l,3))
!    pn4 = 0.0
!    gn4 = 0.0
!    i1 = i1node
!    i2 = i2node
!    i1(1) = i2(1)
!    call nodenormals(pn4, xx, dx, i1, i2, 1)
!    i1 = i1cell
!    i2 = i2cell
!    i1(1) = i2(1)
!    call cellnormals(gn4, xx, dx, i1, i2, 1)
!    if (nl3(1) < npml) then
!        root = (/np3(1), -1, -1/)
!        call rbroadcast4(pn4, root)
!        call rbroadcast4(gn4, root)
!    end if
!end if

! cell volume
call set_halo(vc, 0.0, i1cell, i2cell)
do i = 1, 3
    call diff_nc(vc, xx, i, i, i1cell, i2cell, xx, dx)
    select case (ifn)
    case (1); vc(irup,:,:) = 0.0
    case (2); vc(:,irup,:) = 0.0
    case (3); vc(:,:,irup) = 0.0
    end select
    err = minval(vc) < 0.0
end do
call field_io('>', 'vc', vc)
if (err) then
    write (0,*) 'Negative cell volume. Wrong sign in dx or problem with mesh.'
    stop
end if

end subroutine

end module


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C------------------------------------------------------------------------------
C	SHADY2.FOR	This program shades a VICAR image as though the
C			objects in the image were illuminated by a source
C			at a given azimuth and elevation.
C
C     MODIFIED FOR VAX CONVERSION BY ASM, 9 AUG 1983
C     JHR: CONVERTED TO VICAR2 1 JULY 1985
C     GAM: PORTED TO UNIX 28 JULY 1993
C------------------------------------------------------------------------------
      EXTERNAL ISHADE
      COMMON /C1/ SL,SS,NLO,NSO,FORMAT,LSCALE,SSCALE,ZSCALE,SCALE,
     &            ILVEC,IUNIT,OUNIT
C
      REAL*4 LSCALE,ILVEC(3)
      INTEGER*4 OUNIT,STAT,SL,SS,IPIXSIZE
      CHARACTER*8 FORMAT
C------------------------------------------------------------------------------
C PARAMETERS:
C
C AZ,R		THE AZIMUTH OF THE SOURCE, MEASURED FROM UP, PROCEEDING
C		CLOCKWISE IN DEGREES.
C
C EL,R          SOURCE ELEVATION MEASURED FROM THE IMAGE PLANE WHERE VERTICAL
C		IS 90. IN DEGREES.
C
C SSCALE,R      THE SCALE IN THE SAMPLE DIRECTION. DEFAULTS TO 208. FT/PIXEL
C		WHICH IS DMA RESOLUTION.
C
C LSCALE,R      LINE SCALE. DEFAULTS TO 208 FT/PIXEL.
C
C ZSCALE,R      ALTITUDE SCALE. DEFAULTS TO 1 FT/DN, THE DMA RESOLUTION.
C
C SCALE,R       THE DN/COS(THETA) IN THE OUTBUF IMAGE, WHERE THETA IS THE ANGLE
C	 	BETWEEN THE SURFACE NORMAL AND THE ILLUMINATION DIRECTION.
C------------------------------------------------------------------------------
C SET ERROR CODE AND PRINT DISCLAIMER
      CALL XVEACTION('SA',' ')
      CALL XVMESSAGE('SHADY2 version  28-JUL-1993',' ')
C OPEN INPUT DATA SET
      CALL XVUNIT(IUNIT,'INP',1,STAT,' ')
      CALL XVOPEN(IUNIT,STAT,'U_FORMAT','HALF',' ')
C
C GET DATA FORMAT AND CHECK
      CALL XVGET(IUNIT,STAT,'FORMAT',FORMAT,' ')
      STAT = XVPIXSIZEU(IPIXSIZE, FORMAT, IUNIT)
      IF(FORMAT.NE.'BYTE'.AND.FORMAT.NE.'HALF') THEN
         CALL XVMESSAGE('SHADY2 ACCEPTS BYTE OR HALFWORD DATA ONLY',
     &   ' ')
         CALL ABEND
      END IF
C
C GET SIZE INFORMATION AND CHECK
      CALL XVSIZE(SL,SS,NLO,NSO,NLI,NSI)
      IF(SL+NLO-1 .GT. NLI) THEN
         CALL XVMESSAGE('NUMBER OF LINES REQUESTED EXCEEDS INPUT SIZE',
     &	 ' ')
         CALL ABEND
      END IF
      IF(SS+NSO-1 .GT. NSI) THEN
         CALL XVMESSAGE(
     &   'NUMBER OF SAMPLES REQUESTED EXCEEDS INPUT SIZE',' ')
         CALL ABEND
      END IF
C
C OPEN OUTPUT DATA SET
      CALL XVUNIT(OUNIT,'OUT',1,STAT,' ')
      CALL XVOPEN(OUNIT,STAT,'OP','WRITE','U_FORMAT','HALF',
     &            'U_NL',NLO,'U_NS',NSO,' ')
C
C PROCESS PARAMETERS
      CALL PARPRO
C
C DETERMINE CORE SIZE NEEDED
      NBYTES=2*NSO
      LCHECK=NBYTES
C
C CALL SUBROUTINE ISHADE VIA STACKA   (ALLOC 4 HALFWORD BUFFERS)
      CALL STACKA(8,ISHADE,4,NBYTES,NBYTES,NBYTES,NBYTES,LCHECK,IND)
      IF(IND.EQ.1) GO TO 995
C
C CLOSE DATA SETS
      CALL XVCLOSE(IUNIT,STAT,' ')
      CALL XVCLOSE(OUNIT,STAT,' ')
C
      RETURN
C
C ERROR RETURNS
995   CALL ABEND
      END
C
C**********************************************************************
      SUBROUTINE PARPRO
C
      COMMON /C1/ SL,SS,NLO,NSO,FORMAT,LSCALE,SSCALE,ZSCALE,SCALE,
     &            ILVEC,IUNIT,OUNIT
C
      REAL*4 AZ,EL,LSCALE,SSCALE,ZSCALE,SCALE,ILVEC(3)
      REAL*4 PI
      DATA PI/3.141592/
      INTEGER*4 OUNIT,SL,SS
      CHARACTER*8 FORMAT
C
C Set default values
C
      AZ=0.
      EL=45.
      SCALE=0.
      SSCALE=208.0
      LSCALE=208.0
      ZSCALE=1.0
C
C Read in parameter values from the process:
C
      CALL XVPARM('AZIMUTH',AZ,ICOUNT,IDEF,1)
      CALL XVPARM('ELEV',EL,ICOUNT,IDEF,1)
      CALL XVPARM('SSCALE',SSCALE,ICOUNT,IDEF,1)
      CALL XVPARM('LSCALE',LSCALE,ICOUNT,IDEF,1)
      CALL XVPARM('ZSCALE',ZSCALE,ICOUNT,IDEF,1)
      CALL XVPARM('SCALE',SCALE,ICOUNT,IDEF,1)
C
C Convert degrees to radians
C
100   AZ=180.0-AZ
      IF(AZ.LT.0.0) AZ=AZ+360.0
      REL = (EL/360.)*2*PI
      RAZ = (AZ/360.)*2*PI
      CALL SPHREC(ILVEC,1.0,REL,RAZ)
C
C ILVEC IS THE UNIT VECTOR IN THE DIRECTION OF ILLUMINATION
C
      IF(SCALE.EQ.0.0.AND.FORMAT.EQ.'HALF') SCALE=16383.
      IF(SCALE.EQ.0.0.AND.FORMAT.EQ.'BYTE') SCALE=254.
C
      RETURN
      END
C
C**********************************************************************
      SUBROUTINE ISHADE(INBUF1,NB1,INBUF2,NB2,INBUF3,NB3,OUTBUF,NB4,
     &                  LCHECK,IND)
C
      COMMON /C1/ SL,SS,NLO,NSO,FORMAT,LSCALE,SSCALE,ZSCALE,SCALE,
     &            ILVEC,IUNIT,OUNIT
C
      REAL*4 S(3),L(3),Z(3),R1,R2,ILVEC(3),LSCALE
      INTEGER*4 LINE,SAMP,EL,ES,SL,SS,OUNIT,STAT
      INTEGER*2 INBUF1(*),INBUF2(*),INBUF3(*),OUTBUF(*)
      CHARACTER*8 FORMAT
C
C CHECK CORE ALLOCATION
      IND=0
      IF(NB4.LT.LCHECK) GO TO 995
C
      EL=NLO-1
      ES=NSO-1
      NBYTES=2*NSO
      IREC=SL
      CALL XVREAD(IUNIT,INBUF1,STAT,'LINE',IREC,
     &                              'SAMP',SS,'NSAMPS',NSO,' ')
      CALL XVREAD(IUNIT,INBUF2,STAT,'LINE',IREC+1,
     &                              'SAMP',SS,'NSAMPS',NSO,' ')
      CALL XVREAD(IUNIT,INBUF3,STAT,'LINE',IREC+2,
     &                              'SAMP',SS,'NSAMPS',NSO,' ')
C
C SET CONSTANT VECTOR COMPONENTS
      L(1)=LSCALE
      L(2)=0.0
      S(1)=0.0
      S(2)=SSCALE
      Z(3)=L(1)*S(2)
C COMPUTE INTERMEDIATE RESULTS TO SAVE CPU TIME
      A3=L(1)*S(2)*ILVEC(3)
      A4=Z(3)*Z(3)
C
C        *** FIRST LINE ***
C
C UPPER LEFT CORNER
C
      S(3) = (INBUF1(2)-INBUF1(1))*ZSCALE
      S(1) = 0
      S(2) = SSCALE
      L(2) = 0
      L(3) = (INBUF2(1)-INBUF1(1))*ZSCALE
      L(1) = LSCALE
      CALL CROSS(L,S,Z)
      CALL DOT(Z,ILVEC,R1)
      CALL MAG(Z,R2)
      OUTBUF(1)=AMAX1(R1/R2*SCALE,0.)
C
C CENTER SAMPLES
C
      DO 100 SAMP=2,ES
      S(3)=(INBUF1(SAMP+1)-INBUF1(SAMP-1))*ZSCALE
      L(3)=(INBUF2(SAMP)-INBUF1(SAMP))*ZSCALE
      Z(1)=L(3)*S(2)
      Z(2)=L(1)*S(3)
      R1=A3-Z(1)*ILVEC(1)-Z(2)*ILVEC(2)
      R2=SQRT(Z(1)*Z(1)+Z(2)*Z(2)+A4)
      OUTBUF(SAMP)=AMAX1(R1/R2*SCALE,0.)
  100 CONTINUE
C
C UPPER RIGHT CORNER
C
      S(3)=(INBUF1(NSO)-INBUF1(NSO-1))*ZSCALE
      L(3)=(INBUF2(NSO)-INBUF1(NSO))*ZSCALE
      CALL CROSS(L,S,Z)
      CALL DOT(Z,ILVEC,R1)
      CALL MAG(Z,R2)
      OUTBUF(NSO)=AMAX1(R1/R2*SCALE,0.)
C
      CALL XVWRIT(OUNIT,OUTBUF,STAT,'NSAMPS',NSO,' ')
C
C        *** MIDDLE LINES ***
C
      DO 250 LINE=2,EL
C
C LEFT SAMPLE
C
      S(3)=(INBUF2(2)-INBUF2(1))*ZSCALE
      L(3)=(INBUF3(2)-INBUF1(2))*ZSCALE
      Z(1)=L(3)*S(2)
      Z(2)=L(1)*S(3)
      R1=A3-Z(1)*ILVEC(1)-Z(2)*ILVEC(2)
      R2=SQRT(Z(1)*Z(1)+Z(2)*Z(2)+A4)
      OUTBUF(1)=AMAX1(R1/R2*SCALE,0.)
C
C CENTER SAMPLES
C
      DO 240 SAMP=2,ES
      S(3)=(INBUF2(SAMP+1)-INBUF2(SAMP-1))*ZSCALE
      L(3)=(INBUF3(SAMP)-INBUF1(SAMP))*ZSCALE
      Z(1)=L(3)*S(2)
      Z(2)=L(1)*S(3)
      R1=A3-Z(1)*ILVEC(1)-Z(2)*ILVEC(2)
      R2=SQRT(Z(1)*Z(1)+Z(2)*Z(2)+A4)
      OUTBUF(SAMP)=AMAX1(R1/R2*SCALE,0.)
  240 CONTINUE
C
C RIGHT SAMPLE
C
      S(3)=(INBUF2(NSO)-INBUF2(NSO-1))*ZSCALE
      L(3)=(INBUF3(NSO)-INBUF1(NSO))*ZSCALE
      Z(1)=L(3)*S(2)
      Z(2)=L(1)*S(3)
      R1=A3-Z(1)*ILVEC(1)-Z(2)*ILVEC(2)
      R2=SQRT(Z(1)*Z(1)+Z(2)*Z(2)+A4)
      OUTBUF(NSO)=AMAX1(R1/R2*SCALE,0.)
C
      CALL XVWRIT(OUNIT,OUTBUF,STAT,'NSAMPS',NSO,' ')
C
C AFTER NEXT TO LAST LINE DON'T READ ANYMORE
C
      IF(LINE.EQ.EL) GO TO 250
      CALL MVE(2,NBYTES/2,INBUF2,INBUF1,1,1)
      CALL MVE(2,NBYTES/2,INBUF3,INBUF2,1,1)
      IREC=SL+LINE+1
      CALL XVREAD(IUNIT,INBUF3,STAT,'LINE',IREC,'SAMP',SS,'NSAMPS',NSO,
     &	' ')
  250 CONTINUE
C
C        *** LAST LINE ***
C
C LOWER LEFT CORNER
C
      S(3)=(INBUF3(2)-INBUF3(1))*ZSCALE
      L(3)=(INBUF3(1)-INBUF2(1))*ZSCALE
      CALL CROSS(L,S,Z)
      CALL DOT(Z,ILVEC,R1)
      CALL MAG(Z,R2)
      OUTBUF(1)=AMAX1(R1/R2*SCALE,0.)
C
C CENTER SAMPLES
C
      DO 300 SAMP=2,ES
      S(3)=(INBUF3(SAMP+1)-INBUF3(SAMP-1))*ZSCALE
      L(3)=(INBUF3(SAMP)-INBUF2(SAMP))*ZSCALE
      Z(1)=L(3)*S(2)
      Z(2)=L(1)*S(3)
      R1=A3-Z(1)*ILVEC(1)-Z(2)*ILVEC(2)
      R2=SQRT(Z(1)*Z(1)+Z(2)*Z(2)+A4)
      OUTBUF(SAMP)=AMAX1(R1/R2*SCALE,0.)
  300 CONTINUE
C
C LOWER RIGHT CORNER
C
      S(3)=(INBUF3(NSO)-INBUF3(NSO-1))*ZSCALE
      L(3)=(INBUF3(NSO)-INBUF2(NSO))*ZSCALE
      CALL CROSS(L,S,Z)
      CALL DOT(Z,ILVEC,R1)
      CALL MAG(Z,R2)
      OUTBUF(NSO)=AMAX1(R1/R2*SCALE,0.)
C
      CALL XVWRIT(OUNIT,OUTBUF,STAT,'NSAMPS',NSO,' ')
C
      RETURN
C
C INSUFFICIENT CORE RETURN
995   CALL XVMESSAGE('INSUFFICIENT CORE',' ')
      IND=1
      RETURN
      END
C
C**********************************************************************
      SUBROUTINE VECTOR
C
      REAL R(3),RMAG,LAT,LONG
      REAL A(3),B(3),C(3)
      REAL D(3,3),E(3,3),F(3,3)
C
      ENTRY SPHREC(R,RMAG,LAT,LONG)
C CONVERT SPHERCAL COORDINATES TO RECTANGULAR VECTOR
      R(1)=RMAG*COS(LAT)*COS(LONG)
      R(2)=RMAG*COS(LAT)*SIN(LONG)
      R(3)=RMAG*SIN(LAT)
      RETURN
C
      ENTRY RECSPH(R,RMAG,LAT,LONG)
C CONVERT RECTANGULAR VECTOR COMPONENTS TO SPHERICAL
      RMAG=SQRT(R(1)*R(1)+R(2)*R(2)+R(3)*R(3))
      LAT=ATAN2(R(3),SQRT(R(1)**2+R(2)**2))
      LONG=ATAN2(R(2),R(1) )
      RETURN
C
      ENTRY UNIT(R)
C MAKE R A UNIT VECTOR IN SAME DIRECTION
      X=SQRT(R(1)*R(1)+R(2)*R(2)+R(3)*R(3))
      DO 10 J=1,3
10    R(J)=R(J)/X
      RETURN
C
      ENTRY MAG(A,RMAG)
C MAGNITUDE OF VECTOR
      RMAG=SQRT(A(1)*A(1)+A(2)*A(2)+A(3)*A(3))
      RETURN
C
      ENTRY DOT (A,B,PROD)
C VECTOR DOT PRODUCT
      PROD=A(1)*B(1)+A(2)*B(2)+A(3)*B(3)
      RETURN
C
      ENTRY CROSS(A,B,C)
C VECTOR CROSS PRODUCT C = A X B
      C(1)=A(2)*B(3)-A(3)*B(2)
      C(2)=A(3)*B(1)-A(1)*B(3)
      C(3)=A(1)*B(2)-A(2)*B(1)
      RETURN
C
      ENTRY MMUL(D,E,F)
C 3 X 3 MATRIX PRODUCT F=D*E
      DO 20 I=1,3
      DO 15 J=1,3
      S=0.
      DO 12 K=1,3
12    S=S+D(I,K)*E(K,J)
      F(I,J)=S
15    CONTINUE
20    CONTINUE
      RETURN
C
      ENTRY VMUL(A,D,R)
C VECTOR (3 X 1) = MATRIX (3 X 3) * VECTOR (3 X 1)  R=D*A
      DO 50 I=1,3
      S=0.
      DO 40 J=1,3
40    S=S+D(I,J)*A(J)
50    R(I)=S
      RETURN
C
      ENTRY TRANS(D,E)
C TRANSPOSE 3 X 3 MATRIX  E=TRANSPOSE(D)
      DO 60 I=1,3
      DO 60 J=1,3
   60 E(J,I)=D(I,J)
      RETURN
      END


module sine_transform_routines

    use auxiliary_routines, only: &
        fft_error_handler, &
        fft_consistent

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

    use real_transform_routines, only: &
        rfft1i, &
        rfft1f, &
        rfftmi, &
        rfftmf

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: sint1i, sint1b, sint1f, sintmi, sintmb, sintmf

    !---------------------------------------------------------------------------------
    ! Variables confined to the module
    !---------------------------------------------------------------------------------
    real (wp), parameter :: ZERO = 0.0_wp
    real (wp), parameter :: HALF = 0.5_wp
    real (wp), parameter :: ONE = 1.0_wp
    real (wp), parameter :: TWO = 2.0_wp
    real (wp), parameter :: THREE = 3.0_wp
    real (wp), parameter :: FOUR = 4.0_wp
    real (wp), parameter :: FIVE = 5.0_wp
    !---------------------------------------------------------------------------------

contains

    subroutine sint1b(n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        !  sint1b: real backward sine transform, 1d.
        !
        !  purpose:
        !
        !  sint1b computes the one-dimensional fourier transform of an odd
        !  sequence within a real array.  this transform is referred to as
        !  the backward transform or fourier synthesis, transforming the
        !  sequence from spectral to physical space.
        !
        !  this transform is normalized since a call to sint1b followed
        !  by a call to sint1f (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n+1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations, in
        !  array r, of two consecutive elements within the sequence.
        !
        !  input/real r(lenr), on input, contains the sequence
        !  to be transformed, and on output, the transformed sequence.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sint1i before the first call to routine sint1f
        !  or sint1b for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to sint1f and sint1b with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n/2 + n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least 2*n+2.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) lenx
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)

        !
        !==> Check validity of input arguments
        !
        if (lenx < inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('sint1b', 6)
            return
        else if ( lensav < n / 2 + n + int(log(real(n, kind=wp) ) &
            / log(TWO ) ) + 4 ) then
            ier = 2
            call fft_error_handler('sint1b', 8)
            return
        else if (lenwrk < (2*n+2)) then
            ier = 3
            call fft_error_handler('sint1b', 10)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        call sintb1(n,inc,x,wsave,work,work(n+2),local_error_flag)

        ! Check error_flag
        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('sint1b',-5)
        end if

    end subroutine sint1b

    subroutine sint1f(n, inc, x, lenx, wsave, lensav, work, lenwrk, ier)
        !
        !  sint1f: real forward sine transform, 1d.
        !
        !  purpose:
        !
        !  sint1f computes the one-dimensional fourier transform of an odd
        !  sequence within a real array.  this transform is referred to as the
        !  forward transform or fourier analysis, transforming the sequence
        !  from physical to spectral space.
        !
        !  this transform is normalized since a call to sint1f followed
        !  by a call to sint1b (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n+1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations,
        !  in array r, of two consecutive elements within the sequence.
        !
        !  input/real r(lenr), on input, contains the sequence
        !  to be transformed, and on output, the transformed sequence.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sint1i before the first call to routine sint1f
        !  or sint1b for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to sint1f and sint1b with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n/2 + n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least 2*n+2.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) lenx
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)

        !
        !==> Check validity of input arguments
        !
        if (lenx < inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('sint1f', 6)
            return
        else if (lensav < n/2 + n + int(log(real(n, kind=wp) ) &
            /log(TWO)) +4) then
            ier = 2
            call fft_error_handler('sint1f', 8)
            return
        else if (lenwrk < (2*n+2)) then
            ier = 3
            call fft_error_handler('sint1f', 10)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        call sintf1(n,inc,x,wsave,work,work(n+2),local_error_flag)

        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('sint1f',-5)
        end if

    end subroutine sint1f

    subroutine sint1i(n, wsave, lensav, ier)
        !
        !  sint1i: initialization for sint1b and sint1f.
        !
        !  purpose:
        !
        !  sint1i initializes array wsave for use in its companion routines
        !  sint1f and sint1b.  the prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave.  separate wsave arrays are required for different
        !  values of n.
        !
        !  parameters:
        !
        !  integer n, the length of the sequence to be
        !  transformed.  the transform is most efficient when n+1 is a product
        !  of small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n/2 + n + int(log(real(n))) + 4.
        !
        !  real wsave(lensav), containing the prime factors
        !  of n and also containing certain trigonometric values which will be used
        !  in routines sint1b or sint1f.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        integer (ip) lensav
        real (wp) dt
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) lnsv
        integer (ip) n
        integer (ip) np1
        integer (ip) ns2
        real (wp), parameter :: pi = acos(-ONE)
        real (wp) wsave(lensav)

        !
        !==> Check validity of input arguments
        !
        if (lensav < n/2 + n + int(log(real(n, kind=wp) ) &
            /log(TWO)) +4) then
            ier = 2
            call fft_error_handler('sint1i', 3)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        if (n > 1) then

            ns2 = n/2
            np1 = n+1
            dt = pi/np1

            do k=1,ns2
                wsave(k) = TWO *sin(k*dt)
            end do

            lnsv = np1 + int(log(real(np1, kind=wp))/log(TWO)) +4

            call rfft1i(np1, wsave(ns2+1), lnsv, local_error_flag)

            ! Check error_flag
            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sint1i',-5)
            end if
        end if

    end subroutine sint1i

    subroutine sintb1(n, inc, x, wsave, xh, work, ier)

        integer (ip) inc
        real (wp) dsum
        real (wp) fnp1s4
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) lnxh
        integer (ip) modn
        integer (ip) n
        integer (ip) np1
        integer (ip) ns2
        real (wp), parameter :: HALF_SQRT3 = sqrt(THREE)/2
        real (wp) t1
        real (wp) t2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) xh(*)
        real (wp) xhold

        ier = 0

        if (n < 2) then
            return
        else if (n == 2) then
            xhold = HALF_SQRT3*(x(1,1)+x(1,2))
            x(1,2) = HALF_SQRT3*(x(1,1)-x(1,2))
            x(1,1) = xhold
        else
            np1 = n+1
            ns2 = n/2
            do k=1,ns2
                kc = np1-k
                t1 = x(1,k)-x(1,kc)
                t2 = wsave(k)*(x(1,k)+x(1,kc))
                xh(k+1) = t1+t2
                xh(kc+1) = t2-t1
            end do

            modn = mod(n,2)

            if (modn /= 0) then
                xh(ns2+2) =  FOUR * x(1,ns2+1)
            end if

            xh(1) = ZERO
            lnxh = np1
            lnsv = np1 + int(log(real(np1, kind=wp))/log(TWO)) + 4
            lnwk = np1

            call rfft1f(np1,1,xh,lnxh,wsave(ns2+1),lnsv,work,lnwk,local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sintb1',-5)
                return
            end if

            if (mod(np1,2) == 0) then
                xh(np1) = xh(np1)+xh(np1)
            end if

            fnp1s4 = real(np1, kind=wp)/4
            x(1,1) = fnp1s4*xh(1)
            dsum = x(1,1)

            do i=3,n,2
                x(1,i-1) = fnp1s4*xh(i)
                dsum = dsum+fnp1s4*xh(i-1)
                x(1,i) = dsum
            end do

            if (modn == 0) then
                x(1,n) = fnp1s4*xh(n+1)
            end if
        end if

    end subroutine sintb1

    subroutine sintf1(n, inc, x, wsave, xh, work, ier)

        integer (ip) inc
        real (wp) dsum
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) kc
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) lnxh
        integer (ip) modn
        integer (ip) n
        integer (ip) np1
        integer (ip) ns2
        real (wp) sfnp1
        real (wp) t1
        real (wp) t2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) xh(*)
        real (wp) xhold

        ier = 0

        if (n < 2) then
            return
        else if (n == 2) then
            xhold = (x(1,1)+x(1,2))/sqrt(THREE)
            x(1,2) = (x(1,1)-x(1,2))/sqrt(THREE)
            x(1,1) = xhold
        else
            np1 = n+1
            ns2 = n/2
            do k=1,ns2
                kc = np1-k
                t1 = x(1,k)-x(1,kc)
                t2 = wsave(k)*(x(1,k)+x(1,kc))
                xh(k+1) = t1+t2
                xh(kc+1) = t2-t1
            end do

            modn = mod(n,2)

            if (modn /= 0) then
                xh(ns2+2) =  FOUR * x(1,ns2+1)
            end if

            xh(1) = ZERO
            lnxh = np1
            lnsv = np1 + int(log(real(np1, kind=wp))/log(TWO)) + 4
            lnwk = np1

            call rfft1f(np1,1,xh,lnxh,wsave(ns2+1),lnsv,work, lnwk,local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sintf1',-5)
                return
            end if

            if (mod(np1,2) == 0) then
                xh(np1) = xh(np1)+xh(np1)
            end if

            sfnp1 = ONE/np1
            x(1,1) = HALF * xh(1)
            dsum = x(1,1)

            do i=3,n,2
                x(1,i-1) = HALF * xh(i)
                dsum = dsum + HALF * xh(i-1)
                x(1,i) = dsum
            end do

            if (modn == 0) then
                x(1,n) = HALF * xh(n+1)
            end if
        end if

    end subroutine sintf1

    subroutine sintmb(lot, jump, n, inc, x, lenx, wsave, lensav, &
        work, lenwrk, ier)
        !
        ! sintmb: real backward sine transform, multiple vectors.
        !
        !  purpose:
        !
        !  sintmb computes the one-dimensional fourier transform of multiple
        !  odd sequences within a real array.  this transform is referred to as
        !  the backward transform or fourier synthesis, transforming the
        !  sequences from spectral to physical space.
        !
        !  this transform is normalized since a call to sintmb followed
        !  by a call to sintmf (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be transformed
        !  within the array r.
        !
        !  integer jump, the increment between the locations, in
        !  array r, of the first elements of two consecutive sequences.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n+1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations, in
        !  array r, of two consecutive elements within the same sequence.
        !
        !  input/real r(lenr), containing lot sequences, each
        !  having length n.  r can have any number of dimensions, but the total
        !  number of locations must be at least lenr.  on input, r contains the data
        !  to be transformed, and on output, the transformed data.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least (lot-1)*jump + inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sintmi before the first call to routine sintmf
        !  or sintmb for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to sintmf and sintmb with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n/2 + n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least lot*(2*n+4).
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  4, input parameters inc,jump,n,lot are not consistent;
        !  20, input error returned by lower level routine.
        !
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) iw1
        integer (ip) iw2
        integer (ip) jump
        integer (ip) lenx
        integer (ip) lot
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)

        if (lenx < (lot-1)*jump + inc*(n-1) + 1) then
            ier = 1
            call fft_error_handler('sintmb', 6)
            return
        else if ( lensav < n / 2 + n + int(log(real(n, kind=wp) ) &
            /log(TWO)) +4) then
            ier = 2
            call fft_error_handler('sintmb', 8)
            return
        else if (lenwrk < lot*(2*n+4)) then
            ier = 3
            call fft_error_handler('sintmb', 10)
            return
        else if (.not. fft_consistent(inc,jump,n,lot)) then
            ier = 4
            call fft_error_handler('sintmb', -1)
            return
        else
            ier = 0
        end if

        iw1 = 2*lot+1
        iw2 = iw1+lot*(n+1)

        call msntb1(lot,jump,n,inc,x,wsave,work,work(iw1),work(iw2),local_error_flag)

        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('sintmb',-5)
            return
        end if

    end subroutine sintmb

    subroutine sintmf(lot, jump, n, inc, x, lenx, wsave, lensav, &
        work, lenwrk, ier)
        !
        !  sintmf: forward sine transform, multiple vectors.
        !
        !  Purpose:
        !
        !  Computes the 1-dimensional fourier transform of multiple
        !  odd sequences within a real array. This transform is referred to as
        !  the forward transform or fourier analysis, transforming the sequences
        !  from physical to spectral space.
        !
        !  This transform is normalized since a call to sintmf followed
        !  by a call to sintmb (or vice-versa) reproduces the original
        !  array within roundoff error.
        !
        !  parameters:
        !
        !  integer lot, the number of sequences to be
        !  transformed within.
        !
        !  integer jump, the increment between the locations,
        !  in array r, of the first elements of two consecutive sequences.
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n+1 is a product of
        !  small primes.
        !
        !  integer inc, the increment between the locations, in
        !  array r, of two consecutive elements within the same sequence.
        !
        !  input/real r(lenr), containing lot sequences, each
        !  having length n.  r can have any number of dimensions, but the total
        !  number of locations must be at least lenr.  on input, r contains the data
        !  to be transformed, and on output, the transformed data.
        !
        !  integer lenr, the dimension of the r array.
        !  lenr must be at least (lot-1)*jump + inc*(n-1)+ 1.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to sintmi before the first call to routine sintmf
        !  or sintmb for a given transform length n.  wsave's contents may be re-used
        !  for subsequent calls to sintmf and sintmb with the same n.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n/2 + n + int(log(real(n))) + 4.
        !
        !  workspace, real (wp) work(lenwrk).
        !
        !  integer lenwrk, the dimension of the work array.
        !  lenwrk must be at least lot*(2*n+4).
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  1, input parameter lenr not big enough;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  4, input parameters inc,jump,n,lot are not consistent;
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip) inc
        integer (ip) lensav
        integer (ip) lenwrk

        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) iw1
        integer (ip) iw2
        integer (ip) jump
        integer (ip) lenx
        integer (ip) lot
        integer (ip) n
        real (wp) work(lenwrk)
        real (wp) wsave(lensav)
        real (wp) x(inc,*)

        !
        !==> Check validity of input arguments
        !
        if ( lenx < ( lot - 1) * jump + inc * ( n - 1 ) + 1 ) then
            ier = 1
            call fft_error_handler('sintmf', 6)
            return
        else if ( lensav < n / 2 + n + int(log(real(n, kind=wp) ) &
            / log(TWO ) ) + 4 ) then
            ier = 2
            call fft_error_handler('sintmf', 8)
            return
        else if ( lenwrk < lot * ( 2 * n + 4 ) ) then
            ier = 3
            call fft_error_handler('sintmf', 10)
            return
        else if (.not. fft_consistent(inc, jump, n, lot)) then
            ier = 4
            call fft_error_handler('sintmf', -1)
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        iw1 = 2 * lot + 1
        iw2 = iw1 + lot * (n + 1)

        call msntf1(lot, jump, n, inc, x, wsave, work, work(iw1), work(iw2), local_error_flag)

        ! Check error_flag
        if (local_error_flag /= 0) then
            ier = 20
            call fft_error_handler('sintmf', -5)
        end if

    end subroutine sintmf

    subroutine sintmi(n, wsave, lensav, ier)
        !
        ! sintmi: initialization for sintmb and sintmf.
        !
        !  Purpose:
        !
        !  Initializes array wsave for use in its companion routines
        !  sintmf and sintmb.  The prime factorization of n together with a
        !  tabulation of the trigonometric functions are computed and stored
        !  in array wsave.  Separate wsave arrays are required for different
        !  values of n.
        !
        !  Parameters:
        !
        !  integer n, the length of each sequence to be
        !  transformed.  the transform is most efficient when n is a product of
        !  small primes.
        !
        !  integer lensav, the dimension of the wsave array.
        !  lensav must be at least n/2 + n + int(log(real(n))) + 4.
        !
        !  real wsave(lensav), containing the prime factors
        !  of n and also containing certain trigonometric values which will be used
        !  in routines sintmb or sintmf.
        !
        !  integer ier, error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip) lensav
        real (wp) dt
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) k
        integer (ip) lnsv
        integer (ip) n
        integer (ip) np1
        integer (ip) ns2
        real (wp), parameter :: PI = acos(-ONE)
        real (wp) wsave(lensav)
        !--------------------------------------------------------------

        !
        !==> Check validity of input arguments
        !
        if (lensav < n / 2 + n + int(log(real(n, kind=wp)) &
            / log(TWO ) ) + 4 ) then
            ier = 2
            call fft_error_handler('sintmi', 3 )
            return
        else
            ier = 0
        end if

        !
        !==> Perform transform
        !
        if (n > 1) then

            ns2 = n / 2
            np1 = n + 1
            dt = PI/np1

            do k = 1, ns2
                wsave(k) = TWO * sin(real(k, kind=wp) * dt)
            end do

            associate( nsv => np1+int(log(real(np1, kind=wp) )/log(TWO))+4)

                call rfftmi(np1, wsave(ns2+1), lnsv, local_error_flag)

            end associate

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('sintmi', -5)
            end if
        end if

    end subroutine sintmi

    subroutine msntb1(lot,jump,n,inc,x,wsave,dsum,xh,work,ier)

        integer (ip) inc
        integer (ip) lot

        real (wp) dsum(*)
        real (wp) fnp1s4
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) jump
        integer (ip) k
        integer (ip) kc
        integer (ip) lj
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) lnxh
        integer (ip) m
        integer (ip) m1
        integer (ip) modn
        integer (ip) n
        integer (ip) np1
        integer (ip) ns2
        real (wp), parameter :: HALF_SQRT3 = sqrt(THREE)/2
        real (wp) t1
        real (wp) t2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) xh(lot,*)
        real (wp) xhold

        ier = 0
        lj = (lot-1)*jump+1

        if (n < 2) then
            return
        else if (n == 2) then
            do m=1,lj,jump
                xhold = HALF_SQRT3*(x(m,1)+x(m,2))
                x(m,2) = HALF_SQRT3*(x(m,1)-x(m,2))
                x(m,1) = xhold
            end do
        else
            np1 = n+1
            ns2 = n/2
            do k=1,ns2
                kc = np1-k
                m1 = 0
                do m=1,lj,jump
                    m1 = m1+1
                    t1 = x(m,k)-x(m,kc)
                    t2 = wsave(k)*(x(m,k)+x(m,kc))
                    xh(m1,k+1) = t1+t2
                    xh(m1,kc+1) = t2-t1
                end do
            end do

            modn = mod(n,2)

            if (modn /= 0) then
                m1 = 0
                do m=1,lj,jump
                    m1 = m1+1
                    xh(m1,ns2+2) =  FOUR * x(m,ns2+1)
                end do
            end if

            xh(:,1) = ZERO

            lnxh = lot-1 + lot*(np1-1) + 1
            lnsv = np1 + int(log(real(np1, kind=wp))/log(TWO)) + 4
            lnwk = lot*np1

            call rfftmf(lot,1,np1,lot,xh,lnxh,wsave(ns2+1),lnsv,work,lnwk,local_error_flag)

            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('msntb1',-5)
                return
            end if

            if (mod(np1,2) == 0) then
                xh(:,np1) = TWO * xh(:,np1)
            end if

            fnp1s4 = real(np1, kind=wp)/4
            m1 = 0

            do m=1,lj,jump
                m1 = m1+1
                x(m,1) = fnp1s4*xh(m1,1)
                dsum(m1) = x(m,1)
            end do

            do i=3,n,2
                m1 = 0
                do m=1,lj,jump
                    m1 = m1+1
                    x(m,i-1) = fnp1s4*xh(m1,i)
                    dsum(m1) = dsum(m1)+fnp1s4*xh(m1,i-1)
                    x(m,i) = dsum(m1)
                end do
            end do

            if (modn == 0) then
                m1 = 0
                do m=1,lj,jump
                    m1 = m1+1
                    x(m,n) = fnp1s4*xh(m1,n+1)
                end do
            end if
        end if

    end subroutine msntb1

    subroutine msntf1(lot,jump,n,inc,x,wsave,dsum,xh,work,ier)

        integer (ip) inc
        integer (ip) lot

        real (wp) dsum(*)
        integer (ip) i
        integer (ip) ier
        integer (ip) local_error_flag
        integer (ip) jump
        integer (ip) k
        integer (ip) kc
        integer (ip) lj
        integer (ip) lnsv
        integer (ip) lnwk
        integer (ip) lnxh
        integer (ip) m
        integer (ip) m1
        integer (ip) modn
        integer (ip) n
        integer (ip) np1
        integer (ip) ns2
        real (wp) sfnp1
        real (wp) t1
        real (wp) t2
        real (wp) work(*)
        real (wp) wsave(*)
        real (wp) x(inc,*)
        real (wp) xh(lot,*)
        real (wp) xhold

        ier = 0
        lj = (lot-1)*jump+1

        if (n < 2) then
            return
        else if (n == 2) then
            do m=1,lj,jump
                associate( sqrt3 => sqrt(THREE) )
                    xhold = (x(m,1)+x(m,2))/sqrt3
                    x(m,2) = (x(m,1)-x(m,2))/sqrt3
                    x(m,1) = xhold
                end associate
            end do
        else
            np1 = n+1
            ns2 = n/2
            do k=1,ns2
                kc = np1-k
                m1 = 0
                do m=1,lj,jump
                    m1 = m1 + 1
                    t1 = x(m,k)-x(m,kc)
                    t2 = wsave(k)*(x(m,k)+x(m,kc))
                    xh(m1,k+1) = t1+t2
                    xh(m1,kc+1) = t2-t1
                end do
            end do

            modn = mod(n,2)

            if (modn /= 0) then
                m1 = 0
                do m=1,lj,jump
                    m1 = m1 + 1
                    xh(m1,ns2+2) =  FOUR * x(m,ns2+1)
                end do
            end if

            xh(:,1) = ZERO

            lnxh = lot-1 + lot*(np1-1) + 1
            lnsv = np1 + int(log(real(np1, kind=wp))/log(TWO)) + 4
            lnwk = lot*np1

            call rfftmf(lot,1,np1,lot,xh,lnxh,wsave(ns2+1),lnsv,work,lnwk,local_error_flag)

            ! Check error_flag
            if (local_error_flag /= 0) then
                ier = 20
                call fft_error_handler('msntf1',-5)
                return
            end if

            if (mod(np1,2) == 0) then
                xh(:,np1) = TWO * xh(:,np1)
            end if

            sfnp1 = ONE/np1
            m1 = 0

            do m=1,lj,jump
                m1 = m1+1
                x(m,1) = HALF * xh(m1,1)
                dsum(m1) = x(m,1)
            end do

            do i=3,n,2
                m1 = 0
                do m=1,lj,jump
                    m1 = m1+1
                    x(m,i-1) = HALF * xh(m1,i)
                    dsum(m1) = dsum(m1)+ HALF * xh(m1,i-1)
                    x(m,i) = dsum(m1)
                end do
            end do

            if (modn == 0) then
                m1 = 0
                do m=1,lj,jump
                    m1 = m1+1
                    x(m,n) = HALF * xh(m1,n+1)
                end do
            end if
        end if

    end subroutine msntf1

end module sine_transform_routines


      constant nx, ny, nz, nbdy;

      do j = 4-nbdy,ny+nbdy-3
         do i = 4-nbdy,nx+nbdy-3
            do k = 4-nbdy,nz+nbdy-2
               af(k,i,j) = (f60 * (a(k-1,i,j) + a(k,i,j)) + f61
     * (a(k-2,i,j) + a(k+1,i,j)) + f62 * (a(k-3,i,j) + a(k+2,i,j)))
      * thirddtbydz * uzf(k,i,j)
            end do
         end do
      end do

      do j = 4-nbdy,ny+nbdy-3
         do i = 4-nbdy,nx+nbdy-3
            do k = 4-nbdy,nz+nbdy-3
               athird(k,i,j) = a(k,i,j) + (al(k,i+1,j) - al(k,i,j))
      + (ab(k,i,j+1) - ab(k,i,j)) + (af(k+1,i,j) - af(k,i,j))
            end do
         end do
      end do


module StiffnessMatrixClass
    use ShapeFunctionClass
    use MeshClass
    use StressClass
    use StrainClass

    implicit none

    ! Provides a set of Element-by-element stiffness matrix & RHS vector of internal force
    ! for all types of elements, all Strain Theory, and all constitutive models.

    type :: StiffnessMatrix_
        real(8),allocatable     :: Amat(:,:),bvec(:)
        type(ShapeFunction_)    :: ShapeFunc
        type(Stress_),pointer   :: Stress
        type(Strain_),pointer   :: Strain

        integer :: TheoryID,ElemID,GpID

        character*40 :: StrainTheory

        ! Please input one of following keyphrases

        ! Finite_Elasticity
        ! Finite_ElastoPlasticity
        ! Infinitesimal_Elasticity
        ! Infinitesimal_ElastoPlasticity
        ! Small_strain
    contains
        procedure,public :: init    => initStiffnessMatrix
        procedure,public :: update  => updateStiffnessMatrix
    end type

contains

! ######################################
subroutine initStiffnessMatrix(obj,FEMDomain,Stress,Strain,withInit)
    class(StiffnessMatrix_),intent(inout)::obj
    !character(*),intent(in) :: StrainTheory
    class(FEMDomain_),intent(in) :: FEMDomain
    class(Stress_),target,intent(in) :: Stress
    class(Strain_),target,intent(in) :: Strain
    logical,optional,intent(in) :: withInit
    integer :: NumOfDim,NumOfNodePerElem

    obj%Stress => Stress
    obj%Strain => Strain
    ! create Stress/Strain measure objects
    !obj%StrainTheory = StrainTheory
    !call obj%Stress%init(StrainTheory)
    !call obj%Stress%init(StrainTheory)

    ! create a ShapeFunction object
    NumOfDim         = size(FEMDomain%Mesh%NodCoord,2)
    NumOfNodePerElem = size(FEMDomain%Mesh%ElemNod,2)
    call obj%ShapeFunc%getType(NumOfDim=NumOfDim,NumOfNodePerElem=NumOfNodePerElem)
    call obj%ShapeFunc%setType()

    obj%ElemID=1
    obj%GpID=1

end subroutine
! ######################################

! ######################################
subroutine updateStiffnessMatrix(obj,Mesh,ElemID,MeshID)
    class(StiffnessMatrixClass_),intent(inout) :: obj
    class(Mesh_),intent(in) :: Mesh
    integer,optional,intent(in) :: ElemID,MeshID
    integer :: ElemID_out,MeshID_out

    ! get element ID and Gauss-point-id
    if(present(ElemID))then
        ElemID_out=ElemID
    else
        ElemID_out=obj%ElemID
    endif
    if(present(GpID))then
        GpID_out=GpID
    else
        GpID_out=obj%GpID
    endif

    ! get all objects related to a shape function
    call obj%ShapeFunc%update(ElemType=obj%ShapeFunc%ElemType,&
        NodCoord=Mesh%NodCoordInit,NodCoord=Mesh%NodCoord_n,&
        ElemNod=Mesh%ElemNod,ElemID=ElemID_out,GpID=GpID_out)

    ! create strain tensor

    ! create stress tensor

    ! create stiffness matrix

    ! update element ID and Gauss-point-id
    obj%GpID = obj%GpID +1
    if(obj%GpID > size(obj%ShapeFunc%NumOfGp) )then
        ! go to next element
        obj%GpID = 1
        obj%ElemID =obj%ElemID + 1
    else
        ! go to next Gauss point in the same element
        obj%GpID = obj%GpID + 1
    endif
end subroutine
! ######################################

end module


subroutine calculateDT(initialTime, time, saveInterval, maxAllowCourantNo, tfin)

    use var_module
    use arrays_module

    implicit none

    real(kind=4), intent(in) :: initialTime, time, saveInterval, tfin
    real(kind=4), intent(in) :: maxAllowCourantNo
    integer(kind=4)  :: a, b

    !! initialTime is in hours
    !! tfin is in hours
    !! time is in minutes
    !! dtini is in seconds
    !! saveInterval is in seconds

    !print*, time, saveInterval, maxAllowCourantNo

    dtini = maxAllowCourantNo*minval(dx)/maxval(celerity)

    a = floor( (time-initialTime*60.) /( saveInterval/60. ))
    b = floor(( (time-initialTime*60.) +dtini/60.)/( saveInterval/60. ))

    if( b .gt. a ) then
        dtini = ( initialTime*60. + (a+1)*saveInterval/60. -  time ) * 60.
    end if
    if ( a*saveInterval / 60. +initialTime*60.+dtini / 60. .gt. tfin*60. ) then
        dtini = ( tfin*60. - time )*60.
    end if
    !print*, 'dt =', dtini, time, saveInterval, maxAllowCourantNo

end subroutine


! fp_special.f90 --
!     Investigate the behaviour of the program vis-a-vis special
!     IEEE numbers and floating-point exceptions
!
!     Note:
!     To get full insight, the program may need to run several times
!     successively skipping tests.
!
program fp_special
    implicit none

    integer :: test, success
    logical :: exists

    real    :: y = 0.0
    real    :: z = 1.0e30

    ! Start afresh? If the file "fp_special.done" exists or the
    ! file "fp_special.next' does not.
    !
    test = -1

    inquire( file = "fp_special.done", exist = exists )
    if ( exists ) then
        open( 10, file = "fp_special.done" )
        close( 10, status = 'delete' )
        test = 1
    else
        inquire( file = "fp_special.next", exist = exists )
        if ( .not. exists ) then
            test = 1
        endif
    endif

    open( 10, file = "fp_special.next" )
    if ( test == -1 ) then
        read( 10, * ) test, success
        rewind( 10 )
        if ( success /= 1 ) then
            write(*,*) 'Previous test failed! The program aborted'
        endif
    endif

    !
    ! Select the next test
    !
    if ( test == 1 ) then
        write( 10, * ) test, 0
        rewind( 10 )
        call division_by_zero
        test = 2
    endif

    if ( test == 2 ) then
        write( 10, * ) test, 0
        rewind( 10 )
        call not_a_number
        test = 3
    endif

    if ( test == 3 ) then
        write( 10, * ) test, 0
        rewind( 10 )
        call overflow
        test = 4
    endif

    if ( test == 4 ) then
        write( 10, * ) test, 0
        rewind( 10 )
        call underflow
    endif

    call negative_zero

    close( 10 )
    open( 10, file= "fp_special.done" )
    write( 10, * ) 'Done'
    close( 10 )

contains

! division_by_zero --
!     Does the compiler support division by zero? Or does the program abort?
!
! Arguments:
!     None
!
subroutine division_by_zero

    real :: x

    write( 10, * ) test+1, 0

    write(*,*) 'Test: division by zero'

    x = 1.0 / y

    write(*,*) '      Test succeeded, the program continues'
    write(*,*) '      Result of 1/0: ', x
    if ( x > huge(1.0) ) then
        write(*,*) '      Result is "infinity"'
    else
        write(*,*) '      Result is "huge" - it should be "infinity"'
    endif

    write( 10, * ) test+1, 1

end subroutine

! not_a_number --
!     Does the compiler support not-a-numbers? Or does the program abort?
!
! Arguments:
!     None
!
subroutine not_a_number

    real :: x

    write( 10, * ) test+1, 0

    write(*,*) 'Test: creating Not-a-number'

    x = 0.0 / y

    write(*,*) '      Test succeeded, the program continues'
    write(*,*) '      Result of 0/0: ', x
    if ( x >= 0.0 .or. x <= 0.0 ) then
        write(*,*) '      Result is 0.0 - it should be "NaN"'
    else
        write(*,*) '      Result is "NaN"'
    endif

    write( 10, * ) test+1, 1

end subroutine

! overflow --
!     Does the compiler support overflow? Or does the program abort?
!
! Arguments:
!     None
!
subroutine overflow

    real :: x

    write( 10, * ) test+1, 0

    write(*,*) 'Test: computations with overflow'

    x = 1.0e20 * z

    write(*,*) '      Test succeeded, the program continues'
    write(*,*) '      Result of 1.0e20 * 1.0e30: ', x
    if ( x > huge(1.0) ) then
        write(*,*) '      Result is "Infinity"'
    else
        write(*,*) '      Result is "huge"'
    endif

    write( 10, * ) test+1, 1

end subroutine

! underflow --
!     Does the compiler support underflow (denormalised numbers)?
!
! Arguments:
!     None
!
subroutine underflow

    real :: x
    real :: xprev

    write( 10, * ) test+1, 0

    write(*,*) 'Test: computations with underflow'

    x = 1.0
    do while ( x > tiny(x) )
        xprev = x
        x     = x / 2.0
    enddo

    write(*,*) '      Test succeeded, the program continues'
    write(*,*) '      Result of repeated halving: ', x
    if ( x == 0.0 ) then
        write(*,*) '      Note: no underflow - small values are truncated to zero'
    else
        write(*,*) '      Small values will gradually go to zero'
    endif

    write( 10, * ) test+1, 1

end subroutine

! negative_zero --
!     Does the compiler support negative zeros?
!
! Arguments:
!     None
!
subroutine negative_zero

    logical :: supported
    real :: neg_zero

    supported = .false.

    neg_zero = -0.0
    if ( sign(1.0,neg_zero) < 0.0 ) then
        supported = .true.
    else
        neg_zero = -tiny(1.0)

        do while ( neg_zero /= 0 )
            neg_zero = neg_zero / 2.0
        enddo
        if ( sign(1.0,neg_zero) < 0.0 ) then
            supported = .true.
        endif
    endif

    if ( supported ) then
        write(*,*) 'Negative zeros are supported'
    else
        write(*,*) 'Negative zeros are NOT supported'
    endif

    neg_zero = sqrt( -0.0 )

    if ( sign(1.0,neg_zero) < 0.0 ) then
        write(*,*) 'SQRT(-0) is indeed negative (as required by the IEEE standard)'
    else
        write(*,*) 'SQRT(-0) is NOT negative! Inconsistent with the IEEE standard'
    endif

end subroutine

end program


C File: test_module_08.f
C Purpose: Illustrates the use of selective imports from Fortran modules.  In
C    this example, the program PGM uses module MYMOD8 but only imports the
C    name myadd from MYMOD8.  Since MYMOD's variable X is not imported by PGM,
C    its value is not overwritten by the assignment to X in the body of PGM.
C
C Compile and run this program as follows:
C
C    gfortran -c test_module_08.f     # << this will create a file "mymod8.mod"
C    gfortran test_module_08.f        # << this will create a file "a.out"
C
C The output generated by this program is (see test_module_08-OUT.txt):
C
C    5678      6912

!-------------------------------------------------------------------------------
      MODULE MYMOD8
          IMPLICIT NONE
          INTEGER :: X = 1234
      contains
          subroutine myadd(y, sum)
          integer y, sum

          sum = x+y
          end subroutine myadd
      END MODULE MYMOD8

!-------------------------------------------------------------------------------
      PROGRAM PGM
      USE mymod8, only : myadd  ! << Note: only myadd() is imported; x is not.
      integer x, v

      x = 5678    ! << This assignment does NOT overwrite mymod8's variable x

      call myadd(x,v)

 10   FORMAT (I8,2X,I8)
      write (*,10) x, v

      stop
      end program PGM
!-------------------------------------------------------------------------------


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR SEULEX AT BRUSS 1D PROBLEM
C * * * * * * * * * * * * * * * * * * * * * * * * *
        IMPLICIT REAL*8 (A-H,O-Z)
C --- PARAMETERS FOR SEULEX (BANDED JACOBIAN)
        PARAMETER (NDGL=1000,NL=2,NU=2,KM=12)
        PARAMETER(LWORK=(3*NL+2*NU+KM+11)*NDGL+4*KM+20,
     &             LIWORK=2*NDGL+KM+20)
        COMMON/PARAM/N,N2,GAMMA,GAMMA2
        DIMENSION Y(NDGL),WORK(LWORK),IWORK(LIWORK),ISTAT(20)
C -------- END PARAMETER LIST --------
        REAL*4 TARRAY(2),TRESULT
        EXTERNAL FBRUS,JBRUS,SOLOUT
c ------ FILE DE DONNEES ----------
        OPEN(8,FILE='res_seulex')
        REWIND 8
c -------- INITIAL CONSTANTES --------
        PI=3.14159265358979324D0
        N=500
        N2=2*N
        USDELQ=(DBLE(N+1))**2
        GAMMA=0.02D0*USDELQ
        GAMMA2=2.D0*GAMMA
C --- LOOP FOR DIFFERENT TOLERANCES
        NTOLMN=2
        NTOLMX=10
        NTOLDF=4
        NRLOOP=(NTOLMX-NTOLMN)*NTOLDF+1
        TOLST=0.1D0**NTOLMN
        TOLFC=0.1D0**(1.D0/NTOLDF)
        DO 30 NTOL=1,NRLOOP
C ---------- VAL INIT ------------
        X=0.D0
        XEND=10.D0
        DO 1 I=1,N
        ANP1=N+1
        XI=I/ANP1
        Y(2*I)=3.D0
   1    Y(2*I-1)=1.D0+0.5D0*DSIN(2.D0*PI*XI)
C --- COMPUTE THE JACOBIAN NUMERICALLY
        IJAC=1
C --- JACOBIAN IS NOT FULL
        MLJAC=NL
        MUJAC=NU
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
        IMAS=0
C --- DIFFERENTIAL EQUATION IS AUTONOMOUS
        IDFX=0
        IFCN=0
C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=0
C --- REQUIRED TOLERANCE
        RTOL=TOLST
        ATOL=RTOL
        ITOL=0
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- SET DEFAULT VALUES
        DO I=1,20
           WORK(I)=0.D0
           IWORK(I)=0
           ISTAT(I)=0
        END DO
C --- CALL OF THE SUBROUTINE SEULEX
        CALL DTIME(TARRAY,TRESULT)
        CALL SEULEX(N2,FBRUS,IFCN,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JBRUS,IJAC,MLJAC,MUJAC,
     &                  FBRUS,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT SOLUTION
        CALL DTIME(TARRAY,TRESULT)
        WRITE(8,9921)(Y(I),I=1,995,7)
 9921   FORMAT(1X,F22.16)
C --- PRINT STATISTICS
         DO J=14,20
            ISTAT(J)=ISTAT(J)+IWORK(J)
         END DO
        WRITE(8,*)TARRAY(1)
        WRITE (8,*)(ISTAT(J),J=14,20)
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
 91     FORMAT(' fcn=',I6,' jac=',I5,' step=',I5,
     &        ' accpt=',I5,' rejct=',I4,' dec=',I5,
     &        ' sol=',I6)
C -------- NEW TOLERANCE ---
        TOLST=TOLST*TOLFC
        IF (TARRAY(1).GT.500.) STOP
 30     CONTINUE
        STOP
        END
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,RC,LRC,IC,LIC,N,RPAR,IPAR,IRTRN)
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),RC(LRC),IC(LIC)
           WRITE (6,99) X,Y(1),Y(2),Y(3),NR-1
 99     FORMAT(1X,'X =',F11.4,'    Y =',3E18.10,'    NSTEP =',I4)
        RETURN
        END