|
|
|
دانلود جزوه کامل مبانی برنامه نویسی فرترن بر اساس فرترن 90
___________________________________________________________________________
ضميمه 2 : برنامه ها
برنامه 1 : محاسبه ب. م . م دو عدد
PROGRAM
GreatestCommonDivisor
IMPLICIT
NONE
INTEGER
:: a, b, c
WRITE(*,*) 'Two positive
integers please --> '
READ(*,*)
a, b
IF (a < b) THEN
! since a >= b must be true, they
c = a
! are swapped if a < b
a = b
b = c
END IF
DO
! now we have a <= b
c = MOD(a,
b) !
compute c, the reminder
IF (c == 0)
EXIT !
if c is zero, we are done.
GCD = b
a = b
!
otherwise, b becomes a
b = c
!
and c becomes b
END DO
!
go back
WRITE(*,*) 'The GCD is ', b
END PROGRAM
GreatestCommonDivisor
برنامه 2 : محاسبه جذر يک عدد از طريق رابطه نيوتن
PROGRAM
SquareRoot
IMPLICIT
NONE
REAL
:: Input, X, NewX, Tolerance
INTEGER :: Count
READ(*,*)
Input, Tolerance
Count = 0
X
= Input
DO
Count =
Count + 1
NewX = 0.5*(X + Input/X)
IF (ABS(X -
NewX) < Tolerance) EXIT
X = NewX
END DO
WRITE(*,*)
'After ', Count, ' iterations:'
WRITE(*,*)
' The estimated square root
is ', NewX
WRITE(*,*)
' The square root from SQRT()
is ', SQRT(Input)
WRITE(*,*)
' Absolute error = ',
ABS(SQRT(Input) - NewX)
END PROGRAM
SquareRoot
برنامه 3 :
يافتن تمامي عوامل اول يک عدد
PROGRAM
Factorize
IMPLICIT
NONE
INTEGER
:: Input
INTEGER
:: Divisor
INTEGER
:: Count
WRITE(*,*)
'This program factorizes any integer >= 2 --> '
READ(*,*)
Input
Count = 0
DO
IF
(MOD(Input,2) /= 0 .OR. Input == 1) EXIT
Count =
Count + 1
WRITE(*,*)
'Factor # ', Count, ': ', 2
Input =
Input / 2
END DO
Divisor = 3
DO
IF (Divisor
> Input) EXIT
DO
IF (MOD(Input,Divisor) /= 0 .OR. Input == 1)
EXIT
Count = Count + 1
WRITE(*,*)
'Factor # ',
Count, ': ', Divisor
Input = Input / Divisor
END DO
Divisor =
Divisor + 2
END DO
END PROGRAM
Factorize
برنامه 4 : نمايش مثلث بالايي يک ماتريس 10 در 10
PROGRAM
UpperTriangularMatrix
IMPLICIT
NONE
INTEGER, PARAMETER
:: SIZE = 10
INTEGER,
DIMENSION(1:SIZE,1:SIZE) :: Matrix
INTEGER
:: Number
INTEGER
:: Position
INTEGER
:: i, j
CHARACTER(LEN=100)
:: Format
READ(*,"(I5)")
Number
DO i = 1, Number
READ(*,"(10I5)")
(Matrix(i,j), j =
1, Number)
END DO
WRITE(*,"(1X,A)")
"Input Matrix:"
DO i = 1, Number
WRITE(*,"(1X,10I5)")
(Matrix(i,j), j
= 1, Number)
END DO
WRITE(*,"(/1X,A)") "Upper
Triangular Part:"
Position = 2
DO i = 1, Number
WRITE(Format,"(A,I2.2,A)")
"(T",
Position, ", 10I5)"
WRITE(*,Format)
(Matrix(i,j), j = i,
Number)
Position =
Position + 5
END DO
END PROGRAM
UpperTriangularMatrix
برنامه 5 : چاپ
جدول ضرب
PROGRAM
Multiplication_Table
IMPLICIT
NONE
INTEGER, PARAMETER :: MAX = 9
INTEGER
:: i, j
CHARACTER(LEN=80)
:: FORMAT
FORMAT = "(9(2X, I1, A, I1,
A, I2))"
DO i = 1, MAX
WRITE(*,FORMAT) (i, '*', j, '=', i*j, j = 1, MAX)
END DO
END PROGRAM
Multiplication_Table
برنامه
6 : مرتب کردن داده ها
PROGRAM
Sorting
IMPLICIT
NONE
INTEGER, PARAMETER ::
MAX_SIZE = 100
INTEGER,
DIMENSION(1:MAX_SIZE) :: InputData
INTEGER
:: ActualSize
INTEGER
:: i
READ(*,*)
ActualSize, (InputData(i), i = 1, ActualSize)
WRITE(*,*) "Input Array:"
WRITE(*,*) (InputData(i), i =
1, ActualSize)
CALL
Sort(InputData, ActualSize)
WRITE(*,*)
WRITE(*,*) "Sorted Array:"
WRITE(*,*) (InputData(i), i =
1, ActualSize)
CONTAINS
INTEGER FUNCTION
FindMinimum(x, Start, End)
IMPLICIT NONE
INTEGER,
DIMENSION(1:), INTENT(IN) :: x
INTEGER,
INTENT(IN)
:: Start, End
INTEGER
:: Minimum
INTEGER
:: Location
INTEGER
:: i
Minimum = x(Start)
Location =
Start
DO i =
Start+1, End
IF (x(i) < Minimum) THEN
Minimum = x(i)
Location = i
END IF
END DO
FindMinimum
= Location
END FUNCTION
FindMinimum
SUBROUTINE
Swap(a, b)
IMPLICIT NONE
INTEGER,
INTENT(INOUT) :: a, b
INTEGER
:: Temp
Temp = a
a
= b
b
= Temp
END SUBROUTINE
Swap
SUBROUTINE
Sort(x, Size)
IMPLICIT NONE
INTEGER,
DIMENSION(1:), INTENT(INOUT) :: x
INTEGER,
INTENT(IN)
:: Size
INTEGER
:: i
INTEGER
:: Location
DO i = 1,
Size-1
Location = FindMinimum(x, i, Size)
CALL Swap(x(i), x(Location))
!
END DO
END SUBROUTINE
Sort
END PROGRAM
Sorting
برنامه 7 : محاسبه اعداد آرمسترانگ سه رقمي
PROGRAM
ArmstrongNumber
IMPLICIT
NONE
INTEGER :: a, b, c
INTEGER :: abc, a3b3c3
INTEGER :: Count
Count = 0
DO a = 0, 9
DO b = 0, 9
DO c = 0, 9
abc
= a*100 +
b*10 + c
a3b3c3 = a**3 + b**3 + c**3
IF (abc == a3b3c3) THEN
Count = Count + 1
WRITE(*,*)
'Armstrong number
', Count, ': ', abc
END IF
END DO
END DO
END DO
END PROGRAM
ArmstrongNumber
برنامه 8 : محاسبه تمامي حالات
ايجاد 1000 ريالي توسط واحد هاي پولي
integer
o
open(2,file="c:\1000.txt",status="replace")
write(2,*) "1000 Rls
500 Rls
200 Rls
100 Rls
50 Rls
20 Rls
10 Rls"
write(2,*) "--------
-------
-------
-------
------
------
------"
do 1
ic0,1
!1000 rls
do j=0,2
!500 rls
do 1 k=0,5
!200 rls
do 1 l=0,10
!100 rls
do 1 m=0,20
!50 rls
do 1 n=0,50
!20 rls
do 1 o=0,100
!10 rls
if & (i*1000+j*500+k*200+l*100+m*50+n*20+o*10==1000) then
write(2,30) i,j,k,l,m,n,o
end if
1
continue
30
format (3x,I1,10x,I1,9x,I1,9x,I2,7x,I2,7x,I2,6x,I3)
end
برنامه 9 : محاسبه ماکزيمم و ميني موم اعداد تا زماني که صفر وارد نشده است .
Read
*,A
Nmax=A
; Nmin=A
Do
Read
*,A
Nmax=Max(A,Nmax)
; Nmin=Min(A,Nmin)
IF
(A==0.) Goto 11
End do
11 print *,"Max=",Nmax,"Min=",Nmin
End
|