!module METS2AORSA

!  private
!  public:: WMATPRECALC_AORSA,GETNONMAXSWMAT_AORSA,GETNONMAXSWMAT_AORSA_NEW

!contains

!
!*************************************************************************
!

  subroutine WMATPRECALC_AORSA(ZSPEC,ASPEC,ENORM,BMAG,KPER,UPER, &
       &                   NUPER,NBESSJ,NBESSJ_START,XI,JNXI,IFAIL)
    implicit none
    real, intent(IN):: ZSPEC, ASPEC, ENORM,BMAG,KPER
    integer, intent(IN):: NUPER
    real, dimension(NUPER), intent(IN):: UPER
    integer, intent(IN):: NBESSJ,NBESSJ_START
    real, dimension(NUPER), intent(OUT):: XI
    real, dimension(NUPER,NBESSJ), intent(OUT):: JNXI
    integer, intent(OUT):: IFAIL

    real, parameter:: EOVERAMU=9.64853e7
    real, parameter:: EVPERAMU=9.314943e8
    real, parameter:: MPC2=938271998.38
    real, parameter:: C=2.99792458e8
    real:: WC,MUT0,SQMUT0

    MUT0=0.5*MPC2*ASPEC/ENORM
    SQMUT0=SQRT(MUT0)
    WC=BMAG*ZSPEC*EOVERAMU/ASPEC
    XI(:)=KPER*UPER(:)*C/SQMUT0/WC

    call BESSJ(XI(1),JNXI(1,1),NUPER,NBESSJ,NBESSJ_START)

  end subroutine WMATPRECALC_AORSA

!
!*************************************************************************
!

  subroutine GETNONMAXSIGMA_AORSA_NEW(W,ZSPEC,ASPEC,DENS,BMAG, &
       & K1,XI1,JNXI1,K2,XI2,JNXI2,NBESSJ,ENORM,UPARMIN,UPARMAX, &
       & NUPAR,NUPER,UPER,UPAR,DFDUPER,DFDUPAR,WSPEC,IFAIL)
    implicit none
    real, intent(IN):: W,ZSPEC,ASPEC,DENS,BMAG
    real, dimension(3):: K1,K2
    integer, intent(IN):: NUPAR,NUPER,NBESSJ
    real, dimension(NUPER), intent(IN):: XI1,XI2
    real, dimension(NUPER, NBESSJ), intent(IN):: JNXI1,JNXI2
    real, intent(IN):: ENORM,UPARMIN,UPARMAX
    real, dimension(NUPER), intent(IN):: UPER
    real, dimension(NUPAR), intent(IN):: UPAR
    real, dimension(NUPER,NUPAR), intent(IN):: DFDUPER,DFDUPAR
    real  DFDTH(NUPER,NUPAR)
    complex, dimension(3,3), intent(OUT):: WSPEC
    integer, intent(OUT):: IFAIL

    complex:: BETAFACT
    real, parameter:: EOVERAMU = 9.64853e7
    real, parameter:: WP2FACT=1.745915
    real, parameter:: MPC2=938271998.38
    real, parameter:: C=2.99792458e8
    real, parameter:: PI=3.141592653597932384
    real, dimension(NUPER):: JN0XI1,JNP1XI1,JNM1XI1
    real, dimension(NUPER):: JN0XI2,JNP1XI2,JNM1XI2
    real, dimension(NUPER,3,3):: SSGG
    real, dimension(NUPAR,3,3):: SGG

    real ga_33(nupar)
    real, dimension(NUPAR,-1:NBESSJ-2) :: sgg_31
    real, dimension(NUPAR,-1:NBESSJ-2) :: sgg_11

    real, dimension(NUPAR) :: sgg_31_last, sgg_21p
    real, dimension(3,3):: THETARE,THETAIM
    real:: W2,WP2,WPFACT,WCW,RRP,RRM,RR,IRR, du_3, g_33, g_33j
    real:: MUT0,SQMUT0,BETA1,BETA2,KPARA1,NPARA1
    real:: ISQ2,CUPAR,CUPER,NWCW,DFACTPAR,DFACTPER,LF0,LNF0UPER
    real:: DFACTPERI
    real:: UPAR0,SFACT0,SFACTP1,SFACTM1, factor, kperp2, vperp_norm2
    real:: ssgg_11,ssgg_22,ssgg_31,ssgg_33,ssgg_32,ssgg_21,du, temp
    integer:: NHARM,IHARM,NJ,NJP1,NJM1,J,K,M,N

    logical, parameter :: use_original  = .false.
    logical, parameter :: use_gemm  = .false.
    real, dimension(nupar) :: irr_j, rr_j

    integer :: kdim,  jdim
    real, dimension(nuper,nupar) :: LF0kj
    real :: ssgg_11a,ssgg_33a, ssgg_31a
    real :: maxabserr, maxrelerr
    real :: abserr_11, abserr_33, abserr_31
    real :: relerr_11, relerr_33, relerr_31

    real, dimension(:,:), pointer :: JN0N0,JN0N0U,JN0N1U
    real, dimension(:,:), pointer :: LF0JN0N0, LF0JN0N0U, LF0JN0N1U
    real, dimension(nupar,3*nbessj-1), target :: Jmat
    real, dimension(nuper,3*nbessj-1), target :: Kmat

    integer :: mm,nn,kk,ld1,ld2,ld3
    real :: alpha,beta

    integer :: mn
    integer, dimension(6) :: mlist,nlist
    real, dimension(3,3) :: sumsgg_even, sumsgg_odd
    real :: sum_even, sum_odd, JNP1XI1_K, JN0XI1_K
!dir$ ssp_private CAUCHY_PPART2

    jdim = nupar
    kdim = nuper

    mn = 1
    do m=1,3
    do n=1,m
      mlist(mn) = m
      nlist(mn) = n
      mn = mn+1
    enddo
    enddo

    IFAIL=0
    WSPEC(1:3,1:3) = cmplx(0.,0.)
    W2=W*W
    WP2=DENS*ZSPEC**2*WP2FACT/ASPEC
    WPFACT=WP2/W2
    WCW=BMAG*ZSPEC*EOVERAMU/ASPEC/W
    BETA1=ATAN2(K1(2),K1(1))
    BETA2=ATAN2(K2(2),K2(1))
    KPARA1=K1(3)
    NPARA1=KPARA1*C/W
    MUT0=0.5*MPC2*ASPEC/ENORM
    SQMUT0=SQRT(MUT0)
    DFACTPER = NPARA1 / SQMUT0
    DFACTPERI = 1.0 / DFACTPER
    ISQ2=SQRT(0.5)
    NHARM=NBESSJ-2
    kperp2 = k1(1)*k1(1)+ k1(2)*k1(2)
    vperp_norm2 = mut0*wcw*wcw*w2/c/c/kperp2  ! need to fix kperp = 0

!      -------------------------------------------------------
!      do extra integral (STIX) to convert all elements to "U"
!      do perpendicular integral by inline trapezoidal rule
!      and parallel integral by simpson's rule
!      -------------------------------------------------------
    if (use_original) then

        do J = 1, NUPAR
	  g_33j = 0.0

          do K = 2, NUPER - 1
             g_33j = g_33j +                                                 &
     &         UPAR(J)*(UPER(K)*DFDUPAR(K,J)-UPAR(J)*DFDUPER(K,J))
          end do

	  k = 1
          g_33j = g_33j +                                                    &
     &      0.5 * UPAR(J)*(UPER(K)*DFDUPAR(K,J)-UPAR(J)*DFDUPER(K,J))

	  k = nuper
          g_33j = g_33j +                                                    &
     &      0.5 * UPAR(J)*(UPER(K)*DFDUPAR(K,J)-UPAR(J)*DFDUPER(K,J))

	  du = (uper(nuper) - uper(1))/(nuper - 1)
	  ga_33(j) = g_33j * du

       end do

       g_33  = 0.0

!      the uperp integral is done; now do parallel integral by simpson's rule

       call EQSIMPSON1D_2(NUPAR, UPAR, ga_33, g_33)

       do j = 1, nupar
       do k = 1 , nuper
	     DFDTH(k,j) = upar(j) * DFDUPER(k,j) - uper(k) * DFDUPAR(k,j)
       end do
       end do

     else
       do j = 1, nupar
       do k = 1 , nuper
	     DFDTH(k,j) = upar(j) * DFDUPER(k,j) - uper(k) * DFDUPAR(k,j)
       end do
       end do

        du = (uper(nuper) - uper(1))/(nuper - 1)
        do J = 1, NUPAR

          g_33j =  0.0
          do K = 2, NUPER - 1
             g_33j = g_33j + DFDTH(k,j)
          end do
          k = 1
          g_33j = g_33j + 0.5d0*DFDTH(k,j)
          k = nuper
          g_33j = g_33j + 0.5d0*DFDTH(k,j)

          g_33j = upar(j)*(-g_33j)

          ga_33(j) = g_33j  * du

        enddo

         g_33  = 0.0

!      the uperp integral is done; now do parallel integral by simpson's rule

       call EQSIMPSON1D_2(NUPAR, UPAR, ga_33, g_33)

     endif

     if (.not.use_original) then

    JN0N0 => Kmat(1:kdim,1:nbessj)
    JN0N0U => Kmat(1:kdim,(nbessj+1):(2*nbessj) )
    JN0N1U => Kmat(1:kdim,(2*nbessj+1):(2*nbessj+nbessj-1) )

    LF0JN0N0 => Jmat(1:jdim,1:nbessj)
    LF0JN0N0U => Jmat(1:jdim,(nbessj+1):(2*nbessj) )
    LF0JN0N1U => Jmat(1:jdim,(2*nbessj+1):(2*nbessj+nbessj-1) )

      do j=1,jdim
      do k=1,kdim
        LF0kj(k,j) = DFDUPER(K,J) - DFACTPER * dfdth(k,j)
      enddo
      enddo

!     -------------------------------
!     precompute LF0kj(k,j) * vectors
!     -------------------------------
      do nj=1,nbessj
        do k=1,kdim
         JN0N0(k,nj) = JNXI1(k,nj)**2
         JN0N0U(k,nj) = (JNXI1(k,nj) * UPER(k))**2
        enddo
      enddo
      do nj=1,nbessj-1
        do k=1,kdim
          JN0N1U(k,nj) = JNXI1(k,nj)*JNXI1(k,nj+1)*UPER(k)
        enddo
      enddo

!	-----------------------------
!	one big happy matrix multiply
!	-----------------------------
        if (use_gemm) then

        mm = jdim
        nn = 3*nbessj-1
        kk = (kdim-1) - 2 + 1
        ld1 = size(LF0kj,1)
        ld2 = size(Kmat,1)
        ld3 = size(Jmat,1)
        alpha = 1.0
        beta = 0.0
        call dgemm( 'T', 'N', mm,nn,kk,                 &
            alpha, LF0kj(2,1), ld1,   Kmat(2,1),ld2,    &
            beta,  Jmat(1,1), ld3 )

        else

!       LF0JN0N0(1:jdim,1:nbessj) = matmul(                    &
!                         transpose(LF0kj(2:(kdim-1),1:jdim)), &
! 			JN0N0(2:(kdim-1),1:nbessj) )
!       LF0JN0N0U(1:jdim,1:nbessj) = matmul(               &
!                         transpose(LF0kj(2:(kdim-1),1:jdim)), &
!                         JN0N0U(2:(kdim-1),1:nbessj) )
!       LF0JN0N1U(1:jdim,1:(nbessj-1)) = matmul(               &
!                         transpose(LF0kj(2:(kdim-1),1:jdim)), &
!                         JN0N1U(2:(kdim-1),1:(nbessj-1))  )

         Jmat(1:jdim,1:(3*nbessj-1)) = matmul(                  &
             transpose( LF0kj(2:(kdim-1), 1:jdim)),             &
                        Kmat(2:(kdim-1),1:(3*nbessj-1))  )

        endif

       endif

      maxabserr = 0.0
      maxrelerr = 0.0

!      -------------------
!      Loop over harmonics
!      -------------------

    do IHARM = -1, NHARM

       NWCW=real(IHARM)*WCW  !L*omega_cyc

       BETAFACT=exp(cmplx(0.,IHARM*(BETA1-BETA2)))
       NJ=ABS(IHARM)+1
       NJP1=ABS(IHARM+1)+1
       NJM1=ABS(IHARM-1)+1
       SFACT0=real(sign(1,IHARM))**ABS(IHARM)
       SFACTP1=real(sign(1,IHARM+1))**ABS(IHARM+1)
       SFACTM1=real(sign(1,IHARM-1))**ABS(IHARM-1)

       if (use_original) then
       JN0XI1(1:NUPER)=SFACT0*JNXI1(1:NUPER,NJ)
       JNP1XI1(1:NUPER)=SFACTP1*JNXI1(1:NUPER,NJP1)
       JNM1XI1(1:NUPER)=SFACTM1*JNXI1(1:NUPER,NJM1)
       endif

       ! -- Build array with integrand -- !

       do J=1,NUPAR

          ssgg_11 = 0.0
          ssgg_31 = 0.0
          ssgg_33 = 0.0

          if (use_original) then

          do K = 2, NUPER - 1

             LF0 = DFDUPER(K,J) - DFACTPER * dfdth(k,j)
             ssgg_33 = ssgg_33 + JN0XI1(K)**2 *LF0

             LF0 = UPER(K) * JNP1XI1(K) * LF0
             ssgg_11 = ssgg_11 + UPER(K) * JNP1XI1(K)* LF0
             ssgg_31 = ssgg_31 + UPAR(J) * JN0XI1(K) * LF0
          end do

          else
!         --------------------------------------------
!         sums already computed in the matrix multiply
!         --------------------------------------------

          ssgg_33a = LF0JN0N0(j,nj) * (sfact0**2)
          ssgg_11a = LF0JN0N0U(j,njp1) * (sfactp1**2)

!         -------------------------------------
!         note it is possible for njp1 .lt. nj
!         -------------------------------------
          ssgg_31a = LF0JN0N1U(j,min(nj,njp1)) * (sfact0*sfactp1) * upar(j)

          ssgg_33 = ssgg_33a
          ssgg_11 = ssgg_11a
          ssgg_31 = ssgg_31a

          endif

!

          ssgg_11 = ssgg_11 * 0.5
	    ssgg_31 = ssgg_31 * ISQ2

          if (use_original) then
	    k = 1

          LF0 = DFDUPER(K,J) - DFACTPER * dfdth(k,j)
          ssgg_33 = ssgg_33 + 0.5 * JN0XI1(K)**2 *LF0

          LF0 = UPER(K) * JNP1XI1(K) * LF0
          ssgg_11 = ssgg_11 + 0.25 *       UPER(K) * JNP1XI1(K)* LF0
          ssgg_31 = ssgg_31 + 0.5 * ISQ2 * UPAR(J) * JN0XI1(K) * LF0

	  k = nuper

	  LF0 = DFDUPER(K,J) - DFACTPER * dfdth(k,j)
	  ssgg_33 = ssgg_33 + 0.5 * LF0 * JN0XI1(K)**2

	  LF0 = UPER(K) * JNP1XI1(K) * LF0
	  ssgg_11 = ssgg_11 + 0.25 *       UPER(K) * JNP1XI1(K)* LF0
          ssgg_31 = ssgg_31 + 0.5 * ISQ2 * UPAR(J) * JN0XI1(K) * LF0

          else
!         ---------------------------------------------------
!         no need to form vectors for JN0XI1(:) or JNP1XI1(:)
!         ---------------------------------------------------

          k = 1

          LF0 = LF0kj(k,j)
          JN0XI1_K = (sfact0*JNXI1(k,nj))
          ssgg_33 = ssgg_33 + 0.5 * JN0XI1_K**2 *LF0

          JNP1XI1_k = (sfactp1*JNXI1(k,njp1))
          LF0 = UPER(K) * JNP1XI1_K * LF0
          ssgg_11 = ssgg_11 + 0.25 *       UPER(K) * JNP1XI1_K * LF0
          ssgg_31 = ssgg_31 + 0.5 * ISQ2 * UPAR(J) * JN0XI1_K  * LF0

          k = nuper

          LF0 = LF0kj(k,j)
          JN0XI1_K = (sfact0*JNXI1(k,nj))
          ssgg_33 = ssgg_33 + 0.5 * LF0 * JN0XI1_K**2

          JNP1XI1_K = (sfactp1 * JNXI1(k,njp1))
          LF0 = UPER(K) * JNP1XI1_K  * LF0
          ssgg_11 = ssgg_11 + 0.25 *       UPER(K) * JNP1XI1_K * LF0
          ssgg_31 = ssgg_31 + 0.5 * ISQ2 * UPAR(J) * JN0XI1_K  * LF0

          endif

       !  end of the kperp loop

	  du = (uper(nuper) - uper(1))/(nuper - 1)
	  sgg_11(j,iharm) =  ssgg_11 * du
	  sgg_21p(j) =  ssgg_33 * du  ! this is a piece of 21
	  sgg_31(j,iharm) =	ssgg_31 * du
	  SGG(j,3,3) =	UPAR(J)**2 * sgg_21p(j)

       end do

!      the perp integrals have been calculated now do
!      parallel, but reuse them for negative harmonics

       if(iharm .eq. -1) cycle

       du_3 = (UPAR(NUPAR)-UPAR(1))/real(nupar-1)/3.
	 SGG(1:nupar,1,1) = sgg_11(1:nupar,iharm)

	 ! do the 31--32, 21, 22 compression

	 select case(iharm)
	 case(0)
            SGG(1:nupar,2,2) = sgg_11(1:nupar,iharm)  ! no -2 for 0 but they are the same
	    SGG(1:nupar,2,1) = - SGG(1:nupar,2,2)     ! 12--21 are anti symmetric
	 case default
	    SGG(1:nupar,2,2) = sgg_11(1:nupar,iharm-2)!  look two back for 22
            SGG(1:nupar,2,1) = -0.5*(SGG(1:nupar,1,1)+ SGG(1:nupar,2,2))&
	      &+ vperp_norm2*iharm*iharm*(sgg_21p(1:nupar))  ! use bessel function identity for 21
	 end select

	 SGG(1:nupar,3,2) = sgg_31(1:nupar,iharm-1)
	 SGG(1:nupar,3,1) = sgg_31(1:nupar,iharm)

       ! -- Resonance relation -- !

       RRP=1. - NWCW - DFACTPER * UPARMAX
       RRM=1. - NWCW - DFACTPER * UPARMIN

       if (RRP*RRM.GT.0) then
          ! -- No resonance here -- !

          if (use_original) then
          do J=1,NUPAR
             RR = 1.- NWCW - DFACTPER * UPAR(J)
             IRR = 1. / RR
             do M=1,3
                do N=1,M
                   SGG(J,M,N) = SGG(J,M,N) * IRR
                end do
             end do
          end do

          else
          do J=1,NUPAR
             RR = 1.- NWCW - DFACTPER * UPAR(J)
             IRR = 1. / RR
             rr_j(j) = rr
             irr_j(j) = irr
          enddo

!dir$     concurrent
          do mn=1,6
           m = mlist(mn)
           n = nlist(mn)

           do j=1,nupar
            IRR = irr_j(j)
	    SGG(J,M,N) = SGG(J,M,N) * IRR
           enddo

          end do

          endif

          !-- Hermitian part of $\Theta/(2\pi)$ --!

          if (use_original) then
	  THETARE(1,1) = (sgg(1,1,1)+sgg(nupar,1,1)+2.*sum(sgg(2:nupar-1,1,1)) +&
	       & 2.*sum(sgg(2:nupar-1:2,1,1)))*du_3
	  THETARE(2,1) = (SGG(1,2,1)+SGG(nupar,2,1)+2.*sum(SGG(2:nupar-1,2,1)) +&
	       & 2.*sum(SGG(2:nupar-1:2,2,1)))*du_3
	  THETARE(3,1) = (sgg(1,3,1)+sgg(nupar,3,1)+2.*sum(sgg(2:nupar-1,3,1)) +&
	       & 2.*sum(sgg(2:nupar-1:2,3,1)))*du_3
	  THETARE(2,2) = (sgg(1,2,2)+sgg(nupar,2,2)+2.*sum(sgg(2:nupar-1,2,2)) +&
	       & 2.*sum(sgg(2:nupar-1:2,2,2)))*du_3
          THETARE(3,2) = (sgg(1,3,2)+sgg(nupar,3,2)+2.*sum(sgg(2:nupar-1,3,2)) +&
	       & 2.*sum(sgg(2:nupar-1:2,3,2)))*du_3
	  THETARE(3,3) = (sgg(1,3,3)+sgg(nupar,3,3)+2.*sum(sgg(2:nupar-1,3,3)) +&
	       & 2.*sum(sgg(2:nupar-1:2,3,3)))*du_3
          else

!dir$     concurrent,preferstream,novector
            do mn=1,6
               m = mlist(mn)
               n = nlist(mn)
!dir$ vector
               sum_even = sum(sgg(2:(nupar-1):2,m,n))
               sum_odd  = sum(sgg(3:(nupar-1):2,m,n))

               thetare(m,n) = (sgg(1,m,n) + sgg(nupar,m,n) +    &
                   2.0d0*(sum_odd + sum_even) + 2.0d0*sum_even ) * du_3
            enddo
           endif

          if (use_original) then
	  do J=1,NUPAR ! restore sgg
	     RR = 1.- NWCW - DFACTPER * UPAR(J)

             do M=1,3
                do N=1,M
                   SGG(J,M,N) = SGG(J,M,N) * RR
                end do
             end do

          end do
          else

!dir$        concurrent
             do mn=1,6
              m = mlist(mn)
              n = nlist(mn)

              do j=1,nupar
                   SGG(J,M,N) = SGG(J,M,N) * rr_j(j)
              enddo
             end do

          endif

 	  THETARE(1,2) = THETARE(2,1)
          THETARE(1,3) = THETARE(3,1)
          THETARE(2,3) = THETARE(3,2)

          !-- Anti-hermitian part of $\Theta/(2\pi)$ --!
          THETAIM(1:3,1:3)=0.

       else

          ! -- There is a resonance all right -- !
          ! -- 1. Hermitian part -- !
          UPAR0 = (1. - NWCW) * DFACTPERI

          if (use_original) then
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,1,1),THETARE(1,1))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,2,1),THETARE(2,1))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,1),THETARE(3,1))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,2,2),THETARE(2,2))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,2),THETARE(3,2))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,3),THETARE(3,3))
          else
!dir$       concurrent
            do mn=1,6
             m = mlist(mn)
             n = nlist(mn)
             call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,m,n),THETARE(m,n))
            enddo
          endif

          THETARE(1,2) = THETARE(2,1)
          THETARE(1,3) = THETARE(3,1)
          THETARE(2,3) = THETARE(3,2)

          ! -- 2. Anti-hermitian part -- !
          call WINTERP1D_2(UPAR,NUPAR,SGG(1,1,1),UPAR0,THETAIM(1,1))
          call WINTERP1D_2(UPAR,NUPAR,SGG(1,2,1),UPAR0,THETAIM(2,1))
          call WINTERP1D_2(UPAR,NUPAR,SGG(1,3,1),UPAR0,THETAIM(3,1))
          call WINTERP1D_2(UPAR,NUPAR,SGG(1,2,2),UPAR0,THETAIM(2,2))
          call WINTERP1D_2(UPAR,NUPAR,SGG(1,3,2),UPAR0,THETAIM(3,2))
          call WINTERP1D_2(UPAR,NUPAR,SGG(1,3,3),UPAR0,THETAIM(3,3))

          THETAIM(1,2) = THETAIM(2,1)
          THETAIM(1,3) = THETAIM(3,1)
          THETAIM(2,3) = THETAIM(3,2)

          do M=1,3
             do N=1,3
                THETARE(M,N) = -THETARE(M,N) * DFACTPERI
                THETAIM(M,N) = -PI * THETAIM(M,N) * abs(DFACTPERI)
             end do
          end do

       end if

       do N=1,3
          do M=1,3
             WSPEC(M,N)=WSPEC(M,N)+2.*PI*WPFACT*BETAFACT*cmplx(THETARE(M,N),THETAIM(M,N))
          end do
       end do

	 if(iharm .ne. 0) then  !  skip the negative for zero

	    nwcw = - nwcw

      	  ! -- Resonance relation -- !

          RRP = 1. - NWCW - DFACTPER * UPARMAX
          RRM = 1. - NWCW - DFACTPER * UPARMIN

          if (RRP*RRM.GT.0) then
      	 ! -- No resonance here -- !

          if (use_original) then
      	  do J=1,NUPAR

             RR = 1. - NWCW - DFACTPER * UPAR(J)
             IRR = 1. / RR
             do M=1,3
                do N = 1,M
                   SGG(J,M,N) = SGG(J,M,N) * IRR
                end do
             end do
      	  end do
          else
            do J=1,NUPAR
             RR = 1.- NWCW - DFACTPER * UPAR(J)
             IRR = 1. / RR
             rr_j(j) = rr
             irr_j(j) = irr
            enddo

             do mn=1,6
              m = mlist(mn)
              n = nlist(mn)
              do j=1,nupar
                   IRR = irr_j(j)
                   SGG(J,M,N) = SGG(J,M,N) * IRR
              enddo
             end do

          endif

          !-- Hermitian part of $\Theta/(2\pi)$ --!

          if (use_original) then
	  THETARE(1,1) = (sgg(1,1,1)+sgg(nupar,1,1)+2.*sum(sgg(2:nupar-1,1,1)) +&
	       & 2.*sum(sgg(2:nupar-1:2,1,1)))*du_3
	  THETARE(2,1) = (SGG(1,2,1)+SGG(nupar,2,1)+2.*sum(SGG(2:nupar-1,2,1)) +&
	       & 2.*sum(SGG(2:nupar-1:2,2,1)))*du_3
	  THETARE(3,1) = (sgg(1,3,1)+sgg(nupar,3,1)+2.*sum(sgg(2:nupar-1,3,1)) +&
	       & 2.*sum(sgg(2:nupar-1:2,3,1)))*du_3
	  THETARE(2,2) = (sgg(1,2,2)+sgg(nupar,2,2)+2.*sum(sgg(2:nupar-1,2,2)) +&
	       & 2.*sum(sgg(2:nupar-1:2,2,2)))*du_3
          THETARE(3,2) = (sgg(1,3,2)+sgg(nupar,3,2)+2.*sum(sgg(2:nupar-1,3,2)) +&
	       & 2.*sum(sgg(2:nupar-1:2,3,2)))*du_3
	  THETARE(3,3) = (sgg(1,3,3)+sgg(nupar,3,3)+2.*sum(sgg(2:nupar-1,3,3)) +&
	       & 2.*sum(sgg(2:nupar-1:2,3,3)))*du_3
          else
!dir$     concurrent,preferstream,novector

             do mn=1,6
!dir$     vector
               m = mlist(mn)
               n = nlist(mn)

               sum_even = sum(sgg(2:(nupar-1):2,m,n))
               sum_odd  = sum(sgg(3:(nupar-1):2,m,n))

               thetare(m,n) = (sgg(1,m,n)+sgg(nupar,m,n) +     &
                  2.0d0*(sum_even + sum_odd) + 2.0d0*sum_even) * du_3
             enddo
           endif

          if (use_original) then
          do J=1,NUPAR  ! restore sgg
             RR=1.- NWCW - DFACTPER * UPAR(J)
	     do M=1,3
                do N=1,M
                   SGG(J,M,N) = SGG(J,M,N) * RR
            	end do
             end do
      	  end do
          else

!dir$        concurrent
             do mn=1,6
               m = mlist(mn)
               n = nlist(mn)

               do j=1,nupar
                   SGG(J,M,N) = SGG(J,M,N)  * rr_j(j)
               enddo

             end do
          endif

	  temp = THETARE(3,2)
	  THETARE(3,2) = -THETARE(3,1)
	  THETARE(3,1) = -temp

	  temp = THETARE(1,1)
	  THETARE(1,1) = THETARE(2,2)
	  THETARE(2,2) = temp

 	  THETARE(1,2) = THETARE(2,1)
      	  THETARE(1,3) = THETARE(3,1)
      	  THETARE(2,3) = THETARE(3,2)

      	 !-- Anti-hermitian part of $\Theta/(2\pi)$ --!
      	 THETAIM(1:3,1:3)=0.

          else

      	 ! -- There is a resonance all right -- !
      	 ! -- 1. Hermitian part -- !

      	 UPAR0 = DFACTPERI * (1. - NWCW)

         if (use_original) then
      	 call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,1,1),THETARE(1,1))
      	 call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,2,1),THETARE(2,1))
      	 call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,1),THETARE(3,1))
      	 call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,2,2),THETARE(2,2))
      	 call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,2),THETARE(3,2))
      	 call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,3),THETARE(3,3))
         else

!dir$       concurrent
            do mn=1,6
              m = mlist(mn)
              n = nlist(mn)
      	      call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,m,n),THETARE(m,n))
            enddo
         endif

		 temp = THETARE(3,2)
		 THETARE(3,2) = -THETARE(3,1)
		 THETARE(3,1) = -temp
		 temp = THETARE(1,1)
		 THETARE(1,1) = THETARE(2,2)
		 THETARE(2,2) = temp

      	 THETARE(1,2) = THETARE(2,1)
      	 THETARE(1,3) = THETARE(3,1)
      	 THETARE(2,3) = THETARE(3,2)

      	 ! -- 2. Anti-hermitian part -- !
      	 call WINTERP1D_2(UPAR,NUPAR,SGG(1,1,1),UPAR0,THETAIM(1,1))
      	 call WINTERP1D_2(UPAR,NUPAR,SGG(1,2,1),UPAR0,THETAIM(2,1))
      	 call WINTERP1D_2(UPAR,NUPAR,SGG(1,3,1),UPAR0,THETAIM(3,1))
      	 call WINTERP1D_2(UPAR,NUPAR,SGG(1,2,2),UPAR0,THETAIM(2,2))
      	 call WINTERP1D_2(UPAR,NUPAR,SGG(1,3,2),UPAR0,THETAIM(3,2))
      	 call WINTERP1D_2(UPAR,NUPAR,SGG(1,3,3),UPAR0,THETAIM(3,3))

	 temp = THETAIM(3,2)
	 THETAIM(3,2) = -THETAIM(3,1)
	 THETAIM(3,1) = -temp
	 temp = THETAIM(1,1)
	 THETAIM(1,1) = THETAIM(2,2)
	 THETAIM(2,2) = temp

      	 THETAIM(1,2) = THETAIM(2,1)
      	 THETAIM(1,3) = THETAIM(3,1)
      	 THETAIM(2,3) = THETAIM(3,2)

         do M=1,3
            do N=1,3
               THETARE(M,N) = -THETARE(M,N) * DFACTPERI
               THETAIM(M,N) = -PI * THETAIM(M,N) * abs(DFACTPERI)
            end do
      	 end do

          end if  !resonance exists

	 do N=1,3
      	 do M=1,3
                WSPEC(M,N)=WSPEC(M,N)+                                &
                2.0d0*PI*WPFACT*BETAFACT*cmplx(THETARE(M,N),THETAIM(M,N))
      	 end do
         end do

	 end if ! zero skip if
    end do !harmonic sum

    ! add in extra term in sig33 from the w to u conversion

    WSPEC(3,3)=WSPEC(3,3)+2.*PI*WPFACT*BETAFACT*cmplx(g_33,0.0)

    call WROTATE_AORSA(BETA1,BETA2,WSPEC)

  end subroutine GETNONMAXSIGMA_AORSA_NEW

!
!*************************************************************************
!

  subroutine GETNONMAXSWMAT_AORSA_NEW(W,ZSPEC,ASPEC,DENS,BMAG, &
       & K1,XI1,JNXI1,K2,XI2,JNXI2,NBESSJ,ENORM,UPARMIN,UPARMAX, &
       & NUPAR,NUPER,UPER,UPAR,DFDUPER,DFDUPAR,WSPEC,IFAIL)
    implicit none
    real, intent(IN):: W,ZSPEC,ASPEC,DENS,BMAG
    real, dimension(3):: K1,K2
    integer, intent(IN):: NUPAR,NUPER,NBESSJ
    real, dimension(NUPER), intent(IN):: XI1,XI2
    real, dimension(NUPER, NBESSJ), intent(IN):: JNXI1,JNXI2
    real, intent(IN):: ENORM,UPARMIN,UPARMAX
    real, dimension(NUPER), intent(IN):: UPER
    real, dimension(NUPAR), intent(IN):: UPAR
    real, dimension(NUPER,NUPAR), intent(IN):: DFDUPER,DFDUPAR
    complex, dimension(3,3), intent(OUT):: WSPEC
    integer, intent(OUT):: IFAIL

    complex:: BETAFACT
    real, parameter:: EOVERAMU = 9.64853e7
    real, parameter:: WP2FACT=1.745915
    real, parameter:: MPC2=938271998.38
    real, parameter:: C=2.99792458e8
    real, parameter:: PI=3.141592653597932384
    real, dimension(NUPER):: JN0XI1,JNP1XI1,JNM1XI1
    real, dimension(NUPER):: JN0XI2,JNP1XI2,JNM1XI2
    real, dimension(NUPER,3,3):: SSGG
    real, dimension(NUPAR,3,3):: SGG
    real, dimension(3,3):: THETARE,THETAIM
    real:: W2,WP2,WPFACT,WCW,RRP,RRM,RR,IRR
    real:: MUT0,SQMUT0,BETA1,BETA2,KPARA1,NPARA1
    real:: ISQ2,CUPAR,CUPER,NWCW,DFACTPAR,DFACTPER,LF0,LNF0UPER
    real:: UPAR0,SFACT0,SFACTP1,SFACTM1
    integer:: NHARM,IHARM,NJ,NJP1,NJM1,J,K,M,N

    IFAIL=0
    WSPEC(1:3,1:3) = cmplx(0.,0.)
    W2=W*W
    WP2=DENS*ZSPEC**2*WP2FACT/ASPEC
    WPFACT=WP2/W2
    WCW=BMAG*ZSPEC*EOVERAMU/ASPEC/W
    BETA1=ATAN2(K1(2),K1(1))
    BETA2=ATAN2(K2(2),K2(1))
    KPARA1=K1(3)
    NPARA1=KPARA1*C/W
    MUT0=0.5*MPC2*ASPEC/ENORM
    SQMUT0=SQRT(MUT0)
    ISQ2=SQRT(0.5)
    NHARM=NBESSJ-2

    ! -- Loop over harmonics -- !
    do IHARM=-NHARM,NHARM
       NWCW=real(IHARM)*WCW

       BETAFACT=exp(cmplx(0.,IHARM*(BETA1-BETA2)))
       NJ=ABS(IHARM)+1
       NJP1=ABS(IHARM+1)+1
       NJM1=ABS(IHARM-1)+1
       SFACT0=real(sign(1,IHARM))**ABS(IHARM)
       SFACTP1=real(sign(1,IHARM+1))**ABS(IHARM+1)
       SFACTM1=real(sign(1,IHARM-1))**ABS(IHARM-1)
       JN0XI1(1:NUPER)=SFACT0*JNXI1(1:NUPER,NJ)
       JNP1XI1(1:NUPER)=SFACTP1*JNXI1(1:NUPER,NJP1)
       JNM1XI1(1:NUPER)=SFACTM1*JNXI1(1:NUPER,NJM1)
       JN0XI2(1:NUPER)=SFACT0*JNXI2(1:NUPER,NJ)
       JNP1XI2(1:NUPER)=SFACTP1*JNXI2(1:NUPER,NJP1)
       JNM1XI2(1:NUPER)=SFACTM1*JNXI2(1:NUPER,NJM1)

       ! -- Build array with integrand -- !
       do J=1,NUPAR
          CUPAR=UPAR(J)
          DFACTPAR=NPARA1*CUPAR/SQMUT0
          do K=1,NUPER
             CUPER=UPER(K)
             DFACTPER=NPARA1*CUPER/SQMUT0
             LF0=(1.-DFACTPAR)*DFDUPER(K,J)+DFACTPER*DFDUPAR(K,J)
             LNF0UPER=NWCW*DFDUPER(K,J)*CUPAR+(1.-NWCW)*DFDUPAR(K,J)*CUPER
             SSGG(K,1,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNP1XI2(K)*CUPER
             SSGG(K,2,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNM1XI2(K)*CUPER
             SSGG(K,3,1)=ISQ2*CUPAR*LF0*JNP1XI1(K)*JN0XI2(K)*CUPER
             SSGG(K,1,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNP1XI2(K)*CUPER
             SSGG(K,2,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNM1XI2(K)*CUPER
             SSGG(K,3,2)=ISQ2*CUPAR*LF0*JNM1XI1(K)*JN0XI2(K)*CUPER
             SSGG(K,1,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNP1XI2(K)
             SSGG(K,2,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNM1XI2(K)
             SSGG(K,3,3)=CUPAR*LNF0UPER*JN0XI1(K)*JN0XI2(K)
          end do

          ! -- Integrate of $u_\perp$ -- !
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,1,1),SGG(J,1,1))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,2,1),SGG(J,2,1))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,3,1),SGG(J,3,1))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,1,2),SGG(J,1,2))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,2,2),SGG(J,2,2))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,3,2),SGG(J,3,2))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,1,3),SGG(J,1,3))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,2,3),SGG(J,2,3))
          call EQSIMPSON1D(NUPER,UPER,SSGG(1,3,3),SGG(J,3,3))

       end do

       ! -- Resonance relation -- !
       RRP=1.-NWCW-NPARA1*UPARMAX/SQMUT0
       RRM=1.-NWCW-NPARA1*UPARMIN/SQMUT0

       if (RRP*RRM.GT.0) then
          ! -- No resonance here -- !
          do J=1,NUPAR
             CUPAR=UPAR(J)
             DFACTPAR=NPARA1*CUPAR/SQMUT0
             RR=1.-NWCW-DFACTPAR
             IRR=1./RR
             do N=1,3
                do M=1,3
                   SGG(J,M,N)=SGG(J,M,N)*IRR
                end do
             end do
          end do

          !-- Hermitian part of $\Theta/(2\pi)$ --!
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,1,1),THETARE(1,1))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,2,1),THETARE(2,1))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,3,1),THETARE(3,1))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,1,2),THETARE(1,2))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,2,2),THETARE(2,2))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,3,2),THETARE(3,2))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,1,3),THETARE(1,3))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,2,3),THETARE(2,3))
          call EQSIMPSON1D(NUPAR,UPAR,SGG(1,3,3),THETARE(3,3))

          !-- Anti-hermitian part of $\Theta/(2\pi)$ --!
          THETAIM(1:3,1:3)=0.

       else

          ! -- There is a resonance all right -- !
          ! -- 1. Hermitian part -- !
          UPAR0=SQMUT0/NPARA1*(1.-NWCW)
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,1,1),THETARE(1,1))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,2,1),THETARE(2,1))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,1),THETARE(3,1))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,1,2),THETARE(1,2))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,2,2),THETARE(2,2))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,2),THETARE(3,2))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,1,3),THETARE(1,3))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,2,3),THETARE(2,3))
          call CAUCHY_PPART2(UPAR,NUPAR,UPAR0,SGG(1,3,3),THETARE(3,3))

          ! -- 2. Anti-hermitian part -- !
          call WINTERP1D(UPAR,NUPAR,SGG(1,1,1),UPAR0,THETAIM(1,1))
          call WINTERP1D(UPAR,NUPAR,SGG(1,2,1),UPAR0,THETAIM(2,1))
          call WINTERP1D(UPAR,NUPAR,SGG(1,3,1),UPAR0,THETAIM(3,1))
          call WINTERP1D(UPAR,NUPAR,SGG(1,1,2),UPAR0,THETAIM(1,2))
          call WINTERP1D(UPAR,NUPAR,SGG(1,2,2),UPAR0,THETAIM(2,2))
          call WINTERP1D(UPAR,NUPAR,SGG(1,3,2),UPAR0,THETAIM(3,2))
          call WINTERP1D(UPAR,NUPAR,SGG(1,1,3),UPAR0,THETAIM(1,3))
          call WINTERP1D(UPAR,NUPAR,SGG(1,2,3),UPAR0,THETAIM(2,3))
          call WINTERP1D(UPAR,NUPAR,SGG(1,3,3),UPAR0,THETAIM(3,3))

          do N=1,3
             do M=1,3
                THETARE(M,N)=-THETARE(M,N)*SQMUT0/NPARA1
                THETAIM(M,N)=-PI*THETAIM(M,N)*SQMUT0/abs(NPARA1)
             end do
          end do

       end if

       do N=1,3
          do M=1,3
             WSPEC(M,N)=WSPEC(M,N)+2.*PI*WPFACT*BETAFACT*cmplx(THETARE(M,N),THETAIM(M,N))
          end do
       end do

    end do

    call WROTATE_AORSA(BETA1,BETA2,WSPEC(1,1))

  end subroutine GETNONMAXSWMAT_AORSA_NEW

!
!*************************************************************************
!

  subroutine GETNONMAXSWMAT_AORSA(W,ZSPEC,ASPEC,DENS,BMAG, &
       & K1,XI1,JNXI1,K2,XI2,JNXI2,NBESSJ,ENORM,UPARMIN,UPARMAX, &
       & NUPAR,NUPER,UPER,UPAR,DFDUPER,DFDUPAR,WSPEC,IFAIL)
    implicit none
    real, intent(IN):: W,ZSPEC,ASPEC,DENS,BMAG
    real, dimension(3):: K1,K2
    integer, intent(IN):: NUPAR,NUPER,NBESSJ
    real, dimension(NUPER), intent(IN):: XI1,XI2
    real, dimension(NUPER, NBESSJ), intent(IN):: JNXI1,JNXI2
    real, intent(IN):: ENORM,UPARMIN,UPARMAX
    real, dimension(NUPER), intent(IN):: UPER
    real, dimension(NUPAR), intent(IN):: UPAR
    real, dimension(NUPER,NUPAR), intent(IN):: DFDUPER,DFDUPAR
    complex, dimension(3,3), intent(OUT):: WSPEC
    integer, intent(OUT):: IFAIL

    complex:: BETAFACT
    real, parameter:: EOVERAMU = 9.64853e7
    real, parameter:: WP2FACT=1.745915
    real, parameter:: MPC2=938271998.38
    real, parameter:: C=2.99792458e8
    real, parameter:: PI=3.141592653597932384
    real:: W2,WP2,WPFACT,WCW,BETA1,BETA2
    real:: MUT0,SQMUT0,ISQ2,NWCW
    real:: SFACT0,SFACTP1,SFACTM1,RRP,RRM,KPARA1
    real:: KPARABS,NPARA1,CUPAR,CUPER,DFACTPAR,DFACTPER
    real:: RR,IRR,LF0,LNF0UPER,UPAR0,DUPARF,UPARMMAX
    real:: CLUPARF,CUPARP,CUPARM,DFACTPARP,DFACTPARM
    real:: IDFDUPARM,IDFDUPERM,IDFDUPARP,IDFDUPERP
    real:: LF0P,LF0M,LNF0PUPER,LNF0MUPER
    real:: DLF0,DLNF0UPER,UDLF0,UDLNF0UPER
    real:: DFDUPER0,DFDUPAR0
    real, dimension(3,3):: THETARE,THETAIM,G
    real, dimension(NUPER,3,3):: SWW
    real, dimension(NUPAR,3,3):: IRRG,GG,UDDGG
    real, dimension(NUPER):: JN0XI1,JNP1XI1,JNM1XI1
    real, dimension(NUPER):: JN0XI2,JNP1XI2,JNM1XI2
    real, dimension(NUPAR):: LUPARF,LLOGF
    integer:: IHARM,NHARM,NJ,NJP1,NJM1,I,J,J1,K,N,M

    IFAIL=0
    WSPEC(1:3,1:3) = cmplx(0.,0.)
    W2=W*W
    WP2=DENS*ZSPEC**2*WP2FACT/ASPEC
    WPFACT=WP2/W2
    WCW=BMAG*ZSPEC*EOVERAMU/ASPEC/W
    BETA1=ATAN2(K1(2),K1(1))
    BETA2=ATAN2(K2(2),K2(1))
    KPARA1=K1(3)
    NPARA1=KPARA1*C/W
    MUT0=0.5*MPC2*ASPEC/ENORM
    SQMUT0=SQRT(MUT0)
    ISQ2=SQRT(0.5)
    NHARM=NBESSJ-2

    ! -- Loop over harmonics -- !
    do IHARM=-NHARM,NHARM
       NWCW=real(IHARM)*WCW

       BETAFACT=exp(cmplx(0.,IHARM*(BETA1-BETA2)))
       NJ=ABS(IHARM)+1
       NJP1=ABS(IHARM+1)+1
       NJM1=ABS(IHARM-1)+1
       SFACT0=real(sign(1,IHARM))**ABS(IHARM)
       SFACTP1=real(sign(1,IHARM+1))**ABS(IHARM+1)
       SFACTM1=real(sign(1,IHARM-1))**ABS(IHARM-1)
       JN0XI1(1:NUPER)=SFACT0*JNXI1(1:NUPER,NJ)
       JNP1XI1(1:NUPER)=SFACTP1*JNXI1(1:NUPER,NJP1)
       JNM1XI1(1:NUPER)=SFACTM1*JNXI1(1:NUPER,NJM1)
       JN0XI2(1:NUPER)=SFACT0*JNXI2(1:NUPER,NJ)
       JNP1XI2(1:NUPER)=SFACTP1*JNXI2(1:NUPER,NJP1)
       JNM1XI2(1:NUPER)=SFACTM1*JNXI2(1:NUPER,NJM1)

       ! -- Resonance relation -- !
       RRP=1.-NWCW-NPARA1*UPARMAX/SQMUT0
       RRM=1.-NWCW-NPARA1*UPARMIN/SQMUT0

       if (RRP*RRM.GT.0) then

          !--------------------------------------!
          !-- First case: vector, no resonant  --!
          !-- parallel velocity in the  domain --!
          !--------------------------------------!

          do J=1,NUPAR
             CUPAR=UPAR(J)
             DFACTPAR=NPARA1*CUPAR/SQMUT0
             RR=1.-NWCW-DFACTPAR
             IRR=1./RR

             ! --- Computation of $sww=u_\perp*w$ ---
             do K=1,NUPER
                CUPER=UPER(K)
                DFACTPER=NPARA1*CUPER/SQMUT0
                LF0=(1.-DFACTPAR)*DFDUPER(K,J)+DFACTPER*DFDUPAR(K,J)
                LNF0UPER=NWCW*DFDUPER(K,J)*CUPAR+(1.-NWCW)*DFDUPAR(K,J)*CUPER
                SWW(K,1,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,1)=ISQ2*CUPAR*LF0*JNP1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,2)=ISQ2*CUPAR*LF0*JNM1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNP1XI2(K)
                SWW(K,2,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNM1XI2(K)
                SWW(K,3,3)=CUPAR*LNF0UPER*JN0XI1(K)*JN0XI2(K)
             end do

             !-- Integration over $u_\perp$ --!
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,1),G(1,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,1),G(2,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,1),G(3,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,2),G(1,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,2),G(2,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,2),G(3,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,3),G(1,3))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,3),G(2,3))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,3),G(3,3))

             do N=1,3
                do M=1,3
                   IRRG(J,M,N)=G(M,N)*IRR
                end do
             end do

          end do

          !-- Hermitian part of $\Theta/(2\pi)$ --!
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,1,1),THETARE(1,1))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,2,1),THETARE(2,1))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,3,1),THETARE(3,1))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,1,2),THETARE(1,2))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,2,2),THETARE(2,2))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,3,2),THETARE(3,2))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,1,3),THETARE(1,3))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,2,3),THETARE(2,3))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,3,3),THETARE(3,3))

          !-- Anti-hermitian part of $\Theta/(2\pi)$ --!
          THETAIM(1:3,1:3)=0.

       else

          !---------------------------------------------------!
          !-- Second case: there is a resonant              --!
          !-- parallel velocity in the $u_\parallel$ domain --!
          !---------------------------------------------------!

          !-- Resonant parallel velocity --!
          UPAR0=SQMUT0/NPARA1*(1.-NWCW)

          ! --- 1. Hermitian part --- !

          !-- New $u_\parallel$ grid --!
          LUPARF(1)=0.
          LLOGF(1)=0.
          UPARMMAX=max(abs(UPARMIN),abs(UPARMAX))
          DUPARF=(UPARMMAX+ABS(UPAR0))/(NUPAR-1)
          do J1=2,NUPAR
             CLUPARF=DUPARF*(J1-1)
             LUPARF(J1)=CLUPARF
             LLOGF(J1)=CLUPARF*(LOG(ABS(CLUPARF))-1.)
          end do

          do J=1,NUPAR
             CUPARP=UPAR0+LUPARF(J)
             CUPARM=UPAR0-LUPARF(J)
             DFACTPARP=NPARA1*CUPARP/SQMUT0
             DFACTPARM=NPARA1*CUPARM/SQMUT0

             ! --- Computation of $sww=u_\perp*w$ ---
             do K=1,NUPER
                CUPER=UPER(K)
                DFACTPER=NPARA1*CUPER/SQMUT0
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPAR, &
                     & CUPER,CUPARP,IDFDUPARP)
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPER, &
                     & CUPER,CUPARP,IDFDUPERP)
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPAR, &
                     & CUPER,CUPARM,IDFDUPARM)
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPER, &
                     & CUPER,CUPARM,IDFDUPERM)
                LF0P=(1.-DFACTPARP)*IDFDUPERP+DFACTPER*IDFDUPARP
                LF0M=(1.-DFACTPARM)*IDFDUPERM+DFACTPER*IDFDUPARM
                LNF0PUPER=NWCW*IDFDUPERP*CUPARP+(1.-NWCW)*IDFDUPARP*CUPER
                LNF0MUPER=NWCW*IDFDUPERM*CUPARM+(1.-NWCW)*IDFDUPARM*CUPER
                DLF0=LF0P-LF0M
                DLNF0UPER=LNF0PUPER-LNF0MUPER
                UDLF0=CUPARP*LF0P-CUPARM*LF0M
                UDLNF0UPER=CUPARP*LNF0PUPER-CUPARM*LNF0MUPER
                SWW(K,1,1)=0.5*CUPER*DLF0*JNP1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,1)=0.5*CUPER*DLF0*JNP1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,1)=ISQ2*UDLF0*JNP1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,2)=0.5*CUPER*DLF0*JNM1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,2)=0.5*CUPER*DLF0*JNM1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,2)=ISQ2*UDLF0*JNM1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,3)=ISQ2*CUPER*DLNF0UPER*JN0XI1(K)*JNP1XI2(K)
                SWW(K,2,3)=ISQ2*CUPER*DLNF0UPER*JN0XI1(K)*JNM1XI2(K)
                SWW(K,3,3)=UDLNF0UPER*JN0XI1(K)*JN0XI2(K)
             end do

             !-- Integration over $u_\perp$ --!
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,1),GG(J,1,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,1),GG(J,2,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,1),GG(J,3,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,2),GG(J,1,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,2),GG(J,2,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,2),GG(J,3,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,3),GG(J,1,3))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,3),GG(J,2,3))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,3),GG(J,3,3))

          end do

          !-- $gg''*llogf$ --!
          UDDGG(1,1:3,1:3)=0.
          UDDGG(NUPAR,1:3,1:3)=0.
          do J=2,NUPAR-1
             UDDGG(J,1,1)=LLOGF(J)* &
                  & (GG(J+1,1,1)-2.*GG(J,1,1)+GG(J-1,1,1))/DUPARF**2
             UDDGG(J,2,1)=LLOGF(J)* &
                  & (GG(J+1,2,1)-2.*GG(J,2,1)+GG(J-1,2,1))/DUPARF**2
             UDDGG(J,3,1)=LLOGF(J)* &
                  & (GG(J+1,3,1)-2.*GG(J,3,1)+GG(J-1,3,1))/DUPARF**2
             UDDGG(J,1,2)=LLOGF(J)* &
                  & (GG(J+1,1,2)-2.*GG(J,1,2)+GG(J-1,1,2))/DUPARF**2
             UDDGG(J,2,2)=LLOGF(J)* &
                  & (GG(J+1,2,2)-2.*GG(J,2,2)+GG(J-1,2,2))/DUPARF**2
             UDDGG(J,3,2)=LLOGF(J)* &
                  & (GG(J+1,3,2)-2.*GG(J,3,2)+GG(J-1,3,2))/DUPARF**2
             UDDGG(J,1,3)=LLOGF(J)* &
                  &(GG(J+1,1,3)-2.*GG(J,1,3)+GG(J-1,1,3))/DUPARF**2
             UDDGG(J,2,3)=LLOGF(J)* &
                  & (GG(J+1,2,3)-2.*GG(J,2,3)+GG(J-1,2,3))/DUPARF**2
             UDDGG(J,3,3)=LLOGF(J)* &
                  & (GG(J+1,3,3)-2.*GG(J,3,3)+GG(J-1,3,3))/DUPARF**2
          end do

          !-- Real part of $\Theta/(2\pi)$ --!
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,1,1),THETARE(1,1))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,2,1),THETARE(2,1))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,3,1),THETARE(3,1))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,1,2),THETARE(1,2))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,2,2),THETARE(2,2))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,3,2),THETARE(3,2))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,1,3),THETARE(1,3))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,2,3),THETARE(2,3))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,3,3),THETARE(3,3))

          do N=1,3
             do M=1,3
                THETARE(M,N)=-THETARE(M,N)*SQMUT0/NPARA1
             end do
          end do

          ! --- 2. Anti-hermitian part --- !
          do K=1,NUPER
             CUPER=UPER(K)
             DFACTPER=NPARA1*CUPER/SQMUT0
             call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPAR,CUPER,UPAR0,DFDUPAR0)
             call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPER,CUPER,UPAR0,DFDUPER0)

             LF0=NWCW*DFDUPER0+DFACTPER*DFDUPAR0
             LNF0UPER=NWCW*DFDUPER0*UPAR0+(1.-NWCW)*DFDUPAR0*CUPER

             SWW(K,1,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNP1XI2(K)*CUPER
             SWW(K,2,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNM1XI2(K)*CUPER
             SWW(K,3,1)=ISQ2*UPAR0*LF0*JNP1XI1(K)*JN0XI2(K)*CUPER
             SWW(K,1,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNP1XI2(K)*CUPER
             SWW(K,2,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNM1XI2(K)*CUPER
             SWW(K,3,2)=ISQ2*UPAR0*LF0*JNM1XI1(K)*JN0XI2(K)*CUPER
             SWW(K,1,3)=ISQ2*CUPAR*LNF0UPER*JN0XI1(K)*JNP1XI2(K)
             SWW(K,2,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNM1XI2(K)
             SWW(K,3,3)=UPAR0*LNF0UPER*JN0XI1(K)*JN0XI2(K)
          end do

          !--- Integration over $u_perp$ ---!
          call EQTRAPZ1D(NUPER,UPER,SWW(1,1,1),G(1,1))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,2,1),G(2,1))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,3,1),G(3,1))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,1,2),G(1,2))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,2,2),G(2,2))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,3,2),G(3,2))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,1,3),G(1,3))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,2,3),G(2,3))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,3,3),G(3,3))

          !-- Imaginary part of $\Theta/(2\pi)$ --!
          do N=1,3
             do M=1,3
                THETAIM(M,N)=-PI*G(M,N)*SQMUT0/abs(NPARA1)
             end do
          end do

       end if

       do N=1,3
          do M=1,3
             WSPEC(M,N)=WSPEC(M,N)+ &
                  & 2.*PI*WPFACT*BETAFACT*cmplx(THETARE(M,N),THETAIM(M,N))
          end do
       end do
    end do

    call WROTATE_AORSA(BETA1,BETA2,WSPEC(1,1))

  end subroutine GETNONMAXSWMAT_AORSA

!
!*************************************************************************
!

    subroutine GETNONMAXSIGMA_AORSA(W,ZSPEC,ASPEC,DENS,BMAG, &
       & K1,XI1,JNXI1,K2,XI2,JNXI2,NBESSJ,ENORM,UPARMIN,UPARMAX, &
       & NUPAR,NUPER,UPER,UPAR,DFDUPER,DFDUPAR,WSPEC,IFAIL)
    implicit none
    real, intent(IN):: W,ZSPEC,ASPEC,DENS,BMAG
    real, dimension(3):: K1,K2
    integer, intent(IN):: NUPAR,NUPER,NBESSJ
    real, dimension(NUPER), intent(IN):: XI1,XI2
    real, dimension(NUPER, NBESSJ), intent(IN):: JNXI1,JNXI2
    real, intent(IN):: ENORM,UPARMIN,UPARMAX
    real, dimension(NUPER), intent(IN):: UPER
    real, dimension(NUPAR), intent(IN):: UPAR
    real, dimension(NUPER,NUPAR), intent(IN):: DFDUPER,DFDUPAR
    complex, dimension(3,3), intent(OUT):: WSPEC
    integer, intent(OUT):: IFAIL

    complex:: BETAFACT
    real, parameter:: EOVERAMU = 9.64853e7
    real, parameter:: WP2FACT=1.745915
    real, parameter:: MPC2=938271998.38
    real, parameter:: C=2.99792458e8
    real, parameter:: PI=3.141592653597932384
    real:: W2,WP2,WPFACT,WCW,BETA1,BETA2
    real:: MUT0,SQMUT0,ISQ2,NWCW
    real:: SFACT0,SFACTP1,SFACTM1,RRP,RRM,KPARA1
    real:: KPARABS,NPARA1,CUPAR,CUPER,DFACTPAR,DFACTPER
    real:: RR,IRR,LF0,LNF0UPER,UPAR0,DUPARF,UPARMMAX
    real:: CLUPARF,CUPARP,CUPARM,DFACTPARP,DFACTPARM
    real:: IDFDUPARM,IDFDUPERM,IDFDUPARP,IDFDUPERP
    real:: LF0P,LF0M,LNF0PUPER,LNF0MUPER
    real:: DLF0,DLNF0UPER,UDLF0,UDLNF0UPER
    real:: DFDUPER0,DFDUPAR0
    real, dimension(3,3):: THETARE,THETAIM,G
    real, dimension(NUPER,3,3):: SWW
    real, dimension(NUPAR,3,3):: IRRG,GG,UDDGG
    real, dimension(NUPER):: JN0XI1,JNP1XI1,JNM1XI1
    real, dimension(NUPER):: JN0XI2,JNP1XI2,JNM1XI2
    real, dimension(NUPAR):: LUPARF,LLOGF
    integer:: IHARM,NHARM,NJ,NJP1,NJM1,I,J,J1,K,N,M

    IFAIL=0
    WSPEC(1:3,1:3) = cmplx(0.,0.)
    W2=W*W
    WP2=DENS*ZSPEC**2*WP2FACT/ASPEC
    WPFACT=WP2/W2
    WCW=BMAG*ZSPEC*EOVERAMU/ASPEC/W
    BETA1=ATAN2(K1(2),K1(1))
    BETA2=ATAN2(K2(2),K2(1))
    KPARA1=K1(3)
    NPARA1=KPARA1*C/W
    MUT0=0.5*MPC2*ASPEC/ENORM
    SQMUT0=SQRT(MUT0)
    ISQ2=SQRT(0.5)
    NHARM=NBESSJ-2

    ! -- Loop over harmonics -- !
    do IHARM=-NHARM,NHARM
       NWCW=real(IHARM)*WCW

       BETAFACT=exp(cmplx(0.,IHARM*(BETA1-BETA2)))
       NJ=ABS(IHARM)+1
       NJP1=ABS(IHARM+1)+1
       NJM1=ABS(IHARM-1)+1
       SFACT0=real(sign(1,IHARM))**ABS(IHARM)
       SFACTP1=real(sign(1,IHARM+1))**ABS(IHARM+1)
       SFACTM1=real(sign(1,IHARM-1))**ABS(IHARM-1)
       JN0XI1(1:NUPER)=SFACT0*JNXI1(1:NUPER,NJ)
       JNP1XI1(1:NUPER)=SFACTP1*JNXI1(1:NUPER,NJP1)
       JNM1XI1(1:NUPER)=SFACTM1*JNXI1(1:NUPER,NJM1)
       JN0XI2(1:NUPER)=SFACT0*JNXI2(1:NUPER,NJ)
       JNP1XI2(1:NUPER)=SFACTP1*JNXI2(1:NUPER,NJP1)
       JNM1XI2(1:NUPER)=SFACTM1*JNXI2(1:NUPER,NJM1)

       ! -- Resonance relation -- !
       RRP=1.-NWCW-NPARA1*UPARMAX/SQMUT0
       RRM=1.-NWCW-NPARA1*UPARMIN/SQMUT0

       if (RRP*RRM.GT.0) then

          !--------------------------------------!
          !-- First case: vector, no resonant  --!
          !-- parallel velocity in the  domain --!
          !--------------------------------------!

          do J=1,NUPAR
             CUPAR=UPAR(J)
             DFACTPAR=NPARA1*CUPAR/SQMUT0
             RR=1.-NWCW-DFACTPAR
             IRR=1./RR

             ! --- Computation of $sww=u_\perp*w$ ---
             do K=1,NUPER
                CUPER=UPER(K)
                DFACTPER=NPARA1*CUPER/SQMUT0
                LF0=(1.-DFACTPAR)*DFDUPER(K,J)+DFACTPER*DFDUPAR(K,J)
                LNF0UPER=NWCW*DFDUPER(K,J)*CUPAR+(1.-NWCW)*DFDUPAR(K,J)*CUPER
                SWW(K,1,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,1)=ISQ2*CUPAR*LF0*JNP1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,2)=ISQ2*CUPAR*LF0*JNM1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNP1XI2(K)
                SWW(K,2,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNM1XI2(K)
                SWW(K,3,3)=CUPAR*LNF0UPER*JN0XI1(K)*JN0XI2(K)
             end do

             !-- Integration over $u_\perp$ --!
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,1),G(1,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,1),G(2,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,1),G(3,1))
           ! call EQTRAPZ1D(NUPER,UPER,SWW(1,1,2),G(1,2)) !
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,2),G(2,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,2),G(3,2))
           ! call EQTRAPZ1D(NUPER,UPER,SWW(1,1,3),G(1,3)) !
           ! call EQTRAPZ1D(NUPER,UPER,SWW(1,2,3),G(2,3)) !
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,3),G(3,3))

	     G(1,2) = - G(2,1)
	     G(1,3) =   G(3,1)
	     G(2,3) = - G(3,2)

             do N=1,3
                do M=1,3
                   IRRG(J,M,N)=G(M,N)*IRR
                end do
             end do

          end do

          !-- Hermitian part of $\Theta/(2\pi)$ --!
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,1,1),THETARE(1,1))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,2,1),THETARE(2,1))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,3,1),THETARE(3,1))
       !  call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,1,2),THETARE(1,2)) !
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,2,2),THETARE(2,2))
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,3,2),THETARE(3,2))
       !  call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,1,3),THETARE(1,3)) !
       !  call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,2,3),THETARE(2,3)) !
          call EQTRAPZ1D(NUPAR,UPAR,IRRG(1,3,3),THETARE(3,3))

	  THETARE(1,2) = - THETARE(2,1)
	  THETARE(1,3) =   THETARE(3,1)
	  THETARE(2,3) = - THETARE(3,2)

          !-- Anti-hermitian part of $\Theta/(2\pi)$ --!
          THETAIM(1:3,1:3)=0.

       else

          !---------------------------------------------------!
          !-- Second case: there is a resonant              --!
          !-- parallel velocity in the $u_\parallel$ domain --!
          !---------------------------------------------------!

          !-- Resonant parallel velocity --!
          UPAR0=SQMUT0/NPARA1*(1.-NWCW)

          ! --- 1. Hermitian part --- !

          !-- New $u_\parallel$ grid --!
          LUPARF(1)=0.
          LLOGF(1)=0.
          UPARMMAX=max(abs(UPARMIN),abs(UPARMAX))
          DUPARF=(UPARMMAX+ABS(UPAR0))/(NUPAR-1)
          do J1=2,NUPAR
             CLUPARF=DUPARF*(J1-1)
             LUPARF(J1)=CLUPARF
             LLOGF(J1)=CLUPARF*(LOG(ABS(CLUPARF))-1.)
          end do

          do J=1,NUPAR
             CUPARP=UPAR0+LUPARF(J)
             CUPARM=UPAR0-LUPARF(J)
             DFACTPARP=NPARA1*CUPARP/SQMUT0
             DFACTPARM=NPARA1*CUPARM/SQMUT0

             ! --- Computation of $sww=u_\perp*w$ ---
             do K=1,NUPER
                CUPER=UPER(K)
                DFACTPER=NPARA1*CUPER/SQMUT0
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPAR, &
                     & CUPER,CUPARP,IDFDUPARP)
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPER, &
                     & CUPER,CUPARP,IDFDUPERP)
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPAR, &
                     & CUPER,CUPARM,IDFDUPARM)
                call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPER, &
                     & CUPER,CUPARM,IDFDUPERM)
                LF0P=(1.-DFACTPARP)*IDFDUPERP+DFACTPER*IDFDUPARP
                LF0M=(1.-DFACTPARM)*IDFDUPERM+DFACTPER*IDFDUPARM
                LNF0PUPER=NWCW*IDFDUPERP*CUPARP+(1.-NWCW)*IDFDUPARP*CUPER
                LNF0MUPER=NWCW*IDFDUPERM*CUPARM+(1.-NWCW)*IDFDUPARM*CUPER
                DLF0=LF0P-LF0M
                DLNF0UPER=LNF0PUPER-LNF0MUPER
                UDLF0=CUPARP*LF0P-CUPARM*LF0M
                UDLNF0UPER=CUPARP*LNF0PUPER-CUPARM*LNF0MUPER
                SWW(K,1,1)=0.5*CUPER*DLF0*JNP1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,1)=0.5*CUPER*DLF0*JNP1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,1)=ISQ2*UDLF0*JNP1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,2)=0.5*CUPER*DLF0*JNM1XI1(K)*JNP1XI2(K)*CUPER
                SWW(K,2,2)=0.5*CUPER*DLF0*JNM1XI1(K)*JNM1XI2(K)*CUPER
                SWW(K,3,2)=ISQ2*UDLF0*JNM1XI1(K)*JN0XI2(K)*CUPER
                SWW(K,1,3)=ISQ2*CUPER*DLNF0UPER*JN0XI1(K)*JNP1XI2(K)
                SWW(K,2,3)=ISQ2*CUPER*DLNF0UPER*JN0XI1(K)*JNM1XI2(K)
                SWW(K,3,3)=UDLNF0UPER*JN0XI1(K)*JN0XI2(K)
             end do

             !-- Integration over $u_\perp$ --!
             call EQTRAPZ1D(NUPER,UPER,SWW(1,1,1),GG(J,1,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,1),GG(J,2,1))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,1),GG(J,3,1))
          !  call EQTRAPZ1D(NUPER,UPER,SWW(1,1,2),GG(J,1,2)) !
             call EQTRAPZ1D(NUPER,UPER,SWW(1,2,2),GG(J,2,2))
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,2),GG(J,3,2))
          !  call EQTRAPZ1D(NUPER,UPER,SWW(1,1,3),GG(J,1,3)) !
          !  call EQTRAPZ1D(NUPER,UPER,SWW(1,2,3),GG(J,2,3)) !
             call EQTRAPZ1D(NUPER,UPER,SWW(1,3,3),GG(J,3,3))

	     GG(J,1,2) = - GG(J,2,1)
	     GG(J,1,3) =   GG(J,3,1)
	     GG(J,2,3) = - GG(J,3,2)

          end do

          !-- $gg''*llogf$ --!
          UDDGG(1,1:3,1:3)=0.
          UDDGG(NUPAR,1:3,1:3)=0.
          do J=2,NUPAR-1
             UDDGG(J,1,1)=LLOGF(J)* &
                  & (GG(J+1,1,1)-2.*GG(J,1,1)+GG(J-1,1,1))/DUPARF**2
             UDDGG(J,2,1)=LLOGF(J)* &
                  & (GG(J+1,2,1)-2.*GG(J,2,1)+GG(J-1,2,1))/DUPARF**2
             UDDGG(J,3,1)=LLOGF(J)* &
                  & (GG(J+1,3,1)-2.*GG(J,3,1)+GG(J-1,3,1))/DUPARF**2
             UDDGG(J,1,2)=LLOGF(J)* &
                  & (GG(J+1,1,2)-2.*GG(J,1,2)+GG(J-1,1,2))/DUPARF**2
             UDDGG(J,2,2)=LLOGF(J)* &
                  & (GG(J+1,2,2)-2.*GG(J,2,2)+GG(J-1,2,2))/DUPARF**2
             UDDGG(J,3,2)=LLOGF(J)* &
                  & (GG(J+1,3,2)-2.*GG(J,3,2)+GG(J-1,3,2))/DUPARF**2
             UDDGG(J,1,3)=LLOGF(J)* &
                  &(GG(J+1,1,3)-2.*GG(J,1,3)+GG(J-1,1,3))/DUPARF**2
             UDDGG(J,2,3)=LLOGF(J)* &
                  & (GG(J+1,2,3)-2.*GG(J,2,3)+GG(J-1,2,3))/DUPARF**2
             UDDGG(J,3,3)=LLOGF(J)* &
                  & (GG(J+1,3,3)-2.*GG(J,3,3)+GG(J-1,3,3))/DUPARF**2
          end do

          !-- Real part of $\Theta/(2\pi)$ --!
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,1,1),THETARE(1,1))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,2,1),THETARE(2,1))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,3,1),THETARE(3,1))
       !  call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,1,2),THETARE(1,2)) !
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,2,2),THETARE(2,2))
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,3,2),THETARE(3,2))
       !  call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,1,3),THETARE(1,3)) !
       !  call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,2,3),THETARE(2,3)) !
          call EQTRAPZ1D(NUPAR,LUPARF,UDDGG(1,3,3),THETARE(3,3))

	  THETARE(1,2) = - THETARE(2,1)
	  THETARE(1,3) =   THETARE(3,1)
	  THETARE(2,3) = - THETARE(3,2)

          do N=1,3
             do M=1,3
                THETARE(M,N)=-THETARE(M,N)*SQMUT0/NPARA1
             end do
          end do

          ! --- 2. Anti-hermitian part --- !
          do K=1,NUPER
             CUPER=UPER(K)
             DFACTPER=NPARA1*CUPER/SQMUT0
             call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPAR,CUPER,UPAR0,DFDUPAR0)
             call WINTERP2D(UPER,NUPER,UPAR,NUPAR,DFDUPER,CUPER,UPAR0,DFDUPER0)

             LF0=NWCW*DFDUPER0+DFACTPER*DFDUPAR0
             LNF0UPER=NWCW*DFDUPER0*UPAR0+(1.-NWCW)*DFDUPAR0*CUPER

             SWW(K,1,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNP1XI2(K)*CUPER
             SWW(K,2,1)=0.5*CUPER*LF0*JNP1XI1(K)*JNM1XI2(K)*CUPER
             SWW(K,3,1)=ISQ2*UPAR0*LF0*JNP1XI1(K)*JN0XI2(K)*CUPER
             SWW(K,1,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNP1XI2(K)*CUPER
             SWW(K,2,2)=0.5*CUPER*LF0*JNM1XI1(K)*JNM1XI2(K)*CUPER
             SWW(K,3,2)=ISQ2*UPAR0*LF0*JNM1XI1(K)*JN0XI2(K)*CUPER
             SWW(K,1,3)=ISQ2*CUPAR*LNF0UPER*JN0XI1(K)*JNP1XI2(K)
             SWW(K,2,3)=ISQ2*CUPER*LNF0UPER*JN0XI1(K)*JNM1XI2(K)
             SWW(K,3,3)=UPAR0*LNF0UPER*JN0XI1(K)*JN0XI2(K)
          end do

          !--- Integration over $u_perp$ ---!
          call EQTRAPZ1D(NUPER,UPER,SWW(1,1,1),G(1,1))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,2,1),G(2,1))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,3,1),G(3,1))
       !  call EQTRAPZ1D(NUPER,UPER,SWW(1,1,2),G(1,2)) !
          call EQTRAPZ1D(NUPER,UPER,SWW(1,2,2),G(2,2))
          call EQTRAPZ1D(NUPER,UPER,SWW(1,3,2),G(3,2))
       !  call EQTRAPZ1D(NUPER,UPER,SWW(1,1,3),G(1,3)) !
       !  call EQTRAPZ1D(NUPER,UPER,SWW(1,2,3),G(2,3)) !
          call EQTRAPZ1D(NUPER,UPER,SWW(1,3,3),G(3,3))

	  G(1,2) = - G(2,1)
	  G(1,3) =   G(3,1)
	  G(2,3) = - G(3,2)

          !-- Imaginary part of $\Theta/(2\pi)$ --!
          do N=1,3
             do M=1,3
                THETAIM(M,N)=-PI*G(M,N)*SQMUT0/abs(NPARA1)
             end do
          end do

       end if

       do N=1,3
          do M=1,3
             WSPEC(M,N)=WSPEC(M,N)+ &
                  & 2.*PI*WPFACT*BETAFACT*cmplx(THETARE(M,N),THETAIM(M,N))
          end do
       end do
    end do

    call WROTATE_AORSA(BETA1,BETA2,WSPEC(1,1))

  end subroutine GETNONMAXSIGMA_AORSA

!
!*************************************************************************
!

  subroutine BESSJ(XI,JNXI,LXI,LNBESSJ,LNSBESSJ)
    implicit none
    integer, intent(IN):: LXI,LNBESSJ,LNSBESSJ
    real, dimension(LXI), intent(IN):: XI
    real, dimension(LXI,LNBESSJ), intent(OUT):: JNXI
    real, parameter:: BIGNO=1.e10,BIGNI=1.e-10
    real, dimension(LXI):: TOX,AXI,J0XI,J1XI
    real, dimension(LXI):: BJP,BJ,BJM,JSUM
    integer:: MSUM,IX,N,NP
    integer, dimension(LXI):: MCOR

    ! --- Returns the J bessel functions from 0 to LNBESSJ --- !
    ! --- LNSBESSJ is the starting point for the downard recurence --- !
    ! --- XI(LXI) is the argument array and JNXI(LXI,LNBESSJ) is the output ---!

!dir$ preferstream,prefervector
    do IX=1,LXI
    JNXI(IX,1:LNBESSJ)=0.

    TOX(IX)=0.
    AXI(IX)=ABS(XI(IX))
    if (AXI(IX).GT.0.)then
       TOX(IX)=2./AXI(IX)
    endif

    BJP(IX)=0.
    BJ(IX)=1.
    JSUM(IX)=0.
    enddo
!    MSUM=0
    do N=LNSBESSJ,1,-1
!dir$ concurrent,preferstream,prefervector
      do IX=1,LXI
      MSUM=mod((LNSBESSJ-N),2)
       MCOR(IX)=0
       BJM(IX)=REAL(N)*TOX(IX)*BJ(IX)-BJP(IX)
       BJP(IX)=BJ(IX)
       BJ(IX)=BJM(IX)
       if (ABS(BJ(IX)).GT.BIGNO)then
          BJ(IX)=BJ(IX)*BIGNI
          BJP(IX)=BJP(IX)*BIGNI
          JSUM(IX)=JSUM(IX)*BIGNI
          MCOR(IX)=1
       endif
       JSUM(IX)=JSUM(IX)+REAL(MSUM)*BJ(IX)
!       MSUM=1-MSUM
       if (N.LT.LNBESSJ) JNXI(IX,N+1)=BJP(IX)
       do NP=N+2,LNBESSJ
          if (MCOR(IX).EQ.1)then
             JNXI(IX,NP)=JNXI(IX,NP)*BIGNI
          endif
       end do
      enddo
    end do
    do IX=1,LXI

    JSUM(IX)=2.*JSUM(IX)-BJ(IX)
    do N=1,LNBESSJ
       JNXI(IX,N)=JNXI(IX,N)/JSUM(IX)
    end do
    end do

    ! --- Upward Recurrence for x>=n --- !
    call BESSJ0(AXI,J0XI,LXI)
    call BESSJ1(AXI,J1XI,LXI)
    do IX=1,LXI
    BJM(IX)=J0XI(IX)
    BJ(IX)=J1XI(IX)
    do N=1,LNBESSJ
       if (AXI(IX)>=real(N-1))then
          JNXI(IX,N)=BJM(IX)
          BJP(IX)=REAL(N)*TOX(IX)*BJ(IX)-BJM(IX)
          BJM(IX)=BJ(IX)
          BJ(IX)=BJP(IX)
       endif
    end do

    ! --- Zero --- !
       if (XI(IX)==0.) then
          JNXI(IX,1)=1.
          do N=2,LNBESSJ
             JNXI(IX,N)=0.
          end do
       end if
!    end do

    ! --- Revert when needed --- !
    ! --- N.B. J1 does not need to be reverted --- !
!    do IX=1,LXI
       do N=4,LNBESSJ,2
          if (XI(IX).LT.0.) JNXI(IX,N)=-JNXI(IX,N)
       end do
    end do

  end subroutine BESSJ

!
!*************************************************************************
!

  subroutine BESSJ0(XI,J0XI,LXI)
    implicit none
    integer, intent(IN):: LXI
    real, dimension(LXI), intent(IN) :: XI
    real, dimension(LXI), intent(OUT) :: J0XI
    real, dimension(LXI) :: YI,AXI,XXI,ZI
    real, dimension(5):: P,Q
    real, dimension(6):: R,S
    P=(/1.0,-0.1098628627e-2,0.2734510407e-4, &
         -0.2073370639e-5,0.2093887211e-6/)
    Q=(/-0.1562499995e-1,0.1430488765e-3, &
         -0.6911147651e-5,0.7621095161e-6,-0.934945152e-7/)
    R=(/57568490574.0,-13362590354.0,651619640.7, &
         -11214424.18,77392.33017,-184.9052456/)
    S=(/57568490411.0,1029532985.0,&
         9494680.718,59272.64853,267.8532712,1.0/)

    where (abs(XI).LT.8.0)
       YI=XI*XI
       J0XI=(R(1)+YI*(R(2)+YI*(R(3)+YI*(R(4)+YI*(R(5)+YI*R(6))))))/ &
            (S(1)+YI*(S(2)+YI*(S(3)+YI*(S(4)+YI*(S(5)+YI*S(6))))))
    elsewhere
       AXI=abs(XI)
       ZI=8./AXI
       YI=ZI*ZI
       XXI=AXI-0.785398164
       J0XI=sqrt(0.636619772/AXI)* &
            (cos(XXI)*(P(1)+YI*(P(2)+YI*(P(3)+YI*(P(4)+YI*P(5))))) &
            - ZI*sin(XXI)*(Q(1)+YI*(Q(2)+YI*(Q(3)+YI*(Q(4)+YI*Q(5))))))
    end where
  end subroutine BESSJ0

!
!*************************************************************************
!

  subroutine BESSJ1(XI,J1XI,LXI)
    implicit none
    integer, intent(IN):: LXI
    real, dimension(LXI), intent(IN):: XI
    real, dimension(LXI), intent(OUT):: J1XI
    real, dimension(LXI) :: YI,AXI,XXI,ZI
    real, dimension(5):: P,Q
    real, dimension(6):: R,S
    integer:: IX

    P=(/1.0,0.183105e-2,-0.3516396496e-4, &
         0.2457520174e-5,-0.240337019e-6/)
    Q=(/0.04687499995,-0.2002690873e-3, &
         0.8449199096e-5,-0.88228987e-6,0.105787412e-6/)
    R=(/72362614232.0,-7895059235.0,242396853.1, &
         -2972611.439,15704.48260,-30.16036606/)
    S=(/144725228442.0,2300535178.0,18583304.74, &
         99447.43394,376.9991397,1.0/)

    where (abs(XI).LT.8.0)
       YI=XI*XI
       J1XI=XI*(R(1)+YI*(R(2)+YI*(R(3)+YI*(R(4)+YI*(R(5)+YI*R(6))))))/ &
            (S(1)+YI*(S(2)+YI*(S(3)+YI*(S(4)+YI*(S(5)+YI*S(6))))))
    elsewhere
       AXI=abs(XI)
       ZI=8./AXI
       YI=ZI*ZI
       XXI=AXI-2.356194491
       J1XI=sqrt(0.636619772/AXI)* &
            (cos(XXI)*(P(1)+YI*(P(2)+YI*(P(3)+YI*(P(4)+YI*P(5))))) &
            - ZI*sin(XXI)*(Q(1)+YI*(Q(2)+YI*(Q(3)+YI*(Q(4)+YI*Q(5)))))) &
            *sign(1.0,XI)
    end where

    ! --- Revert if needed --- !
    do IX=1,LXI
       if (XI(IX).LT.0.) J1XI(IX)=-J1XI(IX)
    end do

  end subroutine BESSJ1

!
!*************************************************************************
!

  subroutine EQTRAPZ1D(LNU,LU,ARRAY,INTEGRAL)
    ! -- 1D trapezoidal integration for equally spaced coordinates -- !
    implicit none
    integer, intent(IN):: LNU
    real, dimension(LNU), intent(IN):: LU,ARRAY
    real, intent(OUT):: INTEGRAL
    real:: DU

    DU=(LU(LNU)-LU(1))/(LNU-1.)
    INTEGRAL=(sum(ARRAY(2:LNU-1))+0.5*(ARRAY(1)+ARRAY(LNU)))*DU

  end subroutine EQTRAPZ1D

!
!*************************************************************************
!

      subroutine sgrate2(nxmax, x, f, ans)

      implicit none

      integer n, nxmax
      real f(nxmax), x(nxmax), ans

      ans = 0.0
      do n = 1, nxmax-1
         ans = ans + (x(n+1) - x(n)) * (f(n) + f(n+1)) / 2.0
      end do

      return
      end
!
!*************************************************************************
!

  subroutine EQSIMPSON1D(LNU,LU,ARRAY,INTEGRAL)
    ! -- 1D Simpson integration for equally spaced coordinates and odd N -- !
    implicit none
    integer, intent(IN):: LNU
    real, dimension(LNU), intent(IN):: LU,ARRAY
    real, intent(OUT):: INTEGRAL

    real:: DU
    integer:: I

    DU=(LU(LNU)-LU(1))/(LNU-1.)
    INTEGRAL=2.*sum(ARRAY(2:LNU-1))+ARRAY(1)+ARRAY(LNU)
    do I=1,(LNU-1)/2
       INTEGRAL=INTEGRAL+2.*ARRAY(2*I)
    end do
    INTEGRAL=INTEGRAL*DU / 3.

  end subroutine EQSIMPSON1D

!
!*************************************************************************
!
  subroutine EQSIMPSON1D_2(LNU,LU,ARRAY,INTEGRAL)
    ! -- 1D Simpson integration for equally spaced coordinates and odd N -- !
    implicit none
    integer, intent(IN):: LNU
    real, dimension(LNU), intent(IN):: LU,ARRAY
    real, intent(OUT):: INTEGRAL

    real:: DU

    DU=(LU(LNU)-LU(1))/(LNU-1.)
    INTEGRAL=ARRAY(1)+ARRAY(LNU)+ 2.*sum(array(2:lnu-1))
    integral = integral + 2.*sum(array(2:lnu-1:2))

    INTEGRAL=INTEGRAL*DU / 3.

  end subroutine EQSIMPSON1D_2

!
!*************************************************************************
!

  subroutine WINTERP2D(X,LX,Y,LY,FXY,X0,Y0,FXY0)
    implicit none
    integer, intent(IN):: LX,LY
    real, dimension(LX), intent(IN):: X
    real, dimension(LY), intent(IN):: Y
    real, dimension(LX,LY), intent(IN):: FXY
    real, intent(IN):: X0,Y0
    real, intent(OUT):: FXY0
    real:: A0,A1,A2,A3,A4,A5,P,Q
    real:: XMIN,XMAX,YMIN,YMAX,DX,DY
    integer:: I,J

    FXY0=0.
    XMIN=X(1)
    YMIN=Y(1)
    XMAX=X(LX)
    YMAX=Y(LY)
    DX=(XMAX-XMIN)/(LX-1)
    DY=(YMAX-YMIN)/(LY-1)
    if ((X0>=XMIN).and.(X0<=XMAX).and.(Y0>=YMIN).and.(Y0<=YMAX)) then

       I=int(1.+(X0-XMIN)/DX)
       J=int(1.+(Y0-YMIN)/DY)
       P=(X0-X(I))/DX
       Q=(Y0-Y(J))/DY

       if (I.eq.LX) I=LX-1
       if (J.eq.LY) J=LY-1
       if ((I.ne.1).and.(J.ne.1)) then
          A0=0.5*Q*(Q-1.)
          A1=0.5*P*(P-1.)
          A2=1.+P*Q-P*P-Q*Q
          A3=0.5*P*(P-2.*Q+1.)
          A4=0.5*Q*(Q-2.*P+1.)
          A5=P*Q
          FXY0=A0*FXY(I,J-1)+A1*FXY(I-1,J)+A2*FXY(I,J)+A3*FXY(I+1,J) &
               +A4*FXY(I,J+1)+A5*FXY(I+1,J+1)
       else
          A0=(1.-P)*(1.-Q)
          A1=P*(1.-Q)
          A2=Q*(1.-P)
          A3=P*Q
          FXY0=A0*FXY(I,J)+A1*FXY(I+1,J)+A2*FXY(I,J+1)+A3*FXY(I+1,J+1)
       end if
   end if
  end subroutine WINTERP2D

!
!*************************************************************************
!

  SUBROUTINE WROTATE_AORSA(BETA1,BETA2,W)
    !     Apply unitary polarization matrices, eg., Wout = C2*Win*C1
    !     Transforms the perpendicular part of the tensor from right
    !     and left polarized components into fixed real components.
    IMPLICIT NONE
    real:: BETA1,BETA2
    complex :: W(3,3),WW(3,3),C1(3,3),C2(3,3)
    complex :: C1P,C1M,C2P,C2M
    INTEGER I,J,K
    real, parameter :: ZERO = 0.0, ONE = 1.0
    real, parameter :: ROOTHALF = 0.707106781
    C1P = ROOTHALF*EXP(CMPLX(ZERO,BETA1))
    C1M = ROOTHALF*EXP(CMPLX(ZERO,-BETA1))
    C2P = ROOTHALF*EXP(CMPLX(ZERO,BETA2))
    C2M = ROOTHALF*EXP(CMPLX(ZERO,-BETA2))
    C1(1,1) = C1P
    C1(2,1) = C1M
    C1(3,1) = CMPLX(ZERO,ZERO)
    C1(1,2) = C1P*CMPLX(ZERO,-ONE)
    C1(2,2) = C1M*CMPLX(ZERO,ONE)
    C1(3,2) = CMPLX(ZERO,ZERO)
    C1(1,3) = CMPLX(ZERO,ZERO)
    C1(2,3) = CMPLX(ZERO,ZERO)
    C1(3,3) = CMPLX(ONE,ZERO)
    C2(1,1) = C2M
    C2(2,1) = C2M*CMPLX(ZERO,ONE)
    C2(3,1) = CMPLX(ZERO,ZERO)
    C2(1,2) = C2P
    C2(2,2) = C2P*CMPLX(ZERO,-ONE)
    C2(3,2) = CMPLX(ZERO,ZERO)
    C2(1,3) = CMPLX(ZERO,ZERO)
    C2(2,3) = CMPLX(ZERO,ZERO)
    C2(3,3) = CMPLX(ONE,ZERO)
    DO I=1,3
       DO J=1,3
          WW(I,J) = CMPLX(ZERO,ZERO)
          DO K=1,3
             WW(I,J) = WW(I,J) + W(I,K)*C1(K,J)
          enddo
       enddo
    enddo
    DO I=1,3
       DO J=1,3
          W(I,J) = CMPLX(ZERO,ZERO)
          DO K=1,3
             W(I,J) = W(I,J) + C2(I,K)*WW(K,J)
          enddo
       enddo
    enddo
    RETURN
  END subroutine WROTATE_AORSA

!
!*************************************************************************
!

  subroutine CAUCHY_PPART(X,NX,XRES,FX,PINT)
    ! -- Returns principal part of int(x,fx/(x-xres)) -- !
    implicit none
    integer, intent(IN):: NX
    real, dimension(NX), intent(IN):: X,FX
    real, intent(IN):: XRES
    real, intent(OUT):: PINT

    real:: CXP,CXM,FXP,FXM,LLOGF,XMAX,XMIN
    real:: CXF,DXF,DX
    real, dimension(NX):: LXF,INTGD,FXPP
    integer:: IX,IXM1,IXP1

    IXM1(IX)=MAX(IX-1,1)
    IXP1(IX)=MIN(IX+1,NX)

    XMAX=X(NX)
    XMIN=X(1)
    DXF=(XMAX+ABS(XRES))/(NX-1)
    DX=(XMAX-XMIN)/(NX-1)

    do IX=1,NX
       CXF=DXF*(IX-1)
       FXPP(IX)=(FX(IXP1(IX))-2.*FX(IX)+FX(IXM1(IX)))/DX**2
       LXF(IX)=CXF
    end do

    INTGD(1)=0.
    do IX=2,NX
       CXF=LXF(IX)
       LLOGF=CXF*(LOG(ABS(CXF))-1.)
       CXP=XRES+CXF
       CXM=XRES-CXF
       call WINTERP1D(X,NX,FXPP,CXP,FXP)
       call WINTERP1D(X,NX,FXPP,CXM,FXM)
       INTGD(IX)=LLOGF*(FXP-FXM)
    end do

    call EQSIMPSON1D(NX,LXF,INTGD,PINT)

  end subroutine CAUCHY_PPART

!
!*************************************************************************
!
  subroutine WINTERP1D(X,LX,FX,X0,FX0)
    implicit none
    integer, intent(IN):: LX
    real, dimension(LX), intent(IN):: X,FX
    real, intent(IN):: X0
    real, intent(OUT):: FX0

    real:: FXY0,XMIN,XMAX,DX
    real:: P,A1,A2,A3
    integer:: I

    FX0=0.
    XMIN=X(1)
    XMAX=X(LX)
    DX=(XMAX-XMIN)/(LX-1)
    if ((X0>=XMIN).and.(X0<=XMAX)) then
       I=int(1.+(X0-XMIN)/DX)
       P=(X0-X(I))/DX
       if (I.eq.LX) I=LX-1
       if (I.eq.1) I=2
       A1=0.5*P*(P-1.)
       A2=1.-P*P
       A3=0.5*P*(P+1.)
       FX0=A1*FX(I-1)+A2*FX(I)+A3*FX(I+1)
    end if
  end subroutine WINTERP1D
!
!*************************************************************************
!
  subroutine WINTERP1D_2(X,LX,FX,X0,FX0)
    implicit none
    integer, intent(IN):: LX
    real, dimension(LX), intent(IN):: X,FX
    real, intent(IN):: X0
    real, intent(OUT):: FX0

    real:: FXY0,XMIN,XMAX,DX
    real:: P,A1,A2,A3
    integer:: I

    FX0=0.
    XMIN=X(1)
    XMAX=X(LX)
    DX=(XMAX-XMIN)/(LX-1)
    if ((X0>=XMIN).and.(X0<=XMAX)) then
       I=int(1.+(X0-XMIN)/DX)
       P=(X0-X(I))/DX
!       if (I.eq.LX) I=LX-1
!       if (I.eq.1) I=2

       if(i .ne. 1 .and. i .ne. lx)then
          A1=0.5*P*(P-1.)
          A2=1.-P*P
          A3=0.5*P*(P+1.)
          FX0=A1*FX(I-1)+A2*FX(I)+A3*FX(I+1)
       else
          if(i .eq. lx) fx0 = fx(i)
          if(i .eq. 1)  fx0 = fx(i) + (fx(i+1) - fx(i)) * p
       end if

    end if
  end subroutine WINTERP1D_2

!
!*************************************************************************
!

       subroutine intplt1d(x, lx, fx, x0, fx0)

!      -----------------------
!      1D linear interpolation
!      -----------------------

       implicit none

       integer lx, i
       real fx(lx), x(lx), fx0, x0, dx

       dx = (x(lx) - x(1)) / (lx - 1)
       i = int((x0 - x(1)) / dx) + 1

       if(i .eq. lx)then
          fx0 = fx(lx)
       else
          fx0 = fx(i) + (fx(i+1) - fx(i)) * (x0 - x(i)) / dx
       end if

	 return
	 end subroutine intplt1d

!
!*************************************************************************
!

!end module METS2AORSA


      subroutine compute_px(ctfmp,n_Axx,n_beta,n_divbeta,x,Nx,hx,myzero,
     &vee,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 vee
      real*8 ctfmp(Nx)
      real*8 n_Axx(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(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 = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = -0.6666666666666667D0 * n_Axx(i) * vee * n_divbeta(i) + (n_Ax
     #x(i) * (-0.1D1 * n_beta(i - 1) + n_beta(i + 1)) + 0.50000000000000
     #00D0 * (-0.1D1 * n_Axx(i - 1) + n_Axx(i + 1)) * n_beta(i)) / ctfmp
     #(i) / hx
      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


      FUNCTION RTSAFE(FUNCD,X1,X2,XACC)
      PARAMETER (MAXIT=100)
      CALL FUNCD(X1,FL,DF)
      CALL FUNCD(X2,FH,DF)
      IF(FL*FH.GE.0.) PAUSE 'root must be bracketed'
      IF(FL.LT.0.)THEN
        XL=X1
        XH=X2
      ELSE
        XH=X1
        XL=X2
        SWAP=FL
        FL=FH
        FH=SWAP
      ENDIF
      RTSAFE=.5*(X1+X2)
      DXOLD=ABS(X2-X1)
      DX=DXOLD
      CALL FUNCD(RTSAFE,F,DF)
      DO 11 J=1,MAXIT
        IF(((RTSAFE-XH)*DF-F)*((RTSAFE-XL)*DF-F).GE.0.
     *      .OR. ABS(2.*F).GT.ABS(DXOLD*DF) ) THEN
          DXOLD=DX
          DX=0.5*(XH-XL)
          RTSAFE=XL+DX
          IF(XL.EQ.RTSAFE)RETURN
        ELSE
          DXOLD=DX
          DX=F/DF
          TEMP=RTSAFE
          RTSAFE=RTSAFE-DX
          IF(TEMP.EQ.RTSAFE)RETURN
        ENDIF
        IF(ABS(DX).LT.XACC) RETURN
        CALL FUNCD(RTSAFE,F,DF)
        IF(F.LT.0.) THEN
          XL=RTSAFE
          FL=F
        ELSE
          XH=RTSAFE
          FH=F
        ENDIF
11    CONTINUE
      PAUSE 'RTSAFE exceeding maximum iterations'
      RETURN
      END


! hilbert transform

use MathClass
use ArrayClass
use IOClass
implicit none

type(Math_) :: math
type(IO_)   :: f
complex(complex64),allocatable :: t(:), wave(:), h_top_wave(:)&
    ,h_bottom_wave(:),spectre(:)
real(real64) :: omega_1
real(real64) :: omega_2

omega_1=0.10d0/math%pi
omega_2=0.3d0/math%pi

t = linspace([0.0d0,1000.0d0],1024)
wave = sin(omega_1*t(:)) * 0.30d0*sin(omega_2*t(:) +2.0d0)* exp(-omega_1/10.0d0*t(:) ) +0.10d0*sin(omega_1*10.0d0*t(:))

call f%open("input_wave.txt")
call f%write(abs(t),real(wave) )
call f%close()
call f%plot(option="with lines")

h_top_wave = hilbert(wave)
h_bottom_wave = hilbert(-wave)

call f%open("ht_wave.txt")
call f%write(abs(t),abs(h_top_wave) )
call f%plot(option="with lines")

end


program main
    use, intrinsic :: iso_c_binding

    integer(kind=4), parameter :: max_bits = 128
    integer(kind=4), parameter :: fraction_bits = 30
    integer(kind=4), parameter :: EBIAS = 127

    integer(kind=4), dimension(16), parameter :: PERM =&
    & [0, 1, 4, 5, 2, 8, 6, 9, 3, 12, 10, 7, 13, 11, 14, 15]

    integer(kind=4), parameter :: NBMASK = Z'aaaaaaaa'

    ! Golomb encoding
    integer, parameter :: G_M = 10
    integer, parameter :: G_b = 4

    ! Rice encoding
    integer, parameter :: R_k = 3
    integer, parameter :: R_M = 2**R_k

    real(kind=4), dimension(4, 4) :: x
    integer, dimension(4, 4) :: e
    integer, dimension(4, 4) :: qint, i
    integer, dimension(16) :: iblock
    integer :: max_exp

    ! bitstream
    ! the first bit (pos .eq. 0) : '0' - all values are either non-NaN or NaN
    ! the second bit (pos .eq. 1) : if the first bit is '0' then '0' : non-NaN, '1' : NaN
    integer(kind=16) :: bitstream
    integer :: pos
    integer :: bits

    ! loop counters
    integer ix, iy

    do iy = 1, 4
        do ix = 1, 4
            x(ix, iy) = ix*iy
        end do
    end do

    x(4/2, 4/2) = 6.4

    print *, x

    e = exponent(x)
    max_exp = maxval(e)

    print *, 'e:', e
    print *, 'max_exp:', max_exp

    ! clear the bitstream
    bitstream = 0
    pos = 0

    ! bitstream = ibset(bitstream, 0)
    ! call mvbits(int(3, kind=16), 0, 3, bitstream, pos)

    ! all values are non-NaN, emit '0';
    ! no need to do anything since initially bitstream = 0
    pos = pos + 1

    ! emit the biased exponent (8 bits)
    ! call mvbits(int(max_exp + EBIAS, kind=16), 0, 8, bitstream, pos)

    bits = max_exp + EBIAS
    write (*, '(a,b32.32)') 'biased max_exp ', bits

    call stream_write_bits(bitstream, bits, 8, pos)

    ! quantize
    i = e - max_exp + fraction_bits
    qint = nint(set_exponent(x, i))
    iblock = reshape(qint, (/16/))

    print *, 'i:', i
    print *, 'iblock:', iblock

    ! decorrelate
    call fwd_xform(iblock)
    print *, 'iblock:', iblock

    ! reorder signed coefficients and convert to unsigned integer
    call fwd_order(iblock)
    print *, 'ublock:', iblock

    ! encode 32-bit integers
    call encode_many_ints(iblock, bitstream, pos)

    if (pos .lt. max_bits) then
        call pad_stream(bitstream, max_bits - pos, pos)
    end if

    write (*, '(a,b128.128)') 'bitstream ', bitstream
    print *, 'pos', pos

    ! reverse the process
    pos = max_bits - 1

    ! read the NaN mask bit
    print *, 'NaN mask', stream_read_bit(bitstream, pos)

    bits = stream_read_bits(bitstream, pos, 8)
    max_exp = bits - EBIAS
    print *, 'max_exp', max_exp

    ! decode 32-bit integers
    call decode_many_ints(iblock, bitstream, pos)
    print *, 'ublock:', iblock

    ! reorder unsigned coefficients and convert to signed integer
    call inv_order(iblock)
    print *, 'iblock:', iblock

    ! perform decorrelating transform
    call inv_xform(iblock)
    print *, 'iblock:', iblock

    ! de-quantize
    qint = reshape(iblock, (/4, 4/))

    i = max_exp - fraction_bits
    x = scale(real(qint), i)

    print *, x

contains
    pure subroutine fwd_lift(p, offset, s)
        implicit none

        integer, dimension(16), intent(inout) :: p
        integer, intent(in) :: offset, s
        integer :: idx, x, y, z, w

        idx = 1 + offset

        x = p(idx)
        idx = idx + s

        y = p(idx)
        idx = idx + s

        z = p(idx)
        idx = idx + s

        w = p(idx)

        ! non-orthogonal transform
        !        ( 4  4  4  4) (x)
        ! 1/16 * ( 5  1 -1 -5) (y)
        !        (-4  4  4 -4) (z)
        !        (-2  6 -6  2) (w)

        ! shiftr does not preserve the sign bit
        ! therefore shifta is used in the code below

        x = x + w
        x = shifta(x, 1)
        w = w - x
        z = z + y
        z = shifta(z, 1)
        y = y - z
        x = x + z
        x = shifta(x, 1)
        z = z - x
        w = w + y
        w = shifta(w, 1)
        y = y - w
        w = w + shifta(y, 1)
        y = y - shifta(w, 1)

        p(idx) = w
        idx = idx - s

        p(idx) = z
        idx = idx - s

        p(idx) = y
        idx = idx - s

        p(idx) = x

    end subroutine fwd_lift

    ! inverse lifting transform of 4 - vector
    pure subroutine inv_lift(p, offset, s)
        implicit none

        integer, dimension(16), intent(inout) :: p
        integer, intent(in) :: offset, s
        integer :: idx, x, y, z, w

        idx = 1 + offset

        x = p(idx)
        idx = idx + s

        y = p(idx)
        idx = idx + s

        z = p(idx)
        idx = idx + s

        w = p(idx)

        ! non - orthogonal transform
        ! (4 6 - 4 - 1) (x)
        ! 1/4*(4 2 4 5) (y)
        ! (4 - 2 4 - 5) (z)
        ! (4 - 6 - 4 1) (w)

        ! shiftr does not preserve the sign bit
        ! therefore shifta is used in the code below

        y = y + shifta(w, 1)
        w = w - shifta(y, 1)
        y = y + w
        w = shiftl(w, 1)
        w = w - y
        z = z + x
        x = shiftl(x, 1)
        x = x - z
        y = y + z
        z = shiftl(z, 1)
        z = z - y
        w = w + x
        x = shiftl(x, 1)
        x = x - w

        p(idx) = w
        idx = idx - s

        p(idx) = z
        idx = idx - s

        p(idx) = y
        idx = idx - s

        p(idx) = x

    end subroutine inv_lift

    pure subroutine fwd_xform(p)
        implicit none

        integer, dimension(16), intent(inout) :: p
        integer :: x, y

        ! transform along x
        do y = 0, 3
            call fwd_lift(p, 4*y, 1)
        end do

        ! transform along y
        do x = 0, 3
            call fwd_lift(p, 1*x, 4)
        end do

    end subroutine fwd_xform

    ! inverse decorrelating 2D transform
    pure subroutine inv_xform(p)
        implicit none

        integer, dimension(16), intent(inout) :: p
        integer :: x, y

        ! transform along y
        do x = 0, 3
            call inv_lift(p, 1*x, 4)
        end do

        ! transform along x
        do y = 0, 3
            call inv_lift(p, 4*y, 1)
        end do

    end subroutine inv_xform

    ! reorder signed coefficients and convert to unsigned integer
    pure subroutine fwd_order(p)
        implicit none

        integer, dimension(16), intent(inout) :: p

        ! re-order and convert to unsigned integer
        p = int2uint(p(1 + PERM))

    end subroutine fwd_order

    ! reorder unsigned coefficients and convert to signed integer
    pure subroutine inv_order(p)
        implicit none

        integer, dimension(16), intent(inout) :: p

        ! convert to signed integer and re-order
        p(1 + PERM) = uint2int(p)

    end subroutine inv_order

    ! map two's complement signed integer to negabinary unsigned integer
    elemental integer function int2uint(x)
        implicit none

        integer, intent(in) :: x

        ! ((uint)x + NBMASK) ^ NBMASK
        int2uint = IEOR(x + NBMASK, NBMASK)

    end function int2uint

    ! map two's complement signed integer to negabinary unsigned integer
    elemental integer function uint2int(x)
        implicit none

        integer, intent(in) :: x

        ! (int)((x ^ NBMASK) - NBMASK)
        uint2int = IEOR(x, NBMASK) - NBMASK

    end function uint2int

    subroutine encode_many_ints(data, stream, pos)
        implicit none

        integer, dimension(16), intent(in) :: data
        integer(kind=16), intent(inout) :: stream
        integer, intent(inout) :: pos

        integer :: i, k, bit, c, n

        ! a counter for runs of '1'
        integer :: bcount

        bcount = 0
        n = 0

        ! iterate over 32 bits from MSB to LSB
        do k = 31, 0, -1
            print *, 'k', k, 'n', n, 'pos', pos

            ! gather / emit up to n bits from the k-th bit plane
            do i = 1, n
                bit = ibits(data(i), k, 1)

                ! check if there is space to write
                if (pos .eq. max_bits) return
                call stream_write_bit(stream, bit, pos)
            end do

            if (n .eq. 16) cycle

            ! reset the '1' bit counter
            bcount = 0

            ! count remaining '1's in the k-th bit plane
            do i = n + 1, 16
                bit = ibits(data(i), k, 1)

                if (bit .eq. 1) bcount = bcount + 1
            end do

            print *, '"1" bcount', bcount

            ! unary run-length encode the remaining bits
            if (bcount .gt. 0) then
                do c = 1, bcount
                    print *, 'c', c

                    ! emit '1'
                    if (pos .eq. max_bits) return
                    call stream_write_bit(stream, 1, pos)

                    ! keep emitting '0' until '1' is encountered
1001                n = n + 1
                    if (n .gt. 16) exit

                    bit = ibits(data(n), k, 1)

                    if (pos .eq. max_bits) return
                    call stream_write_bit(stream, bit, pos)

                    if (bit .eq. 0) go to 1001
                end do
            end if

            if (n .lt. 16) then
                ! emit '0'
                if (pos .eq. max_bits) return
                call stream_write_bit(stream, 0, pos)
            end if

        end do

    end subroutine encode_many_ints

    subroutine decode_many_ints(data, stream, pos)
        implicit none

        integer, dimension(16), intent(out) :: data
        integer(kind=16), intent(in) :: stream
        integer, intent(inout) :: pos

        integer :: i, k, bit, c, n

        ! a counter for runs of '1'
        integer :: bcount

        bcount = 0
        n = 0

        ! zero-out the integer data array
        data = 0

        ! iterate over 32 bits from MSB to LSB
        do k = 31, 0, -1
            print *, 'k', k, 'n', n, 'pos', pos

            ! read the first n bits
            do i = 1, n
                bit = stream_read_bit(stream, pos)
                if (bit .lt. 0) return

                if (bit .eq. 1) data(i) = ibset(data(i), k)
            end do

            if (n .eq. 16) cycle

            ! read one bit, test it for '1'
1002        bit = stream_read_bit(stream, pos)
            if (bit .lt. 0) return

            if (bit .eq. 1) then
                ! keep on reading '0' until '1' is encountered

                print *, 'a new sequence starting @', n + 1

1003            bit = stream_read_bit(stream, pos)
                if (bit .lt. 0) return

                n = n + 1
                if (n .gt. 16) go to 1004

                if (bit .eq. 1) then
                    print *, 'setting bit @', n
                    data(n) = ibset(data(n), k)

                    if (n .eq. 16) go to 1004

                    go to 1002
                else
                    go to 1003
                end if
            else
                go to 1004
            end if

1004        continue

        end do

    end subroutine decode_many_ints

    subroutine encode_ints(data, stream, pos)
        implicit none

        integer, dimension(16), intent(in) :: data
        integer(kind=16), intent(inout) :: stream
        integer, intent(inout) :: pos

        integer(kind=2) :: val, i, k, bit

        ! a counter for runs of '0'
        integer :: zcount, status, bit_count

        zcount = 0
        bit_count = 0

        ! iterate over 32 bits from MSB to LSB
        do k = 31, 0, -1
            print *, 'k', k

            val = 0
            ! gather k-plane bits from the input data
            do i = 1, 16
                bit = int(ibits(data(i), k, 1), kind=2)
                ! print *, 'i', i, 'bit', bit, data(i)

                if (bit .eq. 1) then
                    ! the runs of zeroes has finished

                    ! Golomb or Rice-encode the zcount
                    status = Golomb_encode(stream, pos, zcount)
                    if (status .eq. -1) return

                    ! reset the zeroes counters
                    zcount = 0
                else
                    zcount = zcount + 1
                end if

                bit_count = bit_count + 1
                print *, 'bit_count', bit_count

                ! val = ior(shiftl(val, 1), bit)
            end do

            ! display the value (validation)
            ! write (*, '(a,i0,a,b16.16)') 'k: ', k, ', val: ', val
        end do

        ! flush the encoder
        status = Golomb_encode(stream, pos, zcount)

    end subroutine encode_ints

    subroutine decode_ints(data, stream, pos)
        implicit none

        integer, dimension(16), intent(out) :: data
        integer(kind=16), intent(in) :: stream
        integer, intent(inout) :: pos

        integer :: i, k

        ! a counter for runs of '0'
        integer :: zcount

        data = 0
        zcount = -1

        ! iterate over 32 bits from MSB to LSB
        do k = 31, 0, -1

            ! set k-plane bits
            do i = 1, 16

                ! decode the next zero-run length
                if (zcount .lt. 0) then

                    zcount = Golomb_decode(stream, pos)

                    if (zcount .lt. 0) return

                    print *, 'zcount', zcount

                end if

                zcount = zcount - 1

                if (zcount .lt. 0) then
                    ! set the appropriate bit to '1'
                    data(i) = ibset(data(i), k)
                end if

            end do
        end do

    end subroutine decode_ints

    integer function Golomb_encode(stream, pos, N)
        implicit none

        integer(kind=16), intent(inout) :: stream
        integer, intent(inout) :: pos
        integer, intent(in) :: N

        integer :: i, t, nbits

        ! quotient, remainder
        integer :: q, r

        Golomb_encode = -1

        q = N/G_M
        r = modulo(N, G_M)

        print *, 'Golomb encoder: N', N, 'pos', pos, 'q', q, 'r', r

        ! Quotient Code
        if (q .gt. 0) then
            do i = 1, q
                ! check if there is space to write
                if (pos .eq. max_bits) return
                call stream_write_bit(stream, 1, pos)
            end do
        end if

        if (pos .eq. max_bits) return

        call stream_write_bit(stream, 0, pos)

        ! Remainder Code
        t = 2**G_b - G_M

        if (r .lt. t) then

            nbits = G_b - 1

            print *, 'coding the remainder using', nbits, 'nbits'

            ! check if there is space to write
            if (pos + nbits .gt. max_bits) return
            call stream_write_bits(stream, r, nbits, pos)

        else

            nbits = G_b
            r = r + t

            print *, 'coding remainder+', r, 'using', nbits, 'nbits'

            ! check if there is space to write
            if (pos + nbits .gt. max_bits) return
            call stream_write_bits(stream, r, nbits, pos)

        end if

        Golomb_encode = 0

        return

    end function Golomb_encode

    integer function Golomb_decode(stream, pos)
        implicit none

        integer(kind=16), intent(in) :: stream
        integer, intent(inout) :: pos

        integer :: s, x, bit, t

        Golomb_decode = -1

        s = 0
        ! count the number of consecutive '1', stop at '0'

        do
            bit = stream_read_bit(stream, pos)

            if (bit .lt. 0) return

            if (bit .eq. 0) exit

            s = s + 1
        end do

        x = stream_read_bits(stream, pos, G_b - 1)

        if (x .lt. 0) return

        t = 2**G_b - G_M

        if (x .lt. t) then
            Golomb_decode = s*G_M + x
            return
        end if

        bit = stream_read_bit(stream, pos)

        if (bit .lt. 0) return

        x = shiftl(x, 1) + bit

        Golomb_decode = s*G_M + x - t

        return

    end function Golomb_decode

    subroutine Rice_encode(stream, pos, N)
        implicit none

        integer(kind=16), intent(inout) :: stream
        integer, intent(inout) :: pos
        integer, intent(in) :: N

        integer :: i

        ! quotient, pseudo-remainder
        integer :: q, r

        q = shiftr(N, R_k) ! divide by R_M = 2**R_k
        r = N

        print *, 'Rice encoder: N', N, 'pos', pos, 'q', q

        ! Quotient Code
        if (q .gt. 0) then
            do i = 1, q
                ! check if there is space to write
                if (pos .eq. max_bits) return

                call stream_write_bit(stream, 1, pos)
            end do
        end if

        if (pos .eq. max_bits) return

        call stream_write_bit(stream, 0, pos)

        ! Remainder Code
        ! check if there is space to write
        if (pos + R_k .gt. max_bits) return

        call stream_write_bits(stream, r, R_k, pos)

    end subroutine Rice_encode

    integer function Rice_decode(stream, pos)
        implicit none

        integer(kind=16), intent(in) :: stream
        integer, intent(inout) :: pos

        integer :: s, x, bit

        Rice_decode = -1

        s = 0
        ! count the number of consecutive '1', stop at '0'

        do
            bit = stream_read_bit(stream, pos)

            if (bit .lt. 0) return

            if (bit .eq. 0) exit

            s = s + 1
        end do

        x = stream_read_bits(stream, pos, R_k)

        if (x .lt. 0) return

        Rice_decode = shiftl(s, R_k) + x

        return

    end function Rice_decode

    subroutine stream_write_bit(stream, bit, pos)
        implicit none

        integer(kind=16), intent(inout) :: stream
        integer, intent(in) :: bit
        integer, intent(inout) :: pos

        ! make place for the new bit
        stream = shiftl(stream, 1)

        ! set the LSB bit
        if (bit .eq. 1) then
            stream = ibset(stream, 0)
        end if

        pos = pos + 1

        return

    end subroutine stream_write_bit

    subroutine stream_write_bits(stream, bits, n, pos)
        implicit none

        integer(kind=16), intent(inout) :: stream
        integer, intent(inout) :: bits
        integer, intent(in) :: n
        integer, intent(inout) :: pos

        integer :: i

        if (n .lt. 1) return

        stream = shiftl(stream, n)

        call mvbits(int(bits, kind=16), 0, n, stream, 0)

        pos = pos + n

        return

    end subroutine stream_write_bits

    subroutine pad_stream(stream, n, pos)
        implicit none

        integer(kind=16), intent(inout) :: stream
        integer, intent(in) :: n
        integer, intent(inout) :: pos

        integer :: i

        if (n .lt. 1) return

        print *, 'padding the stream with', n, '0 bits'

        stream = shiftl(stream, n)
        pos = pos + n

        return
    end subroutine pad_stream

    integer function stream_read_bit(stream, pos)
        implicit none

        integer(kind=16), intent(in) :: stream
        integer, intent(inout) :: pos

        if (pos .lt. 0) then
            stream_read_bit = -1
            return
        end if

        if (btest(stream, pos)) then
            stream_read_bit = 1
        else
            stream_read_bit = 0
        end if

        pos = pos - 1

        return

    end function stream_read_bit

    integer function stream_read_bits(stream, pos, n)
        implicit none

        integer(kind=16), intent(in) :: stream
        integer, intent(inout) :: pos
        integer, intent(in) :: n

        integer :: i

        stream_read_bits = -1

        if (n .lt. 1) return

        if (pos - n + 1 .lt. 0) return

        stream_read_bits = int(ibits(stream, pos - n + 1, n))

        pos = pos - n

        return

    end function stream_read_bits

end program main


module NewModule
    use iso_fortran_env
    use ArrayClass
    use RandomClass
    use IOClass
    implicit none

contains

end module

program main
    use LinearSolverClass
    implicit none

    integer(int32) :: i
    real(real64),allocatable :: coeff(:),fit_coeff(:)
    real(real64),allocatable :: training_data(:,:)
    real(real64) :: err
    type(IO_) :: f

    training_data = zeros(21,2)
    ! input
    training_data(:,1) = linspace([-10.0d0,10.0d0],21)
    ! result
    training_data(:,2) = training_data(:,1)*training_data(:,1)*training_data(:,1) - training_data(:,1) +1.0d0

    ! trial : -x^3 + x^2 + x + 1
    coeff = [-1.0d0, 1.0d0, 1.0d0, 1.0d0]

    ! fitting by Robbin-Monro algorithm (SGD)
    fit_coeff = fit(f=polynomial, training_data=training_data, params=coeff ,eta=0.000001d0, error=err,logfile="SGD.log")

    ! show result
    call f%open("training_data.txt","w")
    do i=1,size(training_data,1)
        call f%write(training_data(i,1), training_data(i,2) )
    enddo
    call f%close()

    call f%open("SGD_fit.txt","w")
    do i=-20,20
        call f%write(dble(i), polynomial(x=dble(i),params=fit_coeff ) )
    enddo
    call f%close()
    call f%plot()

end program main


SUBROUTINE GridBarnes(f,l,n,b)

!==========================================================
!  This routine applied a Barnes analysis to a gridded two
!  dimensional function as a filter.
!
!  HISTORY: JAN. 2005 by YUANFU XIE.
!==========================================================

   IMPLICIT NONE

   INTEGER, INTENT(IN) :: l(2),n(2)
   REAL,    INTENT(IN) :: f(l(1),l(2))
   REAL,    INTENT(OUT) :: b(l(1),l(2))

   ! Local variables:
   INTEGER :: i,j,ir,ni,nj,ip
   REAL    :: gama,s,w,ws,t(l(1),l(2)),tmp

   gama = 0.2
   s = 2.0e3/gama  ! kapa_0
   ir = 60	   ! neighbors

   ! Clean analysis field:
   b = 0.0
   t = 0.0

   ! Barnes analysis:
   DO ip=1,1

      s = s*gama

      ! For every gridpoint:
      DO j=1,n(2)
         DO i=1,n(1)

	    ! For each neighbor within ir:
	    ws = 0.0
	    tmp = 0.0
	    DO nj=-ir,ir,2
	       DO ni=-ir,ir,2
		  w = EXP(-(FLOAT(ni)**2+FLOAT(nj)**2)/s)

		  IF ((i+ni .GE. 1) .AND. (i+ni .LE. n(1)) .AND. &
		      (j+nj .GE. 1) .AND. (j+nj .LE. n(2))) THEN
		     tmp = tmp+(f(i+ni,j+nj)-t(i+ni,j+nj))*w
		     ws = ws + w
		  ENDIF

	       ENDDO
	    ENDDO

	    b(i,j) = b(i,j)+tmp/ws
         ENDDO
      ENDDO

      t = b

   ENDDO

END SUBROUTINE GridBarnes


! CREATED BY ${USER_NAME} ON 11/27/18.

PROGRAM SOLVE_REPRESS
  !     SOLVE CME OF THE REPRESSILATOR
  USE STATESPACE
  USE KRYLOVSOLVER
  IMPLICIT NONE

  INTERFACE
     DOUBLE PRECISION FUNCTION CLOCK()
     END FUNCTION CLOCK
  END INTERFACE

  DOUBLE PRECISION :: T = 10.0D0, EXP_TOL = 1.0D-14, FSP_TOL = 1.0D-4
  TYPE (CME_MODEL) :: MODEL
  TYPE (FINITE_STATE_PROJECTION) :: FSP_IN, FSP
  DOUBLE PRECISION, DIMENSION(NMAX) :: P0, P
  DOUBLE PRECISION :: TIC
  INTEGER :: I

  CALL RANDOM_SEED()

  CALL MODEL%CREATE(3, 6, 3)
  MODEL%STOICHIOMETRY = RESHAPE((/1,0,0,-1,0,0,0,1,0,0,-1,0,0,0,1,0,0,-1/), (/3,6/))
  MODEL%CUSTOMPROP => PROPENSITY
  CALL MODEL%RESET_PARAMETERS([100.0D0, 25.0D0, 1.0D0])
  MODEL%LOADED = .TRUE.

  ! INITIALIZE THE ATTRIBUTES OF THE FSP BASED ON THE UNDERLYING MODEL
  TIC = CLOCK()
  WRITE(*,*) 'ALLOCATING MEMORY FOR THE FSP...'
  CALL FSP_IN%CREATE(MODEL)
  CALL FSP%CREATE(MODEL)
  WRITE(*, FMT = 200) CLOCK() - TIC

  FSP_IN%SIZE = 1
  FSP_IN%STATE(:, 1) = [22, 0, 0]
  P0(1) = 1.0
  FSP_IN%VECTOR = P0
  FSP = FSP_IN
  TIC = CLOCK()
  WRITE(*,*) 'CALLING THE SOLVER...'
  CALL CME_SOLVE(MODEL, T, FSP_IN, FSP, FSP_TOL, EXP_TOL, VERBOSITY = 1)
  WRITE(*, FMT = 200) CLOCK() - TIC
200 FORMAT ('ELAPSED TIME :', F10.2)

  CALL FSP%CLEAR()
  CALL FSP_IN%CLEAR()
CONTAINS
  DOUBLE PRECISION FUNCTION PROPENSITY(STATE, REACTION, PARAMETERS)
    INTEGER, INTENT(IN) :: STATE(:), REACTION
    DOUBLE PRECISION, INTENT(IN), OPTIONAL :: PARAMETERS(:)

    SELECT CASE (REACTION)
    CASE(1)
       PROPENSITY = PARAMETERS(1)/(1D0 + PARAMETERS(2)*STATE(2)**6.0D0)
    CASE(2)
       PROPENSITY = PARAMETERS(3)*STATE(1)
    CASE(3)
      PROPENSITY = PARAMETERS(1)/(1D0 + PARAMETERS(2)*STATE(3)**6.0D0)
    CASE(4)
      PROPENSITY = PARAMETERS(3)*STATE(2)
    CASE(5)
      PROPENSITY = PARAMETERS(1)/(1D0 + PARAMETERS(2)*STATE(1)**6.0D0)
    CASE(6)
      PROPENSITY = PARAMETERS(3)*STATE(3)

    END SELECT
  END FUNCTION PROPENSITY
END PROGRAM


    program wavedd

    implicit none

    integer, parameter :: jprocs = 3, iprocs = 3
    integer, parameter :: isrc=14, jsrc=14
    real(8), parameter :: Lx=1000, Ly=1000, t=2
    real(8), parameter :: CFL=0.5, c=1
    real(8), parameter :: dx=0.1, dy=0.1

    integer :: i, j
    integer :: irank
    real(8), dimension(:,:), allocatable :: wn, wnm1
    integer :: ista, iend, jsta, jend
    real(8) :: tt
    integer, parameter :: nxlocal=Lx/dx, nylocal=Ly/dy
    integer, parameter :: nx=nxlocal+2, ny=nylocal+2
    real(8), parameter :: dt=CFL*dx/c
    integer :: curimage(2)
    ! alloc coarray
    real(8), allocatable :: wnp1(:,:)[:,:]

    allocate(wn(nx,ny))
    allocate(wnp1(nx,ny)[iprocs,*])
    allocate(wnm1(nx,ny))

    curimage=this_image(wnp1)
    ! write(*,*) this_image(wnp1)
    sync all

    !! Calculation of the wave equation
    wn=0
    wnp1=wn
    tt=0

    do while (tt<t)

        ! sync all

        if (curimage(1) > 1) &
            wnp1(1,:)=wnp1(nx-1,:)[curimage(1)-1,curimage(2)]
        if (curimage(1) < iprocs) &
            wnp1(nx,:)=wnp1(2,:)[curimage(1)+1,curimage(2)]
        if (curimage(2)>1) &
            wnp1(:,1)=wnp1(:,ny-1)[curimage(1),curimage(2)-1]
        if (curimage(2) < jprocs) &
            wnp1(:,ny)=wnp1(:,2)[curimage(1),curimage(2)+1]

        sync all

        ista=2
        jsta=2
        iend=nx-1
        jend=ny-1
        if (curimage(1) == 1) then
            wn(ista,:)=0
            ista=ista+1
        endif
        if (curimage(1) == iprocs) then
            wn(iend,:)=0
            iend=iend-1
        endif
        if (curimage(2) == 1) then
            wn(:,jsta)=0
            jsta=jsta+1
        endif
        if (curimage(2) == jprocs) then
            wn(:,jend)=0
            jend=jend-1
        endif

        wnm1=wn
        wn=wnp1
        do i=ista,iend
            do j=jsta,jend
                wnp1(i,j)=2*wn(i,j)-wnm1(i,j)+CFL*CFL*(wn(i+1,j)+wn(i,j+1)-4*wn(i,j)+wn(i-1,j)+wn(i,j-1))
                if (isrc == (curimage(1)-1)*nxlocal+i-1 .and. jsrc == (curimage(2)-1)*nylocal+j-1) then
                    wnp1(i,j)=wnp1(i,j)+dt*dt*20*sin(30*3.14*tt/20)
                endif
            enddo
        enddo
        tt=tt+dt
    enddo

    ! Display and write the result
    !do irank=1, num_images()
    !    if (irank==this_image()) then
    !        write(*,*) "image: ", this_image()
    !        write(*,*) wn(2:nx-1,2:ny-1)
    !        open(unit = 1 , file = "wavedd.txt", position="append")
    !        write(1,*) wn(2:nx-1,2:ny-1)
    !        close(1)
    !   endif
    !   sync all
    !enddo

    end program wavedd


      function sdist (r0, r1)
c     find distance squared between cartesian points r0 and r1
c     single precision
      dimension r0(3), r1(3)
      sdist = 0
      do 10  i = 1, 3
         sdist = sdist + (r0(i) - r1(i))**2
   10 continue
      sdist = sqrt(sdist)
      return
      end