نیک فایل

مرجع دانلود فایل ,تحقیق , پروژه , پایان نامه , فایل فلش گوشی

نیک فایل

مرجع دانلود فایل ,تحقیق , پروژه , پایان نامه , فایل فلش گوشی

کلیه کد های درس محاسبات عددی به زبان فرترن (رایگان)

اختصاصی از نیک فایل کلیه کد های درس محاسبات عددی به زبان فرترن (رایگان) دانلود با لینک مستقیم و پر سرعت .

کد فرترن روش ماتریس معکوس در حل دستگاه معادلات

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

کد فرترن سری فیبوناچی

کد فرترن برنامه ای که که عدد n رو میگیره و تا جمله n ام سری فیبوناچی رو به صورت سطری چاپ میکنه.در پست قبل همین سری به صورت ستونی چاپ میشه.

 

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


دانلود با لینک مستقیم


کلیه کد های درس محاسبات عددی به زبان فرترن (رایگان)
نظرات 0 + ارسال نظر
برای نمایش آواتار خود در این وبلاگ در سایت Gravatar.com ثبت نام کنید. (راهنما)
ایمیل شما بعد از ثبت نمایش داده نخواهد شد