!=======================================================================
!
!  Calculate the cubic spline for a set of points (X,Y)
!  (c.f. Numerical Recipes, Chapter 3.3: Spline Routine)
!
!  Given the arrays X and Y (size N) containing a tabulated
!  function, i.e., Y(I)=f(X(I)), with X(1) < X(2) < ... < X(N),
!  and given values YP1 and YPN for the first derivative of the
!  interpolating function at points 1 and N, respectively, this
!  routine returns an array Y2 of length N, which contains the
!  second derivatives of the interpolating function at the
!  tabulated points X(I). If YP1 and/or YPN are equal to 1.0E+30
!  or larger, the routine is signalled to set the corresponding
!  boundary condition for a natural spline, with zero second
!  derivative at that boundary.
!
!  I/O parameters:
!  Input   X   = vector for independent variable; dimension X(1:N)
!  Input   Y   = vector for x-dependent variable; dimension Y(1:N)
!  Input   N   = dimension of vectors containing tabulated function
!  Input   YP1 = 1st derivative of the function at point 1
!  Input   YPN = 1st derivative of the function at point N
!  Output  Y2  = 2nd derivative of the function; dimension Y2(1:N)
!
!-----------------------------------------------------------------------
SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2)

   USE HEALPIX_TYPES
   IMPLICIT NONE

   INTEGER(KIND=I4B), INTENT(IN)  :: N
   REAL(KIND=DP),     INTENT(IN)  :: X(1:N),Y(1:N)
   REAL(KIND=DP),     INTENT(IN)  :: YP1,YPN
   REAL(KIND=DP),     INTENT(OUT) :: Y2(1:N)

   INTEGER(KIND=I4B) :: I
   REAL(KIND=DP)     :: P,QN,SIG,U(1:N),UN

   IF(YP1.GE.1.0D30) THEN
!     The lower boundary condition is either set to be "natural"
      Y2(1)=0.0D0
      U(1)=0.0D0
   ELSE
!     or to have a specified first derivative
      Y2(1)=-0.5D0
      U(1)=(3.0D0/(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1)
   ENDIF

!  This is the decomposition loop of the tridiagonal algorithm
!  Y2 and U are used for temporary storage of the decomposed factors
   DO I=2,N-1
      SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
      P=SIG*Y2(I-1)+2.0D0
      Y2(I)=(SIG-1.0D0)/P
      U(I)=(6.0D0*((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
   ENDDO

   IF(YPN.GE.1.0D30) THEN
!     The upper boundary condition is either set to be "natural"
      QN=0.0D0
      UN=0.0D0
   ELSE
!     or to have a specified first derivative
      QN=0.5D0
      UN=(3.0D0/(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1)))
   ENDIF

   Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.0D0)
!  This is the back-substitution loop of the tridiagonal algorithm
   DO I=N-1,1,-1
      Y2(I)=Y2(I)*Y2(I+1)+U(I)
   ENDDO

   RETURN
END SUBROUTINE SPLINE
!=======================================================================

!=======================================================================
!
!  Perform a cubic spline interpolation evaluated at the point X
!  (c.f. Numerical Recipes, Chapter 3.3: Splint Routine,
!        Numerical Recipes, Chapter 3.4: Hunt Routine)
!
!  Given the arrays XA and YA (size N) containing a tabulated
!  function, i.e., YA(I) = f(XA(I)), with the XA(I)'s in order,
!  and given the array Y2A produced by the SPLINE routine, this
!  routine returns a cubic spline interpolated value Y.
!
!  I/O parameters:
!  Input   XA  = vector for independent variable; dimension XA(1:N)
!  Input   YA  = vector for x-dependent variable; dimension YA(1:N)
!  Input   Y2A = 2nd derivative of the function; dimension Y2A(1:N)
!  Input   N   = dimension of input vectors
!  Input   X   = x-value at which Y is to be interpolated
!  Output  Y   = result of interpolation
!
!-----------------------------------------------------------------------
SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)

   USE HEALPIX_TYPES
   IMPLICIT NONE

   INTEGER(KIND=I4B), INTENT(IN)  :: N
   REAL(KIND=DP),     INTENT(IN)  :: XA(1:N),YA(1:N),Y2A(1:N)
   REAL(KIND=DP),     INTENT(IN)  :: X
   REAL(KIND=DP),     INTENT(OUT) :: Y

   LOGICAL           :: ASCND
   INTEGER(KIND=I4B) :: JLO,JHI,JMID,INC
   REAL(KIND=DP)     :: A,B

   JLO=0
   JHI=0

!  ASCND is TRUE if the table values are in ascending order, FALSE otherwise
   ASCND=XA(N).GT.XA(1)

!  Find the interval XA(JLO) <= X <= XA(JLO+1) = XA(JHI)
   IF(JLO.LE.0 .OR. JLO.GT.N) THEN
!     Input guess not useful, go immediately to bisection
      JLO=0
      JHI=N+1
      GOTO 3
   ENDIF

!  Set the hunting increment
   INC=1

   IF(X.GE.XA(JLO) .EQV. ASCND) THEN
!     Hunt up:
 1    JHI=JLO+INC
      IF(JHI.GT.N) THEN
!        Done hunting, since off the end of the table
         JHI=N+1
      ELSE IF(X.GE.XA(JHI) .EQV. ASCND) THEN
!        Not done hunting...
         JLO=JHI
!        ...so double the increment...
         INC=INC+INC
!        ...and try again
         GOTO 1
      ENDIF
!  Done hunting, value bracketed
   ELSE
      JHI=JLO
!     Hunt down:
 2    JLO=JHI-INC
      IF(JLO.LT.1) THEN
!        Done hunting, since off the end of the table
         JLO=0
      ELSE IF(X.LT.XA(JLO) .EQV. ASCND) THEN
!        Not done hunting...
         JHI=JLO
!        ...so double the increment...
         INC=INC+INC
!        ...and try again
         GOTO 2
      ENDIF
!  Done hunting, value bracketed
   ENDIF

 3 IF((JHI-JLO).NE.1) THEN
!     Hunt is done, so begin the final bisection phase
      JMID=(JHI+JLO)/2
      IF(X.GT.XA(JMID) .EQV. ASCND) THEN
         JLO=JMID
      ELSE
         JHI=JMID
      ENDIF
      GOTO 3
   ENDIF

   IF(JLO.EQ.0) THEN
      JLO=1
      JHI=2
   ENDIF
   IF(JLO.EQ.N) THEN
      JLO=N-1
      JHI=N
   ENDIF

!  JLO and JHI now bracket the input value X
!  The cubic spline polynomial is now evaluated
   A=(XA(JHI)-X)/(XA(JHI)-XA(JLO))
   B=(X-XA(JLO))/(XA(JHI)-XA(JLO))
   Y=A*YA(JLO)+B*YA(JHI)+((A**3-A)*Y2A(JLO)+(B**3-B)*Y2A(JHI)) &
    & *((XA(JHI)-XA(JLO))**2)/6.0D0

   RETURN
END SUBROUTINE SPLINT
!=======================================================================

!=======================================================================
!
!  Copied from Numerical Recipes
!
!  Given a tabulated function YA (of size MxN) and tabulated independent
!  variables X1A (M values) and X2A (N values), this routine constructs
!  one-dimensional natural cubic splines of the rows of YA and returns
!  the second derivatives in the array Y2A.
!
!-----------------------------------------------------------------------
SUBROUTINE SPLIE2(X1A,X2A,YA,M,N,Y2A)

   USE HEALPIX_TYPES
   IMPLICIT NONE

   INTEGER(KIND=I4B), INTENT(IN)  :: M,N
   REAL(KIND=DP),     INTENT(IN)  :: X1A(1:M),X2A(1:N),YA(1:M,1:N)
   REAL(KIND=DP),     INTENT(OUT) :: Y2A(1:M,1:N)

   INTEGER(KIND=I4B) :: I,J
   REAL(KIND=DP)     :: YTMP(1:N),Y2TMP(1:N)

   DO I=1,M
      DO J=1,N
         YTMP(J)=YA(I,J)
      ENDDO
!     Values of 1.0D30 indicate a natural spline
      CALL SPLINE(X2A,YTMP,N,1.0D30,1.0D30,Y2TMP)
      DO J=1,N
         Y2A(I,J)=Y2TMP(J)
      ENDDO
   ENDDO

   RETURN
END SUBROUTINE SPLIE2
!=======================================================================

!=======================================================================
!
!  Given X1A, X2A, YA, M & N (as described in SPLIE2) and the resulting
!  Y2A (as produced by that routine), and given a desired interpolating
!  point (X1,X2), this routine returns an interpolated function value Y
!  by performing a bicubic spline interpolation.
!
!-----------------------------------------------------------------------
SUBROUTINE SPLIN2(X1A,X2A,YA,Y2A,M,N,X1,X2,Y)

   USE HEALPIX_TYPES
   IMPLICIT NONE

   INTEGER(KIND=I4B), INTENT(IN)  :: M,N
   REAL(KIND=DP),     INTENT(IN)  :: X1A(1:M),X2A(1:N),YA(1:M,1:N),Y2A(1:M,1:N)
   REAL(KIND=DP),     INTENT(IN)  :: X1,X2
   REAL(KIND=DP),     INTENT(OUT) :: Y

   INTEGER(KIND=I4B) :: I,J
   REAL(KIND=DP)     :: YTMP(1:N),Y2TMP(1:N),YYTMP(1:M),YY2TMP(1:M)

!  Perform M evaluations of the row splines constructed by
!  SPLIE2 using the one-dimensional spline evaluator SPLINT
   DO I=1,M
      DO J=1,N
         YTMP(J)=YA(I,J)
         Y2TMP(J)=Y2A(I,J)
      ENDDO
      CALL SPLINT(X2A,YTMP,Y2TMP,N,X2,YYTMP(I))
   ENDDO

!  Construct the one-dimensional column spline and evaluate it
!  Values of 1.0D30 indicate a natural spline
   CALL SPLINE(X1A,YYTMP,M,1.0D30,1.0D30,YY2TMP)
   CALL SPLINT(X1A,YYTMP,YY2TMP,M,X1,Y)

   RETURN
END SUBROUTINE SPLIN2
!=======================================================================


! Like array_constructor_6.f90, but check integer(8) iterators.
! { dg-do run }
program main
  integer (kind = 8) :: i, l8, u8, step8
  integer (kind = 4) :: l4, step4
  integer (kind = 8), parameter :: big = 10000000000_8

  l4 = huge (l4)
  u8 = l4 + 10_8
  step4 = 2
  call test ((/ (i, i = l4, u8, step4) /), l4 + 0_8, u8, step4 + 0_8)

  l8 = big
  u8 = big * 20
  step8 = big
  call test ((/ (i, i = l8, u8, step8) /), l8, u8, step8)

  u8 = big + 100
  l8 = big
  step4 = -20
  call test ((/ (i, i = u8, l8, step4) /), u8, l8, step4 + 0_8)

  u8 = big * 40
  l8 = big * 20
  step8 = -big * 2
  call test ((/ (i, i = u8, l8, step8) /), u8, l8, step8)

  u8 = big
  l4 = big / 100
  step4 = -big / 500
  call test ((/ (i, i = u8, l4, step4) /), u8, l4 + 0_8, step4 + 0_8)

  u8 = big * 40 + 200
  l4 = 200
  step8 = -big
  call test ((/ (i, i = u8, l4, step8) /), u8, l4 + 0_8, step8)
contains
  subroutine test (a, l, u, step)
    integer (kind = 8), dimension (:), intent (in) :: a
    integer (kind = 8), intent (in) :: l, u, step
    integer (kind = 8) :: i
    integer :: j

    j = 1
    do i = l, u, step
      if (a (j) .ne. i) call abort
      j = j + 1
    end do
    if (size (a, 1) .ne. j - 1) call abort
  end subroutine test
end program main


      subroutine basecode_test
      implicit none
      integer imax
      parameter (imax = 8)
      integer icode,iarray(imax),ibase,i,j
      logical done

      ibase = 3
c      do i=0,ibase**3-1
c         call decode(i,iarray,ibase,imax)
c         call encode(icode,iarray,ibase,imax)
c         write(*,*) i,icode,"=",(iarray(j),j=1,imax)
c      enddo
      icode = 0
      call decode(icode,iarray,ibase,imax)
      iarray(2)=1
      iarray(4)=1
      iarray(5)=1
      iarray(7)=1
      done = .false.
      write(*,*) (iarray(j),j=1,imax)
      do while (.not. done)
         write(*,*) (iarray(j),j=1,imax)
         call increment_array(iarray,imax,ibase,done)
      enddo
      end

      subroutine EnCode(icode,iarray,ibase,imax)
c******************************************************************************
c     Turns array of integers (iarray) values range (0,ibase-1) into a single
c     integer icode. icode = Sum[ iarray(k) * ibase^k]
c******************************************************************************
      implicit none
c
c     Arguments
c
      integer imax           !Number of integers to encode
      integer icode          !Output encoded value of iarray
      integer iarray(imax)   !Input values to be encoded
      integer ibase          !Base for encoding

c
c     Local
c
      integer i
c-----
c  Begin Code
c-----
      icode = 0
      do i = 1, imax
         if (iarray(i) .ge. 0 .and. iarray(i) .lt. ibase) then
            icode = icode + iarray(i)*ibase**(i-1)
         else
            write(*,*) 'Error invalid number to be encoded',i,iarray(i)
         endif
      enddo
      end

      subroutine DeCode(icode,iarray,ibase,imax)
c******************************************************************************
c     Decodes icode, into base integers used to create it.
c     integer icode. icode = Sum[ iarray(k) * ibase^k]
c******************************************************************************
      implicit none
c
c     Arguments
c
      integer imax           !Number of integers to encode
      integer icode          !Input encoded value of iarray
      integer iarray(imax)   !Output decoded values icode
      integer ibase          !Base for encoding

c
c     Local
c
      integer i, jcode
c-----
c  Begin Code
c-----
      jcode = icode          !create copy for use
      do i =  imax, 1, -1
         iarray(i) = 0
         do while (jcode .ge. ibase**(i-1) .and. iarray(i) .lt. ibase)
            jcode = jcode-ibase**(i-1)
            iarray(i)=iarray(i)+1
         enddo
      enddo
      end

      subroutine increment_array(iarray,imax,ibase,done)
c************************************************************************
c     Increments iarray
c************************************************************************
      implicit none
c
c     Arguments
c
      integer imax          !Input, number of elements in iarray
      integer ibase         !Base for incrementing, 0 is skipped
      integer iarray(imax)  !Output:Array of values being incremented
      logical done          !Output:Set when no more incrementing
c
c     Local
c
      integer i,j
      logical found
c-----
c  Begin Code
c-----
      found = .false.
      i = 1
      do while (i .le. imax .and. .not. found)
         if (iarray(i) .eq. 0) then    !don't increment this
            i=i+1
         elseif (iarray(i) .lt. ibase-1) then
            found = .true.
            iarray(i)=iarray(i)+1
         else
            iarray(i)=1
            i=i+1
         endif
      enddo
      done = .not. found
      end


*DECK CSROOT
      SUBROUTINE CSROOT (XR, XI, YR, YI)
C***BEGIN PROLOGUE  CSROOT
C***SUBSIDIARY
C***PURPOSE  Compute the complex square root of a complex number.
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (CSROOT-S)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     (YR,YI) = complex sqrt(XR,XI)
C
C***SEE ALSO  EISDOC
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   811101  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  CSROOT
      REAL XR,XI,YR,YI,S,TR,TI,PYTHAG
C
C     BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
C***FIRST EXECUTABLE STATEMENT  CSROOT
      TR = XR
      TI = XI
      S = SQRT(0.5E0*(PYTHAG(TR,TI) + ABS(TR)))
      IF (TR .GE. 0.0E0) YR = S
      IF (TI .LT. 0.0E0) S = -S
      IF (TR .LE. 0.0E0) YI = S
      IF (TR .LT. 0.0E0) YR = 0.5E0*(TI/YI)
      IF (TR .GT. 0.0E0) YI = 0.5E0*(TI/YR)
      RETURN
      END


c subroutine lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c dimension of           theta(l),  pb(id,nm+1),  wlfim(4*l*(nm+1))
c arguments
c
c purpose                given n and l, routine lfim calculates
c                        the normalized associated legendre functions
c                        pbar(n,m,theta) for m=0,...,n and theta(i)
c                        for i=1,...,l where
c
c                        pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)
c                        /(2*factorial(n+m)))*sin(theta)**m/(2**n*
c                        factorial(n)) times the (n+m)th derivative of
c                        (x**2-1)**n with respect to x=cos(theta)
c
c usage                  call lfim (init,theta,l,n,nm,pb,id,wlfim)
c
c arguments
c on input               init
c                        = 0
c                            initialization only - using parameters
c                            l, nm and array theta, subroutine lfim
c                            initializes array wlfim for subsequent
c                            use in the computation of the associated
c                            legendre functions pb. initialization
c                            does not have to be repeated unless
c                            l, nm, or array theta are changed.
c                        = 1
c                            subroutine lfim uses the array wlfim that
c                            was computed with init = 0 to compute pb.
c
c                        theta
c                          an array that contains the colatitudes
c                          at which the associated legendre functions
c                          will be computed. the colatitudes must be
c                          specified in radians.
c
c                        l
c                          the length of the theta array. lfim is
c                          vectorized with vector length l.
c
c                        n
c                          nonnegative integer, less than nm, specifying
c                          degree of pbar(n,m,theta). subroutine lfim
c                          must be called starting with n=0. n must be
c                          incremented by one in subsequent calls and
c                          must not exceed nm.
c
c                        nm
c                          the maximum value of n and m
c
c                        id
c                          the first dimension of the two dimensional
c                          array pb as it appears in the program that
c                          calls lfim. (see output parameter pb)
c
c                        wlfim
c                          an array with length 4*l*(nm+1) which
c                          must be initialized by calling lfim
c                          with init=0 (see parameter init)  it
c                          must not be altered between calls to
c                          lfim.
c
c
c on output              pb
c                          a two dimensional array with first
c                          dimension id in the program that calls
c                          lfim. the second dimension of pb must
c                          be at least nm+1. starting with n=0
c                          lfim is called repeatedly with n being
c                          increased by one between calls. on each
c                          call, subroutine lfim computes
c                          = pbar(m,n,theta(i)) for m=0,...,n and
c                          i=1,...l.
c
c                        wlfim
c                          array containing values which must not
c                          be altered unless l, nm or the array theta
c                          are changed in which case lfim must be
c                          called with init=0 to reinitialize the
c                          wlfim array.
c
c special conditions     n must be increased by one between calls
c                        of lfim in which n is not zero.
c
c precision              single
c
c
c algorithm              routine lfim calculates pbar(n,m,theta) using
c                        a four term recurrence relation. (unpublished
c                        notes by paul n. swarztrauber)
c
      SUBROUTINE DLFIM(INIT,THETA,L,N,NM,PB,ID,WLFIM)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION PB
      DOUBLE PRECISION WLFIM
      DIMENSION PB(1),WLFIM(1)
c
c     total length of wlfim is 4*l*(nm+1)
c
      LNX = L* (NM+1)
      IW1 = LNX + 1
      IW2 = IW1 + LNX
      IW3 = IW2 + LNX
      CALL DLFIM1(INIT,THETA,L,N,NM,ID,PB,WLFIM,WLFIM(IW1),WLFIM(IW2),
     +           WLFIM(IW3),WLFIM(IW2))
      RETURN
      END
      SUBROUTINE DLFIM1(INIT,THETA,L,N,NM,ID,P3,PHZ,PH1,P1,P2,CP)
      DOUBLE PRECISION THETA
      DOUBLE PRECISION P3
      DOUBLE PRECISION PHZ
      DOUBLE PRECISION PH1
      DOUBLE PRECISION P1
      DOUBLE PRECISION P2
      DOUBLE PRECISION CP
      DOUBLE PRECISION SSQRT2
      DOUBLE PRECISION SQ5S6
      DOUBLE PRECISION SQ1S6
      DOUBLE PRECISION FN
      DOUBLE PRECISION TN
      DOUBLE PRECISION CN
      DOUBLE PRECISION FM
      DOUBLE PRECISION FNPM
      DOUBLE PRECISION FNMM
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION CC
      DOUBLE PRECISION DD
      DOUBLE PRECISION EE
      DIMENSION P1(L,1),P2(L,1),P3(ID,1),PHZ(L,1),PH1(L,1),CP(1),
     +          THETA(1)

      NMP1 = NM + 1
      IF (INIT.NE.0) GO TO 5
      SSQRT2 = 1.D0/SQRT(2.D0)
      DO 10 I = 1,L
          PHZ(I,1) = SSQRT2
   10 CONTINUE
      DO 15 NP1 = 2,NMP1
          NH = NP1 - 1
          CALL DALFK(NH,0,CP)
          DO 16 I = 1,L
              CALL DLFPT(NH,0,THETA(I),CP,PHZ(I,NP1))
   16     CONTINUE
          CALL DALFK(NH,1,CP)
          DO 17 I = 1,L
              CALL DLFPT(NH,1,THETA(I),CP,PH1(I,NP1))
   17     CONTINUE
   15 CONTINUE
      RETURN
    5 IF (N.GT.2) GO TO 60
      IF (N-1) 25,30,35
   25 DO 45 I = 1,L
          P3(I,1) = PHZ(I,1)
   45 CONTINUE
      RETURN
   30 DO 50 I = 1,L
          P3(I,1) = PHZ(I,2)
          P3(I,2) = PH1(I,2)
   50 CONTINUE
      RETURN
   35 SQ5S6 = SQRT(5.D0/6.D0)
      SQ1S6 = SQRT(1.D0/6.D0)
      DO 55 I = 1,L
          P3(I,1) = PHZ(I,3)
          P3(I,2) = PH1(I,3)
          P3(I,3) = SQ5S6*PHZ(I,1) - SQ1S6*P3(I,1)
          P1(I,1) = PHZ(I,2)
          P1(I,2) = PH1(I,2)
          P2(I,1) = PHZ(I,3)
          P2(I,2) = PH1(I,3)
          P2(I,3) = P3(I,3)
   55 CONTINUE
      RETURN
   60 NM1 = N - 1
      NP1 = N + 1
      FN = DBLE(N)
      TN = FN + FN
      CN = (TN+1.D0)/ (TN-3.D0)
      DO 65 I = 1,L
          P3(I,1) = PHZ(I,NP1)
          P3(I,2) = PH1(I,NP1)
   65 CONTINUE
      IF (NM1.LT.3) GO TO 71
      DO 70 MP1 = 3,NM1
          M = MP1 - 1
          FM = DBLE(M)
          FNPM = FN + FM
          FNMM = FN - FM
          TEMP = FNPM* (FNPM-1.D0)
          CC = SQRT(CN* (FNPM-3.D0)* (FNPM-2.D0)/TEMP)
          DD = SQRT(CN*FNMM* (FNMM-1.D0)/TEMP)
          EE = SQRT((FNMM+1.D0)* (FNMM+2.D0)/TEMP)
          DO 70 I = 1,L
              P3(I,MP1) = CC*P1(I,MP1-2) + DD*P1(I,MP1) - EE*P3(I,MP1-2)
   70 CONTINUE
   71 FNPM = FN + FN - 1.D0
      TEMP = FNPM* (FNPM-1.D0)
      CC = SQRT(CN* (FNPM-3.D0)* (FNPM-2.D0)/TEMP)
      EE = SQRT(6.D0/TEMP)
      DO 75 I = 1,L
          P3(I,N) = CC*P1(I,N-2) - EE*P3(I,N-2)
   75 CONTINUE
      FNPM = FN + FN
      TEMP = FNPM* (FNPM-1.D0)
      CC = SQRT(CN* (FNPM-3.D0)* (FNPM-2.D0)/TEMP)
      EE = SQRT(2.D0/TEMP)
      DO 80 I = 1,L
          P3(I,N+1) = CC*P1(I,N-1) - EE*P3(I,N-1)
   80 CONTINUE
      DO 90 MP1 = 1,NP1
          DO 90 I = 1,L
              P1(I,MP1) = P2(I,MP1)
              P2(I,MP1) = P3(I,MP1)
   90 CONTINUE
      RETURN
      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_bravais
      use m_juDFT
!----------------------------------------------------------------------!
! given a Bravais-matrix amat, determine the lattice system and type   !
! (idsyst,idtype)                                              gb`05   !
!----------------------------------------------------------------------!
      CONTAINS
      SUBROUTINE bravais(
     >                   amat,
     <                   idsyst,idtype)

      USE m_constants

      IMPLICIT NONE

      REAL,    INTENT (IN)  :: amat(3,3)
      INTEGER, INTENT (OUT) :: idsyst,idtype

      REAL a(3),b(3),c(3),g(3),e(3),f(3)
      REAL sa, sb, sc, al, be, ga
      REAL, PARAMETER :: eps = 1.0e-5
      REAL, PARAMETER :: thrd = -1./3.
      INTEGER i,j,k
      LOGICAL l_ab, l_bc, l_ac, al_be, be_ga, al_ga

      CHARACTER (len=12) :: c_sy(7)
      CHARACTER (len=15) :: c_ty(6)
      c_sy = (/'cubic       ','tetragonal  ','orthorhombic',
     +         'hexagonal   ','trigonal    ','monoclinic  ',
     +         'triclinic   '/)
      c_ty = (/'primitive      ','body centered  ','face centered  ',
     +         'A-face centered','B-face centered','C-face centered'/)

      a(:) = amat(:,1) ; b(:) = amat(:,2) ; c(:) = amat(:,3)
      sa = SQRT( DOT_PRODUCT( a, a) )
      sb = SQRT( DOT_PRODUCT( b, b) )
      sc = SQRT( DOT_PRODUCT( c, c) )
      al = DOT_PRODUCT( b, c) / ( sb * sc )
      be = DOT_PRODUCT( a, c) / ( sa * sc )
      ga = DOT_PRODUCT( b, a) / ( sb * sa )
      write (oUnit,*) sa,sb,sc,al,be,ga

      l_ab = .false. ; l_bc = .false. ; l_ac = .false.
      al_be = .false. ; be_ga = .false. ; al_ga = .false.
      IF ( ABS(sa-sb) < eps ) l_ab = .true.
      IF ( ABS(sb-sc) < eps ) l_bc = .true.
      IF ( ABS(sa-sc) < eps ) l_ac = .true.
      IF ( ABS(al-be) < eps ) al_be = .true.
      IF ( ABS(be-ga) < eps ) be_ga = .true.
      IF ( ABS(al-ga) < eps ) al_ga = .true.

      idsyst = 99 ; idtype = 99

      IF (l_ab.AND.l_bc)  THEN                ! all sides equal
        IF (al_be.AND.be_ga) THEN             ! all angles equal
          IF ( ABS(al) < eps )  THEN          ! alpha = 90 deg
            idsyst = 1 ; idtype = 1           !       --> simple cubic
          ELSEIF ( ABS(al-thrd) < eps ) THEN  ! alpha = 109 deg
            idsyst = 1 ; idtype = 2           !       --> bcc
          ELSEIF ( ABS(al-0.5) < eps ) THEN   ! alpha = 60  deg
            idsyst = 1 ; idtype = 3           !       --> fcc
          ELSE
            idsyst = 5 ; idtype = 1           ! -->  trigonal (rhomboedric)
          ENDIF
        ELSEIF (al_be.OR.be_ga.OR.al_ga) THEN ! two angles equal
          idsyst = 2 ; idtype = 2             !  -->  tetragonal - I
        ELSE
          idsyst = 3 ; idtype = 2             !  -->  orthorhombic - I
        ENDIF
      ENDIF

      IF (idsyst == 99) THEN                  ! continue the search

      IF (l_ab.OR.l_bc.OR.l_ac)  THEN         ! two sides equal
                                              ! hexagonal or tetragonal or base-centered
        IF (al_be.AND.be_ga) THEN             ! all angles equal
          IF ( ABS(al) < eps )  THEN          ! alpha = 90  deg
            idsyst = 2 ; idtype = 1           !       --> simple tetragonal
          ELSE
            IF (l_ab) THEN
             idsyst = 6 ; idtype = 6          ! special monoclinic - C
            ELSEIF (l_bc) THEN
             idsyst = 6 ; idtype = 4          ! special monoclinic - A
            ELSEIF (l_ac) THEN
             idsyst = 6 ; idtype = 5          ! special monoclinic - B
            ENDIF
          ENDIF
        ELSEIF (.NOT.(al_be.OR.be_ga.OR.al_ga)) THEN  ! all angles different
          idsyst = 7 ; idtype = 1                     ! triclinic
        ELSE
          IF ( al_be.AND.( ABS(ABS(ga)-0.5) < eps ) ) THEN
            idsyst = 4 ; idtype = 1 ! hexagonal
          ELSEIF ((ABS(al)<eps).OR.(ABS(be)<eps).OR.(ABS(ga)<eps)) THEN  ! one is 90 deg
            IF ( (ABS(al)<eps).AND.(ABS(be)<eps) ) THEN
              idsyst = 3 ; idtype = 6                         ! orthorhombic - C
            ELSEIF ( (ABS(ga)<eps).AND.(ABS(be)<eps) ) THEN
              idsyst = 3 ; idtype = 4                         ! orthorhombic - A
            ELSEIF ( (ABS(al)<eps).AND.(ABS(ga)<eps) ) THEN
              idsyst = 3 ; idtype = 5                         ! orthorhombic - B
            ELSE
              idsyst = 6 ; idtype = 1            ! simple monoclinic
            ENDIF
          ELSE                                                           ! none is 90 deg
            IF (al_be) THEN
             idsyst = 6 ; idtype = 6             ! monoclinic - C
            ELSEIF (be_ga) THEN
             idsyst = 6 ; idtype = 4             ! monoclinic - A
            ELSEIF (al_ga) THEN
             idsyst = 6 ; idtype = 5             ! monoclinic - B
            ELSE
              idsyst = 6 ; idtype = 1            ! simple monoclinic
            ENDIF
          ENDIF
        ENDIF

      ELSE                                    ! orthorhombic or tricinic or monoclinic

        IF (al_be.AND.be_ga) THEN             ! all angles equal
          IF ( ABS(al) < eps )  THEN          ! angles 90 deg
           idsyst = 3 ; idtype = 1            ! --> simple orthorhombic
          ELSE
           idsyst = 7 ; idtype = 1            ! triclinic
          ENDIF
        ELSEIF (.NOT.(al_be.OR.be_ga.OR.al_ga)) THEN ! all angles different
          e = a + b - c ; f = b + c - a ; g = a + c - b
          IF ( (DOT_PRODUCT( e, f) == 0).AND.
     +         (DOT_PRODUCT( e, g) == 0).AND.
     +         (DOT_PRODUCT( g, f) == 0) )  THEN
             idsyst = 3 ; idtype = 3          ! --> face-centered orthorhombic
          ELSE
             idsyst = 7 ; idtype = 1         ! triclinic
          ENDIF
        ELSE
          idsyst = 6 ; idtype = 1   ! simple monoclinic
        ENDIF

      ENDIF

      ENDIF

      IF ((idsyst == 99).OR.(idtype == 99) ) CALL juDFT_error("bravais!"
     +     ,calledby ="bravais")
 10   WRITE(oUnit,*) c_ty(idtype),' ',c_sy(idsyst)

      END SUBROUTINE bravais
      END MODULE m_bravais


program fqbox
    implicit none
    integer, parameter  :: dp=kind(0.d0)

    integer, parameter :: res=100, iterations=10000
    real(dp) :: dt=0.1
    real(dp) :: V(res, res)=0.0_dp
    complex(dp) :: phi(res, res)=(1.0_dp, 1.0_dp), a(res, res)=(0.0_dp, 0.0_dp), grad(res, res)=(0.0_dp, 0.0_dp)

    integer :: i1

    phi(1, :) = (0.0_dp, 0.0_dp)
    phi(res, :) = (0.0_dp, 0.0_dp)
    phi(:, 1) = (0.0_dp, 0.0_dp)
    phi(:, res) = (0.0_dp, 0.0_dp)

    phi = phi/sqrt(sum(conjg(phi)*phi))

    do i1 = 1, iterations
        phi = phi - sum(conjg(a)*phi)*a
        grad(2:res - 1, 2:res - 1) = phi(3:res, 2:res - 1) &
                                   + phi(1:res - 2, 2:res - 1) &
                                   + phi(2:res - 1, 3:res) &
                                   + phi(2:res - 1, 1:res - 2) &
                                   - 4*phi(2:res - 1, 2:res - 1)
        phi = phi + dt*(grad - V*phi)
        phi = phi/sqrt(sum(conjg(phi)*phi))
    end do
end program fqbox


! NOTE: This will only works for orthorombic cell
SUBROUTINE calc_dr_periodic( LL, r0, Npoints, lingrid, dr )
  IMPLICIT NONE
  !
  REAL(8) :: LL(3)
  REAL(8) :: r0(3)
  INTEGER :: Npoints
  REAL(8) :: lingrid(3,Npoints)
  REAL(8) :: dr(Npoints)
  !
  INTEGER :: ip
  REAL(8) :: Lx, Ly, Lz
  REAL(8) :: xx1, xx2, xx3, xx
  REAL(8) :: yy1, yy2, yy3, yy
  REAL(8) :: zz1, zz2, zz3, zz

  Lx = LL(1)
  Ly = LL(2)
  Lz = LL(3)

  DO ip = 1, Npoints
    xx1 = abs( lingrid(1,ip) - r0(1) )
    xx2 = abs( r0(1) + Lx - lingrid(1,ip) )
    xx3 = abs( lingrid(1,ip) - r0(1) - Lx)
    xx  = minval( (/xx1,xx2,xx3/) )
    !
    yy1 = abs( lingrid(2,ip) - r0(2) )
    yy2 = abs( r0(2) + Ly - lingrid(2,ip) )
    yy3 = abs( lingrid(2,ip) - r0(2) - Ly)
    yy  = minval( (/yy1,yy2,yy3/) )
    !
    zz1 = abs( lingrid(3,ip) - r0(3) )
    zz2 = abs( r0(3) + Lz - lingrid(3,ip) )
    zz3 = abs( lingrid(3,ip) - r0(3) - Lz)
    zz  = minval( (/zz1,zz2,zz3/) )
    !
    dr(ip) = sqrt( xx**2 + yy**2 + zz**2 )
  ENDDO

END SUBROUTINE


       subroutine qinit(meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q,maux,aux)
      implicit none

      integer meqn, mbc, mx, my, maux
      double precision xlower, ylower, dx, dy
      double precision q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

      integer i,j, blockno
      double precision xlow, ylow, w

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      double precision init_radius, init_location(2)
      common /initradius_comm/ init_radius, init_location

      double precision ravg, x0, y0, xp,yp, zp,xc,yc, r, r0,B

      blockno = 0

      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            xlow = xlower + (i-1)*dx
            ylow = ylower + (j-1)*dy
            call cellave2(blockno,xlow,ylow,dx,dy,w)
            q(1,i,j) = w

c            xc = xlow + dx/2.d0
c            yc = ylow + dy/2.d0
c            call mapc2m_annulus(xc,yc,xp,yp,zp)
c
c            x0 = init_location(1)
c            y0 = init_location(2)
c
c            r0 = init_radius
c            B = 1 !! maximum value
c            r = B + (-B/r0**2)*((xp - x0)**2 + (yp-y0)**2)
c            if (r .gt. 0) then
c               q(1,i,j) = r
c            else
c               q(1,i,j) = 0
c            endif
         enddo
      enddo

      return
      end


subroutine sdrop(len,wid,dens,vs,musum,sdrsa,sdrback,dback)

 implicit none
 real::pi,len,wid,rlarge,rasp,ex,a,mu,vs,dens,musum
 real::smom,smoma,smomback   ! Seismic moment
 real::scale  ! scale to adjust seismic moment 20180822
 real::s,smat,sback,dsmat,dback,sdrsa,sdrback  ! area,slip,sigma
 real::gam1,gam2,gam3,ss,dback0
 integer::nasp

  pi=acos(-1.0)
  s=len*wid  ! fault area km2
  rlarge=sqrt(s/pi)
  ! vs (m/s), dens(kg/m3), mu(N/m2)
  mu=dens*vs*vs

! Seismic Moment Nm
  if(s.le.400) then
     ! Somerville et al. 1999
     ex=3./2. ; smom=((s/2.23*1.0e15)**ex)*1.0e-7
  else if(s.le.1800) then
     ! Irikura & Miyake 2001
     smom=((s/4.24*1.0e11)**2)*1.0e-7
  else
     ! Murotani et al. 2015
     smom=s*1.0e17
  endif

  if(len.le.25.and.wid.lt.15) then
     nasp=1
  else
     if(len.lt.70) then
        nasp=2
        ! Sa1:Sa2=16:6
        gam1=sqrt(16./22.) ; gam2=sqrt(6./22.)
        ss=gam1**3+gam2**3
     else
        nasp=3
        ! Sa1:Sa2:Sa3=2:1:1
        gam1=sqrt(2./4.) ; gam2=sqrt(1./4.) ; gam3=sqrt(1./4.)
        ss=gam1**3+gam2**3+gam3**3
     endif
  endif

  write(6,*) ' Number of Asperities : ',nasp

  ex=1./3. ; a=(2.46*(smom*1.0e7)**ex)*1.0e10 ! short-period level
  rasp=(7.*pi/4.0)*smom/a/rlarge*vs*vs*1.0e-6 ! asp radius (km)
  smat=pi*rasp*rasp ! total asperity area (km^2)
  if(nasp.ge.3) then
     smat=0.22*s
     rasp=sqrt(smat/pi)
  endif
  dsmat=2.0*smom/mu/(s*1.0e6) ! average slip (m) in asperities
  smoma=mu*dsmat*smat*1.0e6  ! total moment of asperities (Nm)
  smomback=smom-smoma ! background moment (Nm)
  sback=s-smat  ! background area(km2)
  dback=smomback/mu/(sback*1.0e6)  ! slip(m) in background

  scale=mu*s*1.0e6/musum
  write(6,*) '  scale = ',scale
  dback0=dback
  dback=dback*scale ! 20180822  ! adjust to seismic moment

  ! Effective stress drop in asperities
  sdrsa=(7./16.)*smom*1.0e-15/(rasp*rasp*rlarge) ! MPa
  ! 20180904 adjust difference in Vs and Dens
  if(scale>1.0) then
     sdrsa=sdrsa*scale
  endif
  ! Three asperities : Sa = S x 22%
  if(nasp.ge.3) then
     sdrsa=14.1 ! 3.1MPa/22%
  endif

  if(nasp.eq.1) then
     sdrback=dback0/dsmat/wid*sqrt(smat)*sdrsa  ! MPa
  else
     sdrback=dback0/dsmat/wid*sqrt(pi)*rasp*ss*sdrsa
  endif
  write(6,*) ' Seismic Moment (Nm) : ', smom
  write(6,*) ' Short-period level (Nm/s/s) : ',a
  write(6,*) ' Total asperity area (m^2) : ',smat
  write(6,*) ' Asperity stress drop (MPa) : ',sdrsa
  write(6,*) ' Asperity average slip (m) : ',dsmat
  write(6,*) ' Background stress drop (MPa) : ',sdrback
  write(6,*) ' Background moment (Nm) : ' ,smomback
  write(6,*) ' Background slip (m) : ' ,dback

  return
end subroutine sdrop


module FindMax
	interface
		subroutine FindSpectrumMax(t, f, w, nu_min, nu_max, alpha, beta, numax)
			use kind_defs
			implicit none
			real(dbl), intent(in) :: t(:), f(:), w(:), nu_min, nu_max
			real(dbl), intent(out) :: alpha, beta, numax
		end subroutine
	end interface
end module

subroutine FindSpectrumMax(t, f, w, nu_min_in, nu_max, alpha, beta, numax)
	use kind_defs
	use timeseries, only : CalcAlphaBeta
	implicit none
	real(dbl), intent(in) :: t(:), f(:), w(:), nu_min_in, nu_max
	real(dbl), intent(out) :: alpha, beta, numax
	real(dbl), external :: Amp
	real(dbl), parameter :: eps = 1e-5_dbl
	real(dbl) :: dF, Amax, nu, A, nu_min, nu1, nu2
	real(dbl) :: priv_max, priv_numax
	real(dbl) :: fmin
	integer :: j, Nspec

	! Set the crude spacing to 1/(4*T):
	! FIXME: Serious wast of time!
	! We are doing *2 more points!
	nu_min = nu_min_in
	dF = 0.25e6_dbl/(maxval(t)-minval(t))
	if (nu_min == 0) nu_min = dF ! Don't calculate nu=0
	Nspec = ceiling((nu_max-nu_min)/dF)+1
	if (Nspec <= 0 .or. nu_min < 0 .or. nu_max < 0) stop "Wrong frequencies!"

	! Calcultate spectrum:
	Amax = 0.0_dbl
	!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(j,alpha,beta,nu,A,priv_max,priv_numax)
	priv_max = 0.0_dbl
	!$OMP DO SCHEDULE(STATIC)
	do j = 1,Nspec
		nu = nu_min+dF*(j-1)

		! Calculate amplitude:
		call CalcAlphaBeta(t,f,w,nu,alpha,beta)
		A = alpha**2 + beta**2

		! Save the maximum amplitude in this part:
		if (A > priv_max) then
			priv_max = A
			priv_numax = nu
		endif

		! Write the progress:
		call Progress2(Nspec)
	enddo
	!$OMP END DO NOWAIT
	! Compare the maximums found by different threads:
	!$OMP FLUSH
	if (priv_max > Amax) then
		!$OMP CRITICAL
			! Save only the very highest peak:
			if (priv_max > Amax) then
				Amax = priv_max
				numax = priv_numax
			endif
		!$OMP END CRITICAL
	endif
	!$OMP END PARALLEL

	! Be careful -- If using old version of the PGI-compiler, you should at max use -O1 as optimization.
	! Otherwise, the above will fail, as Amax is not used later on. OR the problem can be
	! worked around by using Amax for something:
	alpha = Amax - Amax

	! Minimize to find the true maximum:
	nu1 = max(nu_min, numax-dF)
	nu2 = min(nu_max, numax+dF)
	numax = fmin(nu1, nu2, Amp, eps)

	! Calculate the max alpha and beta corresponding to the found frequency:
	call CalcAlphaBeta(t,f,w,numax,alpha,beta)
end subroutine FindSpectrumMax

! Function to use to minimize in the CLEAN-algorithm:
function Amp(nu)
	use kind_defs
	use timeseries, only : t, f, w, CalcAlphaBeta
	implicit none
	real(dbl), intent(in) :: nu
	real(dbl) :: Amp
	real(dbl) :: alpha, beta

	call CalcAlphaBeta(t,f,w,nu,alpha,beta)
	Amp = -alpha**2 - beta**2
end function Amp


*> \brief \b ZLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLAEV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION   CS1, RT1, RT2
*       COMPLEX*16         A, B, C, SN1
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix
*>    [  A         B  ]
*>    [  CONJG(B)  C  ].
*> On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
*> eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
*> eigenvector for RT1, giving the decomposition
*>
*> [ CS1  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]
*> [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16
*>         The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX*16
*>         The (1,2) element and the conjugate of the (2,1) element of
*>         the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is COMPLEX*16
*>         The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] RT1
*> \verbatim
*>          RT1 is DOUBLE PRECISION
*>         The eigenvalue of larger absolute value.
*> \endverbatim
*>
*> \param[out] RT2
*> \verbatim
*>          RT2 is DOUBLE PRECISION
*>         The eigenvalue of smaller absolute value.
*> \endverbatim
*>
*> \param[out] CS1
*> \verbatim
*>          CS1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] SN1
*> \verbatim
*>          SN1 is COMPLEX*16
*>         The vector (CS1, SN1) is a unit right eigenvector for RT1.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  RT1 is accurate to a few ulps barring over/underflow.
*>
*>  RT2 may be inaccurate if there is massive cancellation in the
*>  determinant A*C-B*B; higher precision or correctly rounded or
*>  correctly truncated arithmetic would be needed to compute RT2
*>  accurately in all cases.
*>
*>  CS1 and SN1 are accurate to a few ulps barring over/underflow.
*>
*>  Overflow is possible only if RT1 is within a factor of 5 of overflow.
*>  Underflow is harmless if the input data is 0 or exceeds
*>     underflow_threshold / macheps.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   CS1, RT1, RT2
      COMPLEX*16         A, B, C, SN1
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   T
      COMPLEX*16         W
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLAEV2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG
*     ..
*     .. Executable Statements ..
*
      IF( ABS( B ).EQ.ZERO ) THEN
         W = ONE
      ELSE
         W = DCONJG( B ) / ABS( B )
      END IF
      CALL DLAEV2( DBLE( A ), ABS( B ), DBLE( C ), RT1, RT2, CS1, T )
      SN1 = W*T
      RETURN
*
*     End of ZLAEV2
*
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_poly_residuals
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the roots of a polynomial expressed in the
! monomial basis using the fast algorithm described in:
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    degree of the polynomial
!
!  COEFFS          COMPLEX(8) array of dimension (N+1)
!                    coefficients of polynomial ordered from highest
!                    degree coefficient to lowest degree
!
!  ROOTS           COMPLEX(8) array of dimension (N)
!                    computed roots
!
! OUTPUT VARIABLES:
!
!  RESIDUALS       REAL(8) array of dimension (N)
!                    residuals
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_poly_residuals(N,COEFFS,ROOTS,K,RESIDUALS)

  implicit none

  ! input variables
  integer, intent(in) :: N
  integer, intent(inout) :: K
  complex(8), intent(in) :: COEFFS(N+1)
  complex(8), intent(inout) :: ROOTS(N)
  real(8), intent(inout) :: RESIDUALS(N)

  ! compute variables
  integer :: ii, jj, kk
  complex(8) :: p, dp

  ! check K
  if (K<0) then
    K = 0
  end if

  ! newton corrections
  do kk = 1,K

    ! loop through roots
    do ii = 1,N

      ! inside unit circle
      if (abs(ROOTS(ii)) <= 1d0) then

        ! horners rule
        p = COEFFS(1)
        dp = dble(N)*p
        do jj = 1,(N-1)
          p = ROOTS(ii)*p + COEFFS(jj+1)
          dp = ROOTS(ii)*dp + dble(N-jj)*COEFFS(jj+1)
        end do
        p = ROOTS(ii)*p + COEFFS(N+1)

        ! store residual
        ROOTS(ii) = ROOTS(ii) - p/dp

      ! outside the unit circle
      else

        ! horners rule
        p = COEFFS(N+1)
        dp = COEFFS(N)
        do jj = 1,(N-1)
          p = p/ROOTS(ii) + COEFFS(N+1-jj)
          dp = dp/ROOTS(ii) + dble(jj+1)*COEFFS(N-jj)
        end do
        p = p/ROOTS(ii) + COEFFS(1)

        ! store residual
        ROOTS(ii) = ROOTS(ii) - ROOTS(ii)*p/dp

      end if

    end do

  end do

  ! loop through roots
  do ii = 1,N

    ! inside unit circle
    if (abs(ROOTS(ii)) <= 1d0) then

      ! horners rule
      p = COEFFS(1)
      dp = dble(N)*p
      do jj = 1,(N-1)
        p = ROOTS(ii)*p + COEFFS(jj+1)
        dp = ROOTS(ii)*dp + dble(N-jj)*COEFFS(jj+1)
      end do
      p = ROOTS(ii)*p + COEFFS(N+1)

      ! store residual
      RESIDUALS(ii) = abs(p/dp)

    ! outside the unit circle
    else

      ! horners rule
      p = COEFFS(N+1)
      dp = COEFFS(N)
      do jj = 1,(N-1)
        p = p/ROOTS(ii) + COEFFS(N+1-jj)
        dp = dp/ROOTS(ii) + dble(jj+1)*COEFFS(N-jj)
      end do
      p = p/ROOTS(ii) + COEFFS(1)

      ! store residual
      RESIDUALS(ii) = abs(ROOTS(ii)*p/dp)

    end if

  end do

end subroutine z_poly_residuals


C$Procedure      RECCYL ( Rectangular to cylindrical coordinates )

      SUBROUTINE RECCYL (RECTAN, R, LONG, Z )

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

      DOUBLE PRECISION RECTAN(3)
      DOUBLE PRECISION R
      DOUBLE PRECISION LONG
      DOUBLE PRECISION Z

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  -------------------------------------------------
C     RECTAN     I   Rectangular coordinates of a point.
C     R          O   Distance of the point from Z axis.
C     LONG       O   Angle (radians) of the point from XZ plane
C     Z          O   Height of the point above XY plane.
C
C$ Detailed_Input
C
C     RECTAN     Rectangular coordinates of the point of interest.
C
C$ Detailed_Output
C
C     R          Distance of the point of interest from Z axis.
C
C     LONG       Cylindrical angle (in radians) of the point of
C                interest from XZ plane. The LONG range is [0, 2pi].
C
C     Z          Height of the point above XY plane.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine transforms the coordinates of a point from
C     rectangular to cylindrical coordinates.
C
C$ Examples
C
C     Below are two tables.
C
C     Listed in the first table (under X(1), X(2) and X(3) ) are a
C     number of points whose rectangular coordinates coorindates are
C     taken from the set {-1, 0, 1}.
C
C     The result of the code fragment
C
C          CALL RECCYL ( X, R, LONG, Z )
C
C          Use the SPICELIB routine CONVRT to convert the angular
C          quantities to degrees
C
C          CALL CONVRT ( LONG, 'RADIANS', 'DEGREES', LONG )
C
C     are listed to 4 decimal places in the second parallel table under
C     R (radius), LONG (longitude), and  Z (same as rectangular Z
C     coordinate).
C
C
C       X(1)       X(2)     X(3)        R         LONG     Z
C       --------------------------      -------------------------
C       0.0000     0.0000   0.0000      0.0000    0.0000   0.0000
C       1.0000     0.0000   0.0000      1.0000    0.0000   0.0000
C       0.0000     1.0000   0.0000      1.0000   90.0000   0.0000
C       0.0000     0.0000   1.0000      0.0000    0.0000   1.0000
C      -1.0000     0.0000   0.0000      1.0000  180.0000   0.0000
C       0.0000    -1.0000   0.0000      1.0000  270.0000   0.0000
C       0.0000     0.0000  -1.0000      0.0000    0.0000  -1.0000
C       1.0000     1.0000   0.0000      1.4142   45.0000   0.0000
C       1.0000     0.0000   1.0000      1.0000    0.0000   1.0000
C       0.0000     1.0000   1.0000      1.0000   90.0000   1.0000
C       1.0000     1.0000   1.0000      1.4142   45.0000   1.0000
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.2, 22-AUG-2001 (EDW)
C
C        Corrected ENDIF to END IF. Obsolete Revisions section
C        deleted.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     rectangular to cylindrical coordinates
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION TWOPI

C
C     Local Variables
C
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION BIG

C
C     Use temporary variables for computing R.
C
      BIG = MAX( DABS(RECTAN(1)), DABS(RECTAN(2)) )

C
C     Convert to cylindrical coordinates
C
      Z = RECTAN(3  )

      IF ( BIG .EQ. 0 ) THEN
         R      = 0.D0
         LONG   = 0.D0
      ELSE
         X      = RECTAN(1) / BIG
         Y      = RECTAN(2) / BIG

         R      = BIG * DSQRT (X*X + Y*Y)

         LONG   = DATAN2 (Y,X)
      END IF

      IF ( LONG .LT. 0.D0) THEN
         LONG = LONG + TWOPI()
      END IF

      RETURN
      END


      SUBROUTINE SNCNDN(UU,EMMC,SN,CN,DN)
      PARAMETER (CA=.0003)
      LOGICAL BO
      DIMENSION EM(13),EN(13)
      EMC=EMMC
      U=UU
      IF(EMC.NE.0.)THEN
        BO=(EMC.LT.0.)
        IF(BO)THEN
          D=1.-EMC
          EMC=-EMC/D
          D=SQRT(D)
          U=D*U
        ENDIF
        A=1.
        DN=1.
        DO 11 I=1,13
          L=I
          EM(I)=A
          EMC=SQRT(EMC)
          EN(I)=EMC
          C=0.5*(A+EMC)
          IF(ABS(A-EMC).LE.CA*A)GO TO 1
          EMC=A*EMC
          A=C
11      CONTINUE
1       U=C*U
        SN=SIN(U)
        CN=COS(U)
        IF(SN.EQ.0.)GO TO 2
        A=CN/SN
        C=A*C
        DO 12 II=L,1,-1
          B=EM(II)
          A=C*A
          C=DN*C
          DN=(EN(II)+A)/(B+A)
          A=C/B
12      CONTINUE
        A=1./SQRT(C**2+1.)
        IF(SN.LT.0.)THEN
          SN=-A
        ELSE
          SN=A
        ENDIF
        CN=C*SN
2       IF(BO)THEN
          A=DN
          DN=CN
          CN=A
          SN=SN/D
        ENDIF
      ELSE
        CN=1./COSH(U)
        DN=CN
        SN=TANH(U)
      ENDIF
      RETURN
      END


SUBROUTINE periodic_tdma_solver(a,b,c,d,X,N)
    IMPLICIT NONE
    integer, intent(in)::N
    double precision, intent(in), dimension(1:N)::a,b,c,d
    double precision, intent(out),dimension(1:N)::X
    double precision, allocatable,dimension(:) :: p , q , r , w , u , x1
    INTEGER :: i
    double precision::sum1=0.0d0

    allocate(p(2:N),q(1:N),r(1:N-2),w(1:N-2),u(1:N-1),x1(1:N))

    q(1) = b(1)
    w(1) = a(1) / b(1)
    u(1) = c(1) / b(1)
    r(1) = c(N)
    sum1 = r(1) * w(1)

    DO i = 2 , N-2
      p(i) = a(i)
      q(i) = b(i) - p(i) * u(i-1)
      u(i) = c(i) / q(i)
      w(i) = - p(i) * w(i-1) / q(i)
      r(i) = - r(i-1) * u(i-1)
      sum1  = sum1 + r(i) * w(i)
    ENDDO

    i = N-1
    p(i) = a(i)
    q(i) = b(i) - p(i) * u(i-1)
    u(i) = (c(i) - p(i) * w(i-1)) / q(i)
    p(N) = a(N) - r(N-2) * u(N-2)
    q(N) = b(N) - sum1 - p(N) * u(N-1)
    x1(1) = d(1) / q(1)
!
    DO i = 2 , N-1
      x1(i) = (d(i) - p(i) * x1(i-1)) / q(i)
    ENDDO
    sum1 = 0.0d0
    DO i = 1 , N-2
      sum1 = sum1 + r(i) * x1(i)
    ENDDO
    x1(N) = (d(N) - sum1 - p(N) * x1(N-1)) / q(N)
    X(N) = x1(N)

    X(N-1) = x1(N-1) - u(N-1) * X(N)

    DO i = N-2 , 1 , -1
      X(i) = x1(i) - u(i) * X(i+1) - w(i) * X(N)
    ENDDO

    deallocate(x1,p,q,u,w,r)

END SUBROUTINE periodic_tdma_solver

subroutine Periodic_OUCS3(temp,tempzi,N,dzi)
    implicit none

    integer::j,N
    double precision::alpha1=0.0d0
    double precision::b2=1.0d0
    double precision,dimension(-2:2)::Const
    double precision::b1,b3, dzi
    double precision,dimension(1:N)::an,bn,cn,Rn
    double precision,intent(in),dimension(0:N)::temp
    double precision,intent(out),dimension(0:N)::tempzi

    Const(-2)=-0.183205192/4.0d0+alpha1/300.0d0
    Const( 2)= 0.183205192/4.0d0+alpha1/300.0d0
    Const(-1)=-1.57557379/2.0d0+alpha1/30.0d0
    Const( 1)= 1.57557379/2.0d0+alpha1/30.0d0
    Const( 0)=-11.0d0*alpha1/150.0d0

    b2= 1.0d0
    b1= 0.3793894912d0-alpha1/60.0d0
    b3= 0.3793894912d0+alpha1/60.0d0

    an=b1
    bn=b2
    cn=b3

    do j=2,N-2
      Rn(j)=(Const(-2)*temp(j-2)+Const(-1)*temp(j-1)+Const(0)*temp(j)&
             &+Const(1)*temp(j+1)+Const(2)*temp(j+2))/dzi
    enddo
    Rn(1)  =(Const(-2)*temp(N-1)+Const(-1)*temp(N)+Const(0)*temp(1)&
             &+Const(1)*temp(2)+Const(2)*temp(3))/dzi
    Rn(N)  =(Const(-2)*temp(N-2)+Const(-1)*temp(N-1)+Const(0)*temp(N)&
             &+Const(1)*temp(1)+Const(2)*temp(2))/dzi
    Rn(N-1)=(Const(-2)*temp(N-3)+Const(-1)*temp(N-2)+Const(0)*temp(N-1)&
             &+Const(1)*temp(0)+Const(2)*temp(1))/dzi
    call periodic_tdma_solver(an,bn,cn,Rn,tempzi(1:N),N)
    tempzi(0)=tempzi(N)
end subroutine Periodic_OUCS3

subroutine Periodic_O3CS(temp,tempzi3,N,dzi3)     ! for 3rd derivative
    implicit none

    integer::j,N
    double precision::b2=1.0d0
    double precision,dimension(-2:2)::Const
    double precision::b1, b3, dzi3
    double precision,dimension(1:N)::an,bn,cn,Rn
    double precision,intent(in),dimension(0:N)::temp
    double precision,intent(out),dimension(0:N)::tempzi3

    Const(-2)= -0.957036d0      !+alpha1/300.0d0
    Const( 2)=  0.957036d0      !+alpha1/300.0d0
    Const(-1)=  1.914072d0      !+alpha1/30.0d0
    Const( 1)= -1.914072d0      !+alpha1/30.0d0
    Const( 0)=  0d0         !-11.0d0*alpha1/150.0d0

    b2= 1.0d0
    b1= 0.457036d0     !-alpha1/60.0d0
    b3= 0.457036d0     !+alpha1/60.0d0

    an=b1
    bn=b2
    cn=b3

    do j=2,N-2
      Rn(j)=(Const(-2)*temp(j-2)+Const(-1)*temp(j-1)+Const(0)*temp(j)&
             &+Const(1)*temp(j+1)+Const(2)*temp(j+2))/dzi3
    enddo
    Rn(1)  =(Const(-2)*temp(N-1)+Const(-1)*temp(N)+Const(0)*temp(1)&
             &+Const(1)*temp(2)+Const(2)*temp(3))/dzi3
    Rn(N)  =(Const(-2)*temp(N-2)+Const(-1)*temp(N-1)+Const(0)*temp(N)&
             &+Const(1)*temp(1)+Const(2)*temp(2))/dzi3
    Rn(N-1)=(Const(-2)*temp(N-3)+Const(-1)*temp(N-2)+Const(0)*temp(N-1)&
             &+Const(1)*temp(0)+Const(2)*temp(1))/dzi3
    call periodic_tdma_solver(an,bn,cn,Rn,tempzi3(1:N),N)
    tempzi3(0)=tempzi3(N)
end subroutine Periodic_O3CS

subroutine convection(spatial_conv, UUx, u, N, dx)
    IMPLICIT NONE
    integer::i
    integer, intent(in)::spatial_conv, N
    double precision, intent(in)::dx
    double precision, intent(out), dimension(0:N)::UUx
    double precision, intent(in), dimension(0:N)::u
    !*** Convection term****!
    select case(spatial_conv)
       case(1)
       !CD2
           do i = 1,N-1
         UUx(i) = (u(i+1)**2 - u(i-1)**2)/2d0/dx/2d0
           enddo
           UUx(N) = (u(1)**2 - u(N-1)**2)/2d0/dx/2d0
           UUx(0) = UUx(N)

       case(2)
       !UD3
          UUx(1) = (3d0*u(1)**2 - 4d0*u(0)**2 + u(N-1)**2)/2d0/dx/2d0
          do i = 2,N
        UUx(i) = (3d0*u(i)**2 - 4d0*u(i-1)**2 + u(i-2)**2)/2d0/dx/2d0
          enddo
          UUx(0) = UUx(N)

       case(3)
       !CD4
           do i = 2,N-2
         UUx(i) = -(u(i+2)**2 - 8d0*u(i+1)**2 + 8d0*u(i-1)**2 - u(i-2)**2)/12d0/dx/2d0
           enddo
           UUx(1)   = -(u(3)**2 - 8d0*u(2)**2 + 8d0*u(N)**2   - u(N-1)**2)/12d0/dx/2d0
           UUx(N)   = -(u(2)**2 - 8d0*u(1)**2 + 8d0*u(N-1)**2 - u(N-2)**2)/12d0/dx/2d0
           UUx(N-1) = -(u(1)**2 - 8d0*u(0)**2 + 8d0*u(N-2)**2 - u(N-3)**2)/12d0/dx/2d0
           UUx(0) = UUx(N)
       case(4)
       !CD4 - Non_conservation form
           do i = 2,N-2
         UUx(i) = -u(i)*(u(i+2) - 8d0*u(i+1) + 8d0*u(i-1) - u(i-2))/12d0/dx
           enddo
           UUx(1)   = -u(1)*(u(3) - 8d0*u(2)+ 8d0*u(N)   - u(N-1))/12d0/dx
           UUx(N)   = -u(N)*(u(2) - 8d0*u(1)+ 8d0*u(N-1) - u(N-2))/12d0/dx
           UUx(N-1) = -u(N-1)*(u(1) - 8d0*u(0)+ 8d0*u(N-2) - u(N-3))/12d0/dx
           UUx(0) = UUx(N)
       case(5)
          ! call Dealias1d(u, usq,N)
          ! call ShiftAlign(u,usq,N)
           call Periodic_OUCS3(u*u,UUx,N,dx)
           UUx= UUx/2d0
    end select
end subroutine convection

subroutine dispersion(spatial_disp, Uxxx, u, N, dx3)
    IMPLICIT NONE
    integer::i
    integer, intent(in)::spatial_disp, N
    double precision, intent(in)::dx3
    double precision, intent(out),dimension(0:N)::Uxxx
    double precision, intent(in), dimension(0:N)::u
    ! Dispersion term
    select case(spatial_disp)
    !CD2
        case(1)
           do i = 2,N-2
         Uxxx(i) = (u(i+2) - 2d0*u(i+1) + 2d0*u(i-1) - u(i-2))/2d0/dx3
           enddo
           Uxxx(1) = (u(3) - 2d0*u(2) + 2d0*u(N) - u(N-1))/2d0/dx3
           Uxxx(N) = (u(2) - 2d0*u(1) + 2d0*u(N-1) - u(N-2))/2d0/dx3
           Uxxx(N-1) = (u(1) - 2d0*u(N) + 2d0*u(N-2) - u(N-3))/2d0/dx3
           Uxxx(0) = Uxxx(N)
    !CD4
        case(2)
           do i = 3,N-3
         Uxxx(i) = (-u(i+3) +8d0*u(i+2) - 13d0*u(i+1) + 13d0*u(i-1) - 8d0*u(i-2) + u(i-3))/8d0/dx3
           enddo
           Uxxx(2)   = (-u(5) +8d0*u(4) - 13d0*u(3) + 13d0*u(1) - 8d0*u(N)   + u(N-1))/8d0/dx3
           Uxxx(1)   = (-u(4) +8d0*u(3) - 13d0*u(2) + 13d0*u(N) - 8d0*u(N-1) + u(N-2))/8d0/dx3
           Uxxx(N)   = (-u(3) +8d0*u(2) - 13d0*u(1) + 13d0*u(N-1) - 8d0*u(N-2) + u(N-3))/8d0/dx3
           Uxxx(N-1) = (-u(2) +8d0*u(1) - 13d0*u(0) + 13d0*u(N-2) - 8d0*u(N-3) + u(N-4))/8d0/dx3
           Uxxx(N-2) = (-u(1) +8d0*u(0) - 13d0*u(N-1) + 13d0*u(N-3) - 8d0*u(N-4) + u(N-5))/8d0/dx3
           Uxxx(0)   = Uxxx(N)
    !O3CS
         case(3)
           call Periodic_O3CS(u,Uxxx,N,dx3)
       end select
endsubroutine dispersion


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_modcyli
      use m_juDFT

c     generates modified bessel functions I_m for a given x and
c     order m
c                Y.Mokrousov, 21 oct 2002
      CONTAINS
      SUBROUTINE modcyli(
     >                   m1,x,
     <                   iJ)

      USE m_constants, ONLY : pimach
      IMPLICIT NONE

      integer, intent  (in) :: m1
      real,    intent  (in) :: x
      real,    intent (out) :: iJ

      real, parameter :: zero = 0.0
      real, parameter :: twelve = 12.0

      integer :: mm,i,mass,m,j
      real    :: quot,sm,qm,iJ0,fact1,fact2,iiJ,nk,fact
      real, allocatable :: aux(:)

      intrinsic abs,int,sqrt

      m = int(abs(m1))

      iJ = 0.
      if (x.lt.zero)  CALL juDFT_error("x.lt.zero",calledby="modcyli")
      if (x.eq.zero) then
        if (m.eq.0) then
           iJ = 1.0
           return
        else
           iJ = 0.0
           return
        end if
      else
         sm = sqrt(real(m))
         qm = m*m
         if (x.le.twelve .and. x.le.4*sm) then
c            write (*,*) '<12,<4sqrt(n)'
            fact1 = 1.
            fact = 1.
            do i = 1,m
               fact = fact*i
            end do
            iJ = ((x/2.)**m)/fact
            fact2 = 1.
            do i=1,31
               fact1 = fact1*i
               fact2 = fact
               do j=1,i
                  fact2 = fact2*(m+j)
               end do
               iJ = iJ + ((x/2.)**m)*(((x*x)/4.)**i)/
     /              (fact1*fact2)
            end do
            return
         elseif (x.gt.twelve .and. x.ge.6*qm) then
c           write (*,*) '>12,>6n2'
            iJ = exp(x)/sqrt(2*pimach()*x)
            fact1 = 1.
            iiJ = 1.
            nk = 1.
            do i = 1,31
               fact1 = fact1*i
               nk = nk*(4*(m*m)-(2*i-1)*(2*i-1))
               iiJ = iiJ + ((-1)**i)*nk/(fact1*((8*x)**i))
            end do
            iJ = iJ*iiJ
            return
         else
            mass = int( m + 10 + x )
            allocate ( aux(0:mass) )
            aux(mass) = 0.0
            aux(mass-1) = 1.0e-22
            do i=mass-2,0,-1
               aux(i) = 2*(i+1)*aux(i+1)/x + aux(i+2)
c               if (i.lt.m .and. x.gt.6*qm .and. i.ne.0) then
c                  quot = aux(i)
c                  iJ = aux(m)/quot
c                  return
c               end if
            end do
            quot = aux(0)
            if (x.le.twelve) then
c               write (*,*) 'fucking here'
               fact1 = 1.
               iJ0 = 1.
               do i=1,31
                  fact1 = fact1*i
                  iJ0 = iJ0 + (((x*x)/4.)**i)/(fact1*fact1)
               end do
               iJ = aux(m)*iJ0/quot
               deallocate (aux)
               return
            elseif (x.gt.twelve) then
               iJ0 = exp(x)/sqrt(2*pimach()*x)
               fact1 = 1.
               iiJ = 1.
               nk = 1.
               do i = 1,31
                  fact1 = fact1*i
                  nk = nk*(-(2*i-1)*(2*i-1))
                  iiJ = iiJ + ((-1)**i)*nk/(fact1*((8*x)**i))
               end do
               iJ0 = iJ0*iiJ
               iJ = aux(m)*iJ0/quot
               deallocate (aux)
               return
            end if
         end if
      end if

      END SUBROUTINE modcyli
      END MODULE m_modcyli


c=======================================================================
c
c     GENNCH
c
c     Generate random value of Noncentral chi-square variable
c
c     Generates random deviate from the distribution of a noncentral
c     chisquare with DF degrees of freedom and noncentrality parameter
c     XNONC.
c
c-----------------------------------------------------------------------
c
c     Copyright (c) 2014 NumX
c     All rights reserved.
c
c     This software is the confidential and proprietary information
c     of NumX. You shall not disclose such Confidential
C     Information and shall use it only in accordance with the terms
c     of the licence agreement you entered into with NumX.
c
c     author: Yann Vernaz
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION gennch(df, xnonc)
c-----------------------------------------------------------------------
c
c     INPUT :
c      df    : degrees of freedom of the chisquare (>=1.0)       double
c      xnonc : noncentrality parameter of the chisquare (>=0)    double
c
c      Method
c
c     Uses fact that  noncentral chisquare  is  the  sum of a  chisquare
c     deviate with DF-1  degrees of freedom plus the  square of a normal
c     deviate with mean sqrt(XNONC) and standard deviation 1.
c
c-----------------------------------------------------------------------
c
c     scalar arguments
      DOUBLE PRECISION df, xnonc
c
c     external functions
c     changed these to call GENCHI and GENNOR directly
c      DOUBLE PRECISION genchi, gennor
c      EXTERNAL genchi, gennor
      DOUBLE PRECISION sgamma, snorm
      EXTERNAL sgamma, snorm
c
c     intrinsic functions
      INTRINSIC sqrt
c
c     changed abort to df < 1, and added case: df = 1
c     executable statements
c     changed this to call GENCHI and GENNOR directly
c      gennch = genchi(df-1.0) + gennor(sqrt(xnonc),1.0)**2
 10   IF (df.GE.1.000001) GO TO 20
c
c     case DF = 1.0
      gennch = (snorm() + sqrt(xnonc))**2
      GO TO 30
c
c     case DF > 1.0
 20   gennch = 2.0*sgamma((df-1.0)/2.0) + (snorm() + sqrt(xnonc))**2
 30   RETURN
      END
c
c=======================================================================


!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-422                                                         *
!    5765-C41                                                         *
!    (C) COPYRIGHT IBM CORP. 1995, 1997. ALL RIGHTS RESERVED.         *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
        program main
!
!   Purpose, to  find the cooling rate for a specified set of
!   points in an anisotropic rectangular beam, immersed in a constant
!   heat bath with a temperature of 0.
!
!   Routines called:
!     expand_temp_profile
!     get_diffusion_matrix
!     igamx2d
!     init_diffusion
!     initialize_rarray
!     initialize_scale
!     pdgemv
!     pdsyevx
!     rlocal_to_rglobal
!
        use parameters
        use scale
        use diffusion
        use fourier
        implicit none

        integer :: n, ix, jx, iy, jy, k, i, j, stat, it, ib, ig
        integer :: num_errors, lwork, ilwork
        integer, allocatable :: iwork(:)
        real(long), allocatable :: work(:)
!
!       a contains the sine expansion coefficients of the initial
!                temperature profile.
!       b contains the eigenvectors of the diffusion operator in the
!                sine function basis.
!       ab contains the initial temperature profile expanded in the
!                eigenvectors of the diffusion operator.
!       f contains the matrix elements of the diffusion operation in
!                sine function basis.
!       lambda contains the eigenvalues of the diffusion operator.
!
!       df contains the Fourier transform of the diffusion coefficient function.
!
        real(long), allocatable ::  lambda(:), xg(:,:)
        real(long), allocatable ::  gap(:)
        real(long) :: dum

        real(long), pointer :: f(:,:), b(:,:), a(:,:)
        type (g_index), pointer :: f_i, b_i, a_i
        integer :: f_d(DESC_DIM), b_d(DESC_DIM), a_d(DESC_DIM)

        real(long), pointer :: x(:,:), ab(:,:), abt(:,:)
        type (g_index), pointer :: x_i, ab_i, abt_i
        integer :: x_d(DESC_DIM), ab_d(DESC_DIM), abt_d(DESC_DIM)

        real(long), allocatable :: xsines(:,:), ysines(:,:), temp(:,:)
        integer, allocatable :: ifail(:), iclustr(:)
        integer :: biga_index, num_eigvalues, num_vectors, info

!
!   Read in the problem size, initialize the problem dimensions,
!   choose functional form for the spatially dependent heat diffusion
!   coefficients, choose funtional form of initial temperature distribution
!   and choose the number of points, in both space and time, of the solution
!   to print out.
!
        call init_diffusion
        num_errors = 0
!
!       Read in how many sine functions to include in both the
!            x and y directions.
!
!       Because we need to get the Fourier coefficients of the sums
!       and differences of the indices, we need to include twice as
!       many Fourier coefficients as the number of sine expansion coefficients.
!       Also, because the top and bottom halves of the Fourier
!       transform are identical,
!       an artifact of artificially extending the diffusion coefficient
!       function and the initial temperature distribution, we need to
!       double the number of Fourier coefficients again. Finally, the
!       extra sum of one comes from the fact that the sine function
!       expansion starts a 1 and the Fourier expansion starts at 0.
!

!  n is the order of the diffusion operator equation.
        n = dif_nx * dif_ny
!
!  Initialize BLACS and calculate default block sizes.
!
        call initialize_scale(n, biga_index)

!
!
!   Allocate room for the eigenvalues of diffusion operator.
!
        allocate( lambda(n), stat=stat)
        if( stat .ne. 0) num_errors = num_errors + 1

!
!   Allocate room for sines of x and y coordinates.
!
        allocate( xsines(dif_npts, dif_nx) , stat=stat )
        if( stat .ne. 0) num_errors = num_errors + 1

        allocate( ysines(dif_npts, dif_ny) , stat=stat )
        if( stat .ne. 0) num_errors = num_errors + 1

!
!   Allocate room for temperature history at selected points.
!
        allocate( temp(dif_npts, dif_ntemps) , stat=stat )
        if( stat .ne. 0) num_errors = num_errors + 1

!
!   Allocate room for global temperature profile expansion vector at time t.
!
        allocate( xg(1, n) , stat=stat )
        if( stat .ne. 0) num_errors = num_errors + 1

        call igamx2d(sc_icontext,'A',' ',1,1,num_errors,1,-1,-1,-1,            &
     &               -1,-1)
        if( num_errors .gt. 0 ) then
           if( sc_iam .eq. 0 ) then
               write(*,*) 'Error in allocating arrays in main'
               call blacs_abort(sc_icontext, 1)
           endif
        endif

!
!      A call to expand_temp_profile returns the sine expansion
!      coefficients of the initial temperature profile.
!
!
!  Get matrices.
!
!  Diffusion operator matrix.
        call initialize_rarray(f, f_d, f_i, n, n, biga_index)

!  Eigenvectors of diffusion operator matrix.
        call initialize_rarray(b, b_d, b_i, n, n, biga_index)

!  Initial temperature profile, in row vector.
        call initialize_rarray(a, a_d, a_i, 1, n, biga_index)

!  Initial temperature profile, in eigenfunction basis, in row vector.
        call initialize_rarray(ab, ab_d, ab_i, 1, n, biga_index)

!  Temperature profile, at time t, in eigenfunction basis, in row vector.
        call initialize_rarray(abt, abt_d, abt_i, 1, n, biga_index)

!  Temperarure profile in at time t in sine expansion basis, in row vector.
        call initialize_rarray(x, x_d, x_i, 1, n, biga_index)

!
!  Represent initial temperature in sine function expansion.
!
        call expand_temp_profile(a,a_i,a_d)
!
!  Here, we are calculating the initial set of coefficients
!  in the sine function expansion as given in equations 3 and 4 of
!  the discussion paper
!

!
!       The call to get_diffusion_matrix returns the diffusion
!        operator in the sine function basis.
!
        call get_diffusion_matrix(f,f_i,f_d)
!
!   This last call determines the matrix elements defined by equation 10
!   in the discussion paper.
!

!
!    Here we precalculate the sine functions, sin(kx) and sin(jy) used
!    in equation 13 of the discussion paper.
!    These sine functions are only evaluated at the points x and y for
!    which the solution is evaluated.
!

        do i = 1, dif_nx
          do j = 1, dif_npts
            xsines(j,i) = sqrt(2.d0/pi) * sin( i * dif_x(j))
          enddo
        enddo

        do i = 1, dif_ny
          do j = 1, dif_npts
            ysines(j,i) = sqrt(2.d0/pi) * sin( i * dif_y(j))
          enddo
        enddo

!
!  Allocate arrays for eigenvalue decomposition.
!
        allocate( ifail(n), stat=stat)
        if( stat .ne. 0) num_errors = num_errors + 1
        allocate( iclustr(n), stat=stat)
        if( stat .ne. 0) num_errors = num_errors + 1
        allocate( gap(sc_nnodes), stat=stat)
        if( stat .ne. 0) num_errors = num_errors + 1

!
!  Allocate scratch space for the symetric eigenvector solver.
!
        lwork = 20*n  + max( 5*n, n*(n+ sc_nnodes-1)/sc_nnodes )               &
     &         + n*( (n+ sc_nnodes-1)/sc_nnodes) + 2*f_d(MB_) * f_d(MB_)

        ilwork = 2*n + max((3*n+1+sc_nnodes),max(4*n,14))

        allocate( work(lwork) , stat=stat )
        if( stat .ne. 0) num_errors = num_errors + 1
        allocate( iwork(ilwork) , stat=stat )
        if( stat .ne. 0) num_errors = num_errors + 1

!
!   Test to see if we had any allocation errors.
!

        call igamx2d(sc_icontext,'A',' ',1,1,num_errors,1,-1,-1,-1,            &
     &               -1,-1)
        if( num_errors .gt. 0 ) then
           if( sc_iam .eq. 0 ) then
               write(*,*) 'Error in allocating arrays for pdsyevx in ',        &
     &                     'main'
               call blacs_abort(sc_icontext, 1)
           endif
        endif

        do i = 1, sc_nnodes
           gap(i) = 0.d0
        enddo
        do i = 1, n
           ifail(i) = 0
           iclustr(i) = 0
        enddo
!
! The call to pdsyevx will find both the eigenvalues and eigenvectors
! of the diffusion matrix operator f. The eigenvalues will be stored in
! the vector lambda and the corresponding eigenvectors will be stored in
! the matrix b.  The f and b matrices in the program correspond to the
! F and B matrices in equations 11 and 12 in the
! discussion paper.
!
!
        call pdsyevx('V','A','U',n,f,1,1,f_d,-1.d30,1.d30,0,n,                 &
     &        0.d0,num_eigvalues,num_vectors,lambda,1.d-5,b,1,1,b_d,           &
     &        work, lwork, iwork, ilwork, ifail, iclustr, gap, info)

        if( sc_iam .eq. 0) then
          if( info .ne. 0 ) then
             write(*,*) ' info is ', info
             call blacs_abort(sc_icontext, 1)
          endif
        endif
!
!       Multiply the transpose of the eigenvector matrix, b, with the sine
!       expansion of the initial temperature profile, a, to obtain the
!       initial temperature profile in terms of the eigenfunctions of the
!       diffusion operator.
!
        call pdgemv('T', n, n, 1.d0, b, 1, 1, b_d, a, 1, 1, a_d, 1,            &
     &              0.d0, ab, 1, 1, ab_d, 1)
!
!  This first matrix multiplication, yielding the matrix ab,
!  corresponds to the inner summation in equation 10
!  of the discussion paper.
!

!
!    Calculate temperature profile for each time step.
!
        do it = 1, dif_ntemps
          i = 0
          do ib = 1, ab_i%num_col_blks
            do ig = ab_i%scb(ib), ab_i%ecb(ib)
              i = i + 1
              abt(1,i) = exp( -lambda(ig) * it * dif_delta_t) * ab(1,i)
            enddo
          enddo
!
!   abt now has the expansion of the temperature profile in terms of the
!   eigenvectors of the diffusion operator.
!

!
!   Multiply the eigenvector matrix with abt to give the sine function
!   expansion of the temperature profile at time t, x.
!
          call pdgemv('N', n, n, 1.d0, b, 1, 1, b_d, abt, 1, 1, abt_d,         &
     &              1, 0.d0, x, 1, 1, x_d, 1)
!  This last sum corresponds to the outer sum of equation 12, where the
!  time dependent expansion coefficients a{sub l}(t) are stored in the
!  temporary array x in the program.
!

!
!   Gather all of the local pieces of the array x to the array xg.
!
          call rlocal_to_rglobal(x, x_d, xg )

          do k = 1, dif_npts
            temp(k, it) = 0.d0
          enddo

          do iy = 1, dif_ny
            do ix = 1, dif_nx
              i = (iy -1) * dif_nx + ix
              do k = 1, dif_npts
                temp(k,it) = temp(k,it) + xsines(k,ix) * ysines(k,iy)          &
     &                       * xg(1,i)
              enddo
            enddo
          enddo
!
!  This last do loop corresponds to the double summation in equation
!  13 of the discussion paper.
!

        enddo  ! end of time loop

!
!   Here, we are just writing out the temperatures at the selected times
!   and points.
!
        if( sc_iam .eq. 0 ) then    ! if I am node 0
           write(*,*) '   point #      X         Y'
           do i = 1, dif_npts
             write(*,'(2x, i6, 2x, 2f11.4)') i, dif_x(i), dif_y(i)
           enddo
           write(*,*)
           do k = 1, dif_npts, 6
             write(*,*)
             write(*,'(30X,''Points'')')
             write(*,'(''   TIME   '',6(5x,''#'', i4))') (i, i=k, k+5)
             do i = 1, dif_ntemps
                write(*,'(7f10.5)') i*dif_delta_t,                             &
     &                          (temp(j,i),j=k,min(k+5,dif_npts))
             enddo
          enddo
        endif

        deallocate(xg)
        deallocate(xsines)
        deallocate(ysines)
        deallocate(lambda)
        deallocate(temp)
        deallocate( ifail)
        deallocate( iclustr)
        deallocate( gap)
        call blacs_exit(0)
        stop
        end


C cctbx_project/compcomm/newsletter09/sf_times.py, svn rev. 9983
C cos_wrapper, exp_wrapper replaced with COS, SIN, EXP

      subroutine sf(abcss, n_scatt, xyz, b_iso, n_refl, hkl, f_calc)
      implicit none
      REAL abcss(3)
      integer n_scatt
      REAL xyz(3, *)
      REAL b_iso(*)
      integer n_refl
      integer hkl(3, *)
      REAL f_calc(2, *)
      integer i_refl, i_scatt, j, h
      REAL phi, cphi, sphi, dss, ldw, dw, a, b
      DO i_refl=1,n_refl
        a = 0
        b = 0
        DO i_scatt=1,n_scatt
          phi = 0
          DO j=1,3
            phi = phi + hkl(j,i_refl) * xyz(j,i_scatt)
          enddo
          phi = phi * 2 * 3.1415926535897931
          cphi = COS(phi)
          sphi = SIN(phi)
          dss = 0
          DO j=1,3
            h = hkl(j,i_refl)
            dss = dss + h*h * abcss(j)
          enddo
          ldw = -0.25 * dss * b_iso(i_scatt)
          dw = EXP(ldw)
          a = a + dw * cphi
          b = b + dw * sphi
        enddo
        f_calc(1, i_refl) = a
        f_calc(2, i_refl) = b
      enddo
      return
      end

      program run
      implicit none
      REAL abcss(3)
      integer n_scatt
      parameter(n_scatt=10)
      REAL xyz(3, n_scatt)
      REAL b_iso(n_scatt)
      integer n_refl
      parameter(n_refl=10)
      integer hkl(3, n_refl)
      REAL f_calc(2, n_refl)
      integer i, j, jr
      REAL a, b, max_a, max_b
      abcss(1) = 1/(11.0*11.0)
      abcss(2) = 1/(12.0*12.0)
      abcss(3) = 1/(13.0*13.0)
      jr = 0
      DO i=1,n_scatt
        DO j=1,3
          jr = mod(jr*1366+150889, 714025)
          xyz(j,i) = (mod(jr, 20000) - 10000) / 10000.0
        enddo
      enddo
      DO i=1,n_scatt
        jr = mod(jr*1366+150889, 714025)
        b_iso(i) = mod(jr, 10000) / 100.0
      enddo
      if (n_scatt .le. 10) then
        DO i=1,n_scatt
          write(6, '(4(1x,f9.6))')
     &      xyz(1,i), xyz(2,i), xyz(3, i), b_iso(i)
        enddo
      endif
      DO i=1,n_refl
        DO j=1,3
          jr = mod(jr*1366+150889, 714025)
          hkl(j,i) = mod(jr, 10) - 5
        enddo
      enddo
      call sf(abcss, n_scatt, xyz, b_iso, n_refl, hkl, f_calc)
      if (n_refl .le. 100) then
        DO i=1,n_refl
          write(6, '(3(1x,i3),1x,f12.6,1x,f12.6)')
     &      hkl(1,i), hkl(2,i), hkl(3,i),
     &      f_calc(1,i), f_calc(2,i)
        enddo
      else
        max_a = 0
        max_b = 0
        DO i=1,n_refl
          a = f_calc(1,i)
          b = f_calc(2,i)
          if (max_a .lt. a) max_a = a
          if (max_b .lt. b) max_b = b
        enddo
        write(6, '(2(1x,f12.6))') max_a, max_b
      endif
      end