module interp3d
use types, only: dp
implicit none
private
public trilinear

contains

real(dp) function trilinear(x, p1, p2, values) result(r)
! Returns trilinear interpolation of a point 'x' using uniform data 'values'
! specified in a box determined by 'p1' and 'p2' points.
real(dp), intent(in) :: x(:) ! The 3D coordinates of a point to interpolate
real(dp), intent(in) :: p1(:) ! The lower left front corner is p1(3)
real(dp), intent(in) :: p2(:) ! The upper right back corner is p2(3)
real(dp), intent(in) :: values(:, :, :) ! Values on a uniform 3D grid
real(dp) :: x0(3)
integer :: ijk(3), nelem(3)
! Number of elements in each direction:
nelem = shape(values) - 1
! Transform to box [0,1] x [0,1] x [0,1] * nelem, that is, make the
! element length exactly 1 in each direction
x0 = nelem * (x - p1) / (p2 - p1)
ijk = int(x0)+1 ! indices of the nearest vertex
where (ijk > nelem) ijk = nelem
where (ijk < 1) ijk = 1
r = trilinear_unitbox(x0-ijk+1, values(ijk(1):ijk(1)+1, ijk(2):ijk(2)+1, &
        ijk(3):ijk(3)+1))
end function

real(dp) function trilinear_unitbox(xyz, V) result(Vxyz)
! Returns trilinear interpolation of a point (x, y, z) in a unit box
real(dp), intent(in) :: xyz(3)  ! The point in a unit box [0,1] x [0,1] x [0,1]
! V(i, j, k) ... value at vertex i, j, k of the box, where i,j,k = 1,2:
real(dp), intent(in) :: V(:, :, :)
real(dp) :: x, y, z
x = xyz(1)
y = xyz(2)
z = xyz(3)
Vxyz = &
    V(1, 1, 1) * (1-x)*(1-y)*(1-z) + &
    V(2, 1, 1) *   x  *(1-y)*(1-z) + &
    V(1, 2, 1) * (1-x)*  y  *(1-z) + &
    V(1, 1, 2) * (1-x)*(1-y)*  z   + &
    V(1, 2, 2) * (1-x)*  y  *  z   + &
    V(2, 1, 2) *   x  *(1-y)*  z   + &
    V(2, 2, 1) *   x  *  y  *(1-z) + &
    V(2, 2, 2) *   x  *  y  *  z
end function

end module


PROGRAM Main
! This is main program to compute potential flow by using Finite Element Method
USE READ_GRID          ! Module read grid
USE FIND_BOUND         ! Module find boundary
USE CONJ_GRAD          ! Module Conjugate Gradient Solver for symmetry positive define system
implicit none
!------------------------------------------------------------------------

! Mesh variables
integer NP,NE                              ! Number of Nodes and Elements
real*8, allocatable:: X(:),Y(:)            ! Position of Nodes
integer, allocatable::  NOD(:,:)           ! Topology of Elements

! Record boundary nodes
integer:: N_ab = 0
integer, allocatable::  ab(:)
integer:: N_bc = 0
integer, allocatable::  bc(:)
integer:: N_de = 0
integer, allocatable::  de(:)
integer:: N_ea = 0
integer, allocatable::  ea(:)

! local index variables
integer i,j,ii
integer status_msg

! Stiffness Matrix and right column vector
real*8, allocatable:: A(:,:), f(:)

real*8 A_e                    ! Area of element
real*8 b1,b2,b3,c1,c2,c3      ! interpolation coefficient
integer i_e1,i_e2,i_e3        ! index of elements' nodes

! Punishment factor for Dirichelet boundary condition
real*8,parameter:: punishment = 1D8

! Result variables
real*8, allocatable:: phi(:),u(:),p(:)

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

! Message
print*, 'Program Main exit...'
!------------------------------------------------------------------------

! Read Grid data
call ReadGrid(NP,NE,X,Y,NOD)              ! Call sbroutine to read grid
!------------------------------------------------------------------------

! Find Boundary Nodes
call FindBoundary(NP,X,Y,N_ab,N_bc,N_de,N_ea,ab,bc,de,ea)
!------------------------------------------------------------------------

! Generate Element Stifness Matrix and Assemble Total Stiffness Matrix
Allocate(A(1:NP,1:NP), STAT = status_msg)
print*, 'memory allocate state for A(:,:) is:("0" means success)  ',status_msg

do i = 1,NP
   do j = 1,NP
      A(i,j) = 0.d0         ! initializing stiffness matrix
   end do
end do

do i = 1,NE
   ! load nodes index
   i_e1 = NOD(1,i)
   i_e2 = NOD(2,i)
   i_e3 = NOD(3,i)

   ! computing element's area
   A_e = 5.d-1*( (X(i_e2)-X(i_e1))*(Y(i_e3)-Y(i_e1)) - (Y(i_e2)-Y(i_e1))*(X(i_e3)-X(i_e1)) )

   ! computing interpolation coefficient b_{i}
   b1 = 5.d-1 * 1.d0/A_e*( Y(i_e2)-Y(i_e3) )
   b2 = 5.d-1 * 1.d0/A_e*( Y(i_e3)-Y(i_e1) )
   b3 = 5.d-1 * 1.d0/A_e*( Y(i_e1)-Y(i_e2) )

   ! computing interpolation coefficient c_{i}
   c1 = 5.d-1 * 1.d0/A_e*( X(i_e3)-X(i_e2) )
   c2 = 5.d-1 * 1.d0/A_e*( X(i_e1)-X(i_e3) )
   c3 = 5.d-1 * 1.d0/A_e*( X(i_e2)-X(i_e1) )

   ! assemble total stiffness matrix
   A(i_e1,i_e1) = A(i_e1,i_e1) + b1**2 + c1**2
   A(i_e1,i_e2) = A(i_e1,i_e2) + b2*b1 + c2*c1
   A(i_e1,i_e3) = A(i_e1,i_e3) + b3*b1 + c3*c1

   A(i_e2,i_e1) = A(i_e2,i_e1) + b1*b2 + c1*c2
   A(i_e2,i_e2) = A(i_e2,i_e2) + b2**2 + c2**2
   A(i_e2,i_e3) = A(i_e2,i_e3) + b3*b2 + c3*c2

   A(i_e3,i_e1) = A(i_e3,i_e1) + b1*b3 + c1*c3
   A(i_e3,i_e2) = A(i_e3,i_e2) + b2*b3 + c2*c3
   A(i_e3,i_e3) = A(i_e3,i_e3) + b3**2 + c3**2

end do

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

! Adding Dirichelet boundary condition in Total Stiffness Matrix and creat right column vector
Allocate(f(1:NP), STAT = status_msg)
print*, 'memory allocate state for f(:) is:("0" means success)  ',status_msg

do i = 1,NP       ! Initializing f(:)
    f(i) = 0.d0
end do

do i = 1,N_ab     ! boundary ab
     ii = ab(i)   ! get node's ID in boundary
     A(ii,ii) = A(ii,ii) + punishment
     f(ii) = punishment * 0.d0
end do

do i = 1,N_bc     ! boundary bc
     ii = bc(i)   ! get node's ID in boundary
     A(ii,ii) = A(ii,ii) + punishment
     f(ii) = punishment * 0.d0
end do

do i = 1,N_de     ! boundary de
     ii = de(i)   ! get node's ID in boundary
     A(ii,ii) = A(ii,ii) + punishment
     f(ii) = punishment * 2.d0
end do

do i = 1,N_ea     ! boundary ea
     ii = ea(i)   ! get node's ID in boundary
     A(ii,ii) = A(ii,ii) + punishment
     f(ii) = punishment * Y(ii)
end do

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

! Solve Total Stiffness Matrix
Allocate(phi(1:NP), STAT = status_msg)
print*, 'memory allocate state for phi(:) is:("0" means success)  ',status_msg
Allocate(u(1:NP), STAT = status_msg)
print*, 'memory allocate state for u(:) is:("0" means success)  ',status_msg
Allocate(p(1:NP), STAT = status_msg)
print*, 'memory allocate state for p(:) is:("0" means success)  ',status_msg

call solve(A,f,phi,NP)
!------------------------------------------------------------------------

! Regroup data

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

! Output Result
call Output(NP,NE,X,Y,Phi,NOD)
!------------------------------------------------------------------------

! Free Memory
DEALLOCATE(X,Y,NOD)
DEALLOCATE(ab,bc,de,ea)
!------------------------------------------------------------------

! Message
print*, 'Program Main exit...'
print*, ''
!------------------------------------------------------------------------

! Program end
END PROGRAM Main


!> ********************************************************************
!! @brief TDMA
!! @param [in]     nx   配列長
!! @param [in,out] d    RHS vector -> 解ベクトル (in-place)
!! @param [in]     a    L_1 vector
!! @param [in]     b    D vector
!! @param [in]     c    U_1 vector
!! @param [in]     w    work vector (U_1)
!! @param [in,out] flop flop count
!!
!! Algorithm
!!
!! w_1 = c_1 / b_1
!! g_1 = d_1 / b_1
!!
!! ==> Forward elimination
!! for i=2, N do
!!  e = 1 / (b_i - a_i * w_{i-1})
!!  w_i = c_i * e                    // N-1までが意味がある
!!  g_i = (d_i - a_i * g_{i-1}) * e
!!
!!  x_n = g_n
!!
!! ==> Backward substitution
!! for i=N-1, 1 do
!!  x_i = g_i - w_i * x_{i+1}
!!
!! 上記のアルゴリズムで In-place にすると、
!! g と x を d で置き換えることができる
!!
!!  A = (a, b, c) の三重対角
!!  Ax = d を解く
!!  L = (a, e^{-1}) aが下副要素(L_1)、e^{-1}が対角要素
!!  U = (1, w) 対角要素1、wが上副要素(U_1)
!!
!!  LU分解: Lg=d, Ux=g
!<
subroutine tdma_0 (nx, d, a, b, c, w)
implicit none
integer                          ::  i, nx
real                             ::  e
real, dimension(nx)              ::  d, w, a, b, c

d(1) = d(1)/b(1);
w(1) = c(1)/b(1);

do i=2, nx
  e = 1.0 / (b(i) - a(i) * w(i-1))
  w(i) = e * c(i)
  d(i) = (d(i) - a(i) * d(i-1)) * e
end do

do i=nx-1, 1, -1
  d(i) = d(i) - w(i) * d(i+1)
end do

return
end subroutine tdma_0

!> ********************************************************************
subroutine tdma_p (nx, d, a, c, w)
implicit none
integer                          ::  i, nx
real                             ::  e
real, dimension(nx)              ::  d, w, a, c

w(1) = c(1);

do i=2, nx
  e = 1.0 / (1.0 - a(i) * w(i-1))
  w(i) = e * c(i)
  d(i) = (d(i) - a(i) * d(i-1)) * e
end do

do i=nx-1, 1, -1
  d(i) = d(i) - w(i) * d(i+1)
end do

return
end subroutine tdma_p

!> ********************************************************************
subroutine tdma_mp (nx, ms, d, a, c, w)
implicit none
integer                          ::  i, m, nx, ms
real                             ::  e
real, dimension(ms, 0:nx+1)      ::  d, w, a, c
!dir$ assume_aligned d:64, w:64, a:64, c:64

!$OMP PARALLEL DO SCHEDULE(static)
!dir$ vector always
!dir$ vector aligned
!dir$ ivdep
do m=1, ms
  w(m,1) = c(m,1)
end do

!$OMP PARALLEL DO SCHEDULE(static) private(e)
do i=2, nx
!dir$ vector always
!dir$ vector aligned
!dir$ ivdep
do m=1, ms
  e = 1.0 / (1.0 - a(m,i) * w(m,i-1))
  w(m,i) = e * c(m,i)
  d(m,i) = (d(m,i) - a(m,i) * d(m,i-1)) * e
end do
end do

!$OMP PARALLEL DO SCHEDULE(static)
do i=nx-1, 1, -1
!dir$ vector always
!dir$ vector aligned
!dir$ ivdep
do m=1, ms
  d(m,i) = d(m,i) - w(m,i) * d(m,i+1)
end do
end do

return
end subroutine tdma_mp

!> ********************************************************************
!! @brief TDMA
!! @param [in]     nx   配列長
!! @param [in]     g    ガイドセル長
!! @param [in,out] d    RHS vector -> 解ベクトル (in-place)
!! @param [in]     cf   係数
!! @param [in]     w    U_1 vector
!! @param [in,out] flop flop count
!<
subroutine tdma_1 (nx, d, cf, w, flop)
implicit none
integer                   ::  i, nx
double precision          ::  flop
real                      ::  a, b, c, e
real, dimension(nx)       ::  d, w
real, dimension(3)        ::  cf

a = cf(1)
b = cf(2)
c = cf(3)

flop = flop + dble(nx-1)*(14.0 + 2.0) + 8.0*2.0

d(1) = d(1)/b;
w(1) = c/b;

do i=2, nx
  e = 1.0 / (b - a * w(i-1))
  w(i) = e * c
  d(i) = (d(i) - a * d(i-1)) * e
end do

do i=nx-1, 1, -1
  d(i) = d(i) - w(i) * d(i+1)
end do

return
end subroutine tdma_1


! This program computes the integral of a known function with known
! ranges and compares them against analytically derived answers. If the
! program determines that the computed value is not what you expected, then
! it will print out FAILURE, otherwise it will print out SUCCESS
! Written by psilord 01/19/2008, converted from f77 into f90.

PROGRAM AREAUC
	IMPLICIT NONE

	REAL, DIMENSION(1:4) :: XL, XR, AREA, RES

	INTEGER :: I
	INTEGER :: SUCC

	! Don't increase C above 4 because it converges faster than bits of
	! precision in the real representation. You'll just end up introducing
	! error into the system and getting bad numbers out. Also, IVL MUST be even
	! for this adapted algorithm to work.

	REAL, PARAMETER :: IVL = 4

	! Assume the tests are going to succeed
	SUCC = 1

	! A simple test set
	XL(1) = 0.0
	XR(1) = 1.0
	XL(2) = -1.0
	XR(2) = 0.0
	XL(3) = -1.0
	XR(3) = 1.0
	XL(4) = -1.0
	XR(4) = 7.0

	! These are the results I should expect gotten from analytical analysis.
	RES(1) = 0.25000
	RES(2) = -0.2500
	RES(3) = 0.00000
	RES(4) = 600.00000

	! Compute the tests for the ranges specified
	DO I = 1, 4
		AREA(I) = SIMPSN(XL(I), XR(I), IVL)
		!PRINT '(A, F9.5, A, F9.5)', 'AREA UNDER CURVE IS ', AREA(I), &
      	!	 ' EXPECTED: ', RES(I)
	CALL CKPT_AND_EXIT
	END DO

	! Compare the tests to see if all is ok
	DO I = 1, 4
		IF (AREA(I) .NE. RES(I)) THEN
			SUCC = 0
		END IF
	END DO

	! Print out the results
	IF (SUCC .EQ. 1) THEN
		PRINT '(A)', 'SUCCESS'
	ELSE
		PRINT '(A)', 'FAILURE'
	END IF

CONTAINS
! ----------------------------------------------------------------------
! and now all of my function definitions.
! ----------------------------------------------------------------------

! The one dimensional function I wish to integrate: f(x) = x^3
REAL FUNCTION F(X)
	IMPLICIT NONE
	REAL, INTENT(IN) :: X

	F = X ** 3
END FUNCTION F

! Computes the area under x^3 from between A and B using Simpson's
! rule for N intervals
! Precondition: A must be less than B and N is defined
! Postcondition: returns the area under F(X) from X = A to X = B
! Adapted from Friedmann's fortran book page 641
! Input Arguments
!	A, B - the endpoints of the integration region
!	N - the number of intervals
REAL FUNCTION SIMPSN(A, B, N)
	IMPLICIT NONE

	! Argument Declarations
	REAL, INTENT(IN) :: A, B, N

	! Local Declarations
	REAL, PARAMETER :: PI = 3.14159
	REAL :: H, DELTAZ, SUMODD, SUMEVE, Z
	INTEGER :: I

	! Compute required increments
	H = (B - A) / N
	DELTAZ = 2.0 * H

	! Compute SUMODD
	! This collects all of the odd coeffs into one sum
	SUMODD = 0.0
	Z = A + H
	DO I = 2, N, 2
		SUMODD = SUMODD + F(Z)
		CALL CKPT_AND_EXIT
		Z = Z + DELTAZ
	END DO

	! Compute SUMEVE
	! This collects all of the even coeffs into one sum
	SUMEVE = 0.0
	Z = A + DELTAZ
	DO I = 2, N-2, 2
		SUMEVE = SUMEVE + F(Z)
		CALL CKPT_AND_EXIT
		Z = Z + DELTAZ
	END DO

	! Compute the integral and return
	SIMPSN = (F(A) + F(B) + 4.0 * SUMODD + 2.0 * SUMEVE) * (H / 3.0)
END FUNCTION SIMPSN

END PROGRAM AREAUC


subroutine init_phi(phi, lo, hi, ng, dx, prob_lo, prob_hi) bind(C, name="init_phi")

  implicit none

  integer          :: lo(2), hi(2), ng
  double precision :: phi(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng)
  double precision :: dx(2)
  double precision :: prob_lo(2)
  double precision :: prob_hi(2)

  integer          :: i,j
  double precision :: x,y,r2

  do j = lo(2), hi(2)
     y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
     do i = lo(1), hi(1)
        x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

        r2 = ((x-0.25d0)**2 + (y-0.25d0)**2) / 0.01d0

        phi(i,j) = 1.d0 + exp(-r2)

     end do
  end do

end subroutine init_phi


FUNCTION TSUM(xin,yin)

  !simple trapezoidal integration of tabulated function (xin,yin)
  !NB: notice the abs(dx) in the equation below.  The x-axis can
  !therefore be in reverse order

  USE sps_vars
  IMPLICIT NONE

  REAL(SP), DIMENSION(:), INTENT(in) :: xin,yin
  REAL(SP) :: tsum
  INTEGER  :: nn

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

  nn = SIZE(xin)

  tsum = SUM( ABS((xin(2:nn)-xin(1:nn-1))) * &
       (yin(2:nn)+yin(1:nn-1))/2. )

END FUNCTION TSUM


subroutine calc_residualt(phi, atp, atw, ate, ats, atn, bt, imax, jmax, dx, dy, residualt)
use kind_parameters
implicit none

integer :: it, jt, imax, jmax
real(kind=dp), intent(inout) :: residualt
real(kind=dp), dimension(imax,jmax), intent(in) :: atp, atw, ate, ats, atn, bt
real(kind=dp), dimension(imax,jmax), intent(in) :: phi
real(kind=dp), dimension(imax), intent(in) :: dx
real(kind=dp), dimension(jmax), intent(in) :: dy
real(kind=dp) :: tempsum1

tempsum1 = 0.0d0

!write(*,*) imax, jmax
!write(*,*) size(phi)

do jt = 2,jmax-1

 do it = 2,imax-1

  tempsum1 = tempsum1 + abs(atp(it,jt)*phi(it,jt) - atw(it,jt)*phi(it-1,jt) - ate(it,jt)*phi(it+1,jt) - ats(it,jt)*phi(it,jt-1) - atn(it,jt)*phi(it,jt+1) - bt(it,jt)*dx(it)*dy(jt))

  !if(bt(it,jt) /= 0.0d0) write(*,*) 'bt not zero', it, jt
 end do

end do

residualt = tempsum1

end subroutine


SUBROUTINE clawpack46_qinit(maxmx,maxmy,meqn,mbc,mx,my, &
    xlower,ylower,dx,dy,q,maux,aux)

    IMPLICIT NONE

    INTEGER maxmx, maxmy, meqn,mbc,mx,my, maux
    DOUBLE PRECISION xlower,ylower, dx,dy

    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
    DOUBLE PRECISION aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

    DOUBLE PRECISION  grav
    COMMON /common_swe/ grav

    DOUBLE PRECISION pi, pi2
    COMMON /compi/ pi, pi2

    double precision :: a,b,h0
    common /common_initheight/ a,b,h0

    DOUBLE PRECISION xc,yc,hl, hr, ur, ybar
    INTEGER i,j

!!
    hl = h0 + a
    hr = h0
    ur = 0.d0

    ybar = ylower + my*dy/2.d0

    do i = 1-mbc,mx+mbc
        xc = xlower + (i-0.5)*dx
        do j = 1-mbc,my+mbc
            yc = ylower + (j-0.5)*dy
            if (abs(xc) .lt. b) then
                q(i,j,1) = h0 + a*exp(-20*(yc-ybar)**2)
            else
                q(i,j,1) = hr
            endif
            q(i,j,2) = 0
            q(i,j,3) = 0
        end do
    end do

    return
end subroutine clawpack46_qinit


subroutine phasefield_fort_rhs(blockno, mbc,mx,my,meqn,mfields, &
                         xlower,ylower,dx,dy,dt, method,q,rhs)
    IMPLICIT NONE

    INTEGER mbc,mx,my, mfields, meqn, method
    DOUBLE PRECISION xlower,ylower,dx,dy, dt
    DOUBLE PRECISION rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

    DOUBLE PRECISION S, alpha, m_parm, xi, k, gamma
    COMMON /comm_parms/ S, alpha, m_parm, xi, k, gamma

    INTEGER i,j, blockno
    DOUBLE PRECISION lambda, u, phi, g0, g, s1, s3, beta

    lambda = -1.d0/dt
    beta = xi**2/m_parm;

    do j = 1,my
        do i = 1,mx
            u = q(i,j,1)
            phi = q(i,j,2)

            g0 = phi*(1-phi)
            g = g0**2

            s1 = 30*g/S
            s3 = g0*(phi-0.5d0)

            rhs(i,j,1) = lambda*(u + s1*phi)
            rhs(i,j,2) = lambda*beta*phi - s3
        end do
    end do

end subroutine phasefield_fort_rhs

subroutine phasefield_update_q(mbc,mx,my,meqn,mfields,rhs,q)
    IMPLICIT NONE

    INTEGER mbc,mx,my, mfields, meqn
    DOUBLE PRECISION rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

    INTEGER i,j, m

    do m = 1,2
        do j = 1-mbc,my+mbc
            do i = 1-mbc,mx+mbc
                q(i,j,m) = rhs(i,j,m)
            end do
        end do
    end do
!!100 format(2F16.8)

end subroutine phasefield_update_q


program main_program
   use iso_fortran_env
   Use combinations_module
implicit none
!
!---------------------------------------------------------------------
!Find the kth lexicographical combination
!in the set of combinations of m out of n
!---------------------------------------------------------------------
!
integer(kind=int64) :: k_comb, m, n, test, i, j, previous_step, m_comb, l
integer, allocatable, dimension(:) :: combination
logical :: finish
!
!--------------------------------------------------
!example:
!--------------------------------------------------
!
!number of combinations of 5 out of 10 = 252
!
!lets find the 100th in lexicographical order.
!
!----------------------------------------------
!The very first combination is:
!--------------------------------------------
!
![1 2 3 4 5]
!
!and, then the rest are combinations of the type:
!
!1 . . . . . . . . .
!
!But, how many of them are there?
!
!Well, there are nine elements left, and for the initial set, and four for
!the set of elements in the particular combination, so the number of
!1 x x x x combinations is:
!
!C 4 of 9 = 189
!
!So, there are 189 more such combinations, and the 199th is of the type
!2 x x x x. More precisely, the 199th is 2 3 4 5 6.
!
!199th : . 2 . . . . . . . .
!
!That is over 100, so we stick with the 1 . . . . type combinations, which are from 1 to 189, and thus contain the 100th
!combination.
!
!------------------------------------
!------------------------------------
!
!      [ 1 . . . . ]
!
!
!---------------------------------
!---------------------------------
!
!1st : 1 2 . . . . . . . .
!
!---------------------------------
!---------------------------------
!
!c 3 of 8 = 56 + 1 = 57
!
!57th: 1 . 3 . . . . . . .
!
!--------------------------------------
!--------------------------------------
!
!c 3 of 7 = 35 + 57 = 92
!
!92nd: 1 . . 4 . . . . . .
!
!-------------------------------------
!-------------------------------------
!
!c 3 of 6 = 20
!
!112th : 1 . . . 5 . . . .
!
!---------------------------------------
!-----------------------------------------
!
!           [ 1 4 . . . ]
!
!----------------------------------------------
!--------------------------------------------
!
!92nd: 1 . . 4 5 . . . . .
!
!------------------------------------------------
!------------------------------------------------
!
!c 2 of 5 = 10 + 92 = 102
!
!102th 1 . . 4 . 6 . . . .
!
!------------------------------------------
!------------------------------------------
!
!           [1 4 5 . . ]
!
!92nd: 1 . . 4 5 6 . . . .
!
!-----------------------------------------
!------------------------------------------
!
!c 1 of 4 = 4
!
!96th 1 . . 4 5 . 7 . . .
!
!--------------------------------------
!----------------------------------------
!
!c 1 of 3 = 3
!
!99th: 1 . . 4 5 . . 8 . .
!
!------------------------------------------
!------------------------------------------
!
!c 1 of 2 = 2 + 99 = 101
!
!101st: 1 . . 4 5 . . . 9
!
!           [1 4 5 8 . ]
!
!--------------------------------------------
!----------------------------------------------
!
!99th: 1 . . 4 5 . . 8 9 .
!
!c 0 of 1  = 1
!
!--------------------------------------------------
!--------------------------------------------------
!
!99 + 1 = 100
!
!100th: 1 . . 4 5 . . 8 . 10
!
!-------------------------------------------------------------------
!---------------------------------------------------------------------
!
write(*,*) 'm out of n?'
read(*,*) m
read(*,*) n
!
allocate( combination(m) )
!
write(*,*) 'k_comb?'
read(*,*) k_comb
!
!------------------------
!First combination:
!------------------------
!
do i = 1, m
   combination(i) = i
end do
!
test = 1
i = 1 ! number of elements in the combination (m-x)
j = n !number of elements in the set from which the combination is
!           selected (n-p)
finish = .false.
m_comb = 1
!
!---------------------------------
!The other combinations:
!---------------------------------
!
do while ( (i .le. m) .and. (finish .eqv. .false.) )
   write(*,*) ' TEST !!!!! '
   do while (j .ge. 0)
      m_comb = m_comb + 1
      write(*,*) 'm_comb', m_comb
      combination(i) = m_comb
      previous_step = test
      test = test + combination_x_of_p(m-i,j-i)
      write(*,*) 'test', test
      if (test == k_comb) then
         do l = i + 1, m
            combination(l) = combination(l-1) + 1
         end do
         finish = .true.
         exit
      else if (test .gt. k_comb) then
         m_comb = m_comb - 1
         combination(i) = m_comb
         test = previous_step
         m_comb = m_comb + 1
         exit
      else if (test .lt. k_comb) then
         j = j - 1
      end if
   end do
   i = i + 1
end do
!
write(*,'(I5,A14,I5,A6,I5,A1)') k_comb, 'combination of', m, 'out of', n, ':'
write(*,*) combination
!
end program main_program


MODULE BASIS

USE MPI
USE PARAM, ONLY: N, M

IMPLICIT NONE

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: GLL_POINT, GLL_W  ! GAUSS LEGENDRE LOBATTO POINTS AND WEIGHTS
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: GL_POINT, GL_W  ! GAUSS LEGENDRE POINTS AND WEIGHTS
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BARY     ! BARYCENTRIC WEIGHTS
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: DER              ! DERIVATIVE MATRIX
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: G     ! INV(MASS MATRIX) * (STIFFNESS MATRIX)
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LAGRANGE_LEFT   ! LAGRANGE POLY AT LEFT END POINT -1
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: LAGRANGE_RIGHT  ! LAGRANGE POLY AT RIGHT END POINT +1

CONTAINS

SUBROUTINE MATRIX_VECTOR_DERIVATIVE(N, D, F, DER1)
!!----------------------------------------------------------------------
!! COMPUTE THE DERIVATIVE BY MATRIX MULTIPLICATION
!! ALGORITHM 19
!!----------------------------------------------------------------------
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N    ! POLY ORDER
    INTEGER :: I, J

    DOUBLE PRECISION :: D(0:N, 0:N) ! DERVATIVE MATRIX
    DOUBLE PRECISION :: F(0:N)
    DOUBLE PRECISION :: T
    DOUBLE PRECISION :: DER1(0:N)

    !-------------------------------------------------------------------
    DO I=0, N

        T=0.0D0

        DO J=0, N
            T =T + D(I,J)*F(J)
        ENDDO
        DER1(I) = T

    ENDDO
    !-------------------------------------------------------------------

END SUBROUTINE MATRIX_VECTOR_DERIVATIVE

SUBROUTINE LEGENDRE_POLYNOMIAL_AND_DERIVATIVE(N,X,Q,DQ)
!!--------------------------------------------------------------------
!!       Algorithm 22 Kopriva - compute L_n (Q) and L_n' (DQ)
!!
!! Legendre polynomial of degree k and its derivative using the three
!!                        term recursive.
!!--------------------------------------------------------------------
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    INTEGER :: K

    DOUBLE PRECISION, INTENT(IN) :: X   ! GLL POINT
    DOUBLE PRECISION :: Q   ! LEGENDRE POLY OF DEGREE K
    DOUBLE PRECISION :: DQ  ! DERIVETIVE OF LEGENDRE POLY
    DOUBLE PRECISION :: Q_M1, Q_M2
    DOUBLE PRECISION :: DQ_M1, DQ_M2

    IF (N==0) THEN
        Q = 1.0D0
        DQ = 0.0D0
    ELSEIF (N==1) THEN
        Q = X
        DQ = 1.0D0
    ELSE
        Q_M2 = 1.0D0
        Q_M1 = X
        DQ_M2 = 0.0D0
        DQ_M1 = 1.0D0

        DO K = 2,N
            Q = DBLE(2*K-1)*X*Q_M1/DBLE(K) - DBLE(K-1)*Q_M2/DBLE(K)
            DQ = DQ_M2 + DBLE(2*K-1)*Q_M1
            Q_M2 = Q_M1
            Q_M1 = Q
            DQ_M2 = DQ_M1
            DQ_M1 = DQ
        END DO
    END IF

END SUBROUTINE LEGENDRE_POLYNOMIAL_AND_DERIVATIVE

SUBROUTINE GL(N)
!!----------------------------------------------------------------------
!! COMPUTE THE GAUSS LEGENDRE NODES AND WEIGHTS
!! ALGORITHM 23
!!----------------------------------------------------------------------
    USE PARAM, ONLY : PI

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N    ! POLYNOMIAL ORDER
    INTEGER :: J

    DOUBLE PRECISION :: DELTA
    DOUBLE PRECISION :: Q, DQ, TOL

    TOL = 4.0D0*EPSILON(1.0D0)
    Q = 0.0D0
    DQ = 0.0D0

    ALLOCATE(GL_POINT(0:N), GL_W(0:N))

    IF(N==0)THEN
        GL_POINT(0)=0.0D0
        GL_W(0)=2.0D0
    ELSEIF (N==1) THEN
        GL_POINT(0)=-DSQRT(1.0D0/3.0D0)
        GL_W(0)=1.0D0
        GL_POINT(1)= DSQRT(1.0d0/3.0d0)
        GL_W(1)=1.0D0
    ELSE
        DO J=0,((N+1)/2) -1
            !Initial guess
            GL_POINT(J)=-DCOS(PI*DBLE(2*J+1)/DBLE(2*N+2))

            !Iterative method
            DELTA=1.0D30
            DO WHILE(DABS(DELTA).GE.TOL*DABS(GL_POINT(J)))
                CALL LEGENDRE_POLYNOMIAL_AND_DERIVATIVE(N+1,GL_POINT(J),Q,DQ)   ! ALGORITHM 22
                DELTA=-Q/DQ
                GL_POINT(J)=GL_POINT(J)+DELTA
            END DO

            CALL LEGENDRE_POLYNOMIAL_AND_DERIVATIVE(N+1,GL_POINT(J),Q,DQ)
            GL_POINT(N-J)=-GL_POINT(J)
            GL_W(J)=2.0D0/((1.0d0 - GL_POINT(J)**2)*(DQ**2))
            GL_W(N-J) = GL_W(J)
        END DO
    END IF

    IF(MOD(N,2)==0)THEN
        CALL LEGENDRE_POLYNOMIAL_AND_DERIVATIVE(N+1,0.0d0,Q,DQ)
        GL_POINT(N/2)=0.0D0
        GL_W(N/2)=2.0D0/(DQ**2)
    END IF

END SUBROUTINE GL

SUBROUTINE q_And_L_Evaluation(N, X,POL,DPOL,Q,DQ)
!!--------------------------------------------------------------------
!!       Algorithm 24 Kopriva - combined algorithm to compute L_n (POL)
!!       L'_n (DPOL), Q = L_n+1 - L_n-1, and Q'
!!
!!--------------------------------------------------------------------
    IMPLICIT NONE

    INTEGER :: N
    INTEGER :: K

    DOUBLE PRECISION, INTENT(IN) :: X
    DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: VAL,DVAL   ! L_n and L'_n
    DOUBLE PRECISION :: POL,DPOL,Q,DQ

    ! ALLOCATE----------------------------------------------------------
    ALLOCATE(VAL(0:N+1), DVAL(0:N+1))
    !-------------------------------------------------------------------

    K=2
    VAL(K-2)=1.0D0
    VAL(K-1)=X
    DVAL(K-2)=0.0D0
    DVAL(K-1)=1.0D0

    DO K=2,N+1
        VAL(K) = DBLE(2*K-1)/DBLE(K)*X*VAL(K-1)-DBLE(K-1)/DBLE(K)*VAL(K-2)
        DVAL(K)= DVAL(K-2)+DBLE(2*K-1)*VAL(K-1)
    ENDDO

    POL=VAL(N)
    DPOL=DVAL(N)

    Q=VAL(N+1)-VAL(N-1)
    DQ=DVAL(N+1)-DVAL(N-1)

    ! DEALLOCATE--------------------------------------------------------
    DEALLOCATE(VAL, DVAL)
    !-------------------------------------------------------------------

END SUBROUTINE q_And_L_Evaluation

SUBROUTINE GLL(N)
!!----------------------------------------------------------------------
!!
!!       Compute Gauss Legendre Lobatto nodes and weights.
!!       Algorithm taken from algorithm 25 in Kopriva
!!----------------------------------------------------------------------
    USE PARAM, ONLY: PI
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: N ! POLY ORDER
    INTEGER :: J, ITER

    DOUBLE PRECISION :: DELTA,VAL,DVAL,Q,DQ
    DOUBLE PRECISION :: FACTOR
    DOUBLE PRECISION,PARAMETER:: TOL=1.0D-12

    ! ALLOCATE----------------------------------------------------------
    ALLOCATE(GLL_POINT(0:N))
    ALLOCATE(GLL_W(0:N))
    !-------------------------------------------------------------------

    ! GLL POINTS AND WEIGHTS--------------------------------------------
    IF(N==1)THEN
        GLL_POINT(0)=-1.0D0; GLL_W(0)=1.0D0
        GLL_POINT(1)= 1.0D0; GLL_W(1)=GLL_W(0)
    ELSE
        GLL_POINT(0)=-1.0D0; GLL_W(0)=2.0D0/(DBLE(N*(N+1)))
        GLL_POINT(N)= 1.0D0; GLL_W(N)=GLL_W(0)

        DO J=1,(N+1)/2-1

            ! TO FIND THE QUADRATURE POINTS, USE NEWTON METHOD----------
            ! Initial guess
            FACTOR=PI*(DBLE(J)+0.25D0)
            GLL_POINT(J)=-DCOS(FACTOR/DBLE(N)-3.0D0/8.0D0/DBLE(N)/FACTOR)
            !-----------------------------------------------------------

            !Iterative method
            DELTA=1.0D30
            ITER=0
            DO WHILE(DABS(DELTA).GE.TOL*DABS(GLL_POINT(J)))
                ITER=ITER+1
                CALL q_And_L_Evaluation(N,GLL_POINT(J),VAL,DVAL,Q,DQ)
                DELTA=-Q/DQ
                GLL_POINT(J)=GLL_POINT(J)+DELTA
            ENDDO

            CALL q_And_L_Evaluation(N,GLL_POINT(J),VAL,DVAL,Q,DQ)
            GLL_POINT(N-J)=-GLL_POINT(J)
            GLL_W(J)=2.0D0/(DBLE(N*(N+1))*VAL**2)
            GLL_W(N-J)=GLL_W(J)
        ENDDO
    ENDIF

    IF(MOD(N,2)==0)THEN
        CALL q_And_L_Evaluation(N,0.0D0,VAL,DVAL,Q,DQ)
        GLL_POINT(N/2)=0.0D0
        GLL_W(N/2)=2.0D0/(DBLE(N*(N+1))*VAL**2)
    ENDIF
    !-------------------------------------------------------------------

!    PRINT *, GLL_POINT

END SUBROUTINE GLL

SUBROUTINE BARW(N, X)
!!--------------------------------------------------------------------
!!       Barycentric weights
!!       Algorithm 30 in Kopriva
!!-------------------------------------------------------------------
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    INTEGER :: I,J,K

    DOUBLE PRECISION :: X(0:N)    ! SPECTRAL POINTS

    ! ALLOCATE----------------------------------------------------------
    ALLOCATE(BARY(0:N))    ! BARYCENTRIC WEIGHTS
    !-------------------------------------------------------------------

    DO I=0,N
        BARY(I)=1.0D0
    ENDDO

    DO J=1,N
        DO K=0,J-1
            BARY(K)=BARY(K)*(X(K)-X(J))
            BARY(J)=BARY(J)*(X(J)-X(K))
        ENDDO
    ENDDO

    DO J=0,N
        BARY(J)=1.0D0/BARY(J)
    ENDDO

!    PRINT *, BARY

END SUBROUTINE BARW

SUBROUTINE LAGRANGE_INTERPOLATING_POLYNOMIAL(N, POINT_X, X, BARY, LAGRANGE)
!!---------------------------------------------------------------------
!! LAGRANGE INTERPOLATING POLYNOMIAL VALUES AT POINT X
!! INPUT : GL_POINTS AND BARYCENTRIC WEIGHTS
!! ALGORITHM 34
!!----------------------------------------------------------------------

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N    ! PLOY ORDER
    INTEGER :: J

    DOUBLE PRECISION :: POINT_X ! THE AIMED POINT
    DOUBLE PRECISION :: X(0:N)  ! GL POINTS
    DOUBLE PRECISION :: BARY(0:N) ! BARYCENTRIC WEIGHTS
    DOUBLE PRECISION :: S, T
    DOUBLE PRECISION, DIMENSION(0:N) :: LAGRANGE ! LAGRANGE INTERPOLATING POLYNOMIAL VALUE AT POINT X

    LOGICAL :: X_MATCHES_NODE = .FALSE.
    LOGICAL :: FLAG = .FALSE.

    LAGRANGE=0.0D0
    S=0.0D0

    DO J=0, N
        LAGRANGE(J) = 0.0D0

        CALL ALMOSTEQUAL(FLAG, POINT_X, X(J))

        IF(FLAG) THEN
            LAGRANGE(J) = 1.0D0
            X_MATCHES_NODE = .TRUE.
        ENDIF
    ENDDO

    IF (X_MATCHES_NODE) RETURN

    DO J=0, N
        T = BARY(J) / (POINT_X - X(J))
        LAGRANGE(J) = T
        S = S+T
    ENDDO

    DO J=0, N
        LAGRANGE(J) = LAGRANGE(J)/S

    ENDDO

END SUBROUTINE LAGRANGE_INTERPOLATING_POLYNOMIAL

SUBROUTINE mth_Order_Polynomial_Derivative_Matrix(N,MTH_DER, X)
!!----------------------------------------------------------------------
!!       M-th order derivative matrix
!!       Algorithm 37-38 in Kopriva
!!--------------------------------------------------------------------
    IMPLICIT NONE

    INTEGER :: I,J,K
    INTEGER, INTENT(IN) :: MTH_DER ! M-TH ORDER POLY DERIVATIVE
    INTEGER, INTENT(IN) ::N

    DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:, :) :: AUX
    DOUBLE PRECISION :: X(0:N)  ! SPECTRAL POINTS

    ! ALLOCATE----------------------------------------------------------
    ALLOCATE(DER(0:N, 0:N))
    !-------------------------------------------------------------------

    ! FIRST DERIVATIVE APPROXIMATION MATRIX-----------------------------
    CALL BARW(N, X)    ! GET BARYCENTRIC WEIGHTS

    DER=0.0D0

    DO I=0,N
        DER(I,I)=0.0D0
        DO J=0,N
            IF(J /= I)THEN
                DER(I,J)=BARY(J)/BARY(I)/(X(I)-X(J))
                DER(I,I)=DER(I,I)-DER(I,J)
            ENDIF
        ENDDO
    ENDDO
    !-------------------------------------------------------------------

    ! IF MTH_DER == 1 STOP----------------------------------------------
    IF(MTH_DER==1) RETURN
    !-------------------------------------------------------------------

    !-------------------------------------------------------------------
    ALLOCATE(AUX(0:N, 0:N))
    !-------------------------------------------------------------------

    ! IF MTH_DER > 1 ---------------------------------------------------
    AUX=DER
    DO K=2,MTH_DER
        DO I=0,N
            DER(I,I)=0.0D0
            DO J=0,N
                IF(J /= I)THEN
                    DER(I,J)=DBLE(K)/(X(I)-X(J))*(BARY(J)/BARY(I)*AUX(I,I)-AUX(I,J))
                    DER(I,I)=DER(I,I)-DER(I,J)
                ENDIF
            ENDDO
        ENDDO
    ENDDO
    !-------------------------------------------------------------------

    ! DEALLOCATE--------------------------------------------------------
    DEALLOCATE(AUX)
    !-------------------------------------------------------------------

END SUBROUTINE mth_Order_Polynomial_Derivative_Matrix

SUBROUTINE CG_DERIVATIVE_MATRIX(N)
!!----------------------------------------------------------------------
!!  MATRIX FOR LEGENDRE GALERKIN APPROXIMATION
!!  G = INV(MASS MATRIX) * (STIFFNESS MATRIX)
!!  ALGORITHM 57
!!  NEED FIRST DERIVATIVE MATRIX
!!----------------------------------------------------------------------

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    INTEGER :: I, J, K

    DOUBLE PRECISION :: S

    ! COMPUTE G---------------------------------------------------------
    ALLOCATE(G(0:N, 0:N))

    DO J=0, N
        DO I=0, N
            S=0.0D0

            DO K=0,N
                S = S + DER(K, I) * DER(K, J) * GLL_W(K)
            ENDDO
            G(J,I) = S
        ENDDO

    ENDDO
    !-------------------------------------------------------------------

END SUBROUTINE CG_DERIVATIVE_MATRIX

SUBROUTINE ALMOSTEQUAL(FLAG,A,B)
!!----------------------------------------------------------------------
!! TESTING EQUALITY OF TWO FLOATING POINT NUMBER
!! ALGORITHM 139
!!----------------------------------------------------------------------
    IMPLICIT NONE

    LOGICAL FLAG
    DOUBLE PRECISION A,B

    IF ((A.EQ.0.0d0).OR.(B.EQ.0.0d0)) THEN
        IF (DABS(A-B).LE.2.0d0*EPSILON(A)) THEN
            FLAG = .TRUE.
        ELSE
            FLAG = .FALSE.
        ENDIF
    ELSE
        IF ((DABS(A-B).LE.EPSILON(A)*DABS(A)).AND.(DABS(A-B).LE.EPSILON(A)*DABS(B))) THEN
            FLAG = .TRUE.
        ELSE
            FLAG = .FALSE.
        ENDIF
    ENDIF

END SUBROUTINE ALMOSTEQUAL

END MODULE BASIS


! 7.2.2 Trapezoidal rule integral with I/O.
!
! $ mpifort -g -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace trapezoidal_all.f90
! $ mpirun -np 4 --oversubscribe ./a.out
program trapezoidal_all
    use mpi_f08
    implicit none
    integer :: my_rank, n_ranks
    type(MPI_Comm) :: comm = MPI_COMM_WORLD
    real :: a, b, a_r, b_r, integral, total, step
    integer :: m, m_r

    call MPI_Init()
    call MPI_Comm_size(comm, n_ranks)
    call MPI_Comm_rank(comm, my_rank)

    if (my_rank == 0) then
        print '(a)', "Enter the interval [a, b] and the number of steps m (1.0e-3, 1.0, 1024):"
        read *, a, b, m
    end if
    call MPI_Bcast(a, 1, MPI_REAL, 0, comm)
    call MPI_Bcast(b, 1, MPI_REAL, 0, comm)
    call MPI_Bcast(m, 1, MPI_INTEGER, 0, comm)

    step = (b - a) / m
    m_r  = m / n_ranks

    a_r = a   + my_rank * m_r * step
    b_r = a_r +           m_r * step
    integral = trap_integral(a_r, b_r, m_r)

    call MPI_Reduce(integral, total, 1, MPI_REAL, MPI_SUM, 0, comm)

    if (my_rank == 0) then
        print '(a, i0, 3(a, es12.6))', &
            "With ", m, " trapezoids the integral from ", a, " to ", b, " is ", total
    end if

    call MPI_Finalize()
contains
    !---------------------------------------------------------------------------
    function func(x)
        implicit none
        real :: func
        real, intent(in) :: x

        func = sin(1.0 / x) ! strongly oscillating, needs many intervals
        return
    end function func
    !---------------------------------------------------------------------------
    function trap_integral(x_s, x_e, steps)
        implicit none
        real                :: trap_integral
        real,    intent(in) :: x_s, x_e
        integer, intent(in) :: steps
        integer :: i
        real    :: x, dx

        dx = (x_e - x_s) / steps
        trap_integral = (func(x_s) + func(x_e)) / 2.0
        x = x_s
        do i = 2, steps
            x = x + dx
            trap_integral = trap_integral + func(x)
        end do
        trap_integral = trap_integral * step
        return
    end function trap_integral
end program trapezoidal_all


submodule(stdlib_math) stdlib_math_arange

contains

    !> `arange` creates a vector of the `real(dp)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_r_dp(start, end, step) result(result)

        real(dp), intent(in) :: start
        real(dp), intent(in), optional :: end, step
        real(dp), allocatable :: result(:)

        real(dp) :: start_, end_, step_
        integer :: i

        start_ = merge(start, 1.0_dp, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1.0_dp)
        step_  = sign(merge(step_, 1.0_dp, step_ /= 0.0_dp), end_ - start_)

        allocate(result(floor((end_ - start_)/step_) + 1))

        result = [(start_ + (i - 1)*step_, i=1, size(result), 1)]

    end function arange_r_dp

    !> `arange` creates a vector of the `integer(int32)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_i_int32(start, end, step) result(result)

        integer(int32), intent(in) :: start
        integer(int32), intent(in), optional :: end, step
        integer(int32), allocatable :: result(:)

        integer(int32) :: start_, end_, step_
        integer(int32) :: i

        start_ = merge(start, 1_int32, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1_int32)
        step_  = sign(merge(step_, 1_int32, step_ /= 0_int32), end_ - start_)

        allocate(result((end_ - start_)/step_ + 1))

        result = [(i, i=start_, end_, step_)]

    end function arange_i_int32

end submodule stdlib_math_arange


! enum_space.f90 --
!     Module with subroutines to enumerate grid points in space
!
!     Motivation:
!     When solving Diophantine equations with brute force (so simply try
!     all combinations of integer values and see whether that gives a
!     solution), one would like to search a limited region of the solution
!     space and stop after, say, 100 solutions. For instance:
!
!     x**2 + y**2 = z**3 + 3*z**2
!
!     You never know in which region these solutions lie, so it may that
!     you need to examine a very large range for all variables involved:
!
!     do z = 1,1000
!         do y = 1,1000
!             do x = 1,1000
!                 ... is (x,y,z) a solution? Print it
!             enddo
!         enddo
!     enddo
!
!     The drawback is that you examine the cube line by line and if
!     the solutions have coordinates of the same order of magnitude,
!     So examining solutions with very different sizes (x=1000, y= 10, z=1)
!     may waste a lot of time.
!     The procedures in this module use a simple enumeration technique that
!     makes it possible to enumerate the grid points around the origin
!     in ever wider shells (square around the origin or an octaeder in 3D
!     space):
!
!     |
!     9
!     |
!     5   8   .
!     | .   .   .
!     2   4   7   .
!     | .   .   .   .
!     0---1---3---6--10-
!
!     This works for all dimensions - just repeatedly split up the
!     coordinates (see the implementation of enum_octant), but it
!     is non-trivial to expand this to an arbitrary dimension.
!
!     To cover both positive and negative integers, the module uses an
!     alternating scheme: 0, 1, -1, 2, -2, 3, -3, ...
!
!     TODO: enum_ndspace? Non-trivial as said
!
module enumerate_space
    implicit none

    integer, parameter :: start_enumeration = 0

contains

! enum_1dspace --
!     Enumerate the grid points on a line
!
! Arguments:
!     index         The index of the grid point (updated to give the next
!                   index, unless you specify update = .false.)
!     x             The x-coordinate of the grid point (output)
!     update        (Optional) whether to update the index (default) or not
!
! Result:
!     The x-coordinate of the grid point with the given index
!
! Note:
!     Initialise the index to "start_enumeration"
!
subroutine enum_1dspace( index, x, update )
    integer, intent(inout)        :: index
    integer, intent(out)          :: x
    logical, intent(in), optional :: update

    logical                       :: do_update

    do_update = .true.
    if ( present(update) ) then
        do_update = update
    endif

    x = (index + 1) / 2
    if ( mod(index,2) == 0 ) then
        x = -x
    endif

    if ( do_update ) then
        index = index + 1
    endif
end subroutine enum_1dspace

! enum_2dspace --
!     Enumerate the grid points on a plane
!
! Arguments:
!     index         The index of the grid point (updated to give the next
!                   index, unless you specify update = .false.)
!     x             The x-coordinate of the grid point (output)
!     y             The y-coordinate of the grid point (output)
!     update        (Optional) whether to update the index (default) or not
!
! Result:
!     The x- and y-coordinates of the grid point with the given index
!
! Note:
!     Initialise the index to "start_enumeration"
!
subroutine enum_2dspace( index, x, y, update )
    integer, intent(inout)        :: index
    integer, intent(out)          :: x
    integer, intent(out)          :: y
    logical, intent(in), optional :: update

    logical                       :: do_update
    integer                       :: xx, yy

    do_update = .true.
    if ( present(update) ) then
        do_update = update
    endif

    call enum_quadrant( index, xx, yy, do_update )
    call enum_1dspace( xx, x )
    call enum_1dspace( yy, y )

end subroutine enum_2dspace

! enum_3dspace --
!     Enumerate the grid points in 3D space
!
! Arguments:
!     index         The index of the grid point (updated to give the next
!                   index, unless you specify update = .false.)
!     x             The x-coordinate of the grid point (output)
!     y             The y-coordinate of the grid point (output)
!     z             The z-coordinate of the grid point (output)
!     update        (Optional) whether to update the index (default) or not
!
! Result:
!     The x- and y-coordinates of the grid point with the given index
!
! Note:
!     Initialise the index to "start_enumeration"
!
subroutine enum_3dspace( index, x, y, z, update )
    integer, intent(inout)        :: index
    integer, intent(out)          :: x
    integer, intent(out)          :: y
    integer, intent(out)          :: z
    logical, intent(in), optional :: update

    logical                       :: do_update
    integer                       :: xx, yy, zz

    do_update = .true.
    if ( present(update) ) then
        do_update = update
    endif

    call enum_octant( index, xx, yy, zz, do_update )
    call enum_1dspace( xx, x )
    call enum_1dspace( yy, y )
    call enum_1dspace( zz, z )

end subroutine enum_3dspace

! enum_quadrant --
!     Enumerate the grid points in the first 2D quadrant
!
! Arguments:
!     index         The index of the grid point (updated to give the next
!                   index, unless you specify update = .false.)
!     x             The x-coordinate of the grid point (output)
!     y             The y-coordinate of the grid point (output)
!     update        (Optional) whether to update the index (default) or not
!
! Result:
!     The x- and y-coordinates of the grid point with the given index
!
! Note:
!     Initialise the index to "start_enumeration"
!
subroutine enum_quadrant( index, x, y, update )
    integer, intent(inout)        :: index
    integer, intent(out)          :: x
    integer, intent(out)          :: y
    logical, intent(in), optional :: update

    integer, parameter            :: dp = kind(1.0d0)
    real(kind=dp)                 :: dindex
    real(kind=dp)                 :: dn
    integer                       :: n
    logical                       :: do_update

    do_update = .true.
    if ( present(update) ) then
        do_update = update
    endif

    !
    ! Use double-precision reals to avoid rounding and overflow problems
    ! And take care of very large indices
    !
    dindex = index

    dn     = -0.5_dp + sqrt( 200.0 * dindex + 25.0_dp + 1.0_dp ) / 10.0_dp
    n      = dn

    if ( mod(n,2) == 0 ) then
        y = index - (n / 2) * (n + 1)
    else
        y = index - n * ((n + 1) / 2)
    endif
    x  = n - y

    if ( do_update ) then
        index = index + 1
    endif
end subroutine enum_quadrant

! enum_octant --
!     Enumerate the grid points in the first 3D octant
!
! Arguments:
!     index         The index of the grid point (updated to give the next
!                   index, unless you specify update = .false.)
!     x             The x-coordinate of the grid point (output)
!     y             The y-coordinate of the grid point (output)
!     z             The y-coordinate of the grid point (output)
!     update        (Optional) whether to update the index (default) or not
!
! Result:
!     The x-, y and z-coordinates of the grid point with the given index
!
! Note:
!     Initialise the index to "start_enumeration"
!
subroutine enum_octant( index, x, y, z, update )
    integer, intent(inout)        :: index
    integer, intent(out)          :: x
    integer, intent(out)          :: y
    integer, intent(out)          :: z
    logical, intent(in), optional :: update

    integer, parameter            :: dp = kind(1.0d0)
    real(kind=dp)                 :: dindex
    real(kind=dp)                 :: dn
    integer                       :: n
    integer                       :: nindex, prev_index
    logical                       :: do_update

    do_update = .true.
    if ( present(update) ) then
        do_update = update
    endif

    !
    ! We can not use the same approach as for 2D, as it difficult to solve
    ! the third-degree equation that would be involved. Use the brute force
    ! approach instead.
    !
    ! For each plane we have n(n+1)/2 points, so count how many such planes
    ! are completely filled. Some manipulation of the numbers involved is
    ! required to make sure all points are covered.
    !
    nindex = index + 1
    n      = 1

    do while( nindex > 0 )
        prev_index = nindex
        if ( mod(n,2) == 0 ) then
            nindex = nindex - (n / 2) * (n + 1)
        else
            nindex = nindex - n * ((n + 1) / 2)
        endif

        n = n + 1
    enddo

    nindex = prev_index - 1
    n      = n - 2
    call enum_quadrant( nindex, x, y )
    z = n - x - y

    if ( do_update ) then
        index = index + 1
    endif
end subroutine enum_octant
end module enumerate_space


include "EulerCommon.f90"
program euler_146
   use EulerCommon
   integer(int64) :: n, ct=1242490, num=3

   ! (1) the numbers must be even since we're adding 1,3,7,9,13,27 to the square
   ! (2) the numbers also need to be multiples of 5 (n^2=1 mod 5, etc), so we go by 10's
   ! (3) we start at 1,000,000 since we know the solution to that point
   do n=10**6,150*10**6,10
      if (test_prime_adds(n)) then
         ct = ct + n
         num = num + 1
         print *,n
      end if
   end do !- n
   print '("There are ",i0," such primes, summing to ",i0)',num,ct

contains
   logical function test_prime_adds(n) result(bool)
      integer(int64), intent(in) :: n
      integer(int64) :: p, k

      bool = .false.
      p = n*n + 1
      if (.not. is_prime(p)) return

      k = p
      p = p + 2 ! n*n + 3
      if (next_prime(k) /= p) return

      k = p
      p = p + 4 ! n*n + 7
      if (next_prime(k) /= p) return

      k = p
      p = p + 2 ! n*n + 9
      if (next_prime(k) /= p) return

      k = p
      p = p + 4 ! n*n + 13
      if (next_prime(k) /= p) return

      k = p
      p = p + 14 ! n*n + 27
      if (next_prime(k) /= p) return

      bool = .true.
      return
   end function test_prime_adds
end program euler_146


      subroutine scond(a,b,c,king)
!     to obtain parabolic derivative of curve (unequally spaced points)
      use kinddefine
      implicit none
      integer(kind=K4),intent(in) :: king
      integer(kind=K4) :: k,n
      real(kind=K8),dimension(150),intent(in) :: a,b
      real(kind=K8),dimension(150),intent(out) :: c
      real(kind=K8) :: qf,qo,qst,s,sf,so,t,t0,tf
      n=king-1
      do k=2,n
       s=a(k)-a(k-1)
       t=a(k+1)-a(k)
       c(k)=((b(k+1)-b(k))*s*s+(b(k)-b(k-1))*t*t)/(s*s*t+s*t*t)
      enddo
      so=a(2)-a(1)
      t0=a(3)-a(2)
      qo=so+t0
      c(1)=(-t0*(qo+so)*b(1)+qo*qo*b(2)-so*so*b(3))/qo/so/t0
      sf=a(king-1)-a(king-2)
      tf=a(king)-a(king-1)
      qf=sf+tf
      qst=qf*sf*tf
      c(king)=(sf*(qf+tf)*b(king)-qf*qf*b(king-1)+tf*tf*b(king-2))/qst
      end subroutine scond


!       AUTHORS: MIKE MYERS AND LUCIA SPAGNUOLO
!       DATE:    MAY 8, 1989

!       Variables:
!               SCORE -> an array of test scores
!               SUM ->   sum of the test scores
!               COUNT -> counter of scores read in
!               I ->     loop counter

REAL FUNCTION COMPAV(SCORE,COUNT)
  INTEGER SUM,COUNT,J,SCORE(5)

  DO I = 1,COUNT
     SUM = SUM + SCORE(I)
  END DO
  COMPAV = SUM/COUNT
END FUNCTION COMPAV

PROGRAM AVENUM
!
!                       MAIN PROGRAM
!
!       AUTHOR:   LOIS BIGBIE
!       DATE:     MAY 15, 1990
!
!       Variables:
!               MAXNOS -> maximum number of input values
!               NUMS    -> an array of numbers
!               COUNT   -> exact number of input values
!               AVG     -> average returned by COMPAV
!               I       -> loop counter
!

  PARAMETER(MAXNOS=5)
  INTEGER I, COUNT
  REAL NUMS(MAXNOS), AVG
  COUNT = 0
  DO I = 1,MAXNOS
     READ (5,*,END=100) NUMS(I) ; COUNT = COUNT + 1

  END DO
100 AVG = COMPAV(NUMS, COUNT)
END PROGRAM AVENUM


! **********************************************************************************
! *                         ELEMENTARY MATRIX OPERATIONS                           *
! *    -----------------------------------------------------------------------     *
! *    Partial list of subroutines:                                                *
! *      determinant,                          transpose,                          *
! *      product_vector_vector,                product_vector_vector1,             *
! *      product_vector_vector2,               product_vector_vector_AVplus,       *
! *      product_vector_vector_AVminus,        product_matrix_vector,              *
! *      product_matrix_vector1,               product_matrix_vector2,             *
! *      product_matrix_vector3,               product_matrix_vector4,             *
! *      product_matrices,                     product_matrices1,                  *
! *      product_matrices2,                    product_matrixSUB,                  *
! *      sum_matrices,                         sum_diagonal_elements,              *
! *      sum_vectors,                          copy_matrix,                        *
! *      copy_vector,                          minus_matrix,                       *
! *      matrix_m_negativ,                     identity_matrix,                    *
! *      zero_matrix,                          cdot,                               *
! *      normvct                                                                   *
! **********************************************************************************
subroutine determinant (a, np, mp, n, det)
  use parameters
  implicit none
  integer    :: n, np, mp
  complex(O) :: a(np,mp), det
!
  integer    :: i
  real(O)    :: d
  integer,allocatable :: indx(:)
!
  allocate (indx(n))
  call LUDCMP (a, np, mp, n, indx, d)
  det = one
  do i = 1, n
    det = det * a(i,i)
  end do
  det = d * det
  deallocate (indx)
end subroutine determinant
! **********************************************************************************
subroutine transpose (a, np, mp, n)
  use parameters
  implicit none
  integer    :: n, np, mp
  complex(O) :: a(np,mp)
!
  integer    :: i, j
  complex(O) :: tampon
!
  do i = 1, n - 1
    do j = i + 1, n
      tampon = a(i,j)
      a(i,j) = a(j,i)
      a(j,i) = tampon
    end do
  end do
end subroutine transpose
! **********************************************************************************
subroutine product_vector_vector (N, a, b, c)
  use parameters
  implicit none
  integer    :: N, i
  complex(O) :: a(N), b(N), c(N)
!
  do i = 1, N
    c(i) = a(i) * b(i)
  end do
end subroutine product_vector_vector
! ***********************************************************************************
subroutine product_vector_vector1 (n, a, b, alpha, beta)
!------------------------------------------------------------------------------------
! The routine computes a = alpha * a + beta * b.                                    !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, i
  real(O)    :: absa, absb
  complex(O) :: a(*), b(*), alpha, beta
!
  absa = abs(alpha)
  absb = abs(beta)
  if (absa == 0._O) then
    if (absb == 0._O) then
      do i = 1, n
        a(i) = zero
      end do
    else
      do i = 1, n
        a(i) = beta * b(i)
      end do
    end if
  else
    if (absb == 0._O) then
      do i = 1, n
        a(i) = alpha * a(i)
      end do
    else
      do i = 1, n
        a(i) = alpha * a(i) + beta * b(i)
      end do
    end if
  end if
end subroutine product_vector_vector1
! ***********************************************************************************
subroutine product_vector_vector2 (n, a, b, c, d, alpha, beta, gamma)
!------------------------------------------------------------------------------------
! The routine computes d = alpha * a + beta * b + gama * c.                         !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, i
  real(O)    :: absa, absb, absg
  complex(O) :: a(*), b(*), c(*), d(*), alpha, beta, gamma
!
  absa = abs(alpha)
  absb = abs(beta)
  absg = abs(gamma)
  if (absa == 0._O) then
    if (absb == 0._O) then
      if (absg == 0._O) then
        do i = 1, n
          d(i) = zero
        end do
      else
        do i = 1, n
          d(i) = gamma * c(i)
        end do
      end if
    else
      if (absg == 0._O) then
        do i = 1, n
          d(i) = beta * b(i)
        end do
      else
        do i = 1, n
          d(i) = beta * b(i) + gamma * c(i)
        end do
      end if
    end if
  else
    if (absb == 0._O) then
      if (absg == 0._O) then
        do i = 1, n
          d(i) = alpha * a(i)
        end do
      else
        do i = 1, n
          d(i) = alpha * a(i) + gamma * c(i)
        end do
      end if
    else
      if (absg == 0._O) then
        do i = 1, n
          d(i) = alpha * a(i) + beta * b(i)
        end do
      else
        do i = 1, n
          d(i) = alpha * a(i) + beta * b(i) + gamma * c(i)
        end do
      end if
    end if
  end if
end subroutine product_vector_vector2
!***********************************************************************************
subroutine product_vector_vector_AVplus (Nc, Nmax, TV, nTV, c, c1)
  use parameters
  implicit none
  integer    :: Nc, Nmax, NTV, i, j
  complex(O) :: TV(nTV), c(2*Nmax), c1(2*Nmax), sum
!
  do i = 1, 2*Nmax
    sum = zero
    do j = 1, 2*Nmax
      sum = sum + TV(Nc+i+2*(j-1)*Nmax) * c(j)
    end do
    c1(i) = sum
  end do
end subroutine product_vector_vector_AVplus
!***********************************************************************************
subroutine product_vector_vector_AVminus (Nc, Nmax, TV, nTV, c, c1)
  use parameters
  implicit none
  integer    :: Nc, Nmax, NTV, i, j
  complex(O) :: TV(nTV), c(2*Nmax), c1(2*Nmax), sum
!
  do i = 1, Nmax
    sum = zero
    do j = 1, Nmax
      sum = sum + TV(Nc+i+2*(j-1)*Nmax) * c(j)
    end do
    c1(i) = sum
    sum   = zero
    do j = Nmax + 1, 2*Nmax
      sum = sum + TV(Nc+i+2*(j-1)*Nmax) * c(j)
    end do
    c1(i) = c1(i) - sum
  end do
  do i = Nmax + 1, 2*Nmax
    sum = zero
    do j = 1, Nmax
      sum = sum + TV(Nc+i+2*(j-1)*Nmax) * c(j)
    end do
    c1(i) = - sum
    sum   =   zero
    do j = Nmax + 1, 2 * Nmax
      sum = sum + TV(Nc+i+2*(j-1)*Nmax) * c(j)
    end do
    c1(i) = c1(i) + sum
  end do
end subroutine product_vector_vector_AVminus
! **********************************************************************************
subroutine product_matrix_vector (N, M, a, np, mp, b, c)
!-----------------------------------------------------------------------------------
! The routine computes c(N) = a(N,M) * b(M).                                       !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, np, mp, j, i
  complex(O) :: a(np,mp), b(M), c(N)
!
  do i = 1, N
    c(i) = zero
  end do
  do j = 1, M
    if (b(j) /= zero) then
      do i = 1, N
        c(i) = c(i) + a(i,j) * b(j)
      end do
    end if
  end do
end subroutine product_matrix_vector
! **********************************************************************************
subroutine product_matrix_vector1 (N, M, c, a, nap, map, b, nbp, mbp)
!-----------------------------------------------------------------------------------
! The routine computes b(i,j) = c(i) * a(i,j) for i = 1,..,N; j = 1,...,M.         !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, nap, map, nbp, mbp, j, i
  complex(O) :: a(nap,map), b(nbp,mbp), c(N)
!
  do i = 1, N
    do j = 1, M
      b(i,j) = c(i) * a(i,j)
    end do
  end do
end subroutine product_matrix_vector1
! **********************************************************************************
subroutine product_matrix_vector2 (N, M, c, a, np, mp)
!-----------------------------------------------------------------------------------
! The routine computes a(i,j) = c(i) * a(i,j) for i = 1,..,N; j = 1,...,M.         !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, np, mp, j, i
  complex(O) :: a(np,mp), c(N)
!
  do i = 1, N
    do j = 1, M
      a(i,j) = c(i) * a(i,j)
    end do
  end do
end subroutine product_matrix_vector2
! ***********************************************************************************
subroutine product_matrix_vector3 (n, m, a, nap, map, u, v, alpha, beta, x)
!-----------------------------------------------------------------------------------
! The routine computes x = alpha * A * u + beta * v.                               !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, m, nap, map
  complex(O) :: a(nap,map), u(*), v(*), x(*), alpha, beta
!
  integer    :: i, j
  complex(O) :: sum
!
  do i = 1, n
    sum = zero
    do j = 1, m
      if (u(j) /= zero) sum = sum + a(i,j) * u(j)
    end do
    x(i) = alpha * sum + beta * v(i)
  end do
end subroutine  product_matrix_vector3
! ***********************************************************************************
subroutine product_matrix_vector4 (n, m, a, nap, map, u, v, alpha, beta)
!-----------------------------------------------------------------------------------
! The routine computes v = alpha * A * u + beta * v.                               !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, m, nap, map
  complex(O) :: a(nap,map), u(*), v(*), alpha, beta
!
  integer    :: i, j
  complex(O) :: sum
!
  do i = 1, n
    sum = zero
    do j = 1, m
      if (u(j) /= zero) sum = sum + a(i,j) * u(j)
    end do
    v(i) = alpha * sum + beta * v(i)
  end do
end subroutine  product_matrix_vector4
!***********************************************************************************
subroutine product_matrices (N, M, L, a, nap, map, b, nbp, mbp)
!-----------------------------------------------------------------------------------
! The routine computes c(N,L) = a(N,M) * b(M,L), where c(N,L) is stored in         !
! a(nap,map). The natural conditions: nap >= N, map >= M  and the additional       !
! condition map >= L must be satisfied.                                            !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, L, nap, map, nbp, mbp, j, i, k
  complex(O) :: a(nap,map), b(nbp,mbp)
  complex(O), allocatable :: c(:)
!
  if (map < L) then
    print "(/,2x,'Error in subroutine product_matrices:')"
    print "(  2x,'the real dimension exceeds the physical dimension of the matrix;')"
    stop
  end if
  allocate (c(L))
  do i = 1, N
    do j = 1, L
      c(j) = zero
    end do
    do k = 1, M
      if (a(i,k) /= zero) then
        do j = 1, L
          c(j) = c(j) + a(i,k) * b(k,j)
        end do
      end if
    end do
    do j = 1, L
      a(i,j) = c(j)
    end do
  end do
  deallocate (c)
end subroutine product_matrices
!***********************************************************************************
subroutine product_matrices1 (N, M, L, a, nap, map, b, nbp, mbp, c, ncp, mcp)
!-----------------------------------------------------------------------------------
! The routine computes c(N,L) = a(N,M) * b(M,L).                                   !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, L, nap, map, nbp, mbp, ncp, mcp, j, i, k
  complex(O) :: a(nap,map), b(nbp,mbp), c(ncp,mcp)
!
  do i = 1, N
    do j = 1, L
          c(i,j) = zero
    end do
    do k = 1, M
      if (a(i,k) /= zero ) then
        do j = 1, L
          c(i,j) = c(i,j) + a(i,k) * b(k,j)
        end do
      end if
    end do
  end do
end subroutine product_matrices1
! **********************************************************************************
subroutine product_matrices2 (index, N, M, L, a, nap, map, b, nbp, mbp, c, ncp, mcp)
!-----------------------------------------------------------------------------------
! The routine computes c(N,L) = c(N,L) + a(N,M) * b(M,L).                          !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, L, j, i, k, index, nap, map, nbp, mbp, ncp, mcp
  complex(O) :: a(nap,map), b(nbp,mbp), c(ncp,mcp)
!
  if (index == 1) then
    do i = 1, N
      do j = 1, L
        c(i,j) = zero
      end do
    end do
  end if
  do i = 1, N
    do k = 1, M
      if (a(i,k) /= zero) then
        do j = 1, L
          c(i,j) = c(i,j) + a(i,k) * b(k,j)
        end do
      end if
    end do
  end do
end subroutine product_matrices2
! **********************************************************************************
subroutine product_matrixSUB (a, na, ma, b, nb, mb, n)
!-----------------------------------------------------------------------------------
! The routine computes a(n,n) = I(n,n) - a(n,n) * b(n,n).                          !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: n, na, ma, nb, mb
  complex(O) :: a(na,ma), b(nb,mb)
!
  integer    :: i, j, k
  complex(O) :: sum
  complex(O),allocatable :: c(:)
!
  allocate (c(n))
  do i = 1, n
    do j = 1, n
      sum = zero
      do k = 1, n
        sum = sum + a(i,k) * b(k,j)
      end do
      c(j) = sum
    end do
    do j = 1, n
      a(i,j) = c(j)
    end do
  end do
  do i = 1, n
    do j = 1, n
      if (j == i) then
        a(i,j) = one - a(i,j)
      else
        a(i,j) = - a(i,j)
      end if
    end do
  end do
  deallocate (c)
end subroutine product_matrixSUB
! **********************************************************************************
subroutine sum_matrices (N, M, a, nap, map, b, nbp, mbp)
!-----------------------------------------------------------------------------------
! The routine computes a(N,M) = a(N,M) + b(N,M).                                   !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, nap, map, nbp, mbp, j, i
  complex(O) :: a(nap,map), b(nbp,mbp)
!
  do i = 1, N
    do j = 1, M
      a(i,j) = a(i,j) + b(i,j)
    end do
  end do
end subroutine sum_matrices
! **********************************************************************************
subroutine sum_diagonal_elements (N, c, a, nap, map)
!-----------------------------------------------------------------------------------
! The routine computes a(i,i) = c(i) + a(i,i) for i = 1,..,N.                      !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, nap, map, i
  complex(O) :: c(N), a(nap,map)
!
  do i = 1, N
    a(i,i) = c(i) + a(i,i)
  end do
end subroutine sum_diagonal_elements
! **********************************************************************************
subroutine sum_vectors (a, b, n)
  use parameters
  implicit none
  integer    :: n, i
  complex(O) :: a(n), b(n)
!
  do i = 1, n
    a(i) = a(i) + b(i)
  end do
end subroutine sum_vectors
! **********************************************************************************
subroutine copy_matrix (N, M, a, nap, map, b, nbp, mbp)
  use parameters
  implicit none
  integer    :: N, M, nap, map, nbp, mbp, i, j
  complex(O) :: a(nap,map), b(nbp,mbp)
!
  do i = 1, N
    do j = 1, M
      b(i,j) = a(i,j)
    end do
  end do
end subroutine copy_matrix
! **********************************************************************************
subroutine copy_vector (c, c1, N)
  use parameters
  implicit none
  integer    :: N, i
  complex(O) :: c(N), c1(N)
!
  do i = 1, N
    c1(i) = c(i)
  end do
end subroutine copy_vector
! **********************************************************************************
subroutine minus_matrix (N, M, a, nap, map)
!-----------------------------------------------------------------------------------
! The routine computes a(N,M) = - a(N,M).                                          !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, nap, map, j, i
  complex(O) :: a(nap,map)
!
  do i = 1, N
    do j = 1, M
      a(i,j) = - a(i,j)
    end do
  end do
end subroutine minus_matrix
! **********************************************************************************
subroutine matrix_m_negativ (N, M, a, nap, map)
!-----------------------------------------------------------------------------------
! The routine transforms the matrix a(2*N,2*M) as follows:                         !
!                                                                                !
!             | a11(N,M)   a12(N,M) |      | a11(N,M)  -a12(N,M) |                 !
!             |                     |  --> |                     |.                !
!             | a21(N,M)   a22(N,M) |      |-a21(N,M)   a22(N,M) |                 !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: N, M, nap, map, i, j
  complex(O) :: a(2*nap,2*map)
!
  do i = 1, N
    do j = 1, M
      a(i,j+M) = - a(i,j+M)
      a(i+N,j) = - a(i+N,j)
    end do
  end do
end subroutine matrix_m_negativ
!***********************************************************************************
subroutine identity_matrix (N, a, nap, map)
  use parameters
  implicit none
  integer    :: N, nap, map, i, j
  complex(O) :: a(nap,map)
!
  do i = 1, N
    do j = 1, N
      a(i,j) = zero
      if (j == i) a(i,j) = one
    end do
  end do
end subroutine identity_matrix
! **********************************************************************************
subroutine zero_matrix (N, M, a, nap, map)
  use parameters
  implicit none
  integer    :: N, M, nap, map, i, j
  complex(O) :: a(nap,map)
!
  do i = 1, N
    do j = 1, M
      a(i,j) = zero
    end do
  end do
end subroutine zero_matrix
!************************************************************************************
function cdot (n, a, b) result (prod)
  use parameters
  implicit none
  integer      :: n, i
  complex(O)   :: a(*), b(*), prod, sum

  sum = zero
  do i = 1, n
    sum = sum + a(i) * conjg(b(i))
  end do
  prod = sum
end function cdot
! ***********************************************************************************
function normvct (n, cx) result (norm)
  use parameters
  implicit none
  integer     :: n, i
  real(O)     :: norm, abscx, sum
  complex(O)  :: cx(*)
!
  sum = 0._O
  do i = 1, n
    abscx = abs(cx(i))
    sum   = sum + abscx * abscx
  end do
  norm = sqrt(sum)
end function normvct