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

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

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

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