Please note, this is a STATIC archive of website www.tutorialspoint.com from 11 May 2019, cach3.com does not collect or store any user information, there is no "phishing" involved.
real function f(x,p,q,t)
real x, p, q, t
f=p*x*x+q*x+t
end function f
program root
real p, q, t, a, b, e
open (1,file='data.txt')
read (1,*) p, q, t, a, b, e
print "('f(x)=(',f4.0,')x^2+(',f4.0,')x+(',f4.0,')')", p, q, t
call Chords(a,b,e,p,q,t)
end program root
subroutine Chords(a,b,e,p,q,t)
real, external :: f
real a, b, e, p, q, t, k
integer :: m=0
print "(/6x,'МЕТОД ХОРД'//'Поиск корня по формуле: x = (a+b)/2'//&
2x,'Итерационный процесс:'/)"
if (2.*p*f(a,p,q,t)>0.) then
print "('fxx(a)*f(a) =',f9.4,' > 0'/'=> конец a неподвижен'/&
3x,'x(0) = b =',f8.4/&
'Поиск корня по формуле: x = x-f(x)/(f(x)-f(a))*(x-a)'//&
'Итерационный процесс:'/)", 2.*p*f(a,p,q,t), b
x=b
do
k=x
x=k-f(k,p,q,t)/(f(k,p,q,t)-f(a,p,q,t))*(k-a)
m=m+1
print "(i2,') x =',f8.4/4x,'|x(n)-x(n-1)| =',f7.4)", m, x, abs(k-x)
if(abs(k-x)<e) exit
end do
else
print "('fxx(a)*f(a) =',f9.4,' > 0'/'=> конец b неподвижен'/&
3x,'x(0) = a =',f8.4/&
'Поиск корня по формуле: x = x-f(x)/(f(b)-f(x))*(b-x)'//&
'Итерационный процесс:'/)", 2.*p*f(a,p,q,t), a
x=a
do
k=x
x=k-f(k,p,q,t)/(f(b,p,q,t)-f(k,p,q,t))*(b-k)
m=m+1
print "(i2,') x =',f8.4/4x,'|x(n)-x(n-1)| =',f7.4)", m, x, abs(k-x)
if(abs(k-x)<e) exit
end do
end if
print *,'Ответ: x =', x
end subroutine Chords
program probniy
real a, b, e, m, Smin
a=-7.
b=20.
e=0.01
call minn(a,b,e,m,Smin)
print *, "Точка минимума:"
print *, m
print *, "Значение функции в точке минимума:"
print *, Smin
end
subroutine minn(a,b,e,m,Smin)
real a, b, e, x1, x2, m, Ymin, f, x, G, k, S(4), Smin
f(x)=x**2.+6.*x-16.
G=1.618
x1=b-(b-a)/G
x2=a+(b-a)/G
do while ((b-a)>e)
S=(/f(a), f(x1), f(x2), f(b)/)
i=1
Smin=S(1)
do i=2,4
if(S(i)<Smin) Smin=S(i)
end do
if( (Smin==S(1)).or.(Smin==S(2))) then
m=x1
b=x2
x2=x1
x1=b-(b-a)/G
else
m=x2
a=x1
x1=x2
x2=a+(b-a)/G
end if
end do
end
program Darageh3
implicit none
! Variables
real*8 :: a, b, c, d, root1, root2, root3, xn1, xn, fx, df, h, moshtagh, tabeh, deltax, a1, b1, c1
integer*4 :: n,i
logical*2 :: control=.true.
xn = 0
write(*,*) 'It is a cubic function(a can not be zero'
write(*,*) 'Enter a'
read (*,*) a
write(*,*) 'Enter b'
read (*,*) b
write(*,*) 'Enter c'
read (*,*) c
write(*,*) 'Enter d'
read (*,*) d
write(*,*) 'Enter the first numeric value'
read (*,*) xn
! Body of Darageh3
do while(control)
xn1 = xn - ( tabeh(xn,a,b,c,d)/moshtagh(xn) )
if( dabs(xn - xn1) < 0.0001 ) then
control=.false.
else
xn=xn1
end if
end do
xn1 = root1
a1 = a
b1 = a*root1 + b
c1 = a*(root1**2) + b*root1 + c
deltax = b1**2 - 4*a1*c1
if(deltax < 0.0) then
write(*,*) 'root 1'
write(*,*) root1
write(*,*) 'The cubic function has only 1 root'
else if( deltax == 0.0) then
root2 = (-b1)/(2*a1)
write(*,*) 'root 1'
write(*,*) root1
write(*,*) 'root 2'
write(*,*) root2
write(*,*) 'The cubic function has 2 roots'
else
root2 = ( -b1 + sqrt(deltax) ) / 2*a1
root3 = ( -b1 - sqrt(deltax) ) / 2*a1
write(*,*) 'root 1'
write(*,*) root1
write(*,*) 'root 2'
write(*,*) root2
write(*,*) 'root 3'
write(*,*) root3
write(*,*) 'The cubic equation has 3 roots'
end if
read(*,*)
end program Darageh3
function tabeh(xn,a,b,c,d) result(fx)
implicit none
real*8 :: a, b, c, d, xn, fx
fx = a*(xn**3) + b*(xn**2) + c*(xn) + d
end function
function moshtagh(xn) result(df)
implicit none
real*8 :: tabeh, xn, h, df, a, b, c, d
h = 1.0D-6
df = ( tabeh(xn,a,b,c,d) - tabeh(xn+h,a,b,c,d) ) / h
end function
!*****************************************************************************
!
!! This program is to solve one dimensional heat transfer in a rod with constant tempreture boundary conditions by implicit method
!
program oneDTempIm
implicit none
real, allocatable :: T(:), B(:), Lx(:)
real :: Dx, R, Dt, Alfa, M, TRight, TLeft, initial, time, u, stability
integer :: i, j, n, nx
!****************************************************
!**************** Introducing Parameters**************
do
print *, "please enter the numbers of Dx "
read *, Dx
print *, "please enter the numbers of Dt and time of solution "
read *, Dt, time
print *, "please enter the numbers of T(Left), T(Right)"
read *, TLeft, TRight
print *, "please enter the numbers of alfa and initial condition"
read *, alfa, initial
stability=(alfa*Dt)/(Dx**2)
if(stability<0.5) exit
end do
nx = ((1.0/Dx)+1)
n = nx
allocate(T(n), B(n), Lx(n))
R = (Alfa * Dt)/(Dx**2)
M = (1-(2*R))
!======================End===============================
B(1) = TLeft
B(n) = TRight
do i= 2, n-1
B(i) = initial
end do
u = 0
do while ( u <= time )
T(1) = TLeft
T(n) = TRight
do i = 2, n-1
T(i) = R*B(i+1) + M*B(i) + R*B(i-1)
end do
do i = 1 , n
B(i) = T(i)
end do
u = u + Dt
end do
!***********showing Temperatures*************
OPEN(UNIT=15,FILE='Temperatures.txt')
do i = 1, n
write(15,*) i, T(i)
end do
close(15)
!======================End===============================
!*********showing temperature contour in tecplot**********
do i=1, n
Lx(i)= (i-1)*Dx
end do
OPEN(UNIT=20,FILE='Temperature contour.PLT')
WRITE(20,*)'VARIABLES="X","T"'
WRITE(20,*)'ZONE I=',nx,'F=POINT'
do i=1,n
WRITE(20,*)Lx(i), T(i)
END DO
close(20)
!======================End===============================
end program oneDTempIm
program hello
implicit none
integer ::Num=15
integer ::i
integer ::thisyear=1984
character(len=4) ::YYYY
character(len=31)::filename='../Output/Analysis/Ensemble/00/'
write(YYYY,'(I4)') thisyear
do i=1,Num
write(filename(29:30),'(I2.2)') i
print*,filename//YYYY//'.grd'
enddo
end program Hello
program collatz
implicit none
integer :: numero 27, resultado, par
print *, 'dame numero entero'
read *, numero 27
print *, 'vamos a ver si es maravilloso el numero', numero 27
resultado=numero 27
do
par= mod(resultado, 2)
if (par==0) resultado=resultado/2
if (par>0) resultado=3 *resultado +1
print *, 'resultado'
if(resultado==1)then
print *, 'el numero es maravilloso'
exit
end if
end do
end program collatz
