کد فرترن روش ماتریس معکوس در حل دستگاه معادلات
program matrix_inverse_method
implicit none
INTEGER::i2,i,j,k,p,i1,j1,n,j2,i3
REAL::s,detr,deta
REAL,ALLOCATABLE::a(:,:),b(:,:),c(:,:),f(:),x(:,:),t(:,:),g(:,:)
PRINT*
PRINT*," _ _ _ _ _ _ "
PRINT*," | a11 a12 ..a1n1 | | x1 | | b1 | "
PRINT*," | | | | | | "
PRINT*," | a21 a22 ..a2n1 | X | x2 | = | b2 | "
PRINT*," | . | | . | | . | "
PRINT*," | . | | . | | . | "
PRINT*," |_am11 am12..am1n1_| |_xn_| |_bn_| "
PRINT*," nxn nx1 nx1 "
PRINT*
PRINT*,"------------------------------------------------------------------------"
PRINT*
PRINT*,"tedad moadelat ya n ra vared konid : "
READ*,n
ALLOCATE(a(n,n),b(n-1,n-1),c(n,n),f(n-1),x(n,1),t(n,1),g(n,n))
do i2=1,n
PRINT*,"khate",i2,"matris a ra vared konid : "
READ*,a(i2,:)
PRINT*,"b(",i2,") ra vared konid :"
READ*,x(i2,1)
end do
call det(n,a,deta)
if (deta==0) then
PRINT*,"matris makoos pazir nist! "
stop
end if
do i1=1,n
do j1=1,n
p=0
do i=1,n
if (i/=i1) then
k=0
do j=1,n
if (j/=j1) then
k=k+1
f(k)=a(i,j)
end if
end do
p=p+1
b(p,:)=f
end if
end do
call det(n-1,b,detr)
s=((-1)**(i1+j1))*detr
c(i1,j1)=s
end do
end do
do j2=1,n
g(:,j2)=c(j2,:)
end do
g=g/deta
call mat(n,g,x,t)
do i3=1,n
PRINT*," X(",i3,") = ",t(i3,1)
end do
PRINT*
end
subroutine det(n,a,t1)
implicit none
INTEGER::i,j,g,f,r,j1,k,s,n
REAL::landa,t,a(n,n),b(n),c(n,n),t1
c=a
k=0
do i=1,n
if (c(i,i)==0) then
do j=i+1,n
if (c(j,i)/=0) then
k=k+1
b=c(j,:)
c(j,:)=c(i,:)
c(i,:)=b
end if
end do
end if
do j1=i+1,n
landa=-c(j1,i)/c(i,i)
c(j1,:)=(landa*c(i,:))+c(j1,:)
end do
end do
t=1
do s=1,n
t=t*c(s,s)
end do
if (MOD(k,2)==0) then
t1=t
else
t1=-t
end if
end
subroutine mat(n,a,b,c)
implicit none
INTEGER::m1,n1,m2,n2,t,k1,k2,i,k,j,n
REAL::a(n,n),b(n,1),c(n,1),c1(n),c2(n),s
do i=1,3
do j=1,1
c1=a(i,:)
c2=b(:,j)
s=0.
do k=1,3
s=s+(c1(k)*c2(k))
end do
PRINT*
c(i,j)=s
end do
end do
end
کد فرترن معکوس یک ماتریس
program matrix_inverse
implicit none
INTEGER::n,i,j,k,p,i1,j1,i2,j2,i3
REAL::s,detr,deta
REAL,ALLOCATABLE::a(:,:),b(:,:),c(:,:),f(:),g(:,:)
PRINT*
PRINT*," _ _ "
PRINT*," | a11 a12 ..a1n1 | "
PRINT*," | | -1"
PRINT*,"A = | a21 a22 ..a2n1 | A = ?"
PRINT*," | . |"
PRINT*," | . |"
PRINT*," |_am11 am12..am1n1_|"
PRINT*," nxn "
PRINT*
PRINT*,"------------------------------------------------------------------------"
PRINT*
PRINT*," n ra vared konid : "
READ*,n
ALLOCATE(a(n,n),b(n-1,n-1),c(n,n),f(n-1),g(n,n))
do i2=1,n
PRINT*," khate",i2,"matris a ra vared konid : "
READ*,a(i2,:)
end do
PRINT*,"-----------------------------------------------------"
PRINT*
call det(n,a,deta)
if (deta==0) then
PRINT*," matris makoos pazir nist! "
PRINT*
stop
end if
do i1=1,n
do j1=1,n
p=0
do i=1,n
if (i/=i1) then
k=0
do j=1,n
if (j/=j1) then
k=k+1
f(k)=a(i,j)
end if
end do
p=p+1
b(p,:)=f
end if
end do
call det(n-1,b,detr)
s=((-1)**(i1+j1))*detr
c(i1,j1)=s
end do
end do
do j2=1,n
g(:,j2)=c(j2,:)
end do
g=g/deta
PRINT*," -1 "
PRINT*," A : "
PRINT*
do i3=1,n
PRINT*," ",g(i3,:)
end do
PRINT*
end
subroutine det(n,a,t1)
implicit none
INTEGER::i,j,g,f,r,j1,k,s,n
REAL::landa,t,a(n,n),b(n),c(n,n),t1
c=a
k=0
do i=1,n
if (c(i,i)==0) then
do j=i+1,n
if (c(j,i)/=0) then
k=k+1
b=c(j,:)
c(j,:)=c(i,:)
c(i,:)=b
end if
end do
end if
do j1=i+1,n
landa=-c(j1,i)/c(i,i)
c(j1,:)=(landa*c(i,:))+c(j1,:)
end do
end do
t=1
do s=1,n
t=t*c(s,s)
end do
if (MOD(k,2)==0) then
t1=t
else
t1=-t
end if
end
کد فرترن ضرب دو ماتریس
program matrix
implicit none
INTEGER::m1,n1,m2,n2,t,k1,k2,i,k,j
REAL,allocatable::a(:,:),b(:,:),c(:,:),c1(:),c2(:)
REAL::s
PRINT*
PRINT*," _ _ _ _ _ _ "
PRINT*," | a11 a12 ..a1n1 | | b11 b12 ..b1n2 | | c11 c12 ..c1n2 | "
PRINT*," | | | | | | "
PRINT*," | a21 a22 ..a2n1 | X | b21 b22 ..b2n2 | = | c21 c22 ..c2n2 | "
PRINT*," | . | | . . . | | . . . | "
PRINT*," | . | | . . . | | . . . | "
PRINT*," |_am11 am12..am1n1_| |_bm21 bm22..bm2n2_| |_cm11 cm12..cm1n2_| "
PRINT*," m1xn1 m2xn2 m1xn2 "
PRINT*
PRINT*,"------------------------------------------------------------------------"
PRINT*
PRINT*,"input m1 and n1 : "
READ*,m1,n1
PRINT*,"input m1 and n2 : "
READ*,m2,n2
if (n1/=m2) then
PRINT*," n1 must be equal m2"
PRINT*
stop
end if
ALLOCATE(a(m1,n1),b(m2,n2),c(m1,n2),c1(n1),c2(m2))
PRINT*
do k1=1,m1
PRINT*,"input line",k1,"of matrix a :"
READ*,a(k1,:)
end do
do k2=1,m2
PRINT*,"input line",k2,"of matrix b :"
READ*,b(k2,:)
end do
do i=1,m1
do j=1,n2
c1=a(i,:)
c2=b(:,j)
s=0.
do k=1,m2
s=s+(c1(k)*c2(k))
end do
PRINT*
c(i,j)=s
end do
end do
PRINT*," C(",m1,",",n2,") :"
PRINT*
do t=1,m1
PRINT*," ",c(t,:)
end do
PRINT*
end program
کد فرترن انتگرال به روش ذوزنقه
program antegral
implicit none
INTEGER::n
REAL::t,i,s,fa,fb,b,a,delx
PRINT*
PRINT*," f(x) = x - 2**x"
PRINT*," baraye antegral az a ta b , a va b ra vared konid : "
PRINT*," a = "
READ*,a
PRINT*," b = "
READ*,b
PRINT*," n ra vared konid : "
READ*,n
delx=(b-a)/n
s=0.
do i=a+delx,b-delx,delx
s=s+(i-2**(i))
end do
fa=a-2**(a)
fb=b-2**(b)
t=(s+((fa+fb)/2))*delx
PRINT*," javab antegral az",a,"ta",b," = ",t
PRINT*
end
کد فرترن اثر ماتریس
این کد اول n رو که همون تعداد سطر و ستون ماتریس مربعی ماست رو میگره.سپس سطر به سطر درایه های های ماتریس رو از کاربر میگیره و شروع به محاسبه تریس ماریس میکنه.تریس یا اثر یک ماتریس برابر حاصل جمع درایه های روی قطر اصلی ماتریسه.در آخر هم جواب رو نمایش میده.
program trace
implicit none
INTEGER::n,i,t
REAL::s
REAL,ALLOCATABLE::a(:,:)
PRINT*," input n : "
READ*,n
ALLOCATE (a(n,n))
do t=1,n
PRINT*," input a(",t,", 1 ) to a(",t,",",n,") :"
PRINT*
READ*,a(t,:)
end do
s=0.
do i=1,n
s=s+a(i,i)
end do
PRINT*," trace = ",s
PRINT*
end
کد فرترن روش تکرار نیوتن
program nioton
implicit none
INTEGER::k,i
REAL::x,fpx,fx,c,e,y
!F(x)= x - cos(x)
PRINT*
PRINT*," F(X) = X - cos(X) X = ? "
PRINT*
PRINT*," Nerkhe hamgarayi ra vared konid : "
READ*,c
x=0
k=0
do
k=k+1
y=x
fx=x - COS(x)
fpx=1 + SIN(x)
x=x-(fx/fpx)
e=(ABS(x-y))/ABS(x)
if (e < c) exit
end do
PRINT*," Javab dar tekrar",k," barabar ast ba : X =",x
PRINT*
end
کد فرترن روش نابجایی
program nabejayi
implicit none
INTEGER::k
REAL::a,b,fa,fb,x,e,c,y
!F(x)=x^2 - 2^x
PRINT*
PRINT*," F(X) = X^2 - 2^X X = ? "
PRINT*
PRINT*," Baraye baze [a,b], a & b ra vared konid : "
READ*,a,b
PRINT*," Nerkhe hamgarayi ra vared konid : "
READ*,c
x=0
k=0
do
k=k+1
y=x
fa=(a**2)-(2**a)
fb=(b**2)-(2**b)
x=(a*fb - b*fa)/(fb-fa)
e=ABS((x-y))/ABS(x)
if (e < c) then
exit
end if
if ((x*fa) > 0) then
a=x
else
if ((x*fa) < 0) then
b=x
else
exit
end if
end if
end do
PRINT*," Javab dar tekrar",k," barabar ast ba : X =",x
PRINT*
end
کد فرترن مشتق مرتبه اول به روش تفاضل مرکزی
program dif
implicit none
REAL::x,fp,y1,y2,n,e,yp
!f(x)=(x**3)-2x+1
PRINT*
PRINT*," F(x) = x^3 - 2x + 1"
PRINT*
PRINT*," input n :"
READ*,n
PRINT*," , "
PRINT*," baraye F(x), noghte x ra vared konid:"
READ*,x
y2=((x+(1/n))**3)-2*(x+(1/n))+1
y1=((x-(1/n))**3)-2*(x-(1/n))+1
fp=(y2-y1)*n/2
PRINT*,"-------------------------------------------------"
PRINT*," moshtagh F(x) dar noghte",x," = ",fp
yp=3*(x**2)-2
e=(ABS(yp-fp)/yp)*100
PRINT*
PRINT*," Error =",e,"%"
PRINT*,"-------------------------------------------------"
PRINT*
end
کد فرترن روش کرامر
program keramer
implicit none
INTEGER::i,n,j
REAL::detnet,det
REAL,ALLOCATABLE::a(:,:),b(:),x(:),c(:)
PRINT*
PRINT*
PRINT*," 1 | X(1)a(1,1) + X(2)a(1,2) + ... + X(n)a(1,n) = b(1) |"
PRINT*," 2 | X(1)a(2,1) + X(2)a(2,2) + ... + X(n)a(2,n) = b(2) |"
PRINT*," . | . . . . . . . . . |"
PRINT*," . | . . . . . . . . . |"
PRINT*," . | . . . . . . . . . |"
PRINT*," . | . . . . . . . . . |"
PRINT*," n |_ X(1)a(n,1) + X(2)a(n,2) + ... + X(n)a(n,n) = b(n)_|"
PRINT*," n*n+1"
PRINT*
PRINT*,"-------------------------------------------------------------------"
PRINT*," lotfan n ya tedad moadelat ra vared konid : "
READ*,n
ALLOCATE(a(n,n),b(n),x(n),c(n))
do i=1,n
PRINT*," satre",i,"matris ra vared konid :"
READ*,a(i,:)
PRINT*," b(",i,") ra vared konid : "
READ*,b(i)
end do
PRINT*
PRINT*
call determinant(n,a,det)
detnet=det
do j=1,n
c=a(:,j)
PRINT*
a(:,j)=b
call determinant(n,a,det)
x(j)=det/detnet
PRINT*," X(",j,") = ",x(j)
a(:,j)=c
end do
PRINT*
PRINT*,"------------------------------------------------"
PRINT*
end
subroutine determinant(n,a,det)
implicit none
INTEGER::i,j,g,f,r,i1,j1,k,s,n
REAL::landa,a(n,n),b(n),det,t,d(n,n)
d=a
k=0
do i=1,n
if (a(i,i)==0) then
do j=i+1,n
if (a(j,i)/=0) then
k=k+1
b=a(j,:)
a(j,:)=a(i,:)
a(i,:)=b
end if
end do
end if
do j1=i+1,n
landa=-a(j1,i)/a(i,i)
a(j1,:)=(landa*a(i,:))+a(j1,:)
end do
end do
t=1
do s=1,n
t=t*a(s,s)
end do
if (MOD(k,2)==0) then
det=t
else
det=-t
end if
a=d
end
کد فرترن محاسبه دترمینان ماتریس n در n
program determinan
implicit none
INTEGER::i,j,g,f,r,j1,k,s,n
REAL::landa,t
REAL,ALLOCATABLE::a(:,:),b(:)
PRINT*
PRINT*," for matrix(n,n) input n : "
READ*,n
ALLOCATE (a(n,n),b(n))
do g=1,n
PRINT*," input line",g,":"
READ*,a(g,:)
end do
k=0
do i=1,n
if (a(i,i)==0) then
do j=i+1,n
if (a(j,i)/=0) then
k=k+1
b=a(j,:)
a(j,:)=a(i,:)
a(i,:)=b
end if
end do
end if
do j1=i+1,n
landa=-a(j1,i)/a(i,i)
a(j1,:)=(landa*a(i,:))+a(j1,:)
end do
end do
PRINT*
PRINT*
t=1
do s=1,n
t=t*a(s,s)
end do
if (MOD(k,2)==0) then
PRINT*," Determinant = ",t
else
PRINT*," Determinant = ",-t
end if
PRINT*
PRINT*,"-----------------------------------------------------------------"
end
کد فرترن روش تکرار ساده
program tekrar_sade
implicit none
!f(x)=(e**x)-x-4
!x=(e**x)-4
!g(x)=(e**x)-4
INTEGER::k
REAL::x,y,e,c,t,r1,r2,a,b
PRINT*,"baze [a,b] ra vared konid : "
PRINT*,"a = "
READ*,a
PRINT*,"b = "
READ*,b
t=(a+b)/2
r1=(2.71828182**t)-4
r2=2.71828182**t
if ( ( r1 > a ) .and. ( r1 < b ) .and. (( ABS(r2)) < 1)) then
PRINT*
PRINT*,"nerkh hamgarayi ra vared konid : "
READ*,c
x=0
k=0
do
k=k+1
y=(2.71828182**x)-4
e=(y-x)/y
if ( e < c ) then
exit
else
x=y
end if
end do
PRINT*,"javab dar tekrar",k," barabar : ",y
else
PRINT*,"dar baze [",a,",",b,"] hich javabi vojood nadarad."
end if
PRINT*
end
کد فرترن الگوریتم توماس
program toomas
implicit none
INTEGER::n,i,j,k,l
REAL::landa
REAL,ALLOCATABLE::a(:,:),r(:),x(:)
PRINT*
PRINT*," _ _"
PRINT*," | | | "
PRINT*," 1 | b(1) c(1) 0 0 0 . 0 | r(1) | "
PRINT*," | | |"
PRINT*," 2 | a(2) b(2) c(2) 0 0 . 0 | r(2) | "
PRINT*," | | |"
PRINT*," 3 | 0 a(3) b(3) c(3) 0 . 0 | r(3) | "
PRINT*," | | |"
PRINT*," . | 0 0 a(4) b(4) . . . | r(4) | "
PRINT*," . | | | "
PRINT*," . | . . . . . . 0 | . | "
PRINT*," . | | | "
PRINT*," . | . . . . . . c(n) | . | "
PRINT*," | | |"
PRINT*," n | 0 0 0 . 0 a(n) b(n) | r(n) | "
PRINT*," |_ | _| "
PRINT*," (n , n+1)"
PRINT*
PRINT*,"-----------------------------------------------------------------"
PRINT*
PRINT*," n ya tedad moadelat ra vared konid : "
READ*,n
ALLOCATE (a(n,n),r(n),x(n))
PRINT*
PRINT*," b( 1 ) va c( 1 ) ra be tartib vared konid :"
READ*,a(1,1),a(1,2)
do i=2,n-1
PRINT*," a(",i,") , b(",i,") , c(",i,") ra be tartib vared konid : "
READ*,a(i,i-1:i+1)
end do
PRINT*," a(",n,") va b(",n,") ra be tartib vared konid : "
READ*,a(n,n-1),a(n,n)
PRINT*
PRINT*," r(1) ta r(",n,") ra be tartib vared konid : "
READ*,r(1:n)
PRINT*
PRINT*,"------------------------------------------------------------------"
PRINT*
do j=1,n-1
landa=-a(j+1,j)/a(j,j)
a(j+1,j)=0
a(j+1,j+1)=(a(j,j+1)*landa)+a(j+1,j+1)
r(j+1)=(landa*r(j))+r(j+1)
end do
x(n)=r(n)/a(n,n)
do k=n,1,-1
x(k)=(r(k)-(a(k,k+1)*x(k+1)))/a(k,k)
end do
do l=1,n
PRINT*," X(",l,") = ",x(l)
end do
PRINT*
end
کد فرترن ریشه های معادله درجه دوم
program daraje_2
implicit none
REAL::a,b,c,x1,x2,delta
PRINT*
PRINT*," 2 "
PRINT*," aX + bX + c = 0 ===>> a , b , c = ?"
PRINT*
PRINT*," a : "
READ*,a
PRINT*," b : "
READ*,b
PRINT*," c : "
READ*,c
PRINT*
PRINT*,"-----------------------------------------------------------------"
PRINT*
delta=(b**2)-(4*a*c)
if (delta>0) then
x1=(-b+SQRT(delta))/(2*a)
x2=(-b-SQRT(delta))/(2*a)
PRINT*," X(1) =",x1
PRINT*
PRINT*," X(2) =",x2
PRINT*
else
if (delta==0) then
x1=-b/(2*a)
PRINT*," X =",x1
PRINT*
else
x1=-b/(2*a)
x2=-delta/(2*a)
PRINT*," X(1) and X(2) are complex : "
PRINT*
PRINT*," X(1) =",x1,"+",x2,"i"
PRINT*
PRINT*," X(2) =",x1,"-",x2,"i"
PRINT*
end if
end if
PRINT*,"-----------------------------------------------------------------"
end
کد فرترن تبدیل عدد از مبنایی به مبنای دیگر
program mabna_m_be_n
implicit none
INTEGER::a,m,n,k,s1,s2,j,i,r,a10,am
PRINT*
PRINT*," (a) = (?)"
PRINT*," m n"
PRINT*
PRINT*," a ra vared konid : "
READ*,a
PRINT*
PRINT*,"mabnaye m ra vared konid : "
READ*,m
PRINT*
PRINT*,"mabnaye n ra vared konid : "
READ*,n
PRINT*
am=a
k=1
do
if (a<(10**k)) then
exit
else
k=k+1
end if
end do
s1=0
do i=0,k-1
r=MOD(a,10)
s1=s1+(r*(m**i))
a=INT(a/10)
end do
a10=s1
s2=0
j=0
do
if (s1==0) then
exit
else
r=MOD(s1,n)
s2=s2+(r*10**j)
j=j+1
s1=INT(s1/n)
end if
END do
PRINT*," (",am,") =",a10,"= (",s2,")"
PRINT*," ",m," ",n
end
کد فرترن روش تنصیف
program bisection
implicit none
INTEGER::k
REAL::x,xo,a,b,e,e1,a1,x1,t1,t2
!y=x**2-e**x
do
PRINT*,"baze [a,b] ra vared konid : "
PRINT*,"a = "
READ*,a
PRINT*,"b = "
READ*,b
t1=(a**2)-((2.71828182)**a)
t2=(b**2)-((2.71828182)**b)
if ((t1*t2)>0) then
PRINT*,"dar baze [",a,",",b,"] hich javabi vojood nadarad."
PRINT*
else
exit
end if
END do
xo=0
PRINT*
PRINT*,"nerkh hamgarayi ra vared konid : "
READ*,e
k=0
do
k=k+1
x=(a+b)/2
a1=(a**2)-((2.71828182)**a)
x1=(x**2)-((2.71828182)**x)
if ((a1*x1)>0) then
a=x
else
if ((a1*x1) < 0) then
b=x
else
exit
end if
end if
e1=abs(x-xo)/ABS(x)
if (e1 < e) then
exit
else
xo=x
end if
END do
PRINT*,"javab dar tekrar",k," barabar : ",x
PRINT*
end
کد فرترن روش گاوس-سایدل
program gauss_sidel
implicit none
INTEGER::i,j,i1,j1,k,t1,n,j2,k1
REAL::s,e
REAL,ALLOCATABLE::a(:,:),x(:),y(:),t(:)
PRINT*
PRINT*
PRINT*," 1 2 . . . n n+1"
PRINT*," _ - - - - - _ "
PRINT*," 1 | X(1)a(1,1) + X(2)a(1,2) + ... + X(n)a(1,n) = a(1,n+1) |"
PRINT*," 2 | X(1)a(2,1) + X(2)a(2,2) + ... + X(n)a(2,n) = a(2,n+1) |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," n |_ X(1)a(n,1) + X(2)a(n,2) + ... + X(n)a(n,n) = a(n,n+1)_|"
PRINT*," n*n+1"
PRINT*
PRINT*,"baraye matris n*n+1 bala lotfan n (tedad moadalat) ra vared konid :"
READ*,n
ALLOCATE (a(n,n+1),x(n),y(n),t(n))
do i1=1,n
PRINT*,"khate",i1,"ra vared konid ( az a(",i1,", 1) ta a(",i1,",",n+1,")) : "
READ*,a(i1,:)
end do
PRINT*,"nerkh hamgarayi ra vared konid : "
READ*,e
do j2=1,n
x(j2)=0
y(j2)=0
end do
k=1
do
do i=1,n
s=0
do j=1,n
if (j.ne.i) then
s=s+x(j)*a(i,j)
end if
end do
x(i)=(a(i,n+1)-s)/a(i,i)
end do
do t1=1,n
t(t1)=(abs(x(t1)-y(t1)))/ABS(x(t1))
end do
if (MAXVAL(t) < e) then
exit
else
k=k+1
y(1:n)=x(1:n)
end if
end do
PRINT*,"javab ha dar tekrar ",k," ba hadse avaliye X(1:n)=0 ::"
PRINT*
do k1=1,n
PRINT*," X(",k1,") = ",x(k1)
end do
PRINT*
end
کد فرترن تعویض درایه های ماتریس نسبت به قطر اصلی
د فرترن برنامه ای که درایه های یک ماتریس مربعی n در n را نسبت به قطر اصلی عوض میکنه.این برنامه اول n رو میگیره و ماتریس n در n رو تشکیل میده سپس ماتریس رو خط به خط از بالا به پایین از کاربر میگیره و در آخر درایه هارو نسبت به قطر اصلی عوض میکنه و نمایش میده.
program matris
implicit none
INTEGER::b,i,j,k,n,t
INTEGER,ALLOCATABLE::a(:,:)
PRINT*,"baraye matris n*n lotfan n ra vared konid : "
READ*,n
ALLOCATE (a(n,n))
do t=1,n
PRINT*,"khate",t,"ra vared konid : "
READ*,a(t,:)
end do
PRINT*
do i=1,n-1
do j=i+1,n
b=a(i,j)
a(i,j)=a(j,i)
a(j,i)=b
end do
end do
do k=1,n
PRINT*,a(k,:)
end do
PRINT*
end
کد فرترن روش تکرار ژاکوبی
program jacobi
implicit none
INTEGER::i,j,i1,i2,j1,n,j2,k,k1,t1
REAL::s,e
REAL,ALLOCATABLE::a(:,:),x(:),y(:),t(:)
PRINT*
PRINT*
PRINT*," 1 2 . . . n n+1"
PRINT*," _ - - - - - _ "
PRINT*," 1 | X(1)a(1,1) + X(2)a(1,2) + ... + X(n)a(1,n) = a(1,n+1) |"
PRINT*," 2 | X(1)a(2,1) + X(2)a(2,2) + ... + X(n)a(2,n) = a(2,n+1) |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," . | . . . . . . . . . . . |"
PRINT*," n |_ X(1)a(n,1) + X(2)a(n,2) + ... + X(n)a(n,n) = a(n,n+1)_|"
PRINT*," n*n+1"
PRINT*
PRINT*,"baraye matris n*n+1 bala lotfan n (tedad moadalat) ra vared konid :"
READ*,n
ALLOCATE (a(n,n+1),x(n),y(n),t(n))
do i1=1,n
PRINT*,"khate",i1,"ra vared konid ( az a(",i1,", 1) ta a(",i1,",",n+1,")) : "
READ*,a(i1,:)
end do
PRINT*,"nerkh hamgarayi ra vared konid : "
READ*,e
do j2=1,n
x(j2)=0
end do
k=1
do
do i=1,n
s=0
do j=1,n
if (j.ne.i) then
s=s+x(j)*a(i,j)
end if
end do
y(i)=(a(i,n+1)-s)/a(i,i)
end do
do t1=1,n
t(t1)=(abs(y(t1)-x(t1)))/ABS(y(t1))
end do
if ( MAXVAL(t) < e ) then
exit
else
k=k+1
x(1:n)=y(1:n)
end if
end do
PRINT*
PRINT*,"javab ha dar tekrar ",k," ba hadse avaliye X(1:n)=0 ::"
PRINT*
do k1=1,n
PRINT*,"X(",k1,") = ",x(k1)
end do
PRINT*
PRINT*
end
کد فرترن روش حذفی گاوس
program gauss
implicit none
INTEGER::n,i,j,j1,i2,i3,j3,i4,k
REAL::landa,s
REAL,allocatable::a(:,:),x(:),b(:)
PRINT*
PRINT*,"matrix n dar n+1 zir ra dar nazar begirid::"
PRINT*
PRINT*," _ _ "
PRINT*," 1 | a(1,1) a(1,2) ... a(1,n) | a(1,n+1) | "
PRINT*," 2 | a(2,1) a(2,2) ... a(2,n) | a(2,n+1) | "
PRINT*," 3 | a(3,1) a(3,2) ... a(3,n) | a(3,n+1) | "
PRINT*," . | . . . . | . | "
PRINT*," . | . . . . | . | "
PRINT*," . | . . . . | . | "
PRINT*," . | . . . . | . | "
PRINT*," . | . . . . | . | "
PRINT*," n |_ a(n,1) a(n,2) ... a(n,n) | a(n,n+1) _| "
PRINT*," (n,n+1)"
PRINT*," ------------------------- -----------"
PRINT*," matris zarayeb bordar ma-loom"
PRINT*
PRINT*,"__________________________________________________________________"
PRINT*
PRINT*,"lotafan tedad moadelat ya (n) ra vared konid:"
READ*,n
ALLOCATE (a(n,n+1),x(n),b(n+1))
do k=1,n
PRINT*,"khate",k,"ra vared konid ( az a(",k,", 1) ta a(",k,",",n+1,") ) :"
READ*,a(k,:)
end do
PRINT*,"-----------------------------------------------------------------"
do i=1,n
if (a(i,i)==0) then
do j=i+1,n
if (a(j,i)/=0) then
b=a(j,:)
a(j,:)=a(i,:)
a(i,:)=b
end if
end do
end if
do j1=i+1,n
landa=-a(j1,i)/a(i,i)
a(j1,:)=(landa*a(i,:))+a(j1,:)
end do
end do
PRINT*
PRINT*
x(n)=a(n,n+1)/a(n,n)
do i3=n-1,1,-1
s=0.
do j3=i3+1,n
s=s+(a(i3,j3)*x(j3))
end do
x(i3)=(a(i3,n+1)-s)/a(i3,i3)
end do
do i4=1,n
PRINT*," x(",i4,") = ",x(i4)
END do
PRINT*
PRINT*
PRINT*,"__________________________________________________________"
end
کد فرترن ضرایب دوجمله ای نیوتن
program khayam
implicit none
INTEGER::n,i,t1,t2,t3,j1,j2,j3
INTEGER,ALLOCATABLE::a(:)
PRINT*," n ra vared konid : "
READ*,n
PRINT*
ALLOCATE (a(n+1))
t1=1
do j1=1,n
t1=t1*j1
end do
do i=0,n
t3=1
t2=1
do j2=1,i
t2=t2*j2
end do
do j3=1,n-i
t3=t3*j3
end do
a(i+1)=t1/(t2*t3)
end do
PRINT*,"zarayeb baraye tavan",n," : ",a
PRINT*
end
کد فرترن اعداد اول بین دو عدد
program prime
implicit none
INTEGER::n,i,k,j,m
READ*,m,n
PRINT*
do i=m+1,n-1
k=0
do j=1,i
if (MOD(i,j)==0) then
k=k+1
end if
end do
if (k==2) then
PRINT*,i
end if
end do
end
کد فرترن اعداد اول 1 تاn
program prime
implicit none
INTEGER::n,i,k,j
READ*,n
PRINT*
do i=1,n
k=0
do j=1,i
if (MOD(i,j)==0) then
k=k+1
end if
end do
if (k==2) then
PRINT*,i
end if
end do
end
کد فرترن تعداد ارقام یک عدد
program ragham
implicit none
INTEGER::n,i
READ*,n
PRINT*
i=1
do
if (n<(10**i)) then
exit
else
i=i+1
end if
end do
PRINT*,i
end
کد فرترن مجموع معکوس فاکتوریل n عدد
s=(1/1!)+(1/2!)+(1/3!) =1.666666
--------------------------------------------------------------------------------------------------------------------------------------
program fuct
implicit none
INTEGER::n,t,i
REAL::s
READ*,n
t=1
s=0
do i=1,n
t=t*i
s=s+(1/REAL(t))
end do
PRINT*,s
end
کد فرترن مجموع فاکتوریل n عدد
s=1!+2!+3! =9
-----------------------------------------------------------------------------------------------------------------------------------
program fuct
implicit none
INTEGER::n,s,t,i
READ*,n
t=1
s=0
do i=1,n
t=t*i
s=s+t
end do
PRINT*,s
end
کد فرترن سری فیبوناچی
program fibo
implicit none
INTEGER::f1,f2,f3,i,n
INTEGER,allocatable::a(:)
READ*,n
ALLOCATE (a(n))
PRINT*
f1=1
f2=1
a(1)=f1
a(2)=f2
do i=3,n
f3=f2+f1
a(i)=f3
f1=f2
f2=f3
end do
PRINT*,a
end
کد فرترن سری فیبوناچی
کد فرترن برنامه ای که عدد n رو میگیره و تا جمله n ام سری فیبوناچی رو به صورت زیر هم دیگه چاپ میکنه.در پست بعد کد برنامه ایه مه سری فیبوناپی رو در یک سطر چاپ میکنه.
program fibo
implicit none
INTEGER::f1,f2,f3,i,n
READ*,n
PRINT*
f1=1
f2=1
PRINT*,f1
PRINT*,f2
do i=3,n
f3=f2+f1
PRINT*,f3
f1=f2
f2=f3
end do
end
کد فرترن نمایش معکوس یک عدد
مثلا 12345 رو به صورت 54321 نشون میده
program makoos
implicit none
INTEGER::n,b,p,i,s,k,j
INTEGER,ALLOCATABLE::a(:)
READ*,n
p=1
do
if (n<10**p) then
exit
else
p=p+1
end if
end do
ALLOCATE (a(p))
do i=1,p
a(i)=MOD(n,10)
n=INT(n/10)
end do
s=0
k=p
do j=0,p-1
t=a(k)*(10**j)
s=s+t
k=k-1
end do
PRINT*,s
end program
کد فرترن مقسوم علیه های مشترک دو عدد
کد فرترن برنامه ای که دو عدد رو میگیره و مقسوم علیه های مشترک رو نشون میده
program mas
implicit none
INTEGER::n,s,i,a,m
READ*,m,n
if (n>m) then
a=m
m=n
n=a
end if
do i=1,n
if (MOD(n,i)==0) then
if (MOD(m,i)==0) then
PRINT*,i
end if
end if
end do
end
کد فرترن به صورت نزولی مرتب کردن
کد فرترن برنامه ای که تعداد دلخواه عدد رو میگیره و اونا رو به ترتیب نزولی(از بزرگ به کوچک) مرتب میکنه
n=تعداد اعدادی که میخواید وارد کنید
program ny
implicit none
INTEGER::n,i
INTEGER,ALLOCATABLE::a(:),b(:)
READ*,n
ALLOCATE (a(n),b(n))
READ*,a
do i=1,n
b(i)=MAXVAL(a)
a(MAXLOC(a))=MINVAL(a)
end do
PRINT*,b
end
کد فرترن به صورت صعودی مرتب کردن
n=تعداد اعدادی میخواید وارد کنید
program nyy
implicit none
INTEGER::n,i
INTEGER,ALLOCATABLE::a(:),b(:)
READ*,n
ALLOCATE (a(n),b(n))
READ*,a
do i=1,n
b(i)=minVAL(a)
a(minLOC(a))=maxVAL(a)
end do
PRINT*,b
end
کد فرترن تشخیص عدد کامل
کد فرترن برنامه ای که تعداد دلخواه عدد رو میگیره و اونا رو به ترتیب نزولی(از بزرگ به کوچک) مرتب میکنه
عدد کامل عددیه که مجموع مقسوم علیه های غیر از خوش برابر خود عدد بشه.مثل عدد 6 که مجموع 1 و2 و3 که مقسوم عیه های غیر خودش هستن میشه 6
program kamel
implicit none
INTEGER::n,s,i
READ*,n
s=0
do i=1,(n/2)+1
if (MOD(n,i)==0) then
s=s+i
end if
end do
if (s==n) then
PRINT*,"yes"
else
PRINT*,"no"
end if
end program
کد فرترن محاسبه فاکتوریل
کد فرترن محاسبه ی فاکتوریل یک عدد
program fuct
implicit none
INTEGER::n,s,i
READ*,n
s=1
do i=1,n
s=s*i
end do
PRINT*,s
end
کد فرترن تشخیص عدد اول
کد فرترن برنامه ای که عددی رو میگیره و نشون میده اول هست یا نه.
یکی از راه های تشخیص عدد اول اینه که تعداد مقسوم علیه هاش فقط 2 تا است.من هم از همین روش استفاده کردم.
program fuct
implicit none
INTEGER::n,i,k
READ*,n
k=0
do i=1,n
if (MOD(n,i)==0) then
k=k+1
end if
end do
if (k==2) then
PRINT*,"yes"
else
PRINT*,"no"
end if
end
کد فرترن به توان رساندن بدون استفاده از عمل توان و ضرب
program tavan
implicit none
INTEGER::k,t,i,j,m,n
READ*,m,n
t=0
k=m
do i=1,n-1
do j=1,m
t=t+k
end do
k=t
t=0
end do
PRINT*,k
end program
کد فرترن تبدیل مبنای 2 به 10
کد فرترن تبدیل یک عدد از مبنای 2 به مبنای 10
program mabna
implicit none
INTEGER::n,s,i,j,t,k
READ*,n
j=1
do
if (n<(10**j)) then
k=i
exit
else
j=j+1
end if
end do
s=0
do i=0,k-1
t=MOD(n,10)*(2**i)
s=s+t
n=INT(n/10)
end do
PRINT*,s
end
کد فرترن ب.م.م و ک.م.م دو عدد
کد فرترن بزرگ ترین مقسوم علیه مشترک (ب.م.م) و کوچکترین مضرب مشترک دو عدد (ک.م.م)
program bmm_kmm
implicit none
INTEGER::n ,i,r,m,a,b,kmm
READ*,m,n
a=m
b=n
do
r=MOD(m,n)
if (r==0) then
PRINT*,"bmm =",n
exit
else
m=n
n=r
end if
end do
kmm=(a*b)/n
PRINT*,"kmm =",kmm
end
کد فرترن تجزیه ی یک عدد به اعداد اول
program tajziye
implicit none
INTEGER::i,n,a
READ*,n
a=n+1
i=2
do
if (MOD(n,i)==0) then
PRINT*,i
n=n/i
else
i=i+1
if (i==a) then
exit
end if
end if
end do
end program
کلیه کد های درس محاسبات عددی به زبان فرترن (رایگان)
