!

==============================================================
! Solution for a quadratic equation ax^2 + bx + c = 0
! Fortran 90 Demo program for students
! method: analytic solutions
! written by: Alex Godunov (February 2007)
!----------------------------------------------------------------
!input:
! a, b, c - coefficiants of equation (supplied by the user)
!output:
! x1, x2 - roots (can be complex)
!================================================================*/
program quad
implicit none

real a, b, c, x1, x2, xr, xi, D, D2

complex x1c, x2c

write (*,100)
read (*,*) a, b, c

if(a == 0.0) then

if(b == 0.0) then ! case c = 0 (no solutions)
write (*,101)
else ! case bx + c = 0
x1 = -c/b
write(*,102) x1
end if

else ! general case ax^2 + bx + c = 0

D2 = b*b - 4.0*a*c
if (D2 >= 0.0) then ! real roots
D = sqrt(D2)
x1 = ((-1.0)*b + D)/(2.0*a)
x2 = ((-1.0)*b - D)/(2.0*a)
write(*,103) x1, x2
else
D = sqrt(-1.0*D2)
xr = b/(2.0*a)
xi = D/(2.0*a)
x1c = cmplx(xr, xi)
x2c = cmplx(xr,-xi)
write(*,104) x1c, x2c
end if
end if

100 format (' solution of the quadratic equation ax^2 + bx + c = 0',/,&

' enter a b c (as floats separated by space)')
101 format (' no solution if a = 0 and b = 0')
102 format (' single root x = ',f10.5)
103 format (' real roots',/,' x1 = ',f10.5,/,' x2 = ',f10.5)
104 format (' complex roots',/,' real imagin.',/,&
' x1 = ',2f10.5,/,' x2 = ',2f10.5)
stop
end
 program fibonacci
! the program generate fibonacci numbers
! f(0) = 0
! f(1) = 1
! f(n) = f(n-1) + f(n-2) for n>1
! September 2008 (AG)
implicit none
integer :: f(0:100)
integer :: i, j
character :: prime*5

f(0) = 0
f(1) = 1

do i=2,40
f(i) = f(i-1) + f(i-2)
! check for prime numbers
prime = 'prime'
do j=2,f(i)-1
if (f(i) == (f(i)/j)*j) then
prime = ' '
exit
end if
end do
write (*,102) i, f(i), prime
end do

102 format(i3, i12, a6)

stop
end

program Legendre
!=======================================
! Fortran 90 demo program for students
! calculates Legendre polynomials Pn(x)
! using the recurrence relation
! written by: Alex Godunov (2008)
!=======================================
implicit none
double precision x, xmin, xmax, dx
double precision pl, plg
integer n

xmin = -1.0 ! left point

dx = 0.1 ! step
xmax = 1.0 ! right point

n = 10 ! order of Pn(x)

x = xmin

!open (unit=7,file="Legendre.dat")
write(*,100) n
do while (x < xmax+0.01)
plg = pl(x,n)
write(*,101) x, plg
x = x + dx
end do

100 format(' Legendre polynomials for n=',i3,/,&

' x Pn(x)')
101 format(f12.2,2f10.4)

stop
end

function pl(x,n)
!======================================
! calculates Legendre polynomials Pn(x)
! using the recurrence relation
! if n > 100 the function retuns 0.0
!======================================
double precision pl
double precision x
double precision pln(0:n)
integer n, k

pln(0) = 1.0
pln(1) = x

if (n <= 1) then
pl = pln(n)
else
do k=1,n-1
pln(k+1) = ((2.0*k+1.0)*x*pln(k) - float(k)*pln(k-1))/(float(k+1))
end do
pl = pln(n)
end if
return
end

program main
!====================================================================
! A single root of an equation f(x)=0 in [x1,x2] interval
! Method: Bisectional
!====================================================================
implicit none
double precision f,x1,x2,root,eps
integer flag
external f

x1 = -10.0
x2 = 10.0
eps = 1.0e-6

write (*,100)

call bisection(f,x1,x2,eps,root,flag)
! print solutions
if(flag == 0) then
write(*,104)
stop
end if

write(*,101) flag, eps

if(flag > 0) then
write(*,102) Root
else
write(*,103) Root
end if

! test solution
write(*,105) f(Root)

100 format(' A single root of f(x) ',/, &

' Method - Bisectional')
101 format(' iterations = ',i3,/,&
' tolerance = ',1pe12.5)
102 format(' root = ',1pe12.5)
103 format(' Singularity = ',1pe12.5)
104 format(' no roots for Bisectional method')
105 format(' f(root) = ',1pe12.5)

end program main

Subroutine bisection(f,x1,x2,eps,Root,flag)
!============================================================
! Solutions of equation f(x)=0 on [x1,x2] interval
! Method: Bisectional (closed domain) (a single root)
! Alex G. January 2010
!------------------------------------------------------------
! input ...
! f - function - evaluates f(x) for any x in [x1,x2]
! x1 - left endpoint of initial interval
! x2 - right endpoint of initial interval
! eps - desired uncertainity of the root as |b-a|<eps
! output ...
! Root - root of the equation f(x)=0
! flag - indicator of success
! >0 - a single root found, flag=number of iterations
! 0 - no solutions for the bisectional method
! <0 - not a root but singularity, flag=number of iterations
!
! Comments: Function f(x) has to change sign between x1 and x2
! Max number of iterations - 200 (accuracy (b-a)/2**200)
!====================================================================
implicit none
double precision f, x1, x2, eps, Root
double precision a, b, c
integer i, flag
integer, parameter:: iter=200

!* check the bisection condition

if(f(x1)*f(x2)>0.0) then
flag = 0
return
end if

!* initialize calculations
a=x1
b=x2

!* Iterative refining the solution

do i=1,iter
c=(b+a)/2.0
if(f(a)*f(c).le.0.0) then
b = c
else
a=c
end if
! condition(s) to stop iterations)
if(abs(b-a)<= eps) exit
end do
Root=(b+a)/2.0

!* check if it is a root or singularity

if (abs(f(Root)) < 1.0) then
flag=i
else
flag = -i
end if
end subroutine bisection

!-----------------------------------------------------
Function f(x)
implicit none
double precision f, x
f = x + cos(x)
end function f

program main
!====================================================================
! A single root of an equation f(x)=0 in [x1,x2] interval
! Method: Closed Domain (Bisectional or False position)
!====================================================================
implicit none
double precision f,x1,x2,root,eps
integer key, flag
external f

key = 2
x1 = -10.0
x2 = 10.0
eps = 1.0e-6

write (*,*) ' A single root of f(x)'

if(key == 1) write (*,*) ' Method - Bisectional'
if(key == 2) write (*,*) ' Method - False position'
write (*,100) x1, x2

call CDomain(f,x1,x2,eps,root,key,flag)

! print solutions
if(flag == 0) then
write(*,*)' no roots for closed domain methods'
stop
end if

write(*,101) eps, flag

if(flag > 0) then
write(*,102) Root
else
write(*,103) Root
end if

! test solution
write(*,104) f(Root)

100 format(' interval [',f7.3,',',f7.3,']')

101 format(' tolerance = ',1pe12.5,//,&
' iterations = ',i3)
102 format(' root = ',1pe12.5)
103 format(' Singularity = ',1pe12.5)
104 format(' f(root) = ',1pe12.5)

end program main

Subroutine CDomain(f,x1,x2,eps,Root,key,flag)
!============================================================
! Solutions of equation f(x)=0 on [x1,x2] interval
! Close Domain Methods: bisectional or false position
! Alex G. January 2010
!------------------------------------------------------------
! input ...
! f - function - evaluates f(x) for any x in [x1,x2]
! x1 - left endpoint of initial interval
! x2 - right endpoint of initial interval
! eps - desired uncertainity of the root as |b-a|<eps
! key - select a method
! 1 - bisectional method
! 2 - false position method
! output ...
! Root - root of the equation f(x)=0
! flag - indicator of success
! >0 - a single root found, flag=number of iterations
! 0 - no solutions for the bisectional method
! <0 - not a root but singularity, flag=number of iterations
!
! Comments: Function f(x) has to change sign between x1 and x2
! Max number of iterations - 200 (accuracy (b-a)/2**200)
!====================================================================
implicit none
double precision f, x1, x2, eps, Root
double precision a, b, c
integer i, key, flag
integer, parameter:: iter=200

!* check the bisection condition

if(f(x1)*f(x2)>0.0) then
flag = 0
return
end if

!* initialize calculations
a=x1
b=x2

!* Iterative refining the solution

do i=1,iter
if(key == 1) then
c=(b+a)/2.0
else
c = b - f(b)*(b-a)/(f(b)-f(a))
end if
if(f(a)*f(c).le.0.0) then
b = c
else
a=c
end if
! condition(s) to stop iterations)
if(abs(b-a)<= eps) exit
end do
Root=(b+a)/2.0

!* check if it is a root or singularity

if (abs(f(Root)) < 1.0) then
flag=i
else
flag = -i
end if
end subroutine CDomain

!-----------------------------------------------------
Function f(x)
implicit none
double precision f, x
f = x + cos(x)
end function f

program main
!====================================================================
! A single root of an equation f(x)=0 in around x1
! Method: Open Domain (Newton)
!====================================================================
implicit none
double precision f,x1,root,eps
integer flag
external f
x1 = -1.0
eps = 1.0e-7

write (*,*) ' A single root of f(x)'

write (*,*) ' Method - Newton'
write (*,100) x1

call Newton1(f,x1,eps,Root,flag)

! print solutions
if(flag == 0) then
write(*,*)' no root found'
stop
end if

write(*,101) eps, flag

write(*,102) Root

! test solution
write(*,104) f(Root,0)

100 format(' First point = ',f6.2)

101 format(' tolerance = ',1pe12.5,//,&
' iterations = ',i3)
102 format(' root = ',1pe12.5)
104 format(' f(root) = ',1pe12.5)

end program main

Subroutine Newton1(f,x1,eps,Root,flag)
!============================================================
! Solutions of equation f(x)=0 around point x
! Methods: Newton
! Alex G. January 2010
!------------------------------------------------------------
! input ...
! f - function - evaluates f(x)
! fp - finction - evaluates f'(x)
! x1 - a guess point
! eps - desired uncertainity of the root as f(Root)<eps
! output ...
! Root - root of the equation f(Root)=0
! flag - indicator of success
! >0 - a single root found, flag=number of iterations
! 0 - no solutions for the method of secants
!
! Comments: a user should suply both f(x) and f'(x)
!====================================================================
implicit none
double precision f, x1, eps, Root
double precision x2
integer i, flag
integer, parameter:: iter=200

!* Iterative refining the solution

do i=1,iter
 x2 = x1 - f(x1,0)/f(x1,1)
! check the step. if it is improbably large - use bisection
if(abs(x2) > 100.0*abs(x1)) x2 = 1.2*x1
! condition(s) to stop iterations)
if(abs(f(x2,0))<= eps) exit
x1 = x2;
end do
Root=x2

!* check the convergence

if (i /= iter) then
flag=i
else
flag = 0
end if

end subroutine Newton1

Function f(x,k)
!-----------------------------------------------------
! evaluates f(x) for k=0
! evaluates f'(x) for k=1
!-----------------------------------------------------
implicit none
double precision f, x
integer k
if(k==0) f = x + cos(x)
if(k==1) f = 1 - sin(x)
end function f