!---------------------------------------------------------------------------
! This is a fortran90 program to evaluate the 2 dimension laplace equation:
!   Fxx + Fyy = 0
!   {F(Xi+1,Yj)-2*(Fxi,Yj)+F(Xi-1,Yj)}/dX^2 +
!   {F(Xi,Yj+1)-2*F(Xi,Yj)+F(Xi,Yj-1)}/dY^2 = 0
!   for 1/2 >= {x,y} >= 0
!
! The boundary conditions are:
!   f(x=0,y) = 0
!   f(x,y=0) = 0
!   f(x=1/2,y) = 200y
!   f(x,y=1/2) = 200x
! In this example the boundary condition represents temperature in degC.
!
! Mapping:
!   i,j goes from 1 to N-1
!   i,j at the edges (0 and N) are constrained by the boundary conditions
!
! 2017-03-15
!      - working now, 171 iterations needed
!
! 2017-03-06
!      - Initial try.
!      - jacobi method:
!        1. fill f square with boundary conditions,
!        2. iterate through each interior square, where:
!           U(i,j) = (1/4)*{(U(i-1,j)+U(i+1,j)+U(i,j-1)+U(i,j+1)}
!        3. how many iterations does it take to converge?
!        4. compare error.
!      - based on professor xxx's code,
!      - written by xxx.
!---------------------------------------------------------------------------

program part3_jacobi_10
  implicit none

  integer, parameter :: N=10,NM1=N-1,M=NM1*NM1

  real ALX,ALY,dx,dy
  real tolerance, error2, error

  real, dimension (0:N,0:N)  :: F,Fold,Fexact
  real, dimension (0:N)      :: X,Y

  integer i,j,k,iter

  open (2, file = 'part3_jacobi_10.out')

  tolerance = 1.0e-4
  error=0; error2=0

  ALX = 0.5 ! boundary
  ALY = 0.5
  dx = ALX/N ! discretize
  dy = ALY/N
  do i=0,N,1
     X(i) = i*dx
     Y(i) = i*dy
  enddo

  ! setup Fexact matrix
  do i=0,N,1
     do j=0,N,1
        Fexact(i,j) = 400*X(i)*Y(j) ! exact solution
     enddo
  enddo

  ! setup F matrix, boundary conditions
  F=0
  do i=0,N,1
     F(i,0) = 0
     F(0,i) = 0
     F(N,i) = 200*Y(i)
     F(i,N) = 200*X(i)
  enddo

  ! iterate using Jacobi method
  Fold = F
  do iter=1,200,1
     do i=1,NM1,1
        do j=1,N-1,1
           F(i,j) = 0.25*( &
                          Fold(i-1,j) + Fold(i+1,j) + &
                          Fold(i,j-1) + Fold(i,j+1)   &
                         )
        enddo
     enddo

     ! calculate error
     error2 = 0
     do i=1,NM1,1
        do j=1,NM1,i
           error2 = error2 + (F(i,j) - Fold(i,j))**2
        enddo
     enddo
     error = sqrt(error2)/NM1 ! this calculates the L2 norm error / #elements
     write(2,*), iter, 'l2 norm error / #elements:',  error

     Fold = F
     if (error.le.tolerance) goto 1000
  enddo
1000 continue

  ! write F and Fexact to output
  write(2,*), 'F:'
  do i=0,N,1
     write(2,*) (F(i,j),j=0,N)
  enddo
  write(2,*), 'Fexact:'
  do i=0,N,1
     write(2,*) (Fexact(i,j),j=0,N)
  enddo

end program


program laplace_mc

    use problem_description, only: utrue,nx,ny,ax,ay,dx,dy
    use random_util, only: init_random_seed
    use mc_walk, only: random_walk, many_walks, nwalks

    implicit none
    integer :: i,i0,j0,max_steps,seed1,n_mc,n_success,n_total
    real(kind=8) :: x0,y0,u_true,u_mc,u_sum_old,u_sum_new, u_mc_total,error

    open(unit=25, file='mc_laplace_error.txt', status='unknown')

    x0 = 0.9d0
    y0 = 0.6d0
    i0 = nint((x0-ax)/dx)
    j0 = nint((y0-ay)/dy)

    ! shift (x0,y0) to a grid point if it wasn't already:
    x0 = ax + i0*dx
    y0 = ay + j0*dy

    max_steps = 100*max(nx,ny)
    !max_steps = 10

    nwalks = 0   ! to keep track of calls to random_walk

    u_true = utrue(x0, y0)

    seed1 = 12345   ! or set to 0 for random seed
    call init_random_seed(seed1)

    n_mc = 10
    call many_walks(i0, j0, max_steps, n_mc, u_mc, n_success)

    ! start accumulating totals:
    u_mc_total = u_mc
    n_total = n_success

    ! relative error gives estimate of number of correct digits:
    error = abs(u_mc_total - u_true) / abs(u_true)
    write(25,'(i10,e23.15,e15.6)') n_total, u_mc_total, error
    print '(i10,e23.15,e15.6)', n_total, u_mc_total, error

    ! loop to add successively double the number of points used:

    do i=1,12
        ! compute approximation with new chunk of points
        call many_walks(i0, j0, max_steps, n_mc, u_mc, n_success)

        ! update estimate of u based on doubling number:
        ! but not that not all were successful:
        u_sum_old = u_mc_total * n_total
        u_sum_new = u_mc * n_success
        n_total = n_total + n_success
        u_mc_total = (u_sum_old + u_sum_new) / n_total

        ! relative error:
        error = abs(u_mc_total - u_true) / abs(u_true)

        write(25,'(i10,e23.15,e15.6)') n_total, u_mc_total, error
        print '(i10,e23.15,e15.6)', n_total, u_mc_total, error

        n_mc = 2*n_mc
        enddo

    print '("Final approximation to u(x0,y0): ",es22.14)',u_mc_total
    print '("Total number of random walks: ",i10)',nwalks

end program laplace_mc


!  Program to perform a random walk in 1 dimension
!  Only one walker present

PROGRAM random_walk_1dim
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER::  max_trials, number_walks
  REAL(dp):: move_probability
  INTEGER, ALLOCATABLE, DIMENSION(:) :: x_cum, x2_cum

  ! get max trials, number of walks and the probability to move
  CALL  initialise(max_trials, number_walks, move_probability)
  ! allocate memory
  ALLOCATE (x_cum(number_walks), x2_cum(number_walks))
  x_cum = 0; x2_cum = 0
  ! do the Monte Carlo move
  CALL  mc_sampling(max_trials, number_walks, move_probability,x_cum, x2_cum)
  ! Print out results
  CALL  output(max_trials, number_walks, x_cum, x2_cum)
  ! free memory
  DEALLOCATE(x_cum, x2_cum)
END PROGRAM random_walk_1dim

! Read in data from screen

SUBROUTINE initialise(max_trials, number_walks, move_probability)
  USE constants
  IMPLICIT NONE
  INTEGER, INTENT(inout) ::max_trials, number_walks
  REAL(DP) :: move_probability
  WRITE(*,*)'Number of Monte Carlo trials ='
  READ(*,*)  max_trials
  WRITE(*,*) 'Number of attempted walks='
  READ(*,*) number_walks
  WRITE(*,*) 'Move probability='
  READ(*,*)  move_probability
END SUBROUTINE initialise

! Output of expectation values, <x>, <y> and their variances
! <x^2> - <x>^2  and <y^2> - <y>^2

SUBROUTINE output(max_trials, number_walks, x_cum, x2_cum)
  USE constants
  IMPLICIT NONE
  INTEGER :: i
  INTEGER, INTENT(in) :: max_trials, number_walks
  INTEGER, INTENT(in) :: x_cum(number_walks), x2_cum(number_walks)
  REAL(dp) :: xaverage, x2average, y2average, xvariance

  OPEN(UNIT=6, FILE='out.dat')
  DO i =1, number_walks
     xaverage = x_cum(i)/FLOAT(max_trials)
     x2average = x2_cum(i)/FLOAT(max_trials)
     xvariance = x2average - xaverage*xaverage
     WRITE(6,'(I3,2X,3F12.6)') i, xaverage, x2average ,xvariance
  ENDDO
END SUBROUTINE output

! Here we perform the Monte Carlo samplings and moves in 2 dim

SUBROUTINE mc_sampling(max_trials,number_walks, move_probability, x_cum, x2_cum)
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER, INTENT(in) :: max_trials,number_walks
  INTEGER, INTENT(inout) :: x_cum(number_walks), x2_cum(number_walks)
  INTEGER :: idum, x, trial, walks
  REAL(dp) :: rantest
  REAL(dp), INTENT(in) :: move_probability
  idum=-1
  ! loop over Monte Carlo trials
  DO trial = 1, max_trials
     x = 0
     ! loop over attempted walks in 2 dimensions
     DO walks = 1, number_walks
        rantest = ran0(idum)
        IF (rantest <= move_probability) THEN
           x = x+1
        ELSE
           x = x-1
        ENDIF
        x_cum(walks) = x_cum(walks)+x
        x2_cum(walks) = x2_cum(walks)+x*x
     ENDDO
  ENDDO
END SUBROUTINE mc_sampling


program rec_sum
    implicit none
    integer :: n, io, i
    real, dimension(:), allocatable :: data
    real :: total_sum, recsum
    real :: start_time, finish_time
    character(len=100) :: fmt

    call cpu_time(start_time)
    write(*,*) 'Recursive Summation Function'
    write(*,*)

    open(1, file='data_recursive.txt')
    n = 0
    do
        read(1,*,iostat=io)
        if (io /= 0) exit
        n = n + 1
    end do
    close(1)

    allocate(data(n))
    open(2, file='data_recursive.txt')
    do i = 1,n
        read(2,*) data(i)
    end do
    close(2)

    write(*,*) 'DATA:', data
    write(*,*) 'N DATA:', n

    total_sum = recsum(data,n)
    write(*,*) 'Total:', total_sum
    deallocate(data)

    call cpu_time(finish_time)
    fmt = '(a, f10.7, a)'
    write(*,fmt) 'Time Processing:', finish_time-start_time, ' seconds'

end program

recursive function recsum(data,n) result(total)
    real,dimension(n) :: data
    real :: total

    if (n == 1) then
        total = data(n)
        return
    else
        total = data(n) + recsum(data,n-1)
        return
    end if
end function recsum


! Created by EverLookNeverSee@GitHub on 5/31/20
! For more information see FCS/img/Exercise_07.png

program main
    implicit none
    ! declaring variables
    integer :: i, degree
    real :: x, result = 0.0
    real, allocatable, dimension(:) :: P    ! to store polynomial coefficients
    ! specifying polynomial degree using user input
    do
        print *, "Enter degree of the polynomial:"
        read *, degree
        if (degree < 0) then
            print *, "Degree should not be negative!"
            cycle
        end if
        exit
    end do
    ! creating array blocks based on polynomial degree
    allocate(P(degree + 1))
    ! when we have constant(degree of zero) equation
    if (degree == 0) then
        print *, "Please enyter your single value(intercept):"
        read *, P(1)
        result = P(1)
    else    ! for upper degrres of equations
        print *, "Please enter the value of x:"
        read *, x
        print *, "Please enter polynomial coeffs using the form below:"
        print *, "ax**0 +- bx**1 +- cx**2 +- ... +- dx**n"
        do i = 1, size(P)
            print *, "Enter cefficient of x**", i - 1, ":"
            read *, P(i)
        end do
        do i = size(P), 1, -1
            result = result * x + P(i)
        end do
    end if
    ! printing the result
    print *, "Result:", result
end program main


    program demo_modulo
    implicit none
         print *, modulo(17,3)        ! yields 2
         print *, modulo(17.5,5.5)    ! yields 1.0

         print *, modulo(-17,3)       ! yields 1
         print *, modulo(-17.5,5.5)   ! yields 4.5

         print *, modulo(17,-3)       ! yields -1
         print *, modulo(17.5,-5.5)   ! yields -4.5
    end program demo_modulo


module array_functions
  implicit none

contains
  function sumVector(vector) result(vecSum)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecSum, i

    vecSum = 0
    do i = 1, size(vector)
      vecSum = vecSum + vector(i)
    end do
  end function sumVector

  subroutine sumVectorSub(vector, vecSum)
    integer, intent(in) :: vector(:)
    integer, intent(out) :: vecSum
    integer :: i

    vecSum = 0
    do i = 1, size(vector)
      vecSum = vecSum + vector(i)
    end do
  end subroutine sumVectorSub

  function prodVector(vector) result(vecprod)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecprod, i

    vecprod = 1
    do i = 1, size(vector)
      vecprod = vecprod*vector(i)
    end do
  end function prodVector

  function minVector(vector) result(vecMin)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecMin, i

    vecMin = vector(1)
    do i = 2, size(vector)
      if (vecMin > vector(i)) then
        vecMin = vector(i)
      end if
    end do
  end function minVector

  function maxVector(vector) result(vecMax)
    intrinsic :: size
    integer, intent(in) :: vector(:)
    integer vecMax, i

    vecMax = vector(1)
    do i = 2, size(vector)
      if (vecMax < vector(i)) then
        vecMax = vector(i)
      end if
    end do
  end function maxVector

  function dotProd(v, w) result(res)
    intrinsic :: size
    integer, intent(in) :: v(:), w(:)
    integer :: res, i

    res = 0
    do i = 1, size(v)
      res = res + v(i)*w(i)
    end do
  end function dotProd

end module array_functions

program main
  use array_functions
  implicit none
  intrinsic :: dot_product

  ! interface way to write functions
  ! interface
  !   function sumVector(vector) result(vecSum)
  !     integer, intent(in) :: vector(:)
  !     integer :: vecSum
  !   end function sumVector
  ! end interface

  integer, allocatable :: vec(:)
  integer :: status
  integer :: i, ndim, vecSum

  read (*, *) ndim
  allocate (vec(ndim), stat=status)
  write (*, *) "Status ", status

  do i = 1, ndim
    vec(i) = i
  end do

  write (*, *) "Sum of all elements (func)", sumVector(vec)
  call sumVectorSub(vec, vecSum)
  write (*, *) "Sum of all elements (sub)", vecSum
  write (*, *) "Product of all elements ", prodVector(vec)
  write (*, *) "Minimal: ", minVector(vec), "Maximal value: ", maxVector(vec)
  write (*, *) "Dot product ", dotProd(vec, vec), dot_product(vec, vec)

  deallocate(vec, stat=status)
end program main

! interface way to write functions
! function sumVector(vector) result (vecSum)
!   implicit none
!   intrinsic :: size
!   integer, intent(in) :: vector(:)
!   integer vecSum, i

!   vecSum = 0
!   do i = 1, size(vector)
!     vecSum = vecSum + vector(i)
!   end do
! end function sumVector


!======================================================================================
! Realiza un calculo aproximado del valor de pi mediante la generacion aleatoria
!         de puntos que se localizan dentro de un circulo unitario
! Autor:  Martin Alejandro Paredes Sosa
!
!======================================================================================
Module Cte
  Implicit None
  Integer :: m , n                                   !Acertados : Intentos
  Real, Parameter :: Pi = 3.1415
  Integer,Parameter :: Sav = 5 !DEBUG
  Integer, Parameter :: Seed1 = 3321, seed2 = 1815   !Semillas Posibles
End Module Cte

!==========================================
Subroutine InOutCircle(x, y ,nNew)  !CHECAR SE ESTA DENTRO DEL CIRCULO UNITARIO
  Use Cte
  Implicit None
  Real, Dimension(n) :: x , y
  Logical :: logic
  Integer :: i, nNew !indice

  RunPos: Do i = 1, nNew

     logic = x(i)*x(i) + y(i)*y(i) < 1  !CONDICION A CUMPILR
     ContIn:If (logic) Then             !CUMPLIR CONDICION
        m = m+1                         !AVANZAR CONTADOR DE EXITO
     End If ContIn

  End Do RunPos

End Subroutine InOutCircle

!=========================================
Subroutine RPosc(x,y)               !GENERAR POSICIONES ALEATORIAS EN "X" Y "Y"

  Use Cte
  Implicit None
  Integer :: i
  Real, Dimension(n) :: x , y

  Call Random_Number(x)             !NUM ALEATORIO X
  Call Random_Number(y)             !NUM ALEATORIO Y

  !Debug Probando Generador de las posiciones
  !Writedo : Do i=1,n
  !   Write(*,*) x(i),y(i)
  !End Do Writedo

End Subroutine RPosc

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

Program PiCalculation

  Use Cte
  Implicit None
  Integer :: l                               !INDICE DE CONTADOR
  Integer, Allocatable, Dimension(:) :: mm
  Real, Allocatable, Dimension (:) :: x , y, PiCalc, DelPi, ErrRel

  Write(*,*) "Cuantos Intentos"     !INGRESANDO N
  Read(*,*) N

  Allocate( x(n),y(n) )             !ALOJANDO ESPACIO EN MEMORIA

  Call RPosc(x,y)                   !LLAMANDO SUBRUITNA PARA OBTENER POSICIONES
  Allocate( mm(n) )                 !ALOJANDO ESPACIO EN MEMORIA

  Check: Do l = 1, n                !CONSIDERACION DE DIFERENTES N (L, EVOLUCION DE N)

     Call InOutCircle(x,y,l)        !LLAMANDO SUBRUTINA PARA CONDICION DEL CIRCULO
     mm(l) = m                      !GUARDANDO VALOR M PARA DIFERENTES N (ESTE CASO L)
     m=0                            !REINICIANDO LA M
  End Do Check

  Deallocate (x,y)                 !DESALOJAR ESPCIO EN MEMORIA (SE BORRO LO GUARDADO)

  Allocate( PiCalc(n) )
  PiC: Do l=1, n                    !CALCULO DE PI EN SU EVOLUCION DE N
     PiCalc(l) = ( 4*real( mm(l) ) )/real(l) !CALCULANDO PI
  End Do PiC

  !CALCULANDO DELTA PI DESVIACION, ERROR RELATIVA
  ALLOCATE( DelPi(n), ErrRel(n) )
  DelPi = Pi - PiCalc
  ErrRel = DelPi / Pi

  Open(1,File= "Table.dat")

  WriteDo: Do l=1 , n
     Write(1,*) l,PiCalc(l), DelPi(l), ErrRel(l)
  End Do WriteDo

  DEALLOCATE(mm,PiCalc,DelPi,ErrRel) !DESALOJAR ESPACIO EN MEMORIA

End Program PiCalculation


        real*8 FUNCTION FINTRP ( MODE, X, X1, F1, X2, F2 )

	real*8 X,X1, F1, X2, F2
C
C         *FINTRP* INTERPOLATES BETWEEN X1 AND X2 USING A FUNCTIONAL
C         FORM THAT DEPENDS UPON THE SPECIFIED MODE. MODES - -
C     1 = LINEAR - - A * X + B
C     2 = EXPONENTIAL - - A * EXP( B * X )
C     3 = POWER LAW - - A * X**B
C

c       write(*,*)'X, X1, F1, X2, F2',X, X1, F1, X2, F2

      GO TO ( 10, 20, 30 ), MODE
C
C         LINEAR INTERPOLATION
C
  10  F = F1 + ( F1 - F2 ) * ( X - X1 ) / ( X1 - X2 )
      GO TO 40
C
C         EXPONENTIAL INTERPOLATION
C
  20  F = F1 * ( F1 / F2 )**( ( X - X1 ) / ( X1 - X2 ) )
      GO TO 40
C
C         POWER LAW INTERPOLATION
C
  30  IF ( X1 .LE. 0. ) GO TO 20
      F = F1 * ( X / X1 )**( DLOG( F1 / F2 ) / DLOG( X1 / X2 ) )
C
  40  FINTRP = F
c	write(*,*)'FINTRP',FINTRP
C
      RETURN
      END


      SUBROUTINE DK01MD( TYPE, N, A, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To apply an anti-aliasing window to a real signal.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPE    CHARACTER*1
C             Indicates the type of window to be applied to the signal
C             as follows:
C             = 'M':  Hamming window;
C             = 'N':  Hann window;
C             = 'Q':  Quadratic window.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of samples.  N >= 1.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the signal to be
C             processed.
C             On exit, this array contains the windowing function.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     If TYPE = 'M', then a Hamming window is applied to A(1),...,A(N),
C     which yields
C       _
C       A(i) = (0.54 + 0.46*cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N.
C
C     If TYPE = 'N', then a Hann window is applied to A(1),...,A(N),
C     which yields
C       _
C       A(i) = 0.5*(1 + cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N.
C
C     If TYPE = 'Q', then a quadratic window is applied to A(1),...,
C     A(N), which yields
C       _
C       A(i) = (1 - 2*((i-1)/(N-1))**2)*(1 - (i-1)/(N-1))*A(i),
C                                             i = 1,2,...,(N-1)/2+1;
C       _
C       A(i) = 2*(1 - ((i-1)/(N-1))**3)*A(i), i = (N-1)/2+2,...,N.
C
C     REFERENCES
C
C     [1] Rabiner, L.R. and Rader, C.M.
C         Digital Signal Processing.
C         IEEE Press, 1972.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0( N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine DK01AD by R. Dekeyser, State
C     University of Gent, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Digital signal processing, Hamming window, Hann window, real
C     signals, windowing.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  PT46, HALF, PT54, ONE, TWO, FOUR
      PARAMETER         ( PT46=0.46D0, HALF=0.5D0, PT54=0.54D0,
     $                    ONE = 1.0D0, TWO=2.0D0, FOUR=4.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TYPE
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*)
C     .. Local Scalars ..
      LOGICAL           MTYPE, MNTYPE, NTYPE
      INTEGER           I, N1
      DOUBLE PRECISION  BUF, FN, TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ATAN, COS, DBLE
C     .. Executable Statements ..
C
      INFO = 0
      MTYPE = LSAME( TYPE, 'M' )
      NTYPE = LSAME( TYPE, 'N' )
      MNTYPE = MTYPE.OR.NTYPE
C
C     Test the input scalar arguments.
C
      IF( .NOT.MNTYPE .AND. .NOT.LSAME( TYPE, 'Q' ) )
     $   THEN
         INFO = -1
      ELSE IF( N.LE.0 ) THEN
         INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DK01MD', -INFO )
         RETURN
      END IF
C
      FN = DBLE( N-1 )
      IF( MNTYPE ) TEMP = FOUR*ATAN( ONE )/FN
C
      IF ( MTYPE ) THEN
C
C        Hamming window.
C
         DO 10 I = 1, N
            A(I) = A(I)*( PT54 + PT46*COS( TEMP*DBLE( I-1 ) ) )
   10    CONTINUE
C
      ELSE IF ( NTYPE ) THEN
C
C        Hann window.
C
         DO 20 I = 1, N
            A(I) = A(I)*HALF*( ONE + COS( TEMP*DBLE( I-1 ) ) )
   20    CONTINUE
C
      ELSE
C
C        Quadratic window.
C
         N1 = ( N-1 )/2 + 1
C
         DO 30 I = 1, N
            BUF = DBLE( I-1 )/FN
            TEMP = BUF**2
            IF ( I.LE.N1 ) THEN
               A(I) = A(I)*( ONE - TWO*TEMP )*( ONE - BUF )
            ELSE
               A(I) = A(I)*TWO*( ONE - BUF*TEMP )
            END IF
   30    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of DK01MD ***
      END


SUBROUTINE removal (num)
    IMPLICIT  NONE
    integer(kind=8) num
    integer i
    integer, parameter :: ARR_SIZE = 2000000
    COMMON primes
    integer(kind=8), DIMENSION(ARR_SIZE) :: primes

    if (num /= 0) then
        do i=num+num, ARR_SIZE, num
            primes(i) = 0
        end do
    end if
END SUBROUTINE removal

program  problem_10
    integer(kind=8) i
    integer, parameter :: ARR_SIZE = 2000000
    integer(kind=8), DIMENSION(ARR_SIZE) :: primes
    integer(kind=8) total
    integer(kind=8) rez
    integer(kind=8) lg_sum
    COMMON primes
    total = 0

    ! Set primes to 1, 2, .. ARR_SIZE
    primes = (/ (i, i = 1, ARR_SIZE) /)
    primes(1) = 0
    ! Using: Sieve of Eratosthenes
    do i=1, ARR_SIZE
        CALL removal(primes(i))
        total = total + primes(i)
    end do

    print *,"Problem 10:", total

end program problem_10


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer, allocatable :: seed(:)
    integer :: n
    integer :: i
    interface
        function Discrete_varible()
            ! 离散随机变量产生器
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp) :: Discrete_varible
        end function Discrete_varible

        function Poisson(lambda)
            ! Poisson 分布
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            integer, intent(in) :: lambda
            real(dp) :: Poisson
        end function Poisson
    end interface

    call random_seed(size=n)
    allocate(seed(n))
    seed = 1
    call random_seed(put=seed)
    do i = 1, 100
        write(*,*) Discrete_varible()
    end do

    do i = 1, 100
        write(*,*) Poisson(1)
    end do
end program main

function Discrete_varible()
    ! 离散随机变量产生器
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    real(dp) :: Discrete_varible

    real(dp) :: xi
    integer :: i
    real(dp), parameter :: p(3) = [1 / 4.d0, 5 / 8.d0, 1 / 8.d0]
    real(dp), parameter :: x(3) = [1.d0, 2.d0, 3.d0]

    call random_number(xi)
    i = 1
    do while (xi >= sum(p(:i)))
        i = i + 1
    end do
    Discrete_varible = x(i)
end function Discrete_varible

function Poisson(lambda)
    ! Poisson 分布
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer, intent(in) :: lambda
    real(dp) :: Poisson

    real(dp) :: xi
    integer :: i
    real(dp) :: sum_of_p_n

    call random_number(xi)
    xi = xi * exp(dble(lambda))
    i = 0
    sum_of_p_n = lambda**i / dble(factorial(i))
    do while (xi >= sum_of_p_n)
        i = i + 1
        sum_of_p_n = sum_of_p_n + lambda**i / dble(factorial(i))
    end do
    Poisson = i

    contains
        function factorial(n)
            implicit none

            integer, intent(in) :: n
            integer :: factorial

            integer :: i

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


*DECK ALBETA
      FUNCTION ALBETA (A, B)
C***BEGIN PROLOGUE  ALBETA
C***PURPOSE  Compute the natural logarithm of the complete Beta
C            function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7B
C***TYPE      SINGLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C)
C***KEYWORDS  FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ALBETA computes the natural log of the complete beta function.
C
C Input Parameters:
C       A   real and positive
C       B   real and positive
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNGAM, ALNREL, GAMMA, R9LGMC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  ALBETA
      EXTERNAL GAMMA
      SAVE SQ2PIL
      DATA SQ2PIL / 0.9189385332 0467274 E0 /
C***FIRST EXECUTABLE STATEMENT  ALBETA
      P = MIN (A, B)
      Q = MAX (A, B)
C
      IF (P .LE. 0.0) CALL XERMSG ('SLATEC', 'ALBETA',
     +   'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2)
      IF (P.GE.10.0) GO TO 30
      IF (Q.GE.10.0) GO TO 20
C
C P AND Q ARE SMALL.
C
      ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) )
      RETURN
C
C P IS SMALL, BUT Q IS BIG.
C
 20   CORR = R9LGMC(Q) - R9LGMC(P+Q)
      ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) +
     1  (Q-0.5)*ALNREL(-P/(P+Q))
      RETURN
C
C P AND Q ARE BIG.
C
 30   CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q)
      ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q))
     1  + Q*ALNREL(-P/(P+Q))
      RETURN
C
      END


!     jacobian calculation
subroutine r_jacob(x,xj,xji,det)
  use solid_variables, only:nsd_solid,nen_solid
  use r_common
  implicit none

  real(8) :: x(nsd_solid,nen_solid),xj(nsd_solid,nsd_solid),xji(nsd_solid,nsd_solid),cf(nsd_solid,nsd_solid)
  real(8),intent(out) :: det
  real(8) :: dum
  integer :: i,j,k

 !...compute the jacobians
  do i=1,nsd_solid
     do j=1,nsd_solid
        dum = 0.0d0
        do k=1,nen_solid
           dum = dum + r_p(j,k)*x(i,k)
        enddo
        xj(i,j) = dum
     enddo
  enddo
 !...compute the determinant of the jacobian matrix

  threedim: if (nsd_solid .eq. 3) then
 !...3-D determinant
  cf(1,1) = + (xj(2,2)*xj(3,3) - xj(2,3)*xj(3,2))
  cf(1,2) = - (xj(2,1)*xj(3,3) - xj(2,3)*xj(3,1))
  cf(1,3) = + (xj(2,1)*xj(3,2) - xj(2,2)*xj(3,1))
  cf(2,1) = - (xj(1,2)*xj(3,3) - xj(1,3)*xj(3,2))
  cf(2,2) = + (xj(1,1)*xj(3,3) - xj(1,3)*xj(3,1))
  cf(2,3) = - (xj(1,1)*xj(3,2) - xj(1,2)*xj(3,1))
  cf(3,1) = + (xj(1,2)*xj(2,3) - xj(1,3)*xj(2,2))
  cf(3,2) = - (xj(1,1)*xj(2,3) - xj(1,3)*xj(2,1))
  cf(3,3) = + (xj(1,1)*xj(2,2) - xj(1,2)*xj(2,1))

  det = - ( xj(1,1) * cf(1,1) + &
         xj(1,2) * cf(1,2) + &
         xj(1,3) * cf(1,3) )
!  write(*,*) 'jacobi in r_jacobian', det
  if (det .lt. 1.0d-15) then
     write(*,100)
     stop
!	det=-det
  endif
100 format(6x, 'error, zero or negative jacobian determinant')

!...compute the inverse of the jacobian matrix
  xji(1,1) = cf(1,1)/det
  xji(1,2) = cf(2,1)/det
  xji(1,3) = cf(3,1)/det
  xji(2,1) = cf(1,2)/det
  xji(2,2) = cf(2,2)/det
  xji(2,3) = cf(3,2)/det
  xji(3,1) = cf(1,3)/det
  xji(3,2) = cf(2,3)/det
  xji(3,3) = cf(3,3)/det

  endif  threedim

  twodim: if (nsd_solid .eq. 2) then
 !...2-D determinant
  det = ( xj(1,1) * xj(2,2) - &
         xj(1,2) * xj(2,1) )

  if (det .lt. 1.0d-15) then
     write(*,100)
     stop
  endif

!...compute the inverse of the jacobian matrix
  xji(1,1) = xj(2,2)/det
  xji(1,2) = -xj(1,2)/det
  xji(2,1) = -xj(2,1)/det
  xji(2,2) = xj(1,1)/det

	endif twodim

  return
end subroutine r_jacob


!******************************************************************************
!**                      GETTING INVERS OF A MATRIX                          **
!******************************************************************************
subroutine inverse(a,n,ainv)
 implicit none
!dummy arguments
 integer :: n
 REAL(8) :: A(N,N)
 REAL(8) :: AINV(N,N)
!local arguments
 INTEGER :: I,J,K,L
 REAL(KIND=8) :: M,MAUM(N,2*N)
!sE CREA LA MATRIZ AUMENTADA
 DO I=1,N
   DO J=1,2*N
     IF (J<=N) THEN
       MAUM(I,J)=A(I,J)
     ELSE IF ((I+N)==J) THEN
       MAUM(I,J)=1.D0
     ELSE
       MAUM(I,J)=0.D0
     END IF
   END DO
 END DO
!SE REDUCE LA MATRIZ A UNA TRIANGULAR superior por eliminacion
 DO K=1,N-1
   DO J=K+1,N
     M=MAUM(J,K)/MAUM(K,K)
     DO I=K,2*N
       MAUM(J,I)=MAUM(J,I)-M*MAUM(K,I)
     END DO
   END DO
 END DO
!elementos de la diagonal iguales a 1
 DO I=1,N
   M=MAUM(I,I)
   DO J=I,2*N
     MAUM(I,J)=MAUM(I,J)/M
   END DO
 END DO
!DIAGONALIZACION
 DO K=N-1,1,-1
   DO I=1,K
     M=MAUM(I,K+1)
     DO J=K,2*N
       MAUM(I,J)=MAUM(I,J)-MAUM(K+1,J)*M
     END DO
   END DO
 END DO
!ALMACENAMIENTO
 DO I=1,N
   DO J=1,N
     AINV(I,J)=MAUM(I,J+N)
   END DO
 END DO
end subroutine inverse


PROGRAM gravity
IMPLICIT NONE
  REAL, PARAMETER :: G = 6.672E-11 ! Gravitational constant in N m**2/kg**2
  REAL, PARAMETER :: M = 5.98E+24 ! Mass of the Earth in kg
  REAL, PARAMETER :: R = 6371.0 ! Mean radius of the Earth in km
  REAL :: h ! Height in km
  REAL :: start_height = 40000.0 ! Starting height
  REAL :: inc = 500.0 ! Height increment in km
  REAL :: result ! Acceleration due to gravity at height h
  INTEGER :: index

  h = start_height
  WRITE(*, 100) "Height (km)","Accel (m/s^2)"
  WRITE(*, 100) "-----------","-------------"
  100 FORMAT (1X,A11,2X,A13)
  DO index = 0, INT(start_height / inc)
    result = -G * (M / (R + h)**2)
    WRITE(*,'(F12.1,2X,ES13.3)') h, result
    h = h - inc
  END DO

END PROGRAM gravity


C$Procedure      MXV ( Matrix times vector, 3x3 )

      SUBROUTINE MXV ( MATRIX, VIN, VOUT )

C$ Abstract
C
C     Multiply a 3x3 double precision matrix with a 3-dimensional
C     double precision vector.
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     MATRIX
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION   MATRIX   ( 3,3 )
      DOUBLE PRECISION   VIN      (   3 )
      DOUBLE PRECISION   VOUT     (   3 )

C$ Brief_I/O
C
C     VARIABLE  I/O              DESCRIPTION
C     --------  ---  --------------------------------------------------
C     MATRIX     I   3x3 double precision matrix.
C     VIN        I   3-dimensional double precision vector.
C     VOUT       O   3-dimensinoal double precision vector. VOUT is
C                    the product MATRIX*VIN.
C
C$ Detailed_Input
C
C     MATRIX     is an arbitrary 3x3 double precision matrix.
C
C     VIN        is an arbitrary 3-dimensional double precision vector.
C
C$ Detailed_Output
C
C     VOUT       is a 3-dimensional double precision vector. VOUT is
C                the product MATRIX * V.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The code reflects precisely the following mathematical expression
C
C        For each value of the subscript I from 1 to 3:
C
C        VOUT(I) = Summation from K=1 to 3 of  ( MATRIX(I,K) * VIN(K) )
C
C$ Examples
C
C      Let
C
C         MATRIX = |  0.0D0  1.0D0  0.0D0 |   and  VIN = | 1.0D0 |
C                  |                      |              |       |
C                  | -1.0D0  0.0D0  0.0D0 |              | 2.0D0 |
C                  |                      |              |       |
C                  |  0.0D0  0.0D0  1.0D0 |              | 3.0D0 |
C
C      Then the call,
C
C         CALL MXV ( MATRIX, VIN, VOUT )
C
C      produces the vector
C
C         VOUT = |  2.0D0 |
C                |        |
C                | -1.0D0 |
C                |        |
C                |  3.0D0 |
C
C
C$ Restrictions
C
C     The user is responsible for checking the magnitudes of the
C     elements of MATRIX and VIN so that a floating point overflow does
C     not occur.
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     matrix times 3-dimensional vector
C
C-&

      DOUBLE PRECISION PRODV(3)
      INTEGER I

C
C  Perform the matrix-vector multiplication
C
      DO I = 1, 3
         PRODV(I) = MATRIX(I,1)*VIN(1) +
     .              MATRIX(I,2)*VIN(2) +
     .              MATRIX(I,3)*VIN(3)
      END DO
C
C  Move the buffered vector into the output vector VOUT.
C
      VOUT(1) = PRODV(1)
      VOUT(2) = PRODV(2)
      VOUT(3) = PRODV(3)

      RETURN
      END


! Created by EverLookNeverSee@GitHub on 4/23/20.
! This program calculates the GCD betwen two numbers.

program gcd
    implicit none
    ! declaring variables
    integer :: num_1, num_2, temp
    ! gettig user input
    print *, "Enter two positive integers:"
    read *, num_1, num_2
    temp = mod(num_1, num_2)
    if (temp == 0) then
        print *, "The gcd of", num_1, "and", num_2, "is", num_2
        stop
    end if
    do while (temp /= 0)
        num_1 = num_2
        num_2 = temp
        temp = mod(num_1, num_2)
    end do
    print *, "The gcd is", num_2
end program gcd


! Solve
! phi_t = k phi_xx
! using explicit method
! 2nd order centred in space, 1st order fwd in time

program explicit1d

  implicit none

  integer, parameter :: num=selected_real_kind(p=15) !p=6 or 15
  real(num) :: x_min, x_max, x_c, dx
  real(num) :: time, t_end , dt, dtk
  integer :: step, nsteps
  integer :: ix
  integer :: nx
  real(num) :: C, k, phi1, phi2, t0
  real(num), allocatable, dimension(:) :: phi, x, phi_new, phi_analytic
  integer :: out_unit = 10

  !user control
  t_end = 0.008_num
  nx = 16
  x_min = 0.0_num
  x_max = 1.0_num
  x_c = (x_max - x_min) / 2.0_num
  nsteps = 100 !max number of steps
  C = 0.8_num ! CFL-like factor in time step, le 1 required

  !initial condition optin

  k = 1.0 ! diffusion coefficient
  t0 = 0.001_num !constant in initial condition, NOT the initial time
  time = 0.0_num !initial time
  phi2 = 2.0_num
  phi1 = 1.0_num

  ! initialise the arrays and fill grid, 1 ghost cell needed

  allocate(x(0:nx+1))
  allocate(phi(0:nx+1))
  allocate(phi_new(0:nx+1))

  dx = (x_max - x_min) / REAL(nx-1,num)
  x(0) = x_min - dx
  do ix = 1, nx+1
    x(ix) = x(ix-1) + dx
  enddo

  ! set the initial condition on phi
  phi = 0.0_num
  do ix = 1, nx
    phi(ix) = (phi2-phi1)  * (t0/(time + t0))**0.5_num * &
      & exp(-(x(ix)-x_c)**2 / 4.0_num / k / (time+t0)) + phi1
  enddo

  !main loop

  step = 0
  dt = 0.5_num * C * dx**2 / k
  dtk = dt * k
  do
    if ((step >= nsteps .and. nsteps >= 0) .or. (time >= t_end)) exit

    step = step+1
    time = time + dt
    print *, step,time

    !set bc (simple Dirichlet)
    phi(0) = phi1
    phi(nx+1) = phi1

    !loop through domain
    do ix = 1, nx
      phi_new(ix) = phi(ix) + &
        & dtk * (phi(ix+1) - 2.0_num * phi(ix) + phi(ix-1))/dx**2
    enddo !ix = 1, nx

    phi = phi_new

  enddo

  ! Output

  call execute_command_line("rm -rf x*.dat phi*.dat")
     !^ dont stream to existing *dat files

  ! output numerical solution
  open(out_unit, file="x.dat", access="stream")
  write(out_unit) x(1:nx)
  close(out_unit)
  open(out_unit, file="phi.dat", access="stream")
  write(out_unit) phi(1:nx)
  close(out_unit)

  ! calculate and output analytical sln and corresponding grid,
  ! at several times the resolution to better-sample the continuous sln

  if (nx <= 2**14) then
    deallocate(x)
    nx = nx * 16
    allocate(x(0:nx+1))
    dx = (x_max - x_min) / REAL(nx-1,num)
    x(0) = x_min - dx
    do ix = 1, nx+1
      x(ix) = x(ix-1) + dx
    enddo
  endif

  allocate(phi_analytic(0:nx+1))
  do ix = 0,nx+1
    phi_analytic(ix) = (phi2-phi1)  * (t0/(time + t0))**0.5_num * &
      & exp(-(x(ix)-x_c)**2 / 4.0_num / k / (time+t0)) + phi1
  enddo

  open(out_unit, file="x_analytic.dat", access="stream")
  write(out_unit) x(1:nx)
  close(out_unit)

  open(out_unit, file="phi_analytic.dat", access="stream")
  write(out_unit) phi_analytic(1:nx)
  close(out_unit)

  call execute_command_line("python plot1.py")

end program explicit1d


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

      program depth_profile

!-----------------------------------------------------------------------
!
!     computes layer thicknesses for each level for POP ocean code
!
!-----------------------------------------------------------------------

      implicit none

      integer, parameter ::
     &  km = 20             ! number of vertical levels

      real, parameter ::
     &  zmax    = 5500.0,   ! max depth in meters
     &  dz_sfc  =   25.0,   ! thickness of surface layer
     &  dz_deep =  400.0,   ! thickness of deep ocean layers
     &  eps     = 1.e-6     ! convergence criterion

      real, dimension(km) ::
     &  z,                  ! depth at bottom of layer
     &  dz                  ! layer thickness of each layer

      real ::
     &  depth,              ! depth based on integrated thicknesses
     &  zlength,            ! adjustable parameter for thickness
     &  d0, d1,             ! depths used by midpoint search
     &  zl0, zl1,           ! parameter used by midpoint search
     &  dzl                 ! zl1-zl0

      integer k

!-----------------------------------------------------------------------
!
!     initialize bisection search to find best value of zlength
!     parameter such that integrated depth = zmax
!
!-----------------------------------------------------------------------

      zl0 = eps
      zl1 = zmax
      dzl = zl1 - zl0

      call compute_dz(dz,d0,zl0,dz_sfc,dz_deep,km)
      call compute_dz(dz,d1,zl1,dz_sfc,dz_deep,km)

      if ((d0-zmax)*(d1-zmax) > 0.0) then
        print *,d0,d1,zmax
        stop 'zero point not in initial interval'
      endif

!-----------------------------------------------------------------------
!
!     do bisection search
!
!-----------------------------------------------------------------------

      do while ( (dzl/zmax) > eps)

        !***
        !*** compute profile at midpoint
        !***

        zlength = zl0 + 0.5*dzl

        call compute_dz(dz,depth,zlength,dz_sfc,dz_deep,km)

        !***
        !*** find interval to use for continuing search
        !***

        if ((d0-zmax)*(depth-zmax) < 0.0) then
          d1 = depth
          zl1 = zlength
        else if ((d1-zmax)*(depth-zmax) < 0.0) then
          d0 = depth
          zl0 = zlength
        else
         print *,d0,d1,depth,zmax
         stop 'zero point not in interval'
        endif

        dzl = zl1 - zl0

      end do

!-----------------------------------------------------------------------
!
!     presumably, we have converged, but check to make sure
!
!-----------------------------------------------------------------------

      print *,'Integrated depth = ',depth,'    zmax = ',zmax

!-----------------------------------------------------------------------
!
!     write results to file and stdout
!
!-----------------------------------------------------------------------

      open(12,file='in_depths.dat',form='formatted',status='unknown')

      depth = 0.0
      do k =1,km
        depth = depth + dz(k)

        print *,k,dz(k),depth
        write(12,*) dz(k)*100.,'   !   ',depth
      end do

      close(12)

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

      end program depth_profile

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

      subroutine compute_dz(dz,depth,zlength,dz_sfc,dz_deep,km)

!-----------------------------------------------------------------------
!
!     computes a thickness profile and total depth given the
!     parameters for the thickness function
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
!     input variables
!
!-----------------------------------------------------------------------

      integer, intent(in) ::
     &  km                 ! number of vertical levels

      real, intent(in) ::
     &  zlength,           ! gaussian parameter for thickness func
     &  dz_sfc,            ! thickness of surface layer
     &  dz_deep            ! thickness of deep ocean layers

!-----------------------------------------------------------------------
!
!     output variables
!
!-----------------------------------------------------------------------

      real, dimension(km), intent(out) ::
     &  dz                  ! layer thickness of each layer

      real, intent(out) ::
     &  depth               ! depth based on integrated thicknesses

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      integer k

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

      depth = 0.0

      do k=1,km

        dz(k) = dz_deep - (dz_deep - dz_sfc)*exp(-(depth/zlength)**2)
        depth = depth + dz(k)

      end do

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

      end subroutine compute_dz

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


INCLUDE 'pib_mod.f03'
      program pib_02
      USE pib_mod
!
!     USAGE:
!       ./pib_02.exe <mass> <boxLength> <slope> <nBasis>
!
!     ABOUT:
!     This program builds and prints the Hamiltonian for the modified Particle-
!     in-a-Box (mPIB) problem. In this problem, the standard PIB potential is
!     modified to include a linear potential within the box (0 < x < L) given by
!     V(x) = bx.
!
!     This program accepts command line arguments for the mass, box length,
!     slope parameter b, and the number of basis functions to use (nBasis; taken
!     to mean the first nBasis PIB eigenfunctions). The program reports kinetic
!     energy, potential energy, and Hamiltonian matrices.
!
!     All input and results are taken to be in atomic units.
!
!
!     H. P. Hratchian, 2020.
!
!
!     Variable Declarations
!
      implicit none
      integer::i,j,k,nArguments,nBasis,lapackInfo
      real::mass,boxLength,slope
      real,dimension(:),allocatable::hamiltonianEVals,lapackWork
      real,dimension(:,:),allocatable::kineticEnergyMatrix,  &
        potentialEnergyMatrix,hamiltonianMatrix,hamiltonianEVecs
      character(len=256)::commandLineArg
      logical::fail=.false.
!
!     Format Statements
!
 1000 Format('Modified Particle-in-a-Box Program.'/,'Unit Test 2.',/,/,  &
        'Input Parameters:',/,  &
        2x,'mass      = ',F10.3,/,  &
        2x,'boxLength = ',F10.3,/,  &
        2x,'slope     = ',F10.3,/,  &
        2x,'nBasis    = ',I4,/)
 2000 Format('< i | T | j > = ')
 2010 Format('< i | V | j > = ')
 2020 Format('< i | H | j > = ')
 9000 Format('Incorrect number of command line arguments.',/,  &
        'Expected 5 but found ',I2,'.'/,  &
        'The list of arguments is:',/,  &
        3x,'<mass> <boxLength> <slope> <nBasis>')
 9100 Format('Input parameter ',A,' must be greater than 0.')
 9200 Format('Failure solving for Hamiltonian eigensystem.')
 9999 Format(/,'PROGRAM FAILED!')
!
!     Find out how many command line arguments there are, ensure it's the right
!     number, read-in the values, and echo the input as output.
!
      nArguments = COMMAND_ARGUMENT_COUNT()
      if(nArguments.ne.4) then
        write(iOut,9000) nArguments
        fail = .true.
        goto 999
      endIf
      call GET_COMMAND_ARGUMENT(1,commandLineArg)
      read(commandLineArg,*) mass
      call GET_COMMAND_ARGUMENT(2,commandLineArg)
      read(commandLineArg,*) boxLength
      call GET_COMMAND_ARGUMENT(3,commandLineArg)
      read(commandLineArg,*) slope
      call GET_COMMAND_ARGUMENT(4,commandLineArg)
      read(commandLineArg,*) nBasis
      write(iOut,1000) mass,boxLength,slope,nBasis
      if(mass.le.0) then
        write(iOut,9100) 'mass'
        fail = .true.
      endIf
      if(boxLength.le.0) then
        write(iOut,9100) 'boxLength'
        fail = .true.
      endIf
      if(slope.le.0) then
        write(iOut,9100) 'slope'
        fail = .true.
      endIf
      if(fail) goto 999
!
!     Allocate memory for the kinetic, potential, and Hamiltonian matrices.
!
      Allocate(kineticEnergyMatrix(nBasis,nBasis),  &
        potentialEnergyMatrix(nBasis,nBasis),  &
        hamiltonianMatrix(nBasis,nBasis))
!
!     Calculate the kinetic energy matrix element.
!
      do i = 1,nBasis
        do j = 1,nBasis
          kineticEnergyMatrix(i,j) = kineticEnergy(mass,boxLength,i,j)
          potentialEnergyMatrix(i,j) = potentialEnergy(mass,boxLength,slope,i,j)
        endDo
      endDo
      hamiltonianMatrix = kineticEnergyMatrix + potentialEnergyMatrix
!
!     Print out the kinetic energy, potential energy, and Hamiltonian matrices.
!
      write(iOut,2000)
      call print_matrix(kineticEnergyMatrix)
      write(iOut,2010)
      call print_matrix(potentialEnergyMatrix)
      write(iOut,2020)
      call print_matrix(hamiltonianMatrix)
!
!     Diagonalize the Hamiltonian and report eigenvectors and eigenvalues.
!
      allocate(hamiltonianEVecs(nbasis,nBasis))
      allocate(hamiltonianEVals(nBasis),lapackWork(3*nBasis))
      write(iOut,*)' Hrant - here is the linearized hamiltonian...'
      hamiltonianEVecs = hamiltonianMatrix
      call SSYEV('V','L',nBasis,hamiltonianEVecs,nBasis,hamiltonianEVals,  &
        lapackWork,3*nBasis,lapackInfo)
      write(iOut,*)' lapackInfo = ',lapackInfo
      if(lapackInfo.ne.0) then
        write(iOut,9200)
        fail = .true.
        goto 999
      endIf
      call print_matrix(RESHAPE(hamiltonianEVecs,[ nBasis,nBasis ]))
      call print_matrix(RESHAPE(hamiltonianEVals,[ 1,nBasis ]))
!
!     Complete the program...
!
  999 if(fail) write(iOut,9999)
      end program pib_02


module lin_alg
  use nrtype
  ! Module for numerical linear algebra.
contains
  subroutine tridiag(c, a, b, y, x)
    implicit none
    ! Tridiagonal matrix
    !
    ! a_(1,1)   a_(2,1)   0         0         ...         0           |
    ! a_(2,1)   a_(2,2)   a_(2,3)   0         ...         0           |
    ! 0         a_(3,2)   a_(3,3)   a_(3,4)   ...         0           |
    ! 0         0         a_(4,3)   a_(4,4)   ...         0
    ! ...       ...       ...       ...       ...         a_(n-1,n)
    ! 0         0         0         ...       a_(n,n-1)   a_(n,n)
    !
    ! Inputs:
    ! c(:) = Lower Diagonal.
    ! a(:) = Main Diagonal.
    ! b(:) = Upper Diagonal.
    ! y(:) = Image.
    ! Outputs:
    ! x(:) = Solution vector.
    ! Locals:
    ! i, j = Counters.
    ! w(:) = Dummy Vector.
    ! c    = Dummy Variable.
    real(dp), intent(in)  :: c(:), a(:), b(:), y(:)
    real(dp), intent(out) :: x(:)
    real(dp) :: w(size(a)), den
    integer  :: n, i

    ! Set the value of n to be the number of entries in the main diagonal.
    n = size(a)
    ! Check that the sizes of the lower, main and upper diagonals make sense.
    check_size: if( n /= size(c) + 1 .or. &
                    n /= size(b) + 1 .or. &
                    n /= size(y)            ) then
      write(*,*) " Error: lin_alg: tridiag: check_size: Sizes of the upper and lower diagonals must be one smaller than the main &
                   diagonal; size(lower_diagonal) = ", size(c), "; size(upper_diagonal) = ", size(b), &
                   "; size(main_diagonal) = ", size(a)
    end if check_size

    ! Calculate the First Denominator.
    den = a(1)
    fd: if ( den == 0._dp ) then
      write(*,*) " Error: lin_alg: tridiag: Next iteration will divide by zero. den = ", den
      stop
    end if fd
    ! Calculate preliminary value of x(1).
    x(1) = y(1) / den

    ! Decomposition and Forward Substitution.
    dfs: do i = 2, n
      w(i) = b(i - 1) / den
      den  = a(i) - c(i - 1) * w(i)
      ! Error if Next Iteration will Divide by 0.
      nid0: if ( den == 0._dp ) then
        write(*,*) " Error: lin_alg: tridiag: dfs: Next iteration will divide by zero. den = ", den
        stop
      end if nid0
      ! x(2) = ( y(2) - c(1) * x(1) ) /
      ! Solution vector.
      x(i) = ( y(i) - c(i - 1) * x(i - 1) ) / den
    end do dfs

    ! Back Substitution.
    bs: do i = n - 1, 1, -1
      x(i) = x(i) - w(i + 1) * x(i + 1)
    end do bs

  end subroutine tridiag
end module lin_alg


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer :: i
    interface
        function Load_subtraction_generator(seed_)
            implicit none
            integer, parameter :: li = selected_int_kind(10)
            integer, parameter :: dp = selected_real_kind(8)

            integer(li), intent(in), optional :: seed_
            real(dp) :: Load_subtraction_generator
        end function Load_subtraction_generator
    end interface

    do i = 1, 100
        write(*,*) Load_subtraction_generator()
    end do
end program main

function Load_subtraction_generator(seed_)
    ! 带载减法产生器
    implicit none
    integer, parameter :: li = selected_int_kind(10)
    integer, parameter :: dp = selected_real_kind(8)

    integer(li), intent(in), optional :: seed_
    real(dp) :: Load_subtraction_generator

    integer :: i
    integer(li), save :: I_list(44) = [(-1, i = 1, 44)]
    logical :: initialized = .false.
    integer(li), parameter :: m = 16807
    integer :: C = 0

    if (present(seed_)) then
        I_list(1) = seed_
        initialized = .false.
    else if (I_list(1) == -1) then
        I_list(1) = 1
        initialized = .false.
    end if

    if (initialized) then
        I_list(1:43) = I_list(2:44)
    else
        I_list(2) = Congruential_16807(I_list(1))
        do i = 2, 43
            I_list(i + 1) = Congruential_16807()
        end do
        initialized = .true.
    end if
    I_list(44) = I_list(22) - I_list(1) - C
    if (I_list(44) >= 0) then
        C = 0
    else
        C = 1
        I_list(44) = I_list(44) + (2**32 - 5)
    end if
    Load_subtraction_generator = mod(I_list(44), m) / dble(m)

    contains
        function Congruential_16807(seed_)
            ! Schrage 方法产生 16807 产生器中的随机整数
            implicit none
            integer, parameter :: li = selected_int_kind(10)

            integer(li), intent(in), optional :: seed_
            integer :: Congruential_16807

            integer, parameter :: a = 7**5, m = 2**31 - 1
            integer, parameter :: q = 12773, r = 2836
            integer, save :: z

            if (present(seed_)) then
                z = seed_
            else if (z == -1) then
                z = 1
            end if
            z = a * mod(z, q) - r * (z / q)
            if (z < 0) then
                z = z + m
            end if
            Congruential_16807 = z
        end function Congruential_16807
end function Load_subtraction_generator


! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/56318
!
! Contributed by Alberto Luaces
!
SUBROUTINE mass_matrix
  DOUBLE PRECISION,PARAMETER::m1=1.d0
  DOUBLE PRECISION,DIMENSION(3,2),PARAMETER::A1=reshape([1.d0,0.d0, 0.d0, &
       0.d0,1.d0, 0.d0],[3,2])
  DOUBLE PRECISION,DIMENSION(2,2),PARAMETER::Mel=reshape([1.d0/3.d0, 0.d0, &
       0.d0, 1.d0/3.d0],[2,2])

  DOUBLE PRECISION,DIMENSION(3,3)::MM1

  MM1=m1*matmul(A1,matmul(Mel,transpose(A1)))
  !print '(3f8.3)', MM1
  if (any (abs (MM1 &
                - reshape ([1.d0/3.d0, 0.d0,      0.d0,  &
                            0.d0,      1.d0/3.d0, 0.d0,  &
                            0.d0,      0.d0,      0.d0], &
                           [3,3])) > epsilon(1.0d0))) &
    STOP 1
END SUBROUTINE mass_matrix

program name
  implicit none
  integer, parameter :: A(3,2) = reshape([1,2,3,4,5,6],[3,2])
  integer, parameter :: B(2,3) = reshape([3,17,23,31,43,71],[2,3])
  integer, parameter :: C(3)   = [-5,-7,-21]
  integer, parameter :: m1 = 1

!  print *, matmul(B,C)
   if (any (matmul(B,C) /= [-1079, -1793])) STOP 2
!  print *, matmul(C,A)
   if (any (matmul(C,A) /= [-82, -181])) STOP 3
!  print '(3i5)', m1*matmul(A,B)
  if (any (m1*matmul(A,B) /= reshape([71,91,111, 147,201,255, 327,441,555],&
                                     [3,3]))) &
     STOP 4
  call mass_matrix
end program name

! { dg-final { scan-tree-dump-times "matmul" 0 "original" } }


program Verifying_Goldbach_Conjecture_With_Subroutine
implicit none
    integer::x,y,n,W

    do n=6,100,2
        do x = 2 , n/2
        call Judge_Prime(x,W)
            if (W==0) then
                y = n - x
                call Judge_Prime(y,W)
                if (W==0) then
                    write(*,*) n,'=',x,'+',y
                end if
            end if
        end do
    end do
end program

subroutine Judge_Prime(x,W)
    integer,intent(in)::x
    integer,intent(out)::W
    integer::i,j

        i = sqrt(real(x))
        j = 2
        do while(j<=i .and. mod(x,j)/=0)
            j = j + 1
        end do

        if (j>i) then
            W=0
        else
            W=1
        end if

end subroutine


module stdlib_math
    use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp
    use stdlib_optval, only: optval

    implicit none
    private
    public :: clip, gcd, linspace, logspace
    public :: EULERS_NUMBER_SP, EULERS_NUMBER_DP
    public :: DEFAULT_LINSPACE_LENGTH, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH
    public :: arange

    integer, parameter :: DEFAULT_LINSPACE_LENGTH = 100
    integer, parameter :: DEFAULT_LOGSPACE_LENGTH = 50
    integer, parameter :: DEFAULT_LOGSPACE_BASE = 10

    ! Useful constants for lnspace
    real(sp), parameter :: EULERS_NUMBER_SP = exp(1.0_sp)
    real(dp), parameter :: EULERS_NUMBER_DP = exp(1.0_dp)

    interface clip
        module procedure clip_int32
        module procedure clip_dp
    end interface clip

    !> Returns the greatest common divisor of two integers
    !> ([Specification](../page/specs/stdlib_math.html#gcd))
    !>
    !> Version: experimental
    interface gcd
        module procedure gcd_int32
    end interface gcd

    interface linspace
    !! Version: Experimental
    !!
    !! Create rank 1 array of linearly spaced elements
    !! If the number of elements is not specified, create an array with size 100. If n is a negative value,
    !! return an array with size 0. If n = 1, return an array whose only element is end
    !!([Specification](../page/specs/stdlib_math.html#linspace-create-a-linearly-spaced-rank-one-array))
      pure module function linspace_default_1_rdp_rdp(start, end) result(res)
        real(dp), intent(in) :: start
        real(dp), intent(in) :: end

        real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_rdp_rdp
      pure module function linspace_default_1_cdp_cdp(start, end) result(res)
        complex(dp), intent(in) :: start
        complex(dp), intent(in) :: end

        complex(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_cdp_cdp

      pure module function linspace_n_1_rdp_rdp(start, end, n) result(res)
        real(dp), intent(in) :: start
        real(dp), intent(in) :: end
        integer, intent(in) :: n

        real(dp) :: res(max(n, 0))
      end function linspace_n_1_rdp_rdp
      pure module function linspace_n_1_cdp_cdp(start, end, n) result(res)
        complex(dp), intent(in) :: start
        complex(dp), intent(in) :: end
        integer, intent(in) :: n

        complex(dp) :: res(max(n, 0))
      end function linspace_n_1_cdp_cdp

    ! Add support for integer linspace
    !!
    !! When dealing with integers as the `start` and `end` parameters, the return type is always a `real(dp)`.
      pure module function linspace_default_1_iint32_iint32(start, end) result(res)
        integer(int32), intent(in) :: start
        integer(int32), intent(in) :: end

        real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_iint32_iint32

      pure module function linspace_n_1_iint32_iint32(start, end, n) result(res)
        integer(int32), intent(in) :: start
        integer(int32), intent(in) :: end
        integer, intent(in) :: n

        real(dp) :: res(max(n, 0))
      end function linspace_n_1_iint32_iint32

  end interface

  interface logspace
  !! Version: Experimental
  !!
  !! Create rank 1 array of logarithmically spaced elements from base**start to base**end.
  !! If the number of elements is not specified, create an array with size 50. If n is a negative value,
  !! return an array with size 0. If n = 1, return an array whose only element is base**end. If no base
  !! is specified, logspace will default to using a base of 10
  !!
  !!([Specification](../page/specs/stdlib_math.html#logspace-create-a-logarithmically-spaced-rank-one-array))
    pure module function logspace_1_rdp_default(start, end) result(res)

      real(dp), intent(in) :: start
      real(dp), intent(in) :: end

      real(dp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_rdp_default
    pure module function logspace_1_cdp_default(start, end) result(res)

      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end

      complex(dp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_cdp_default
    pure module function logspace_1_iint32_default(start, end) result(res)

      integer, intent(in) :: start
      integer, intent(in) :: end

      real(dp) :: res(DEFAULT_LOGSPACE_LENGTH)

  end function logspace_1_iint32_default

    pure module function logspace_1_rdp_n(start, end, n) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n

      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n
    pure module function logspace_1_cdp_n(start, end, n) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n

      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n
    pure module function logspace_1_iint32_n(start, end, n) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n

      real(dp) :: res(n)
    end function logspace_1_iint32_n

    ! Generate logarithmically spaced sequence from dp base to the powers
    ! of dp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    pure module function logspace_1_rdp_n_rbase(start, end, n, base) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n
      real(dp), intent(in) :: base
      ! real(dp) endpoints + real(dp) base = real(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n_rbase

    pure module function logspace_1_rdp_n_cbase(start, end, n, base) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n
      complex(dp), intent(in) :: base
      ! real(dp) endpoints + complex(dp) base = complex(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n_cbase

    pure module function logspace_1_rdp_n_ibase(start, end, n, base) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! real(dp) endpoints + integer base = real(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n_ibase
    ! Generate logarithmically spaced sequence from dp base to the powers
    ! of dp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    pure module function logspace_1_cdp_n_rbase(start, end, n, base) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n
      real(dp), intent(in) :: base
      ! complex(dp) endpoints + real(dp) base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n_rbase

    pure module function logspace_1_cdp_n_cbase(start, end, n, base) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n
      complex(dp), intent(in) :: base
      ! complex(dp) endpoints + complex(dp) base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n_cbase

    pure module function logspace_1_cdp_n_ibase(start, end, n, base) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! complex(dp) endpoints + integer base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n_ibase
    ! Generate logarithmically spaced sequence from dp base to the powers
    ! of dp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    pure module function logspace_1_iint32_n_rdpbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      real(dp), intent(in) :: base
      ! integer endpoints + real(dp) base = real(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_iint32_n_rdpbase

    pure module function logspace_1_iint32_n_cdpbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      complex(dp), intent(in) :: base
      ! integer endpoints + complex(dp) base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_iint32_n_cdpbase

    pure module function logspace_1_iint32_n_ibase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! integer endpoints + integer base = integer result
      integer :: res(max(n, 0))
    end function logspace_1_iint32_n_ibase

  end interface

    !> Version: experimental
    !>
    !> `arange` creates a one-dimensional `array` of the `integer/real` type
    !>  with fixed-spaced values of given spacing, within a given interval.
    !> ([Specification](../page/specs/stdlib_math.html#arange))
    interface arange
        pure module function arange_r_dp(start, end, step) result(result)
            real(dp), intent(in) :: start
            real(dp), intent(in), optional :: end, step
            real(dp), allocatable :: result(:)
        end function arange_r_dp
        pure module function arange_i_int32(start, end, step) result(result)
            integer(int32), intent(in) :: start
            integer(int32), intent(in), optional :: end, step
            integer(int32), allocatable :: result(:)
        end function arange_i_int32
    end interface arange

contains

    elemental function clip_int32(x, xmin, xmax) result(res)
        integer(int32), intent(in) :: x
        integer(int32), intent(in) :: xmin
        integer(int32), intent(in) :: xmax
        integer(int32) :: res

        res = max(min(x, xmax), xmin)
    end function clip_int32

    elemental function clip_dp(x, xmin, xmax) result(res)
        real(dp), intent(in) :: x
        real(dp), intent(in) :: xmin
        real(dp), intent(in) :: xmax
        real(dp) :: res

        res = max(min(x, xmax), xmin)
    end function clip_dp

    !> Returns the greatest common divisor of two integers of kind int32
    !> using the Euclidean algorithm.
    elemental function gcd_int32(a, b) result(res)
        integer(int32), intent(in) :: a
        integer(int32), intent(in) :: b
        integer(int32) :: res

        integer(int32) :: rem, tmp

        rem = min(abs(a), abs(b))
        res = max(abs(a), abs(b))
        do while (rem /= 0_int32)
          tmp = rem
          rem = mod(res, rem)
          res = tmp
        end do
    end function gcd_int32

end module stdlib_math


C$Procedure VPERP ( Perpendicular component of a 3-vector )

      SUBROUTINE VPERP ( A, B, P )

C$ Abstract
C
C     Find the component of a vector that is perpendicular to a second
C     vector.  All vectors are 3-dimensional.
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

      DOUBLE PRECISION   A ( 3 )
      DOUBLE PRECISION   B ( 3 )
      DOUBLE PRECISION   P ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     A          I    The vector whose orthogonal component is sought.
C     B          I    The vector used as the orthogonal reference.
C     P          O    The component of A orthogonal to B.
C
C$ Detailed_Input
C
C     A     is a double precision, 3-dimensional vector.  It the vector
C           whose component orthogonal to B is sought. (There is a
C           unique decomposition of A into a sum V + P, where V is
C           parallel to B and P is orthogonal to B.  We want the
C           component P.)
C
C     B     is a double precision, 3-dimensional vector.  This
C           vector is the vector used as a reference for the
C           decomposition of A.
C
C
C$ Detailed_Output
C
C     P     is a double precision, 3-dimensional vector containing
C           the component of A that is orthogonal to B.
C           P may overwrite either A or B.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Given and non-zero vector B and a vector A, there is a unique
C     decomposition of A as a sum V + P such that P is orthogonal
C     to B and V is parallel to B.  This routine finds the vector P.
C
C     If B is a zero vector, P will be identical to A.
C
C$ Examples
C
C     The following table gives sample inputs and results from calling
C     VPERP.
C
C        A                  B                 P
C        ------------------------------------------
C        (6, 6, 6)      ( 2, 0, 0)        (0, 6, 6)
C        (6, 6, 6)      (-3, 0, 0)        (0, 6, 6)
C        (6, 6, 0)      ( 0, 7, 0)        (6, 0, 0)
C        (6, 0, 0)      ( 0, 0, 9)        (6, 0, 0)
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     Any reasonable calculus text (for example Thomas)
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 11-MAY-2010 (EDW)
C
C       Minor edit to code comments eliminating typo.
C
C        Reordered header sections to proper NAIF convention.
C        Removed Revision section, it listed a duplication of a
C        Version section entry.
C
C-    SPICELIB Version 1.1.0, 09-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
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     perpendicular component of a 3-vector
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      BIGA
      DOUBLE PRECISION      BIGB
      DOUBLE PRECISION      R(3)
      DOUBLE PRECISION      T(3)
      DOUBLE PRECISION      V(3)

C
C     Error free routine:  no check-in.
C
      BIGA = MAX ( DABS(A(1)), DABS(A(2)), DABS(A(3)) )
      BIGB = MAX ( DABS(B(1)), DABS(B(2)), DABS(B(3)) )

C
C     If A is the zero vector, just set P to zero and return.
C
      IF ( BIGA .EQ. 0.0D0 ) THEN

         P(1) = 0.0D0
         P(2) = 0.0D0
         P(3) = 0.0D0
         RETURN

      END IF

C
C     If B is the zero vector, then set P equal to A.
C
      IF ( BIGB .EQ. 0.0D0 ) THEN

         P(1) = A(1)
         P(2) = A(2)
         P(3) = A(3)
         RETURN

      END IF

      T(1) = A(1) / BIGA
      T(2) = A(2) / BIGA
      T(3) = A(3) / BIGA

      R(1) = B(1) / BIGB
      R(2) = B(2) / BIGB
      R(3) = B(3) / BIGB

      CALL VPROJ  ( T,    R, V )
      CALL VSUB   ( T,    V, P )
      CALL VSCLIP ( BIGA,    P )

      RETURN
      END


! 6.2a в учебнике

program ex_6_2a
   implicit none

   integer, parameter      :: R_ = 16
   real(R_), parameter         :: PI = 4*ATAN(1.0)
   real(R_)                :: x = 0, numerator = 0, currentElement = 0, currentSum = 0, newSum = 0, numeratorDiff = 0
   integer                 :: In = 0, Out = 0, denominator = 0, i = 0, denominator_fact = 0, denominator_mul = 0
   character(*), parameter :: output_file = "output.txt", input_file = "../data/input.txt"

   open (file=input_file, newunit=In)
      read(In,*) x
   close (In)

   currentElement   = 1
   numerator        = 1
   denominator      = 1
   denominator_fact = 1
   numeratorDiff    = x**2

   do while (denominator > 0)
      i = i + 1

      newSum = currentSum + currentElement
      currentSum = newSum

      numerator = - numerator * numeratorDiff

      denominator_fact = denominator_fact * i
      denominator_mul = (2 * i) + 1
      denominator = denominator_fact * denominator_mul

      currentElement = numerator / denominator
   enddo

   open (file=output_file, newunit=Out)
      write(Out, '(f5.2,a,f5.2)') (2 * x) / sqrt(PI) * currentSum, ' ~' , erf(x)
   close (Out)

end program ex_6_2a


C******************** START FILE SPLAAN.FOR ; GROUP TRKRLIB ******************
C-------------------------------------------
C  derived from Forsyth/Malcolm/Moler SPLINE.FOR -- different BC:
C  y'=0 at LHS of data interval (low index side)
C
CCCCCCCCCCCCCCC
      SUBROUTINE r8splaan (N, X, Y, B, C, D)
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER N
      REAL*8 X(N), Y(N), B(N), C(N), D(N)
C
C  THE COEFFICIENTS B(I), C(I), AND D(I), I=1,2,...,N ARE COMPUTED
C  FOR A CUBIC INTERPOLATING SPLINE FOR WHICH S'(X1)=0.
C
C    S(X) = Y(I) + B(I)*(X-X(I)) + C(I)*(X-X(I))**2 + D(I)*(X-X(I))**3
C
C    FOR  X(I) .LE. X .LE. X(I+1)
C
C  INPUT..
C
C    N = THE NUMBER OF DATA POINTS OR KNOTS (N.GE.2)
C    X = THE ABSCISSAS OF THE KNOTS IN STRICTLY INCREASING ORDER
C    Y = THE ORDINATES OF THE KNOTS
C
C  OUTPUT..
C
C    B, C, D  = ARRAYS OF SPLINE COEFFICIENTS AS DEFINED ABOVE.
C
C  USING  P  TO DENOTE DIFFERENTIATION,
C
C    Y(I) = S(X(I))
C    B(I) = SP(X(I))
C    C(I) = SPP(X(I))/2
C    D(I) = SPPP(X(I))/6  (DERIVATIVE FROM THE RIGHT)
C
CCCCCCCCCCCCCCC
C  THE ACCOMPANYING FUNCTION SUBPROGRAM  SEVAL  CAN BE USED
C  TO EVALUATE THE SPLINE.
C
C
      INTEGER NM1, IB, I
      REAL*8 T
C
      NM1 = N-1
      IF ( N .LT. 2 ) RETURN
      IF ( N .LT. 3 ) GO TO 50
C
C  SET UP TRIDIAGONAL SYSTEM
C
C  B = DIAGONAL, D = OFFDIAGONAL, C = RIGHT HAND SIDE.
C
      D(1) = X(2) - X(1)
      C(2) = (Y(2) - Y(1))/D(1)
      DO 10 I = 2, NM1
         D(I) = X(I+1) - X(I)
         B(I) = 2._r8*(D(I-1) + D(I))
         C(I+1) = (Y(I+1) - Y(I))/D(I)
         C(I) = C(I+1) - C(I)
   10 CONTINUE
C
C  END CONDITIONS.  THIRD DERIVATIVES AT  X(1)  AND  X(N)
C  OBTAINED FROM DIVIDED DIFFERENCES
C
      B(1)=2._r8*D(1)
      B(N) = -D(N-1)
      C(1) = 0._r8
      C(N) = 0._r8
      IF ( N .EQ. 3 ) GO TO 15
      C(1) = (Y(2)-Y(1))/D(1)
      C(N) = C(N-1)/(X(N)-X(N-2)) - C(N-2)/(X(N-1)-X(N-3))
      C(N) = -C(N)*D(N-1)**2/(X(N)-X(N-3))
C
C  FORWARD ELIMINATION
C
   15 DO 20 I = 2, N
         T = D(I-1)/B(I-1)
         B(I) = B(I) - T*D(I-1)
         C(I) = C(I) - T*C(I-1)
   20 CONTINUE
C
C  BACK SUBSTITUTION
C
      C(N) = C(N)/B(N)
      DO 30 IB = 1, NM1
         I = N-IB
         C(I) = (C(I) - D(I)*C(I+1))/B(I)
   30 CONTINUE
C
C  C(I) IS NOW THE SIGMA(I) OF THE TEXT
C
C  COMPUTE POLYNOMIAL COEFFICIENTS
C
      B(N) = (Y(N) - Y(NM1))/D(NM1) + D(NM1)*(C(NM1) + 2._r8*C(N))
      DO 40 I = 1, NM1
         B(I) = (Y(I+1) - Y(I))/D(I) - D(I)*(C(I+1) + 2._r8*C(I))
         D(I) = (C(I+1) - C(I))/D(I)
         C(I) = 3._r8*C(I)
   40 CONTINUE
      C(N) = 3._r8*C(N)
      D(N) = D(N-1)
      RETURN
C
   50 B(1) = (Y(2)-Y(1))/(X(2)-X(1))
      C(1) = 0._r8
      D(1) = 0._r8
      B(2) = B(1)
      C(2) = 0._r8
      D(2) = 0._r8
      RETURN
      END
C******************** END FILE SPLAAN.FOR ; GROUP TRKRLIB ******************


subroutine Wigner3j(w3j, jmin, jmax, j2, j3, m1, m2, m3)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will calculate the Wigner 3j symbols
!
!		j  j2 j3
!		m1 m2 m3
!
!	for all allowable values of j. The returned values in the array j are
!	calculated only for the limits
!
!		jmin = max(|j2-j3|, |m1|)
!		jmax = j2 + j3
!
!	To be non-zero, m1 + m2 + m3 = 0. In addition, it is assumed that all j and m are
!	integers. Returned values have a relative error less than ~1.d-8 when j2 and j3
!	are less than 103 (see below). In practice, this routine is probably usable up to 165.
!
!	This routine is based upon the stable non-linear recurence relations of Luscombe and
!	Luban (1998) for the "non classical" regions near jmin and jmax. For the classical
!	region, the standard three term recursion relationship is used (Schulten and Gordon 1975).
!	Note that this three term recursion can be unstable and can also lead to overflows. Thus
!	the values are rescaled by a factor "scalef" whenever the absolute value of the 3j coefficient
!	becomes greater than unity. Also, the direction of the iteration starts from low values of j
!	to high values, but when abs(w3j(j+2)/w3j(j)) is less than one, the iteration will restart
!	from high to low values. More efficient algorithms might be found for specific cases
!	(for instance, when all m's are zero).
!
!	Verification:
!
!	The results have been verified against this routine run in quadruple precision.
!	For 1.e7 acceptable random values of j2, j3, m2, and m3 between -200 and 200, the relative error
!	was calculated only for those 3j coefficients that had an absolute value greater than
!	1.d-17 (values smaller than this are for all practical purposed zero, and can be heavily
!	affected by machine roundoff errors or underflow). 853 combinations of parameters were found
!	to have relative errors greater than 1.d-8. Here I list the minimum value of max(j2,j3) for
!	different ranges of error, as well as the number of times this occured
!
!	1.d-7 < error  <=1.d-8 = 103	# = 483
!	1.d-6 < error <= 1.d-7 =  116	# = 240
!	1.d-5 < error <= 1.d-6 =  165	# = 93
!	1.d-4 < error <= 1.d-5 = 167	# = 36
!
!	Many times (maybe always), the large relative errors occur when the 3j coefficient
!	changes sign and is close to zero. (I.e., adjacent values are about 10.e7 times greater
!	in magnitude.) Thus, if one does not need to know highly accurate values of the 3j coefficients
!	when they are almost zero (i.e., ~1.d-10) then this routine is probably usable up to about 160.
!
!	These results have also been verified for parameter values less than 100 using a code
!	based on the algorith of de Blanc (1987), which was originally coded by Olav van Genabeek,
!	and modified by M. Fang (note that this code was run in quadruple precision, and
!	only calculates one coefficient for each call. I also have no idea if this code
!	was verified.) Maximum relative errors in this case were less than 1.d-8 for a large number
!	of values (again, only 3j coefficients greater than 1.d-17 were considered here).
!
!	The biggest improvement that could be made in this routine is to determine when one should
!	stop iterating in the forward direction, and start iterating from high to low values.
!
!	Calling parameters
!		IN
!			j2, j3, m1, m2, m3 	Integer values.
!		OUT
!			w3j			Array of length jmax - jmin + 1.
!			jmin, jmax		Minimum and maximum values
!						out output array.
!	Dependencies: None
!
!	Written by Mark Wieczorek August (2004)
!
!	August 2009: Based on the suggestions of Roelof Rietbroek, the calculation of RS has been slightly
!	modified so that division by zero will not cause a run time crash (this behavior depends on how the
!	compiler treats IEEE floating point exceptions). These values were never used in the original code
!	when this did occur.
!
!	Copyright (c) 2005-2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	j2, j3, m1, m2, m3
	integer, intent(out) ::	jmin, jmax
	real*8, intent(out) ::	w3j(:)
	real*8 ::		wnmid, wpmid, scalef, denom, rs(j2+j3+1), &
				wl(j2+j3+1), wu(j2+j3+1), xjmin, yjmin, yjmax, zjmax, xj, zj
	integer :: 		j, jnum, jp, jn, k, flag1, flag2, jmid

	if (size(w3j) < j2+j3+1) then
		print*, "Error --- Wigner3j"
		print*, "W3J must be dimensioned (J2+J3+1) where J2 and J3 are ", j2, j3
		print*, "Input array is dimensioned ", size(w3j)
		stop
	endif

	w3j = 0.0d0

	flag1 = 0
	flag2 = 0

	scalef = 1.0d3

	jmin = max(abs(j2-j3), abs(m1))
	jmax = j2 + j3
	jnum = jmax - jmin + 1

	if (abs(m2) > j2 .or. abs(m3) > j3) then
		return
	elseif (m1 + m2 + m3 /= 0) then
		return
	elseif (jmax < jmin) then
		return
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Only one term is present
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (jnum == 1) then
		w3j(1) = 1.0d0 / sqrt(2.0d0*jmin+1.0d0)
		if ( (w3j(1) < 0.0d0 .and. (-1)**(j2-j3+m2+m3) > 0) .or. &
			(w3j(1) > 0.0d0 .and. (-1)**(j2-j3+m2+m3) < 0) ) &
			w3j(1) = -w3j(1)
		return
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Calculate lower non-classical values for [jmin, jn]. If the second term
	!	can not be calculated because the recursion relationsips give rise to a
	!	1/0, then set flag1 to 1.  If all m's are zero, then this is not a problem
	!	as all odd terms must be zero.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	rs = 0.0d0
	wl = 0.0d0

	xjmin = x(jmin)
	yjmin = y(jmin)

	if (m1 == 0 .and. m2 == 0 .and. m3 == 0) then		! All m's are zero

		wl(jindex(jmin)) = 1.0d0
		wl(jindex(jmin+1)) = 0.0d0
		jn = jmin+1

	elseif (yjmin == 0.0d0) then				! The second terms is either zero

		if (xjmin == 0.0d0) then			! or undefined
			flag1 = 1
			jn = jmin
		else
			wl(jindex(jmin)) = 1.0d0
			wl(jindex(jmin+1)) = 0.0d0
			jn = jmin+1
		endif

	elseif ( xjmin * yjmin >= 0.0d0) then			! The second term is outside of the
								! non-classical region
		wl(jindex(jmin)) = 1.0d0
		wl(jindex(jmin+1)) = -yjmin / xjmin
		jn = jmin+1

	else							! Calculate terms in the non-classical region

		rs(jindex(jmin)) = -xjmin / yjmin

		jn = jmax
		do j=jmin + 1, jmax-1, 1
			denom =  y(j) + z(j)*rs(jindex(j-1))
			xj = x(j)
			if (abs(xj) > abs(denom) .or. xj * denom >= 0.0d0 .or. denom == 0.0d0) then
				jn = j-1
				exit
			else
				rs(jindex(j)) = -xj / denom
			endif

		enddo

		wl(jindex(jn)) = 1.0d0

		do k=1, jn - jmin, 1
			wl(jindex(jn-k)) = wl(jindex(jn-k+1)) * rs(jindex(jn-k))
		enddo

		if (jn == jmin) then					! Calculate at least two terms so that
			wl(jindex(jmin+1)) = -yjmin / xjmin		! these can be used in three term
			jn = jmin+1					! recursion

		endif

	endif

	if (jn == jmax) then					! All terms are calculated

		w3j(1:jnum) = wl(1:jnum)
		call normw3j
		call fixsign

		return

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Calculate upper non-classical values for [jp, jmax].
	!	If the second last term can not be calculated because the
	!	recursion relations give a 1/0, then set flag2 to 1.
	!	(Note, I don't think that this ever happens).
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	wu = 0.0d0

	yjmax = y(jmax)
	zjmax = z(jmax)

	if (m1 == 0 .and. m2 == 0 .and. m3 == 0) then

		wu(jindex(jmax)) = 1.0d0
		wu(jindex(jmax-1)) = 0.0d0
		jp = jmax-1

	elseif (yjmax == 0.0d0) then

		if (zjmax == 0.0d0) then
			flag2 = 1
			jp = jmax
		else
			wu(jindex(jmax)) = 1.0d0
			wu(jindex(jmax-1)) = - yjmax / zjmax
			jp = jmax-1
		endif

	elseif (yjmax * zjmax >= 0.0d0) then

		wu(jindex(jmax)) = 1.0d0
		wu(jindex(jmax-1)) = - yjmax / zjmax
		jp = jmax-1

	else
		rs(jindex(jmax)) = -zjmax / yjmax

		jp = jmin
		do j=jmax-1, jn, -1
			denom = y(j) + x(j)*rs(jindex(j+1))
			zj = z(j)
			if (abs(zj) > abs(denom) .or. zj * denom >= 0.0d0 .or. denom == 0.0d0) then
				jp = j+1
				exit
			else
				rs(jindex(j)) = -zj / denom
			endif
		enddo

		wu(jindex(jp)) = 1.0d0

		do k=1, jmax - jp, 1
			wu(jindex(jp+k)) = wu(jindex(jp+k-1))*rs(jindex(jp+k))
		enddo

		if (jp == jmax) then
			wu(jindex(jmax-1)) = - yjmax / zjmax
			jp = jmax-1
		endif

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Calculate classical terms for [jn+1, jp-1] using standard three
	! 	term rercusion relationship. Start from both jn and jp and stop at the
	! 	midpoint. If flag1 is set, then perform the recursion solely from high to
	! 	low values. If flag2 is set, then perform the recursion solely from low to high.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (flag1 == 0) then

		jmid = (jn + jp)/2

		do j=jn, jmid - 1, 1
			wl(jindex(j+1)) = - (z(j)*wl(jindex(j-1)) +y(j)*wl(jindex(j))) / x(j)

			if (abs(wl(jindex(j+1))) > 1.0d0) then				! watch out for overflows.
				wl(jindex(jmin):jindex(j+1)) = wl(jindex(jmin):jindex(j+1)) / scalef
			endif

			if (abs(wl(jindex(j+1)) / wl(jindex(j-1))) < 1.0d0 .and. &	! if values are decreasing
				wl(jindex(j+1)) /= 0.0d0) then				! then stop upward iteration
				jmid = j+1						! and start with the downward
				exit							! iteration.
			endif
		enddo

		wnmid = wl(jindex(jmid))

		if (abs(wnmid/wl(jindex(jmid-1))) < 1.d-6 .and. &
			wl(jindex(jmid-1)) /= 0.0d0) then				! Make sure that the stopping
			wnmid = wl(jindex(jmid-1))					! midpoint value is not a zero,
			jmid = jmid - 1							! or close to it!
		endif

		do j=jp, jmid+1, -1
			wu(jindex(j-1)) = - (x(j)*wu(jindex(j+1)) + y(j)*wu(jindex(j)) ) / z(j)
			if (abs(wu(jindex(j-1))) > 1.0d0) then
				wu(jindex(j-1):jindex(jmax)) = wu(jindex(j-1):jindex(jmax)) / scalef
			endif

		enddo

		wpmid = wu(jindex(jmid))

		! rescale two sequences to common midpoint

		if (jmid == jmax) then
			w3j(1:jnum) = wl(1:jnum)
		elseif (jmid == jmin) then
			w3j(1:jnum) = wu(1:jnum)
		else
			w3j(1:jindex(jmid)) = wl(1:jindex(jmid)) * wpmid / wnmid
			w3j(jindex(jmid+1):jindex(jmax)) = wu(jindex(jmid+1):jindex(jmax))
		endif

	elseif (flag1 == 1 .and. flag2 == 0) then	! iterature in downward direction only

		do j=jp, jmin+1, -1
			wu(jindex(j-1)) = - (x(j)*wu(jindex(j+1)) + y(j)*wu(jindex(j)) ) / z(j)
			if (abs(wu(jindex(j-1))) > 1) then
				wu(jindex(j-1):jindex(jmax)) = wu(jindex(j-1):jindex(jmax)) / scalef
			endif
		enddo

		w3j(1:jnum) = wu(1:jnum)

	elseif (flag2 == 1 .and. flag1 == 0) then	! iterature in upward direction only

		do j=jn, jp-1, 1
			wl(jindex(j+1)) = - (z(j)*wl(jindex(j-1)) +y(j)*wl(jindex(j))) / x(j)
			if (abs(wl(jindex(j+1))) > 1) then
				wl(jindex(jmin):jindex(j+1)) = wl(jindex(jmin):jindex(j+1))/ scalef
			endif
		enddo

		w3j(1:jnum) = wl(1:jnum)

	elseif (flag1 == 1 .and. flag2 == 1) then

		print*, "Fatal Error --- Wigner3j"
		print*, "Can not calculate function for input values, both flag1 and flag 2 are set."
		stop
	endif

	call normw3j
	call fixsign

	contains

		integer function jindex(j)
			integer :: j
			jindex = j-jmin+1
		end function jindex

		real*8 function a(j)
			integer :: j
			a = (dble(j)**2 - dble(j2-j3)**2) * (dble(j2+j3+1)**2 - dble(j)**2) * (dble(j)**2-dble(m1)**2)
			a = sqrt(a)
		end function a

		real*8 function y(j)
			integer :: j
			y = -dble(2*j+1) * &
				( dble(m1) * (dble(j2)*dble(j2+1) - dble(j3)*dble(j3+1) ) - dble(m3-m2)*dble(j)*dble(j+1) )
		end function y

		real*8 function x(j)
			integer :: j
			x = dble(j) * a(j+1)
		end function x

		real*8 function z(j)
			integer :: j
			z = dble(j+1)*a(j)
		end function z

		subroutine normw3j
			real*8:: norm
			integer j

			norm = 0.0d0
			do j = jmin, jmax
				norm = norm + dble(2*j+1) * w3j(jindex(j))**2
			enddo

			w3j(1:jnum) = w3j(1:jnum) / sqrt(norm)

		end subroutine normw3j

		subroutine fixsign

			if ( (w3j(jindex(jmax)) < 0.0d0 .and. (-1)**(j2-j3+m2+m3) > 0) .or. &
				(w3j(jindex(jmax)) > 0.0d0 .and. (-1)**(j2-j3+m2+m3) < 0) ) then
				w3j(1:jnum) = -w3j(1:jnum)
			endif

		end subroutine fixsign

end subroutine Wigner3j


! This program demonstrates the usage of selected_int_kind
! SELECTED_INT_KIND(R) return the kind value of the smallest integer
! type that can represent all values ranging from
! -10^R (exclusive) to 10^R (exclusive).
! If there is no integer kind that accommodates this range,
! SELECT_INT_KIND returns -1.
!
program kind_int_types
  implicit none
  print*, 'SELECTED_INT_KIND(1) = ', selected_int_kind(1)
  print*, 'SELECTED_INT_KIND(2) = ', selected_int_kind(2)
  print*, 'SELECTED_INT_KIND(3) = ', selected_int_kind(3)
  print*, 'SELECTED_INT_KIND(4) = ', selected_int_kind(4)
  print*, 'SELECTED_INT_KIND(5) = ', selected_int_kind(5)
  print*, 'SELECTED_INT_KIND(6) = ', selected_int_kind(6)
  print*, 'SELECTED_INT_KIND(7) = ', selected_int_kind(7)
  print*, 'SELECTED_INT_KIND(8) = ', selected_int_kind(8)
  print*, 'SELECTED_INT_KIND(9) = ', selected_int_kind(9)
  print*, 'SELECTED_INT_KIND(10) = ', selected_int_kind(10)
end program kind_int_types