program test_simple
use types, only: dp
use utils, only: stop_error, assert
use linalg, only: eye
use linalg_feast, only: eigh
implicit none

real(dp), parameter :: eps = 1e-9_dp
real(dp) :: A(2, 2) = reshape([2, -1, -1, 2], [2, 2])
real(dp) :: Emin=-10, Emax=10
integer :: M0=2 ! (Initial) subspace dimension
real(dp), allocatable :: lam(:), c(:, :), r(:)
real(dp) :: norm
integer :: i

allocate(lam(M0))
allocate(r(M0))
allocate(c(2,M0))

call eigh(A, Emin, Emax, M0, lam, c)

print *, 'Eigenvalues'
do i = 1, M0
    print *, i, lam(i)
end do
print *,'Eigenvectors'
do i=1, M0
    print *,i,"(",c(1,i),c(2,i),")"
end do

call assert(all(abs(lam - [1, 3]) < eps))
do i = 1, 2
    ! Test that c(:, i) are eigenvectors:
    r = matmul(A-lam(i)*eye(2), c(:, i))
    call assert(sqrt(dot_product(r, r)) < eps)
    ! Test that eigenvectors are properly normalized:
    norm = dot_product(c(:, i), c(:, i))
    call assert(abs(norm - 1) < eps)
end do

end program


      SUBROUTINE NATURAL_SPLINE(YA,LEX,N)
!----------------------------------------------------------------------
!  This is a program of cubic spline interpolation. The imported
!  series, YA have a length of LEX, with N numbers of value
!  not equal to 1.0E31. The program is to use the cubic line to
!  interpolate the values for the points other thatn these N
!  numbers.
!-----------------------------------------------------------------------

      implicit none

      integer, intent(in):: N, LEX
      real, dimension(LEX), intent(inout):: YA
      real, dimension(N):: Y, Y2
      integer, dimension(N):: LX
      integer:: J, I, KLO, KHI
      real:: YP1, YPN, H, A, B

!  The following code is to realocate the series of X(N), Y(N)

      J=1
      DO I=1, LEX
        IF( YA(I).LT.1.0E30 ) THEN
          LX(J)=I
          Y(J)=YA(I)
          J=J+1
        ENDIF
      ENDDO

!  The following code is used to calculate the second order derivative,
!  set the derivatives at both ends for a natural cubic spline.
      YP1=1.0E31
      YPN=1.0E31

      CALL SPLINE(LX,Y,N,YP1,YPN,Y2)

!  calculate the cubic spline
      DO I=2,N
        KLO=LX(I-1)
        KHI=LX(I)
        H=real(KHI-KLO)
        DO J=KLO+1,KHI-1
          A=REAL(KHI-J)/H
          B=REAL(J-KLO)/H
          YA(J)=A*Y(I-1)+B*Y(I)   &
                +((A*A*A-A)*Y2(I-1)+(B*B*B-B)*Y2(I))*(H*H)/6.0
        ENDDO
      ENDDO

      END SUBROUTINE NATURAL_SPLINE

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

      SUBROUTINE SPLINE(LX,Y,N,YP1,YPN,Y2)
!-----------------------------------------------------------------
!  see NUMEIRCAL RECIPES to find out meaning of each variables
!-----------------------------------------------------------------
      implicit none

      integer, intent(in) :: N
      real, intent(in) :: YP1, YPN
      integer, dimension(N), intent(in):: LX
      real, dimension(N) :: X, U
      real, dimension(N), intent(inout):: Y, Y2
      integer:: I, K
      real:: SIG, P, QN, UN

      DO I=1,N
        X(I)=real(LX(I))
      ENDDO

      Y2(1)=0.
      U(1)=0.

      DO I=2,N-1
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
        P=SIG*Y2(I-1)+2.
        Y2(I)=(SIG-1.)/P
        U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) &
             /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
      ENDDO

      QN=0.
      UN=0.

      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.)

      DO K=N-1,1,-1
        Y2(K)=Y2(K)*Y2(K+1)+U(K)
      ENDDO

      END SUBROUTINE SPLINE


program matrix_product_do_loop
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    implicit none
    integer, parameter :: m = 1000, n = 2000, p = 300
    integer :: i, j, k
    real(kind=dp), dimension(m, n) :: A
    real(kind=dp), dimension(n, p) :: B
    real(kind=dp), dimension(m, p) :: C

    do j = 1, n
        do i = 1, m
            A(i, j) = 1.0_dp
        end do
    end do
    do j = 1, p
        do i = 1, n
            B(i, j) = 1.0_dp
        end do
    end do
    do j = 1, p
        do i = 1, m
            C(i, j) = 0.0_dp
            do k = 1, n
                C(i, j) = C(i, j) + A(i, k)*B(k, j)
            end do
          end do
    end do

    print *, sum(C)

end program matrix_product_do_loop


use ArrayClass
use IOClass
implicit none

real(real64),allocatable :: t(:),Ft(:)
real(real64) :: tau
type(IO_) :: f

tau = 100.0d0
t = linspace([0.0d0,2.0d0*tau],10000)
Ft = t

Ft(1   : 5000) = 0.50d0*t(1:5000)*t(1:5000)/tau/tau
Ft(5001:10000) = - 0.50d0*t(5001:)*t(5001:)/tau/tau +2.0d0*t(5001:)/tau-1

call f%plot(t,Ft)
! 1st Derivative
call f%plot(t, d_dx(t,Ft) )
! 2nd Derivative
call f%plot(t, d_dx(t,d_dx(t,Ft)) )

end


SUBROUTINE dsimul ( a, b, soln, ndim, n, error )
!
!  Purpose:
!    Subroutine to solve a set of N linear equations in N
!    unknowns using Gaussian elimination and the maximum
!    pivot technique.  This version of simul has been
!    modified to use array sections and automatic arrays.
!    It uses double precision arithmetic to avoid
!    cumulative roundoff errors.  It DOES NOT DESTROY the
!    original input values.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/23/06    S. J. Chapman        Original code
! 1. 11/24/06    S. J. Chapman        Add automatic arrays
! 2. 11/27/06    S. J. Chapman        Double precision
!
IMPLICIT NONE

! Data dictionary: declare constants
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
                                     ! Double kind number
REAL(KIND=DBL), PARAMETER :: EPSILON = 1.0E-12
                                     ! A "small" number for comparison
                                     ! when determining singular eqns

! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: ndim          ! Dimension of arrays a and b
REAL(KIND=DBL), INTENT(IN), DIMENSION(ndim,ndim) :: a
                                     ! Array of coefficients (N x N).
                                     ! This array is of size ndim x
                                     ! ndim, but only N x N of the
                                     ! coefficients are being used.
REAL(KIND=DBL), INTENT(IN), DIMENSION(ndim) :: b
                                     ! Input: Right-hand side of eqns.
REAL(KIND=DBL), INTENT(OUT), DIMENSION(ndim) :: soln
                                     ! Output: Solution vector.
INTEGER, INTENT(IN) :: n             ! Number of equations to solve.
INTEGER, INTENT(OUT) :: error        ! Error flag:
                                     !   0 -- No error
                                     !   1 -- Singular equations

! Data dictionary: declare local variable types & definitions
REAL(KIND=DBL), DIMENSION(n,n) :: a1 ! Copy of "a" which will be
                                     ! destroyed during the solution
REAL(KIND=DBL) :: factor             ! Factor to multiply eqn irow by
                                     ! before adding to eqn jrow
INTEGER :: irow                      ! Number of the equation currently
                                     ! currently being processed
INTEGER :: ipeak                     ! Pointer to equation containing
                                     ! maximum pivot value
INTEGER :: jrow                      ! Number of the equation compared
                                     ! to the current equation
REAL(KIND=DBL) :: temp               ! Scratch value
REAL(KIND=DBL),DIMENSION(n) :: temp1 ! Scratch array

! Make copies of arrays "a" and "b" for local use
a1 = a(1:n,1:n)
soln = b(1:n)

! Process N times to get all equations...
mainloop: DO irow = 1, n

   ! Find peak pivot for column irow in rows irow to N
   ipeak = irow
   max_pivot: DO jrow = irow+1, n
      IF (ABS(a1(jrow,irow)) > ABS(a1(ipeak,irow))) THEN
         ipeak = jrow
      END IF
   END DO max_pivot

   ! Check for singular equations.
   singular: IF ( ABS(a1(ipeak,irow)) < EPSILON ) THEN
      error = 1
      RETURN
   END IF singular

   ! Otherwise, if ipeak /= irow, swap equations irow & ipeak
   swap_eqn: IF ( ipeak /= irow ) THEN
      temp1 = a1(ipeak,1:n)
      a1(ipeak,1:n) = a1(irow,1:n)   ! Swap rows in a
      a1(irow,1:n) = temp1
      temp = soln(ipeak)
      soln(ipeak) = soln(irow)       ! Swap rows in b
      soln(irow)  = temp
   END IF swap_eqn

   ! Multiply equation irow by -a1(jrow,irow)/a1(irow,irow),
   ! and add it to Eqn jrow (for all eqns except irow itself).
   eliminate: DO jrow = 1, n
      IF ( jrow /= irow ) THEN
         factor = -a1(jrow,irow)/a1(irow,irow)
         a1(jrow,1:n) = a1(irow,1:n)*factor + a1(jrow,1:n)
         soln(jrow) = soln(irow)*factor + soln(jrow)
      END IF
   END DO eliminate
END DO mainloop

! End of main loop over all equations.  All off-diagonal
! terms are now zero.  To get the final answer, we must
! divide each equation by the coefficient of its on-diagonal
! term.
divide: DO irow = 1, n
   soln(irow) = soln(irow) / a1(irow,irow)
END DO divide

! Set error flag to 0 and return.
error = 0

END SUBROUTINE dsimul


! /* This code simulates a 2-dimensional laplace equation
!  * using jacobi interation
!  * accelated by mpi
!  * author: btli(2021)
!  */

! /*  data mesh arrangement
!  *  ny
!  *  ^
!  *  | (1,3)
!  *  | (1,2)
!  *  | (1,1)  (2,1)  (3,1)
!  *  ---------------------> nx
!  *
!     for fortran language, data fill row first, (1,1),(2,1) ...
! */

program main
    implicit none
    integer, parameter :: nx = 1000, ny = 1000, itc_max = 1000
    real(8), parameter :: tolerance = 1.0e-5
    integer :: i, j, itc
    real(8) :: A(0:nx+1, 0:ny+1), A_new(0:nx+1, 0:ny+1), f(0:nx+1, 0:ny+1), A_p(0:nx+1, 0:ny+1)
    real(8) :: error, error_max, check_diff
    real(8) :: start_time, end_time

    call init(A, A_new, f, nx, ny)

    call CPU_TIME(start_time)

    !! jacobi iteration
    itc = 0
    error_max = 1.0
    A_p = A
    do while(error_max > tolerance .AND. itc <= itc_max)
        itc =  itc + 1

        call jacobi(A, A_new, f, nx, ny)
        call swap(A, A_new)

        if(MOD(itc, 100) == 0) then
        error = check_diff(A, A_p, nx, ny)
        write(*, *) itc, error_max
        endif
    enddo

    call CPU_TIME(end_time)
    write(*,*) "Total run time =", end_time-start_time, "s."

end program main

subroutine init(A, A_new, f, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny
    real(8), intent(inout) :: A(0:nx+1, 0:ny+1), A_new(0:nx+1, 0:ny+1), f(0:nx+1, 0:ny+1)
    integer :: i, j

    ! initialize
    do j = 0, ny+1
        do i = 0, nx+1
            A(i, j) = 0.0d0
            A_new(i, j) = 0.0d0
            f(i, j) = 0.0d0
        enddo
    enddo

    ! boundary condition (top boundary = 1.0, others = 0.0)
    do i = 0, nx+1
        A(i, ny+1) = 1.0d0
        A_new(i, ny+1) = 1.0d0
    enddo

end subroutine init

subroutine jacobi(A, A_new, f, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny
    real(8), intent(inout) :: A(0:nx+1, 0:ny+1), A_new(0:nx+1, 0:ny+1), f(0:nx+1, 0:ny+1)
    integer :: i, j

    do j = 1, ny
        do i = 1, nx
            A_new(i, j) = 0.25 * (A(i-1, j) + A(i+1, j) + A(i, j-1) + A(i, j+1) + f(i, j))
        enddo
    enddo

end subroutine jacobi

function check_diff(A, A_p, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny
    real(8), intent(in) :: A(0:nx+1, 0:ny+1)
    real(8), intent(inout) :: A_p(0:nx+1, 0:ny+1)
    integer :: i, j
    real(8) :: error, check_diff

    error = 0.0d0
    do j = 1, ny
        do i = 1, nx
            error = max( error, abs(A_p(i,j)-A(i,j)) )
        enddo
    enddo

    A_p = A
    check_diff = error

end function check_diff

subroutine swap(A, A_new, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny
    real(8), intent(inout) :: A(0:nx+1, 0:ny+1), A_new(0:nx+1, 0:ny+1)
    integer :: i, j

    do j = 1, ny
        do i = 1, nx
            A(i, j) = A_new(i, j)
        enddo
    enddo

end subroutine swap


      SUBROUTINE DROTG( A, B, C, S )
*
*  -- Automatically Tuned Linear Algebra Software (ATLAS)
*     (C) Copyright 2000 All Rights Reserved
*
*  -- ATLAS routine -- F77 Interface -- Version 3.9.24 -- December 25, 2000
*
*  Author         : Antoine P. Petitet
*  Originally developed at the University of Tennessee,
*  Innovative Computing Laboratory,  Knoxville TN, 37996-1301, USA.
*
*  ---------------------------------------------------------------------
*
*  -- Copyright notice and Licensing terms:
*
*  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 distri-
*     bution.
*  3. The name of the University,  the ATLAS group,  or the names of its
*     contributors  may not be used to endorse or promote products deri-
*     ved from this software without specific written permission.
*
*  -- Disclaimer:
*
*  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 UNIVERSITY
*  OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,  INDIRECT, INCIDENTAL, SPE-
*  CIAL, 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 THEO-
*  RY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  (IN-
*  CLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
*  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*  ---------------------------------------------------------------------
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   C, A, B, S
*     ..
*
*  Purpose
*  =======
*
*  DROTG  constructs a Givens plane rotation. Given the scalars a and b,
*  this routine computes the following quantities:
*
*     sigma = sgn(a) if |a| > |b|, sgn(b) otherwise;
*     r     = sigma * sqrt( a^2 + b^2 );
*     c     = a / r if r <> 0, 1 otherwise;
*     s     = b / r if r <> 0, 0 otherwise.
*
*  The numbers c, s and r then satisfy the matrix equation:
*
*     [ c  s ] [ a ]    [ r ]
*     [ -s c ] [ b ] =  [ 0 ].
*
*  The introduction of  sigma  is not essential  to the computation of a
*  Givens rotation matrix, but it permits later stable reconstruction of
*  c and s from just one stored number.  For  this purpose, this routine
*  also computes
*
*          s        if |a| > |b|,
*     z =  1 / c    if |b| >= |a| and c <> 0,
*          1        if c = 0.
*
*  This subroutine returns r overwriting a, and z overwriting b, as well
*  as returning c and s. If one later wishes to reconstruct c and s from
*  z, it can be done as follows:
*
*     if  z  = 1,    set c = 0             and s = 1,
*     if |z| < 1,    set c = sqrt(1 - z^2) and s = z,
*     if |z| > 1,    set c = 1 / z         and s = sqrt(1 - c^2).
*
*  Arguments
*  =========
*
*  A       (input/output)                DOUBLE PRECISION
*          On entry, A specifies the scalar a. On exit, A is overwritten
*          by the scalar r defined above.
*
*  B       (input/output)                DOUBLE PRECISION
*          On entry, B specifies the scalar b. On exit, B is overwritten
*          by the scalar z defined above.
*
*  C       (output)                      DOUBLE PRECISION
*          On exit, C  specifies the scalar c defined above.
*
*  S       (output)                      DOUBLE PRECISION
*          On exit, S  specifies the scalar s defined above.
*
*  Further Details
*  ===============
*
*  For further information on the Level 1 BLAS specification, see:
*
*  ``A Proposal for Standard Linear Algebra Subprograms''  by R. Hanson,
*  F. Krogh and C. Lawson, ACM SIGNUM Newsl., 8(16), 1973,
*
*  ``Basic Linear Algebra Subprograms for Fortran Usage''  by C. Lawson,
*  R. Hanson, D. Kincaid and F. Krogh,  ACM Transactions on Mathematical
*  Software, 5(3) pp 308-323, 1979.
*
*  For further information on the Level 2 BLAS specification, see:
*
*  ``An  Extended Set of  FORTRAN  Basic Linear Algebra Subprograms'' by
*  J. Dongarra,  J. Du Croz,  S. Hammarling and R. Hanson,  ACM Transac-
*  tions on Mathematical Software, 14(1) pp 1-17, 1988.
*
*  ``Algorithm 656: An extended Set of Basic Linear Algebra Subprograms:
*  Model Implementation and Test Programs''  by J. Dongarra, J. Du Croz,
*  S. Hammarling and R. Hanson,  ACM  Transactions on Mathematical Soft-
*  ware, 14(1) pp 18-32, 1988.
*
*  For further information on the Level 3 BLAS specification, see:
*
*  ``A Set of Level 3 Basic Linear Algebra Subprograms'' by J. Dongarra,
*  J. Du Croz, I. Duff and S. Hammarling, ACM Transactions on Mathemati-
*  cal Software, 16(1), pp 1-17, 1990.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_DROTG
*     ..
*     .. Executable Statements ..
*
      CALL ATL_F77WRAP_DROTG( A, B, C, S )
*
      RETURN
*
*     End of DROTG
*
      END


module constants_module

  doubleprecision pi,pihalf,twopi,fourpi,sqrtpi
  parameter(pi=3.14159265358979323846264338328d0)
  parameter(pihalf=1.57079632679489661923132169164d0)
  parameter(twopi=6.28318530717958647692528676656d0)
  parameter(fourpi=12.5663706143591729538505735331d0)
  parameter(sqrtpi=1.772453850905515881919d0)

  doubleprecision :: parsec,au
  parameter(parsec=3.08572d18,au=1.49598d13)

  doubleprecision :: cc,kk,mp,hh
  parameter(cc  = 2.9979245800000d10)     ! Light speed             [cm/s]
  parameter(kk  = 1.3807d-16)             ! Bolzmann's constant     [erg/K]
  parameter(mp  = 1.6726d-24)             ! Mass of proton          [g]
  parameter(hh  = 6.6262000d-27)          ! Planck constant

  integer :: stdi, stdo, fflo, ffli
  logical :: radmc_as_child

end module constants_module


!==========================================
! random_walk.f90
! Author: Devansh Shukla
!------------------------------------------
program walk
    implicit none
    ! Define the parameters
    real*8, dimension(1000000) :: X, Y
    real*8 :: pi=3.14159
    real*8 :: x_value=0.0, y_value=0.0, a=0.0, b=0.0, step=1, R=0.0
    integer :: i=0, j=0, n=0
    character(len=*), parameter :: fmt="(F12.3,xF12.3,xF12.3,F12.3)"

    ! open the data file
    open(unit=8, file="walk.dat")
    ! get input from user
    print *, "Enter the no. of steps (n)"
    read *, n

    ! initialize the array
    do j=1, n
       X(j) = 0.0
       Y(j) = 0.0
    enddo

    ! compute
    do i=1, n, 1
        call random_number(a)
        call random_number(b)
        x_value = step * cos(2*pi*a)
        y_value = step * sin(2*pi*b)
        X(i) = X(i-1) + x_value
        Y(i) = Y(i-1) + y_value
        write (8, fmt) x_value, y_value, X(i), Y(i)
        R = R + x_value**2 + y_value**2
    enddo
    ! print for the user
    print "(A, F10.3)", "The value of Radius, R =", sqrt(R)
    ! close the data file
    close(8)
end program walk


*
* primes - Print out the primes from 1-15
*
*  Written by: C. Severance 16Mar92
*
      INTEGER VALUE,ISPRIME,J,TEST
*
* Outside loop goes from 1 to 15
*
      DO VALUE=1,15
*
* The inside loop will see if there are any numbers other than 1 and
* the number itself can be evenly divided into the number.  If a some other
* number evenly divides intothe number it is not prime.
*
        ISPRIME = 1
        DO J=2,VALUE-1
          TEST = VALUE / J
          IF ( VALUE .EQ. (TEST * J) ) THEN
            ISPRIME = 0
          ENDIF
        ENDDO
*
* Now print out whether or not the number is prime
*
        IF ( ISPRIME .EQ. 1 ) THEN
          PRINT *,VALUE,' is a prime number'
        ELSE
          PRINT *,VALUE,' is a composite number'
        ENDIF
      ENDDO
*
      END


program optional_argument
  implicit none

  real :: x(10)

  call random_number(x)

  x = x*50.3

  print*, average(x)
  print*, average(x,10.,30.)
 contains

 real function average(x,low,up)
  implicit none
  real, dimension(:), intent(in) :: x
  real, intent(in), optional :: low, up

  real :: a, b

  integer :: i, icount

  a=-huge(a)
  b = huge(b)

  if (present(low)) a = low
  if (present(up)) b = up

  average = 0.0
  icount = 0
  do i=1, size(x)
    if (x(i) >= a .and. x(i) <= b) then
      average = average + x(i)
      icount = icount + 1
    endif
  enddo
  average = average / icount
 end function average
end program optional_argument


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
c
      program testfft
      implicit none
c
c --- local variables
c
      integer i,ier,iflag,j,k1,mx,ms,nj
      parameter (mx=10 000)
      real*8 xj(mx), sk(mx)
      real*8 err,eps,pi
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*16 cj(mx),cj0(mx),cj1(mx)
      complex*16 fk0(mx),fk1(mx)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
      ms = 90
      nj = 128
      do k1 = -nj/2, (nj-1)/2
         j = k1+nj/2+1
         xj(j) = pi * dcos(-pi*j/nj)
         cj(j) = dcmplx( dsin(pi*j/nj), dcos(pi*j/nj))
      enddo
c
c     --------------------------------------------------
c     start tests
c     --------------------------------------------------
c
      iflag = 1
      print*,' Start 1D testing: ', ' nj =',nj, ' ms =',ms
      do i = 1,4
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
         if (i.eq.4) eps=1d-16
c extended/quad precision tests
         if (i.eq.5) eps=1d-20
         if (i.eq.6) eps=1d-24
         if (i.eq.7) eps=1d-28
         if (i.eq.8) eps=1d-32
	 print*,' '
  	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 1D Type1 method
c     -----------------------
c
         call dirft1d1(nj,xj,cj,iflag, ms,fk0)
         call nufft1d1f90(nj,xj,cj,iflag,eps, ms,fk1,ier)
         call errcomp(fk0,fk1,ms,err)
         print *,' ier = ',ier
         print *,' type 1 error = ',err
c
c     -----------------------
c     call 1D Type2 method
c     -----------------------
c
         call dirft1d2(nj,xj,cj0,iflag, ms,fk0,ier)
         call nufft1d2f90(nj,xj,cj1,iflag, eps, ms,fk0,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 2 error = ',err
c
c     -----------------------
c     call 1D Type3 method
c     -----------------------
         do k1 = 1, ms
            sk(k1) = 48*dcos(k1*pi/ms)
         enddo
         call dirft1d3(nj,xj,cj,iflag, ms,sk,fk0)
         call nufft1d3f90(nj,xj,cj,iflag,eps, ms,sk,fk1,ier)
         call errcomp(cj0,cj1,nj,err)
         print *,' ier = ',ier
         print *,' type 3 error = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex*16 fk0(n), fk1(n)
      real *8 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cdabs(fk1(k)-fk0(k))**2
         salg = salg + cdabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


*> \brief \b SNRM2
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL FUNCTION SNRM2(N,X,INCX)
*
*       .. Scalar Arguments ..
*       INTEGER INCX,N
*       ..
*       .. Array Arguments ..
*       REAL X(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SNRM2 returns the euclidean norm of a vector via the function
*> name, so that
*>
*>    SNRM2 := sqrt( x'*x ).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup single_blas_level1
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  -- This version written on 25-October-1982.
*>     Modified on 14-October-1993 to inline the call to SLASSQ.
*>     Sven Hammarling, Nag Ltd.
*> \endverbatim
*>
*  =====================================================================
      REAL FUNCTION SNRM2(N,X,INCX)
*
*  -- Reference BLAS level1 routine (version 3.4.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER INCX,N
*     ..
*     .. Array Arguments ..
      REAL X(*)
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL ONE,ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
*     ..
*     .. Local Scalars ..
      REAL ABSXI,NORM,SCALE,SSQ
      INTEGER IX
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC ABS,SQRT
*     ..
      IF (N.LT.1 .OR. INCX.LT.1) THEN
          NORM = ZERO
      ELSE IF (N.EQ.1) THEN
          NORM = ABS(X(1))
      ELSE
          SCALE = ZERO
          SSQ = ONE
*        The following loop is equivalent to this call to the LAPACK
*        auxiliary routine:
*        CALL SLASSQ( N, X, INCX, SCALE, SSQ )
*
          DO 10 IX = 1,1 + (N-1)*INCX,INCX
              IF (X(IX).NE.ZERO) THEN
                  ABSXI = ABS(X(IX))
                  IF (SCALE.LT.ABSXI) THEN
                      SSQ = ONE + SSQ* (SCALE/ABSXI)**2
                      SCALE = ABSXI
                  ELSE
                      SSQ = SSQ + (ABSXI/SCALE)**2
                  END IF
              END IF
   10     CONTINUE
          NORM = SCALE*SQRT(SSQ)
      END IF
*
      SNRM2 = NORM
      RETURN
*
*     End of SNRM2.
*
      END


program main
  use timers
  type(TimerType) :: gbTime
  integer check

  integer maxn,n,i
  parameter (n=20000)
  integer numpairs(n)

  call TimerCreate(gbTime,"goldbach")

  do i=1,n
     numpairs(i) = 0
  end do

! FIND NO. OF GOLDBACH PAIRS FOR THE FIRST n EVEN NUMBERS

  call TimerOn(gbTime)
  do i=1,n
     call goldbach(2*i,numpairs(i))
  end do
  call TimerOff(gbTime)

!  OUTPUT SELECTED RESULTS

  do i=1,n,n/10
     print *, 2*i, numpairs(i)
  end do

!  OUTPUT TIMING DATA

  call TimerPrint(gbTime)

  stop
end program main

subroutine goldbach(evenno,numpairs)

  integer evenno,numpairs,j
  logical isprime

! TEST ALL PAIRS WHICH SUM TO evenno FOR PRIMALITY

  do j=2,evenno/2
     if (isprime(j).and.isprime(evenno-j)) numpairs = numpairs+1
  end do

  return
end subroutine goldbach

logical function isprime(num)

  integer num,i

! CRUDE PRIMALITY TEST: CHECK ALL INTEGERS LESS THAN SQARE ROOT
! OF NUMBER

  isprime = .true.
  i=2
  do while ( (i.le.(int(sqrt(real(num)))) ) .and. isprime)
     isprime = mod(num,i).ne.0
     i=i+1
  end do

  return
end function isprime


program tarefab3
    implicit real(8) (a-h,o-z)
    parameter (pi = 4d0*atan(1d0))

    dt = 1d-4
    tmax = 30d0
    i = 0

    g = 9.8d0
    a_l = 9.8d0
    theta_i = pi/6
    omega_i = 0d0
    F0 = 0d0
    gama = 0.5d0
    Omega = 0d0

    open(10, file='saida-b3-10407962.dat')

    write(10,'(F0.6,2(" ",F0.6))') dt*i, theta_i

    do while ( i*dt.le.tmax )

        omega_j = omega_i +dw(g, a_l, theta_i, gama, omega_i, F0, Omega, dt*i)*dt
        theta_j = theta_i +omega_j*dt

        theta_i = theta_j
        omega_i = omega_j

        write(10,'(F0.6,2(" ",F0.6))') dt*i, theta_i

        i = i+1
    end do

    close(10)

    freqnat = sqrt(g/a_l)
    write(*,'(A,F8.6)') 'Freq. Natural: ', freqnat
    write(*,'(A,F8.6)') 'gamma: ', gama
    write(*,'(A,F0.6)') 'Delta: ', 4*(gama**2 -freqnat**2)

contains
    function dw(g, a_l, theta, gama, dTheta, F0, Omega, t)
        implicit real(8) (a-h,o-z)
        dw = -(g/a_l)*sin(theta) -gama*dTheta +F0*sin(Omega*t)
        return
    end function

end program tarefab3


program tridiag_solver
    implicit none
    write(*,*)tridiag_solve(1., -3., 1., (/ 7., 8., 9. /), 3 )
contains
function tridiag_solve(l, d, r, b, n)
    implicit none
    integer, intent(in) :: n
    real,  dimension(n) :: b
    real, intent(in) :: l, d, r
    real, dimension(n) :: tridiag_solve

    real,  dimension(n) :: bhat, rhat
    integer :: i

    ! your code here
    rhat(1) = r / d
    bhat(1) = b(1) / d
    do i=2,n
        rhat(i) = r / (d - l * rhat(i - 1))
        bhat(i) = (b(i) - l * bhat(i-1)) / (d - l * rhat(i-1))
    enddo

    tridiag_solve(n) = bhat(n)
    do i=n-1,1,-1
        tridiag_solve(i) = bhat(i) - rhat(i) * tridiag_solve(i + 1)
    end do

end function
end program


program thomas_algo
implicit none

real(8):: ud(4),d(4),ld(4) ! diagonals of the original matrix
real(8):: x(4) ! the unknown 'x' matrix and the matrix with values
integer :: i,j,k,l,m,o,p,t

real(8) ::rhs(4)
real(8) :: a,b,c !the  of the upper, lower and diagonal elements
!real(8):: points(:),error(:)
!real(8) :: ul,ll,delx
ud = (/-1.0,-1.0,-1.0,-1.0/)
d = (/4.0,4.0,4.0,4.0/)
ld = (/-1.0,-1.0,-1.0,-1.0/)
rhs=(/2.0,4.0,6.0,13.0/)

do i=2,4
d(i) = d(i) - ld(i)/d(i-1) * ud(i-1)
print*,'dia = ',d(i)

end do
print*,' ALL DIAG ELE ' , d
do p=2,4
rhs(p) = rhs(p) - ld(p)/d(p-1) * rhs(p-1)
print*,'the new RHS =',rhs(p)
end do
print*,'the last RHS = ',rhs(4)

x(4) = rhs(4)/d(4)
print*,' the last x= ',x(4)

do k=4,1,-1

x(k-1) = (rhs(k-1) - x(k)*ud(k-1))/d(k-1)
print*,'the value of all x =' ,x(k)
end do

end program thomas_algo


************************************************************************
* This file contains basic transformation routines for lines and
* line segments.
************************************************************************

************************************************************************
* Determine minimum (Euclidean) distance from a point (DPX,DPY) to
* a straight line segment.
*
* In:
*  DPX    - x-coodinate of point
*  DPY    - y-coodinate of point
*  PSTART - starting point of the line segment.
*           PSTART(1) = X-coordinate
*           PSTART(2) = Y-coordinate
*  PEND   - endpoint of the line segment.
*           PEND(1) = X-coordinate
*           PEND(2) = Y-coordinate
*
* Out:
*  Return value = minimum distance
************************************************************************

      DOUBLE PRECISION FUNCTION DPO2SG(DPX,DPY,PSTART,PEND)

      IMPLICIT NONE
      DOUBLE PRECISION DPX,DPY,PSTART(2),PEND(2)

C local variables

      DOUBLE PRECISION DSX1,DSY1,DSX2,DSY2,DVX,DVY,DWX,DWY
      DOUBLE PRECISION DBX,DBY,DB
      DOUBLE PRECISION DVL,DPL

      DSX1 = PSTART(1)
      DSY1 = PSTART(2)
      DSX2 = PEND(1)
      DSY2 = PEND(2)

C Vector PSTART -> PEND and its length

      DVX = DSX2-DSX1
      DVY = DSY2-DSY1
      DVL = SQRT(DVX*DVX+DVY*DVY)

C Vector PSTART -> (DPX,DPY)

      DWX = DPX-DSX1
      DWY = DPY-DSY1

C Scalar product to calculate the length of the
C projected vector

      DPL = DWX*DVX+DWY*DVY

C Relative length of the projection:

      DB  = DPL/(DVL*DVL)

C Relative Length <= 0
C  => Connection between PSTART and (DPX,DPY) is shortest distance
C
C Relative Length >= 1
C  => Connection between PEND and (DPX,DPY) is shortest distance

      IF (DB.LE.0D0) THEN
        DPO2SG = SQRT((DPX-DSX1)**2+(DPY-DSY1)**2)
      ELSE IF (DB.GE.1D0) THEN
        DPO2SG = SQRT((DPX-DSX2)**2+(DPY-DSY2)**2)
      ELSE
C Calculate the projection and the distance to that point.
C Remember to take the square root of the distances as they
C are squared...
        DBX = DSX1+DVX*DB
        DBY = DSY1+DVY*DB
        DPO2SG = SQRT((DPX-DBX)**2+(DPY-DBY)**2)
      ENDIF

      END

************************************************************************
* Project a point (DPX,DPY) onto a line segment.
*
* In:
*  DPX    - x-coodinate of point
*  DPY    - y-coodinate of point
*  PSTART - starting point of the line segment.
*           PSTART(1) = X-coordinate
*           PSTART(2) = Y-coordinate
*  PEND   - endpoint of the line segment.
*           PEND(1) = X-coordinate
*           PEND(2) = Y-coordinate
*
* Out:
*  DPROJ  - Projection of (DPX,DPY) onto the line segment.
*           DPROJ(1) = X-coordinate
*           DPROJ(2) = Y-coordinate
*  DPARM  - Parameter value of the projected point along the line
*           segment. Values in [0,1].
*           DPROJ = PSTART + DPROJ*(PEND-PSTART)
************************************************************************

      SUBROUTINE PPO2SG(DPX,DPY,PSTART,PEND,DPARM,DPROJ)

      IMPLICIT NONE
      DOUBLE PRECISION DPX,DPY,PSTART(2),PEND(2),DPROJ(2),DPARM

C local variables

      DOUBLE PRECISION DSX1,DSY1,DSX2,DSY2,DVX,DVY,DWX,DWY
      DOUBLE PRECISION DVL, DPL

      DSX1 = PSTART(1)
      DSY1 = PSTART(2)
      DSX2 = PEND(1)
      DSY2 = PEND(2)

C Vector PSTART -> PEND and its length

      DVX = DSX2-DSX1
      DVY = DSY2-DSY1
      DVL = SQRT(DVX*DVX+DVY*DVY)

C Vector PSTART -> (DPX,DPY)

      DWX = DPX-DSX1
      DWY = DPY-DSY1

C Scalar product to calculate the length of the
C projected vector

      DPL = DWX*DVX+DWY*DVY

C Relative length of our projected vector:

      DPARM  = DPL/(DVL*DVL)

C Length <= 0
C  => Point is projected onto the starting point PSTART
C
C Length >= 1
C  => Point is projected onto the endpoint PEND

      IF (DPARM.LE.0D0) THEN
        DPARM = 0D0
        DPROJ(1)=DSX1
        DPROJ(2)=DSY1
      ELSE IF (DPARM.GE.1D0) THEN
        DPARM = 1D0
        DPROJ(1)=DSX2
        DPROJ(2)=DSY2
      ELSE
C Calculate the projection and the distance to that point.
C Remember to take the square root of the distances as they
C are squared...
        DPROJ(1) = DSX1+DVX*DPARM
        DPROJ(2) = DSY1+DVY*DPARM
      ENDIF

      END

************************************************************************
* Determine minimum (Euclidean) distance from a point (DPX,DPY) to
* a straight line, given by two points on the line.
*
* In contrast to DPO2SG the line has no starting/ending point!
*
* In:
*  DPX    - x-coodinate of point
*  DPY    - y-coodinate of point
*  PPT1   - one point of the line segment.
*           PPT1(1) = X-coordinate
*           PPT1(2) = Y-coordinate
*  PPT2   - another point of the line segment. PEND != PSTART !!!
*           PPT2(1) = X-coordinate
*           PPT2(2) = Y-coordinate
*
* Out:
*  Return value = minimum distance, >= 0.
*  < 0 indicates an error: PPT1=PPT2.
************************************************************************

      DOUBLE PRECISION FUNCTION DPO2SL(DPX,DPY,PPT1,PPT2)

      IMPLICIT NONE
      DOUBLE PRECISION DPX,DPY,PPT1(2),PPT2(2)

C local variables

      DOUBLE PRECISION DSX1,DSY1,DSX2,DSY2,DVX,DVY,DWX,DWY
      DOUBLE PRECISION DB,DBX,DBY
      DOUBLE PRECISION DVL,DPL

      DSX1 = PPT1(1)
      DSY1 = PPT1(2)
      DSX2 = PPT2(1)
      DSY2 = PPT2(2)

C Vector PSTART -> PEND and its length DC2

      DVX = DSX2-DSX1
      DVY = DSY2-DSY1
      DVL = SQRT(DVX*DVX+DVY*DVY)

C Stop calculation if both points are the same.

      IF (DVL.EQ.0D0) THEN
        DPO2SL = -1
        RETURN
      END IF

C Vector PSTART -> (DPX,DPY)

      DWX = DPX-DSX1
      DWY = DPY-DSY1

C Calculate length of projected vector

      DPL = DWX*DVX+DWY*DVY

C Calculate the projection

      DB  = DPL/DVL
      DBX = DSX1+DVX*DB
      DBY = DSY1+DVY*DB
      DPO2SL = SQRT((DPX-DBY)**2+(DPY-DBY)**2)

      END

************************************************************************
* Project a point (DPX,DPY) onto a straight line.
*
* In contrast to PPO2SG the line has no starting/ending point!
*
* In:
*  DPX    - x-coodinate of point
*  DPY    - y-coodinate of point
*  PPT1   - one point of the line segment.
*           PPT1(1) = X-coordinate
*           PPT1(2) = Y-coordinate
*  PPT2   - another point of the line segment. PEND != PSTART !!!
*           PPT2(1) = X-coordinate
*           PPT2(2) = Y-coordinate
*
* Out:
*  DPROJ  - Projection of (DPX,DPY) onto the line.
*           DPROJ(1) = X-coordinate
*           DPROJ(2) = Y-coordinate
*  DPARM  - Parameter value of the projected point along the line
*           segment.
*           DPROJ = PPT1 + DPROJ*(PPT2-PPT1)
*           DPARM=1D99 indicates an error: PSTART=PEND
************************************************************************

      SUBROUTINE PPO2SL(DPX,DPY,PPT1,PPT2,DPARM,DPROJ)

      IMPLICIT NONE
      DOUBLE PRECISION DPX,DPY,PPT1(2),PPT2(2),DPROJ(2),DPARM

C local variables

      DOUBLE PRECISION DSX1,DSY1,DSX2,DSY2,DVX,DVY,DWX,DWY
      DOUBLE PRECISION DVL,DPL

      DSX1 = PPT1(1)
      DSY1 = PPT1(2)
      DSX2 = PPT2(1)
      DSY2 = PPT2(2)

C Vector PSTART -> PEND and its length DC2

      DVX = DSX2-DSX1
      DVY = DSY2-DSY1
      DVL = SQRT(DVX*DVX+DVY*DVY)

C Stop calculation if both points are the same.

      IF (DVL.EQ.0D0) THEN
        DPARM = 1D99
        RETURN
      END IF

C Vector PSTART -> (DPX,DPY)

      DWX = DPX-DSX1
      DWY = DPY-DSY1

C Calculate length of projected vector

      DPL = DWX*DVX+DWY*DVY

C Calculate the projection and the distance to that point

      DPARM  = DPL/(DVL*DVL)
      DPROJ(1) = DSX1+DVX*DPARM
      DPROJ(2) = DSY1+DVY*DPARM

      END

************************************************************************
* Test if a point is right-side of a line
*
* This routine tests, if a given point (DPX,DPY) is right-side or
* left-side of a line, given by two points.
*
* In:
*  DPX    - x-coodinate of point
*  DPY    - y-coodinate of point
*  PPT1   - one point of the line segment.
*           PPT1(1) = X-coordinate
*           PPT1(2) = Y-coordinate
*  PPT2   - another point of the line segment. PEND != PSTART !!!
*           PPT2(1) = X-coordinate
*           PPT2(2) = Y-coordinate
*
* Out:
*  Return value >  0, if the point is right-side of the line PPT1->PPT2
*               <  0, if the point if left-side of the line
*               =  0, if the point is on the line or if an error
*                     occurred (PPT1=PPT2)
*
* Remark: More specifically the return value is the squared scalar
*  product of the normal vector of the line with the vector
*  PPT1->point...
************************************************************************

      INTEGER FUNCTION PTROLN (DPX,DPY,PPT1,PPT2)

      IMPLICIT NONE
      DOUBLE PRECISION DPX,DPY,PPT1(2),PPT2(2)

      DOUBLE PRECISION DNX,DNY

C To distinguish where the point is, relative to the line, we check
C the vector PPT1->point in relation to the normal vector of the line.
C
C At first build the normal vector by rotating the tangential vector
C by -90 degrees; this points to the right side of the line.

      DNX = (PPT2(2)-PPT1(2))
      DNY = -(PPT2(1)-PPT1(1))

C If this normal vector points into the "same" direction like the
C vector PPT1->point, the point is on the right.
C So we build the scalar product. This is:
C  > 0, if the point is on the right
C  < 0, if the point is on the left
C  = 0, if the point is on the line
C and thus a candidate to serve as a return value of this function!

      PTROLN = DNX*(DPX-PPT1(1)) + DNY*(DPY-PPT1(2))

      END


      SUBROUTINE GCDBR2
     &          (dphi,clt1,cclt1,sclt1,clt2,cclt2,sclt2,rho,br,inb)

c***********************************************************************
c                   subroutine gcdbr2
c***********************************************************************

c  Program Source:  Naval Ocean Systems Center - Code 542

c  Date:
c     05 Apr 1990

c  Function:
c     Returns great circle distance and geographic bearing angle from
c     position 1 (P1) to position 2 (P2).

c  Parameters passed:
c     dphi          [r] longitude of P1 minus longitude of P2
c     clt1          [r] co-latitude of P1
c     cclt1         [r] cosine of clt1
c     sclt1         [r] sine   of clt1
c     clt2          [r] co-latitude of P2
c     cclt2         [r] cosine of clt2
c     sclt2         [r] sine   of clt2
c     rho           [r] great circle distance from P1 to P2
c     inb           [i] =0: RHO is computed and
c                           BR from P1 thru P2 is computed at 1
c                       =1: RHO is input    and
c                           BR from P1 thru P2 is computed at 2

c  Parameters returned:
c     rho           [r] great circle distance from P1 to P2
c     br            [r] geographic bearing angle of the path

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     abs
c     acos
c     cos
c     min
c     mod
c     sign
c     sin

c  References:

c  Change History:

c  Notes:
c     Sign convention is + for West and North.
c     All coordinates are in radians.

c*******************!***************************************************

      data          pi/3.1415926535898/,twopi/6.2831853071796/

      REDUCE(arg)=SIGN(MIN(ABS(arg),1.),arg)

      dl=MOD(dphi,twopi)
      adl=ABS(dl)
      if (ABS(clt1) .eq. 0. .or. ABS(clt1-pi) .eq. 0.) then
c        Point 1 is at one of the poles
         gcd=ABS(clt1-clt2)
         if (ABS(clt1) .eq. 0.) then
            br=pi-dl
         else
            br=dl
         end if
         if (br .lt. 0.) br=br+twopi
      else
     &if (adl .eq. 0.) then
c        Coordinates are on same longitude
         gcd=clt1-clt2
         if (gcd .ge. 0.) then
            br=0.
         else
            gcd=-gcd
            br=pi
         end if
      else
     &if (ABS(adl-pi) .eq. 0.) then
c        Coordinates are on opposite longitudes
         gcd=clt1+clt2
         if (gcd .le. pi) then
            if (inb .eq. 0) then
               br=0.
            else
               br=pi
            end if
         else
            gcd=twopi-gcd
            if (inb .eq. 0) then
               br=pi
            else
               br=0.
            end if
         end if
      else
         if (adl .ge. pi) then
            if (dl .ge. 0.) then
               dl=dl-twopi
            else
               dl=dl+twopi
            end if
         end if
         if (inb .eq. 0) then
            cgcd=cclt1*cclt2+sclt1*sclt2*COS(dl)
            gcd=ACOS(REDUCE(cgcd))
            if (gcd .eq. 0.) then
               br=0.
            else
               if (sclt1 .eq. 0.) then
c                 Point 1 is at one of the poles
                  if (ABS(clt1) .lt. .5*pi) then
                     br=pi
                  else
                     br=0.
                  end if
               else
                  br=ACOS(REDUCE((cclt2-cclt1*cgcd)/
     &                                 (sclt1*SIN(gcd))))
               end if
            end if
         else
            if (rho .gt. pi) then
               gcd=twopi-rho
            else
               gcd=rho
            end if
            if (gcd .eq. 0.) then
               br=0.
            else
               if (sclt2 .eq. 0.) then
c                 Point 2 is at one of the poles
                  if (ABS(clt2) .lt. .5*pi) then
                     br=pi
                  else
                     br=0.
                  end if
               else
                  br=pi-ACOS(REDUCE((cclt1-cclt2*COS(gcd))/
     &                                    (sclt2*SIN(gcd))))
               end if
            end if
         end if
         if (dl .lt. 0.) br=twopi-br
      end if
      if (inb .eq. 0) then
         rho=gcd
      else
         if (rho .gt. pi) then
c           Long path calculations
            if (br .lt. pi) then
               br=br+pi
            else
               br=br-pi
            end if
         end if
      end if

      RETURN
      END      ! GCDBR2


module functions

    use utils

    implicit none

contains

real(rk) function myfunc1(x)

    real(rk), intent(in) :: x

    myfunc1 = sin(x)

end function myfunc1

real(rk) function myfunc2(x)

    real(rk), intent(in) :: x

    myfunc2 = sqrt(x)

end function myfunc2

end module functions


C$Procedure      VSCLG ( Vector scaling, general dimension )

      SUBROUTINE VSCLG ( S, V1, NDIM, VOUT )

C$ Abstract
C
C     Multiply a scalar and a double precision vector of arbitrary
C     dimension.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C
C$ Declarations

      INTEGER            NDIM
      DOUBLE PRECISION   S
      DOUBLE PRECISION   V1   ( NDIM )
      DOUBLE PRECISION   VOUT ( NDIM )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     S          I   Scalar to multiply a vector.
C     V1         I   Vector to be multiplied.
C     NDIM       I   Dimension of V1 (and also VOUT).
C     VOUT       O   Product vector, S*V1.
C
C$ Detailed_Input
C
C     S      is a double precision scalar.
C
C     V1     is a double precision vector of arbitrary dimension.
C
C     NDIM   is the dimension of V1 (and VOUT).
C
C$ Detailed_Output
C
C     VOUT   is a double precision vector of arbitrary dimension
C            containing the product of the scalar with the vector V1.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     For each value of the index I from 1 to NDIM, this subroutine
C     performs the following multiplication
C
C        VOUT(I) = S * V1(I)
C
C     No error checking is performed to guard against numeric overflow
C     or underflow.
C
C$ Examples
C
C     The following table shows the results of VSCLG from various
C     inputs.
C
C        V1                 S           NDIM        VOUT
C        ----------------------------------------------------------
C        (1, 2, -3, 4)      3            4         ( 3,  6, -9, 12)
C        (1, 2, -3, 4)      0            4         ( 0,  0,  0,  0)
C        (1, 2, -3, 4)     -1            4         (-3, -6,  9,-12)
C
C$ Restrictions
C
C     No error checking is performed to guard against numeric overflow.
C     The programmer is thus required to insure that the values in V1
C     and S are reasonable and will not cause overflow.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     n-dimensional vector scaling
C
C-&

      INTEGER I

      DO I=1,NDIM
         VOUT(I) = S * V1(I)
      END DO

      RETURN
      END


module logic
  implicit none

contains

function xor(a, b)
  logical :: xor
  logical, intent(in) :: a, b

  xor = (a .and. .not. b) .or. (b .and. .not. a)
end function xor

function halfadder(a, b, c)
  logical :: halfadder
  logical, intent(in)  :: a, b
  logical, intent(out) :: c

  halfadder = xor(a, b)
  c = a .and. b
end function halfadder

function fulladder(a, b, c0, c1)
  logical :: fulladder
  logical, intent(in)  :: a, b, c0
  logical, intent(out) :: c1
  logical :: c2, c3

  fulladder = halfadder(halfadder(c0, a, c2), b, c3)
  c1 = c2 .or. c3
end function fulladder

subroutine fourbitadder(a, b, s)
  logical, intent(in)  :: a(0:3), b(0:3)
  logical, intent(out) :: s(0:4)
  logical :: c0, c1, c2

  s(0) = fulladder(a(0), b(0), .false., c0)
  s(1) = fulladder(a(1), b(1), c0, c1)
  s(2) = fulladder(a(2), b(2), c1, c2)
  s(3) = fulladder(a(3), b(3), c2, s(4))
end subroutine fourbitadder
end module

program Four_bit_adder
  use logic
  implicit none

  logical, dimension(0:3) :: a, b
  logical, dimension(0:4) :: s
  integer, dimension(0:3) :: ai, bi
  integer, dimension(0:4) :: si
  integer :: i, j

  do i = 0, 15
    a(0) = btest(i, 0); a(1) = btest(i, 1); a(2) = btest(i, 2); a(3) = btest(i, 3)
    where(a)
      ai = 1
    else where
      ai = 0
    end where
    do j = 0, 15
      b(0) = btest(j, 0); b(1) = btest(j, 1); b(2) = btest(j, 2); b(3) = btest(j, 3)
      where(b)
        bi = 1
      else where
        bi = 0
      end where
      call fourbitadder(a, b, s)
      where (s)
        si = 1
      elsewhere
        si = 0
      end where
      write(*, "(4i1,a,4i1,a,5i1)") ai(3:0:-1), " + ", bi(3:0:-1), " = ", si(4:0:-1)
    end do
  end do
end program


program poisson2D
	use poisson_module

	implicit none

	integer :: i,j,k,ret
	real, allocatable, dimension(:,:) :: u,u0,f
	real :: h, l2
	real :: t_start, t_end

	h = 1. / (N+1)

	allocate(u((N+1),(N+1)),u0((N+1),(N+1)),f((N+1),(N+1)))

	u0 = 0.
	do i = 2, N
		do j = 2, N
			f(i,j) = -2.*100. * M_PI * M_PI * sin(10.*M_PI*(i-1)*h) * sin(10.*M_PI*(j-1)*h)
		enddo
	enddo

	k = 0
	l2 = 1.
	call CPU_TIME(t_start)
	do while (l2 > eps)
		l2 = 0.

		do i = 2, N
			do j = 2, N
				u(i,j) = 0.25 * ( u0(i-1,j) + u0(i+1,j) + u0(i,j-1) + u0(i,j+1) - f(i,j)*h*h);
				! L2 norm
				l2 = l2 + (u0(i,j) - u(i,j))*(u0(i,j) - u(i,j));
			enddo
		enddo

		u0 = u
		! output
!		write(*,*) 'iteration',k,sqrt(l2)
!		ret=write_to_file_binary(N,c_loc(u(1)),k,-1.,1.)
		k = k + 1
	enddo
	call CPU_TIME(t_end)
	write(*,*) 'T',(t_end - t_start),'[s]'
	write(*,*) 'Nb steps',k,'l2',l2

	deallocate(u,u0,f)

end program poisson2D


program gauss_quad
  use tools

  implicit none
  real(dp) :: res
  integer :: a, b, k

  res = 0.0
  a = -2; b = 4
  k = 5

  call g_quad(k, a, b, res)

  print *, ''
  print *, 'result:'
  write (*, form_result2r) res, '-- the required result of the integration'
end program gauss_quad


! { dg-do run }
! testcase from PR 19032 adapted for testsuite
! Our implementation of modulo was wrong for P = 1 and P = -1,
! both in the real and the integer case
program main
  integer, parameter :: n=16
  real, dimension(n) :: ar, br, modulo_result, floor_result
  integer, dimension(n) :: ai, bi , imodulo_result, ifloor_result

  ai(1:4) = 5
  ai(5:8) = -5
  ai(9:12) = 1
  ai(13:16) = -1
  bi(1:4) = (/ 3,-3, 1, -1/)
  bi(5:8) = bi(1:4)
  bi(9:12) = bi(1:4)
  bi(13:16) = bi(1:4)
  ar = ai
  br = bi
  modulo_result = modulo(ar,br)
  imodulo_result = modulo(ai,bi)
  floor_result = ar-floor(ar/br)*br
  ifloor_result = nint(real(ai-floor(real(ai)/real(bi))*bi))

  do i=1,n
     if (modulo_result(i) /= floor_result(i) ) then
!        print "(A,4F5.0)" ,"real case failed: ", &
!             ar(i),br(i), modulo_result(i), floor_result(i)
        call abort()
    end if
    if (imodulo_result(i) /= ifloor_result(i)) then
!       print "(A,4I5)", "int case failed: ", &
!            ai(i), bi(i), imodulo_result(i), ifloor_result(i)
       call abort ()
     end if
  end do
end program main


ELEMENTAL FUNCTION func_degrees(x) RESULT(ans)
    ! This function returns the passed angle converted from radians to degrees.

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare input variables ...
    REAL(kind = REAL64), INTENT(in)                                             :: x        ! The input angle in radians.

    ! Declare output variables ...
    REAL(kind = REAL64)                                                         :: ans      ! The output angle in degrees.

    ! Set value ...
    ans = 180.0e0_REAL64 * x / const_pi                                         ! [deg]
END FUNCTION func_degrees


REAL FUNCTION ave_value(func, first_value, last_value, n)
IMPLICIT NONE
  REAL, EXTERNAL :: func
  REAL, INTENT(IN) :: first_value, last_value
  INTEGER, INTENT(IN) :: n
  REAL :: delta, sum
  INTEGER :: i

  delta = (last_value - first_value) / REAL(n - 1)
  sum = 0
  DO i = 1, n
    sum = sum + func(REAL(i - 1) * delta)
  END DO
  ave_value = sum / REAL(n)
END FUNCTION ave_value

PROGRAM test_ave_value
IMPLICIT NONE
  REAL :: ave_value
  REAL, EXTERNAL :: my_function
  REAL :: ave
  ave = ave_value(my_function, 0.0, 1.0, 1000001)
  WRITE(*, 1000) 'my_function', ave
  1000 FORMAT ('The average value of ', A, ' between 0.0 and 1.0 is ', &
               F16.8,'.')
END PROGRAM test_ave_value

REAL FUNCTION my_function(x)
IMPLICIT NONE
  REAL, INTENT(IN) :: x
  !my_function = SIN(X)**2
  my_function = 2.
END FUNCTION my_function


program problem24
  implicit none
  integer, parameter           :: digits=10
  integer                      :: n=1000000,i,j,temp,skip
  integer*1, dimension(digits) :: permskip,unused,answer

  n=n-1

  do i=digits,1,-1
     unused(i)=i-1
     if (n > 0) then
        temp=factorial(i-1)         ! size of a sub-permutation
        permskip(digits+1-i)=n/temp ! sub-permutations to skip before correct order of magnitude
        n=mod(n,temp)               ! residual after sub-permutations
     else
        permskip(digits+1-i)=0
     end if
  end do

  do i=1,digits
     skip=permskip(i)                             ! number of unused numbers to skip
     do j=1,digits
        if (unused(j) /= -1 .and. skip == 0) then ! if no more to skip ...
           answer(i)=unused(j)                    ! record unused number in answer
           unused(j)=-1                           ! record previously-unused number as used
           goto 1
        else if (unused(j) /= -1) then            ! skip
           skip=skip-1
        end if
     end do
1    continue
  end do

  print *, answer

contains

  pure function factorial(n)
    implicit none
    integer, intent(in) :: n
    integer             :: factorial,i

    factorial=1
    do i=1,n
       factorial=factorial*i
    end do

  end function factorial
end program problem24


! ****************************************************************************
! ... Module for variable types
! ... COSMO Project
! ... Quim Ballabrera, March 2017
! ... Version 0.1, released October 2017
! ****************************************************************************

module module_constants

use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan, ieee_is_nan, ieee_positive_inf

use module_types, only: sp,dp

implicit none

! ... Logical constants
! ...
logical, parameter     :: True    = .true.
logical, parameter     :: False   = .false.

! ... Mathematical constants
! ...
real(dp), parameter    :: minus   =-1.0_dp
real(dp), parameter    :: zero    = 0.0_dp
real(dp), parameter    :: one     = 1.0_dp
real(dp), parameter    :: two     = 2.0_dp
real(dp), parameter    :: three   = 3.0_dp
real(dp), parameter    :: four    = 4.0_dp
real(dp), parameter    :: five    = 5.0_dp
real(dp), parameter    :: six     = 6.0_dp
real(dp), parameter    :: seven   = 7.0_dp
real(dp), parameter    :: eight   = 8.0_dp
real(dp), parameter    :: nine    = 9.0_dp
real(dp), parameter    :: ten     = 10.0_dp
real(dp), parameter    :: half    = 0.5_dp
real(dp), parameter    :: quarter = 0.25_dp
real(dp), parameter    :: hundred = 100.0_dp
real(dp), parameter    :: pi      = 3.1415926535897932384626433832795_dp
real(dp), parameter    :: dpi     = 2.0_dp*pi
real(dp), parameter    :: hpi     = 0.5_dp*pi
real(dp), parameter    :: rpi     = 1.0D0/pi
real(dp), parameter    :: e_      = 2.7182818284590452353602874713527_dp
real(DP), parameter    :: deg2rad = pi/180.0_dp
real(DP), parameter    :: rad2deg = 180.0_dp/pi
COMPLEX(dp), parameter :: zj      = (0.0_dp, 1.0_dp)

! ... Nan and Inf
! ...
real(sp), parameter    :: nan4    = 0.0_sp/0.0_sp
real(sp), parameter    :: inf4    = 1.0_sp/0.0_sp
real(dp), parameter    :: nan     = 0.0_dp/0.0_dp
real(dp), parameter    :: inf     = 1.0_dp/0.0_dp

! ... Physical constants
! ...
real(dp), parameter    :: grav    = 9.80665_dp     ! m / s^2
real(dp), parameter    :: Omega   = 7.292E-5_dp    ! 1/s
real(dp), parameter    :: Rearth  = 6371315.0_dp   ! m

end module module_constants


      subroutine ascrv(x1,x2,x3,x4,x5,x6)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes shape parameters x5 and x6 for the S curve
!!    equation x = y/(y + exp(x5 + x6*y)) given 2 (x,y) points along the curve.
!!    x5 is determined by solving the equation with x and y values measured
!!    around the midpoint of the curve (approx. 50% of the maximum value for x)
!!    and x6 is determined by solving the equation with x and y values measured
!!    close to one of the endpoints of the curve (100% of the maximum value for
!!    x) This subroutine is called from readbsn.f and readcrop.f

      implicit none

      real :: xx                  !none          |temp variable, used to hold calculated
                                  !              |value needed in later equations

      real, intent (in) :: x1     !none          |value for x in the above equation for first
                                  !              |datapoint, x1 should be close to 0.5 (the
                                  !              |midpoint of the curve)
      real, intent (in) :: x2     !none          |value for x in the above equation for second
                                  !              |datapoint, x2 should be close to 0.0 or 1.0
      real, intent (in) :: x3     !none          |value for y in the above equation corresponding to x1
      real, intent (in) :: x4     !none          |value for y in the above equation corresponding to x2

      real, intent (out) :: x5    !none          |1st shape parameter for S curve equation
                                  !              |characterizing the midpoint of the curve
      real, intent (out) :: x6     !none          |2nd shape parameter for S curve equation
                                  !              |characterizing the regions close to the
                                  !              |endpoints of the curve

      xx = Log(x3/x1 - x3)
      x6 = (xx - Log(x4/x2 - x4)) / (x4 - x3)
      x5 = xx + (x3 * x6)

      return
      end


C$Procedure      SPHCYL ( Spherical to cylindrical coordinates )

      SUBROUTINE SPHCYL ( RADIUS, COLAT, SLONG, R, LONG, Z )

C$ Abstract
C
C     This routine converts from spherical coordinates to cylindrical
C     coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   RADIUS
      DOUBLE PRECISION   COLAT
      DOUBLE PRECISION   SLONG
      DOUBLE PRECISION   R
      DOUBLE PRECISION   LONG
      DOUBLE PRECISION   Z

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  -------------------------------------------------
C     RADIUS     I   Distance of point from origin.
C     COLAT      I   Polar angle (co-latitude in radians) of point.
C     SLONG      I   Azimuthal angle (longitude) of point (radians).
C     R          O   Distance of point from Z axis.
C     LONG       O   angle (radians) of point from XZ plane.
C     Z          O   Height of point above XY plane.
C
C$ Detailed_Input
C
C     RADIUS     Distance of the point from origin.
C
C     COLAT      Polar angle (co-latitude in radians) of the point.
C
C     SLONG      Azimuthal angle (longitude) of the point (radians).
C
C$ Detailed_Output
C
C     R          Distance of the point of interest from Z axis.
C
C     LONG       cylindrical angle (radians) of the point from the
C                XZ plane. LONG is set equal to SLONG.
C
C     Z          Height of the point above XY plane.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This returns the cylindrical coordinates of a point whose
C     position is input through spherical coordinates.
C
C$ Examples
C
C     Other than the obvious conversion between coordinate systems
C     this routine could be used to obtain the axial projection
C     from a sphere to a cylinder about the z-axis that contains
C     the equator of the sphere.  The following code fragment
C     illustrates this idea.
C
C           CALL SPHCYL ( RADIUS, COLAT, LONG, R, LONG, Z )
C           R = RADIUS
C
C     R, LONG, and Z now contain the coordinates of the projected
C     point. Such a projection is valuable because it preserves the
C     areas between regions on the sphere and their projections to the
C     cylinder.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     spherical to cylindrical coordinates
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C        Example section of header upgraded.
C
C-&

C
C     Local Variables
C
      DOUBLE PRECISION RR
      DOUBLE PRECISION ZZ

C
C     Convert to cylindrical coordinates, storing the results in
C     temporary variables.
C
      RR = RADIUS*DSIN(COLAT)
      ZZ = RADIUS*DCOS(COLAT)

C
C     Move the results to the output variables.
C
      LONG   = SLONG
      R      = RR
      Z      = ZZ

      RETURN
      END


! diffusion grid time step
where     (edge_type(1:n,1:m) == center)
   anew(1:n,1:m) = (a(1:n,1:m) + a(0:n-1,1:m) + a(2:n+1,1:m) + a(1:n,0:m-1) + a(1:n,2:m+1)) / 5

elsewhere (edge_type(1:n,1:m) == left)
   anew(1:n,1:m) = (a(1:n,1:m) + 2*a(2:n+1,1:m) + a(1:n,0:m-1) + a(1:n,2:m+1)) / 5

elsewhere (edge_type(1:n,1:m) == right)
   anew(1:n,1:m) = (a(1:n,1:m) + 2*a(0:n-1,1:m) + a(1:n,0:m-1) + a(1:n,2:m+1)) / 5

elsewhere (edge_type(1:n,1:m) == top)
   anew(1:n,1:m) = (a(1:n,1:m) + a(0:n-1,1:m) + a(2:n+1,1:m) + 2*a(1:n,2:m+1)) / 5

elsewhere (edge_type(1:n,1:m) == bottom)
   anew(1:n,1:m) = (a(1:n,1:m) + a(0:n-1,1:m) + a(2:n+1,1:m) + 2*a(1:n,0:m-1)) / 5

elsewhere (edge_type(1:n,1:m) == left_top)
   anew(1:n,1:m) = (a(1:n,1:m) + 2*a(2:n+1,1:m) + 2*a(1:n,2:m+1)) / 5

elsewhere (edge_type(1:n,1:m) == right_top)
   anew(1:n,1:m) = (a(1:n,1:m) + 2*a(0:n-1,1:m) + 2*a(1:n,2:m+1)) / 5

elsewhere (edge_type(1:n,1:m) == left_bottom)
   anew(1:n,1:m) = (a(1:n,1:m) + 2*a(2:n+1,1:m) + 2*a(1:n,0:m-1)) / 5

elsewhere (edge_type(1:n,1:m) == right_bottom)
   anew(1:n,1:m) = (a(1:n,1:m) + 2*a(0:n-1,1:m) + 2*a(1:n,0:m-1)) / 5

elsewhere      ! sink/source, does not change
   anew(1:n,1:m) = a(1:n,1:m)
end where


! Program to test the Riccati-Bessel Hankel functions
! and the Associated Legendre functions

program bessel_legendre_test
    use bessel_mod
    use legendre_mod
    implicit none

    real(8) :: x = 0.0707372d0
    integer, parameter :: n_max = 50
    integer, parameter :: m = 8
    integer :: i_index

    complex(8), allocatable :: rbh1(:)
    complex(8), allocatable :: rbh1_d(:)
    complex(8), allocatable :: rbh1_dd(:)
    complex(8), allocatable :: rbh2(:)
    complex(8), allocatable :: rbh2_d(:)
    complex(8), allocatable :: rbh2_dd(:)

    real(8), allocatable :: legendre(:)
    real(8), allocatable :: legendre_d(:)

    print *, "Riccati-Bessel Hankel"
    call rb_hankel1(n_max, x, rbh1, rbh1_d, rbh1_dd)
    call rb_hankel2(n_max, x, rbh2, rbh2_d, rbh2_dd)

    do i_index = 0, n_max
        print *, "n:", i_index
        print *, "riccati-bessel-hankel1_n(x)", rbh1(i_index)
        print *, "riccati-bessel-hankel2_n(x)", rbh2(i_index)
        print *, "(d/dx) riccati-bessel-hankel1_n(x)", rbh1_d(i_index)
        print *, "(d/dx) riccati-bessel-hankel2_n(x)", rbh2_d(i_index)
        print *, "(d/dx)^2 riccati-bessel-hankel1_n(x)", rbh1_dd(i_index)
        print *, "(d/dx)^2 riccati-bessel-hankel2_n(x)", rbh2_dd(i_index)
        print *,
    end do

    print *, "Associated Legendre"
    call associated_legendre(x, n_max=n_max, m=m, p_nm=legendre, p_nm_d=legendre_d)

    do i_index = 0, n_max
        print *, "l:", i_index, "; m:", m
        print *, "p_l^m(x):", legendre(i_index)
        print *, "(d/dx) p_l^m(x):", legendre_d(i_index)
        print *,
    end do

end program


subroutine wavenumbers(M, N, deltak, Lens)
use moduleone
!==================================================
! wavenumbers in BZ
!
!  Kprime (2Pi/3sqrt(3)a ,  2pi/3a  ) ;  K  (4pi/3asqrt3, 0 )
!                      -----
!                   /          \
!                   \          /
!                       ----
!
!!!          BZ for graphene
!
!  peiliang write at Feb. 2018
!==================================================
Implicit real (kind=DP) (a-h,o-z)

integer(kind=4), intent(in) ::M, N
real(KIND=DP), dimension(0:M,0:N) :: rankx, ranky
real(Kind=DP), intent(out):: deltaK
integer(kind=4), intent(OUT) :: Lens

Xbound=(4.0_DP*Pi)/(3.0_DP*sq3*carbondistance)
Ybound=(2.0_DP*Pi)/(3.0_DP*carbondistance)

deltak=2.0_DP*Ybound/real(N,DP)   !!  dependent on the value of N

!## open file  'wavenumber.dat'
open (unit =UNIT11, file = FILENAME11,  status="UNKNOWN" ,  iostat=ierror)
write(UNIT11,'(69("=") )')
write(UNIT11, '( 6(" "), a, 5(" "), a, 12(" "), a, 20(" "), a )' ) "M", "N", "Kx", "Ky"

Lens=0
do i=0,M
    do j=0,N
	   ranky(i,j)=real(j,DP)*deltak-Ybound

	   rankx(i,j)=real(i,DP)*deltak-Xbound

        if (    (ranky(i,j)>= -2.0_DP*Ybound+sq3*rankx(i,j) ) .and. &
				 (ranky(i,j)<= 2.0_DP*Ybound-sq3*rankx(i,j))  .and. &
		         ( ranky(i,j)>=-2.0_DP*Ybound-sq3*rankx(i,j)) .and. &
		         ( ranky(i,j)<= 2.0_DP*Ybound+sq3*rankx(i,j) ) .and. &
		         (rankx(i,j)<=Xbound)         ) then

		  write(UNIT11, '(1x, I6, I6, 2(1xES23.15E3) )') i, j, rankx(i,j), ranky(i,j)
		  Lens=Lens+1
		  !~ write(UNIT11, '(1x, I10, I6, I6, 2(1xES23.15E3) )') i, j, rankx(i,j), ranky(i,j)
		 end if
	end do
end do
close(UNIT11)

end subroutine wavenumbers

!~ ===============================================
			!~ second wavenumbers routine  wavenumbersII
!~ ===============================================

subroutine wavenumbersII( M, N, deltak, Lens,  fkx, fky )
use moduleone
!==================================================
! wavenumbers in BZ
!
!  Kprime (2Pi/3sqrt(3)a ,  2pi/3a  ) ;  K  (4pi/3asqrt3, 0 )
!                      -----
!                   /          \
!                   \          /
!                       ----
!
!!!          BZ for graphene
!
!  peiliang write at Feb. 2018
!==================================================
Implicit real (kind=DP) (a-h,o-z)

integer(kind=4), intent(in) ::M, N
integer(kind=4), intent(OUT) :: Lens
real(Kind=DP), intent(out):: deltaK
real(KIND=DP), dimension( 1:(M+1)*(N+1)  ),  intent(out) :: fkx, fky

fkx(:)=0.d0
fky(:)=0.d0

Xbound=(4.0_DP*Pi)/(3.0_DP*sq3*carbondistance)
Ybound=(2.0_DP*Pi)/(3.0_DP*carbondistance)
deltak=2.0_DP*Ybound/real(N,DP)   !!  dependent on the value of N

!## open file  'wavenumber.dat'
open (unit =UNIT11, file = FILENAME11,  status="UNKNOWN" ,  iostat=ierror)
write(UNIT11,'(69("=") )')
write(UNIT11, '( 6(" "), a, 5(" "), a, 12(" "), a, 20(" "), a )' ) "M", "N", "Kx", "Ky"

Lens=0
do i=0,M
    do j=0,N

	   rky=real(j,DP)*deltak-Ybound
	   rkx=real(i,DP)*deltak-Xbound

        if (    ( rky>= -2.0_DP*Ybound+sq3*rkx ) .and. &
				 ( rky<= 2.0_DP*Ybound-sq3*rkx )  .and. &
		         ( rky>=-2.0_DP*Ybound-sq3*rkx ) .and. &
		         ( rky<= 2.0_DP*Ybound+sq3*rkx ) .and. &
		         ( rkx<=Xbound)         ) then
		  write(UNIT11, '(1x, I6, I6, 2(1xES23.15E3) )') i, j, rkx, rky
		  Lens=Lens+1
          fkx(Lens)=rkx
          fky(Lens)=rky
		 end if
	end do
end do
close(UNIT11)

end subroutine wavenumbersII

!-------------------------------------------------------------------------
       !~ BANDSTRUCTURE KPOINTS
!-------------------------------------------------------------------------

subroutine BandKs(Blens, Bkx, Bky)
use moduleone
Implicit real (kind=DP) (a-h,o-z)
integer(kind=4):: Blens   !  839
real   (KIND=DP), dimension(0:Blens-1) :: Bkx, Bky

!~ sq3=dsqrt(3.0_DP)
sin30=sin(pi/6.0d0)
cos30=cos(pi/6.0d0)

Bkxbound=(4.0_DP*Pi)/(3.0_DP*sq3*carbondistance)
deltaBkx=Bkxbound*(1.50d0+0.5d0*sq3)/real(514-2)

BMX=pi/(sq3*carbondistance)
BMY=Pi/(3.0_DP*carbondistance)

open (unit =UNIT6, file = FILENAME6,  status="UNKNOWN" , ACTION="WRITE", iostat=ierror)
!write (UNIT6, '(60("="))' )
!write(UNIT6,'(a)')
!write(UNIT6,'( a)') 'Bkxs       and           Bkys'
!write(UNIT6,'( 60("-") )')

do i=0, 839

If (i <= 186 ) then

Bkx(i)=real(i)*deltaBkx*cos30
Bky(i)=real(i)*deltaBkx*sin30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==187 ) then

Bkx(i)=BMX
Bky(i)=BMY
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GE. 188)  .and.  (i .LE. 295)  ) then

Bkx(i)=BMX+ real(i-187)*deltaBkx*sin30
Bky(i)=BMY- real(i-187)*deltaBkx*cos30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==296 ) then

Bkx(i)=Bkxbound
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GE. 297)  .and.  (i .LE. 512)  ) then

Bkx(i)=Bkxbound- real(i-296)*deltaBkx
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GE. 513)  .and.  (i .LE. 729)  ) then

Bkx(i)=real(i-513)*deltaBkx*sin30
Bky(i)=real(i-513)*deltaBkx*cos30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==730 ) then

Bkx(i)=Bkxbound*0.5d0
Bky(i)=BMY*2.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GE. 731)  .and.  (i .LE. 838)  ) then

Bkx(i)=Bkxbound*0.5d0+ real(i-730)*deltaBkx*sin30
Bky(i)=BMY*2.0d0- real(i-730)*deltaBkx*cos30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==839 ) then

Bkx(i)=BMX
Bky(i)=BMY
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

end if
end do
close(UNIT6)
end subroutine   BandKs

!-------------------------------------------------------------------------
       !~ BANDSTRUCTURE KPOINTS   II
!-------------------------------------------------------------------------

subroutine BandKs2(Blens, Bkx, Bky)
use moduleone
Implicit real (kind=DP) (a-h,o-z)
integer(kind=4):: Blens   !  514
real   (KIND=DP), dimension(0:Blens-1) :: Bkx, Bky

!~ sq3=dsqrt(3.0_DP)
sin30=sin(pi/6.0d0)
cos30=cos(pi/6.0d0)

Bkxbound=(4.0_DP*Pi)/(3.0_DP*sq3*carbondistance)
deltaBkx=Bkxbound*(1.50d0+0.5d0*sq3)/real(514-2)

BMX=pi/(sq3*carbondistance)
BMY=Pi/(3.0_DP*carbondistance)

open (unit =UNIT6, file = FILENAME6,  status="UNKNOWN" , ACTION="WRITE", iostat=ierror)
!write (UNIT6, '(60("="))' )
!write(UNIT6,'(a)')
!write(UNIT6,'( a)') 'Bkxs       and           Bkys'
!write(UNIT6,'( 60("-") )')

do i=0, 513

If (i <= 186 ) then

Bkx(i)=real(i)*deltaBkx*cos30
Bky(i)=real(i)*deltaBkx*sin30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==187 ) then

Bkx(i)=BMX
Bky(i)=BMY
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GE. 188)  .and.  (i .LE. 295)  ) then

Bkx(i)=BMX+ real(i-187)*deltaBkx*sin30
Bky(i)=BMY- real(i-187)*deltaBkx*cos30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==296 ) then

Bkx(i)=Bkxbound
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GE. 297)  .and.  (i .LE. 512)  ) then

Bkx(i)=Bkxbound- real(i-296)*deltaBkx
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==513 ) then

Bkx(i)=0.0d0
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

end if
end do
close(UNIT6)
end subroutine   BandKs2

!-------------------------------------------------------------------------
       !~ BANDSTRUCTURE KPOINTS   III
!-------------------------------------------------------------------------

subroutine BandKs3(Blens, Bkx, Bky)
use moduleone
Implicit real (kind=DP) (a-h,o-z)
integer(kind=4):: Blens   !
real   (KIND=DP), dimension(0:Blens-1) :: Bkx, Bky

!~ sq3=dsqrt(3.0_DP)
sin30=sin(pi/6.0d0)
cos30=cos(pi/6.0d0)

Bkxbound=(4.0_DP*Pi)/(3.0_DP*sq3*carbondistance)
!~ deltaBkx=Bkxbound*(1.50d0+0.5d0*sq3)/real(Blens-2)

deltaBkx1=Bkxbound*0.5d0*sq3/real(30)

deltaBkx2=Bkxbound*0.5d0/real(24)

deltaBkx3=Bkxbound/real(29)

BMX=pi/(sq3*carbondistance)
BMY=Pi/(3.0_DP*carbondistance)

open (unit =UNIT6, file = FILENAME6,  status="UNKNOWN" , ACTION="WRITE", iostat=ierror)
!write (UNIT6, '(60("="))' )
!write(UNIT6,'(a)')
!write(UNIT6,'( a)') 'Bkxs       and           Bkys'
!write(UNIT6,'( 60("-") )')

do i=0, 85

If (i <= 29 ) then

Bkx(i)=real(i)*deltaBkx1*cos30
Bky(i)=real(i)*deltaBkx1*sin30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==30 ) then

Bkx(i)=BMX
Bky(i)=BMY
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GT. 30)  .and.  (i .LE. 54)  ) then

Bkx(i)=BMX+ real(i-30)*deltaBkx2*sin30
Bky(i)=BMY- real(i-30)*deltaBkx2*cos30
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==55 ) then

Bkx(i)=Bkxbound
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( (i.GT. 55)  .and.  (i .LE. 84)  ) then

Bkx(i)=Bkxbound- real(i-55)*deltaBkx3
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

else if ( i==85 ) then

Bkx(i)=0.0d0
Bky(i)=0.0d0
write(UNIT6, '(1x,2(1xE18.11) )') Bkx(i),  Bky(i)

end if
end do
close(UNIT6)
end subroutine   BandKs3

!~ ========================================
                       !~ wavenumberlocal
!~ ========================================

subroutine wavenumberlocal( Lens, vectorx, vectory,  wkx, wky, Qx, Qy,  M )

use moduleone
Implicit real (kind=DP) (a-h,o-z)

integer(kind=4), intent(IN):: Lens
real(kind=DP),dimension(1:Lens), intent(in):: vectorx, vectory
real(kind=DP)::  kx, ky, Qx, Qy, wkx, wky
integer(kind=4),intent(out):: M

integer:: Local(1)
complex(kind=DP), dimension(Lens):: Cks
real(kind=DP), dimension(Lens) :: RCKS
complex(kind=DP)::  CKQ

!~ write(*,*)
!~ write(*, '(13x, 2(1xES23.15E3) )' ) vectorx(12),  vectory(12)
!~ write(*,*)

Cks=CMPLX( vectorx, vectory)

!~ write(*,*)
!~ write(*,*) Cks(12)

!~ write(*, '( a )' )
!~ write(*, '( a, I6 )'  ) "Subroutine Lens is::", lens

Bvector1x=(2.0_DP*Pi)/(sq3*carbondistance)
Bvector1y=(2.0_DP*Pi)/(3.0_DP*carbondistance)
Xbound=(4.0_DP*Pi)/(3.0_DP*sq3*carbondistance)
Ybound=(2.0_DP*Pi)/(3.0_DP*carbondistance)

!~ write(*,*)
!~ write(*, '( 2(1xES23.15E3) )') kx, ky

kx=wkx+Qx
ky=wky+Qy

!~ write(*,*)
!~ write(*,*) kx, ky

if(    ky>= sq3*kx          .and. &
					   ky> Ybound              .and. &
					   ky>= -sq3*kx   )   then
		    ky=ky-2.0_DP*Bvector1y
		else if (  ky>=0.0d0                 .and. &
					   ky<= sq3*kx         .and. &
					   ky> 2.0_DP*Ybound-sq3*kx   ) then
             kx=kx-Bvector1x
		     ky=ky-Bvector1y
		else if (  ky<=0.0d0                 .and. &
					   ky>=-sq3*kx         .and. &
					   ky< -2.0_DP*Ybound+sq3*kx   ) then
             kx=kx-Bvector1x
		     ky=ky+Bvector1y
		else if (  ky<= sq3*kx          .and. &
					   ky< -Ybound              .and. &
					   ky<= -sq3*kx   )   then
		     ky=ky+2.0_DP*Bvector1y
		else if (  ky<=0.0d0                 .and. &
					   ky>= sq3*kx         .and. &
					   ky< -2.0_DP*Ybound-sq3*kx   ) then
             kx=kx+Bvector1x
		     ky=ky+Bvector1y
		else if (  ky>=0.0d0                 .and. &
					   ky<=-sq3*kx         .and. &
					   ky> 2.0_DP*Ybound+sq3*kx   ) then
             kx=kx+Bvector1x
		     ky=ky-Bvector1y
end if

!~ write(*,*)
!~ write(*,*) kx, ky

CKQ=CMPLX(kx, ky)
   !~ write(*, '( a )' )
   !~ write(*, *  ) CKQ
Cks=Cks-CKQ

do i=1, Lens
        RCKS(i)=abs(Cks(i) )
end do

Local=MINLOC( RCks )
M=Local(1)

   !~ write(*, '( a )' )
   !~ write(*, '( I6 )'  ) Local
   !~ write(*, '( a )' )
   !~ write(*, '( I6 )'  ) Local(1)

end subroutine wavenumberlocal


program sin_02
use, intrinsic :: iso_fortran_env, only: dp => real64
implicit none

real(dp), parameter :: pi = 3.1415926535897932384626433832795_dp
real(dp) :: x, r1, r2, err

x = 10.5_dp
r1 = dsin(x)
r2 = -0.87969575997167_dp
err = abs(r1-r2)
print *, x, r1, r2
print *, err
if (err > 1e-15_dp) error stop

contains

real(dp) function abs(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = -x
end if
end function

elemental integer function floor(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = x-1
end if
end function

elemental real(dp) function modulo(x, y) result(r)
real(dp), intent(in) :: x, y
r = x-floor(x/y)*y
end function

elemental real(dp) function min(x, y) result(r)
real(dp), intent(in) :: x, y
if (x < y) then
    r = x
else
    r = y
end if
end function

elemental real(dp) function max(x, y) result(r)
real(dp), intent(in) :: x, y
if (x > y) then
    r = x
else
    r = y
end if
end function

elemental real(dp) function dsin(x) result(r)
real(dp), intent(in) :: x
real(dp) :: y
integer :: n
y = modulo(x, 2*pi)
y = min(y, pi - y)
y = max(y, -pi - y)
y = min(y, pi - y)
r = kernel_dsin(y)
end function

! Accurate on [-pi/2,pi/2] to about 1e-16
elemental real(dp) function kernel_dsin(x) result(res)
real(dp), intent(in) :: x
real(dp), parameter :: S1 = 0.9999999999999990771_dp
real(dp), parameter :: S2 = -0.16666666666664811048_dp
real(dp), parameter :: S3 = 8.333333333226519387e-3_dp
real(dp), parameter :: S4 = -1.9841269813888534497e-4_dp
real(dp), parameter :: S5 = 2.7557315514280769795e-6_dp
real(dp), parameter :: S6 = -2.5051823583393710429e-8_dp
real(dp), parameter :: S7 = 1.6046585911173017112e-10_dp
real(dp), parameter :: S8 = -7.3572396558796051923e-13_dp
real(dp) :: z
z = x*x
res = x * (S1+z*(S2+z*(S3+z*(S4+z*(S5+z*(S6+z*(S7+z*S8)))))))
end function

end program


program test_trace
use types, only: dp
use utils, only: assert
use linalg, only: trace
use constants, only : i_
implicit none

real(dp), parameter :: eps = 1e-9_dp
real(dp) :: A(3,3)
complex(dp) :: B(3,3)

A = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], shape=[3,3], order=[2,1])
call assert(abs(trace(A) - 15.0_dp) < eps)

B = i_*reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], shape=[3,3], order=[2,1])
call assert(abs(trace(B) - 15*i_) < eps)

end program


subroutine lu(a, deter)
  implicit none

  real, dimension(:,:), intent(inout) :: a
  real, intent(out) :: deter

  integer :: n, j, i, r, k

  n = size(a(1,:))
  deter = 1

  do r = 2,n
    if(abs(a(1,1)) < 1.e-12) then
      print*, 'ERROR!'
      stop
    end if
    a(r,1) = a(r,1)/a(1,1)
  end do

  do i=2,n
    do j=i,n
      do k=1,i-1
        a(i,j) = a(i,j) - a(i,k)*a(k,j)
      end do
    end do

    do r=i+1,n
      do k=1,i-1
        a(r,i) = a(r,i) - a(r,k)*a(k,i)
      end do
      if(abs(a(i,i)) < 1.e-12) then
        print*, 'ERROR!'
        stop
      end if
      a(r,i) = a(r,i)/a(i,i)
    end do
  end do
end subroutine


    Program dsygst_example

!     DSYGST 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: dpotrf, dsterf, dsygst, dsytrd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, lda, ldb, lwork, n
      Character (1) :: uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), d(:), e(:), tau(:), &
        work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DSYGST Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      lwork = 64*n
      Allocate (a(lda,n), b(ldb,n), d(n), e(n-1), tau(n), work(lwork))

!     Read A and B from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)(a(i,i:n), i=1, n)
        Read (nin, *)(b(i,i:n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)(a(i,1:i), i=1, n)
        Read (nin, *)(b(i,1:i), i=1, n)
      End If

!     Compute the Cholesky factorization of B
      Call dpotrf(uplo, n, b, ldb, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'B is not positive definite.'
      Else

!       Reduce the problem to standard form C*y = lambda*y, storing
!       the result in A
        Call dsygst(1, uplo, n, a, lda, b, ldb, info)

!       Reduce C to tridiagonal form T = (Q**T)*C*Q
        Call dsytrd(uplo, n, a, lda, d, e, tau, work, lwork, info)

!       Calculate the eigenvalues of T (same as C)
        Call dsterf(n, d, e, info)

        If (info>0) Then
          Write (nout, *) 'Failure to converge.'
        Else

!         Print eigenvalues

          Write (nout, *) 'Eigenvalues'
          Write (nout, 100) d(1:n)
        End If
      End If

100   Format (3X, (9F8.4))
    End Program


!> 计算光滑函数 Wij 及其倒数 dWdxij 的子例程
!> subroutine to calculate the smoothing kernel wij and its
!> derivatives dwdxij.
subroutine kernel(r, dx, hsml, w, dwdx)

    use sph_kind, only: rk
    use parameter
    implicit none

    !> 粒子 i 和 j 之间的距离
    !> distance between particles i and j
    real(rk), intent(in) :: r
    !> 粒子 i 和 j 之间的坐标差
    !> x-, y- and z-distance between i and j
    real(rk), intent(in) :: dx(dim)
    !> 粒子的光滑长度
    !> smoothing length
    real(rk), intent(in) :: hsml
    !> 给定相互作用对的光滑核函数
    !> kernel for all interaction pairs
    real(rk), intent(out) :: w
    !> 核函数对 x, y, z 的导数
    !> derivative of kernel with respect to x, y and z
    real(rk), intent(out) :: dwdx(dim)

    integer :: i, j, d
    real(rk) :: q, dw, factor

    q = r/hsml
    w = 0._rk
    do d = 1, dim
        dwdx(d) = 0._rk
    end do

    if (skf == 1) then

        if (dim == 1) then
            factor = 1._rk/hsml
        else if (dim == 2) then
            factor = 15._rk/(7._rk*pi*hsml*hsml)
        else if (dim == 3) then
            factor = 3._rk/(2._rk*pi*hsml*hsml*hsml)
        else
            print *, ' >>> error <<< : wrong dimension: dim =', dim
            stop
        end if
        if (q >= 0 .and. q <= 1._rk) then
            w = factor*(2._rk/3._rk - q*q + q**3._rk/2._rk)
            do d = 1, dim
                dwdx(d) = factor*(-2._rk + 3._rk/2._rk*q)/hsml**2*dx(d)
            end do
        else if (q > 1._rk .and. q <= 2) then
            w = factor*1._rk/6._rk*(2._rk - q)**3
            do d = 1, dim
                dwdx(d) = -factor*1._rk/6._rk*3.*(2._rk - q)**2/hsml*(dx(d)/r)
            end do
        else
            w = 0._rk
            do d = 1, dim
                dwdx(d) = 0._rk
            end do
        end if

    else if (skf == 2) then

        factor = 1._rk/(hsml**dim*pi**(dim/2._rk))
        if (q >= 0 .and. q <= 3) then
            w = factor*exp(-q*q)
            do d = 1, dim
                dwdx(d) = w*(-2._rk*dx(d)/hsml/hsml)
            end do
        else
            w = 0._rk
            do d = 1, dim
                dwdx(d) = 0._rk
            end do
        end if

    else if (skf == 3) then

        if (dim == 1) then
            factor = 1._rk/(120._rk*hsml)
        else if (dim == 2) then
            factor = 7._rk/(478._rk*pi*hsml*hsml)
        else if (dim == 3) then
            factor = 1._rk/(120._rk*pi*hsml*hsml*hsml)
        else
            print *, ' >>> error <<< : wrong dimension: dim =', dim
            stop
        end if
        if (q >= 0 .and. q <= 1) then
            w = factor*((3 - q)**5 - 6*(2 - q)**5 + 15*(1 - q)**5)
            do d = 1, dim
                dwdx(d) = factor*((-120 + 120*q - 50*q**2)/hsml**2*dx(d))
            end do
        else if (q > 1 .and. q <= 2) then
            w = factor*((3 - q)**5 - 6*(2 - q)**5)
            do d = 1, dim
                dwdx(d) = factor*(-5*(3 - q)**4 + 30*(2 - q)**4)/hsml*(dx(d)/r)
            end do
        else if (q > 2 .and. q <= 3) then
            w = factor*(3 - q)**5
            do d = 1, dim
                dwdx(d) = factor*(-5*(3 - q)**4)/hsml*(dx(d)/r)
            end do
        else
            w = 0._rk
            do d = 1, dim
                dwdx(d) = 0._rk
            end do
        end if

    end if

end subroutine kernel


module averages
use types, only: dp
use constants, only: pi
implicit none
private
public arit, arit2, rmean, smean

contains

real(dp) function arit(longitude, latitude, field, mask) result(r)
! field is (long, lat), mask is the same shape,
! only .true. elements will be considered
! longitude is [-180, 180], latitude is [-90, 90]
real(dp), intent(in) :: longitude(:), latitude(:), field(:, :)
logical, intent(in) :: mask(:, :)
real(dp) :: w(size(field, 1), size(field, 2))
w = spread(cos(latitude*pi/180), 1, size(longitude))
w = w / sum(w)
r = sum(field*w, mask=mask) / sum(w, mask=mask)
end function

real(dp) function rmean(longitude, latitude, field, mask, r) result(m)
! field is (long, lat), mask is the same shape,
! only .true. elements will be considered
! longitude is [-180, 180], latitude is [-90, 90]
real(dp), intent(in) :: longitude(:), latitude(:), field(:, :)
logical, intent(in) :: mask(:, :)
real(dp), intent(in) :: r
real(dp) :: w(size(field, 1), size(field, 2))
w = spread(cos(latitude*pi/180), 1, size(longitude))
w = w / sum(w)
m = (sum(field**r * w, mask=mask) / sum(w, mask=mask))**(1/r)
end function

real(dp) function smean(longitude, latitude, field, mask, s) result(m)
! field is (long, lat), mask is the same shape,
! only .true. elements will be considered
! longitude is [-180, 180], latitude is [-90, 90]
real(dp), intent(in) :: longitude(:), latitude(:), field(:, :)
logical, intent(in) :: mask(:, :)
real(dp), intent(in) :: s
real(dp) :: w(size(field, 1), size(field, 2))
w = spread(cos(latitude*pi/180), 1, size(longitude))
w = w / sum(w)
m = log(sum(exp(s*field) * w, mask=mask) / sum(w, mask=mask)) / s
end function

real(dp) function arit2(longitude, latitude, field, mask) result(r)
! field is (long, lat), mask is the same shape,
! only .true. elements will be considered
! longitude is [-180, 180], latitude is [-90, 90]
real(dp), intent(in) :: longitude(:), latitude(:), field(:, :)
logical, intent(in) :: mask(:, :)
real(dp) :: tmp(size(mask, 2)), w(size(mask, 2))
integer :: tmp2(size(mask, 1)), n
logical :: tmp_mask(size(mask, 2))
integer :: i
w = sin(pi/144) * cos(latitude*pi/180)
tmp2 = 1
do i = 1, size(field, 2)
    n = sum(tmp2, mask=mask(:, i))
    if (n == 0) then
        tmp_mask(i) = .false.
    else
        tmp(i) = sum(field(:, i), mask=mask(:, i)) / n
        tmp_mask(i) = .true.
    end if
end do
r = sum(tmp*w, mask=tmp_mask) / sum(w, mask=tmp_mask)
end function

end module


c
c
c      this file contains some common routines for helmrouts3d
c      and helmrouts3d_vec
c
c      h3d01: computes h0, h1 (first two spherical Hankel fns.)
c      h3dall: computes Hankel functions of all orders and scales them
c
c      h3dadd: adds one expansion to another
c
c      h3dadd_trunc: adds one expansion to another
c                 allowing for different spherical harmonic array dimensions
c
c
c**********************************************************************
      subroutine h3d01(z,h0,h1)
c**********************************************************************
c
c     Compute spherical Hankel functions of order 0 and 1
c
c     h0(z)  =   exp(i*z)/(i*z),
c     h1(z)  =   - h0' = -h0*(i-1/z) = h0*(1/z-i)
c
c-----------------------------------------------------------------------
c     INPUT:
c
c	z   :  argument of Hankel functions
c              if abs(z)<1.0d-15, returns zero.
c
c-----------------------------------------------------------------------
c     OUTPUT:
c
c	h0  :  h0(z)    (spherical Hankel function of order 0).
c	h1  :  -h0'(z)  (spherical Hankel function of order 1).
c
c-----------------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      complex *16 z,zinv,eye,cd,h0,h1
      data eye/(0.0d0,1.0d0)/, thresh/1.0d-15/, done/1.0d0/
c
      if (abs(z).lt.thresh) then
         h0=0.0d0
         h1=0.0d0
         return
      endif
c
c     Otherwise, use formula
c
      cd = eye*z
      h0=exp(cd)/cd
      h1=h0*(done/z - eye)
c
      return
      end
c
c
c
c**********************************************************************
      subroutine h3dall(nterms,z,scale,hvec,ifder,hder)
c**********************************************************************
c
c     This subroutine computes scaled versions of the spherical Hankel
c     functions h_n of orders 0 to nterms.
c
c       	hvec(n)= h_n(z)*scale^(n)
c
c     The parameter SCALE is useful when |z| < 1, in which case
c     it damps out the rapid growth of h_n as n increases. In such
c     cases, we recommend setting
c
c               scale = |z|
c
c     or something close. If |z| > 1, set scale = 1.
c
c     If the flag IFDER is set to one, it also computes the
c     derivatives of h_n.
c
c		hder(n)= h_n'(z)*scale^(n)
c
c     NOTE: If |z| < 1.0d-15, the subroutine returns zero.
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nterms  : highest order of the Hankel functions to be computed.
c     z       : argument of the Hankel functions.
c     scale   : scaling parameter discussed above
c     ifder   : flag indcating whether derivatives should be computed.
c		ifder = 1   ==> compute
c		ifder = 0   ==> do not compute
c
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     hvec    : the vector of spherical Hankel functions
c     hder    : the derivatives of the spherical Hankel functions
c
c-----------------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      complex *16 hvec(0:*),hder(0:*)
      complex *16 zk2,z,zinv,ztmp,fhextra
c
      data thresh/1.0d-15/,done/1.0d0/
c
c     If |z| < thresh, return zeros.
c
      if (abs(z).lt.thresh) then
         do i=0,nterms
            hvec(i)=0
            hder(i)=0
         enddo
         return
      endif
c
c     Otherwise, get h_0 and h_1 analytically and the rest via
c     recursion.
c
      call h3d01(z,hvec(0),hvec(1))
      hvec(0)=hvec(0)
      hvec(1)=hvec(1)*scale
c
c     From Abramowitz and Stegun (10.1.19)
c
c     h_{n+1}(z)=(2n+1)/z * h_n(z) - h_{n-1}(z)
c
c     With scaling:
c
c     hvec(n+1)=scale*(2n+1)/z * hvec(n) -(scale**2) hvec(n-1)
c
      scal2=scale*scale
      zinv=scale/z
      do i=1,nterms-1
	 dtmp=(2*i+done)
	 ztmp=zinv*dtmp
	 hvec(i+1)=ztmp*hvec(i)-scal2*hvec(i-1)
      enddo
c
c     From Abramowitz and Stegun (10.1.21)
c
c	h_{n}'(z)= h_{n-1}(z) - (n+1)/z * h_n(z)
c
c     With scaling:
c
c     hder(n)=scale* hvec(n-1) - (n+1)/z * hvec(n)
c
c
      if (ifder.eq.1) then
c
	 hder(0)=-hvec(1)/scale
         zinv=1.0d0/z
         do i=1,nterms
	    dtmp=(i+done)
	    ztmp=zinv*dtmp
	    hder(i)=scale*hvec(i-1)-ztmp*hvec(i)
	 enddo
      endif
c
      return
      end
c
c
c
c**********************************************************************
      subroutine h3dadd(nd,mpole,mpole2,nterms)
c**********************************************************************
c
c     add mpole to mpole2
c
c----------------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      integer nd
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      complex *16 mpole2(nd,0:nterms,-nterms:nterms)
c
      do i = 0,nterms
         do j = -i,i
           do idim=1,nd
     	    mpole2(idim,i,j) = mpole2(idim,i,j)+mpole(idim,i,j)
           enddo
	 enddo
      enddo
      return
      end
c
c
c
c**********************************************************************
      subroutine h3dadd_trunc(mpole,mpole2,nterms,ldc)
c**********************************************************************
c
c     add mpole to mpole2
c
c----------------------------------------------------------------------
      implicit real *8 (a-h,o-z)
      complex *16 mpole(0:nterms,-nterms:nterms)
      complex *16 mpole2(0:ldc,-ldc:ldc)
c
      do i = 0,nterms
         do j = -i,i
	    mpole2(i,j) = mpole2(i,j)+mpole(i,j)
	 enddo
      enddo
      return
      end


! { dg-do run }
! Test the fix for PR61406
! Contributed by Adam Hirst  <adam@aphirst.karoo.co.uk>
program test
  implicit none
  real :: theta = 1.0

  associate (n => [cos(theta), sin(theta)])
    if (abs (norm2(n) - 1.0) .gt. 1.0e-4) STOP 1
  end associate

end program test


    program dofft
! Fortran example.
! Compile line:
! ifort -mkl $MKLROOT/include/mkl_dfti.f90  -O3 tfft.f90 -o tfft
! 1D complex to complex, and real to conjugate-even
    Use MKL_DFTI
    integer count0,count1,count2,count3,count4, COUNT_RATE, COUNT_MAX
!    integer,parameter::mysize=32,mysize2=34
!    integer,parameter::mysize=13200000,mysize2=13200002
    integer,parameter::mysize=35,mysize2=mysize+2
    Complex :: X(mysize)
    Real :: Y(mysize2)
    Real :: rp,cp
    integer ic
    type(DFTI_DESCRIPTOR), POINTER :: My_Desc1_Handle, My_Desc2_Handle
    Integer :: Status
!...put input data into X(1),...,X(mysize); Y(1),...,Y(mysize)
    call SYSTEM_CLOCK(COUNT0, COUNT_RATE, COUNT_MAX)
    do i=1,mysize
      x(i)=i*i
      y(i)=i*i
    end do
    call SYSTEM_CLOCK(COUNT1)
! Perform a complex to complex transform
    Status = DftiCreateDescriptor( My_Desc1_Handle, DFTI_SINGLE, DFTI_COMPLEX, 1, mysize )
    Status = DftiCommitDescriptor( My_Desc1_Handle )
    Status = DftiComputeForward( My_Desc1_Handle, X )
    Status = DftiFreeDescriptor(My_Desc1_Handle)
    call SYSTEM_CLOCK(COUNT2)
    write(*,*)"! result is given by {X(1),X(2),...,X(mysize)}",mysize
    jline=1
    do i=1,min(64,mysize)
        write(*,*)jline,x(i)
        jline=jline+1
    end do
! Perform a real to complex conjugate-even transform
    call SYSTEM_CLOCK(COUNT3)
    Status = DftiCreateDescriptor(My_Desc2_Handle, DFTI_SINGLE, DFTI_REAL, 1, mysize)
    Status = DftiCommitDescriptor(My_Desc2_Handle)
    Status = DftiComputeForward(My_Desc2_Handle, Y)
    Status = DftiFreeDescriptor(My_Desc2_Handle)
    write(*,*)"! result is given in CCS format.",mysize
    call SYSTEM_CLOCK(COUNT4)
    ic=0
    jline=1
    do i=1,min(64,mysize2)
    	if(ic == 0)then
    	  rp=y(i)
    	  ic=1
    	else
    	  cp=y(i)
          write(*,*)jline,rp,cp,sqrt(rp*rp+cp*cp)
          ic=0
          jline=jline+1
        endif
    end do
    write(*,*)y
    write(*,*)
    write(*,*)"create time      ",real(count1-count0)/real(count_rate)
    write(*,*)"complex fft time ",real(count2-count1)/real(count_rate)
    write(*,*)"real fft time    ",real(count4-count3)/real(count_rate)
    write(*,*)COUNT0, COUNT_RATE, COUNT_MAX
    end program