! Modern Fortran statistical computations module
module stats_module
contains
   ! function returns real mean of all array elements
   function mean(x, n) result(m)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function result location
      real :: m
      ! processing
      m = sum(x) / n
   end function mean

   ! function returns array of deviations about central tendency m
   function compute_dev(x, m, n) result(dev)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in) :: m
      real, dimension(n), intent(in) :: x
      ! function result location
      real, dimension(n) :: dev
      ! processing
      dev = x - m
   end function compute_dev

   ! function returns array of absolute deviations about central tendency m
   function compute_adev(x, m, n) result(dev)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in) :: m
      real, dimension(n), intent(in) :: x
      ! function result location
      real, dimension(n) :: dev
      ! processing
      dev = abs(x - m)
   end function compute_adev

   ! function returns real population variance of x
   function pop_var(x, n) result(var)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: var
      ! processing
      var = sum(compute_dev(x, mean(x, n), n)**2) / n
   end function pop_var

   ! function returns real sample variance of x
   function sam_var(x, n) result(var)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: var
      ! processing
      var = sum(compute_dev(x, mean(x, n), n)**2) / (n - 1)
   end function sam_var

   ! function returns real population standard deviation of x
   function pop_std(x, n) result(std)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: std
      ! processing
      std = sqrt(pop_var(x, n))
   end function pop_std

   ! function returns real sample standard deviation of x
   function sam_std(x, n) result(std)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: std
      ! processing
      std = sqrt(sam_var(x, n))
   end function sam_std

   ! functions returns index of kth element of x
   ! C. A. R. Hoare's algorithm
   ! implementation works on index array only - preserves data set array
   function quick_select(k, n, x) result(v)
      implicit none
      ! dummy arguments
      integer, intent(in) :: k, n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: v
      ! local variables
      integer :: i, j, left, right, tmp
      integer, dimension(n) :: idx
      real :: pivot
      ! processing
      do i=1,n
         idx(i)=i
      end do
      left=1
      right=n
      do while (left < right)
         pivot=x(idx(k))
         i=left
         j=right
         do
            do while (x(idx(i)) < pivot)
               i=i+1
            end do
            do while (pivot < x(idx(j)))
               j=j-1
            end do
            if (i <= j) then
               tmp=idx(i)
               idx(i)=idx(j)
               idx(j)=tmp
               i=i+1
               j=j-1
            end if
            if (i > j) exit
         end do
         if (j < k) left=i
         if (k < i) right=j
      end do
      v=x(idx(k))
   end function quick_select

   ! function returns median of x
   function median(x, n) result(mdn)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: mdn
      ! processing
      if (mod(n, 2) /= 0) then
         mdn=quick_select(n/2+1, n, x)
      else
         mdn=(quick_select(n/2, n, x) + quick_select(n/2+1, n, x))/2
      end if
   end function median

   !funcition returns median absolute deviation of x
   function median_deviation(x, n) result(mad)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: mad
      ! processing
      mad = median( compute_adev(x, median(x, n), n), n )
   end function median_deviation

   ! function computes the mean absolute deviation of x
   function mean_deviation(x, n) result(aad)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: aad
      ! processing
      aad = mean( compute_adev(x, mean(x, n), n), n )
   end function mean_deviation

   ! function computes the skewness of x (expected value 1/N)
   function skewness(x, n) result(skw)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, intent(in), dimension(n) :: x
      ! function return location
      real :: skw
      ! processing
      skw = sum(compute_dev(x, mean(x, n), n)**3) / ((n - 1) * sam_std(x, n)**3)
   end function skewness

   ! function computes the sample covariance of data sets x and y
   function covar(x, y, n) result(cov)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, dimension(n), intent(in) :: x, y
      ! function return location
      real :: cov
      ! processing
      cov = sum(compute_dev(x,mean(x,n),n)*compute_dev(y,mean(y,n),n))/(n-1)
   end function covar

   ! correlation coefficient of data sets x and y
   function p(x, y, n) result(corr)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      real, dimension(n), intent(in) :: x, y
      ! function return location
      real :: corr
      ! processing
      corr = covar(x, y, n) / (sam_std(x, n) * sam_std(y, n))
   end function p
end module stats_module


program main
    implicit none
    integer :: clock, i, n
    integer, allocatable :: seed(:)
    integer(4) :: n_in, n_tot = 100000000
    real(8) :: x, y
    real(8) :: pi

    call SYSTEM_CLOCK(clock)
    call RANDOM_SEED(size = n)
    allocate(seed(n))
    do i = 1, n
        seed(i) = clock + 37 * i
    end do
    call RANDOM_SEED(put = seed)
    do i = 1, n_tot
        call RANDOM_NUMBER(x)
        x = 2 * x - 1
        call RANDOM_NUMBER(y)
        y = 2 * y - 1
        if (x**2 + y**2 <= 1.d0) then
            n_in = n_in + 1
        end if
    end do
    pi = 4 * dble(n_in) / dble(n_tot)
    write(*,'(f10.8)') pi
end program main


      FUNCTION BESSY0 (X)
      IMPLICIT NONE
      REAL *8 X,BESSY0,BESSJ0,FS,FR,Z,FP,FQ,XX
! ---------------------------------------------------------------------
!     This subroutine calculates the Second Kind Bessel Function of
!     order 0, for any real number X. The polynomial approximation by
!     series of Chebyshev polynomials is used for 0<X<8 and 0<8/X<1.
!     REFERENCES:
!     M.ABRAMOWITZ,I.A.STEGUN, HANDBOOK OF MATHEMATICAL FUNCTIONS, 1965.
!     C.W.CLENSHAW, NATIONAL PHYSICAL LABORATORY MATHEMATICAL TABLES,
!     VOL.5, 1962.
! ---------------------------------------------------------------------
      REAL *8 Y,P1,P2,P3,P4,P5,R1,R2,R3,R4,R5,R6  &
               ,Q1,Q2,Q3,Q4,Q5,S1,S2,S3,S4,S5,S6
      DATA P1,P2,P3,P4,P5 /1.D0,-.1098628627D-2,.2734510407D-4, &
      -.2073370639D-5,.2093887211D-6 /
      DATA Q1,Q2,Q3,Q4,Q5 /-.1562499995D-1,.1430488765D-3,  &
      -.6911147651D-5,.7621095161D-6,-.9349451520D-7 /
      DATA R1,R2,R3,R4,R5,R6 /-2957821389.D0,7062834065.D0, &
      -512359803.6D0,10879881.29D0,-86327.92757D0,228.4622733D0 /
      DATA S1,S2,S3,S4,S5,S6 /40076544269.D0,745249964.8D0, &
      7189466.438D0,47447.26470D0,226.1030244D0,1.D0 /
      IF (X.EQ.0.D0) THEN
      BESSY0 = -1.E30
      RETURN
      ENDIF
      IF (X.LT.8.D0) THEN
      Y = X*X
      FR = R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))
      FS = S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6))))
      BESSY0 = FR/FS+.636619772D0*BESSJ0(X)*LOG(X)
      ELSE
      Z = 8.D0/X
      Y = Z*Z
      XX = X-.785398164D0
      FP = P1+Y*(P2+Y*(P3+Y*(P4+Y*P5)))
      FQ = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))
      BESSY0 = SQRT(.636619772D0/X)*(FP*SIN(XX)+Z*FQ*COS(XX))
      ENDIF
      RETURN
      END


PROGRAM ROOTS_OF_A_FUNCTION

  IMPLICIT NONE

  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15)
  REAL(dp) :: f, e, x, step, value
  LOGICAL :: s

  f(x) = x*x*x - 3.0_dp*x*x + 2.0_dp*x

  x = -1.0_dp ; step = 1.0e-6_dp ; e = 1.0e-9_dp

  s = (f(x) > 0)
  DO WHILE (x < 3.0)
    value = f(x)
    IF(ABS(value) < e) THEN
      WRITE(*,"(A,F12.9)") "Root found at x =", x
      s = .NOT. s
    ELSE IF ((value > 0) .NEQV. s) THEN
      WRITE(*,"(A,F12.9)") "Root found near x = ", x
      s = .NOT. s
    END IF
    x = x + step
  END DO

END PROGRAM ROOTS_OF_A_FUNCTION


program main1
    use Matrix

    implicit none

!   Command-line Args
    integer :: argc

    character(len=32) :: matrix_fname, vector_fname

!   Matrices
    integer :: m, n, i
    double precision, allocatable :: A(:, :)

!   Determinant
    double precision :: d

!   Spectral Radius
    double precision :: r

!   For LU decomposition & Cholesky also
    double precision, allocatable :: L(:, :), U(:, :)

!   For PLU decomposition
    double precision, allocatable :: P(:, :)

!   Vectors
    integer :: t
    double precision, allocatable :: b(:)
    double precision, allocatable :: x(:)
    double precision, allocatable :: y(:)

!   Error
    double precision :: e

!   Get Command-Line Args
    matrix_fname = 'matrix.txt'
    vector_fname = 'vector.txt'

    argc = iargc()

    if (argc == 1) then
        call getarg(1, matrix_fname)
    elseif(argc == 2) then
        call getarg(1, matrix_fname)
        call getarg(2, vector_fname)
    elseif (argc > 2) then
        goto 92
    end if

    call read_matrix(matrix_fname, A, m, n)
    call read_vector(vector_fname, b, t)

    if (m /= n) then
        goto 90
    elseif (m /= t) then
        goto 91
    end if

!   Print Matrix
!   Print Matrix Name
    write(*, *) 'A:'
    call print_matrix(A, m, n)

!   Print Matrix
!   Print Matrix Name
    write(*, *) 'b:'
    call print_vector(b, t)

!   Print its Determinant
    d = det(A, n)
    write(*, *) 'Matrix Determinant =', d

!   Print its Spectral Radius
    r = spectral_radius(A, n)
    write(*, *) 'Spectral Radius =', r

    if (d == 0.0D0) then
        goto 93
    endif

!   Decomposition Time!
!   Allocate Result Matrices
    allocate(P(n, n))
    allocate(L(n, n))
    allocate(U(n, n))

!   Linear System Time!
!   Allocate Result Vectors
    allocate(x(n))
    allocate(y(n))

!   Try LU Decomposition
    call info(':: Decomposição LU (sem pivoteamento) ::')
    if (.NOT. LU_DECOMP(A, L, U, n)) then
        goto 81
    else if (.NOT. LU_solve(A, x, y, b, n)) then
        goto 81
    end if

    write(*, *) 'L:'
    call print_matrix(L, n, n)

    write(*, *) 'U:'
    call print_matrix(U, n, n)

    write(*, *) 'y:'
    call print_vector(y, n)

    write(*, *) 'x:'
    call print_vector(x, n)

!   Try PLU Decomposition
81  call info(':: Decomposição PLU (com pivoteamento) ::')
    if (.NOT. PLU_DECOMP(A, P, L, U, n)) then
        goto 82
    else if (.NOT. PLU_solve(A, x, y, b, n)) then
        goto 82
    end if

    write(*, *) 'P:'
    call print_matrix(P, n, n)

    write(*, *) 'L:'
    call print_matrix(L, n, n)

    write(*, *) 'U:'
    call print_matrix(U, n, n)

    write(*, *) 'y:'
    call print_vector(y, n)

    write(*, *) 'x:'
    call print_vector(x, n)

    call info("DET")
    d = 1.0D0
    do i = 1, n
        d = d * U(i, i) * L(i, i)
    end do
    write(*, *) d

    write(*, *) 'x:'
    call print_vector(x, n)

!   Try Cholesky Decomposition
82  call info(':: Decomposição de Cholesky ::')
    if (.NOT. CHOLESKY_DECOMP(A, L, n)) then
        goto 83
    else if (.NOT. Cholesky_solve(A, x, y, b, n)) then
        goto 83
    end if

    write(*, *) 'L:'
    call print_matrix(L, n, n)

    write(*, *) 'y:'
    call print_vector(y, n)

    write(*, *) 'x:'
    call print_vector(x, n)

!   Try Jacobi Method
83  call info(':: Método de Jacobi ::')
    if (.NOT. Jacobi(A, x, b, e, n)) then
        goto 84
    end if

    write(*, *) 'x:'
    call print_vector(x, n)

    print *, 'e =', e

!   Try Gauss-Seidel Method
84  call info(':: Método de Gauss-Seidel ::')
    if (.NOT. Gauss_Seidel(A, x, b, e, n)) then
        goto 85
    end if

    write(*, *) 'A:'
    call print_matrix(A, n, n)

    write(*, *) 'x:'
    call print_vector(x, n)

    write(*, *) 'b:'
    call print_vector(b, n)

    print *, 'e = ', e

85  call info('Sucesso!')
    deallocate(A)
    deallocate(P)
    deallocate(L)
    deallocate(U)
    deallocate(b)
    goto 100

90  call error('Essa matriz não é quadrada! Assim o programa não faz sentido.')
    goto 100
91  call error('A matriz `A` e o vetor `b` não possuem a mesma dimensão. Não tem como fazer Ax = b!')
    goto 100
92  call error('Parâmetros em excesso: O programa espera apenas o nome do arquivo da matriz.')
    goto 100
93  call error('O Determinante é 0! Os métodos não se aplicam nesse caso.')
    goto 100

100     stop

end program main1


	FUNCTION PR_SPED ( uwnd, vwnd )
C************************************************************************
C* PR_SPED 								*
C*									*
C* This function computes SPED from UWND and VWND.  The following	*
C* equation is used:				 			*
C* 									*
C*           SPED = SQRT ( (UWND**2) + (VWND**2) )			*
C*									*
C* This function computes SKNT if UKNT and VKNT are input.		*
C*									*
C* REAL PR_SPED  ( UWND, VWND )						*
C*									*
C* Input parameters:							*
C*	UWND		REAL		U component of velocity		*
C*	VWND		REAL		V component of velocity		*
C*									*
C* Output parameters:							*
C*	PR_SPED		REAL		Wind speed 			*
C**									*
C* Log:									*
C* P. Kocin/914		1980	Original source code			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 7/88	Documentation				*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( uwnd ) .or. ERMISS ( vwnd ) )  THEN
	    PR_SPED = RMISSD
	  ELSE
	    PR_SPED = SQRT ( ( uwnd **2 ) + ( vwnd **2 ) )
	END IF
C*
	RETURN
	END


MODULE tools
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
CONTAINS
  SUBROUTINE derivative(func, x, step_size, result)
  IMPLICIT NONE
  INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
  REAL(KIND=DBL), EXTERNAL :: func
  REAL(KIND=DBL), INTENT(IN) :: x
  REAL(KIND=DBL), INTENT(IN) :: step_size
  REAL(KIND=DBL), INTENT(OUT) :: result
  ! Calculate average rate of change at x over step_size
  result = (func(x + step_size) - func(x)) / step_size
  END SUBROUTINE derivative

  REAL(KIND=DBL) FUNCTION f1(x)
  IMPLICIT NONE
  REAL(KIND=DBL), INTENT(IN) :: x
  f1 = x**2 + 1._DBL
  END FUNCTION f1

  REAL(KIND=DBL) FUNCTION f2(x)
  IMPLICIT NONE
  REAL(KIND=DBL), INTENT(IN) :: x
  f2 = 10._DBL * SIN(20._DBL * x)
  END FUNCTION f2
END MODULE tools

PROGRAM test_der_2
USE tools
IMPLICIT NONE
REAL(KIND=DBL) :: x, step_size, result
x = 0._DBL
step_size = 0.000001_DBL
CALL derivative(f2, x, step_size, result)
WRITE(*, *) result
END PROGRAM test_der_2


!##############################################################################
! PROGRAM bisection
!
! ## A bisection method to find the root of a function
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program bisection

    implicit none
    integer :: iter
    real*8 :: x, a, b, fx, fa, fb

    ! set initial guesses and function values
    a =  0.05d0
    b =  0.25d0
    fa = 0.5d0*a**(-0.2d0)+0.5d0*a**(-0.5d0)-2d0
    fb = 0.5d0*b**(-0.2d0)+0.5d0*b**(-0.5d0)-2d0

    ! check whether there is a root in [a,b]
    if(fa*fb >= 0d0)then
        stop 'Error: There is no root in [a,b]'
    endif

    ! start iteration process
    do iter = 1, 200

        ! calculate new bisection point and function value
        x = (a+b)/2d0
        fx = 0.5d0*x**(-0.2d0)+0.5d0*x**(-0.5d0)-2d0

        write(*,'(i4,f12.7)')iter, abs(x-a)

        ! check for convergence
        if(abs(x-a) < 1d-6)then
            write(*,'(/a,f12.7,a,f12.9)')' x = ',x,'    f = ',fx
            stop
        endif

        ! calculate new interval
        if(fa*fx < 0d0)then
            b = x
            fb = fx
        else
            a = x
            fa = fx
        endif
    enddo

    write(*,'(a)')'Error: no convergence'

end program


module class_Polygon

  implicit none
  private
  real :: pi = acos(-1.0d0)

  type, public :: Polygon
    integer :: nSides
    real :: side
  contains
    procedure :: area => polygon_area
    procedure :: print => polygon_print
  end type

contains

  pure function polygon_area(this) result(area)

    class(Polygon), intent(in) :: this
    real :: area
    real :: perimeter, apothem

    perimeter = this%nSides * this%side
    apothem = this%side / (2.0d0 * tan(pi / this%nSides))

    area = (perimeter * apothem) / 2.0d0

  end function

  subroutine polygon_print(this)

    class(Polygon), intent(in) :: this
    real:: area

    area = this%area()
    print *, 'Polygon: nSides = ', this%nSides, ' side = ', this%side, ' area = ', area

  end subroutine

end module


! In this module you can define for example global constants

MODULE constants
  ! definition of variables for double precisions and complex variables
  INTEGER,  PARAMETER :: dp = KIND(1.0D0)
  INTEGER, PARAMETER :: dpc = KIND((1.0D0,1.0D0))
  ! Global Truncation parameter
  REAL(DP), PARAMETER, PUBLIC ::  truncation=1.0E-10
END MODULE constants

PROGRAM improved_exp
  USE constants
  IMPLICIT NONE
  REAL (dp) :: x, term, final_sum
  INTEGER  :: n, loop_over_x

  !  loop over x-values, no floats as loop variables
  DO loop_over_x=0, 100, 10
     x=loop_over_x
     !  initialize the EXP sum
     final_sum=1.0 ; term=1.0 ; n = 1
     DO WHILE ( ABS(term) > truncation)
        term = -term*x/FLOAT(n)
        final_sum=final_sum+term
        n=n+1
     ENDDO
     !  write the argument x, the exact value, the computed value and n
     WRITE(*,*) x ,EXP(-x), final_sum, n
  ENDDO

END PROGRAM improved_exp


implicit none
real :: a, b, m, f

a = 1.0
b = 2.0

do while (b - a > 1.0e-11)
  m = (a + b) / 2.0
  if (f(a) * f(m) < 0.0) then
    b = m
  else
    a = m
  end if
  print*, 'Current m: ', m
  print*, 'Current (b - a): ', b-a
end do
stop
end

real function f(x)
  implicit none
  real :: x

  f = x**2 - 3.0

  return
end

4670 Numerical Analysis/Class Examples/bb1.f90


MODULE coord

	use constantes
	implicit none

	contains

subroutine cart_sph(x,r)
	!----------------------------------------------------------
	! Switching from cartesian to spherical coordinates
	! CALLING SEQUENCE: call cart_sph(x,r)
	! INPUT:  x: position vector in cartesian coordinates
	! OUTPUT: r: position vector in spherical coordinates
	!            (radial distance,azimuthal angle,polar angle)			!
	!----------------------------------------------------------

	real(kind=8), dimension(:,:), intent(in)  :: x
	real(kind=8), dimension(:,:), intent(out) :: r

	r(1,:) = sqrt(x(1,:)**2+x(2,:)**2+x(3,:)**2)

	!longitude
	where (x(2,:) < 0.d0)
		r(2,:) = 2.d0*pi-acos(x(1,:)/sqrt(x(1,:)**2+x(2,:)**2))
	elsewhere
		r(2,:) = acos(x(1,:)/sqrt(x(1,:)**2+x(2,:)**2))
	end where

	where (x(1,:) .eq. 0.d0 .and. x(2,:).eq. 0.d0)
		r(2,:) = pi/2.d0
	end where

	!colatitude
	where (r(1,:) .ne. 0.d0)
		r(3,:) = pi/2.d0 - acos(x(3,:)/r(1,:))
	elsewhere
		r(3,:) = pi/2.d0
	end where

end subroutine cart_sph

subroutine cart_cyl(x,r)
	!----------------------------------------------------------
	! Switching from cartesian to cylindrical coordinates
	! CALLING SEQUENCE: call cart_cyl(x,r)
	! INPUT:  x: position vector in cartesian coordinates
	! OUTPUT: r: position vector in cylindrical coordinates
	!	     (radial distance,angular coordinate,altitude)			!
	!----------------------------------------------------------

	real(kind=8), dimension(:,:), intent(in)  :: x
	real(kind=8), dimension(:,:), intent(out) :: r

	! altitude
	r(3,:)=x(3,:)

	! radial distance
	r(1,:) = sqrt(x(1,:)**2+x(2,:)**2)

	! angular coordinate
	where (x(1,:) .ge. 0.d0 .and. x(2,:) .ne. 0.d0)
		r(2,:) = asin(x(2,:)/r(1,:))
	end where
	where (x(1,:) .lt. 0.d0 .and. x(2,:) .ne. 0.d0)
		r(2,:) = pi - asin(x(2,:)/r(1,:))
	end where

	where (x(1,:) .eq. 0.d0 .and. x(2,:).eq. 0.d0)
		r(2,:) = 0.d0
	end where

end subroutine cart_cyl

subroutine sph_cart(r,x)
	!----------------------------------------------------------
	! Switching from spherical to cartesian coordinates
	! CALLING SEQUENCE: call cart_sph(r,x)
	! INPUT:  r: position vector in spherical coordinates
	!	     (radial distance,azimuthal angle,polar angle)
	! OUTPUT: x: position vector in cartesian coordinates
	!----------------------------------------------------------

	real(kind=8), dimension(:,:), intent(in)  :: r
	real(kind=8), dimension(:,:), intent(out) :: x

	x(1,:) = r(1,:)*cos(r(3,:))*cos(r(2,:))
	x(2,:) = r(1,:)*cos(r(3,:))*sin(r(2,:))
	x(3,:) = r(1,:)*sin(r(3,:))

end subroutine sph_cart

subroutine cyl_cart(r,x)
	!----------------------------------------------------------
	! Switching from cylindrical to cartesian coordinates
	! CALLING SEQUENCE: call cyl_cart(r,x)
	! INPUT:  r: position vector in cylindrical coordinates
	!	     (radial distance,angular coordinate,altitude)
	! OUTPUT: x: position vector in cartesian coordinates
	!----------------------------------------------------------

	real(kind=8), dimension(:,:), intent(in)  :: r
	real(kind=8), dimension(:,:), intent(out) :: x

	x(1,:) = r(1,:)*cos(r(2,:))
	x(2,:) = r(1,:)*sin(r(2,:))
	x(3,:) = r(3,:)

end subroutine cyl_cart

subroutine sph_cart_vect(Vr,r,Vx)
	!-------------------------------------------------------------------------------------
	! Switching from spherical to cartesian coordinates for a vector at a point r
	! CALLING SEQUENCE: call sph_cart_vect(Vr,r,Vx)
	! INPUT: Vr : vector in spherical coordinates
	!	     (radial distance,azimuthal angle,polar angle)
	!         r : position vector in spherical coordinates
	!	     (radial distance,azimuthal angle,polar angle)
	! OUTPUT: Vx: vector in cartesian coordinates  (Vx,Vy,Vz)
	!-------------------------------------------------------------------------------------

	real(kind=8), dimension(:,:), intent(in)  :: r,Vr
	real(kind=8), dimension(:,:), intent(out) :: Vx

	Vx(1,:)=Vr(1,:)*cos(r(2,:))*cos(r(3,:))-Vr(2,:)*sin(r(2,:))-Vr(3,:)*sin(r(3,:))*cos(r(2,:))
	Vx(2,:)=Vr(1,:)*sin(r(2,:))*cos(r(3,:))+Vr(2,:)*cos(r(2,:))-Vr(3,:)*sin(r(2,:))*sin(r(3,:))
	Vx(3,:)=Vr(1,:)*sin(r(3,:))+Vr(3,:)*cos(r(3,:))

end subroutine sph_cart_vect
subroutine cyl_cart_vect(Vr,r,Vx)
	!-------------------------------------------------------------------------------------
	! Switching from cylindrical to cartesian coordinates for a vector at a point r
	! CALLING SEQUENCE: call cyl_cart_vect(Vr,r,Vx)
	! INPUT: Vr : vector in cylindrical coordinates
	!             (radial distance,angular coordinate,altitude)
	!         r : position vector in cylindrical coordinates
	!             (radial distance,angular coordinate,altitude)
	!
	! OUTPUT: Vx: vector in cartesian coordinates  (Vx,Vy,Vz)
	!-------------------------------------------------------------------------------------

	real(kind=8), dimension(:,:), intent(in)  :: r,Vr
	real(kind=8), dimension(:,:), intent(out) :: Vx

	Vx(1,:)=Vr(1,:)*cos(r(2,:))-Vr(2,:)*sin(r(2,:))
	Vx(2,:)=Vr(1,:)*sin(r(2,:))+Vr(2,:)*cos(r(2,:))
	Vx(3,:)=Vr(3,:)

end subroutine cyl_cart_vect
subroutine rot(Vin,theta,Vout)
	!------------------------------------------------------
	! Rotation of the Vin vector by an angle theta
	! CALLING SEQUENCE: call rot(Vin,theta,Vout)
	! INPUT:  Vin: vector in cartesian coordinates
	!       theta: angle in degre
	!
	! OUTPUT: Vout: modified vector in cartesian coordinates.
	!------------------------------------------------------
	real(kind=8), dimension(:,:), intent(in)  :: Vin
	real(kind=8), dimension(:), intent(in)    :: theta
	real(kind=8), dimension(:,:), intent(out) :: Vout
	real(kind=8), dimension(3,3)			  :: matrot
	integer									  :: i

	write(*,*) theta
	do i=1,size(theta)
!		matrot(1,1) = cos(theta(i)*pi/180.) ; matrot(1,2) = -sin(theta(i)*pi/180.) ; matrot(1,3)=0.d0
!		matrot(2,1) = sin(theta(i)*pi/180.) ; matrot(2,2) = cos(theta(i)*pi/180.)  ; matrot(2,3)=0.d0
!		matrot(3,1) = 0.d0		 		    ; matrot(3,2) = 0.d0				   ; matrot(3,3)=1.d0

		matrot(1,1) = cos(theta(i)*pi/180.) ; matrot(1,2) =  0.d0		; matrot(1,3)=-sin(theta(i)*pi/180.)
		matrot(2,1) = 0.d0				    ; matrot(2,2) =  1.d0		; matrot(2,3)=0.d0
		matrot(3,1) = sin(theta(i)*pi/180.) ; matrot(3,2) = 0.d0		; matrot(3,3)=cos(theta(i)*pi/180.)

		Vout(:,i) = matmul(matrot,Vin(:,i))

	enddo

end subroutine rot

END MODULE coord


!=====================================================================================
module det  ! �s�񎮌v�Z���W���[���u���l�v�Z�̂��߂�Fortran90/95�v���O���~���O����v�����p
  implicit none
contains
  recursive function det_mat(a,n) result(det)
    integer, intent(in) :: n
    real(8), intent(in) :: a(n, n)
    real(8) det, b(n-1, n-1)
    integer i
    if (n > 1) then
      det = 0.0d0
      do i = 1, n
        b(1:i-1, 1:n-1) = a(1:i-1, 2:n)
        b(i:n-1, 1:n-1) = a(i+1:n, 2:n)
        det = det + (-1.0d0) ** (i + 1) &
          * a(i, 1) * det_mat(b, n-1)

      enddo
    else
      det = a(1,1)
    endif
  end function det_mat
  !=====================================================================================
   subroutine trans_rank_2(A,A_T)
	  real(8),intent(in)::A(:,:)
	  real(8),allocatable,intent(out)::A_T(:,:)
	  integer n,m,i,j

	  n=size(A,1)
	  m=size(A,2)
	  if(.not. allocated(A_T) )allocate(A_T(m,n))

	  do i=1,n
		do j=1, m
			A_T(j,i)=A(i,j)
		enddo
	  enddo

   end subroutine trans_rank_2
  !==================================================================================
     function trans1(A) result(A_T)
	  real(8),intent(in)::A(:)
	  real(8),allocatable::A_T(:,:)
	  integer n,m,i,j

	  n=size(A)
	  if(.not. allocated(A_T) )allocate(A_T(1,n))

	  do i=1,n
			A_T(1,i)=A(i)
	  enddo

   end function trans1
  !==================================================================================
   function trans2(A) result(A_T)
	  real(8),intent(in)::A(:,:)
	  real(8),allocatable::A_T(:,:)
	  integer n,m,i,j

	  n=size(A,1)
	  m=size(A,2)
	  if(.not. allocated(A_T) )allocate(A_T(m,n))

	  do i=1,n
		do j=1, m
			A_T(j,i)=A(i,j)
		enddo
	  enddo

   end function trans2
  !==================================================================================
     subroutine inverse_rank_2(A,A_inv)
	  real(8),intent(in)::A(:,:)
	  real(8),allocatable::A_inv(:,:)
	  real(8) detA,detA_1
	  integer m,n

	  m=size(A,1)
	  n=size(A,2)
	  if(.not. allocated(A_inv) )allocate(A_inv(m,n))
	  detA=det_mat(A,n)
	  if(detA==0.0d0) stop "ERROR: inverse, detA=0"
	  detA_1=1.0d0/detA
	  if(n==2)then
		A_inv(1,1)=detA_1*A(2,2)
		A_inv(1,2)=-detA_1*A(1,2)
		A_inv(2,1)=-detA_1*A(2,1)
		A_inv(2,2)=detA_1*A(1,1)
	  elseif(n==3)then
		A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
		A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3))
		A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2))
		A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3))
		A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1))
		A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3))
		A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
		A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2))
		A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1))
	  else
		print *, "ERROR: Aij with i=j=",n,"/=2or3"
	  endif

   end subroutine inverse_rank_2
  !==================================================================================
	subroutine tensor_exponential(A,expA,TOL,itr_tol)
	real(8),intent(in)::A(:,:),TOL
	real(8),allocatable,intent(inout)::expA(:,:)
	real(8),allocatable::increA(:,:)
	integer, intent(in)::itr_tol
	real(8) increment,NN
	integer i,j,n

	if(.not. allocated(expA) )allocate(expA(size(A,1),size(A,2) ))
	allocate(increA(size(A,1),size(A,2) ))
	if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix"

	expA(:,:)=0.0d0
	do n=1,size(expA,1)
		expA(n,n)=1.0d0
	enddo
	NN=1.0d0
	increA(:,:)=expA(:,:)
	do n=1,itr_tol
		if(n>1)then
			NN       = NN*(NN+1.0d0)
		endif
		increA(:,:)=matmul(increA,A)
		expA(:,:)= expA(:,:)+1.0d0/NN*increA(:,:)

		increment=0.0d0
		do i=1,size(A,1)
			do j=1,size(A,2)
				increment=increment+1.0d0/NN*increA(i,j)*increA(i,j)
			enddo
		enddo

		if(increment<=TOL)then
			exit
		else
			if(n>=itr_tol)then
				 stop "tensor exponential is not converged"
			endif
			cycle
		endif
	enddo

	deallocate(increA)

	end subroutine tensor_exponential
  !==================================================================================
  subroutine tensor_expo_der(A,expA_A,TOL,itr_tol)
	real(8),intent(in)::A(:,:),TOL
	real(8),allocatable,intent(inout)::expA_A(:,:,:,:)
	real(8),allocatable::increA_1(:,:),increA_2(:,:),increA_3(:,:,:,:),I_ij(:,:),A_inv(:,:)
	integer, intent(in)::itr_tol
	real(8) increment,NN
	integer i,j,k,l,n,m,o

	if(.not. allocated(expA_A) )allocate(expA_A(size(A,1),size(A,1),size(A,1),size(A,1) ))
	allocate(I_ij(size(A,1),size(A,1) ))
	allocate(increA_1(size(A,1),size(A,1) ))
	allocate(increA_2(size(A,1),size(A,1) ))
	allocate(increA_3(size(A,1),size(A,1),size(A,1),size(A,1) ) )
	if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix"

	call inverse_rank_2(A,A_inv)

	I_ij(:,:)=0.0d0
	do n=1,size(expA_A,1)
		I_ij(n,n)=1.0d0
	enddo
	NN=1.0d0

	do i=1,size(A,1)
		do j=1,size(A,1)
			do k=1, size(A,1)
				do l=1, size(A,1)
					expA_A(i,j,k,l)=I_ij(i,k)*I_ij(l,j)
				enddo
			enddo
		enddo
	enddo

	increA_1(:,:)=I_ij(:,:)
	increA_2(:,:)=I_ij(:,:)
	do n=1,itr_tol
		if(n>2)then
			NN = NN*(NN+1.0d0)
		endif
		increA_1(:,:)=A_inv(:,:)
		increA_2(:,:)=matmul(increA_2,A)

		increA_3(:,:,:,:)=0.0d0
		do m=1,n
			increA_1(:,:)=matmul(increA_1,A    )

			increA_2(:,:)=matmul(increA_2,A_inv)

			do i=1,size(A,1)
				do j=1,size(A,1)
					do k=1, size(A,1)
						do l=1, size(A,1)
							increA_3(i,j,k,l)=increA_3(i,j,k,l)+increA_1(i,k)*increA_2(l,j)
							expA_A(i,j,k,l)=expA_A(i,j,k,l)+1.0d0/NN*increA_3(i,j,k,l)
						enddo
					enddo
				enddo
			enddo
		enddo

		do i=1,size(A,1)
			do j=1,size(A,1)
				do k=1, size(A,1)
					do l=1, size(A,1)
						increment=increment+1.0d0/NN*increA_3(i,j,k,l)&
							*increA_3(i,j,k,l)&
							*increA_3(i,j,k,l)&
							*increA_3(i,j,k,l)
					enddo
				enddo
			enddo
		enddo

		if(increment<=TOL)then
			exit
		else
			if(n>=itr_tol)then
				 stop "tensor exponential is not converged"
			endif
			cycle
		endif
	enddo

	deallocate(increA_1,increA_2,increA_3,I_ij,A_inv)

	end subroutine tensor_expo_der
  !==================================================================================
end module det


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0)
    real(dp) :: epsilonA = 1.d0, epsilonB = 1.d0, t = 5.d-1, k, E1, E2

    ! reduced zone scheme
    open(unit = 1, file = '3-E-k-ReducedZoneScheme-2.txt', status = 'unknown')
    k = -pi
    do while(k <= pi)
        ! acoustic mode
        E1 = ((epsilonA + epsilonB) - sqrt((epsilonA - epsilonB)**2 + 4.d0 * (2.d0 + 2.d0 * cos(k)))) / 2.d0
        ! optical mode
        E2 = ((epsilonA + epsilonB) + sqrt((epsilonA - epsilonB)**2 + 4.d0 * (2.d0 + 2.d0 * cos(k)))) / 2.d0
        write(1,'(3f20.8)') k, E1, E2
        k = k + 1.d-2
    end do
    close(1)

    ! extended zone scheme
    ! optical mode
    open(unit = 2, file = '3-E-k-ExtendedZoneScheme-Optical-2.txt', status = 'unknown')
    k = 0.d0
    do while (k <= pi)
        E1 = ((epsilonA + epsilonB) + sqrt((epsilonA - epsilonB)**2 + 4.d0 * (2.d0 + 2.d0 * cos(-2.d0 * pi + k)))) / 2.d0
        E2 = ((epsilonA + epsilonB) + sqrt((epsilonA - epsilonB)**2 + 4.d0 * (2.d0 + 2.d0 * cos(pi + k)))) / 2.d0
        write(2,'(4f20.8)') -2.d0 * pi + k, E1, pi + k, E2
        k = k + 1.d-2
    end do
    close(2)
end program main


PROGRAM PIB1D_INFINITE_WELL
    IMPLICIT NONE

    REAL, PARAMETER :: PI = acos(-1.0)
    REAL, ALLOCATABLE:: potential(:), x(:)
    DOUBLE PRECISION, ALLOCATABLE:: hmat(:,:), eigenVal(:), work(:)
    DOUBLE PRECISION:: Expect_X
    REAL:: xmax, xmin, dx, hbar = 1.0, m = 1.0, tconst
    INTEGER:: nx, lwork, i, ifail, Expect_N, n

    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter the number of grid points: "
    READ(*, *) nx

    xmax = 5.0
    xmin = 0.0
    dx = (xmax - xmin)/(nx - 1)

    ALLOCATE(potential(nx), hmat(nx,nx), eigenVal(nx), x(nx), work(64*nx))
    DO i = 1, nx
        x(i) = xmin + (i-1)*dx
    ENDDO

    tconst = (hbar**2) / (2.0 * m * dx**2)
    hmat = 0.0

    potential = 0.0

    DO i = 1, nx-1
        hmat(i, i) = potential(i) + 2.0 * tconst
        hmat(i, i+1) = -tconst
        hmat(i+1, i) = -tconst
    ENDDO
    hmat(nx, nx) = potential(nx) + 2.0 * tconst

    lwork = 64*nx
    CALL dsyev('V', 'U', nx, hmat, nx, eigenVal, work, lwork, ifail)

    ! Sorting but no need as eigenVal is already sorted
    ! DO i = 1, nx
    !     DO j = i, nx
    !         IF(eigenVal(i) .GT. eigenVal(j)) THEN
    !             tmp = eigenVal(j)
    !             eigenVal(j) = eigenVal(i)
    !             eigenVal(i) = tmp
    !         ENDIF
    !     ENDDO
    ! ENDDO

    OPEN(UNIT = 20, FILE = 'output.txt')
        ! WRITE(20, *) 'Grid Point (Value of x)         eigenValue Calculated           Exect EigenValue        WaveFunction'
        DO i = 1, nx
            WRITE(20, 10) x(i), eigenVal(i), i**2 * pi**2/(2.0 * (xmax-xmin)**2), (hmat(i, n)/sqrt(dx), n = 1, 5)
            10 FORMAT(f8.3, 3x, f0.3, 3x, f0.3, 3x, f8.3, 3x, f8.3, 3x, f8.3, 3x, f8.3, 3x, f8.3, 3x)
        ENDDO
    CLOSE(20)

    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Expectation value for n = "

    ! Expect_N is a expectation value of quantum number N
    READ(*, *) Expect_N

    ! Expect_X is a expectation value of position x
    Expect_X = 0.0

    DO i = 1, nx
        Expect_X = Expect_X + hmat(i, Expect_N) * x(i) * hmat(i, Expect_N) !*dx
    ENDDO

    WRITE(*, *) Expect_X

END PROGRAM PIB1D_INFINITE_WELL

Particle In a Box (PIB)/1_InfiniteWell.f90


SUBROUTINE running_average ( x, ave, std_dev, nvals, reset )
!
!  Purpose:
!    To calculate the running average, standard deviation,
!    and number of data points as data values x are received.
!    If "reset" is .TRUE., clear running sums and exit.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    06/26/02    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
REAL, INTENT(IN) :: x           ! Input data value.
REAL, INTENT(OUT) :: ave        ! Running average.
REAL, INTENT(OUT) :: std_dev    ! Running standard deviation.
INTEGER, INTENT(OUT) :: nvals   ! Current number of points.
LOGICAL, INTENT(IN) :: reset    ! Reset flag: clear sums if true

! Data dictionary: declare local variable types & definitions
INTEGER, SAVE :: n              ! Number of input values.
REAL, SAVE :: sum_x             ! Sum of input values.
REAL, SAVE :: sum_x2            ! Sum of input values squared.

! If the reset flag is set, clear the running sums at this time.
calc_sums: IF ( reset ) THEN

   n       = 0
   sum_x   = 0.
   sum_x2  = 0.
   ave     = 0.
   std_dev = 0.
   nvals   = 0

ELSE

   ! Accumulate sums.
   n      = n + 1
   sum_x  = sum_x + x
   sum_x2 = sum_x2 + x**2

   ! Calculate average.
   ave = sum_x / REAL(n)

   ! Calculate standard deviation.
   IF ( n >= 2 ) THEN
      std_dev = SQRT( (REAL(n) * sum_x2 - sum_x**2) &
              / (REAL(n) * REAL(n-1)) )
   ELSE
      std_dev = 0.
   END IF

   ! Number of data points.
   nvals = n

END IF calc_sums

END SUBROUTINE running_average


function legpts(n,I_in) result(x)
! Returns legendre points on interval I by applying the recurrence relation for the Legendre polynomials and their derivatives to perform Newton iteration on the WKB approximation to the roots.
!This code was adapted from Chebfun (https://www.chebfun.org) legpts.m
! === Parameters ===========================================
! n - number of chebyshev points
! I_in - (array) 2x1 array containing inteval
! === Output ==============================================
! c - (array) nx1 array of chebyshev points

integer, intent(in) :: n
real(kind=8), intent(in), optional :: I_in(2)
real(kind=8) :: I(2), eps
real(kind=8), allocatable :: x(:), Pm1(:), Pm2(:), PPm1(:), PPm2(:), P(:), PP(:), dx(:), xp(:)
integer :: counter, j, npn, nnn

if(present(I_in)) then
    I = I_in
else
    I = (/ -1.d0, 1.d0 /)
endif

allocate(x(n))

if(n .eq. 1) then
  x(1) = 0.d0
  RETURN
endif

npn = ceiling(n / 2.d0) ! num positive nodes
nnn = floor(n / 2.0d0)  ! num negative nodes

allocate(xp(npn))
allocate(P(npn))
allocate(PP(npn))
allocate(Pm1(npn))
allocate(Pm2(npn))
allocate(PPm2(npn))
allocate(PPm1(npn))
allocate(dx(npn))

do j = 1, npn
    xp(j) = real(npn - (j - 1))
enddo

! form initial guess
xp = PI * (4.d0 * xp - 1.d0) / (4.d0 * n + 2.d0)
xp = (1.d0 - (n - 1.d0) / (8.d0 * n**3) - 1.d0 / (384.d0 * n**4) * (39.d0 - 28.d0 / sin(xp)**2) ) * cos(xp)

Pm2  = 1.d0
Pm1  = xp
PPm2 = 0.d0
PPm1 = 1.d0
eps  = .00000000000000023d0
dx   = 2.d0 * eps
counter = 0

! Newton Interations
do while ( maxval(abs(dx)) > eps .and. counter < 10)
    counter = counter + 1;
    do j = 1, n-1
        P    = ((2.d0 * j + 1.d0) * Pm1 * xp - j * Pm2) / (j + 1.d0);
        Pm2  = Pm1;
        Pm1  = P;
        PP   = ((2.d0 * j + 1.d0) * (Pm2 + xp * PPm1) - j * PPm2) / (j + 1.d0);
        PPm2 = PPm1;
        PPm1 = PP;
    enddo
    ! Newton correction and update
    dx = -P / PP;
    xp = xp + dx;
    ! reinitialize
    Pm2  = 1;
    Pm1  = xp;
    PPm2 = 0;
    PPm1 = 1;
enddo

! reflect positive points
x(n-npn+1:n) = xp
do j = 1, nnn
    x(j) = -1 * xp(npn - j + 1)
end do

! scale according to interval
x = (I(2) - I(1))/2.d0 * x + (I(2) + I(1))/2.d0

end function legpts


PROGRAM Radioactive_Decay
!--------------------------------------------------------
! 给定放射性元素的初量值和半衰期，计算一定时间后的剩余量
! 变量名：
!　      InitialAmount     : 放射性元素的初量值(mg)
!        RemainingAmount   : 放射性元素的剩余量(mg)
!        HalfLife          : 放射性元素的半衰期(天)
!        Time              : 给定时间          (天)
! 输入变量：InitialAmount，HalfLife，Time
! 输出变量：RemainingAmount
!--------------------------------------------------------

IMPLICIT NONE
REAL :: InitialAmount, RemainingAmount, HalfLife, Time

PRINT *, "输入初量值(mg)，半衰期(天)，时间(天)"
READ  *, InitialAmount, HalfLife, Time

RemainingAmount=InitialAmount*0.5**(Time/HalfLife)
PRINT *, "剩余量=",RemainingAmount," (mg)"

END PROGRAM Radioactive_Decay


C  User-defined Rate Law functions
C  Note: the default argument type for rate laws, as read from the equations file, is single precision
C        but all the internal calculations are performed in REAL*8

C Arrhenius
      KPP_REAL FUNCTION ARR( A0,B0,C0 )
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'

      REAL A0,B0,C0
      ARR =  DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0D0)**DBLE(C0)

      RETURN
      END

C Simplified Arrhenius, with two arguments
C Note: The argument B0 has a changed sign when compared to ARR
      KPP_REAL FUNCTION ARR2( A0,B0 )
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'

      REAL A0,B0
      ARR2 =  DBLE(A0) * EXP( DBLE(B0)/TEMP )

      RETURN
      END

      KPP_REAL FUNCTION EP2(A0,C0,A2,C2,A3,C3)
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'

      REAL A0,C0,A2,C2,A3,C3
      REAL*8 K0,K2,K3

      K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP)
      K3 = K3*CFACTOR*1.0d6
      EP2 = K0 + K3/(1.0d0+K3/K2 )

      RETURN
      END

      KPP_REAL FUNCTION EP3(A1,C1,A2,C2)
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'

      REAL A1, C1, A2, C2
      REAL*8 K1, K2

      K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      EP3 = K1 + K2*(1.0d6*CFACTOR)

      RETURN
      END

      KPP_REAL FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF)
      INCLUDE 'KPP_ROOT_Parameters.h'
      INCLUDE 'KPP_ROOT_Global.h'

      REAL A0,B0,C0,A1,B1,C1,CF
      REAL*8 K0, K1

      K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0D0)**DBLE(C0)
      K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0D0)**DBLE(C1)
      K0 = K0*CFACTOR*1.0D6
      K1 = K0/K1
      FALL = (K0/(1.0d0+K1))*
     *      DBLE(CF)**(1.0d0/(1.0d0+(DLOG10(K1))**2))

      RETURN
      END


PROGRAM  question3
    IMPLICIT NONE
    ! ----------------- Static Dimension Statements ------------------- !
    ! INTEGER :: i, j, k
    ! REAL, DIMENSION(3):: a, b, sum

    ! WRITE(*, *) "Enter 3 Real Number for first vector in a line"
    ! READ(*, *) (a(i), i = 1, 3)
    ! WRITE(*, *) "Enter 3 Real Number for Second vector in a line"
    ! READ(*, *) (b(j), j = 1, 3)

    ! DO k = 1, 3
    !     sum(k) = a(k) + b(k)
    ! ENDDO

    ! WRITE(*, *) "The sum of these vector is"
    ! WRITE(*, *) (sum(k), k = 1, 3)
    ! WRITE(*, *) "The lenghth of final vector is = 3"

    ! ----------------- Allocatable Arrays ------------------- !
    INTEGER :: i, j, k, n, m, sum_size
    REAL, DIMENSION(:), ALLOCATABLE:: a, b, sum

    10 FORMAT("Enter ", i0, " real number for this vector: ")

    WRITE(*, '(A)', ADVANCE = "NO") "Enter dimention of first vector: "
    READ(*, *) n
    WRITE(*, *)
    ALLOCATE(a(n))
    WRITE(*, 10, ADVANCE = "NO") n
    READ(*, *) (a(i), i = 1, n)

    WRITE(*, *)
    WRITE(*, '(A)', ADVANCE = "NO") "Enter dimention of second vector: "
    READ (*, *) m
    ALLOCATE(b(m))
    WRITE(*, 10, ADVANCE = "NO") m
    READ(*, *) (b(j), j = 1, m)

    sum_size = MAX(n, m)
    ALLOCATE(sum(sum_size))

    DO k = 1, sum_size
        IF(n == 0) THEN
            sum(k) = b(k)
        ELSE IF(m == 0) THEN
            sum(k) = a(k)
        ELSE
            sum(k) = a(k) + b(k)
            n = n-1
            m = m-1
        ENDIF
    ENDDO

    WRITE(*, *)
    WRITE(*, '(A)', ADVANCE = "NO") "The sum of these vector is: "
    WRITE(*, *) (sum(k), k = 1, sum_size)

    WRITE(*, 11) sum_size
    11 FORMAT(/,"Length of final vector = ", i0/)

END


! triangle - SSS configuration
!   input - the lengths of the three sides
!   output -
!       the angles opposite each side
!       the semiperimeter and the area
!       type of triangle

      program triangle
      print*,"SSS Congruence"
      print*,"Enter the lengths of the three sides:"
      read(*,*) a, b, c

! Error conditions
!   (1) the sides must be positive in length
      if(a.le.0.0 .or. b.le.0.0 .or. c.le.0.0) then
          print*,"ERROR: The sides must be positive in length"
          stop 1
      end if
!   (2) The triangle inequality must be strictly satisfied.
!           a + b < c; b + c < a; c + a < c
!       A sufficient and necessary condition is that no side may
!       exceed the semiperimeter.
      s = (a + b + c) / 2.0     ! semiperimeter
      if (max(a,b,c) .ge. s) then
          print*,"ERROR: (triangle inequality) max(a,b,c) < s"
          stop 1
      end if

      write(6,*) "sides:", a, b, c

! law of cosines
      alpha = acos((b*b + c*c - a*a) / (2*b*c))
      beta = acos((a*a + c*c - b*b) / (2*a*c))
      gamm = acos((a*a + b*b - c*c) / (2*a*b))

! angles in degrees
      pi = 4*atan(1.d0)
      dalpha = 180 * alpha / pi
      dbeta = 180 * beta / pi
      dgamma = 180 * gamm / pi

! output solution of triangle
      print*,"------- SOLUTION ------------------------------------"
      write(6,*) "a =", a, "  (given)"
      write(6,*) "b =", b, "  (given)"
      write(6,*) "c =", c, "  (given)"
      write(6,*) "A =", alpha, "degrees:", dalpha
      write(6,*) "B =", beta, "degrees:", dbeta
      write(6,*) "C =", gamm, "degrees:", dgamma
      print*,"-----------------------------------------------------"

! output semiperimeter and area
      write(6,*) "semiperimeter:", s
      area = sqrt(s * (s-a) * (s-b) * (s-c))    ! Heron's formula
      write(6,*) "area:", area

! angle sum
      sum1 = alpha + beta + gamm
      err1 = sum1 - pi
      sum2 = dalpha + dbeta + dgamma
      err2 = sum2 - 180.0
      write(6,*) "angle sum (radians):", sum1, "   error:", err1
      write(6,*) "angle sum (degrees):", sum2, "   error:", err2

! Nesbitt's inequality
      symsum = a/(b+c) + b/(a+c) + c/(a+b)
      print*,"Nesbitt's symmetric sum:", symsum
      if (symsum.lt.1.5) then
          print*,"   Error: sum < 1.5"
      end if
      if (symsum.ge.2) then
          print*,"   Error: sum > 2"
      end if

      end program


! **
! * Provides a root finder using Newton's method
! **
module newton
    use kinds, only: dp
    implicit none
    private
    public :: root

    contains

        ! **
        ! * Searches for the root of the function f(x, [p2,p3,p4,p5])-offset_in.
        ! *
        ! * Input:
        ! *     - f: function, whose root will be searched
        ! *     - df: derivative of f(x,...)
        ! *     - xguess: an initial guess for the root
        ! *     - minx_in (optional): if this parameter is present, the root is only searched for in the right neighborhood of minx_in
        ! *     - max_iter_in (optional): maximum amount of iterations in Newton's method
        ! *     - eps_in (optional): if this parameter is present, the root is approximated until the absolute difference between subsequent guesses for the root abs(dx)<=eps.
        ! *       Default value, if parameter is not present: 1.d-08
        ! *     - offset_in (optional): if this parameter is present, the root is only searched for in the right neighborhood of minx_in
        ! *     - p2, p3, p4, p5 (optional): optional parameters for the function f and its derivative df
        ! *
        ! * Return value: the x* for which f(x*,...)-offset_in=0.
        ! **
        real(dp) function root(f,df,xguess,minx_in,max_iter_in,eps_in, offset_in,p2,p3,p4,p5)
            procedure(real(dp))                           :: f,df
            real(dp), intent(in)                          :: xguess
            real(dp), intent(in), optional                :: p2,p3,p4,p5
            real(dp), intent(in), optional                :: eps_in, minx_in, offset_in
            integer, intent(in), optional                 :: max_iter_in

            integer                                       :: i, max_iter
            real(dp)                                      :: x,xn,dx,val,eps,minx,offset

            eps = 1.d-08
            minx = -10.d14
            max_iter = 400
            offset = 0.0_dp
            if (present(eps_in)) eps = eps_in
            if (present(minx_in)) minx = minx_in
            if (present(max_iter_in)) max_iter = max_iter_in
            if (present(offset_in)) offset = offset_in

            x=xguess
            do i=1, max_iter
                val = f(x,p2,p3,p4,p5)-offset
                dx = val/df(x,p2,p3,p4,p5)
                xn = x - dx
                if (xn <= minx) xn=minx+0.000000000001_dp
    !            if (abs(dx) <= eps .AND. xn > minx) then
                if (abs(dx) <= eps*(1+abs(xn)) .AND. abs(val)<=eps) then
                    root = xn
                    return
                end if
                x = xn
            end do
            print *, "Could not find root of equation within ",max_iter," iterations."
            print *, "This usually happens when the optimal continuous choice is almost 0, often indicating a problem with the model."
            stop
        end function root
end module newton


module signals

use, intrinsic:: iso_c_binding, only: c_int
use comm, only: sp, dp, J

implicit none (type, external)
private
public :: signoise

interface randn
procedure randn_r, randn_c
end interface randn

interface signoise
procedure signoise_r, signoise_c
end interface signoise

real(dp) :: pi = 4._dp * atan(1._dp)
real(sp) :: pi_sp = 4._sp * atan(1._sp)

contains

subroutine signoise_c(fs,f0,snr,Ns,x) bind(c)
! generate noisy tone

real(dp),intent(in) :: fs,f0,snr
integer(c_int), intent(in) :: Ns
complex(dp),intent(out) :: x(Ns)

real(dp) :: t(Ns),nvar
complex(dp) :: noise(Ns)
integer :: i

t = [(i, i=0,size(x)-1)] / fs
x = sqrt(2._dp) * exp(J * 2._dp * pi * f0 * t)
!--- add noise
call randn(noise)

nvar = 10._dp**(-snr/10._dp)

x = x + sqrt(nvar)*noise

end subroutine signoise_c

subroutine signoise_r(fs,f0,snr,Ns,x) bind(c)
! generate noisy tone

real(sp),intent(in) :: fs,f0,snr
integer(c_int), intent(in) :: Ns
real(sp),intent(out) :: x(Ns)

real(sp) :: t(Ns),nvar
real(sp) :: noise(Ns)
integer(c_int) :: i

t = [(i, i=0, size(x)-1)] / fs
x = sqrt(2._sp) * cos(2._sp * pi_sp * f0 * t)

!--- add noise
call randn(noise)

nvar = 10._sp**(-snr / 10._sp)

x = x + sqrt(nvar) * noise

end subroutine signoise_r

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

impure elemental subroutine randn_c(noise)
! implements Box-Muller Transform
! https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform
!
! Input:
! N: length of 1-D noise vector
! Output:
! noise: Gaussian 1-D noise vector

complex(dp), intent(out) :: noise
real(dp) :: u1, u2, x_i, x_r

call random_number(u1)
call random_number(u2)

x_r = sqrt(-2._dp * log(u1)) * cos(2._dp * pi * u2)
x_i = sqrt(-2._dp * log(u1)) * sin(2._dp * pi * u2)

noise = cmplx(x_r, x_i, dp)  !complex() can only handle scalars

end subroutine randn_c

impure elemental subroutine randn_r(noise)
! implements Box-Muller Transform
! https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform
!
! Input:
! N: length of 1-D noise vector
! Output:
! noise: Gaussian 1-D noise vector

real(sp), intent(out) :: noise
real(sp) :: u1, u2

call random_number(u1)
call random_number(u2)

noise = sqrt(-2._sp * log(u1)) * cos(2._sp * pi_sp * u2)

end subroutine randn_r

end module signals


! A fortran f90 code to test mlfv_mod (Mittag-Leffler f90 implementation)
!
!
! Created by Davide Verotta on 3/12/10.
! Copyright 2010 UCSF. All rights reserved.
!
! Completely modified by Eduardo Mendes (with the permission of Davide Verotta) on 5/12/15
!    to fix bugs, to deal with complex numbers and to include the derivative
!    of the Mittag-Leffler function
!
! Examples: I have tried to reproduce Figres 5 to 15 of the paper Computation of the Mittag-Leffler
!           function and its derivatives. Fract. Calc. Appl. Anal. 5(2002), 491-518
!           by R.Gorenflo, J.Loutchko, and Yu. Luchko
!
! Obs.:  The derivative shown here is not the time derivative shown on the paper but the derivative
!        shown on Section 4 of the aforementioned paper.
!
!        Please nota that the way the Mittag-Leffler function is called.
!        In case where z is not complex, use real to get the real part of the result.

program test_mlfv

use mlfv_mod

implicit none

integer, parameter :: npoints = 4

real(8) :: alpha,beta,y,x
real(8), dimension(npoints+1) :: t
complex(8) :: z,aux
integer :: fi
integer ::  i
character(len=3) :: imag_unity = '+i*'
character(len=3) :: imag_unitz = '+i*'
real(8), parameter :: pi = 3.1415926535897932384626434D0

fi=8

! Figure 5

alpha=0.25d0
beta=1.0d0

print *,' '
print *,'********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a20)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta," E_{alpha,beta}(-t)"
print *,' '
print *,'Figure 5 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'********************************************************************************************************'
print *, ' '

print*,"---------------------------------------------------------------------------------------------------"
print*, " t                   alpha               beta                y                   Derivative of E "
print*,"---------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(10d0-0d0)/dble(npoints)) ! 10
     z=dcmplx(-t(i),0)
     y=real(mlfv(alpha,beta,z,fi))
     x=real(mlfvderiv(alpha,beta,z,fi))
     write(*,"(5E20.12)") t(i),alpha,beta,y,x
end do

print *,' '

! Figure 6

alpha=1.75d0
beta=1.0d0

print *,' '
print *,'********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a20)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta," E_{alpha,beta}(-t)"
print *,' '
print *,'Figure 6 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'********************************************************************************************************'
print *, ' '

print*,"---------------------------------------------------------------------------------------------------"
print*, " t                   alpha               beta                y                   Derivative of E "
print*,"---------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(50d0-0d0)/dble(npoints)) ! 50
     z=dcmplx(-t(i),0)
     y=real(mlfv(alpha,beta,z,fi))
     x=real(mlfvderiv(alpha,beta,z,fi))
     write(*,"(5E20.12)") t(i),alpha,beta,y,x
end do

print *,' '

! Figure 7

alpha=2.25d0
beta=1.0d0

print *,' '
print *,'********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a20)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta," E_{alpha,beta}(-t)"
print *,' '
print *,'Figure 7 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'********************************************************************************************************'
print *, ' '

print*,"---------------------------------------------------------------------------------------------------"
print*, " t                   alpha               beta                y                   Derivative of E "
print*,"---------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(100d0-0d0)/dble(npoints)) ! 100
     z=dcmplx(-t(i),0)
     y=real(mlfv(alpha,beta,z,fi))
     x=real(mlfvderiv(alpha,beta,z,fi))
     write(*,"(5E20.12)") t(i),alpha,beta,y,x
end do

print *,' '

!  Figure 8

alpha=0.75d0
beta=1.0d0

print *,'********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a20)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = alpha*pi/4"
print *,' '
print *,'Figure 8 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  abs(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(5d0-0d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*alpha*pi/4d0)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),abs(aux)
end do

print *,' '

!  Figure 9

alpha=0.75d0
beta=1.0d0

print *,'********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a20)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = alpha*pi/2"
print *,' '
print *,'Figure 9 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  abs(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(50d0-0d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*alpha*pi/2d0)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),abs(aux)
end do

print *,' '

!  Figure 10

alpha=0.75d0
beta=1.0d0

print *,'**********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a22)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = alpha*3*pi/4"
print *,' '
print *,'Figure 10 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'**********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  abs(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(50d0-0d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*alpha*3d0*pi/4d0)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),abs(aux)
end do

print *,' '

!  Figure 11

alpha=0.75d0
beta=1.0d0

print *,'**********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a22)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = pi"
print *,' '
print *,'Figure 11 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'**********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  real(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(100d0-0d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*pi)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),real(aux)
end do

print *,' '

!  Figure 12

alpha=1.25d0
beta=1.0d0

print *,'********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a20)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = alpha*pi/4"
print *,' '
print *,'Figure 12 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  abs(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(5d0-0d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*alpha*pi/4d0)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),abs(aux)
end do

print *,' '

!  Figure 13

alpha=1.25d0
beta=1.0d0

print *,'********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a20)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = alpha*pi/2"
print *,' '
print *,'Figure 13 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  abs(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(50d0-0d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*alpha*pi/2d0)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),abs(aux)
end do

print *,' '

!  Figure 14

alpha=1.25d0
beta=1.0d0

print *,'**********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a22)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = alpha*3*pi/4"
print *,' '
print *,'Figure 14 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'**********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  abs(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(50d0-0d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*alpha*3d0*pi/4d0)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),abs(aux)
end do

print *,' '

!  Figure 15

alpha=1.25d0
beta=1.0d0

print *,'**********************************************************************************************************'
write(*,"(a36,f4.2,a9,f4.2,a22)") " Mittag-Leffer function for alpha = ",alpha,", beta = ", beta,"arg(z) = pi"
print *,' '
print *,'Figure 15 of the paper Fract. Calc. Appl. Anal. 5(2002), 491-518 by R.Gorenflo, J.Loutchko and Yu. Luchko'
print *,'**********************************************************************************************************'
print *, ' '

print*,"-----------------------------------------------------------------------------------------------------------------------"
print*, " t                  z               alpha   beta                y                  real(y) "
print*,"-----------------------------------------------------------------------------------------------------------------------"

do i=1,(npoints+1)
     t(i)=(dble(i-1)*(100d0)/dble(npoints))
     z=dcmplx(t(i),0)*exp(dcmplx(0,1)*pi)
     if (aimag(z)<0.) then
       imag_unitz = '-i*'
     else
       imag_unitz = '+i*'
     end if
     aux=mlfv(alpha,beta,z,fi)
     if (aimag(aux)<0.) then
       imag_unity = '-i*'
     else
       imag_unity = '+i*'
     end if
!     write(*,"(4E20.12)") t(i),alpha,beta,y
     write(*,"(f6.2,3x,e11.5,a3,e11.5,3x,f4.2,4x,f4.2,3x,e11.5,a3,e11.5,4x,e11.5)") t(i),real(z),&
                         &imag_unitz,abs(aimag(z)),alpha,beta,real(aux),imag_unity,abs(aimag(aux)),real(aux)
end do

print *,' '

end program test_mlfv


! Created by EverLookNeverSee@GitHub on 6/7/20
! For more information see FCS/img/Exercise_09_a.png

program main
    implicit none
    ! declaring and initializing variables
    integer :: i, n
    real :: norm, tmp, sum_of_elements = 0.0
    real, allocatable, dimension(:) :: A
    print *, "please enter number of elements in the vector:"
    read *, n
    allocate(A(n))
    read *, A
    ! sum of all squared elements in the vector
    do i = 1, n
        tmp = (abs(A(i))) ** 2
        sum_of_elements = sum_of_elements + tmp
    end do
    ! square root of sum
    norm = sqrt(sum_of_elements)
    ! printing results
    print *, "norm=", norm
end program main


!>
module MathConstants
    use PrecisionMod, only: MK, SP
    implicit none
    real(MK), parameter :: eps           = 2.220446049250313e-16_MK
    ! Pi related
    real(MK), parameter :: pi            = 3.141592653589793238462643383279502884197169399375105820974944_MK
    real(MK), parameter :: pi_half       = 1.570796326794896619231321691639751442098584699687552910487472_MK
    real(MK), parameter :: twopi         = 6.283185307179586476925286766559005768394338798750211641949889_MK
    real(MK), parameter :: fourpi        = 12.56637061435917295385057353311801153678867759750042328389977_MK
    real(MK), parameter :: twopi_inv     = 0.159154943091895335768883763372514362034459645740456448747667_MK
    real(MK), parameter :: fourpi_inv    = 0.079577471545947667884441881686257181017229822870228224373833_MK
    real(MK), parameter :: four_third_pi = 4.188790204786390984616857844372670512262892532500141094633259_MK
    real(MK), parameter :: rad2deg       = 57.29577951308232087679815481410517033240547246656432154916024_MK
    real(MK), parameter :: deg2rad       = 0.017453292519943295769236907684886127134428718885417254560971_MK
    ! NaN
    integer, parameter  :: NaN=-999999
    real(MK), parameter :: rNaN=-999999._MK
    real(SP), parameter :: NaN_SP=-999999._SP

    interface is_nan
        module procedure iis_nan, ris_nan
    end interface
contains
    logical function iis_nan(x)
        integer,intent(in) ::x
        iis_nan=(x==-NaN)
    end function

    logical function ris_nan(x)
        use PrecisionMod, only:PRECISION_EPS
        real(MK),intent(in) ::x
        ris_nan=abs(x-rNaN)<PRECISION_EPS
    end function

end module MathConstants


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     1/976
!
!     a program for testing all vector laplacian and its inverse
!
!     (1) first set the vector function (rotation about equator) using
!         v = cos(phi) and w = -cos(theta)*sin(phi)
!
!     (2) set vector laplacian ananlytically
!         vlap = -2.*cos(phi)=-2.*v, wlap = -2.*w
!         (i.e., L(v, w) = -2.*(v, w) so (v, w) is an eigenfunction for the
!         vector Laplacian with eigenvalue -2.
!
!     (3) compute the coefficients br, bi, cr, ci of (v, w) using vector analysis
!
!     (3) compute the vector laplacian of (v, w) using vlapec, vlapes, vlapgc, vlapgs
!
!     (4) compare (3) with (2)
!
!     (5) invert (4) and compare with (v, w)
!
program tvlap

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: err2v
    real(wp) :: err2w
    integer(ip) :: i
    integer(ip) :: solver_case

    integer(ip) :: error_flag
    integer(ip) :: j
    integer(ip) :: k

    real(wp) :: phi

    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta

    ! Set dimensions with parameter statements
    integer(ip), parameter :: nlat = 29, nlon = 16, nt = 1
    integer(ip), parameter :: mdbc = min(nlat, nlon/2)
    integer(ip), parameter :: isym = 0, ityp = 0
    real(wp), allocatable  :: wavetable(:)
    real(wp), dimension(mdbc, nlat, nt) :: br, bi, cr, ci
    real(wp), dimension(nlat)           :: gaussian_latitudes, gaussian_weights
    real(wp), dimension(nlat, nlon, nt) :: v, w, ve, we, vlap, wlap, vlape, wlape
    real(wp), parameter                 :: ZERO = 0.0_wp, TWO = 2.0_wp

    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")

    ! Set equally spaced colatitude and longitude increments
    dphi = TWO_PI/nlon
    dlat = PI/(nlat-1)

    call compute_gaussian_latitudes_and_weights(nlat, &
        gaussian_latitudes, gaussian_weights, error_flag)

    call name("compute_gaussian_latitudes_and_weights")
    call iout(error_flag, " error_flag")
    call vecout(gaussian_latitudes, "gaussian_latitudes", nlat)
    !
    !     test all divergence and inverse divergence subroutines
    !
    do solver_case=1, 4
        call name("****")
        call name("****")
        call iout(solver_case, "icas")

        ! Set vector field v, w
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (solver_case)
                        case (0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    if (k==1) then
                        v(i, j, k) = cosp
                        w(i, j, k) = -cost*sinp
                        vlape(i, j, k) = -TWO * v(i, j, k)
                        wlape(i, j, k) = -TWO * w(i, j, k)
                    end if
                end do
            end do
        end do

        ! Store exact solution
        ve = v
        we = w

        select case (solver_case)
            case (1)

                call name("**ec")
                !
                !     analyze vector field
                !
                call initialize_vhaec(nlat, nlon, wavetable, error_flag)
                call name("vhai")
                call iout(error_flag, "error_flag = ")

                call vhaec(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vha ")
                call iout(error_flag, "error_flag = ")

                !     compute vector laplacian
                call initialize_vhsec(nlat, nlon, wavetable, error_flag)
                call name("vhsi")
                call iout(error_flag, "error_flag = ")

                call vlapec(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlap")
                call iout(error_flag, "error_flag = ")

            case (2)

                call name("**es")
                !
                !     analyze vector field
                !
                call initialize_vhaes(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhaes")
                call iout(error_flag, "error_flag = ")

                call vhaes(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vhaes")
                call iout(error_flag, "error_flag = ")

                call initialize_vhses(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhses")
                call iout(error_flag, "error_flag = ")

                call vlapes(nlat, nlon, isym, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlapes")
                call iout(error_flag, "error_flag = ")

            case (3)

                call name("**gc")
                !
                !     analyze vector field
                !
                call initialize_vhagc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhagc")
                call iout(error_flag, "error_flag = ")

                call vhagc(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vhagc")
                call iout(error_flag, "error_flag = ")

                !     compute vector laplacian
                !

                call initialize_vhsgc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgc")
                call iout(error_flag, "error_flag = ")

                call vlapgc(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlapgc")
                call iout(error_flag, "error_flag = ")

            case (4)

                call name("**gs")
                !
                !     analyze vector field
                !
                call initialize_vhags(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhags")
                call iout(error_flag, "error_flag = ")

                call vhags(nlat, nlon, ityp, nt, v, w, nlat, nlon, br, bi, cr, ci, mdbc, &
                    nlat, wavetable, error_flag)
                call name("vhags")
                call iout(error_flag, "error_flag = ")

                !     compute vector laplacian
                call initialize_vhsgs(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgs")
                call iout(error_flag, "error_flag = ")

                call vlapgs(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vlapgs")
                call iout(error_flag, "error_flag = ")

        end select

        ! Set and print least squares discretization error in vlap, wlap
        err2v = norm2(vlape - vlap)
        err2w = norm2(wlape - wlap)
        call vout(err2v, "errv")
        call vout(err2w, "errw")

        ! Now recompute (v, w) inverting (vlap, wlap) ivlap codes
        v = ZERO
        w = ZERO

        select case (solver_case)
            case (1)
                call name("analyze vector field (vlap, wlap)")
                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhaec(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhaec")
                call iout(error_flag, "error_flag = ")

                call vhaec(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhaec ")
                call iout(error_flag, "error_flag = ")

                call initialize_vhsec(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsec")
                call iout(error_flag, "error_flag = ")

                call ivlapec(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapec")
                call iout(error_flag, "error_flag = ")

            case (2)

                call name("analyze vector field (vlap, wlap)")
                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhaes(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhaes")
                call iout(error_flag, "error_flag = ")

                call vhaes(nlat, nlon, isym, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhaes")
                call iout(error_flag, "error_flag = ")

                call initialize_vhses(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhses")
                call iout(error_flag, "error_flag = ")

                call ivlapes(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapes")
                call iout(error_flag, "error_flag = ")

            case (3)

                call name("analyze vector field (vlap, wlap)")

                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhagc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhagc")
                call iout(error_flag, "error_flag = ")

                call vhagc(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhagc")
                call iout(error_flag, "error_flag = ")

                call initialize_vhsgc(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgc")
                call iout(error_flag, "error_flag = ")

                call ivlapgc(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapgc")
                call iout(error_flag, "error_flag = ")

            case default

                call name("analyze vector field (vlap, wlap)")

                !
                !     analyze vector field (vlap, wlap)
                !
                call initialize_vhags(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhags")
                call iout(error_flag, "error_flag = ")

                call vhags(nlat, nlon, ityp, nt, vlap, wlap, nlat, nlon, &
                    br, bi, cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("vhags")
                call iout(error_flag, "error_flag = ")

                call initialize_vhsgs(nlat, nlon, wavetable, error_flag)
                call name("initialize_vhsgs")
                call iout(error_flag, "error_flag = ")

                call ivlapgs(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, &
                    cr, ci, mdbc, nlat, wavetable, error_flag)
                call name("ivlapgs")
                call iout(error_flag, "error_flag = ")

        end select

        ! Compare this v, w with original
        err2v = norm2(ve - v)
        err2w = norm2(we - w)
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    end do

    ! Release memory
    deallocate (wavetable)

end program tvlap


       function det_2(T)
        implicit none

        type(Tensor2) :: T
        real(kind=8) :: det_2

        det_2 = T%ab(1,1)*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2))
     *        + T%ab(1,2)*(T%ab(2,3)*T%ab(3,1)-T%ab(2,1)*T%ab(3,3))
     *        + T%ab(1,3)*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1))

       end function det_2

       function det_2s(T)
        ! strain
        implicit none

        type(Tensor2s), intent(in) :: T
        !integer, intent(in), optional :: w
        real(kind=8) :: det_2s!, v

        !v = 1.0

        det_2s = T%a6(1)*T%a6(2)*T%a6(3)
     *         + T%a6(4)*T%a6(5)*T%a6(6)! /v**3
     *         + T%a6(6)*T%a6(4)*T%a6(5)! /v**3
     *         - T%a6(6)*T%a6(2)*T%a6(6)! /v**3
     *         - T%a6(5)*T%a6(5)*T%a6(1)! /v**3
     *         - T%a6(3)*T%a6(4)*T%a6(4)! /v**3

       end function det_2s


MODULE ProblemBank
IMPLICIT NONE

CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!	This is the where MOPs are defined
SUBROUTINE MOP1_circles(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	fit(1) = indv(1)**2 + indv(2)**2
	fit(2) = (indv(1)-2.0)**2 + (indv(2)-2.0)**2
	viol = 0
END SUBROUTINE MOP1_circles

SUBROUTINE MOP2_Fonseca(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	fit(1) = 1-EXP(-((indv(1)- 1.0/(3.0)**0.5)**2.0 + &
					(indv(2) - 1.0/(3.0)**0.5)**2.0 + &
					(indv(3) - 1.0/(3.0)**0.5)**2.0));
	fit(2) = 1-EXP(-((indv(1)+ 1.0/(3.0)**0.5)**2.0 + &
					(indv(2) + 1.0/(3.0)**0.5)**2.0 + &
					(indv(3) + 1.0/(3.0)**0.5)**2.0));
	viol = 0
END SUBROUTINE MOP2_Fonseca

SUBROUTINE MOP3_Poloni(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: 	A1 = 0.873648562314064, &	!= 0.5*sin(1)-2*cos(1)+sin(2)-1.5*cos(2)
			A2 = 2.748572443268639, &	!=1.5*sin(1)-cos(1)+2*sin(2)-.5*cos(2)
			x, y ,B1, B2

	x = indv(1)
	y = indv(2)
	B1 = 0.5*SIN(x) - 2.0*COS(x) + SIN(y) - 1.5*COS(y)
	B2 = 1.5*SIN(x) - COS(x) + 2.0*SIN(y) - 0.5*COS(y)

	fit(1) = (1 + (A1-B1)**2 + (A2-B2)**2)
	fit(2) = ((x+3)**2 + (y+1)**2)

	viol = 0
END SUBROUTINE MOP3_Poloni

SUBROUTINE MOP4_Kursawe(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL::a, b, x1, x2, x3

	a = 0.8
	b = 3.0
	x1 = indv(1)
	x2 = indv(2)
	x3 = indv(3)

	fit(1) = -10 * (exp(-0.2 * SQRT(x1**2.0 + x2**2.0)) &
    			  + exp(-0.2 * SQRT(x2**2.0 + x3**2.0)))
	fit(2) =(ABS(x1))**a + 5.0*SIN(x1**b) + &
    		(ABS(x2))**a + 5.0*SIN(x2**b) + &
    		(ABS(x3))**a + 5.0*SIN(x3**b)

	viol = 0
END SUBROUTINE MOP4_Kursawe

SUBROUTINE MOP5_Viennet(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: x, y, temp

	y = indv(2)
	x = indv(1)
	temp = x**2+y**2

	fit(1) = 0.5 * temp + SIN(temp)
	fit(2) = (3.0*x-2.0*y+4.0)**2.0/8.0 + &
			 (x-y+1.0)**2.0/27.0 + 15.0
	fit(3) = 1.0 / (temp+1.0) - 1.1*EXP(-temp)

	viol = 0
END SUBROUTINE MOP5_Viennet

SUBROUTINE ZDT3_10D(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: r
	INTEGER::dims = 10, i
	REAL, PARAMETER:: pi = 3.141592653589793

	fit(1) = indv(1)

	r = 0.0

	DO i = 2, dims
		r = r + indv(i)
	END DO

	fit(2) = (1.0+9.0*r/(dims-1)) * &
			(1-SQRT(indv(1)/(1.0+9.0*r/(dims-1))) - &
			(indv(1)/(1.0+9.0*r/(dims-1)))*SIN(10.0*pi*indv(1)));

	viol = 0
END SUBROUTINE ZDT3_10D

SUBROUTINE MOP_C4_Tanaka(fit, indv, viol, NF, NP)
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, NP
	REAL, INTENT(IN):: indv(NP)
	REAL, INTENT(OUT):: fit(NF)
	INTEGER, INTENT(OUT)::viol

	REAL:: a, b

	a = 0.1
	b = 16.0

	fit(1) = indv(1)
	fit(2) = indv(2)

	viol = 0
	IF (- indv(1)**2.0 - indv(2)**2.0 + 1.0 + &
		a * COS(b*ATAN(indv(1)/indv(2)))>0.0) viol = 1
END SUBROUTINE 	MOP_C4_Tanaka

END MODULE ProblemBank


      PROGRAM xqrdcmp
C     driver for routine qrdcmp
      INTEGER NP
      PARAMETER(NP=20)
      INTEGER i,j,k,l,m,n
      REAL con,a(NP,NP),c(NP),d(NP),q(NP,NP),qt(NP,NP),r(NP,NP),
     *     x(NP,NP)
      CHARACTER txt*3
      LOGICAL sing
      open(7,file='MATRX1.DAT',status='old')
      read(7,*)
10    read(7,*)
      read(7,*) n,m
      read(7,*)
      read(7,*) ((a(k,l), l=1,n), k=1,n)
      read(7,*)
      read(7,*) ((x(k,l), k=1,n), l=1,m)
C     print out a-matrix for comparison with product of Q and R
C     decomposition matrices.
      write(*,*) 'Original matrix:'
      do 11 k=1,n
        write(*,'(1x,6f12.6)') (a(k,l), l=1,n)
11    continue
C     perform the decomposition
      call qrdcmp(a,n,NP,c,d,sing)
      if (sing) write(*,*) 'Singularity in QR decomposition.'
C     find the Q and R matrices
      do 13 k=1,n
        do 12 l=1,n
          if (l.gt.k) then
            r(k,l)=a(k,l)
            q(k,l)=0.0
          else if (l.lt.k) then
            r(k,l)=0.0
            q(k,l)=0.0
          else
            r(k,l)=d(k)
            q(k,l)=1.0
          endif
12      continue
13    continue
      do 21 i=n-1,1,-1
        con=0.0
        do 14 k=i,n
          con=con+a(k,i)**2
14      continue
        con=con/2.0
        do 17 k=i,n
          do 16 l=i,n
            qt(k,l)=0.0
            do 15 j=i,n
              qt(k,l)=qt(k,l)+q(j,l)*a(k,i)*a(j,i)/con
15          continue
16        continue
17      continue
        do 19 k=i,n
          do 18 l=i,n
            q(k,l)=q(k,l)-qt(k,l)
18        continue
19      continue
21    continue
C     compute product of Q and R matrices for comparison with original matrix.
      do 24 k=1,n
        do 23 l=1,n
          x(k,l)=0.0
          do 22 j=1,n
            x(k,l)=x(k,l)+q(k,j)*r(j,l)
22        continue
23      continue
24    continue
      write(*,*) 'Product of Q and R matrices:'
      do 25 k=1,n
        write(*,'(1x,6f12.6)') (x(k,l), l=1,n)
25    continue
      write(*,*) 'Q matrix of the decomposition:'
      do 26 k=1,n
        write(*,'(1x,6f12.6)') (q(k,l), l=1,n)
26    continue
      write(*,*) 'R matrix of the decomposition:'
      do 27 k=1,n
        write(*,'(1x,6f12.6)') (r(k,l), l=1,n)
27    continue
      write(*,*) '***********************************'
      write(*,*) 'Press RETURN for next problem:'
      read(*,*)
      read(7,'(a3)') txt
      if (txt.ne.'END') goto 10
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xqrdcmp.for


integer function PlmIndex(l,m)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will return the index corresponding
!	to a given l and m in the arrays of Legendre Polynomials
!	generated by routines such as PlmBar and PlmSchmidt.
!
!	Calling Parameters:
!		l	Spherical harmonic angular degree.
!		m	Spherical harmonic angular order.
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek (May 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in)	:: l, m

	if (l < 0) then
		print*, "Error --- PlmIndex"
		print*, "L must be greater of equal to 0."
		print*, "L = ", l
		print*, "M = ", m
		stop
	elseif (m < 0 .or.  m > l) then
		print*, "Error --- PlmIndex"
		print*, "M must be greater than or equal to zero and less than or equal to L."
		print*, "L = ", l
		print*, "M = ", m
		stop
	endif

	PlmIndex = l*(l+1)/2+m+1

end function PlmIndex


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Exponentiation (** operator) to real, double, or complex powers.

	program p
	implicit complex (c), real*8 (d)

	integer rslts(18), expect(18)

	integer ctoi
	ctoi(c) = real(c) + aimag(c)

	data x2 / 2.0/, d2 / 2.0d0/, i2 / 2 /
	data c2, c23, c11, c12/ (2, 0), (2, 3), (1, 1), (1, 2) /

c --- tests 1 - 6:  exponentiation to real power:

	rslts(1) = 2.1 ** 2.0
	rslts(2) = 2.1 ** x2
	rslts(3) = (3 ** x2) * 100.001
	rslts(4) = (i2 + 1) ** 3.01
	rslts(5) = i2 ** (x2 + 1) + .01
	rslts(6) = x2 ** 0.0 * 100

c --- tests 7 - 12: exponentiation to double prec. power:

	rslts(7) = 2.1d0 ** 2.0d0
	rslts(8) = 2.1d0 ** x2
	rslts(9) = (3 ** d2) * 100.001
	rslts(10) = (x2 + 1) ** 3.01d0
	rslts(11) = i2 ** (d2 + 1) + .01
	rslts(12) = d2 ** 0.0 * 100

c --- tests 13 - 18:  exponentiation to complex power:

	rslts(13) = ctoi( (2.1, 0.0) ** (2.0, 0.0) )
	rslts(14) = ctoi( (2.1, 0.0) ** c2)
	rslts(15) = ctoi( c23 ** x2 + .001 )
	rslts(16) = c23 ** c11 + 10
	rslts(17) = ctoi( 10 ** c12 )
	rslts(18) = ctoi(x2 ** (-1.0, 2.0) * 10)

c --- check results:

	call check(rslts, expect, 18)

	data expect / 4, 4, 900, 27, 8, 100,
     +                4, 4, 900, 27, 8, 100,
     +                4, 4, 7, 9, -11, 5      /

	end