      subroutine caprsh2(irho)
c--
c  Evaluate CAPR, CAPS, and H2.  Here, m is the poloidal mode number
c  and n is the toroidal mode number/periods.
c--LAB--changed calculation of H2 to use proper 1/b**2 Jacobian for
c  flux surface average
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use parambs
      use vmec0
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer irho
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec), parameter :: zero = 0, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: nh, m, i, j
      real(rprec) :: h2top_th, h2top_phi, den, qn, e2
      real(rprec) ::  b2, h2top
      real(rprec) :: h2top_tmp, den_tmp, sin_eps
C-----------------------------------------------------------------------

c  the following code was added to evaluate H2 LAB
      h2top = zero
      den   = zero
      do i=1, nthetah
         do j=1, nzetah
            h2top_th = zero
            h2top_phi = zero
            den_tmp = zero
            do nh = 0, nbuse            !  evaluate i,j terms in num and denom of H2
               qn = qsafety(irho)*periods*nh*zetasign
               do m = -mbuse, mbuse
                  sin_eps = amnfit(irho,m,nh)*
     1            (sinmi(m,i)*cosnj(nh,j)+cosmi(m,i)*sinnj(nh,j))
                  h2top_th = h2top_th - m*sin_eps
                  h2top_phi = h2top_phi - qn*sin_eps
                  den_tmp = den_tmp - (m + qn)*sin_eps
               enddo
            enddo
            b2 = bfield(i,j)**2
            h2top = h2top + (h2top_th**2 - h2top_phi**2)/b2
            den  = den + den_tmp**2/b2
         enddo
      enddo

      ! Modified by SAL so code won't stop
      !if (den .eq. zero) stop 'den = 0 in caprsh2'
      IF (den .eq. zero) THEN
         IF (lscreen) THEN
            WRITE(6,'(A)')      'WARNING(BOOTSJ): den = 0 in caprsh2'
            WRITE(6,'(A,I3.3)') '                 irho: ',irho
         END IF
         h2(irho) = 0.0
      ELSE
         h2(irho) = h2top/den
      END IF
      capr(irho) = (one - h2(irho))/(2*qsafety(irho))
      caps(irho) = (one + h2(irho))/2

      end subroutine caprsh2


      SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the convolution or deconvolution of two real signals
C     A and B using the Hartley transform.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     CONV    CHARACTER*1
C             Indicates whether convolution or deconvolution is to be
C             performed as follows:
C             = 'C':  Convolution;
C             = 'D':  Deconvolution.
C
C     WGHT    CHARACTER*1
C             Indicates whether the precomputed weights are available
C             or not, as follows:
C             = 'A':  available;
C             = 'N':  not available.
C             Note that if N > 1 and WGHT = 'N' on entry, then WGHT is
C             set to 'A' on exit.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of samples.  N must be a power of 2.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the first signal.
C             On exit, this array contains the convolution (if
C             CONV = 'C') or deconvolution (if CONV = 'D') of the two
C             signals.
C
C     B       (input) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the second signal.
C             NOTE that this array is overwritten.
C
C     W       (input/output) DOUBLE PRECISION array,
C                            dimension (N - LOG2(N))
C             On entry with WGHT = 'A', this array must contain the long
C             weight vector computed by a previous call of this routine
C             or of the SLICOT Library routine DG01OD.f, with the same
C             value of N. If WGHT = 'N', the contents of this array on
C             entry is ignored.
C             On exit, this array contains the long weight vector.
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     This routine computes the convolution or deconvolution of two
C     real signals A and B using three scrambled Hartley transforms
C     (SLICOT Library routine DG01OD).
C
C     REFERENCES
C
C     [1] Van Loan, Charles.
C         Computational frameworks for the fast Fourier transform.
C         SIAM, 1992.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(N log(N)) floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, April 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     KEYWORDS
C
C     Convolution, deconvolution, digital signal processing,
C     fast Hartley transform, real signals.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  HALF, TWO
      PARAMETER         ( HALF = 0.5D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         CONV, WGHT
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*), W(*)
C     .. Local Scalars ..
      LOGICAL           LCONV, LWGHT
      INTEGER           J, L, LEN, M, P1, R1
      DOUBLE PRECISION  T1, T2, T3
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DG01OD, DLADIV, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MOD
C     .. Executable Statements ..
C
      INFO  = 0
      LCONV = LSAME( CONV, 'C' )
      LWGHT = LSAME( WGHT, 'A' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN
         INFO = -2
      ELSE
         M = 0
         J = 0
         IF( N.GE.1 ) THEN
            J = N
C           WHILE ( MOD( J, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( J, 2 ).EQ.0 ) THEN
               J = J/2
               M = M + 1
               GO TO 10
            END IF
C           END WHILE 10
            IF ( J.NE.1 ) INFO = -3
         ELSE IF ( N.LT.0 ) THEN
            INFO = -3
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DE01PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.LE.0 ) THEN
         RETURN
      ELSE IF ( N.EQ.1 ) THEN
         IF ( LCONV ) THEN
            A(1) = A(1)*B(1)
         ELSE
            A(1) = A(1)/B(1)
         END IF
         RETURN
      END IF
C
C     Scrambled Hartley transforms of A and B.
C
      CALL DG01OD( 'OutputScrambled', WGHT, N, A, W, INFO )
      CALL DG01OD( 'OutputScrambled', WGHT, N, B, W, INFO )
C
C     Something similar to a Hadamard product/quotient.
C
      LEN = 1
      IF( LCONV )  THEN
         A(1) = TWO*A(1)*B(1)
         A(2) = TWO*A(2)*B(2)
C
         DO 30 L = 1, M - 1
            LEN = 2*LEN
            R1  = 2*LEN
C
            DO 20 P1 = LEN + 1, LEN + LEN/2
               T1 = B(P1) + B(R1)
               T2 = B(P1) - B(R1)
               T3 = T2*A(P1)
               A(P1) = T1*A(P1) + T2*A(R1)
               A(R1) = T1*A(R1) - T3
               R1 = R1 - 1
   20       CONTINUE
C
   30    CONTINUE
C
      ELSE
C
         A(1) = HALF*A(1)/B(1)
         A(2) = HALF*A(2)/B(2)
C
         DO 50 L = 1, M - 1
            LEN = 2*LEN
            R1  = 2*LEN
C
            DO 40 P1 = LEN + 1, LEN + LEN/2
               CALL DLADIV( A(P1), A(R1), B(P1)+B(R1), B(R1)-B(P1), T1,
     $                      T2 )
               A(P1) = T1
               A(R1) = T2
               R1 = R1 - 1
   40       CONTINUE
C
   50    CONTINUE
C
      END IF
C
C     Transposed Hartley transform of A.
C
      CALL DG01OD( 'InputScrambled', WGHT, N, A, W, INFO )
      IF ( LCONV ) THEN
         CALL DSCAL( N, HALF/DBLE( N ), A, 1 )
      ELSE
         CALL DSCAL( N, TWO/DBLE( N ), A, 1 )
      END IF
C
      RETURN
C *** Last line of DE01PD ***
      END


c.......subroutine bfilter
c
c	Written by:  David R. Russell, AFTAC/TT 10 December 2004
c
c       Subroutine bfilter executes a fast, stable zero phase butterworth
c       bandpass filter of order (m), which is optimized for narrow band
c       applications.  The method produces a complex time series output,
c       of which the real portion is used to calculate the filtered time
c       series, and the modulus is used to calculate the envelope function.
c       Stability of the method is achieved by reducing the bandpass
c       filter calculations to simple cascaded first order filters,
c       which are forward and reverse filtered for zero phase.  The method
c       also does a linear shift of a butterworth lowpass filter
c       to an equivalent bandpass, without going through a standard
c       non-linear translation (Kanasewich, E.R., 1975) to bandpass. An option
c       is included to remove the signal mean initially to compensate for
c       large DC offsets
c
c	INPUT:
c
c	m:      Order of Butterworth filter
c	n:      Number of input, output time series points
c       mzer:   Integer flag to remove mean (0 no, 1 yes)
c	xr(n):  Input (real) time series
c       f0:     Center value of bandpass filter
c       fc:     Corners of filter [ flow= f0-fc; fhigh= f0+fc ]
c       dt:     Time series sampling interval
c
c	OUTPUT:
c
c       yr(n):  Output filtered (real) time series
c	er(n):  Output envelope function for filtered time series
c       ermx:   Maximum value of envelope function er.
c
c****************************
      subroutine bfilter(xr,yr,er,ermx,f0,fc,dt,m,n,mzer)
c****************************
c
c.......nmax = total possible number of time series points
c       mmax = highest possible order of butterworth filter
c
      parameter (nmax=65000,mmax=10)
c
      double complex z1(nmax),z2(nmax),a1(mmax),a2(mmax),
     &               a1c(mmax),a2c(mmax),p,s,ctemp
      double precision pi,w0,wc,w1,w2,dtemp,dtt
      dimension xr(n),yr(n),er(n)
c
c.......error check on frequencies
c
      fnyq=1.0/(2.0*dt)
      if ((f0-fc).le.0.0) then
        write(6,*)'low corner frequency (f0-fc) <= 0.0'
        stop
      endif
      if ((f0+fc).ge.fnyq) then
        write(6,*)'high corner frequency (f0+fc) >= nyquist'
        stop
      endif
c
c.......initialize double precision pi, dtt, angular frequencies w0,wc
c
      pi=3.14159265358979d0
      w0=2.0d0*pi*dble(f0)
      wc=2.0d0*pi*dble(fc)
      dtt=dble(dt)
c
c.......prewarp frequencies for bilinear z-transform
c
      w1=w0-wc
      w2=w0+wc
      w1=2.0d0/dtt*dtan(w1*dtt/2.0d0)
      w2=2.0d0/dtt*dtan(w2*dtt/2.0d0)
      w0=(w1+w2)/2.0d0
      wc=(w2-w1)/2.0d0
c
c.......calculate (m) prototype lowpass poles (p), translate into bandpass
c       poles (s), calculate bilinear recursive coefficients (a1,a2),
c       conjugates of coefficients (a1c,a2c)
c
      do j=1,m
        dtemp=pi*(2.0d0*dble(j)-1.0d0+dble(m))/(2.0d0*dble(m))
        ctemp=dcmplx(0.0d0,dtemp)
        p=cdexp(ctemp)
        s=p*wc+dcmplx(0.0d0,w0)
        a1(j)=wc*dtt/(2.0d0-s*dtt)
        a2(j)=(2.0d0+s*dtt)/(2.0d0-s*dtt)
        a1c(j)=dconjg(a1(j))
        a2c(j)=dconjg(a2(j))
      enddo
c
c.......put real time series xr into complex series z1 and remove mean
c       if mzer set to 1
c
      xmean=0.0
      if(mzer.eq.1) then
        do k=1,n
          xmean=xmean+xr(k)
        enddo
        xmean=xmean/float(n)
      endif
      do k=1,n
        z1(k)=xr(k)-xmean
      enddo
c
c.......calculate (m) cascaded first order complex filters
c
      do j=1,m
        do k=1,n
          z2(k)=z1(k)
        enddo
        z1(1)=a1(j)*z2(1)
        do k=2,n
          z1(k)=a1(j)*(z2(k)+z2(k-1))+a2(j)*z1(k-1)
        enddo
      enddo
c
c.......reverse filtered time series
c
      do k=1,n
        z2(k)=z1(n-k+1)
      enddo
c
c.......calculate (m) cascaded first order complex filters on
c       reversed series - note conjugate bilinear coefficients
c       for complex conjugate of filter
c
      do j=1,m
        do k=1,n
          z1(k)=z2(k)
        enddo
        z2(1)=a1c(j)*z1(1)
        do k=2,n
          z2(k)=a1c(j)*(z1(k)+z1(k-1))+a2c(j)*z2(k-1)
        enddo
      enddo
c
c.......reverse filtered time series
c
      do k=1,n
        z1(k)=z2(n-k+1)
      enddo
c
c.......calculate real output time series (yr), envelope (er),
c       envelope maximum (ermx)
c
      ermx=0.0
      do k=1,n
        yr(k)=2.0*dreal(z1(k))
        er(k)=2.0*cdabs(z1(k))
        ermx=amax1(er(k),ermx)
      enddo
      return
      end


PROGRAM mo_bootstrapping_test

  USE mo_bootstrapping_sensitivity_analysis,  only: bootstrap_si
  USE mo_kind,                                only: i4, i8, dp
  USE mo_model,                               only: model, par_range
  USE mo_sobol,                               only: sobol_array
  USE mo_sobol_index,                         only: sobol_index
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

!-----------------------------------------------------------

  integer(i4),   parameter                   :: npar = 4_i4             ! number of parameters
  integer(i4),   parameter                   :: nsets = 1500_i4         ! number of parameter sets
  integer(i4),   parameter                   :: nt = 10_i4              ! number of time points
  integer(i4),   parameter                   :: nboot = 19_i4           ! number of new datasets generated with bootstrapping

  integer(i4)                                :: skip = 30000_i4
  integer(i8)                                :: seed = 123_i8

  real(dp),  dimension(nt)                   :: t                       ! i.e. time series

  real(dp),  dimension(npar,2)               :: range                   ! parameter range

  real(dp),  dimension(nsets,2*npar)         :: p                       ! sobol sequence
  real(dp),  dimension(nsets,npar)           :: pa                      ! parameter sample A
  real(dp),  dimension(nsets,npar)           :: pb                      ! parameter sample B
  real(dp),  dimension(nsets,npar)           :: pci                     ! parameter sample Ci

  real(dp),  dimension(nsets,nt)             :: ya                      ! model output A
  real(dp),  dimension(nsets,nt)             :: yb                      ! model output B
  real(dp),  dimension(nsets,npar,nt)        :: yci                     ! model output C(i), i=1,npar

  real(dp),  dimension(nboot+1,npar,nt)      :: si                      ! sobol index (main effect)
                                                                        !    per parameter and time point
                                                                        !    for each bootstrapping sample
  real(dp),  dimension(nboot+1,npar,nt)      :: sti                     ! sobol index (total effect)
                                                                        !    per parameter and time point
                                                                        !    for each bootstrapping sample
  integer(i4)        :: i
  logical            :: isgood = .true.

!----------------------------------------------------------

  do i = 1, nt
     t(i) = real(i-1,dp)
  end do

  ! Generating parameter sets
  call sobol_array(2*npar,nsets,skip,p)
  range = par_range()
  pa = p(:,:npar)
  pb = p(:,npar+1:)
  do i = 1, npar
     pa(:,i) = pa(:,i)*(range(i,2)-range(i,1)) + range(i,1)
     pb(:,i) = pb(:,i)*(range(i,2)-range(i,1)) + range(i,1)
  end do

  ! Calculating the model output
  ya = model(pa,t)
  yb = model(pb,t)

  do i = 1, npar
     pci = pa
     pci(:,i) = pb(:,i)
     yci(:,i,:) = model(pci,t)
  end do

  ! Calculating the sobol index
  call sobol_index(ya, yb, yci, si(1,:,:), sti(1,:,:))

  ! Bootstrapping
  call bootstrap_si(ya, yb, yci, nboot, si(2:,:,:), sti(2:,:,:), seed = seed)

 if (abs(si(1,1,3) - 0.97236268) > 0.000001) isgood = .false.
 if (abs(si(1,2,3) - 0.01255484) > 0.000001) isgood = .false.
 if (abs(si(1,3,3) - 0.00000000) > 0.000001) isgood = .false.
 if (abs(si(1,4,3) - 0.00275693) > 0.000001) isgood = .false.
 if (abs(si(2,1,3) - 0.82035742) > 0.000001) isgood = .false.
 if (abs(si(2,2,3) - 0.00413255) > 0.000001) isgood = .false.
 if (abs(si(2,3,3) - 0.00000000) > 0.000001) isgood = .false.
 if (abs(si(2,4,3) - 0.01841593) > 0.000001) isgood = .false.
 if (abs(sti(1,1,3) - 0.97907962) > 0.000001) isgood = .false.
 if (abs(sti(1,2,3) - 0.01529379) > 0.000001) isgood = .false.
 if (abs(sti(1,3,3) - 0.00000000) > 0.000001) isgood = .false.
 if (abs(sti(1,4,3) - 0.00382390) > 0.000001) isgood = .false.
 if (abs(sti(2,1,3) - 1.01645796) > 0.000001) isgood = .false.
 if (abs(sti(2,2,3) - 0.01582186) > 0.000001) isgood = .false.
 if (abs(sti(2,3,3) - 0.00000000) > 0.000001) isgood = .false.
 if (abs(sti(2,4,3) - 0.00392133) > 0.000001) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_bootstrapping_sensitivity_analysis ', color('o.k.', c_green)
  else
     write(*,*) 'mo_bootstrapping_sensitivity_analysis ', color('failed', c_red)
  end if

!-----------------------------------------------------------
END PROGRAM mo_bootstrapping_test


      include 'ttb/ttb_library.f'

      subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,
     2             nshear,disp,dispt,coord,ffn,frotn,strechn,eigvn,ffn1,
     3                   frotn1,strechn1,eigvn1,ncrd,itel,ndeg,ndm,
     4                   nnode,jtype,lclass,ifr,ifu)

      ! HYPELA2 St. Venant - Kirchhoff Material
      ! Formulation: Total Lagrange, Large Strain
      !              (Updated Lagrange with Push Forward
      !               and Jaumann Correction)
      !
      ! Andreas Dutzler, Graz University of Technology
      ! 2018-02-11

      use Tensor
      implicit none

      real*8 coord, d, de, disp, dispt, dt, e, eigvn, eigvn1, ffn, ffn1
      real*8 frotn, frotn1, g
      integer ifr, ifu, itel, jtype, kcus, lclass, matus, m, ncrd, ndeg
      integer ndi, ndm, ngens, nn, nnode, nshear
      real*8 s, strechn, strechn1, t

      dimension e(*),de(*),t(*),dt(*),g(*),d(ngens,*),s(*)
      dimension m(2),coord(ncrd,*),disp(ndeg,*),matus(2),
     *          dispt(ndeg,*),ffn(itel,3),frotn(itel,3),
     *          strechn(itel),eigvn(itel,*),ffn1(itel,3),
     *          frotn1(itel,3),strechn1(itel),eigvn1(itel,*),
     *          kcus(2),lclass(2)

      include 'concom'

      type(Tensor2)  :: F1

      type(Tensor2s) :: E1,S1,Eye
      type(Tensor4s) :: C4

      real(kind=8) :: J,young,nu,lambda,mu

      ! material parameters
      young = 210000.0
      nu = 0.3

      ! lame parameter
      mu = young / ( 2.*(1.+nu) )
      lambda = nu*young / ((1.+nu)*(1.-2.*nu))

      ! large strain formulation
      Eye = Eye**0
      F1 = Eye
      F1%ab(1:itel,1:3) = ffn1(1:itel,1:3)
      E1 = 0.5*(transpose(F1)*F1-Eye)

      ! material elasticity tensor
      C4 = lambda*(Eye.dya.Eye) + 2.*mu*(Eye.cdya.Eye)

      ! pk2 stress
      S1 = lambda*tr(E1)*Eye + 2.*mu*E1

      if (iupdat.eq.1) then ! updated lagrange
       J = det(F1)
       ! cauchy stress
       S1 = piola(F1,S1)/J
       ! tangent matrix (jaumann)
       C4 = piola(F1,C4)/J
     *      + (S1.cdya.Eye) + (Eye.cdya.S1)
      endif

      ! output as array
      s(1:ngens)         = asarray( asvoigt(S1), ngens )
      d(1:ngens,1:ngens) = asarray( asvoigt(C4), ngens,ngens )

      return
      end


*> \brief \b SSXT1
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL             FUNCTION SSXT1( IJOB, D1, N1, D2, N2, ABSTOL,
*                        ULP, UNFL )
*
*       .. Scalar Arguments ..
*       INTEGER            IJOB, N1, N2
*       REAL               ABSTOL, ULP, UNFL
*       ..
*       .. Array Arguments ..
*       REAL               D1( * ), D2( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSXT1  computes the difference between a set of eigenvalues.
*> The result is returned as the function value.
*>
*> IJOB = 1:   Computes   max { min | D1(i)-D2(j) | }
*>                         i     j
*>
*> IJOB = 2:   Computes   max { min | D1(i)-D2(j) | /
*>                         i     j
*>                              ( ABSTOL + |D1(i)|*ULP ) }
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] IJOB
*> \verbatim
*>          IJOB is INTEGER
*>          Specifies the type of tests to be performed.  (See above.)
*> \endverbatim
*>
*> \param[in] D1
*> \verbatim
*>          D1 is REAL array, dimension (N1)
*>          The first array.  D1 should be in increasing order, i.e.,
*>          D1(j) <= D1(j+1).
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*>          N1 is INTEGER
*>          The length of D1.
*> \endverbatim
*>
*> \param[in] D2
*> \verbatim
*>          D2 is REAL array, dimension (N2)
*>          The second array.  D2 should be in increasing order, i.e.,
*>          D2(j) <= D2(j+1).
*> \endverbatim
*>
*> \param[in] N2
*> \verbatim
*>          N2 is INTEGER
*>          The length of D2.
*> \endverbatim
*>
*> \param[in] ABSTOL
*> \verbatim
*>          ABSTOL is REAL
*>          The absolute tolerance, used as a measure of the error.
*> \endverbatim
*>
*> \param[in] ULP
*> \verbatim
*>          ULP is REAL
*>          Machine precision.
*> \endverbatim
*>
*> \param[in] UNFL
*> \verbatim
*>          UNFL is REAL
*>          The smallest positive number whose reciprocal does not
*>          overflow.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup single_eig
*
*  =====================================================================
      REAL             FUNCTION SSXT1( IJOB, D1, N1, D2, N2, ABSTOL,
     $                 ULP, UNFL )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            IJOB, N1, N2
      REAL               ABSTOL, ULP, UNFL
*     ..
*     .. Array Arguments ..
      REAL               D1( * ), D2( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               TEMP1, TEMP2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      TEMP1 = ZERO
*
      J = 1
      DO 20 I = 1, N1
   10    CONTINUE
         IF( D2( J ).LT.D1( I ) .AND. J.LT.N2 ) THEN
            J = J + 1
            GO TO 10
         END IF
         IF( J.EQ.1 ) THEN
            TEMP2 = ABS( D2( J )-D1( I ) )
            IF( IJOB.EQ.2 )
     $         TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
         ELSE
            TEMP2 = MIN( ABS( D2( J )-D1( I ) ),
     $              ABS( D1( I )-D2( J-1 ) ) )
            IF( IJOB.EQ.2 )
     $         TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
         END IF
         TEMP1 = MAX( TEMP1, TEMP2 )
   20 CONTINUE
*
      SSXT1 = TEMP1
      RETURN
*
*     End of SSXT1
*
      END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_orthfact_qr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the real Schur factorization of a real
! orthogonal upper-Hessenberg matrix that is stored as a product of
! N-1 Givens rotations and a diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: compute schurvectors
!                    .FALSE.: no schurvectors
!
!  ID              LOGICAL
!                    .TRUE.: initialize to Z to identity
!                    .FALSE.: assume Z is already initialized
!
!  N               INTEGER
!                    dimension of matrix
!
!  Q               REAL(8) array of dimension (2*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (N)
!                    array of generators for complex diagonal matrix
!
!  M               INTEGER
!                    leading dimension of Z
!
! OUTPUT VARIABLES:
!
!  Z               REAL(8) array of dimension (M,N)
!                    components of schurvectors
!                    if VEC = .FALSE. unused
!                    if VEC = .TRUE. and ID = .TRUE. initializes Z to I
!                    if VEC = .TRUE. and ID = .FALSE. assumes Z initialized
!
!  ITS             INTEGER array of dimension (N-1)
!                    Contains the number of iterations per deflation
!
!  INFO            INTEGER
!                    INFO = 1 implies no convergence
!                    INFO = 0 implies successful computation
!                    INFO = -3 implies N is invalid
!                    INFO = -4 implies Q is invalid
!                    INFO = -5 implies D is invalid
!                    INFO = -6 implies M is invalid
!                    INFO = -7 implies Z is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_orthfact_qr(VEC,ID,N,Q,D,M,Z,ITS,INFO)

  implicit none

  ! input variables
  logical, intent(in) :: VEC, ID
  integer, intent(in) :: N, M
  integer, intent(inout) :: INFO, ITS(N-1)
  real(8), intent(inout) :: Q(2*(N-1)), D(N), Z(M,N)

  ! compute variables
  logical :: flg
  integer :: ii, kk
  integer :: STR, STP, ZERO, ITMAX, ITCNT
  real(8) :: block(2,2)

  ! initialize INFO
  INFO = 0

  ! check factorization
  call d_orthfact_factorcheck(N,Q,D,INFO)
  if (INFO.NE.0) then
    INFO = INFO - 2
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"N, Q, or D is invalid",INFO,INFO)
    end if
    return
  end if

  ! check M
  if (VEC.AND.(M < 1)) then
    INFO = -6
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"M must be at least 1",INFO,INFO)
    end if
    return
  end if

  ! check Z
  if (VEC.AND..NOT.ID) then
    call d_2Darray_check(M,N,Z,flg)
    if (.NOT.flg) then
      INFO = -7
      ! print error message in debug mode
      if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"Z is invalid",INFO,INFO)
      end if
      return
    end if
  end if

  ! initialize storage
  ITS = 0

  if (VEC.AND.ID) then
    Z = 0d0
    do ii=1,min(M,N)
      Z(ii,ii) = 1d0
    end do
  end if

  ! initialize indices
  STR = 1
  STP = N-1
  ZERO = 0
  ITMAX = 20*N
  ITCNT = 0

  ! loop for bulgechasing
  do kk=1,ITMAX

    ! check for completion
    if(STP <= 0)then
      exit
    end if

    ! check for deflation
    call d_orthfact_deflationcheck(STP-STR+2,Q((2*STR-1):(2*STP)),D(STR:(STP+1)),ZERO)

    ! if 1x1 block remove and check again
    if(STP == (STR+ZERO-1))then

      ! update indices
      ITS(STR+STP-1) = ITCNT
      ITCNT = 0
      STP = STP - 1
      ZERO = 0
      STR = 1

    ! if 2x2 block remove and check again
    else if(STP == (STR+ZERO))then

      ! call 2x2 deflation
      call d_orthfact_2x2deflation(VEC,Q((2*STP-1):(2*STP)),D(STP:(STP+1)),M,Z(:,STP:(STP+1)))

      ! update indices
      ITS(STR+STP-1) = ITCNT
      ITCNT = 0
      STP = STP - 2
      ZERO = 0
      STR = 1

    ! if greater than 2x2 chase a bulge
    else

      ! check STR
      if (ZERO.GT.0) then
        STR = STR+ZERO
      end if

      ! perform singleshift iteration
      call d_orthfact_doublestep(VEC,STP-STR+2,Q((2*STR-1):(2*STP)),D(STR:(STP+1)) &
      ,M,Z(:,STR:(STP+1)),ITCNT)

      ! update indices
      ITCNT = ITCNT + 1

    end if

    ! if ITMAX hit
    if (kk == ITMAX) then
      INFO = 1
      ITS(STR+STP-1) = ITCNT
    end if

  end do

end subroutine d_orthfact_qr


module utils
    implicit none

    integer, parameter, public :: dp = kind(0.d0)
    real(dp), parameter, public :: pi = 4.0_dp * datan(1.0_dp)

contains

pure function r_to_inds(r, l, m) result(inds)
    real(kind(0.d0)), intent(in) :: r(:, :), l
    integer, intent(in) :: m
    integer :: inds(size(r, 1), size(r, 2))

    inds = 1 + int((r + l / 2.0_dp) / (l / m))
end function

pure function r_wrap(r, l, l_half)
    real(kind(0.d0)), intent(in) :: r, l, l_half
    real(kind(0.d0)) :: r_wrap

    if (r > l_half) then
        r_wrap = r - l
    else if (r < -l_half) then
        r_wrap = r + l
    else
        r_wrap = r
    end if
end function

pure function i_wrap(i, m)
    integer, intent(in) :: i, m
    integer :: i_wrap

    if (i > m) then
        i_wrap = i - m
    else if (i < 1) then
        i_wrap = i + m
    else
        i_wrap = i
    end if
end function

pure function r_sep_sq(r_1, r_2, l, l_half)
    real(kind(0.d0)), intent(in) :: r_1(:), r_2(size(r_1)), l, l_half
    real(kind(0.d0)) :: r_sep_sq, r_diff
    integer :: i

    r_sep_sq = 0.0d0
    do i = 1, size(r_1, 1)
        r_diff = dabs(r_1(i) - r_2(i))
        if (r_diff > l_half) r_diff = l - r_diff
        r_sep_sq = r_sep_sq + r_diff ** 2
    end do
end function

pure function rot_2d(a, theta) result(a_rot)
    real(kind(0.d0)), intent(in) :: a(2), theta
    real(kind(0.d0)) :: a_rot(2), s, c

    s = sin(theta)
    c = cos(theta)
    a_rot(1) = c * a(1) - s * a(2)
    a_rot(2) = s * a(1) + c * a(2)
end function

subroutine add_noise_2d(v, eta)
    real(kind(0.d0)), intent(inout) :: v(:, :)
    real(kind(0.d0)), intent(in) :: eta
    real(kind(0.d0)) :: theta(size(v, 2))
    integer :: i

    call random_number(theta)
    theta = (theta - 0.5_dp) * eta
    do i = 1, size(v, 2)
        v(:, i) = rot_2d(v(:, i), theta(i))
    end do
end subroutine

subroutine clusters(r_raw, r_cut_raw, l, list)
    real(kind(0.d0)), intent(in) :: r_raw(:, :), r_cut_raw, l
    integer, intent(out) :: list(size(r_raw, 2))
    real(kind(0.d0)) :: r(size(r_raw, 1), size(r_raw, 2)), r_cut_sq, r_j(size(r_raw, 1)), r_j_k(size(r_raw, 1))
    integer :: n, d, i, j, k, list_k

    d = size(r, 1)
    n = size(r, 2)

    ! scale distances to internal units
    r = r_raw / l
    r_cut_sq = (r_cut_raw / l) ** 2

    do i = 1, n
        list(i) = i
    end do

    do i = 1, n - 1
        if (i == list(i)) then
            j = i
            r_j = r(:, j)
            do k = i + 1, n
                list_k = list(k)
                if (list_k == k) then
                    r_j_k = r_j - r(:, k)
                    r_j_k = r_j_k - anint(r_j_k)
                    if (sum(r_j_k ** 2) < r_cut_sq) then
                        list(k) = list(j)
                        list(j) = list_k
                    end if
                end if
            end do

            j = list(j)
            r_j = r(:, j)

            do while (j /= i)
                do k = i + 1, n
                    list_k = list(k)
                    if (list_k == k) then
                        r_j_k = r_j - r(:, k)
                        r_j_k = r_j_k - anint(r_j_k)
                        if (sum(r_j_k ** 2) < r_cut_sq) then
                            list(k) = list(j)
                            list(j) = list_k
                        end if
                    end if
                end do
                j = list(j)
                r_j = r(:, j)
            end do
        end if
    end do
end subroutine clusters

end module


    Program dggev3_example

!     DGGEV3 Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_sort_cmplxvec_rank_rearrange, &
        nagf_sort_realmat_rank_rows, nagf_file_print_matrix_complex_gen, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dggev3
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Integer :: i, ifail, info, j, k, lda, ldb, ldvr, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: eigval(:), eigvec(:, :)
      Real (Kind=dp), Allocatable :: a(:, :), alphai(:), alphar(:), b(:, :), &
        beta(:), vr(:, :), work(:)
      Real (Kind=dp) :: dummy(1, 1)
      Integer, Allocatable :: irank(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, all, cmplx, conjg, epsilon, maxloc, nint
!     .. Executable Statements ..
      Write (nout, *) 'DGGEV3 Example Program Results'
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvr = n
      Allocate (a(lda,n), alphai(n), alphar(n), b(ldb,n), beta(n), vr(ldvr,n), &
        eigvec(n,n), eigval(n), irank(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dggev3('No left vectors', 'Vectors (right)', n, a, lda, b, ldb, &
        alphar, alphai, beta, dummy, 1, vr, ldvr, dummy, lwork, info)

      lwork = nint(dummy(1,1))
      Allocate (work(lwork))

!     Read in the matrices A and B

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Solve the generalized eigenvalue problem

      Call dggev3('No left vectors', 'Vectors (right)', n, a, lda, b, ldb, &
        alphar, alphai, beta, dummy, 1, vr, ldvr, work, lwork, info)
      If (info>0) Then
        Write (nout, *)
        Write (nout, 110) 'Failure in DGGEV3. INFO =', info
        Go To 100
      End If

!     Re-normalize the eigenvectors, largest absolute element real
      j = 0
      Do i = 1, n
        If (alphai(i)==zero) Then
          eigvec(1:n, i) = cmplx(vr(1:n,i), zero, kind=dp)
        Else If (j==0) Then
          eigvec(1:n, i) = cmplx(vr(1:n,i), vr(1:n,i+1), kind=dp)
          j = 1
        Else
          eigvec(1:n, i) = cmplx(vr(1:n,i-1), -vr(1:n,i), kind=dp)
          j = 0
        End If
        work(1:n) = abs(eigvec(1:n,i))
        k = maxloc(work(1:n), 1)
        scal = conjg(eigvec(k,i))/abs(eigvec(k,i))
        eigvec(1:n, i) = eigvec(1:n, i)*scal
      End Do

!     If eigenvalues are finite, order by descending absolute values
      If (all(abs(beta(1:n))>epsilon(1.0E0_dp))) Then
!       add small amount to alphai to distinguish conjugates
        alphai(1:n) = alphai(1:n) + epsilon(1.0E0_dp)*10.0_dp
        eigval(1:n) = cmplx(alphar(1:n), alphai(1:n), kind=dp)
        eigval(1:n) = eigval(1:n)/beta(1:n)
        work(1:n) = abs(eigval(1:n))
        ifail = 0
        Call nagf_sort_realmat_rank_rows(work, n, 1, n, 1, 1, 'Descending', &
          irank, ifail)
        Call nagf_sort_cmplxvec_rank_rearrange(eigval, 1, n, irank, ifail)

!       Print ordered eigenvalues
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('Gen', ' ', 1, n, eigval, 1, &
          'Eigenvalues:', ifail)

!       Order the eigenvectors in the same way and print
        Do j = 1, n
          eigval(1:n) = eigvec(j, 1:n)
          Call nagf_sort_cmplxvec_rank_rearrange(eigval, 1, n, irank, ifail)
          eigvec(j, 1:n) = eigval(1:n)
        End Do

        Write (nout, *)
        Flush (nout)
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('Gen', ' ', n, n, eigvec, n, &
          'Right Eigenvectors (columns):', ifail)
      Else
        Write (nout, *) 'Some of the eigenvalues are infinite'
        Write (nout, *)
        Flush (nout)
        ifail = 0
        Call nagf_file_print_matrix_real_gen('Gen', ' ', 1, n, alphar, 1, &
          'Alpha (real):', ifail)
        Call nagf_file_print_matrix_real_gen('Gen', ' ', 1, n, alphai, 1, &
          'Alpha (imag):', ifail)
        Call nagf_file_print_matrix_real_gen('Gen', ' ', 1, n, beta, 1, &
          'Beta:', ifail)
      End If
100   Continue

110   Format (1X, A, I4)
    End Program


      REAL FUNCTION LINT2 (TABNAM,TABLE,ILTAB,X)
      IMPLICIT NONE

*     FORMAL_PARAMETERS:
      CHARACTER*(*) TABNAM
      INTEGER ILTAB
      REAL TABLE(ILTAB), X

**    local variables
      INTEGER I1, IUP, IL, UNLOG
      REAL SLOPE, TINY
      PARAMETER (TINY=1.E-7)
      LOGICAL ERR, TOSCR, TOLOG
      SAVE

*     initialize
      ERR  = .FALSE.

*     desired output type for messages
      CALL MESSINQ (TOSCR, TOLOG, UNLOG)

*     check on value of ILTAB
      IF (MOD(ILTAB,2).NE.0 .OR. ILTAB.LE.2) THEN
         IL = MAX (1, LEN_TRIM (TABNAM))
         IF (TOSCR) WRITE (*,'(2A,/,A)')
     &    ' Number of elements in interpolation table: ',TABNAM(1:IL),
     &    ' not correct !'
         IF (TOLOG) WRITE (UNLOG,'(2A,/,A)')
     &    ' Number of elements in interpolation table: ',TABNAM(1:IL),
     &    ' not correct !'
         ERR = .TRUE.

      ELSE
         IUP = 0
         DO 10 I1=3,ILTAB,2
*           check on ascending order of X-values in function
            IF (TABLE(I1).LE.TABLE(I1-2)) THEN
               IL = MAX (1, LEN_TRIM (TABNAM))
               IF (TOSCR) WRITE (*,'(2A,/,A,I4)')
     &          ' X-coordinates in interpolation table: ',TABNAM(1:IL),
     &          ' not in ascending order at point',I1
               IF (TOLOG) WRITE (UNLOG,'(2A,/,A,I4)')
     &          ' X-coordinates in interpolation table: ',TABNAM(1:IL),
     &          ' not in ascending order at point',I1
               ERR = .TRUE.
            END IF
            IF (IUP.EQ.0 .AND. TABLE(I1).GE.X) IUP = I1
10       CONTINUE
      END IF

      IF (.NOT.ERR .AND. X.LT.TABLE(1)) THEN
         IUP = 3
         IF ((TABLE(1)-X) .GT. ABS(X)*TINY) THEN
            IL = MAX (1, LEN_TRIM (TABNAM))
            IF (TOSCR) WRITE (*,'(A,G13.5,/,2A)')
     &       ' WARNING in LINT2: X-value below defined region at X=',X,
     &       ' in interpolation table: ',TABNAM(1:IL)
            IF (TOLOG) WRITE (UNLOG,'(A,G13.5,/,2A)')
     &       ' WARNING in LINT2: X-value below defined region at X=',X,
     &       ' in interpolation table: ',TABNAM(1:IL)
         END IF
      ELSE IF (.NOT.ERR .AND. X.GT.TABLE(ILTAB-1)) THEN
         IUP = ILTAB-1
         IF ((X-TABLE(ILTAB-1)) .GT. ABS(X)*TINY) THEN
            IL = MAX (1, LEN_TRIM (TABNAM))
            IF (TOSCR) WRITE (*,'(A,G13.5,/,2A)')
     &       ' WARNING in LINT2: X-value above defined region at X=',X,
     &       ' in interpolation table: ',TABNAM(1:IL)
            IF (TOLOG) WRITE (UNLOG,'(A,G13.5,/,2A)')
     &       ' WARNING in LINT2: X-value above defined region at X=',X,
     &       ' in interpolation table: ',TABNAM(1:IL)
         END IF
      END IF

      IF (ERR) CALL FATALERR ('LINT2',' ')

*     interpolation and extrapolation
      SLOPE = (TABLE(IUP+1)-TABLE(IUP-1))/(TABLE(IUP)-TABLE(IUP-2))
      LINT2 = TABLE(IUP-1)+(X-TABLE(IUP-2))*SLOPE

      RETURN
      END


!*******************************************************************
!                                                                  *
      SUBROUTINE SIXJ3(J, K, L, M, N, ITIK, SI)
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
!                                                                  *
!     | J/2  K/2  L/2 |                                            *
!     | M/2  N/2   2  |             [B.M.X. 75]                    *
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vanderbilt University,  Nashville               October  1996  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, ONE, TWO, THREE, FOUR, SEVEN
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ixjtik_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J, K, L, M, N
      INTEGER, INTENT(IN) :: ITIK
      REAL(DOUBLE), INTENT(OUT) :: SI
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER      :: I1
      REAL(DOUBLE) :: AS, A, B, C, AKA
!-----------------------------------------------
      SI = ZERO
      IF (ITIK /= 0) THEN
!
!     CHESKED TRIANGULAR CONDITIONS
!
         IF (IXJTIK(J,K,L,M,N,6) == 0) RETURN
      ENDIF
      I1 = (J + K + L)/2
      AS = DBLE(I1)
      A = DBLE(L)
      B = DBLE(J)
      C = DBLE(K)
      AKA = ONE
      IF (MOD(I1,2) /= 0) AKA = -AKA
      IF (J - N == 6) THEN
! -3
         IF (K - M == 6) THEN
!                        -3  -3
            SI = AKA*DSQRT((AS + ONE)*AS*(AS - ONE)*(AS - TWO)*(AS - THREE)*(AS&
                - FOUR)/((B + ONE)*B*(B - ONE)*(B - TWO)*(B - THREE)*(B - FOUR)&
               *(B - THREE - TWO)))
            SI = SI*DSQRT((AS - A - THREE - TWO)*(AS - A - FOUR)*(AS - A - &
               THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - A)/((C + ONE)*C*(C - &
               ONE)*(C - TWO)*(C - THREE)*(C - FOUR)*(C - THREE - TWO)))
         ELSE IF (M - K == 6) THEN
!                        3  -3
            SI = AKA*DSQRT((AS - C)*(AS - C - ONE)*(AS - C - TWO)*(AS - C - &
               THREE)*(AS - C - FOUR)*(AS - C - THREE - TWO)/((B + ONE)*B*(B - &
               ONE)*(B - TWO)*(B - THREE)*(B - FOUR)*(B - THREE - TWO)))
            SI = SI*DSQRT((AS - B + THREE + THREE)*(AS - B + THREE + TWO)*(AS&
                - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((C&
                + FOUR + THREE)*(C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR&
               )*(C + THREE)*(C + TWO)*(C + ONE)))
         ELSE IF (K - M == 4) THEN
!                       -2  -3
            SI = AKA*DSQRT(TWO*THREE*(AS - C)*(AS - B + ONE)*(AS - THREE)*(AS&
                - TWO)*(AS - ONE)*AS*(AS + ONE)/((B - THREE - TWO)*(B - FOUR)*(&
               B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)))
            SI = SI*DSQRT((AS - A - FOUR)*(AS - A - THREE)*(AS - A - TWO)*(AS&
                - A - ONE)*(AS - A)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)&
               *C*(C + ONE)*(C + TWO)))
         ELSE IF (M - K == 4) THEN
!                        2  -3
            SI = AKA*DSQRT(TWO*THREE*(AS + ONE)*(AS - A)*(AS - C - FOUR)*(AS - &
               C - THREE)*(AS - C - TWO)*(AS - C - ONE)*(AS - C)/((C + THREE + &
               THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + &
               ONE)*C))
            SI = SI*DSQRT((AS - B + THREE + TWO)*(AS - B + FOUR)*(AS - B + &
               THREE)*(AS - B + TWO)*(AS - B + ONE)/((B - THREE - TWO)*(B - &
               FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)))
         ELSE IF (K - M == 2) THEN
!                       -1   -3
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - B&
                + TWO)*(AS - B + ONE)*(AS - TWO)*(AS - ONE)*AS*(AS + ONE)/((B&
                - THREE - TWO)*(B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B&
                + ONE)))
            SI = SI*DSQRT((AS - A - THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - &
               A)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + &
               THREE)))
         ELSE IF (M - K == 2) THEN
!                        1   -3
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - ONE)*(AS&
                - A)*(AS - C - THREE)*(AS - C - TWO)*(AS - C - ONE)*(AS - C)/((&
               B - THREE - TWO)*(B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B&
                + ONE)))
            SI = SI*DSQRT((AS - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS&
                - B + ONE)/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*&
               (C + ONE)*C*(C - ONE)))
         ELSE IF (M - K == 0) THEN
!                        0   -3
            SI = AKA*TWO*DSQRT((THREE + TWO)*(AS + ONE)*AS*(AS - ONE)*(AS - A&
                - TWO)*(AS - A - ONE)*(AS - A)/((B - THREE - TWO)*(B - FOUR)*(B&
                - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)))
            SI = SI*DSQRT((AS - C - TWO)*(AS - C - ONE)*(AS - C)*(AS - B + &
               THREE)*(AS - B + TWO)*(AS - B + ONE)/((C + FOUR)*(C + THREE)*(C&
                + TWO)*(C + ONE)*C*(C - ONE)*(C - TWO)))
         ENDIF
      ELSE IF (N - J == 6) THEN
!  3
         IF (K - M == 6) THEN
!                        -3  3
            SI = AKA*DSQRT((AS - B)*(AS - B - ONE)*(AS - B - TWO)*(AS - B - &
               THREE)*(AS - B - FOUR)*(AS - B - THREE - TWO)/((C + ONE)*C*(C - &
               ONE)*(C - TWO)*(C - THREE)*(C - FOUR)*(C - THREE - TWO)))
            SI = SI*DSQRT((AS - C + THREE + THREE)*(AS - C + THREE + TWO)*(AS&
                - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((B&
                + FOUR + THREE)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR&
               )*(B + THREE)*(B + TWO)*(B + ONE)))
         ELSE IF (M - K == 6) THEN
!                        3   3
            SI = AKA*DSQRT((AS - A + THREE + THREE)*(AS - A + THREE + TWO)*(AS&
                - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(AS - A + ONE)/((B&
                + SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B + &
               THREE)*(B + TWO)*(B + ONE)))
            SI = SI*DSQRT((AS + SEVEN)*(AS + THREE + THREE)*(AS + THREE + TWO)*&
               (AS + FOUR)*(AS + THREE)*(AS + TWO)/((C + SEVEN)*(C + THREE + &
               THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + &
               ONE)))
         ELSE IF (K - M == 4) THEN
!                       -2   3
            SI = -AKA*DSQRT(TWO*THREE*(AS - A + ONE)*(AS + TWO)*(AS - B - FOUR)&
               *(AS - B - THREE)*(AS - B - TWO)*(AS - B - ONE)*(AS - B)/((B + &
               SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B + &
               THREE)*(B + TWO)*(B + ONE)))
            SI = SI*DSQRT((AS - C + THREE + TWO)*(AS - C + FOUR)*(AS - C + &
               THREE)*(AS - C + TWO)*(AS - C + ONE)/((C - FOUR)*(C - THREE)*(C&
                - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)))
         ELSE IF (M - K == 4) THEN
!                        2   3
            SI = -AKA*DSQRT(TWO*THREE*(AS - B)*(AS - C + ONE)*(AS - A + THREE&
                + TWO)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(AS - A&
                + ONE)/((B + SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + &
               FOUR)*(B + THREE)*(B + TWO)*(B + ONE)))
            SI = SI*DSQRT((AS + THREE + THREE)*(AS + THREE + TWO)*(AS + FOUR)*(&
               AS + THREE)*(AS + TWO)/((C + THREE + THREE)*(C + THREE + TWO)*(C&
                + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C))
         ELSE IF (K - M == 2) THEN
!                       -1   3
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - A + ONE)*(AS - A + TWO)*(&
               AS + THREE)*(AS + TWO)*(AS - B - THREE)*(AS - B - TWO)*(AS - B&
                - ONE)*(AS - B)/((B + SEVEN)*(B + THREE + THREE)*(B + THREE + &
               TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)))
            SI = SI*DSQRT((AS - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS&
                - C + ONE)/((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + &
               TWO)*(C + THREE)))
         ELSE IF (M - K == 2) THEN
!                        1   3
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - C&
                + TWO)*(AS - C + ONE)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A&
                + TWO)*(AS - A + ONE)/((B + SEVEN)*(B + THREE + THREE)*(B + &
               THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)))
            SI = SI*DSQRT((AS + THREE + TWO)*(AS + FOUR)*(AS + THREE)*(AS + TWO&
               )/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*&
               C*(C - ONE)))
         ELSE IF (M - K == 0) THEN
!                        0   3
            SI = -AKA*TWO*DSQRT((THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - B&
                - TWO)*(AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((B + &
               SEVEN)*(B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B + &
               THREE)*(B + TWO)*(B + ONE)))
            SI = SI*DSQRT((AS - A + THREE)*(AS - A + TWO)*(AS - A + ONE)*(AS + &
               FOUR)*(AS + THREE)*(AS + TWO)/((C + FOUR)*(C + THREE)*(C + TWO)*&
               (C + ONE)*C*(C - ONE)*(C - TWO)))
         ENDIF
      ELSE IF (J - N == 4) THEN
! -2
         IF (K - M == 6) THEN
!                       -3  -2
            SI = AKA*DSQRT(TWO*THREE*(AS - B)*(AS - C + ONE)*(AS - THREE)*(AS&
                - TWO)*(AS - ONE)*AS*(AS + ONE)/((C - THREE - TWO)*(C - FOUR)*(&
               C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)))
            SI = SI*DSQRT((AS - A - FOUR)*(AS - A - THREE)*(AS - A - TWO)*(AS&
                - A - ONE)*(AS - A)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)&
               *B*(B + ONE)*(B + TWO)))
         ELSE IF (M - K == 6) THEN
!                       3   -2
            SI = -AKA*DSQRT(TWO*THREE*(AS - A + ONE)*(AS + TWO)*(AS - C - FOUR)&
               *(AS - C - THREE)*(AS - C - TWO)*(AS - C - ONE)*(AS - C)/((C + &
               SEVEN)*(C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C + &
               THREE)*(C + TWO)*(C + ONE)))
            SI = SI*DSQRT((AS - B + THREE + TWO)*(AS - B + FOUR)*(AS - B + &
               THREE)*(AS - B + TWO)*(AS - B + ONE)/((B - FOUR)*(B - THREE)*(B&
                - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)))
         ELSE IF (K - M == 4) THEN
!                      -2  -2
            SI = AKA*((TWO + THREE)*(AS - C)*(AS - B) - (AS + TWO)*(AS - A - &
               FOUR))*DSQRT((AS - TWO)*(AS - ONE)*AS*(AS + ONE)/((B - FOUR)*(B&
                - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)))
            SI = SI*DSQRT((AS - A - THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - &
               A)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + &
               TWO)))
         ELSE IF (M - K == 4) THEN
!                       2  -2
            SI = -AKA*((TWO + THREE)*(AS + ONE)*(AS - A + ONE) - (AS - C + ONE)&
               *(AS - B + THREE + TWO))*DSQRT((AS - C - THREE)*(AS - C - TWO)*(&
               AS - C - ONE)*(AS - C)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - &
               ONE)*B*(B + ONE)*(B + TWO)))
            SI = SI*DSQRT((AS - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS&
                - B + ONE)/((C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C&
                + THREE)*(C + TWO)*(C + ONE)*C))
         ELSE IF (K - M == 2) THEN
!                       -1  -2
            SI = AKA*(TWO*(AS - C - ONE)*(AS - B) - (AS + TWO)*(AS - A - THREE)&
               )*DSQRT(TWO*(THREE + TWO)*(AS - C)*(AS - B + ONE)*(AS - ONE)*AS*&
               (AS + ONE)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B + &
               ONE)*(B + TWO)))
            SI = SI*DSQRT((AS - A - TWO)*(AS - A - ONE)*(AS - A)/((C - THREE)*(&
               C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE)))
         ELSE IF (M - K == 2) THEN
!                        1  -2
            SI = -AKA*(TWO*AS*(AS - A + ONE) - (AS - C + ONE)*(AS - B + FOUR))*&
               DSQRT(TWO*(THREE + TWO)*(AS + ONE)*(AS - A)*(AS - C - TWO)*(AS&
                - C - ONE)*(AS - C)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)&
               *B*(B + ONE)*(B + TWO)))
            SI = SI*DSQRT((AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((C + &
               THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - &
               ONE)))
         ELSE IF (M - K == 0) THEN
!                        0  -2
            SI = -AKA*((AS - ONE)*(AS - A + ONE) - (AS - C + ONE)*(AS - B + &
               THREE))*DSQRT(TWO*THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - &
               ONE)*(AS - A)/((B - FOUR)*(B - THREE)*(B - TWO)*(B - ONE)*B*(B&
                + ONE)*(B + TWO)))
            SI = SI*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + TWO)*(AS - B + ONE)&
               /((C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE)*(C - &
               TWO)))
         ENDIF
      ELSE IF (N - J == 4) THEN
!  2
         IF (K - M == 6) THEN
!                        -3  2
            SI = AKA*DSQRT(TWO*THREE*(AS + ONE)*(AS - A)*(AS - B - FOUR)*(AS - &
               B - THREE)*(AS - B - TWO)*(AS - B - ONE)*(AS - B)/((B + THREE + &
               THREE)*(B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + &
               ONE)*B))
            SI = SI*DSQRT((AS - C + THREE + TWO)*(AS - C + FOUR)*(AS - C + &
               THREE)*(AS - C + TWO)*(AS - C + ONE)/((C - THREE - TWO)*(C - &
               FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)))
         ELSE IF (M - K == 6) THEN
!                        3  2
            SI = -AKA*DSQRT(TWO*THREE*(AS - C)*(AS - B + ONE)*(AS - A + THREE&
                + TWO)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(AS - A&
                + ONE)/((C + SEVEN)*(C + THREE + THREE)*(C + THREE + TWO)*(C + &
               FOUR)*(C + THREE)*(C + TWO)*(C + ONE)))
            SI = SI*DSQRT((AS + THREE + THREE)*(AS + THREE + TWO)*(AS + FOUR)*(&
               AS + THREE)*(AS + TWO)/((B + THREE + THREE)*(B + THREE + TWO)*(B&
                + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B))
         ELSE IF (K - M == 4) THEN
!                       -2  2
            SI = -AKA*((TWO + THREE)*(AS + ONE)*(AS - A + ONE) - (AS - B + ONE)&
               *(AS - C + THREE + TWO))*DSQRT((AS - B - THREE)*(AS - B - TWO)*(&
               AS - B - ONE)*(AS - B)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - &
               ONE)*C*(C + ONE)*(C + TWO)))
            SI = SI*DSQRT((AS - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS&
                - C + ONE)/((B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B&
                + THREE)*(B + TWO)*(B + ONE)*B))
         ELSE IF (M - K == 4) THEN
!                        2  2
            SI = AKA*((TWO + THREE)*(AS - B)*(AS - C) - (AS - A)*(AS + THREE + &
               THREE))*DSQRT((AS - A + FOUR)*(AS - A + THREE)*(AS - A + TWO)*(&
               AS - A + ONE)/((B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*&
               (B + THREE)*(B + TWO)*(B + ONE)*B))
            SI = SI*DSQRT((AS + THREE + TWO)*(AS + FOUR)*(AS + THREE)*(AS + TWO&
               )/((C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*&
               (C + TWO)*(C + ONE)*C))
         ELSE IF (K - M == 2) THEN
!                       -1  2
            SI = AKA*(TWO*(AS - A + TWO)*(AS + ONE) - (AS - B + ONE)*(AS - C + &
               FOUR))*DSQRT(TWO*(THREE + TWO)*(AS - A + ONE)*(AS + TWO)*(AS - B&
                - TWO)*(AS - B - ONE)*(AS - B)/((B + THREE + THREE)*(B + THREE&
                + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B))
            SI = SI*DSQRT((AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((C - &
               THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE)))
         ELSE IF (M - K == 2) THEN
!                        1  2
            SI = -AKA*(TWO*(AS - B - ONE)*(AS - C) - (AS - A)*(AS + THREE + TWO&
               ))*DSQRT(TWO*(THREE + TWO)*(AS - B)*(AS - C + ONE)*(AS - A + &
               THREE)*(AS - A + TWO)*(AS - A + ONE)/((B + THREE + THREE)*(B + &
               THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B))
            SI = SI*DSQRT((AS + FOUR)*(AS + THREE)*(AS + TWO)/((C + THREE + TWO&
               )*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE)))
         ELSE IF (M - K == 0) THEN
!                        0  2
            SI = AKA*((AS - B - TWO)*(AS - C) - (AS - A)*(AS + FOUR))*DSQRT(TWO&
               *THREE*(THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - C + TWO)*(AS&
                - C + ONE)/((B + THREE + THREE)*(B + THREE + TWO)*(B + FOUR)*(B&
                + THREE)*(B + TWO)*(B + ONE)*B))
            SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)&
               /((C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE)*(C - &
               TWO)))
         ENDIF
      ELSE IF (J - N == 2) THEN
! - 1
         IF (K - M == 6) THEN
!                       -3   -1
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - B)*(AS - B - ONE)*(AS - C&
                + TWO)*(AS - C + ONE)*(AS - TWO)*(AS - ONE)*AS*(AS + ONE)/((C&
                - THREE - TWO)*(C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C&
                + ONE)))
            SI = SI*DSQRT((AS - A - THREE)*(AS - A - TWO)*(AS - A - ONE)*(AS - &
               A)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + &
               THREE)))
         ELSE IF (M - K == 6) THEN
!                       3    -1
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - A + ONE)*(AS - A + TWO)*(&
               AS + THREE)*(AS + TWO)*(AS - C - THREE)*(AS - C - TWO)*(AS - C&
                - ONE)*(AS - C)/((C + SEVEN)*(C + THREE + THREE)*(C + THREE + &
               TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)))
            SI = SI*DSQRT((AS - B + FOUR)*(AS - B + THREE)*(AS - B + TWO)*(AS&
                - B + ONE)/((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + &
               TWO)*(B + THREE)))
         ELSE IF (K - M == 4) THEN
!                       -2   -1
            SI = AKA*(TWO*(AS - B - ONE)*(AS - C) - (AS + TWO)*(AS - A - THREE)&
               )*DSQRT(TWO*(THREE + TWO)*(AS - B)*(AS - C + ONE)*(AS - ONE)*AS*&
               (AS + ONE)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C + &
               ONE)*(C + TWO)))
            SI = SI*DSQRT((AS - A - TWO)*(AS - A - ONE)*(AS - A)/((B - THREE)*(&
               B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE)))
         ELSE IF (M - K == 4) THEN
!                       2    -1
            SI = AKA*(TWO*(AS - A + TWO)*(AS + ONE) - (AS - C + ONE)*(AS - B + &
               FOUR))*DSQRT(TWO*(THREE + TWO)*(AS - A + ONE)*(AS + TWO)*(AS - C&
                - TWO)*(AS - C - ONE)*(AS - C)/((C + THREE + THREE)*(C + THREE&
                + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C))
            SI = SI*DSQRT((AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((B - &
               THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE)))
         ELSE IF (K - M == 2) THEN
!                        -1   -1
            SI = AKA*(TWO*THREE*(AS - C)*(AS - C - ONE)*(AS - B - ONE)*(AS - B)&
                - TWO*FOUR*(AS - C)*(AS - B)*(AS + TWO)*(AS - A - TWO) + (AS + &
               THREE)*(AS + TWO)*(AS - A - THREE)*(AS - A - TWO))
            SI = SI*DSQRT(AS*(AS + ONE)*(AS - A - ONE)*(AS - A)/((B - THREE)*(B&
                - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE)*(C - THREE)*&
               (C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE)))
         ELSE IF (M - K == 2) THEN
!                         1   -1
            SI = AKA*(TWO*THREE*(AS + ONE)*AS*(AS - A + ONE)*(AS - A + TWO) - &
               TWO*FOUR*(AS + ONE)*(AS - A + ONE)*(AS - C + ONE)*(AS - B + &
               THREE) + (AS - C + ONE)*(AS - C + TWO)*(AS - B + FOUR)*(AS - B&
                + THREE))
            SI = SI*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + TWO)*(AS - B + ONE)&
               /((B - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + &
               THREE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + &
               ONE)*C*(C - ONE)))
         ELSE IF (M - K == 0) THEN
!                         0   -1
            SI = AKA*TWO*(AS*(AS - ONE)*(AS - A + ONE)*(AS - A + TWO) - THREE*&
               AS*(AS - A + ONE)*(AS - C + ONE)*(AS - B + TWO) + (AS - C + ONE)&
               *(AS - C + TWO)*(AS - B + THREE)*(AS - B + TWO))
            SI = SI*DSQRT(THREE*(AS + ONE)*(AS - A)*(AS - C)*(AS - B + ONE)/((B&
                - THREE)*(B - TWO)*(B - ONE)*B*(B + ONE)*(B + TWO)*(B + THREE)*&
               (C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - ONE)*(C - TWO)&
               ))
         ENDIF
      ELSE IF (N - J == 2) THEN
! - 1
         IF (K - M == 6) THEN
!                        -3   1
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - ONE)*(AS&
                - A)*(AS - B - THREE)*(AS - B - TWO)*(AS - B - ONE)*(AS - B)/((&
               C - THREE - TWO)*(C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C&
                + ONE)))
            SI = SI*DSQRT((AS - C + FOUR)*(AS - C + THREE)*(AS - C + TWO)*(AS&
                - C + ONE)/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*&
               (B + ONE)*B*(B - ONE)))
         ELSE IF (M - K == 6) THEN
!                        3    1
            SI = AKA*DSQRT(THREE*(THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - B&
                + TWO)*(AS - B + ONE)*(AS - A + FOUR)*(AS - A + THREE)*(AS - A&
                + TWO)*(AS - A + ONE)/((C + SEVEN)*(C + THREE + THREE)*(C + &
               THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)))
            SI = SI*DSQRT((AS + THREE + TWO)*(AS + FOUR)*(AS + THREE)*(AS + TWO&
               )/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*&
               B*(B - ONE)))
         ELSE IF (K - M == 4) THEN
!                        -2   1
            SI = -AKA*(TWO*AS*(AS - A + ONE) - (AS - B + ONE)*(AS - C + FOUR))*&
               DSQRT(TWO*(THREE + TWO)*(AS + ONE)*(AS - A)*(AS - B - TWO)*(AS&
                - B - ONE)*(AS - B)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)&
               *C*(C + ONE)*(C + TWO)))
            SI = SI*DSQRT((AS - C + THREE)*(AS - C + TWO)*(AS - C + ONE)/((B + &
               THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - &
               ONE)))
         ELSE IF (M - K == 4) THEN
!                         2   1
            SI = -AKA*(TWO*(AS - C - ONE)*(AS - B) - (AS - A)*(AS + THREE + TWO&
               ))*DSQRT(TWO*(THREE + TWO)*(AS - C)*(AS - B + ONE)*(AS - A + &
               THREE)*(AS - A + TWO)*(AS - A + ONE)/((C + THREE + THREE)*(C + &
               THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C))
            SI = SI*DSQRT((AS + FOUR)*(AS + THREE)*(AS + TWO)/((B + THREE + TWO&
               )*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE)))
         ELSE IF (M - K == 2) THEN
!                         1   1
            SI = AKA*(TWO*THREE*(AS - B)*(AS - B - ONE)*(AS - C)*(AS - C - ONE)&
                - TWO*FOUR*(AS - B)*(AS - C)*(AS - A)*(AS + FOUR) + (AS - A)*(&
               AS - A - ONE)*(AS + THREE + TWO)*(AS + FOUR))
            SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)&
               /((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B&
               *(B - ONE)*(C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C&
                + ONE)*C*(C - ONE)))
         ELSE IF (K - M == 2) THEN
!                        -1   1
            SI = AKA*(TWO*THREE*(AS + ONE)*AS*(AS - A + ONE)*(AS - A + TWO) - &
               TWO*FOUR*(AS + ONE)*(AS - A + ONE)*(AS - B + ONE)*(AS - C + &
               THREE) + (AS - B + ONE)*(AS - B + TWO)*(AS - C + FOUR)*(AS - C&
                + THREE))
            SI = SI*DSQRT((AS - B - ONE)*(AS - B)*(AS - C + TWO)*(AS - C + ONE)&
               /((C - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + &
               THREE)*(B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + &
               ONE)*B*(B - ONE)))
         ELSE IF (M - K == 0) THEN
!                         0   1
            SI = -AKA*TWO*((AS - B - ONE)*(AS - B - TWO)*(AS - C)*(AS - C - ONE&
               ) - THREE*(AS - B - ONE)*(AS - C)*(AS - A)*(AS + THREE) + (AS - &
               A)*(AS - A - ONE)*(AS + FOUR)*(AS + THREE))
            SI = SI*DSQRT(THREE*(AS - B)*(AS - C + ONE)*(AS - A + ONE)*(AS + &
               TWO)/((B + THREE + TWO)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + &
               ONE)*B*(B - ONE)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C&
                - ONE)*(C - TWO)))
         ENDIF
      ELSE IF (J - N == 0) THEN
!  0
         IF (K - M == 6) THEN
!                       -3    0
            SI = AKA*TWO*DSQRT((THREE + TWO)*(AS + ONE)*AS*(AS - ONE)*(AS - A&
                - TWO)*(AS - A - ONE)*(AS - A)/((C - THREE - TWO)*(C - FOUR)*(C&
                - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)))
            SI = SI*DSQRT((AS - B - TWO)*(AS - B - ONE)*(AS - B)*(AS - C + &
               THREE)*(AS - C + TWO)*(AS - C + ONE)/((B + FOUR)*(B + THREE)*(B&
                + TWO)*(B + ONE)*B*(B - ONE)*(B - TWO)))
         ELSE IF (M - K == 6) THEN
!                        3    0
            SI = -AKA*TWO*DSQRT((THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - C&
                - TWO)*(AS - B + THREE)*(AS - B + TWO)*(AS - B + ONE)/((C + &
               SEVEN)*(C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C + &
               THREE)*(C + TWO)*(C + ONE)))
            SI = SI*DSQRT((AS - A + THREE)*(AS - A + TWO)*(AS - A + ONE)*(AS + &
               FOUR)*(AS + THREE)*(AS + TWO)/((B + FOUR)*(B + THREE)*(B + TWO)*&
               (B + ONE)*B*(B - ONE)*(B - TWO)))
         ELSE IF (K - M == 4) THEN
!                       -2    0
            SI = -AKA*((AS - ONE)*(AS - A + ONE) - (AS - B + ONE)*(AS - C + &
               THREE))*DSQRT(TWO*THREE*(THREE + TWO)*(AS + ONE)*AS*(AS - A - &
               ONE)*(AS - A)/((C - FOUR)*(C - THREE)*(C - TWO)*(C - ONE)*C*(C&
                + ONE)*(C + TWO)))
            SI = SI*DSQRT((AS - B - ONE)*(AS - B)*(AS - C + TWO)*(AS - C + ONE)&
               /((B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE)*(B - &
               TWO)))
         ELSE IF (M - K == 4) THEN
!                        2    0
            SI = AKA*((AS - C - TWO)*(AS - B) - (AS - A)*(AS + FOUR))*DSQRT(TWO&
               *THREE*(THREE + TWO)*(AS - C)*(AS - C - ONE)*(AS - B + TWO)*(AS&
                - B + ONE)/((C + THREE + THREE)*(C + THREE + TWO)*(C + FOUR)*(C&
                + THREE)*(C + TWO)*(C + ONE)*C))
            SI = SI*DSQRT((AS - A + TWO)*(AS - A + ONE)*(AS + THREE)*(AS + TWO)&
               /((B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE)*(B - &
               TWO)))
         ELSE IF (K - M == 2) THEN
!                       -1    0
            SI = AKA*TWO*(AS*(AS - ONE)*(AS - A + ONE)*(AS - A + TWO) - THREE*&
               AS*(AS - A + ONE)*(AS - B + ONE)*(AS - C + TWO) + (AS - B + ONE)&
               *(AS - B + TWO)*(AS - C + THREE)*(AS - C + TWO))
            SI = SI*DSQRT(THREE*(AS + ONE)*(AS - A)*(AS - B)*(AS - C + ONE)/((C&
                - THREE)*(C - TWO)*(C - ONE)*C*(C + ONE)*(C + TWO)*(C + THREE)*&
               (B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE)*(B - TWO)&
               ))
         ELSE IF (M - K == 2) THEN
!                        1    0
            SI = -AKA*TWO*((AS - C - ONE)*(AS - C - TWO)*(AS - B)*(AS - B - ONE&
               ) - THREE*(AS - C - ONE)*(AS - B)*(AS - A)*(AS + THREE) + (AS - &
               A)*(AS - A - ONE)*(AS + FOUR)*(AS + THREE))
            SI = SI*DSQRT(THREE*(AS - C)*(AS - B + ONE)*(AS - A + ONE)*(AS + &
               TWO)/((C + THREE + TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + &
               ONE)*C*(C - ONE)*(B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B&
                - ONE)*(B - TWO)))
         ELSE IF (K - M == 0) THEN
!                        0    0
            SI = AKA*((AS - B)*(AS - B - ONE)*(AS - B - TWO)*(AS - C)*(AS - C&
                - ONE)*(AS - C - TWO) - THREE*THREE*(AS - B)*(AS - B - ONE)*(AS&
                - C)*(AS - C - ONE)*(AS - A)*(AS + TWO) + THREE*THREE*(AS - B)*&
               (AS - C)*(AS - A)*(AS - A - ONE)*(AS + THREE)*(AS + TWO) - (AS&
                - A)*(AS - A - ONE)*(AS - A - TWO)*(AS + FOUR)*(AS + THREE)*(AS&
                + TWO))
            SI = SI/DSQRT((B + FOUR)*(B + THREE)*(B + TWO)*(B + ONE)*B*(B - ONE&
               )*(B - TWO)*(C + FOUR)*(C + THREE)*(C + TWO)*(C + ONE)*C*(C - &
               ONE)*(C - TWO))
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE SIXJ3


      SUBROUTINE PHO_PECMS(Id,Pmass1,Pmass2,Ecm,Pp,Ee)
C*******************************************************************
C
C     calculation of cms momentum and energy of massive particle
C     (ID=  1 using PMASS1,  2 using PMASS2)
C
C     output:  PP    cms momentum
C              EE    energy in CMS of particle ID
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION Ecm , Ee , pm1 , pm2 , Pmass1 , Pmass2 , Pp , s
      INTEGER Id
      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  some constants
      INCLUDE 'inc/pocons'

      s = Ecm**2
      pm1 = SIGN(Pmass1**2,Pmass1)
      pm2 = SIGN(Pmass2**2,Pmass2)
      Pp = SQRT(s**2-2.D0*pm1*s-2.D0*pm2*s-2.D0*pm1*pm2+pm1**2+pm2**2)
     &     /(2.D0*Ecm)

      IF ( Id.EQ.1 ) THEN
         Ee = SQRT(pm1+Pp**2)
      ELSE IF ( Id.EQ.2 ) THEN
         Ee = SQRT(pm2+Pp**2)
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I3,/)')
     &         'PHO_PECMS:ERROR: invalid ID number:' , Id
         Ee = Pp
      END IF

      END SUBROUTINE


      double precision function vol_mass(decaymass,s)
      implicit none
      double precision decaymass,b0,bp,bm,s,vol,ro,ddilog

      ro=4d0*decaymass**2/s
      b0=dsqrt(1d0-ro)
      bp=0.5d0*(1d0+b0)
      bm=0.5d0*(1d0-b0)

c      temp=(4d0*b0*(27d0 - 26d0*b0**2 + 3d0*b0**4)
c     . + 3d0*(-1d0 + b0**2)**2*dlog((-1d0 + b0)**2)**2 +
c     . 6d0*(-1d0 + b0**2)**2*dlog(1d0-b0)*(1d0-4d0*dlog(1d0 + b0))+
c     . 6d0*(-1d0 + b0**2)*dlog(1d0 + b0)*
c     . (9d0 - b0**4 + (-1d0 + b0**2)*dlog(16d0)
c     . - 2d0*(-1d0 + b0**2)*dlog(1d0 + b0))
c     . + 3d0*(-1d0 + b0**2)*dlog((-1d0 + b0)**2)*
c     . (-8d0 + b0**4 + dlog(16d0) - b0**2*(1d0 + dlog(16d0)) +
c     . 4d0*(-1d0 + b0**2)*dlog(1d0 + b0)) +
c     . 24d0*(-1d0 + b0**2)**2*Ddilog((1d0 - b0)/2d0) -
c     . 24d0*(-1d0 + b0**2)**2*Ddilog((1d0 + b0)/2d0))/192d0
c
c--- normalize to massless case (1/12)
c      temp=temp/(1d0/12d0)

      vol_mass=b0*(1d0+5d0*ro+0.75d0*ro**2)
     . +1.5d0*ro**2*(Ddilog(bm)-Ddilog(bp))
     . -ro*dlog(bp/bm)*(24d0+6d0*ro-3d0*ro**2+6d0*ro*dlog(bp*bm))/8d0
      vol_mass=vol_mass*vol(s,4)

      return
      end


! To compile, type following command.
! gfortran vicsek.f95 gettime.c -o vicsek && ./vicsek
program main
implicit none
character filename*128
integer:: i,j, iter
integer:: iflag=0, gettime
real:: rand
integer:: num_particle, steps
parameter(num_particle=300)
real*8:: pi=atan(1.0)*4.0
real*8:: x(num_particle), y(num_particle), vx(num_particle), vy(num_particle), theta(num_particle)
real*8:: mean_ang(num_particle)=0, D(num_particle, num_particle), randarray(num_particle)
real*8:: L, vc, dt, eta, r

call system('mkdir -p data')

!L:             system size
!num_particle:  the number of particles
!vc:            constant speed
!dt:            time step
!steps:         the number of run steps
!eta:           Order
!r:             interaction radius
steps=500
L=5.0; vc=1.0; dt=0.1; eta=0.1; r=0.5
! initial condition
i=rand(gettime())
do i=1,num_particle
    theta(i) = unirand(-pi,pi)
    x(i) = unirand(0.0d0,L)
    y(i) = unirand(0.0d0,L)
    vx(i) = vc * cos(theta(i))
    vy(i) = vc * sin(theta(i))
end do

! start vicsek model
do iter=1,steps
    call filewrite(x,y,vx,vy,iter,num_particle)
    call ppdist(x,y,D,num_particle,L)
    call cal_mean_ang(D, mean_ang, theta, num_particle, r)

    !i=rand(gettime())
    do i=1,num_particle
        randarray(i) = unirand(-pi,pi)
    end do
    theta = mean_ang + eta * randarray
    vx = vc * cos(theta); vy = vc * sin(theta)
    x = x + vx * dt; y = y + vy * dt

    ! periodic boundary condition
    x = dmod((x + L), L); y = dmod((y + L), L)
end do

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! function, subroutine
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
contains
    ! uniform random number
    function unirand(a,b)
        real*8:: unirand, a, b
!       real:: rand
!       integer:: i
        unirand = a + (b-a)*rand(iflag)
    end function unirand

    ! pairwise distance
    function dist(x1, x2, y1, y2, L)
        real*8 dist, x1, x2, y1, y2, L, dx, dy
        dx = dabs(x1 - x2)
        if (dx > L-dx) then
            dx = L-dx
        end if

        dy = dabs(y1 - y2)
        if (dy > L-dy) then
            dy = L-dy
        end if
        dist = sqrt(dx**2 + dy**2)
    end function dist

    subroutine ppdist(x,y,D,num_particle,L)
        integer:: num_particle, i, j
        real*8:: x(num_particle), y(num_particle), D(num_particle,num_particle), L

        do i=1,num_particle
            do j=1,num_particle
                D(i,j) = dist(x(i),x(j), y(i), y(j), L)
            end do
        end do
    return
    end subroutine ppdist

    ! mean angle
    subroutine cal_mean_ang(D, mean_ang, theta, N, r)
        integer:: N, near_count, i, j
        real*8:: D(N,N), mean_ang(N), theta(N), list_ang(N), mean_sin, mean_cos, r

        do i=1,N
            near_count = 0
            do j=1,N
                if (D(i,j) .le. r) then
                    list_ang(near_count+1) = theta(j)
                    near_count = near_count + 1
                end if
            end do

            mean_sin=0.0d0; mean_cos=0.0d0
            do j=1,near_count
                mean_sin = mean_sin + sin(list_ang(j))
                mean_cos = mean_cos + cos(list_ang(j))
            end do
            mean_sin = mean_sin / dble(near_count)
            mean_cos = mean_cos / dble(near_count)

            mean_ang(i) = atan2(mean_sin, mean_cos)
        end do
    end subroutine cal_mean_ang

    ! file write
    subroutine filewrite(x,y,vx,vy,iter,N)
        integer:: iter, N
        real*8:: x(N), y(N), vx(N), vy(N)
        write (filename, '("./data/",i5.5, ".csv")') iter-1
            open(17,file=filename, status='replace')
                do i=1,N
                    write (17,*) x(i), ",", y(i), ",", vx(i), ",", vy(i)
                end do
            close(17)
    end subroutine filewrite
end program main


      subroutine compute_th(ctfm,ctfmp,n_a1,n_alpha,n_b1,n_beta,np1_a1,n
     &p1_alpha,np1_b1,np1_beta,x,Nx,ht,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_b1(Nx)
      real*8 n_beta(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_b1(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = 0.1D1 + myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = ((0.5000000000000000D0 / np1_alpha(i) + 0.5000000000000000D0
     #/ n_alpha(i)) * (-0.1D1 * n_b1(i) + np1_b1(i)) / ht + 0.5000000000
     #000000D0 * (0.1D1 / np1_a1(i) - 0.1D1 * np1_beta(i) / np1_alpha(i)
     #) * (-0.5000000000000000D0 * (np1_b1(i - 1) - 0.1D1 * np1_b1(i + 1
     #)) / hx / ctfmp(i) + np1_b1(i) / ctfm(i)) + 0.5000000000000000D0 *
     # (0.1D1 / n_a1(i) - 0.1D1 * n_beta(i) / n_alpha(i)) * (-0.50000000
     #00000000D0 * (n_b1(i - 1) - 0.1D1 * n_b1(i + 1)) / hx / ctfmp(i) +
     # n_b1(i) / ctfm(i))) / (0.5000000000000000D0 * np1_b1(i) + 0.50000
     #00000000000D0 * n_b1(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END


      subroutine setprob_annulus()
      implicit none

      integer iunit
      character(len=25) fname

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

      integer example
      common /example_comm/ example

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

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

      integer refine_pattern
      common /refine_comm/ refine_pattern

      double precision init_radius
      common /initradius_comm/ init_radius

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

      iunit = 10
      fname = 'setprob.data'
      open(iunit,file=fname)

      read(iunit,*) example
      read(iunit,*) revs_per_s
      read(iunit,*) cart_speed
      read(iunit,*) amplitude
      read(iunit,*) freq
      read(iunit,*) beta
      read(iunit,*) theta(1), theta(2)
      read(iunit,*) refine_pattern
      read(iunit,*) init_radius    !! radius
      close(iunit)

      cart_speed = 1.092505803290319d0

      open(10,file='mapping.dat')
      write(10,*) example
      write(10,*) amplitude
      write(10,*) init_radius
      write(10,*) beta
      write(10,*) theta(1)
      write(10,*) theta(2)
      write(10,*) freq
      write(10,*) cart_speed
      close(10)

      end


C*************************************************************
C Subroutine CHEBYFIT
C Fits a Chebyscheff polynomial to arrays XX and YY
C
C XX real*8 array, in any order (!)
C KK : Order of the polynomial (less than 19)
C ICLASS=1 if array in ascending order and need to be sorted
C	      =0 otherwise
C************************************************************
	SUBROUTINE CHEBYFIT(XX,YY,NPTS,KK,ICLASS)
	IMPLICIT REAL*8 (A-H,O-Z)
	PARAMETER (IDIM=2000)
	REAL*8 XX(NPTS),YY(NPTS)
	REAL*8 WORK1(3,IDIM),WORK2(2,20)
	REAL*8 W(IDIM),CHEBY(20),SIGMA(20),ACHEBY(20,20)
C This common block is internal to these two subroutines
	COMMON /CHEBYFIT1/CHEBY,XMIN,XMAX,DELTA
C
C	Generating the array of the weights
C
	DO I=1,NPTS
	W(I)=1.D0
	END DO
C Sort the array XX in ascending order (if ICLASS=0)
	IF(ICLASS.EQ.0)THEN
	  CALL SORT_REAL8(XX,YY,NPTS,'A')
	ENDIF
C
C Generates the coefficients of the Chebyscheff polynomial
C
C	M=NPTS : number of points to fit
C	XX=RAD : array X
C	YY=PROF1 : array Y
C	W(M) : array of the weights
C	WORK1 and WORK2 : arrays for E02ADF to work
C	ACHEBY(nrows,kplus1) : coeff. of the Chebyscheff polynomial
C	SIGMA(kplus1) : rms of the different fits of poly. of degree K
C	IFAIL : error flag
C
	M=NPTS
	KPLUS1=KK+1
	NROWS=20
	IFAIL=1
	CALL E02ADF(M,KPLUS1,NROWS,XX,YY,W,WORK1,WORK2,
	1	ACHEBY,SIGMA,IFAIL)
	IF(IFAIL.NE.0)PRINT 56,IFAIL
56	FORMAT(' WARNING : ERROR IN E02ADF    IFAIL=',I4)
	XMIN=XX(1)
	XMAX=XX(M)
	DELTA=XMAX-XMIN
C	WRITE (6,99) SIGMA(KK+1)
99	FORMAT(' RMS FOR THE FIT WITH POLYNOMIALS = ',F9.4)
C
C	Generating the array of the Chebyscheff polynomial
C
	DO IPLUS1=1,KPLUS1
	CHEBY(IPLUS1)=ACHEBY(KPLUS1,IPLUS1)
C	PRINT 100,IPLUS1,CHEBY(IPLUS1)
	END DO
100	FORMAT(' CHEBY ',I2,' : ',F10.3)
	RETURN
	END
C***************************************************************
C	Subroutine CALCHEBY
C	Calculates the image Y of X by a CHEBYSCHEFF polynomial
C***************************************************************
	SUBROUTINE CALCHEBY(X,Y,KK)
	IMPLICIT REAL*8 (A-H,O-Z)
	REAL*8 CHEBY(20)
	REAL*8 X,Y,XMIN,XMAX
C This common block is internal to these two subroutines
	COMMON /CHEBYFIT1/CHEBY,XMIN,XMAX,DELTA
C
C	Calculates the value of XCAP corresponding to X
C	(for Chebyscheff polynomials, XCAP comprised between -1 and +1
C
	XCAP=((X-XMIN)-(XMAX-X))/DELTA
	IPLUS1=KK+1
	IFAIL=1
C	IPLUS1 : degree + 1 of the polynomial
C	CHEBY(20) : array of the coeff. of the Chebyscheff function
C	IFAIL : error flag
C
	CALL E02AEF(IPLUS1,CHEBY,XCAP,Y,IFAIL)
	IF(IFAIL.NE.0)PRINT 56,IFAIL
56	FORMAT(' WARNING : ERROR IN E02AEF    IFAIL=',I4)
	RETURN
	END
C******************************************************************
	include 'jlpsub:sort_set.for'


      PROGRAM MAIN_POWER
!     Purpose: Build sparse matrix and
!              perform power iteration via calls to Sparse BLAS

!     Header file of prototypes and named constants
      USE BLAS_SPARSE
      INTEGER, PARAMETER :: NMAX = 4, NNZ = 6
      INTEGER A,I,N,NITERS,ISTAT
      INTEGER, DIMENSION(:), ALLOCATABLE :: INDX,JNDX
      REAL(KIND=DP), DIMENSION(:), ALLOCATABLE :: VAL,Q,WORK
      REAL(KIND=DP) LAMBDA

      ALLOCATE (VAL(NNZ),INDX(NNZ),JNDX(NNZ))
      ALLOCATE (Q(NMAX),WORK(NMAX))

!     -----------------------------------
!     Define matrix, in coordinate format
!     -----------------------------------
      VAL  = (/ 1.1_dp, 2.2_dp, 2.4_dp, 3.3_dp, 4.1_dp, 4.4_dp/)
      INDX = (/  1,  2,  2,  3,  4,  4/)
      JNDX = (/  1,  2,  4,  3,  1,  4/)

      N = NMAX

!     ----------------------------------
!     Step 1:  Create Sparse BLAS handle
!     ----------------------------------
      CALL DUSCR_BEGIN( N, N, A, ISTAT)

!     -----------------------------------
!     Step 2:  Insert entries all at once
!     -----------------------------------
      CALL USCR_INSERT_ENTRIES(A, VAL, INDX, JNDX, ISTAT)

!     -----------------------------------------------
!     Step 3:  Complete construction of sparse matrix
!     -----------------------------------------------
      CALL USCR_END(A, ISTAT)

!     -----------------------------------------------
!     Step 4:  Call Power Method Routine
!     -----------------------------------------------
!     q      - eigenvector approximation.
!     lambda - eigenvalue approximation.
      NITERS = 100
      CALL POWER_METHOD(A, Q, LAMBDA, N, NITERS, WORK, ISTAT)
      IF (ISTAT.NE.0) THEN
         WRITE(*,*) 'ERROR IN POWER_METHOD = ',ISTAT
      ELSE
         WRITE(*,*) 'NUMBER OF ITERATIONS = ',NITERS
         WRITE(*,*) 'APPROXIMATE DOMINANT EIGENVALUE = ',LAMBDA
      ENDIF

!     -----------------------------------------------
!     Step 5:  Release Matrix Handle
!     -----------------------------------------------
      CALL USDS(A,ISTAT)

    CONTAINS

        SUBROUTINE POWER_METHOD(A, Q, LAMBDA, N, NITERS, Z, ISTAT)
        USE BLAS_SPARSE
        IMPLICIT NONE
        REAL(KIND=DP), DIMENSION(:),INTENT(INOUT) :: Q(N),Z(N)
        REAL(KIND=DP), INTENT(OUT) :: LAMBDA
        INTEGER, INTENT(IN) :: A,N,NITERS
        INTEGER, INTENT(OUT):: ISTAT
        INTEGER I,ITER,ISEED
        REAL(KIND=DP):: NORMZ
        REAL Y
        INTRINSIC RANDOM_NUMBER,DOT_PRODUCT

        !     Fill Z by random numbers
        DO I = 1, N
           CALL RANDOM_NUMBER(HARVEST=Y)
           Z(I)=DBLE(Y)
        END DO

        DO ITER = 1, NITERS
           !Compute 2-norm of Z
           NORMZ = SQRT(DOT_PRODUCT(Z(1:N),Z(1:N)))
           !Normalize Z
           if (NORMZ.NE.0) Z(1:N) = Z(1:N)/NORMZ
           !Copy Z to Q
           Q=Z
           !Set Z to 0
           Z=0.D0
           !Compute new Z
           CALL USMV(A, Q, Z, ISTAT)
           !Test error flag
           IF (ISTAT.NE.0) RETURN
           !New LAMBDA
           LAMBDA = DOT_PRODUCT(Q,Z)
        END DO

        RETURN
        END SUBROUTINE POWER_METHOD

      END PROGRAM MAIN_POWER


       function unimod_2(T)
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: unimod_2, Eye
        real(kind=8) :: detT

        detT = det(T)
        Eye = identity2(Eye)

        unimod_2 = detT**(-1./3.) * T

       end function unimod_2

       function unimod_2s(T)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: unimod_2s, Eye
        real(kind=8) :: detT

        detT = det(T)
        Eye = identity2(Eye)

        unimod_2s = detT**(-1./3.) * T

       end function unimod_2s

       function unimod_2d(T,detT)
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: unimod_2d, Eye
        real(kind=8), intent(in) :: detT

        Eye = identity2(Eye)

        unimod_2d = detT**(-1./3.) * T

       end function unimod_2d

       function unimod_2sd(T,detT)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: unimod_2sd, Eye
        real(kind=8), intent(in) :: detT

        Eye = identity2(Eye)

        unimod_2sd = detT**(-1./3.) * T

       end function unimod_2sd


SUBROUTINE bisect(d,e,acheps,ifail)
!
! This subroutine finds the eigenvalues of a tridiagonal matrix,
! given with its diagonal elements in the array d(n) and
! its subdiagonal elements in the last n - 1 stores of the
! array e(n), using ql transformations. The eigenvalues are
! overwritten on the diagonal elements in the array d in
! ascending order. The subroutine will fail if any one
! eigenvalue takes more than 30 iterations.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::acheps
 REAL(iwp),INTENT(IN OUT)::d(0:),e(0:)
 INTEGER,INTENT(IN OUT)::ifail
 INTEGER::m,n,i,l,j,i1,m1,ii,aux
 REAL(iwp)::b,f,h,g,p,r,c,s,zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp,         &
   two=2.0_iwp
 n=UBOUND(d,1)
 IF(n/=1)THEN
   DO i=2,n
     e(i-1)=e(i)
   END DO
 END IF
 e(n)=zero
 b=zero
 f=zero
 loop_1: DO l=1,n
   j=0
   h=acheps*(ABS(d(l))+ABS(e(l)))
   IF(b<h)b=h
   ! look for small sub diagonal element
   DO  m=l,n
     IF(ABS(e(m))<=b)EXIT
   END DO
   IF(m/=l)THEN
     loop_2: DO
       IF(j==30)THEN
         ifail=1
         EXIT loop_1
       END IF
       j = j + 1
       ! form shift
       g = d(l)
       h = d(l+1) - g
       IF(ABS(h)<ABS(e(l)))THEN
         p=h*pt5/e(l)
         r=SQRT(p*p+one)
         h=p+r
         IF(p<zero)h=p-r
         d(l)=e(l)/h
       ELSE
         p=two*e(l)/h
         r=SQRT(p*p+one)
         d(l)=e(l)*p/(one+r)
       END IF
       h=g-d(l)
       i1=l+1
       IF(i1<=n)THEN
         DO i=i1,n
           d(i)=d(i)-h
         END DO
       END IF
       f=f+h
       ! ql transformation
       p=d(m)
       c=one
       s=zero
       m1=m-1
       loop_4: DO ii=l,m1
         i=m1-ii+l
         g=c*e(i)
         h=c*p
         IF(ABS(p)>=ABS(e(i)))THEN
           c= e(i)/p
           r=SQRT(c*c+one)
           e(i+1)=s*p*r
           s=c/r
           c=one/r
         ELSE
           c=p/e(i)
           r=SQRT(c*c+one)
           e(i+1)=s*e(i)*r
           s=one/r
           c=c/r
         END IF
         p=c*d(i)-s*g
         d(i+1)=h+s*(c*g+s*d(i))
       END DO loop_4
       e(l)=s*p
       d(l)=c*p
       IF(ABS(e(l))<=b)EXIT loop_2
     END DO loop_2
   END IF
   p=d(l)+f
   ! order eigenvalue
   aux=0
   IF(l/=1)THEN
     loop_3: DO ii=2,l
       i=l-ii+2
       IF(p>=d(i-1))THEN
         aux=1
         EXIT loop_3
       END IF
       d(i)=d(i-1)
     END DO loop_3
   END IF
   IF(aux==0)THEN
     i=1
   END IF
   d(i) = p
   ifail=0
 END DO loop_1
RETURN
END SUBROUTINE bisect


MODULE lorenz96
  use common
  PRIVATE

  PUBLIC :: tinteg_rk4

  INTEGER,PARAMETER,PUBLIC :: nx=40         ! number of grid points
  REAL(r_size),SAVE,PUBLIC :: dt=0.005d0    ! time of one time step
  REAL(r_size),SAVE,PUBLIC :: force=8.0d0   ! F term
  REAL(r_size),SAVE,PUBLIC :: oneday=0.2d0  ! time for one day
CONTAINS

SUBROUTINE tinteg_rk4(kt,xin,xout)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: kt
  REAL(r_size),INTENT(IN)  :: xin(1:nx)
  REAL(r_size),INTENT(OUT) :: xout(1:nx)
  REAL(r_size),ALLOCATABLE :: x(:),xtmp(:),q1(:),q2(:),q3(:),q4(:)
  INTEGER :: k
!--[1.1.1] allocation --------------------------------------------------
  ALLOCATE( x(1:nx) ) ! nx : number of grid points
  ALLOCATE( xtmp(1:nx) )
  ALLOCATE( q1(1:nx) )
  ALLOCATE( q2(1:nx) )
  ALLOCATE( q3(1:nx) )
  ALLOCATE( q4(1:nx) )
!--[1.1.2] time integration --------------------------------------------
  x(:) = xin(:)
!>>>>> TIME INTEGRATION START
  DO k=1,kt
    xtmp(:) = x(:)
    CALL lorenz96_core(xtmp,q1)
    xtmp(:) = x(:) + 0.5d0 * q1(:)
    CALL lorenz96_core(xtmp,q2)
    xtmp(:) = x(:) + 0.5d0 * q2(:)
    CALL lorenz96_core(xtmp,q3)
    xtmp(:) = x(:) + q3(:)
    CALL lorenz96_core(xtmp,q4)
    x(:) = x(:) + ( q1(:) + 2.0d0 * q2(:) + 2.0d0 * q3(:) + q4(:) ) / 6.0d0
  END DO
!<<<<< TIME INTEGRATION END
  xout(:) = x(:)
!--[1.1.3] tidy up -----------------------------------------------------
  DEALLOCATE( xtmp,q1,q2,q3,q4 )

  RETURN
END SUBROUTINE tinteg_rk4

SUBROUTINE lorenz96_core(xin,xout)
  IMPLICIT NONE

  REAL(r_size),INTENT(IN) :: xin(1:nx)
  REAL(r_size),INTENT(OUT) :: xout(1:nx)
  INTEGER :: i

  xout(1) = xin(nx) * ( xin(2) - xin(nx-1) ) - xin(1) + force
  xout(2) = xin(1) * ( xin(3) - xin(nx) ) - xin(2) + force
  DO i=3,nx-1
    xout(i) = xin(i-1) * ( xin(i+1) - xin(i-2) ) - xin(i) + force
  END DO
  xout(nx) = xin(nx-1) * ( xin(1) - xin(nx-2) ) - xin(nx) + force

  xout(:) = dt * xout(:)

  RETURN
END SUBROUTINE lorenz96_core

END MODULE lorenz96


SUBROUTINE DGEEV_F95( A, WR, WI, VL, VR, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: GEEV_F77 => LA_GEEV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:,:)
   REAL(WP), INTENT(OUT) :: WR(:), WI(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: VL(:,:), VR(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!        LA_GEEV computes for a real or complex square matrix A, the
! eigenvalues and, optionally, the left and/or right eigenvectors. A
! right eigenvector v(j) of A satisfies
!                   A * v(j) = lambda(j) * v(j)
! where lambda(j) is its eigenvalue. A left eigenvector u(j) of A
! satisffies
!                   u(j)^H * A = lambda(j) * u(j)^H
! where u(j)^H denotes the conjugate-transpose of u(j).
!
! =========
!
!       SUBROUTINE LA_GEEV( A, <w>, VL=vl, VR=vr, INFO=info )
!            <type>(<wp>), INTENT(INOUT) :: A(:,:)
!            <type>(<wp>), INTENT(OUT) :: <w(:)>
!            <type>(<wp>), INTENT(OUT), OPTIONAL :: VL(:,:), VR(:,:)
!            INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!            <type> ::= REAL | COMPLEX
!            <wp>   ::= KIND(1.0) | KIND(1.0D0)
!            <w>    ::= WR, WI | W
!            <w(:)> ::= WR(:), WI(:) | W(:)
!
! Arguments
! =========
!
! A        (input/output) REAL or COMPLEX square array, shape (:,:).
!          On entry, the matrix A.
!          On exit, the contents of A are destroyed.
! <w>      (output) REAL or COMPLEX array, shape (:) with size(w) =
!          size(A,1).
!          The computed eigenvalues.
!          <w(:)> ::= WR(:), WI(:) | W(:),
!          where
!          WR(:), WI(:) are of REAL type (for the real and imaginary
!          parts) and W(:) is of COMPLEX type.
!          Note: If A is real, then a complex-conjugate pair appear
!          consecutively, with the eigenvalue having the positive
!          imaginary part appearing first.
! VL       Optional (output) REAL or COMPLEX square array, shape (:,:)
!          with size(VL,1) = size(A,1).
!          The left eigenvectors u(j) are stored in the columns of VL in
!          the order of their eigenvalues. Each eigenvector is scaled so
!          that the Euclidean norm is 1 and the largest component is real.
!          Note: If A is real then complex eigenvectors, like their
!          eigenvalues, occur in complex conjugate pairs. The real and
!          imaginary parts of the first eigenvector of the pair are
!          stored in VL(:,j) and VL(:,j+1). Thus a complex conjugate pair
!          is given by
!            u(j) = VL(:,j) + i*VL(:,j+1), u(j+1) = VL(:,j) - i*VL(:,j+1)
! VR       Optional (output) REAL or COMPLEX square array, shape (:,:)
!          with size(VR,1) = size(A,1).
!          The right eigenvectors v(j) are stored in the columns of VR in
!          the order of their eigenvalues.
!          Each eigenvector is scaled so that the Euclidean norm is 1 and
!          the largest component is real.
!          Note: If A is real then complex eigenvectors, like their
!          eigenvalues, occur in complex conjugate pairs. The real and
!          imaginary parts of the first eigenvector of the pair are stored
!          in VR(:,j) and VR(:,j+1). Thus a complex conjugate pair is
!          given by
! 	     v(j) = VR(:,j) + i*VR(:,j+1), v(j+1) = VR(:,j) - i*VR(:,j+1)
! INFO     Optional (output) INTEGER.
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, the QR algorithm failed to compute all the
!          eigenvalues and no eigenvectors were computed. Elements
! 	   i+1 : n of <w> contain eigenvalues which have converged.
!          n is the order of A
!          If INFO is not present and an error occurs, then the program
!          is terminated with an error message.
!----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GEEV'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBVL, LJOBVR
   INTEGER, SAVE :: LWORK = 0
   INTEGER :: N, NN, LINFO, LD, ISTAT, ISTAT1, S1VL, S2VL, S1VR, S2VR
!  .. LOCAL ARRAYS ..
   REAL(WP), TARGET :: LLVL(1,1), LLVR(1,1)
   REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A,1); LD = MAX(1,N)
   IF( PRESENT(VL) )THEN; S1VL = SIZE(VL,1); S2VL = SIZE(VL,2); LJOBVL = 'V'
   ELSE; S1VL = 1; S2VL = 1; LJOBVL = 'N'; END IF
   IF( PRESENT(VR) )THEN; S1VR = SIZE(VR,1); S2VR = SIZE(VR,2); LJOBVR = 'V'
   ELSE; S1VR = 1; S2VR = 1; LJOBVR = 'N'; END IF
!  .. TEST THE ARGUMENTS
   IF( N < 0 .OR. SIZE(A,2) /= N )THEN; LINFO = -1
   ELSE IF( SIZE( WR ) /= N )THEN; LINFO = -2
   ELSE IF( SIZE( WI ) /= N )THEN; LINFO = -3
   ELSE IF( PRESENT(VL) .AND. ( S1VL /= N .OR. S2VL /= N ) )THEN; LINFO = -4
   ELSE IF( PRESENT(VR) .AND. ( S1VR /= N .OR. S2VR /= N ) )THEN; LINFO = -5
   ELSE IF( N > 0 )THEN
      NN = 3; IF( LSAME(LJOBVL,'V').OR.LSAME(LJOBVR,'V') ) NN = NN + 1
      LWORK = MAX( 1, NN*N, LWORK); ALLOCATE(WORK(LWORK), STAT=ISTAT)
         IF( ISTAT /= 0 )THEN; DEALLOCATE(WORK,STAT=ISTAT1)
            LWORK = MAX( 1, NN*N ); ALLOCATE(WORK(LWORK), STAT=ISTAT)
            IF( ISTAT == 0) CALL ERINFO( -200, SRNAME, LINFO )
         END IF
      IF( ISTAT == 0 ) THEN
        IF( PRESENT(VL) )THEN
           IF( PRESENT(VR) )THEN
               CALL GEEV_F77( LJOBVL, LJOBVR, N, A, LD, WR, WI, &
                        VL, S1VL, VR, S1VR, WORK, LWORK, LINFO )
	   ELSE
	      CALL GEEV_F77( LJOBVL, LJOBVR, N, A, LD, WR, WI, &
                        VL, S1VL, LLVR, S1VR, WORK, LWORK, LINFO )
	   ENDIF
	 ELSE
	   IF( PRESENT(VR) )THEN
	       CALL GEEV_F77( LJOBVL, LJOBVR, N, A, LD, WR, WI, &
                        LLVL, S1VL, VR, S1VR, WORK, LWORK, LINFO )
	   ELSE
	       CALL GEEV_F77( LJOBVL, LJOBVR, N, A, LD, WR, WI, &
                        LLVL, S1VL, LLVR, S1VR, WORK, LWORK, LINFO )
	   ENDIF
	 ENDIF
         IF( LINFO == 0 ) LWORK = INT(WORK(1)+1)
      ELSE; LINFO = -100; ENDIF
      DEALLOCATE(WORK, STAT=ISTAT1)
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE DGEEV_F95