/* EXAMPLE OF I/O STATEMENTS */
GLOBAL
MAIN
CHAR *S = "STRING", *FLNAME = "TDAT.G"
INTEGER A = 234, B = 678
OPEN #1, "DATA.TST", "w"
PRINT #1, "%s %d %d", S, A, B
CLOSE #1
OPEN #1, "DATA.TST", "r"
INPUT #1, "%s %d %d", *S, A, B
CLOSE #1
PRINT "%s %d %d \n", S, A, B
LIST(FLNAME)
END IOEX

FUNCTION LIST(FILENAME)
CHAR *FILENAME
BEGIN
CHAR C
OPEN #4, FILENAME, "r"
WHILE (C = getc(fp4)) <> EOF
putchar(C);
ENDWH
CLOSE#4
END LIST

/* ERATOSTHENES SIEVE */
GLOBAL
CON SIZE 8190
MAIN
INTEGER ITER, COUNT, I, K
INTEGER PRIME, FLAG[8191]
PRINT "10 ITERATIONS \n"
FOR ITER = 1 TO 10
COUNT = 0
FOR I = 0 TO SIZE
FLAG[I] = 1
NEXT I
FOR I = 0 TO SIZE
IF FLAG[I] <> 0
PRIME = I+I+3
K = I + PRIME
WHILE K <= SIZE
FLAG[K] = 0
K = K + PRIME
ENDWH
COUNT++
ENDIF
NEXT I
NEXT ITER
PRINT " %d PRIMES \n", COUNT
END SIEVE

/* EIGHT QUEENS CHESS PROBLEM */
GLOBAL
INTEGER COLFREE[8], X[8]
INTEGER UPFREE[15], DOWNFREE[15]
INTEGER R, K
MAIN
/* INITIALIZE EMPTY BOARD */
FOR K=0 TO 7
COLFREE[K] = TRUE
NEXT K
FOR K=0 TO 14
UPFREE[K] = DOWNFREE[K] = TRUE
NEXT K
R = -1
END QUEEN8

BEGIN
INTEGER C
R++
FOR C=0 TO 7
/* IS SQUARE[R,C] FREE? */
IF COLFREE[C] AND UPFREE[R-C+7] AND DOWNFREE[R+C]
/* SET QUEEN ON SQUARE[R,C] */
X[R] = C
COLFREE[C] = UPFREE[R-C+7] = DOWNFREE[R+C] = FALSE
IF R == 7
PRINT "\n CONFIGURATION \n"
FOR K=0 TO 7
PRINT " %d", X[K]
NEXT K
STOP
ENDIF
/* REMOVE QUEEN FROM SQUARE[R,C)] */
COLFREE[C] = UPFREE[R-C+7] = DOWNFREE[R+C] = TRUE
ENDIF
NEXT C
R--

/* PRODUCT OF TWO MATRICES OF VARIABLE DIMENSIONS */
GLOBAL
CON DLIM 21
MAIN
REAL A[DLIM,DLIM], B[DLIM,DLIM], C[DLIM,DLIM]
INTEGER I,J,K, N1,N2,N3
PRINT "DIMENSIONS = "
INPUT "%d %d %d", N1, N2, N3
/* GENERATE MATRICES */
FOR J=1 TO N2
FOR I=1 TO N1
A[I,J] = (REAL)(J-I)
NEXT I

FOR K=1 TO N3
B[J,K] = (REAL)(J+K)
NEXT K
NEXT J
MATPRI(A,N1,N2)
MATPRI(B,N2,N3)
MULT(A,B,C,N1,N2,N3)
MATPRI(C,N1,N3)
END MAIN

FUNCTION MULT(E,F,G, L1,L2,L3)
REAL E[DLIM,DLIM], F[DLIM,DLIM], G[DLIM,DLIM]
INTEGER L1, L2, L3
BEGIN
INTEGER I,J,K
FOR I=1 TO L1
FOR K=1 TO L3
G[I,K] = 0
FOR J=1 TO L2
G[I,K] = G[I,K]+E[I,J]*F[J,K]
NEXT J
NEXT K
NEXT I
END MULT

FUNCTION MATPRI(A, L1,L2)
REAL A[DLIM,DLIM]; INTEGER L1, L2
BEGIN
INTEGER I,J
PRINT "\n"
FOR I=1 TO L1
FOR J=1 TO L2
PRINT "%8.3f", A[I,J]
NEXT J
PRINT "\n"
NEXT I
END MATPRI

/* EXAMPLE USING CONDITIONAL STATEMENTS */
GLOBAL
MAIN
CHAR *S = "@\$^&*+"
INTEGER I
FOR I=1 TO 5
IF S[I] == '@'
PRINT "@"
ELSE IF S[I] == '+'
PRINT "\$"
ELSE IF S[I] == '^'
PRINT "^"
ELSE
PRINT "NO MATCH"
ENDIF
NEXT I
END CONDIT

/* TOWERS OF HANOI */
GLOBAL
CON NDISK 64
MAIN
MOVE(NDISK, 1, 3, 2)
END HANOI

FUNCTION MOVE(N, A, B, C)
INTEGER N, A, B, C
BEGIN
IF N > 0
MOVE(N-1, A, C, B)
PRINT "MOVE A DISK FROM %d TO %d \n", A, B
MOVE(N-1, C, B, A)
ENDIF
END MOVE

/* INVERSE AND DETERMINANT OF SYMMETRIC MATRIX */
GLOBAL
CON DLIM 31
MAIN
REAL A[DLIM,DLIM],R[DLIM,DLIM],DET,SINV()
INTEGER I,J,ND
PRINT "ND = "
INPUT "%d", ND
/* GENERATE ND X ND MATRIX */
FOR I=1 TO ND
FOR J=1 TO ND
A[I,J]=1.
NEXT J
A[I,I]=2.
NEXT I
MATPRI(A,ND,ND)
DET=SINV(A,R,ND)
MATPRI(R,ND,ND)
PRINT "%10.3f\n", DET
ENDMAIN

REAL FUNCTION SINV(A,R,NN)
REAL A[DLIM,DLIM], R[DLIM,DLIM]
INTEGER NN
BEGIN
REAL VEC[DLIM],DET,RL
INTEGER I,J,K,L
DET=A[1,1]
R[1,1]=1./A[1,1]
FOR L=2 TO NN
K=L-1
RL=A[L,L]
FOR I=1 TO K
VEC[I]=0.
FOR J=1 TO K
VEC[I]=VEC[I]+R[I,J]*A[L,J]
NEXT J
RL=RL-A[L,I]*VEC[I]
NEXT I
DET=DET*RL
FOR I=1 TO K
R[L,I]=-VEC[I]/RL
R[I,L]=R[L,I]
NEXT I
FOR I=1 TO K
FOR J=I TO K
R[I,J]=R[I,J]-VEC[I]*R[L,J]
R[J,I]=R[I,J]
NEXT J
NEXT I
R[L,L]=1./RL
NEXT L
RETURN(DET)
END SINV

/* SHELL-METZNER SORT */
GLOBAL
CON DLIM 101
CON NN 20
MAIN
INTEGER X[DLIM]
/* GENERATE VECTOR */
FOR I=1 TO N
X[I] = N-I+1
NEXT I
PRVEC(X,L)
SZSORT(X,L)
PRVEC(X,L)
END SORT

FUNCTION SZSORT(X,N)
INTEGER X,N
BEGIN
INTEGER KT,TP,I,J, K = 1
WHILE K < N
K = 2*K
ENDWH
K = K/2 - 1
WHILE K >= 1
KT=1
WHILE KT > 0
J = K
KT = 0
FOR I=1 TO N
J++
IF J <= N AND X[I] > X[J]
TP=X[I];X[I]=X[J];X[J]=TP
KT++
ENDIF
NEXT I
ENDWH
K = K/2
ENDWH
END SZSORT

FUNCTION PRVEC(A,LL)
INTEGER A[], LL
BEGIN
INTEGER I
PRINT "\n"
FOR I=1 TO LL
PRINT " %d ", A[I]
NEXT I
PRINT "\n"
RETURN
END PRVEC

/* FIBONACCI NUMBERS */
GLOBAL
MAIN
INTEGER N
PRINT "N = "
INPUT "%d", N
PRINT "FIBON = %d\n", FIB(N)
END FIBNUM

INTEGER FUNCTION FIB(K)
INTEGER K
BEGIN
IF K <= 2
RETURN(1)
ELSE
RETURN(FIB(K-1) + FIB(K-2))
ENDIF
END FIB

/* ZERO OF FUNCTION BY NEWTON'S METHOD */
GLOBAL
MAIN
INTEGER NMAX=20
REAL TOL=1.0E-6, X0, X, NEWT()
X0 = 2
X = NEWT(X0,TOL,NMAX)
PRINT "%f \n", X
END NEWTON

REAL FUNCTION NEWT(X0,TOL,NMAX)
REAL X0,TOL; INTEGER NMAX
BEGIN
REAL FN(), DFN(), fabs(), X, INC
INTEGER I, N
X = X0
FOR I = 1 TO NMAX
INC = -FN(X)/DFN(X)
X = X + INC
IF fabs(INC) < TOL
RETURN(X)
ENDIF
NEXT I
PRINT "NO CONVERGENCE"
STOP
END NEWT

^ÿw