C ------------------------- C PROGRAM HELLO.F C ------------------------- C A KIIRAS FORMATUMA EGY HOLLERITH-KONSTANS: C AZ 5 KARAKTER HOSSZU HELLO SZOVEG 10 FORMAT (5HHELLO) C KIIRJUK A FORMATUMOT ADAT NELKUL :) C (NINCS STRINGKEZELES!) WRITE(*, 10) STOP END

C ------------------------- C PROGRAM MUL.F C ------------------------- C NEGY INTEGER TIPUSU VALTOZO DEKLARACIOJA INTEGER M, N, RES1, RES2 C A KIIRASHOZ HASZNALT FORMATUM 4 HOSSZU C HOLLERITH-KONSTANS AZ M = SZOVEGGEL 10 FORMAT(4HM = ) 11 FORMAT(4HN = ) C A KIIRASHOZ HASZNALT FORMATUM: C CSAK EGY HAROMJEGYU EGESZT IRUNK KI 20 FORMAT(I3) C A KIIRASHOZ HASZNALT FORMATUM: C 6 HOSSZU HOLLERITH-KONSTANS UTAN KIIRUNK C EGY NYOLC HOSSZU EGESZT 30 FORMAT(6HMUL = , I8) 31 FORMAT(6HSUM = , I8) 40 FORMAT(14HWRONG NUMBERS!) C 1 WRITE(*, 10) READ(*, 20) M WRITE(*, 11) READ(*, 20) N IF (M.LT.N) GOTO 2 WRITE(*, 40) GOTO 1 C MEGHIVJUK A MUL ALPROGRAMOT C (EGESZ INTERVALLUM SZORZASA) 2 CALL MUL(M, N, RES1) C MEGHIVJUK A SUMM FUGGVENYT C (EGESZ INGERVALLUM OSSZEGE) RES2 = SUMM(M, N) WRITE(*, 30) RES1 WRITE(*, 31) RES2 C A PROGRAM VEGET ER STOP END C C ------------------------- INTEGER FUNCTION SUMM(MM, MN) C ------------------------- INTEGER MM, MN C SUM = 0 DO 99 I = MM, MN SUM = SUM + I 99 CONTINUE C A FUGGVENY VISSZATER RETURN END C C ------------------------- SUBROUTINE MUL(MM, MN, MRES) C ------------------------- INTEGER MM, MN, MRES C MRES = 1 DO 99 I = MM, MN MRES = MRES * I 99 CONTINUE C AZ ALPROGRAM VISSZATER RETURN END

C ------------------------- C PROGRAM GCD.F C ------------------------- PROGRAM GCD C EGYSZERUBB I/O PRINT *, 'A?' READ *, NA IF (NA.LE.0) THEN PRINT *, 'A LEGYEN POZITIV EGESZ!' STOP END IF PRINT *, 'B?' READ *, NB IF (NB.LE.0) THEN PRINT *, 'B LEGYEN POZITIV EGESZ!' STOP END IF PRINT *, NA, ' ES ', NB, ' LNKO-JA: ', LNKO(NA, NB), '.' STOP END FUNCTION LNKO(NA, NB) IA = NA IB = NB 1 IF (IB.NE.0) THEN ITEMP = IA IA = IB IB = MOD(ITEMP, IB) GOTO 1 END IF NGCD = IA RETURN END

C ------------------------- C PROGRAM VEKTOR.F C FORTRAN 90 C ------------------------- INTEGER I, N, MAXDIM PARAMETER (MAXDIM = 1000) REAL*4 V(MAXDIM) REAL*4 OSSZEG, MAX, MIN, VEKTORNORMA REAL*4 SUM1, MAXVAL1, MINVAL1, NORMA C A FORMAT-BAN KELL MEGADNI A BEOLVASANDÓ / C KIÍRANDÓ ELEMEK FORMÁTUMÁT C AZ 1X AZT JELENTI, HOGY AZ ELEMEK KÖZÉ C NE TEGYEN SZÓKÖZT (2X EGY SZÓKÖZ STB.) 10 WRITE(*,20) 'HANY DIMENZIOS LEGYEN A VEKTOR (MAX. ',MAXDIM,'): ' 20 FORMAT(1X,A,I4,A,$) READ(*,*) N IF ((N .GT. MAXDIM) .OR. (N .LT. 1)) GO TO 10 C CIKLUS GO TO-VAL I = 1 30 WRITE(*,40) I,'. KOORDINATA: ' 40 FORMAT(1X,I4,A,$) READ(*,50) V(I) 50 FORMAT(F7.2) I = I + 1 IF (I .LE. N) GO TO 30 OSSZEG = SUM1(V, N) MAX = MAXVAL1(V, N) MIN = MINVAL1(V, N) C A FENTI HÁROM FÜGGVÉNY SUM, MAXVAL, C MINVAL A FOTRAN90-BEN MÁR MEGTALÁLHATÓK, C (EKVIVALENSEK AZ ALÁBB MEGTALÁLHATÓ C IMPLEMENTÁCIÓKKAL) C A FORDÍTÓ AZONBAN MÁR ITT IS FOGLALT C SZÓNKÉNT KEZELI, NEM LEHET HASZNÁLNI VEKTOR NORMA = NORMA(V, N) C A VEKTORNORMA ÉS VEKTOR NORMA EKVIVALENSEK, C MIVEL A FORDÍTÓ ELTÁVOLT MINDEN SZÓKÖZT WRITE(*,60) 'KOORDINATAOSSZEG:',OSSZEG WRITE(*,60) 'MAXIMALIS KOORDINATA:',MAX WRITE(*,60) 'MINIMALIS KOORDINATA:',MIN WRITE(*,60) 'VEKTORNORMA:',VEKTORNORMA 60 FORMAT(2X,A,F7.2) C UGYANAZT A FORMÁTUMOT TERMÉSZETESEN TÖBB C KIÍRÁS IS HASZNÁLHATJA STOP END C KOORDINÁTAÖSSZEG-(SUM1) C ILYEN RONDA KÓD IS ÍRHATÓ, MIVEL A FORDÍTÓ C AZZAL KEZD, HOGY KISZED MINDEN SZÓKÖZT C AZ ALÁBBI KÓDRÉSZLET AZ ALATTA KOMMENTBEN C TALÁLHATÓ "SZÉP" KÓDDAL EKVIVALENS. REAL*4FUNCTIONSUM1(VEKT, DIM) IMPLICITNONE;INTEGERI,DIM;REAL*4OSSZEG,VEKT(DIM) C REAL*4 FUNCTION SUM1(VEKT, DIM) C IMPLICIT NONE C INTEGER I, DIM C REAL*4 OSSZEG, VEKT(DIM) OSSZEG = 0 C EZ A DO MÁR A FORTRAN90-BOL ÚJÍTÁS, NINCS C LEZÁRÓ END DO DO 10 I = 1, DIM 10 OSSZEG = OSSZEG + VEKT(I) SUM1 = OSSZEG RETURN END C MAXIMÁLIS-KOORDINÁTA REAL*4 FUNCTION MAXVAL1(VEKT, DIM) IMPLICIT NONE INTEGER I, DIM REAL*4 MAX ,VEKT(DIM) MAX = -9999.99 C MIVEL A KOORDINÁTÁK F7.2 ALAKÚAK C (-9999.99 ... 9999.99) DO 10 I = 1, DIM 10 IF (VEKT(I) .GT. MAX) MAX = VEKT(I) MAXVAL1 = MAX RETURN END C MINIMÁLIS-KOORDINÁTA REAL*4 FUNCTION MINVAL1(VEKT, DIM) IMPLICIT NONE INTEGER I, DIM REAL*4 MIN ,VEKT(DIM) MIN = 9999.99 DO 10 I = 1, DIM 10 IF (VEKT(I) .LT. MIN) MIN = VEKT(I) MINVAL1 = MIN RETURN END C A-VEKTOR-NORMÁJA REAL*4 FUNCTION NORMA(VEKT, DIM) IMPLICIT NONE INTEGER I, DIM REAL*4 OSSZEG ,VEKT(DIM) OSSZEG = 0 DO 10 I = 1, DIM 10 OSSZEG = OSSZEG + VEKT(I)*VEKT(I) OSSZEG = SQRT(OSSZEG) NORMA = OSSZEG RETURN END

C ------------------------- C PROGRAM TRIANGLE2.F C ------------------------- C HAROMSZOG TERULETE HERON KEPLETTEL 501 FORMAT(I5,I5,I5) 601 FORMAT(4H A= ,I5,4H B= ,I5,4H C= ,I5,4H T= ,F10.2) 602 FORMAT(4HVEGE) 603 FORMAT(10HINPUT HIBA) INTEGER A,B,C 10 READ(*,501,END=50,ERR=90) A,B,C IF(A.EQ.0 .OR. B.EQ.0 .OR. C.EQ.0) GO TO 90 S = (A + B + C) / 2.0 AREA = SQRT( S * (S - A) * (S - B) * (S - C)) WRITE(*,601) A,B,C,AREA GO TO 10 50 WRITE(*,602) STOP 90 WRITE(*,603) STOP END

C ------------------------- C PROGRAM RENDEZES.F C ------------------------- C RENDEZENDO TÖMB EGÉSZEKKEL FELTÖLTVE INTEGER I(9) DATA I/12,23,11,8,45,2,56,17,6/ CALL RENDEZ(9,I) END C RENDEZO SZUBRUTIN C X TÖMB, N AZ ELEMSZÁMA, HEAP: A KUPAC TÖMBJE SUBROUTINE RENDEZ (N, X) INTEGER N, J INTEGER X(*) INTEGER HEAP(N) CALL KIIR(N,X) C HEAP KIALAKITASA DO 21 I=1, N HEAP(I)=X(I) CALL INSHEAP(I,HEAP) 21 CONTINUE CALL KIIR(N,HEAP) C HEAP SORT C A HEAP ELSO ELEME A MAXIMUM, KIVESSZÜK, ÉS A JOBB-ALSÓ ELEMET C AZ ELSO HELYRE RAKJUK, MAJD SULLYESZTJÜK DO 22 I=1, N X(I)=HEAP(1) HEAP(1)=HEAP(N-I+1) HEAP(N-I+1)=0 CALL SULYESZT(N,HEAP) CALL KIIR(N,HEAP) 22 CONTINUE CALL KIIR(N,X) END C a CSÚCSON LÉVO ELEMET HELYÉRE SÜLLYESZTO SZUBRUTIN SUBROUTINE SULYESZT(N, X) INTEGER N, I, J, SWAP INTEGER X(*) C AZ I=1 HELYROL INDITJUK A SÜLLYESZTÉST I=1 C HA 2 GYEREKE VAN AZ ADOTT CSÚCSNAK 51 IF ((I*2+1).LE.N) THEN C HA VAN NAGYOBB GYEREKE AKKOR A NAGYOBBIKKAL CSERELUNK C MAJD FOLYTATJUK A SULLYESZTEST IF (( X(2*I).GT.X(I) ).OR.( X(2*I+1).GT.X(I) )) THEN IF (X(2*I).GT.X(2*I+1)) THEN J=2*I ELSE J=2*I+1 ENDIF SWAP=X(I) X(I)=X(J) X(J)=SWAP I=J ELSE RETURN ENDIF C HA 1 GYEREKE VAN AZ ADOTT CSÚCSNAK ÉS AZ NAGYOBB C AKKOR CSERÉLÜNK ÉS FOLYTATJUK A SÜLLYESZTÉST ELSEIF (((I*2).EQ.N).AND.(X(I*2).GT.X(I))) THEN SWAP=X(I*2) X(I*2)=X(I) X(I)=SWAP I=I*2 ELSE RETURN ENDIF GOTO 51 END C HEAP-BE ÚJ ELEMET HELYEZO ELJÁRÁS C A HEAP VÉGÉROL INDITJUK AZ ÚJ ELEMET C MAJD ADDIG VISSZIK FÖLFELÉ AMIG A HELYÉRE NEM KERÜL SUBROUTINE INSHEAP(M, X) INTEGER N, M, SWAP INTEGER X(*) N=M 41 IF (N.EQ.1) RETURN IF (X(N).GT.X(N/2)) THEN SWAP=X(N/2) X(N/2)=X(N) X(N)=SWAP N=N/2 GOTO 41 ENDIF RETURN END SUBROUTINE KIIR (N, X) INTEGER N INTEGER X(*) 31 FORMAT (I5) 32 FORMAT (4HVEGE) DO 30 I=1, N WRITE (*, 31) X(I) 30 CONTINUE WRITE (*,32) RETURN END

C -------------- C PROGRAM DIJK.F C -------------- C A DEKLARALT VALTOZOKAT INTEGER DIST, PAR C KOZOSSE TESSZUK, ES TOMBNEK DIMENZIONALJUK COMMON /PUBLIC/ DIST(100), PAR(100) INTEGER STACK, SSIZE COMMON /STACK/ STACK(100), SSIZE C INTEGER Y, T, S INTEGER I, J C I/O FORMATUMOK 10 FORMAT(5HPATH:) 20 FORMAT(19HMINIMAL DISTANCE = , I3) 30 FORMAT(4HS = ) 40 FORMAT(4HT = ) 50 FORMAT(1H>, I1) 60 FORMAT(1H ) 70 FORMAT(I1) C WRITE(*, 30) READ(*, 70) S WRITE(*, 40) READ(*, 70) T C ELJARASHIVAS CALL DIJKSTRA(S) C WRITE(*, 60) WRITE(*, 20) DIST(T) WRITE(*, 60) WRITE(*, 10) I = T 1 IF (I.EQ.0) GOTO 2 CALL PUSH(I) I = PAR(I) GOTO 1 2 IF (SSIZE.EQ.0) GOTO 3 CALL POP(J) WRITE(*, 50) J GOTO 2 C 3 STOP END C C ---------------------- SUBROUTINE DIJKSTRA(X) C ---------------------- INTEGER X INTEGER S, U, V, E INTEGER I C INTEGER DIST, PAR COMMON /PUBLIC/ DIST(100), PAR(100) INTEGER NHOOD, EDGES COMMON /GRAPH/ NHOOD(100,100), EDGES(100, 100) INTEGER INDEX, HEAP, HSIZE COMMON /HEAP/ INDEX(100), HEAP(100), HSIZE C S = X C CALL PUT(S,0) 1 IF(HSIZE.EQ.0) RETURN CALL DELMIN(U) I = 1 2 V = NHOOD(U,I) E = EDGES(U,I) IF (V.EQ.0) GOTO 1 IF (INDEX(V).EQ.-2) GOTO 6 IF (INDEX(V).EQ.-1) GOTO 3 GOTO 4 3 CALL PUT(V, DIST(U)+E) PAR(V) = U GOTO 6 4 IF(DIST(V).GT.DIST(U)+E) GOTO 5 GOTO 6 5 CALL KEYDEC(V, DIST(U)+E) PAR(V) = U 6 I = I + 1 GOTO 2 C VISSZATERES ALPROGRAMBOL RETURN END C C ------------------- SUBROUTINE PUT(X,Y) C ------------------- INTEGER X, Y INTEGER PARENT C INTEGER DIST, PAR COMMON /PUBLIC/ DIST(100), PAR(100) INTEGER INDEX, HEAP, HSIZE COMMON /HEAP/ INDEX(100), HEAP(100), HSIZE C IF (INDEX(X).NE.-1) RETURN C HSIZE = HSIZE + 1 DIST(X) = Y HEAP(HSIZE) = X INDEX(X) = HSIZE C 1 PARENT = INDEX(X)/2 IF (PARENT.EQ.0) RETURN IF (DIST(HEAP(PARENT)).LE.DIST(X)) RETURN CALL CHANGE(INDEX(X), PARENT) GOTO 1 C RETURN END C C -------------------- SUBROUTINE DELMIN(X) C -------------------- INTEGER X, PARENT, CHILD C INTEGER DIST, PAR COMMON /PUBLIC/ DIST(100), PAR(100) INTEGER INDEX, HEAP, HSIZE COMMON /HEAP/ INDEX(100), HEAP(100), HSIZE C IF (HSIZE.GT.0) GOTO 1 X = -1 RETURN C 1 X = HEAP(1) INDEX(HEAP(1)) = -2 HSIZE = HSIZE - 1 IF (HSIZE.EQ.0) RETURN HEAP(1) = HEAP(HSIZE+1) C PARENT = 1 2 IF ((2*PARENT).GT.HSIZE) RETURN CHILD = 2*PARENT IF ((2*PARENT).LT.HSIZE) GOTO 3 GOTO 4 3 IF (DIST(HEAP(2*PARENT)).GT.DIST(HEAP(2*PARENT+1))) - CHILD = 2*PARENT+1 4 IF (DIST(HEAP(CHILD)).GE.DIST(HEAP(PARENT))) RETURN CALL CHANGE(CHILD, PARENT) PARENT = CHILD GOTO 2 C RETURN END C C ---------------------- SUBROUTINE KEYDEC(X,Y) C ---------------------- INTEGER X, Y, PARENT C INTEGER DIST, PAR COMMON /PUBLIC/ DIST(100), PAR(100) INTEGER INDEX, HEAP, HSIZE COMMON /HEAP/ INDEX(100), HEAP(100), HSIZE C IF (INDEX(X).LT.1) RETURN IF (Y.GE.DIST(X)) RETURN C DIST(X) = Y IF (INDEX(X).EQ.1) RETURN 1 PARENT = INDEX(X)/2 IF (DIST(HEAP(PARENT)).LE.DIST(X)) RETURN CALL CHANGE(INDEX(X), PARENT) GOTO 1 C RETURN END C C ---------------------- SUBROUTINE CHANGE(X,Y) C ---------------------- INTEGER X, Y INTEGER X2, Y2, TMP C INTEGER INDEX, HEAP, HSIZE COMMON /HEAP/ INDEX(100), HEAP(100), HSIZE C IF (X.LT.1.OR.Y.LT.1.OR.X.GT.HSIZE.OR.Y.GT.HSIZE.OR.X.EQ.Y) - RETURN C X2 = X Y2 = Y TMP = HEAP(X2) INDEX(HEAP(X2)) = Y2 INDEX(HEAP(Y2)) = X2 HEAP(X2) = HEAP(Y2) HEAP(Y2) = TMP C RETURN END C C ------------------ SUBROUTINE PUSH(X) C ------------------ INTEGER X C INTEGER STACK, SSIZE COMMON /STACK/ STACK(100), SSIZE C IF (SSIZE.EQ.100) RETURN C SSIZE = SSIZE + 1 STACK(SSIZE) = X C RETURN END C C ----------------- SUBROUTINE POP(X) C ----------------- INTEGER X C INTEGER STACK, SSIZE COMMON /STACK/ STACK(100), SSIZE C IF (SSIZE.EQ.0) RETURN C X = STACK(SSIZE) SSIZE = SSIZE - 1 C RETURN END C C ---------- BLOCK DATA C ---------- INTEGER DIST, PAR COMMON /PUBLIC/ DIST(100), PAR(100) INTEGER NHOOD, EDGES COMMON /GRAPH/ NHOOD(100,100), EDGES(100, 100) INTEGER INDEX, HEAP, HSIZE COMMON /HEAP/ INDEX(100), HEAP(100), HSIZE INTEGER STACK, SSIZE COMMON /STACK/ STACK(100), SSIZE C DATA SSIZE /0/ DATA HSIZE /0/ C DATA INDEX(1) /-1/ DATA INDEX(2) /-1/ DATA INDEX(3) /-1/ DATA INDEX(4) /-1/ DATA INDEX(5) /-1/ DATA INDEX(6) /-1/ DATA INDEX(7) /-1/ C DATA PAR(1) /0/ DATA PAR(2) /0/ DATA PAR(3) /0/ DATA PAR(4) /0/ DATA PAR(5) /0/ DATA PAR(6) /0/ DATA PAR(7) /0/ C DATA NHOOD(1,1) /2/ DATA NHOOD(1,2) /3/ DATA NHOOD(1,3) /7/ DATA NHOOD(1,4) /0/ C DATA NHOOD(2,1) /1/ DATA NHOOD(2,2) /3/ DATA NHOOD(2,3) /0/ C DATA NHOOD(3,1) /1/ DATA NHOOD(3,2) /2/ DATA NHOOD(3,3) /4/ DATA NHOOD(3,4) /7/ DATA NHOOD(3,5) /0/ C DATA NHOOD(4,1) /3/ DATA NHOOD(4,2) /5/ DATA NHOOD(4,3) /0/ C DATA NHOOD(5,1) /4/ DATA NHOOD(5,2) /6/ DATA NHOOD(5,3) /7/ DATA NHOOD(5,4) /0/ C DATA NHOOD(6,1) /5/ DATA NHOOD(6,2) /7/ DATA NHOOD(6,3) /0/ C DATA NHOOD(7,1) /1/ DATA NHOOD(7,2) /3/ DATA NHOOD(7,3) /5/ DATA NHOOD(7,4) /6/ DATA NHOOD(7,5) /0/ C DATA EDGES(1,1) /3/ DATA EDGES(1,2) /4/ DATA EDGES(1,3) /1/ C DATA EDGES(2,1) /3/ DATA EDGES(2,2) /2/ C DATA EDGES(3,1) /4/ DATA EDGES(3,2) /2/ DATA EDGES(3,3) /2/ DATA EDGES(3,4) /2/ C DATA EDGES(4,1) /2/ DATA EDGES(4,2) /5/ C DATA EDGES(5,1) /5/ DATA EDGES(5,2) /1/ DATA EDGES(5,3) /4/ C DATA EDGES(6,1) /1/ DATA EDGES(6,2) /2/ C DATA EDGES(7,1) /1/ DATA EDGES(7,2) /2/ DATA EDGES(7,3) /4/ DATA EDGES(7,4) /2/ C END

C 2009. PETER CSIZSEK. PROGRAMMING LANGUAGES 4. SEMINAR. C =================================================== C THIS PROGRAM IS A DEMONSTRATION OF THE K-MEANS CLUSTERING ALGORITHM. PROGRAM K_MEANS C VARIABLE DECLARATIONS. REAL CENTERS(1:100,1:100), POINTS(1:100,1:10000) INTEGER OWNERS(1:10000) INTEGER N, K, M CHARACTER * (80) FILENAME INTEGER IARGC INTEGER NARGS CHARACTER * (80) OPT C THE COMMONLY-USED DATA AMONG THE SUBPROGRAMS. COMMON /DAT/ CENTERS, POINTS COMMON /OWN/ OWNERS COMMON /PAR/ N, K, M COMMON /FNAME/ FILENAME C SET PARAMETERS. N = 5 K = 20 M = 200 C CHECK THE NUMBER OF THE COMMAND-LINE ARGUMENTS. WRITE(*, 9010) 'CHECKING COMMAND-LINE ARGUMENTS.' NARGS = IARGC() IF(NARGS .NE. 2) THEN WRITE(*, 9010) 'ERROR:' WRITE(*, 9010) 'THE PROGRAM HAS TO BE CALLED WITH EXACTLY TWO COMM /AND-LINE ARGUMENTS:' WRITE(*, 9010) '- THE OPTION (''GEN'' = GENERATE RANDOM DATA / ''S /OL'' = SOLVE PROBLEM).' WRITE(*, 9010) '- THE FILE NAME (OUTPUT FILE NAME FOR GENERATING D /ATA / INPUT FILE NAME FOR SOLVING PROBLEM).' GOTO 10 ENDIF C THE FIRST ARGUMENT HAS TO BE 'GEN' OR 'SOL'. CALL GETARG(1, OPT) IF(OPT .NE. 'GEN' .AND. OPT .NE. 'SOL') THEN WRITE(*, 9010) 'ERROR:' WRITE(*, 9010) 'THE OPTION MUST BE ONE OF THE FOLLOWING:' WRITE(*, 9010) '-''GEN'' (GENERATE RANDOM DATA).' WRITE(*, 9010) '-''SOL'' (SOLVE PROBLEM).' GOTO 10 ENDIF C THIS ARGUMENT IS THE FILE NAME. CALL GETARG(2, FILENAME) WRITE(*, 9020) 'OK' IF(OPT .EQ. 'GEN') THEN WRITE(*, 9010) 'GENERATING RANDOM DATA WITH PARAMETERS: ' WRITE(*, 9030) 'N: ', N WRITE(*, 9030) 'K: ', K WRITE(*, 9030) 'M: ', M CALL GENERATE WRITE(*, 9040) 'SUCCESFULLY GENERATED DATA. EXITING.' ELSE WRITE(*, 9010) 'SOLVING PROBLEM WITH PARAMETERS: ' WRITE(*, 9030) 'N: ', N WRITE(*, 9030) 'K: ', K WRITE(*, 9030) 'M: ', M CALL SOLVE WRITE(*, 9040) 'SUCCESFULLY SOLVED THE PROBLEM. EXITING.' ENDIF 9010 FORMAT(A) 9020 FORMAT(5X, A) 9030 FORMAT(5X, A, I5) 9040 FORMAT(A, A) 10 STOP END C =================================================== C THIS SUBROUTINE GENERATES A RANDOM PROBLEM INTO A FILE. SUBROUTINE GENERATE REAL RAND CHARACTER * (80) FILENAME INTEGER N, K, M INTEGER * 4 TARRAY(3), I, J COMMON /FNAME/ FILENAME COMMON /PAR/ N, K, M C INITIATE RANDOM GENERATOR. WRITE(*, 9110) 'INITIATING RANDOM GENERATOR.' CALL ITIME(TARRAY) I = RAND(TARRAY(1) + TARRAY(2) + TARRAY(3)) WRITE(*, 9120) 'OK' C OPEN OUTPUT FILE TO WRITE. WRITE(*, 9140) 'OPENING FILE TO WRITE: ', FILENAME OPEN(10, FILE = FILENAME, STATUS = 'NEW') WRITE(*, 9120) 'OK' C GENERATE DATA. WRITE(*, 9110) 'WRITING DATA TO FILE.' DO 20 J = 1, N * (K + M) WRITE(10, *) RAND(0) 20 CONTINUE WRITE(*, 9120) 'OK' C CLOSE FILE. WRITE(*, 9140) 'CLOSING FILE: ', FILENAME CLOSE(10) WRITE(*, 9120) 'OK' 9110 FORMAT(A) 9120 FORMAT(5X, A) 9140 FORMAT(A, A) RETURN END C =================================================== C THIS SUBROUTINE LOADS THE PROBLEM INTO THE COMMON DATA FROM A FILE. SUBROUTINE LOAD CHARACTER * (80) FILENAME INTEGER N, K, M, I, J REAL CENTERS(1:100,1:100), POINTS(1:100,1:10000) COMMON /FNAME/ FILENAME COMMON /PAR/ N, K, M COMMON /DAT/ CENTERS, POINTS C OPEN INPUT FILE TO READ FROM. WRITE(*, 9240) 'OPENING FILE TO READ FROM: ', FILENAME OPEN(11, FILE = FILENAME, STATUS = 'OLD') WRITE(*, 9220) 'OK' WRITE(*, 9210) 'LOADING DATA FROM FILE.' C LOAD CENTROIDS. DO 30 I = 1, K DO 40 J = 1, N READ(11, *) CENTERS(J, I) 40 CONTINUE 30 CONTINUE C LOAD POINTS. DO 50 I = 1, M DO 60 J = 1, N READ(11, *) POINTS(J, I) 60 CONTINUE 50 CONTINUE WRITE(*, 9220) 'OK' C CLOSE FILE. WRITE(*, 9240) 'CLOSING FILE: ', FILENAME CLOSE(11) WRITE(*, 9220) 'OK' 9210 FORMAT(A) 9220 FORMAT(5X, A) 9240 FORMAT(A, A) RETURN END C =================================================== C THIS SUBROUTINE SOLVES THE PROBLEM THAT IS LOADED INTO THE COMMON DATA. SUBROUTINE SOLVE LOGICAL CHANGED CALL LOAD CALL SETOWNERS(CHANGED) CALL PSTATE 150 CONTINUE IF(CHANGED) THEN CALL MOVEALL CALL SETOWNERS(CHANGED) CALL PSTATE GOTO 150 ENDIF 100 RETURN END C =================================================== C THIS SUBROUTINE DETERMINES THE OWNER OF ALL POINTS AND SETS L TRUE IF C THERE WAS ANY CHANGE. SUBROUTINE SETOWNERS(L) INTEGER I, N, K, M, TMP, OWNER INTEGER OWNERS(1:10000) LOGICAL L COMMON /PAR/ N, K, M COMMON /OWN/ OWNERS L = .FALSE. DO 90 I = 1, M TMP = OWNER(I) IF(OWNERS(I) .NE. TMP) THEN OWNERS(I) = TMP L = .TRUE. ENDIF 90 CONTINUE RETURN END C =================================================== C THIS FUNCTION RETURNS THE OWNER OF A GIVEN POINT. INTEGER FUNCTION OWNER(P) INTEGER OWNERS(1:10000) INTEGER IDX, I, N, K, M REAL MINV,MINP, DIST, TMP COMMON /PAR/ N, K, M COMMON /OWN/ OWNERS MINP = 1 MINV = DIST(P,1) DO 80 I = 2, K TMP = DIST(P, I) IF(TMP .LT. MINV) THEN MINP = I MINV = TMP ENDIF 80 CONTINUE OWNER = MINP RETURN END C =================================================== C THIS FUNCTION RETURNS THE DISTANCE OF A GIVEN POINT AND A GIVEN CENTROID. REAL FUNCTION DIST(P, C) INTEGER P, C, I, N, K, M REAL S REAL CENTERS(1:100,1:100), POINTS(1:100,1:10000) COMMON /PAR/ N, K, M COMMON /DAT/ CENTERS, POINTS S = 0 DO 70 I = 1, N S = S + (POINTS(I, P) - CENTERS(I, C)) ** 2 70 CONTINUE DIST = SQRT(S) RETURN END C =================================================== C THIS SUBROUTINE MOVES THE CENTROIDS TO THE APPROPRIATE POSITIONS. SUBROUTINE MOVEALL INTEGER I, N, K, M COMMON /PAR/ N, K, M DO 110 I = 1, K CALL MOVE(I) 110 CONTINUE RETURN END C =================================================== C THIS SUBROUTINE MOVES A GIVEN CENTROID TO THE APPROPRIATE POSITION. SUBROUTINE MOVE(C) INTEGER C, I, N, K, M REAL CENTERS(1:100,1:100), POINTS(1:100,1:10000) COMMON /PAR/ N, K, M COMMON /DAT/ CENTERS, POINTS DO 120 I = 1, N CENTERS(I,C) = PAVG(C, I) 120 CONTINUE RETURN END C =================================================== C THIS FUNCTION RETURNS THE AVERAGE OF THE I. COORDINATES OF THE POINTS C BELONGING TO THE C. CENTROID. REAL FUNCTION PAVG(C, I) INTEGER OWNERS(1:10000) REAL CENTERS(1:100,1:100), POINTS(1:100,1:10000) REAL S INTEGER C, I, J, CNT, N, K, M COMMON /PAR/ N, K, M COMMON /DAT/ CENTERS, POINTS COMMON /OWN/ OWNERS S = 0 CNT = 0 DO 130 J = 1, M IF(OWNERS(J) .EQ. C) THEN S = S + POINTS(I, J) CNT = CNT + 1 ENDIF 130 CONTINUE PAVG = S / CNT RETURN END C =================================================== C THIS SUBROUTINE PRINTS THE STATE OF THE SYSTEM. SUBROUTINE PSTATE INTEGER OWNERS(1:10000) REAL CENTERS(1:100,1:100), POINTS(1:100,1:10000) INTEGER I, J, N, K, M COMMON /PAR/ N, K, M COMMON /DAT/ CENTERS, POINTS COMMON /OWN/ OWNERS WRITE(*, 9310) 'SYSTEM STATE:' WRITE(*, 9320) 'CENTROIDS:' DO 140 I = 1, K WRITE(*, 9330) 'CENTROID: ', I DO 150 J = 1, N WRITE(*, 9340) CENTERS(J,I) 150 CONTINUE 140 CONTINUE WRITE(*, 9320) 'POINTS:' DO 160 I = 1, M WRITE(*, 9330) 'POINT: ', I WRITE(*, *) 'OWNER: ', OWNERS(I) DO 170 J = 1, N WRITE(*, 9340) POINTS(J,I) 170 CONTINUE 160 CONTINUE 9310 FORMAT(A) 9320 FORMAT(5X,A) 9330 FORMAT(10X,A,I3) 9340 FORMAT(15X,F10.5) 9350 FORMAT(15X,A,I10) RETURN END C ===================================================

PROGRAM testg !----------------------------------------------------------- ! A kövektkező program egy lineáris egyenletrendszert old meg ! Gauss-Jordan módszerrel, teljes főelem kiválasztással ! külső modul és osztály használata !----------------------------------------------------------- USE Gauss_Jordan USE Permutation INTEGER IMAX,JMAX PARAMETER(IMAX=3,JMAX=4) !PARAMETER(IMAX=10,JMAX=11) ! tömb deklalárása REAL matrix(IMAX, JMAX) ! ugyanez vektorra REAL ismeretlen(IMAX) ! egész számok INTEGER i, index, n ! tömb feltöltése oszloponként DATA matrix(:,:) / 2.0, -1.0, 3.0, & 3.0, 2.0, 0.0, & 0.0, -1.0, 2.0, & 8.0, 0.0, 9.0/ n = IMAX ! matrix = 0.0 ! do 10, i =1, n ! matrix(i,i) = 1 ! matrix(i,n+1) = i ! 10 continue write(*,*) "Az eredeti matrix,",n," X ",n+1," :" ! szubrutin hívás call wrtmat(matrix, n) call ELIMINATION(matrix, n) write(*,*) "A felso haromszog-matrix:" call wrtmat(matrix, n) call VISSZHELY(matrix, ismeretlen, n) write(*,*) "A megoldas visszahelyettesites utan:" write(*,*) "********************************************" write(*,*) (ismeretlen(i), i=1,n) write(*,*) "********************************************" end MODULE Gauss_Jordan !--------------------------------------------- ! Ez a modul három szubrutint tartalmaz: ! 1. wrtmat(matrix, n) ! 2. ELIMINATION(A, n) ! 3. VISSZHELY(A, x, n) !--------------------------------------------- USE Permutation IMPLICIT NONE CONTAINS ! szubrutin definiálása SUBROUTINE wrtmat(matrix, n) ! paraméterek típusa INTEGER i,j,n REAL matrix(n, n+1) do 10, i=1, n ! belső do-ra egy példa write(*,*) (matrix(i,j), j= 1,n+1) 10 continue write(*,*) end subroutine wrtmat SUBROUTINE ELIMINATION(A, n) INTEGER n, i, j, k, u, v, maxi, maxj, tc REAL A(n, n+1), tempsor(n+1), temposzlop(n) i = 1 j = 1 call permut_init(n) ! iterácio fortranban do while (i <= n .and. j <= n) ! Főelem kiválasztása az i. sortól és j. oszloptól maxi = i maxj= j do k=i,n do u=j,n if (abs(A(k,u)) > abs(A(maxi,maxj))) then maxi = k maxj = u end if end do end do if (A(maxi,maxj) .ne. 0) then ! Az i. és a főelemet tartalmazó sor cseréje-vektor műveletek !$OMP WORKSHARE ! blokk kiosztása a szálak között tempsor = A(i, :) A(i, :) = A(maxi, :) A(maxi, :) = tempsor !$OMP END WORKSHARE write(*,*) "Az", i, ". es a foelemet tartalmazo (", maxi, ") sor csereje" call wrtmat(A, n) ! A j. és a főelemet tartalmazó oszlop cseréje !$OMP WORKSHARE temposzlop = A(:,j) A(:,j) = A(:,maxj) A(:,maxj) = temposzlop !$OMP END WORKSHARE call permut_csere(j, maxj) write(*,*) "Az", j, ". es a foelemet tartalmazo (", maxj, ") oszlop csereje" call wrtmat(A, n) ! Az i. sort elosztjuk a főelemmel A(i, :) = A(i, :) / A(i,j) write(*,*) "Az", i, ". sort elosztjuk a foelemmel" call wrtmat(A,n) ! A főelem A(i, j) = 1 ! A j. oszlop eliminálása !$OMP DO SCHEDULE(STATIC,1) do u=i+1,n A(u, j+1:) = A(u, j+1:) - A(i, j+1:) * A(u,j) enddo !$OMP END DO A(i+1:,j) = 0 write(*,*) "Az", j, ". oszlop eliminalasa!" call wrtmat(A, n) i = i+1 else write(*,*) "Szingularis matrix: nincs inverz!" stop end if j = j+1 end do end subroutine ELIMINATION SUBROUTINE VISSZHELY(A, x, n) INTEGER n, i, j REAL A(n, n+1), x(n), sum !$OMP PARALLEL do i=n,1,-1 ! belső függvény- skaláris szorzat ! bágyazott szálak létrehozása !$OMP PARALLEL sum = dot_product(A(i,i+1:n), x(i+1:n)) !$OMP END PARALLEL x(i) = A(i, n+1) - sum/A(i, i) enddo !$OMP END PARALLEL ! Az eredeti sorrend az oszlopcseréket figyelembe véve call permut_vector(x) end subroutine VISSZHELY end module gauss_jordan MODULE Permutation IMPLICIT NONE INTEGER, PRIVATE, ALLOCATABLE :: permutacio(:) INTEGER, PRIVATE :: n CONTAINS SUBROUTINE permut_init(quantity) INTEGER, INTENT(IN) :: quantity INTEGER i ALLOCATE (permutacio(quantity)) n = quantity DO 10,i=1,n permutacio(i) = i 10 CONTINUE END SUBROUTINE permut_init SUBROUTINE permut_csere(i,j) INTEGER, INTENT(IN) :: i, j INTEGER temp, k temp = permutacio(i) permutacio(i) = permutacio(j) permutacio(j) = temp do 10, k=1,n ! write(*,*) "permutacio(", k,")=", permutacio(k) 10 continue END SUBROUTINE permut_csere SUBROUTINE permut_vector(x) REAL, INTENT(OUT) :: x(n) REAL :: temp(n) INTEGER i DO 10, i=1,n temp(i) = x(permutacio(i)) 10 continue x(:) = temp(:) END SUBROUTINE permut_vector END module Permutation

PROGRAM harmadfoku IMPLICIT NONE DOUBLE PRECISION a1, b1, c1, d1 !A bemeno egyutthatok DOUBLE PRECISION a, b, c !A lenormalt egyutthatok DOUBLE PRECISION a2, b2, theta !segedvaltozok COMPLEX q, r !Segedvaltozok COMPLEX x1, x2, x3 !Gyokok DOUBLE PRECISION pi !A pi szam pi=3.1415926535897932 WRITE(*,*) 'Valos egyutthatos harmadfoku egyenlet megoldasa.' WRITE(*,*) 'Adja meg az egyenlet egyutthatoit,' WRITE(*,*) 'es megadom az adott egyutthatoju egyenlet megoldasait.' WRITE(*,*) 'Kerem x**3 egyutthatojat:' READ(*,*) a1 IF (a1 .NE. 0) THEN WRITE(*,*) 'Kerem x**2 egyutthatojat:' READ(*,*) b1 WRITE(*,*) 'Kerem x egyutthatojat:' READ(*,*) c1 WRITE(*,*) 'Kerem a konstans tagot:' READ(*,*) d1 !Az egyenlet egyutthatoinak atszamitasa, hogy a foegyutthato 1 legyen a=b1/a1 b=c1/a1 c=d1/a1 !Segedvaltozok q=(a**2-3*b)/9 r=(2*a**3-9*a*b+27*c)/54 IF ((real(r)**2) .LT. (real(q)**3)) THEN !Casus irreducibilis, a valos gyokok csak komplex szamolassal erhetok el WRITE(*,*) 'Az egyenletnek harom kulonbozo valos gyoke van.' theta=acos(real(r)/(sqrt((real(q))**3))) !A komplex gyokvonasnak megfeleloen harom gyok adodik x1=-2.0*sqrt(q)*cos(theta/3)-a/3 x2=-2.0*sqrt(q)*cos((theta+2*pi)/3)-a/3 x3=-2.0*sqrt(q)*cos((theta-2*pi)/3)-a/3 ELSE !Casus reducibilis, egy valos es ket konjugalt komplex gyok a2=0 IF (real(r) .LT. 0) THEN a2=(abs(r)+sqrt(r**2-q**3))**(1.0/3) ELSE a2=-1*(abs(r)+sqrt(r**2-q**3))**(1.0/3) ENDIF b2=0 IF (a2 .NE. 0) THEN b2=q/a2 ENDIF !A valos gyok x1=(a2+b2)-a/3 !A komplex gyokok x2=cmplx((-1.0/2)*(a2+b2)-a/3, sqrt(3.0)/2*(a2-b2)) x3=cmplx((-1.0/2)*(a2+b2)-a/3, -1*sqrt(3.0)/2*(a2-b2)) ENDIF WRITE(*,*) 'Az ', a1, b1, c1, d1, ' egyutthatos harmadfoku egyenlet gyokei' WRITE(*,*) 'x1 = ', x1 WRITE(*,*) 'x2 = ', x2 WRITE(*,*) 'x3 = ', x3 ELSE WRITE(*,*) 'Az egyenlet nem harmadfoku.' ENDIF STOP END PROGRAM

! ************************************************************************ ! Fájl: QRAlg.f08 ! Leírás: QR felbontás és QR módszer mátrix sajátértékeinek meghatározására ! ************************************************************************ program QRAlg implicit none ! Rövid főprogram amely teszt adatokon futtatja a QR módszer algoritmusát double precision, dimension(4,4) :: A,eig double precision :: eps = 0.00001 ! epsilon a megengedett hiba ! Az A 4x4-es mátrix, elemei oszlopfolytonosan megadva A = reshape( [2.0, 2.0, 0.0, 0.0, 1.0, 3.0, 0.0, 0.0, -1.0, 1.0, 4.0, -1.0, 1.0, -2.0, 2.0, 1.0], shape(A) ) ! eig egy 4x4-es felsőháromszögmátrix, ! a diagonálisában a számított sajátértékekkel eig = qr_method(A, eps) ! Input és az eredmény kiíratása call print_matrix(A) print *, '--------------------------' call print_matrix(eig) ! A lényegi munkát végző függvények contains ! ******************************************************** ! Egy adott mátrix QR felbontását készíti el ! Input: A = négyzetes valós elemű mátrix ! Output: Q,R = négyzetes valós mátrixok, ! A = Q*R, Q ortogonális, R felsőháromszög mátrix ! A megvalósítás Gram-Schmidt ortogonalizációval történik ! Segédfüggvények: normalize(), projection() ! ******************************************************** subroutine qr_decomposition(A,Q,R) implicit none double precision, intent(in), dimension(:,:) :: A double precision, intent(out), dimension(:,:) :: Q,R ! segédváltozó, az A n x n-es esetén egy n hosszú vektor double precision, dimension(size(A,1)) :: sum_proj integer :: n,k,j n = size(A,1) ! mátrix mérete ! Elég csupán a Q mátrixot elkészíteni, az R utána szorzással megkapható ! Az algoritmus inicializálása, az input mátrix első oszlopát normalizáljuk ! Megjegyzés: A(1:n,1) syntaxis: array slice, A első oszlopát adja Q(1:n,1) = normalize(A(1:n,1)) ! A ciklusban Q további oszlopait ortogonalizáljuk minden előzőre do k=2,n ! Gram-Schmidt féle projekciók elkészítése és összegzése sum_proj = 0.0 do j=1,k-1 ! A k. lépésben az eredeti mátrix k. oszlopát vetítjük a már meglévőkre sum_proj = sum_proj + projection(vector=A(1:n,k),project_to=Q(1:n,j)) end do ! A vetítések összegét levonva az eredeti vektorból, ! egy az összes a rendszerben őt megelőzőre merőleges vektort kapunk, ! majd az elkészült új oszlopot normalizáljuk Q(1:n, k) = normalize(A(1:n, k) - sum_proj) end do ! R = Q'*A, a két intrinsic a transzponálást és mátrixszorzást végzi R = matmul(transpose(Q), A) end subroutine qr_decomposition ! ******************************************************** ! Merőleges vetület számítása ! Input: vector = n hosszú valós vektor, amit vetítünk ! project_to, ugyanakkora méretű vektor, amire vetítünk ! Result: vetület vektor ! ******************************************************** function projection(vector, project_to) implicit none double precision, intent(in), dimension(:) :: vector, project_to double precision, dimension(size(vector)) :: projection ! proj a on b = a dot b/ a dot a * a ! a vetület vektor tehát két skalár szorzat hányadosa * a vektor amire vetítünk projection = dot_product(project_to, vector)/dot_product(project_to, project_to) * project_to end function projection ! ******************************************************** ! Vektor normalizálása (2-es normában) ! Input: vector, n hosszú valós vektor ! Result: a normalizált vektor ! ******************************************************** function normalize(vector) implicit none double precision, intent(in), dimension(:) :: vector double precision, dimension(size(vector)) :: normalize ! A vektort elosztjuk a hosszával, vagyis sqrt() - vel normalize = vector / sqrt(dot_product(vector, vector)) end function normalize ! ******************************************************** ! Mátrix sajátértékeinek meghatározása QR módszerrel ! Input: matrix, négyzetes valós mátrix ! eps: numerikus hibakorlát ! Result: R felsőháromszög mátrix, ! ami a sajátértékeket a diagonálisában tartalmazza ! X(k+1) = R(k) * Q(k) k=1,2,... az iteráció ! segédfüggvény: qr_decomposition(),check_convergence() ! ******************************************************** function qr_method(matrix, eps) implicit none double precision, intent(in), dimension(:,:) :: matrix double precision, dimension(size(matrix,1),size(matrix,2)) :: qr_method double precision, intent(in) :: eps double precision, dimension(size(matrix,1),size(matrix,2)) :: Q,R,eigenvalues ! inicializáljuk az algoritmust eigenvalues = matrix ! A fő iterációs ciklus do while ( check_convergence(eigenvalues, eps) .eqv. .false. ) ! Előállítjuk a QR felbontást, call qr_decomposition(eigenvalues, Q,R) ! majd fordított sorrendben szorozzuk őket össze eigenvalues = matmul(R,Q) end do qr_method = eigenvalues end function qr_method ! ******************************************************** ! A QR módszer segéd függvénye a konvergencia ellenőrzésére ! Input: matrix: négyzetes valós mátrix ! eps: a numerikus hibakorlát ! ******************************************************** function check_convergence(matrix, eps) implicit none logical :: check_convergence double precision, intent(in), dimension(:,:) :: matrix double precision, intent(in) :: eps double precision :: max_err integer :: n,i,j n = size(matrix,1) ! A mátrixnak felsőháromszög mátrixhoz kell tartania, ! vagyis az alsóháromszög beli elemeknek 0-hoz kell tartania ! Megkeressük az alsóháromszög rész abszolútértékben maximális elemét max_err = 0.0 do i=2,n do j=1,i-1 if ( abs(matrix(i,j)) > max_err ) then max_err = abs(matrix(i,j)) end if end do end do ! Ha a maximális hiba kisebb mint epsilon akkor ok if ( max_err < eps ) then check_convergence = .true. else check_convergence = .false. end if end function check_convergence ! Egyszerű kiírató segédfüggvény, a mátrixot soronként írja ki subroutine print_matrix(matrix) implicit none double precision, dimension(:,:) :: matrix integer :: i,j,n,m n = size(matrix,1) m = size(matrix,2) do i=1,n print *, ( matrix(i,j), j=1,m ) end do end subroutine print_matrix end program QRAlg

C Verme típus szimulációs program FORTRAN 77-ben C Készítette: Kuthi Balázs C Használt fordítóprogram: fort77 PROGRAM VEREM INTEGER BE C Szimulációhoz szükséges menü kiiratása 1 WRITE (*,*) "---------------------------------" WRITE (*,*) "Verem muveletek tesztelese" WRITE (*,*) "1. Ures-e a verem" WRITE (*,*) "2. Legfelso elem lekerdezese" WRITE (*,*) "3. Elem felvetele" WRITE (*,*) "4. Legfelso elem eltavolitasa" WRITE (*,*) "5. Verem tartalmának megtekintése" WRITE (*,*) "6. Kilepes" WRITE (*,*) "Kivalasztott muvelet: " C Választott művelet beolvasása READ (*,*) BE C Felhasználó választásának megfelelő művelet végrehajtása IF (BE .EQ. 1) THEN IF (ISEMPTY()) THEN WRITE (*,*) "A verem ures." ELSE WRITE (*,*) "A verem nem ures." END IF GOTO 1 ELSE IF (BE .EQ. 2) THEN IF (ISEMPTY()) THEN WRITE (*,*) "A veremben nincsenek elemek." ELSE 20 FORMAT(1x, 'A verem legfelso eleme: ', I3) WRITE (*,20) TOP() END IF GOTO 1 ELSE IF (BE .EQ. 3) THEN WRITE (*,*) "Kerem a felveendo elemet: " READ (*,*) BE IF((BE .GE. 100) .OR. (BE .LE. -100)) THEN WRITE(*,*) "Az adat nem -100 és 100 között van" GOTO 1 END IF CALL PUSH(BE) GOTO 1 ELSE IF (BE .EQ. 4) THEN IF (.NOT. ISEMPTY()) THEN 30 FORMAT(1x, 'A verem legfelso eleme eltavoltiva: ', I3) WRITE (*,30) POP() ELSE WRITE (*,*) "A veremben nincsenek elemek." END IF GOTO 1 ELSE IF (BE .EQ. 5) THEN CALL WRITESTACK() GOTO 1 ELSE IF (BE .NE. 6) THEN WRITE (*,*) "Nem megfeleo input." GOTO 1 END IF STOP END C Közös használatú adatok (verem szimulálása egy tömbbel valamint egy elemszámmal) BLOCK DATA INTEGER STACK(100), COUNT COMMON /STACK/ STACK, COUNT DATA STACK/100*0/, COUNT/0/ END C Üres-e a tömb LOGICAL FUNCTION ISEMPTY() INTEGER STACK(100), COUNT COMMON /STACK/ STACK, COUNT IF (COUNT .EQ. 0) THEN ISEMPTY = .TRUE. ELSE ISEMPTY = .FALSE. END IF RETURN END C Legfelső elem lekérdezése INTEGER FUNCTION TOP() INTEGER STACK(100), COUNT COMMON /STACK/ STACK, COUNT TOP = STACK(COUNT) RETURN END C Elem felvétele a tömbbe SUBROUTINE PUSH(A) INTEGER STACK(100), COUNT COMMON /STACK/ STACK, COUNT INTEGER A IF(COUNT .LT. 100) THEN STACK(COUNT + 1) = A COUNT = COUNT + 1 ELSE WRITE (*,*) "A verem betelt." END IF RETURN END C Legfeső elem eltávolítása (ezt az elemet visszaadjuk) INTEGER FUNCTION POP() INTEGER STACK(100), COUNT COMMON /STACK/ STACK, COUNT POP = STACK(COUNT) COUNT = COUNT - 1 RETURN END C Verem tartalmának kiiratása SUBROUTINE WRITESTACK() INTEGER STACK(100), COUNT COMMON /STACK/ STACK, COUNT WRITE(*,*) "A verem tartalma:" DO 100 I=COUNT, 1, -1 WRITE(*,40) COUNT-I+1, STACK(I) 40 FORMAT(1x, I3, ".: ", I3) 100 CONTINUE RETURN END

program miner c Author: Zsolt Turi c E-mail: tuzraai at inf.elte.hu c Date: 2013.05.15. c c Description: The classic minesweeper game written in fortran c c 'mines(i,j)' stores how many adjacent mines, 9 if it is a mine c 'visible(i,j)' stores is the field visible for the user c 'maxn' is the size of the minefield c 'mineCount' is the number of mines hidden c 'state' is an enum: 0 playing, 1 lost, 2 won c TODO: randomize the mines c TODO: make colors if possible c initial definitions implicit none integer maxn, mineCount parameter (maxn=8) parameter (mineCount=5) integer mines(maxn,maxn) logical visible(maxn,maxn) integer x,y, state, remains state = 0 remains = maxn*maxn-mineCount call init(mines, visible, maxn, mineCount) call draw(mines, visible, maxn) 50 call getPoint(x,y,maxn) write(*,200) x,y call reveal(mines, visible, maxn, x, y, state, remains) call draw(mines, visible, maxn) if (state .eq. 1) go to 250 if (state .eq. 2) go to 280 go to 50 200 format (i3,i3) 250 call showall(visible, maxn) call draw(mines, visible, maxn) call gameOver() goto 300 280 call showall(visible, maxn) call draw(mines, visible, maxn) call winner() 300 end c-------------------------------------- c the 2nd version of reveal, to make recursion c NOTE: recursion is not allowed to oneself subroutine reveal2(mines, visible, n, x, y, state, remains) implicit none integer i,j,n,x,y, state, remains integer mines(n,n) logical visible(n,n) call reveal(mines, visible, n, x, y, state, remains) end c-------------------------------------- c reveals a field (x,y) on the minefield subroutine reveal(mines, visible, n, x, y, state, remains) implicit none integer i,j,n,x,y, state, remains integer mines(n,n) logical visible(n,n) if(.not.(((x .gt. 0) .and. (x .le. n)) .and. 1 ((y .gt. 0) .and. (y .le. n)))) go to 1700 if(visible(x,y)) go to 1700 visible (x,y) = .true. remains = remains - 1 if (mines(x,y) .eq. 9) then state = 1 else if (remains .lt. 1) then state = 2 else if (mines(x,y) .eq. 0) then call reveal2(mines, visible, n, x-1, y, state, remains) call reveal2(mines, visible, n, x+1, y, state, remains) call reveal2(mines, visible, n, x, y-1, state, remains) call reveal2(mines, visible, n, x, y+1, state, remains) endif 1700 end c-------------------------------------- c writes the winning caption to the screen subroutine winner() write (*,1750) '' write (*,1750) '' write (*,1750) 'CONGRATULATION!' write (*,1750) 'You won the GAME!' write (*,1750) '' write (*,1750) '' 1750 format(a) end c-------------------------------------- c writes the losing caption to the screen subroutine gameOver() write (*,1780) '' write (*,1780) '' write (*,1780) 'BOOOOOM!' write (*,1780) 'GAME OVER!' write (*,1780) '' write (*,1780) '' 1780 format(a) end c-------------------------------------- c asks for a coordinate from the user subroutine getPoint(x,y,n) implicit none integer x,y,n,i 1800 write (*, 1810) 'Adj meg egy sort es egy oszlopot! Pl.:34' read (*, 1820) x,y if(((x .gt. 0) .and. (x .le. n)) .and. ((y .gt. 0) .and. (y .le. n))) go to 1850 go to 1800; 1810 format(a) 1820 format(i1,i1) 1850 end c-------------------------------------- c draws the minefield to the console subroutine draw(mines, visible, n) implicit none integer i,j,n integer mines(n,n) logical visible(n,n) write(*,1930) write(*,1950) ' 1 2 3 4 5 6 7 8' write(*,1950) 'o----------------' do 1910 i=1,n write(*,1940) i,'|' do 1900 j=1,n if (visible(i,j)) then if (mines(i,j) .ne. 9) then if (mines(i,j) .ne. 0) then write(*,1920) mines(i,j) else write(*,1921) ' ' end if else write(*,1921) 'X' end if else write(*,1921) '?' end if 1900 continue write(*,1930) 1910 continue write(*,1930) 1920 format(i2,$) 1921 format(1x,a,$) 1930 format(1x) 1940 format(1x,i2,a,$) 1950 format(3x,a) end c-------------------------------------- c initialises the minefield subroutine init(m, v, n, mc) implicit none integer i,j,n,mc,s,x,y integer m(n,n) logical v(n,n) do 2000 i=1,n do 2000 j=1,n m(i,j) = 0 v(i,j) = .false. 2000 continue do 2050 i=1,mc 2030 x = int(rand(0)*n+1) y = int(rand(0)*n+1) if (m(x,y) .eq. 9) go to 2030 m(x,y)=9 2050 continue do 2100 i=1,n do 2100 j=1,n if (m(i,j) .ne. 9) then call near(m,n,i,j,s) m(i,j) = s end if 2100 continue end c-------------------------------------- c show the whole field subroutine showall(v, n) implicit none integer i,j,n logical v(n,n) do 2200 i=1,n do 2200 j=1,n v(i,j) = .true. 2200 continue end c-------------------------------------- c computes how many mines are in the nearest fields subroutine near(m,n,i,j,s) implicit none integer n,i,j integer m(n,n) integer s s = 0 if(i .gt. 0)then if(j .gt. 0)then if(m(i-1,j-1) .eq. 9) s = s + 1 end if if(m(i-1,j ) .eq. 9) s = s + 1 if(j .lt. n)then if(m(i-1,j+1) .eq. 9) s = s + 1 end if end if if(j .gt. 0)then if(m(i ,j-1) .eq. 9) s = s + 1 end if if(j .lt. n)then if(m(i ,j+1) .eq. 9) s = s + 1 end if if(i .lt. n)then if(j .gt. 0)then if(m(i+1,j-1) .eq. 9) s = s + 1 end if if(m(i+1,j ) .eq. 9) s = s + 1 if(j .lt. n)then if(m(i+1,j+1) .eq. 9) s = s + 1 end if end if end c--------------------------------------

c egy dama jatek, ahol nincs uteskenyszer, sem utessorozat az alap babuk: o,x c a dama babuk: O,X ; a tabla 8x8 as, lepni a sor oszlop indexek megadasaval c pl. E2 F3, kilepni a programbol az EX paranccsal lehet program draughts implicit none character table(8, 8) logical pl_o, piece_ok, valid_index, move_ok character*2 in_from, in_to character c integer fr,fc,tr,tc,player_lose,letter_to_int call build_table(table) c a o jatekos kezd pl_o = .true. c elvalaszto karakterek, atlathatosag miatt, (A10)--> formatum 600 write(*, "(A10)") "==========" c a tabla kriajzolasa call print_table(table) c kiirom ki lep if (pl_o) then c /: uj sor karakter write(*, "(A5/)") "o lep" else write(*, "(A5/)") "x lep" end if 601 print *, "Adja meg honnan lep (pl. E2)" print *, "Kilepes: EX parancs" read (*, *) in_from c ha ex et irt be kilepek a programbol(, ugorj a 900 as cimkehez) if(in_from .eq. "ex")then goto 900 end if c fr,fc be beolvasom melyik oszlop, sor lett megadva fr = letter_to_int(in_from(2:2)) fc = letter_to_int(in_from(1:1)) c ellenorzom, hogy 1-8 kozott vannak e az indexek if(.not.valid_index(fr,fc)) then goto 601 end if c a mezon o vagy x kell hogy legyen, jatekostol fuggoen c = table(fr, fc) if(.not.piece_ok(c, pl_o)) then c ha nem, akkor ujra bekeram a mezoket goto 601 end if print *, "Adja meg hova lep (pl. F3)" read (*, *) in_to c ha ex et irt be kilepek if(in_to .eq. "ex")then goto 900 end if c tr, tc-be beolvasom melyik oszlop, sor lett megadva tr = letter_to_int(in_to(2:2)) tc = letter_to_int(in_to(1:1)) c ellenorzom, hogy 1-8 kozott vannak e az indexek if(.not.valid_index(tr,tc)) then goto 601 end if c legalis-e a lepes if(.not.move_ok(fr,fc, + tr,tc,c,pl_o,table,.true.)) then goto 601 end if c ha legalis a lepes, lepek table(fr,fc) = "_" table(tr,tc) = c c a masik jatekos fog jonni pl_o = .not.pl_o c megnezem beert e valaki az ellenfel alapvonalara, ha igen dama lesz call cr_dames(table) c megnezem vesztett-e valaki, ha nem visszamegyek az elejere if (player_lose(table) .eq. 0) then goto 600 else if(player_lose(table) .eq. 1) then print *, "jatek vege, x nyert" else if(player_lose(table) .eq. 2) then print *, "jatek vege, 0 nyert" end if 900 end program draughts c a table kiirasa subroutine print_table(table) character table(8, 8) do i=1,8 c kiirom a sor szamat c I1: 1 hosszu integer, $: ne tegyen be uj sor karaktert a vegen write(*, "(I1, A1$)") i," " do j=1,8 c kiirom a sorban levo babukat write(*, "(A1$)") table(i, j) end do print *, "" end do c /: uj sor karakter, a10: 10 hosszu karakterlanc write(*, "(/A10)") " ABCDEFGH" write(*, "(A10)") "==========" end subroutine print_table c c pl_o-tol fuggoen, o,O vagy x,X kell legyen? logical function piece_ok(c, pl_o) implicit none character c logical pl_o c ha az o jatekos van soron, akkor o,O egyebkent x,X if(pl_o .and. c.ne.'o' .and. c.ne.'O') then print *, "hiba:nincs babuja az adott indexen" piece_ok = .false. else if(.not.pl_o .and. c.ne.'x' .and. c.ne.'X') then print *, "hiba:nincs babuja az adott indexen" piece_ok = .false. else piece_ok = .true. end if end function piece_ok c melyik jatekos vesztett 0: egyik sem, 1: o vesztett, 2: x vesztett c osszeszamolom a babuk szamat a tablan integer function player_lose(table) character table(8, 8) integer o_num, x_num o_num = 0 x_num = 0 do i=1,8 do j=1,8 if (table(i, j) .eq. 'o' .or. + table(i, j) .eq. 'O') then o_num = o_num + 1 else if (table(i, j) .eq. 'x' .or. + table(i, j) .eq. 'X') then x_num = x_num + 1 end if end do end do c ha 0 darab o van, akkor o vesztett if(0 .eq. o_num )then player_lose = 1 c ha 0 darab x van akkor x vesztett else if (0 .eq. x_num) then player_lose = 2 else c egyebkent megy tovabb a jatek player_lose = 0 end if end function player_lose c lephet-e a babu ebbe az iranyba logical function move_ok(fr,fc,tr,tc,c,pl_o,table,mod) implicit none character table(8, 8) integer fr, fc, tr, tc integer r_d, c_d, mr, mc character c logical pl_o, mod, piece_ok c r_d: honnan sor indexe - hova sor indexe r_d = fr - tr c_d = fc - tc c mr: a leutendo babu sorindexe mr = fr-1*sign(1,r_d) mc = fc-1*sign(1,c_d) c ha nem dama a babu, akkor megnezem hogy visszafele lepett-e if(pl_o.and.c.eq.'o'.and.r_d.le.0) then move_ok = .false. print *, "hiba: csak damaval lehet visszafele lepni" return else if(.not.pl_o.and.c.eq.'x'.and.r_d.ge.0) then move_ok = .false. print *, "hiba: csak damaval lehet visszafele lepni" return end if c atlosan lepett-e 1-et if(abs(r_d).eq.1.and.abs(c_d).eq.1) then c van e ott valaki, ha van akkor nem legalis if(table(tr,tc).ne."_") then move_ok = .false. print *, "hiba: van babu az adott mezon" return else move_ok = .true. return end if end if c atlosan leptett- 2-t if(abs(r_d).eq.2.and.abs(c_d).eq.2) then c ha igen akkor van-e ott valaki if(table(tr,tc).ne."_") then move_ok = .false. print *, "hiba: van babu az adott mezon" return else c ha nincs senki akkor van-e ellenfel akit tudok utni if(piece_ok(table(mr,mc),.not.pl_o)) then move_ok = .true. c ha van, es a modositas engedelyezett: leutom if(mod) then table(mr,mc) = "_" end if return else move_ok = .false. print *, "hiba: nincs ellenfel" return end if end if end if c egyéb esetben nem legalis a lepes print *, "hiba: unkown" move_ok = .false. end function move_ok c a megadott sor, oszlop indexek megfeleloek-e: [1, 8] kozottiek logical function valid_index(r, c) integer r, c if (1 .gt. r .or. 8 .lt. r .or. + 1 .gt. c .or. 8 .lt. c) then valid_index = .false. print *, "hiba:nem jo indexeket adott meg" else valid_index = .true. end if end function valid_index c betu index szam indexxe konvertalasa integer function letter_to_int(letter) character letter select case(letter) case ('a') letter_to_int = 1 case ('b') letter_to_int = 2 case ('c') letter_to_int = 3 case ('d') letter_to_int = 4 case ('e') letter_to_int = 5 case ('f') letter_to_int = 6 case ('g') letter_to_int = 7 case ('h') letter_to_int = 8 case ('A') letter_to_int = 1 case ('B') letter_to_int = 2 case ('C') letter_to_int = 3 case ('D') letter_to_int = 4 case ('E') letter_to_int = 5 case ('F') letter_to_int = 6 case ('G') letter_to_int = 7 case ('H') letter_to_int = 8 case ('1') letter_to_int = 1 case ('2') letter_to_int = 2 case ('3') letter_to_int = 3 case ('4') letter_to_int = 4 case ('5') letter_to_int = 5 case ('6') letter_to_int = 6 case ('7') letter_to_int = 7 case ('8') letter_to_int = 8 case default letter_to_int = 0 end select end function letter_to_int c kezdo tabla letrehozasa subroutine build_table(table) character table(8, 8) do i=1,8 do j=1,8 if(4 .GT. i .AND. 0 .EQ. modulo(i+j, 2)) then table(i, j) = 'x' else if(5 .LT. i + .AND. 0 .EQ. modulo(i+j, 2) ) then table(i, j) = 'o' else table(i, j) = '_' endif end do end do end subroutine build_table c ha egy babu atert a tuloldalra, ezert dama lesz subroutine cr_dames(table) character table(8, 8) do i=1,8 if(table(1,i) .eq. "o") then table(1,i) = "O" end if if(table(8,i) .eq. "x") then table(8,i) = "X" end if end do end subroutine cr_dames