subroutine fft_3d_backward (mf_fft_in_real, mf_fft_in_imag, lo, hi, domain_size, dx, comm, alloc_local, &
                            mf_fft_out_real, mf_fft_out_imag, threads_ok)
    use, intrinsic :: iso_c_binding
    use fftw3_mpi
    use omp_lib

    implicit none

    integer(c_int), intent(in ) :: lo(3), hi(3), domain_size(3), comm
    integer(c_intptr_t), intent(in) :: alloc_local
    real(c_double), intent(in) :: mf_fft_in_real (lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)
    real(c_double), intent(in) :: mf_fft_in_imag (lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)
    real(c_double), intent(in) :: dx
    integer, intent(in) :: threads_ok

    real(c_double), intent(out) :: mf_fft_out_real(lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)
    real(c_double), intent(out) :: mf_fft_out_imag(lo(1):hi(1), lo(2):hi(2), lo(3):hi(3), 1)

    integer(c_intptr_t) :: l, m, n, local_n
    type(c_ptr) :: plan, cdata
    complex(c_double_complex), pointer :: mf_data(:, :, :)

    integer(c_int) :: cmplx_i, cmplx_j, cmplx_k
    integer(c_int) :: i, j, k
    real(c_double) :: grid_volume

    l = domain_size(1)
    m = domain_size(2)
    n = domain_size(3)

    local_n = hi(3)-lo(3)+1

    ! We must use these special C-style pointers to feed data into FFTW.
    cdata = fftw_alloc_complex(alloc_local)
    call c_f_pointer(cdata, mf_data, [l, m, local_n])

    if (threads_ok /= 0) call fftw_plan_with_nthreads(omp_get_num_threads())
    ! The sign convention used in the Nyx algorithms is the opposite of that used in FFTW. So a "forward" DFT in Nyx is "backward"
    ! in FFTW, and vice versa.
    plan = fftw_mpi_plan_dft_3d (n, m, l, mf_data, mf_data, comm, FFTW_FORWARD, FFTW_MEASURE)

    ! First translate the separate real and imaginary MultiFab data to a complex array. The indices for the local complex data
    ! arrays start their indices at one, unlike the Box indices which follow the domain grid coordinates.
    do k = lo(3), hi(3)
      cmplx_k = k - lo(3) + 1
      do j = lo(2), hi(2)
        cmplx_j = j - lo(2) + 1
        do i = lo(1), hi(1)
          cmplx_i = i - lo(1) + 1
          mf_data(cmplx_i, cmplx_j, cmplx_k) = cmplx(mf_fft_in_real(i, j, k, 1), mf_fft_in_imag(i, j, k, 1), c_double_complex)
        end do
      end do
    end do

    call fftw_mpi_execute_dft(plan, mf_data, mf_data)

    ! Copy data back to separate MultiFabs for real and imaginary components.
    do k = lo(3), hi(3)
      cmplx_k = k - lo(3) + 1
      do j = lo(2), hi(2)
        cmplx_j = j - lo(2) + 1
        do i = lo(1), hi(1)
          cmplx_i = i - lo(1) + 1
          ! Strip out real and imaginary components and save as separate
          ! MultiFabs. This syntax is super dumb.
          mf_fft_out_real (i, j, k, 1) = real(real (mf_data(cmplx_i, cmplx_j, cmplx_k)), c_double)
          mf_fft_out_imag (i, j, k, 1) = real(aimag(mf_data(cmplx_i, cmplx_j, cmplx_k)), c_double)
        end do
      end do
    end do

    call fftw_destroy_plan(plan)
    call fftw_free(cdata)

    ! Assumes cubic domain
    grid_volume = (domain_size(1) * dx)**3

    ! Normalize by grid volume
    mf_fft_out_real (:, :, :, 1) = mf_fft_out_real (:, :, :, 1) / grid_volume
    mf_fft_out_imag (:, :, :, 1) = mf_fft_out_imag (:, :, :, 1) / grid_volume

end subroutine fft_3d_backward


C ================================================================
C  Changes since makQ_orig.f:
C  1. constant metric is replaced by linear metric
C  2. use LAPACK's routine dsyev instead of Linpack's dsvdc
C  3. added routine computing average quality
C ================================================================

C ================================================================
      Subroutine makQ(
C ================================================================
C Routine computes hStar and Quality of elements in the initial
c mesh.
C ================================================================
c group (M)
     &     nP, nE, XYP, IPE, IEE, nEV, IEV,
     &     nEStar, hStar, status,
c group (Q)
     &     HesP, detG, qE)
C ================================================================
      include 'status.fd'
C ================================================================
C group (M)
C     Integer MaxP, MaxF, MaxE, nEStar
      real  XYP(2, *)
      Integer IPE(3, *), IEE(3, *), IEV(*)
      Integer status

      real  hStar

C group (Q)
      real  HesP(3, *)
      real  detG(*), qE(*)

C group (Local variables)
      Integer iref(4)
      real  HesAvg(3), detAvg, dsum, calVol
      real  VStar, Vn, qEt
      Logical ifXnode

C ================================================================
      iref(1) = 1
      iref(2) = 2
      iref(3) = 3
      iref(4) = 1

      Do n = 1, nP
         Call calDet(HesP(1, n), detG(n))
      End do

      VStar = 0D0
      Do n = 1, nE
         dsum = 0D0

         Do i1 = 1, 3
            i2 = iref(i1 + 1)
            iP1 = IPE(i1, n)
            iP2 = IPE(i2, n)

            Do i = 1, 3
               HesAvg(i) = (HesP(i, iP1) + HesP(i, iP2)) / 2
            End do

            Call calDet(HesAvg, detAvg)

            dsum = dsum + sqrt(detAvg)
         End do

         i3 = iref(i2 + 1)
         iP3 = IPE(i3, n)

         Vn = calVol(XYP(1, iP1), XYP(1, iP2), XYP(1, iP3))
         VStar = VStar + abs(Vn) * dsum / 3
      End do

      hStar = sqrt(VStar / nEStar * 4D0 / sqrt(3D0))

      Do n = 1, nE
         i1 = IPE(1, n)
         i2 = IPE(2, n)
         i3 = IPE(3, n)

         Call calQE(
     &        HesP(1, i1), XYP(1, i1),
     &        HesP(1, i2), XYP(1, i2),
     &        HesP(1, i3), XYP(1, i3),
     &        hStar, qE(n))

         If(ifXnode(status, ANISmoothMesh)) Then
            Do i = 1, 3
               k = IEE(i, n)
               If(k.GT.0) Then
                  j1 = IPE(1, k)
                  j2 = IPE(2, k)
                  j3 = IPE(3, k)

                  Call calQE(
     &                 HesP(1, j1), XYP(1, i1),
     &                 HesP(1, j2), XYP(1, i2),
     &                 HesP(1, j3), XYP(1, i3),
     &                 hStar, qEt)

                  qE(n) = min(qE(n), qEt)
               End if
            End do
         End if
      End do

c ... set quality of fixed elements to 1
      Do n = 1, nEv
         qE(IEV(n)) = 1D0
      End do

      Return
      End

C ================================================================
      real Function calVol(xy1, xy2, xy3)
C ================================================================
C Routine computes triangle area
C ================================================================
      real xy1(2), xy2(2), xy3(2)

      calVol = ((xy1(1) - xy3(1)) * (xy2(2)-xy3(2)) -
     &          (xy1(2) - xy3(2)) * (xy2(1)-xy3(1))) / 2
      Return
      End

C ================================================================
      Subroutine calDet(HesP, detG)
C ================================================================
      include 'magic.fd'
C ================================================================
C Routine computes determinat det(H) of matrix H where
C       | HesP(1)  HesP(3) |
C   H = |                  |
C       | HesP(3)  HesP(2) |
C ================================================================
      real  HesP(3), detG

C Local arrays for LAPACK
      real  A(2, 2), E(2), rW(10)
      Integer info

C ================================================================
      detG = HesP(1) * HesP(2) - HesP(3) ** 2

      If(detG.LE.0D0) Then
        A(1, 1) = HesP(1)
        A(2, 2) = HesP(2)
        A(1, 2) = HesP(3)

        Call dsyev('V', 'U', 2, A, 2, E, rW, 10, info)
        If(info.NE.0) Call errMes(3011, 'calDet',
     &                    'Error in Lapack routine dsyev')

        E(1) = abs(E(1))
        E(2) = abs(E(2))

        E(1) = max( E(1), E(2) * AniRatio )

        If(E(2).EQ.0D0) Then
           E(1) = AniEigenvalue
           E(2) = AniEigenvalue
        End if

        HesP(1) = E(1) * A(1, 1) ** 2 + E(2) * A(1, 2) ** 2
        HesP(2) = E(1) * A(2, 1) ** 2 + E(2) * A(2, 2) ** 2
        HesP(3) = E(1) * A(1, 1) * A(2, 1) + E(2) * A(1, 2) * A(2, 2)

        detG = HesP(1) * HesP(2) - HesP(3) ** 2
      End if

      Return
      End

C ================================================================
      Subroutine calQE(
C ================================================================
     &      Hes1, xy1, Hes2, xy2, Hes3, xy3,
     &      hStar, qE)
C ================================================================
C Routines computes quality of triangle {xy1, xy2, xy3} assuming
C that the metric is linear.
C
C *** Remarks:
C        1. round-off errors require to use |Lk|
C        2. moved division by 2 in HesAvg in calculation of Lk
C ================================================================
      real Hes1(3), xy1(2)
      real Hes2(3), xy2(2)
      real Hes3(3), xy3(2)
      real hStar, qE

C group (Local variables)
      real HesAvg(3), det12, det13, det23, dsum
      real Pk, Vk, Lk
      real F, x1, y1, x2, y2

C group (FUnction)
      F(x1) = (x1 * (2D0 - x1)) ** 3

C ================================================================
      Do i = 1, 3
         HesAvg(i) = Hes2(i) + Hes3(i)
      End do
      Call calDet(HesAvg, det23)

      x1 = xy3(1) - xy2(1)
      y1 = xy3(2) - xy2(2)
      Lk = abs(HesAvg(1) * x1 * x1 + HesAvg(2) * y1 * y1 +
     &                            2 * HesAvg(3) * x1 * y1) / 2
      Pk = sqrt(Lk)

      Do i = 1, 3
         HesAvg(i) = Hes1(i) + Hes2(i)
      End do
      Call calDet(HesAvg, det12)

      x1 = xy1(1) - xy2(1)
      y1 = xy1(2) - xy2(2)
      Lk = abs(HesAvg(1) * x1 * x1 + HesAvg(2) * y1 * y1 +
     &                            2 * HesAvg(3) * x1 * y1) / 2
      Pk = Pk + sqrt(Lk)

      Do i = 1, 3
         HesAvg(i) = Hes1(i) + Hes3(i)
      End do
      Call calDet(HesAvg, det13)

      x2 = xy1(1) - xy3(1)
      y2 = xy1(2) - xy3(2)
      Lk = abs(HesAvg(1) * x2 * x2 + HesAvg(2) * y2 * y2 +
     &                            2 * HesAvg(3) * x2 * y2) / 2
      Pk = Pk + sqrt(Lk)

      dsum = (sqrt(det12) + sqrt(det23) + sqrt(det13)) / 2

c     Vk = abs(x1 * y2 - y1 * x2) * 5D-1 * dsum / 3
c     qE = 20.784619D0 * Vk / (Pk ** 2) * F(x1)

      Vk = abs(x1 * y2 - y1 * x2) * dsum

      x1 = Pk / (3 * hStar)
      If(x1.GT.1D0) x1 = 1D0 / x1

      qE = 3.46410316666D0 * Vk / (Pk ** 2) * F(x1)

      Return
      End

C ================================================================
      Subroutine calQF(
C ================================================================
     &      Hes1, det1, xy1,
     &      Hes2, det2, xy2,
     &      Hes3, det3, xy3,
     &      hStar, iw)
C ================================================================
C Routine orders mesh edges in assending of their quality
C ================================================================
      real  Hes1(3), det1, xy1(2)
      real  Hes2(3), det2, xy2(2)
      real  Hes3(3), det3, xy3(2)
      real  hStar

      Integer iw(3)

C group (Local variables)
      real  HesMax(3), detMax
      real  qF(3)
      real  F, x1, y1

C group (Function)
      F(x1) = (x1 * (2D0 - x1)) ** 3

C ================================================================
      detMax = det1
      Do i = 1, 3
         HesMax(i) = Hes1(i)
      End do

      If(det2.GT.detMax) Then
         detMax = det2
         Do i = 1, 3
            HesMax(i) = Hes2(i)
         End do
      End if

      If(det3.GT.detMax) Then
         detMax = det3
         Do i = 1, 3
            HesMax(i) = Hes3(i)
         End do
      End if

      x1 = xy1(1) - xy2(1)
      y1 = xy1(2) - xy2(2)
      x1 = sqrt(HesMax(1) * x1 * x1 + HesMax(2) * y1 * y1 +
     &                             2 * HesMax(3) * x1 * y1) / hStar
      x1 = min(x1, 1D0 / x1)
      qF(1) = F(x1)

      x1 = xy3(1) - xy2(1)
      y1 = xy3(2) - xy2(2)
      x1 = sqrt(HesMax(1) * x1 * x1 + HesMax(2) * y1 * y1 +
     &                             2 * HesMax(3) * x1 * y1) / hStar
      x1 = min(x1, 1D0 / x1)
      qF(2) = F(x1)

      x1 = xy1(1) - xy3(1)
      y1 = xy1(2) - xy3(2)
      x1 = sqrt(HesMax(1) * x1 * x1 + HesMax(2) * y1 * y1 +
     &                             2 * HesMax(3) * x1 * y1) / hStar
      x1 = min(x1, 1D0 / x1)
      qF(3) = F(x1)

      iw(1) = 1
      iw(2) = 2
      iw(3) = 3

      Do i = 1, 2
         iMin = i
         Do j = i + 1, 3
            If(qF(j).LT.qF(iMin)) iMin = j
         End do

         x1 = qF(i)
         qF(i) = qF(iMin)
         qF(iMin) = x1

         k = iw(i)
         iw(i) = iw(iMin)
         iw(iMin) = k
      End do

      Return
      End

C ================================================================
      Subroutine updQE(XYP, lE, iEs, IPEs,
     &                 HesP, rQuality, detG, hStar, qEs, flag)
C ================================================================
C Routine is used for mesh smoothing (status & ANISmoothMesh = 1)
C
C *** Remark: the routine is obsolete
C ================================================================
      Integer IPEs(3, *), iEs(*)
      real  XYP(2, *),  HesP(3, *)
      real  rQuality,  detG(*), hStar, qEs(*)
      Logical flag

C group (Local variables)
      Integer iref(4)
      real  qEt
      Logical flagFirst

C ==========================================================
      iref(1) = 1
      iref(2) = 2
      iref(3) = 3
      iref(4) = 1

      flagFirst = flag
      flag = .FALSE.

      Do 50 n = 1, lE
         If(iEs(n).LE.0) goto 50

         Do 30 i1 = 1, 3
            i2 = iref(i1 + 1)

            iP1 = IPEs(i1, n)
            iP2 = IPEs(i2, n)

            Do 20 k = n + 1, lE
               If(iEs(k).LE.0)  goto 20

               Do j1 = 1, 3
                  j2 = iref(j1 + 1)

                  jP1 = IPEs(j1, k)
                  jP2 = IPEs(j2, k)

                  If(iP1.EQ.jP1 .AND. iP2.EQ.jP2 .OR.
     &               iP1.EQ.jP2 .AND. iP2.EQ.jP1) Then

                     i3 = iref(i2 + 1)
                     iP3 = IPEs(i3, n)

                     j3 = iref(j2 + 1)
                     jP3 = IPEs(j3, k)

                     Call calQE(
     &                    HesP(1, jP1), XYP(1, iP1),
     &                    HesP(1, jP2), XYP(1, iP2),
     &                    HesP(1, jP3), XYP(1, iP3),
     &                    hStar, qEt)

                     If(qEt.LT.rQuality .AND. flagFirst) goto 1000
                     qEs(n) = min(qEs(n), qEt)

                     Call calQE(
     &                    HesP(1, iP1), XYP(1, jP1),
     &                    HesP(1, iP2), XYP(1, jP2),
     &                    HesP(1, iP3), XYP(1, jP3),
     &                    hStar, qEt)

                     If(qEt.LT.rQuality. AND. flagFirst) goto 1000
                     qEs(k) = min(qEs(k), qEt)

                     goto 30
                  End if
               End do
 20         Continue
 30      Continue
 50   Continue

      flag = .TRUE.

 1000 Return
      End

C ================================================================
      real Function avgQ(nE, qE, L1E, L2E)
C ================================================================
      real  qE(*)
      Integer L2E(*), L1E(2, *)

      avgQ = 0D0

      iE = L2E(1)
      Do n = 1, nE
         avgQ = avgQ + qE(iE)
         iE = L1E(2, iE)
      End do

      avgQ = avgQ / nE

      Return
      End


C$Procedure      NVC2PL ( Normal vector and constant to plane )

      SUBROUTINE NVC2PL ( NORMAL, CONST, PLANE )

C$ Abstract
C
C     Make a SPICELIB plane from a normal vector and a constant.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PLANES
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C     PLANE
C
C$ Declarations

      INTEGER               UBPL
      PARAMETER           ( UBPL    =   4 )

      DOUBLE PRECISION      NORMAL (    3 )
      DOUBLE PRECISION      CONST
      DOUBLE PRECISION      PLANE  ( UBPL )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     NORMAL,
C     CONST      I   A normal vector and constant defining a plane.
C     PLANE      O   An array representing the plane.
C
C$ Detailed_Input
C
C     NORMAL,
C     CONST          are, respectively, a normal vector and constant
C                    defining a plane. NORMAL need not be a unit
C                    vector. Let the symbol < a, b > indicate the inner
C                    product of vectors a and b; then the geometric
C                    plane is the set of vectors X in three-dimensional
C                    space that satisfy
C
C                       < X,  NORMAL >  =  CONST.
C
C$ Detailed_Output
C
C     PLANE          is a SPICELIB plane that represents the geometric
C                    plane defined by NORMAL and CONST.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the input vector NORMAL is the zero vector, the error
C         SPICE(ZEROVECTOR) is signalled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     SPICELIB geometry routines that deal with planes use the `plane'
C     data type to represent input and output planes.  This data type
C     makes the subroutine interfaces simpler and more uniform.
C
C     The SPICELIB routines that produce SPICELIB planes from data that
C     define a plane are:
C
C        NVC2PL ( Normal vector and constant to plane )
C        NVP2PL ( Normal vector and point to plane    )
C        PSV2PL ( Point and spanning vectors to plane )
C
C     The SPICELIB routines that convert SPICELIB planes to data that
C     define a plane are:
C
C        PL2NVC ( Plane to normal vector and constant )
C        PL2NVP ( Plane to normal vector and point    )
C        PL2PSV ( Plane to point and spanning vectors )
C
C     Any of these last three routines may be used to convert this
C     routine's output, PLANE, to another representation of a
C     geometric plane.
C
C$ Examples
C
C     1)  Apply a linear transformation represented by the matrix M to
C         a plane represented by the normal vector N and the constant C.
C         Find a normal vector and constant for the transformed plane.
C
C            C
C            C     Make a SPICELIB plane from N and C, and then find a
C            C     point in the plane and spanning vectors for the
C            C     plane.  N need not be a unit vector.
C            C
C                  CALL NVC2PL ( N,      C,      PLANE         )
C                  CALL PL2PSV ( PLANE,  POINT,  SPAN1,  SPAN2 )
C
C            C
C            C     Apply the linear transformation to the point and
C            C     spanning vectors.  All we need to do is multiply
C            C     these vectors by M, since for any linear
C            C     transformation T,
C            C
C            C           T ( POINT  +  t1 * SPAN1     +  t2 * SPAN2 )
C            C
C            C        =  T (POINT)  +  t1 * T(SPAN1)  +  t2 * T(SPAN2),
C            C
C            C     which means that T(POINT), T(SPAN1), and T(SPAN2)
C            C     are a point and spanning vectors for the transformed
C            C     plane.
C            C
C                  CALL MXV ( M, POINT, TPOINT )
C                  CALL MXV ( M, SPAN1, TSPAN1 )
C                  CALL MXV ( M, SPAN2, TSPAN2 )
C
C            C
C            C     Make a new SPICELIB plane TPLANE from the
C            C     transformed point and spanning vectors, and find a
C            C     unit normal and constant for this new plane.
C            C
C                  CALL PSV2PL ( TPOINT,  TSPAN1,  TSPAN2,  TPLANE )
C                  CALL PL2NVC ( TPLANE,  TN,      TC              )
C
C$ Restrictions
C
C     No checking is done to prevent arithmetic overflow.
C
C$ Literature_References
C
C     [1] `Calculus and Analytic Geometry', Thomas and Finney.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 02-NOV-2009 (NJB)
C
C        Corrected header typo.
C
C-    SPICELIB Version 1.1.0, 30-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VMINUS call.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     normal vector and constant to plane
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 30-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VMINUS call.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local parameters
C

C
C     The contents of SPICELIB planes are as follows:
C
C        Elements NMLPOS through NMLPOS + 2 contain a unit normal
C        vector for the plane.
C
C        Element CONPOS contains a constant for the plane;  every point
C        X in the plane satisifies
C
C           < X, PLANE(NMLPOS) >  =  PLANE(CONPOS).
C
C        The plane constant is the distance of the plane from the
C        origin; the normal vector, scaled by the constant, is the
C        closest point in the plane to the origin.
C
C
      INTEGER               NMLPOS
      PARAMETER           ( NMLPOS = 1 )

      INTEGER               CONPOS
      PARAMETER           ( CONPOS = 4 )

C
C     Local variables
C
      DOUBLE PRECISION      MAG
      DOUBLE PRECISION      TMPVEC ( 3 )

C
C     This routine checks in only if an error is discovered.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL UNORM ( NORMAL, PLANE(NMLPOS), MAG )

C
C     The normal vector must be non-zero.
C
      IF ( MAG .EQ. 0 ) THEN

         CALL CHKIN  ( 'NVC2PL'                            )
         CALL SETMSG ( 'Plane''s normal must be non-zero.' )
         CALL SIGERR ( 'SPICE(ZEROVECTOR)'                 )
         CALL CHKOUT ( 'NVC2PL'                            )
         RETURN

      END IF

C
C     To find the plane constant corresponding to the unitized normal
C     vector, we observe that
C
C        < X, NORMAL > = CONST,
C
C     so
C
C        < X, NORMAL / || NORMAL || >   =   CONST / || NORMAL ||
C
C
      PLANE(CONPOS) =  CONST / MAG

C
C     The constant should be the distance of the plane from the
C     origin.  If the constant is negative, negate both it and the
C     normal vector.
C
      IF ( PLANE(CONPOS) .LT. 0.D0 ) THEN

         PLANE(CONPOS) =   -PLANE(CONPOS)
         CALL VMINUS     (  PLANE(NMLPOS), TMPVEC        )
         CALL VEQU       (  TMPVEC,        PLANE(NMLPOS) )

      END IF

      RETURN
      END


      subroutine zroots(a,m,roots,plsh,ier)
      parameter(eps=1.e-6,maxm=201)
c********************************************
c  Complex roots of polynomial Sum(i=0,m) a(i+1)x**i
c============================================
      complex a(m+1),roots(m),ad(maxm),x,b,c
      logical*1 plsh
      intent(in) a,m
      intent(out) roots,ier
c****************************
c Trap m
      if(m>=maxm) then
       write(6,*) 'm+1 ',m+1,' > maxm ',maxm,' in ZROOTS'
       return
      endif
      do j=1,m+1
       ad(j)=a(j)
      enddo
      do j=m,1,-1
       x=cmplx(0.,0.)
       call laguer(ad,j,x,its,ier)
       if(abs(aimag(x))<=2.*eps**2*abs(real(x))) x=cmplx(real(x),0.)
       roots(j)=x
       b=ad(j+1)
       do jj=j,1,-1
        c=ad(jj)
        ad(jj)=b
        b=x*b+c
       enddo
      enddo
      if(plsh) then
       do j=1,m
        call laguer(a,m,roots(j),its,ier)
       enddo
      endif
      do j=2,m
       x=roots(j)
       do i=j-1,1,-1
        if(real(roots(i))<=real(x)) goto 1
        roots(i+1)=roots(i)
       enddo
       i=0
1      roots(i+1)=x
      enddo
c-------
      return
      end
c
c============================================
c
      subroutine laguer(a,m,x,its,ier)
      parameter(epss=2.e-7,mr=8,mt=100,maxit=mt*mr)
c***********************************
c  Called by zroots
c===================================
      real frac(mr)
      complex a(m+1),x,dx,x1,b,d,f,g,h,sq,gp,gm,g2
      save frac
      data frac /.5,.25,.75,.13,.38,.62,.88,1./
      intent(in) a,m
      intent(out) x,its,ier
c****************************
      do iter=1,maxit
       its=iter
       b=a(m+1)
       err=abs(b)
       d=cmplx(0.,0.)
       f=cmplx(0.,0.)
       abx=abs(x)
       do j=m,1,-1
        if(abs(f)>1.e35.or.abs(b)>1.35.or.abs(d)>1.35) then
         exit
        endif
        f=x*f+d
        d=x*d+b
        b=x*b+a(j)
        err=abs(b)+abx*err
       enddo
       err=epss*err
       if(abs(b)<=err) then
        return
         else
          g=d/b
          g2=g*g
          h=g2-2.*f/b
          sq=sqrt((m-1)*(m*h-g2))
          gp=g+sq
          gm=g-sq
          abp=abs(gp)
          abm=abs(gm)
          if(abp<abm) gp=gm
          if(max(abp,abm)>0.) then
           dx=m/gp
            else
             dx=exp(cmplx(log(1.+abx),real(iter)))
          endif
        endif
        x1=x-dx
        if(abs(x-x1)<1.e-9) return
        if(mod(iter,mt)/=0) then
         x=x1
          else
           x=x-dx*frac(iter/mt)
       endif
      enddo
c-------
      ier=1
      return
      end


module special
  !-----------------------------------------------------------------------------
  ! Module: special
  !  This modules contains subroutines to compute special functions.
  !
  ! Subroutines:
  !  auxiliary (public)
  !    Compute the auxiliary rotation functions (also called generalized
  !    spherical functions) for a given k.
  !
  ! Useful Citations:
  !  Siewert, CE. "A discrete-ordinates solution for radiative-transfer
  !  models that include polarization effects." JQSRT, 2000.
  !
  !  Hovenier, JW, CVM van der Mee, and H Domke. Transfer of
  !  polarized light in planetary atmospheres: basic concepts and practical
  !  methods. Vol. 318. Springer Science & Business Media, 2014.
  !
  !  Varshalovich DA, Moskalev AN, Khersonskii VK. Quantum theory of angular
  !  momentum. World scientific, 1988.
  !---
  ! Developed by J.P. Dark
  ! Contact: email@jpdark.com
  ! Last modified June 2017
  !-----------------------------------------------------------------------------

  implicit none

  integer, parameter :: sp = kind(1.0)
  integer, parameter :: dp = kind(1.d0)
  real(dp), parameter :: PI = 3.141592653589793_dp

  private
  public :: auxiliary

contains

  subroutine auxiliary(k, N, L, mu, plk, rlk, tlk)
    !!--------------------------------------------------------------------------
    !! Name: auxiliary
    !!  Compute the auxiliary rotation functions (also called generalized
    !!  spherical functions) for a given k.
    !!
    !! Synopsis
    !!  auxiliary(k, N, L, mu, plk, rlk, tlk)
    !!
    !!     INPUT
    !!      Integer ------------- k, N, L
    !!      Double precision ---- mu(N)
    !!
    !!    OUTPUT
    !!      Double precision ---- plk(L+1, N), rlk(L+1, N), tlk(L+1, N)
    !!
    !!
    !! Purpose
    !!  Compute the auxiliary functions Plk, Rlk, and Tlk for a given k at
    !!  gridpoints mu (in the interval [-1,1]) using the initial values:
    !!
    !!    P[k,k](x) = sqrt((2k)!) * (1-x^2)^{k-2},
    !!    R[k,k](x) = 1/2^k * sqrt((2k)! / ((k+2)!(k-2)!)) * (1+x^2)
    !!                 * (1-x^2)^(1+l/2),
    !!    T[k,k](x) = 1/2^k * sqrt((2k)! / ((k+2)!(k-2)!)) * (1+x^2)
    !!                 * (1-x^2)^(1+l/2),
    !!
    !!
    !!  and the recurrence relations
    !!
    !!     sqrt((j+1)^2 - k^2) * P[j+1,k](x) = (2*j+1) * x * P[j,k](x)
    !!                                        - sqrt(j^2-k^2) P[j-1,k](x),
    !!
    !!     j * sqrt((j+1)^2 - k^2) * sqrt((j+1)^2 - 4) * R[j+1,k](x)
    !!        = j * (j+1) * (2*j+1) * x * R[j,k](x)
    !!          - (j+1) * sqrt(j^2 - 4) * sqrt(j^2 - k^2) * R[j-1,k](x)
    !!          - 2 * k * (2j+1) T[j,k](x),
    !!
    !!     j * sqrt((j+1)^2 - k^2) * sqrt((j+1)^2 - 4) * T[j+1,k](x)
    !!        = j * (j+1) * (2*j+1) * x * T[j,k](x)
    !!          - (j+1) * sqrt(j^2 - 4) * sqrt(j^2 - k^2) * T[j-1,k](x)
    !!          - 2 * k * (2j+1) R[j,k](x)
    !!
    !!
    !! Arguments
    !!  k (input) integer
    !!   Index for the auxiliary functions.
    !!
    !!  N (input) integer
    !!   The number of ordinate quadrature points.
    !!
    !!  L (input) integer
    !!   The order of the expansion.
    !!
    !!  mu (input) double precision, array(N)
    !!   Quadrature of ordinate directions.
    !!
    !!  plk (output) double precision, array(L+1, N)
    !!   Auxiliary functions as defined by Siewert et.al. 2000.
    !!
    !!  rlk (output) double precision, array(L+1, N)
    !!   Auxiliary functions as defined by Siewert et.al. 2000.
    !!
    !!  tlk (output) double precision, array(L+1, N)
    !!   Auxiliary functions as defined by Siewert et.al. 2000.
    !!--------------------------------------------------------------------------
    implicit none
    ! INPUT
    integer(8), intent(in) :: k, N, L
    real(dp), dimension(:), intent(in) :: mu ! dim(N)
    ! OUTPUT
    real(dp), dimension(L+1, N), intent(out) :: plk, rlk, tlk
    ! Workspace
    real(dp), dimension(N) :: smu
    real(dp) :: a1, a2, c1, c2, d1
    real(dp) :: tmp
    integer(8) :: jj
    plk = 0.0_dp
    rlk = 0.0_dp
    tlk = 0.0_dp
    if (k > L .or. k < 0) then
       write (*,*) "> PROGRAM STOPPED BEFORE COMPLETING."
       write (*,*) "> ERROR in __special_MOD_auxiliary."
       write (*,*) "> Illegal value of k: must have 0 <= k <= L."
       stop
    endif
    smu = sqrt((1.0_dp - mu) * (1.0_dp + mu))
    if (k > 2) then
       !
       ! Compute initial value for Plk(x), Rlk(x), and Tlk(x).
       !
       tmp = 1.0_dp
       do jj = 1, k
          tmp = tmp * sqrt(0.25_dp + 0.25 * real(k, dp) / real(jj, dp))
       enddo
       plk(k+1, :) = tmp * smu **  k
       !
       ! Compute initial value for Plk(x), Rlk(x), and Tlk(x).
       !
       tmp = 0.5_dp ** k
       do jj = 1, k-2
          tmp = tmp * sqrt(1.0_dp + real(k + 2, dp) / real(jj, dp))
       enddo
       rlk(k+1, :) = tmp * (1.0_dp + mu ** 2) * smu ** (k - 2_dp)
       tlk(k+1, :) = 2.0_dp * mu * tmp * smu ** (k - 2_dp)
       !
       ! Compute higher order polynomials using recurrence relation.
       !
       if (L == k) then
          return
       endif
       plk(k+2, :) = sqrt(real(2 * k + 1, dp)) * mu * plk(k+1, :)
       tmp = sqrt(real((k+1) ** 2 - 4, dp))
       c1 = sqrt(real(2 *k + 1, dp)) * real((k+1), dp) / tmp
       d1 = 2.0_dp * sqrt(real(2 *k + 1, dp)) / tmp
       rlk(k+2, :) = c1 * mu * rlk(k+1, :) - d1 * tlk(k+1, :)
       tlk(k+2, :) = c1 * mu * tlk(k+1, :) - d1 * rlk(k+1, :)
       do jj = k+2, L
          tmp = sqrt(real(jj ** 2 - k ** 2, dp))
          a1 = real(2 * jj - 1, dp) / tmp
          a2 = sqrt(real((jj-1) ** 2 - k ** 2, dp)) / tmp
          plk(jj+1, :) = a1 * mu * plk(jj, :) - a2 * plk(jj-1, :)
          tmp = sqrt(real((jj ** 2 - 4) * (jj ** 2 - k ** 2), dp)) &
               * real(jj - 1, dp)
          c1 = real((2 * jj - 1) * jj * (jj - 1), dp) / tmp
          c2 = sqrt(real(((jj - 1) ** 2 - 4) * ((jj - 1) ** 2 - k ** 2), dp)) &
               * real(jj, dp) / tmp
          d1 = real(2 * k * (2 * jj - 1), dp) / tmp
          rlk(jj+1, :) = c1 * mu * rlk(jj, :) - c2 * rlk(jj-1, :) &
               - d1 * tlk(jj, :)
          tlk(jj+1, :) = c1 * mu * tlk(jj, :) - c2 * tlk(jj-1, :) &
               - d1 * rlk(jj, :)
       enddo

    else if (k == 2) then
       !
       ! Compute initial value for Plk(x).
       !
       plk(3, :) = sqrt(0.375_dp) * smu ** 2
       rlk(3, :) = 0.25_dp * (1.0_dp + mu ** 2)
       tlk(3, :) = 0.5_dp * mu
       if (L == 2) then
          return
       endif
       plk(4, :) = sqrt(5.0_dp) * mu * plk(3, :)
       rlk(4, :) = 3.0_dp * mu * rlk(3, :) - 2.0_dp * tlk(3, :)
       tlk(4, :) = 3.0_dp * mu * tlk(3, :) - 2.0_dp * rlk(3, :)
       !
       ! Compute higher order polynomials using recurrence relation.
       !
       do jj = 4, L
          ! Plk(x)
          tmp = sqrt(real(jj ** 2 - 4_dp, dp))
          a1 = real(2_dp * jj - 1_dp, dp) / tmp
          a2 = sqrt(real((jj-1) ** 2 - 4_dp, dp)) / tmp
          plk(jj+1, :) = a1 * mu * plk(jj, :) - a2 * plk(jj-1, :)
          ! Rlk(x), Tlk(x)
          tmp = real((jj ** 2 - 4) * (jj - 1), dp)
          c1 = real((2 * jj - 1) * jj * (jj - 1), dp) / tmp
          c2 = real(((jj - 1) ** 2 - 4) * jj, dp) / tmp
          d1 = real(4 * (2 * jj - 1), dp) / tmp
          rlk(jj+1, :) = c1 * mu * rlk(jj, :) - c2 * rlk(jj-1, :) &
               - d1 * tlk(jj, :)
          tlk(jj+1, :) = c1 * mu * tlk(jj, :) - c2 * tlk(jj-1, :) &
               - d1 * rlk(jj, :)
       enddo

    else if (k == 1) then
       !
       ! Compute initial value for Plk(x).
       !
       plk(2, :) = sqrt(0.5_dp) * smu ! Check sign.
       if (L == 1) then
          return
       endif
       plk(3, :) = sqrt(1.5_dp) * mu * smu
       tlk(3, :) = - 0.5_dp * smu
       rlk(3, :) = mu * tlk(3, :)
       if (L == 2) then
          return
       endif
       plk(4, :) = sqrt(3.125_dp) * mu * plk(3, :) &
            - sqrt(0.375_dp) * plk(2, :)
       rlk(4, :) = sqrt(5.625_dp) * mu * rlk(3, :) &
            - sqrt(0.625_dp) * tlk(3, :)
       tlk(4, :) = sqrt(5.625_dp) * mu * tlk(3, :) &
            - sqrt(0.625_dp) * rlk(3, :)
       !
       ! Compute higher order polynomials using recurrence relation.
       !
       do jj = 4, L
          !
          ! P[j+1,1](x) = a1(l) * x * P[j,1](x) - a2(l) * P[j-1,1](x)
          !
          tmp = sqrt(real(jj ** 2 - 1, dp))
          a1 = real(2 * jj - 1, dp) / tmp
          a2 = sqrt(real((jj - 1) ** 2 - 1, dp)) / tmp
          plk(jj+1, :) = a1 * mu * plk(jj, :) - a2 * plk(jj-1, :)
          !
          ! R[j+1,1](x) = c1 * mu R[j,1](x) - c2 * R[j-1,1](x)
          !               - d1 * T[j,1](x)
          !
          ! and
          !
          ! T[j+1,1](x) = c1 * mu T[j,1](x) - c2 * T[j-1,1](x)
          !               - d1 * R[j,1](x)
          !
          tmp = sqrt( real( (jj ** 2 - 4) * (jj ** 2 - 1), dp)) &
               * real(jj - 1, dp)
          c1 = real((2 * jj - 1) * jj * (jj - 1), dp) / tmp
          c2 = sqrt(real(((jj - 1) ** 2 - 4) * ((jj - 1) ** 2 - k), dp)) &
               * real(jj, dp) / tmp
          d1 = real(2 * k * (2 * jj - 1), dp) / tmp
          rlk(jj+1, :) = c1 * mu * rlk(jj, :) - c2 * rlk(jj-1, :) &
               - d1 * tlk(jj, :)
          tlk(jj+1, :) = c1 * mu * tlk(jj, :) - c2 * tlk(jj-1, :) &
               - d1 * rlk(jj, :)
       enddo

    else if (k == 0) then
       !
       ! Compute initial values for Plk(x) and Rlk(x). Tlk(x) = 0.
       !
       plk(1, :) = 1.0_dp
       if (L == 0) then
          return
       endif
       plk(2, :) = mu
       if (L == 1) then
          return
       endif
       plk(3, :) = 1.5_dp * mu ** 2 - 0.5_dp
       rlk(3, :) = sqrt(0.375_dp) * smu ** 2
       if (L == 2) then
          return
       endif
       plk(4, :) = 0.5 * (5.0_dp * mu ** 3 - 3.0_dp * mu)
       rlk(4, :) = sqrt(5.0_dp) * mu * rlk(3, :)
       !
       ! Compute higher order values.
       !
       do jj = 4, L
          !
          ! (j+1) * P[j+1,k](x) = (2j+1) * x * P[j,k](x) - j * P[j-1,k](x).
          !
          tmp = real(jj, dp)
          a1 = real(2_dp * jj - 1_dp, dp) / tmp
          a2 = real(jj - 1, dp) / tmp
          plk(jj+1, :) = a1 * mu * plk(jj, :) - a2 * plk(jj-1, :)
          !
          ! sqrt((j+1)^2 - 4) * R[j+1,k](x) = (2j+1) * R[j,k}(x)
          !     - sqrt(j^2 - 4) * R[j-1,k](x).
          !
          tmp = sqrt(real(jj ** 2 - 4_dp, dp))
          c1 = real(2_dp * jj - 1_dp, dp) / tmp
          c2 = sqrt(real((jj-1) ** 2 - 4_dp, dp)) / tmp
          rlk(jj+1, :) = c1 * mu * rlk(jj, :) - c2 * rlk(jj-1, :)
       enddo
    endif
    !---------------------------------------------------------------------------
    ! Correct for sign error in convention chosen?
    !
    rlk = -rlk
    tlk = -tlk
    !---------------------------------------------------------------------------
  end subroutine auxiliary

end module special


!
! Copyright (C) 2001 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------
subroutine struc_fact (nat, tau, ntyp, ityp, ngm, g, bg, nr1, nr2, &
     nr3, strf, eigts1, eigts2, eigts3)
  !----------------------------------------------------------------------
  !
  !   calculate the structure factors for each type of atoms in the unit
  !   cell
  !
  USE kinds
  USE constants, ONLY : tpi
  implicit none
  !
  !   Here the dummy variables
  !

  integer :: nat, ntyp, ityp (nat), ngm, nr1, nr2, nr3
  ! input: the number of atom in the unit cel
  ! input: the number of atom types
  ! input: for each atom gives the type
  ! input: the number of G vectors
  ! input: fft dimension along x
  ! input: fft dimension along y
  ! input: fft dimension along z

  real(DP) :: bg (3, 3), tau (3, nat), g (3, ngm)
  ! input: reciprocal crystal basis vectors
  ! input: the positions of the atoms in the c
  ! input: the coordinates of the g vectors

  complex(DP) :: strf (ngm, ntyp),        &
                      eigts1 ( -nr1:nr1, nat), &
                      eigts2 ( -nr2:nr2, nat), &
                      eigts3 ( -nr3:nr3, nat)
  ! output: the structure factor
  !
  ! output: the phases e^{-iG\tau_s}
  !
  !
  !    here the local variables
  !
  integer :: nt, na, ng, n1, n2, n3, ipol
  ! counter over atom type
  ! counter over atoms
  ! counter over G vectors
  ! counter over fft dimension along x
  ! counter over fft dimension along y
  ! counter over fft dimension along z
  ! counter over polarizations

  real(DP) :: arg, bgtau (3)
  ! the argument of the exponent
  ! scalar product of bg and tau

  strf(:,:) = (0.d0,0.d0)
  do nt = 1, ntyp
     do na = 1, nat
        if (ityp (na) .eq.nt) then
           do ng = 1, ngm
              arg = (g (1, ng) * tau (1, na) + g (2, ng) * tau (2, na) &
                   + g (3, ng) * tau (3, na) ) * tpi
              strf (ng, nt) = strf (ng, nt) + CMPLX(cos (arg), -sin (arg),kind=DP)
           enddo
        endif
     enddo
  enddo

  do na = 1, nat
     do ipol = 1, 3
        bgtau (ipol) = bg (1, ipol) * tau (1, na) + &
                       bg (2, ipol) * tau (2, na) + &
                       bg (3, ipol) * tau (3, na)
     enddo
     do n1 = - nr1, nr1
        arg = tpi * n1 * bgtau (1)
        eigts1 (n1, na) = CMPLX(cos (arg), - sin (arg) ,kind=DP)
     enddo
     do n2 = - nr2, nr2
        arg = tpi * n2 * bgtau (2)
        eigts2 (n2, na) = CMPLX(cos (arg), - sin (arg) ,kind=DP)
     enddo
     do n3 = - nr3, nr3
        arg = tpi * n3 * bgtau (3)
        eigts3 (n3, na) = CMPLX(cos (arg), - sin (arg) ,kind=DP)
     enddo
  enddo

  return
end subroutine struc_fact


program array_op_1
implicit none

integer :: a(4), b(4)
real :: c(4), d(4)
integer :: i, j

i = 0

a = [i + 1, (i + j, j = 1, i + 3), i + 4]

b = [4*a(i + 1), 5*a(i + 2), 6*a(i + 3), 7*a(i + 4)]

! c = [i + 1, (i*j, j = 1, i + 3), i + 4]

c(1) = i + 1
c(2) = i*1
c(3) = i*2
c(4) = i*3

print *, a(1), a(2), a(3), a(4)

print *, b(1), b(2), b(3), b(4)

print *, c(1), c(2), c(3), c(4)

d = a + b + c
print *, d(1), d(2), d(3), d(4)

d = a - b*c
print *, d(1), d(2), d(3), d(4)

d = a*b*c
print *, d(1), d(2), d(3), d(4)

d = (a*b)/(c + 1)
print *, d(1), d(2), d(3), d(4)

end program


! integrator.f90
!
!>  Module with the integration routines.
!
!> @copyright
!> 2015 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!
!
!>  @remark
!>  This module actually contains the Heun algorithm routines.
!>  The user can modify it according to its preferred integration scheme.
!>  For higher-order schemes, additional buffers will probably have to be defined.
!
!---------------------------------------------------------------------------

MODULE integrator
  USE params, only: ndim
  USE tensor, only:sparse_mul3
  USE aotensor_def, only: aotensor
  IMPLICIT NONE

! PRIVATE
  PUBLIC !STEVE: needed to finalize buf arrays externally

  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: buf_y1 !< Buffer to hold the intermediate position (Heun algorithm)
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: buf_f0 !< Buffer to hold tendencies at the initial position
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: buf_f1 !< Buffer to hold tendencies at the intermediate position

  PUBLIC :: init_integrator, step

CONTAINS

  !> Routine to initialise the integration buffers.
  SUBROUTINE init_integrator
    INTEGER :: AllocStat
    ALLOCATE(buf_y1(0:ndim),buf_f0(0:ndim),buf_f1(0:ndim) ,STAT=AllocStat)
    IF (AllocStat /= 0) then
      print *, "init_integrator:: AllocStat = ", AllocStat
      STOP "*** Not enough memory ! ***"
    ENDIF
  END SUBROUTINE init_integrator

  !> Routine computing the tendencies of the model
  !> @param t Time at which the tendencies have to be computed. Actually not needed for autonomous systems.
  !> @param y Point at which the tendencies have to be computed.
  !> @param res vector to store the result.
  !> @remark Note that it is NOT safe to pass `y` as a result buffer,
  !> as this operation does multiple passes.
  SUBROUTINE tendencies(t,y,res)
    REAL(KIND=8), INTENT(IN) :: t
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: y
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
    CALL sparse_mul3(aotensor, y, y, res)
  END SUBROUTINE tendencies

  !> Routine to perform an integration step (Heun algorithm). The incremented time is returned.
  !> @param y Initial point.
  !> @param t Actual integration time
  !> @param dt Integration timestep.
  !> @param res Final point after the step.
  SUBROUTINE step(y,t,dt,res)
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: y
    REAL(KIND=8), INTENT(INOUT) :: t
    REAL(KIND=8), INTENT(IN) :: dt
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res

    CALL tendencies(t,y,buf_f0)
    buf_y1 = y+dt*buf_f0
    CALL tendencies(t+dt,buf_y1,buf_f1)
    res=y+0.5*(buf_f0+buf_f1)*dt
    t=t+dt
  END SUBROUTINE step

END MODULE integrator


SUBROUTINE gmst_iers(mjd, ut1_utc , GMST)

! ----------------------------------------------------------------------
! SUBROUTINE: gmst_iers.f03
! ----------------------------------------------------------------------
! Purpose:
!  Greenwich Mean Sidereal Time (GMST) computation based on the IERS
!  Convetions 2010 and IAU 2006 resolutions
! ----------------------------------------------------------------------
! Input arguments
! - mjd:			Modified Julain Day (MJD) number in Terrestrial Time (TT)
! 					scale including the fraction of the day
! - ut1_utc:   		Time difference between UT1 and UTC (seconds)
!
! Output arguments:
! - GMST :			Greenwich mean sidereal time (radians)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	27 October 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: mjd, ut1_utc

! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: GMST
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC, mjd_UT1
      INTEGER (KIND = prec_int8) :: mjd_UTC_day
      DOUBLE PRECISION TT1_UT1, TT2_UT1, TT1, TT2
      DOUBLE PRECISION GMST00, GMST06
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Called Functions (F77)
      DOUBLE PRECISION iau_GMST00, iau_GMST06, iau_ANP
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time Systems transformation
CALL time_TT (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! TT
      TT1 = 2400000.5D0
      TT2 = mjd_TT
! ----------------------------------------------------------------------
! UTC
      mjd_UTC_day = INT (mjd_UTC)
! ----------------------------------------------------------------------
! UT1
      mjd_UT1 = mjd_UTC + UT1_UTC / 86400.D0
      TT1_UT1 = 2400000.5D0
      TT2_UT1 = mjd_UT1
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! IAU SOFA subroutines
! Model consistent with IAU 2000 resolutions
GMST00 = iau_GMST00 ( TT1_UT1, TT2_UT1, TT1, TT2 )

! IERS Conventions 2010 Equation 5.32
! Model consistent with IAU 2006 resolutions
GMST06 = iau_GMST06 ( TT1_UT1, TT2_UT1, TT1, TT2 )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Greenwich Mean Sidereal Time (GMST) in radians
!GMST = GMST00
GMST = GMST06
! ----------------------------------------------------------------------

END


!*==dlapy2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAPY2 returns sqrt(x2+y2).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAPY2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION   X, Y
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
!> overflow.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] X
!> \verbatim
!>          X is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in] Y
!> \verbatim
!>          Y is DOUBLE PRECISION
!>          X and Y specify the values x and y.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2017
!
!> \ingroup OTHERauxiliary
!
!  =====================================================================
      DOUBLE PRECISION FUNCTION DLAPY2(X,Y)
      IMPLICIT NONE
!*--DLAPY267
!
!  -- LAPACK auxiliary routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION X , Y
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION w , xabs , yabs , z
      LOGICAL x_is_nan , y_is_nan
!     ..
!     .. External Functions ..
      LOGICAL DISNAN
      EXTERNAL DISNAN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX , MIN , SQRT
!     ..
!     .. Executable Statements ..
!
      x_is_nan = DISNAN(X)
      y_is_nan = DISNAN(Y)
      IF ( x_is_nan ) DLAPY2 = X
      IF ( y_is_nan ) DLAPY2 = Y
!
      IF ( .NOT.(x_is_nan .OR. y_is_nan) ) THEN
         xabs = ABS(X)
         yabs = ABS(Y)
         w = MAX(xabs,yabs)
         z = MIN(xabs,yabs)
         IF ( z==ZERO ) THEN
            DLAPY2 = w
         ELSE
            DLAPY2 = w*SQRT(ONE+(z/w)**2)
         ENDIF
      ENDIF
!
!     End of DLAPY2
!
      END FUNCTION DLAPY2


!======================================================================!
REAL FUNCTION Atanh(x)
    !----------------------------------------------------------------------!
    !   Calculates inverse of hyperbolic tangens.                          !
    !----------------------------------------------------------------------!
    IMPLICIT NONE
    !-----------------------------[Parameters]-----------------------------!
    REAL :: x
    !--------------------------------[CVS]---------------------------------!
    !  $Id: Atanh.f90,v 1.6 2002/10/30 16:29:20 niceno Exp $
    !  $Source: /home/muhamed/.CVSROOT/T-Rex/Generate/Atanh.f90,v $
    !======================================================================!
    if(x  > 1.0) then
        write(*,*) 'Error message from atanh: bad argument'
        stop
    end if

    atanh=log( sqrt( (1.0+x)/(1.0-x) ) )

END FUNCTION Atanh


      subroutine torus_setprob()
      implicit none

      double precision pi, pi2
      common /compi/ pi, pi2

      integer example
      common /example_comm/ example

      integer initchoice
      common /initchoice_comm/ initchoice

      integer refine_pattern
      common /refine_comm/ refine_pattern

      double precision init_radius
      common /initradius_comm/ init_radius

      double precision alpha, beta, theta_range(2), phi_range(2)
      common /torus_comm/ alpha, beta, theta_range, phi_range

      double precision revs_per_s, cart_speed
      common /stream_comm/ revs_per_s, cart_speed

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

      open(10,file='setprob.data')
      read(10,*) example
      read(10,*) initchoice
      read(10,*) refine_pattern
      read(10,*) alpha
      read(10,*) beta
      read(10,*) init_radius
      read(10,*) revs_per_s
      read(10,*) cart_speed
      read(10,*) theta_range(1)
      read(10,*) theta_range(2)
      read(10,*) phi_range(1)
      read(10,*) phi_range(2)
      close(10)

      end


C****************************************************************************
C
C WAVEPACK:  routines to compute the wavelet transform of a time series,
C            and significance levels.
C
C Written by:   Christopher Torrence and Gilbert P. Compo
C
C Available from:  http://paos.colorado.edu/research/wavelets/
C
C Requires the following packages:   CFFTPACK, CHISQR
C
C Notes:
C
C  (1) All routines are written in single precision (DOUBLE PRECISION),
C      except for CHISQR, which requires double precision input.
C      Single precision should be sufficient for most applications.
C
C  (2) The CFFTPACK and CHISQR routines were not written by us,
C      and no guarentees are made as to their reliability or efficiency.
C
C  (3) No provision is made for output to files or to graphics packages.
C      The user is expected to call these routines from within
C      their own programs. See sample program "wavetest.f".
C
C  (4) Little error checking is done. Check your input carefully.
C      The programs are not completely ANSI compatible, so use caution.
C
C  (5) Time series are currently limited to 65535 points.
C
C
C Reference: Torrence, C. and G. P. Compo, 1998: A Practical Guide to
C            Wavelet Analysis. Bull. Amer. Meteor. Soc., 79, 61-78.
C
C Notice: Please acknowledge the use of this software in any publications:
C    ``Wavelet software was provided by C. Torrence and G. Compo,
C      and is available at URL: http://paos.colorado.edu/research/wavelets/''.
C
C  Copyright (C) 1998, Christopher Torrence
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.
C
C
C Modified: November 1999 by Arjan van Dijk to include IMPLICIT NONE and
C           to convert all routines to DOUBLE precision.
C****************************************************************************

C****************************************************************************
C WAVELET: computes the wavelet transform of a time series,
C          with appropriate parameters.
C
C
C INPUTS:
C
C  n [INT] = the number of points in "y".
C
C  y [DOUBLE PRECISION] = the time series of length "n".
C
C  dt [DOUBLE PRECISION] = amount of time between each Y value, i.e. the sampling time.
C
C  mother [INT] = An integer giving the mother wavelet to use.
C                   0='Morlet'
C                   1='Paul'
C                   2='DOG' (derivative of Gaussian)
C               If (mother<0 or >2) then default is 'Morlet'.
C
C  param [DOUBLE PRECISION] = mother wavelet parameter. If <0 then default is used.
C            For 'Morlet' this is k0 (wavenumber), default is 6.
C            For 'Paul' this is m (order), default is 4.
C            For 'DOG' this is m (m-th derivative), default is 2.
C
C
C  s0 [DOUBLE PRECISION] = the smallest scale of the wavelet.  Typically = 2*dt.
C         Note: for accurate reconstruction and variance computation
C             set s0=dt for Morlet; s0=dt/4 for Paul
C
C  dj [DOUBLE PRECISION] = the spacing between discrete scales. Typically = 0.25.
C         A smaller # will give better scale resolution, but be slower.
C
C  jtot [INT] = the # of scales.
C             Scales range from s0 up to s0*2^[(jtot-1)*dj],
C             Typically jtot=1+(LOG2(n dt/s0))/dj
C
C  npad [INT] = the total number of points (including padding) to
C             use for the wavelet transform. Typically this is some
C             power of 2. It must be greater or equal to "n".
C             If npad>n, then zeroes are padded onto the end
C             of the time series.
C
C
C OUTPUTS:
C
C  wave [DCMPLX(n,jtot)] = 2D array of the real & imaginary parts
C                 of the wavelet transform, versus time & scale.
C                 CABS(wave) gives the WAVELET amplitude,
C                 ATAN2(AIMAG(wave),DBLE(wave)) gives WAVELET phase.
C                 The WAVELET power spectrum is CABS(wave)**2.
C
C  scale [DOUBLE PRECISION(jtot)] = the wavelet scales that were used.
C
C  period [DOUBLE PRECISION(jtot)] = the "Fourier" periods (in time units) corresponding
C            to "scale".
C
C  coi [DOUBLE PRECISION(n)] = the e-folding factor used for the cone of influence.
C
C
C REQUIRES:   WAVE_FUNCTION, CFFTPACK
C
C  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.

      SUBROUTINE WAVELET (n,y,dt,mother,param,s0,dj,jtot,npad,
     &             wave,scale,period,coi)
      IMPLICIT none

      INTEGER n,mother,jtot,npad
      DOUBLE PRECISION y(n),dt,param,s0,dj,scale(jtot),period(jtot),
     &  coi(n)
      DOUBLE COMPLEX wave(n,jtot)

      INTEGER i,j,k,nk
      DOUBLE PRECISION ymean,freq1,pi,period1,coi1

C** initialize work arrays
      PARAMETER (nk=65535)
      DOUBLE PRECISION wsave(4*nk+15),kwave(nk)
      DOUBLE COMPLEX yfft(nk),daughter(nk)

      pi = 4.D0*ATAN(1.D0)

      IF (npad.LT.n) THEN
        PRINT*,'**WAVELET: "npad" must be greater than or equal to "n"'
        RETURN
      END IF

      IF ((mother.LT.0).OR.(mother.GT.2)) mother = 0

C** find the time-series mean & remove it
      ymean = 0.D0
      DO 10 i=1,n
        ymean = ymean + y(i)
10    CONTINUE
      ymean = ymean/n
      DO 15 i=1,n
        yfft(i) = y(i) - ymean
15    CONTINUE

C** if desired, pad with extra zeroes
      DO 20 i=n+1,npad
        yfft(i) = 0.D0
20    CONTINUE

C** find the FFT of the time series [Eqn(3)]
      CALL CFFTI(npad,wsave)
      CALL CFFTF(npad,yfft,wsave)
      DO 30 k=1,npad
        yfft(k) = yfft(k)/npad
30    CONTINUE

C** construct the wavenumber array [Eqn(5)]
      freq1 = 2.D0*pi/(DBLE(npad)*dt)
      kwave(1) = 0.D0
      DO 40 i=2,npad/2+1
        kwave(i) = (DBLE(i)-1.D0)*freq1
40    CONTINUE
      DO 50 i=npad/2+2,npad
        kwave(i) = -kwave(npad-i+2)
50    CONTINUE

c**----- Main wavelet loop
c      PRINT '(A8,2A12,/,5X,27("-"))','j','scale','period'
      DO 100 j=1,jtot
        scale(j) = s0*(2.D0**(DBLE(j-1)*dj))
        CALL WAVE_FUNCTION(npad,dt,mother,param,scale(j),
     &            kwave,period1,coi1,daughter)
        period(j) = period1
C**    multiply the daughter by the time-series FFT
        DO 60 k=1,npad
          daughter(k) = daughter(k)*yfft(k)
60      CONTINUE
C**    inverse FFT [Eqn(4)]
        CALL CFFTB(npad,daughter,wsave)
C**    store the wavelet transform, discard zero-padding at end
        DO 70 i=1,n
          wave(i,j) = daughter(i)
70      CONTINUE
c        PRINT '(I8,2F12.3)',j,scale(j),period(j)
100   CONTINUE
c**----- end loop

C** construct the cone of influence
      DO 110 i=1,(n+1)/2
        coi(i) = coi1*dt*(DBLE(i)-1.D0)
        coi(n-i+1) = coi(i)
110   CONTINUE

      RETURN
      END

C****************************************************************************
C WAVE_FUNCTION: computes the daughter wavelets for a particular
C              wavelet function, with appropriate parameters.
C
C
C INPUTS:
C
C  nk [INT] = the number of points in "kwave"
C
C  dt [DOUBLE PRECISION] = amount of time between each Y value, i.e. the sampling time.
C
C  mother [INT] = An integer giving the mother wavelet to use.
C                   0='Morlet'
C                   1='Paul'
C                   2='DOG' (derivative of Gaussian)
C
C  param [DOUBLE PRECISION] = mother wavelet parameter. If <0 then default is used.
C            For 'Morlet' this is k0 (wavenumber), default is 6.
C            For 'Paul' this is m (order), default is 4.
C            For 'DOG' this is m (m-th derivative), default is 2.
C
C  scale1 [DOUBLE PRECISION] = the wavelet scale used to construct the daughter.
C
C  kwave [DOUBLE PRECISION(n)] = vector of wavenumbers, used to construct daughter.
C
C
C OUTPUTS:
C
C  period1 [DOUBLE PRECISION] = the "Fourier" period (in time units) that corresponds
C            to "scale1".
C
C  coi1 [DOUBLE PRECISION] = the e-folding factor used for the cone of influence.
C
C  daughter [DCMPLX(nk)] = real & imaginary parts of the wavelet function
C                    at "scale1" and "kwave".
C
C
C REQUIRES:   FACTORIAL, CHISQR
C
C
C Reference: Tables 1 & 2 in
C            Torrence, C. and G. P. Compo, 1998: A Practical Guide to
C            Wavelet Analysis. Bull. Amer. Meteor. Soc., 79, 61-78.
C
C  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C whatsoever.

      SUBROUTINE WAVE_FUNCTION (nk,dt,mother,param,scale1,
     &                  kwave,period1,coi1,daughter)
      IMPLICIT none

      INTEGER nk,mother
      DOUBLE PRECISION dt,kwave(nk),param,scale1,period1,coi1
      DOUBLE COMPLEX daughter(nk),norm

      DOUBLE PRECISION expnt,sk,pi,fourier_factor
      INTEGER k,m,factorial
      DOUBLE PRECISION gamma

      pi = 4.D0*ATAN(1.D0)

      IF (mother.EQ.0) THEN
C*******************************************   Morlet wavelet
        IF (param.LT.0) param = 6.D0
        norm = SQRT(2.D0*pi*scale1/dt)*(pi**(-0.25D0))
        DO 10 k=1,nk/2+1
          expnt = -0.5D0*(scale1*kwave(k) - param)**2
          daughter(k) = DCMPLX(norm*EXP(expnt))
10      CONTINUE
         DO 20 k=nk/2+2,nk
          daughter(k) = DCMPLX(0.D0)
20      CONTINUE
        fourier_factor = (4.D0*pi)/(param + SQRT(2.D0+param**2))
        period1 = scale1*fourier_factor
        coi1 = fourier_factor/SQRT(2.D0)
      ELSE IF (mother.EQ.1) THEN
C*******************************************   Paul wavelet
        IF (param.LT.0) param = 4.D0
        m = INT(param)
        norm = SQRT(2.D0*pi*scale1/dt)*
     &         (2.D0**m/SQRT(DBLE(m*FACTORIAL(2*m-1))))
        DO 30 k=1,nk/2+1
          expnt = -scale1*kwave(k)
          daughter(k) = DCMPLX(norm*(scale1*kwave(k))**m*EXP(expnt))
30      CONTINUE
         DO 40 k=nk/2+2,nk
          daughter(k) = DCMPLX(0.D0)
40      CONTINUE
        fourier_factor = (4.D0*pi)/(2.D0*m + 1.D0)
        period1 = scale1*fourier_factor
        coi1 = fourier_factor*SQRT(2.D0)
      ELSE IF (mother.EQ.2) THEN
C*******************************************   DOG wavelet
        IF (param.LT.0) param = 2.D0
        m = INT(param)
        norm = SQRT(2.D0*pi*scale1/dt)*SQRT(1.D0/GAMMA(m+0.5D0))
        norm = -norm*(DCMPLX(0.D0,1.D0)**m)
        DO 50 k=1,nk
          sk = scale1*kwave(k)
          daughter(k) = norm*(sk**m)*EXP(-0.5D0*sk**2)
50      CONTINUE
        fourier_factor = 2.D0*pi*SQRT(2.D0/(2.D0*m+1.D0))
        period1 = scale1*fourier_factor
        coi1 = fourier_factor/SQRT(2.D0)
      ELSE
        stop
      END IF
      RETURN
      END

C****************************************************************************
C FACTORIAL: compute the factorial (n!) of an integer n
C  Copyright (C) 1998, Christopher Torrence
      FUNCTION FACTORIAL(n)
      IMPLICIT NONE
      INTEGER factorial,n,i

      factorial = 1
      DO 10 i=1,n
        factorial = factorial*i
10    CONTINUE
      END

C****************************************************************************
C WAVE_SIGNIF: computes the significance levels for a wavelet transform.
C
C
C INPUTS:
C
C  isigtest [INT] = 0, 1, or 2.
C
C          If 0, then just do a regular chi-square test,
C              i.e. Eqn (18) from Torrence & Compo.
C          If 1, then do a "time-average" test, i.e. Eqn (23).
C              In this case, DOF(j) should be set to NA, the number
C              of local wavelet spectra that were averaged together
C              at each scale. For the Global Wavelet Spectrum,
C              this would be dof(j)=N-scale(j),
C              where N is the number of points in your time series.
C          If 2, then do a "scale-average" test, i.e. Eqns (25)-(28).
C              In this case, "dof(1)" and "dof(2)" should be set to the
C              smallest (S1) and largest (S2) scales that were averaged
C              together, respectively.
C              e.g. if you scale-averaged scales between 2 and 8,
C                   then dof(1)=2.0 and dof(2)=8.0
C
C
C  n [INT] = the number of points in "y".
C
C  y [DOUBLE PRECISION] = the time series of length "n".
C
C  dt [DOUBLE PRECISION] = amount of time between each Y value, i.e. the sampling time.
C
C  mother [INT] = An integer giving the mother wavelet to use.
C                   0='Morlet'
C                   1='Paul'
C                   2='DOG' (derivative of Gaussian)
C
C  param [DOUBLE PRECISION] = mother wavelet parameter.
C
C  s0 [DOUBLE PRECISION] = the smallest scale of the wavelet.
C
C  dj [DOUBLE PRECISION] = the spacing between discrete scales.
C
C  jtot [INT] = the # of scales.
C
C  scale [DOUBLE PRECISION(jtot)] = the wavelet scales that were used.
C
C  period [DOUBLE PRECISION(jtot)] = the "Fourier" periods corresponding to "scale".
C
C  lag1 [DOUBLE PRECISION] = lag 1 Autocorrelation, used for signif levels.
C              Default is 0.0, which corresponds to white-noise.
C
C  siglvl [DOUBLE PRECISION] = significance level to use. Default is 0.05 (the "5%" level)
C
C  dof [DOUBLE PRECISION(jtot)] = degrees-of-freedom for signif test.
C     IF SIGTEST=0, then the input dof is ignored.
C     IF SIGTEST=1, then dof(j) = NA, the number of times averaged together.
C     IF SIGTEST=2, then dof(1)=S1, dof(2)=S2, the range of scales averaged.
C
C
C OUTPUTS:
C
C  dof [DOUBLE PRECISION(jtot)] = degrees-of-freedom that were actually used.
C     IF SIGTEST=0, then dof(j) = 2 (or 1 for the 'DOG')
C     IF SIGTEST=1, then dof(j) = degrees-of-freedom versus scale.
C     IF SIGTEST=2, then dof(1)=degrees-of-freedom, dof(2...jtot)=0.0
C
C  fft_theor [DOUBLE PRECISION(jtot)] = theoretical red-noise spectrum vs scale.
C     IF SIGTEST=2, then fft_theor(1) = the average spectrum from S1-->S2
C                   fft_theor(2...jtot) = 0.0
C
C  signif [DOUBLE PRECISION(jtot)] = significance levels vs scale.
C     IF SIGTEST=2, then signif(1) = the significance level
C                   signif(2...jtot) = 0.0
C
C  ymean [DOUBLE PRECISION] = the mean of the time series.
C
C  variance [DOUBLE PRECISION] = the variance of the time series.
C
C  Cdelta [DOUBLE PRECISION] = the constant "Cdelta" for the mother wavelet (Table 2).
C
C  psi0[DOUBLE PRECISION] = the constant 'psi(0)' for the mother wavelet (Table 2)
C
C REQUIRES:   CHISQR
C
C  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
C This software may be used, copied, or redistributed as long as it is not
C sold and this copyright notice is reproduced on each copy made.  This
C routine is provided as is without any express or implied warranties
C 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
      DOUBLE PRECISION y(n),dt,param,dj,scale(jtot),period(jtot)
      DOUBLE PRECISION lag1,siglvl,dof(jtot),fft_theor(jtot),
     &  signif(jtot)
      DOUBLE PRECISION ymean,variance,Cdelta,psi0

      INTEGER i,j,m,status,javg1,javg2,navg
      DOUBLE PRECISION pi,freq1,dofmin,gammafac,dj0,Savg,Smid
      DOUBLE PRECISION fft_theor1
      DOUBLE PRECISION chisqr,p,q,bound

      pi = 4.D0*ATAN(1.D0)

      IF (siglvl.LE.0.) siglvl = 0.05D0
      IF (lag1.LE.0.D0) lag1 = 0.D0

      Cdelta = -1.D0
      gammafac = -1.D0
      dj0 = -1.D0
      psi0 = -1.D0

      IF (mother.EQ.0) THEN
C*******************************************   Morlet wavelet
        dofmin = 2.D0
        IF (param.EQ.6.D0) THEN
          Cdelta = 0.776D0
          gammafac = 2.32D0
          dj0 = 0.60D0
          psi0 = pi**(-0.25D0)
        END IF
      ELSE IF (mother.EQ.1) THEN
C*******************************************   Paul wavelet
        m = INT(param)
        dofmin = 2.D0
        IF (m.EQ.4) THEN
          Cdelta = 1.132D0
          gammafac = 1.17D0
          dj0 = 1.5D0
          psi0 = 1.079D0
        END IF
      ELSE IF (mother.EQ.2) THEN
C*******************************************   DOG wavelet
        m = INT(param)
        dofmin = 1.D0
        IF (m.EQ.2) THEN
          Cdelta = 3.541D0
          gammafac = 1.43D0
          dj0 = 1.4D0
          psi0 = 0.867D0
        ELSE IF (m.EQ.6) THEN
          Cdelta = 1.966D0
          gammafac = 1.37D0
          dj0 = 0.97D0
          psi0 = 0.884D0
        END IF
      ELSE
        stop
      END IF

C** find the time-series variance
      ymean = 0.D0
      DO 10 i=1,n
        ymean = ymean + y(i)
10    CONTINUE
      ymean = ymean/n
      variance = 0.D0
      DO 15 i=1,n
        variance = variance + (y(i) - ymean)**2
15    CONTINUE
      variance = variance/(DBLE(n)) ! - 1.D0)

C** construct theoretical red(white)-noise power spectrum [Eqn(16)]
      DO 20 j=1,jtot
        freq1 = dt/period(j)
        fft_theor(j) = variance*(1.D0-lag1**2)/
     &          (1.D0 - 2.D0*lag1*COS(freq1*2.D0*pi) + lag1**2)
20    CONTINUE

      q = DBLE(siglvl)
      p = 1d0 - q

      IF (isigtest.EQ.0) THEN
C*******************************************   no smoothing, dof=dofmin
C   see Eqn(18)
        DO 30 j=1,jtot
          dof(j) = dofmin
          CALL CDFCHI(2,p,q,chisqr,DBLE(dofmin),status,bound)
          signif(j) = fft_theor(j)*chisqr/dofmin
30      CONTINUE
      ELSE IF (isigtest.EQ.1) THEN
C***********************************   time-averaged, dof depend on scale
        IF (gammafac.LE.0.D0) THEN
        PRINT*,'**WAVE_SIGNIF: "gammafac" undefined for this wavelet'
          RETURN
        END IF
        DO 40 j=1,jtot
            IF (dof(j).LT.1.) dof(j) = 1.D0
C   see Eqn(23)
            dof(j) = dofmin*SQRT(1.D0+(dof(j)*dt/gammafac/scale(j))**2)
            IF (dof(j).LT.dofmin) dof(j) = dofmin
            CALL CDFCHI(2,p,q,chisqr,DBLE(dof(j)),status,bound)
            signif(j) = fft_theor(j)*chisqr/dof(j)
40      CONTINUE
       ELSE IF (isigtest.EQ.2) THEN
C***********************************   scale-averaged, dof depend on scale
        IF (Cdelta.LE.0.) THEN
          PRINT*,'**WAVE_SIGNIF: "Cdelta" and "dj0" '//
     &     'undefined for this wavelet'
          RETURN
        END IF
        javg1 = 0
        javg2 = 0
        DO 50 j=1,jtot
          IF ((scale(j).GE.dof(1)).AND.(javg1.EQ.0)) javg1 = j
          IF (scale(j).LE.dof(2)) javg2 = j
50      CONTINUE
        IF ((javg1.EQ.0).OR.(javg2.EQ.0).OR.(javg1.GT.javg2)) THEN
          PRINT*,'**WAVE_SIGNIF: Scales in "dof(1)" & "dof(2)" '//
     &     'are out of range.'
          RETURN
        END IF
        navg = javg2 - javg1 + 1
C   see Eqn(25)
        Savg = 0.D0
        DO 60 j=javg1,javg2
          Savg = Savg + 1.D0/scale(j)
60      CONTINUE
        Savg = 1.D0/Savg
C   see Eqn(27)
        fft_theor1 = 0.D0
        DO 70 j=javg1,javg2
          fft_theor1 = fft_theor1 + fft_theor(j)/scale(j)
70      CONTINUE
        fft_theor(1) = Savg*fft_theor1
C   see Eqn(28)
        Smid = EXP(0.5D0*(LOG(scale(javg1)) + LOG(scale(javg2))))
        dof(1) = (dofmin*navg*Savg/Smid)*SQRT(1 + (navg*dj/dj0)**2)
C   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 80 j=2,jtot
          dof(j) = 0.D0
          fft_theor(j) = 0.D0
          signif(j) = 0.D0
80      CONTINUE
      ELSE
        stop
      END IF

      END


program josephus
   implicit none
   integer :: n, i, k, p
   integer, allocatable :: next(:)
   read *, n, k
   allocate(next(0:n - 1))
   do i = 0, n - 2
      next(i) = i + 1
   end do
   next(n - 1) = 0
   p = 0
   do while(next(p) /= p)
      do i = 1, k - 2
         p = next(p)
      end do
      print *, "Kill", next(p)
      next(p) = next(next(p))
      p = next(p)
   end do
   print *, "Alive", p
   deallocate(next)
end program


program test3
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
 use modsparse
 implicit none
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 real(kind=wp)::val
 logical::lup=.false.
 type(coosparse)::coo
 type(crssparse)::crs,subcrs

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !COO  FULL
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(nrow,nel=4_int64,lupper=.false.)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR FULL
 crs=coo
 call crs%printstats
 call crs%print(lint=.true.)

 print*,'FULL => FULL xxxxxxxxxxxxxxxxxxxxxxxxxx'
 call crs%printsquare()
 print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 3 4'
 subcrs=crs%submatrix(1,2,3,4)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 3 4 1 2'
 subcrs=crs%submatrix(3,4,1,2)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 1 3'
 subcrs=crs%submatrix(1,2,1,3)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,''
 print*,'FULL => UPPER xxxxxxxxxxxxxxxxxxxxxxxxxx'
 call crs%printsquare()
 print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 3 4'
 subcrs=crs%submatrix(1,2,3,4,.true.)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT LOWER BLOCK a xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 3 4 1 2'
 subcrs=crs%submatrix(3,4,1,2,.true.)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 1 3'
 subcrs=crs%submatrix(1,2,1,3,.true.)
 call subcrs%printstats()
 call subcrs%printsquare()

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !COO UPPER
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(nrow,nel=4_int64,lupper=.true.)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR UPPER
 crs=coo
 call crs%printstats()
 call crs%print(lint=.true.)

 print*,'UPPER => FULL xxxxxxxxxxxxxxxxxxxxxxxxxx'
 call crs%printsquare()
 print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 3 4'
 subcrs=crs%submatrix(1,2,3,4)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 3 4 1 2'
 subcrs=crs%submatrix(3,4,1,2)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 1 3'
 subcrs=crs%submatrix(1,2,1,3)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,''
 print*,'UPPER => UPPER xxxxxxxxxxxxxxxxxxxxxxxxxx'
 call crs%printsquare()
 print*,'SELECT UPPER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 3 4'
 subcrs=crs%submatrix(1,2,3,4,.true.)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT LOWER BLOCK xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 3 4 1 2'
 subcrs=crs%submatrix(3,4,1,2,.true.)
 call subcrs%printstats()
 call subcrs%printsquare()

 print*,'SELECT BLOCK + DIAG xxxxxxxxxxxxxxxxxxxxxxxxxx'
 print*,'aaaa 1 2 1 3'
 subcrs=crs%submatrix(1,2,1,3,.true.)
 call subcrs%printstats()
 call subcrs%printsquare()

end program


subroutine calc_core_formation(j,t)

  !************************************************
  ! Computes collapse of grain cluster into a core
  !************************************************

  use embryodata
  use eosdata, only: pi
  implicit none

  integer, intent(in) :: j
  real, intent(in) :: t

  real :: l_jeans

  ! Compute jeans length of grain cluster

  l_jeans = embryo(j)%R*embryo(j)%fg**0.5

  IF(embryo(j)%rg < l_jeans .or. embryo(j)%rg < 0.0) THEN

     print*, "Embryo ", j,"forms a core ",embryo(j)%idiss
     embryo(j)%ijeans = 1

     ! Set up initial core parameters
     embryo(j)%mcore = embryo(j)%fg*embryo(j)%m
     embryo(j)%rcore = (3.0*embryo(j)%mcore/(4.0*pi*rho_s))**0.333
     embryo(j)%rg = embryo(j)%rcore

     ! If testing for radiative feedback, do it here
     if(core_feedback=='y') call calc_core_radiativefeedback(j)

  ELSE

     ! If rg > Jeans length, no core is formed
     embryo(j)%mcore = 0.0
     embryo(j)%rcore = 0.0
  ENDIF

end subroutine calc_core_formation


      subroutine pl_nupd

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    This subroutine calculates plant nitrogen demand

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units          |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bio_n1(:)   |none           |1st shape parameter for plant N uptake equation
!!    bio_n2(:)   |none           |2nd shape parameter for plant N uptake equation
!!    ihru        |none           |HRU number
!!    pltnfr(1,:) |kg N/kg biomass|nitrogen uptake parameter #1: normal fraction
!!                                |of N in crop biomass at emergence
!!    pltnfr(3,:) |kg N/kg biomass|nitrogen uptake parameter #3: normal fraction
!!                                |of N in crop biomass at maturity
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    uno3d       |kg N/ha       |plant nitrogen deficiency for day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use plant_data_module
      use hru_module, only : un2, uno3d, ihru, ipl
      use plant_module
      use organic_mineral_mass_module

      implicit none

      integer :: icrop       !none      |land cover code
      integer :: j           !none      |hru number
      integer :: l           !none      |counter (soil layer)
      real :: uno3l          !kg N/ha   |plant nitrogen demand
      integer :: ir          !none      |flag to denote bottom of root zone reached
      integer :: idp         !          |
      real :: gx             !mm        |lowest depth in layer from which nitrogen may be removed

      j = ihru

      idp = pcom(j)%plcur(1)%idplt

      pcom(j)%plm(ipl)%n_fr = (pldb(idp)%pltnfr1 - pldb(idp)%pltnfr3) *  &
          (1. -pcom(j)%plcur(ipl)%phuacc / (pcom(j)%plcur(ipl)%phuacc +  &
          Exp(plcp(idp)%nup1 - plcp(idp)%nup2 *                          &
          pcom(j)%plcur(ipl)%phuacc))) + pldb(idp)%pltnfr3

      un2(ipl) = pcom(j)%plm(ipl)%n_fr * pl_mass(j)%ab_gr(ipl)%m
      if (un2(ipl) < pl_mass(j)%ab_gr(ipl)%n) un2(ipl) = pl_mass(j)%ab_gr(ipl)%n
      uno3d(ipl) = un2(ipl) - pl_mass(j)%ab_gr(ipl)%n

      return
      end subroutine pl_nupd


      SUBROUTINE SB04OW( M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE,
     $                   F, LDF, SCALE, IWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve a periodic Sylvester equation
C
C              A * R - L * B = scale * C                           (1)
C              D * L - R * E = scale * F,
C
C     using Level 1 and 2 BLAS, where R and L are unknown M-by-N
C     matrices, (A, D), (B, E) and (C, F) are given matrix pairs of
C     size M-by-M, N-by-N and M-by-N, respectively, with real entries.
C     (A, D) and (B, E) must be in periodic Schur form, i.e. A, B are
C     upper quasi triangular and D, E are upper triangular. The solution
C     (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling
C     factor chosen to avoid overflow.
C
C     This routine is largely based on the LAPACK routine DTGSY2
C     developed by Bo Kagstrom and Peter Poromaa.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of A and D, and the row dimension of C, F, R
C             and L.  M >= 0.
C
C     N       (input) INTEGER
C             The order of B and E, and the column dimension of C, F, R
C             and L.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,M)
C             On entry, the leading M-by-M part of this array must
C             contain the upper quasi triangular matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,M).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper quasi triangular matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right-hand-side of the first matrix equation
C             in (1).
C             On exit, the leading M-by-N part of this array contains
C             the solution R.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,M).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading M-by-M part of this array must
C             contain the upper triangular matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1,M).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper triangular matrix E.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     F       (input/output) DOUBLE PRECISION array, dimension (LDF,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right-hand-side of the second matrix equation
C             in (1).
C             On exit, the leading M-by-N part of this array contains
C             the solution L.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1,M).
C
C     SCALE   (output) DOUBLE PRECISION
C             On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the arrays
C             C and F will hold the solutions R and L, respectively, to
C             a slightly perturbed system but the input matrices A, B, D
C             and E have not been changed. If SCALE = 0, C and F will
C             hold solutions to the homogeneous system with C = F = 0.
C             Normally, SCALE = 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M+N+2)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  the matrix products A*D and B*E have common or very
C                   close eigenvalues.
C
C     METHOD
C
C     In matrix notation solving equation (1) corresponds to solving
C     Z*x = scale*b, where Z is defined as
C
C         Z = [  kron(In, A)  -kron(B', Im) ]            (2)
C             [ -kron(E', Im)  kron(In, D)  ],
C
C     Ik is the identity matrix of size k and X' is the transpose of X.
C     kron(X, Y) is the Kronecker product between the matrices X and Y.
C     In the process of solving (1), we solve a number of such systems
C     where Dim(Im), Dim(In) = 1 or 2.
C
C     REFERENCES
C
C     [1] Kagstrom, B.
C         A Direct Method for Reordering Eigenvalues in the Generalized
C         Real Schur Form of a Regular Matrix Pair (A,B). M.S. Moonen
C         et al (eds.), Linear Algebra for Large Scale and Real-Time
C         Applications, Kluwer Academic Publ., pp. 195-218, 1993.
C
C     [2] Sreedhar, J. and Van Dooren, P.
C         A Schur approach for solving some periodic matrix equations.
C         U. Helmke et al (eds.), Systems and Networks: Mathematical
C         Theory and Applications, Akademie Verlag, Berlin, vol. 77,
C         pp. 339-362, 1994.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DTGPY2).
C
C     KEYWORDS
C
C     Matrix equation, periodic Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER           LDZ
      PARAMETER         ( LDZ = 8 )
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N
      DOUBLE PRECISION  SCALE
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  E(LDE,*), F(LDF,*)
C     .. Local Scalars ..
      INTEGER           I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
     $                  K, MB, NB, P, Q, ZDIM
      DOUBLE PRECISION  SCALOC
C     .. Local Arrays ..
      INTEGER           IPIV(LDZ), JPIV(LDZ)
      DOUBLE PRECISION  RHS(LDZ), Z(LDZ,LDZ)
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2,
     $                  DGETC2, DLASET, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO = 0
      IERR = 0
      IF ( M.LE.0 ) THEN
         INFO = -1
      ELSE IF ( N.LE.0 ) THEN
         INFO = -2
      ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF ( LDC.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF ( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF ( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -14
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB04OW', -INFO )
         RETURN
      END IF
C
C     Determine block structure of A.
C
      P = 0
      I = 1
   10 CONTINUE
      IF ( I.GT.M )
     $   GO TO 20
      P = P + 1
      IWORK(P) = I
      IF( I.EQ.M )
     $   GO TO 20
      IF ( A(I+1,I).NE.ZERO ) THEN
         I = I + 2
      ELSE
         I = I + 1
      END IF
      GO TO 10
   20 CONTINUE
      IWORK(P+1) = M + 1
C
C     Determine block structure of B.
C
      Q = P + 1
      J = 1
   30 CONTINUE
      IF ( J.GT.N )
     $   GO TO 40
      Q = Q + 1
      IWORK(Q) = J
      IF( J.EQ.N )
     $   GO TO 40
      IF ( B(J+1,J).NE.ZERO ) THEN
         J = J + 2
      ELSE
         J = J + 1
      END IF
      GO TO 30
   40 CONTINUE
      IWORK(Q+1) = N + 1
C
C     Solve (I, J) - subsystem
C       A(I,I) * R(I,J) - L(I,J) * B(J,J) = C(I,J)
C       D(I,I) * L(I,J) - R(I,J) * E(J,J) = F(I,J)
C     for I = P, P - 1, ..., 1; J = 1, 2, ..., Q.
C
      SCALE  = ONE
      SCALOC = ONE
      DO 120 J = P + 2, Q
         JS = IWORK(J)
         JSP1 = JS + 1
         JE = IWORK(J+1) - 1
         NB = JE - JS + 1
         DO 110 I = P, 1, -1
C
            IS = IWORK(I)
            ISP1 = IS + 1
            IE = IWORK(I+1) - 1
            MB = IE - IS + 1
            ZDIM = MB*NB*2
C
            IF ( ( MB.EQ.1 ).AND.( NB.EQ.1 ) ) THEN
C
C              Build a 2-by-2 system Z * x = RHS.
C
               Z(1,1) =  A(IS,IS)
               Z(2,1) = -E(JS,JS)
               Z(1,2) = -B(JS,JS)
               Z(2,2) =  D(IS,IS)
C
C              Set up right hand side(s).
C
               RHS(1) = C(IS,JS)
               RHS(2) = F(IS,JS)
C
C              Solve Z * x = RHS.
C
               CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
               IF ( IERR.GT.0 )
     $            INFO = IERR
C
               CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
               IF ( SCALOC.NE.ONE ) THEN
                  DO 50 K = 1, N
                     CALL DSCAL( M, SCALOC, C(1,K), 1 )
                     CALL DSCAL( M, SCALOC, F(1,K), 1 )
   50             CONTINUE
                  SCALE = SCALE*SCALOC
               END IF
C
C              Unpack solution vector(s).
C
               C(IS,JS) = RHS(1)
               F(IS,JS) = RHS(2)
C
C              Substitute R(I,J) and L(I,J) into remaining equation.
C
               IF ( I.GT.1 ) THEN
                  CALL DAXPY( IS-1, -RHS(1), A(1,IS), 1, C(1,JS), 1 )
                  CALL DAXPY( IS-1, -RHS(2), D(1,IS), 1, F(1,JS), 1 )
               END IF
               IF ( J.LT.Q ) THEN
                  CALL DAXPY( N-JE, RHS(2), B(JS,JE+1), LDB, C(IS,JE+1),
     $                        LDC )
                  CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1),
     $                        LDF )
               END IF
C
            ELSE IF ( ( MB.EQ.1 ).AND.( NB.EQ.2 ) ) THEN
C
C              Build a 4-by-4 system Z * x = RHS.
C
               Z(1,1) =  A(IS,IS)
               Z(2,1) =  ZERO
               Z(3,1) = -E(JS,JS)
               Z(4,1) = -E(JS,JSP1)
C
               Z(1,2) =  ZERO
               Z(2,2) =  A(IS,IS)
               Z(3,2) =  ZERO
               Z(4,2) = -E(JSP1,JSP1)
C
               Z(1,3) = -B(JS,JS)
               Z(2,3) = -B(JS,JSP1)
               Z(3,3) =  D(IS,IS)
               Z(4,3) =  ZERO
C
               Z(1,4) = -B(JSP1,JS)
               Z(2,4) = -B(JSP1,JSP1)
               Z(3,4) =  ZERO
               Z(4,4) =  D(IS,IS)
C
C              Set up right hand side(s).
C
               RHS(1) = C(IS,JS)
               RHS(2) = C(IS,JSP1)
               RHS(3) = F(IS,JS)
               RHS(4) = F(IS,JSP1)
C
C              Solve Z * x = RHS.
C
               CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
               IF ( IERR.GT.0 )
     $            INFO = IERR
C
               CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
               IF ( SCALOC.NE.ONE ) THEN
                  DO 60 K = 1, N
                     CALL DSCAL( M, SCALOC, C(1,K), 1 )
                     CALL DSCAL( M, SCALOC, F(1,K), 1 )
   60             CONTINUE
                  SCALE = SCALE*SCALOC
               END IF
C
C              Unpack solution vector(s).
C
               C(IS,JS)   = RHS(1)
               C(IS,JSP1) = RHS(2)
               F(IS,JS)   = RHS(3)
               F(IS,JSP1) = RHS(4)
C
C              Substitute R(I,J) and L(I,J) into remaining equation.
C
               IF ( I.GT.1 ) THEN
                  CALL DGER( IS-1, NB, -ONE, A(1,IS), 1, RHS(1), 1,
     $                       C(1,JS), LDC )
                  CALL DGER( IS-1, NB, -ONE, D(1,IS), 1, RHS(3), 1,
     $                       F(1,JS), LDF )
               END IF
               IF ( J.LT.Q ) THEN
                  CALL DAXPY( N-JE, RHS(3), B(JS,JE+1), LDB, C(IS,JE+1),
     $                        LDC )
                  CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1),
     $                        LDF )
                  CALL DAXPY( N-JE, RHS(4), B(JSP1,JE+1), LDB,
     $                        C(IS,JE+1), LDC )
                  CALL DAXPY( N-JE, RHS(2), E(JSP1,JE+1), LDE,
     $                        F(IS,JE+1), LDF )
               END IF
C
            ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
C
C              Build a 4-by-4 system Z * x = RHS.
C
               Z(1,1) =  A(IS,IS)
               Z(2,1) =  A(ISP1,IS)
               Z(3,1) = -E(JS,JS)
               Z(4,1) =  ZERO
C
               Z(1,2) =  A(IS,ISP1)
               Z(2,2) =  A(ISP1,ISP1)
               Z(3,2) =  ZERO
               Z(4,2) = -E(JS,JS)
C
               Z(1,3) = -B(JS,JS)
               Z(2,3) =  ZERO
               Z(3,3) =  D(IS,IS)
               Z(4,3) =  ZERO
C
               Z(1,4) =  ZERO
               Z(2,4) = -B(JS,JS)
               Z(3,4) =  D(IS,ISP1)
               Z(4,4) =  D(ISP1,ISP1)
C
C              Set up right hand side(s).
C
               RHS(1) = C(IS,JS)
               RHS(2) = C(ISP1,JS)
               RHS(3) = F(IS,JS)
               RHS(4) = F(ISP1,JS)
C
C              Solve Z * x = RHS.
C
               CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
               IF ( IERR.GT.0 )
     $            INFO = IERR
C
               CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
               IF ( SCALOC.NE.ONE ) THEN
                  DO 70 K = 1, N
                     CALL DSCAL( M, SCALOC, C(1,K), 1 )
                     CALL DSCAL( M, SCALOC, F(1,K), 1 )
   70             CONTINUE
                  SCALE = SCALE*SCALOC
               END IF
C
C              Unpack solution vector(s).
C
               C(IS,JS)   = RHS(1)
               C(ISP1,JS) = RHS(2)
               F(IS,JS)   = RHS(3)
               F(ISP1,JS) = RHS(4)
C
C              Substitute R(I,J) and L(I,J) into remaining equation.
C
               IF ( I.GT.1 ) THEN
                  CALL DGEMV( 'N', IS-1, MB, -ONE, A(1,IS), LDA, RHS(1),
     $                        1, ONE, C(1,JS), 1 )
                  CALL DGEMV( 'N', IS-1, MB, -ONE, D(1,IS), LDD, RHS(3),
     $                        1, ONE, F(1,JS), 1 )
               END IF
               IF ( J.LT.Q ) THEN
                  CALL DGER( MB, N-JE, ONE, RHS(3), 1, B(JS,JE+1), LDB,
     $                       C(IS,JE+1), LDC )
                  CALL DGER( MB, N-JE, ONE, RHS(1), 1, E(JS,JE+1), LDE,
     $                       F(IS,JE+1), LDF )
               END IF
C
            ELSE IF ( ( MB.EQ.2 ).AND.( NB.EQ.2 ) ) THEN
C
C              Build an 8-by-8 system Z * x = RHS.
C
               CALL DLASET( 'All', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
C
               Z(1,1) =  A(IS,IS)
               Z(2,1) =  A(ISP1,IS)
               Z(5,1) = -E(JS,JS)
               Z(7,1) = -E(JS,JSP1)
C
               Z(1,2) =  A(IS,ISP1)
               Z(2,2) =  A(ISP1,ISP1)
               Z(6,2) = -E(JS,JS)
               Z(8,2) = -E(JS,JSP1)
C
               Z(3,3) =  A(IS,IS)
               Z(4,3) =  A(ISP1,IS)
               Z(7,3) = -E(JSP1,JSP1)
C
               Z(3,4) =  A(IS,ISP1)
               Z(4,4) =  A(ISP1,ISP1)
               Z(8,4) = -E(JSP1,JSP1)
C
               Z(1,5) = -B(JS,JS)
               Z(3,5) = -B(JS,JSP1)
               Z(5,5) =  D(IS,IS)
C
               Z(2,6) = -B(JS,JS)
               Z(4,6) = -B(JS,JSP1)
               Z(5,6) =  D(IS,ISP1)
               Z(6,6) =  D(ISP1,ISP1)
C
               Z(1,7) = -B(JSP1,JS)
               Z(3,7) = -B(JSP1,JSP1)
               Z(7,7) =  D(IS,IS)
C
               Z(2,8) = -B(JSP1,JS)
               Z(4,8) = -B(JSP1,JSP1)
C
               Z(7,8) = D(IS,ISP1)
               Z(8,8) = D(ISP1,ISP1)
C
C              Set up right hand side(s).
C
               K  = 1
               II = MB*NB + 1
               DO 80 JJ = 0, NB - 1
                  CALL DCOPY( MB, C(IS,JS+JJ), 1, RHS(K),  1 )
                  CALL DCOPY( MB, F(IS,JS+JJ), 1, RHS(II), 1 )
                  K  = K  + MB
                  II = II + MB
   80          CONTINUE
C
C              Solve Z * x = RHS.
C
               CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
               IF ( IERR.GT.0 )
     $            INFO = IERR
C
               CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
               IF ( SCALOC.NE.ONE ) THEN
                  DO 90 K = 1, N
                     CALL DSCAL( M, SCALOC, C(1,K), 1 )
                     CALL DSCAL( M, SCALOC, F(1,K), 1 )
   90             CONTINUE
                  SCALE = SCALE*SCALOC
               END IF
C
C              Unpack solution vector(s).
C
               K  = 1
               II = MB*NB + 1
               DO 100 JJ = 0, NB - 1
                  CALL DCOPY( MB, RHS(K),  1, C(IS,JS+JJ), 1 )
                  CALL DCOPY( MB, RHS(II), 1, F(IS,JS+JJ), 1 )
                  K  = K  + MB
                  II = II + MB
  100          CONTINUE
C
C              Substitute R(I,J) and L(I,J) into remaining equation.
C
               K = MB*NB + 1
               IF ( I.GT.1 ) THEN
                  CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, A(1,IS),
     $                        LDA, RHS(1), MB, ONE, C(1,JS), LDC )
                  CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, D(1,IS),
     $                        LDD, RHS(K), MB, ONE, F(1,JS), LDF )
               END IF
               IF ( J.LT.Q ) THEN
                  CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(K), MB,
     $                        B(JS,JE+1), LDB, ONE, C(IS,JE+1), LDC )
                  CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(1), MB,
     $                        E(JS,JE+1), LDE, ONE, F(IS,JE+1), LDF )
               END IF
C
            END IF
C
  110    CONTINUE
  120 CONTINUE
      RETURN
C *** Last line of SB04OW ***
      END