! This is the 2D mesh generator for linear, triangular elements
!
! This code is modified from J.N. REDDY, AN INTRODUCTION TO THE
! FINITE ELEMENT METHOD, 2nd EDITION
!
! Coded by Tyler Hayes, April 3, 2007
!
!
! INPUTS:
!
!      NX = NUMBER OF DIVISIONS IN THE X-DIR
!      NY = NUMBER OF DIVISIONS IN THE Y-DIR
!    NEX1 = INTEGER = NX+1
!    NEY1 = INTEGER = NY+1
!     NEM = INTEGER = 2*NX*NY
!     NNM = INTEGER = ((IEL*NX)+1) * ((IEL*NY)+1) IEL = 1 for tri
!      DX = VECTOR OF SPACINGS IN THE X-DIR <- CAN BE VARIABLE
!           THE VECTOR SHOULD BE NX+1 IN SIZE BUT THE DX(NX+1) IS
!           SET TO ZERO AND IS A DUMMY VARIABLE
!      DY = VECTOR OF SPACINGS IN THE Y-DIR <- CAN BE VARIABLE
!           THE VECTOR SHOULD BE NY+1 IN SIZE BUT THE DY(NY+1) IS
!           SET TO ZERO AND IS A DUMMY VARIABLE
!      X0 = ORIGIN OF THE X AXIS
!      Y0 = ORIGIN OF THE Y AXIS
!
! OUTPUT:
!      NOD = INTEGER MATRIX OF ELEMENT NOD INDICES
!     GLXY = GLOBAL COORDINATES OF NOD
!
! MISC.:
!      NPE = NODES PER ELEMENT
!----------------------------------------------------------------

SUBROUTINE MESH(NOD,GLXY,NX,NY,NEX1,NEY1,NEM,NNM,DX,DY,X0,Y0)
  IMPLICIT NONE
  INTEGER :: NXX,NYY,NX2,NY2,NXX1,NYY1
  INTEGER :: K,IY,L,M,N,I,NI,NJ,IEL
  INTEGER,PARAMETER :: NPE=3
  REAL :: XC,YC
! INPUTS
  INTEGER,INTENT(IN) :: NX,NY,NEM,NNM,NEX1,NEY1
  REAL,INTENT(IN) :: X0,Y0
  REAL,DIMENSION(NEX1),INTENT(IN) :: DX
  REAL,DIMENSION(NEY1),INTENT(IN) :: DY
! PARAMETERS
! OUTPUTS
  INTEGER,DIMENSION(NEM,NPE),INTENT(OUT) :: NOD
  REAL,DIMENSION(NNM,2),INTENT(OUT) :: GLXY

! CREATE VARIABLES
  IEL  = 1 ! FOR <= 4 NODES PER ELEMENT
  NXX  = IEL*NX
  NYY  = IEL*NY
  NXX1 = NXX + 1
  NYY1 = NYY + 1
  NX2  = 2*NX
  NY2  = 2*NY

! CREATE TRIANGUALR ELEMENTS
!----------------------------------------------------------------

! INITIALIZE FIRST TWO ELEMENTS
  NOD(1,1) = 1
  NOD(1,2) = IEL+1
  NOD(1,3) = IEL*NXX1 + IEL + 1
  NOD(2,1) = 1
  NOD(2,2) = NOD(1,3)
  NOD(2,3) = IEL*NXX1 + 1

! LOOP THROUGH MESH
  K=3
  DO IY=1,NY
     L=IY*NX2
     M=(IY-1)*NX2
     IF (NX > 1) THEN
        DO N=K,L,2
           DO I=1,NPE
              NOD(N,I)   = NOD(N-2,I) + IEL
              NOD(N+1,I) = NOD(N-1,I) + IEL
           END DO
        END DO
     END IF
     IF (IY < NY) THEN
        DO I=1,NPE
           NOD(L+1,I) = NOD(M+1,I) + IEL*NXX1
           NOD(L+2,I) = NOD(M+2,I) + IEL*NXX1
        END DO
     END IF
     K=L+3
  END DO

! NOW GENERATE GLOBAL COORDINATES OF THE NODES
  XC = X0
  YC = Y0

  DO NI=1,NEY1
     XC = X0
     I  = NXX1*IEL*(NI-1)
     DO NJ = 1,NEX1
        I=I+1
        GLXY(I,1) = XC
        GLXY(I,2) = YC
        IF (NJ < NEX1) THEN
           IF (IEL == 2) THEN
              I=I+1
              XC = XC + 0.5*DX(NJ)
              GLXY(I,1) = XC
              GLXY(I,2) = YC
           END IF
        END IF
        XC = XC + DX(NJ)/IEL
     END DO
     XC = X0
     IF (IEL == 2) THEN
        YC = YC + 0.5*DY(NI)
        DO NJ = 1,NEX1
           I=I+1
           GLXY(I,1) = XC
           GLXY(I,2) = YC
           IF (NJ < NEX1) THEN
              I=I+1
              XC = XC + 0.5*DX(NJ)
              GLXY(I,1) = XC
              GLXY(I,2) = YC
           END IF
           XC = XC + 0.5*DX(NJ)
        END DO
     END IF
     YC = YC + DY(NI)/IEL
  END DO
END SUBROUTINE MESH


program quadtest

      use quadrature_module

      implicit none

      integer :: npoints
      real*8,allocatable :: x(:)
      real*8,allocatable :: w(:)
      integer :: i

      npoints=1

      call gll_gen(x,w,npoints)

      do i=1,npoints+1

      		print *,x(i),w(i)

	enddo

end program quadtest


program hip_dgemm
  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_hipblas

  implicit none

  integer(kind(HIPBLAS_OP_N)), parameter :: transa = HIPBLAS_OP_N, transb = HIPBLAS_OP_N;
  complex(kind=4), parameter ::  alpha = 1.1d0, beta = 0.9d0;

  integer, parameter :: m = 512, n = 512, k = 512;

  complex(kind=4), allocatable, dimension(:,:) :: ha, hb, hc
  complex(kind=4), allocatable, dimension(:,:) :: hc_exact

  complex(kind=4), pointer, dimension(:,:) :: da, db, dc
  type(c_ptr) :: handle = c_null_ptr

  integer :: i,j
  double precision :: error
  double precision, parameter :: error_max = 10*epsilon(error)

  write(*,"(a)",advance="no") "-- Running test 'CGEMM' (Fortran 2008 interfaces) - "

  call hipblasCheck(hipblasCreate(handle))

  ! C = A_MxK * B_KxN

  allocate(ha(m,k))
  allocate(hb(k,n))
  allocate(hc(m,n))
  allocate(hc_exact(m,n))

  ! Use these constant matrices so the exact answer is also a
  ! constant matrix and therefore easy to check
  ha(:,:) = 1.d0
  hb(:,:) = 2.d0
  hc(:,:) = 3.d0
  hc_exact(:,:) = alpha*k*2.d0 + beta*3.d0

  ! Allocate device memory
  call hipCheck(hipMalloc(da,mold=ha))
  call hipCheck(hipMalloc(db,mold=hb))
  call hipCheck(hipMalloc(dc,mold=hc))

  !Transfer from host to device
  call hipCheck(hipMemcpy(da, ha, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(db, hb, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dc, hc, hipMemcpyHostToDevice))

  call hipblasCheck(hipblasCgemm(handle,transa,transb,m,n,k,alpha,da,size(da,1),db,size(db,1),beta,dc,size(dc,1)))

  call hipCheck(hipDeviceSynchronize())

  ! Transfer data back to host memory
  call hipCheck(hipMemcpy(hc, dc, hipMemcpyDeviceToHost))

  do j = 1,n
    do i = 1,m
      !write(*,*) "hc(i,j)=",hc(i,j),",hc_exact(i,j)=",hc_exact(i,j)
      error = abs((hc_exact(i,j) - hc(i,j))/hc_exact(i,j))
      if( error > error_max )then
         write(*,*) "FAILED! Error bigger than max! Error = ", error
         call exit(1)
      end if
    end do
  end do

  call hipCheck(hipFree(da))
  call hipCheck(hipFree(db))
  call hipCheck(hipFree(dc))

  call hipblasCheck(hipblasDestroy(handle))

  deallocate(ha,hb,hc,hc_exact)

  write(*,*) "PASSED!"

end program hip_dgemm


!*==cladiv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CLADIV performs complex division in real arithmetic, avoiding unnecessary overflow.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CLADIV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       COMPLEX FUNCTION CLADIV( X, Y )
!
!       .. Scalar Arguments ..
!       COMPLEX            X, Y
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CLADIV := X / Y, where X and Y are complex.  The computation of X / Y
!> will not overflow on an intermediary step unless the results
!> overflows.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] X
!> \verbatim
!>          X is COMPLEX
!> \endverbatim
!>
!> \param[in] Y
!> \verbatim
!>          Y is COMPLEX
!>          The complex scalars X and Y.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERauxiliary
!
!  =====================================================================
      COMPLEX FUNCTION CLADIV(X,Y)
      IMPLICIT NONE
!*--CLADIV68
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      COMPLEX X , Y
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      REAL zi , zr
!     ..
!     .. External Subroutines ..
      EXTERNAL SLADIV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC AIMAG , CMPLX , REAL
!     ..
!     .. Executable Statements ..
!
      CALL SLADIV(REAL(X),AIMAG(X),REAL(Y),AIMAG(Y),zr,zi)
      CLADIV = CMPLX(zr,zi)
!
!
!     End of CLADIV
!
      END FUNCTION CLADIV


    Program dgerqf_example

!     DGERQF Example Program Text

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

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgerqf, dormrq, dtrtrs
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, lda, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:), tau(:), work(:), x(:)
!     .. Executable Statements ..
      Write (nout, *) 'DGERQF Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      lwork = nb*m
      Allocate (a(lda,n), b(m), tau(m), work(lwork), x(n))

!     Read the matrix A and the vector b from data file

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

!     Compute the RQ factorization of A
      Call dgerqf(m, n, a, lda, tau, work, lwork, info)

!     Copy the m element vector b into elements x(n-m+1), ..., x(n) of x

      x(n-m+1:n) = b(1:m)

!     Solve R*y2 = b, storing the result in x2
      Call dtrtrs('Upper', 'No transpose', 'Non-Unit', m, 1, a(1,n-m+1), lda, &
        x(n-m+1), m, info)

      If (info>0) Then
        Write (nout, *) 'The upper triangular factor, R, of A is singular, '
        Write (nout, *) 'the least squares solution could not be computed'
      Else

        x(1:n-m) = zero

!       Compute the minimum-norm solution x = (Q**T)*y
        Call dormrq('Left', 'Transpose', n, 1, m, a, lda, tau, x, n, work, &
          lwork, info)

!       Print minimum-norm solution

        Write (nout, *) 'Minimum-norm solution'
        Write (nout, 100) x(1:n)

      End If

100   Format (1X, 8F9.4)
    End Program


      SUBROUTINE quad3d(x1,x2,ss)
      REAL ss,x1,x2,h
      EXTERNAL h
CU    USES h,qgausx
      call qgausx(h,x1,x2,ss)
      return
      END
      FUNCTION f(zz)
      REAL f,zz,func,x,y,z
      COMMON /xyz/ x,y,z
CU    USES func
      z=zz
      f=func(x,y,z)
      return
      END
      FUNCTION g(yy)
      REAL g,yy,f,z1,z2,x,y,z
      EXTERNAL f
      COMMON /xyz/ x,y,z
CU    USES f,qgausz,z1,z2
      REAL ss
      y=yy
      call qgausz(f,z1(x,y),z2(x,y),ss)
      g=ss
      return
      END
      FUNCTION h(xx)
      REAL h,xx,g,y1,y2,x,y,z
      EXTERNAL g
      COMMON /xyz/ x,y,z
CU    USES g,qgausy,y1,y2
      REAL ss
      x=xx
      call qgausy(g,y1(x),y2(x),ss)
      h=ss
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/quad3d.for


      function fuel(mass)
        integer mass, fuel
        fuel = 0

 98     mass = mass / 3 - 2
        if (mass .lt. 1) go to 99
        fuel = fuel + mass
        go to 98

 99     return
      end function

      program day01
          integer x, part1, part2, fuel
          part1 = 0
          part2 = 0

 1        read (*,*,END=2) x
          part1 = part1 + x / 3 - 2
          part2 = part2 + fuel(x)
          goto 1

 2        write(*,*) part1, part2
      stop
      end


program problem77
  implicit none
  integer, parameter     :: ms=100,ps=664579,limit=5000
  integer, dimension(ps) :: primes
  integer, dimension(ms) :: memo
  integer                :: i,a

  open(33,file='./data/problem70.dat')
  read(33,*) primes

  ! https://oeis.org/A000607
  do i=1,ms
     memo(i)=-1
  end do
  memo(1:10)=(/ 0, 1, 1, 1, 2, 2, 3, 3, 4, 5 /)

  i=1
  a=1
  do while(a<=limit)
     i=i+1
     a=a000607(i)
  end do
  print *, i

contains

  ! https://oeis.org/A000607
  ! a(n) = (1/n)*Sum_{k=1..n} A008472(k)*a(n-k)
  recursive function a000607(n) result(r)
    implicit none
    integer, intent(in) :: n
    integer             :: k,r

    if (n<0) then
       r=1
       return
    else if (n==0) then
       r=1
       return
    else
       if (memo(n) /= -1) then
          r=memo(n)
          return
       else
          r=0
          do k=1,n
             r=r+(a008472(k)*a000607(n-k))
          end do
          r=r/n
          if (n<=ms) memo(n)=r
          return
       end if
    end if

  end function a000607

  ! https://oeis.org/A008472
  pure function a008472(n)
    implicit none
    integer, intent(in) :: n
    integer             :: p,a008472,i,rest

    a008472=0
    rest=n
    do i=1,n
       p=primes(i)
       if (mod(rest,p)==0) then
          a008472=a008472+p
          do while (mod(rest,p)==0)
             rest=rest/p
          end do
       end if

       ! Important: if the current prime is more than the square root
       ! of what is left, then what is left must be the last prime
       ! factor.
       if (p>sqrt(real(rest))) then
          if (rest>1) a008472=a008472+rest
          exit
       end if
    end do

  end function a008472

end program problem77


*DECK DVNRMS
      DOUBLE PRECISION FUNCTION DVNRMS (N, V, W)
C***BEGIN PROLOGUE  DVNRMS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DDEBDF
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (VNWRMS-S, DVNRMS-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   DVNRMS computes a weighted root-mean-square vector norm for the
C   integrator package DDEBDF.
C
C***SEE ALSO  DDEBDF
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DVNRMS
      INTEGER I, N
      DOUBLE PRECISION SUM, V, W
      DIMENSION V(*),W(*)
C***FIRST EXECUTABLE STATEMENT  DVNRMS
      SUM = 0.0D0
      DO 10 I = 1, N
         SUM = SUM + (V(I)/W(I))**2
   10 CONTINUE
      DVNRMS = SQRT(SUM/N)
      RETURN
C     ----------------------- END OF FUNCTION DVNRMS
C     ------------------------
      END


SUBROUTINE linear(a,b,Du,Dv,dt,modescalereal,coef,kx,ky,kz,u,v,uhat,vhat,decomp)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine solves the linear equation in a splitting
	! method for the Brusselator equation in 3 dimensions
	! u_t = a + u^2v - (b+1)u + Du (u_xx + u_yy + u_zz)
    ! v_t = bu - u^2v + Dv (v_xx + v_yy + v_zz)
	!
	!
	! INPUT
	!
	! .. Parameters ..
	!  a                = equation parameter
	!  b                = equation parameter
	!  Du               = equation diffusion coefficient
	!  Dv               = equation diffusion coefficient
    !  modescalereal    = scaling of terms after forward and backward FFT
	!  dt				= timestep
	!  coef				= (complex) timestep coefficient
	! .. Arrays ..
	!  kx               = Fourier wave numbers in x direction
	!  ky               = Fourier wave numbers in y direction
	!  kz               = Fourier wave numbers in z direction
	!  u				= u field
	!  v				= v field
	!  uhat				= storage for u field in Fourier space
	!  vhat				= storage for v field in Fourier space
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!					see http://www.2decomp.org/ for more information
	! OUTPUT
	!
	! .. Arrays ..
	!  u 				= updated u field
	!  v 				= updated v field
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  temp             = temporary storage variable
	!  uhattemp         = temporary storage variable
	!  vhattemp         = temporary storage variable
	!  uhatstore        = temporary storage variable
	!  vhatstore        = temporary storage variable
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library
	USE decomp_2d
	USE decomp_2d_fft
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	! Declare variables
	TYPE(DECOMP_INFO), INTENT(IN)						    :: decomp
	REAL(KIND=8), INTENT(IN)                                :: dt,a,b,Du,Dv,modescalereal
	COMPLEX(KIND=8), INTENT(IN)                             :: coef
	COMPLEX(kind=8), DIMENSION(decomp%zst(1):decomp%zen(1)), INTENT(IN) :: kx
	COMPLEX(kind=8), DIMENSION(decomp%zst(2):decomp%zen(2)), INTENT(IN) :: ky
	COMPLEX(kind=8), DIMENSION(decomp%zst(3):decomp%zen(3)), INTENT(IN) :: kz
	COMPLEX(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1),&
   							   decomp%xst(2):decomp%xen(2),&
   							   decomp%xst(3):decomp%xen(3)),&
   											   INTENT(INOUT) :: u,v
	COMPLEX(KIND=8), DIMENSION(decomp%zst(1):decomp%zen(1),&
                               decomp%zst(2):decomp%zen(2),&
                               decomp%zst(3):decomp%zen(3)),&
   											INTENT(OUT)      :: uhat,vhat
	INTEGER(kind=4)										     :: i,j,k
	COMPLEX(kind=8)                   :: uhattemp,vhattemp,uhatstore,vhatstore
	CALL decomp_2d_fft_3d(u,uhat,DECOMP_2D_FFT_FORWARD)
	CALL decomp_2d_fft_3d(v,vhat,DECOMP_2D_FFT_FORWARD)
	IF ((decomp%zst(3).eq.1).and.(decomp%zst(2).eq.1).and.(decomp%zst(1).eq.1)) THEN
	 uhattemp=uhat(1,1,1)
	 vhattemp=vhat(1,1,1)
	END IF
 	DO k=decomp%zst(3),decomp%zen(3); DO j=decomp%zst(2),decomp%zen(2); DO i=decomp%zst(1),decomp%zen(1)
 	 uhatstore=uhat(i,j,k)
 	 vhatstore=vhat(i,j,k)
 	 vhat(i,j,k)=vhatstore*exp(coef*dt*Dv*(kx(i)**2+ky(j)**2+kz(k)**2)) &
 	 	            +b*uhatstore*(exp(coef*dt*Dv*(kx(i)**2+ky(j)**2+kz(k)**2)) &
 	 		                     -exp(coef*dt*(Du*(kx(i)**2+ky(j)**2+kz(k)**2)-b-1.0d0) )) &
 	 	                         /(b+1.0d0-(Du-Dv)*(kx(i)**2+ky(j)**2+kz(k)**2))
 	 uhat(i,j,k)=uhatstore*exp( coef*dt*(-b-1.0d0+Du*( kx(i)**2 + ky(j)**2 + kz(k)**2 )) )
 	END DO; END DO; END DO
	IF ((decomp%zst(3).eq.1).and.(decomp%zst(2).eq.1).and.(decomp%zst(1).eq.1)) THEN
	 uhat(1,1,1)=uhattemp*exp(-coef*dt*(b+1.0d0))+&
	               (a/modescalereal)*(1.0d0-exp(-coef*dt*(b+1.0d0)))/(b+1.0d0)
	 vhat(1,1,1)=vhattemp+b*( (exp(-(b+1)*coef*dt)-1.0d0)* &
			                (-uhattemp+(a/modescalereal)/(b+1.0d0))/(b+1.0d0) &
			                    +(a/modescalereal)*coef*dt/(b+1.0d0))
	END IF
	! don't forget to scale
	CALL decomp_2d_fft_3d(uhat,u,DECOMP_2D_FFT_BACKWARD)
	CALL decomp_2d_fft_3d(vhat,v,DECOMP_2D_FFT_BACKWARD)
	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	 u(i,j,k)=u(i,j,k)*modescalereal
	 v(i,j,k)=v(i,j,k)*modescalereal
	END DO; END DO; END DO
	END SUBROUTINE linear


    Program dgeev_example

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

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgeev
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: eig
      Real (Kind=dp) :: alpha, beta, scale
      Integer :: i, info, j, k, lda, ldvr, lwork, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), vr(:, :), wi(:), work(:), wr(:)
      Real (Kind=dp) :: dummy(1, 1)
!     .. Intrinsic Procedures ..
      Intrinsic :: cmplx, max, maxloc, nint, sqrt
!     .. Executable Statements ..
      Write (nout, *) 'DGEEV Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldvr = n
      Allocate (a(lda,n), vr(ldvr,n), wi(n), wr(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dgeev('No left vectors', 'Vectors (right)', n, a, lda, wr, wi, &
        dummy, 1, vr, ldvr, dummy, lwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+2)*n, nint(dummy(1,1)))
      Allocate (work(lwork))

!     Read the matrix A from data file

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

!     Compute the eigenvalues and right eigenvectors of A

      Call dgeev('No left vectors', 'Vectors (right)', n, a, lda, wr, wi, &
        dummy, 1, vr, ldvr, work, lwork, info)

      If (info==0) Then

!       Print solution

        Do j = 1, n
          Write (nout, *)
          If (wi(j)==zero) Then
            Write (nout, 100) 'Eigenvalue(', j, ') = ', wr(j)
          Else
            eig = cmplx(wr(j), wi(j), kind=dp)
            Write (nout, 110) 'Eigenvalue(', j, ') = ', eig
          End If
          Write (nout, *)
          Write (nout, 120) 'Eigenvector(', j, ')'
          If (wi(j)==zero) Then
!           Scale by making largest element positive
            k = maxloc(vr(1:n,j), 1)
            If (vr(k,j)<zero) Then
              vr(1:n, j) = -vr(1:n, j)
            End If
            Write (nout, 130) vr(1:n, j)
          Else If (wi(j)>0.0E0_dp) Then
!           Scale by making largest element real and positive
            work(1:n) = vr(1:n, j)**2 + vr(1:n, j+1)**2
            k = maxloc(work(1:n), 1)
            scale = sqrt(work(k))
            work(1:n) = vr(1:n, j)
            alpha = vr(k, j)/scale
            beta = vr(k, j+1)/scale
            vr(1:n, j) = alpha*work(1:n) + beta*vr(1:n, j+1)
            vr(1:n, j+1) = alpha*vr(1:n, j+1) - beta*work(1:n)
            Write (nout, 140)(vr(i,j), vr(i,j+1), i=1, n)
          Else
            Write (nout, 140)(vr(i,j-1), -vr(i,j), i=1, n)
          End If
        End Do
      Else
        Write (nout, *)
        Write (nout, 150) 'Failure in DGEEV.  INFO = ', info
      End If

100   Format (1X, A, I2, A, 1P, E11.4)
110   Format (1X, A, I2, A, '(', 1P, E11.4, ',', 1P, E11.4, ')')
120   Format (1X, A, I2, A)
130   Format (1X, 1P, E11.4)
140   Format (1X, '(', 1P, E11.4, ',', 1P, E11.4, ')')
150   Format (1X, A, I4)
    End Program


!> Author:   Jabir Ali Ouassou
!> Category: Foundation
!>
!> This file provides a common interface to a large library of mathematical
!> functions and subroutines. See the documentation of individual interfaces
!> below for more information about the contents of the mathematical library.

module math_m
  use :: basic_m
  use :: calculus_m
  use :: matrix_m
  private

  !------------------------------------------------------------
  ! Public interface
  !------------------------------------------------------------

  ! Floating-point precision
  public :: sp, dp, qp, wp

  ! Numerical constants
  public :: inf, eps, pi

  ! Basic routines
  public :: unitvector, nonzero, re, im, cx, arg

  ! Matrix routines
  public :: trace, diag, inverse, identity, commutator, anticommutator

  ! Calculus routines
  public :: mean, differentiate, integrate, interpolate, linspace

  !------------------------------------------------------------
  ! Interfaces for working with matrices
  !------------------------------------------------------------

  interface trace
    !! Public interface for functions that calculate a matrix trace.
    module procedure matrix_trace     ! Trace of a matrix
  end interface

  interface inverse
    !! Public interface for functions that calculate a matrix inverse.
    module procedure matrix_inverse_re, &  ! Inverse of a real matrix
                     matrix_inverse_cx     ! Inverse of a complex matrix
  end interface

  interface diag
    !! Public interface for functions that deal with matrix diagonals.
    module procedure matrix_diag, &   ! Construct a diagonal matrix
                     vector_diag      ! Extract a matrix diagonal
  end interface

  !------------------------------------------------------------
  ! Interfaces for calculus routines
  !------------------------------------------------------------

  interface mean
    !! Public interface for routines that calculate the mean value.
    module procedure mean_array_re, &               ! Mean of a real array
                     mean_array_cx                  ! Mean of a complex array
  end interface

  interface differentiate
    !! Public interface for various differentiation routines.
    module procedure differentiate_array_re, &      ! Derivative of a real array
                     differentiate_array_cx         ! Derivative of a complex array
  end interface

  interface integrate
    !! Public interface for various integration routines.
    module procedure integrate_array_re, &          ! Trapezoid integration of a real array
                     integrate_array_cx, &          ! Trapezoid integration of a complex array
                     integrate_range_re, &          ! Interpolated integration of a real array
                     integrate_range_cx             ! Interpolated integration of a complex array
  end interface

  interface interpolate
    !! Public interface for various interpolation routines.
    module procedure interpolate_point_re, &        ! Interpolate a scalar function from a real array to a point
                     interpolate_point_cx, &        ! Interpolate a scalar function from a complex array to a point
                     interpolate_array_re, &        ! Interpolate a scalar function from a real array to an array
                     interpolate_array_cx, &        ! Interpolate a scalar function from a complex array to an array
                     interpolate_point_matrix_re    ! Interpolate a matrix function from a real array array to a point
  end interface

  interface linspace
    !! Public interface for routines that initialize arrays.
    module procedure linspace_array_re              ! Linearly spaced real numbers
  end interface

end module


MODULE Meltingmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_melting(jul, &
        Tmf, &
        DKmax, &
        Kmin, &
        tavg, &
        M)
        IMPLICIT NONE
        INTEGER, INTENT(IN) :: jul
        REAL, INTENT(IN) :: Tmf
        REAL, INTENT(IN) :: DKmax
        REAL, INTENT(IN) :: Kmin
        REAL, INTENT(IN) :: tavg
        REAL, INTENT(OUT) :: M
        REAL:: K
        !- Name: Melting -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: snow in the process of melting
    !            * Author: STICS
    !            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    !            * Institution: INRA
    !            * Abstract: It simulates snow in the process of melting
        !- inputs:
    !            * name: jul
    !                          ** description : current day of year for the calculation
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !                          ** datatype : INT
    !                          ** default : 0
    !                          ** min : 0
    !                          ** max : 366
    !                          ** unit : d
    !                          ** uri :
    !            * name: Tmf
    !                          ** description : threshold temperature for snow melting
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.5
    !                          ** min : 0.0
    !                          ** max : 1.0
    !                          ** unit : degC
    !                          ** uri :
    !            * name: DKmax
    !                          ** description : difference between the maximum and the minimum melting rates
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : mmW/degC/d
    !                          ** uri :
    !            * name: Kmin
    !                          ** description : minimum melting rate on 21 December
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : mmW/degC/d
    !                          ** uri :
    !            * name: tavg
    !                          ** description : average temperature
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 100.0
    !                          ** unit : degC
    !                          ** uri :
        !- outputs:
    !            * name: M
    !                          ** description : snow in the process of melting
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : mmW/d
    !                          ** uri :
        M = 0.0
        K = DKmax / 2.0 * (-SIN((2.0 * 3.14159265 * REAL(jul) / 366.0 + (9.0  &
                / 16.0 * 3.14159265)))) + Kmin + (DKmax / 2.0)
        IF(tavg .GT. Tmf) THEN
            M = K * (tavg - Tmf)
        END IF
    END SUBROUTINE model_melting

END MODULE


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of DBLE()
module ft_data
  integer nx, ny, nz
  parameter (nx=64, ny=64, nz=64, maxdim=64)
  double precision ntotal_f
  parameter (ntotal_f =  dble(nx)*ny*nz)
  logical, parameter :: test_dble_1 = ntotal_f == real(nx*ny*nz, kind(0.0D0))
  logical, parameter :: test_dble_2 = kind(dble(nx)) == kind(0.0D0)
end module ft_data


C AREBENCH.F - Gateway function to generate the benchmark examples
C             for algebraic Riccati equations using SLICOT routines
C             BB01AD, for continuous-time case, and BB02AD, for
C             discrete-time case.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [X,A,G,Q(,B,C)(,S)(,parval)] = arebench(dico,nr1,nr2 ...
C                                           (,flag,param,opt,filnam))
C
C Purpose:
C   To generate benchmark examples for continuous-time algebraic
C   Riccati equations (CARE)
C
C     0  =  Q + A'X + XA - XGX,
C
C   where A,G,Q,X are real N-by-N matrices, Q and G are symmetric and
C   may be given in factored form
C                   -1 T                         T
C      (I)   G = B R  B  ,           (II)   Q = C W C ,
C   where C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W
C   and R are symmetric,
C
C   or
C
C   to generate benchmark examples for the discrete-time algebraic
C   Riccati equations (DARE)
C            T            T               T    -1  T       T
C     0  =  A X A - X - (A X B + S) (R + B X B)  (B X A + S ) + Q,
C
C   where the matrices Q and R are symmetric and Q may be given in
C   factored form (II).
C   If R is nonsingular and S = 0, the DARE can be rewritten as
C                  T             -1
C     0  =  X  -  A X (I_n + G X)  A  -  Q,
C
C   where I_n is the N-by-N identity matrix and G is factored as in (I).
C
C Input parameters:
C   dico   - integer option to indicate continuous- or discrete-time:
C            = 1 : continuous-time example.
C            = 2 : discrete-time example.
C   nr1    - the group of examples:
C            = 1 : parameter-free problems of fixed size.
C            = 2 : parameter-dependent problems of fixed size.
C            = 3 : parameter-free problems of scalable size.
C            = 4 : parameter-dependent problems of scalable size.
C   nr2    - the number of the example in group nr1.
C            Let NEXi be the number of examples in group i. Currently,
C            NEX1 =  6, NEX2 = 9, NEX3 = 2, NEX4 = 4, for
C                                                     continuous-time,
C            NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1, for discrete-time.
C            1 <= nr1 <= 4;
C            1 <= nr2 <= NEXi , where i = nr1.
C   flag   - (optional) vector containing options:
C               flag(1) = 1  : G is returned.
C               flag(1) = 0  : G is returned in factored form, i.e.,
C                              B and R from (I) are returned.
C               flag(2) = 1  : Q is returned.
C               flag(2) = 0  : Q is returned in factored form, i.e.,
C                              C and W from (II) are returned.
C            If dico = 1, it has size 2; if dico = 2, it has size 3:
C               flag(3) = 1  : The coefficient matrix S of the DARE
C                              is returned in array S.
C               flag(3) = 0  : The coefficient matrix S of the DARE
C                              is not returned.
C   param  - (optional) real vector of parameter values:
C            = epsilon, if dico = 1, nr1 = 2;
C            = [q,r], if dico = 1, for 4.1 (i.e., nr1 = 4, nr2 = 1);
C            = [a,b,c,beta1,beta2,gamma1,gamma2], if dico = 1, for 4.2;
C            = [mu,delta,kappa], if dico = 1, nr1 = 4, nr2 = 3;
C            = epsilon, if dico = 2, nr1 = 2, nr2 = 2:4;
C            = [tau,D,K,r], if dico = 2, nr1 = 2, nr2 = 5;
C            = R, if dico = 2, nr1 = 2, nr2 = 1 or nr1 = 4, nr2 = 1;
C   opt    - (optional) integer vector for additional
C            options/parameters:
C            if dico = 1,
C            = 1, (when nr1 = 2, nr2 = 9): generates the CARE for
C                  optimal state feedback (default);
C            = 2, (when nr1 = 2, nr2 = 9): generates the
C                  Kalman filter CARE.
C            = the number of vehicles, if nr1 = 3, nr2 = 1.
C            = the order of the matrix A, for 3.2, 4.1 or 4.2.
C            = the dimension of the second-order system, i.e., the
C              order of the stiffness matrix for 4.3 or 4.4.
C            if dico = 2,
C            = the order of the output matrix A, for 4.1.
C   filnam - (optional) if nr1 = nr2 = 4 and opt differs from the
C            default dimension of the second-order system (211), a
C            character string containing the name of the data file
C            to be used.
C Output parameters:
C   X      - real symmetric solution of Riccati equation (an exact
C            solution is available for the continuous-time examples
C            1.1, 1.2, 2.1, 2.3-2.6, 3.2, and for the discrete-time
C            examples 1.1, 1.3, 1.4, 2.1, 2.3-2.5, 4.1;
C            otherwise, X is an empty array).
C   A      - real n-by-n coefficient matrix.
C   G      - real symmetric n-by-n matrix.
C            If flag(1) = 1, then a non-factored coefficient matrix G
C            of the ARE is returned.
C            If flag(1) = 0, then array G contains the
C            'control weighting matrix' R from (I).
C   Q      - real symmetric n-by-n matrix.
C            If flag(2) = 1, then a non-factored coefficient matrix Q
C            of the ARE is returned.
C            If flag(2) = 0, then array Q contains the
C            'output weighting matrix' W from (II).
C   B      - real n-by-m input matrix.
C            If flag(1) = 0, this array contains the coefficient
C            matrix B of the ARE.
C   C      - real p-by-n output matrix.
C            If flag(2) = 0, this array contains the coefficient
C            matrix C of the ARE.
C   S      - if (dico = 2, flag(3) = 1), then this array contains the
C            coefficient matrix S of the DARE.
C   parval - the values used for the problem parameters:
C            either the values given in param, or default values,
C            if param is not used.
C
C Contributor:
C   D. Sima, University of Bucharest, August 2001.
C
C Revisions:
C   V. Sima, Research Institute for Informatics, Nov. 2001, Oct. 2004,
C   Apr. 2009, Dec. 2012, May 2016, Jan. 2017.
C
C **********************************************************************
C
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxGetString, mxIsChar,
     $                  mxIsNumeric, mxIsComplex
C
C     .. Parameters ..
C     . # of examples available , # of examples with fixed size. .
      INTEGER           NEXC1, NEXC2, NEXC3, NEXC4, NEXD1, NEXD2, NEXD3,
     $                  NEXD4, NMX
      PARAMETER         ( NEXC1 =  6, NEXC2 = 9, NEXC3 = 2, NEXC4 = 4,
     $                    NEXD1 = 13, NEXD2 = 5, NEXD3 = 0, NEXD4 = 1,
     $                    NMX   = 13 )
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         DEF
      INTEGER           INFO, LDA, LDB, LDC, LDG, LDQ, LDS, LDWORK, LDX,
     $                  M, N, P
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      DOUBLE PRECISION, ALLOCATABLE :: A(:,:),   B(:,:), C(:,:),
     $                                 DWORK(:), G(:,:), Q(:,:), S(:,:),
     $                                 X(:,:)
C
C .. Local variables and constant dimension arrays ..
      LOGICAL           BPAR(7), VEC(10)
      CHARACTER*255     CHPAR
      CHARACTER*120     TEXT
      INTEGER           DICO, FLAG(3), I, IE, IP, IPAR(4), ISIZE, L,
     $                  MDEFC(2,NMX), MDEFD(2,NMX), NDEFC(4,NMX),
     $                  NDEFD(4,NMX), NEX(4), NEXC(4), NEXD(4), NR(2),
     $                  PDEFC(2,NMX), PDEFD(2,NMX)
      DOUBLE PRECISION  DPAR(7), FLAGR(3), ITMP(7), TEMP
C
C .. External functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C
C .. External subroutines ..
      EXTERNAL          BB01AD, BB02AD, DLACPY
C
C ..Intrinsic functions..
      INTRINSIC         MAX
C
C     .. Data Statements ..
C     . default values for dimensions .
      DATA (NEXC(I), I = 1, 4) /NEXC1, NEXC2, NEXC3, NEXC4/
      DATA (NEXD(I), I = 1, 4) /NEXD1, NEXD2, NEXD3, NEXD4/
      DATA (NDEFC(1,I), I = 1, NEXC1) /2, 2, 4, 8, 9, 30/
      DATA (NDEFC(2,I), I = 1, NEXC2) /2, 2, 2, 2, 2, 3, 4, 4, 55/
      DATA (NDEFC(3,I), I = 1, NEXC3) /20, 64/
      DATA (NDEFC(4,I), I = 1, NEXC4) /21, 100, 30, 211/
      DATA (MDEFC(1,I), I = 1, NEXC1) /1, 1, 2, 2, 3, 3/
      DATA (MDEFC(2,I), I = 1, NEXC2) /1, 2, 1, 2, 1, 3, 1, 1, 2/
      DATA (PDEFC(1,I), I = 1, NEXC1) /2, 2, 4, 8, 9, 5/
      DATA (PDEFC(2,I), I = 1, NEXC2) /1, 1, 2, 2, 2, 3, 2, 1, 10/
      DATA (NDEFD(1,I), I = 1, NEXD1) /2, 2, 2, 3, 4, 4, 4, 5, 6, 9,
     $                                 11, 13, 26/
      DATA (NDEFD(2,I), I = 1, NEXD2) /2, 2, 2, 3, 4/
      DATA (NDEFD(4,I), I = 1, NEXD4) /100/
      DATA (MDEFD(1,I), I = 1, NEXD1) /1, 2, 1, 2, 2, 2, 4, 2, 2, 3,
     $                                 2, 2, 6/
      DATA (MDEFD(2,I), I = 1, NEXD2) /1, 2, 1, 3, 1/
      DATA (PDEFD(1,I), I = 1, NEXD1) /1, 2, 2, 3, 4, 4, 4, 5, 2, 2,
     $                                 4, 4, 12/
      DATA (PDEFD(2,I), I = 1, NEXD2) /2, 2, 2, 3, 1/
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.3 ) THEN
         CALL mexErrMsgTxt
     $        ( 'AREBENCH requires at least 3 input arguments' )
      ELSE IF ( NRHS.GT.6  ) THEN
         CALL mexErrMsgTxt
     $        ( 'AREBENCH requires at most 6 input arguments' )
      ELSE IF ( NLHS.GT.8 ) THEN
         CALL mexErrMsgTxt
     $        ( 'AREBENCH requires at most 8 output arguments' )
      END IF
C
      DEF = 'D'
C
C Check dimensions of input parameters and read/set scalar parameters.
C
C   dico
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR. mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'DICO must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'DICO must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      DICO = TEMP
      IF ( DICO.LT.1 .OR. DICO.GT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'DICO has 1 or 2 the only admissible values' )
      END IF
C
C   nr1, nr2
C
      IF ( mxGetM( PRHS(2) ).NE.1 .OR. mxGetN( PRHS(2) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'NR1 must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'NR1 must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), TEMP, 1 )
      NR(1) = TEMP
      IF ( NR(1).LT.1 .OR. NR(1).GT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'NR1 has 1,2,3, or 4 the only admissible values' )
      END IF
      IF ( DICO.EQ.2 .AND. NR(1).EQ.3 ) THEN
         CALL mexErrMsgTxt
     $        ( 'No available examples for this section' )
      END IF
C
      IF ( DICO.EQ.1 ) THEN
          NEX(1) = NEXC1
          NEX(2) = NEXC2
          NEX(3) = NEXC3
          NEX(4) = NEXC4
      ELSE
          NEX(1) = NEXD1
          NEX(2) = NEXD2
          NEX(3) = NEXD3
          NEX(4) = NEXD4
      END IF
C
      IF ( mxGetM( PRHS(3) ).NE.1 .OR. mxGetN( PRHS(3) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'NR2 must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'NR2 must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), TEMP, 1 )
      NR(2) = TEMP
      IF ( NR(2).LT.1 .OR. NR(2).GT.NEX(NR(1)) ) THEN
         WRITE( TEXT, '( " NR2 has 1..", I4,
     $          " the only admisible values" )' ) NEX(NR(1))
         CALL mexErrMsgTxt ( TEXT )
      END IF
C
C   flag
C
      DO 10 I = 1, 7
         BPAR(I) = .TRUE.
   10 CONTINUE
      IP = 3
      IF ( NRHS.GT.IP ) THEN
        IP = IP + 1
        ISIZE = mxGetM( PRHS(IP) ) * mxGetN( PRHS(IP) )
        IF ( DICO.EQ.1 ) THEN
           IF ( ISIZE.NE.2 ) THEN
              CALL mexErrMsgTxt
     $              ( 'FLAG must be a vector with 2 elements' )
           END IF
        ELSE
           IF ( ISIZE.NE.3 ) THEN
              CALL mexErrMsgTxt
     $              ( 'FLAG must be a vector with 3 elements' )
           END IF
        END IF
        IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $       mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
           CALL mexErrMsgTxt( 'FLAG must be a real vector' )
        END IF
        CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), FLAGR, ISIZE )
        FLAG = FLAGR
C
        IF ( DICO.EQ.1 ) THEN
           IF ( FLAG(1).EQ.0 )
     $        BPAR(1) = .FALSE.
           IF ( FLAG(2).EQ.0 )
     $        BPAR(4) = .FALSE.
        ELSE
           IF ( FLAG(1).EQ.0 )
     $        BPAR(4) = .FALSE.
           IF ( FLAG(2).EQ.0 )
     $        BPAR(1) = .FALSE.
           IF ( FLAG(3).EQ.0 )
     $        BPAR(7) = .FALSE.
        END IF
      END IF
C
C  param
C
      IF ( NRHS.GT.IP .AND. ( NR(1).NE.4 .OR. NR(2).NE.4 ) ) THEN
        IP = IP + 1
        IF ( mxGetM( PRHS(IP) ).NE.0 .AND. mxGetN( PRHS(IP) ).NE.0 )
     $  THEN
           L = 0
           IF ( DICO.EQ.1 ) THEN
              IF ( NR(1).EQ.2 ) THEN
                 L = 1
              ELSE IF ( NR(1).EQ.4 ) THEN
                 IF ( NR(2).EQ.1 ) THEN
                    L = 2
                 ELSE IF ( NR(2).EQ.2 ) THEN
                    L = 7
                 ELSE IF ( NR(2).EQ.3 ) THEN
                    L = 3
                 END IF
              END IF
           ELSE IF ( ( NR(1).EQ.2 .AND. NR(2).LE.4 ) .OR.
     $               ( NR(1).EQ.4 .AND. NR(2).EQ.1 ) ) THEN
              L = 1
           ELSE IF ( NR(1).EQ.2 .AND. NR(2).EQ.5 ) THEN
              L = 4
           END IF
           IF ( L.NE.0 ) THEN
              IF ( mxGetM( PRHS(IP) )*mxGetN( PRHS(IP) ).NE.L ) THEN
                 WRITE( TEXT,
     $                 '(''PARAM must be a vector of length '', I2)') L
                 CALL mexErrMsgTxt( TEXT )
              END IF
              IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $             mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
                 CALL mexErrMsgTxt( 'PARAM must be a real vector' )
              END IF
              CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), DPAR, L )
           ELSE
              CALL mexErrMsgTxt
     $             ( 'PARAM must not be used for this example' )
           END IF
        ELSE
           IF ( NRHS.EQ.IP )
     $        CALL mexErrMsgTxt( 'PARAM must be a real vector' )
        END IF
      END IF
C
C opt
C
      IF ( NRHS.GT.IP ) THEN
        IP = IP + 1
        IF ( mxGetM( PRHS(IP) ).NE.0 .AND. mxGetN( PRHS(IP) ).NE.0 )
     $  THEN
           L = 0
           IF ( DICO.EQ.1 ) THEN
              IF ( NR(1).EQ.2 .AND. NR(2).EQ.9 ) THEN
                 L = 2
              ELSE IF ( NR(1).EQ.3 .AND. NR(2).LE.2 .OR.
     $                  NR(1).EQ.4 .AND. NR(2).LE.4 ) THEN
                 L = 1
              END IF
           ELSE IF ( NR(1).EQ.4 .AND. NR(2).EQ.1 ) THEN
              L = 1
           END IF
           IF ( L.NE.0 ) THEN
              IF ( mxGetM( PRHS(IP) ).NE.1 .OR.
     $             mxGetN( PRHS(IP) ).NE.1 ) THEN
                 CALL mexErrMsgTxt( 'OPT must be a scalar' )
              END IF
              IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $             mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
                 CALL mexErrMsgTxt( 'OPT must be an integer scalar' )
              END IF
              CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, 1 )
              IPAR(1) = TEMP
              IF ( L.EQ.2 .AND. IPAR(1).NE.1 .AND. IPAR(1).NE.2 ) THEN
                 CALL mexErrMsgTxt
     $               ( 'OPT has 1 and 2 the only admissible values' )
              END IF
              IF ( NR(1).EQ.4 .AND. NR(2).EQ.4 .AND.
     $             IPAR(1).NE.NDEFC(4,4) ) THEN
C
C                Specify the file name; if it is '', the default name
C                is used.
C
                 IF ( NRHS.GT.IP ) THEN
                    IP = IP + 1
                    IF ( mxIsChar( PRHS(IP) ).NE.1 )
     $                 CALL mexErrMsgTxt( 'File name must be a string' )
                    L = mxGetN( PRHS(IP) )
                    IF ( L.EQ.0 ) THEN
                       CALL mexPrintf( 'Default file name is used' )
                       WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01',
     $                                      NR(1), '0', NR(2) , '.dat'
                       IPAR(4) = 11
                    ELSE
                       IE = mxGetString( PRHS(IP), CHPAR, L )
                       IF ( IE.NE.0 )
     $                    CALL mexErrMsgTxt
     $                               ( 'File name must be a string' )
                       IPAR(4) = L
                    END IF
                 ELSE
                    WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01',
     $                                   NR(1), '0', NR(2) , '.dat'
                    IPAR(4) = 11
                 END IF
              END IF
           ELSE
              CALL mexErrMsgTxt
     $             ( 'OPT must not be used for this example' )
           END IF
        ELSE
           CALL mexErrMsgTxt( 'OPT must be an integer scalar' )
        END IF
      END IF
C
      IF ( IP.GT.4 )
     $   DEF = 'N'
C
C Determine array dimensions.
C
      IF ( DICO.EQ.1 ) THEN
         N = NDEFC( NR(1), NR(2) )
         IF ( NR(1).LE.2  ) THEN
            M = MDEFC( NR(1), NR(2) )
            P = PDEFC( NR(1), NR(2) )
         ELSE
            IF ( NR(1).EQ.3 ) THEN
               IF ( NR(2).EQ.1 ) THEN
                  IF ( LSAME( DEF, 'D' ) ) THEN
                     M = N
                     P = N - 1
                     N = 2*N - 1
                  ELSE
                     M = IPAR(1)
                     P = IPAR(1) - 1
                     N = 2*IPAR(1) - 1
                  END IF
               ELSE IF ( NR(2).EQ.2 ) THEN
                  IF ( LSAME( DEF, 'N' ) )
     $               N = IPAR(1)
                  M = N
                  P = N
               END IF
            ELSE IF ( NR(1).EQ.4 ) THEN
               IF ( NR(2).LE.2 ) THEN
                  IF ( LSAME( DEF, 'N' ) )
     $               N = IPAR(1)
                  M = 1
                  P = 1
               ELSE IF ( NR(2).EQ.3 ) THEN
                  IF ( LSAME( DEF, 'D' ) ) THEN
                     N = 2*N
                     M = 2
                     P = N
                  ELSE
                     N = 2*IPAR(1)
                     M = 2
                     P = N
                  END IF
               ELSE IF ( NR(2).EQ.4 ) THEN
                  IF ( LSAME( DEF, 'D' ) ) THEN
                     M = N
                     P = N
                     N = 2*N - 1
                  ELSE
                     N = 2*IPAR(1) - 1
                     M = IPAR(1)
                     P = IPAR(1)
                  END IF
               END IF
            END IF
         END IF
      ELSE
         N = NDEFD( NR(1), NR(2) )
         IF ( NR(1).LE.2 ) THEN
            M = MDEFD( NR(1), NR(2) )
            P = PDEFD( NR(1), NR(2) )
         ELSE IF ( NR(1).EQ.4 ) THEN
            IF ( NR(2).EQ.1 ) THEN
               IF ( LSAME( DEF, 'D' ) ) THEN
                  N = 100
               ELSE
                  N = IPAR(1)
               END IF
               M = 1
               P = N
            END IF
         END IF
      END IF
C
C Determine the lengths of working arrays.
C
      LDA = N
      LDG = LDA
      LDQ = LDA
      LDB = LDA
      LDC = P
      LDX = LDA
C
      IF ( DICO.EQ.1 ) THEN
         LDWORK = N*MAX( 4, N )
      ELSE
         LDS = LDA
         IF ( .NOT.BPAR(4) ) LDG = M
         IF ( .NOT.BPAR(1) ) LDQ = P
         LDWORK = N*N
      END IF
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE( A(LDA,N), B(LDB,M), C(LDC,N), G(LDG,N), Q(LDQ,N),
     $          X(LDX,N), DWORK(LDWORK) )
      IF ( DICO.EQ.2 )
     $   ALLOCATE( S(LDS,M) )
C
C Do the actual computations.
C
      IF ( DICO.EQ.1 ) THEN
         CALL BB01AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P,
     $                A, LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX,
     $                DWORK, LDWORK, INFO )
      ELSE
         CALL BB02AD( DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P,
     $                A, LDA, B, LDB, C, LDC, Q, LDQ, G, LDG, S, LDS,
     $                X, LDX, DWORK, LDWORK, INFO )
      END IF
C
C Copy output to MATLAB workspace.
C
      IF ( INFO.EQ.0 ) THEN
         CALL mexPrintf( CHPAR )
         IF ( NLHS.GE.1 ) THEN
            IF ( ( DICO.EQ.1 .AND. VEC(9) ) .OR.
     $           ( DICO.EQ.2 .AND. VEC(10) ) ) THEN
               PLHS(1) = mxCreateDoubleMatrix( N, N, 0 )
               CALL mxCopyReal8ToPtr( X, mxGetPr( PLHS(1) ), N*N )
            ELSE
               PLHS(1) = mxCreateDoubleMatrix( 0, 0, 0 )
            END IF
         END IF
         IF ( NLHS.GE.2 ) THEN
            PLHS(2) = mxCreateDoubleMatrix( N, N, 0 )
            CALL mxCopyReal8ToPtr( A, mxGetPr( PLHS(2) ), N*N )
         END IF
         IF ( NLHS.GE.3 ) THEN
            IF ( FLAG(1).EQ.1 ) THEN
               PLHS(3) = mxCreateDoubleMatrix( N, N, 0 )
               CALL mxCopyReal8ToPtr( G, mxGetPr( PLHS(3) ), N*N )
            ELSE
               IF ( M.LT.LDG )
     $            CALL DLACPY( 'Full', M, M, G, LDG, G, M )
               PLHS(3) = mxCreateDoubleMatrix( M, M, 0 )
               CALL mxCopyReal8ToPtr( G, mxGetPr( PLHS(3) ), M*M )
            END IF
         END IF
         IF ( NLHS.GE.4 ) THEN
            IF ( FLAG(2).EQ.1 ) THEN
               PLHS(4) = mxCreateDoubleMatrix( N, N, 0 )
               CALL mxCopyReal8ToPtr( Q, mxGetPr( PLHS(4) ), N*N )
            ELSE
               IF ( P.LT.LDQ )
     $            CALL DLACPY( 'Full', P, P, Q, LDQ, Q, P )
               PLHS(4) = mxCreateDoubleMatrix( P, P, 0 )
               CALL mxCopyReal8ToPtr( Q, mxGetPr( PLHS(4) ), P*P )
            END IF
         END IF
         IP = 5
         IF ( ( NLHS.GE.IP ) .AND. ( FLAG(1).EQ.0 ) ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( N, M, 0 )
            CALL mxCopyReal8ToPtr( B, mxGetPr( PLHS(IP) ), N*M )
            IP = IP + 1
         END IF
         IF ( ( NLHS.GE.IP ) .AND. ( FLAG(2).EQ.0 ) ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( P, N, 0 )
            CALL mxCopyReal8ToPtr( C, mxGetPr( PLHS(IP) ), N*P )
            IP = IP + 1
         END IF
         IF ( NLHS.GE.IP .AND. DICO.EQ.2 .AND. BPAR(7) ) THEN
            PLHS(IP) = mxCreateDoubleMatrix( N, M, 0 )
            CALL mxCopyReal8ToPtr( S, mxGetPr( PLHS(IP) ), N*M )
            IP = IP + 1
         END IF
         IF ( NLHS.GE.IP ) THEN
            IF ( DICO.EQ.1 ) THEN
               PLHS(IP) = mxCreateDoubleMatrix( 7, 1, 0 )
               CALL mxCopyReal8ToPtr( DPAR, mxGetPr( PLHS(IP) ), 7 )
            ELSE
               PLHS(IP) = mxCreateDoubleMatrix( 4, 1, 0 )
               CALL mxCopyReal8ToPtr( DPAR, mxGetPr( PLHS(IP) ), 4 )
            END IF
         END IF
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      DEALLOCATE( A, B, C, G, Q, X, DWORK )
      IF ( DICO.EQ.2 )
     $   DEALLOCATE( S )
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         IF ( DICO.EQ.1 ) THEN
            WRITE( TEXT,'( " INFO = ", I4, " ON EXIT FROM BB01AD" )' )
     $             INFO
         ELSE
            WRITE( TEXT,'( " INFO = ", I4, " ON EXIT FROM BB02AD" )' )
     $             INFO
         END IF
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C
C *** Last line of AREBENCH ***
      END


! =============================================================================
!                       Test Jacobi diagonalisation
!
!               This unit test checks the eigenvalue solver.
! =============================================================================
program test_jacobi_1
    use unit_test
    use constants, only : zero
    use jacobi
    implicit none

    double precision     :: error
    integer              :: n, k, sk
    logical              :: valid
    double precision     :: V(3, 3)
    double precision     :: B(3, 3), D(3)
    double precision     :: Q(3, 3), EV(3) ! reference
    integer, allocatable :: seed(:)

    call random_seed(size=sk)
    allocate(seed(1:sk))
    seed(:) = 42
    call random_seed(put=seed)

    error = zero

    n = 1
    do while (n <= 100000)

        call create_symmetric_matrix

        if (valid) then
            n = n + 1

            call jacobi_diagonalise(B, D, V)

            ! check eigenvalues
            error = max(error, dabs(EV(1) - D(1)) &
                             + dabs(EV(2) - D(2)) &
                             + dabs(EV(3) - D(3)))

            ! check eigenvectors
            do k = 1, 3
                if (Q(1, k) / V(1, k) < zero) then
                    ! opposite sign
                    Q(:, k) = - Q(:, k)
                endif
                error = max(error, sum(dabs(Q(:, k) - V(:, k))))
            enddo
        endif
    enddo

    call print_result_dp('Test Jacobi 1', error, atol=dble(1.0e-9))

    contains

        subroutine create_symmetric_matrix
            integer          :: i, j
            double precision :: rndm(3, 3), val
            double precision :: tmp

            ! random eigenvalue
            do j = 1, 3
                call random_number(tmp)
                EV(j) = 2.0d0 * tmp
            enddo

            ! sort
            if (EV(1) < EV(2)) then
                tmp = EV(1)
                EV(1) = EV(2)
                EV(2) = tmp
            endif

            if (EV(2) < EV(3)) then
                tmp = EV(2)
                EV(2) = EV(3)
                EV(3) = tmp
            endif

            if (EV(1) < EV(2)) then
                tmp = EV(1)
                EV(1) = EV(2)
                EV(2) = tmp
            endif

            ! Create orthogonal vectors using Gram-Schmidt orthogonalization
            ! (https://de.wikipedia.org/wiki/Gram-Schmidtsches_Orthogonalisierungsverfahren)
            do i = 1, 3
                do j = 1, 3
                    call random_number(val)
                    rndm(i, j) = 10.0d0 * val
                enddo
            enddo

            Q = 0.0d0

            do j = 1, 3
                Q(:, j) = rndm(:, j)
                do i = 1, j - 1
                    Q(:, j) = Q(:, j) &
                            - Q(:, i) * dot_product(Q(:, i), rndm(:, j)) &
                                      / dot_product(Q(:, i), Q(:, i))
                enddo
                Q(:, j) = Q(:, j) / norm2(Q(:, j))
            enddo

            ! Check orthogonalization error:
            val = dabs(dot_product(Q(:, 1), Q(:, 2))) &
                + dabs(dot_product(Q(:, 1), Q(:, 3))) &
                + dabs(dot_product(Q(:, 2), Q(:, 3)))

            valid = (val < 1.0e-13)
            if (.not. valid) then
                return
            endif

            ! Create symmetric B matrix
            B = 0.0d0
            do i = 1, 3
                do j = 1, 3
                    do k = 1, 3
                        B(i, j) = B(i, j) + Q(i, k) * EV(k) * Q(j, k)
                    enddo
                enddo
            enddo
        end subroutine create_symmetric_matrix

end program test_jacobi_1


! BSD 3-Clause License
!
! Copyright (c) 2020, Fabio Durastante
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
submodule (psfun_utils_mod) psfun_z_utils_mod
  !! Complex variants of the utils functions
  use psb_base_mod
  implicit none

  complex, parameter :: iunit = cmplx(0.0_psb_dpk_,1.0_psb_dpk_)

contains

  recursive module subroutine z_ellipj(u,L,sn,cn,dn,flag)
    !! Returns the values of the Jacobi elliptic functions evaluated at double
    !! argument u and parameter \(M = \exp(-2 \pi L)\), \(0 < L < \infty\).
    !! For \(M = K^2\), and \(K\) the elliptic modulus.
    !
    complex(psb_dpk_), intent(in)    :: u
    real(psb_dpk_), intent(in)       :: L
    complex(psb_dpk_), intent(out)   :: sn,cn,dn
    logical, optional, intent(in)    :: flag

    real(psb_dpk_)      :: m,K(2),kappa,mu
    complex(psb_dpk_)   :: ucp, sinu, cosu, v, sn1, cn1, dn1, denom, snh, cnh, dnh
    logical             :: flag_, high
    real(psb_dpk_), parameter :: coeffs(7) = (/0.0,1.0,2.0,5.0,14.0,42.0,132.0/)

    ucp = u

    if( present(flag) ) then
      flag_ = flag
    else
      flag_ = .true.
    end if

    if(flag_) then
      K = ellipkkp(L)
      high = (aimag(ucp) > K(2)/2.0_psb_dpk_ )
      if (high) then
        ucp = iunit*K(2) - ucp
      end if
      m = exp(-2.0_psb_dpk_*DPI*L)
    else
      ! In case of recursive call we have already transformed L into m
      high = .false.
      m = L
    endif

    if (m < 4.0_psb_dpk_*EPSILON(m) ) then
      sinu = sin(u);
      cosu = cos(u);
      sn = sinu + m/4.0_psb_dpk_*( sinu*cosu-u)*cosu;
      cn = cosu + m/4.0_psb_dpk_*(-sinu*cosu+u)*sinu;
      dn = 1    + m/4.0_psb_dpk_*( cosu**2 -sinu**2-1.0_psb_dpk_);
    else
      if( m > 1e-3) then
        kappa = (1.0_psb_dpk_-sqrt(1.0_psb_dpk_-m))/(1.0_psb_dpk_+sqrt(1.0_psb_dpk_-m))
      else
        kappa = horner( coeffs , m/4.0_psb_dpk_ )
      end if
      mu = kappa**2
      v = u/(1.0_psb_dpk_ + kappa)
      call z_ellipj(v,mu,sn1,cn1,dn1,.false.)
      denom = (1.0_psb_dpk_ + kappa*sn1**2)
      sn = (1+kappa)*sn1/denom
      cn = cn1*dn1/denom
      dn = (1-kappa*sn1**2)/denom
    end if

    if(high) then
      snh = sn
      cnh = cn
      dnh = dn
      sn = -1.0_psb_dpk_/(sqrt(m)*snh)
      cn = iunit*dnh/(sqrt(m)*snh)
      dn = iunit*cnh/snh
    endif

    return

  end subroutine

end submodule


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MFibonacci

    implicit none
    private

    type, public :: TFibonacci
    contains
        procedure, nopass :: fibonacci => fibonacciRecursive

        procedure, nopass :: fibonacciRecursive
        procedure, nopass :: fibonacciIterate
    end type
contains
    recursive function fibonacciRecursive(position) result(fibonacci)
        integer, intent(in) :: position
        integer :: fibonacci

        if (position <= 2) then
            fibonacci = 1
            return
        end if

        fibonacci = fibonacciRecursive(position - 1) + fibonacciRecursive(position - 2)
    end function

    function fibonacciIterate(position) result(fibonacci)
        integer, intent(in) :: position
        integer :: fibonacci

        integer, dimension(10), save :: buffer
        integer, save                :: index  = 3
        buffer(1) = 1
        buffer(2) = 1

        if (buffer(position) == 0) then
            do index = index, position
                buffer(index) = buffer(index - 1) + buffer(index - 2)
            end do
        end if

        fibonacci = buffer(position)
    end function
end module


! This program calculates permutations for passwords with varying lengths & complexities
! This is designed to show the security of length over complexity
!
! Author: Josh McIntyre
!

! Define data parameters in a module
MODULE pass_data

    ! Constant declarations for character spaces and lengths
    INTEGER, PARAMETER::ASIZE = 7

    ! numerical (10), lowercase, upper lower, upper lower numerical (62), various amounts of symbols
    REAL, DIMENSION(ASIZE), PARAMETER::COMPLEXITIES = (/ 10, 26, 52, 62, 72, 82, 92 /)
    REAL, PARAMETER::LENGTH_SAMPLE = 8

    ! Lengths of the password in characters
    REAL, DIMENSION(ASIZE), PARAMETER::LENGTHS = (/ 8, 9, 10, 12, 14, 16, 20 /)
    REAL, PARAMETER::COMPLEXITY_SAMPLE = 62

    ! Password cracking constants
    ! 180 billion (giga) hashes per second - professional 25 GPU cluster, MD5 algorithm
    ! 7.652 billion (giga) hashes per second - consumer laptop with Nvidia GeForce 1050 Ti GPU
    REAL, PARAMETER::HASHPOWER_PRO = 180000000000.0
    REAL, PARAMETER::HASHPOWER_LAPTOP = 7652000000.0
    REAL, PARAMETER::SECONDS_PER_MINUTE = 60.0
    REAL, PARAMETER::SECONDS_PER_HOUR = 3600.0
    REAL, PARAMETER::SECONDS_PER_DAY = 86400.0
    REAL, PARAMETER::SECONDS_PER_YEAR = 31557600.0

    ! Output constants
    INTEGER, PARAMETER::HSIZE = 100

    CHARACTER(HSIZE), PARAMETER::COMPLEXITIES_LABEL = "Combinations for constant length 8, variable complexity"
    CHARACTER(HSIZE), PARAMETER::COMPLEXITIES_HEADER = "Complexity           Combinations            Crack Time"

    CHARACTER(HSIZE), PARAMETER::CRACKTIME_LABEL_PRO = "Cracking w/ 180 GH/s, MD5 - 25 GPU professional cluster"
    CHARACTER(HSIZE), PARAMETER::CRACKTIME_LABEL_LAPTOP = "Cracking w/ 7.652 GH/s, MD5 - NVidia GeForce 1050 Ti consumer laptop"

    CHARACTER(HSIZE), PARAMETER::LENGTHS_LABEL = "Combinations for constant complexity 62, variable length"
    CHARACTER(HSIZE), PARAMETER::LENGTHS_HEADER = "Length           Combinations            Crack Time"

END MODULE

! This is the main entry point for the program
PROGRAM passperms

    ! Data declarations for command line args
    USE pass_data

    IMPLICIT NONE
    CHARACTER(15)::flag, flag2

    ! Data declarations for calculations and results
    REAL(8), DIMENSION(ASIZE)::results, times
    CHARACTER(HSIZE)::cracktime_label

    ! Calculate and output just the permutations with no guess time specified
    ! Otherwise, calculate and output the crack time matrix
    IF (IARGC() == 1 .OR. IARGC() == 2) THEN

        ! Fetch arguments
        CALL getarg(1, flag)
        CALL getarg(2, flag2)
        IF (flag == "-h" .OR. flag == "--help") THEN
            CALL output_help()
        ELSE IF (flag == "-c" .OR. flag == "--complexities") THEN
            CALL calc_complexities(results)
            IF (flag2 == "-f" .OR. flag2 == "--fast") THEN
                CALL calc_times(results, HASHPOWER_LAPTOP, times)
                cracktime_label = CRACKTIME_LABEL_PRO
            ELSE
                ! Default to consumer laptop cracking time
                CALL calc_times(results, HASHPOWER_PRO, times)
                cracktime_label = CRACKTIME_LABEL_LAPTOP
            END IF
            CALL output_results(COMPLEXITIES_LABEL, cracktime_label, COMPLEXITIES_HEADER, COMPLEXITIES, results, times)
        ELSE IF (flag == "-l" .OR. flag == "--lengths") THEN
            CALL calc_lengths(results)
            IF (flag2 == "-f" .OR. flag2 == "--fast") THEN
                CALL calc_times(results, HASHPOWER_LAPTOP, times)
                cracktime_label = CRACKTIME_LABEL_PRO
            ELSE
                ! Default to consumer laptop cracking time
                CALL calc_times(results, HASHPOWER_PRO, times)
                cracktime_label = CRACKTIME_LABEL_LAPTOP
            END IF
            CALL output_results(LENGTHS_LABEL, cracktime_label, LENGTHS_HEADER, LENGTHS, results, times)
        END IF
    ELSE
        CALL output_help()
    END IF

END PROGRAM

! This subroutine calculates the results array for the given complexity (character space)
! It will calculate an entry for each complexity space to the sample-length power
SUBROUTINE calc_complexities(results)

    ! Declare function params and returns, and data
    USE pass_data

    IMPLICIT none
    REAL(8), DIMENSION(ASIZE), INTENT(OUT)::results

    ! Can just use array per-element shorthand here
    results = COMPLEXITIES ** LENGTH_SAMPLE

    RETURN
END SUBROUTINE calc_complexities

! This subroutine calculates the results array for the given lengths
! It will calculate an entry for one sample-complexity to the length power
SUBROUTINE calc_lengths(results)

    ! Declare function params and returns, and data
    USE pass_data

    IMPLICIT none
    REAL(8), DIMENSION(ASIZE), INTENT(OUT)::results

    INTEGER::i

    ! Loop on each element and exponentiate; array shorthand does not work in reverse
    DO i = 1, ASIZE, 1
        results(i) = COMPLEXITY_SAMPLE ** LENGTHS(i)
    END DO

    RETURN
END SUBROUTINE calc_lengths

! This subroutine will calculate cracking times for a given result set and hashing power
SUBROUTINE calc_times(results, hash, times)

    ! Declare function params and returns, and data
    USE pass_data

    IMPLICIT none
    REAL(8), DIMENSION(ASIZE), INTENT(IN)::results
    REAL, INTENT(IN)::hash
    REAL(8), DIMENSION(ASIZE), INTENT(OUT)::times

    REAL::optime

    ! Calculate the time per one operation, based on Gigahashes per second
    optime = 1.0 / hash

    ! Calculate times per element
    times = results * optime

    RETURN
END SUBROUTINE calc_times

! This subroutine outputs the results of the calculations
SUBROUTINE output_results(label, cracktime_label, header, bases, results, times)

    ! Declare function params and returns, and data
    USE pass_data

    IMPLICIT none
    CHARACTER(HSIZE), INTENT(IN)::label, cracktime_label, header
    REAL, DIMENSION(ASIZE), INTENT(IN)::bases
    REAL(8), DIMENSION(ASIZE), INTENT(IN)::results, times

    INTEGER::i

    WRITE(*, *) label
    WRITE(*, *) cracktime_label
    WRITE(*, *) header

    DO i = 1, ASIZE, 1

        IF (times(i) .LE. SECONDS_PER_MINUTE) THEN
            WRITE(*, 100) bases(i), results(i), times(i)
            100 FORMAT(3x, F3.0, 5x, ES20.0, F20.5, " seconds")
        ELSE IF (times(i) .LE. SECONDS_PER_HOUR) THEN
            WRITE(*, 200) bases(i), results(i), times(i) / SECONDS_PER_MINUTE
            200 FORMAT(3x, F3.0, 5x, ES20.0, F20.5, " minutes")
        ELSE IF (times(i) .LE. SECONDS_PER_DAY) THEN
            WRITE(*, 300) bases(i), results(i), times(i) / SECONDS_PER_HOUR
            300 FORMAT(3x, F3.0, 5x, ES20.0, F20.5, " hours")
        ELSE IF (times(i) .LE. SECONDS_PER_YEAR) THEN
            WRITE(*, 400) bases(i), results(i), times(i) / SECONDS_PER_DAY
            400 FORMAT(3x, F3.0, 5x, ES20.0, F20.5, " days")
        ELSE IF (times(i) .LE. SECONDS_PER_YEAR * 10000) THEN
            WRITE(*, 500) bases(i), results(i), times(i) / SECONDS_PER_YEAR
            500 FORMAT(3x, F3.0, 5x, ES20.0, F20.5, " years")
        ELSE
            WRITE(*, 600) bases(i), results(i), times(i) / SECONDS_PER_YEAR
            600 FORMAT(3x, F3.0, 5x, ES20.0, ES20.5, " years")
        END IF

    END DO

    RETURN
END SUBROUTINE output_results

! This subroutine prints a help message
SUBROUTINE output_help()
    WRITE(*, *) "Usage: ./passperms [-p/--perms] [-h/--help] "
    WRITE(*, *) "-c/--complexities - Show the number of possible permutations for a constant length and variable complexities"
    WRITE(*, *) "-l/--lengths - Show the number of possible permutations for a constant complexity and variable lengths"
    WRITE(*, *) "-f/--fast - Show professional grade crack times (180 GH/s, MD5) 25 GPU cluster"
    WRITE(*, *) "-r/--regular - Show consumer grade crack times (7.652 GH/s, MD5) Nvidia GeForce 1050 Ti"
    WRITE(*, *) "-h/--help - Show this help message"

    STOP
END SUBROUTINE output_help


! RUN: bbc %s -o - | FileCheck %s

! Test real add on real kinds.

! CHECK-LABEL: real2
REAL(2) FUNCTION real2(x0, x1)
  REAL(2) :: x0
  REAL(2) :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f16>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f16>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f16
  real2 = x0 + x1
  ! CHECK: return %{{.*}} : f16
END FUNCTION real2

! CHECK-LABEL: real3
REAL(3) FUNCTION real3(x0, x1)
  REAL(3) :: x0
  REAL(3) :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<bf16>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<bf16>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : bf16
  real3 = x0 + x1
  ! CHECK: return %{{.*}} : bf16
END FUNCTION real3

! CHECK-LABEL: real4
REAL(4) FUNCTION real4(x0, x1)
  REAL(4) :: x0
  REAL(4) :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f32>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f32>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f32
  real4 = x0 + x1
  ! CHECK: return %{{.*}} : f32
END FUNCTION real4

! CHECK-LABEL: defreal
REAL FUNCTION defreal(x0, x1)
  REAL :: x0
  REAL :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f32>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f32>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f32
  defreal = x0 + x1
  ! CHECK: return %{{.*}} : f32
END FUNCTION defreal

! CHECK-LABEL: real8
REAL(8) FUNCTION real8(x0, x1)
  REAL(8) :: x0
  REAL(8) :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f64>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f64>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f64
  real8 = x0 + x1
  ! CHECK: return %{{.*}} : f64
END FUNCTION real8

! CHECK-LABEL: doubleprec
DOUBLE PRECISION FUNCTION doubleprec(x0, x1)
  DOUBLE PRECISION :: x0
  DOUBLE PRECISION :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f64>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f64>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f64
  doubleprec = x0 + x1
  ! CHECK: return %{{.*}} : f64
END FUNCTION doubleprec

! CHECK-LABEL: real10
REAL(10) FUNCTION real10(x0, x1)
  REAL(10) :: x0
  REAL(10) :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f80>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f80>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f80
  real10 = x0 + x1
  ! CHECK: return %{{.*}} : f80
END FUNCTION real10

! CHECK-LABEL: real16
REAL(16) FUNCTION real16(x0, x1)
  REAL(16) :: x0
  REAL(16) :: x1
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f128>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f128>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f128
  real16 = x0 + x1
  ! CHECK: return %{{.*}} : f128
END FUNCTION real16

! CHECK-LABEL: real16b
REAL(16) FUNCTION real16b(x0, x1)
  REAL(16) :: x0
  REAL(16) :: x1
  ! CHECK-DAG: %[[v0:.+]] = arith.constant 4.0{{.*}} : f128
  ! CHECK-DAG: %[[v1:.+]] = fir.load %arg0 : !fir.ref<f128>
  ! CHECK-DAG: %[[v2:.+]] = fir.load %arg1 : !fir.ref<f128>
  ! CHECK: %[[v3:.+]] = arith.addf %[[v1]], %[[v2]] : f128
  ! CHECK: %[[v4:.+]] = arith.subf %[[v3]], %[[v0]] : f128
  real16b = x0 + x1 - 4.0_16
  ! CHECK: return %{{.*}} : f128
END FUNCTION real16b


!*******************************************************************************
!   Copyright(C) 2005-2013 Intel Corporation. All Rights Reserved.
!
!   The source code, information  and  material ("Material") contained herein is
!   owned  by Intel Corporation or its suppliers or licensors, and title to such
!   Material remains  with Intel Corporation  or its suppliers or licensors. The
!   Material  contains proprietary information  of  Intel or  its  suppliers and
!   licensors. The  Material is protected by worldwide copyright laws and treaty
!   provisions. No  part  of  the  Material  may  be  used,  copied, reproduced,
!   modified, published, uploaded, posted, transmitted, distributed or disclosed
!   in any way  without Intel's  prior  express written  permission. No  license
!   under  any patent, copyright  or  other intellectual property rights  in the
!   Material  is  granted  to  or  conferred  upon  you,  either  expressly,  by
!   implication, inducement,  estoppel or  otherwise.  Any  license  under  such
!   intellectual  property  rights must  be express  and  approved  by  Intel in
!   writing.
!
!   *Third Party trademarks are the property of their respective owners.
!
!   Unless otherwise  agreed  by Intel  in writing, you may not remove  or alter
!   this  notice or  any other notice embedded  in Materials by Intel or Intel's
!   suppliers or licensors in any way.
!
!*******************************************************************************
!   Content : Intel MKL Extended Eigensolvers FORTRAN 77 example
!
!*******************************************************************************
!
! Example program for using Intel MKL Extended Eigensolvers (sparse format).
!
! The following routines are used in the example:
!          DGEMM  DFEAST_SCSREV  DFEAST_SCSRGV  FEASTINIT.
!
! Consider the matrix A
!
!                 |  5   2   1   1   0   0   0   0   0   0   0  |
!                 |  2   6   3   1   1   0   0   0   0   0   0  |
!                 |  1   3   6   3   1   1   0   0   0   0   0  |
!                 |  1   1   3   6   3   1   1   0   0   0   0  |
!                 |  0   1   1   3   6   3   1   1   0   0   0  |
!    A    =       |  0   0   1   1   3   6   3   1   1   0   0  |,
!                 |  0   0   0   1   1   3   6   3   1   1   0  |
!                 |  0   0   0   0   1   1   3   6   3   1   1  |
!                 |  0   0   0   0   0   1   1   3   6   3   1  |
!                 |  0   0   0   0   0   0   1   1   3   6   2  |
!                 |  0   0   0   0   0   0   0   1   1   2   5  |

!
! stored as a compessed sparse row  matrix (DOUBLE PRECISION).
! B is a unit matrix:
!
!                 |  1   0   0   0   0   0   0   0   0   0   0  |
!                 |  0   1   0   0   0   0   0   0   0   0   0  |
!                 |  0   0   1   0   0   0   0   0   0   0   0  |
!                 |  0   0   0   1   0   0   0   0   0   0   0  |
!                 |  0   0   0   0   1   0   0   0   0   0   0  |
!    B    =       |  0   0   0   0   0   1   0   0   0   0   0  |.
!                 |  0   0   0   0   0   0   1   0   0   0   0  |
!                 |  0   0   0   0   0   0   0   1   0   0   0  |
!                 |  0   0   0   0   0   0   0   0   1   0   0  |
!                 |  0   0   0   0   0   0   0   0   0   1   0  |
!                 |  0   0   0   0   0   0   0   0   0   0   1  |
!
!
!  In what follows the symbol ' represents a transpose operation.
!
!  The test performs the following operations :
!
!
!       1. The code calls  FEASTINIT  to define the default values for the input
!          FEAST parameters.
!
!       2. The  code  solves  the  standard eigenvalue  problem  Ax=ex   using
!          DFEAST_SCSREV.
!
!       3. The code computes the residual R(i) = | E(i) - Eig(i) |  where Eig(i)
!           are the expected eigenvalues  and E(i) are eigenvalues computed
!           with the help of DFEAST_SCSREV().
!
!       4. The code computes the maximum absolute value of the matrix  Y=(X')*X-I
!          where X is the matrix of eigenvectors computed with the help of
!          DFEAST_SCSREV. DGEMM (BLAS Level 3 Routine) is called  to compute (X')*X.
!
!       5. The  code solves  the generalized eigenvalue problem  Ax=eBx using
!          DFEAST_SCSRGV.
!
!       6. The code computes the residual R(i) = | E(i) - Eig(i) |  where Eig(i)
!           are the expected eigenvalues  and E(i) are eigenvalues computed
!           with the help of DFEAST_SCSRGV().
!
!       7. The code computes the maximum absolute value of the matrix  Y=(X')*X-I
!          where X is the matrix of eigenvectors computed with the help of
!          DFEAST_SCSREV. DGEMM (BLAS Level 3 Routine) is called  to compute (X')*X.
!
!*******************************************************************************
      program  dexample_sparse
      implicit none
!!!!!!!!!!!!!!!!! Matrix declaration variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      character*1 UPLO
      parameter   (UPLO='F')
      integer     n
      parameter   (n=11)
      real*8      val(65), valb(n)
      integer     rows(n+1), cols(65), rowsb(n+1), colsb(n)
!!!!!!!!!!!!!!!!! Declaration of FEAST variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!! E - eigenvalues, X - eigenvectors, res - residual !!!!!!!!!!!!
      integer     fpm(128)
      real*8      Emin,Emax
      real*8      epsout
      integer     loop
      integer     L
      parameter   (L=8)
      integer     M0,M,info
      real*8      E(n)
      real*8      X(n,n)
      real*8      res(n)
!!!!!!!!!!!!!!!!! Declaration of local variables !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!! Eig - exact eigenvalues, R=|E-Eig|, Y=(X')*X-I !!!!!!!!!!!!!!!
      real*8        Eig(n)
      real*8        R(n)
      real*8        Y(n,n)
      integer       i,j
      integer       ldx, ldy
      real*8        one, zero, smax, eigabs
!!!!!!!!!!!!!!!!! Exact eigenvalues in range (3.0, 7.0) !!!!!!!!!!!!!!!!!!!!!!
      Eig=0.0d0
      Eig(1)=3.17157287525381d0
      Eig(2)=4.0d0
      Eig(3)=4.0d0
      Eig(4)=4.1292484841890931d0
      Eig(5)=4.4066499006731521d0
      Eig(6)=6.0d0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!! Initialize input matrices A and B !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      do i=1, 65
         val(i)=1.0d0
      enddo
      do i=1,6
        val(7*(i+1)-2)=6.0d0
        val(7*(i+1)-1)=3.0d0
        val(7*(i+1)+4)=3.0d0
      enddo
      val(1)=5.0d0
      val(2)=2.0d0
      val(5)=2.0d0
      val(6)=6.0d0
      val(7)=3.0d0
      val(11)=3.0d0
      val(54)=6.0d0
      val(55)=3.0d0
      val(59)=3.0d0
      val(60)=6.0d0
      val(61)=2.0d0
      val(64)=2.0d0
      val(65)=5.0d0

      rows(1)=1
      rows(2)=5
      rows(3)=10
      rows(4)=16
      rows(5)=23
      rows(6)=30
      rows(7)=37
      rows(8)=44
      rows(9)=51
      rows(10)=57
      rows(11)=62
      rows(12)=66

      do i=1,5
        do j=2,8
            cols(7*(i+1)+j)=i-1+j-1
        enddo
      enddo

      do j=1,4
        do i=1,2
            cols(5*i+j-1)=j
            cols(48+5*i+j-1)=j+7
        enddo
        cols(j)=j
        cols(61+j)=j+7
      enddo

      cols(9)=5
      cols(14)=5
      cols(15)=6
      cols(51)=6
      cols(52)=7
      cols(57)=7
      write(*,*)rows
      write(*,*)
      write(*,*)cols
      write(*,*)
      write(*,*)val

      do i=1,n
        valb(i)=1.0d0
        colsb(i)=i
        rowsb(i)=i
      enddo
      rowsb(n+1)=n+1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!   Print matrix dimension          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      print *,'Sparse matrix size',n

!!! Search interval [Emin,Emax] including M eigenpairs !!!!!!!!!!!!!!!!!!!!!!!!!
      Emin=3.0
      Emax=7.0
      M0=L
      M=M0
      print *,'Search interval ', Emin,' ', Emax
      ldx=n
      ldy=n
      one=1.0d0
      zero=0.0d0

!
!        Task 1. Call FEASTINIT to define the default values for the input
!        FEAST parameters.
!
      call feastinit(fpm)
      fpm(1)=1
      print *, ' Testing dfeast_scsrev '
!
!         Task 2. Solve the standard eigenvalue problem Ax=ex.
!
      call dfeast_scsrev(UPLO,N,val,rows,cols,fpm,epsout,loop,
     $   Emin,Emax,M0,E,X,M,res,info)
      print  *,' FEAST OUTPUT INFO ',info
      if(info.ne.0) stop 1
!
!         Task 3. Compute the residual R(i) = | E(i) - Eig(i) |  where Eig(i)
!         are the expected eigenvalues  and E(i) are eigenvalues computed
!         with the help of SFEAST_SCSREV().
!
      print *, 'Number of eigenvalues found ', M
      print *, ' Computed    |    Expected  '
      print *, ' Eigenvalues |    Eigenvalues '
      eigabs=0.0d0
      do i=1,M
         R(i)=dabs(E(i)-Eig(i))
         eigabs=max(eigabs, R(i))
         print *, E(i), Eig(i)
      enddo
      print *, ' Max value of '
      print *, ' | computed eigenvalue -expected eigenvalues | ', eigabs
!
!         Task 4.  Compute the maximum absolute value of the matrix
!         Y=(X')*X-I  where X is the matrix of eigenvectors computed with
!         the help of DFEAST_SCSREV.
!         Call DGEMM (BLAS Level 3 Routine) to compute (X')*X.
!
      Y=zero
      call dgemm('T','N',M,M,n,one,X,ldx,X,ldx,zero,Y,ldy)
!
!          Compute Y=Y-I
!
       do i=1,M
        Y(i,i)=Y(i,i)-one
      enddo
      print *,'*************************************************'
      print *,'************** REPORT ***************************'
      print *,'*************************************************'
      print *,'# Search interval [Emin,Emax]',Emin,Emax
      print *,'# mode found/subspace',M,M0
      print *,'# iterations',loop
      print *,'Relative error on the trace',epsout
      print *,'Eigenvalues/Residuals'
      do i=1,M
        print *,i,E(i),' | ', res(i)
      enddo
      smax=zero
      do i=1,M
        do j=1,M
           smax=max(smax, abs(Y(i, j)))
        enddo
      enddo
      print *, '  Max absolute value of the matrix '
      print *, ' (transposed of X)*X-I ', smax
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!! GENERALIZED EIGENVALUE PROBLEM !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      M0=L
      M=M0
      Y=zero
      E=zero
      X=zero
      res=zero
      epsout=zero
      print *, ' Testing dfeast_scsrgv'
!
!         Task 5. Solve the generalized eigenvalue problem Ax=eBx.
!
      call dfeast_scsrgv(UPLO,N,val,rows,cols,valb,rowsb,colsb,
     $ fpm,epsout,loop,Emin,Emax,M0,E,X,M,res,info)
      print  *,' FEAST OUTPUT INFO ',info
      if(info.ne.0) stop 1
!
!         Task 6. Compute the residual R(i) = | E(i) - Eig(i) |  where Eig(i)
!         are the expected eigenvalues  and E(i) are eigenvalues computed
!         with the help of DFEAST_SCSRGV().
!
      print *, 'Number of eigenvalues found ', M
      print *, ' Computed    |    Expected  '
      print *, ' Eigenvalues |    Eigenvalues '
      eigabs=zero
      do i=1,M
         R(i)=dabs(E(i)-Eig(i))
         eigabs=max(eigabs, R(i))
         print *, E(i), Eig(i)
      enddo
      print *, ' Max | computed eigenvalue -expected eigenvalues | ',
     & eigabs
!
!         Task 7.  Compute the maximum absolute value of the matrix
!         Y=(X')*X-I  where X is the matrix of eigenvectors computed with
!         the help of DFEAST_SCSREV.
!         Call DGEMM (BLAS Level 3 Routine) to compute (X')*X.
!
      Y=zero
      call dgemm('T','N',M,M,n,one,X,ldx,X,ldx,zero,Y,ldy)
!
!          Compute Y=Y-I
!
      do i=1,M
        Y(i,i)=Y(i,i) - one
      enddo
      print *,'*************************************************'
      print *,'************** REPORT ***************************'
      print *,'*************************************************'
      print *,'# Search interval [Emin,Emax]',Emin,Emax
      print *,'# mode found/subspace',M,M0
      print *,'# iterations',loop
      print *,'Relative error on the trace',epsout
      print *,'Eigenvalues/Residuals'
      do i=1,M
        print *,i,E(i),' | ', res(i)
      enddo
      smax=zero
      do i=1,M
        do j=1,M
           smax=max(smax, abs(Y(i, j)))
        enddo
      enddo
      print *, '  Max absolute value of the matrix '
      print *, ' (transposed of X)*X-I ', smax
      stop 0
      end program dexample_sparse


c=======================================================================
c
c     subroutine TESTLINEARCST
c
c     This function tests if w(n) verifies the lower/upper bounds and
c     general linear constraints for a specified precision EPS=1.E-10
c
c     C*w <= b                      (general linear constraints)
c     Cinf(i) <= w(i) <= Csup(i)    (lower/upper bounds)
c
c     if the constraints are verified then info = 0
c                                     else info = -115
c-----------------------------------------------------------------------
      SUBROUTINE testlinearcst ( n, w, neq, nin, ccst, bcst, cinf, csup,
     &                           dwork, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : portfolio size                                  integer
c       w      : point (n)                                        double
c       neq    : number equality constraints                     integer
c       nin    : number inequality constraints                   integer
c       ccst   : matrix of constraints (nasset*(neq+nin))         double
c       bcst   : vector initial of constraints (neq+nin)          double
c       cinf   : lower bound (n)                                  double
c       csup   : upper bound (n)                                  double
c
c     WORKSPACE
c       dwork  : n                                                double
c
c     OUTPUT
c       info   : diagnostic argument                             integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION w(*), cinf(*), csup(*), ccst(n,*), bcst(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, m, pdy
      DOUBLE PRECISION a, b, EPS
      PARAMETER (EPS = 1.E-10)
c
c     external subroutines
      EXTERNAL PMTV
c
c-----------------------------------------------------------------------
c
c
c     initializations
      info = 0          ! diagnostic argument
      m    = neq + nin  ! number of general linear constraints
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdy = 1
c
c     Total size of dwork array = n
c
c-----------------------------------------------------------------------
c
c     test: cinf <= w <= csup
      DO i = 1,n
        IF ((w(i).LT.cinf(i)-EPS).OR.(w(i).GT.csup(i)+EPS)) THEN
            info = -115
            RETURN
        ENDIF
      ENDDO
c
c     no test todo if m=0
      IF (m .EQ. 0) THEN
        RETURN
      ENDIF
c
c     PMTV : matrix vector product, pdy(m) <- C'(n,m)*w(n)
      CALL PMTV ( n, m, ccst, w, dwork(pdy) )
c
c     test: C*w <= b
      DO i = 1,m
        a = dwork(pdy+i-1)
        b = bcst(i)
        IF (a .GT. b+EPS) THEN
            info = -115
            RETURN
        ENDIF
      ENDDO
      RETURN
      END


      PROGRAM PRIMES2
C
C     PROGRAM TO PRINT THE FIRST N PRIMES
C
      READ(*,*)N
      I=1
      J=0
 10   I=I+1
      IS = SQRT(FLOAT(I))
      DO 20 K=2,IS
      IF (I/K*K .EQ.I) GOTO 10
 20   CONTINUE
      WRITE(*,*)I
      J=J+1
      IF (J.LT.N) GOTO 10
      END


program speed
  use interpreter
  implicit none

  integer, parameter :: N=10000000
  character(200) :: s, v, e
  real(8) :: x, y, r, t
  integer :: i, ff, c1, c2, cr, cm

  r = 0.0d0

  call system_clock(c1, cr, cm)
  do i = 1, N
     x = 500.0d0 - dble(i)/1000.0d0
     y = 100.0d0 - dble(i)/5000.0d0
     r = r + f(x, y)
  end do
  call system_clock(c2)

  write(*, *) "Compiled code time= ", dble(c2-c1)/dble(cr)
  write(*, *) "Compiled code result= ", r

  s = '0.5d0 - 0.5d0*cos(x-2.0d0*y) '
  v = 'x y'
  call s_createfn(s, v, ff, e)
  r = 0.0d0

  call system_clock(c1)
  do i = 1, N
     x = 500.0d0 - dble(i)/1000.0d0
     y = 100.0d0 - dble(i)/5000.0d0
     call s_evaluatefn(ff, (/ x, y /), t, e)
     r = r + t
  end do
  call system_clock(c2)

  write(*,*) "Parsed code time= ", dble(c2-c1)/dble(cr)
  write(*,*) "Parsed code result= ", r

contains

  function f(x,y)
    real(8) :: f, x, y

    f = 0.5d0 - 0.5d0*cos(x-2.0d0*y)
  end function f
end program speed