    subroutine my_func(x, y)
        implicit none
        complex(kind=kind(0d0)), dimension(3), intent(in) :: x
        complex(kind=kind(0d0)), dimension(2), intent(out) :: y

        integer :: j
        do j = 1, 2
            y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2))
        end do
    end subroutine my_func

    subroutine my_func_jac(x_value, y_value, dy_dx)
        use adjac
        implicit none
        complex(kind=kind(0d0)), dimension(3), intent(in) :: x_value
        complex(kind=kind(0d0)), dimension(2), intent(out) :: y_value
        complex(kind=kind(0d0)), dimension(2,3), intent(out) :: dy_dx

        type(adjac_complexan), dimension(3) :: x
        type(adjac_complexan), dimension(2) :: y
        integer :: j

        call adjac_reset()
        call adjac_set_independent(x, x_value)

        do j = 1, 2
            y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2))
        end do

        call adjac_get_value(y, y_value)
        call adjac_get_dense_jacobian(y, dy_dx)
        call adjac_free()
    end subroutine my_func_jac

program simple
  implicit none
  double precision, parameter :: dx = 1e-7

  complex(kind=kind(0d0)), dimension(3) :: x, x2
  complex(kind=kind(0d0)), dimension(2) :: y, y2
  complex(kind=kind(0d0)), dimension(2,3) :: dy_dx

  integer :: i

  do i = 1, 3
     x(i) = i + (0d0,1d0) * i**2
  end do

  ! Evaluate function values
  call my_func(x, y)
  write(*,*) '-- my_func:'
  write(*,*) y

  ! Find jacobian by numerical differentiation
  dy_dx = 0
  do i = 1, 3
     x2 = x
     x2(i) = x(i) + dx
     call my_func(x2, y2)
     dy_dx(:,i) = (y2 - y) / dx
  end do

  write(*,*) '-- Jacobian via numerical differentiation:'
  do i = 1, 2
     write(*,*) cmplx(dy_dx(i,:))
  end do

  ! Get the same results via adjac
  dy_dx = 0
  call my_func_jac(x, y, dy_dx)
  write(*,*) '-- my_func_jac value:'
  write(*,*) y
  write(*,*) '-- my_func_jac Jacobian:'
  do i = 1, 2
     write(*,*) cmplx(dy_dx(i,:))
  end do

end program simple


 FUNCTION IDAY(YYYY, MM, DD) RESULT(IVAL)
!====IDAY IS A COMPANION TO CALEND; GIVEN A CALENDAR DATE, YYYY, MM,
!           DD, IDAY IS RETURNED AS THE DAY OF THE YEAR.
!           EXAMPLE: IDAY(1984, 4, 22) = 113

 INTEGER, INTENT(IN) :: YYYY, MM, DD
 INTEGER             :: IVAL

 IVAL = 3055*(MM+2)/100 - (MM+10)/13*2 -91 +  &
       (1-(MODULO(YYYY, 4)+3)/4              &
        + (MODULO(YYYY, 100) + 99)/100 -        &
       (MODULO(YYYY, 400)+399)/400)*(MM+10)/13 + DD

 RETURN
 END FUNCTION IDAY

FUNCTION JD_OUT(YYYY, MM, DD) RESULT(IVAL)
  INTEGER, INTENT(IN)  :: YYYY
  INTEGER, INTENT(IN)  :: MM
  INTEGER, INTENT(IN)  :: DD
  INTEGER*8            :: IVAL
!              DATE ROUTINE JD(YYYY, MM, DD) CONVERTS CALENDER DATE TO
!              JULIAN DATE.  SEE CACM 1968 11(10):657, LETTER TO THE
!              EDITOR BY HENRY F. FLIEGEL AND THOMAS C. VAN FLANDERN.
!    EXAMPLE JD(1970, 1, 1) = 2440588
  IVAL = DD - 32075 + 1461*(YYYY+4800+(MM-14)/12)/4 +  &
        367*(MM-2-((MM-14)/12)*12)/12 - 3*((YYYY+4900+(MM-14)/12)/100)/4
  RETURN
 END FUNCTION JD_OUT

 SUBROUTINE CDATE(JD,YYYY,MM,DD)
!====GIVEN A JULIAN DAY NUMBER, NNNNNNNN, YYYY,MM,DD ARE RETURNED AS THE
!         CALENDAR DATE. JD = NNNNNNNN IS THE JULIAN DATE FROM AN EPOCH
!         IN THE VERY DISTANT PAST.  SEE CACM 1968 11(10):657,
!         LETTER TO THE EDITOR BY FLIEGEL AND VAN FLANDERN.
!    EXAMPLE CALL CDATE(2440588, YYYY, MM, DD) RETURNS 1970 1 1 .

 INTEGER,INTENT(IN)  ::  JD
 INTEGER,INTENT(OUT) ::  YYYY,MM,DD
 INTEGER L

 L = JD + 68569
 N = 4*L/146097
 L = L - (146097*N + 3)/4
 YYYY = 4000*(L+1)/1461001
 L = L - 1461*YYYY/4 + 31
 MM = 80*L/2447
 DD = L - 2447*MM/80
 L = MM/11
 MM = MM + 2 - 12*L
 YYYY = 100*(N-49) + YYYY + L
 RETURN
 END SUBROUTINE CDATE

      FUNCTION REF_ATT (R_TIME, R_DATE)
!
!=======================================================================
!                                                                      !
!  This function encodes the relative time attribute that gives the    !
!  elapsed interval since a specified reference time.  The "units"     !
!  attribute takes the form "time-unit since reference-time".          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     r_time     Time-reference (real; %Y%m%d.%f, for example,         !
!                  20020115.5 for 15 Jan 2002, 12:0:0).                !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     ref_att    Time-reference for "units" attribute (string).        !
!     r_date     Calendar date vector (real):                          !
!                  r_date(1) => reference date (yyyymmdd.f).           !
!                  r_date(2) => year.                                  !
!                  r_date(3) => year day.                              !
!                  r_date(4) => month.                                 !
!                  r_date(5) => day.                                   !
!                  r_date(6) => hour.                                  !
!                  r_date(7) => minute.                                !
!                  r_date(8) => second.                                !
!                                                                      !
!=======================================================================
!
!

!
!  Imported variable declarations.
!
      USE GLOBAL
      REAL(WP), INTENT(IN) :: R_TIME
      REAL(WP), DIMENSION(8), INTENT(OUT) :: R_DATE
      CHARACTER (LEN=19) :: REF_ATT
!
!  Local variable declarations.
!
      INTEGER(WP) :: IDAY, IHOUR, ISEC, IYEAR, LEAP, MINUTE, MONTH
      INTEGER(WP), DIMENSION(13) :: IYD =                                   &
     &         (/ 1,32,60,91,121,152,182,213,244,274,305,335,366 /)
      INTEGER(WP), DIMENSION(13) :: IYDL =                                  &
     &         (/ 1,32,61,92,122,153,183,214,245,275,306,336,367 /)
      REAL(WP) :: DAY, SEC, YDAY
      CHARACTER (LEN=19) :: TEXT
!
!-----------------------------------------------------------------------
!  Decode reference time.
!-----------------------------------------------------------------------
!
      IYEAR=MAX(1,INT(R_TIME*0.0001))
      MONTH=MIN(12,MAX(1,INT((R_TIME-REAL(IYEAR*10000))*0.01)))
      DAY=R_TIME-AINT(R_TIME*0.01)*100.0
      IDAY=INT(DAY)
      SEC=(DAY-AINT(DAY))*86400.0
      IHOUR=INT(SEC/3600.0)
      MINUTE=INT(MOD(SEC,3600.0)/60.0)
      ISEC=INT(MOD(SEC,60.0))
!
!-----------------------------------------------------------------------
!  Get year day.
!-----------------------------------------------------------------------
!
      LEAP=MOD(IYEAR,4)
      IF (LEAP.EQ.0) THEN
        YDAY=REAL(IYDL(MONTH))+REAL(IDAY)-1.0
      ELSE
        YDAY=REAL(IYD(MONTH))+REAL(IDAY)-1.0
      END IF
!
!-----------------------------------------------------------------------
!  Build output date vector.
!-----------------------------------------------------------------------
!
      R_DATE(1)=R_TIME
      R_DATE(2)=REAL(IYEAR)
      R_DATE(3)=MAX(1.0,YDAY)
      R_DATE(4)=REAL(MONTH)
      R_DATE(5)=MAX(1.0,REAL(IDAY))
      R_DATE(6)=REAL(IHOUR)
      R_DATE(7)=REAL(MINUTE)
      R_DATE(8)=REAL(ISEC)
!
!-----------------------------------------------------------------------
!  Build reference-time string.
!-----------------------------------------------------------------------
!
      WRITE (TEXT,10) IYEAR, MONTH, IDAY, IHOUR, MINUTE, ISEC
 10   FORMAT (I4,'-',I2.2,'-',I2.2,1X,I2.2,':',I2.2,':',I2.2)
      REF_ATT=TEXT
      RETURN
      END FUNCTION REF_ATT

   SUBROUTINE  CONVERSION(NUMBER, YEAR, MONTH, DAY)
   IMPLICIT  NONE

   INTEGER, INTENT(IN)  :: NUMBER
   INTEGER, INTENT(OUT) :: YEAR, MONTH, DAY

   YEAR  = NUMBER / 10000
   MONTH = MOD(NUMBER, 10000) / 100
   DAY   = MOD(NUMBER, 100)
   END SUBROUTINE  CONVERSION


! Ricker wavelet
subroutine ricker(nt,f0,dt,source)
    implicit none
    integer                      :: nt, it
    real (kind=8)                :: f0, pt, a_ricker, dt, t0,t
    real (kind=8),dimension(nt)  :: source, temp

    source = 0
    temp   = 0
    pt = 1 / f0
    t0=pt/dt
    a_ricker=4./pt

    do it=1,nt+1
        t=(it-t0)*dt
        temp(it) = -2.*a_ricker*t*exp(-(a_ricker*t)**2)
    enddo

    do it=1,nt
        source(it) = temp(it+1) - temp(it)
    end do

    source = -source

END subroutine ricker


subroutine eigenvalueprob(NDIM,A,W,WORK,workmax,A_OLD)
implicit none

!Global variables

INTEGER, INTENT(IN)      :: NDIM, workmax
REAL(kind=4), intent(out) :: WORK(workmax), W(NDIM)
REAL(kind=4), intent(inout) ::A(NDIM,NDIM),A_OLD(NDIM,NDIM)

!Local Variables
integer      :: LDA,LWORK, INFO, J, I
real(kind=4)     ::  eps
real(kind=4)     ::  slamch
CHARACTER    :: JOBZ,UPLO
REAL             ZERO
PARAMETER        ( ZERO = 0.0 )
real(kind=4)     :: cpu_sekunden, st0, ste

    external slamch
    external ssyev

    eps = slamch('e')
    print*,' relative machine precision epsilon          ',&
            ' eps      = ',eps

    JOBZ = 'V'
    UPLO = 'U'

    LDA = NDIM

    LWORK = workmax

    call cpu_time(st0)
!--------------------------------!

    CALL ssyev(JOBZ,UPLO,NDIM,A,LDA,W,WORK, LWORK, INFO)
!--------------------------------!

    print*,' LAPACK INFO = ',info

    IF( INFO.GT.0 ) THEN
        WRITE(*,*)'The calculation was unsuccessfull.'
        STOP
     END IF

    print*,' '

!-------------------------!
    PRINT*,' Eigenvalues :'
    PRINT*,' '
    DO J = 1, NDIM
          WRITE(*,*) W( J )
    END DO
    WRITE(*,*)

!-------------------------!
    WRITE(*,*) 'Eigenvectors:'
    WRITE(*,*) 'Columnwise saved'
   do i = 1, ndim
      write(*,*)(A(i,j),j=1,ndim)
   end do

    call cpu_time(ste)
    cpu_sekunden = (ste - st0)
    print*, ''
    print*,' CPU Time: ',cpu_sekunden

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

end subroutine eigenvalueprob


program test_det
use types, only: dp
use utils, only: assert
use linalg, only: det, eye
use constants, only : i_
implicit none

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

A = real(reshape([ 1, 2, 3, 4, 5, 6, 7, 8, -9 ], shape=[3,3]))
Adet = det(A)
call assert(abs(Adet - 54.0_dp) < eps)

B = 0*i_
B = A
B(1,1) = i_
! B has det(B) = 147 - 93i (SymPy)
Bdet = det(B)
call assert(abs(Bdet - (147.0_dp, -93.0_dp)) < eps)

end program


FUNCTION random_gamma(s, b, first) RESULT(fn_val)

! Adapted from Fortran 77 code from the book:
!     Dagpunar, J. 'Principles of random variate generation'
!     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

!     N.B. This version is in `double precision' and includes scaling

!     FUNCTION GENERATES A RANDOM GAMMA VARIATE.
!     CALLS EITHER random_gamma1 (S > 1.0)
!     OR random_exponential (S = 1.0)
!     OR random_gamma2 (S < 1.0).

!     S = SHAPE PARAMETER OF DISTRIBUTION (0 < REAL).
!     B = Scale parameter

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp), INTENT(IN)  :: s, b
LOGICAL, INTENT(IN)    :: first
REAL (dp)              :: fn_val

! Local parameters
REAL (dp), PARAMETER  :: one = 1.0_dp, zero = 0.0_dp

IF (s <= zero) THEN
  WRITE(*, *) 'SHAPE PARAMETER VALUE MUST BE POSITIVE'
  STOP
END IF

IF (s >= one) THEN
  fn_val = random_gamma1(s, first)
ELSE IF (s < one) THEN
  fn_val = random_gamma2(s, first)
END IF

! Now scale the random variable
fn_val = b * fn_val
RETURN

CONTAINS

FUNCTION random_gamma1(s, first) RESULT(fn_val)

! Adapted from Fortran 77 code from the book:
!     Dagpunar, J. 'Principles of random variate generation'
!     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO GAMMA**(S-1)*EXP(-GAMMA),
! BASED UPON BEST'S T DISTRIBUTION METHOD

!     S = SHAPE PARAMETER OF DISTRIBUTION
!          (1.0 < REAL)

REAL (dp), INTENT(IN)  :: s
LOGICAL, INTENT(IN)    :: first
REAL (dp)              :: fn_val

!     Local variables
REAL (dp)             :: d, r, g, f, x
REAL (dp), SAVE       :: b, h
REAL (dp), PARAMETER  :: sixty4 = 64.0_dp, three = 3.0_dp, pt75 = 0.75_dp,  &
                         two = 2.0_dp, half = 0.5_dp

IF (s <= one) THEN
  WRITE(*, *) 'IMPERMISSIBLE SHAPE PARAMETER VALUE'
  STOP
END IF

IF (first) THEN                        ! Initialization, if necessary
  b = s - one
  h = SQRT(three*s - pt75)
END IF

DO
  CALL RANDOM_NUMBER(r)
  g = r - r*r
  IF (g <= zero) CYCLE
  f = (r - half)*h/SQRT(g)
  x = b + f
  IF (x <= zero) CYCLE
  CALL RANDOM_NUMBER(r)
  d = sixty4*g*(r*g)**2
  IF (d <= zero) EXIT
  IF (d*x < x - two*f*f) EXIT
  IF (LOG(d) < two*(b*LOG(x/b) - f)) EXIT
END DO
fn_val = x

RETURN
END FUNCTION random_gamma1

FUNCTION random_gamma2(s, first) RESULT(fn_val)

! Adapted from Fortran 77 code from the book:
!     Dagpunar, J. 'Principles of random variate generation'
!     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO
! GAMMA2**(S-1) * EXP(-GAMMA2),
! USING A SWITCHING METHOD.

!    S = SHAPE PARAMETER OF DISTRIBUTION
!          (REAL < 1.0)

REAL (dp), INTENT(IN)  :: s
LOGICAL, INTENT(IN)    :: first
REAL (dp)              :: fn_val

!     Local variables
REAL (dp)             :: r, x, w
REAL (dp), SAVE       :: a, p, c, uf, vr, d
REAL (dp), PARAMETER  :: vsmall = EPSILON(one)

IF (s <= zero .OR. s >= one) THEN
  WRITE(*, *) 'SHAPE PARAMETER VALUE OUTSIDE PERMITTED RANGE'
  STOP
END IF

IF (first) THEN                        ! Initialization, if necessary
  a = one - s
  p = a/(a + s*EXP(-a))
  IF (s < vsmall) THEN
    WRITE(*, *) 'SHAPE PARAMETER VALUE TOO SMALL'
    STOP
  END IF
  c = one/s
  uf = p*(vsmall/a)**s
  vr = one - vsmall
  d = a*LOG(a)
END IF

DO
  CALL RANDOM_NUMBER(r)
  IF (r >= vr) THEN
    CYCLE
  ELSE IF (r > p) THEN
    x = a - LOG((one - r)/(one - p))
    w = a*LOG(x)-d
  ELSE IF (r > uf) THEN
    x = a*(r/p)**c
    w = x
  ELSE
    fn_val = zero
    RETURN
  END IF

  CALL RANDOM_NUMBER(r)
  IF (one-r <= w .AND. r > zero) THEN
    IF (r*(w + one) >= one) CYCLE
    IF (-LOG(r) <= w) CYCLE
  END IF
  EXIT
END DO

fn_val = x
RETURN

END FUNCTION random_gamma2

END FUNCTION random_gamma

PROGRAM demo_gamma
! Demo program to generate a small smaple of random gamma's

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp)  :: shape, scale, rg(100), avge, mean
LOGICAL    :: first
INTEGER    :: i, order(100)

INTERFACE
  FUNCTION random_gamma(s, b, first) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: s, b
    LOGICAL, INTENT(IN)    :: first
    REAL (dp)              :: fn_val
  END FUNCTION random_gamma

  RECURSIVE SUBROUTINE quick_sort(list, order)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), DIMENSION (:), INTENT(IN OUT)  :: list
    INTEGER, DIMENSION (:), INTENT(OUT)      :: order
  END SUBROUTINE quick_sort
END INTERFACE

WRITE(*, '(a)', ADVANCE='NO') ' Enter the shape & scale parameter values: '
READ(*, *) shape, scale

first = .TRUE.
DO i = 1, 100
  rg(i) = random_gamma(shape, scale, first)
  first = .FALSE.
END DO

CALL quick_sort(rg, order)
WRITE(*, '(" ", 10f7.3)') rg

mean = shape * scale
avge = SUM( rg ) / 100._dp
WRITE(*, '(a, g12.5, a, g12.5)')  &
         ' Population mean = ', mean, '  Sample mean = ', avge

STOP
END PROGRAM demo_gamma

RECURSIVE SUBROUTINE quick_sort(list, order)

! Quick sort routine from:
! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to
! Fortran 90", McGraw-Hill  ISBN 0-07-000248-7, pages 149-150.
! Modified by Alan Miller to include an associated integer array which gives
! the positions of the elements in the original order.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp), DIMENSION (:), INTENT(IN OUT)  :: list
INTEGER, DIMENSION (:), INTENT(OUT)       :: order

! Local variable
INTEGER :: i

DO i = 1, SIZE(list)
  order(i) = i
END DO

CALL quick_sort_1(1, SIZE(list))
RETURN

CONTAINS

RECURSIVE SUBROUTINE quick_sort_1(left_end, right_end)

INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
REAL (dp)           :: reference, temp
INTEGER, PARAMETER  :: max_simple_sort_size = 6

IF (right_end < left_end + max_simple_sort_size) THEN
  ! Use interchange sort for small lists
  CALL interchange_sort(left_end, right_end)

ELSE
  ! Use partition ("quick") sort
  reference = list((left_end + right_end)/2)
  i = left_end - 1
  j = right_end + 1

  DO
    ! Scan list from left end until element >= reference is found
    DO
      i = i + 1
      IF (list(i) >= reference) EXIT
    END DO
    ! Scan list from right end until element <= reference is found
    DO
      j = j - 1
      IF (list(j) <= reference) EXIT
    END DO

    IF (i < j) THEN
      ! Swap two out-of-order elements
      temp = list(i)
      list(i) = list(j)
      list(j) = temp
      itemp = order(i)
      order(i) = order(j)
      order(j) = itemp
    ELSE IF (i == j) THEN
      i = i + 1
      EXIT
    ELSE
      EXIT
    END IF
  END DO

  IF (left_end < j) CALL quick_sort_1(left_end, j)
  IF (i < right_end) CALL quick_sort_1(i, right_end)
END IF

RETURN
END SUBROUTINE quick_sort_1

SUBROUTINE interchange_sort(left_end, right_end)

INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
REAL (dp)           :: temp

DO i = left_end, right_end - 1
  DO j = i+1, right_end
    IF (list(i) > list(j)) THEN
      temp = list(i)
      list(i) = list(j)
      list(j) = temp
      itemp = order(i)
      order(i) = order(j)
      order(j) = itemp
    END IF
  END DO
END DO

RETURN
END SUBROUTINE interchange_sort

END SUBROUTINE quick_sort


!=====================================================================!
! Module containing test problems for Newton's method
!=====================================================================!

module test_problems

  implicit none

contains

  ! f = 2x^2 -5
  pure function f1(x)
    real(8), intent(in) :: x(:)
    real(8) :: f1(size(x))
    f1 = 2.0d0*x*x - 5.0d0
  end function f1

  ! dfdx = 4x
  pure function dfdx1(x)
    real(8), intent(in) :: x(:)
    real(8) :: dfdx1(size(x),size(x))
    dfdx1(1,1) = 4.0d0*x(1)
  end function dfdx1

  ! f = sin(x) + x
  pure function f2(x)
    real(8), intent(in) :: x(:)
    real(8) :: f2(size(x))
    f2 = sin(x) + x
  end function f2

  ! dfdx = cos(x) + 1
  pure function dfdx2(x)
    real(8), intent(in) :: x(:)
    real(8) :: dfdx2(size(x),size(x))
    dfdx2(1,1) = cos(x(1)) + 1.0d0
  end function dfdx2

  ! f = cos(x)
  pure function f3(x)
    real(8), intent(in) ::  x(:)
    real(8) :: f3(size(x))
    f3 = cos(x)
  end function f3

  ! dfdx = sin(x)
  pure function dfdx3(x)
    real(8), intent(in) :: x(:)
    real(8) :: dfdx3(size(x),size(x))
    dfdx3(1,1) = -sin(x(1))
  end function dfdx3

  ! Chandrasekhar H equations
  function chandra_res(x)

    real(8), intent(in) :: x(:)
    real(8)  :: chandra_res(size(x))
    integer, parameter  :: N = 200
    real(8), parameter  :: c = 0.9d0

    if ( n .ne. 200) stop "variable-mismatch"

    assemble: block

      real(8) :: mui, muj, alpha, beta
      integer :: i, j

      do i = 1, N

         mui = (dble(i) - 0.5d0)/dble(N)

         ! Find the term within integral
         alpha = 0.0d0
         do j = 1, N
            muj = (dble(j) - 0.5d0)/dble(N)
            alpha = mui*x(j)/(mui+muj)
         end do

         ! Evaluate the inverse term
         beta = 1.0d0 - c*alpha/(2.0d0*dble(N))

         ! Assmble residual
         chandra_res(i) = x(i) - 1.0d0/beta

      end do

    end block assemble

  end function chandra_res

  !===================================================================!
  ! Finite difference approximation for jacobian
  !===================================================================!

  function chandra_jac(x)

    use nonlinear_algebra, only : diffjac

    real(8), intent(in) :: x(:)
    real(8) :: chandra_jac(size(x),size(x))
    integer, parameter :: N = 200

    call diffjac(x, chandra_res, chandra_jac)

  end function chandra_jac

end module test_problems

!=====================================================================!
! Main program to solve the test problems using different methods
!=====================================================================!

program test_nonlinear

  use test_problems, only : f1, f2, f3, dfdx1, dfdx2, dfdx3, &
       & chandra_res, chandra_jac

  use nonlinear_algebra, only : newton, secant, chord, fixed_point, &
       & shamanskii

  implicit none

  real(8), parameter :: tau_r = 1.0d-6
  real(8), parameter :: tau_a = 1.0d-6
  integer, parameter :: maxit = 100

  integer :: iter, flag
  real(8) :: tol

  ! Test nonlinear solvers on chandrasekhar method
  test_chandra: block

    integer, parameter :: npts = 200
    real(8) :: x(npts,4)

    print *, "Chandrasekhar Equation using Newton method"

    x(:,1) = 2.0d0
    call newton(chandra_res, chandra_jac, tau_r, tau_a, maxit, x(:,1))
    !print *, x(:,1)

    print *, "Chandrasekhar Equation using chord method"
    x(:,2) = 1.0d0
    call chord(chandra_res, chandra_jac, tau_r, tau_a, maxit, x(:,2))
    !print *, x(:,2)

    print *, "Chandrasekhar Equation using fixed point method"
    x(:,3) = 1.0d0
    call fixed_point(chandra_res, tau_r, tau_a, maxit, x(:,3))
    !print *, x(:,3)

    print *, "Chandrasekhar Equation using shamanskii method"
    x(:,4) = 1.0d0
    call shamanskii(chandra_res, chandra_jac, 2, tau_r, tau_a, maxit, x(:,4))
    !print *, x(:,4)

  end block test_chandra

  test_f1 : block

    integer, parameter :: npts = 1
    real(8) :: x(npts), x0(npts)

    print *, "function 1 using newton method"
    x = 10.0d0
    call newton(f1, dfdx1, tau_r, tau_a, maxit, x)
    print *, x

    print *, "function 1 using secant method"
    x = 10.0d0
    x0 = 0.99d0*x
    call secant(f1, tau_r, tau_a, maxit, x0, x)
    print *, x

    print *, "function 1 using chord method"
    x = 10.0d0
    call chord(f1, dfdx1, tau_r, tau_a, maxit, x)
    print *, x

  end block test_f1

  test_f2: block

    integer, parameter :: npts = 1
    real(8) :: x(npts), x0(npts)

    print *, "function 2 using newton method"
    x = 0.5d0
    call newton(f2, dfdx2, tau_r, tau_a, maxit, x)
    print *, x

    print *, "function 2 using secant method"
    x = 0.5d0
    x0 = 0.99d0*x
    call secant(f2, tau_r, tau_a, maxit, x0, x)
    print *, x

    print *, "function 2 using chord method"
    x = 0.5d0
    call chord(f2, dfdx2, tau_r, tau_a, maxit, x)
    print *, x

  end block test_f2

  test_f3: block

    integer, parameter :: npts = 1
    real(8) :: x(npts), x0(npts)

    print *, "function 3 using newton method"
    x = 3.0d0
    call newton(f3, dfdx3, tau_r, tau_a, maxit, x)
    print *, x

    print *, "function 3 using secant method"
    x = 3.0d0
    x0 = 0.99d0*x
    call secant(f3, tau_r, tau_a, maxit, x0, x)
    print *, x

    print *, "function 3 using chord method"
    x = 3.0d0
    call chord(f3, dfdx3, tau_r, tau_a, maxit, x)
    print *, x

  end block test_f3

end program test_nonlinear


program insertion
implicit none

!-----------------------------------------------------------------
! This programme sorts a series of values in increasing order,
! using insertion sort, implemented with one working array
!
! It works like this:
! unsorted: A = [5, 3, 4, 1, 2, 6]
! sorting:
! pass 1: A = [3, 5, 4, 1, 2, 6]
! pass 2: A = [3, 4, 5, 1, 2, 6]
! pass 3: A = [1, 3, 4, 5, 2, 6]
! pass 4: A = [1, 2, 3, 4, 5, 6]
! pass 5: B = [1, 2, 3, 4, 5, 6]
!------------------------------------------------------

real(kind=8), allocatable, dimension(:) :: A
real :: temp
integer :: i, j, k, n

!------------------------------------------------------------
! Make some random array:
!------------------------------------------------------------

write(*,*) 'size od array?'
read(*,*) n
allocate (A(n))

call random_seed()
do i = 1, n
   call random_number(A(i))
   A(i) = (A(i) * 100.0)
   A(i) = real(nint(A(i)*1000)) / 1000.0 !rounding off to 3 decimal places
end do

!------------------------------------------------------------
! Prepare output file:
!------------------------------------------------------------

open(unit=1, file='insert', status='replace', action='write')
write(1,*) 'here you can see the details of how the loops and conditionals'
write(1,*) 'really work'

write(1,*)
write(1,*) '(using one array)'
write(1,*)
write(1,'(A3,10F7.3)') ' A ', A
write(*,'(A3,10F7.3)') ' A ', A
write(1,*)

!------------------------------------------------------------
! The actual sorting:
!------------------------------------------------------------

do i = 2, n
   write (1,*) 'i', i
   do j = 1, i-1
      write(1,*) '   j', j
      if (A(j) .ge. A(i)) then
         write(1,*) 'found it'
         temp = A(i)
         do k = i-1, j, -1 !from the last value different from 0, to
!                                   the first one greater than i
            A(k+1) = A(k) !move every element by one
            write(1,*) '      k', k
         end do
         A(j) = temp
         exit
      end if
   end do
   write(1,'(I4,10F7.3)') i, A
   write(1,*)
   write(*,'(I4,10F7.3)') i, A
end do

end program insertion


! Created by EverLookNeverSee@GitHub on 4/15/20.
! This program calculates the roots of a quadratic equaion.

program roots
    implicit none
    ! defining variables
    real :: a, b, c, x_1, x_2, delta, sr_delta
    ! getting user input
    print *, "Enter the values of a, b, c:"
    read *, a, b, c
    ! calculating delta
    delta = (b ** 2) - (4.0 * a * c)
     if (delta > 0.0) then
        sr_delta = sqrt(delta)
        x_1 = (-b + sr_delta) / (2.0 * a)
        x_2 = (-b - sr_delta) / (2.0 * a)
        print *, "roots are:", x_1, x_2
    elseif (delta == 0.0) then
        x_1 = -b / (2.0 * a)
        x_2 = x_1
        print *, "roots are equal:", x_1, x_2
    else    ! value of delta is less than 0.0
        print *, "This quadratic equation has no real root."
    end if
end program roots


SUBROUTINE interp_lin (x, y, x_int, y_int)

! ----------------------------------------------------------------------
! Subroutine:  interp_lin.f90
! ----------------------------------------------------------------------
! Purpose:
!  Linear interpolation based on two data points
! ----------------------------------------------------------------------
! Input arguments:
! - x:			Array with two values of the x variable
! - y:			Array with two values of the y variable given as a
!               function of x. y = f(x)
! - x_int:		Value of x variable that the interpolation of y is required
!
! Output arguments:
! - y_int:		Interpolated value of y variable at the value x_int
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia               March 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: x(2), y(2), x_int
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: y_int
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      y_int = y(1) + ( x_int - x(1) ) * ( (y(2) - y(1)) / (x(2) - x(1)) )
! ----------------------------------------------------------------------

END


MODULE MathConstants

   SAVE
   REAL    (KIND=8), PARAMETER :: pi = 3.1415926535898D0, RadDeg = 180.0D0 / pi, DegRad = pi / 180.0D0
   COMPLEX (KIND=8), PARAMETER :: i  = ( 0.0D0, 1.0D0 )

END MODULE MathConstants


!> \file p80.f90
!! \BRIEF
!> Module with p80 function - compute pressure from depth
MODULE mp80
CONTAINS
!>     Function to compute pressure from depth using Saunder's (1981) formula with eos80.
FUNCTION p80(dpth,xlat)

  !     Compute Pressure from depth using Saunder's (1981) formula with eos80.

  !     Reference:
  !     Saunders, Peter M. (1981) Practical conversion of pressure
  !     to depth, J. Phys. Ooceanogr., 11, 573-574, (1981)

  !     Coded by:
  !     R. Millard
  !     March 9, 1983
  !     check value: p80=7500.004 dbars at lat=30 deg., depth=7321.45 meters

  !     Modified (slight format changes + added ref. details):
  !     J. Orr, 16 April 2009

  USE msingledouble
  IMPLICIT NONE

! Input variables:
  !> depth [m]
  REAL(kind=rx), INTENT(in) :: dpth
  !> latitude [degrees]
  REAL(kind=rx), INTENT(in) :: xlat

! Output variable:
  !> pressure [db]
  REAL(kind=rx) :: p80

! Local variables:
  REAL(kind=rx) :: pi
  REAL(kind=rx) :: plat, d, c1

  pi=3.141592654

  plat = ABS(xlat*pi/180.)
  d  = SIN(plat)
  c1 = 5.92e-3+d**2 * 5.25e-3

  p80 = ((1-c1)-SQRT(((1-c1)**2)-(8.84e-6*dpth))) / 4.42e-6

  RETURN
END FUNCTION p80
END MODULE mp80


real, dimension(n,m) :: a = reshape( [ (i, i=1, n*m) ], [ n, m ] )
real, dimension(m,k) :: b = reshape( [ (i, i=1, m*k) ], [ m, k ] )
real, dimension(size(a,1), size(b,2)) :: c    ! C is an array whose first dimension (row) size
                                              ! is the same as A's first dimension size, and
                                              ! whose second dimension (column) size is the same
                                              ! as B's second dimension size.

c = matmul( a, b )

print *, 'A'
do i = 1, n
    print *, a(i,:)
end do

print *,
print *, 'B'
do i = 1, m
    print *, b(i,:)
end do

print *,
print *, 'C = AB'
do i = 1, n
    print *, c(i,:)
end do


! 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


program mc_pi
  use tools

  implicit none
  integer :: sq_points, cr_points
  real(dp) :: result, dev

  sq_points = 10000 !number of points inside the square

  ! use grphmonte_pi() subroutine
  ! to get those data points in a file and use the grphing tools in graph/
  call monte_pi(sq_points, cr_points, result)

  dev = abs(pi - result)

  print *, ''
  print *, 'result:'
  write (*, form_result2rp) result, '-- approximate value of pi'
  write (*, form_result2rp) pi, '-- acutal value of pi'
  write (*, form_result2rp) dev, '-- deviation from actual value'
  write (*, form_result2i) cr_points, '-- points inside circle'
end program mc_pi


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


SUBROUTINE fibo(num,b)
    INTEGER :: a
    INTEGER :: b
    INTEGER :: c
    a = 0
    b = 1

    IF (num < 0) THEN
        b = 0
    ELSE
        IF (num == 0) THEN
            b = 0
        ELSE
            DO i = 1, num-1
                c = a + b
                a = b
                b = c
            END DO
        END IF
    END IF
! to compile the fortran code: run `gfortran -ffree-form filename.f`
! ro run the output `./a.out`
END SUBROUTINE fibo
PROGRAM fibonnaci
INTEGER :: r
INTEGER :: b
    PRINT*, "Enter the number of elements"
    READ *, r
    do i = 0,r-1
        call fibo(i,b)
        print*, b
    END DO
END PROGRAM fibonnaci


! 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