ضميمه 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