!######################################################
!# Original XRDSF url: https://github.com/rraffiu/XRDSF
!# Author. : Amsera
!# Date.   : 21st Dec. 2020
!######################################################
Module xrdsf_lib
Contains
  Function Calc_intents(msd, natm, atm_loc, curg, prma, prmb, prmc) Result (sq)
    Implicit None
    Integer, Intent(in) :: natm
    Real(8), Intent(in) :: atm_loc(natm,3), prma(natm,4), prmb(natm,4), prmc(natm), curg(3), msd
    Integer    i
    Real(8)    nrmg, sq(2), tsq, dwf, proj(natm)
    Complex(8) v, prow
    v    = cmplx(0.,1.)
    Call Calc_proj(natm,atm_loc,curg,proj)
    nrmg = Norm(curg)
    dwf  = Exp(-1.d0*msd*nrmg*nrmg/3.d0)
    prow = 0.d0
    Do i = 1, natm
      prow = prow + Calc_eaff(prma(i,:),prmb(i,:),prmc(i),nrmg)*Exp(proj(i)*v)
    Enddo
    tsq  = Abs(prow*dwf)
    tsq  = tsq * tsq
    sq(1)= nrmg
    sq(2)= tsq
    Return
  End function Calc_intents

  Subroutine Calc_proj(natm,aloc,curg,proj)
    Implicit None
    Integer, Intent(in) :: natm
    Real(8), Intent(in) :: aloc(natm,3), curg(3)
    Real(8), Intent(inout) :: proj(natm)
    Integer i
    Do i = 1, natm
      proj(i) = Dot_product(aloc(i,:),curg)
    Enddo
    Return
  End subroutine Calc_proj

  Function Calc_eaff(a,b,c,g) Result(f)
    Implicit None
    Real(8), Intent(in) :: a(4), b(4), c, g
    Real(8) tmp,f,pi
    Integer i
    pi  = 3.1415926d0
    tmp = -1.d0*((0.25*g/pi)**2.d0)
    f   = c
    Do i = 1, 4
      f = f + a(i)*Exp(b(i)*tmp)
    Enddo
    Return
  End function Calc_eaff

  Function Norm(v) Result(l)
    Implicit None
    Real(8), Intent(in) :: v(3)
    Real(8) l
    l = v(1)*v(1) + v(2)*v(2) + v(3)*v(3)
    l = Sqrt(l)
    Return
  End function Norm

  Function Get_g(rvec,indx) Result(cg)
    Implicit None
    Integer, Intent(in)  :: indx(3)
    Real(8), Intent(in)  :: rvec(3,3)
    Real(8) cg(3)
    cg = matmul(indx,rvec)
    Return
  End function Get_g
End Module xrdsf_lib

Subroutine f_calc_ints(m,n,l,g,a,b,c,sq)
  Use xrdsf_lib
  Integer, Intent(in)  :: n
  Real(8), Intent(in)  :: m, l(n,3), g(3), a(n,4), b(n,4), c(n)
  Real(8), Intent(out) :: sq(2)
!f2py intent(in)  :: m,m,l,g,a,b,c
!f2py intent(out) :: sq
  sq = Calc_intents(m,n,l,g,a,b,c)
  Return
End subroutine f_calc_ints

Subroutine f_loop(msd,mh,mk,ml,ng,rvec,na,aloc,prma,prmb,prmc,sq)
  Use xrdsf_lib
  Integer, Intent(in)   :: mk, mh, ml, ng, na
  Real(8), Intent(in)   :: rvec(3,3),aloc(na,3),prma(na,4),prmb(na,4),prmc(na),msd
  Real(8), Intent(out)  :: sq(ng,5)
  Integer  h,k,l,ig
  Real(8)  cg(3)
!f2py intent(out) :: sq
  ig = 0
  Do h = -mh, mh
    Do k = -mk, mk
      Do l = -ml, ml
        ig = ig + 1
        sq(ig,1:3) = (/h,k,l/)
        cg = Get_g(rvec,(/h,k,l/))
        sq(ig,4:5) = Calc_intents(msd,na,aloc,cg,prma,prmb,prmc)
      Enddo
    Enddo
  Enddo
  Return
End Subroutine f_loop


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_upr1utri_unimodscale
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine scales either a row or column of a unitary plus rank
! one upper-triangular matrix (upr1utri) by a complex unimodular scalar.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  ROW             LOGICAL
!                    .TRUE.: scale row
!                    .FALSE.: scale column
!
!  D               REAL(8) array of dimension (2)
!                    array of generators for complex diagonal matrix
!                    in the upper-triangular factor
!
!  C               REAL(8) array of dimension (3)
!                    first array of generators for upper-triangular part
!
!  B               REAL(8) array of dimension (3)
!                    second array of generators for upper-triangular part
!
!  SCL             COMPLEX(8)
!                    scalar, assumed unimodular
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_upr1utri_unimodscale(ROW,D,C,B,SCL)

  implicit none

  ! input variables
  logical, intent(in) :: ROW
  real(8), intent(inout) :: D(2), C(3), B(3)
  complex(8), intent(in) :: SCL

  ! compute variables
  real(8) :: nrm
  complex(8) :: temp

  ! update D regardless of row or column
  temp = SCL*cmplx(D(1),D(2),kind=8)
  call d_rot2_vec2gen(dble(temp),aimag(temp),D(1),D(2),nrm)

  ! update B and C
  if (.NOT.ROW) then

      ! update B
    temp = SCL*cmplx(B(1),B(2),kind=8)
    call z_rot3_vec3gen(dble(temp),aimag(temp),B(3),B(1),B(2),B(3),nrm)

    ! update C
    temp = conjg(SCL)*cmplx(C(1),C(2),kind=8)
    call z_rot3_vec3gen(dble(temp),aimag(temp),C(3),C(1),C(2),C(3),nrm)

  end if

end subroutine z_upr1utri_unimodscale


module mvwrap
use precision_model
use mvstat
IMPLICIT NONE

contains
SUBROUTINE MVNDIST(N, COVRNC, NU, M, LOWER, CONSTR, UPPER, INFIN, DELTA, &
        MAXPTS, ABSEPS, RELEPS, ERROR, VALUE, NEVALS, INFORM)
      INTEGER,                         INTENT(IN)  :: N, NU, M, MAXPTS
      REAL(KIND=STND), DIMENSION(M),   INTENT(IN)  :: LOWER, UPPER, DELTA
      REAL(KIND=STND), DIMENSION(N,N), INTENT(IN)  :: COVRNC
      REAL(KIND=STND), DIMENSION(M,N), INTENT(IN)  :: CONSTR
      INTEGER,    DIMENSION(M),        INTENT(IN)  :: INFIN
      REAL(KIND=STND),                 INTENT(IN)  :: RELEPS, ABSEPS
      INTEGER,                         INTENT(OUT) :: INFORM, NEVALS
      REAL(KIND=STND),                 INTENT(OUT) :: ERROR, VALUE

      CALL MVDIST(N, COVRNC, NU, M, LOWER, CONSTR, UPPER, INFIN, DELTA, MAXPTS, ABSEPS, RELEPS, ERROR, VALUE, NEVALS, INFORM)
END SUBROUTINE MVNDIST
end module mvwrap


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Single shift RQZ for real Hessenberg pairs
! ___________________________________________________________________
module d_RQZ

use u_parameters
use u_activeparts
use d_computepoles
use d_setpoles
use d_deflations
use d_swappoles12
use d_swappoles22
use d_memorymgmt

implicit none
private
public d_RQZ2, d_getEigenvalues

contains
  subroutine d_RQZ2(A, B, compAB, strtidx, stpidx, Q, compQ, qcol, &
                    Z, compZ, zcol, sa)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Implements the combination shift real-valued RQZ method
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [INOUT]
  !           Matrix in upper block-Hessenberg form on entrance.
  !           On exit, the part defined by strtidx and stpidx is
  !           in upper blocktriangular form and is equivalent with A
  !           if compAB is true.
  !
  ! B       double array [INOUT]
  !           Matrix in upper Hessenberg form on entrance.
  !           On exit, the part defined by strtidx and stpidx is
  !           in upper triangular form and is equivalent with B
  !           if compAB is true.
  !
  ! compAB  boolean       [IN]
  !           If true, the equivalences are applied to (A,B) such
  !           that the output (block)triangular pair is equivalent to
  !           the input pair. If not, the output is not
  !           equivalent but the eigenvalues of the original pair
  !           are available on the diagonal.
  !
  ! strtidx integer     [IN]
  !           Start index of part of the matrix pencil that needs
  !           to be reduced to Schur form. Provide '0' if start is
  !           the beginning of the pencil.
  !
  ! stpidx  integer     [IN]
  !           Stop index of the part of the matrix pencil that needs
  !           to be reduced to Schur form. Provide N (matrix size) if
  !           stop is the end of the pencil. The strt and stp parameters
  !           need to satisfy:
  !               0 <= strtidx < stpidx <= N
  !
  ! Q       double array [INOUT]
  !           Orthonormal matrix containing the left Schur
  !           vectors. The number of columns of Q should be at least
  !           stpidx-strtidx. The Q array is not initialized in this routine.
  !
  ! compQ   boolean       [IN]
  !           If true, the left Schur vectors are computed.
  !
  ! qcol    integer       [IN]
  !           Column index from whereon the equivalence transformations
  !           are applied. If they should be applied from the beginning
  !           of the Q array, qcol needs to be set to 1. If qcol > 1, then
  !           the Q array should have at least qcol+stpidx-strtidx-1 columns.
  !
  ! Z       double array [INOUT]
  !           Orthonormal matrix containing the right Schur
  !           vectors. The number of columns of Z should be at least
  !           stp-strt. The Z array is not initialized in this routine.
  !
  ! compZ   boolean       [IN]
  !           If true, the right Schur vectors are computed.
  !
  ! zcol    integer       [IN]
  !           Column index from whereon the equivalence transformations
  !           are applied. If they should be applied from the beginning
  !           of the Z array, zcol needs to be set to 1. If zcol > 1, then
  !           the Z array should have at least zcol+stpidx-strtidx-1 columns.
  !
  ! sa   boolean [OPTIONAL - IN]
  !           Optional boolean, defaults to true. If true, the routine is
  !           assumed to be called 'standalone'. This means that:
  !             * auxilary arrays allocated in this subroutine are deallocated
  !           A standalone call of d_RQZ2 should omit this optional
  !           argument, or provide true. Otherwise memory can leak.
  !
  ! On successful completion of the routine the following equivalences hold:
  !   A(out) = Q^T A(in) Z
  !   B(out) = Q^T B(in) Z
  !___________________________________________________________________________
  ! last edit: January 15, 2019

  real(kind=dp), intent(inout)      ::  A(:,:), B(:,:), Q(:,:), Z(:,:)
  logical, intent(in)               ::  compAB, compQ, compZ
  integer, intent(in)               ::  strtidx, stpidx, qcol, zcol
  logical, intent(in), optional     ::  sa

  ! Internal variables
  type(tAp), pointer                :: apHead, apCurrent, apTotal
  integer                           :: i, N, nit, nswaps, ld, qci, zci
  integer,pointer                   :: cstrt, cstp
  logical                           :: problemsolved, defl, isreal, ds, sa2
  real(kind=dp)                     :: mu, nu

  external                          :: DGEMM
  real(kind=dp)                     :: DLAMCH

  ! Initialize variables
  sfmin = DLAMCH('S')
  N = stpidx-strtidx
  if (present(sa)) then
    sa2 = sa
  else
    sa2 = .true.
  end if

  ! apHead stores the active parts throughout the iteration
  call tApInit(apHead,strt=strtidx,stp=stpidx)
  ! apTotal stores the active part at the start and is never modified
  call tApInit(apTotal,strt=strtidx,stp=stpidx)
  ! Q and Z indices
  qci = qcol-strtidx
  zci = zcol-strtidx

  ! For larger swaps
  call d_allocateSwap4Mem
  call d_allocateRCMem(4,N)

  ! Performance tracking
  nit = 0
  nswaps = 0
  ld = 0
  problemsolved = .false.
  ! Start of main program
  do while (.not. problemsolved)
  ! Main loop is repeated until no active parts are left
  apCurrent => apHead
  do
  ! Loop over all active parts
    call tApGet(apCurrent,cstrt,cstp)
    if (cstp - cstrt .le. 3) then
      if (cstp - cstrt .eq. 2) then
        ! 2 x 2 Block
        if (abs(A(cstrt+2,cstrt+1)) .gt. dzero) then
          ! Check if cc
          call d_eigenvalues2x2(A,B,cstrt+1,cstrt+1,mu,nu,isreal)
          if (isreal) then
            call d_make_hess(mu,cstrt+1,cstrt+1,A,B,compAB,apCurrent,apTotal,&
                   Q,compQ,qci+cstrt,Z,compZ,zci+cstrt)
          end if
        end if
      elseif (cstp - cstrt .eq. 3) then
        ! 3 x 3 Block
        ! Handle direct to avoid getting stuck
        if (abs(A(cstrt+3,cstrt+1)) .gt. dzero) then
          call d_first_double_to_inf(A,B,compAB,apCurrent,apTotal,&
                  Q,compQ,qci+cstrt)
        end if
        defl = .false.
        ld = 0
        do while (.not. defl)
          call d_start_deflation_single(defl,A,B,compAB,apCurrent,apTotal,&
                  Q,compQ,qci+cstrt)
          if (defl) exit

          if ((ld .gt. 0) .and. (mod(ld,10) .eq. 0)) then
            ! exceptional shift
            isreal = .true.
            mu = A(cstp-1,cstp)
            nu = B(cstp-1,cstp)
          else
            call d_get_shift(A, B, cstp, mu, nu, isreal)
          end if

          if (isreal) then
            call d_first_single_pole(mu,nu,A,B,compAB,apCurrent,apTotal,&
                     Q,compQ,qci+cstrt)
            call d_swap11(cstrt+2,cstrt+1,A,B,compAB,apCurrent,apTotal,&
                     Q,compQ,qci+cstrt+1,Z,compZ,zci+cstrt)
            call d_last_single_pole(done,dzero,A,B,compAB,apCurrent,apTotal,&
                     Z,compZ,zci+cstrt+1)
          else
            call d_first_double_pole(cmplx(mu,nu,kind=dp),A,B,compAB,&
                     apCurrent,apTotal,Q,compQ,qci+cstrt,Z,compZ,zci+cstrt)
            call d_last_double_to_inf(A,B,compAB,apCurrent,apTotal,&
                     Z,compZ,zci+cstrt)
          end if
          call d_stop_deflation_single(defl,A,B,compAB,apCurrent,apTotal,&
                  Z,compZ,zci+cstrt+1)
          if (defl) exit
          ld = ld + 1
        end do
      end if
      ! Not an active part anymore, remove from list
      if (.not. (associated(tApPrevious(apCurrent)))) then
        ! apCurrent is the head, update head
        apHead => tApNext(apCurrent) ! can be null()
      end if
      ! Delete and restart
      call tApDelete(apCurrent)
      apCurrent => apHead
    else
      ! Handle the current active part with an RQZ sweep
      ! Check for deflations
      ! at front:
      if (abs(A(cstrt+3,cstrt+1)) .gt. dzero) then
        call d_start_deflation_double(defl,A,B,compAB,apCurrent,apTotal,&
                                   Q,compQ,qci+cstrt,Z,compZ,zci+cstrt)
      else
        call d_start_deflation_single(defl,A,B,compAB,apCurrent,apTotal,&
                                   Q,compQ,qci+cstrt)
      end if
      ! apCurrent is updated; consequently cstrt, and cstp are !
      if (defl) then
        ! Make sure that we're handling the correct range
        call tApGet(apCurrent,cstrt,cstp)
        ld = 0
      end if
      ! along subdiagonal:
      call d_check_interior_deflations(defl,A, B, compAB, apCurrent, apTotal, &
             Q, compQ, qci+cstrt, Z, compZ, zci+cstrt)
      ! apCurrent is updated; consequently cstrt, and cstp
      if (defl) then
        ! Make sure that we're handling the correct range
        call tApGet(apCurrent,cstrt,cstp)
        ld = 0
      end if

      if (cstp - cstrt .gt. 3) then
        ! Get the shift
        if ((ld .gt. 0) .and. (mod(ld,10) .eq. 0)) then
          ! exceptional shift
          mu = A(cstp-1,cstp)
          nu = B(cstp-1,cstp)
          isreal = .true.
        else
          call d_get_shift(A, B, cstp, mu, nu, isreal)
        endif
        ld = ld + 1

        if (isreal) then
          ! Will chase a real shift
          if (abs(A(cstrt+3,cstrt+1)) .gt. dzero) then
            ! We need to shift it to infinity
            call d_first_double_to_inf(A, B, compAB, apCurrent, apTotal, &
                    Q, compQ, qci+cstrt)
          end if
          call d_first_single_pole(mu, nu, A, B, compAB, apCurrent, apTotal, &
                                         Q, compQ, qci+cstrt)
        else
          ! Will chase a double shift
          if (abs(A(cstrt+4,cstrt+2)) .gt. dzero) then
            ! We place the double block first
            call d_swap12(cstrt+2,cstrt+1, A, B, compAB, apCurrent, apTotal, &
                        Q, compQ, qci+cstrt+1, Z, compZ, zci+cstrt)
          end if
          call d_first_double_pole(cmplx(mu,nu,kind=dp), A, B, compAB, &
                  apCurrent, apTotal, Q, compQ, qci+cstrt, Z, compZ, zci+cstrt)
        end if

        !Chase
        nit = nit + 1
        i = cstrt+1
        if (isreal) then
          ! Chase a single shift
          do while(i .lt. cstp-2)
            if (abs(A(i+3,i+1)) .gt. dzero) then
              ! Next is a double pole
              call d_swap12(i+1,i, A, B, compAB, apCurrent, apTotal, &
                          Q, compQ, qci+i, Z, compZ, zci+i-1)
              i = i + 2
              nswaps = nswaps + 2
            else
              ! Next is a single pole
              call d_swap11(i+1,i, A, B, compAB, apCurrent, apTotal, &
                          Q, compQ, qci+i, Z, compZ, zci+i-1)
              i = i + 1
              nswaps = nswaps + 1
            end if
          end do
          if (i .eq. cstp-2) then
            ! can take one more single swap
            call d_swap11(i+1,i, A, B, compAB, apCurrent, apTotal, &
                        Q, compQ, qci+i, Z, compZ, zci+i-1)
            i = i + 1
            nswaps = nswaps + 1
          end if
        else
          ! Chase a double shift
          do while (i .lt. cstp-3)
            if (abs(A(i+4,i+2)) .gt. dzero) then
              ! Next is a double pole
              call d_swap22(i+1,i, A, B, compAB, apCurrent, apTotal, &
                          Q, compQ, qci+i, Z, compZ, zci+i-1)
              i = i + 2
              nswaps = nswaps + 4

            else
              ! Next is a single pole
              call d_swap21(i+1,i, A, B, compAB, apCurrent, apTotal, &
                          Q, compQ, qci+i, Z, compZ, zci+i-1)
              i = i + 1
              nswaps = nswaps + 2
            end if
          end do
          if (i .eq. cstp-3) then
            ! Can take one more single swap
            call d_swap21(i+1,i, A, B, compAB, apCurrent, apTotal, &
                        Q, compQ, qci+i, Z, compZ, zci+i-1)
            i = i + 1
            nswaps = nswaps + 1
          end if
        end if

        ! Check for deflations at end
        if (.not.(abs(A(cstp,cstp-2)) .gt. dzero)) then
          call d_stop_deflation_single(defl, A, B, compAB,apCurrent, apTotal,&
                                    Z, compZ, zci+cstp-2)
        else
          call d_stop_deflation_double(defl, A, B, compAB,apCurrent, apTotal,&
                                    Q, compQ, qci+cstp-2,Z, compZ, zci+cstp-3)
        end if
        ! apCurrent is updated; consequently cstrt, and cstp
        if (defl) then
          ld = 0
        end if

        if (cstp - cstrt .gt. 3) then ! Check again
          ! set the pole
          ! Francis poles
          call d_get_pole(A, B, cstrt+1, mu, nu,isreal)
          ! infinity poles
          ! isreal = .true.
          ! mu = done
          ! nu = dzero
          if (isreal) then
            if (abs(A(cstp,cstp-2)) .gt. dzero) then
              ! Shift to Inf
              call d_last_double_to_inf( A, B, compAB, apCurrent, apTotal, &
                      Z, compZ, zci+cstp-3)
              ! Introduce real pole
              call d_last_single_pole(mu, nu, A, B, compAB, apCurrent,apTotal,&
                                   Z, compZ, zci+cstp-2)
              call d_swap11(cstp-1,cstp-2, A, B, compAB, apCurrent, apTotal, &
                             Q, compQ, qci+cstp-2, Z, compZ, zci+cstp-3)
            else
              ! Introduce real pole
              call d_last_single_pole(mu, nu, A, B, compAB, apCurrent,apTotal,&
                                   Z, compZ, zci+cstp-2)
            end if
          else
            ! Need to introduce a C.C. pole
            if (abs(A(cstp-1,cstp-3)) .gt. dzero) then
              call d_swap21(cstp-2,cstp-3, A, B, compAB, apCurrent, apTotal, &
                          Q, compQ, qci+cstp-3, Z, compZ, zci+cstp-4)
              ds = .true.
            else
              ds = .false.
            end if
            call d_last_double_pole(cmplx(mu,nu,kind=dp), A, B, compAB, &
                   apCurrent,apTotal, Q, compQ,qci+cstp-2, Z, compZ, zci+cstp-3)
            if (ds) then
              ! Avoids stagnation
              call d_swap12(cstp-2,cstp-3, A, B, compAB, apCurrent, apTotal, &
                          Q, compQ, qci+cstp-3, Z, compZ, zci+cstp-4)
            end if
          end if
        end if
      end if
    end if

    ! Check for exit condition
    if (associated(tApNext(apCurrent))) then
      apCurrent => tApNext(apCurrent) ! Set the next one
    else
      exit ! Exit this loop over the active parts
    end if
  ! end of loop over active parts
  end do

  ! Check if entire problem is solved
  call tApGet(apHead,cstrt,cstp)
  if (.not. (associated(cstrt) .or. associated(cstp))) then
    problemsolved = .true.
  end if
  ! end of main loop
  end do

  ! Normalize all 2x2 blocks
  apCurrent => apTotal ! This allows us to run make_hess if needed
  call d_normalizeSchur(A,B,compAB,apCurrent,apTotal,&
                            Q,compQ,qci,Z,compZ,zci,sa2)

  if (sa2) then
    call d_deallocateSwap4Mem
    call d_deallocateRCMem
  end if

  ! free everything
  apCurrent => null()
  call tApFree(apHead)
  call tApFree(apTotal)

  end subroutine

  subroutine d_getEigenvalues(A,B,strtidx,stpidx,realev,k,ccevr,ccevc,l)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Retrieve the eigenvalues for a pencil that has been (partially)
  ! reduced to generalized Schur form.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [IN]
  !         block upper triangular matrix
  ! B       double array [IN]
  !         upper triangular matrix
  ! strtidx integer [IN]
  !         pencil (A,B) is assumed to be in generalized Schur form from
  !         strtidx+1:stpidx
  ! stpidx  integer [IN]
  !         pencil (A,B) is assumed to be in generalized Schur form from
  !         strtidx+1:stpidx
  ! realev  double array [OUT]
  !         array that contains the k real eigenvalues in the range
  !         strtidx+1:stpidx
  ! k       integer [OUT]
  !         number of real eigenvalues in range strtidx+1:stpidx
  ! ccevr   double array [OUT]
  !         real parts of the l pairs of complex conjugate eigenvalues
  !         in range strtidx+1:stpidx
  ! ccevc   double array [OUT]
  !         complex parts of the l pairs of complex conjugate eigenvalues
  !         in range strtidx+1:stpidx
  ! l       integer [OUT]
  !         number of pairs of complex conjugate eigenvalues
  !         l and k satisfy : k + 2*l = stpidx - strtidx
  !___________________________________________________________________________
  ! last edit: January 15, 2019
    real(kind=dp), intent(in)   :: A(:,:), B(:,:)
    integer, intent(in)         :: strtidx, stpidx
    real(kind=dp), intent(out)  :: realev(:), ccevr(:), ccevc(:)
    integer, intent(out)        :: k, l

    integer :: i
    logical :: isreal
    real(kind=dp) :: mu, nu

    i = strtidx+1
    k = 0
    l = 0
    do while (i .lt. stpidx)
      if (abs(A(i+1,i)) .gt. dzero) then
        call d_eigenvalues2x2(A,B,i,i,mu,nu,isreal)
        if (isreal) then
          realev(k+1) = mu
          realev(k+2) = nu
          k = k + 2
        else
          ccevr(l+1) = mu
          ccevc(l+1) = nu
          l = l + 1
        end if
        i = i + 2
      else
        realev(k+1) = A(i,i)/B(i,i)
        k = k + 1
        i = i + 1
      end if
    end do
    if (i .eq. stpidx) then
      realev(k+1) = A(i,i)/B(i,i)
      k = k + 1
    end if
  end subroutine
end module d_RQZ


	INCLUDE 'VICMAIN_FOR'
C------------------------------------------------------------------------------
C FRACGEN
C Revisions:
C       12 March 1990, Megan O'Shaughnessy
C          Changed directory in which the scratch file is created, from
C          the default directory to V2$SCRATCH:.  (The scratch file takes up
C          lots of space (~8200 blocks in my runs of FRACGEN,) and if the user
C          didn't have enough file quota the program would abend.)  Also,
C          mention that the scratch file is created was added to the help file.
C 	2-AUG-1993 by G. A. Madrid Jr.
C	   Deleted call to OPENSCRATCH subroutine because a reference to a
C	   specific VMS filename was coded into the CALL statement, which is
C	   does not lead to very portable code.  Instead, a new parameter was
C	   made up which allows the user the option of specifying the name of
C	   scratch file to be used and its location, making it more convenient
C	   to use and more portable.  This new parameter is called IDSNAM.
C	   LGEOM has a parameter by that same name, and users can refer to LGEOM
C 	   to see what its functionality is.
C        5-MAY-1994 by C.R. Schenk (CRI)
C          Corrected logic for seed generation and replaced random number
C          generator code with a new FUNCTION RANGEN.
C          RANGEN is an optional random number generator which will
C          generate the same random number sequence regardless of the
C          host platform (when the same seed is used on both machines).
C          This is useful for performance verification of the "portable"
C          code.
C------------------------------------------------------------------------------
	SUBROUTINE MAIN44

	IMPLICIT NONE
	INTEGER	UNIT, SCRUNIT, COUNT, DEF, STATUS, SCRNUM
	INTEGER	NL,NS, NLFFT,NSFFT, LINE, SAMP
	INTEGER	SIGN, LOG2
	INTEGER SEED, BUF

        REAL*4  RAND_NUM
	REAL	Y2,R2, FILTER, S, PH, AMP, MAX
	REAL	FRACDIM, BETA, POWER
	REAL	MINVAL,MAXVAL, MAXFORMAT, SLOPE,OFFSET, SCPOW
	REAL	RBUFFER(4096)

	COMPLEX	CBUFFER(4096)
	COMPLEX	COLBUF(4096)
	CHARACTER*8 FORMAT
	CHARACTER*256 IDSNAM

	CALL IFMESSAGE('FRACGEN  version 1-JULY-1994')
	CALL XVEACTION('SA',' ')

C		GET THE INPUT PARAMETERS
	CALL XVP ('NL', NL, COUNT)
	CALL XVP ('NS', NS, COUNT)
	NLFFT = 2**( LOG2(NL-1) + 1)
	NSFFT = 2**( LOG2(NS-1) + 1)

	CALL XVP ('FRACDIM', FRACDIM, COUNT)

	CALL XVPARM ('SEED', SEED, COUNT, DEF,1)
	IF (COUNT .EQ. 0) THEN
            CALL GET_SECONDS(BUF)
	    SEED = MOD(BUF,2**24)
        ENDIF

	CALL XVP ('POWER', SCPOW, COUNT)

	CALL XVP ('FORMAT', FORMAT, COUNT)
	IF (FORMAT(1:4) .EQ. 'HALF') THEN
	    MAXFORMAT = 32767.0
	ELSE IF (FORMAT(1:4) .EQ. 'REAL') THEN
	    MAXFORMAT = 1.0
	ELSE
	    MAXFORMAT = 255.0
	ENDIF

C		CREATE AND OPEN THE SCRATCH FILE
	SCRNUM = 1
C------------------------------------------------------------------------------
c Change made, 3-12-1990 by M. O'Shaughnessy
c 	Changed filename of scratch file from 'fracgen.scr' to
c 	'v2$scratch:fracgen.scr'
c Change made, 2-AUG-1993 by G. A. Madrid Jr.
c	Substituted the value of parameter IDSNAM for the specification
c	'v2$scratch:fracgen.scr' which would only work in VMS.
C------------------------------------------------------------------------------
	CALL XVPARM('IDSNAM',IDSNAM,COUNT,DEF,0)
	CALL XVUNIT(SCRUNIT,' ',SCRNUM,STATUS,'U_NAME',IDSNAM,' ')

	CALL XVOPEN(SCRUNIT,STATUS,'OP','WRITE','U_NL',NLFFT,
     +			'U_NS',NSFFT,'O_FORMAT','REAL',
     +                  'COND','LABELS',' ')
	CALL XVCLOSE(SCRUNIT,STATUS,' ')

	CALL XVUNIT(SCRUNIT,' ',SCRNUM,STATUS,'U_NAME',IDSNAM,' ')
	CALL XVOPEN(SCRUNIT,STATUS,'OP','UPDATE','U_NL',NLFFT,
     +			'U_NS',NSFFT,'I_FORMAT','REAL','U_FORMAT','REAL',
     +			'O_FORMAT','REAL','COND','LABELS',' ')

	BETA = 2*(3.0 - FRACDIM) + 1.0
	POWER = -(1.+BETA)/4.0

C		MAKE THE POWER LAW NOISE
	DO LINE = 1, NLFFT
	    SIGN = (-1)**LINE
	    Y2 = ( FLOAT(MIN(LINE,NLFFT+2-LINE) - 1) /NLFFT )**2
	    DO SAMP = 1,NSFFT/2
		SIGN = -SIGN
		R2 = ( FLOAT(SAMP - 1) /NSFFT )**2 + Y2
		IF (R2 .NE. 0.0) THEN
		    FILTER = R2**POWER
   		    CALL RANGEN(SEED,RAND_NUM)
		    S = RAND_NUM
		    IF (RAND_NUM.LT.1.0E-10) THEN
                        S = 1.0E-10
                    ENDIF
		    AMP = FILTER*SQRT(-LOG(S))
   		    CALL RANGEN(SEED,RAND_NUM)
		    PH = 2.*3.14159*RAND_NUM
		    IF (SIGN .LT. 0)  PH = -PH
		    CBUFFER(SAMP) = AMP*CEXP((0,1)*PH)
		ENDIF
	    ENDDO
	    CALL XVWRIT (SCRUNIT, CBUFFER, STATUS, 'LINE',LINE,' ')
	ENDDO

C		TRANSFORM THE NOISE
	CALL FFTVICARR (SCRUNIT, NLFFT, NSFFT, -1, COLBUF)

C		SCALE THE FRACTIONAL NOISE
	MINVAL = +1.0E20
	MAXVAL = -1.0E20
	DO LINE = 1,NL
	    CALL XVREAD (SCRUNIT, RBUFFER, STATUS, 'LINE',LINE,' ')
	    DO SAMP = 1,NS
		MINVAL = MIN( MINVAL, RBUFFER(SAMP) )
		MAXVAL = MAX( MAXVAL, RBUFFER(SAMP) )
	    ENDDO
	ENDDO

	CALL XVUNIT (UNIT, 'OUT',1, STATUS,' ')
	CALL XVOPEN (UNIT, STATUS,
     +		'OP','WRITE',  'U_FORMAT','REAL', 'O_FORMAT',FORMAT,
     +		'U_NL',NL, 'U_NS',NS,' ')

	SLOPE = MAXFORMAT/(MAXVAL-MINVAL)
	OFFSET = -MINVAL*SLOPE
	IF (FORMAT(1:4) .NE. 'REAL')  OFFSET = OFFSET + 0.5
	DO LINE = 1,NL
	    CALL XVREAD (SCRUNIT, RBUFFER, STATUS, 'LINE',LINE,' ')
	    DO SAMP = 1,NS
		RBUFFER(SAMP) = SLOPE*RBUFFER(SAMP) + OFFSET
		RBUFFER(SAMP) = MAXFORMAT*(RBUFFER(SAMP)/MAXFORMAT)**SCPOW
	    ENDDO
	    CALL XVWRIT (UNIT, RBUFFER, STATUS,' ')
	ENDDO

	CALL XVCLOSE (UNIT, STATUS,' ')
	CALL XVCLOSE (SCRUNIT, STATUS, 'CLOS_ACT','DELETE',' ')

	RETURN
	END

	SUBROUTINE FFTVICARC (UNIT, NLFFT, NSFFT, FFTSIGN)
C
C
C	FFTVICARC IS A TWO DIMENSIONAL FAST FOURIER TRANSFORM ROUTINE.
C	    IT DOES AN IN PLACE COMPLEX TO COMPLEX TRANSFORM
C	    ON AN EXISTING VICAR IMAGE.  THE COMPLEX IMAGE MUST BE ALREADY
C	    OPENED FOR UPDATE WITH XVOPEN AND HAVE SIZE NLFFT BY NSFFT
C	    WHICH MUST BE POWERS OF TWO.  THE SIGN (+1 OR -1) OF THE
C	    TRANSFORM IS PASSED IN FFTSIGN.  THE MAXIMUM SIZE IN EITHER
C	    DIRECTION IS 32768.
C	THE TRANSFORM DOES NOT TRANSPOSE THE IMAGE AND THE ZERO-FREQUENCY
C	    PIXEL IS AT THE FIRST LINE AND SAMPLE.
C
C
	IMPLICIT NONE
	INTEGER	UNIT, NLFFT, NSFFT, FFTSIGN
	INTEGER	MAXN, LINE, STATUS, BUFPTR
	INTEGER*2 BITREV(65536)
	COMPLEX BUFFER(256*256), PHASE(65536)

	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	MAXN = MAX(NLFFT,NSFFT)
	CALL MAKEBITREV (BITREV, MAXN)
	CALL MAKEPHASE (PHASE, FFTSIGN, MAXN)

	IF (NLFFT*NSFFT .GT. 256*256) THEN

	    DO LINE = 1, NLFFT
	        CALL XVREAD (UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
	        CALL FFTC1D (BUFFER, NSFFT)
	        CALL XVWRIT (UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
	    ENDDO

	    CALL FFTC1VD (UNIT, NSFFT, NLFFT)

	ELSE

	    DO LINE = 1, NLFFT
		BUFPTR = NSFFT*(LINE-1)+1
		CALL XVREAD (UNIT, BUFFER(BUFPTR), STATUS,
     +		'LINE',LINE,' ')
		CALL FFTC1D (BUFFER(BUFPTR), NSFFT)
	    ENDDO
	    CALL FFTCV (BUFFER, NSFFT, NLFFT)
	    DO LINE = 1, NLFFT
		BUFPTR = NSFFT*(LINE-1)+1
		CALL XVWRIT (UNIT, BUFFER(BUFPTR), STATUS,
     +		'LINE', LINE,' ')
	    ENDDO

	ENDIF

	RETURN
	END

	SUBROUTINE FFTVICARR (UNIT, NLFFT, NSFFT, FFTSIGN, COLBUF)
C
C
C	FFTVICARR IS A TWO DIMENSIONAL FAST FOURIER TRANSFORM ROUTINE.
C	    IT DOES AN IN PLACE REAL TO COMPLEX CONJUGATE OR COMPLEX
C	    CONJUGATE TO REAL TRANSFORM ON AN EXISTING VICAR IMAGE.
C	    THE IMAGE MUST BE ALREADY OPENED FOR UPDATE WITH XVOPEN,
C	    WITH REAL FORMATS, AND HAVE REAL SIZE NLFFT BY NSFFT
C	    WHICH MUST BE POWERS OF TWO.
C	    THE SIGN (+1 OR -1) OF THE TRANSFORM IS PASSED IN FFTSIGN.
C	    IF FFTSIGN = +1 THEN THE TRANSFORM IS REAL TO COMPLEX CONJUGATE
C	    AND IF FFTSIGN = -1 THEN THEN TRANSFORM IS THE OTHER WAY.
C	    COLBUF IS A COMPLEX ARRAY OF LENGTH EQUAL TO THE NUMBER OF ROWS.
C	      IT CONTAINS THE 'EXTRA' COLUMN FOR THE COMPLEX CONJUGATE FORMAT.
C	    THE MAXIMUM SIZE IN EITHER DIRECTION IS 32768.
C	THE TRANSFORM DOES NOT TRANSPOSE THE IMAGE AND THE ZERO-FREQUENCY
C	    PIXEL IS AT THE FIRST LINE AND SAMPLE.
C
C
	IMPLICIT NONE
	INTEGER	UNIT, NLFFT, NSFFT, FFTSIGN
	INTEGER	MAXN, LINE, STATUS, BUFPTR
	COMPLEX COLBUF(1)
	INTEGER*2 BITREV(65536)
	COMPLEX BUFFER(256*128), PHASE(65536)

	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	MAXN = MAX(NLFFT,NSFFT)
	CALL MAKEBITREV (BITREV, MAXN)
	CALL MAKEPHASE (PHASE, FFTSIGN, MAXN)

	IF (NLFFT*NSFFT .GT. 256*256) THEN

	IF (FFTSIGN .EQ. +1) THEN
	    DO LINE = 1, NLFFT
		CALL XVREAD (UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
		CALL FFTC1D (BUFFER, NSFFT/2)
		CALL FIXREAL (BUFFER, COLBUF(LINE), NSFFT/2, +1)
		CALL XVWRIT (UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
	    ENDDO
	    CALL FFTC1D (COLBUF, NLFFT)
	    CALL FFTC1VD (UNIT, NSFFT/2, NLFFT)
	ELSE
	    CALL FFTC1VD (UNIT, NSFFT/2, NLFFT)
	    CALL FFTC1D (COLBUF, NLFFT)
	    DO LINE = 1, NLFFT
		CALL XVREAD (UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
		CALL FIXREAL (BUFFER, COLBUF(LINE), NSFFT/2, -1)
		CALL FFTC1D (BUFFER, NSFFT/2)
		CALL XVWRIT (UNIT, BUFFER, STATUS, 'LINE',LINE,' ')
	    ENDDO
	ENDIF

	ELSE

	IF (FFTSIGN .EQ. +1) THEN
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL XVREAD (UNIT, BUFFER(BUFPTR), STATUS,
     +		'LINE',LINE,' ')
		CALL FFTC1D (BUFFER(BUFPTR), NSFFT/2)
		CALL FIXREAL (BUFFER(BUFPTR), COLBUF(LINE), NSFFT/2,+1)
	    ENDDO
	    CALL FFTCV (BUFFER, NSFFT/2, NLFFT)
	    CALL FFTC1D (COLBUF, NLFFT)
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL XVWRIT (UNIT, BUFFER(BUFPTR), STATUS,
     +		'LINE',LINE,' ')
	    ENDDO
	ELSE
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL XVREAD (UNIT, BUFFER(BUFPTR), STATUS,
     +		'LINE',LINE,' ')
	    ENDDO
	    CALL FFTC1D (COLBUF, NLFFT)
	    CALL FFTCV (BUFFER, NSFFT/2, NLFFT)
	    DO LINE = 1, NLFFT
		BUFPTR = (NSFFT/2)*(LINE-1)+1
		CALL FIXREAL (BUFFER(BUFPTR), COLBUF(LINE), NSFFT/2, -1)
		CALL FFTC1D (BUFFER(BUFPTR), NSFFT/2)
		CALL XVWRIT (UNIT, BUFFER(BUFPTR), STATUS,
     +		'LINE',LINE,' ')
	    ENDDO
	ENDIF

	ENDIF

	RETURN
	END

	SUBROUTINE MAKEBITREV(BITREV,NMAX)
	IMPLICIT NONE
	INTEGER	I,IREV,J,K,L,M,LMAX,NMAX
	INTEGER*2 BITREV(1)
	INTEGER LOG2

	LMAX=LOG2(NMAX)
	I=0
	DO L=0,LMAX
	    IREV=0
	    DO J=0,2**L-1
		I=I+1
		BITREV(I)=IREV
		DO K=1,L
		    M=2**(L-K)
		    IF (IREV.LT.M) GO TO 70
		    IREV=IREV-M
		END DO
70		IREV=IREV+M
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE MAKEPHASE (PHASE, SIGN, NMAX)
	IMPLICIT NONE
	INTEGER	I,J,L,LMAX,NMAX,SIGN, LOG2
	COMPLEX	PHASE(1)

	LMAX=LOG2(NMAX)
	J=0
	DO L=0,LMAX
	    DO I=0,2**L-1
		J=J+1
		PHASE(J) = CEXP(SIGN*2*3.1415926535*(0,1)*FLOAT(I)/2**L)
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE FFTC1D (DATA, N)
	IMPLICIT NONE
	INTEGER	I,J,K,N,LN,M0,M1,JMAX,OFF,IDXPH,POWER, LOG2
	INTEGER*2 BITREV(65536)
	COMPLEX	DATA(1),TMP,PHASE(65536)
	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	LN = LOG2(N)
	DO I = 0,N-1
	    J = BITREV(I+N)
	    IF (J .GT. I) THEN
		TMP = DATA(I+1)
		DATA(I+1) = DATA(J+1)
		DATA(J+1) = TMP
	    END IF
	END DO

	M0 = 1
	M1 = 2
	JMAX = N/2
	DO J = 1,JMAX
	    TMP = DATA(M1)
	    DATA(M1) = DATA(M0) - TMP
	    DATA(M0) = DATA(M0) + TMP
	    M0 = M0 + 2
	    M1 = M1 + 2
	END DO

	DO I = 1,LN-1
	    POWER = 2**I
	    OFF = 2*POWER
	    M0 = 0
	    M1 = POWER
	    JMAX = 2**(LN-I-1)
	    DO J = 1,JMAX
		IDXPH = OFF
		DO K = 0,POWER-1
		    M0 = M0 + 1
		    M1 = M1 + 1
		    TMP = PHASE(IDXPH)*DATA(M1)
		    IDXPH = IDXPH + 1
		    DATA(M1) = DATA(M0) - TMP
		    DATA(M0) = DATA(M0) + TMP
		END DO
		M0 = M0 + POWER
		M1 = M1 + POWER
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE FIXREAL(DATA,COLBUF,N,DIR)
	IMPLICIT NONE
	INTEGER N,DIR,I,ICONJ,IDXPH
	REAL PHR(2),TMPR
	COMPLEX DATA(1),COLBUF, PHASE(65536), TMP0,TMP1, PH
	EQUIVALENCE (PHR(1),PH)
	COMMON  /PHASE/  PHASE

	IDXPH = 2*N+1
	ICONJ = N

	IF (DIR .EQ. +1) THEN
	    COLBUF = REAL(DATA(1))-AIMAG(DATA(1))
	    DATA(1) = REAL(DATA(1))+AIMAG(DATA(1))
	    DO I = 2,N/2+1
		PH = PHASE(IDXPH)
		IDXPH = IDXPH + 1
		TMPR = PHR(1)		! MULT BY i
		PHR(1) = -PHR(2)
		PHR(2) = TMPR
		TMP0 = DATA(I)+CONJG(DATA(ICONJ))
		TMP1 = PH*( DATA(I)-CONJG(DATA(ICONJ)) )
		DATA(I) = (TMP0-TMP1)/2
		DATA(ICONJ) = CONJG(TMP0+TMP1)/2
		ICONJ = ICONJ-1
	    ENDDO
	ELSE
	    DATA(1) = ( REAL(DATA(1)) + REAL(COLBUF) )
     +			+ (0,1)*( REAL(DATA(1)) - REAL(COLBUF) )
	    DO I = 2,N/2+1
		PH = PHASE(IDXPH)
		IDXPH = IDXPH + 1
		TMPR = PHR(1)		! MULT BY -i
		PHR(1) = PHR(2)
		PHR(2) = -TMPR
		TMP0 = DATA(I)+CONJG(DATA(ICONJ))
		TMP1 = PH*( DATA(I)-CONJG(DATA(ICONJ)) )
		DATA(I) = TMP0-TMP1
		DATA(ICONJ) = CONJG(TMP0+TMP1)
		ICONJ = ICONJ-1
	    ENDDO
	ENDIF

	RETURN
	END

	SUBROUTINE FFTC1VD (UNIT, NS, NL)
	IMPLICIT NONE
	INTEGER	I,J,K,C,NS,NL,LNL,ROW0,ROW1,JMAX,OFF
	INTEGER*2 BITREV(65536)
	COMPLEX	PHASE(65536)
	INTEGER	POWER,STAT, LOG2, UNIT
	COMPLEX	DATA0(32768),DATA1(32768),TMP0,TMP1,PH
	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	LNL=LOG2(NL)
	DO I=0,NL-1
	    J=BITREV(I+NL)
	    IF (J.GT.I) THEN
		CALL XVREAD(UNIT, DATA0, STAT, 'LINE',I+1,' ')
		CALL XVREAD(UNIT, DATA1, STAT, 'LINE',J+1,' ')
		CALL XVWRIT(UNIT, DATA0, STAT, 'LINE',J+1,' ')
		CALL XVWRIT(UNIT, DATA1, STAT, 'LINE',I+1,' ')
	    END IF
	END DO

	DO I=0,LNL-1
	    JMAX=2**(LNL-I-1)
	    POWER=2**I
	    OFF=2*POWER
	    DO J=0,JMAX-1
		ROW0=OFF*J
		ROW1=ROW0+POWER
		DO K=0,POWER-1
		    ROW0=ROW0+1
		    ROW1=ROW1+1
		    PH=PHASE(K+OFF)
		    CALL XVREAD(UNIT, DATA0, STAT, 'LINE',ROW0,' ')
		    CALL XVREAD(UNIT, DATA1, STAT, 'LINE',ROW1,' ')
		    DO C=1,NS
			TMP0=DATA0(C)
			TMP1=PH*DATA1(C)
			DATA0(C)=TMP0+TMP1
			DATA1(C)=TMP0-TMP1
		    END DO
		    CALL XVWRIT(UNIT, DATA0, STAT, 'LINE',ROW0,' ')
		    CALL XVWRIT(UNIT, DATA1, STAT, 'LINE',ROW1,' ')
		END DO
	    END DO
	END DO

	RETURN
	END

	SUBROUTINE FFTCV(DATA,NS,NL)
	IMPLICIT NONE
	INTEGER	I,J,K,C,NS,NL,LNL,M0,M1,JMAX,OFF, LOG2
	INTEGER POWER,IDXPH
	INTEGER*2 BITREV(65536)
	COMPLEX	DATA(1),TMP,PHASE(65536),PH
	COMMON	/BITREV/ BITREV
	COMMON  /PHASE/  PHASE

	LNL = LOG2(NL)
	DO I = 0,NL-1
	    J = BITREV(I+NL)
	    IF (J .GT. I) THEN
		M0 = NS*I
		M1 = NS*J
		DO C = 1,NS
		    M0 = M0 + 1
		    M1 = M1 + 1
		    TMP = DATA(M0)
		    DATA(M0) = DATA(M1)
		    DATA(M1) = TMP
		END DO
	    END IF
	END DO

	DO I = 0,LNL-1
	    JMAX = 2**(LNL-I-1)
	    POWER = 2**I
	    OFF = 2*POWER
	    M0 = 0
	    M1 = POWER*NS
	    DO J = 0,JMAX-1
		IDXPH = OFF
		DO K = 0,POWER-1
		    PH = PHASE(IDXPH)
		    IDXPH = IDXPH + 1
		    DO C = 1,NS
			M0 = M0 + 1
			M1 = M1 + 1
			TMP = PH*DATA(M1)
			DATA(M1) = DATA(M0) - TMP
			DATA(M0) = DATA(M0) + TMP
		    END DO
		END DO
		M0 = M0 + POWER*NS
		M1 = M1 + POWER*NS
	    END DO
	END DO

	RETURN
	END

	INTEGER FUNCTION LOG2(N)
	IMPLICIT NONE
	INTEGER	N
	LOG2 = 2
	DO WHILE (ISHFT(N,-LOG2) .GT. 0)
	    LOG2 = LOG2 + 1
	ENDDO
	LOG2 = LOG2 - 1
	RETURN
	END


submodule (Prng_Class) sm_xorshift1024star
!!# xorshift1024*
!!This module contains routines to generate random numbers using the xorshift1024* method by Vigna's extensions to
!!Marsaglia, G., 2003. Xorshift RNGs. Journal of Statistical Software 8, 1-6.
!!
!!This module is a modified version of the public domain code written by Shun Sakuraba in 2015-2016.
!!The original code can be found [here](https://bitbucket.org/shun.sakuraba/xorshiftf90).
!!The modified code in coretran is distributed under the coretran license, see the repository for that information.
!!
!!Vigna's xorshift1024* pseudorandom generator.
!!Sebastiano Vigna. 2014. An experimental exploration of Marsaglia's xorshift generators, scrambled. CoRR, abs/1402.6246.
!!xorshift1024* is a pseudorandom generator with reasonable speed and a good size state space.
!!
!!
!!## Why xorshift1024* ?
!!The seed of the xorshift1024* can be jumped by k cycles, where each cycle jumps ahead by $2^{512}$ random numbers, but quickly.
!!This ability to jump is an important aspect for using random number generators in general but especially in parallel
!!in either OpenMP or MPI paradigms.
!!The time taken to generate a 64 bit integer was 1.36 ns on an IntelR CoreTM i7-4770 CPU @3.40GHz (Haswell) as shown in Vigna (2014).
!!xorshift1024* is better for massively parallel applications that draw many realizations.
!!
!!If the size of the random number generator is too much for your application, consider using the [[m_xorshift128plus]]
!!generator which has a period of $2^{64}$ numbers. The time to generate a 64 bit integer is faster at 1.06 ns
!!
!!### Important note: This next aspect needs to be tested.
!!@todo: test this
!!Because the Fortran standard does not specify an integer model, int64 overflow has an undefined behaviour.
!!Thus, there might be warnings issued while compiling this program, or worse, it may not work.
!!A workaround uses the int(int(a, kind=16) "op" b, kind=8) trick, which works well with gfortran,
!!but commercial compilers do not accept 128-bit arithmetics (incl. Intel, Cray, and Fujitsu).

implicit none

contains

  !====================================================================!
  module procedure rngInteger_1024star!(this, val)
  !====================================================================!
  !class(prng), intent(inout) :: this
  !integer(i64), intent(out) :: val

  integer(i64) :: s0, s1, r
  ! New value to eliminate linear dependencies from lowest bit
  integer(i64), parameter :: spreader = -7046029254386353133_i64
  ! Old parameter values: 1181783497276652981_i64

  ! get state variables
  s0 = this%seed(this%ptr)
  this%ptr = iand(this%ptr + 1, 15)
  s1 = this%seed(this%ptr)

  ! xorshift
  s1 = ieor(s1, ishft(s1, 31))
  s1 = ieor(s1, ishft(s1, -11))
  s0 = ieor(s0, ishft(s1, -30))

  r = ieor(s0, s1)
  this%seed(this%ptr) = r

  val = r * spreader
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure jumpState_1024star!(this)
  !====================================================================!
  !! Jumps the current prng state by $2^{512}$ pulls from the generator without drawing $2^{512}$ numbers.
  !class(Prng), intent(inout) :: this
  integer(i64) :: jump_table(16)
  integer(i64) :: t(0:15)
  integer(i64) :: tmp
  integer :: i, j, b
  data jump_table / -8924956236279331811_i64,& !0x84242F96ECA9C41D
                    -6645523562763818923_i64,& !0xA3C65B8776F96855
                     6572057659653707831_i64,& !0x5B34A39F070B5837
                     4938671967096216094_i64,& !0x4489AFFCE4F31A1E
                     3458459993260519232_i64,& !0x2FFEEB0A48316F40
                    -2581239258607468510_i64,& !0xDC2D9891FE68C022
                     3916182429352585840_i64,& !0x3659132BB12FEA70
                    -6142490363719071048_i64,& !0xAAC17D8EFA43CAB8
                    -4266174017505289453_i64,& !0xC4CB815590989B13
                     6839126324828817723_i64,& !0x5EE975283D71C93B
                     7572038374137779520_i64,& !0x691548C86C1BD540
                     8723688107328792229_i64,& !0x7910C41D10A1E6A5
                     819591658532496040_i64,& !0x0B5FC64563B3E2A8
                     324108011427370141_i64,& !0x047F7684E9FC949D
                    -5075132425047734838_i64,& !0xB99181F2D8F685CA
                     2902007988922235075_i64/  !0x284600E3F30E38C3

  t(:) = 0

  do i = 1, 16
      do b = 0, 63
        if(btest(jump_table(i), b)) then
            do j = 0, 15
              t(j) = ieor(t(j), this%seed(iand(j + this%ptr, 15)))
            end do
        end if
        call rngInteger_1024star(this, tmp)
      end do
  end do
  do j = 0, 15
    this%seed(iand(j+this%ptr, 15)) = t(j)
  enddo

  end procedure
  !====================================================================!
end submodule


MODULE mod_exact_riemann

    USE mod_euler_flux_jacobian
    USE mod_thermodynamics

CONTAINS

    SUBROUTINE exact_riemann (wl, wr,  wCl, wCr, xdir)

        ! risolve il sistema di equazioni non lineari:

        !               P(vCl, wl)  =    P(vCr, wr)
        !             u_1(vCl, wl)  =  u_3(vCr, wr)
        !

        ! in realtà il sistema che risolviamo è:

        !             P(vCl, wl)  -    P(vCr, wr)  =  0
        !           u_1(vCl, wl)  -  u_3(vCr, wr)  =  0

        IMPLICIT NONE

        REAL(dp_kind), DIMENSION(:), INTENT(IN)  :: wl, wr ! stati destro e sinistro
        REAL(dp_kind), DIMENSION(:), INTENT(OUT) :: wCl, wCr ! 2 stati intermedi

        LOGICAL, INTENT(IN) :: xdir

        REAL(dp_kind) :: nu,  nu_vacuum,  &
            rhol, vl, ml, ul, el, cl, &
            rhor, vr, mr, ur, er, cr, &
            U2r, U2l, &
            trasv_ul, trasv_ur, &
            u1, v1, P1, Dv1, &
            u2, v2, P2, Dv2, &
            a11, a21, a12, a22, rhs1, rhs2, det

        REAL(dp_kind), PARAMETER :: rel_tol = 1.0d-10
        INTEGER, PARAMETER :: nmax = 1000

        INTEGER :: n

        ! risolviamo un pb di riemann in 1D usando u o v a seconda della direzione

        rhol = wl(1);   vl = 1/rhol
        rhor = wr(1);   vr = 1/rhor

        IF ( xdir) THEN
            ml = wl(2)
            mr = wr(2)
            trasv_ul = wl(3)*vl
            trasv_ur = wr(3)*vr
        ELSE
            ml = wl(3)
            mr = wr(3)
            trasv_ul = wl(2)*vl
            trasv_ur = wr(2)*vr
        END IF

        ul = ml * vl
        ur = mr * vr

        ! parametri limite
        ! due fan
        !    nu_2r =
        ! due shock
        !    nu_2s =

        ! modulo della velocità al quadrato

        U2l = ul**2 + trasv_ul**2
        U2r = ur**2 + trasv_ur**2

        el = wl(4) / rhol  -  U2l**2 / 2;   cl = sound_speed(el, rhol)
        er = wr(4) / rhor  -  U2r**2 / 2;   cr = sound_speed(er, rhor)

        nu_vacuum = 2 * (cl + cr) / (gamma -1)

        nu = ur - ul ! il confronto fra le velocità limite potrebbe
                     ! essere usato per scegliere il guess iniziale
                     ! lo faremo dopo.
                     ! per ora usiamo la media

        IF (nu >= nu_vacuum) THEN

            WRITE(*,*) 'formazione del vuoto'
            WRITE(*,*) 'STOP'
            STOP

        ENDIF

        ! guess iniziale media per entrambe le incognite del sistema 2x2
        v1 = (vl + vr) / 2
        v2 = (vl + vr) / 2

        DO n = 1, nmax

            ! rete di protezione per evitare di andare al di sotto
            ! del limite dell'adiabatica di RH del gas ideal politropico
            !v_asintoto = ((gamma-1)/(gamma+1)) * v_
            !maledetto gamma
            !questi controlli sono limitati al modello del PIG

            IF (v1 < ((gamma-1)/(gamma+1)) * vl) THEN

                v1 = (gamma/(gamma+1)) * vl

                WRITE(*,*) 'metodo di Newton nella subroutine'
                WRITE(*,*) 'exact_riemann genera un volume specifico v1'
                WRITE(*,*) 'inferiore al limite asintotico della adiabatica di RH'
                WRITE(*,*) 'correzione ad hoc forzata in modo ordinario'
                WRITE(*,*) 'v1 = (gamma/(gamma+1)) * vl'

            ENDIF

            CALL loci_rar_RH (1, wl, v1,  P1, u1, a11, a21, xdir)

            IF (v2 < ((gamma-1)/(gamma+1)) * vr) THEN

                v2 = (gamma/(gamma+1)) * vr

                WRITE(*,*) 'metodo di Newton nella subroutine'
                WRITE(*,*) 'exact_riemann genera un volume specifico v2'
                WRITE(*,*) 'inferiore al limite asintotico della adiabatica di RH'
                WRITE(*,*) 'correzione ad hoc forzata in modo ordinario'
                WRITE(*,*) 'v2 = (gamma/(gamma+1)) * vr'

            ENDIF

            CALL loci_rar_RH (3, wr, v2,  P2, u2, a12, a22, xdir)

            ! devo cambiare il segno di a11 e a22
            a12 = -a12;   a22 = -a22

            ! metodo di Newton in forma incrementale per sistema
            rhs1 = - (P1 - P2)
            rhs2 = - (u1 - u2)
            ! dobbiamo risolvere un sistema lineare 2x2

            det = a11 * a22  -  a12 * a21

            Dv1 = (a22*rhs1 - a12*rhs2) / det ! regola di Cramer
            Dv2 = (a11*rhs2 - a21*rhs1) / det

            v1 = v1 + Dv1
            v2 = v2 + Dv2

            IF (SQRT(Dv1**2 + Dv2**2) <=  rel_tol * SQRT(v1**2 + v2**2)) THEN

                wCl(1) = 1/v1;     wCr(1) = 1/v2

                CALL loci_rar_RH(1, wl, v1,  P1, u1, a11, a21, xdir)
                    ! non servono a11 e a21

                IF ( xdir ) THEN
                    wCl(2) = u1/v1;    wCr(2) = u1/v2  ! u2 == u1
                    wCl(3) = trasv_ul/v1;    wCR(3) =  trasv_ur/v2
                ELSE
                    wCl(2) = trasv_ul/v1;    wCR(2) =  trasv_ur/v2
                    wCl(3) = u1/v1;    wCr(3) = u1/v2  ! u2 == u1
                END IF

                wCl(4) = (specific_energy(P1, 1/v1)  +  (u1**2 + trasv_ul**2)/2) / v1 ! controllare se e(P, v) o e(P, rho)
                wCr(4) = (specific_energy(P1, 1/v2)  +  (u1**2 + trasv_ur**2)/2) / v2 ! P1 == P2

                WRITE(*,*) 'metodo di Newton converge in', n, 'iterazioni'
                WRITE(*,*)

                RETURN

            ENDIF

        END DO

        WRITE(*,*)
        WRITE(*,*) 'metodo di Newton non converge in', nmax, 'iterazioni'
        WRITE(*,*) 'STOP nella SUBROUTINE exact_riemann'
        STOP

    END SUBROUTINE exact_riemann

    SUBROUTINE loci_rar_RH (i, w_, v,  P, u, dP_dv, du_dv, xdir)

        IMPLICIT NONE

        INTEGER,                     INTENT(IN) :: i
        REAL(dp_kind), DIMENSION(:), INTENT(IN) :: w_  ! stato pivot
        REAL(dp_kind),               INTENT(IN) :: v ! var indipendente
        REAL(dp_kind),               INTENT(OUT) :: P, u, dP_dv, du_dv
        LOGICAL,                     INTENT(IN) :: xdir

        REAL(dp_kind) :: s, v_, u_, P_, DP, Dv, S_DD

        SELECT CASE (i)

            CASE(1);  s = -1

            CASE(3);  s = 1

            CASE DEFAULT

                WRITE(*,*) 'i deve essere 1 o 3 in loci_rar_RH'
                WRITE(*,*) 'STOP'
                STOP

        END SELECT

        ! definire energia di stato post discontinuità in funzione
        ! di volume specifico e pressione

        v_ = 1/w_(1)

        IF ( xdir ) THEN
            u_ = w_(2) * v_
        ELSE
            u_ = w_(3) * v_
        END IF

        P_ = Pgreco(w_)

        IF (v >= v_) THEN ! rarefazione

            P = pressure_RAR(P_, v_, v, dP_dv)

            u = u_  -  s * integral_c_v_isentropic(P_, v_, v)

            du_dv = -s * sound_speed_isentropic(P_, v_, v) / v

        ELSE ! urto

            P = pressure_RH(P_, v_, v, dP_dv)

            DP = P - P_;   Dv = v - v_

            S_DD = SQRT(-DP * Dv)

            u = u_  +  s * S_DD

            IF (S_DD /= 0) THEN
                du_dv = -s * (Dv * dP_dv  +  DP)/(2 * S_DD)
            ELSE
                du_dv = 0
            ENDIF

        END IF

    END SUBROUTINE loci_rar_RH

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !================================================================

    FUNCTION ws_sonic_state(i, w, xdir) RESULT(ws)

        ! Sonic values of the rarefaction wave
        ! similarity solution at xi = 0

        IMPLICIT NONE

        INTEGER,                     INTENT(IN)  :: i
        REAL(dp_kind), DIMENSION(:), INTENT(IN)  :: w
        LOGICAL,                     INTENT(IN)  :: xdir

        REAL(dp_kind), DIMENSION(SIZE(w)) :: ws

        REAL(KIND=8) :: s,  rho, u, trasv_u, e, P, c, lambda,  &
            rhos, us, Ets, Ps

        SELECT CASE(i)

            CASE(1);  s = -1
            CASE(4);  s = 1

            CASE DEFAULT

                WRITE (*,*) 'In FUNCTION ws_sonic_state, i'
                WRITE (*,*) 'must be either 1 or 4.  STOP.'
                STOP

        END SELECT

        rho = w(1)

        IF ( xdir ) THEN
           u = w(2)/rho
           trasv_u = w(3)/rho
        ELSE
           u = w(3)/rho
           trasv_u = w(2)/rho
        END IF

        e = w(4)/w(1) - (u**2 + trasv_u**2)/2

        P = Pgreco(w)

        c = sound_speed(e, rho)

        lambda = u  +  s * c

        rhos = rho * (1  -  s * ((gamma-1)/(gamma+1)) * lambda/c)**(2/(gamma-1))

        us = u  -  (2/(gamma+1)) * lambda

        Ps = P * (rhos/rho)**gamma

        Ets = rhos * (specific_energy(Ps, rhos)  +  (us**2 + trasv_u**2)/2)

        IF ( xdir ) THEN
            ws = [rhos, rhos*us, rhos*trasv_u, Ets]
        ELSE
            ws = [rhos, rhos*trasv_u, rhos*us, Ets]
        END IF

    END FUNCTION ws_sonic_state

!================================================================

END MODULE mod_exact_riemann


module dipole_mod
    use GF_num_exb
    use tools
    implicit none

    real(8), parameter, private :: PI = 4d0 * atan(1d0)

    private :: gather_MPImatrix

    ! declare external variables as private
    private :: lambda_min, lambda_max, z1, z2, rho,  &
               eps_2_r, eps_2_i, eps_1, GF_num
    private :: GTxx, GTyy, GTzz, GTxz, GTzx
    private :: GFxx, GFyy, GFzz, GFxz, GFzx
    private :: GRxx, GRyy, GRzz, GRxz, GRzx

contains
    ! Computes the total electric field produced by a dipole on top
    ! of a half-space medium
    subroutine halfspace_dipole_field(xEvl, k0, k1, ep1_r, ep2_r, src, pol, Et_list, total)
        real(8), intent(in) :: xEvl(:, :)      ! list of evl points = [x1, x2, ..; y1, y2, ..; z1, z2, ..] in [m], z>=0
        real(8), intent(in) :: k0              ! free-space wavenumber [1/m]
        real(8), intent(in) :: k1              ! wavenumber of upper half-space [1/m]
        real(8), intent(in) :: ep1_r           ! relative permittivity of upper half-space
        complex(8), intent(in) :: ep2_r        ! relative permittivity of lower half-space, Im(eps2)>=0
        real(8), intent(in) :: src(3)          ! dipole position [x', y', z'] in [m], z>=0
        real(8), intent(in) :: pol(3)          ! dipole orientation [dx, dy, dz] in [A m]
        complex(8), allocatable, intent(out) :: Et_list(:, :)  ! total electric field in [V/m]
        logical, intent(in), optional :: total   ! .true. to compute total field
                                                 ! .false. to compute scattered field only
        logical :: total_field = .true.
        integer :: n_points, n

        real(8) :: xEvl_nm(size(xEvl, 1), 3)
        real(8) :: src_nm(3)

        complex(8) :: GT(3, 3)       ! Green's tensor
        real(8) :: Rmat(3, 3)        ! rotation matrix
        real(8) :: delta_x, delta_y
        real(8) :: rho_delta = 1d-16  ! minimum rho, in case rho == 0

        ! initialize variables
        n_points = size(xEvl, 1)
        GT = 0d0
        Rmat = 0d0
        Rmat(3, 3) = 1d0
        if (present(total)) then
            total_field = total
        end if

        ! convert coordinates in [m] to [nm]
        xEvl_nm = xEvl * 1d9
        src_nm = src * 1d9

        ! modify external variables
        lambda_min = 2 * PI / k0 * 1d9  ! free-space wavelength in [nm]
        lambda_max = lambda_min         ! wavelength in [nm]
        z1 = src_nm(3)      ! dipole height in [nm]
        eps_1 = ep1_r
        eps_2_r = dreal(ep2_r)
        eps_2_i = dimag(ep2_r)

        allocate(Et_list(n_points, 3))
        do n = 1, n_points
            ! compute relative position
            delta_x = xEvl_nm(n, 1) - src_nm(1)
            delta_y = xEvl_nm(n, 2) - src_nm(2)

            ! modify external variables
            z2 = xEvl_nm(n, 3)
            rho = sqrt(delta_x**2 + delta_y**2)

            ! modify rotation matrix
            if (rho .ne. 0d0) then
                Rmat(1, 1) = delta_x / rho
                Rmat(1, 2) = delta_y / rho
                Rmat(2, 1) = -Rmat(1, 2)
                Rmat(2, 2) = Rmat(1, 1)
            else
                rho = rho_delta
                Rmat(1, 1) = 1d0
                Rmat(1, 2) = 0d0
                Rmat(2, 1) = 0d0
                Rmat(2, 2) = 1d0
            end if

            ! compute Green's tensor
            call GF_num()

            ! assemble Green's tensor
            if (total_field) then
                ! total Green's tensor
                GT(1, 1) = GRxx + GFxx
                GT(2, 2) = GRyy + GFyy
                GT(3, 3) = GRzz + GFzz
                GT(1, 3) = GRxz - GFxz
                GT(3, 1) = GRzx - GFzx
            else
                ! scattered Green's tensor
                GT(1, 1) = GRxx
                GT(2, 2) = GRyy
                GT(3, 3) = GRzz
                GT(1, 3) = GRxz
                GT(3, 1) = GRzx
            end if

            ! compute electric field
            Et_list(n, :) = matmul(Rmat, pol)      ! apply rotation matrix
            Et_list(n, :) = matmul(GT, Et_list(n, :))  ! apply Green's tensor
            Et_list(n, :) = matmul(transpose(Rmat), Et_list(n, :))  ! apply inverse rotation matrix
        end do

        ! adjust constants
        Et_list = Et_list * k1 / (4d0*PI)
    end subroutine

    ! Computes the total electric field produced by a dipole on top
    ! of a half-space medium. Uses MPI.
    subroutine halfspace_dipole_field_mpi(xEvl, k0, k1, ep1_r, ep2_r, src, pol, Et, total)
        real(8), intent(in) :: xEvl(:, :)      ! list of evl points = [x1, x2, ..; y1, y2, ..; z1, z2, ..] in [m], z>=0
        real(8), intent(in) :: k0              ! free-space wavenumber [1/m]
        real(8), intent(in) :: k1              ! wavenumber of upper half-space [1/m]
        real(8), intent(in) :: ep1_r           ! relative permittivity of upper half-space
        complex(8), intent(in) :: ep2_r        ! relative permittivity of lower half-space, Im(eps2)>=0
        real(8), intent(in) :: src(3)          ! dipole position [x', y', z'] in [m], z>=0
        real(8), intent(in) :: pol(3)          ! dipole orientation [dx, dy, dz] in [A m]
        complex(8), allocatable, intent(out) :: Et(:, :)  ! total electric field in [V/m]
        logical, intent(in), optional :: total   ! .true. to compute total field
                                                 ! .false. to compute scattered field only
        complex(8), allocatable :: Et_aux(:, :), Et_gather(:, :)
        logical :: total_field = .true.
        integer :: n_points, n, nlocal, start, finish
        integer :: ierr, id, N_procs

        real(8) :: xEvl_nm(size(xEvl, 1), 3)
        real(8) :: src_nm(3)

        complex(8) :: GT(3, 3)       ! Green's tensor
        real(8) :: Rmat(3, 3)        ! rotation matrix
        real(8) :: delta_x, delta_y
        real(8) :: rho_delta = 1d-16  ! minimum rho, in case rho == 0

        ! initialize variables
        n_points = size(xEvl, 1)
        GT = 0d0
        Rmat = 0d0
        Rmat(3, 3) = 1d0
        if (present(total)) then
            total_field = total
        end if

        ! convert coordinates in [m] to [nm]
        xEvl_nm = xEvl * 1d9
        src_nm = src * 1d9

        ! modify external variables
        lambda_min = 2 * PI / k0 * 1d9  ! free-space wavelength in [nm]
        lambda_max = lambda_min         ! wavelength in [nm]
        z1 = src_nm(3)                  ! dipole height in [nm]
        eps_1 = ep1_r
        eps_2_r = dreal(ep2_r)
        eps_2_i = dimag(ep2_r)

        ! divide work in multiple processes
        call divide_work(start, finish, n_points)

        allocate(Et_aux(3, finish-start+1))
        nlocal = 0
        do n = start, finish
            nlocal = nlocal + 1
            ! compute relative position
            delta_x = xEvl_nm(n, 1) - src_nm(1)
            delta_y = xEvl_nm(n, 2) - src_nm(2)

            ! modify external variables
            z2 = xEvl_nm(n, 3)
            rho = sqrt(delta_x**2 + delta_y**2)

            ! modify rotation matrix
            if (rho .ne. 0d0) then
                Rmat(1, 1) = delta_x / rho
                Rmat(1, 2) = delta_y / rho
                Rmat(2, 1) = -Rmat(1, 2)
                Rmat(2, 2) = Rmat(1, 1)
            else
                rho = rho_delta
                Rmat(1, 1) = 1d0
                Rmat(1, 2) = 0d0
                Rmat(2, 1) = 0d0
                Rmat(2, 2) = 1d0
            end if

            ! compute Green's tensor
            call GF_num()

            ! assemble Green's tensor
            if (total_field) then
                ! total Green's tensor
                GT(1, 1) = GRxx + GFxx
                GT(2, 2) = GRyy + GFyy
                GT(3, 3) = GRzz + GFzz
                GT(1, 3) = GRxz - GFxz
                GT(3, 1) = GRzx - GFzx
            else
                ! scattered Green's tensor
                GT(1, 1) = GRxx
                GT(2, 2) = GRyy
                GT(3, 3) = GRzz
                GT(1, 3) = GRxz
                GT(3, 1) = GRzx
            end if

            ! compute electric field
            Et_aux(:, nlocal) = matmul(Rmat, pol)      ! apply rotation matrix
            Et_aux(:, nlocal) = matmul(GT, Et_aux(:, nlocal))  ! apply Green's tensor
            Et_aux(:, nlocal) = matmul(transpose(Rmat), Et_aux(:, nlocal))  ! apply inverse rotation matrix
        end do

        call mpi_comm_rank(MPI_comm_world, id, ierr)
        call mpi_comm_size(MPI_comm_world, N_procs, ierr)

        ! Gather matrix in root process
        call gather_MPImatrix(3, n_points, id, N_procs, Et_aux, Et_gather)
        deallocate(Et_aux)

        if (id == 0) then
            ! Adjust constants and transpose data
            ! in root process
            allocate(Et(n_points, 3))
            Et = transpose(Et_gather) * k1 / (4d0*PI)
        end if
    end subroutine

    ! Subroutine to gather a 2D array of shape (size1, size2)
    ! into the root process using MPI.
    ! Each process stores a subarray of shape (size1, size2/N_procs)
    subroutine gather_MPImatrix(size1, size2, id, N_procs, Z_bff, Z_gather)
        integer, intent(in) :: size1, size2
        integer, intent(in) :: id                        ! MPI id of each process
        integer, intent(in) :: N_procs                   ! MPI number of processes
        complex(8), intent(in) :: Z_bff(:,:)           ! Local matrix
        complex(8), allocatable, intent(out) :: Z_gather(:,:)  ! Full matrix

        integer :: i, ierr
        integer :: data_per_process, lWork
        integer :: rcounts(N_procs)          ! list of number of elements sent from each process
        integer :: displs(N_procs)           ! list of relative displacement between blocks of data

        if (id==0) then
            allocate(Z_gather(size1, size2))
            Z_gather = 0d0

            lWork = size2 / N_procs
            data_per_process = size1 * lWork

            rcounts = data_per_process
            rcounts(N_procs) = size1 * (size2 - (N_procs-1)*lWork)
            do i= 1, N_procs
                displs(i) = (i-1) * data_per_process
            end do
        end if

        call mpi_gatherv(Z_bff, size(Z_bff), MPI_double_complex, Z_gather, rcounts, displs,  &
                         MPI_double_complex, 0, MPI_comm_world, ierr)
    end subroutine gather_MPImatrix

end module


      SUBROUTINE LMRWAK(PARA,XMOM,NMOM)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE WAKEBY DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 5. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA, BETA, GAMMA,
C                  DELTA.
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(5),XMOM(NMOM)
      DATA ZERO/0D0/,ONE/1D0/,TWO/2D0/
C
      XI=PARA(1)
      A=PARA(2)
      B=PARA(3)
      C=PARA(4)
      D=PARA(5)
C
C         TEST FOR VALID PARAMETERS
C
      IF(D.GE.ONE)GOTO 1000
      IF(B+D.LE.ZERO.AND.(B.NE.ZERO.OR.C.NE.ZERO.OR.D.NE.ZERO))GOTO 1000
      IF(A.EQ.ZERO.AND.B.NE.ZERO)GOTO 1000
      IF(C.EQ.ZERO.AND.D.NE.ZERO)GOTO 1000
      IF(C.LT.ZERO)GOTO 1000
      IF(A+C.LT.ZERO)GOTO 1000
      IF(A.EQ.ZERO.AND.C.EQ.ZERO)GOTO 1000
      IF(NMOM.GT.20)GOTO 1010
C
C         LAMBDA-1
C
      Y=A/(ONE+B)
      Z=C/(ONE-D)
      XMOM(1)=XI+Y+Z
      IF(NMOM.EQ.1)RETURN
C
C         LAMBDA-2
C
      Y=Y/(TWO+B)
      Z=Z/(TWO-D)
      ALAM2=Y+Z
      XMOM(2)=ALAM2
      IF(NMOM.EQ.2)RETURN
C
C         HIGHER MOMENTS
C
      DO 10 M=3,NMOM
      AM=M
      Y=Y*(AM-TWO-B)/(AM+B)
      Z=Z*(AM-TWO+D)/(AM-D)
      XMOM(M)=(Y+Z)/ALAM2
   10 CONTINUE
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE LMRWAK : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE LMRWAK : PARAMETER NMOM TOO LARGE')
      END


      subroutine htautaudecay(p,jm,jp,msq)
************************************************************************
*     Author: J.M. Campbell, August 2012                               *
*                                                                      *
*     matrix element squared for the process of                        *
*     Higgs decay  H --> tau^-(jm)+tau^+(jp)                                 *
*     with bottom mass included                                        *
************************************************************************
      implicit none
      include 'constants.f'
      include 'masses.f'
      integer jm,jp
      double precision p(mxpart,4),s56,msq,msqhtautau

      s56=2d0*(p(jm,4)*p(jp,4)-p(jm,1)*p(jp,1)
     &        -p(jm,2)*p(jp,2)-p(jm,3)*p(jp,3))+2d0*mtau**2

      msq=msqhtautau(s56)

      return
      end

      double precision function msqhtautau(s)
      implicit none
      double precision s
      include 'masses.f'
      include 'ewcouple.f'

      msqhtautau=gwsq*mtausq/(4d0*wmass**2)*2d0*(s-4d0*mtau**2)

      return
      end


program part2cellgrafic
  !--------------------------------------------------------------------------
  ! Ce programme calcule une cube de densite interpolee NGP
  ! des particules de matiere noire d'une simulation RAMSES.
  ! Version F90 par R. Teyssier le 01/04/01.
  !--------------------------------------------------------------------------
  implicit none
  integer::ncpu,ndim,npart,ngrid,n,i,j,k,icpu,ipos
  integer::ncpu2,npart2,ndim2,levelmin,levelmax,ilevel
  integer::nx=0,ny=0,nz=0,ix,iy,iz,ixp1,iyp1,izp1,idim,jdim,kdim,ncpu_read
  real(KIND=8)::mtot,ddx,ddy,ddz,dex,dey,dez,t
  real(KIND=8)::xmin=0,xmax=1,ymin=0,ymax=1,zmin=0,zmax=1
  integer::imin,imax,jmin,jmax,kmin,kmax,lmin
  real(KIND=8)::xxmin,xxmax,yymin,yymax,zzmin,zzmax,dx,dy,dz,deltax
  real(KIND=4),dimension(:,:,:),allocatable::toto
  real(KIND=8),dimension(:,:,:),allocatable::cube
  real(KIND=8),dimension(:,:),allocatable::x
  real(KIND=8),dimension(:)  ,allocatable::m
  character(LEN=1)::proj='z'
  character(LEN=5)::nchar,ncharcpu
  character(LEN=80)::ordering
  character(LEN=128)::nomfich,repository,outfich
  logical::ok,ok_part,star=.false.
  integer::impi,ndom,bit_length,maxdom
  integer,dimension(1:8)::idom,jdom,kdom,cpu_min,cpu_max
  real(KIND=8),dimension(1:8)::bounding_min,bounding_max
  real(KIND=8)::dkey,order_min,dmax
  real(kind=8),dimension(:),allocatable::bound_key
  logical,dimension(:),allocatable::cpu_read
  integer,dimension(:),allocatable::cpu_list

  call read_params

  !-----------------------------------------------
  ! Lecture du fichier particules au format RAMSES
  !-----------------------------------------------
  ipos=INDEX(repository,'output_')
  nchar=repository(ipos+7:ipos+13)
  nomfich=TRIM(repository)//'/part_'//TRIM(nchar)//'.out00001'
  inquire(file=nomfich, exist=ok) ! verify input file
  if ( .not. ok ) then
     print *,TRIM(nomfich)//' not found.'
     stop
  endif

  nomfich=TRIM(repository)//'/info_'//TRIM(nchar)//'.txt'
  inquire(file=nomfich, exist=ok) ! verify input file
  if ( .not. ok ) then
     print *,TRIM(nomfich)//' not found.'
     stop
  endif
  open(unit=10,file=nomfich,form='formatted',status='old')
  read(10,'("ncpu        =",I11)')ncpu
  read(10,'("ndim        =",I11)')ndim
  read(10,'("levelmin    =",I11)')levelmin
  read(10,'("levelmax    =",I11)')levelmax
  read(10,*)
  read(10,*)
  read(10,*)

  read(10,*)
  read(10,'("time        =",E23.15)')t
  read(10,*)
  read(10,*)
  read(10,*)
  read(10,*)
  read(10,*)
  read(10,*)
  read(10,*)
  read(10,*)
  read(10,*)
  read(10,*)

  read(10,'("ordering type=",A80)'),ordering
  write(*,'(" ordering type=",A20)'),TRIM(ordering)
  read(10,*)
  allocate(cpu_list(1:ncpu))
  if(TRIM(ordering).eq.'hilbert')then
     allocate(bound_key(0:ncpu))
     allocate(cpu_read(1:ncpu))
     cpu_read=.false.
     do impi=1,ncpu
        read(10,'(I8,1X,E23.15,1X,E23.15)')i,bound_key(impi-1),bound_key(impi)
     end do
  endif
  close(10)

  !-----------------------
  ! Map parameters
  !-----------------------
  if(nx==0)then
     nx=2**levelmin
  endif
  if(ny==0)then
     ny=nx
  end if
  if(nz==0)then
     nz=nx
  end if
  write(*,*)'time=',t
  write(*,*)'Working cube =',nx,ny,nz
  allocate(cube(1:nx,1:ny,1:nz))
  cube=0.0d0
  idim=1
  jdim=2
  kdim=3
  xxmin=xmin ; xxmax=xmax
  yymin=ymin ; yymax=ymax
  zzmin=zmin ; zzmax=zmax
  dx=(xxmax-xxmin)/dble(nx)
  dy=(yymax-yymin)/dble(ny)
  dz=(zzmax-zzmin)/dble(nz)

  if(TRIM(ordering).eq.'hilbert')then

     dmax=max(xmax-xmin,ymax-ymin,zmax-zmin)
     do ilevel=1,levelmax
        deltax=0.5d0**ilevel
        if(deltax.lt.dmax)exit
     end do
     lmin=ilevel
     bit_length=lmin-1
     maxdom=2**bit_length
     imin=0; imax=0; jmin=0; jmax=0; kmin=0; kmax=0
     if(bit_length>0)then
        imin=int(xmin*dble(maxdom))
        imax=imin+1
        jmin=int(ymin*dble(maxdom))
        jmax=jmin+1
        kmin=int(zmin*dble(maxdom))
        kmax=kmin+1
     endif

     dkey=(dble(2**(levelmax+1)/dble(maxdom)))**ndim
     ndom=1
     if(bit_length>0)ndom=8
     idom(1)=imin; idom(2)=imax
     idom(3)=imin; idom(4)=imax
     idom(5)=imin; idom(6)=imax
     idom(7)=imin; idom(8)=imax
     jdom(1)=jmin; jdom(2)=jmin
     jdom(3)=jmax; jdom(4)=jmax
     jdom(5)=jmin; jdom(6)=jmin
     jdom(7)=jmax; jdom(8)=jmax
     kdom(1)=kmin; kdom(2)=kmin
     kdom(3)=kmin; kdom(4)=kmin
     kdom(5)=kmax; kdom(6)=kmax
     kdom(7)=kmax; kdom(8)=kmax

     do i=1,ndom
        if(bit_length>0)then
           call hilbert3d(idom(i),jdom(i),kdom(i),order_min,bit_length,1)
        else
           order_min=0.0d0
        endif
        bounding_min(i)=(order_min)*dkey
        bounding_max(i)=(order_min+1.0D0)*dkey
     end do
     cpu_min=0; cpu_max=0
     do impi=1,ncpu
        do i=1,ndom
           if (   bound_key(impi-1).le.bounding_min(i).and.&
                & bound_key(impi  ).gt.bounding_min(i))then
              cpu_min(i)=impi
           endif
           if (   bound_key(impi-1).lt.bounding_max(i).and.&
                & bound_key(impi  ).ge.bounding_max(i))then
              cpu_max(i)=impi
           endif
        end do
     end do

     ncpu_read=0
     do i=1,ndom
        do j=cpu_min(i),cpu_max(i)
           if(.not. cpu_read(j))then
              ncpu_read=ncpu_read+1
              cpu_list(ncpu_read)=j
              cpu_read(j)=.true.
           endif
        enddo
     enddo
  else
     ncpu_read=ncpu
     do j=1,ncpu
        cpu_list(j)=j
     end do
  end  if

  npart=0
  do k=1,ncpu_read
     icpu=cpu_list(k)
     call title(icpu,ncharcpu)
     nomfich=TRIM(repository)//'/part_'//TRIM(nchar)//'.out'//TRIM(ncharcpu)
     open(unit=1,file=nomfich,status='old',form='unformatted')
     read(1)ncpu2
     read(1)ndim2
     read(1)npart2
     close(1)
     npart=npart+npart2
  end do
  write(*,*)'Found ',npart,' particles'

  !-----------------------------------------------
  ! Compute projected mass using CIC smoothing
  !----------------------------------------------
  mtot=0.0d0
  do k=1,ncpu_read
     icpu=cpu_list(k)
     call title(icpu,ncharcpu)
     nomfich=TRIM(repository)//'/part_'//TRIM(nchar)//'.out'//TRIM(ncharcpu)
     open(unit=1,file=nomfich,status='old',form='unformatted')
     write(*,*)'Processing file '//TRIM(nomfich)
     read(1)ncpu2
     read(1)ndim2
     read(1)npart2
     read(1)
     read(1)
     read(1)
     read(1)
     read(1)
     allocate(m(1:npart2))
     allocate(x(1:npart2,1:ndim2))
     do i=1,ndim
        read(1)m
        x(1:npart2,i)=m
     end do
     do i=1,ndim
        read(1)m
     end do
     read(1)m
     close(1)
     do i=1,npart2
        ok_part=(x(i,1)>=xmin.and.x(i,1)<=xmax.and. &
             &   x(i,2)>=ymin.and.x(i,2)<=ymax.and. &
             &   x(i,3)>=zmin.and.x(i,3)<=zmax)
!        if(.not. ok_part) then
!           write(*,*)x(i,1),x(i,2),x(i,3)
!        endif
        if(ok_part)then
           ddx=(x(i,idim)-xxmin)/dx
           ddy=(x(i,jdim)-yymin)/dy
           ddz=(x(i,kdim)-zzmin)/dz
           ix=floor(ddx)+1
           iy=floor(ddy)+1
           iz=floor(ddz)+1
           if(ix<1)ix=ix+nx
           if(ix>nx)ix=ix-nx
           if(iy<1)iy=iy+ny
           if(iy>ny)iy=iy-ny
           if(iz<1)iz=iz+nz
           if(iz>nz)iz=iz-nz
           cube(ix,iy,iz)=cube(ix,iy,iz)+m(i)
           mtot=mtot+m(i)
        end if
     end do
     deallocate(x,m)
  end do
  write(*,*)'Total mass=',mtot

  ! Output file
  nomfich=TRIM(outfich)
  write(*,*)'Ecriture des donnees du fichier '//TRIM(nomfich)
  open(unit=10,file=nomfich,form='unformatted')
  write(10)nx,ny,nz, real(1.0), real(0.0), real(0.0), real(0.0), &
                     real(1.0), real(1.0), real(0.0), real(0.0)
  do k=1,nz
    write(10)real(cube(1:nx,1:ny,k))
  end do
  close(10)

contains

  subroutine read_params

      implicit none

      integer       :: i,n
      integer       :: iargc
      character(len=4)   :: opt
      character(len=128) :: arg
      LOGICAL       :: bad, ok

      n = iargc()
      if (n < 4) then
         print *, 'usage: part2cellgrafic  -inp  input_dir'
         print *, '                  -out  output_file'
         print *, '                 [-xmi xmin] '
         print *, '                 [-xma xmax] '
         print *, '                 [-ymi ymin] '
         print *, '                 [-yma ymax] '
         print *, '                 [-zmi zmin] '
         print *, '                 [-zma zmax] '
         print *, '                 [-nx  nx  ] '
         print *, '                 [-ny  ny  ] '
         print *, '                 [-nz  nz  ] '
         print *, '                 [-str flag] '
         print *, 'ex: part2cellgrafic -inp output_00001 -out cube.dat'// &
              &   ' -xmi 0.1 -xma 0.7'
         stop
      end if

      do i = 1,n,2
         call getarg(i,opt)
         if (i == n) then
            print '("option ",a2," has no argument")', opt
            stop 2
         end if
         call getarg(i+1,arg)
         select case (opt)
         case ('-inp')
            repository = trim(arg)
         case ('-out')
            outfich = trim(arg)
         case ('-xmi')
            read (arg,*) xmin
         case ('-xma')
            read (arg,*) xmax
         case ('-ymi')
            read (arg,*) ymin
         case ('-yma')
            read (arg,*) ymax
         case ('-zmi')
            read (arg,*) zmin
         case ('-zma')
            read (arg,*) zmax
         case ('-nx')
            read (arg,*) nx
         case ('-ny')
            read (arg,*) ny
         case ('-nz')
            read (arg,*) nz
         case ('-str')
            read (arg,*) star
         case default
            print '("unknown option ",a2," ignored")', opt
         end select
      end do

      return

    end subroutine read_params

  end program part2cellgrafic

!=======================================================================
subroutine title(n,nchar)
!=======================================================================
  implicit none
  integer::n
  character*5::nchar

  character*1::nchar1
  character*2::nchar2
  character*3::nchar3
  character*4::nchar4
  character*5::nchar5

  if(n.ge.10000)then
     write(nchar5,'(i5)') n
     nchar = nchar5
  elseif(n.ge.1000)then
     write(nchar4,'(i4)') n
     nchar = '0'//nchar4
  elseif(n.ge.100)then
     write(nchar3,'(i3)') n
     nchar = '00'//nchar3
  elseif(n.ge.10)then
     write(nchar2,'(i2)') n
     nchar = '000'//nchar2
  else
     write(nchar1,'(i1)') n
     nchar = '0000'//nchar1
  endif

end subroutine title

!================================================================
!================================================================
!================================================================
!================================================================
subroutine hilbert3d(x,y,z,order,bit_length,npoint)
  implicit none

  integer     ,INTENT(IN)                     ::bit_length,npoint
  integer     ,INTENT(IN) ,dimension(1:npoint)::x,y,z
  real(kind=8),INTENT(OUT),dimension(1:npoint)::order

  logical,dimension(0:3*bit_length-1)::i_bit_mask
  logical,dimension(0:1*bit_length-1)::x_bit_mask,y_bit_mask,z_bit_mask
  integer,dimension(0:7,0:1,0:11)::state_diagram
  integer::i,ip,cstate,nstate,b0,b1,b2,sdigit,hdigit

  if(bit_length>bit_size(bit_length))then
     write(*,*)'Maximum bit length=',bit_size(bit_length)
     write(*,*)'stop in hilbert3d'
     stop
  endif

  state_diagram = RESHAPE( (/   1, 2, 3, 2, 4, 5, 3, 5,&
                            &   0, 1, 3, 2, 7, 6, 4, 5,&
                            &   2, 6, 0, 7, 8, 8, 0, 7,&
                            &   0, 7, 1, 6, 3, 4, 2, 5,&
                            &   0, 9,10, 9, 1, 1,11,11,&
                            &   0, 3, 7, 4, 1, 2, 6, 5,&
                            &   6, 0, 6,11, 9, 0, 9, 8,&
                            &   2, 3, 1, 0, 5, 4, 6, 7,&
                            &  11,11, 0, 7, 5, 9, 0, 7,&
                            &   4, 3, 5, 2, 7, 0, 6, 1,&
                            &   4, 4, 8, 8, 0, 6,10, 6,&
                            &   6, 5, 1, 2, 7, 4, 0, 3,&
                            &   5, 7, 5, 3, 1, 1,11,11,&
                            &   4, 7, 3, 0, 5, 6, 2, 1,&
                            &   6, 1, 6,10, 9, 4, 9,10,&
                            &   6, 7, 5, 4, 1, 0, 2, 3,&
                            &  10, 3, 1, 1,10, 3, 5, 9,&
                            &   2, 5, 3, 4, 1, 6, 0, 7,&
                            &   4, 4, 8, 8, 2, 7, 2, 3,&
                            &   2, 1, 5, 6, 3, 0, 4, 7,&
                            &   7, 2,11, 2, 7, 5, 8, 5,&
                            &   4, 5, 7, 6, 3, 2, 0, 1,&
                            &  10, 3, 2, 6,10, 3, 4, 4,&
                            &   6, 1, 7, 0, 5, 2, 4, 3 /), &
                            & (/8 ,2, 12 /) )

  do ip=1,npoint

     ! convert to binary
     do i=0,bit_length-1
        x_bit_mask(i)=btest(x(ip),i)
        y_bit_mask(i)=btest(y(ip),i)
        z_bit_mask(i)=btest(z(ip),i)
     enddo

     ! interleave bits
     do i=0,bit_length-1
        i_bit_mask(3*i+2)=x_bit_mask(i)
        i_bit_mask(3*i+1)=y_bit_mask(i)
        i_bit_mask(3*i  )=z_bit_mask(i)
     end do

     ! build Hilbert ordering using state diagram
     cstate=0
     do i=bit_length-1,0,-1
        b2=0 ; if(i_bit_mask(3*i+2))b2=1
        b1=0 ; if(i_bit_mask(3*i+1))b1=1
        b0=0 ; if(i_bit_mask(3*i  ))b0=1
        sdigit=b2*4+b1*2+b0
        nstate=state_diagram(sdigit,0,cstate)
        hdigit=state_diagram(sdigit,1,cstate)
        i_bit_mask(3*i+2)=btest(hdigit,2)
        i_bit_mask(3*i+1)=btest(hdigit,1)
        i_bit_mask(3*i  )=btest(hdigit,0)
        cstate=nstate
     enddo

     ! save Hilbert key as double precision real
     order(ip)=0.
     do i=0,3*bit_length-1
        b0=0 ; if(i_bit_mask(i))b0=1
        order(ip)=order(ip)+dble(b0)*dble(2)**i
     end do

  end do

end subroutine hilbert3d
!================================================================
!================================================================
!================================================================
!================================================================


module PlanarSWEModule

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule, only : MaxEdgeLength
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PSEDirectSumModule

implicit none

include 'mpif.h'

private
public SWEMesh, New, Delete
public AddTracers
public LogStats
public OutputToVTKFile
public SetInitialDepthOnMesh, SetInitialDivergenceOnMesh, SetInitialHOnMesh, SetInitialPotVortOnMesh
public SetInitialVelocityOnMesh, SetInitialVorticityOnMesh

type SWEMesh
	type(PolyMesh2d) :: mesh
	type(Field) :: relVort
	type(Field) :: potVort
	type(Field) :: divergence
	type(Field) :: velocity
	type(Field) :: h
	type(Field) :: depth
	type(Field), pointer :: tracers(:) => null()
	real(kreal) :: f0 = 0.0_kreal
	real(kreal) :: beta = 0.0_kreal
	real(kreal) :: g = 0.0_kreal
	type(MPISetup) :: mpiParticles
	contains
		final :: deletePrivate
end type

interface New
	module procedure newPrivate
end interface

interface Copy
	module procedure copyPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

interface LogStats
	module procedure logStatsPrivate
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'SWE'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL

interface
	real(8) function scalarFnOfSpace( x, y)
		real(8), intent(in) :: x, y
	end function
end interface

interface
	function vectorFnOfSpace( x, y)
		real(8), dimension(2) :: vectorFnOfSpace
		real(8), intent(in) :: x, y
	end function
end interface

contains
!
!----------------
! public methods
!----------------
!

subroutine newPrivate(self, meshSeed, initNest, maxNest, amrLimit, meshRadius, f0, beta, g )
	type(SWEMesh), intent(out) :: self
	integer(kint), intent(in) :: meshSeed
	integer(kint), intent(in) :: initNest
	integer(kint), intent(in) :: maxNest
	integer(kint), intent(in) :: amrLimit
	real(kreal), intent(in) :: meshRadius
	real(kreal), intent(in) :: f0, beta, g

	if ( .NOT. logInit ) call InitLogger(log, procRank)

	if ( meshSeed /= TRI_HEX_SEED .AND. meshSeed /= QUAD_RECT_SEED ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logKey), "new SWEMesh ERROR : invalid meshSeed.")
		return
	endif

	call New(self%mesh, meshSeed, initNest, maxNest, amrLimit, meshRadius )

	call New(self%relVort, 1, self%mesh%particles%N, "relVort", "1/s")
	call New(self%potVort, 1, self%mesh%particles%N, "potVort", "1/s")
	call New(self%divergence, 1, self%mesh%particles%N, "divergence", "1/s")
	call New(self%velocity, 2, self%mesh%particles%N, "velocity", "m/s")
	call New(self%h, 1, self%mesh%particles%N, "h", "m")
	call New(self%depth, 1, self%mesh%particles%N, "depth", "m")
	call New(self%mpiParticles, self%mesh%particles%N, numProcs)

	self%f0 = f0
	self%beta = beta
	self%g = g
end subroutine

subroutine SWEComputeVelocity(self, velocity, x, y, relVort, divergence, area )
	type(SWEMesh), intent(inout) :: self
	type(Field), intent(inout) :: velocity
	real(kreal), intent(in) :: x(:), y(:), relVort(:), divergence(:), area(:)
	!
	integer(kint) :: i, j, mpiErrCode
	real(kint) :: denom

	call SetFieldToZero(velocity)
	velocity%N = self%mesh%particles%N

	do i = self%mpiParticles%indexStart(procRank), self%mpiParticles%indexEnd(procRank)
		do j = 1, self%mesh%particles%N
			if ( self%mesh%particles%isActive(j) ) then
				denom = 2.0_kreal * PI * ( (x(i) - x(j))**2 + (y(i) - y(j))**2)
				velocity%xComp(i) = velocity%xComp(i) + (( y(i) - y(j) ) * relVort(j) + (x(i) - x(j)) * divergence(j)) * &
					area(j) / denom
				velocity%yComp(i) = velocity%yComp(i) + (-(x(i) - x(j) ) * relVort(j) + (y(i) - y(j)) * divergence(j)) * &
					area(j) / denom
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(velocity%xComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
				self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(velocity%yComp(self%mpiParticles%indexStart(i):self%mpiParticles%indexEnd(i)), &
				self%mpiParticles%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
end subroutine

subroutine copyPrivate(self, other)
	type(SWEMesh), intent(inout) :: self
	type(SWEMesh), intent(in) :: other
end subroutine

subroutine deletePrivate(self)
	type(SWEMesh), intent(inout) :: self
	!
	integer(kint) :: i

	call Delete(self%mpiParticles)
	call Delete(self%depth)
	call Delete(self%relVort)
	call Delete(self%potVort)
	call Delete(self%divergence)
	call Delete(self%velocity)
	call Delete(self%h)
	call Delete(self%mesh)
	if ( associated(self%tracers)) then
		do i = 1, size(self%tracers)
			call Delete(self%tracers(i))
		enddo
		deallocate(self%tracers)
	endif
end subroutine

subroutine logStatsPrivate(self, aLog)
	type(SWEMesh), intent(in) :: self
	type(Logger), intent(inout) :: aLog
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "SWE Mesh "," stats : ")
	call LogStats(self%mesh, aLog)
	call LogStats(self%h, aLog)
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "Coriolis f0 = ", self%f0)
	call LogMessage(aLog, TRACE_LOGGING_LEVEL, "Coriolis beta = ", self%beta)
	call LogStats(self%relVort, aLog)
	call LogStats(self%potVort, aLog)
	call LogStats(self%divergence, aLog)
	call LogStats(self%velocity, aLog)
	call LogStats(self%depth, aLog)
end subroutine

subroutine SetCoriolis(self, f0, beta)
	type(SWEMesh), intent(inout) :: self
	real(kreal), intent(in) :: f0, beta
	self%f0 = f0
	self%beta = beta
end subroutine

subroutine AddTracers( self, nTracers, tracerDims )
	type(SWEMesh), intent(inout) :: self
	integer(kint), intent(in) :: nTracers
	integer(kint), dimension(:), intent(in) :: tracerDims
	!
	integer(kint) :: i

	if ( size(tracerDims) /= nTracers ) then
		call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" AddTracers ERROR : ", &
			" must specify dimension of each tracer field.")
		return
	endif

	allocate(self%tracers(nTracers))
	do i = 1, nTracers
		call New(self%tracers(i), tracerDims(i), self%mesh%particles%N)
	enddo
end subroutine

subroutine OutputToVTKFile( self, filename )
	type(SWEMesh), intent(in) :: self
	character(len=*), intent(in) :: filename
	!
	integer(kint) :: i, writeStat

	open(unit=WRITE_UNIT_1, file=filename, status="REPLACE", action="WRITE", iostat=writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToVTK ERROR writing to file = ", trim(filename))
			return
		endif
		!
		!	write points and topology
		!
		call WriteVTKFileHeader(WRITE_UNIT_1)
		write(WRITE_UNIT_1, '(A,I8,A)') "POINTS ", self%mesh%particles%N, " double"
		do i = 1, self%mesh%particles%N
			write(WRITE_UNIT_1,*) self%mesh%particles%x(i), self%mesh%particles%y(i), &
									max(0.0_kreal, self%h%scalar(i) - self%depth%scalar(i))
		enddo
		call WriteFacesToVTKPolygons( self%mesh%faces, WRITE_UNIT_1)
		!
		!	write particle data
		!
		call WriteVTKPointDataSectionHeader(WRITE_UNIT_1, self%mesh%particles%N)
		call WriteVTKLagCoords(self%mesh%particles, WRITE_UNIT_1) ! always has to be first point data call
		call WriteFieldToVTKPointData(self%h, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%relVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%potVort, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%divergence, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%velocity, WRITE_UNIT_1)
		call WriteFieldToVTKPointData(self%depth, WRITE_UNIT_1)
		if ( associated(self%tracers)) then
			do i = 1, size(self%tracers)
				call WriteFieldToVTKPointData(self%tracers(i), WRITE_UNIT_1)
			enddo
		endif
		!
		!	write face data
		!
		call WriteFaceAreaToVTKCellData(self%mesh%faces, self%mesh%particles, WRITE_UNIT_1) ! always has to be first face data call
	close(WRITE_UNIT_1)
end subroutine

subroutine OutputToToMatlabMFile( self, filename )
	type(SWEMesh), intent(in) :: self
	character(len=*), intent(in) :: filename
	!
	integer(kint) :: writeStat
	open(unit=WRITE_UNIT_1, file=filename, status="REPLACE", action="WRITE", iostat=writeStat)
		if ( writeStat /= 0 ) then
			call LogMessage(log, ERROR_LOGGING_LEVEL, trim(logkey)//" OutputToVTK ERROR writing to file = ", trim(filename))
			return
		endif
	close(WRITE_UNIT_1)
end subroutine

subroutine SetInitialVorticityOnMesh(self, vorticityFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOfSpace) :: vorticityFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%relVort, vorticityFn( self%mesh%particles%x(i), self%mesh%particles%y(i) ) )
	enddo
end subroutine

subroutine SetInitialDivergenceOnMesh(self, divergenceFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOfSpace) :: divergenceFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%divergence, divergenceFn( self%mesh%particles%x(i), self%mesh%particles%y(i) ) )
	enddo
end subroutine

subroutine SetInitialHOnMesh(self, hFn )
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOfSpace) :: hFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%h, hFn( self%mesh%particles%x(i), self%mesh%particles%y(i) ))
	enddo
end subroutine

subroutine SetInitialDepthOnMesh( self, depthFn)
	type(SWEMesh), intent(inout) :: self
	procedure(scalarFnOfSpace) :: depthFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertScalarToField(self%depth, depthFn( self%mesh%particles%x(i), self%mesh%particles%y(i) ) )
	enddo
end subroutine

subroutine SetInitialVelocityOnMesh(self, velFn)
	type(SWEMesh), intent(inout) :: self
	procedure(vectorFnOfSpace) :: velFn
	!
	integer(kint) :: i

	do i = 1, self%mesh%particles%N
		call InsertVectorToField(self%velocity, velFn( self%mesh%particles%x(i), self%mesh%particles%y(i)))
	enddo
end subroutine

subroutine SetInitialPotVortOnMesh( self )
	type(SWEMesh), intent(inout) :: self
	!
	integer(kint) :: i
	real(kreal) :: pv

	do i = 1, self%mesh%particles%N
		if ( self%h%scalar(i) - self%depth%scalar(i) > 0.0_kreal ) then
			pv = (self%relVort%scalar(i) + self%f0 + self%beta*self%mesh%particles%y(i)) / self%h%scalar(i)
		else
			pv = 0.0_kreal
		endif
		call InsertScalarToField( self%potVort, pv )
	enddo
end subroutine

!
!----------------
! private methods
!----------------
!

subroutine InitLogger(aLog,rank)
! Initialize a logger for this module and processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

end module


!!# MODULE FUNCTION: COUNT_Consecutive
MODULE FUN_COUNT_Consecutive
!!## PURPOSE
!! A simple function to count the consecutive
!! elements in an array, starting from the first element,
!! optional tolerances <tol> and <reltol>, provide extra
!! functionality.

!!## USAGE
!
!    COUNT = COUNT_Consecutive( ARRAY [,tol] [,reltol] )
!
!! where the <IsApprox> function is used to compare consecutive
!! elements of the <ARRAY>.

!!## NOTES
!! The <ARRAY> may be reals or integers
!! but only reals are allowed the optional arguments
!! <tol> and <reltol>

!!## MODULAR KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp,& !!((01-A-KND_IntrinsicTypes.f90))
                             KIND_I1,KIND_I2,KIND_I4,KIND_I8

!!## MODULE PROCEDURES
USE FUN_IsApprox                                 !!((03-A-FUN_IsApprox.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## TYPE-KIND OVERLOADING
INTERFACE COUNT_Consecutive
 MODULE PROCEDURE COUNT_Consecutive_Rsp
 MODULE PROCEDURE COUNT_Consecutive_Rdp
 MODULE PROCEDURE COUNT_Consecutive_I1
 MODULE PROCEDURE COUNT_Consecutive_I2
 MODULE PROCEDURE COUNT_Consecutive_I4
 MODULE PROCEDURE COUNT_Consecutive_I8
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: COUNT_Consecutive

!!## CONTAINED PROCEDURES
CONTAINS

!!### PURE COUNTING FUNCTION: Count_Consecutive_Rsp
PURE FUNCTION COUNT_Consecutive_Rsp(array,tol,reltol) RESULT(COUNT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_COUNT_Consecutive_R.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_COUNT_Consecutive_R.f90.bdy"
!!--end--
END FUNCTION

!!### PURE COUNTING FUNCTION: Count_Consecutive_Rdp
PURE FUNCTION COUNT_Consecutive_Rdp(array,tol,reltol) RESULT(COUNT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp    !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_COUNT_Consecutive_R.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_COUNT_Consecutive_R.f90.bdy"
!!--end--
END FUNCTION

!!### PURE COUNTING FUNCTION: Count_Consecutive_I1
PURE FUNCTION COUNT_Consecutive_I1(array) RESULT(COUNT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1     !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE COUNTING FUNCTION: Count_Consecutive_I2
PURE FUNCTION COUNT_Consecutive_I2(array) RESULT(COUNT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2     !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE COUNTING FUNCTION: Count_Consecutive_I4
PURE FUNCTION COUNT_Consecutive_I4(array) RESULT(COUNT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4     !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE COUNTING FUNCTION: Count_Consecutive_I8
PURE FUNCTION COUNT_Consecutive_I8(array) RESULT(COUNT)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8     !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.hdr"
!!--begin--
INCLUDE "04-B-FUN_COUNT_Consecutive_I.f90.bdy"
!!--end--
END FUNCTION
END MODULE


! Code converted using TO_F90 by Alan Miller
! Date: 2002-03-06  Time: 08:36:31

! Converted with permission, from the F77 code in the CERN MATHLIB library.
! $Id: assndx.F,v 1.1.1.1 1996/04/01 15:02:49 mclareni Exp $

! $Log: assndx.F,v $
! Revision 1.1.1.1  1996/04/01 15:02:49  mclareni
! Mathlib gen/H (H301)
! Author: F. Bourgeois, 15 February 1994

SUBROUTINE assndx(mode, a, n, m, k, sum)
! N.B. Arguments IDA, IW & IDW have been removed.

! If MODE = 1, then it finds k(1), k(2), ..., k(n) to minimize
!        S = Sum(i=1, .., n) a(i, k(i))
! If MODE = 2,  then it finds k(1), k(2), ..., k(m) to minimize
!        S = Sum(j=1, .., m) a(k(j), j)
! given the array a(n,m).

! References:
! Munkres, J. (1957) `Algorithms for the assignment and transportation problems',
!                    J. SIAM, vol.5, 32-38.
! Silver, R. (1960) `An algorithm for the assignment problem', Comm. ACM, vol.3,
!                   605-606.   The algorithm (CACM 27) is in Algol.

IMPLICIT NONE

INTEGER, INTENT(IN)   :: mode
REAL, INTENT(IN OUT)  :: a(:,:)
INTEGER, INTENT(IN)   :: n
INTEGER, INTENT(IN)   :: m
INTEGER, INTENT(OUT)  :: k(:)
REAL, INTENT(OUT)     :: sum

LOGICAL  :: lsw
INTEGER  :: i, icbl, icl, icl0, iflag, imax, imin, ipp, irl, irs, &
            j, j1, jsv, new
REAL     :: rmin
INTEGER, ALLOCATABLE  :: iw(:,:)

IF (n < 1 .OR. m < 1) THEN
  WRITE(*, '(a, 2i8)') ' ** Error in call to ASSNDX; m, n = ', m, n
  RETURN
END IF

imax = MAX(n,m)
imin = MIN(n,m)
ALLOCATE( iw(imax,6) )
sum = 0.0
IF (n <= m) THEN
  DO  i = 1, n
    rmin = a(i,1)
    DO  j = 1, m
      rmin = MIN(rmin, a(i,j))
    END DO
    sum = sum + rmin
    a(i,1:m) = a(i,1:m) - rmin
  END DO
END IF
IF (n >= m) THEN
  DO  j = 1, m
    rmin = a(1,j)
    DO  i = 1, n
      rmin = MIN(rmin,a(i,j))
    END DO
    sum = sum + rmin
    a(1:n,j) = a(1:n,j) - rmin
  END DO
END IF

DO  i = 1, imax
  k(i) = 0
  iw(i,1) = 0
END DO

loop90:  DO  i = 1, n
  DO  j = 1, m
    IF (a(i,j)+iw(j,1) == 0) THEN
      k(i) = j
      iw(j,1) = i
      CYCLE loop90
    END IF
  END DO
END DO loop90

100 iflag = n
irl = 0
icl = 0
irs = 1

DO  i = 1, n
  iw(i,5) = 0
  IF (k(i) == 0) THEN
    irl = irl + 1
    iw(irl,6) = i
    iw(i,5) = -1
    iflag = iflag - 1
  END IF
END DO
IF (iflag == imin) THEN
  IF (mode == 2) k(1:imax) = iw(1:imax,1)
  RETURN
END IF

iw(1:m,4) = 0

140 i = iw(irs,6)
irs = irs + 1
DO  j = 1, m
  IF (a(i,j)+iw(j,4) == 0) THEN
    iw(j,4) = i
    icl = icl + 1
    iw(icl,2) = j
    NEW = iw(j,1)
    IF (NEW == 0) THEN
      j1 = j
      DO
        iw(j1,1) = iw(j1,4)
        i = iw(j1,4)
        IF (k(i) == 0) THEN
          k(i) = j1
          GO TO 100
        END IF
        jsv = j1
        j1 = k(i)
        k(i) = jsv
      END DO
    END IF
    irl = irl + 1
    iw(irl,6) = NEW
    iw(NEW,5) = i
  END IF
END DO
IF (irs <= irl) GO TO 140

lsw = .true.
icl0 = icl
icbl = 0
DO  j = 1, m
  IF (iw(j,4) == 0) THEN
    icbl = icbl + 1
    iw(icbl,3) = j
  END IF
END DO
rmin = a(iw(1,6),iw(1,3))
DO  i = 1, irl
  DO  j = 1, icbl
    rmin = MIN(rmin, a(iw(i,6), iw(j,3)))
  END DO
END DO
sum = sum + rmin * (irl+icbl-imax)

DO  i = 1, n
  IF (iw(i,5) == 0) THEN
    DO  ipp = 1, icl0
      a(i,iw(ipp,2)) = a(i,iw(ipp,2)) + rmin
    END DO
    CYCLE
  END IF
  DO  ipp = 1, icbl
    NEW = iw(ipp,3)
    a(i,NEW) = a(i,NEW) - rmin
    IF (lsw.AND.a(i,NEW)+iw(NEW,4) == 0) THEN
      iw(NEW,4) = i
      IF (iw(NEW,1) == 0) THEN
        j1 = NEW
        lsw = .false.
      ELSE
        icl = icl + 1
        iw(icl,2) = NEW
        irl = irl + 1
        iw(irl,6) = iw(NEW,1)
      END IF
    END IF
  END DO
END DO

IF (lsw) THEN
  DO  i = icl0 + 1, icl
    iw(iw(iw(i,2),1),5) = iw(i,2)
  END DO
  GO TO 140
ELSE
  DO
    iw(j1,1) = iw(j1,4)
    i = iw(j1,4)
    IF (k(i) == 0) THEN
      k(i) = j1
      GO TO 100
    END IF
    jsv = j1
    j1 = k(i)
    k(i) = jsv
  END DO
END IF

RETURN
END SUBROUTINE assndx