MODULE singleton
  !-----------------------------------------------------------------------------
  ! Multivariate Fast Fourier Transform
  !
  ! Fortran 90 (ELF90) Implementation of Singleton's mixed-radix algorithm,
  ! RC Singleton, Stanford Research Institute, Sept. 1968.
  !
  ! Adapted from fftn.c, translated from Fortran 66 to C by Mark Olesen and
  ! John Beale.
  !
  ! Fourier transforms can be computed either in place, using assumed size
  ! arguments, or by generic function, using assumed shape arguments.
  !
  !
  ! Public:
  !
  !   fftkind                              kind parameter of complex arguments
  !                                        and function results.
  !
  !   fft(array, dim, inv)                 generic transform function
  !    COMPLEX(fftkind), DIMENSION(:,...,:), INTENT(IN)           :: array
  !    INTEGER,          DIMENSION(:),       INTENT(IN),  OPTIONAL:: dim
  !    LOGICAL,                              INTENT(IN),  OPTIONAL:: inv
  !
  !   fftn(array, shape, dim, inv, stat)   in place transform subroutine
  !    COMPLEX(fftkind), DIMENSION(*), INTENT(INOUT)        :: array
  !    INTEGER,          DIMENSION(:), INTENT(IN)           :: shape
  !    INTEGER,          DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
  !    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
  !    INTEGER,                        INTENT(OUT), OPTIONAL:: stat
  !
  !
  ! Formal Parameters:
  !
  !   array    The complex array to be transformed. array can be of arbitrary
  !            rank (i.e. up to seven).
  !
  !   shape    With subroutine fftn, the shape of the array to be transformed
  !            has to be passed separately, since fftradix - the internal trans-
  !            formation routine - will treat array always as one dimensional.
  !            The product of elements in shape must be the number of
  !            elements in array.
  !            Although passing array with assumed shape would have been nicer,
  !            I prefered assumed size in order to prevent the compiler from
  !            using a copy-in-copy-out mechanism. That would generally be
  !            necessary with fftn passing array to fftradix and with fftn
  !            being prepared for accepting non consecutive array sections.
  !            Using assumed size, it's up to the user to pass an array argu-
  !            ment, that can be addressed as continous one dimensional array
  !            without copying. Otherwise, transformation will not really be
  !            performed in place.
  !            On the other hand, since the rank of array and the size of
  !            shape needn't match, fftn is appropriate for handling more than
  !            seven dimensions.
  !            As far as function fft is concerned all this doesn't matter,
  !            because the argument will be copied anyway. Thus no extra
  !            shape argument is needed for fft.
  !
  ! Optional Parameters:
  !
  !   dim      One dimensional integer array, containing the dimensions to be
  !            transformed. Default is (/1,...,N/) with N being the rank of
  !            array, i.e. complete transform. dim can restrict transformation
  !            to a subset of available dimensions. Its size must not exceed the
  !            rank of array or the size of shape respectivly.
  !
  !   inv      If .true., inverse transformation will be performed. Default is
  !            .false., i.e. forward transformation.
  !
  !   stat     If present, a system dependent nonzero status value will be
  !            returned in stat, if allocation of temporary storage failed.
  !            For functions, the integer variable status is used.
  !
  ! Scaling:
  !
  !   Transformation results will always be scaled by the square root of the
  !   product of sizes of each dimension in dim. (See examples below)
  !
  !
  ! Examples:
  !
  !   Let A be a L*M*N three dimensional complex array. Then
  !
  !     result = fft(A)
  !
  !   will produce a three dimensional transform, scaled by sqrt(L*M*N), while
  !
  !     call fftn(A, SHAPE(A))
  !
  !   will do the same in place.
  !
  !     result = fft(A, dim=(/1,3/))
  !
  !   will transform with respect to the first and the third dimension, scaled
  !   by sqrt(L*N).
  !
  !     result = fft(fft(A), inv=.true.)
  !
  !   should (approximately) reproduce A.
  !   With B having the same shape as A
  !
  !     result = fft(fft(A) * CONJG(fft(B)), inv=.true.)
  !
  !   will correlate A and B.
  !
  !
  ! Remarks:
  !
  !   Following changes have been introduced with respect to fftn.c:
  !   - complex arguments and results are of type complex, rather than
  !     real an imaginary part separately.
  !   - increment parameter (magnitude of isign) has been dropped,
  !     inc is always one, direction of transform is given by inv.
  !   - maxf and maxp have been dropped. The amount of temporary storage
  !     needed is determined by the fftradix routine. Both fftn and fft
  !     can handle any size of array. (Maybe they take a lot of time and
  !     memory, but they will do it)
  !
  !   Redesigning fftradix in a way, that it handles assumed shape arrays
  !   would have been desirable. However, I found it rather hard to do this
  !   in an efficient way. Problems were:
  !   - to prevent stride multiplications when indexing arrays. At least our
  !     compiler was not clever enough to discover that in fact additions
  !     would do the job as well. On the other hand, I haven't been clever
  !     enough to find an implementation using array operations.
  !   - fftradix is rather large and different versions would be necessaray
  !     for each possible rank of array.
  !   Consequently, in place transformation still needs the argument stored
  !   in a consecutive bunch of memory and can't be performed on array
  !   sections like A(100:199:-3, 50:1020). Calling fftn with such sections
  !   will most probably imply copy-in-copy-out. However, the function fft
  !   works with everything it gets and should be convenient to use.
  !
  !   To enable this module to be used with ELF90 it appears to be necessary
  !   to allocate a 1-D work array into which the multi-dimensional array is
  !   copied, and then to copy the results back from the 1-D array to the
  !   multi-dimensional array ft.
  !
  !   Unfortunately, ELF90 will not allow a function to return more than one
  !   output variable.   The variable `stat' has been dropped from the function
  !   arguments.   Users should examine the value of the variable `status'
  !   instead.   This is a PUBLIC variable declared in this module.
  !
  ! Michael Steffens, 09.12.96, <Michael.Steffens@mbox.muk.uni-hannover.de>
  ! ELF90-compatible version by Alan Miller, 29 April 1997 & 6 June 1997
  ! amiller @ bigpond.net.au
  ! Restructured fftradix for better optimization by M. Steffens, 4 June 1997
  !-----------------------------------------------------------------------------
  IMPLICIT NONE

  PRIVATE
  PUBLIC:: fft, fftn, fftkind, status

  INTEGER, PARAMETER:: fftkind = KIND(0.0) !--- adjust here for other precisions
  INTEGER, SAVE     :: status = 0 !--- shifted to here as ELF90 does not allow
                                  !    arguments to be INTENT(OUT)

  REAL(fftkind), PARAMETER:: sin60 = 0.86602540378443865_fftkind
  REAL(fftkind), PARAMETER:: cos72 = 0.30901699437494742_fftkind
  REAL(fftkind), PARAMETER:: sin72 = 0.95105651629515357_fftkind
  REAL(fftkind), PARAMETER:: pi    = 3.14159265358979323_fftkind

  INTERFACE fft
     MODULE PROCEDURE fft1d
     MODULE PROCEDURE fft2d
     MODULE PROCEDURE fft3d
     MODULE PROCEDURE fft4d
     MODULE PROCEDURE fft5d
     MODULE PROCEDURE fft6d
     MODULE PROCEDURE fft7d
  END INTERFACE

CONTAINS

  FUNCTION fft1d(array, dim, inv) RESULT(ft)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:), INTENT(IN)           :: array
    INTEGER,          DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
    !--- function result
    COMPLEX(fftkind), DIMENSION(SIZE(array, 1)):: ft

    ft = array
    CALL fftn(ft, SHAPE(array), dim, inv = inv, stat = status)

    RETURN
  END FUNCTION fft1d

  FUNCTION fft2d(array, dim, inv) RESULT(ft)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:,:), INTENT(IN)           :: array
    INTEGER,          DIMENSION(:),   INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                          INTENT(IN),  OPTIONAL:: inv
    !--- function result
    COMPLEX(fftkind), DIMENSION(SIZE(array, 1), SIZE(array, 2)):: ft

    !--- Allocate 1-D array to be used by routine fftn
    COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE :: work

    ALLOCATE( work(SIZE(array)) )
    work = RESHAPE(array, (/ SIZE(array) /))
    CALL fftn(work, SHAPE(array), dim, inv, stat = status)
    ft = RESHAPE(work, (/ SIZE(array, 1), SIZE(array, 2) /))
    DEALLOCATE( work )

    RETURN
  END FUNCTION fft2d

  FUNCTION fft3d(array, dim, inv) RESULT(ft)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:,:,:), INTENT(IN)           :: array
    INTEGER,          DIMENSION(:),     INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                            INTENT(IN),  OPTIONAL:: inv
    !--- function result
    COMPLEX(fftkind), &
         DIMENSION(SIZE(array, 1), SIZE(array, 2), SIZE(array, 3)):: ft

    !--- Allocate 1-D array to be used by routine fftn
    COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE :: work

    ALLOCATE( work(SIZE(array)) )
    work = RESHAPE(array, (/ SIZE(array) /))
    CALL fftn(work, SHAPE(array), dim, inv, stat = status)
    ft = RESHAPE(work, (/ SIZE(array, 1), SIZE(array, 2), SIZE(array, 3) /))
    DEALLOCATE( work )

    RETURN
  END FUNCTION fft3d

  FUNCTION fft4d(array, dim, inv) RESULT(ft)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:,:,:,:), INTENT(IN)           :: array
    INTEGER,          DIMENSION(:),       INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                              INTENT(IN),  OPTIONAL:: inv
    !--- function result
    COMPLEX(fftkind), DIMENSION( &
         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4)):: ft

    !--- Allocate 1-D array to be used by routine fftn
    COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE :: work

    ALLOCATE( work(SIZE(array)) )
    work = RESHAPE(array, (/ SIZE(array) /))
    CALL fftn(work, SHAPE(array), dim, inv, stat = status)
    ft = RESHAPE(work, (/ SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), &
                          SIZE(array, 4) /))
    DEALLOCATE( work )

    RETURN
  END FUNCTION fft4d

  FUNCTION fft5d(array, dim, inv) RESULT(ft)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:,:,:,:,:), INTENT(IN)           :: array
    INTEGER,          DIMENSION(:),         INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                                INTENT(IN),  OPTIONAL:: inv
    !--- function result
    COMPLEX(fftkind), DIMENSION( &
         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
         SIZE(array, 5)):: ft

    !--- Allocate 1-D array to be used by routine fftn
    COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE :: work

    ALLOCATE( work(SIZE(array)) )
    work = RESHAPE(array, (/ SIZE(array) /))
    CALL fftn(work, SHAPE(array), dim, inv, stat = status)
    ft = RESHAPE(work, (/ SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), &
                          SIZE(array, 4), SIZE(array, 5) /))
    DEALLOCATE( work )

    RETURN
  END FUNCTION fft5d

  FUNCTION fft6d(array, dim, inv) RESULT(ft)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:,:,:,:,:,:), INTENT(IN)           :: array
    INTEGER,          DIMENSION(:),           INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                                  INTENT(IN),  OPTIONAL:: inv
    !--- function result
    COMPLEX(fftkind), DIMENSION( &
         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
         SIZE(array, 5), SIZE(array, 6)):: ft

    !--- Allocate 1-D array to be used by routine fftn
    COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE :: work

    ALLOCATE( work(SIZE(array)) )
    work = RESHAPE(array, (/ SIZE(array) /))
    CALL fftn(work, SHAPE(array), dim, inv, stat = status)
    ft = RESHAPE(work, (/ SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), &
                          SIZE(array, 4), SIZE(array, 5), SIZE(array, 6) /))
    DEALLOCATE( work )

    RETURN
  END FUNCTION fft6d

  FUNCTION fft7d(array, dim, inv) RESULT(ft)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:,:,:,:,:,:,:), INTENT(IN)           :: array
    INTEGER,          DIMENSION(:),             INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                                    INTENT(IN),  OPTIONAL:: inv
    !--- function result
    COMPLEX(fftkind), DIMENSION( &
         SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), SIZE(array, 4), &
         SIZE(array, 5), SIZE(array, 6), SIZE(array, 7)):: ft

    !--- Allocate 1-D array to be used by routine fftn
    COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE :: work

    ALLOCATE( work(SIZE(array)) )
    work = RESHAPE(array, (/ SIZE(array) /))
    CALL fftn(work, SHAPE(array), dim, inv, stat = status)
    ft = RESHAPE(work, (/ SIZE(array, 1), SIZE(array, 2), SIZE(array, 3), &
                          SIZE(array, 4), SIZE(array, 5), SIZE(array, 6), &
                          SIZE(array, 7) /))
    DEALLOCATE( work )

    RETURN
  END FUNCTION fft7d

  SUBROUTINE fftn(array, shape, dim, inv, stat)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:), INTENT(IN OUT)       :: array
    INTEGER,          DIMENSION(:), INTENT(IN)           :: shape
    INTEGER,          DIMENSION(:), INTENT(IN),  OPTIONAL:: dim
    LOGICAL,                        INTENT(IN),  OPTIONAL:: inv
    INTEGER,                        INTENT(OUT), OPTIONAL:: stat
    !--- local arrays
    INTEGER, DIMENSION(SIZE(shape)):: d
    !--- local scalars
    LOGICAL      :: inverse
    INTEGER      :: i, ndim, ntotal
    REAL(fftkind):: scale

    !--- optional parameter settings
    IF (PRESENT(inv)) THEN
       inverse = inv
    ELSE
       inverse = .FALSE.
    END IF
    IF (PRESENT(dim)) THEN
       ndim = MIN(SIZE(dim), SIZE(d))
       d(1:ndim) = dim(1:ndim)
    ELSE
       ndim = SIZE(d)
       d = (/(i, i = 1, SIZE(d))/)
    END IF

    ntotal = PRODUCT(shape)
    scale = SQRT(1.0_fftkind / PRODUCT(shape(d(1:ndim))))
    DO i = 1, ntotal
       array(i) = CMPLX(REAL(array(i)) * scale, AIMAG(array(i)) * scale, &
            KIND=fftkind)
    END DO

    DO i = 1, ndim
       CALL fftradix(array, ntotal, shape(d(i)), PRODUCT(shape(1:d(i))), &
            inverse)
    END DO

    IF (PRESENT(stat)) stat = status
    RETURN
  END SUBROUTINE fftn

  SUBROUTINE fftradix(array, ntotal, npass, nspan, inv)
    !--- formal parameters
    COMPLEX(fftkind), DIMENSION(:), INTENT(IN OUT)       :: array
    INTEGER,                        INTENT(IN)           :: ntotal, npass, nspan
    LOGICAL,                        INTENT(IN)           :: inv
    !--- local arrays
    INTEGER,          DIMENSION(BIT_SIZE(0))     :: factor
    !--- local scalars
    INTEGER         :: maxfactor, nfactor, nsquare
    !--- intrinsics used

    IF (npass <= 1) RETURN

    CALL factorize(npass, factor, nfactor, nsquare)

    maxfactor = MAXVAL(factor(:nfactor))

    CALL transform(array, ntotal, npass, nspan, factor, nfactor, inv)
    CALL permute(array, ntotal, npass, nspan, &
            factor, nfactor, nsquare, maxfactor)

    RETURN

  CONTAINS

    SUBROUTINE factorize(npass, factor, nfactor, nsquare)
      !--- formal parameters
      INTEGER,               INTENT(IN) :: npass
      INTEGER, DIMENSION(:), INTENT(OUT):: factor
      INTEGER,               INTENT(OUT):: nfactor, nsquare
      !--- local scalars
      INTEGER:: j, jj, k

      nfactor = 0
      k = npass
      DO WHILE (MOD(k, 16) == 0)
         nfactor = nfactor + 1
         factor(nfactor) = 4
         k = k / 16
      END DO
      j = 3
      jj = 9
      DO
         DO WHILE (MOD(k, jj) == 0)
            nfactor = nfactor + 1
            factor(nfactor) = j
            k = k / jj
         END DO
         j = j + 2
         jj = j * j
         IF (jj > k) EXIT
      END DO
      IF (k <= 4) THEN
         nsquare = nfactor
         factor(nfactor + 1) = k
         IF (k /= 1) nfactor = nfactor + 1
      ELSE
         IF (k - ISHFT(k / 4, 2) == 0) THEN
            nfactor = nfactor + 1
            factor(nfactor) = 2
            k = k / 4
         END IF
         nsquare = nfactor
         j = 2
         DO
            IF (MOD(k, j) == 0) THEN
               nfactor = nfactor + 1
               factor(nfactor) = j
               k = k / j
            END IF
            j = ISHFT((j + 1) / 2, 1) + 1
            IF (j > k) EXIT
         END DO
      END IF
      IF (nsquare > 0) THEN
         j = nsquare
         DO
            nfactor = nfactor + 1
            factor(nfactor) = factor(j)
            j = j - 1
            IF (j==0) EXIT
         END DO
      END IF

      RETURN
    END SUBROUTINE factorize

    SUBROUTINE transform(array, ntotal, npass, nspan, &
         factor, nfactor, inv) !-- compute fourier transform
      !--- formal parameters
      COMPLEX(fftkind), DIMENSION(:), INTENT(IN OUT):: array
      INTEGER,                        INTENT(IN)    :: ntotal, npass, nspan
      INTEGER,          DIMENSION(:), INTENT(IN)    :: factor
      INTEGER,                        INTENT(IN)    :: nfactor
      LOGICAL,                        INTENT(IN)    :: inv
      !--- local scalars
      INTEGER         :: ii, ispan
      INTEGER         :: j, jc, jf, jj
      INTEGER         :: k, kk, kspan, k1, k2, k3, k4
      INTEGER         :: nn, nt
      REAL(fftkind)   :: s60, c72, s72, pi2, radf
      REAL(fftkind)   :: c1, s1, c2, s2, c3, s3, cd, sd, ak
      COMPLEX(fftkind):: cc, cj, ck, cjp, cjm, ckp, ckm
      !--- local arrays
      COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE  :: ctmp
      REAL(fftkind),    DIMENSION(:), ALLOCATABLE  :: sine, cosine

      maxfactor = MAXVAL(factor(:nfactor))
      ALLOCATE(ctmp(maxfactor), sine(maxfactor), cosine(maxfactor), STAT=status)
      IF (status /= 0) RETURN

      c72 = cos72
      IF (inv) THEN
         s72 = sin72
         s60 = sin60
         pi2 = pi
      ELSE
         s72 = -sin72
         s60 = -sin60
         pi2 = -pi
      END IF

      nt = ntotal
      nn = nt - 1
      kspan = nspan
      jc = nspan / npass
      radf = pi2 * jc
      pi2 = pi2 * 2.0_fftkind !-- use 2 PI from here on

      ii = 0
      jf = 0
      DO
         sd = radf / kspan
         cd = SIN(sd)
         cd = 2.0_fftkind * cd * cd
         sd = SIN(sd + sd)
         kk = 1
         ii = ii + 1

         SELECT CASE (factor(ii))
         CASE (2)
            !-- transform for factor of 2 (including rotation factor)
            kspan = kspan / 2
            k1 = kspan + 2
            DO
               DO
                  k2 = kk + kspan
                  ck = array(k2)
                  array(k2) = array(kk)-ck
                  array(kk) = array(kk) + ck
                  kk = k2 + kspan
                  IF (kk > nn) EXIT
               END DO
               kk = kk - nn
               IF (kk > jc) EXIT
            END DO
            IF (kk > kspan) THEN
               DEALLOCATE(ctmp, sine, cosine, STAT=status)
               RETURN
            END IF
            DO
               c1 = 1.0_fftkind - cd
               s1 = sd
               DO
                  DO
                     DO
                        k2 = kk + kspan
                        ck = array(kk) - array(k2)
                        array(kk) = array(kk) + array(k2)
                        array(k2) = ck * CMPLX(c1, s1, KIND=fftkind)
                        kk = k2 + kspan
                        IF (kk >= nt) EXIT
                     END DO
                     k2 = kk - nt
                     c1 = -c1
                     kk = k1 - k2
                     IF (kk <= k2) EXIT
                  END DO
                  ak = c1 - (cd * c1 + sd * s1)
                  s1 = sd * c1 - cd * s1 + s1
                  c1 = 2.0_fftkind - (ak * ak + s1 * s1)
                  s1 = s1 * c1
                  c1 = c1 * ak
                  kk = kk + jc
                  IF (kk >= k2) EXIT
               END DO
               k1 = k1 + 1 + 1
               kk = (k1 - kspan) / 2 + jc
               IF (kk > jc + jc) EXIT
            END DO

         CASE (4) !-- transform for factor of 4
            ispan = kspan
            kspan = kspan / 4

            DO
               c1 = 1.0_fftkind
               s1 = 0.0_fftkind
               DO
                  DO
                     k1 = kk + kspan
                     k2 = k1 + kspan
                     k3 = k2 + kspan
                     ckp = array(kk) + array(k2)
                     ckm = array(kk) - array(k2)
                     cjp = array(k1) + array(k3)
                     cjm = array(k1) - array(k3)
                     array(kk) = ckp + cjp
                     cjp = ckp - cjp
                     IF (inv) THEN
                        ckp = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=fftkind)
                        ckm = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=fftkind)
                     ELSE
                        ckp = ckm + CMPLX(AIMAG(cjm), -REAL(cjm), KIND=fftkind)
                        ckm = ckm + CMPLX(-AIMAG(cjm), REAL(cjm), KIND=fftkind)
                     END IF
                     !-- avoid useless multiplies
                     IF (s1 == 0.0_fftkind) THEN
                        array(k1) = ckp
                        array(k2) = cjp
                        array(k3) = ckm
                     ELSE
                        array(k1) = ckp * CMPLX(c1, s1, KIND=fftkind)
                        array(k2) = cjp * CMPLX(c2, s2, KIND=fftkind)
                        array(k3) = ckm * CMPLX(c3, s3, KIND=fftkind)
                     END IF
                     kk = k3 + kspan
                     IF (kk > nt) EXIT
                  END DO

                  c2 = c1 - (cd * c1 + sd * s1)
                  s1 = sd * c1 - cd * s1 + s1
                  c1 = 2.0_fftkind - (c2 * c2 + s1 * s1)
                  s1 = s1 * c1
                  c1 = c1 * c2
                  !-- values of c2, c3, s2, s3 that will get used next time
                  c2 = c1 * c1 - s1 * s1
                  s2 = 2.0_fftkind * c1 * s1
                  c3 = c2 * c1 - s2 * s1
                  s3 = c2 * s1 + s2 * c1
                  kk = kk - nt + jc
                  IF (kk > kspan) EXIT
               END DO
               kk = kk - kspan + 1
               IF (kk > jc) EXIT
            END DO
            IF (kspan == jc) THEN
               DEALLOCATE(ctmp, sine, cosine, STAT=status)
               RETURN
            END IF

         CASE default
            !-- transform for odd factors
            k = factor(ii)
            ispan = kspan
            kspan = kspan / k

            SELECT CASE (k)
            CASE (3) !-- transform for factor of 3 (optional code)
               DO
                  DO
                     k1 = kk + kspan
                     k2 = k1 + kspan
                     ck = array(kk)
                     cj = array(k1) + array(k2)
                     array(kk) = ck + cj
                     ck = ck - CMPLX( &
                          0.5_fftkind * REAL (cj), &
                          0.5_fftkind * AIMAG(cj), &
                          KIND=fftkind)
                     cj = CMPLX( &
                          (REAL (array(k1)) - REAL (array(k2))) * s60, &
                          (AIMAG(array(k1)) - AIMAG(array(k2))) * s60, &
                          KIND=fftkind)
                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=fftkind)
                     array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=fftkind)
                     kk = k2 + kspan
                     IF (kk >= nn) EXIT
                  END DO
                  kk = kk - nn
                  IF (kk > kspan) EXIT
               END DO

            CASE (5) !-- transform for factor of 5 (optional code)
               c2 = c72 * c72 - s72 * s72
               s2 = 2.0_fftkind * c72 * s72
               DO
                  DO
                     k1 = kk + kspan
                     k2 = k1 + kspan
                     k3 = k2 + kspan
                     k4 = k3 + kspan
                     ckp = array(k1) + array(k4)
                     ckm = array(k1) - array(k4)
                     cjp = array(k2) + array(k3)
                     cjm = array(k2) - array(k3)
                     cc = array(kk)
                     array(kk) = cc + ckp + cjp
                     ck = CMPLX(REAL(ckp) * c72, AIMAG(ckp) * c72, &
                          KIND=fftkind) + &
                          CMPLX(REAL(cjp) * c2,  AIMAG(cjp) * c2,  &
                          KIND=fftkind) + cc
                     cj = CMPLX(REAL(ckm) * s72, AIMAG(ckm) * s72, &
                          KIND=fftkind) + &
                          CMPLX(REAL(cjm) * s2,  AIMAG(cjm) * s2,  &
                          KIND=fftkind)
                     array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=fftkind)
                     array(k4) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=fftkind)
                     ck = CMPLX(REAL(ckp) * c2,  AIMAG(ckp) * c2,  &
                          KIND=fftkind) + &
                          CMPLX(REAL(cjp) * c72, AIMAG(cjp) * c72, &
                          KIND=fftkind) + cc
                     cj = CMPLX(REAL(ckm) * s2,  AIMAG(ckm) * s2,  &
                          KIND=fftkind) - &
                          CMPLX(REAL(cjm) * s72, AIMAG(cjm) * s72, &
                          KIND=fftkind)
                     array(k2) = ck + CMPLX(-AIMAG(cj), REAL(cj), KIND=fftkind)
                     array(k3) = ck + CMPLX(AIMAG(cj), -REAL(cj), KIND=fftkind)
                     kk = k4 + kspan
                     IF (kk >= nn) EXIT
                  END DO
                  kk = kk - nn
                  IF (kk > kspan) EXIT
               END DO

            CASE default
               IF (k /= jf) THEN
                  jf = k
                  s1 = pi2 / k
                  c1 = COS(s1)
                  s1 = SIN(s1)
                  cosine (jf) = 1.0_fftkind
                  sine (jf) = 0.0_fftkind
                  j = 1
                  DO
                     cosine (j) = cosine (k) * c1 + sine (k) * s1
                     sine (j) = cosine (k) * s1 - sine (k) * c1
                     k = k-1
                     cosine (k) = cosine (j)
                     sine (k) = -sine (j)
                     j = j + 1
                     IF (j >= k) EXIT
                  END DO
               END IF
               DO
                  DO
                     k1 = kk
                     k2 = kk + ispan
                     cc = array(kk)
                     ck = cc
                     j = 1
                     k1 = k1 + kspan
                     DO
                        k2 = k2 - kspan
                        j = j + 1
                        ctmp(j) = array(k1) + array(k2)
                        ck = ck + ctmp(j)
                        j = j + 1
                        ctmp(j) = array(k1) - array(k2)
                        k1 = k1 + kspan
                        IF (k1 >= k2) EXIT
                     END DO
                     array(kk) = ck
                     k1 = kk
                     k2 = kk + ispan
                     j = 1
                     DO
                        k1 = k1 + kspan
                        k2 = k2 - kspan
                        jj = j
                        ck = cc
                        cj = (0.0_fftkind, 0.0_fftkind)
                        k = 1
                        DO
                           k = k + 1
                           ck = ck + CMPLX( &
                                REAL (ctmp(k)) * cosine(jj), &
                                AIMAG(ctmp(k)) * cosine(jj), KIND=fftkind)
                           k = k + 1
                           cj = cj + CMPLX( &
                                REAL (ctmp(k)) * sine(jj), &
                                AIMAG(ctmp(k)) * sine(jj), KIND=fftkind)
                           jj = jj + j
                           IF (jj > jf) jj = jj - jf
                           IF (k >= jf) EXIT
                        END DO
                        k = jf - j
                        array(k1) = ck + CMPLX(-AIMAG(cj), REAL(cj), &
                             KIND=fftkind)
                        array(k2) = ck + CMPLX(AIMAG(cj), -REAL(cj), &
                             KIND=fftkind)
                        j = j + 1
                        IF (j >= k) EXIT
                     END DO
                     kk = kk + ispan
                     IF (kk > nn) EXIT
                  END DO
                  kk = kk - nn
                  IF (kk > kspan) EXIT
               END DO

            END SELECT
            !--  multiply by rotation factor (except for factors of 2 and 4)
            IF (ii == nfactor) THEN
               DEALLOCATE(ctmp, sine, cosine, STAT=status)
               RETURN
            END IF

            kk = jc + 1
            DO
               c2 = 1.0_fftkind - cd
               s1 = sd
               DO
                  c1 = c2
                  s2 = s1
                  kk = kk + kspan
                  DO
                     DO
                        array(kk) = CMPLX(c2, s2, KIND=fftkind) * array(kk)
                        kk = kk + ispan
                        IF (kk > nt) EXIT
                     END DO
                     ak = s1 * s2
                     s2 = s1 * c2 + c1 * s2
                     c2 = c1 * c2 - ak
                     kk = kk - nt + kspan
                     IF (kk > ispan) EXIT
                  END DO
                  c2 = c1 - (cd * c1 + sd * s1)
                  s1 = s1 + sd * c1 - cd * s1
                  c1 = 2.0_fftkind - (c2 * c2 + s1 * s1)
                  s1 = s1 * c1
                  c2 = c2 * c1
                  kk = kk - ispan + jc
                  IF (kk > kspan) EXIT
               END DO
               kk = kk - kspan + jc + 1
               IF (kk > jc + jc) EXIT
            END DO

         END SELECT
      END DO

      DEALLOCATE(ctmp, sine, cosine, STAT=status)
      RETURN
    END SUBROUTINE transform

    SUBROUTINE permute(array, ntotal, npass, nspan, &
         factor, nfactor, nsquare, maxfactor)
      !--- formal parameters
      COMPLEX(fftkind), DIMENSION(:), INTENT(IN OUT):: array
      INTEGER,                        INTENT(IN)    :: ntotal, npass, nspan
      INTEGER,          DIMENSION(:), INTENT(IN OUT):: factor
      INTEGER,                        INTENT(IN)    :: nfactor, nsquare
      INTEGER,                        INTENT(IN)    :: maxfactor
      !--- local scalars
      INTEGER         :: ii, ispan
      INTEGER         :: j, jc, jj
      INTEGER         :: k, kk, kspan, kt, k1, k2, k3
      INTEGER         :: nn, nperm, nt
      COMPLEX(fftkind):: ck
      !--- local arrays
      COMPLEX(fftkind), DIMENSION(:), ALLOCATABLE  :: ctmp
      INTEGER         , DIMENSION(:), ALLOCATABLE  :: perm

      ALLOCATE(ctmp(maxfactor), STAT=status)
      IF (status /= 0) RETURN

      IF (nfactor - ISHFT(nsquare, 1) > 0) THEN
         nperm = MAX(nfactor + 1, PRODUCT(factor(nsquare+1: nfactor-nsquare)) - 1)
      ELSE
         nperm = nfactor + 1
      END IF
      ALLOCATE(perm(nperm), STAT=status)
      IF (status /= 0) RETURN

      !--  permute the results to normal order---done in two stages
      !--  permutation for square factors of n

      nt = ntotal
      nn = nt - 1
      kt = nsquare
      kspan = nspan
      jc = nspan / npass

      perm (1) = nspan
      IF (kt > 0) THEN
         k = kt + kt + 1
         IF (nfactor < k) k = k - 1
         j = 1
         perm (k + 1) = jc
         DO
            perm (j + 1) = perm (j) / factor(j)
            perm (k) = perm (k + 1) * factor(j)
            j = j + 1
            k = k - 1
            IF (j >= k) EXIT
         END DO
         k3 = perm (k + 1)
         kspan = perm (2)
         kk = jc + 1
         k2 = kspan + 1
         j = 1

         IF (npass /= ntotal) THEN
            permute_multi: DO
               DO
                  DO
                     k = kk + jc
                     DO
                        !-- swap array(kk) <> array(k2)
                        ck = array(kk)
                        array(kk) = array(k2)
                        array(k2) = ck
                        kk = kk + 1
                        k2 = k2 + 1
                        IF (kk >= k) EXIT
                     END DO
                     kk = kk + nspan - jc
                     k2 = k2 + nspan - jc
                     IF (kk >= nt) EXIT
                  END DO
                  kk = kk - nt + jc
                  k2 = k2 - nt + kspan
                  IF (k2 >= nspan) EXIT
               END DO
               DO
                  DO
                     k2 = k2 - perm (j)
                     j = j + 1
                     k2 = perm (j + 1) + k2
                     IF (k2 <= perm (j)) EXIT
                  END DO
                  j = 1
                  DO
                     IF (kk < k2) CYCLE permute_multi
                     kk = kk + jc
                     k2 = k2 + kspan
                     IF (k2 >= nspan) EXIT
                  END DO
                  IF (kk >= nspan) EXIT
               END DO
               EXIT
            END DO permute_multi
         ELSE
            permute_single: DO
               DO
                  !-- swap array(kk) <> array(k2)
                  ck = array(kk)
                  array(kk) = array(k2)
                  array(k2) = ck
                  kk = kk + 1
                  k2 = k2 + kspan
                  IF (k2 >= nspan) EXIT
               END DO
               DO
                  DO
                     k2 = k2 - perm (j)
                     j = j + 1
                     k2 = perm (j + 1) + k2
                     IF (k2 <= perm (j)) EXIT
                  END DO
                  j = 1
                  DO
                     IF (kk < k2) CYCLE permute_single
                     kk = kk + 1
                     k2 = k2 + kspan
                     IF (k2 >= nspan) EXIT
                  END DO
                  IF (kk >= nspan) EXIT
               END DO
               EXIT
            END DO permute_single
         END IF
         jc = k3
      END IF

      IF (ISHFT(kt, 1) + 1 >= nfactor) THEN
         DEALLOCATE(perm, ctmp)
         RETURN
      END IF

      ispan = perm (kt + 1)
      !-- permutation for square-free factors of n
      j = nfactor - kt
      factor(j + 1) = 1
      DO
         factor(j) = factor(j) * factor(j+1)
         j = j - 1
         IF (j == kt) EXIT
      END DO
      kt = kt + 1
      nn = factor(kt) - 1
      j = 0
      jj = 0
      DO
         k = kt + 1
         k2 = factor(kt)
         kk = factor(k)
         j = j + 1
         IF (j > nn) EXIT !-- exit infinite loop
         jj = jj + kk
         DO WHILE (jj >= k2)
            jj = jj - k2
            k2 = kk
            k = k + 1
            kk = factor(k)
            jj = jj + kk
         END DO
         perm (j) = jj
      END DO
      !--  determine the permutation cycles of length greater than 1
      j = 0
      DO
         DO
            j = j + 1
            kk = perm(j)
            IF (kk >= 0) EXIT
         END DO
         IF (kk /= j) THEN
            DO
               k = kk
               kk = perm (k)
               perm (k) = -kk
               IF (kk == j) EXIT
            END DO
            k3 = kk
         ELSE
            perm (j) = -j
            IF (j == nn) EXIT !-- exit infinite loop
         END IF
      END DO
      !--  reorder a and b, following the permutation cycles
      DO
         j = k3 + 1
         nt = nt - ispan
         ii = nt - 1 + 1
         IF (nt < 0) EXIT !-- exit infinite loop
         DO
            DO
               j = j-1
               IF (perm(j) >= 0) EXIT
            END DO
            jj = jc
            DO
               kspan = jj
               IF (jj > maxfactor) kspan = maxfactor
               jj = jj - kspan
               k = perm(j)
               kk = jc * k + ii + jj
               k1 = kk + kspan
               k2 = 0
               DO
                  k2 = k2 + 1
                  ctmp(k2) = array(k1)
                  k1 = k1 - 1
                  IF (k1 == kk) EXIT
               END DO
               DO
                  k1 = kk + kspan
                  k2 = k1 - jc * (k + perm(k))
                  k = -perm(k)
                  DO
                     array(k1) = array(k2)
                     k1 = k1 - 1
                     k2 = k2 - 1
                     IF (k1 == kk) EXIT
                  END DO
                  kk = k2
                  IF (k == j) EXIT
               END DO
               k1 = kk + kspan
               k2 = 0
               DO
                  k2 = k2 + 1
                  array(k1) = ctmp(k2)
                  k1 = k1 - 1
                  IF (k1 == kk) EXIT
               END DO
               IF (jj == 0) EXIT
            END DO
            IF (j == 1) EXIT
         END DO
      END DO

      DEALLOCATE(perm, ctmp)
      RETURN
    END SUBROUTINE permute

  END SUBROUTINE fftradix

END MODULE singleton


C++--------------------------------------------------------------------
C Program CIRC_PHOTOM
C To get the photometry of stars in circular apertures
C and visualize on the GRINNEL
C
C Warning the colors do not work since activating the overlays
C disable the cursor...
C
C JLP  Version of 06-11-87
C--------------------------------------------------------------------
	PROGRAM CIRC_PHOTOM
	PARAMETER (IDIM=600)
	REAL*8 SUM_STAR,SUMSQ_SKY,SUM_SKY
	REAL*4 INPUT1(IDIM,IDIM),OUTPUT(IDIM,IDIM)
	REAL*4 NSKY,NSTAR
	INTEGER*2 IXP,IYP,IENT,IF1,IF2
	LOGICAL INPUT_FILE
	CHARACTER NAMEIN1*40,NAMEOUT*40,STAR_NAME*14
	CHARACTER COMMENTS*80
	CHARACTER ANS*1,COLOR*1
	COMMON/IN/INPUT_FILE

10	FORMAT(A)

	PRINT *,' Program to compute the total intensity',
     1	' within circular apertures'
	PRINT *,' Version of 21-11-87'

C Initialization :
	CALL GRINNEL_INIT
	CALL JLP_INQUIFMT
	INPUT_FILE=.TRUE.

C Entering the image :
	PRINT *,' INPUT IMAGE DISPLAYED ON THE GRINNEL ?'
	READ(5,10) NAMEIN1
	CALL JLP_READIMAG(INPUT1,NX1,NY1,IDIM,NAMEIN1,COMMENTS)
	LIN1=INDEX(NAMEIN1,'  ')

	PRINT *,' EXPOSURE TIME IN SECONDS ? (THE RESULTS ARE DIVIDED',
     1	' BY THIS NUMBER)'
	READ(5,*) EXPOSURE

15	PRINT *,' OUTPUT FILE WITH THE RESULTS ?'
	READ(5,10) NAMEOUT
	OPEN(2,FILE=NAMEOUT,STATUS='NEW',ERR=15)
	WRITE(2,106)NAMEIN1,EXPOSURE
106	FORMAT(' INPUT IMAGE :',A,/,
     1	' EXPOSURE TIME :',G12.5,/)
	WRITE(2,107)
107	FORMAT(' NAME',T16,'INTENSITY/SEC',T30,
     1	' ERROR',T44,'XCENT',T50,'YCENT',T56,
     1	'STAR DIAM',T68,'SKY DIAM',T80,' SKY',T92,'SIGMA')

C Display the cursor:
C	CALL GRZCO(0,1)
C	CALL GRSBFD

C Entering the centre :
88	PRINT *,' POSITION THE CURSOR ON THE CENTRE OF THE STAR'
	PRINT *,' TYPE "RETURN" WHEN READY'
	READ(5,10) ANS

	CALL GRZCR(0,IXP,IYP,IENT,IF1,IF2)
	CALL GRSBFD

C The origin is 0,0 on the GRINNEL :
	IX0=IXP+1
	IY0=IYP+1

	PRINT *,' NAME OF THE STAR ?'
	READ(5,10) STAR_NAME

C Now the diameters :
89	PRINT *,' ENTER THE DIAMETERS IN PIXELS FOR THE STAR',
     1	' AND THE SKY :'
	READ(5,*) DIAM1,DIAM2

C Drawing the two circles on the screen :
	RAD1=DIAM1/2.
	RAD2=DIAM2/2.
	IRAD1=INT(RAD1)+1
	IRAD2=INT(RAD2)+1

C Green :
	COLOR='G'
	CALL GRINNEL_CIRCLE(FLOAT(IX0),FLOAT(IY0),RAD1,COLOR)
	CALL GRINNEL_CIRCLE(FLOAT(IX0),FLOAT(IY0),RAD2,COLOR)

C Computing the intensity in 3 iterations to estimate the sky with
c a 2-sigma rejection :
	SIGMA=1.E+12
	SKY=0.

	DO IK=1,3

	  SUM_SKY=0.D0
	  SUMSQ_SKY=0.D0
	  SUM_STAR=0.D0
	  NSKY=0.
	  NSTAR=0.

	  DO IY=IY0-IRAD1,IY0+IRAD1
	    DISTY=FLOAT((IY-IY0)*(IY-IY0))
	     DO IX=IX0-IRAD1,IX0+IRAD1
	       DISTX=FLOAT((IX-IX0)*(IX-IX0))
	       DIST=SQRT(DISTX+DISTY+0.1D-09)
	         IF(DIST.LE.RAD1)THEN
	          NSTAR=NSTAR+1.
	          SUM_STAR=SUM_STAR+INPUT1(IX,IY)
	         ELSEIF(DIST.LE.RAD2)THEN
	          TEST=ABS((INPUT1(IX,IY)-SKY)/2.)
	            IF(TEST.LT.SIGMA)THEN
	              NSKY=NSKY+1.
	              SUM_SKY=SUM_SKY+INPUT1(IX,IY)
	              SUMSQ_SKY=SUMSQ_SKY+INPUT1(IX,IY)*INPUT1(IX,IY)
	            ENDIF
	         ENDIF
	     END DO
	  END DO

	SKY=SUM_SKY/NSKY
	SIGMA=SQRT(SUMSQ_SKY/NSKY-SKY*SKY)

	END DO

C Computing the results :
	TOTAL_INTENSITY=(SUM_STAR-SKY*NSTAR)/EXPOSURE
	SIGMA_STAR=SIGMA*NSTAR/EXPOSURE
	SIGMA_SKY=SIGMA

	PRINT 107
	PRINT 101,STAR_NAME,TOTAL_INTENSITY,SIGMA_STAR,
     1	IX0,IY0,DIAM1,DIAM2,SKY,SIGMA_SKY
	WRITE (2,101) STAR_NAME,TOTAL_INTENSITY,SIGMA_STAR,
     1	IX0,IY0,DIAM1,DIAM2,SKY,SIGMA_SKY
101	FORMAT(X,A,T16,G12.5,T30,G12.5,T44,I4,T50,I4,T56,G10.3,T68,
     1	G10.3,T80,G10.3,T92,G10.3)

	PRINT *,' DO YOU WANT ANOTHER TRY WITH THE SAME STAR ?(N)'
	READ(5,10) ANS
	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
C Erasing the circles:
C	  COLOR='G'
C	  CALL GRINNEL_CLEAR(COLOR)
	  GOTO 89
	ELSE
C Drawing the circles in white :
C	  COLOR='W'
C	  CALL GRINNEL_CIRCLE(FLOAT(IX0),FLOAT(IY0),RAD1,COLOR)
C	  CALL GRINNEL_CIRCLE(FLOAT(IX0),FLOAT(IY0),RAD2,COLOR)
	ENDIF

	PRINT *,' DO YOU WANT ANOTHER TRY ANOTHER STAR ?(Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N'.AND.ANS.NE.'n')GOTO 88

C	PRINT *,' DO YOU WANT TO ERASE ALL THE CIRCLES ?(N)'
C	READ(5,10) ANS
C	IF(ANS.EQ.'y'.OR.ANS.EQ.'Y')THEN
C	 CALL GRINNEL_CLEAR('G')
C	 CALL GRINNEL_CLEAR('W')
C	ENDIF

	CALL GRSEND
	CLOSE(2)
	END
C-------------------------------------------------------------
	include 'jlpsub:gri_set.for'


!***********************************************************************************************************************************
!**                                            F U N C T I O N   D E N S I T Y                                                    **
!***********************************************************************************************************************************

REAL(R8) FUNCTION DENSITY (T,TDS,SS)
  use PREC
  USE LOGICC, ONLY: SUSP_SOLIDS, FRESH_WATER, SALT_WATER; USE GLOBAL, ONLY:JW
  IMPLICIT NONE
  REAL(R8) :: T,TDS,SS
                       DENSITY = ((((6.536332D-9*T-1.120083D-6)*T+1.001685D-4)*T-9.09529D-3)*T+6.793952D-2)*T+0.842594D0
  IF (SUSP_SOLIDS)     DENSITY = DENSITY+6.2D-4*SS
  IF (FRESH_WATER(JW)) DENSITY = DENSITY+TDS*((4.99D-8*T-3.87D-6)*T+8.221D-4)
  IF (SALT_WATER(JW))  DENSITY = DENSITY+TDS*((((5.3875D-9*T-8.2467D-7)*T+7.6438D-5)*T-4.0899D-3)*T+0.824493D0)                      &
                                 +((-1.6546D-6*T+1.0227D-4)*T-5.72466D-3)*TDS**1.5D0+4.8314D-4*TDS*TDS
  DENSITY = DENSITY+999.0D0
END FUNCTION DENSITY


      SUBROUTINE MB04TS( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG,
     $                   Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a symplectic URV (SURV) decomposition of a real
C     2N-by-2N matrix H:
C
C             [ op(A)   G   ]        T       [ op(R11)   R12   ]    T
C         H = [             ] = U R V  = U * [                 ] * V ,
C             [  Q    op(B) ]                [   0     op(R22) ]
C
C     where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real
C     N-by-N upper triangular matrix, op(R22) is a real N-by-N lower
C     Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic
C     matrices. Unblocked version.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   CHARACTER*1
C             Specifies the form of op( A ) as follows:
C             = 'N': op( A ) = A;
C             = 'T': op( A ) = A';
C             = 'C': op( A ) = A'.
C
C     TRANB   CHARACTER*1
C             Specifies the form of op( B ) as follows:
C             = 'N': op( B ) = B;
C             = 'T': op( B ) = B';
C             = 'C': op( B ) = B'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
C
C     ILO     (input) INTEGER
C             It is assumed that op(A) is already upper triangular,
C             op(B) is lower triangular and Q is zero in rows and
C             columns 1:ILO-1. ILO is normally set by a previous call
C             to MB04DD; otherwise it should be set to 1.
C             1 <= ILO <= N, if N > 0; ILO=1, if N=0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the triangular matrix R11, and in the zero part
C             information about the elementary reflectors used to
C             compute the SURV decomposition.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix B.
C             On exit, the leading N-by-N part of this array contains
C             the Hessenberg matrix R22, and in the zero part
C             information about the elementary reflectors used to
C             compute the SURV decomposition.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix G.
C             On exit, the leading N-by-N part of this array contains
C             the matrix R12.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix Q.
C             On exit, the leading N-by-N part of this array contains
C             information about the elementary reflectors used to
C             compute the SURV decomposition.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDG >= MAX(1,N).
C
C     CSL     (output) DOUBLE PRECISION array, dimension (2N)
C             On exit, the first 2N elements of this array contain the
C             cosines and sines of the symplectic Givens rotations
C             applied from the left-hand side used to compute the SURV
C             decomposition.
C
C     CSR     (output) DOUBLE PRECISION array, dimension (2N-2)
C             On exit, the first 2N-2 elements of this array contain the
C             cosines and sines of the symplectic Givens rotations
C             applied from the right-hand side used to compute the SURV
C             decomposition.
C
C     TAUL    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, the first N elements of this array contain the
C             scalar factors of some of the elementary reflectors
C             applied from the left-hand side.
C
C     TAUR    (output) DOUBLE PRECISION array, dimension (N-1)
C             On exit, the first N-1 elements of this array contain the
C             scalar factors of some of the elementary reflectors
C             applied from the right-hand side.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -16,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
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
C     METHOD
C
C     The matrices U and V are represented as products of symplectic
C     reflectors and Givens rotations
C
C     U = diag( HU(1),HU(1) )  GU(1)  diag( FU(1),FU(1) )
C         diag( HU(2),HU(2) )  GU(2)  diag( FU(2),FU(2) )
C                              ....
C         diag( HU(n),HU(n) )  GU(n)  diag( FU(n),FU(n) ),
C
C     V = diag( HV(1),HV(1) )       GV(1)   diag( FV(1),FV(1) )
C         diag( HV(2),HV(2) )       GV(2)   diag( FV(2),FV(2) )
C                                   ....
C         diag( HV(n-1),HV(n-1) )  GV(n-1)  diag( FV(n-1),FV(n-1) ).
C
C     Each HU(i) has the form
C
C           HU(i) = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in
C     Q(i+1:n,i), and tau in Q(i,i).
C
C     Each FU(i) has the form
C
C           FU(i) = I - nu * w * w'
C
C     where nu is a real scalar, and w is a real vector with
C     w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in
C     A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The
C     scalar nu is stored in TAUL(i).
C
C     Each GU(i) is a Givens rotation acting on rows i and n+i,
C     where the cosine is stored in CSL(2*i-1) and the sine in
C     CSL(2*i).
C
C     Each HV(i) has the form
C
C           HV(i) = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in
C     Q(i,i+2:n), and tau in Q(i,i+1).
C
C     Each FV(i) has the form
C
C           FV(i) = I - nu * w * w'
C
C     where nu is a real scalar, and w is a real vector with
C     w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in
C     B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise.
C     The scalar nu is stored in TAUR(i).
C
C     Each GV(i) is a Givens rotation acting on columns i+1 and n+i+1,
C     where the cosine is stored in CSR(2*i-1) and the sine in
C     CSR(2*i).
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 80/3 N**3 + 20 N**2 + O(N) floating point
C     operations and is numerically backward stable.
C
C     REFERENCES
C
C     [1] Benner, P., Mehrmann, V., and Xu, H.
C         A numerically stable, structure preserving method for
C         computing the eigenvalues of real Hamiltonian or symplectic
C         pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998.
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 DGESUV).
C
C     KEYWORDS
C
C     Elementary matrix operations, Matrix decompositions, Hamiltonian
C     matrix
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANA, TRANB
      INTEGER           ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*),
     $                  G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*)
C     .. Local Scalars ..
      LOGICAL           LTRA, LTRB
      INTEGER           I
      DOUBLE PRECISION  ALPHA, C, NU, S, TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARF, DLARFG, DLARTG, DROT, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO  = 0
      LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' )
      LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' )
      IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN
         DWORK(1) = DBLE( MAX( 1, N ) )
         INFO = -18
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04TS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      DO 10 I = ILO, N
         ALPHA = Q(I,I)
         IF ( I.LT.N ) THEN
C
C           Generate elementary reflector HU(i) to annihilate Q(i+1:n,i)
C
            CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, NU )
C
C           Apply HU(i) from the left.
C
            Q(I,I) = ONE
            CALL DLARF( 'Left', N-I+1, N-I, Q(I,I), 1, NU, Q(I,I+1),
     $                  LDQ, DWORK )
            IF ( LTRA ) THEN
               CALL DLARF( 'Right', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I),
     $                     LDA, DWORK )
            ELSE
               CALL DLARF( 'Left', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I),
     $                     LDA, DWORK )
            END IF
            IF ( LTRB ) THEN
               CALL DLARF( 'Right', N, N-I+1, Q(I,I), 1, NU, B(1,I),
     $                     LDB, DWORK )
            ELSE
               CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, B(I,1), LDB,
     $                     DWORK )
            END IF
            CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, G(I,1), LDG,
     $                  DWORK )
            Q(I,I) = NU
         ELSE
            Q(I,I) = ZERO
         END IF
C
C        Generate symplectic Givens rotation GU(i) to annihilate Q(i,i).
C
         TEMP = A(I,I)
         CALL DLARTG( TEMP, ALPHA, C, S, A(I,I) )
C
C        Apply G(i) from the left.
C
         IF ( LTRA ) THEN
            CALL DROT( N-I, A(I+1,I), 1, Q(I,I+1), LDQ, C, S )
         ELSE
            CALL DROT( N-I, A(I,I+1), LDA, Q(I,I+1), LDQ, C, S )
         END IF
         IF ( LTRB ) THEN
            CALL DROT( N, G(I,1), LDG, B(1,I), 1, C, S )
         ELSE
            CALL DROT( N, G(I,1), LDG, B(I,1), LDB, C, S )
         END IF
         CSL(2*I-1) = C
         CSL(2*I)   = S
C
         IF ( I.LT.N ) THEN
            IF ( LTRA ) THEN
C
C              Generate elementary reflector FU(i) to annihilate
C              A(i,i+1:n).
C
               CALL DLARFG( N-I+1, A(I,I), A(I,I+1), LDA, TAUL(I) )
C
C              Apply FU(i) from the left.
C
               TEMP = A(I,I)
               A(I,I) = ONE
               CALL DLARF( 'Right', N-I, N-I+1, A(I,I), LDA, TAUL(I),
     $                     A(I+1,I), LDA, DWORK )
               CALL DLARF( 'Left', N-I+1, N-I, A(I,I), LDA, TAUL(I),
     $                     Q(I,I+1), LDQ, DWORK )
               IF ( LTRB ) THEN
                  CALL DLARF( 'Right', N, N-I+1, A(I,I), LDA, TAUL(I),
     $                        B(1,I), LDB, DWORK )
               ELSE
                  CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I),
     $                        B(I,1), LDB, DWORK )
               END IF
               CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I),
     $                     G(I,1), LDG, DWORK )
               A(I,I) = TEMP
            ELSE
C
C              Generate elementary reflector FU(i) to annihilate
C              A(i+1:n,i).
C
               CALL DLARFG( N-I+1, A(I,I), A(I+1,I), 1, TAUL(I) )
C
C              Apply FU(i) from the left.
C
               TEMP = A(I,I)
               A(I,I) = ONE
               CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I),
     $                     A(I,I+1), LDA, DWORK )
               CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I),
     $                     Q(I,I+1), LDQ, DWORK )
               IF ( LTRB ) THEN
                  CALL DLARF( 'Right', N, N-I+1, A(I,I), 1, TAUL(I),
     $                        B(1,I), LDB, DWORK )
               ELSE
                  CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I),
     $                        B(I,1), LDB, DWORK )
               END IF
               CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), G(I,1),
     $                     LDG, DWORK )
               A(I,I) = TEMP
            END IF
         ELSE
            TAUL(I) = ZERO
         END IF
         IF ( I.LT.N )
     $      ALPHA = Q(I,I+1)
         IF ( I.LT.N-1 ) THEN
C
C           Generate elementary reflector HV(i) to annihilate Q(i,i+2:n)
C
            CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, NU )
C
C           Apply HV(i) from the right.
C
            Q(I,I+1) = ONE
            CALL DLARF( 'Right', N-I, N-I, Q(I,I+1), LDQ, NU,
     $                  Q(I+1,I+1), LDQ, DWORK )
            IF ( LTRA ) THEN
               CALL DLARF( 'Left', N-I, N, Q(I,I+1), LDQ, NU,
     $                     A(I+1,1), LDA, DWORK )
            ELSE
               CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU,
     $                     A(1,I+1), LDA, DWORK )
            END IF
            IF ( LTRB ) THEN
               CALL DLARF( 'Left', N-I, N-I+1, Q(I,I+1), LDQ, NU,
     $                     B(I+1,I), LDB, DWORK )
            ELSE
               CALL DLARF( 'Right', N-I+1, N-I, Q(I,I+1), LDQ, NU,
     $                     B(I,I+1), LDB, DWORK )
            END IF
            CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU,
     $                  G(1,I+1), LDG, DWORK )
            Q(I,I+1) = NU
         ELSE IF ( I.LT.N ) THEN
            Q(I,I+1) = ZERO
         END IF
         IF ( I.LT.N ) THEN
C
C           Generate symplectic Givens rotation GV(i) to annihilate
C           Q(i,i+1).
C
            IF ( LTRB ) THEN
               TEMP = B(I+1,I)
               CALL DLARTG( TEMP, ALPHA, C, S, B(I+1,I) )
               S = -S
               CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), LDB, C, S )
            ELSE
               TEMP = B(I,I+1)
               CALL DLARTG( TEMP, ALPHA, C, S, B(I,I+1) )
               S = -S
               CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), 1, C, S )
            END IF
            IF ( LTRA ) THEN
               CALL DROT( N, A(I+1,1), LDA, G(1,I+1), 1, C, S )
            ELSE
               CALL DROT( N, A(1,I+1), 1, G(1,I+1), 1, C, S )
            END IF
            CSR(2*I-1) = C
            CSR(2*I)   = S
         END IF
         IF ( I.LT.N-1 ) THEN
            IF ( LTRB ) THEN
C
C              Generate elementary reflector FV(i) to annihilate
C              B(i+2:n,i).
C
               CALL DLARFG( N-I, B(I+1,I), B(I+2,I), 1, TAUR(I) )
C
C              Apply FV(i) from the right.
C
               TEMP = B(I+1,I)
               B(I+1,I) = ONE
               CALL DLARF( 'Left', N-I, N-I, B(I+1,I), 1, TAUR(I),
     $                     B(I+1,I+1), LDB, DWORK )
               CALL DLARF( 'Right', N-I, N-I, B(I+1,I), 1, TAUR(I),
     $                     Q(I+1,I+1), LDQ, DWORK )
               IF ( LTRA ) THEN
                  CALL DLARF( 'Left', N-I, N, B(I+1,I), 1,
     $                        TAUR(I), A(I+1,1), LDA, DWORK )
               ELSE
                  CALL DLARF( 'Right', N, N-I, B(I+1,I), 1,
     $                        TAUR(I), A(1,I+1), LDA, DWORK )
               END IF
               CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, TAUR(I),
     $                     G(1,I+1), LDG, DWORK )
               B(I+1,I) = TEMP
            ELSE
C
C              Generate elementary reflector FV(i) to annihilate
C              B(i,i+2:n).
C
               CALL DLARFG( N-I, B(I,I+1), B(I,I+2), LDB, TAUR(I) )
C
C              Apply FV(i) from the right.
C
               TEMP = B(I,I+1)
               B(I,I+1) = ONE
               CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I),
     $                     B(I+1,I+1), LDB, DWORK )
               CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I),
     $                     Q(I+1,I+1), LDQ, DWORK )
               IF ( LTRA ) THEN
                  CALL DLARF( 'Left', N-I, N, B(I,I+1), LDB, TAUR(I),
     $                        A(I+1,1), LDA, DWORK )
               ELSE
                  CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB,
     $                        TAUR(I), A(1,I+1), LDA, DWORK )
               END IF
               CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, TAUR(I),
     $                     G(1,I+1), LDG, DWORK )
               B(I,I+1) = TEMP
            END IF
         ELSE IF ( I.LT.N ) THEN
            TAUR(I) = ZERO
         END IF
   10 CONTINUE
      DWORK(1) = DBLE( MAX( 1, N ) )
      RETURN
C *** Last line of MB04TS ***
      END


module setup_init_mod

use constants_mod

contains

subroutine fill(quad)

    use setup_config_mod
    use equations_const_mod

    use mesh_types_mod, only: quad_t
    use quad_utils_mod, only: quad_get_coords

    use math_mod, only: sigmoid

    type(quad_t), intent(inout) :: quad

    real(dp) :: dens(N_NODES,N_NODES,N_NODES)
    real(dp) :: velx(N_NODES,N_NODES,N_NODES)
    real(dp) :: vely(N_NODES,N_NODES,N_NODES)
    real(dp) :: velz(N_NODES,N_NODES,N_NODES)
    real(dp) :: momx(N_NODES,N_NODES,N_NODES)
    real(dp) :: momy(N_NODES,N_NODES,N_NODES)
    real(dp) :: momz(N_NODES,N_NODES,N_NODES)
    real(dp) :: pres(N_NODES,N_NODES,N_NODES)
    real(dp) :: ener(N_NODES,N_NODES,N_NODES)

    real(dp) :: coords(N_NODES,N_NODES,N_NODES,N_DIMS)
    real(dp) :: radius(N_NODES,N_NODES,N_NODES)
    real(dp) :: angles(N_NODES,N_NODES,N_NODES)

    real(dp) :: xyradi(N_NODES,N_NODES,N_NODES)

    integer :: i,j,k,l,r,m

    coords = quad_get_coords(quad)
    radius = SQRT(SUM(coords**2,dim=N_DIMS+1))
    xyradi = SQRT(coords(:,:,:,1)**2 + coords(:,:,:,2)**2)
    angles = atan2(coords(:,:,:,2),coords(:,:,:,1))

    !! original
    !! dens = merge(dens_cloud*(1+0.1*cos(2*angles)),dens0,radius < cloudradius)

    !! dens = dens0 + dens_cloud &
    !!     * sigmoid(-25*(radius/cloudradius - 1.10)) &
    !!     * sigmoid( 25*(xyradi/cloudradius - 0.40)) &
    !!     * (1+0.5*cos(2*angles))

    dens = dens0
    !! velx = velx0
    !! vely = vely0
    !! velz = velz0
    !! pres = 1.0_dp

    dens = dens + dens_cloud &
        * sigmoid(-25*(radius/cloudradius - 1.10))

    radius = SQRT((coords(:,:,:,1)-xofs)**2 + (coords(:,:,:,2))**2 + (coords(:,:,:,3))**2)
    dens = dens + dens_cloud * 1.5 * exp(-0.5*(radius/bell_sigma)**2)

    radius = SQRT((coords(:,:,:,1)+xofs)**2 + (coords(:,:,:,2))**2 + (coords(:,:,:,3))**2)
    dens = dens + dens_cloud * 1.5 * exp(-0.5*(radius/bell_sigma)**2)

    radius = SQRT(SUM(coords**2,dim=N_DIMS+1))
    velx = angl0 * (-coords(:,:,:,2))* sigmoid(-25*(radius/cloudradius - 1.2))
    vely = angl0 *   coords(:,:,:,1) * sigmoid(-25*(radius/cloudradius - 1.2))
    velz = velz0

    where (dens <= dens_critical)
        pres = K_isothermal * dens
    else where
        pres = K_adiabatic * dens**kappa
    end where

    momx = dens * velx
    momy = dens * vely
    momz = dens * velz

    ener = pres/(kappa-1.0_dp) + 0.5*dens*(velx**2+vely**2+velz**2)

    quad%pld%hydro%state(:,:,:,DENS_VAR) = dens
    quad%pld%hydro%state(:,:,:,MOMX_VAR) = momx
    quad%pld%hydro%state(:,:,:,MOMY_VAR) = momy
    quad%pld%hydro%state(:,:,:,MOMZ_VAR) = momz
    quad%pld%hydro%state(:,:,:,ENER_VAR) = ener

end subroutine

function setup_init_probe_refine(quad) result(ok)

    use setup_config_mod
    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CORNERS
    use quad_utils_mod, only: quad_get_center
    use quad_utils_mod, only: quad_get_vertices

    type(quad_t), intent(in)        :: quad
    logical                         :: ok

    real(dp) :: verts(N_DIMS,MESH_CORNERS)
    real(dp) :: center(N_DIMS)

    verts = quad_get_vertices(quad)
    center = quad_get_center(quad)

    ok = .false.

    if (any(abs(SQRT(SUM((verts)**2,dim=1))) < 1.25*cloudradius)) then
    !if (SQRT(SUM(quad%center**2)) < 2.5*cloudradius) then
    !if (any(abs(SQRT(SUM((verts)**2,dim=1))) < 0.25 * 0.5*diameter)) then
    !if (center(1) + center(2) + center(3) < 0) then
    !if (all(center < 0)) then
        ok = .true.
    end if

end function

function setup_init_probe_refine2(quad) result(ok)

    use setup_config_mod
    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CORNERS
    use quad_utils_mod, only: quad_get_center
    use quad_utils_mod, only: quad_get_vertices

    type(quad_t), intent(in)        :: quad
    logical                         :: ok

    real(dp) :: verts(N_DIMS,MESH_CORNERS)
    real(dp) :: center(N_DIMS)

    verts = quad_get_vertices(quad)
    center = quad_get_center(quad)

    ok = .false.

    if (any(abs(SQRT(SUM((verts)**2,dim=1))) < 0.02)) then
        ok = .true.
    end if

end function

function setup_init_probe_coarsen(quads) result(ok)

    use mesh_types_mod, only: quad_t
    use mesh_const_mod, only: MESH_CHILDREN
    use setup_config_mod, only: setup_amr_threshold_coarsen

    type(quad_t), intent(in)    :: quads(MESH_CHILDREN)
    logical                     :: ok

    real(dp)                    :: sensor(MESH_CHILDREN)

    integer :: i

    ok = .false.

end function

subroutine hook_init_810

    use share_mod, only: rt => runtime
    use share_mod, only: mesh

    use mesh_utils_mod, only: mesh_refine
    use mesh_utils_mod, only: mesh_iterate_quads

    integer :: level

    ! do level = mesh%minlevel,mesh%maxlevel-2
    !     call mesh_refine(mesh,setup_init_probe_refine)
    ! end do
    ! call mesh_refine(mesh,setup_init_probe_refine2)

    call mesh_iterate_quads(mesh,fill)

end subroutine

end module


program sudokusolve
use sudokutools
IMPLICIT NONE

integer,dimension(9,9) :: input, work
! integer,dimension(81,81) :: blank_coords
! integer :: blank_count
integer :: direction
integer :: start_guess

integer :: ios
integer :: i, j, guess, a, b
integer :: x, y
integer :: bound_l, bound_r, bound_u, bound_d
logical,dimension(9,9) :: original
logical :: error
character(80) :: fname

real :: final_time, init_time

101 format(a)
102 format(i2) ! 2 integers (single integer w/ space)

write(*,101) 'input sudoku file name'
write(*,101) 'blank spaces as 0'
read(*,*) fname

open(unit = 11, file = fname, status = 'old', action = 'read', iostat = ios)
if (ios .ne. 0) then
  write(*,'(a,i3,a,a)') 'error opening unit', 11, ' -- ', fname
  stop('END PROGRAM')
endif

do i = 1,9
  read(11,*) input(i,:)
enddo

close(unit = 11)

call cpu_time(init_time)
write(*,101)
write(*,101) '-------------------------'
write(*,101) 'input echo'
call sudokuwrite(input)

do i = 1,9
  do j = 1,9
    if (input(i,j) .eq. 0) then
      original(i,j) = .false.
    else
      original(i,j) = .true.
    endif
  enddo
enddo

bound_l = 0
bound_r = 0
bound_u = 0
bound_d = 0
work = input

x = 1
y = 1
direction = 1
i = 0
! do i = 1,10000
do
  i = i + 1
  if (i .eq. 100000) then
    stop('failed to solve with 100000 iterations')
  endif
  if (.not. original(y,x)) then
    ! write(12,'(i7,a,i2,a,i2)') i, ',', x, ',', y
    select case (y)
      case (1:3)
        bound_l = 1
        bound_r = 3
      case(4:6)
        bound_l = 4
        bound_r = 6
      case(7:9)
        bound_l = 7
        bound_r = 9
    endselect
      select case(x)
      case (1:3)
        bound_u = 1
        bound_d = 3
      case(4:6)
        bound_u = 4
        bound_d = 6
      case(7:9)
        bound_u = 7
        bound_d = 9
    endselect

    if (work(y,x) .eq. 9) then
      work(y,x) = 0
      x = x + direction
      if (x .eq. 0) then
        x = 9
        y = y - 1
      elseif (x .eq. 10) then
        x = 1
        y = y + 1
      endif
      cycle
    endif
    do guess = (work(y,x) + 1),9
      work(y,x) = guess
      error = .false.

      ! row check
      do a = 1,9
        if ((work(y,x) .eq. work(y,a)) .and. (a .ne. x)) then
          ! bad guess
          error = .true.
          exit
        endif
      enddo
      ! col check
      do a = 1,9
        if ((work(y,x) .eq. work(a,x)) .and. (a .ne. y)) then
          ! bad guess
          error = .true.
          exit
        endif
      enddo
      ! sector check
      do a = bound_l,bound_r
        do b = bound_u,bound_d
          if ((work(y,x) .eq. work(a,b)) .and. (a .ne. y) .and. (b .ne. x)) then
            ! bad guess
            error = .true.
          endif
        enddo
      enddo

      if (.not. error) then
        ! good guess
        direction = 1
        ! write(*,101) 'good guess'
        ! call sudokuwrite(work)
        exit
      endif
      if ((error) .and. (guess .eq. 9)) then
        ! write(*,'(i7,a,2i3)') i,' couldnt guess - ', y, x
        work(y,x) = 0
        direction = -1
        ! stop
      endif
    enddo
  endif

  x = x + direction
  if (x .eq. 10) then
    x = 1
    y = y + 1
  elseif (x .eq. 0) then
    x = 9
    y = y - 1
  endif
  if (y .eq. 10) then
    write(*,101) 'completed'
    exit
  endif

  if (y .eq. 0) then
    write(*,101) 'ERROR y = 0, out of coords'
    exit
  endif
enddo

call cpu_time(final_time)
write(*,'(i6,a)') i, ' - iterations'
! write(*,'(e12.6,a)') (final_time - init_time), ' - seconds of runtime'
write(*,*)

write(*,101) '-------------------------'
write(*,101) 'solution'
call sudokuwrite(work)

endprogram sudokusolve


module utils_spline

  use utils_constants

  private

  public :: splini , spline , splint

  contains

!
!  Calculate 2nd derivatives of cubic spline interp function
!  Adapted from numerical recipes by press et al
!
    subroutine spline(x,y,yp1,ypn,y2)
      implicit none
!
      integer , parameter :: nmax = 100
!
      ! Arrays of tabulated function in ascending order by x with y = f(x)
      real(dp) , dimension(:) , intent(in)  :: x , y
      ! Specified derivatives at x(1) and x(n)
      ! Values > 1E30 signals second derivative zero
      real(dp) , intent(in) :: yp1 , ypn
      ! Output array of second derivatives
      real(dp) , dimension(:) , intent(out) :: y2
!
      integer :: n , i , k
      real(dp) :: p , qn , sig , un
      real(dp) , dimension(nmax) :: u

      n = size(x,1)
      if ( yp1 > 0.99E30_r8 ) then
        y2(1) = d_0
        u(1) = d_0
      else
        y2(1) = -d_half
        u(1) = (d_3/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      end if
      do i = 2 , n - 1
        sig = (x(i)-x(i-1))/(x(i+1)-x(i-1))
        p = sig*y2(i-1) + d_2
        y2(i) = (sig-d_1)/p
        u(i) = (d_6*((y(i+1)-y(i))/(x(i+1)-x(i))- &
                     (y(i)-y(i-1))/(x(i)-x(i-1))) / &
                     (x(i+1)-x(i-1))-sig*u(i-1))/p
      end do
      if ( ypn > .99E30_r8 ) then
        qn = d_0
        un = d_0
      else
        qn = d_half
        un = (d_3/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      end if
      y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+d_1)
      do k = n - 1 , 1 , -1
        y2(k) = y2(k)*y2(k+1) + u(k)
      end do
    end subroutine spline
!
!   Integrate cubic spline function from xa(1) to x
!
    subroutine splini(xa,ya,y2a,x,yi)
      implicit none
!
      ! Arrays of tabulated function in ascending order by xa with ya = f(xa)
      real(dp) , dimension(:) , intent(in) :: xa , ya
      ! Array of second derivatives
      real(dp) , dimension(:) , intent(in) :: y2a
      ! Ascissa endpoint of integration
      real(dp) , intent(in) :: x
      ! Output value
      real(dp) , intent(out) :: yi
!
      real(dp) :: a , a2 , b , b2 , h , xx
      integer :: n , khi , klo
!
      n = size(xa,1)
      yi = d_0
      klo = 1
      khi = 2
      do while ( x > xa(klo) .and. khi <= n )
        xx = x
        if ( khi<n ) xx = dmin1(x,xa(khi))
        h = xa(khi) - xa(klo)
        a = (xa(khi)-xx)/h
        b = (xx-xa(klo))/h
        a2 = a*a
        b2 = b*b
        yi = yi + ((d_1-a2)*ya(klo)/d_2+b2*ya(khi)/d_2+ &
                   ((-(d_1+a2*a2)/d_4+a2/d_2)*y2a(klo)+ &
                   (b2*b2/d_4-b2/d_2)*y2a(khi))*h*h/d_6)*h
        klo = klo + 1
        khi = khi + 1
      end do
    end subroutine splini
!
!   Calculate cubic spline interp value
!   Adapted from numerical recipes by press et al.
!
    subroutine splint(xa,ya,y2a,x,y)
      implicit none
!
      ! Arrays of tabulated function values in ascending xa order
      real(dp) , dimension(:) , intent(in) :: xa , ya
      ! Arrays of second derivatives
      real(dp) , dimension(:) , intent(in) :: y2a
      ! Abscissa of interpolation
      real(dp) , intent(in) :: x
      ! Output value
      real(dp) , intent(out) :: y
!
      real(dp) :: a , b , h
      integer :: n , k , khi , klo
!
      n = size(xa,1)
      klo = 1
      khi = n
      do while ( khi-klo > 1 )
        k = (khi+klo)/2
        if ( xa(k)>x ) then
          khi = k
        else
          klo = k
        end if
      end do
      h = xa(khi) - xa(klo)
      if ( h==0 ) then
        y = 1.0E-30_r8
        return
      end if
      a = (xa(khi)-x)/h
      b = (x-xa(klo))/h
      y = a*ya(klo) + b*ya(khi) + ((a*a*a-a)*y2a(klo) + &
                                   (b*b*b-b)*y2a(khi))*h*h/d_6
    end subroutine splint

end module utils_spline


      program main
      include "mpif.h"
      double precision  PI25DT
      parameter        (PI25DT = 3.141592653589793238462643d0)
      double precision  mypi, pi, h, sum, x, f, a
      double precision starttime, endtime
      integer n, myid, numprocs, i, ierr
c                                 function to integrate
      f(a) = 4.d0 / (1.d0 + a*a)

      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)

 10   if ( myid .eq. 0 ) then
         print *, 'Enter the number of intervals: (0 quits) '
         read(*,*) n
      endif
c                                 broadcast n
      starttime = MPI_WTIME()
      call MPI_BCAST(n,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
c                                 check for quit signal
      if ( n .le. 0 ) goto 30
c                                 calculate the interval size
      h = 1.0d0/n
      sum  = 0.0d0
      do 20 i = myid+1, n, numprocs
         x = h * (dble(i) - 0.5d0)
         sum = sum + f(x)
 20   continue
      mypi = h * sum
c                                 collect all the partial sums
      call MPI_REDUCE(mypi,pi,1,MPI_DOUBLE_PRECISION,MPI_SUM,0,
     &                  MPI_COMM_WORLD,ierr)
c                                 node 0 prints the answer.
      endtime = MPI_WTIME()
      if (myid .eq. 0) then
         print *, 'pi is ', pi, ' Error is', abs(pi - PI25DT)
         print *, 'time is ', endtime-starttime, ' seconds'
      endif
      goto 10
 30   call MPI_FINALIZE(ierr)
      stop
      end


MODULE Inicializacoes

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE inicializa_variaveis

      USE VariaveisGerais
      USE NavierStokesInOut

      INTEGER :: i, j

      DOUBLE PRECISION :: pi, Tnt, ht1

      ! Lendo arquivo de configuracoes gerais
      CALL read_configuracoes_gerais

      pi=4.D0*DATAN(1.D0)
      Xf = pi/4.
      Xi = -pi/4.
      Yf = pi/4.
      Yi = -pi/4.

      Lx = Xf - Xi
      Ly = Yf - Yi

      hx = Lx/Nx
      hy = Ly/Ny

      !------------------ Tratamento da CFL
      ht1 = CFL/(1.0d0/hx + 1.0d0/hy)

      !Tn => number of iterations
      Tnt = NINT( Tf/ht1 )
      ! Para este ht e garantido que vai convergir, mas e muito lento
      ht = (Tf - Ti)/Tnt

      !ht = (Tf - Ti)*ht1/Tf
      IF ( Experimento .eq. 5 ) THEN
         ht = ((Tf - Ti)/(2.0d0*Tf))*(Re/100.0d0)*(32.0d0/Nx)*26*hx
      ELSE
         ht = ((Tf - Ti)/(2.0d0*Tf))*(100.0d0/(2.0d0*Re))*(32.0d0/Nx)*16*hx
      END IF

      ! O tamanho dos vetores xp e yp Nx e Ny respectivamente
      IF ( .NOT. ALLOCATED( xu ) )     ALLOCATE( xu ( Nx - 1 ) )
      IF ( .NOT. ALLOCATED( yu ) )     ALLOCATE( yu ( Ny ) )
      IF ( .NOT. ALLOCATED( xv ) )     ALLOCATE( xv ( Nx ) )
      IF ( .NOT. ALLOCATED( yv ) )     ALLOCATE( yv ( Ny - 1 ) )

      xv(1) = hx/2.0d0                      + Xi
      DO i = 1, Nx-1

         xu(i)   = hx*i                     + Xi
         xv(i+1) = hx*i + hx/2.0d0          + Xi

      END DO

      yu(1) = hy/2.0d0                        + Yi
      DO j = 1, Ny-1

         yu(j+1) = hy*j + hy/2.0d0            + Yi
         yv(j)   = hy*j                       + Yi

      END DO

      ! Criando o Alias das funcoes pressao_analitica, u_analitica, v_analitica, condicoes de contorno e condicoes iniciais
      CALL CriaExperimentoAlias(Experimento, Extrapolacao_U, Extrapolacao_V)

      CALL atualiza_variaveis_paralelismo()

      CALL u % init( Nx, Ny, Tn, Lx, Ly, ht, Re, Tolerancia_U)
      CALL u % aplica_condicao_inicial()

      CALL v % init( Nx, Ny, Tn, Lx, Ly, ht, Re, Tolerancia_V)
      CALL v % aplica_condicao_inicial()

      CALL p % init( Nx, Ny, Tn, Lx, Ly, ht, Re, Qui, Tolerancia_P, Threads)
      CALL p % aplica_condicao_inicial()
      CALL p % normaliza_pressao()

      CALL escreve_cabecalho

   END SUBROUTINE inicializa_variaveis

   SUBROUTINE CriaExperimentoAlias(Experimento, Extrapolacao_U, Extrapolacao_V)

      USE FuncoesAlias
      USE ExperimentosNumericos
      USE ExtrapolacoesDeUeV

      INTEGER, INTENT(IN) :: Experimento, Extrapolacao_U, Extrapolacao_V

      ! Aplicando as condicoes de contorno e calculando as solucoes analiticas para o problema estudado
      SELECT CASE (Experimento)

         CASE (5)

            cc_u_w => CC_U_W_Experimento5
            cc_u_e => CC_U_E_Experimento5
            cc_u_s => CC_U_S_Experimento5
            cc_u_n => CC_U_N_Experimento5

            cc_v_w => CC_V_W_Experimento5
            cc_v_e => CC_V_E_Experimento5
            cc_v_s => CC_V_S_Experimento5
            cc_v_n => CC_V_N_Experimento5

            pressao_analitica => PressaoAnaliticaExperimento5
            u_analitica => VelocidadeU_AnaliticaExperimento5
            v_analitica => VelocidadeV_AnaliticaExperimento5

            pressao_inicial   => PressaoInicialExperimento5
            u_inicial         => VelocidadeU_InicialExperimento5
            v_inicial         => VelocidadeV_InicialExperimento5

      END SELECT

      extrapola_u_S => Extrapola_u_S_Cubica
      extrapola_u_N => Extrapola_u_N_Cubica
      extrapola_v_W => Extrapola_v_W_Cubica
      extrapola_v_E => Extrapola_v_E_Cubica
   !
   !
   !    SELECT CASE (Extrapolacao)
   !
   !      CASE (1)
   !
   !          extrapola_u_S => Extrapola_u_S_Linear
   !          extrapola_u_N => Extrapola_u_N_Linear
   !          extrapola_v_W => Extrapola_v_W_Linear
   !          extrapola_v_E => Extrapola_v_E_Linear
   !
   !      CASE (2)
   !
   !          extrapola_u_S => Extrapola_u_S_Cubica
   !          extrapola_u_N => Extrapola_u_N_Cubica
   !          extrapola_v_W => Extrapola_v_W_Cubica
   !          extrapola_v_E => Extrapola_v_E_Cubica
   !
   !   END SELECT

   END SUBROUTINE CriaExperimentoAlias

   SUBROUTINE atualiza_variaveis_paralelismo()

       USE OMP_LIB
       USE VariaveisGerais

       INTEGER :: Tne
       INTEGER :: threads_max, C, tc, it, ft, ptt, thread

       ! Atualizando variaveis relacionadas ao paralelismo
       ! Obtendo o numero maximo de threads do sistema
       threads_max = OMP_get_max_threads()

       ! Comparando com o numero de threads que o usuario quer utilizar
       IF (Threads > threads_max) THEN
          WRITE(*,*) ""
          WRITE(*,*) "ATENCAO: numero de threads fornecidas excede o numero de threads disponivel no sistema"
          WRITE(*,*) "Utilizando o numero maximo de threads disponivel:", threads_max
          WRITE(*,*) "Consulte o arquivo " // TRIM(ADJUSTL(arq_geral)) // " para ver os parametros utilizados pelo programa"
          WRITE(*,*) ""
          Threads = threads_max
       END IF

       ALLOCATE( threads_if( Threads, 2) )

       Tne = Tn - 1

       !------------------------ DISSERTACAO PAGINAS 77-79 ----------------------
       ! Estimando incorretamente o numero de passos de tempo por thread
       ptt = FLOOR(DBLE(Tne)/DBLE(Threads))

       ! tc e a thread de referencia
       tc = Threads + 1 - (Tne - Threads * ptt)

       ! Calculando o inicio e fim de cada thread, isto e, quais passos de tempo cada thread vai assumir
       DO thread = 1, Threads
           IF (thread >= tc) THEN
               C = 1
           ELSE
               C = 0
           END IF

           it = (thread -1) * ptt + 1 + C * (thread - tc)
           ft = thread * ptt + C * (thread - tc + 1)

           ! Salvando estas informacoes
           threads_if(thread, 1) = it
           threads_if(thread, 2) = ft

       END DO
       !------------------------ DISSERTACAO PAGINAS 77-79 ----------------------

   END SUBROUTINE atualiza_variaveis_paralelismo

END MODULE Inicializacoes


program main
    use forlab, only: operator(.i.), disp
    real :: x(2, 2)
    complex :: c(2, 2)

    x = 0.0
    x(1, 1) = 0.5
    x(2, 2) = 1.0

    call disp(x, 'x matrix:')
    call disp((.i.x), 'inv of "x":')
    call disp(matmul(.i.x, x), 'check:')

    c = 0.0
    c(1, 1) = cmplx(1.d0, 1.2d0)
    c(2, 2) = cmplx(1.1d0, 1.d0)

    call disp(c, 'c matrix:')
    call disp(.i. (c), 'inv of "c":')
    call disp(matmul(.i. (c), c), 'check:')

end program


PURE SUBROUTINE Insertion_Sort(a)
  REAL, INTENT(in out), DIMENSION(:) :: a
  REAL :: temp
  INTEGER :: i, j

  DO i = 2, SIZE(a)
     j = i - 1
     temp = a(i)
     DO WHILE (j>=1 .AND. a(j)>temp)
        a(j+1) = a(j)
        j = j - 1
     END DO
     a(j+1) = temp
  END DO
END SUBROUTINE Insertion_Sort


      SUBROUTINE SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S,
     $                   LDS, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct the 2n-by-2n Hamiltonian or symplectic matrix S
C     associated to the linear-quadratic optimization problem, used to
C     solve the continuous- or discrete-time algebraic Riccati equation,
C     respectively.
C
C     For a continuous-time problem, S is defined by
C
C             (  A  -G )
C         S = (        ),                                       (1)
C             ( -Q  -A')
C
C     and for a discrete-time problem by
C
C                 -1       -1
C             (  A        A  *G     )
C         S = (   -1           -1   ),                          (2)
C             ( QA     A' + Q*A  *G )
C
C     or
C
C                       -T         -T
C             (  A + G*A  *Q   -G*A   )
C         S = (      -T            -T ),                        (3)
C             (    -A  *Q         A   )
C
C     where A, G, and Q are N-by-N matrices, with G and Q symmetric.
C     Matrix A must be nonsingular in the discrete-time case.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  Continuous-time system;
C             = 'D':  Discrete-time system.
C
C     HINV    CHARACTER*1
C             If DICO = 'D', specifies which of the matrices (2) or (3)
C             is constructed, as follows:
C             = 'D':  The matrix S in (2) is constructed;
C             = 'I':  The (inverse) matrix S in (3) is constructed.
C             HINV is not referenced if DICO = 'C'.
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrices G and Q is
C             stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, G, and Q.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, if DICO = 'D', and INFO = 0, the leading N-by-N
C                                                     -1
C             part of this array contains the matrix A  .
C             Otherwise, the array A is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     G       (input) DOUBLE PRECISION array, dimension (LDG,N)
C             The leading N-by-N upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             must contain the upper triangular part or lower triangular
C             part, respectively, of the symmetric matrix G.
C             The strictly lower triangular part (if UPLO = 'U') or
C             strictly upper triangular part (if UPLO = 'L') is not
C             referenced.
C
C     LDG     INTEGER
C             The leading dimension of array G.  LDG >= MAX(1,N).
C
C     Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
C             The leading N-by-N upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             must contain the upper triangular part or lower triangular
C             part, respectively, of the symmetric matrix Q.
C             The strictly lower triangular part (if UPLO = 'U') or
C             strictly upper triangular part (if UPLO = 'L') is not
C             referenced.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= MAX(1,N).
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
C             If INFO = 0, the leading 2N-by-2N part of this array
C             contains the Hamiltonian or symplectic matrix of the
C             problem.
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,2*N).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal
C             condition number of the given matrix  A.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1          if DICO = 'C';
C             LDWORK >= MAX(2,4*N) if DICO = 'D'.
C             For optimum performance LDWORK should be larger, if
C             DICO = 'D'.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
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             = i:  if the leading i-by-i (1 <= i <= N) upper triangular
C                   submatrix of A is singular in discrete-time case;
C             = N+1:  if matrix A is numerically singular in discrete-
C                   time case.
C
C     METHOD
C
C     For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1)
C     is constructed.
C     For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or
C     (3) - the inverse of the matrix in (2) - is constructed.
C
C     NUMERICAL ASPECTS
C
C     The discrete-time case needs the inverse of the matrix A, hence
C     the routine should not be used when A is ill-conditioned.
C                               3
C     The algorithm requires 0(n ) floating point operations in the
C     discrete-time case.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004,
C     Aug. 2011.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, HINV, UPLO
      INTEGER           INFO, LDA, LDG, LDQ, LDS, LDWORK, N
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*),
     $                  S(LDS,*)
C     .. Local Scalars ..
      LOGICAL           DISCR, LHINV, LQUERY, LUPLO
      INTEGER           I, J, MAXWRK, MINWRK, N2, NJ, NP1
      DOUBLE PRECISION  ANORM, RCOND
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGECON, DGEMM, DGETRF, DGETRI, DGETRS,
     $                  DLACPY, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO = 0
      N2 = N + N
      DISCR = LSAME( DICO, 'D' )
      LUPLO = LSAME( UPLO, 'U' )
      IF( DISCR ) THEN
         LHINV = LSAME( HINV, 'D' )
      ELSE
         LHINV = .FALSE.
      END IF
C
C     Test the input scalar arguments.
C
      IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN
         INFO = -1
      ELSE IF( DISCR ) THEN
         IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) )
     $      INFO = -2
      END IF
      IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN
         INFO = -12
      ELSE
         MINWRK = MAX( 2, 4*N )
         LQUERY = LDWORK.EQ.-1
         IF( ( LDWORK.LT.1 .OR. ( DISCR .AND. LDWORK.LT.MINWRK ) ) .AND.
     $       .NOT.LQUERY ) THEN
            INFO = -15
         ELSE IF( DISCR ) THEN
C
C           Compute workspace.
C           (Note: Comments in the code beginning "Workspace:" describe
C           the minimal amount of workspace needed at that point in the
C           code, as well as the preferred amount for good performance.
C           NB refers to the optimal block size for the immediately
C           following subroutine, as returned by ILAENV.)
C
            CALL DGETRI( N, A, LDA, IWORK, DWORK, -1, INFO )
            MAXWRK = MAX( MINWRK, INT( DWORK(1) ) )
         ELSE
            MAXWRK = 1
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02MU', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         IF ( DISCR ) DWORK(2) = ONE
         RETURN
      END IF
C
C     The code tries to exploit data locality as much as possible.
C
      IF ( .NOT.LHINV ) THEN
         CALL DLACPY( 'Full', N, N, A, LDA, S, LDS )
C
C        Construct Hamiltonian matrix in the continuous-time case, or
C        prepare symplectic matrix in (3) in the discrete-time case:
C
C        Construct full Q in S(N+1:2*N,1:N) and change the sign, and
C        construct full G in S(1:N,N+1:2*N) and change the sign.
C
         DO 200 J = 1, N
            NJ = N + J
            IF ( LUPLO ) THEN
C
               DO 20 I = 1, J
                  S(N+I,J) = -Q(I,J)
   20          CONTINUE
C
               DO 40 I = J + 1, N
                  S(N+I,J) = -Q(J,I)
   40          CONTINUE
C
               DO 60 I = 1, J
                  S(I,NJ) = -G(I,J)
   60          CONTINUE
C
               DO 80 I = J + 1, N
                  S(I,NJ) = -G(J,I)
   80          CONTINUE
C
            ELSE
C
               DO 100 I = 1, J - 1
                  S(N+I,J) = -Q(J,I)
  100          CONTINUE
C
               DO 120 I = J, N
                  S(N+I,J) = -Q(I,J)
  120          CONTINUE
C
               DO 140 I = 1, J - 1
                  S(I,NJ) = -G(J,I)
  140          CONTINUE
C
               DO 180 I = J, N
                  S(I,NJ) = -G(I,J)
  180          CONTINUE
C
            END IF
  200    CONTINUE
C
         IF ( .NOT.DISCR ) THEN
C
            DO 240 J = 1, N
               NJ = N + J
C
               DO 220 I = 1, N
                  S(N+I,NJ) = -A(J,I)
  220          CONTINUE
C
  240       CONTINUE
C
            DWORK(1) = ONE
         END IF
      END IF
C
      IF ( DISCR ) THEN
C
C        Construct the symplectic matrix (2) or (3) in the discrete-time
C        case.
C
         NP1 = N + 1
C
         IF ( LHINV ) THEN
C
C           Put  A'  in  S(N+1:2*N,N+1:2*N).
C
            DO 260 I = 1, N
               CALL DCOPY( N, A(I, 1), LDA, S(NP1,N+I), 1 )
  260       CONTINUE
C
         END IF
C
C        Compute the norm of the matrix A.
C
         ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK )
C
C        Compute the LU factorization of A.
C
         CALL DGETRF( N, N, A, LDA, IWORK, INFO )
C
C        Return if INFO is non-zero.
C
         IF( INFO.GT.0 ) THEN
            DWORK(2) = ZERO
            RETURN
         END IF
C
C        Compute the reciprocal of the condition number of A.
C        Workspace: need 4*N.
C
         CALL DGECON( '1-norm', N, A, LDA, ANORM, RCOND, DWORK,
     $                IWORK(NP1), INFO )
C
C        Return if the matrix is singular to working precision.
C
         IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN
            INFO = N + 1
            DWORK(2) = RCOND
            RETURN
         END IF
C
         IF ( LHINV ) THEN
C
C           Compute S in (2).
C
C           Construct full Q in S(N+1:2*N,1:N).
C
            IF ( LUPLO ) THEN
               DO 270 J = 1, N - 1
                  CALL DCOPY( J, Q(1,J), 1, S(NP1,J), 1 )
                  CALL DCOPY( N-J, Q(J,J+1), LDQ, S(NP1+J,J), 1 )
  270          CONTINUE
               CALL DCOPY( N, Q(1,N), 1, S(NP1,N), 1 )
            ELSE
               CALL DCOPY( N, Q(1,1), 1, S(NP1,1), 1 )
               DO 280 J = 2, N
                  CALL DCOPY( J-1, Q(J,1), LDQ, S(NP1,J), 1 )
                  CALL DCOPY( N-J+1, Q(J,J), 1, S(N+J,J), 1 )
  280          CONTINUE
            END IF
C
C           Compute the solution matrix  X  of the system  X*A = Q  by
C                                                                    -1
C           solving  A'*X' = Q and transposing the result to get  Q*A  .
C
            CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1),
     $                   LDS, INFO )
C
            DO 300 J = 1, N - 1
               CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS )
  300       CONTINUE
C
C           Construct full G in S(1:N,N+1:2*N).
C
            IF ( LUPLO ) THEN
               DO 310 J = 1, N - 1
                  CALL DCOPY( J, G(1,J), 1, S(1,N+J), 1 )
                  CALL DCOPY( N-J, G(J,J+1), LDG, S(J+1,N+J), 1 )
  310          CONTINUE
               CALL DCOPY( N, G(1,N), 1, S(1,N2), 1 )
            ELSE
               CALL DCOPY( N, G(1,1), 1, S(1,NP1), 1 )
               DO 320 J = 2, N
                  CALL DCOPY( J-1, G(J,1), LDG, S(1,N+J), 1 )
                  CALL DCOPY( N-J+1, G(J,J), 1, S(J,N+J), 1 )
  320          CONTINUE
            END IF
C                            -1
C           Compute  A' + Q*A  *G  in  S(N+1:2N,N+1:2N).
C
            CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $                  S(NP1,1), LDS, S(1,NP1), LDS, ONE, S(NP1,NP1),
     $                  LDS )
C
C           Compute the solution matrix  Y  of the system  A*Y = G.
C
            CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1),
     $                   LDS, INFO )
C
C           Compute the inverse of  A  in situ.
C           Workspace: need N;  prefer N*NB.
C
            CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO )
C                  -1
C           Copy  A    in  S(1:N,1:N).
C
            CALL DLACPY( 'Full', N, N, A, LDA, S, LDS )
C
         ELSE
C
C           Compute S in (3) using the already prepared part.
C
C           Compute the solution matrix  X'  of the system  A*X' = -G
C                                                       -T
C           and transpose the result to obtain  X = -G*A  .
C
            CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1),
     $                   LDS, INFO )
C
            DO 340 J = 1, N - 1
               CALL DSWAP( N-J, S(J+1,N+J), 1, S(J,NP1+J), LDS )
  340       CONTINUE
C                           -T
C           Compute  A + G*A  *Q  in  S(1:N,1:N).
C
            CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $                  S(1,NP1), LDS, S(NP1, 1), LDS, ONE, S, LDS )
C
C           Compute the solution matrix  Y  of the system  A'*Y = -Q.
C
            CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1),
     $                   LDS, INFO )
C
C           Compute the inverse of  A  in situ.
C           Workspace: need N;  prefer N*NB.
C
            CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO )
C                  -T
C           Copy  A    in  S(N+1:2N,N+1:2N).
C
            DO 360 J = 1, N
               CALL DCOPY( N, A(J,1), LDA, S(NP1,N+J), 1 )
  360       CONTINUE
C
         END IF
         DWORK(1) = MAXWRK
         DWORK(2) = RCOND
      END IF
C
C *** Last line of SB02MU ***
      RETURN
      END