# VAN WIJNGAARDEN S PENTOMINO PROGRAMMA IN ALGOL68 # 'BEGIN''INT' AANTAL:= 0, VANAF, [1 : 160] 'INT' VELD; 'FOR' K 'TO' 159 'DO' VELD[K]:= 13 'OD'; VELD[160]:= 0; 'FOR' K 'TO' 6 'DO''FOR' J 'FROM' K 'BY' 10 'TO' K + 90 'DO' VELD[J]:= 0 'OD''OD'; 'FOR' K 'FROM' 7 'BY' 10 'TO' 87 'DO' VELD[K]:= 204 'OD'; VELD[97]:= 263; [1 : 12, 0 : 3] 'INT' STANDEN; STANDEN[1 : 12, 0 : 3]:= ((0,0,0,1), (0,1,2,4), (0,1,1,2), (0,1,3,4), (0,1,1,4), (0,1,2,4), (0,1,2,4), (0,2,4,8), (0,2,2,8), (0,2,4,8), (0,1,6,8), (0,1,2,8)); [1 : 12, 1 : 8, 1 : 4] 'INT' VORMEN; VORMEN[1,1, ]:= (9, 11, 20, 10); VORMEN[2, 1 : 4, ]:= ((2, 12, 22, 1), (2, 20, 1, 10), (18, 19, 20, 10), (20, 21, 22, 10)); VORMEN[3, 1 : 2, ]:= ((2, 3, 4, 1), (20, 30, 40, 10)); 'FOR' K 'FROM' 4 'TO' 7 'DO' VORMEN[K, 1 : 4, ]:= 'CASE' K - 3 'IN' ((11,20,21,1), (20,21,1,10), (2, 12, 1,10), (2,11,12,10)), ((2,11,21,1), (8,9,20,10), (19,20,21,10), (11, 12,20,10)), ((11,12,22,1), (9,19,1,10), (11,21,22,10), (9,18,19,10)), ((11,21,22,1), (19,20,1,10), (8,9,18,10), (11,12,22,10)) 'ESAC' 'OD'; 'FOR' K 'FROM' 8 'TO' 12 'DO' VORMEN[K, , ]:= ( K - 7 ! ((11,21,31,1), (2,3,13,1), (2,3,1,10), (20,30,1,10), (20,30,31,10), (7,8,9,10), (20,29,30,10), (11,12,13,10)), ((2,3,11,1), (2,3,12,1), (9,20,30,10), (8,9,11,10), (20,21,30,10), (11,20,30,10), (19,20,30,10), (9,11,12,10)), ((11,12,13,1), (2, 12,13,1), (2,9,1,10), (8,9,1,10), (19,20,29,10), (9,19,29,10), (20,21,31,10), (11,21,31,10)), ((2,11,12,1), (11,20,1,10), (11,12,1,10), (11,21,1,10), (9,11,1,10), (2,11,1,10), (9,19,20,10), (11,20,21,10)), ((11,12,21,1), (9,20,1,10), (9,11,21,10), (11,19,20,10), (9,11,19,10), (11,12,21,10), (8,9,19,10), (9,20,21,10)) ) 'OD'; #BEPERK STANDEN VAN HET V-STUK # STANDEN[2, 0 : 3]:= (1,1,2,2); [1 : 12] 'BOOL' GEBRUIKT; 'FOR' K 'TO' 12 'DO' GEBRUIKT[K]:= 'FALSE' 'OD'; 'REAL' TIJD:= CLOCK; 'PROC' OUTP = 'VOID' : PRINTF(($L 10(L 6( X C("X","V","I","U","T","W","Z","L","Y","N","P","F"))), 3X"OPLOSSING NR :" 4ZD2X, "NA"X 10ZD.3D2X "SEC." L$, VELD[1 : 6], VELD[11 : 16], VELD[21 : 26], VELD[31 : 36], VELD[41 : 46], VELD[51 : 56], VELD[61 : 66], VELD[71 : 76], VELD[81 : 86], VELD[91 : 96], AANTAL +:= 1, CLOCK - TIJD) ) # END OF PROC OUTP #; 'PROC' ZET = ('INT' VRIJ, 'REF' [ ] 'INT' ELD) 'VOID' : 'IF' 'INT' LOW := (ELD[1] = 0 ! 0 ! 2), UP := (ELD[10] = 0 ! 3 ! 1 ); LOW < UP 'THEN' 'FOR' STUK 'TO' 12 'DO' 'IF' 'NOT' GEBRUIKT[STUK] 'THEN' GEBRUIKT[STUK]:= 'TRUE'; ELD[0]:= STUK; 'FOR' STAND 'FROM' STANDEN[STUK,LOW] + 1 'TO' STANDEN[STUK,UP] 'DO' 'REF' [ ] 'INT' VORM := VORMEN[STUK, STAND, ]; 'FOR' K 'TO' 4 'DO' ( ELD[VORM[K]] /= 0 ! OUT) 'OD'; 'FOR' K 'TO' 4 'DO' ELD[VORM[K]]:= STUK 'OD'; VANAF:= 1; 'WHILE' ELD[VANAF] /= 0 'DO' VANAF +:= ( ELD[VANAF] > 200 ! ELD[VANAF] - 200 ! 1) 'OD'; VANAF +:= VRIJ; 'IF' VANAF = 160 'THEN' OUTP 'ELSE' ZET(VANAF, VELD[VANAF : 'AT' 0]) 'FI'; 'FOR' K 'TO' 4 'DO' ELD[VORM[K]]:= 0 'OD'; OUT : 'SKIP' 'OD'; ELD[0]:= 0; GEBRUIKT[STUK]:= 'FALSE' 'FI' 'OD' 'FI' # END OF PROC ZET # ; ZET(1, VELD[1 : 'AT' 0]) 'END' # THIS PARTICULAR PROGRAM SOLVES PENTOMINO 6 BY 10 # ################################################################################ 'BEGIN' 'FOR' N'FROM' 2 'TO' 100 'DO' 'INT' M= ENTIER(1/(1-EXP(-LOG(2)/N) )); 'REAL' D= (2*M+5)/(M+1)*EXP(N*LN((M+2)/(M+1)))-4; 'IF' D>=0 'THEN' PRINT((N,M,"VERSCHIL ",D,NEWLINE))'FI' 'OD' 'END' ################################################################################ 'BEGIN' 'INT' I,J; 'WHILE' I/=0'DO' 'READ(J);I:=0;PRINT((J,NEWLINE)); 'WHILE' J/=0 'DO' ('INT'K=J;J'OVERAB'2;K=2*J!I*:=2;PRINT("0")!I*:=2+:=1;PRINT("1") ) 'OD' PRINT((NEWLINE,I,NEWLINE) ) 'OD' 'END' ################################################################################ 'BEGIN' # JKOK, 740606, TEST PROC SAMEN. SAMEN BEREKENT ( ... ((X1 @ X2) @ X3) @ ... @ XN-1) @ XN, WAARIN XI DE DOOR WAT GELEVERDE LIJST DATA-ITEMS EN @ DE IN HOE GEDEFINIEERDE DYADISCHE OPERATIE # 'PROC' SAMEN = ('PROC' ('REF''REAL', 'REAL') 'VOID' HOE, 'PROC' ('PROC' ('REAL') 'VOID') 'VOID' WAT ) 'REAL' : 'BEGIN''BOOL' START := 'TRUE', 'REAL' STUK := 0; WAT( ('REAL' XI) 'VOID' : ( START ! START:= 'FALSE'; STUK:= XI ! HOE(STUK, XI) ) ); STUK 'END' # END OF SAMEN #, 'PROC' TEL OP = ('REF''INT' I, 'INT' A, B, 'PROC''REAL' XI) 'REAL' : SAMEN( ('REF''REAL' A, 'REAL' B) 'VOID' : A +:= B, ('PROC' ('REAL') 'VOID' ITEM) 'VOID' : 'FOR' II 'FROM' A 'TO' B 'DO' I:= II; ITEM(XI) 'OD' ) # END OF TEL OP #; 'FOR' N 'TO' 10 'DO' 'INT' I; PRINT( TEL OP(I, 1, N, 'REAL' : I * I)) 'OD' 'END' ################################################################################ 'BEGIN' # JKOK, 740507. IS MAN OR BOY ZO CORRECT IN ALGOL68 OVERGEZET (VRAAGTEKEN) # 'PROC' A = ('INT' K, 'PROC''INT' X1, X2, X3, X4, X5) 'INT' : 'BEGIN''INT' KK:= K; 'PROC' B = 'INT' : A(KK -:= 1, B, X1, X2, X3, X4) # END OF B #; 'IF' KK < 1 'THEN' X4 + X5 'ELSE' B 'FI' 'END' # END OF A #; PRINT( A(6, 'INT' : 1, 'INT' : 2, 'INT' : 3, 'INT' : 4, 'INT' : 5) ) 'END' 'PR' STOP 'PR' ################################################################################ 'BEGIN' #JKOK, 740621, LANGSTE DAG-PROGRAMMA # 'INT' N:= 16; [1 : N] 'INT' INF:= (0,1,2,3,0,0,0,4,0,5,6,7,0,0,0,8), WZR:= (-1,8,2,4,-1,-1,-1,3,-1,16,11,11,-1,-1,-1,2); 'BEGIN' 'MODE' 'INFC' = 'STRUCT' ('REF''INT' INFORMATIE, VERWIJZER); 'INT' K:= 0, [1 : N] 'INT' V; 'FOR' I 'TO' N 'DO' (WZR[I] /= - 1 ! K+:= 1 ) 'OD'; [1 : K] 'INFC' INFCEL; K:= 0; 'FOR' I 'TO' N 'DO' V[I]:= 'IF' WZR[I] /= -1 'THEN' INFORMATIE 'OF' INFCEL[ K +:= 1 ] := INF[I]; VERWIJZER 'OF' INFCEL[K] := WZR[I]; K 'ELSE' -1 'FI' 'OD'; 'FOR' I 'TO' K 'DO' 'INT' LOC:= VERWIJZER 'OF' INFCEL[I]; 'REF''INT' ( VERWIJZER 'OF' INFCEL[I] ):= - 1; INF[I]:= INFORMATIE 'OF' INFCEL[I]; WZR[I]:= V[LOC] 'OD' 'END' # OF PROGRAM TO REPLACE CELLS #; 'FOR' I 'TO' N 'DO' PRINT(INF[I]); PRINT(WZR[I]); PRINT(NEWLINE) 'OD' 'END' ################################################################################ TEST2:( # P.W.HEMKER: ALGOL 68 VERSIE VAN ELEM.PROCS. DEC,SOL,DET # # VERSION: 23/07/75 # 'PRIO' ** = 8, 'MAX' = 1, 'MIN' = 1, <= = 1, <> = 1; 'PROC' TRAP = 'VOID' : (PRINT((NEWLINE,"PROGAM TRAPPED BY NUMERICAL ERROR", NEWLINE,"ARRITHMETIC ERROR SIMULATED")); ('REAL' A:= 1/0; A:= 1/A; STOP) ); 'OP' 'MAX' = ('INT' A,B) 'INT': (A>B!A!B); 'OP' 'MIN' = ('INT' A,B) 'INT': (A = ( 'REF' [ ]'REAL' A,B) 'BOOL': 'IF' A :=: B 'THEN' 'FALSE' 'ELSE' 'FOR' I 'FROM' 'LWB' A 'MAX' 'LWB' B 'TO' 'UPB' A 'MIN' 'UPB' B 'DO' 'REF' 'REAL' X=A[I],Y=B[I]; 'REAL' S=X; X:=Y; Y:=S 'OD'; 'TRUE' 'FI'; 'PROC' DEC=('REF'[,]'REAL' X ) 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU): 'IF' 'INT' N = 1'UPB'X - 1'LWB'X + 1; N /= 2'UPB'X - 2'LWB'X + 1 'THEN' PRINT(( NEWLINE,"ERROR: DEC WAS CALLED WITH NON-SQUARE MATRIX", NEWLINE,"1'UPB'X 1'LWB'X 2'UPB'X 2'LWB'X WERE:", NEWLINE, 1'UPB'X , 1'LWB'X , 2'UPB'X , 2'LWB'X )); TRAP; 'SKIP' 'ELSE' 'REF' [,] 'REAL' A = 'HEAP'[1:N,1:N] 'REAL':= X; 'REF' [ ] 'INT' P = 'HEAP'[1:N] 'INT'; [1:N]'REAL' V; 'FOR' I 'TO' N 'DO' V[I]:= SQRT(A[I,1:N]**A[I,1:N]) 'OD'; 'FOR' K 'TO' N 'DO' 'REF' 'INT' PK = P[K]; 'INT' K1 = K-1; 'REAL' S,R:= -1; 'FOR' I 'FROM' K 'TO' N 'DO' 'IF' (S:= 'ABS' ( A[I,K] -:= A[I,1:K1]**A[1:K1,K]) / V[I] ) > R 'THEN' R:= S; PK:= I 'FI' 'OD'; V[PK]:=V[K]; S:= A[PK,K]; ( PK /= K ! A[PK, ] <> A[K, ] ); ( S = 0 ! SINGULAR ); 'FOR' I 'FROM' K+1 'TO' N 'DO' A[K,I] -:= A[K,1:K1]**A[1:K1,I] /:=S 'OD' 'OD'; SINGULAR:(P,A) 'FI' #DEC# ; 'PROC' SOL=( 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU)PLS, 'REF'[]'REAL'Y ) 'REF'[]'REAL' : 'BEGIN''REF'[ ]'INT' P = PIV'OF'PLS; 'INT' N= 'UPB'P; 'REF'[,]'REAL'A = LU'OF'PLS; 'REF'[ ]'REAL'B = 'HEAP' [1:N] 'REAL' := Y; 'FOR' K 'TO' N 'DO' 'IF' 'REAL' AKK = A[K,K]; AKK=0 'THEN' PRINT((NEWLINE, "ERROR: SOL WAS CALLED WITH SINGULAR MATRIX")); TRAP 'ELSE' 'INT' PK=P[K]; 'REF' 'REAL' BK=B[K], BPK= B[PK]; 'REAL' R:= BK; BK:= ( BPK - A[K,1:K-1] ** B[1:K-1])/AKK; ( PK /= K ! BPK:= R) 'FI' 'OD'; 'FOR' K 'FROM' N-1 'BY' -1 'TO' 1 'DO' B[K] -:= A[K,K+1:N] ** B[K+1:N] 'OD'; B 'END' #SOL# ; 'PROC' DET=( 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU)PLS ) 'REAL' : 'BEGIN' 'REF'[,]'REAL'A = LU'OF'PLS; 'REAL'R := A[1,1]; 'FOR' I 'FROM' 2 'TO' 'UPB' A 'DO' R *:= A[I,I] 'OD'; R 'END' #DET# ; 'MODE' 'PIVLU' = 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU); 'PIVLU' PL; [,]'REAL' AA3 =((1,2,3),(2,3,4),(3,4,6)); [,]'REAL' AA4 =((14,3,2,1),(1,2,3,4),(2,3,4,0),(3,4,5,0)); [,]'REAL' AA5 =((4,3,2,1),(1,2,3,4),(2,3,4,0),(3,4,5,0)); [] 'REAL' BB =(11,12,13,14); [1:3,1:3]'REAL' A3; [1:4,1:4]'REAL' A4; [1:4]'REAL' B,C; A3 :=AA3; B :=BB; 'FOR' I 'TO' 3 'DO' C[I]:= A3[I,]**B[1:3] 'OD'; PRINT((NEWLINE,C[1:3] )); PL:= DEC(A3); B[1:3] := SOL(PL,C[1:3] ); PRINT((NEWLINE,A3)); PRINT((NEWLINE,C[1:3] )); PRINT((NEWLINE,DET(PL) )); PRINT((NEWLINE,B[1:3] )); ELM(B,BB,-1); PRINT((NEWLINE,B)); PRINT((NEWPAGE )); A4:= AA4; B := BB; 'FOR' I 'TO' 4 'DO' C[I]:= A4[I,]**B 'OD'; PRINT((NEWLINE,A4)); PRINT((NEWLINE,C )); B:= SOL(DEC(A4),C); PRINT((NEWLINE )); PRINT((NEWLINE,A4)); PRINT((NEWLINE,B )); PRINT((NEWLINE,C )); PRINT((NEWLINE,BB)); PRINT((NEWPAGE )); PRINT((DET(DEC(A4[2:4,1:3])),NEWLINE,A4[2:4,1:3])); PL:=DEC(A4[2:4,1:3]); PRINT((NEWLINE,NEWLINE, LU'OF'PL)); PRINT((NEWLINE,NEWLINE, PIV'OF'PL)); PRINT((NEWPAGE )); 'FOR' I 'TO' 3 'DO' C[I]:= A4[I,2:4]**B[2:4] 'OD'; PRINT((NEWLINE,C[2:4])); C[2:4]:= SOL(DEC(A4[1:3,2:4]),C[1:3]); PRINT((NEWLINE,C[2:4])); PRINT((NEWLINE,B[2:4])); PRINT((NEWLINE,A4)); PRINT((NEWLINE, B )); PRINT((NEWLINE, C )); PRINT((NEWPAGE )); 'FOR' I 'TO' 3 'DO' C[I]:= A4[I,1:3]**B[1:3] 'OD'; PRINT((NEWLINE,C[1:3])); C[1:3]:= SOL(DEC(A4[2:4,1:3]),C[2:4]); PRINT((NEWLINE,C[1:3])); PRINT((NEWLINE,B[1:3])); PRINT((NEWLINE,A4)); PRINT((NEWLINE, B )); PRINT((NEWLINE, C )); PRINT((NEWPAGE )); A4:= AA5; B:= BB; PRINT((NEWLINE,DET(DEC(A4)) )); C:= SOL(DEC(A4),B); PRINT((NEWLINE, C )) ) ################################################################################ TEST3:( # P.W.HEMKER: ALGOL 68 VERSIE VAN MULTISTEP # # VERSION: 14/08/75 # # PROGRAMMA ONGECORRIGEERD # 'PRIO' ** = 8, 'MAX' = 1, 'MIN' = 1, <= = 1, <> = 1; 'PROC' TRAP = 'VOID' : (PRINT((NEWLINE,"PROGAM TRAPPED BY NUMERICAL ERROR", NEWLINE,"ARRITHMETIC ERROR SIMULATED")); ('REAL' A:= 1/0; A:= 1/A; STOP) ); 'OP' 'MAX' = ('INT' A,B) 'INT': (A>B!A!B); 'OP' 'MIN' = ('INT' A,B) 'INT': (A = ( 'REF' [ ]'REAL' A,B) 'BOOL': 'IF' A :=: B 'THEN' 'FALSE' 'ELSE' 'FOR' I 'FROM' 'LWB' A 'MAX' 'LWB' B 'TO' 'UPB' A 'MIN' 'UPB' B 'DO' 'REF' 'REAL' X=A[I],Y=B[I]; 'REAL' S=X; X:=Y; Y:=S 'OD'; 'TRUE' 'FI'; 'PROC' DEC=('REF'[,]'REAL' X ) 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU): 'IF' 'INT' N = 1'UPB'X - 1'LWB'X + 1; N /= 2'UPB'X - 2'LWB'X + 1 'THEN' PRINT(( NEWLINE,"ERROR: DEC WAS CALLED WITH NON-SQUARE MATRIX", NEWLINE,"1'UPB'X 1'LWB'X 2'UPB'X 2'LWB'X WERE:", NEWLINE, 1'UPB'X , 1'LWB'X , 2'UPB'X , 2'LWB'X )); TRAP; 'SKIP' 'ELSE' 'REF' [,] 'REAL' A = 'HEAP'[1:N,1:N] 'REAL':= X; 'REF' [ ] 'INT' P = 'HEAP'[1:N] 'INT'; [1:N]'REAL' V; 'FOR' I 'TO' N 'DO' V[I]:= SQRT(A[I,1:N]**A[I,1:N]) 'OD'; 'FOR' K 'TO' N 'DO' 'REF' 'INT' PK = P[K]; 'INT' K1 = K-1; 'REAL' S,R:= -1; 'FOR' I 'FROM' K 'TO' N 'DO' 'IF' (S:= 'ABS' ( A[I,K] -:= A[I,1:K1]**A[1:K1,K]) / V[I] ) > R 'THEN' R:= S; PK:= I 'FI' 'OD'; V[PK]:=V[K]; S:= A[PK,K]; ( PK /= K ! A[PK, ] <> A[K, ] ); ( S = 0 ! SINGULAR ); 'FOR' I 'FROM' K+1 'TO' N 'DO' A[K,I] -:= A[K,1:K1]**A[1:K1,I] /:=S 'OD' 'OD'; SINGULAR:(P,A) 'FI' #DEC# ; 'PROC' SOL=( 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU)PLS, 'REF'[]'REAL'Y ) 'REF'[]'REAL' : 'BEGIN''REF'[ ]'INT' P = PIV'OF'PLS; 'INT' N= 'UPB'P; 'REF'[,]'REAL'A = LU'OF'PLS; 'REF'[ ]'REAL'B = 'HEAP' [1:N] 'REAL' := Y; 'FOR' K 'TO' N 'DO' 'IF' 'REAL' AKK = A[K,K]; AKK=0 'THEN' PRINT((NEWLINE, "ERROR: SOL WAS CALLED WITH SINGULAR MATRIX")); TRAP 'ELSE' 'INT' PK=P[K]; 'REF' 'REAL' BK=B[K], BPK= B[PK]; 'REAL' R:= BK; BK:= ( BPK - A[K,1:K-1] ** B[1:K-1])/AKK; ( PK /= K ! BPK:= R) 'FI' 'OD'; 'FOR' K 'FROM' N-1 'BY' -1 'TO' 1 'DO' B[K] -:= A[K,K+1:N] ** B[K+1:N] 'OD'; B 'END' #SOL# ; 'PROC' DET=( 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU)PLS ) 'REAL' : 'BEGIN' 'REF'[,]'REAL'A = LU'OF'PLS; 'REAL'R := A[1,1]; 'FOR' I 'FROM' 2 'TO' 'UPB' A 'DO' R *:= A[I,I] 'OD'; R 'END' #DET# ; 'MODE' 'PIVLU' = 'STRUCT'('REF'[]'INT'PIV,'REF'[,]'REAL'LU); 'PIVLU' PL; 'MODE' 'IVPINFO' = 'STRUCT' ('BOOL' NONSTIFF, 'REF'[]'INT' MESSAGE, 'REF' []'REAL' SCALE, HMINHMAX, # CLUSTERS, # SCRATCH, 'REF'[,]'REAL' JACOBIAN, 'REF' 'PROC'('REAL','REF'[]'REAL','REF'[,]'REAL')'VOID' JAC # 'REF'[]'PROC'('REAL',[]'REAL')[ ]'REAL' DERS # ); 'IVPINFO' NOTHING = ( 'FALSE', 'REF'[ ]'INT' ('NIL'), 'REF' []'REAL' ('NIL'), 'REF'[ ]'REAL' ('NIL'), 'REF'[ ]'REAL' ('NIL'), 'REF'[,]'REAL' ('NIL'), 'REF' 'PROC'('REAL','REF'[]'REAL','REF'[,]'REAL')'VOID'('NIL') ), NONSTIFF = ( 'TRUE' , 'REF'[ ]'INT' ('NIL'), 'REF' []'REAL' ('NIL'), 'REF'[ ]'REAL' ('NIL'), 'REF'[ ]'REAL' ('NIL'), 'REF'[,]'REAL' ('NIL'), 'REF' 'PROC'('REAL','REF'[]'REAL','REF'[,]'REAL')'VOID'('NIL') ); 'PROC' IVPODE= ('REF' 'REAL' X, 'REAL' XEND, 'REF' []'REAL' YY, 'PROC'('REAL','REF'[]'REAL','REF'[]'REAL')'VOID'DERIV, 'REAL' EPS, 'REF' 'IVPINFO' INFO,'PROC' 'VOID' OUT ) 'VOID': 'IF' 'INT' N = 'UPB' YY; 'BOOL' FIRST := ( SCRATCH'OF'INFO :=: 'REF'[ ]'REAL'('NIL')); 'BOOL' WITH JACOB:= (JACOBIAN'OF'INFO :=: 'REF'[,]'REAL'('NIL')); 'BOOL' AVAILABLE = 'NOT' (JAC'OF'INFO:=: 'REF''PROC'('REAL','REF'[]'REAL','REF'[,]'REAL')'VOID'('NIL')); 'TRUE' 'THEN' #MULTISTEP PART# 'REF' 'BOOL' ADAMS = NONSTIFF'OF'INFO; 'REF''PROC'('REAL','REF'[]'REAL','REF'[,]'REAL')'VOID' MAKE JAC = JAC'OF'INFO; 'REF'[,]'REAL' JACOBIAN = JACOBIAN'OF'INFO; 'REF'[1:6*N]'REAL' Y ; Y[1:N] := YY; 'REAL' HMIN = ( HMINHMAX'OF'INFO:=:'REF'[]'REAL'('NIL') ! 1.0\-9 ! (HMINHMAX'OF'INFO)[1] ); 'REAL' HMAX = ( HMINHMAX'OF'INFO:=:'REF'[]'REAL'('NIL') ! (XEND-X) ! (HMINHMAX'OF'INFO)[2] ); 'REF'[]'REAL' SAVE = ( FIRST ! SCRATCH'OF'INFO := 'HEAP' [-38:6*N] 'REAL' ! SCRATCH'OF'INFO ); 'REF'[]'REAL' YMAX = ( ( SCALE'OF'INFO :=: 'REF'[]'REAL'('NIL') ! SCALE 'OF'INFO := 'HEAP' [ 1 : N ] 'REAL'; (SCALE 'OF'INFO)<= 1.0 ! ( 'UPB' YMAX /= N ! PRINT((NEWLINE," ERROR IN INPUT IVPODE:", NEWLINE," 'UPB' SCALE'OF'INFO IN ERROR")); TRAP ) ); SCALE 'OF'INFO ); 'REF'[]'INT' MESS = ( ( FISET ! MESSAGE'OF'INFO := 'HEAP' [ 1 : 4 ] 'INT'; MESSAGE'OF'INFO := (0,0,0,0) ); MESSAGE'OF'INFO ); 'BOOL' EVALUATE,EVALUATED,DECOMPOSE,DECOMPOSED,NOCONV; 'REF''REAL' XOLD = SAVE[ 0]; 'REF''REAL' HOLD = SAVE[-1]; 'INT' KOLD:= SAVE[-2], SAME:= SAVE[-3]; 'INT' M = 'UPB' YMAX; 'INT' K, KNEW, FAILS:=0; 'REAL' H,CH,CHNEW,ERROR, A0,TOL,TOLUP,TOLDN,TOLCV; [0:5]'REAL' A; [1:N]'REAL' DELTA,LAST DELTA,DF; 'PIVLU' PL; #P: N, YMAX[1:N] # 'PROC' NORM2= ('REF'[]'REAL'A) 'REAL': 'BEGIN' 'REAL' AA, S:= 1.0\-100; 'REF'[]'REAL' AI = A[@1]; 'FOR' I 'TO' N 'DO' AA:= AI[I]/YMAX[I]; S +:= AA*AA 'OD'; S 'END' #NORM2#; #A: FAILS,HOLD,XOLD,KOLD,CH,SAVE # #P: X,XEND,H,K,Y # 'PROC' SET = 'VOID: 'BEGIN' FAILS:= 0; ( X /= XEND ! XOLD:= X; HOLD:= H; KOLD:= K; CH:= 1; SAVE[1:K*M+N]:= Y[1:K*M+N]; OUT ) 'END' #SET#; #A: H,X,Y,DECOMPOSED # #P: HMAX,HMIN,HOLD,XOLD,K,M,SAVE # 'PROC' RESET= ('REF' 'REAL' CH) 'VOID: 'BEGIN' 'REAL' CHM, C:= 1.0; ( CH < (CHM:=HMIN/HOLD) ! CH:= CHM !:CH > (CHM:=HMAX/HOLD) ! CH:= CHM ); X:= XOLD; H:= HOLD*CH; 'FOR' J 'FROM' 0 'BY' M 'TO' K*M 'DO' 'FOR' I 'TO' N 'DO' Y[J+I]:=SAVE[J+I]*C 'OD'; C *:= CH 'OD'; DECOMPOSED:= 'FALSE' 'END' #RESET#; #A: SAVE[-38:-4],K,KOLD,SAME & "ORDER" # 'PROC' METHOD= ('BOOL' ADAMS) 'VOID': 'BEGIN' SAVE[-38:-4] := ( ADAMS ! ( 1,1,144,4,0,.5,1,.5,576,144,1,5/12,1, .75,1/6,1436,576,4,.375,1,11/12,1/3,1/24, 2844,1436,1,251/720,1,25/24,35/72, 5/48,1/120,0,2844,0.1) ! ( 1,1,9,4,0,2/3,1,1/3,36,20.25,1,6/11, 1,6/11,1/11,84.028,53.778,0.25,.48,1,.7,.2,.02, 156.25, 108.51, .027778, 120/274, 1, 225/274, 85/274, 15/274, 1/274, 0, 187.69, .0047361) ); ORDER( K:= KOLD:= 1 ); SAME:= 2 'END' #METHOD#; #A: A,A0,TOLUP,TOL,TOLDN,TOLCV,DECOMPOSE # #P: EPS,SAVE,N # 'PROC' ORDER= ('INT' K) 'VOID': 'BEGIN' 'REAL' C = EPS * EPS; 'INT' J = 'ROUND' ( (K-1)*(K+8)/2 - 38 ); 'INT' JPK = J + K; A[0:K]:= SAVE[J: JPK]; A0:= A[0]; TOLUP := C * SAVE[JPK + 1]; TOL := C * SAVE[JPK + 2]; TOLDN := C * SAVE[JPK + 3]; TOLCV := EPS/(2 * N * (K + 2)); DECOMPOSE := 'TRUE' 'END' #ORDER#; #A: EVALUATE,DECOMPOSE,EVALUATED,JACOBIAN # #P: AVAILABLE,N, # 'PROC' EVALUATE JACOBIAN= 'VOID': 'IF' EVALUATE:= 'FALSE'; DECOMPOSE:= EVALUATED:= 'TRUE'; AVAILABLE 'THEN' MAKE JAC(X,Y[1:N],JACOBIAN) 'ELSE' 'REAL' FIXY,D; [1:N]'REAL' DY, FIXDY; DERIV(X,Y[1:N],FIXDY); 'FOR' J 'TO' N 'DO' FIXY:= Y[J]; ( EPS > (D:='ABS'FIXY) ! D:= EPS*EPS ! D:= EPS*D); Y[J] +:= D; DERIV(X,Y[1:N],DY); 'FOR' I 'TO' N 'DO' JACOBIAN[I,J]:= (DY[I]-FIXDY[I])/D 'OD'; Y[J]:= FIXY 'OD' 'FI' #EVALUATE JACOBIAN#; #A: DECOMPOSE,DECOMPOSED,JAC,PL # #P: AO,H,N,JACOBIAN # 'PROC' DECOMPOSE JACOBIAN = 'VOID': 'BEGIN' [1:N,1:N]'REAL' JAC; 'REAL' C = -A0 * H; DECOMPOSE:= 'FALSE'; DECOMPOSED:= 'TRUE'; 'FOR' J 'TO' N 'DO' JAC[ ,J] := JACOBIAN[ ,J] * C; JAC[J,J] +:= 1 'OD'; PL:= DEC(JAC) 'END' #DECOMPOSE JACOBIAN#; #A: KNEW,CHNEW,LAST DELTA # #P: K,TOL,TOLUP,TOLDWN, FAILS,DELTA # 'PROC' CALCULATE STEP AND ORDER = 'VOID': 'BEGIN' 'REAL' A1 =( K <= 1 ! 0 ! LN (TOLDN/NORM2(Y[K*M:K*M+M])) / (2*K) - 0.29 ), A2 = LN (TOL/ERROR) / (2*(K + 1)) - 0.22 , A3 =( K >= 5 'OR' FAILS /= 0 ! 0 ! LN (TOLUP/NORM2(LAST DELTA -:= DELTA))/(2/(K+2)) - 0.36 ); ( A1 > A2 'AND' A1 > A3 ! KNEW:= K-1; CHNEW:= A1 !: A2 > A3 ! KNEW:= K ; CHNEW:= A2 ! KNEW:= K+1; CHNEW:= A3 ); CHNEW:= EXP(CHNEW) 'END' #CALCULATE STEP AND ORDER# ; START: 'IF' FIRST 'THEN' ( 'NOT' ADAMS 'AND' 'NOT' WITH JACOB ! WITH JACOB:= 'TRUE'; JACOBIAN:= 'HEAP'[1:N,1:N]'REAL'; EVALUATE JACOBIAN ); METHOD(ADAMS); DERIV(X,Y[1:N],DF); H:= ( 'NOT' WITH JACOB ! HMIN ! SQRT(2 * EPS/SQRT(NORM2( DELTA := JACOBIAN * DF ))) ); ( H > HMAX ! H:= HMAX !: H < HMIN ! H:= HMIN ); XOLD:= X; HOLD:= H; CH:= 1; SAVE[1:N]:= Y[1:N]; SAVE[M+1:M+N]:= Y[M+1:M+N]:= H * DF; OUT 'ELSE' ORDER(K:=KOLD); RESET(CH:=1.0); DECOMPOSE:= WITH JACOB 'FI'; 'WHILE' X < XEND 'DO' 'IF' X + H <= XEND 'THEN' X +:= H 'ELSE' 'REAL' C:= 1.0; H:= XEND-X; X:= XEND; CH:= H/HOLD; 'FOR' J 'FROM' M 'BY' M 'TO' K*M 'DO' Y[J+1:J+N] *:= (C*:=CH) 'OD'; SAME:= ( SAME<3 ! 3 ! SAME+1) 'FI'; 'FOR' I 'FROM' 0 'TO' K-1 'DO' 'FOR' J 'FROM' K-1 'BY' -1 'TO' I 'DO' 'INT' JM:= J*M; 'INT' JM1:= JM + M; A[JM+1:JM+N] +:= A[JM1:JM1+N] 'OD' 'OD'; DELTA <= 0.0; EVALUATED:= 'FALSE'; 'TO' 3 'WHILE' NOCONV 'DO' DERIV(X,Y[1:N],DF); ( DF *:= H) -:= Y[M+1:M+N]; 'IF' WITH JACOB 'THEN' ( EVALUATE ! EVALUATE JACOBIAN ); ( DECOMPOSE ! DECOMPOSE JACOBIAN ); DF:= SOL(PL,DF) 'FI'; NOCONV:= 'FALSE'; 'FOR' I 'TO' N 'DO' 'REAL' DFI= DF[I]; Y[ I] +:= A0 * DFI; Y[M+I] +:= DFI; DELTA[I] +:= DFI; ('ABS'DFI > TOLCV*YMAX[I] ! NOCONV:='TRUE') 'OD' 'OD'; 'IF' NOCONV 'THEN' ( 'NOT' WITH JACOB ( EVALUATE:= WITH JACOB:= SAME >= K 'OR' H<1.1 * HMIN ! JACOBIAN:= 'HEAP'[1:N,1:N]'REAL' ! CH:= CH/4 ) !: 'NOT' DECOMPOSED ! DECOMPOSE:= 'TRUE' !: 'NOT' EVALUATED ! EVALUATE := 'TRUE' !: H > 1.1 * HMIN ! CH:= CH/4 !: ADAMS ! METHOD( ADAMS:='FALSE') ! PRINT ((NEWLINE," MULTISTEP IN IVPODE IN ERROR", NEWLINE," THE CURRENT HMIN ( DEFAULT = 1.0\-9)", NEWLINE," IS TOO LARGE TO RESOLVE THE#, " NONLINEARITY: DECREASE HMIN#, NEWLINE," POSSIBLY BAD JAC'OF'INFO" )); TRAP ); RESET(CH) 'ELIF' (ERROR:= NORM2(DELTA)) > TOL 'THEN' FAILS:= FAILS + 1; ( H > 1.1 * HMIN ! ( FAILS > 2 ! ADAMS:= 'FALSE'; FIRST:= 'TRUE'; KOLD:= 0; RESET(CH); START ! CALCULATE STEP AND ORDER; ( KNEW /= K ! ORDER(K:=KNEW) ); RESET( CH *:= CHNEW ) ) ! ( ADAMS ! METHOD( ADAMS:='FALSE'); RESET(CH) ! ( K = 1 ! ( 'REAL'C = SQRT(ERROR/TOL); C > MESS[3] ! MESS[3]:= 'ROUND' C ); MESS[2] +:= 1; SAME:= 3; SET ); ORDER( K:= KOLD:= 1 ); RESET(CH); SAME:= 2 ) ) 'ELSE' 'FOR' L 'FROM' 2 'TO' K 'DO' 'INT' LM= L*M; Y[LM+1:LM+N] +:= A[L] * DELTA 'OD'; SAME:= SAME - 1; ( SAME = 1 ! LAST DELTA := DELTA; 'FOR' I 'TO' N 'DO' ( 'ABS'Y[I] > YMAX[I] ! YMAX[I]:= 'ABS'Y[I] ) 'OD' !: SAME= 0 ! CALCULATE STEP AND ORDER; ( CHNEW > 1.1 ! 'REAL' C:= 1; ( K /= KNEW ! ( KNEW > K ! ( Y[KNEW*M+1:KNEW*M+N]:= DELTA ) *:= (A[K]/KNEW) ); ORDER( K:=KNEW) ); ( CHNEW * H > HMAX ! CHNEW:= HMAX/H ); H *:= CHNEW; 'FOR' J 'FROM' M 'TO' K*M 'DO' Y[J+1:J+N] *:= (C *:= CHNEW) 'OD'; DECOMPOSED:= 'FALSE'; SAME:= K+1 ! SAME:= 10 ) ); SET 'FI' 'OD' ; SAVE[-2]:= 'REAL':KOLD; SAVE[-3]:= 'REAL':SAME; MESS[ 1]:= ( ADAMS ! 0 ! 1 ); YY:= Y[1:N] 'ELSE' # OTHER IVP METHODS # 'SKIP' 'FI' #END IVPODE#; 'INT' CF,CJ,CA; 'REAL' X,XEND,EPS; [1: 2]'REAL' Y, YMAX; 'IVPINFO' INFOR:= NOTHING; 'PROC' DER = ('REAL'X,'REF'[]'REAL'Y,F)'VOID': 'BEGIN' 'REAL' R; CF +:= 1; F[2]:= R:= 3.0\+7 *Y[1]*Y[1]; F[1]:= 0.04*(1-Y[1]-Y[2]) - 1.0\+4 *Y[1]*Y[2] - R 'END' #DER#; 'PROC'AVAIL:=('REAL'X,'REF'[]'REAL'Y,'REF'[,]'REAL'JAC)'VOID': 'BEGIN' 'REAL' R; CJ +:= 1; JAC[2,1]:= R:= 6.0\+7 *Y[1]; JAC[1,1]:= -0.04 - 1.0\+4 *Y[2] - R; JAC[1,2]:= -0.04 - 1.0\+4 *Y[1]; JAC[2,2]:= 0 'END' #JAC AVAIL#; 'PROC' OUT = 'VOID' : ( CA +:= 1); CA:=CF:=CJ:=0; X:=0; Y:= (0,0); YMAX:= (0.0001, 1); SCALE'OF'INFOR := YMAX; JAC 'OF'INFOR := AVAIL; IVPODE(X, 1,Y,DER,2,1.0\-5,INFOR,OUT); PRINT((NEWLINE, CA,CF,CJ,Y[1],Y[2])); IVPODE(X, 10,Y,DER,2,1.0\-5,INFOR,OUT); PRINT((NEWLINE, CA,CF,CJ,Y[1],Y[2])) ) #TEST3# ################################################################################ TEST1:( # P.W.HEMKER: ALGOL 68 VERSIE VAN QADRAT # # VERSION: 11/07/75 # 'PROC' QADRAT=('PROC'('REAL')'REAL' F, 'REAL' A,B, 'REF' 'STRUCT'('REAL'AE,RE,'INT' OUT) ACC) 'REAL': 'IF' 'REAL' H; (H:=(B-A)/16) = 0 'THEN' 0 'ELSE' 'REAL' D7= 0.330580178199226, D6= 0.173485115707338, D5= 0.321105426559972, D3= 0.135007708341042, D2= 0.165714514228223, D0= 0.393971460638127\-1, E7= 0.260652441323638, E6= 0.239063283351431, E5= 0.263062635477467, E3= 0.218681931383057, E2= 0.275789764664284\-1, E1= 0.105575010053846, E0= 0.157119426059518\-1, C7= 0.245673430150304, C6= 0.255786258286921, C5= 0.228526063690406, C4= 0.500557131555861\-1, C3= 0.177946487736780, C2= 0.584014599032140\-1, C1= 0.874830942871332\-1, C0= 0.189642078648079\-1; 'REF' 'INT' ER = OUT 'OF' ACC; 'REAL' AELOC:= 2 * 'ABS' (AE'OF'ACC /(B-A)), RELOC:= 'ABS' RE'OF'ACC; 'REAL' HMIN:= 'ABS'(B-A)*RELOC, AA:= A, BB:= B, V, W; 'REAL' F0:= F(A), F14:= F(B), F2:= F(A+H), F9 := F(B-4*H), F3:= F(A+2*H), F7 := F(A+8*H), F5:= F(A+4*H), F6 := F(A+6*H); 'PROC' INT=('REF''REAL'X0,XN,F0,F2,F3,F5,F6,F7,F9,F14)'REAL': 'IF' 'REAL' H := (XN-X0)/32, XM := (X0+XN)/2; 'REAL' F1:= F(X0+H), F13:= F(XN-H), F8:= F(XM+4*H), F11:= F(XN-4*H), F12:= F(XN-2*H); 'ABS'( D7*F7+D6*(F6+F8)+D5*(F5+F9)+D3*(F3+F11) +D2*(F2+F12)+D0*(F0+F14) -(W:=E7*F7+E6*(F6+F8)+E5*(F5+F9)+E3*(F3+F11) +E2*(F2+F12)+E1*(F1+F13)+E0*(F0+F14))) < 'ABS'W * RELOC + AELOC 'THEN' H*W 'ELIF' 'ABS'H < HMIN 'THEN' ER +:= 1; H*W 'ELIF' 'REAL' F4:= F(X0+6*H), F10:= F(XN-6*H); 'ABS'((V:= C7*F7+C6*(F6+F8 )+C5*(F5+F9 )+ C4*(F4+F10)+C3*(F3+F11)+C2*(F2+F12)+ C1*(F1+F13)+C0*(F0+F14)) - W) < 'ABS'W * RELOC + AELOC 'THEN' H*V 'ELSE' INT(X0,XM,F0,F1,F2,F3,F4,F5,F6,F7) - INT(XN,XM,F14,F13,F12,F11,F10,F9,F8,F7) 'FI' #INT#; ER:= 0; INT(AA,BB,F0 ,F2 ,F3 ,F5 ,F6 ,F7,F9,F14)*16 'FI' #QADRAT#; 'MODE' 'ACC' = 'STRUCT'('REAL'AE,RE,'INT' OUT); 'PROC' FUNC=('REAL'X )'REAL': (FE +:= 1; SQRT((1-X)*(1+X))); 'ACC' ACC; 'INT' FE; 'FOR' I 'TO' 14 'DO' AE'OF'ACC := RE'OF'ACC := 1/'ROUND' EXP(I*LN(10)); PRINT((NEWLINE, AE'OF'ACC, (FE:=0;QADRAT(FUNC,0,1,ACC)/PI), OUT'OF'ACC, FE )) 'OD' ) ################################################################################ 'BEGIN' 'INT' NUMBER , NO := 0 ; 'REAL' X , MEAN := 0 , VARIANCE := 0 ; 'WHILE' READ(NUMBER) ; NUMBER>0 'DO' 'TO' NUMBER NO +:= 1 ; PRINT( (NEWLINE,"SAMPLE",NO) ) ; 'DO' READ(X) ; MEAN +:= X ; VARIANCE +:= X*X 'OD' ; MEAN /:= NUMBER ; VARIANCE := ( VARIANCE - MEAN*MEAN*NUMBER ) / (NUMBER-1) ; PRINT( (" MEAN= ",MEAN,NEWLINE) ) ; PRINT( (" VARIANCE=",VARIANCE," WITH ROOT",SQRT(VARIANCE)) ) ; PRINT( NEWLINE ) 'OD'; PRINT( (NEWLINE," END OF PROGRAM ") ) 'END' ################################################################################ 'BEGIN' 'INT' LEFT MARGIN := 1, 'INT' PLACE := 0; 'INT' RIGHT MARGIN = 130; [1 : RIGHT MARGIN] 'CHAR' PRINT LINE; 'PROC' INDENT = 'VOID' : LEFT MARGIN +:= 3; 'PROC' DEDENT = 'VOID' : 'IF' LEFT MARGIN > 3 'THEN' LEFT MARGIN -:= 3 'FI'; 'PROC' END LINE = 'VOID': 'BEGIN' PRINT((PRINT LINE[1 : PLACE], NEWLINE)); PLACE := ( LEFT MARGIN > RIGHT MARGIN ? 2 ! RIGHT MARGIN ? 2 ! LEFT MARGIN ) - 1; 'FOR' I 'FROM' 1 'TO' PLACE 'DO' PRINT LINE[I] := " " 'OD' 'END', 'PROC' MY END LINE = 'VOID': 'BEGIN' LEFT MARGIN +:= 6; END LINE; LEFT MARGIN -:= 6 'END'; 'OP' -< = ('CHAR' C) 'VOID' : 'BEGIN' PRINT LINE[PLACE +:= 1] := C; 'IF' PLACE >= RIGHT MARGIN 'THEN' END LINE 'FI' 'END' # OF 'PRINT' CHARACTERS # ; 'OP' -< = ('REF' 'STRING' S) 'VOID' : 'IF' 'IF' PLACE >= RIGHT MARGIN 'THEN' MY END LINE 'FI'; 'INT' UB = 'UPB' S; 'INT' NP = PLACE + UB; NP <= RIGHT MARGIN 'THEN' # NORMAL CASE # PRINT LINE[PLACE+1 : NP] := S; PLACE := NP 'ELSE' 'INT' BREAK = RIGHT MARGIN - PLACE; -< S[1:BREAK]; MY END LINE; -< S[BREAK+1 : ] 'FI' # END OF 'PRINT' FOR STRING VARIABLES #; 'OP' +< = ('STRING' S) 'VOID' : 'IF' 'IF' PLACE >= RIGHT MARGIN 'THEN' MY END LINE 'FI'; 'INT' UB = 'UPB' S; 'INT' NP = PLACE + UB; NP <= RIGHT MARGIN 'THEN' # NORMAL CASE # PRINT LINE[PLACE+1 : NP] := S; PLACE := NP 'ELSE' 'LOC' 'FLEX' [1 : UB] 'CHAR' T; T := S; -< T 'FI'; 'PROC' TEST PRINT = 'VOID': 'BEGIN' [1 : 200] 'CHAR' S; S := "0123456789" * 20; 'FOR' I 'FROM' 0 'BY' 7 'TO' 200 'DO' -< S[1:I]; END LINE 'OD'; 'FOR' I 'FROM' 0 'BY' 10 'TO' 200 'DO' -< S[1:I]; -<","; +< S[1:I]; - 2 'DO' NEWLINE(STANDOUT) ; PRINT(X) ; 'IF' P(X) 'THEN' PRINT(" PRIME") 'ELSE' PRINT(" NON PRIME") 'FI' ; READ(X) 'OD' 'END' ################################################################################ 'BEGIN' # PROGRAM ACIJ-760631. THE MAIN PART OF THIS PROGRAM HAS BEEN GIVEN BY D.GRUNE DURING A COURSE ON ALGOL68 . IT READS WORDS, SEPARATED BY ONE ORE MORE SPACES, TO BE STORED IN A LINEAR LINKED LIST WHICH CONTAINS ALSO THE NUMBER OF OCCURENCES. THIS LIST IS PRINTED AFTER ENCOUNTERING AN EOF ON THE INPUT INPUT . # 'PROC' GET WORD = 'STRING' : ( 'CHAR' CH ; 'STRING' STR := "" ; READ(CH) ; 'WHILE' CH = " " 'DO' READ(CH) 'OD' ; 'WHILE' CH /= " " 'DO' STR +:= CH ; READ(CH) 'OD' ; STR ) ; 'MODE' 'ENTRY' = 'STRUCT' ( 'STRING' WORD, 'INT' CNT, 'REF' 'ENTRY' NEXT ) ; 'ENTRY' DICTIONARY := ( "", 'SKIP', 'NIL' ) ; ON LOGICAL FILE END ( STAND IN, ('REF' 'FILE' F) 'BOOL' : EOF ) ; 'DO' 'STRING' STR = GET WORD ; 'REF' 'ENTRY' PNT := DICTIONARY ; 'WHILE' 'NOT'( ( NEXT 'OF' PNT :=: 'REF' 'ENTRY'('NIL')) 'OR' ( WORD 'OF' PNT = STR ) ) 'DO' PNT := NEXT 'OF' PNT 'OD' ; 'IF' WORD 'OF' PNT /= STR 'THEN' PNT:= NEXT 'OF' PNT := 'HEAP' 'ENTRY' := (STR, 0, 'NIL') 'FI' ; CNT 'OF' PNT +:= 1 'OD' ; 'EXIT' EOF : 'REF' 'ENTRY' PNT := DICTIONARY ; 'WHILE' 'NOT'( NEXT 'OF' PNT :=: 'REF' 'ENTRY' ('NIL') ) 'DO' PNT := NEXT 'OF' PNT ; PRINT( ( WORD 'OF' PNT , CNT 'OF' PNT ) ) ; NEWLINE(STAND OUT) 'OD' 'END' ################################################################################ 'BEGIN' # TEST CONVERSION ROUTINES # 'PROC' UNDEFINED = 'INT': 'SKIP'; 'MODE' 'NUMBER'= 'UNION' ('REAL', 'INT'); 'PROC' HANS WHOLE = ('NUMBER' V, 'INT' WIDTH) 'STRING': 'CASE' V 'IN' ('INT' X): ('STRING' S:= HANS SUBWHOLE('ABS' X); (X < 0 ! "-" !: WIDTH > 0 ! "+" ! "") 'PLUSTO' S; (WIDTH = 0 ! S !: 'INT' N = 'ABS' WIDTH - 'UPB' S; N >= 0 ! N * " " 'PLUSTO' S ! 'ABS' WIDTH * ERRORCHAR)), ('REAL' X): HANS FIXED(X, WIDTH, 0) 'ESAC'; 'PROC' HANS SUBWHOLE = ('INT' X) 'STRING': 'BEGIN' 'STRING' S:= ""; 'INT' N:= X; 'WHILE' DIG CHAR(N 'MOD' 10) 'PLUSTO' S; N 'OVERAB' 10; N /= 0 'DO' 'SKIP' 'OD'; S 'END'; 'PROC' ROUND = ('INT' K, 'REF' 'STRING' S) 'BOOL': 'IF' S[K] < "5" 'THEN' S:= S[ : K - 1]; 'FALSE' 'ELSE' 'BOOL' CARRY:= 'TRUE'; 'FOR' J 'FROM' K - 1 'BY' -1 'TO' 1 'WHILE' CARRY 'DO' CARRY:= ('INT' D = CHAR DIG(S[J]) + 1; (D = 10 ! S[J]:= "0"; 'TRUE' ! S[J]:= DIG CHAR(D); 'FALSE')) 'OD'; S:= 'IF' CARRY 'THEN' "10" + S[2 : K-2] 'ELSE' S[ : K-1] 'FI'; CARRY 'FI'; 'PROC' TO THE POINT = ('REAL' Y) 'INT': 'IF' 'INT' P:= 0; Y < 1.0 'THEN' 'WHILE' Y / 10.0 ** P < 0.10 'DO' P -:= 1 'OD'; P 'ELSE' 'WHILE' Y / 10.0 ** P >= 10.0 'DO' P +:= 1 'OD'; P + 1 'FI'; 'PROC' HANS FIXED = ('NUMBER' V, 'INT' WIDTH, AFTER) 'STRING': 'CASE' V 'IN' ('REAL' X): 'IF' 'INT' LENGTH = 'ABS' WIDTH - (X < 0 'OR' WIDTH > 0 ! 1 ! 0); AFTER < 0 'OR' LENGTH <= AFTER 'AND' WIDTH /= 0 'THEN' UNDEFINED; 'ABS' WIDTH * ERRORCHAR 'ELSE' 'INT' POINT:= TO THE POINT('ABS' X); (POINT <= 0 ! POINT:= 1); 'STRING' S:= HANS SUBFIXED(X, AFTER, POINT); 'INT' L:= LENGTH - 'UPB' S; 'IF' L < 0 'AND' X < 1 'THEN' S:= S[2 : ]; POINT:= 0; L +:= 1 'FI'; (ROUND('UPB' S + (WIDTH = 0 'OR' L >= 0 ! 0 ! L), S) ! POINT +:= 1); (LENGTH > 'UPB' S + 1 ! (LENGTH - 'UPB' S - 1) * " " ! "") + (X < 0 ! "-" !: WIDTH > 0 ! "+" ! "") + S[ : POINT] + "." + S[POINT + 1 : ] 'FI', ('INT' X): HANS FIXED('REAL' (X), WIDTH, AFTER) 'ESAC'; 'PROC' HANS SUBFIXED = ('REAL' X, 'INT' AFTER, POINT) 'STRING': 'BEGIN' 'REAL' Y:= 'ABS' X, 'STRING' S:= ""; 'FOR' I 'FROM' POINT - 1 'BY' -1 'TO' 0 'DO' S 'PLUSAB' DIG CHAR(('INT' C:= 'ENTIER' (Y / 10.0 ** I); (C > 9 ! C:= 9); Y -:= C * 10.0 ** I; C)) 'OD'; 'TO' AFTER + 1 'DO' S 'PLUSAB' DIG CHAR(('INT' C:= 'ENTIER' (Y /:= 0.10); (C > 9 ! C:= 9); Y -:= C; C)) 'OD'; (POINT < 0 ! S[ -POINT + 1 : ] ! S) 'END'; 'PROC' HANS FLOAT = ('NUMBER' V, 'INT' WIDTH, AFTER, EXP) 'STRING': 'CASE' V 'IN' ('REAL' X): 'IF' 'INT' BEFORE:= 'ABS' WIDTH - (X < 0 'OR' WIDTH > 0 ! 1 ! 0) - (AFTER /= 0 ! AFTER + 1 ! 0) - ('ABS' EXP + 1); 'SIGN' BEFORE + 'SIGN' AFTER > 0 'THEN' 'INT' EXPONENT:= TO THE POINT('ABS' X) - BEFORE, AFT:= AFTER, EXPSPACE:= 'ABS' EXP, 'BOOL' ROUNDED:= 'FALSE', POSSIBLE:= 'TRUE', 'STRING' EXPART, S:= HANS SUBFIXED(X, (AFTER - EXPONENT > 0 ! AFTER - EXPONENT ! 0), EXPONENT + BEFORE); 'WHILE' EXPART:= (EXPONENT < 0 ! "-" !: EXP > 0 ! "+" ! "") + HANS SUBWHOLE('ABS' EXPONENT); 'IF' 'SIGN' BEFORE + 'SIGN' AFT <= 0 'THEN' POSSIBLE:= 'FALSE' 'ELIF' 'UPB' EXPART > EXPSPACE 'THEN' EXPSPACE +:= 1; (AFT > 1 ! AFT -:= 1 AFT < 1 ! BEFORE -:= 1; EXPONENT +:= 1 ! BEFORE +:= 1; EXPONENT -:= 1; AFT:= 0); 'TRUE' 'ELIF' ROUNDED 'THE' 'FALSE' 'ELIF' ROUND(BEFORE + AFT + 1, S) 'THEN' ROUNDED:= 'TRUE'; (AFT /= 1 ! EXPONENT +:= 1 ! BEFORE +:= 1; EXPONENT -:= 1; AFT:= 0; EXPSPACE +:= 1); 'TRUE' 'ELSE' 'FALSE' 'FI' 'DO' 'SKIP' 'OD'; 'IF' 'NOT' POSSIBLE 'THEN' UNDEFINED; 'ABS' WIDTH * ERRORCHAR 'ELSE' (X < 0 ! "-" !: WIDTH > 0 ! "+" ! "") + (BEFORE >= 'UPB' S ! S ! S[ : BEFORE] + "." + S[BEFORE + 1 : ]) + "E" + EXPART 'FI' 'ELSE' UNDEFINED; 'ABS' WIDTH * ERRORCHAR 'FI', ('INT' X): HANS FLOAT('REAL' (X), WIDTH, AFTER, EXP) 'ESAC'; 'PROC' REPORT WHOLE= ('NUMBER' V, 'INT' WIDTH) 'STRING': 'CASE' V 'IN' ('INT' X): ('INT' LENGTH:= 'ABS' WIDTH - (X < 0 'OR' WIDTH > 0 ! 1 ! 0), 'INT' N:= 'ABS' X; 'IF' WIDTH= 0 'THEN' 'INT' M:= N; LENGTH:= 0; 'WHILE' M 'OVERAB' 10; LENGTH +:= 1; M /= 0 'DO' 'SKIP' 'OD' 'FI'; 'STRING' S:= REPORT SUBWHOLE (N, LENGTH); 'IF' LENGTH= 0 'OR' CHAR IN STRING (ERRORCHAR, 'LOC' 'INT', S) 'THEN' 'ABS' WIDTH * ERRORCHAR 'ELSE' (X < 0 ! "-" !: WIDTH > 0 ! "+" ! "") 'PLUSTO' S; (WIDTH /= 0 ! ('ABS' WIDTH - 'UPB' S) * " " 'PLUSTO' S); S 'FI'), ('REAL' X): REPORT FIXED (X, WIDTH, 0) 'ESAC'; 'PROC' REPORT FIXED = ('NUMBER' V, 'INT' WIDTH, AFTER) 'STRING': 'CASE' V 'IN' ('REAL' X): 'IF' 'INT' LENGTH:= 'ABS' WIDTH - (X < 0 'OR' WIDTH > 0 ! 1 ! 0); AFTER >= 0 'AND' (LENGTH > AFTER 'OR' WIDTH = 0) 'THEN' 'REAL' Y = 'ABS' X; 'IF' WIDTH = 0 'THEN' LENGTH:= (AFTER = 0 ! 1 ! 0); 'WHILE' Y + .5 * .1 ** AFTER >= 10.0 ** LENGTH 'DO' LENGTH +:= 1 'OD'; LENGTH +:= (AFTER = 0 ! 0 ! AFTER + 1) 'FI'; 'STRING' S := REPORT SUBFIXED(Y, LENGTH, AFTER); 'IF' 'NOT' CHAR IN STRING(ERRORCHAR, 'LOC' 'INT', S) 'THEN' (LENGTH > 'UPB' S 'AND' Y < 1.0 ! "0" 'PLUSTO' S); (X < 0 ! "-" !: WIDTH > 0 ! "+" ! "") 'PLUSTO' S; (WIDTH /= 0 ! ('ABS' WIDTH - 'UPB' S) * " " 'PLUSTO' S); S 'ELIF' AFTER > 0 'THEN' REPORT FIXED(V, WIDTH, AFTER - 1) 'ELSE' 'ABS' WIDTH * ERRORCHAR 'FI' 'ELSE' UNDEFINED; 'ABS' WIDTH * ERRORCHAR 'FI', ('INT' X): REPORT FIXED('REAL' (X), WIDTH, AFTER) 'ESAC'; 'PROC' REPORT FLOAT = ('NUMBER' V, 'INT' WIDTH, AFTER, EXP) 'STRING': 'CASE' V 'IN' ('REAL' X): 'IF' 'INT' BEFORE = 'ABS' WIDTH - 'ABS' EXP - (AFTER /= 0 ! AFTER + 1 ! 0) - (X < 0.0 'OR' WIDTH > 0 ! 2 ! 1); 'SIGN' BEFORE + 'SIGN' AFTER > 0 'THEN' 'STRING' S, 'REAL' Y:= 'ABS' X, 'INT' P:= 0; STANDARDIZE(Y, BEFORE, AFTER, P); S:= REPORT FIXED('SIGN' X * Y, 'SIGN' WIDTH * ('ABS' WIDTH - 'ABS' EXP - 1), AFTER) + "E" + REPORT WHOLE(P, EXP); 'IF' EXP = 0 'OR' CHAR IN STRING(ERRORCHAR, 'LOC' 'INT', S) 'THEN' REPORT FLOAT(X, WIDTH, (AFTER /= 0 ! AFTER - 1 ! 0), (EXP > 0 ! EXP + 1 ! EXP - 1)) 'ELSE' S 'FI' 'ELSE' UNDEFINED; 'ABS' WIDTH * ERRORCHAR 'FI', ('INT' X): REPORT FLOAT('REAL' (X), WIDTH, AFTER, EXP) 'ESAC'; 'PROC' REPORT SUBWHOLE = ('NUMBER' V, 'INT' WIDTH) 'STRING': # RETURNS A STRING OF MAXIMUM LENGTH 'WIDTH''' CONTAINING A DECIMAL REPRESENTATION OF THE POSITIVE INTEGER 'V''' # 'CASE' V 'IN' ('INT' X): 'BEGIN' 'STRING' S, 'INT' N:= X; 'WHILE' DIG CHAR (N 'MOD' 10) 'PLUSTO' S; N 'OVERAB' 10; N /= 0 'DO' 'SKIP' 'OD'; ('UPB' S > WIDTH ! WIDTH * ERRORCHAR ! S) 'END' 'ESAC'; 'PROC' REPORT SUBFIXED = ('NUMBER' V, 'INT' WIDTH, AFTER) 'STRING': # RETURNS A STRING OF MAXIMUM LENGTH 'WIDTH''' CONTAINING A ROUNDED DECIMAL REPRESENTATION OF THE POSITIVE REAL NUMBER 'V'''; IF 'AFTER''' IS GREATER THAN ZERO, THIS STRING CONTAINS A DECIMAL POINT FOLLOWED BY 'AFTER''' DIGITS # 'CASE' V 'IN' ('REAL' X): 'BEGIN' 'STRING' S, 'INT' BEFORE:= 0; 'REAL' Y:= X + .5 * .1 ** AFTER; 'PROC' CHOOSEDIG = ('REF' 'REAL' Y) 'CHAR': DIG CHAR(('INT' C:= 'ENTIER' (Y *:= 10.0); (C > 9 ! C:= 9); Y -:= C; C)); 'WHILE' Y >= 10.0 ** BEFORE 'DO' BEFORE +:= 1 'OD'; Y /:= 10.0 ** BEFORE; 'TO' BEFORE 'DO' S 'PLUSAB' CHOOSEDIG (Y) 'OD'; (AFTER > 0 ! S 'PLUSAB' "."); 'TO' AFTER 'DO' S 'PLUSAB' CHOOSEDIG (Y) 'OD'; ('UPB' S > WIDTH ! WIDTH * ERRORCHAR ! S) 'END' 'ESAC'; 'PROC' STANDARDIZE = ('REF' 'REAL' Y, 'INT' BEFORE, AFTER, 'REF' 'INT' P) 'VOID': # ADJUSTS THE VALUE OF 'Y''' SO THAT IT MAY BE TRANSPUT ACCORDING TO THE FORMAT $ N (BEFORE)D. N(AFTER)D $; 'P''' IS SET SO THAT Y * 10 ** P IS EQUAL TO THE ORIGINAL VALUE OF 'Y''' # 'BEGIN' 'REAL' G = 10.0 ** BEFORE; 'REAL' H= G * .1; 'WHILE' Y >= G 'DO' Y *:= .1; P+:= 1 'OD'; (Y /= 0.0 ! 'WHILE' Y < H 'DO' Y *:= 10.0; P-:= 1 'OD'); (Y + .5 * .1 ** AFTER >= G ! Y:= H; P+:= 1) 'END'; 'PROC' DIG CHAR = ('INT' X) 'CHAR': "0123456789ABCDEF"[X + 1]; 'PROC' CHAR DIG = ('CHAR' X) 'INT': (X = "-" ! 0 ! 'INT' I; CHAR IN STRING(X, I, "0123456789ABCDEF"); I - 1); 'PROC' CHAR IN STRING = ('CHAR' C, 'REF' 'INT' I, 'STRING' S) 'BOOL': ('BOOL' FOUND:= 'FALSE'; 'FOR' K 'FROM' 'LWB' S 'TO' 'UPB' S 'WHILE' 'NOT' FOUND 'DO' (C=S[K] ! I:= K; FOUND:= 'TRUE') 'OD'; FOUND); 'PROC' TEST WHOLE = ('INT' X, WIDTH) 'VOID': (PRINT(("HANS: ", HANS WHOLE(X, WIDTH), NEWLINE)); PRINT(("REPORT: ", REPORT WHOLE(X, WIDTH), NEWLINE)); PRINT(("MACHINE:", WHOLE(X, WIDTH), NEWLINE, NEWLINE))); 'PROC' TEST FIXED = ('REAL' X, 'INT' WIDTH, AFTER) 'VOID': (PRINT(("HANS: ", HANS FIXED(X, WIDTH, AFTER), NEWLINE)); PRINT(("REPORT: ", REPORT FIXED(X, WIDTH, AFTER), NEWLINE)); PRINT(("MACHINE:", FIXED(X, WIDTH, AFTER), NEWLINE, NEWLINE))); 'PROC' TEST FLOAT = ('REAL' X, 'INT' WIDTH, AFTER, EXP) 'VOID': (PRINT(("HANS: ", HANS FLOAT(X, WIDTH, AFTER, EXP), NEWLINE)); PRINT(("REPORT: ", REPORT FLOAT(X, WIDTH, AFTER, EXP), NEWLINE)); PRINT(("MACHINE:", FLOAT(X, WIDTH, AFTER, EXP), NEWLINE, NEWLINE))); TEST FIXED(.9997, -4, 2); TEST FIXED(.9997, -4, 3); TEST FIXED(.9997, -5, 2); TEST FIXED(.9997, -5, 3); TEST FIXED(.9997, -6, 2); TEST FIXED(.9997, -6, 3); TEST FIXED(.9997, -6, 4); TEST FIXED(.9997, -7, 2); TEST FIXED(.9997, -7, 3); TEST FIXED(.9997, -7, 4); TEST FIXED(.9997, -7, 5); TEST FLOAT(.9997E-10, -4, 0, 0); TEST FLOAT(.9997E-10, -4, 0, 1); TEST FLOAT(.9997E-10, -5, 0, 0); TEST FLOAT(.9997E-10, -5, 0, 1); TEST FLOAT(.9997E-10, -6, 0, 1); TEST FLOAT(.9997E-10, -8, 4, 2); TEST FLOAT(.9997E-10, -8, 4, 3); TEST FLOAT(.9997E-10, -9, 4, 2); TEST FLOAT(.9997E-10, -9, 4, 3); TEST FLOAT(.9997E-10, -9, 3, 3); TEST FLOAT(.9997E-10, -9, 3, 4); TEST FLOAT(.9997E-10, -10, 4, 2); TEST FLOAT(.9997E-10, -10, 4, 3); TEST FLOAT(.9997E-10, -10, 4, 4); TEST FLOAT(.9997E-10, -10, 3, 3); TEST FLOAT(.9997E-10, -10, 3, 4); TEST FLOAT(.9997E-10, -10, 2, 5); TEST FLOAT(.9997E-10, -11, 4, 2); TEST FLOAT(.9997E-10, -11, 4, 3); TEST FLOAT(.9997E-10, -11, 4, 4); TEST FLOAT(.9997E+99, -8, 4, 2); TEST FLOAT(.9997E+99, -8, 4, 3); TEST FLOAT(.9997E+99, -9, 4, 2); TEST FLOAT(.9997E+99, -9, 4, 3); TEST FLOAT(.9997E+99, -9, 3, 3); TEST FLOAT(.9997E+99, -9, 3, 4); TEST FLOAT(.9997E+99, -10, 4, 2); TEST FLOAT(.9997E+99, -10, 0, 2); TEST FLOAT(.9997E+99, -10, 1, 2); TEST FLOAT(.9997E+99, -10, 4, 3); TEST FLOAT(.9997E+99, -10, 4, 4); TEST FLOAT(.9997E+99, -10, 3, 3); TEST FLOAT(.9997E+99, -10, 3, 4); TEST FLOAT(.9997E+99, -10, 3, 5); TEST FLOAT(.9997E+99, -10, 2, 5); TEST FLOAT(.9997E+99, -11, 4, 2); TEST FLOAT(.9997E+99, -11, 4, 3); TEST FLOAT(.9997E+99, -11, 4, 4); TEST FLOAT(10E-10, 4, 0, 1); TEST FLOAT(10E-10,-4, 0, 1); TEST FLOAT(10E-10,-5, 0, 1); TEST FLOAT(10E-10, 5, 0, 1); TEST FLOAT(861346134.4E123,10,0,0); 'SKIP' 'END' ################################################################################ 'BEGIN' # FORMATTED TRANSPUT # 'MODE' 'FILE' = 'STRUCT' ('REF' 'BOOK' BOOK, 'UNION' ('FLEXTEXT', 'TEXT') TEXT, 'CHANNEL' CHAN, 'REF' 'FORMAT' FORMAT, # NO FORP! # 'REF' 'BOOL' READ MOOD, WRITE MOOD, CHAR MOOD, BIN MOOD, OPENED, 'REF' 'POS' CPOS, # CURRENT POSITION # 'STRING' TERM, # TERMINATOR # 'CONV' CONV, # CONVERSION KEY # 'PROC' ('REF' 'FILE') 'BOOL' LOGICAL FILE MENDED, PHYSICAL FILE MENDED, PAGE MENDED, LINE MENDED, FORMAT MENDED, 'PROC' ('REF' 'FILE', 'REF' 'CHAR') 'BOOL' CHAR ERROR MENDED); 'MODE' 'FORMAT' = 'STRUCT' ('PIECE' F); 'MODE' 'PIECE' = 'STRUCT' ('INT' CP, # POINTER TO CURRENT COLLECTION # COUNT, # NUMBER OF TIMES PIECE IS TO BE REPEATED # 'REF' 'PIECE' BP, # BACK POINTER # 'FLEX' [1 : 0] 'COLLECTION' C); 'MODE' 'COLLECTION' = 'UNION' ('PICTURE', 'COLLITEM'); 'MODE' 'COLLITEM' = 'STRUCT' ('INSERTION' I1, 'PROC' 'INT' REP, # REPLICATOR # 'REF' 'PIECE' P, # REFERENCE TO ANOTHER PIECE # 'INSERTION' I2); 'MODE' 'INSERTION' = 'FLEX' [1 : 0] 'STRUCT' ('PROC' 'INT' REP, 'UNION' ('STRING', 'CHAR') SA); 'MODE' 'PICTURE' = 'STRUCT' ( 'UNION' ('PATTERN', 'CPATTERN', 'FPATTERN', 'GPATTERN', 'VOID') P, 'INSERTION' I); 'MODE' 'PATTERN' = 'STRUCT' ('INT' TYPE, # OF PATTERN # 'FLEX' [1 : 0] 'FRAME' FRAMES); 'MODE' 'FRAME' = 'STRUCT' ('INSERTION' I, 'PROC' 'INT' REP, # REPLICATOR # 'BOOL' SUPP, # TRUE IF SUPPRESSED # 'CHAR' MARKER); 'MODE' 'CPATTERN' = 'STRUCT' ('INSERTION' I, 'INT' TYPE, # BOOLEAN OR INTEGRAL # '''FLEX' [1 : 0] 'INSERTION' C); 'MODE' 'FPATTERN' = 'STRUCT' ('INSERTION' I, 'PROC' 'FORMAT' PF); 'MODE' 'GPATTERN' = 'STRUCT' ('INSERTION' I, 'FLEX' [1 : 0] 'PROC' 'INT' SPEC); 'PROC' GET NEXT PICTURE = ('REF' 'FILE' F, 'BOOL' READ, 'REF' 'PICTURE' PICTURE) 'VOID': 'BEGIN' 'BOOL' PICTURE FOUND:= 'FALSE'; 'WHILE' 'NOT' PICTURE FOUND 'DO' 'IF' CP 'OF' FORP 'OF' F = 0 # FORMAT ENDED # 'THEN' ( 'NOT' (FORMAT MENDED 'OF' F)(F) ! ENSURE STATE(F, READ); CP 'OF' FORP 'OF' F:= COUNT 'OF' FORP 'OF' F:= 1 !: ENSURE STATE(F, READ); CP 'OF' FORP 'OF' F = 0 ! UNDEFINED) 'ELSE' 'REF' 'PIECE' FORP = FORP 'OF' F; 'CASE' (C 'OF' FORP)[CP 'OF' FORP] 'IN' ('COLLITEM' CL): ([1 : 'UPB' (I1 'OF' CL)] 'SINSERT' SI; BP 'OF' P 'OF' CL:= FORP; FORP:= 'NIL'; (STATICIZE INSERTION(I1 'OF' CL, SI), COUNT 'OF' P 'OF' CL:= REP 'OF' CL); ENSURE STATE(F, READ); # SHOULD I TEST FOR THE FORMAT; HOW? # (READ ! GET INSERTION(F, SI) ! PUT INSERTION(F, SI)); CP 'OF' P 'OF' CL:= 0; FORP:= P 'OF' CL), ('PICTURE' PICT): (PICTURE FOUND:= 'TRUE'; PICTURE:= PICT; 'WHILE' CP 'OF' FORP = 'UPB' C 'OF' FORP 'DO' 'IF' (COUNT 'OF' FORP -:= 1) <= 0 'THEN' 'IF' 'REF' 'PIECE' FF = BP 'OF' FORP; FF :/=: 'NIL' 'THEN' FORP:= FF; 'INSERTION' EXTRA = 'CASE' (C 'OF' FORP)[CP 'OF' FORP] 'IN' ('COLLITEM' CL): (BP 'OF' P 'OF' CL:= 'NIL'; I2 'OF' CL), ('PICTURE' PICT): 'CASE' P 'OF' PICT 'IN' ('FPATTERN' FPATT): I 'OF' PICT 'ESAC' 'ESAC'; 'INT' M = 'UPB' I 'OF' PICTURE, N = 'UPB' EXTRA; [1 : M + N] 'STRUCT' ('PROC' 'INT' REP, 'UNION' ('STRING', 'CHAR') SA) C; C[1 : M]:= I 'OF' PICTURE; C[M + 1 : M + N]:= EXTRA; I 'OF' PICTURE:= C 'ELSE' CP 'OF' FORP:= -1 'FI' 'ELSE' CP 'OF' FORP:= 0 'FI' 'OD'; CP 'OF' FORP +:= 1), 'FI' 'OD' 'END'; 'SKIP' 'END' ################################################################################ PDE: 'BEGIN' 'MODE' 'VEC' = 'REF'[ ][ ]'REAL', 'MAT2' = 'REF'[ ][ , ]'REAL', 'MAT3' = 'REF'[ ][ , , ]'REAL'; 'MODE' 'VMM' = 'UNION'('VEC','MAT2','MAT3'); 'OP' * =('REAL'R,'VMM'Y)'VMM': 'CASE' Y 'IN' ('VEC'V):('HEAP'[1:'UPB'V]['LWB'V[1]:'UPB'V[1]]'REAL'Z; 'FOR' I 'TO' 'UPB'V 'DO' 'FOR' J 'FROM' 'LWB'V[1] 'TO' 'UPB'V[1] 'DO' Z[I][J]:=V[I][J]*R 'OD' 'OD';Z), ('MAT2'M2):('HEAP'[1:'UPB'M2]['LWB'M2[1]:'UPB'M2[1], 2'LWB'M2[1]:2'UPB'M2[1]]'REAL'Z; 'FOR' I 'TO' 'UPB'M2 'DO' 'FOR' J 'FROM' 'LWB'M2[1] 'TO' 'UPB'M2[1] 'DO' 'FOR' K 'FROM'2'LWB'M2[1] 'TO'2'UPB'M2[1] 'DO' Z[I][J,K]:=M2[I][J,K]*R 'OD''OD''OD'; Z), ('MAT3'M3):('HEAP'[1:'UPB'M3]['LWB'M3[1]:'UPB'M3[1], 2'LWB'M3[1]:2'UPB'M3[1], 3'LWB'M3[1]:3'UPB'M3[1]]'REAL'Z; 'FOR' I 'TO' 'UPB'M3 'DO' 'FOR' J 'FROM' 'LWB'M3[1] 'TO' 'UPB'M3[1] 'DO' 'FOR' K 'FROM'2'LWB'M3[1] 'TO'2'UPB'M3[1] 'DO' 'FOR' L 'FROM'3'LWB'M3[1] 'TO'3'UPB'M3[1] 'DO' Z[I][J,K,L]:=M3[I][J,K,L]*R 'OD''OD''OD''OD'; Z) 'ESAC'; 'OP' / =('VMM'Y,'REAL'R)'VMM': 'IF' R/=0.0 'THEN' 1.0/R * Y 'ELSE' ERROR; 'SKIP' 'FI'; 'OP' - =('VMM'Y1,Y2)'VMM': 'CASE' Y1 'IN' ('VEC'V):('HEAP'[1:'UPB'V]['LWB'V[1]:'UPB'V[1]]'REAL'Z; 'CASE' Y2 'IN' ('VEC'W): 'FOR' I 'TO' 'UPB'V 'DO' 'FOR' J 'FROM' 'LWB'V[1] 'TO' 'UPB'V[1] 'DO' Z[I][J]:=V[I][J]-W[I][J] 'OD' 'OD' 'OUT' ERROR 'ESAC'; Z), ('MAT2'M2):('HEAP'[1:'UPB'M2]['LWB'M2[1]:'UPB'M2[1], 2'LWB'M2[1]:2'UPB'M2[1]]'REAL'Z; 'CASE' Y2 'IN' ('MAT2' N2): 'FOR' I 'TO' 'UPB'M2 'DO' 'FOR' J 'FROM' 'LWB'M2[1] 'TO' 'UPB'M2[1] 'DO' 'FOR' K 'FROM'2'LWB'M2[1] 'TO'2'UPB'M2[1] 'DO' Z[I][J,K]:=M2[I][J,K]-N2[I][J,K] 'OD''OD''OD' 'OUT' ERROR 'ESAC'; Z), ('MAT3'M3):('HEAP'[1:'UPB'M3]['LWB'M3[1]:'UPB'M3[1], 2'LWB'M3[1]:2'UPB'M3[1], 3'LWB'M3[1]:3'UPB'M3[1]]'REAL'Z; 'CASE' Y2 'IN' ('MAT3' N3): 'FOR' I 'TO' 'UPB'M3 'DO' 'FOR' J 'FROM' 'LWB'M3[1] 'TO' 'UPB'M3[1] 'DO' 'FOR' K 'FROM'2'LWB'M3[1] 'TO'2'UPB'M3[1] 'DO' 'FOR' L 'FROM'3'LWB'M3[1] 'TO'3'UPB'M3[1] 'DO' Z[I][J,K,L]:=M3[I][J,K,L]-N3[I][J,K,L]'OD''OD''OD''OD' 'OUT' ERROR 'ESAC'; Z) 'ESAC'; 'OP' + =('VMM'Y1,Y2)'VMM': 'CASE' Y1 'IN' ('VEC'V):('HEAP'[1:'UPB'V]['LWB'V[1]:'UPB'V[1]]'REAL'Z; 'CASE' Y2 'IN' ('VEC'W): 'FOR' I 'TO' 'UPB'V 'DO' 'FOR' J 'FROM' 'LWB'V[1] 'TO' 'UPB'V[1] 'DO' Z[I][J]:=V[I][J]+W[I][J] 'OD' 'OD' 'OUT' ERROR 'ESAC'; Z), ('MAT2'M2):('HEAP'[1:'UPB'M2]['LWB'M2[1]:'UPB'M2[1], 2'LWB'M2[1]:2'UPB'M2[1]]'REAL'Z; 'CASE' Y2 'IN' ('MAT2' N2): 'FOR' I 'TO' 'UPB'M2 'DO' 'FOR' J 'FROM' 'LWB'M2[1] 'TO' 'UPB'M2[1] 'DO' 'FOR' K 'FROM'2'LWB'M2[1] 'TO'2'UPB'M2[1] 'DO' Z[I][J,K]:=M2[I][J,K]+N2[I][J,K] 'OD''OD''OD' 'OUT' ERROR 'ESAC'; Z), ('MAT3'M3):('HEAP'[1:'UPB'M3]['LWB'M3[1]:'UPB'M3[1], 2'LWB'M3[1]:2'UPB'M3[1], 3'LWB'M3[1]:3'UPB'M3[1]]'REAL'Z; 'CASE' Y2 'IN' ('MAT3' N3): 'FOR' I 'TO' 'UPB'M3 'DO' 'FOR' J 'FROM' 'LWB'M3[1] 'TO' 'UPB'M3[1] 'DO' 'FOR' K 'FROM'2'LWB'M3[1] 'TO'2'UPB'M3[1] 'DO' 'FOR' L 'FROM'3'LWB'M3[1] 'TO'3'UPB'M3[1] 'DO' Z[I][J,K,L]:=M3[I][J,K,L]+N3[I][J,K,L]'OD''OD''OD''OD' 'OUT' ERROR 'ESAC'; Z) 'ESAC'; 'OP' 'NORMN' = ('VMM'Y)'REAL': 'NORM' Y/( 'CASE' Y 'IN' ('VEC'V) : SQRT('UPB'V*('UPB'V[1]-'LWB'V[1]+1)), ('MAT2'M2): SQRT('UPB'M2*('UPB'M2[1]-'LWB'M2[1]+1)* (2'UPB'M2[1]-2'LWB'M2[1]+1)), ('MAT3'M3): SQRT('UPB'M3*('UPB'M3[1]-'LWB'M3[1]+1)* (2'UPB'M3[1]-2'LWB'M3[1]+1)* (3'UPB'M3[1]-3'LWB'M3[1]+1)) 'ESAC'); 'OP' 'NORM' = ('VMM'Y)'REAL': ('REAL' S:=0.0; 'CASE' Y 'IN' ('VEC' V):'FOR' I 'TO' 'UPB'V 'DO' 'FOR' J 'FROM' 'LWB'V[1] 'TO' 'UPB'V[1] 'DO' S+:=('REAL'VIJ=V[I][J];VIJ*VIJ) 'OD' 'OD' , ('MAT2' M2):'FOR' I 'TO' 'UPB'M2 'DO' 'FOR' J 'FROM' 'LWB'M2[1] 'TO' 'UPB'M2[1] 'DO' 'FOR' K 'FROM'2'LWB'M2[1] 'TO'2'UPB'M2[1] 'DO' S+:=('REAL'MIJK=M2[I][J,K];MIJK*MIJK)'OD''OD''OD', ('MAT3' M3):'FOR' I 'TO' 'UPB'M3 'DO' 'FOR' J 'FROM' 'LWB'M3[1] 'TO' 'UPB'M3[1] 'DO' 'FOR' K 'FROM'2'LWB'M3[1] 'TO'2'UPB'M3[1] 'DO' 'FOR' L 'FROM'3'LWB'M3[1] 'TO'3'UPB'M3[1] 'DO' S+:=('REAL'MIJKL=M3[I][J,K,L];MIJKL*MIJKL)'OD''OD''OD''OD' 'ESAC'; SQRT(S) ); 'OP' 'INITIAL' =('VMM'Y,'REAL'R)'VMM': 'CASE' Y 'IN' ('VEC'V): ('FOR' I 'TO' 'UPB'V 'DO' 'FOR' J 'FROM' 'LWB'V[1] 'TO' 'UPB'V[1] 'DO' V[I][J]:=R 'OD' 'OD'; V), ('MAT2'M2): ('FOR' I 'TO' 'UPB'M2 'DO' 'FOR' J 'FROM' 'LWB'M2[1] 'TO' 'UPB'M2[1] 'DO' 'FOR' K 'FROM'2'LWB'M2[1] 'TO'2'UPB'M2[1] 'DO' M2[I][J,K]:=R 'OD''OD''OD'; M2), ('MAT3'M3): ('FOR' I 'TO' 'UPB'M3 'DO' 'FOR' J 'FROM' 'LWB'M3[1] 'TO' 'UPB'M3[1] 'DO' 'FOR' K 'FROM'2'LWB'M3[1] 'TO'2'UPB'M3[1] 'DO' 'FOR' L 'FROM'3'LWB'M3[1] 'TO'3'UPB'M3[1] 'DO' M3[I][J,K,L]:=R 'OD''OD''OD''OD'; M3) 'ESAC'; 'PRIO' 'INITIAL' = 9; 'OP' ** = ('REAL'A,B)'REAL': 'IF' A > 0.0 'THEN' EXP(B*LN(A)) 'ELSE' ERROR; 'SKIP' 'FI'; 'PR' EJECT 'PR' 'MODE' 'INFO' = 'STRUCT'( 'REAL' H,HMIN,SIGMA,INACC SIGMA,TOL, 'VMM' Y0,Y1,Y2,DY0,DY1, 'BOOL' FIRST CALL, 'INT' IFLAG, SIGMA OPTION, MAX EVALS, STEPS, FAILURES, RESTARTS, EVALS, SIGMA EVALS, DEGREE, MAXDEGREE1, MAXDEGREE2, ORDER, STEPS AFTER START, STEPS AFTER H, STEPS AFTER SIGMA ); 'INFO' DEFAULT = ('SKIP','SKIP','SKIP','SKIP',1.E-3, 'SKIP','SKIP','SKIP','SKIP','SKIP', 'TRUE', 0,2, 10000,'SKIP','SKIP', 'SKIP','SKIP','SKIP', 'SKIP','SKIP','SKIP', 'SKIP', 'SKIP', 'SKIP', 'SKIP' ); 'PR' EJECT 'PR' 'PROC' PARABOLIC PDE = ('REF''REAL'X,'REAL'XE,'VMM'Y,'UNION'('PROC'( 'REAL','VEC')'VEC','PROC'('REAL','MAT2')'MAT2', 'PROC'('REAL','MAT3')'MAT3')UF,'REF''INFO'INFO) 'VOID': 'BEGIN' 'IF'('CASE' Y 'IN' ('VEC' V ) : 'LWB'V, ('MAT2' M2) : 'LWB'M2, ('MAT3' M3) : 'LWB'M3 'ESAC') /= 1 'THEN' ERROR 'FI'; 'REF' 'REAL' H = H 'OF' INFO, HMIN = HMIN 'OF' INFO, SIGMA1= SIGMA 'OF' INFO, SIGMA2= INACC SIGMA 'OF' INFO, 'REAL' TOL = TOL 'OF' INFO, APR = SMALLREAL, 'REF' 'INT' IFLAG = IFLAG 'OF' INFO, 'REF' 'BOOL' I1 = FIRST CALL 'OF' INFO, 'REF' 'INT' I2 = SIGMA OPTION 'OF' INFO, 'INT' I3 = MAX EVALS 'OF' INFO, 'REF' 'INT' I4 = STEPS 'OF' INFO, I5 = FAILURES 'OF' INFO, I6 = RESTARTS 'OF' INFO, I7 = EVALS 'OF' INFO, I8 = SIGMA EVALS 'OF' INFO, I9 = DEGREE 'OF' INFO, I10 = MAXDEGREE1 'OF' INFO, I11 = MAXDEGREE2 'OF' INFO, I12 = ORDER 'OF' INFO, I13 = STEPS AFTER START 'OF' INFO, I14 = STEPS AFTER H 'OF' INFO, I15 = STEPS AFTER SIGMA 'OF' INFO; 'REAL' TOLLIP=1.E4*APR; 'PROC' NEWSPACE = ('VMM'Y)'VMM': 'CASE' Y 'IN' ('VEC' V):'HEAP'[1:'UPB'V]['LWB'V[1]:'UPB'V[1]]'REAL', ('MAT2' M2):'HEAP'[1:'UPB'M2]['LWB'M2[1]:'UPB'M2[1], 2'LWB'M2[1]:2'UPB'M2[1]]'REAL', ('MAT3' M3):'HEAP'[1:'UPB'M3]['LWB'M3[1]:'UPB'M3[1], 2'LWB'M3[1]:2'UPB'M3[1], 3'LWB'M3[1]:3'UPB'M3[1]]'REAL' 'ESAC'; 'IF' I1 'THEN' Y0 'OF' INFO:= NEWSPACE(Y); Y1 'OF' INFO:= NEWSPACE(Y); Y2 'OF' INFO:= NEWSPACE(Y); DY0 'OF' INFO:= NEWSPACE(Y); DY1 'OF' INFO:= NEWSPACE(Y) 'FI'; 'VMM' Y0 = Y0 'OF' INFO, Y1 = Y1 'OF' INFO, Y2 = Y2 'OF' INFO, DY0 = DY0'OF' INFO, DY1 = DY1'OF' INFO; 'PROC' F =('REAL'X,'VMM'Y)'VMM': 'CASE' Y 'IN' ('VEC' V):(UF!('PROC'('REAL','VEC')'VEC' PVV):PVV(X,V)! ERROR;'SKIP'), ('MAT2' M2):(UF!('PROC'('REAL','MAT2')'MAT2' PMM2):PMM2(X,M2)! ERROR;'SKIP'), ('MAT3' M3):(UF!('PROC'('REAL','MAT3')'MAT3' PMM3):PMM3(X,M3)! ERROR;'SKIP') 'ESAC'; 'OP' <= = ('VMM'Y1,Y2)'VMM': 'CASE' Y1 'IN' ('VEC' V) : (Y2 ! ('VEC'W): V:=W ! ERROR;'SKIP'), ('MAT2' M2) : (Y2 ! ('MAT2'N2): M2:=N2 ! ERROR;'SKIP'), ('MAT3' M3) : (Y2 ! ('MAT3'N3): M3:=N3 ! ERROR;'SKIP') 'ESAC'; 'PRIO' <= = 1; 'PR' EJECT 'PR' 'PROC' SETHMAX = 'VOID': HMAX:=(5.15*I10*I10/SIGMA1, 2.29*I11*I11/SIGMA1); 'PROC' COEFS = ('REAL'MU,'REF''REAL'C0,C1,C2)'VOID': ('REAL'H=(MU-1.0)/2.0; C0:=MU*H; C1:=MU*(2.0-MU); C2:=(MU-2.0)*H); 'PROC' HSTART = 'REAL': 'BEGIN' Y<=F(X+1.0/SIGMA1,Y0+DY0/SIGMA1); I7+:=1; 'REAL' H=SQRT(TOL*(1.0+'NORMN'Y0)/('NORMN'(Y-DY0)/SIGMA1+APR))/ (10.0*SIGMA1); 'REAL'BETA=(0.03*I11+0.44)*I11*I11/SIGMA1; ( H > BETA ! BETA ! H ) 'END' # HSTART #; 'PR' EJECT 'PR' 'PROC' PARAMETERS = 'VOID': 'IF' I13 >= 2 'THEN' 'IF' I12 = 1 'THEN' C:='CASE' I9 'IN' 'SKIP', ( .196179108153153E-01,-.819133839887796E-01), ( .118770833204169E-01, .231938014958962E-01, -.836224904085872E-01 ), ( .502235784145405E-02, .160403498495377E-01, .244549990929813E-01,-.841706944235470E-01), ( .256552542325433E-02, .732618047358780E-02, .179205096424427E-01, .249952482317057E-01, -.844664795876864E-01 ), ( .147590086841280E-02, .393878786691768E-02, .854928660674426E-02, .189082409351579E-01, .252848045490299E-01,-.846748027041508E-01), ( .936009001657179E-03, .238161338313533E-02, .479984161017022E-02, .934093457283131E-02, .195837202952756E-01, .254890213216190E-01, -.846762952424460E-01 ), ( .621208643675004E-03, .152988388394921E-02, .293955452497717E-02, .530879923795716E-02, .977956724823542E-02, .199117768782379E-01, .255743782041622E-01,-.848341040905063E-01), ( .437863941687100E-03, .105070104957003E-02, .194810939391503E-02, .334205908735129E-02, .568826270362038E-02, .101228956947610E-01, .201930400326675E-01, .256552664466804E-01, -.848758196191359E-01 ), ( .319003551606634E-03, .750441552138759E-03, .135512843852341E-02, .224177051902781E-02, .362083393064834E-02, .594531512787039E-02, .103457938352773E-01, .203552435862669E-01, .256696005247616E-01,-.848828756811515E-01), ( .239290574831534E-03, .554550605703332E-03, .981992770967527E-03, .158247116919796E-02, .246482057306043E-02, .383982071684931E-02, .616121737479852E-02, .105616496567079E-01, .205807414639380E-01, .257865208509710E-01, -.848610861828170E-01 ), ( .183910770082614E-03, .420489588740360E-03, .732175695428057E-03, .115485736168240E-02, .174888304261575E-02, .262225659606503E-02, .398430251326684E-02, .628601048469427E-02, .106542788963470E-01, .206155478607057E-01, .257688949530674E-01,-.849687025858925E-01) 'ESAC'; LA:='CASE' I9 'IN' 'SKIP', ( .236114213662133E-01, .809186111261504E+00), ( .143058304739038E-01, .279630468008499E-01, .810895217681313E+00 ), ( .604601593926948E-02, .193222931324168E-01, .294798704381324E-01, .811443421696271E+00), ( .310308507303124E-02, .885640714653679E-02, .216533580523272E-01, .301941237256040E-01, .811739206860413E+00 ), ( .179545954712348E-02, .478549256497673E-02, .103753549279950E-01, .229237084688118E-01, .306233945802681E-01, .811947529976877E+00), ( .113130766493322E-02, .287826089439570E-02, .580016214292456E-02, .112863654109042E-01, .236595412149794E-01, .307901131589646E-01, .811949022515172E+00 ), ( .757132294865622E-03, .186353369611307E-02, .357827309500765E-02, .645748051106268E-02, .118853580483738E-01, .241746594171167E-01, .310101134988965E-01, .812106831363231E+00), ( .531535941947433E-03, .127560436756909E-02, .236524020440182E-02, .405769435085915E-02, .690588808135792E-02, .122878703679312E-01, .245036225997679E-01, .311098505248339E-01, .812148546891862E+00 ), ( .388018193257131E-03, .912675201054015E-03, .164783698586841E-02, .272551148183035E-02, .440121292680665E-02, .722471822342052E-02, .125675683895335E-01, .247132280269183E-01, .311366984352272E-01, .812155602953876E+00), ( .291393271477073E-03, .674703224401576E-03, .119376551375253E-02, .192224289253953E-02, .299186843520478E-02, .465774143076075E-02, .746893835164741E-02, .127958247948468E-01, .249199861274321E-01, .312038578351279E-01, .812133813455542E+00 ), ( .224316509871435E-03, .512691029141716E-03, .892424643530829E-03, .140717446493261E-02, .213033881270347E-02, .319324626489569E-02, .485035466704903E-02, .764969261852752E-02, .129599605413823E-01, .250613004257468E-01, .312921276379243E-01, .812241429858616E+00) 'ESAC'; B[1]:='CASE' I9 'IN' 'SKIP', .508727967095290E+00, .509560637580446E+00, .509914825396269E+00, .509857456549888E+00, .509678390414901E+00, .509981771419273E+00, .509637782352229E+00, .509635656502979E+00, .509618959570098E+00, .509880951278163E+00, .509524549723448E+00 'ESAC'; B[2]:= .545454545454545E+00 'ELSE' C:='CASE' I9 'IN' 'SKIP', (-.208272450838904E-01,-.176251440856983E+00), (-.521139515771502E-02,-.204537454654857E-01, -.150676811658657E+00 ), (-.176147103226697E-02,-.599278115368554E-02, -.197072880138351E-01,-.142474486805669E+00), (-.107134982667340E-02,-.299826649785043E-02, -.712560734620138E-02,-.199442161680483E-01, -.137422017332368E+00 ), (-.604231670180290E-03,-.159896048375198E-02, -.342559706795734E-02,-.740230723385568E-02, -.198255427211443E-01,-.135145414990056E+00), (-.278318214941009E-03,-.759118883031255E-03, -.162347074429806E-02,-.330855861378489E-02, -.713176540776259E-02,-.194704888086196E-01, -.134458609951604E+00 ), (-.334232361412569E-03,-.797991874144314E-03, -.147651320422721E-02,-.254478755055698E-02, -.441770433556241E-02,-.831853342706601E-02, -.201674003517510E-01,-.131979437775493E+00), (-.158892315555575E-03,-.393069506998231E-03, -.746927988185854E-03,-.130401770897648E-02, -.223868649325021E-02,-.397090940159806E-02, -.775863209229052E-02,-.197134148378149E-01, -.132298893246350E+00 ), (-.121634600402596E-03,-.285848818062940E-03, -.515794575668280E-03,-.852757517498779E-03, -.137638312131043E-02,-.225710356079413E-02, -.391592582882930E-02,-.764252602126261E-02, -.197179875092944E-01,-.130466073638779E+00), (-.662549438807673E-04,-.156067719540023E-03, -.281948853670529E-03,-.465572994842910E-03, -.746665755072325E-03,-.120341693364751E-02, -.200516410945224E-02,-.357248721108888E-02, -.719819395117924E-02,-.192024247631614E-01, -.132831492930022E+00 ), (-.102994642718880E-03,-.233554144657848E-03, -.402675009004956E-03,-.627463855782561E-03, -.935735406620758E-03,-.137525755447902E-02, -.203399874416459E-02,-.308979758208251E-02, -.495345032599209E-02,-.879895286766497E-02, -.202795277896725E-01,-.129842261469204E+00) 'ESAC'; LA:='CASE' I9 'IN' 'SKIP', ( .115772850207917E+00, .146657402150214E+01), ( .322706885592909E-01, .134046076063337E+00, .144099939230382E+01 ), ( .133871778214583E-01, .430088863850882E-01, .140105103325491E+00, .143279706745083E+01), ( .698672737950515E-02, .199346838452588E-01, .487542837640687E-01, .143571376454619E+00, .142774459797752E+01 ), ( .404201634876247E-02, .107707066239925E-01, .233452828887895E-01, .515966013501086E-01, .145212460730911E+00, .142546799563522E+01), ( .250603246302696E-02, .637655067062040E-02, .128626589598059E-01, .250863264662972E-01, .528138271220564E-01, .145809052032436E+00, .142478119059676E+01 ), ( .171740945875112E-02, .422943439361717E-02, .812597847930835E-02, .146732920126255E-01, .270192532661166E-01, .549219749365157E-01, .147340106604082E+00, .142230201842065E+01), ( .118497529615894E-02, .284489191348582E-02, .527875153282853E-02, .906579186025930E-02, .154529857439050E-01, .275515487743281E-01, .550704625416572E-01, .147252559486519E+00, .142262147389151E+01 ), ( .872783455089815E-03, .205324088453152E-02, .370790338925039E-02, .613438873286459E-02, .990882002529492E-02, .162718375233707E-01, .283274752602443E-01, .558390840810137E-01, .148799097042613E+00, .142078865428394E+01), ( .651788683046089E-03, .150791044134571E-02, .266511608463482E-02, .428578241618491E-02, .666023888900999E-02, .103513856309803E-01, .165742099478320E-01, .283755209595168E-01, .553606804108775E-01, .146972053779980E+00, .142315407357518E+01 ), ( .506971342083145E-03, .115940247548512E-02, .201964144358370E-02, .318762357481359E-02, .483179707553261E-02, .725433442802687E-02, .110418894355304E-01, .174581139505522E-01, .296446922358879E-01, .572907032015069E-01, .148817451454787E+00, .142016484211436E+01) 'ESAC'; B[1]:='CASE' I9 'IN' 'SKIP', -.268261337736233E-01, -.280884356184020E-01, -.278187239988046E-01, -.286526610855615E-01, -.287331992850827E-01, -.283378889783029E-01, -.295164279931444E-01, -.288902503205175E-01, -.288400811815056E-01, -.282269850319168E-01, -.298918878159484E-01 'ESAC'; B[2]:= -.580645161290320E+00 'FI' 'ELSE' B:=(0.0,0.0); 'FOR' I 'TO' I9 'DO' C[I]:=0.0 'OD'; LA:= 'CASE' I9 'IN' 'SKIP', ( .500000000000000E+00, .100000000000000E+01), ( .126608170000000E+00, .500000000000000E+00, .100000000000000E+01 ), ( .469321699961169E-01, .158054716000000E+00, .500000000000000E+00, .100000000000000E+01), ( .224728454998609E-01, .663203570561843E-01, .171211150000000E+00, .500000000000000E+00, .100000000000000E+01 ), ( .125236991593134E-01, .340607016912871E-01, .763290844635254E-01, .178036992000000E+00, .500000000000000E+00, .100000000000000E+01), ( .770639365836728E-02, .198641861737173E-01, .408535008054067E-01, .821994942335218E-01, .182050816000000E+00, .500000000000000E+00, .100000000000000E+01 ), ( .508510799953263E-02, .126230349649284E-01, .245473612167101E-01, .451875345069677E-01, .859462164497931E-01, .184616448000000E+00, .500000000000000E+00, .100000000000000E+01), ( .353435602181355E-02, .853260075977219E-02, .159562606514131E-01, .277222917290663E-01, .481258801498683E-01, .884868940567993E-01, .186357896000000E+00, .500000000000000E+00, .100000000000000E+01 ), ( .255731571963207E-04, .604300164829694E-02, .109795602340940E-01, .183220858017351E-01, .299757552073369E-01, .502114708086094E-01, .902904742681478E-01, .187594930000000E+00, .500000000000000E+00, .100000000000000E+01), ( .191070301553967E-02, .443895271219574E-02, .788881113551870E-02, .127799643987028E-01, .200627788700101E-01, .316337674220291E-01, .517459968097393E-01, .916176293139941E-01, .188505622000000E+00, .500000000000000E+00, .100000000000000E+01 ), ( .146551036584494E-02, .335795377137199E-02, .586417870669934E-02, .928689073356087E-02, .141436426176712E-01, .213812201947804E-01, .328895812991588E-01, .529082908860623E-01, .926229273207144E-01, .189195696000000E+00, .500000000000000E+00, .100000000000000E+01) 'ESAC' 'FI'; 'OP''DISTURB' = ('VMM'Y)'VMM': 'CASE' Y 'IN' ('VEC' V ):('HEAP'[1:'UPB'V]['LWB'V[1]:'UPB'V[1]]'REAL'Z; 'FOR' I 'TO' 'UPB'V 'DO' 'FOR' J 'FROM' 'LWB'V[1] 'TO' 'UPB'V[1] 'DO' 'REAL'RA=(RANDOM*2.0-1.0)*TOLLIP; Z[I][J]:=(V[I][J]=0.0!RA!(1.0+RA)*V[I][J]) 'OD' 'OD'; Z), ('MAT2' M2):('HEAP'[1:'UPB'M2]['LWB'M2[1]:'UPB'M2[1], 2'LWB'M2[1]:2'UPB'M2[1]]'REAL'Z; 'FOR' I 'TO' 'UPB'M2 'DO' 'FOR' J 'FROM' 'LWB'M2[1] 'TO' 'UPB'M2[1] 'DO' 'FOR' K 'FROM'2'LWB'M2[1] 'TO'2'UPB'M2[1] 'DO' 'REAL'RA=(RANDOM*2.0-1.0)*TOLLIP; Z[I][J,K]:=(M2[I][J,K]=0.0!RA!(1.0+RA)*M2[I][J,K]) 'OD' 'OD' 'OD'; Z), ('MAT3' M3):('HEAP'[1:'UPB'M3]['LWB'M3[1]:'UPB'M3[1], 2'LWB'M3[1]:2'UPB'M3[1], 3'LWB'M3[1]:3'UPB'M3[1]]'REAL'Z; 'FOR' I 'TO' 'UPB'M3 'DO' 'FOR' J 'FROM' 'LWB'M3[1] 'TO' 'UPB'M3[1] 'DO' 'FOR' K 'FROM'2'LWB'M3[1] 'TO'2'UPB'M3[1] 'DO' 'FOR' L 'FROM'3'LWB'M3[1] 'TO'3'UPB'M3[1] 'DO' 'REAL'RA=(RANDOM*2.0-1.0)*TOLLIP; Z[I][J,K,L]:=(M3[I][J,K,L]=0.0!RA!(1.0+RA)*M3[I][J,K,L]) 'OD' 'OD' 'OD' 'OD'; Z) 'ESAC'; 'PROC' POWERMETHOD = 'VOID': 'BEGIN''REAL'SIGM:=0.0,SIGM1,NORM; ( I2 = 3 ! I2:=1 ); I15:=0; Y<=DY0; DY0<= 'DISTURB' Y0; DY1<=F(X,DY0); I7+:=1; I8+:=1; 'REAL' NORM0=TOLLIP*( 'REAL'S0='NORM'DY0; S0 < 1.0 ! 1.0 ! S0 ); 'BOOL' OUT:='FALSE', NOUPDATE:='FALSE'; 'FOR' K 'WHILE' ( K = 51 ! IFLAG:=3; ENDPM ); NORM:='NORM'(Y-DY1); SIGM1:=SIGM; SIGM:=NORM/NORM0; ( K = 3 ! ( SIGMA1 = 0.0 ! SIGMA2:=SIGM )); 'IF' K > 2 'THEN' 'IF' SIGMA1 /= 0.0 'THEN' 'IF' SIGM >= SIGMA2*0.9 'THEN' NOUPDATE:='TRUE' 'ELSE' SIGMA2:=SIGM; SIGMA1:=0.0 'FI' 'FI' 'FI'; 'IF' NOUPDATE 'THEN' OUT:='TRUE' 'ELIF'('ABS'(SIGM1-SIGM)/SIGM <= 0.001)'AND' K > 4 'THEN' SIGMA1:=SIGM*1.1;OUT:='TRUE' 'ELSE' Y<=F(X,DY0+(Y-DY1)/SIGM); I7+:=1; I8+:=1 'FI'; 'NOT' OUT 'DO' 'SKIP' 'OD'; DY0<=F(X,Y0); I7+:=1; I8+:=1; 'IF' I13 /= 0 'THEN' DY1<=F(X-H,Y1); I7+:=1; I8+:=1 'FI'; ENDPM:'SKIP' 'END' #POWERMETHOD#; 'PR' EJECT 'PR' 'PROC' MAXIMAL DEGREE = 'VOID': 'BEGIN' []'REAL'Q=(3.E1,1.E2,7.E2,4.E3,3.E4,2.E5,9.E5,5.E6,3.E7,2.E8,1.E9); 'REAL'E=TOL/APR; 'INT' M; 'IF' Q[1] > E 'THEN' IFLAG:=2 'ELSE' M:=11; 'WHILE' Q[M] > E 'DO' M-:=1 'OD'; I10:=M+1; 'IF' Q[1]*100.0 > E 'THEN' IFLAG:=2 'ELSE' M:=11; 'WHILE' Q[M]*100.0 > E 'DO' M-:=1 'OD'; I11:=M+1 'FI' 'FI' 'END' #MAXIMAL DEGREE#; 'PROC' MINIMAL DEGREE = 'INT': 'BEGIN' 'BOOL'START=I13 < 2, 'REAL'BETA=( I12 = 2 ! 2.29 ! 5.15 ); 'INT'M:=2; 'TO' ( I12 = 2 ! I11 ! I10 ) - 1 'WHILE' H > ( START ! M*0.03+0.44 ! BETA)*M*M/SIGMA1 'DO' M+:=1 'OD'; M 'END' #MINIMAL DEGREE#; 'PROC' STEP = 'VOID': 'BEGIN' 'REAL'D= ( I13 < 2 ! 1.0 ! 1.375-(I12-1)*0.6 ); Y<=DY0; 'FOR' J 'TO' I9-2 'DO' Y<=F(X+(C[J]+LA[J])*H,Y0+H*(C[J]*DY1+LA[J]*Y)); I7+:=1 'OD'; Y<=F(X+(-B[1]+C[I9-1]+LA[I9-1])*H, (1.0-B[1])*Y0+B[1]*Y1+H*(C[I9-1]*DY1+LA[I9-1]*Y)); I7+:=1; Y<=D*((1.0-B[2])*Y0+B[2]*Y1+H*(C[I9]*DY1+LA[I9]*Y))+(1.0-D)*Y2 'END' #STEP# ; 'PROC' ESTIMATE ERROR = 'VOID': 'BEGIN' [ ]'REAL'CONST=(2.85,0.49); EPS:=TOL*(1+'NORMN'Y0); ERROR:=CONST[I12]*('CASE' I12 'IN' 'NORMN'(Y-2.0*Y0+Y1), 'NORMN'(Y-3.0*(Y0-Y1)-Y2) 'ESAC') 'END' # ESTIMATE ERROR #; 'PR' EJECT 'PR' 'PROC' NEWH = 'VOID': 'IF' 'REAL' EPSERR = EPS/ERROR; EPSERR > 1 'AND' I14 < 3 'THEN' ALFA:=1.0 'ELSE' ALFA:=EPSERR**(1/(I12+1))/(2-(I12-1)*0.4); 'IF' ALFA > 0.9 'AND' ALFA < 1.1 'THEN' ALFA:=1.0 'ELSE' ( ALFA > 3.0 ! ALFA:=3.0 ); ( ALFA < 0.1 ! ALFA:=0.1 ); H:=HOLD*ALFA; ( H > HMAX[I12] ! H:=HMAX[I12] ); ALFA:=H/HOLD 'FI' 'FI' ; 'PROC' INTER1 = 'VOID': 'BEGIN' 'REAL'C10,C11,C12,C20,C21,C22; COEFS(2.0-ALFA,C10,C11,C12); COEFS(2.0-2.0*ALFA,C20,C21,C22); Y1<=C12*Y2+C11*Y1+C10*Y0; Y2<=(C22-C21*C12/C11)*Y2+C21/C11*Y1+(C20-C21*C10/C11)*Y0; DY1<=F(X-H,Y1); I7+:=1; I14:=0 'END' #INTER1#; 'PROC' INTER2 = ('REAL'A)'VOID': 'BEGIN' 'REAL'C0,C1,C2; COEFS(2.0-A,C0,C1,C2); Y<=C2*Y2+C1*Y1+C0*Y0 'END' #INTER2#; 'PR' EJECT 'PR' 'PROC' SHIFT = 'VOID': 'BEGIN' Y2<=Y1; Y1<=Y0; Y0<=Y; DY1<=DY0; DY0<=F(X+HOLD,Y0); I7+:=1; X+:=HOLD 'END' #SHIFT#; 'PROC' RESTART = 'VOID': 'BEGIN' I6+:=1; I5+:=3; I9:=I13:=I14:=I15:=0; X-:=H*2.0; H/:=10.0; Y0<=Y2; DY0<=F(X,Y0); I7+:=1 'END' #RESTART#; 'PROC' CHECK ORDER 1 TO 2 = 'VOID': ( H < HMAX[2] ! I9:=0; I12:=2 ); 'PROC' CHECK ORDER 2 TO 1 = 'VOID': 'IF' I14 >= 3 'AND' HOLD = HMAX[2] 'AND' H = HMAX[2] 'THEN' I12:=1; ESTIMATE ERROR; NEWH; (ALFA <= 1.0 ! I12:=2 ); H:=HMAX[2]; I14:=-1; ( I12 = 1 ! I9:=0 ) 'FI'; 'PR' EJECT 'PR' 'REAL'HOLD,EPS,ERROR,ALFA, 'INT' REJECT:=0, [1:2]'REAL'B,HMAX,'FLEX'[1:12]'REAL'C,LA; 'IF' 'NOT' I1 'AND' X>=XE 'THEN' INTER2((X-XE)/H) 'ELSE' IFLAG:=0; MAXIMAL DEGREE; ( IFLAG=2 ! EXIT ); I9:=0; 'IF' 'NOT' I1 'THEN' HOLD:=H 'ELSE'I4:=I5:=I6:=I7:=I8:=I13:=I14:=I15:=0; I12:=2; Y0<=Y; DY0<=F(X,Y0); I7+:=1; DY1 'INITIAL' 0.0; Y1 'INITIAL' 0.0; Y2 'INITIAL' 0.0; 'IF' I2 /= 1 'THEN' SIGMA1:=0.0; POWERMETHOD; ( IFLAG = 3 ! EXIT ) 'FI'; HOLD:=H:=HMIN:=HSTART; I1:='NOT' I1 'FI'; SETHMAX; 'BOOL' CHECK DEGREE:='TRUE'; 'WHILE' X= I3 ! IFLAG:=1; EXIT ); ( H < HMIN ! HMIN:=H ); STEP; I13+:=1; I4+:=1; 'IF' I13 < 3 'THEN' SHIFT; I14+:=1; I15+:=1; 'IF' I13 = 1 'THEN' CHECK DEGREE:='FALSE' 'ELSE' I9:=0 'FI' 'ELSE' ESTIMATE ERROR; 'IF' EPS < ERROR 'THEN' 'IF' I13 = 3 'THEN' RESTART 'ELSE''IF' I2 /= 1 'AND' I15 /= 0 'THEN' SIGMA1:=0.0; POWERMETHOD; ( IFLAG = 3 ! EXIT ! SETHMAX ) 'FI'; HOLD:=H; NEWH; ( I12 = 1 ! CHECK ORDER 1 TO 2); REJECT+:=1; I5+:=1; 'IF' REJECT = 3 'THEN' REJECT:=0; I6+:=1; I9:=0; I12:=2; I13:=I14:=0; HOLD:=H:=HSTART 'ELSE' INTER1 'FI' 'FI' 'ELSE' HOLD:=H; NEWH; ( I12 = 1 ! CHECK ORDER 1 TO 2); ( I12 = 2 ! CHECK ORDER 2 TO 1); SHIFT; REJECT:=0; I14+:=1; I15+:=1; 'IF' I2 /= 1 'AND' I15 = 25 'THEN' POWERMETHOD; ( IFLAG = 3 ! EXIT ! SETHMAX ) 'FI'; 'IF' X < XE 'THEN' 'IF' H /= HOLD 'THEN' INTER1 'ELIF' I9 /= 0 'THEN' CHECK DEGREE:='FALSE' 'FI' 'FI' 'FI' 'FI' 'OD'; INTER2((X-XE)/HOLD); 'IF' I13 /= 1 'THEN' ( H /= HOLD ! INTER1 ) 'FI' 'FI' ; EXIT: 'SKIP' 'END' #M3RK#; 'PR' PROG 'PR' 'SKIP' 'END' ################################################################################ INTPRL : # 780214 BS # 'BEGIN''COMMENT' FRACTIONAL, 1-STEP SPLITMETHOD USED WITH LINE-HOPSCOTCH SPLITTING(FORMULA 2.2,NN15) WITH PRESCRIBED STEPLENGTH. 'COMMENT' 'PROC'('REAL')'MAT' Y EXACT ; 'MODE' 'SPLITINFO' = 'STRUCT'('MAT' BR,CR,DR,BK,CK,DK,YNM1, 'REF'[ ]'INT' E,W,S,N, 'BOOL' XDIR, 'REAL' TNM1, 'INT' ITER, 'BOOL' NONLINEAR ); 'SPLITINFO' SPLINFO; 'PROC' ONESTEPLHS = ('REAL' X, H, 'REF''MAT' YY, 'REF''INFOINT' INFO, 'PROC'('INT','INT','REAL','MAT')'REAL' DER, B, 'REF'[ , ]'INT'POS)'VOID': 'BEGIN' 'INT' RMAX = 1 'UPB' YY, KMAX = 2 'UPB' YY; 'INT' RMAX1 = RMAX - 1, KMAX1 = KMAX - 1; 'MAT' Y = 'HEAP'[1 : RMAX, 1 : KMAX]'REAL':= YY, YHALF = 'HEAP'[1 : RMAX, 1 : KMAX]'REAL', 'REF''MAT' BR = BR 'OF' SPLINFO, CR = CR 'OF' SPLINFO, DR = DR 'OF' SPLINFO, BK = BK 'OF' SPLINFO, CK = CK 'OF' SPLINFO, DK = DK 'OF' SPLINFO, YN = YY, YNM1 = YNM1 'OF' SPLINFO, 'REF' 'REF' [ ]'INT' E = E 'OF' SPLINFO, W = W 'OF' SPLINFO, S = S 'OF' SPLINFO, N = N 'OF' SPLINFO, 'REF''REAL' TNM1 = TNM1 'OF' SPLINFO, 'REF''BOOL' XDIR = XDIR 'OF' SPLINFO, FIRST CALL=FIRST CALL 'OF' INFO; 'COMMENT' 'OP' 'NORM' = ('VEC' Y)'REAL' : ( SQRT(Y * Y / 'UPB' Y) ); 'OP' 'NORM' = ('MAT' Y)'REAL' : ( 'REAL' S:= 0.0; 'FOR' I 'TO' 1 'UPB' Y 'DO' S +:= Y[I, ] 'INGR' POS[I, ] * Y[I, ] 'OD'; SQRT(S / NUMGP 'OF' INFO) ); 'COMMENT' 'PROC' ZEROVEC = ('VEC' V)'VOID' : 'FOR' I 'TO' 'UPB' V 'DO' V[I]:= 0 'OD'; 'PROC' ZEROMAT = ('MAT' Z)'VOID' : 'FOR' R 'TO' 1 'UPB' Z 'DO' ZEROVEC(Z[R, ]) 'OD'; 'PROC' ROWVEC = ('INT' R, 'MAT' Y)'VEC' : 'BEGIN' 'HEAP'[1 : KMAX]'REAL' B; ZEROVEC(B); 'FOR' K 'FROM' W[R] 'TO' E[R] 'DO' B[K]:= DER(R, K, X + H / 2, Y) 'OD'; B 'END' # ROWVEC #; 'PROC' COLVEC = ('INT' K, 'MAT' Y)'VEC' : 'BEGIN' 'HEAP'[1 : RMAX]'REAL' B; ZEROVEC(B); 'FOR' R 'FROM' S[K] 'TO' N[K] 'DO' B[R]:=DER(R,K,X+H/2,Y) 'OD'; B 'END' #COLVEC#; 'PROC' UPDATEROWJAC = ('INT' R)'VOID' : 'BEGIN' 'INT'WR = W[R], ER = E[R], 'REAL' FU; [WR : ER]'REAL' DY; 'PROC' ADD = ('INT' K, KK)'MAT' : 'BEGIN' 'HEAP'[R-1:R+1,K-1:K+1]'REAL' YPLUSDY; 'FOR'I'FROM' R-1 'TO' R+1 'DO' 'FOR'J'FROM' K-1 'TO' K+1 'DO' YPLUSDY[I,J]:=YN[I,J] 'OD' 'OD'; YPLUSDY[R,KK]+:=(POS[R,KK]=1!DY[KK]!0.0); YPLUSDY 'END' #ADD#; 'FOR' K 'FROM' WR 'TO' ER 'DO' DY[K]:=1.E-6*(1+'ABS'YN[R,K]) 'OD'; FU:=DER(R,WR,X,YN); CR[R,WR]:=1-H/2*(DER(R,WR,X,ADD(WR,WR))-FU)/DY[WR]; DR[R,WR]:= -H/2*(DER(R,WR,X,ADD(WR,WR+1))-FU)/DY[WR+1]; 'FOR' K 'FROM' WR+1 'TO' ER-1 'DO' FU:=DER(R,K,X,YN); BR[R,K-1]:= -H/2*(DER(R,K,X,ADD(K,K-1))-FU)/DY[K-1]; CR[R,K] :=1-H/2*(DER(R,K,X,ADD(K,K))-FU)/DY[K]; DR[R,K] := -H/2*(DER(R,K,X,ADD(K,K+1))-FU)/DY[K+1] 'OD'; FU:=DER(R,ER,X,YN); BR[R,ER-1]:= -H/2*(DER(R,ER,X,ADD(ER,ER-1))-FU)/DY[ER-1]; CR[R,ER] :=1-H/2*(DER(R,ER,X,ADD(ER,ER))-FU)/DY[ER] 'END' #UPDATEROWJAC#; 'PROC' UPDATECOLJAC = ('INT' K)'VOID' : 'BEGIN' 'INT'SK = S[K], NK = N[K], 'REAL' FU; [SK : NK]'REAL' DY; 'PROC' ADD = ('INT' R, RR)'MAT' : 'BEGIN' 'HEAP'[R-1:R+1,K-1:K+1]'REAL' YPLUSDY; 'FOR'I'FROM' R-1 'TO' R+1 'DO' 'FOR'J'FROM' K-1 'TO' K+1 'DO' YPLUSDY[I,J]:=YN[I,J] 'OD' 'OD'; YPLUSDY[RR,K]+:=(POS[RR,K]=1!DY[RR]!0.0); YPLUSDY 'END' #ADD#; 'FOR' R 'FROM' SK 'TO' NK 'DO' DY[R]:=1.E-6*(1+'ABS'YN[R,K]) 'OD'; FU:=DER(SK,K,X,YN); CK[SK,K]:=1-H/2*(DER(SK,K,X,ADD(SK,SK))-FU)/DY[SK]; DK[SK,K]:= -H/2*(DER(SK,K,X,ADD(SK,SK+1))-FU)/DY[SK+1]; 'FOR' R 'FROM' SK + 1 'TO' NK - 1 'DO' FU:=DER(R,K,X,YN); BK[R-1,K]:= -H/2*(DER(R,K,X,ADD(R,R-1))-FU)/DY[R-1]; CK[R,K] :=1-H/2*(DER(R,K,X,ADD(R,R))-FU)/DY[R]; DK[R,K] := -H/2*(DER(R,K,X,ADD(R,R+1))-FU)/DY[R+1] 'OD'; FU:=DER(NK,K,X,YN); BK[NK-1,K]:= -H/2*(DER(NK,K,X,ADD(NK, NK-1))-FU)/DY[NK - 1]; CK[NK, K] :=1-H/2*(DER(NK, K,X,ADD(NK, NK))-FU)/DY[NK] 'END' # UPDATECOLJAC #; 'OP' 'INGR' = ('VEC' A, 'REF'[ ]'INT' POS)'VEC' : 'BEGIN''INT' U = 'UPB' A; 'VEC' B = 'HEAP'[1 : U]'REAL'; 'FOR' I 'TO' U 'DO' B[I]:= ( POS[I] = INSIDE ! A[I] ! 0 ) 'OD'; B 'END' # OF INGR #; 'PRIO' 'INGR' = 7; 'PROC' NEWTRICONVERGENCE=('PROC''VEC' ROWCOLVEC,'TRIDIAMAT'MAT, 'VEC' RHS, YY, 'REF'[ ]'INT' POS, 'INT' WS, EN)'BOOL' : 'BEGIN' 'VEC' CORR; 'BOOL'CONVERG; 'TO' 10 'WHILE' CORR:= SOLTRI(WS, EN, MAT, RHS - YY - H / 2 * ROWCOLVEC)'INGR' POS; 'FOR' I 'FROM' WS 'TO' EN 'WHILE' CONVERG:='ABS' CORR[I] < 1.0E-8 * (1 + 'ABS'RHS[I]) 'DO' 'SKIP' 'OD'; RHS:=RHS-CORR; ITER 'OF' SPLINFO +:= 1; PRINT("*"); 'NOT' CONVERG 'DO' 'SKIP' 'OD'; CONVERG 'END' # NEWTRICONVERGENCE #; 'PROC' PREDICTOR = ('INT' R, K, 'REAL' Q)'VOID' : Y[R, K]:= (Q + 1.0) * YN[R, K] - Q * YNM1[R, K]; 'COMMENT' 'PROC' LOCAL ERROR = 'REAL': 'BEGIN' 'REAL' Q = 1; Q/(1.0+Q)*'NORM'(Q*YNM1-(1.0+Q)*YN+Y) 'END'; 'COMMENT' 'PROC' ROWJACOBIAN = ('INT' R)'VOID' : 'BEGIN' UPDATEROWJAC(R); DECTRI(W[R],E[R],(BR[R, ],CR[R, ],DR[R, ])) 'END'; 'PROC' COLJACOBIAN = ('INT' K)'VOID' : 'BEGIN' UPDATECOLJAC(K); DECTRI(S[K],N[K],(BK[ ,K],CK[ ,K],DK[ ,K])) 'END'; 'COMMENT' 'PROC' NEWMATRIX = 'VOID' : 'BEGIN' 'FOR' R 'TO' RMAX 'DO' NEWLU(W[R],E[R],(BR[R, ],CR[R, ],DR[R, ])) 'OD'; 'FOR' K 'TO' KMAX 'DO' NEWLU(S[K],N[K],(BK[ ,K],CK[ ,K],DK[ ,K])) 'OD' 'END'; 'PROC' NEWLU = ('INT' MIN, MAX,'TRIDIAMAT' MAT)'VOID' : 'BEGIN' 'VEC' SUB = SUB 'OF' MAT, DIAG = DIAG 'OF' MAT, SUP = SUPER 'OF' MAT; 'REAL' U,V,W; U:=DIAG[MIN]; DIAG[MIN]:=1.0-ALFA*(1.0-U); V:=SUP[MIN]; SUP[MIN]:=ALFA*V*U/DIAG[MIN]; W:=SUB[MIN]; SUB[MIN]*:=ALFA; 'FOR' I 'FROM' MIN+1 'TO' MAX-1 'DO'U:=DIAG[I];DIAG[I]:=1.0-ALFA*(1.0-U-W*V)-SUP[I-1]*SUB[I-1]; V:=SUP[I]; SUP[I]*:=ALFA*U/DIAG[I]; W:=SUB[I]; SUB[I]*:=ALFA 'OD'; DIAG[MAX]:=1.0-ALFA*(1.0-DIAG[MAX]-W*V)-SUP[MAX-1]*SUB[MAX-1] 'END'; 'COMMENT' 'PROC' BV=('REAL'T,'MAT'Y)'VOID' : 'FOR' R 'TO' RMAX 'DO' 'FOR' K 'TO' KMAX 'DO' 'IF' POS[R, K] = BORDER 'THEN''REAL' CORR,BJ,DY; 'WHILE' BJ:=B(R,K,T,Y); DY:=1.E-6*(1.0+'ABS'Y[R,K]); Y[R,K]+:=DY; CORR:=DY*BJ/(B(R,K,T,Y)-BJ); Y[R,K]-:=DY+CORR; 'ABS' CORR > 1.E-10*(1.0+'ABS'Y[R,K]) 'DO' 'SKIP' 'OD' 'FI' 'OD''OD' # OF BV #; 'IF' FIRST CALL 'THEN' E:='HEAP'[2:RMAX1]'INT'; W:='HEAP'[2:RMAX1]'INT'; S:='HEAP'[2:KMAX1]'INT'; N:='HEAP'[2:KMAX1]'INT'; 'FOR' R 'FROM' 2 'TO' RMAX1 'DO' 'INT'K:=2; 'WHILE' POS[R,K]/=1 'DO' K+:=1 'OD'; W[R]:=K; K:=KMAX1; 'WHILE' POS[R,K]/=1 'DO' K-:=1 'OD'; E[R]:=K 'OD'; 'FOR' K 'FROM' 2 'TO' KMAX1 'DO' 'INT'R:=2; 'WHILE' POS[R,K]/=1 'DO' R+:=1 'OD'; S[K]:=R; R:=RMAX1; 'WHILE' POS[R,K]/=1 'DO' R-:=1 'OD'; N[K]:=R 'OD'; XDIR:= 'TRUE'; BR:= 'HEAP'[1 : RMAX, 1 : KMAX]'REAL'; CR:= 'HEAP'[1 : RMAX, 1 : KMAX]'REAL'; DR:= 'HEAP'[1 : RMAX, 1 : KMAX]'REAL'; BK:= 'HEAP'[1 : RMAX, 1 : KMAX]'REAL'; CK:= 'HEAP'[1 : RMAX, 1 : KMAX]'REAL'; DK:= 'HEAP'[1 : RMAX, 1 : KMAX]'REAL'; YNM1:= 'HEAP'[1 : RMAX, 1 : KMAX]'REAL'; TNM1:= X - H; YNM1 :=Y EXACT( TNM1 ); ZEROMAT(BR); ZEROMAT(CR); ZEROMAT(DR); ZEROMAT(BK); ZEROMAT(CK); ZEROMAT(DK); COMPUTE H 'OF' INFO := 'FALSE'; ITER 'OF' SPLINFO := 0 'FI'; 'IF' NONLINEAR 'OF' SPLINFO 'OR' FIRST CALL 'THEN' 'FOR' R 'FROM' 2 'TO' RMAX1 'DO' ROWJACOBIAN(R) 'OD'; 'FOR' K 'FROM' 2 'TO' KMAX1 'DO' COLJACOBIAN(K) 'OD'; FIRST CALL := 'FALSE' 'FI'; XDIR := 'NOT' XDIR; LAST STEP OK 'OF' INFO:= 'FALSE'; BV(X + H / 2, Y); 'IF' XDIR 'THEN' 'FOR' R 'FROM' 2 'BY' 2 'TO' RMAX1 'DO' Y[R, ]:= Y[R, ] + H/2 * ROWVEC(R, YN) 'OD'; 'FOR' R 'FROM' 3 'BY' 2 'TO' RMAX1 'DO''FOR' K 'FROM' W[R] 'TO' E[R] 'DO''IF' POS[R, K] = INSIDE 'THEN' PREDICTOR(R, K, H/(2.0*(X-TNM1)) ) 'FI' 'OD'; 'IF' 'NOT' NEWTRICONVERGENCE('VEC' : ROWVEC(R, Y), (BR[R, ],CR[R, ],DR[R, ]), Y[R, ], YN[R, ] 'INGR' POS[R, ], POS[R, ], W[R], E[R]) 'THEN' PRINT((NEWLINE,"GEEN CONVERGENTIE VOOR R=", R)); ENDLOOP 'ELSE' PRINT((NEWLINE,"WEL CONVERGENTIE VOOR R=", R)) 'FI' 'OD'; YHALF:= Y; 'FOR' R 'FROM' 3 'BY' 2 'TO' RMAX1 'DO' Y[R, ]:=Y[R, ]+H/2*ROWVEC(R,YHALF) 'OD'; 'FOR' R 'FROM' 2 'BY' 2 'TO' RMAX1 'DO''FOR' K 'FROM' W[R] 'TO' E[R] 'DO''IF' POS[R, K] = INSIDE 'THEN' PREDICTOR(R, K, H/(X-TNM1) ) 'FI' 'OD'; 'IF' 'NOT' NEWTRICONVERGENCE('VEC' : ROWVEC(R, Y), (BR[R, ],CR[R, ],DR[R, ]), Y[R, ], YHALF[R, ] 'INGR' POS[R, ], POS[R, ], W[R], E[R]) 'THEN' PRINT((NEWLINE,"GEEN CONVERGENTIE VOOR R=", R)); ENDLOOP 'ELSE' PRINT((NEWLINE,"WEL CONVERGENTIE VOOR R=", R)) 'FI' 'OD' 'ELSE' 'FOR' K 'FROM' 2 'BY' 2 'TO' KMAX1 'DO' Y[ ,K]:=Y[ ,K]+H/2*COLVEC(K,YN) 'OD'; 'FOR' K 'FROM' 3 'BY' 2 'TO' KMAX1 'DO''FOR' R 'FROM' S[K] 'TO' N[K] 'DO''IF' POS[R, K] = INSIDE 'THEN' PREDICTOR(R, K, H/(2.0*(X-TNM1)) ) 'FI' 'OD'; 'IF' 'NOT' NEWTRICONVERGENCE('VEC' : COLVEC(K, Y), (BK[ ,K],CK[ ,K],DK[ ,K]), Y[ ,K], YN[ ,K] 'INGR' POS[ ,K], POS[ ,K], S[K], N[K]) 'THEN' PRINT((NEWLINE,"GEEN CONVERGENTIE VOOR K=", K)); ENDLOOP 'ELSE' PRINT((NEWLINE,"WEL CONVERGENTIE VOOR K=", K)) 'FI' 'OD'; YHALF:=Y; 'FOR' K 'FROM' 3 'BY' 2 'TO' KMAX1 'DO' Y[ ,K]:=Y[ ,K]+H/2*COLVEC(K,YHALF) 'OD'; 'FOR' K 'FROM' 2 'BY' 2 'TO' KMAX1 'DO''FOR' R 'FROM' S[K] 'TO' N[K] 'DO''IF' POS[R, K] = INSIDE 'THEN' PREDICTOR(R, K, H/(X-TNM1) ) 'FI' 'OD'; 'IF' 'NOT' NEWTRICONVERGENCE('VEC' : COLVEC(K, Y), (BK[ ,K],CK[ ,K],DK[ ,K]), Y[ ,K], YHALF[ ,K] 'INGR' POS[ ,K], POS[ ,K], S[K], N[K]) 'THEN' PRINT((NEWLINE,"GEEN CONVERGENTIE VOOR K=", K)); ENDLOOP 'ELSE' PRINT((NEWLINE,"WEL CONVERGENTIE VOOR K=", K)) 'FI' 'OD' 'FI'; LOCAL ERROR 'OF' INFO:= 0.0; LAST STEP OK 'OF' INFO:= 'TRUE'; ORDER 'OF' INFO:= 1; TNM1:=X; YNM1:=YN; YY:=Y; ENDLOOP : 'SKIP' 'END' # ONESTEPLHS #; 'PR' PROG 'PR' 'SKIP' 'END' # OF PARTICULAR PRELUDE : INTEGRATOR ONESTEPLHS, FORMULA 2.2 # ################################################################################ LL1: 'BEGIN' # DIT PROGRAMMA VERZORGT HET INLEZEN EN PRINTEN VAN EEN GRAMMATICA, WAARBIJ EVENTUELE FOUTEN IN DE GRAMMATICA GESIGNALEERD WORDEN. EEN LIJST VAN ALLE VOORKOMENDE IDENTIFIERS WORDT AFGEDRUKT. # 'CHAR' COMMA = ",", POINT = ".", COLON = ":", SEMICOLON = ";", OPENSYMBOL = "(", CLOSESYMBOL = ")", SUB = "[", BUS = "]", EOFSYMBOL = "$"; 'CHAR' SYM, [1:80] 'CHAR' IDF, 'INT' IDFPTR; 'INT' TERMINAL = 1, NONTERMINAL = 2, UNKNOWN = 3, DEFINED TWICE = 4; 'INT' NOTION NUMBER:= 0; 'BOOL' ERROR IN GRAMMAR:= 'FALSE'; 'FILE' IN, OUT; 'PROC' CHAR IN STRING = ('CHAR' C, 'STRING' S) 'BOOL': ('BOOL' FOUND:= 'FALSE'; 'FOR' K 'FROM' 'LWB' S 'TO' 'UPB' S 'WHILE' 'NOT' FOUND 'DO' (C = S[K] ! FOUND:= 'TRUE') 'OD'; FOUND); 'PR' EJECT 'PR' 'MODE' 'GRAMMAR' = 'STRUCT' ('REF' 'TERMINALS' TERM, 'REF' 'RULES' RULES), 'TERMINALS' = 'STRUCT' ('NOTION' N, 'REF' 'TERMINALS' TAIL), 'RULES' = 'STRUCT' ('RULE' R, 'REF' 'RULES' TAIL), 'RULE' = 'STRUCT' ('NOTION' LHS, 'ALTERNATIVES' RHS), 'ALTERNATIVES' = 'STRUCT' ('ALTERNATIVE' A, 'REF' 'ALTERNATIVES' TAIL), 'ALTERNATIVE' = 'STRUCT' ('MEMBER' M, 'REF' 'ALTERNATIVE' TAIL), 'MEMBER' = 'UNION' ('NOTION', 'REF' 'OPTNOTIONS'), 'NOTION' = 'REF' 'INFO', 'INFO' = 'STRUCT' ('STRING' S, 'INT' KIND, NUMBER, 'BOOL' MACRO, PREFIX), 'OPTNOTIONS' = 'STRUCT' ('NOTION' N, 'REF' 'OPTNOTIONS' TAIL), 'TREE' = 'STRUCT' ('INFO' NOTION, 'REF' 'TREE' LEFT, RIGHT); 'PRIO' 'TRAVERSE' = 6; 'OP' 'TRAVERSE' = ('REF' 'RULES' RS, 'PROC'('REF' 'RULE') 'VOID' P) 'VOID': ('REF' 'RULES' RULES:= RS; 'WHILE' RULES 'ISNT' 'REF' 'RULES'('NIL') 'DO' P(R 'OF' RULES); RULES:= TAIL 'OF' RULES 'OD'); 'OP' 'TRAVERSE' = ('REF' 'ALTERNATIVES' A, 'PROC' ('REF' 'ALTERNATIVE') 'VOID' P) 'VOID': ('REF' 'ALTERNATIVES' ALTS:= A; 'WHILE' ALTS 'ISNT' 'REF' 'ALTERNATIVES'('NIL') 'DO' P(A 'OF' ALTS); ALTS:= TAIL 'OF' ALTS 'OD'); 'OP' 'TRAVERSE' = ('REF' 'ALTERNATIVE' A, 'PROC' ('MEMBER') 'VOID' P) 'VOID': ('REF' 'ALTERNATIVE' ALT:= A; 'WHILE' ALT 'ISNT' 'REF' 'ALTERNATIVE'('NIL') 'DO' P(M 'OF' ALT); ALT:= TAIL 'OF' ALT 'OD'); 'OP' 'TRAVERSE' = ('REF' 'OPTNOTIONS' O, 'PROC' ('NOTION') 'VOID' P) 'VOID': ('REF' 'OPTNOTIONS' OPT:= O; 'WHILE' OPT 'ISNT' 'REF' 'OPTNOTIONS'('NIL') 'DO' P(N 'OF' OPT); OPT:= TAIL 'OF' OPT 'OD'); 'PR' EJECT 'PR' 'GRAMMAR' GRAMMAR := ('NIL', 'NIL'); 'PROC' READ TERMINALS = 'VOID': ('REF' 'TERMINALS' BEGIN:= 'NIL'; 'REF' 'REF' 'TERMINALS' END:= BEGIN; 'WHILE' NEXTSYM; END:= TAIL 'OF' ('REF' 'REF' 'TERMINALS'(END):= 'HEAP' 'TERMINALS':= (READ NOTION (TERMINAL), 'NIL')); 'IF' SYM /= SEMICOLON 'AND' SYM /= POINT 'THEN' ERROR ("INCORRECT END OF TERMINAL", ";.") 'FI'; SYM /= POINT 'DO' 'SKIP' 'OD'; TERM 'OF' GRAMMAR:= BEGIN ); # READ TERMINALS # 'PROC' READ NOTION = ('INT' KIND) 'NOTION': ('BOOL' MACRO = SYM = "*", PREFIX = SYM = "<"; 'IF' MACRO 'THEN' 'IF' KIND /= NONTERMINAL 'THEN' ERROR ("MACRO SYMBOL NOT ALLOWED HERE", "*") 'FI'; NEXTSYM 'ELIF' PREFIX 'THEN' 'IF' KIND /= TERMINAL 'THEN' ERROR ("PREFIX SYMBOL NOT ALLOWED HERE", "<") 'FI'; NEXTSYM 'FI'; 'IF' CHAR IN STRING (SYM, "ABCDEFGHIJKLMNOPQRSTUVWXYZ") 'THEN' 'BOOL' BL:= 'FALSE'; IDF[IDFPTR:= 1]:= SYM; 'WHILE' CHAR IN STRING (SYM:= NEXT, " ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") 'DO' 'IF' SYM = BLANK 'THEN' BL:= 'TRUE' 'ELSE' (BL ! BL:= 'FALSE'; IDF[IDFPTR +:= 1]:= BLANK); IDF[IDFPTR +:= 1]:= SYM 'FI' 'OD'; BUFPTR -:= 1; NEXTSYM; SEARCH TREE('HEAP' 'INFO':= (IDF[:IDFPTR], KIND, (KIND /= UNKNOWN ! NOTION NUMBER +:= 1), MACRO, PREFIX), ROOT) 'ELSE' ERROR ("INCORRECT BEGIN OF NOTION", ":,;."); 'HEAP' 'INFO':= (BLANK, UNKNOWN, 1, MACRO, PREFIX) 'FI'); # READ NOTION # [1:80] 'CHAR' BUF, 'INT' BUFPTR:= 80, 'INT' BUFLENGTH = 80; 'PROC' NEXT = 'CHAR': 'IF' BUFPTR >= BUFLENGTH 'THEN' GET(IN, (BUF, NEWLINE)); PUT(OUT, (WHOLE(LINE NUMBER(IN)-1, -5), " ", BUF, NEWLINE)); BUF[BUFPTR:= 1] 'ELSE' BUF[BUFPTR +:= 1] 'FI'; 'PROC' NEXTSYM = 'VOID': # LEVERT EERSTVOLGENDE SYMBOOL ONGELIJK BLANK; SKIPT COMMENTAAR # 'BEGIN' SYM:= NEXT; 'WHILE' SYM = SUB 'OR' SYM = BLANK 'DO' 'IF' SYM = SUB 'THEN' 'WHILE' NEXT /= BUS 'DO' 'SKIP' 'OD'; SYM:= NEXT 'ELSE' 'WHILE' SYM = " " 'DO' SYM:= NEXT 'OD' 'FI' 'OD' 'END'; # NEXTSYM # 'PROC' READ RULES = 'VOID': ( # SYM = "." # 'REF' 'RULES' BEGIN:= 'NIL'; 'REF' 'REF' 'RULES' END:= BEGIN; 'WHILE' NEXTSYM; SYM /= EOFSYMBOL 'DO' END:= TAIL 'OF' ('REF' 'REF' 'RULES'(END):= 'HEAP' 'RULES':= (READ RULE, 'NIL')) 'OD'; RULES 'OF' GRAMMAR:= BEGIN ); # READ RULES # 'PROC' READ RULE = 'RULE': ('NOTION' N = READ NOTION (NONTERMINAL); 'IF' SYM /= COLON 'THEN' SYM:= COLON; ERROR ("COLON MISSING", ":") 'FI'; (N, READ ALTERNATIVES)); # READ RULE # 'PROC' READ ALTERNATIVES = 'ALTERNATIVES': ( # SYM = ":" # 'REF' 'ALTERNATIVES' BEGIN:= 'NIL'; 'REF' 'REF' 'ALTERNATIVES' END:= BEGIN; 'WHILE' END:= TAIL 'OF' ('REF' 'REF' 'ALTERNATIVES'(END):= 'HEAP' 'ALTERNATIVES':= (READ ALTERNATIVE, 'NIL')); 'IF' SYM /= SEMICOLON 'AND' SYM /= POINT 'THEN' ERROR ("INCORRECT END OF ALTERNATIVE", ";.") 'FI'; SYM /= POINT 'DO' 'SKIP' 'OD'; BEGIN); # READ ALTERNATIVES # 'PROC' READ ALTERNATIVE = 'ALTERNATIVE': ( # SYM = ":" OF" ";" # 'REF' 'ALTERNATIVE' BEGIN:= 'NIL'; 'REF' 'REF' 'ALTERNATIVE' END:= BEGIN; 'WHILE' END:= TAIL 'OF' ('REF' 'REF' 'ALTERNATIVE'(END):= 'HEAP' 'ALTERNATIVE':= (READ MEMBER, 'NIL')); 'IF' 'NOT' CHAR IN STRING (SYM, ".,;") 'THEN' ERROR ("INCORRECT END OF MEMBER", ".,;") 'FI'; SYM = COMMA 'DO' 'SKIP' 'OD'; BEGIN); # READ ALTERNATIVE # 'PROC' READ MEMBER = 'MEMBER': # SYM = ":" OF ";" OF "," # 'IF' NEXTSYM; CHAR IN STRING (SYM, ".;") 'THEN' EMPTY NOTION 'ELIF' SYM /= OPENSYMBOL 'THEN' READ NOTION (UNKNOWN) 'ELSE' 'REF' 'OPTNOTIONS' BEGIN:= 'NIL'; 'REF' 'REF' 'OPTNOTIONS' END:= BEGIN; 'WHILE' # SYM = "(" OF "," # NEXTSYM; END:= TAIL 'OF' ('REF' 'REF' 'OPTNOTIONS'(END):= 'HEAP' 'OPTNOTIONS':= (READ NOTION (UNKNOWN), 'NIL')); 'IF' SYM /= CLOSESYMBOL 'AND' SYM /= COMMA 'THEN' ERROR ("INCORRECT END OF NOTION", ",)") 'FI'; SYM /= CLOSESYMBOL 'DO' 'SKIP' 'OD'; NEXTSYM; BEGIN # SYM WAS CLOSESYMBOL, NU EEN MEMBER AFSLUITSYMBOOL, D.W.Z. SYM = ";" OF "," OF "." # 'FI'; # READ MEMBER # 'PROC' ERROR = ('STRING' MESSAGE, SKIPSTRING) 'VOID': (ERROR IN GRAMMAR:= 'TRUE'; SET CHAR NUMBER(OUT, BUFPTR + 5); PUT (OUT, ("^", NEWLINE, "**** ", MESSAGE, " ****", NEWLINE)); 'WHILE' 'NOT' CHAR IN STRING (SYM, SKIPSTRING) 'DO' NEXTSYM 'OD'); # ERROR # 'PROC' PRINT GRAMMAR = 'VOID': 'BEGIN' PUT(OUT, NEWPAGE); 'STRING' S; 'PROC' PRLHS = ('NOTION' N) 'VOID': PUT(OUT, (WHOLE(NUMBER 'OF' N, -4), " ", (MACRO 'OF' N ! "* " !: PREFIX 'OF' N ! "< " ! " "), S 'OF' N, S, NEWLINE)); 'PROC' PRNOT = ('NOTION' N) 'VOID': (PUT(OUT, (S, (CHAR NUMBER(OUT) > 60 ! (NEWLINE, " ") ! ""), S 'OF' N)); S:= ", "); 'REF' 'TERMINALS' T:= TERM 'OF' GRAMMAR; 'BOOL' END:= T 'IS' 'REF' 'TERMINALS'('NIL'); S:= (END ! "." ! ";"); 'WHILE' 'NOT' END 'DO' (END:= TAIL 'OF' T 'IS' 'REF' 'TERMINALS'('NIL') ! S:= "."); PRLHS(N 'OF' T); T:= TAIL 'OF' T 'OD'; PUT(OUT, NEWLINE); RULES 'OF' GRAMMAR 'TRAVERSE' (('REF' 'RULE' R) 'VOID': (S:= ":"; PRLHS(LHS 'OF' R); S:= " "; RHS 'OF' R 'TRAVERSE' (('REF' 'ALTERNATIVE' A) 'VOID': (A 'TRAVERSE' (('MEMBER' M) 'VOID': 'CASE' M 'IN' ('NOTION' N): PRNOT(N), ('REF' 'OPTNOTIONS' OPT): ((CHAR NUMBER(OUT) > 50 ! PUT(OUT, (S, NEWLINE)); S:= " (" ! S +:= "(" ); OPT 'TRAVERSE' (('NOTION' N) 'VOID': PRNOT(N)); PUT(OUT, ")"); S:= ", ") 'ESAC'); S:= "; ")); PUT(OUT, (".", NEWLINE)))); PUT(OUT, NEWPAGE) 'END'; 'PR' EJECT 'PR' 'REF' 'TREE' ROOT:= 'NIL'; 'PROC' SEARCH TREE = ('INFO' INFO, 'REF' 'REF' 'TREE' TREE) 'NOTION': 'IF' TREE 'IS' 'REF' 'TREE' ('NIL') 'THEN' TREE:= 'HEAP' 'TREE':= (INFO, 'NIL', 'NIL'); NOTION 'OF' TREE 'ELIF' S 'OF' INFO < S 'OF' NOTION 'OF' TREE 'THEN' SEARCH TREE (INFO, LEFT 'OF' TREE) 'ELIF' S 'OF' INFO > S 'OF' NOTION 'OF' TREE 'THEN' SEARCH TREE (INFO, RIGHT 'OF' TREE) 'ELIF' KIND 'OF' NOTION 'OF' TREE = UNKNOWN 'THEN' 'REF' 'INFO' R INFO = NOTION 'OF' TREE; R INFO:= INFO # I.P.V. BOVENSTAANDE 2 REGELS IS BETER: NOTION 'OF' TREE:= INFO ECHTER VERSIE 1.2.0 VAN DE A68 COMPILER ACCEPTEERT DIT NIET. # 'ELIF' KIND 'OF' INFO = UNKNOWN 'THEN' NOTION 'OF' TREE 'ELSE' KIND 'OF' NOTION 'OF' TREE:= DEFINED TWICE; NOTION 'OF' TREE 'FI'; 'PROC' PRINT NOTIONS = ('REF' 'TREE' TREE) 'VOID': 'IF' TREE 'ISNT' 'REF' 'TREE' ('NIL') 'THEN' PRINT NOTIONS (LEFT 'OF' TREE); 'INT' KIND = KIND 'OF' NOTION 'OF' TREE; PUT (OUT, ((KIND = TERMINAL 'OR' KIND = NONTERMINAL ! NOTION PTR[NUMBER 'OF' NOTION 'OF' TREE]:= NOTION 'OF' TREE; " " ! ERROR IN GRAMMAR:= 'TRUE'; ""), S 'OF' NOTION 'OF' TREE)); 'IF' CHAR NUMBER (OUT) > 34 'THEN' NEWLINE (OUT) 'FI'; SET CHAR NUMBER (OUT, 35); PUT (OUT, (('BOOL' M = MACRO 'OF' NOTION 'OF' TREE, P = PREFIX 'OF' NOTION 'OF' TREE; 'CASE' KIND 'IN' (" : TERMINAL ", (P !" :PREFIX" !"")), (" : NONTERMINAL", (M !" :MACRO" !"")), " : NOT DEFINED", " : DEFINED TWICE" 'ESAC'), NEWLINE)); PRINT NOTIONS (RIGHT 'OF' TREE) 'FI'; 'PR' EJECT 'PR' ESTABLISH (IN, "GRAMIN", STAND IN CHANNEL, 1, 1000, 80); OUT:= STANDOUT; ON LOGICAL FILE END (IN, ('REF' 'FILE' FILE) 'BOOL': (PUT (OUT, ("** PREMATURE END OF FILE **")); EXIT)); READ TERMINALS; 'INT' SYMBOLS = NOTION NUMBER; 'NOTION' EMPTY NOTION = SEARCH TREE( 'HEAP' 'INFO':= ("* EMPTY *", NONTERMINAL, NOTION NUMBER +:= 1, 'FALSE', 'FALSE'), ROOT); READ RULES; [1 : NOTION NUMBER] 'NOTION' NOTION PTR; CLOSE(IN); PUT (OUT, NEWPAGE); PRINT NOTIONS (ROOT); PRINT GRAMMAR; PUT (OUT, (NEWLINE, NEWLINE, (ERROR IN GRAMMAR !"IN"!""), "CORRECT INPUT GRAMMAR")); 'PR' EJECT 'PR' COLLECT GARBAGE; PUT(OUT, (NEWPAGE, "*** SOME STATISTICS***", NEWLINE, WHOLE(PROGSIZE, -10), " : SIZE OF PROGRAM (IN WORDS)", NEWLINE, WHOLE(MAX ALLOCATED STACK, -10), " : MAX ALLOCATED STACK", NEWLINE, WHOLE(HEAPSIZE, -10), " : SIZE OF THE HEAP (IN WORDS)", NEWLINE, WHOLE(AVAILABLE, -10), " : NUMBER OF FREE WORDS", NEWLINE, NEWLINE, WHOLE(COLLECTIONS, -10), " : NUMBER OF GARBAGE COLLECTIONS", NEWLINE, WHOLE(GARBAGE, -10), " : AMOUNT OF GARBAGE COLLECTED", NEWLINE, NEWLINE, FIXED(COLLECT SECONDS, -10, 2), " : CP TIME SPENT IN GARBAGE " "COLLECTOR", NEWLINE, FIXED(CLOCK, -10, 2), " : TOTAL TIME TO READ THE GRAMMAR")); 'IF' ERROR IN GRAMMAR 'THEN' EXIT 'FI'; 'PR' EJECT 'PR' # LL (1) CHECKER # 'MODE' 'STORENOTION' = 'STRUCT' ('BOOL' B, 'NOTION' N); 'BOOL' LL1:= 'TRUE'; 'INT' TAIL = - NOTION NUMBER 'MOD' BITS WIDTH; 'INT' NOTION BOUND = NOTION NUMBER + TAIL; 'INT' UPB I = 'ROUND' (NOTION BOUND / BITS WIDTH); [1 : NOTION BOUND] 'BOOL' ROWFALSE, ROW; [1 : NOTION BOUND] 'STORENOTION' STRUCTFALSE; 'FOR' I 'TO' NOTION BOUND 'DO' ROWFALSE[I]:= 'FALSE'; STRUCTFALSE[I]:= ('FALSE', 'NIL') 'OD'; [1 : NOTION BOUND, 1 : UPB I] 'BITS' FIRST, FIRST STAR, FOLLOW, LAST, LAST STAR; 'FOR' J 'TO' NOTION BOUND 'DO' 'FOR' I 'TO' UPB I 'DO' FIRST[J, I]:= LAST[J, I]:= FOLLOW[J, I]:= 2R0 'OD' 'OD'; [1 : UPB I] 'INT' LSLICE, USLICE; 'FOR' I 'TO' UPB I 'DO' LSLICE[I]:= BITS WIDTH * (I - 1) + 1; USLICE[I]:= BITS WIDTH * I 'OD'; PUT (OUT, NEWPAGE); 'PR' EJECT 'PR' [1 : NOTION BOUND] 'BOOL' POSSIBLY EMPTY:= ROWFALSE; 'PROC' CHECK FOR EMPTY PRODUCTIONS = 'VOID': ( # CHECK WHICH NOTIONS PRODUCE EMPTY. THE PROCEDURE CONTINUES UNTIL THERE ARE NO MORE CHANGES # POSSIBLY EMPTY[SYMBOLS + 1]:= 'TRUE'; 'BOOL' ANY:= 'FALSE'; 'WHILE' 'BOOL' CHANGED:= 'FALSE'; RULES 'OF' GRAMMAR 'TRAVERSE' (('REF' 'RULE' RULE) 'VOID': ('INT' NUMBER = NUMBER 'OF' LHS 'OF' RULE; 'IF' POSSIBLY EMPTY[NUMBER] 'THEN' 'SKIP' 'ELSE' 'REF' 'ALTERNATIVES' RHS:= RHS 'OF' RULE; 'BOOL' FOUND:= 'FALSE'; 'WHILE' (RHS 'ISNT' 'REF' 'ALTERNATIVES' ('NIL')) 'AND' 'NOT' FOUND 'DO' 'REF' 'ALTERNATIVE' ALT:= A 'OF' RHS; 'BOOL' EMPTY:= 'TRUE'; 'WHILE' (ALT 'ISNT' 'REF' 'ALTERNATIVE' ('NIL')) 'AND' EMPTY 'DO' 'CASE' M 'OF' ALT 'IN' ('NOTION' N): EMPTY:= POSSIBLY EMPTY[NUMBER 'OF' N] 'ESAC'; ALT:= TAIL 'OF' ALT 'OD'; 'IF' EMPTY 'THEN' POSSIBLY EMPTY[NUMBER]:= CHANGED:= ANY:= FOUND:= 'TRUE' 'FI'; RHS:= TAIL 'OF' RHS 'OD' 'FI')); CHANGED 'DO' 'SKIP' 'OD'; 'IF' ANY 'THEN' PUT (OUT, ("THE FOLLOWING NOTIONS MAY PRODUCE EMPTY:", NEWLINE)); 'FOR' I 'FROM' SYMBOLS + 2 'TO' NOTION NUMBER 'DO' 'IF' POSSIBLY EMPTY[I] 'THEN' PUT (OUT, (NEWLINE, S 'OF' NOTION PTR[I])) 'FI' 'OD' 'ELSE' PUT (OUT, "NO RULE PRODUCES EMPTY") 'FI'; 'TO' 5 'DO' PUT (OUT, NEWLINE) 'OD'; CHECK ONLY ONE ALTERNATIVE YIELDS EMPTY ); # CHECK FOR EMPTY PRODUCTIONS # 'PROC' CHECK ONLY ONE ALTERNATIVE YIELDS EMPTY = 'VOID': # THIS PROCEDURE CHECKS WHETHER NOT MORE THAN ONE ALTERNATIVE OF A POSSIBLY EMPTY NOTION YIELDS EMPTY # RULES 'OF' GRAMMAR 'TRAVERSE' (('REF' 'RULE' RULE) 'VOID': 'IF' POSSIBLY EMPTY[NUMBER 'OF' LHS 'OF' RULE] 'THEN' 'INT' NUMB OF EMPTIES:= 0; RHS 'OF' RULE 'TRAVERSE' (('REF' 'ALTERNATIVE' A) 'VOID': ('REF' 'ALTERNATIVE' ALT:= A; 'BOOL' EMPTY:= 'TRUE'; 'WHILE' (ALT 'ISNT' 'REF' 'ALTERNATIVE' ('NIL')) 'AND' EMPTY 'DO' 'CASE' M 'OF' ALT 'IN' ('NOTION' N): EMPTY:= POSSIBLY EMPTY[NUMBER 'OF' N] 'ESAC'; ALT:= TAIL 'OF' ALT 'OD'; 'IF' EMPTY 'THEN' NUMB OF EMPTIES +:= 1 'FI')); 'IF' NUMB OF EMPTIES > 1 'THEN' PUT (OUT, (NEWLINE, "IN ", S 'OF' LHS 'OF' RULE, WHOLE (NUMB OF EMPTIES, -2)," ALTERNATIVES YIELD EMPTY", NEWLINE)); LL1:= 'FALSE' 'FI' 'FI'); # CHECK ONLY ONE ALTERNATIVE YIELDS EMPTY # 'PROC' MAY BEGIN WITH = 'VOID': ( # THIS PROCEDURE DETERMINES THE RELATION "MAY BEGIN WITH". THE RESULT IS STORED IN "FIRST" (DIRECTLY BEGINNING WITH), ITS TRANSITIVE CLOSURE IN "FIRST STAR". WHILE DETERMINING "FIRST", ERROR MESSAGES ARE GIVEN FOR THE "DIRECT INITIAL UNCERTAINTIES" FOUND # 'PROC' BEGINS WITH = ('REF' 'RULE' RULE, 'INT' N) 'VOID': 'IF' ROW[N] 'THEN' PUT (OUT, (NEWLINE, "TWO ALTERNATIVES IN ", S 'OF' LHS 'OF' RULE, " START WITH ", S 'OF' NOTION PTR[N], NEWLINE)); ERRORS:= 'TRUE' 'ELSE' ROW[N]:= 'TRUE' 'FI'; # BEGINS WITH # 'BOOL' ERRORS:= 'FALSE'; RULES 'OF' GRAMMAR 'TRAVERSE' (('REF' 'RULE' RULE) 'VOID': ('INT' NUMBER = NUMBER 'OF' LHS 'OF' RULE; ROW:= ROWFALSE; RHS 'OF' RULE 'TRAVERSE' (('REF' 'ALTERNATIVE' A) 'VOID': ('REF' 'ALTERNATIVE' ALT:= A; 'WHILE' 'IF' ALT 'ISNT' 'REF' 'ALTERNATIVE' ('NIL') 'THEN' 'CASE' M 'OF' ALT 'IN' ('NOTION' N): ('INT' NUMBER = NUMBER 'OF' N; BEGINS WITH (RULE, NUMBER); POSSIBLY EMPTY[NUMBER]), ('REF' 'OPTNOTIONS' OPT): ('REF' 'OPTNOTIONS' OP:= OPT; 'WHILE' 'IF' OP 'ISNT' 'REF' 'OPTNOTIONS' ('NIL') 'THEN' 'INT' NUMBER = NUMBER 'OF' N 'OF' OP; BEGINS WITH (RULE, NUMBER); POSSIBLY EMPTY[NUMBER] 'ELSE' 'FALSE' 'FI' 'DO' OP:= TAIL 'OF' OP 'OD'; 'TRUE') 'ESAC' 'ELSE' 'FALSE' 'FI' 'DO' ALT:= TAIL 'OF' ALT 'OD')); 'FOR' I 'TO' UPB I 'DO' FIRST[NUMBER,I]:= BITSPACK (ROW[LSLICE[I] : USLICE[I]]) 'OD' )); 'IF' ERRORS 'THEN' LL1:= 'FALSE' 'ELSE' PUT (OUT, "NO DIRECT INITIAL UNCERTAINTIES FOUND") 'FI'; 'TO' 5 'DO' PUT (OUT, NEWLINE) 'OD'; TRANSITIVE CLOSURE (FIRST STAR:= FIRST) ); # MAY BEGIN WITH # 'PROC' LEFT RECURSION = 'VOID': ( # DETERMINES WHICH NOTIONS ARE LEFT-RECURSIVE AND IN THE MEANTIME SETS THE DIAGONAL OF FIRST STAR AND LAST STAR # 'BOOL' ANY:= 'FALSE'; [1 : BITS WIDTH] 'BOOL' ROW:= 2R0; 'FOR' I 'TO' UPB I 'DO' 'INT' J = (I - 1) * BITS WIDTH; 'FOR' K 'TO' BITS WIDTH 'DO' 'INT' IND = J + K; ROW[K]:= 'TRUE'; 'BITS' BITS = BITSPACK (ROW); ROW[K]:= 'FALSE'; 'IF' K 'ELEM' FIRST STAR[IND, I] 'THEN' 'IF' 'NOT' ANY 'THEN' PUT (OUT, ("THE FOLLOWING RULES ARE LEFT-RECURSIVE", NEWLINE)); ANY:= 'TRUE' 'FI'; PUT (OUT, (NEWLINE, S 'OF' NOTION PTR[IND])) 'ELSE' FIRST STAR[IND, I]:= FIRST STAR[IND, I] 'OR' BITS 'FI'; LAST STAR[IND, I]:= LAST STAR[IND, I] 'OR' BITS 'OD' 'OD'; 'IF' 'NOT' ANY 'THEN' PUT (OUT, "NO RULE IS LEFT-RECURSIVE") 'FI'; 'TO' 5 'DO' PUT (OUT, NEWLINE) 'OD' ); # LEFT RECURSION # 'PROC' MAY END WITH = 'VOID': ( # THIS PROCEDURE DETERMINES THE RELATION "MAY END WITH" # RULES 'OF' GRAMMAR 'TRAVERSE' (('REF' 'RULE' RULE) 'VOID': ('INT' NUMBER = NUMBER 'OF' LHS 'OF' RULE; ROW:= ROWFALSE; RHS 'OF' RULE 'TRAVERSE' (('REF' 'ALTERNATIVE' A) 'VOID': ('REF' 'ALTERNATIVE' LAST NON EMPTY:= A, ALT:= A; 'WHILE' ALT 'ISNT' 'REF' 'ALTERNATIVE' ('NIL') 'DO' 'CASE' M 'OF' ALT 'IN' ('NOTION' N): 'IF' 'NOT' POSSIBLY EMPTY[NUMBER 'OF' N] 'THEN' LAST NON EMPTY:= ALT 'FI' 'ESAC'; ALT:= TAIL 'OF' ALT 'OD'; LAST NON EMPTY 'TRAVERSE' (('MEMBER' M) 'VOID': 'CASE' M 'IN' ('NOTION' N): ROW[NUMBER 'OF' N]:= 'TRUE', ('REF' 'OPTNOTIONS' OPT): ('REF' 'OPTNOTIONS' LAST NON EMPTY OPT:= OPT, OP:= OPT; 'WHILE' OP 'ISNT' 'REF' 'OPTNOTIONS' ('NIL') 'DO' 'IF' 'NOT' POSSIBLY EMPTY[NUMBER 'OF' N 'OF' OP] 'THEN' LAST NON EMPTY OPT:= OP 'FI'; OP:= TAIL 'OF' OP 'OD'; LAST NON EMPTY OPT 'TRAVERSE' (('NOTION' N) 'VOID': ROW[NUMBER 'OF' N]:= 'TRUE')) 'ESAC'))); 'FOR' I 'TO' UPB I 'DO' LAST[NUMBER, I]:= BITSPACK (ROW[LSLICE[I] : USLICE[I]]) 'OD' )); TRANSITIVE CLOSURE (LAST STAR:= LAST) ); # MAY END WITH # 'PROC' TRANSITIVE CLOSURE = ('REF' [,] 'BITS' R) 'VOID': 'FOR' I 'TO' UPB I 'DO' 'FOR' K 'TO' BITS WIDTH 'DO' 'FOR' J 'TO' NOTION NUMBER 'DO' 'IF' K 'ELEM' R[J, I] 'THEN' 'INT' ROW = (I - 1) * BITS WIDTH + K; 'FOR' L 'TO' UPB I 'DO' R[J, L]:= R[J, L] 'OR' R[ROW, L] 'OD' 'FI' 'OD' 'OD' 'OD'; # TRANSITIVE CLOSURE # 'PROC' FOLLOW WITHIN = 'VOID': ( # THIS PROCEDURE DETERMINES THE SUCCESSIONS OF NOTIONS WITHIN THE PRODUCTION RULES # 'PROC' TREAT FOLLOWERS = ('REF' 'ALTERNATIVE' ALT) 'VOID': ('REF' 'ALTERNATIVE' FOLLOW:= TAIL 'OF' ALT; 'WHILE' 'IF' FOLLOW 'ISNT' 'REF' 'ALTERNATIVE' ('NIL') 'THEN' 'CASE' M 'OF' FOLLOW 'IN' ('NOTION' N): ('INT' NUMBER = NUMBER 'OF' N; ROW[NUMBER]:= 'TRUE'; POSSIBLY EMPTY[NUMBER]), ('REF' 'OPTNOTIONS' OPT): ('REF' 'OPTNOTIONS' OP:= OPT; 'WHILE' 'IF' OP 'ISNT' 'REF' 'OPTNOTIONS' ('NIL') 'THEN' 'INT' NUMBER = NUMBER 'OF' N 'OF' OP; ROW[NUMBER]:= 'TRUE'; POSSIBLY EMPTY[NUMBER] 'ELSE' 'FALSE' 'FI' 'DO' OP:= TAIL 'OF' OP 'OD'; 'TRUE') 'ESAC' 'ELSE' 'FALSE' 'FI' 'DO' FOLLOW:= TAIL 'OF' FOLLOW 'OD' ); # TREAT FOLLOWERS # 'PROC' FILL FOLLOW = ('INT' N) 'VOID': 'FOR' I 'TO' UPB I 'DO' FOLLOW[N, I]:= FOLLOW[N, I] 'OR' BITSPACK (ROW[LSLICE[I] : USLICE[I]]) 'OD'; # FILL FOLLOW # RULES 'OF' GRAMMAR 'TRAVERSE' (('REF' 'RULE' RULE) 'VOID': RHS 'OF' RULE 'TRAVERSE' (('REF' 'ALTERNATIVE' A) 'VOID': ('REF' 'ALTERNATIVE' ALT:= A; 'WHILE' ALT 'ISNT' 'REF' 'ALTERNATIVE' ('NIL') 'DO' 'CASE' M 'OF' ALT 'IN' ('NOTION' N): (ROW:= ROWFALSE; TREAT FOLLOWERS (ALT); FILL FOLLOW (NUMBER 'OF' N)), ('REF' 'OPTNOTIONS' OPT): ('REF' 'OPTNOTIONS' OP:= OPT; 'WHILE' OP 'ISNT' 'REF' 'OPTNOTIONS' ('NIL') 'DO' 'REF' 'OPTNOTIONS' OPT FOLLOW:= TAIL 'OF' OP; ROW:= ROWFALSE; 'BOOL' CONTINUE:= 'TRUE'; 'WHILE' (OPT FOLLOW 'ISNT' 'REF''OPTNOTIONS'('NIL')) 'AND' CONTINUE 'DO' ROW[NUMBER 'OF' N 'OF' OPT FOLLOW]:= 'TRUE'; CONTINUE:= POSSIBLY EMPTY[NUMBER 'OF' N 'OF' OPT FOLLOW]; OPT FOLLOW:= TAIL 'OF' OPT FOLLOW 'OD'; 'IF' CONTINUE 'THEN' TREAT FOLLOWERS (ALT) 'FI'; FILL FOLLOW (NUMBER 'OF' N 'OF' OP); OP:= TAIL 'OF'OP 'OD') 'ESAC'; ALT:= TAIL 'OF' ALT 'OD')))); # FOLLOW WITHIN # 'PR' EJECT 'PR' # CHECK FOR LL(1)-NESS # [1 : NOTION NUMBER] 'INT' K IND, I IND; 'FOR' IND 'TO' NOTION NUMBER 'DO' K IND[IND]:= (IND - 1) 'MOD' BITS WIDTH + 1; I IND[IND]:= (IND - 1) 'OVER' BITS WIDTH + 1 'OD'; 'PROC' REPORT INDIRECT INITIAL UNCERTAINTIES = 'VOID': ( # THIS PROCEDURE DETERMINES WHETHER TWO ALTERNATIVES OF ONE RULE START WITH THE SAME TERMINAL SYMBOL # 'BOOL' LEFT, ANY:= 'FALSE'; 'PROC' REPORT = ('INT' N1, N2) 'VOID': ('IF' 'NOT' ANY 'THEN' PUT (OUT, ("FOR THE FOLLOWING NOTIONS, ", "MORE THAN ONE ALTERNATIVE MAY", NEWLINE, " START WITH A GIVEN NOTION:", NEWLINE)); ANY:= 'TRUE'; LL1:= 'FALSE' 'FI'; PUT (OUT, NEWLINE); 'IF' LEFT 'THEN' PUT (OUT, (NEWLINE, S 'OF' NOTION PTR[N1], "-", NEWLINE)); LEFT:= 'FALSE' 'FI'; PUT (OUT, (" ", S 'OF' NOTION PTR[N2])) ); # REPORT # [1 : NOTION BOUND] 'BOOL' DIRECT START, START; 'FOR' N1 'FROM' SYMBOLS + 2 'TO' NOTION NUMBER 'DO' DIRECT START:= START:= ROWFALSE; LEFT:= 'TRUE'; 'FOR' I 'TO' UPB I 'DO' 'INT' J = (I - 1) * BITS WIDTH; 'FOR' K 'TO' BITS WIDTH 'DO' DIRECT START[J + K]:= K 'ELEM' FIRST[N1, I] 'OD' 'OD'; 'FOR' N2 'TO' NOTION NUMBER 'DO' 'IF' DIRECT START[N2] 'THEN' 'IF' N2 <= SYMBOLS 'THEN' START[N2]:= 'TRUE' 'ELSE' 'FOR' IND 'TO' SYMBOLS 'DO' 'IF' K IND[IND] 'ELEM' FIRST STAR[N2, I IND[IND]]'THEN' 'IF' START[IND] 'THEN' REPORT (N1, IND) 'ELSE' START[IND]:= 'TRUE' 'FI' 'FI' 'OD' 'FI' 'FI' 'OD' 'OD'; 'IF' 'NOT' ANY 'THEN' PUT (OUT, "NO INDIRECT INITIAL UNCERTAINTIES FOUND") 'FI'; 'TO' 5 'DO' PUT (OUT, NEWLINE) 'OD' ); # REPORT INDIRECT INITIAL UNCERTAINTIES # 'PROC' REPORT INDIRECT UNCERTAINTIES = 'VOID': ( # THIS PROCEDURE DETECTS VIOLATIONS OF REQUIREMENT 3 # 'INT' HANDLE; 'BOOL' ANY:= 'FALSE'; 'PROC' CHECK FOLLOW = ('REF' [] 'STORENOTION' START, 'NOTION' N) 'VOID': 'FOR' I 'TO' UPB I 'DO' 'INT' J = (I - 1) * BITS WIDTH; 'FOR' K 'TO' BITS WIDTH 'DO' 'INT' IND = J + K; 'IF' K 'ELEM' FIRST STAR[NUMBER 'OF' N, I] 'THEN' 'IF' B 'OF' START[IND] 'THEN' ANY:= 'TRUE'; PUT (OUT, (NEWLINE, NEWLINE, "IN ", S 'OF' NOTION PTR[HANDLE], " THE POSSIBLY EMPTY OR " "OPTIONAL NOTION ", S 'OF' N 'OF' START[IND], NEWLINE, " MAY BE FOLLOWED BY ", S 'OF' N, ";", NEWLINE, " BOTH MAY BEGIN WITH ", S 'OF' NOTION PTR[IND])) 'ELSE' START[IND]:= ('TRUE', N) 'FI' 'FI' 'OD' 'OD'; # CHECK FOLLOW # 'PROC' CHECK END = ('REF' [] 'STORENOTION' START) 'VOID': 'FOR' J 'FROM' SYMBOLS + 2 'TO' NOTION NUMBER 'DO' 'IF' K IND[HANDLE] 'ELEM' LAST STAR[J, I IND[HANDLE]] 'THEN' # J MAY END WITH HANDLE # 'FOR' I 'TO' UPB I 'DO' 'FOR' K 'TO' BITS WIDTH 'DO' 'IF' K 'ELEM' FOLLOW[J, I] 'THEN' # I MAY FOLLOW J # 'INT' IND I = (I - 1) * BITS WIDTH + K; [ ] 'BITS' FIRST STAR I = FIRST STAR[IND I, ]; [1 : NOTION BOUND] 'BOOL' SAVE FIRST STAR N:=ROWFALSE; 'FOR' N 'TO' NOTION NUMBER 'DO' 'IF' B 'OF' START[N] 'THEN' 'FOR' L 'TO' UPB I 'DO' 'FOR' M 'TO' BITS WIDTH 'DO' 'INT' IND L = (L - 1) * BITS WIDTH + M; 'IF' M 'ELEM' FIRST STAR[N, L] 'AND' M 'ELEM' FIRST STAR I[L] 'THEN' 'IF' SAVE FIRST STAR N[IND L] 'THEN' 'SKIP' 'ELSE' SAVE FIRST STAR N[IND L]:= 'TRUE'; PUT (OUT,(NEWLINE, NEWLINE, "THE NOTION ", S 'OF' N 'OF' START[N], " IS THE ", "BEGINNING OF THE POSSIBLY EMPTY", NEWLINE, " OR OPTIONAL LAST ", "MEMBER OF ", S 'OF' NOTION PTR[J], NEWLINE, " (VIA ", S 'OF' NOTION PTR[HANDLE], ")", NEWLINE, " AND MAY BE FOLLOWED BY ", S 'OF' NOTION PTR[IND I], ";", NEWLINE, " BOTH ", S 'OF' N 'OF' START[N], " AND ", S 'OF' NOTION PTR[IND I], " MAY BEGIN WITH ", S 'OF' NOTION PTR[IND L])); ANY:= 'TRUE' 'FI' 'FI' 'OD' 'OD' 'FI' 'OD' 'FI' 'OD' 'OD' 'FI' 'OD'; # CHECK END # PUT (OUT, ("VIOLATIONS OF REQUIREMENT 3", NEWLINE, "(I.E., AMBIGUITIES ARISING FROM EMPTY NOTIONS OR ", "OPTIONAL PARTS):", NEWLINE, NEWLINE)); [1 : NOTION BOUND] 'STORENOTION' START, OPTSTART; RULES 'OF' GRAMMAR 'TRAVERSE' (('REF' 'RULE' RULE) 'VOID': (HANDLE:= NUMBER 'OF' LHS 'OF' RULE; RHS 'OF' RULE 'TRAVERSE' (('REF' 'ALTERNATIVE' ALT) 'VOID': ('BOOL' TEST:= 'FALSE'; START:= STRUCTFALSE; ALT 'TRAVERSE' (('MEMBER' M) 'VOID': 'CASE' M 'IN' ('NOTION' N): 'IF' POSSIBLY EMPTY[NUMBER 'OF' N] 'THEN' CHECK FOLLOW (START, N); TEST:= 'TRUE' 'ELIF' TEST 'THEN' CHECK FOLLOW (START, N); START:= STRUCTFALSE; TEST:= 'FALSE' 'FI', ('REF' 'OPTNOTIONS' OPT): ('BOOL' AMBIGIOUS:= 'TRUE'; 'REF' [] 'STORENOTION' START1:= START; OPT START:= STRUCTFALSE; OPT 'TRAVERSE' (('NOTION' N) 'VOID': (CHECK FOLLOW (START1, N); 'IF' POSSIBLY EMPTY[NUMBER 'OF' N] 'THEN' 'SKIP' 'ELSE' START1:= OPT START:= STRUCTFALSE; AMBIGIOUS:= 'FALSE' 'FI')); 'FOR' I 'TO' NOTION NUMBER 'DO' 'IF' B 'OF' OPT START[I] 'THEN' B 'OF' START[I]:= 'TRUE' 'FI' 'OD'; TEST:= 'TRUE'; 'IF' AMBIGIOUS 'THEN' PUT (OUT, (NEWLINE,NEWLINE,"IN ", S 'OF' LHS 'OF' RULE, " THE OPTIONAL PART STARTING WITH ",S 'OF' N 'OF' OPT, " PRODUCES EMPTY IN MORE THAN ONE WAY", NEWLINE)) 'FI') 'ESAC'); 'IF' TEST 'THEN' CHECK END (START) 'FI')))); 'IF' ANY 'THEN' LL1:= 'FALSE' 'ELSE' PUT (OUT, "NONE") 'FI' ); # REPORT INDIRECT UNCERTAINTIES # CHECK FOR EMPTY PRODUCTIONS; MAY BEGIN WITH; MAY END WITH; LEFT RECURSION; REPORT INDIRECT INITIAL UNCERTAINTIES; FOLLOW WITHIN; REPORT INDIRECT UNCERTAINTIES; 'TO' 5 'DO' PUT (OUT, NEWLINE) 'OD'; PUT (OUT, ("THE GRAMMAR IS ", ('NOT' LL1 ! "NOT " ! ""), "OF TYPE LL(1)")); EXIT: CLOSE (OUT) 'END' # PROGRAM # ################################################################################ 'BEGIN' 'MODE' 'RYPIVOT' = 'STRUCT' ('REF' [] 'REAL' RIR, 'INT' NUM); 'MODE' 'LINSYSAUX' = 'STRUCT' ( 'REAL' RELTOL, PIVCONTROL, 'REF' 'INT' NUMELIM, 'REF' 'REAL' GROWTH, MAXELEM, 'REF' [,] 'REAL' X, 'REF' [] 'RYPIVOT' RI, 'REF' [] 'INT' CI); [1:10,1:10] 'REAL' A:= ((1,0,0,0,0,0,0,0,0,1),(-1,1,0,0,0,0,0,0,0,1), (-1,-1,1,0,0,0,0,0,0,1),(-1,-1,-1,1,0,0,0,0,0,1), (-1,-1,-1,-1,1,0,0,0,0,1),(-1,-1,-1,-1,-1,1,0,0,0,1), (-1,-1,-1,-1,-1,-1,1,0,0,1),(-1,-1,-1,-1,-1,-1,-1,1,0,1), (-1,-1,-1,-1,-1,-1,-1,-1,1,1),(-1,-1,-1,-1,-1,-1,-1,-1,-1,1)); [1:10] 'REAL' B:= (11,11,10,8,5,1,-4,-10,-17,-35); 'INT' OUT1; 'REAL' OUT2, OUT3; 'LINSYSAUX' AUX := (1E-14,8,OUT1,OUT2,OUT3,'NIL','NIL','NIL'); 'PROC' GSSELM = ('REF' [,] 'REAL' A, 'REF' 'LINSYSAUX' AUX) 'VOID': 'BEGIN' 'INT' N = 1'UPB' A 'MIN' 2'UPB' A; PRINT((NEWLINE,"N IS: ",N)); 'IF' 'NOT'('REF' [,] 'REAL'(X 'OF' AUX):=: 'REF' [,] 'REAL' (A)) 'THEN' X 'OF' AUX:= 'HEAP' [1:N,1:N] 'REAL':= A 'FI'; RI 'OF' AUX:= 'HEAP' [1:N] 'RYPIVOT'; 'REF' [] 'REF' [] 'REAL' RIRIR = RIR 'OF' (RI 'OF' AUX); 'FOR' I 'TO' 'UPB' A 'DO' RIRIR[I]:= (X 'OF' AUX)[I, ]; (NUM 'OF' (RI 'OF' AUX))[I]:= I 'OD'; 'PROC' ABSMAXMAT = ('REF' [] 'REF' [] 'REAL' RR, 'INT' LC, UC, 'REF' 'INT' R, C) 'REAL' : 'BEGIN' 'INT' UR = 'UPB' RR, LR = 'LWB' RR; 'REAL' AID, MAX:= 0; R:= C:= 1; 'FOR' I 'FROM' LR 'TO' UR 'DO' 'FOR' J 'FROM' LC 'TO' UC 'DO' AID:= 'ABS' (RR[I] [J]); 'IF' AID > MAX 'THEN' MAX:= AID; C:= J; R:= I 'FI' 'OD' 'OD'; MAX 'END'; 'INT' I,J,R1,H,RANK:= N; 'REAL' RGROW:= ABSMAXMAT(RIRIR[1:N],1,N,I,J); 'REAL' MAX1, PIVOT, AID, CRIT:= N * RGROW * PIVCONTROL 'OF' AUX, EPS:= RGROW * RELTOL 'OF' AUX, MAX:= ABSMAXMAT(RIRIR[1:N],1,1,I,J); 'BOOL' PARTIAL:= RGROW /= 0; 'REF' [] 'REAL' HV; MAXELEM 'OF' AUX:= RGROW; RGROW +:= MAX; 'FOR' R 'TO' N 'DO' R1:= R + 1; 'IF' I /= R 'THEN' HV:= RIRIR[R]; H:= (NUM 'OF' (RI 'OF' AUX))[R]; RIRIR[R]:= RIRIR[I]; (NUM 'OF' (RI 'OF' AUX))[R]:= (NUM 'OF' (RI 'OF' AUX))[I]; RIRIR[I]:= HV; (NUM 'OF' (RI 'OF' AUX))[I]:= H 'FI'; 'IF' PARTIAL 'THEN' PIVOT:= RIRIR[R] [R]; MAX:= MAX1:= 0; RIRIR[R] [R1:N]/:= PIVOT; 'FOR' P 'FROM' R1 'TO' N 'DO' RIRIR[P] [R1:N] -:= RIRIR [R] [R1:N] * RIRIR [P] [R]; AID:= 'ABS' RIRIR[P] [R1]; 'IF' MAX < AID 'THEN' MAX:= AID; I:= P 'FI' 'OD'; 'FOR' P 'FROM' R1 + 1 'TO' N 'DO' MAX1:= MAX1 'MAX' 'ABS'(RIRIR[I][P]) 'OD'; AID:= RGROW; RGROW +:= MAX1; 'IF' RGROW > CRIT 'OR' MAX < EPS 'THEN' PARTIAL:= 'FALSE'; CI 'OF' AUX := 'HEAP' [R1:N] 'INT'; RGROW:= AID; MAX:= ABSMAXMAT(RIRIR[R1:N @R1],R1,N,I,J) 'FI' # PARTIAL PIVOTING STEP # 'ELSE' ICH((X 'OF' AUX)[,J], (X 'OF' AUX)[,R]); (CI 'OF' AUX)[R]:= J; PIVOT:= RIRIR[R] [R]; 'IF' MAX < EPS 'THEN' RANK := R - 1; OUT 'FI'; RIRIR[R] [R1:N]/:= PIVOT; 'FOR' P 'FROM' R1 'TO' N 'DO' RIRIR[P] [R1:N] -:= RIRIR[R] [R1:N] * RIRIR[P] [R] 'OD'; MAX:= ABSMAXMAT(RIRIR[R1:N@R1],R1,N,I,J); 'IF' RGROW < MAX 'THEN' RGROW:= MAX 'FI' 'FI' # COMPLETE PIVOTING STEP # 'OD' #ELIMINATIONSTEP#; OUT: NUMELIM 'OF' AUX:= RANK; GROWTH 'OF' AUX:= RGROW 'END' #GSSELM#; 'PROC' GSSSOL = ('REF' 'LINSYSAUX' AUX, 'REF' [] 'REAL' B) 'VOID': 'BEGIN' 'INT' N = 'UPB' (RI 'OF' AUX); [1:N] 'REAL' NUMB; 'REF' [] 'REF' [] 'REAL' RIRIR = RIR 'OF' (RI 'OF' AUX); 'REAL' W; 'INT' NN = 'IF' 'REF' [] 'INT' (CI 'OF' AUX) :=: 'NIL' 'THEN' N+1 'ELSE' 'LWB' (CI 'OF' AUX) 'FI'; 'FOR' R 'TO' N 'DO' NUMB[R]:= B[(NUM 'OF' (RI 'OF' AUX))[R] ]; NUMB[R] -:= NUMB[1:R-1] ** RIRIR[R][1:R-1] /:= RIRIR[R] [R] 'OD'; 'FOR' R 'FROM' N 'BY' -1 'TO' 1 'DO' NUMB[R] -:= NUMB[R+1:N] ** RIRIR[R][R+1:N] 'OD'; B:= NUMB; 'FOR' R 'FROM' N 'BY' -1 'TO' NN 'DO' 'INT' CIR = (CI 'OF' AUX)[R]; 'IF' CIR /= R 'THEN' W:= B[R]; B[R]:= B[CIR]; B[CIR]:= W 'FI' 'OD' 'END' #GSSSOL#; 'PROC' GSSINV = ('REF' 'LINSYSAUX' AUX) 'VOID': 'BEGIN' 'INT' N = 'UPB' (RI 'OF' AUX); 'REF' [] 'REF' [] 'REAL' RIRIR = RIR 'OF' (RI 'OF' AUX); 'INT' CIR; 'INT' NN = 'IF' 'REF' [] 'INT' (CI 'OF' AUX) :=: 'NIL' 'THEN' N+1 'ELSE' 'LWB' (CI 'OF' AUX) 'FI'; [1:N] 'REAL' Y; RIRIR[N][N]:= 1/RIRIR[N][N]; 'FOR' K 'FROM' N-1 'BY' -1 'TO' 1 'DO' 'INT' K1 = K+1; Y[K1:N]:= RIRIR[K][K1] * RIRIR[K1][K1:N]; 'FOR' J 'FROM' K1+1 'TO' N 'DO' Y[K1:N]+:= RIRIR[K][J] * RIRIR[J][K1:N] 'OD'; 'FOR' J 'FROM' K1 'TO' N 'DO' RIRIR[K][J]:= -Y[J]; Y[J]:= RIRIR[J][K] 'OD'; 'REAL' R = RIRIR[K][K]; 'FOR' J 'FROM' K1 'TO' N 'DO' RIRIR[J][K]:= -Y[K1:N] ** RIRIR[J][K1:N]/R 'OD'; RIRIR[K][K]:= (1 - Y[K1:N] ** RIRIR[K][K1:N])/R 'OD'; 'FOR' R 'FROM' N 'BY' -1 'TO' NN 'DO' 'INT' CIR = (CI 'OF' AUX)[R]; 'IF' CIR /= R 'THEN' ICH((X 'OF' AUX)[R,],(X 'OF' AUX)[CIR,]) 'FI' 'OD' 'END' #GSSINV#; GSSELM(A,AUX); GSSSOL(AUX,B); 'REF' [,] 'REAL' XX:= X 'OF' AUX; 'REF' [] 'INT' RYP:= NUM 'OF' (RI 'OF' AUX); PRINT((NEWLINE,XX, NEWLINE,NEWLINE,NEWLINE, NEWLINE,RYP,NEWLINE,B, NEWLINE)); GSSINV(AUX); PRINT((NEWLINE,"INVERSE",NEWLINE,XX,NEWLINE)); PRINT((NEWLINE,"EENHEIDSMAT",NEWLINE)); 'FOR' I 'TO' 10 'DO' 'FOR' J 'TO' 10 'DO' 'REAL' HULP= XX[I,1:10] ** A[1:10,J]; PRINT(HULP) 'OD' 'OD'; PRINT((NEWLINE,"KOLOM PIVOTS")); 'IF' 'NOT' ('REF' [] 'INT' (CI 'OF' AUX) :=: 'NIL') 'THEN' 'FOR' I 'FROM' 'LWB' CI 'OF' AUX 'TO' 'UPB' CI 'OF' AUX 'DO' PRINT((NEWLINE,(CI 'OF' AUX)[I])) 'OD' 'FI' 'END' ################################################################################ 'BEGIN' 'MODE' 'INFINITE' = 'STRUCT' ('BOOL' POS); 'MODE' 'POINT' = 'UNION' ('REAL','INFINITE'); 'MODE' 'RANGE' = 'STRUCT' ('POINT' FROM, TO); 'MODE' 'FUN' = 'PROC' ('REAL') 'REAL'; 'MODE' 'INTPROB' = 'STRUCT' ('FUN' F, 'REAL' RELTOL, ABSTOL, HMIN, 'REF' 'INT' SKIPPED); 'INFINITE' INFINITE = ('INFINITE' I; POS 'OF' I := 'TRUE'; I); 'REAL' DEFTOL = 1E-14, DEFMIN = 1E-8; 'INT' EE; 'OP' + = ('INFINITE' INF) 'INFINITE': INF; 'OP' - = ('INFINITE' INF) 'INFINITE': ('INFINITE' I; POS 'OF' I := 'NOT' (POS 'OF' INF); I); 'INTPROB' DEFAULTINTPROB = ('SKIP', DEFTOL, DEFTOL, DEFMIN, 'HEAP' 'INT'); 'OP' 'SETFUN' = ('FUN' F) 'REF' 'INTPROB': ('HEAP' 'INTPROB' I := DEFAULT INTPROB; F 'OF' I := F; I); 'OP' 'ABSTOL' = ('REF' 'INTPROB' F, 'REAL' TOL) 'REF' 'INTPROB': (ABSTOL 'OF' F := TOL; F); 'OP' 'RELTOL' = ('REF' 'INTPROB' F, 'REAL' TOL) 'REF' 'INTPROB': (RELTOL 'OF' F := TOL; F); 'OP' 'RELTOL' = ('FUN' F, 'REAL' TOL) 'REF' 'INTPROB': 'SETFUN' F 'RELTOL' TOL; 'OP' 'ABSTOL' = ('FUN' F, 'REAL' TOL) 'REF' 'INTPROB': 'SETFUN' F 'ABSTOL' TOL; 'OP' 'INTEGRAL' = ('RANGE' R, 'FUN' F) 'REAL': R 'INTEGRAL' 'INTPROB' (F,DEFTOL,DEFTOL,DEFMIN,EE); 'OP' 'INTEGRAL' = ('RANGE' R, 'INTPROB' S) 'REAL': 'BEGIN' 'PROC' QAD = ('REAL' A, B, 'FUN' FUN) 'REAL': 'BEGIN' 'MODE' 'XF' = 'STRUCT' ('REAL' X, F); 'OP' <= = ('REF' 'XF' XF, 'REAL' X) 'REF' 'XF': XF := (X, FUN (X)); 'PROC' INT = ('XF' NUL, TWEE, VIER) 'VOID': 'BEGIN' 'REAL' X0 = X 'OF' NUL, X2 = X 'OF' TWEE, X4 = X 'OF' VIER, F0 = F 'OF' NUL, F2 = F 'OF' TWEE, F4 = F 'OF' VIER, HMIN = HMIN 'OF' S; 'INT' E := 0; 'XF' EEN, DRIE; EEN <= (X0 + X2) * 0.5; DRIE <= (X2 + X4) * 0.5; 'REAL' F1 = F 'OF' EEN, F3 = F 'OF' DRIE, H = X4 - X0, V = (4 * (F1 + F3) + 2 * F2 + F0 + F4) * 15, T = 6 * F2 - 4 * (F1 + F3) + F0 + F4; 'IF' 'ABS' T < 'ABS' V * RELTOL 'OF' S + ABSTOL 'OF' S 'THEN' SUM +:= (V - T) * H 'ELIF' 'ABS' H < HMIN 'THEN' E +:= 1 'ELSE' INT(NUL, EEN, TWEE); INT(TWEE, DRIE, VIER) 'FI'; SKIPPED 'OF' S:= SKIPPED 'OF' S + E 'END' # INT #; 'XF' NUL, TWEE, VIER; NUL <= A; TWEE <= (A + B) * 0.5; VIER <= B; 'REAL' SUM:= 0; INT(NUL, TWEE, VIER); SUM / 180 'END' # QAD #; 'PROC' TRANSF = ('REAL' X) 'REAL' : FUN(1/X) / (X * X); 'FUN' FUN:= F 'OF' S; 'CASE' FROM 'OF' R 'IN' ('REAL' A) : ('CASE' TO 'OF' R 'IN' ('REAL' B) : ('IF' A < B 'THEN' QAD(A, B, FUN) 'ELSE' -QAD(B, A, FUN) 'FI' ), ('INFINITE' B) : ('IF' POS 'OF' B 'THEN' 'IF' A <= 0 'THEN' QAD(A, 1, FUN) + QAD(0, 1, TRANSF) 'ELSE' QAD(0, 1/A, TRANSF) 'FI' 'ELIF' A >= 0 'THEN' QAD(-1, A, FUN) - QAD(-1, 0, TRANSF) 'ELSE' QAD(1/A, 0, TRANSF) 'FI' ) 'ESAC'), ('INFINITE' A) : ('CASE' TO 'OF' R 'IN' ('REAL' B) : ('IF' POS 'OF' A 'THEN' 'IF' B <= 0 'THEN' QAD(B, 1, FUN) + QAD(0, 1, TRANSF) 'ELSE' QAD(0, 1/B, TRANSF) 'FI' 'ELIF' B >= 0 'THEN' QAD(-1, B, FUN) - QAD(-1, 0, TRANSF) 'ELSE' QAD(1/B, 0, TRANSF) 'FI' ), ('INFINITE' B) : ('IF' POS 'OF' A 'THEN' 'IF' POS 'OF' B 'THEN' 0 'ELSE' QAD(-1, 0, TRANSF) + QAD(-1, 1, FUN) 'FI' 'ELIF' POS 'OF' B 'THEN' QAD(-1, 0, TRANSF) + QAD(-1, 1, FUN) + QAD(0, 1, TRANSF) 'ELSE' 0 'FI' ) 'ESAC') 'ESAC' 'END'; 'PRIO' 'INTEGRAL' = 2, 'RELTOL' = 3, 'ABSTOL' = 3, 'SETFUN' = 3; 'FUN' F = ('REAL' X) 'REAL': EXP(X); 'RANGE' AB := (1.0, 5.0); PRINT((NEWLINE,AB 'INTEGRAL' F)) 'END' ################################################################################ 'BEGIN' 'INT' N; 'MODE' 'POSSYMMAT' = 'REF' 'STRUCT'([] 'REF' [] 'REAL' MAT, [] 'REAL' POSSYMMAT); 'PROC' GENPOSSYMMAT = ('INT' ORDER) 'POSSYMMAT': 'BEGIN' 'HEAP' 'STRUCT'([1:ORDER] 'REF' [] 'REAL' MAT, [1:ORDER*(ORDER+1)'OVER'2] 'REAL' POSSYMMAT) A; 'REF' [] 'REF' [] 'REAL' AM = MAT 'OF' A; 'REF' [] 'REAL' AP = POSSYMMAT 'OF' A; 'INT' LOW := 1, UP := ORDER; 'FOR' I 'TO' ORDER 'DO' AM[I] := AP[LOW:UP @ I]; LOW := UP + 1; UP +:= ORDER - I 'OD'; A 'END'; 'PROC' F01ADN = ('POSSYMMAT' P1, P2)'VOID': 'BEGIN' 'PROC' NAG = ('RINT' N, 'RREAL' A, 'RINT' IA, IFAIL)'VOID': 'PR' XREF A68FTN,F01ADF 'PR' 'SKIP'; 'INT' N := 'UPB'(MAT 'OF' P1); 'INT' M := N + 1, IFAIL := 0, LOW := 1, UP := N; [N,M]'REAL' A; 'FOR' I 'TO' N 'DO' A[I:N @ I,I] := (MAT 'OF' P1)[I] 'OD'; NAG(N, A[1,1], M, IFAIL); MESS(IFAIL, "F01ADN"); 'FOR' I 'TO' N 'DO' (POSSYMMAT 'OF' P2)[LOW:UP] := A[I,I+1:M]; LOW := UP + 1; UP +:= N - I 'OD' 'END'; # F01ADN # 'OP' * = ('POSSYMMAT' A, B)'POSSYMMAT': 'BEGIN' 'INT' N = 'UPB' (MAT 'OF' A), M = 'UPB' (MAT 'OF' B); 'IF' N /= M 'THEN' PRINT((NEWLINE, " UNEQUAL ORDERS IN * ")); ERROR 'FI'; 'POSSYMMAT' C := GENPOSSYMMAT(N); 'INT' TELLER := 0, 'REAL' X; 'FOR' I 'TO' N 'DO' 'FOR' J 'FROM' I 'TO' N 'DO' TELLER +:= 1; (POSSYMMAT 'OF' C)[TELLER] := (X := 0; 'FOR' K 'TO' I-1 'DO' X +:= (MAT 'OF' A)[K][I] * (MAT 'OF' B)[K][J] 'OD'; 'FOR' K 'FROM' I 'TO' J-1 'DO' X +:= (MAT 'OF' A)[I][K] * (MAT 'OF' B)[K][J] 'OD'; 'FOR' K 'FROM' J 'TO' N 'DO' X +:= (MAT 'OF' A)[I][K] * (MAT 'OF' B)[J][K] 'OD'; X) 'OD' 'OD'; C 'END'; READ(N); 'POSSYMMAT' MAT1 := GENPOSSYMMAT(N), MAT2 := GENPOSSYMMAT(N); READ((NEWLINE, POSSYMMAT 'OF' MAT1)); F01ADN(MAT1, MAT2); PRINT((NEWLINE, POSSYMMAT 'OF' MAT1, NEWLINE, POSSYMMAT 'OF' MAT2, NEWLINE, POSSYMMAT 'OF' (MAT1 * MAT2))); 'SKIP' 'END' ################################################################################ 'BEGIN' 'OP' 'TBEC' = ('MATRIX' A, B) 'VOID': 'PR' XDEF TBECM 'PR' ( 'MATRIX' A1 = A[ @1, @1 ]; 'FOR' I 'TO' 1 'UPB' A1 'DO' A1[I,]:= B[,I] 'OD') 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'OP' 'TBEC' = ('VECTOR' A, B) 'VOID': 'PR' XDEF TBECV 'PR' ( A[@1]:= B ) 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'OP' 'TCOP' = ('MATRIX' A) 'MATRIX': 'PR' XDEF TCOPM 'PR' ( 'MATRIX' A1 = A[@1, @1]; 'INT' U1 = 1'UPB' A1, U2 = 2'UPB' A1; 'HEAP' [1:U2, 1:U1]'REAL' AA; 'FOR' I 'TO' U2 'DO' AA[I,]:= A[,I] 'OD'; AA) 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'OP' 'TCOP' = ('VECTOR' A) 'VECTOR': 'PR' XDEF TCOPV 'PR' ( 'VECTOR' A1 = A[@1]; 'HEAP' [1:'UPB'A1]'REAL' AA:= A1; AA) # ONTGATEN # 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'OP' 'TBEC' = ('INTMAT' A, B) 'VOID': 'PR' XDEF TBECIM 'PR' ( 'INTMAT' A1 = A[ @1, @1 ]; 'FOR' I 'TO' 1 'UPB' A1 'DO' A1[I,]:= B[,I] 'OD') 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'OP' 'TBEC' = ('INTVEC' A, B) 'VOID': 'PR' XDEF TBECIV 'PR' ( A[@1]:= B ) 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'OP' 'TCOP' = ('INTMAT' A) 'INTMAT': 'PR' XDEF TCOPIM 'PR' ( 'INTMAT' A1 = A[@1, @1]; 'INT' U1 = 1'UPB' A1, U2 = 2'UPB' A1; 'HEAP' [1:U2, 1:U1]'INT' AA; 'FOR' I 'TO' U2 'DO' AA[I,]:= A[,I] 'OD'; AA) 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'OP' 'TCOP' = ('INTVEC' A) 'INTVEC': 'PR' XDEF TCOPIV 'PR' ( 'INTVEC' A1 = A[@1]; 'HEAP' [1:'UPB'A1]'INT' AA:= A1; AA) # ONTGATEN # 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'PROC' MESS = ('INT' I, 'STRING' N ) 'VOID': 'PR' XDEF MESS 'PR' 'IF' I/= 0 'THEN' WRITE((NEWLINE, N, "-IFAIL=", WHOLE(I,-2), NEWLINE)) 'FI'#MESS# 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'PROC' TEST = ( []'UNION'('VECTOR','INTVEC')A,'STRING'N )'INT': 'PR' XDEF TEST 'PR' ( 'OP' 'UB' = ('UNION'('VECTOR','INTVEC')VI )'INT': 'CASE' VI 'IN'('VECTOR'V): 'UPB'V, ('INTVEC'I): 'UPB'I 'ESAC'; 'INT'M = 'UB'A[1]; 'FOR' I 'FROM' 2 'TO' 'UPB'A 'DO' 'IF' 'UB'A[I]/= M 'THEN' WRITE ((NEWLINE, N,"-DIMENSION ERROR", WHOLE(I,-3), NEWLINE));ERROR 'FI' 'OD'; M) # TEST # 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'PROC' F04ATN = ('MATRIX' A, 'VECTOR' B, C, 'MATRIX' AA) 'VOID': 'PR' XDEF F04ATN 'PR' 'BEGIN' 'PROC' NAG = ('RREAL'AT, 'RINT'IA, 'RREAL'U, 'RINT'N, 'RREAL'W, AA, 'RINT'IAA, 'RREAL'WKS1,WKS2, 'RINT' IFAIL ) 'VOID': 'PR' XREF A68FTN,F04ATF 'PR' 'SKIP'; 'MATRIX' AC = 'TCOP' A, AAC = 'TCOP' AA; 'VECTOR' BC = 'TCOP' B, CC = 'TCOP' C ; 'INT' N:= TEST ((AC[1,],AC[,1],B,C,AAC[1,],AAC[,1]), "F04ATN"); [1:N]'REAL' WKS1, WKS2; 'INT' IFAIL:= 0; NAG(AC[1,1], N, BC[1], N, CC[1], AAC[1,1], N, WKS1[1], WKS2[1], IFAIL); MESS(IFAIL,"F04ATN"); C 'TBEC' CC; AA 'TBEC' AAC 'END' # F04ATN # 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'PROC' F02ABN = ('MATRIX' A, 'VECTOR' R, 'MATRIX' V ) 'VOID': 'PR' XDEF F02ABN 'PR' 'BEGIN' 'PROC' NAG = ('RREAL'AC, 'RINT'IA, 'RINT'N, 'RREAL'R, 'RREAL'V, 'RINT'IV, 'RREAL'E, 'RINT'IFAIL)'VOID': 'PR' XREF A68FTN,F02ABF 'PR' 'SKIP'; 'MATRIX' AC = 'TCOP' A, VC = 'TCOP' V; 'VECTOR' RC = 'TCOP' R; 'INT' N:= TEST((AC[1,], AC[,1], VC[1,], VC[,1], RC), "F02ABN"); 'INT' IFAIL:=0; [1:N]'REAL'E; NAG (AC[1,1], N, N, RC[1], VC[1,1], N, E[1], IFAIL); MESS(IFAIL, "F02ABN"); R 'TBEC' RC; V 'TBEC' VC 'END' # F02ABN # 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'PROC' F02AFN = ('MATRIX' A, 'VECTOR'RR, RI, 'INTVEC' INTGER )'VOID': 'PR' XDEF F02AFN 'PR' 'BEGIN' 'PROC' NAG = ('RREAL'AC, 'RINT'IA, N, 'RREAL'RR, RI, 'RINT' INTGER, IFAIL)'VOID': 'PR' XREF,A68FTN F02AFF 'PR' 'SKIP'; 'MATRIX' AC = 'TCOP'A; 'VECTOR'RRC = 'TCOP' RR, RIC = 'TCOP' RI; 'INTVEC' INTGERC = 'TCOP' INTGER; 'INT'N:= TEST((AC[1,], AC[,1], RRC, RIC, INTGERC ),"F02AFN"); 'INT' IFAIL :=0; NAG( AC[1,1],N,N,RRC[1],RIC[1],INTGERC[1],IFAIL ); MESS( IFAIL, "F02AFN" ); A 'TBEC'AC; RR 'TBEC' RRC; RI 'TBEC' RIC; INTGER 'TBEC' INTGERC 'END' # F02AFN # 'PR' FEDX 'PR'; 'SKIP' 'END' 'PR' STOP 'PR' 'BEGIN' 'PROC' E02ACN = ('VECTOR'X, Y, A, 'RREAL' REF)'VOID': 'PR' XDEF E02ACN 'PR' 'BEGIN' 'PROC' NAG = ('RREAL' XC, YC,'RINT' N,'RREAL' AC,'RINT' M1, 'RREAL' REF) 'VOID': 'PR' XREF A68FTN,E02ACF 'PR''SKIP'; 'VECTOR' XC = 'TCOP' X, YC = 'TCOP' Y, AC = 'TCOP' A; 'INT' N:= TEST(( XC, YC ), "E02ACN"), M1:= 'UPB' AC; NAG(XC[1], YC[1], N, AC[1], M1, REF); X 'TBEC' XC; Y 'TBEC' YC; A 'TBEC' AC 'END' # E02ACN # 'PR' FEDX 'PR'; 'SKIP' 'END' ################################################################################ NAG68: 'BEGIN' 'MODE' 'RINT' = 'REF' 'INT', 'RREAL' = 'REF' 'REAL', 'VECTOR' = 'REF' [ ] 'REAL', 'INTVEC' = 'REF' [ ] 'INT', 'INTMAT' = 'REF' [,] 'INT', 'MATRIX' = 'REF' [,] 'REAL'; 'PRIO' 'TBEC' = 4; 'OP' 'TBEC' = ('MATRIX' A, B) 'VOID': ( 'MATRIX' A1 = A[ 'AT'1, 'AT'1 ]; 'FOR' I 'TO' 1 'UPB' A1 'DO' A1[I,]:= B[,I] 'OD' ); 'OP' 'TBEC' = ('VECTOR' A, B) 'VOID': ( A['AT'1]:= B ); 'OP' 'TCOP' = ('MATRIX' A) 'MATRIX': ( 'MATRIX' A1 = A['AT'1, 'AT'1]; 'INT' U1 = 1'UPB' A1, U2 = 2'UPB' A1; 'HEAP' [1:U2, 1:U1]'REAL' AA; 'FOR' I 'TO' U2 'DO' AA[I,]:= A[,I] 'OD'; AA ); 'OP' 'TCOP' = ('VECTOR' A) 'VECTOR': ( 'VECTOR' A1 = A['AT'1]; 'HEAP' [1:'UPB'A1]'REAL' AA:= A1; AA )# ONTGATEN # ; 'OP' 'TBEC' = ('INTMAT' A, B) 'VOID': ( 'INTMAT' A1 = A[ 'AT'1, 'AT'1 ]; 'FOR' I 'TO' 1 'UPB' A1 'DO' A1[I,]:= B[,I] 'OD' ); 'OP' 'TBEC' = ('INTVEC' A, B) 'VOID': ( A['AT'1]:= B ); 'OP' 'TCOP' = ('INTMAT' A) 'INTMAT': ( 'INTMAT' A1 = A['AT'1, 'AT'1]; 'INT' U1 = 1'UPB' A1, U2 = 2'UPB' A1; 'HEAP' [1:U2, 1:U1]'INT' AA; 'FOR' I 'TO' U2 'DO' AA[I,]:= A[,I] 'OD'; AA ); 'OP' 'TCOP' = ('INTVEC' A) 'INTVEC': ( 'INTVEC' A1 = A['AT'1]; 'HEAP' [1:'UPB'A1]'INT' AA:= A1; AA )# ONTGATEN # ; 'PROC' MESS = ('INT' I, 'STRING' N ) 'VOID': 'IF' I/= 0 'THEN' WRITE((NEWLINE, N, "-IFAIL=", WHOLE(I,-2), NEWLINE)) 'FI'#MESS#; 'PROC' TEST = ( []'UNION'('VECTOR','INTVEC')A,'STRING'N )'INT': ( 'OP' 'UB' = ('UNION'('VECTOR','INTVEC')VI )'INT': 'CASE' VI 'IN'('VECTOR'V): 'UPB'V, ('INTVEC'I): 'UPB'I 'ESAC'; 'INT'M = 'UB'A[1]; 'FOR' I 'FROM' 2 'TO' 'UPB'A 'DO' 'IF' 'UB'A[I]/= M 'THEN' WRITE ((NEWLINE, N,"-DIMENSION ERROR", WHOLE(I,-3), NEWLINE));ERROR 'FI' 'OD'; M ) #TEST#; 'PROC' F04ATN = ('MATRIX' A, 'VECTOR' B, C, 'MATRIX' AA) 'VOID': 'BEGIN' 'PROC' NAG = ('RREAL'AT, 'RINT'IA, 'RREAL'U, 'RINT'N, 'RREAL'W, AA, 'RINT'IAA, 'RREAL'WKS1,WKS2, 'RINT' IFAIL ) 'VOID': 'PR' XREF A68FTN,F04ATF 'PR' 'SKIP'; 'MATRIX' AC = 'TCOP' A, AAC = 'TCOP' AA; 'VECTOR' BC = 'TCOP' B, CC = 'TCOP' C ; 'INT' N:= TEST ((AC[1,],AC[,1],B,C,AAC[1,],AAC[,1]), "F04ATN"); [1:N]'REAL' WKS1, WKS2; 'INT' IFAIL:= 0; NAG(AC[1,1], N, BC[1], N, CC[1], AAC[1,1], N, WKS1[1], WKS2[1], IFAIL); MESS(IFAIL,"F04ATN"); C 'TBEC' CC; AA 'TBEC' AAC 'END'# F04ATN #; 'PROC' F02ABN = ('MATRIX' A, 'VECTOR' R, 'MATRIX' V ) 'VOID': 'BEGIN' 'PROC' NAG = ('RREAL'AC, 'RINT'IA, 'RINT'N, 'RREAL'R, 'RREAL'V, 'RINT'IV, 'RREAL'E, 'RINT'IFAIL)'VOID': 'PR' XREF A68FTN,F02ABF 'PR' 'SKIP'; 'MATRIX' AC = 'TCOP' A, VC = 'TCOP' V; 'VECTOR' RC = 'TCOP' R; 'INT' N:= TEST((AC[1,], AC[,1], VC[1,], VC[,1], RC), "F02ABN"); 'INT' IFAIL:=0; [1:N]'REAL'E; NAG (AC[1,1], N, N, RC[1], VC[1,1], N, E[1], IFAIL); MESS(IFAIL, "F02ABN"); R 'TBEC' RC; V 'TBEC' VC 'END' # F02ABN #; 'PROC' F02AFN = ('MATRIX' A, 'VECTOR'RR, RI, 'INTVEC' INTGER )'VOID': 'BEGIN' 'PROC' NAG = ('RREAL'AC, 'RINT'IA, N, 'RREAL'RR, RI, 'RINT' INTGER, IFAIL)'VOID': 'PR' XREF,A68FTN F02AFF 'PR' 'SKIP'; 'MATRIX' AC = 'TCOP'A; 'VECTOR'RRC = 'TCOP' RR, RIC = 'TCOP' RI; 'INTVEC' INTGERC = 'TCOP' INTGER; 'INT'N:= TEST((AC[1,], AC[,1], RRC, RIC, INTGERC ), "F02AFN"); 'INT' IFAIL :=0; NAG( AC[1,1],N,N,RRC[1],RIC[1],INTGERC[1],IFAIL ); MESS( IFAIL, "F02AFN" ); A 'TBEC'AC; RR 'TBEC' RRC; RI 'TBEC' RIC; INTGER 'TBEC' INTGERC 'END' # F02AFN #; 'PROC' E02ACN = ('VECTOR'X, Y, A, 'RREAL' REF)'VOID': 'BEGIN' 'PROC' NAG = ('RREAL' XC, YC,'RINT' N,'RREAL' AC,'RINT' M1, 'RREAL' REF) 'VOID': 'PR' XREF A68FTN,E02ACF 'PR''SKIP'; 'VECTOR' XC = 'TCOP' X, YC = 'TCOP' Y, AC = 'TCOP' A; 'INT' N:= TEST(( XC, YC ), "E02ACN"), M1:= 'UPB' AC; NAG(XC[1], YC[1], N, AC[1], M1, REF); X 'TBEC' XC; Y 'TBEC' YC; A 'TBEC' AC 'END' # E02ACN #; 'PR' PROG 'PR' 'SKIP' 'END' # NAG68 # ################################################################################ AALIB: 'BEGIN' # LAURENTREEKSEN PROGRAMMA # # SCALAR OPERATIES # 'PRIO' 'MIN'=2, 'MAX'=2, 'R'=9; 'PRIO' 'PRINT' = 1, 'POWER'=2, 'ZPOWER'=2, =:= = 2, >< = 4; 'PRIO' 'TERMS' = 3, 'SOL' = 2, 'D'=2; 'OP' 'MIN' = ('INT' A,B) 'INT': (AB!A!B); #RATIONALE ARITHMETIEK# 'MODE' 'RAT' = 'STRUCT'('INT' T,N); 'PROC' GGD=('INT'T,N)'INT': ( N=1 ! 1 !: N=0 ! T !: N>T ! ( N0 'AND' A[U]=ZERO 'DO' U-:= 1 'OD'; A[L:U'AT'L] ) # 'SHRINK' LAUR #; 'OP' 'PRINT' = ('STRING' TEXT,'LAUR' A ) 'VOID': (PRINT((TEXT)); 'FOR' I 'FROM' 'LWB' A 'TO' 'UPB' A 'DO' PRINT(( " (",WHOLE(I, 3),")",SCAL(A[I]) ))'OD'; PRINT(NEWLINE) ) # PRINT LAUR # ; 'OP' 'ORDER' = ('LAUR' A) 'INT': ('INT' L := 'LWB' A; 'INT' U = 'UPB' A; 'FOR' I 'FROM' L 'TO' U 'WHILE' A[L] = ZERO 'DO' L +:= 1 'OD'; ( L>U ! - MAXINT ! - L ) ) # 'ORDER' LAUR #; 'OP' 'ZERO' = ('LAUR' A) 'BOOL': ('BOOL' Z:= 'TRUE'; 'FOR' I 'FROM' 'LWB' A 'TO' 'UPB' A 'WHILE' Z 'DO' Z:= A[I] = ZERO 'OD'; Z ) # 'ZERO' LAUR #; 'OP' *:= = ('LAUR' A, 'SCAL' L ) 'LAUR': ('FOR' I 'FROM' 'LWB' A 'TO' 'UPB' A 'DO' A[I] *:= L 'OD'; A ) # LAUR *:= SCAL #; 'OP' * = ('SCAL' L, 'LAUR' A ) 'LAUR': ('LAUR' B = GENLAUR('LWB' A, 'UPB' A) := A ; B *:= L ) # SCAL * LAUR # ; 'OP' / = ('LAUR' A, 'SCAL' L) 'LAUR': ('LAUR' B = GENLAUR('LWB' A, 'UPB' A) := A ; B *:= UNITY / L ) # LAUR / SCAL # ; 'OP' 'ZPOWER' = ('INT' K, 'LAUR' A ) 'LAUR': ('INT' L = 'LWB' A + K, U = 'UPB' A + K; 'LAUR' C = GENLAUR(L,U); 'PUTZEROS' C[0:L-1]; C[L:U]:= A['AT'1]; 'PUTZEROS' C[U+1:0]; 'SHRINK' C ) # INT 'ZPOWER' LAUR #; 'OP' + = ( 'LAUR' A,B ) 'LAUR': ('INT' LA = 'LWB'A, LB='LWB'B, UA='UPB'A, UB='UPB'B; 'INT' LC := LA'MIN'LB, UC := UA'MAX'UB; 'LAUR' C=GENLAUR(LC,UC); ( LAUB ! 'FOR'I'FROM'UB+1'TO'UA 'DO' C[I]:=A[I] 'OD'; UC:=UB !:UB>UA ! 'FOR'I'FROM'UA+1'TO'UB 'DO' C[I]:=B[I] 'OD'; UC:=UA); 'FOR' I 'FROM' LC 'TO' UC 'DO' C[I]:= A[I]+ B[I] 'OD'; 'SHRINK' C ) # LAUR + LAUR#; 'OP' - = ( 'LAUR' A,B ) 'LAUR': ('INT' LA = 'LWB'A, LB='LWB'B, UA='UPB'A, UB='UPB'B; 'INT' LC := LA'MIN'LB, UC := UA'MAX'UB; 'LAUR' C=GENLAUR(LC,UC); ( LAUB ! 'FOR'I'FROM'UB+1'TO'UA 'DO' C[I]:= A[I] 'OD'; UC:=UB !:UB>UA ! 'FOR'I'FROM'UA+1'TO'UB 'DO' C[I]:=-B[I] 'OD'; UC:=UA); 'FOR' I 'FROM' LC 'TO' UC 'DO' C[I]:= A[I] - B[I] 'OD'; 'SHRINK' C ) # LAUR - LAUR#; 'OP' >< = ( 'LAUR' A,B ) 'SCAL': ('SCAL' PROD := ZERO; 'FOR' I 'FROM' 'LWB'A'MAX'-'UPB'B 'TO' 'UPB'A'MIN'-'LWB'B 'DO' PROD +:= A[I]*B[-I] 'OD'; PROD ) # >< #; 'OP' * = ( 'LAUR' A,B ) 'LAUR': ('INT' LWBB = 'LWB' B; 'LAUR' C = GENLAUR( 'LWB'A + LWBB, 'UPB'A + 'UPB'B ); 'FOR' I 'FROM' 'LWB'C 'TO' 'UPB'C 'DO' C[I]:= A> 0 ) 'DO' 'FOR' I 'TO' K 'WHILE' 'NOT' SING 'DO' SING:= 'ZERO' MM[N+1-I,:N] 'OD' 'OD' # #; 'IF' SING 'THEN' ('NIL',ZPOW,'TRUE') 'ELSE' 'FOR' I 'TO' N 'DO' MM[I,]:= MM[I,]/MM[I,I][0] 'OD'; ( MM ,ZPOW, 'FALSE') 'FI' 'END' # PROC TRIANG # ; 'OP' 'ZEROROWS' = ( 'MAT' A # POLYNOMIALS !!!# ) 'INT': # NUMBER OF DEPENDENT ROWS OF CONSTANT TERMS # ('INT' M = 1'UPB'A, N = 2'UPB'A; 'INT' I:= 1; 'FOR' J 'TO' N 'WHILE' I <= M 'DO' 'INT' K:= I; 'SCAL' PK:= A[I,J][0]; 'FOR' II 'FROM' I+1 'TO' M 'DO' 'SCAL' AIIJ0 = A[II,J][0]; ('ABS' AIIJ0 > 'ABS' PK ! K:= II; PK:= AIIJ0) 'OD';( K /= I ! A[K,] =:= A[I,]); 'IF' PK /= ZERO 'THEN' 'VEC' ELIMROW = A[I,]; 'FOR' II 'FROM' I+1 'TO' M 'DO' 'VEC' ROW = A[II,]; ROW:= ROW - (ROW[J][0]/PK) * ELIMROW 'OD'; I+:= 1 'FI' 'OD' ; M-I+1 ) # 'ZEROROWS' MAT (POLYNOMIALS !!!!!!! ) # ; 'PROC' SOL = ('TRIANG' A, 'INT' NUMBTERMS ) 'VEC': 'BEGIN' 'MAT' MM = MM'OF'A; 'INT' N = 1'UPB'MM; ( 2'UPB'MM /= N+1 ! ERROR ); 'REF'[]'INT' ZPOW := ZPOW'OF'A; ( SING'OF'A ! PRINT(( "SINGULAR MATRIX",NEWLINE)); ERROR ); 'VEC' RHS = MM[,N+1], SOLUT = ZEROVEC(N); 'TO' NUMBTERMS 'WHILE' (REPORT ! "SOLUT" 'PRINT' SOLUT); (REPORT ! "RHS " 'PRINT' RHS ); 'NOT' 'ZERO' 'POLYN' RHS 'DO' 'VEC' X = ZEROVEC(N); 'FOR' I 'FROM' N 'BY' -1 'TO' 1 'DO' 'REF' 'SCAL' XX = X[I][0]:= RHS[I][0]; 'FOR' J 'FROM' I+1 'TO' N 'DO' XX -:= X[J][0] * MM[I,J][0] 'OD' 'OD'; SOLUT := SOLUT + X; RHS := RHS - MM[,:N]*X; -1 'POWER' SOLUT; -1 'POWER' RHS; ZPOW[N+1] +:= 1 'OD' # #; 'FOR' I 'TO' N 'DO' SOLUT[I]:= -ZPOW[I]'ZPOWER'SOLUT[I] 'OD'; ZPOW[N+1] 'ZPOWER' SOLUT 'END' # SOL #; 'OP' 'TERMS' = ('VEC' RHS, 'INT' TERMS) 'STRUCT' ('VEC' RHS, 'INT' TERMS): (RHS,TERMS); 'OP' 'SOL' = ('MAT' MAT, 'STRUCT'('VEC'RHS,'INT'TERMS)STC )'VEC': SOL ( TRIANG ( MAT, RHS'OF'STC ), TERMS'OF'STC ); 'OP' 'SOL' = ('MAT' MAT, 'VEC' RHS ) 'VEC': MAT 'SOL' RHS 'TERMS' ('INT' T:= 0; 'FOR' I 'TO' 'UPB' RHS 'DO' 'LAUR' RHSI = RHS[I]; T:= T 'MAX' ('UPB' RHSI + 'ORDER' RHSI ) 'OD'; T+1 ) # NUMB TERMS # ; 'PR' EJECT 'PR' # SPECIALE OPERATIES # 'OP' 'THETA' = ( 'LAUR' A ) 'LAUR': ('INT' L='LWB'A, U='UPB'A; 'LAUR' B=GENLAUR(L,U); 'FOR' I 'FROM' L 'TO' U 'DO' B[I]:= I*A[I] 'OD'; B ) # 'THETA' LAUR #; 'OP' 'THETA' = ('VEC' V ) 'VEC': ('INT' N = 'UPB' V; 'VEC' W = GENVEC (N); 'FOR' I 'TO' N 'DO' W[I]:= 'THETA' V[I] 'OD'; W ) # 'THETA' VEC #; 'OP' 'D' = ('MAT' A, 'VEC' Y ) 'VEC': ('INT' N = 'UPB' Y; ( N /= 2'UPB' A ! ERROR); 'VEC' DY = GENVEC (N); 'FOR' I 'TO' 1'UPB'A 'DO' DY[I] := 'THETA' Y[I]; 'FOR' J 'TO' N 'DO' DY[I] := DY[I] + A[I,J]*Y[J] 'OD' 'OD' # ALL ROWS #; DY ) # MAT 'D' VEC #; 'MAT' AA; #GIVEN MATRIX OF LAURENT SERIES # 'OP' 'D' = ('VEC' Y ) 'VEC': AA 'D' Y; 'PROC' TESTLEIBNIZ = ('LAUR' L,'VEC' Y) 'VOID': ( "LEIBNIZ 1 " 'PRINT' 'D'(L*Y) ; "LEIBNIZ 2 " 'PRINT' 'THETA' L * Y + L * 'D' Y ) # TEST LEIBNIZ #; 'PR' EJECT 'PR' # BEREKENEN VAN DE EIGENWAARDEN # 'PROC' EIGVALS = ('VEC' V) 'VOID': 'BEGIN' 'INT' N = 'UPB' V; [1:N,1:N]'REAL' M; # 0 0 0 C1 # [1:N]'REAL' RR,RI; # 1 0 0 C2 # [1:N]'INT' JJ; # 0 1 0 .. # # 0 0 1 CN # # WAARIN C1,C2,C3,... DE CONSTANTE TERMEN VAN DE RESP. LAURENT REEKSEN IN DE VECTOR V ZIJN. # 'FOR' I 'TO' N 'DO' 'FOR' J 'TO' N-1 'DO' M[I,J]:= ( J+1=I ! 1 ! 0 ) 'OD'; M[I,N]:= 'VAL' V[I][0] 'OD'; F02AFN(M,RR,RI,JJ); PRINT(NEWLINE); 'FOR' I 'TO' N 'DO' PRINT(("EIGVAL ",FLOAT(RR[I],12,6,2)," + ", FLOAT(RI[I],12,6,2)," * I", NEWLINE)) 'OD'; PRINT(NEWLINE) 'END' # EIGVALS # ; 'PR' PROG 'PR' 'SKIP' 'END' ################################################################################ EFGAL: 'BEGIN' # WOSD AND EFGAL # 'MODE' 'VECTOR' = 'REF' [ ] 'REAL'; 'MODE' 'MATRIX' = 'REF' [,] 'REAL'; 'MODE' 'TRIDIAMAT' = 'STRUCT' ('VECTOR' SUB,DIA,SUP); 'MODE' 'METHOD' = 'STRUCT'('VECTOR' SUBN,W,SPW,PHI, 'MATRIX' WCOF,CSPW,COEF,COEI,CWWI,PHID); 'PRIO' 'ICH' = 4; #SCALAR PRODUCT# 'OP' * = ('VECTOR' A,B) 'REAL': ('REAL' S:= 0; 'FOR' I 'FROM' 'LWB' A 'TO' 'UPB' A 'DO' S +:= A[I]*B[I] 'OD'; S); #INTERCHANGE# 'OP' 'ICH' = ('VECTOR' A,B) 'VOID': 'FOR' I 'FROM' 'LWB' A 'TO' 'UPB' A 'DO' 'REAL' S = A[I]; A[I]:= B[I]; B[I]:= S 'OD'; #SOLUTION TRIDIAGONAL SYSTEM# 'PROC' TRIDSOL := ('TRIDIAMAT' MAT, 'VECTOR' F) 'VECTOR' : 'BEGIN' #FOR A MATRIX OF POSITIVE TYPE# 'VECTOR' A #[1:N ]# = DIA 'OF' MAT, B #[1:N-1]# = SUP 'OF' MAT, C #[1:N-1]# = SUB 'OF' MAT; 'INT' N = 'UPB' F; 'INT' I:= 1; 'REAL' P,G:= F[1]; 'FOR' J 'FROM' 2 'TO' N 'DO' A[J]-:= B[I] * (P:= C[I]/A[I]); G:= F[I:=J] -:= G * P 'OD'; F[N]:= G /:= A[N]; 'FOR' J 'FROM' N-1 'BY' -1 'TO' 1 'DO' G:= (F[J]-:= B[J]*G) /:= A[J] 'OD'; F 'END' # TRIDSOL #; # 1 # 'PROC' WOSD = ('VECTOR' XX,YY, 'PROC'('REAL','REAL','REAL') [ ]'REAL' EQTN) 'VOID': 'BEGIN' 'INT' N = 'UPB' XX; [1:4] 'REAL' EVAL, [0:N] 'REAL' SUB,DIA,SUP; 'VECTOR' RHS = YY; 'REF' 'REAL' EE = EVAL[1], FF= EVAL[2], GG = EVAL[3], RR= EVAL[4]; #THE FUNCTION M, DEFINED BY EQ.(2.4.8)# 'PROC' M = ('REAL' A) 'REAL': 'IF' 'REAL' X, W:= 'ABS' A; W < 0.2 'THEN' W*:= W; (((( W - 9.9 ) * W + 99.0 ) * W - 1039.5 ) * W + 15592.5) * A / 46777.5 'ELSE' X:= (W-1.0)/W; (W < 18.0 ! X+:= 2.0/(EXP(W + W)-1.0)); (A > 0.0 ! X ! -X ) 'FI' # M #; 'REAL' XK,H,K,EH,EK,KH,MM,YK, XH:=XX[1],YH:=YY[1],YM:=YY[0]; H:= XH - XX[0]; DIA[0]:= DIA[N]:= 1; SUB[N]:= SUP[0]:= 0; 'FOR' I 'TO' N - 1 'DO' XK:= XX[I+1]; YK:= YY[I+1]; K := XK - XH; KH:= K + H ; EVAL:= EQTN(XH,YH,(YK-YM)/KH); EE *:= 2.0; EH:= EE/H; EK:= EE/K; MM := M(( FF*EE<0 ! FF/EH ! FF/EK)); KH +:= (K-H)*MM; MM*:= FF; SUB[I]:= EH - FF + MM; DIA[I]:=-EH - EK - MM - MM + GG * KH; SUP[I]:= EK + FF + MM; RHS[I]:= RR * KH; XH:= XK; H:= K; YM:= YH; YH:= YK 'OD'; TRIDSOL((SUB,DIA['AT'1],SUP['AT'1]),RHS['AT'1]) 'END' # WOSD #; # 1 # 'PROC' METHOD = ('INT' CODE) 'METHOD': 'IF' CODE = 0 'THEN' ('NIL','NIL','NIL','NIL','NIL','NIL','NIL','NIL','NIL','NIL') 'ELSE' 'INT' AC= 'ABS' CODE; 'INT' NC= AC + 1; 'HEAP' [1:NC,1:NC] 'REAL' WCOF,CSPW,COEF,COEI,CWWI,PHID, 'HEAP' [1:NC] 'REAL' SUBN,W ,SPW ,PHI; [,] 'REAL' PHIS = #THE COEFFICIENTS OF THE POLYNOMIALS CAPITAL PHI,EQ.(3.1.21)# 'CASE' AC 'IN' 'BEGIN' SUBN:= ( 0, 1); (( 1, -1, 0), ( 0, 1, 0)) 'END', 'BEGIN' SUBN:= ( 0, .5, 1); (( 1, -3, 2), ( 0, 4, -4), ( 0, -1, 2)) 'END', 'BEGIN' 'REAL' A,B,C:=SQRT(5); B:= (5+C)/10; A:= 0.2/B; SUBN:= ( 0, A, B, 1); C*:= 5; B:= (C+5)/2 ; A:= 25/B; (( 1, -6, 10, -5), ( 0, B,-B-C, C), ( 0, -A, A+C, -C), ( 0, 1, -5, 5)) 'END', 'BEGIN' 'REAL' A, B:= 1/7, D:= (7+SQRT(21))/14, P:= -3/49, Q:= 3/112; A:= B/D; SUBN:= ( 0, A, .5, D, 1 ); (( 1, -10 , 30 , -35 ,14 ), ( 0, -D/P , (1+3*D)/P, (-3-2*D)/P, 2/P), ( 0, -B/Q , (1+ B)/Q, -2/Q , 1/Q), ( 0, -A/P , (1+3*A)/P, (-3-2*A)/P, 2/P), ( 0, -1 , 9 , -21 , 14 )) 'END' 'ESAC' # PHIS #; # 1 # #CONSTRUCTION OF METHOD-DEFINING COEFFICIENTS# 'FOR' I 'TO' NC 'DO' SPW[I]:= SUBN[I] *( PHI[I]:= PHIS[I,2] ); W[I] := ('REAL'S:=0;'FOR' J 'TO' NC 'DO' S+:=PHIS[I,J]/J 'OD';S); 'FOR' K 'TO' NC 'DO' COEF[K,I]:= ('REAL' S:= AC*PHIS[I,NC], SK:=SUBN[K]; 'FOR' J 'FROM' AC-1 'BY' -1 'TO' 1 'DO'( S *:=SK )+:= J*PHIS[I,J+1] 'OD'; S ); CWWI[K,I]:= 'IF' K = 1 'THEN' SUBN[I]*PHIS[I,3] 'ELSE' COEF[K,I]*SUBN[I]/SUBN[K] 'FI'; PHID[K,I]:= 2*PHIS[I,3]*PHIS[K,1]+PHIS[I,2]*PHIS[K,2] 'OD'; 'IF' I /= 1 'THEN' CWWI[I,I] -:= 1/SUBN[I] 'FI' 'OD'; 'FOR' I 'TO' NC 'DO' SPW[I] *:= W[1]/W[I]; 'FOR' K 'TO' NC 'DO' 'REAL' C = COEF[K,I]; WCOF[K,I] := C*W[K]; COEI[K,I] := C/W[I]; CWWI[K,I]/:= W[I]; CSPW[I,K] := COEF[1,K]*SPW[I] 'OD' 'OD' #CONSTRUCTION COEFFICIENTS#; 'IF' CODE > 0 'THEN' (SUBN,W, SPW, PHI, WCOF, CSPW,COEF,COEI, CWWI, PHID) 'ELSE' (SUBN,W,'NIL','NIL',WCOF,'NIL',COEF,COEI,'NIL','NIL') 'FI' 'FI' #PROC METHOD# ; # 1 # 'PROC' EFGAL = ('METHOD'METHOD, 'VECTOR' XX,YY, 'PROC'('REAL','REAL','REAL')[]'REAL'EQTN) 'VOID': 'IF' SUBN 'OF' METHOD :=: 'VECTOR' ('NIL') 'THEN' WOSD(XX, YY, EQTN) 'ELSE' 'VECTOR' SUBN = SUBN'OF'METHOD, W = W 'OF'METHOD, SPW = SPW 'OF'METHOD, PHI = PHI 'OF'METHOD, 'MATRIX' WCOF = WCOF'OF'METHOD, CSPW = CSPW'OF'METHOD, COEF = COEF'OF'METHOD, COEI = COEI'OF'METHOD, CWWI = CWWI'OF'METHOD, PHID = PHID'OF'METHOD; 'BOOL' EF = (PHID'OF'METHOD:/=:'MATRIX'('NIL')); 'INT' NC = 'UPB' SUBN, NR = 'UPB' XX; 'INT' AC = NC - 1; [1:NC, 1:4]'REAL'EVALS, [1: 4,1:NC]'REAL' WW, [1: NR+1]'REAL' SUB,DIA,SUP, [1:NC,0:NC]'REAL' A; 'PROC' ('INT','INT') 'REAL' CC = 'IF' AC > 2 'THEN' ('INT' I,J)'REAL': A[I,J] - A[I,2:AC]*A[2:AC,J] 'ELIF' AC = 2 'THEN' ('INT' I,J)'REAL': A[I,J] - A[I,2] *A[2,J] 'ELSE' ('INT' I,J)'REAL': A[I,J] 'FI'; 'VECTOR' RHS = YY['AT'1], EVALL=EVALS[1,], EVALR=EVALS[NC,], WA=WW[1,], WB=WW[2,], WC=WW[3,], WD=WW[4,]; 'REF' 'REAL' WA1=WA[1], WB1=WB[1], WC1=WC[1], WD1=WD[1], EVALL1=EVALL[1], EVALL2=EVALL[2], EVALL3=EVALL[3], EVALR1=EVALR[1], EVALR2=EVALR[2], EVALR3=EVALR[3]; 'BOOL' POST:='FALSE',PRE:='FALSE',TWO:='FALSE'; 'INT' I1,IN; 'REAL' X := XX[0], Y := YY[0], XH:= XX[1], YH:= YY[1]; 'REAL' H := XH-X , Y1:=(YH-Y)/H, HH,XHH,YHH,Y1H,PE,PO,PW, ALPHA:= 0.0, RHS1:= Y, DIAR := 0.0, RHSR:= 0.0, CRIT := SQRT('REAL':(2**NC)); # 1 # 'FOR' N 'TO' NR 'DO' 'IF' N = 1 'THEN' EVALL:= EQTN(X,Y,Y1); ( EF ! PO:= EVALL2*H/EVALL1 ) 'ELSE' X := XH; Y := YH; XH := XHH; YH := YHH; H := HH; Y1 := Y1H; EVALL:= (TWO ! TWO:='FALSE'; EQTN(X,Y,Y1) ! EVALR ) 'FI'; EVALR := EQTN(XH,YH, 'IF' N = NR 'THEN' Y1 'ELSE' XHH := XX[N+1]; YHH:= YY[N+1]; HH := XHH -XH; Y1H:=(YHH-YH)/HH; (TWO:= 'ABS'(Y1H-Y1)>0.1 ! Y1 ! 0.5*(Y1H+Y1) ) 'FI' ); 'FOR' I 'FROM' 2 'TO' AC 'DO' EVALS[I,]:=('REAL' C = H*SUBN[I]; EQTN(X+C,Y+C*Y1,Y1) ) 'OD'; 'IF' EF 'THEN' PRE := CRIT < -( PE:= PO); POST:= CRIT < ( PO:= EVALR2*H/EVALR1); ALPHA:= 'IF' POST 'EQ' PRE 'THEN' 0.0 'ELIF' POST 'THEN' ((PW:= EVALR3*H/EVALR2)<-CRIT ! 0.0 ! PO-PW ) 'ELSE' ((PW:= EVALL3*H/EVALL2)> CRIT ! 0.0 ! PW-PE ) 'FI'; ( PRE := ALPHA>CRIT ! 'SKIP' ! POST := 'FALSE' ) 'FI'; 'FOR' I 'TO' NC 'DO' 'REF'[]'REAL' EVAL= EVALS[(POST!NC+1-I!I),]; WW[,I] := (EVAL[1]/H,(POST!-EVAL[2]!EVAL[2]),EVAL[3]*H,EVAL[4]*H) 'OD'; # 1 # #CONSTRUCTION OF ELEMENT MATRIX (3.1.24) AND VECTOR (3.1.25)# 'IF' PRE 'THEN' 'REAL' AW:= ALPHA * ALPHA; 'REAL' MU:=(ALPHA > 50.0 ! 0.0 ! ALPHA * AW * ('REAL' C=EXP(-ALPHA); C/(1.0-C))); 'REAL' ZZ:= (A[1,0]:= ( ALPHA*WD1+PHI*WD )/ ( AW *:= W[1] )); 'FOR' I 'FROM' 2 'TO' NC 'DO' A[I,0]:= WD[I] - SPW[I]*(ZZ-WD1) 'OD'; 'FOR' J 'TO' NC 'DO' 'REAL' ZZ:= (J=1 ! ALPHA*WC1 + PHI*WC ! 0.0); 'FOR' K 'TO' NC 'DO' ZZ +:= MU*WCOF[K,J]*WA[K] + PHID[K,J]*(ALPHA*WA[K]+WB[K]) 'OD'; A[1,J]:= (ZZ /:= AW); 'FOR' I 'FROM' 2 'TO' NC 'DO' 'REAL' Z:= COEF[I,J]*WB[I] + CSPW[I,J]*WB1; 'FOR' K 'TO' NC 'DO' Z -:= WCOF[K,J]*CWWI[K,I]*WA[K] 'OD'; A[I,J]:= (J=I ! Z+WC[I] ! Z ) - SPW[I] * (J=1 ! ZZ- WC1 ! ZZ) 'OD' 'OD' 'ELSE' 'FOR' I 'TO' NC 'DO' 'FOR' J 'TO' NC 'DO' 'REAL' Z:= COEF[I,J]*WB[I]; 'FOR' K 'TO' NC 'DO' Z -:= WCOF[K,J]*COEI[K,I]*WA[K] 'OD'; A[I,J]:= (J=I ! Z+WC[I] ! Z ) 'OD'; A[I,0]:= WD[I] 'OD' 'FI' #ELEMENT MATRIX AND VECTOR CONSTRUCTION#; # 1 # #STATIC CONDENSATION# 'IF' AC>2 'THEN' 'FOR' J 'FROM' 2 'TO' AC 'DO' 'INT' JP1= J+1; 'REAL' SI,S:= 'ABS' A[J,J]; 'INT' PJ:= J; 'FOR' I 'FROM' JP1 'TO' AC 'DO' ((SI:='ABS'A[I,J]) >S ! S:=SI; PJ:=I ) 'OD'; 'IF'J /= PJ 'THEN' A[PJ,] 'ICH' A[J,]'FI'; S:= A[J,J]; 'FOR' I 'FROM' JP1 'TO' AC 'DO' SI:= A[I,J]/S; 'FOR' K 'FROM' 0 'TO' NC 'DO' A[I,K] -:= A[J,K]*SI 'OD' 'OD' 'OD'; 'FOR' J 'FROM' AC 'BY' -1 'TO' 2 'DO' 'REAL' SI = A[J,J]; 'REAL' AJ0 = A[J, 0]/:=SI, AJ1 = A[J,1]/:= SI, AJNC = A[J,NC]/:=SI; 'FOR' I 'FROM' J-1 'BY' -1 'TO' 2 'DO' 'REAL' SI= A[I,J]; A[I, 0]-:= AJ0 *SI; A[I,1] -:= AJ1*SI; A[I,NC]-:= AJNC*SI 'OD' 'OD' 'ELIF' AC=2 'THEN' 'REAL' SI = A[2,2]; 'FOR' K 'FROM' 0 'TO' NC 'DO' A[2,K] /:= SI 'OD' 'FI' #STATIC CONDENSATION# ; (POST ! I1:=NC; IN:=1 ! I1:= 1; IN:=NC); DIA[N]:= CC(I1,I1) + DIAR; SUP[N]:= CC(I1,IN); SUB[N]:= CC(IN,I1); DIAR := CC(IN,IN); RHS[N]:= CC(I1, 0) + RHSR; RHSR := CC(IN, 0) 'OD'; RHS[1]:= RHS1; DIA[1]:= DIA[NR+1]:=1.0; SUP[1]:= SUB[NR ]:=0.0; TRIDSOL((SUB,DIA,SUP),RHS) 'FI' # EFGAL #; 'PR' PROG 'PR' 'SKIP' 'END' ################################################################################ IBVPPR : # 771111 JK # 'BEGIN' # PRELUDE OF LIBRARY FOR THE INTERFACE FOR SEMIDISCRETIZATION OF INITIAL BOUNDARY VALUE PROBLEMS. UPDATE : 780131. CONTROL CARD : A68,I=**,N. (AND EDITLIB-RUN) # 'MODE' 'VEC' = 'REF'[ ]'REAL', 'MAT' = 'REF'[ , ]'REAL', 'MOLS' = 'VEC', 'MOLSMAT' = 'REF'[ , ]'MOLS', 'INFO' = 'STRUCT'('REAL' LOCERRTOL, LOCAL ERROR, HMIN, 'PROC'('REAL')'REAL' NEXT H, 'PROC'('INT')'BOOL' PRINTSOME, 'INT' NSTEPSPERF, NSTEPSREJ, NUMGP, 'PROC'('INT', 'REAL', 'REAL', 'MAT')'VOID' # PARS : CASE, T, H, U # MONITOR ), 'INFOINT' = 'STRUCT'('REAL' LOCERRTOL, 'INT' NUM GP, 'BOOL' FIRST CALL, LAST STEP OK, 'REAL' LOCAL ERROR, 'INT' ORDER, 'BOOL' COMPUTE H ), 'TRIDIAMAT' = 'STRUCT'('VEC' SUB, DIAG, SUPER), 'EPS' = 'STRUCT'('REAL' INFNRM, EPS, BMAX, DMIN, 'INT' IMAX, COUNT, RNK ), 'RHSFU' = 'PROC'('PROC''REAL', 'PROC''REAL', 'PROC''REAL', 'PROC''REAL', 'PROC''REAL', 'PROC''REAL', 'PROC''REAL', 'PROC''REAL', 'PROC''REAL')'REAL' # RIGHT HAND SIDE G #, 'BOUNDFU' = 'PROC'('PROC''REAL', 'PROC''REAL', 'PROC''REAL', 'PROC''REAL')'REAL' # BV IMPLICIT #, 'POINT' = 'STRUCT'('REAL' XC, YC), 'DEFGRID' = 'STRUCT'( 'UNION'('REF'[ , ]'POINT', 'PROC'('INT', 'INT')'POINT') R # EITHER R[I, J] OR R(I, J) #, 'REF'[ ]'INT' CX, CY ), 'INTEGRATOR' = 'PROC'('REAL', 'REAL', 'REF''MAT', 'REF''INFOINT', 'PROC'('INT', 'INT', 'REAL', 'MAT')'REAL', 'PROC'('INT', 'INT', 'REAL', 'MAT')'REAL', 'REF'[ , ]'INT' )'VOID', 'BOOL' ERRONEOUS:= 'FALSE', 'INT' INSIDE = 1, BORDER = 0, OUTSIDE = -1; 'OP' * = ('REAL' A, 'VEC' B) 'VEC': 'PR' XREF SCLMULV 'PR' 'SKIP', 'OP' * = ('VEC' A, B) 'REAL': 'PR' XREF INPROD 'PR' 'SKIP', 'OP' + = ('VEC' A, B) 'VEC': 'PR' XREF VECADD 'PR' 'SKIP', 'OP' - = ('VEC' A, B) 'VEC' : 'PR' XREF VECSUB 'PR' 'SKIP', 'PROC' TFM GRID = ('DEFGRID' DGRID, 'INT' SHR, SHK, 'REF'[,]'INT' POSITN, 'REF''REF'[,]'POINT' GRID)'INT' : 'PR' XREF TFMGRID 'PR' 'SKIP', 'PROC' PRINT GRID = ('REF'[,]'INT' POSITN, 'INT' SHR, SHK, PAGLIM )'VOID' : 'PR' XREF PRINTGR 'PR' 'SKIP', 'PROC' UPRINT = ('MAT' U, 'INT' SHI, SHJ, 'REF'[,]'INT' POS)'VOID' : 'PR' XREF UPRINT 'PR' 'SKIP', 'PROC' I B V P S O L V E R = ('INTEGRATOR' INTEGRATOR, 'RHSFU' G # RIGHT HAND SIDE #, 'BOUNDFU' UB # BOUNDARY CONDITION #, 'DEFGRID' DGRID # USER'S REPRESENTATION OF GRID AND BORDER #, 'REF''MAT' U, 'REF''REAL' T START, [ ]'REAL' T END, 'REF''INFO' INF )'VOID' : 'PR' XREF IBVPSOL 'PR' 'SKIP', 'OP' + = ('MAT' Y1, Y2)'MAT' : 'PR' XREF MATADD 'PR' 'SKIP', 'OP' - = ('MAT' Y1, Y2)'MAT' : 'PR' XREF MATSUB 'PR' 'SKIP', 'OP' * = ('REAL' R, 'MAT' Y)'MAT' : 'PR' XREF SCLMULM 'PR' 'SKIP', 'PROC' DECTRI=('INT'MIN,MAX,'TRIDIAMAT'MAT)'VOID': 'PR' XREF DECTRI 'PR' 'SKIP', 'PROC' SOLTRI=('INT'MIN,MAX,'TRIDIAMAT'MAT,'VEC'RHS)'VEC': 'PR' XREF SOLTRI 'PR' 'SKIP', 'PROC' RETRIEVE DATA = ('INT' K,R, 'MOLSMAT' MASTOR,'REF''MOLS' DATA)'VOID': 'PR' XREF RETRDAT 'PR' 'SKIP', 'PROC' FORM MOLECULES = ('MOLS' DATA, 'MAT' DDX,DDY,DDXX,DDXY,DDYY )'VOID': 'PR' XREF FORMMOL 'PR' 'SKIP', 'PROC' COMPUTE DATA = ('MOLSMAT' MASTOR, 'REF'[ , ]'POINT' GRID, 'REF'[ , ]'INT' POSITION )'VOID' : 'PR' XREF COMPDAT 'PR' 'SKIP'; 'OP' 'SQR' = ('REAL' X)'REAL' : X * X, 'OP' 'SQR' = ('VEC' X)'REAL' : 'PR' XREF SQRVEC 'PR' 'SKIP', 'PROC' ROTVEC = ('VEC' A, B, 'REAL' C, S)'VOID' : 'PR' XREF ROTVEC 'PR' 'SKIP', 'OP' +:= = ('VEC' A, B)'VEC' : 'PR' XREF ELMVEC 'PR' 'SKIP', 'PROC' HSHREABID = ('MAT' A, 'VEC' D, B, 'REF''EPS' AUX)'VOID' : 'PR' XREF HSHREAB 'PR' 'SKIP', 'PROC' PSTTFMMAT = ('MAT' A, 'MAT' V, 'VEC' B)'VOID' : 'PR' XREF PSTTFMM 'PR' 'SKIP', 'PROC' PRETFMMAT = ('MAT' A, 'VEC' D)'VOID' : 'PR' XREF PRETFMM 'PR' 'SKIP', 'PROC' SVALBIDQR = ('VEC' D, B, 'REF''EPS' AUX)'INT' : 'PR' XREF SVALBID 'PR' 'SKIP', 'PROC' SVDECBIDQR = ('VEC' D, B, 'MAT' U, V, 'REF''EPS' AUX)'INT' : 'PR' XREF SVDECBD 'PR' 'SKIP', 'PROC' SVALQR = ('MAT' A, 'VEC' VAL, 'REF''EPS' AUX) 'INT' : 'PR' XREF SVALQR 'PR' 'SKIP', 'PROC' SVDECQR = ('MAT' A, 'VEC' VAL, 'MAT' V, 'REF''EPS' AUX)'INT': 'PR' XREF SVDECQR 'PR' 'SKIP', 'PROC' INVERSE = ('MAT' A)'MAT' : 'PR' XREF GNRLINV 'PR' 'SKIP', 'PROC' ARREB = 'REAL' : 1 / (2 ** 47), 'PROC' PDERROR = ('INT' ERNUM, 'BOOL' STOP)'VOID' : 'BEGIN' PRINT((NEWLINE, " * * * ERROR # ", WHOLE(ERNUM, -5), ( STOP ! "(FATAL)" ! " " ), NEWLINE)); 'IF' STOP 'THEN' ERR EXIT 'FI'; ERRONEOUS:= 'TRUE' 'END' # OF ERROR #; 'PR' PROG 'PR' 'SKIP'; ERR EXIT : 'SKIP' 'END' # OF PRELUDE FOR IBVP SOLVER # ################################################################################ IBVPLB1 : # 771110 JK # 'BEGIN' # PART 1 OF LIBRARY FOR THE INTERFACE FOR SEMIDISCRETIZATION OF INITIAL BOUNDARY VALUE PROBLEMS. UPDATE : 780227. EXTERNAL PROCEDURES, TO BE COMPILED WITH THE PRELUDE IBVPPR. CONTROL CARD : A68,I=**,P=IBVPLIB/IBVPPR. (AND EDITLIB-RUN). # 'OP' * = ('REAL' A, 'VEC' B) 'VEC': 'PR' XDEF SCLMULV 'PR' ('INT' N = 'UPB' B; 'VEC' C = 'HEAP'[1 : N]'REAL'; 'FOR' I 'TO' N 'DO' C[I]:= B[I] * A 'OD'; C) 'PR' FEDX 'PR', 'OP' * = ('VEC' A, B) 'REAL': 'PR' XDEF INPROD 'PR' ('REAL' S:= 0; 'FOR' I 'TO' 'UPB' A 'DO' S+:=A[I]*B[I]'OD'; S) 'PR' FEDX 'PR', 'OP' + = ('VEC' A, B) 'VEC': 'PR' XDEF VECADD 'PR' ('INT' N = 'UPB' B; 'VEC' C = 'HEAP'[1 : N]'REAL'; 'FOR' I 'TO' N 'DO' C[I]:= A[I] + B[I] 'OD'; C)'PR' FEDX 'PR', 'OP' - = ('VEC' A, B) 'VEC' : 'PR' XDEF VECSUB 'PR' ('INT' N = 'UPB' B; 'VEC' C = 'HEAP'[1 : N]'REAL'; 'FOR' I 'TO' N 'DO' C[I]:= A[I] - B[I] 'OD'; C)'PR' FEDX 'PR'; 'OP' + =('MAT' Y1, Y2)'MAT' : 'PR' XDEF MATADD 'PR' ( 'INT' N2 = 1 'UPB' Y1; 'MAT' Y = 'HEAP'[1 : N2, 1 : 2 'UPB' Y1]'REAL'; 'FOR' I 'TO' N2 'DO' Y[I, ]:= Y1[I, ] + Y2[I, ] 'OD'; Y ) 'PR' FEDX 'PR', 'OP' - = ('MAT' Y1, Y2)'MAT' : 'PR' XDEF MATSUB 'PR' ( 'INT' N2 = 1 'UPB'Y1; 'MAT' Y = 'HEAP'[1 : N2, 1 : 2 'UPB' Y1]'REAL'; 'FOR' I 'TO' N2 'DO' Y[I, ]:= Y1[I, ] - Y2[I, ] 'OD'; Y ) 'PR' FEDX 'PR'; 'OP' * = ('REAL' R,'MAT' Y)'MAT' : 'PR' XDEF SCLMULM 'PR' ( 'INT' N2 = 1 'UPB' Y; 'MAT' Z = 'HEAP'[1 : N2, 1 : 2 'UPB' Y]'REAL'; 'FOR' I 'TO' N2 'DO' Z[I, ]:= R * Y[I, ] 'OD'; Z ) 'PR' FEDX 'PR'; 'PROC' DECTRI=('INT'MIN,MAX,'TRIDIAMAT'MAT)'VOID': 'PR' XDEF DECTRI 'PR' 'BEGIN''VEC' SUB = (SUB 'OF' MAT)[MIN : ], DIAG = (DIAG 'OF' MAT)[MIN : MAX], SUP = (SUPER 'OF' MAT)[MIN : ]; 'PROC' TESTD='VOID': 'IF' 'ABS' D <= NORM1 * 1.E-8 'THEN' PDERROR(110, 'TRUE') 'FI'; 'REAL' S:= 0, U:= 0, NORM1, R, 'REF''REAL' D; 'FOR' I 'TO' 'UPB' DIAG 'DO' D:=DIAG[I]; R:=SUP[I]; NORM1:='ABS'D+'ABS'R+'ABS'S; D -:= U * S; TESTD; U:=SUP[I]:=R/D; S:=SUB[I] 'OD'; D:= DIAG['UPB' DIAG]; NORM1:='ABS'D+'ABS'S; D -:= U * S; TESTD 'END' #DECTRI# 'PR' FEDX 'PR', 'PROC' SOLTRI=('INT'MIN,MAX,'TRIDIAMAT'MAT,'VEC'RHS)'VEC': 'PR' XDEF SOLTRI 'PR' 'BEGIN''VEC' SUB = (SUB 'OF' MAT)[MIN : ], DIAG = (DIAG 'OF' MAT)[MIN : MAX], SUP = (SUPER 'OF' MAT)[MIN : ], RHS1 = RHS [MIN : ]; 'REAL' R:= RHS1[1] /:= DIAG[1]; 'FOR' I 'FROM' 2 'TO' 'UPB' DIAG 'DO' R:=RHS1[I]:=(RHS1[I]-SUB[I-1]*R)/DIAG[I] 'OD'; 'FOR' I 'FROM' 'UPB' DIAG-1 'BY' -1 'TO' 1 'DO' R:=RHS1[I]-:=SUP[I]*R 'OD'; RHS 'END' #SOLTRI# 'PR' FEDX 'PR'; 'SKIP' 'END' # OF LIBRARY 1 # ################################################################################ IBVPLB2 : # 771121 JK # 'BEGIN' # PART 2 OF LIBRARY FOR THE INTERFACE FOR SEMIDISCRETIZATION OF INITIAL BOUNDARY VALUE PROBLEMS. UPDATE : 780203. EXTERNAL PROCEDURES, TO BE COMPILED WITH THE PRELUDE IBVPPR. CONTROL CARD : A68,I=**,P=IBVPLIB/IBVPPR. (AND EDITLIB-RUN). CHAPTER 2. PRELUDE FOR COMPUTATION OF GRID FROM THE USER SUPPLIED INFORMATION IN DGRID. # 'PROC' TFM GRID = ('DEFGRID' DGRID, 'INT' SHI, SHJ, 'REF'[,]'INT' POSITN, 'REF''REF'[,]'POINT' GRID)'INT' : 'PR' XDEF TFMGRID 'PR' # YIELD IS NUMBER OF GRID POINTS # 'BEGIN''INT' IMAX = 1 'UPB' POSITN, JMAX = 2 'UPB' POSITN; 'FOR' I 'TO' IMAX 'DO''FOR' J 'TO' JMAX 'DO' POSITN[I, J]:= INSIDE 'OD' 'OD'; # GRID PRESET ON INSIDE # 'REF'[ ]'INT' CX = (CX 'OF' DGRID)['AT' 1], CY = (CY 'OF' DGRID)['AT' 1], 'INT' I0, J0, NUMGP:= IMAX * JMAX; 'INT' UPB CX = 'UPB' CX; 'IF' UPB CX /= 'UPB' CY 'THEN' PDERROR(201, 'TRUE') 'FI'; 'FOR' I 'TO' UPB CX # FILL BORDER ELEMENTS OF GRID # 'DO' 'IF' I = 1 'THEN' I0:= CX[1] - SHI; J0:= CY[1] - SHJ 'ELSE' 'INT' I1 = CX[I] - SHI, J1 = CY[I] - SHJ; 'IF' I1 < 1 'OR' I1 > IMAX 'THEN' PDERROR(203, 'TRUE') 'ELIF' J1 < 1 'OR' J1 > JMAX 'THEN' PDERROR(204, 'TRUE') 'FI'; 'REF'[ ]'INT' LOCP; 'PROC' TRACE = 'VOID' : 'FOR' K 'TO' 'UPB' LOCP 'DO''IF' LOCP[K] = BORDER 'THEN'PDERROR(205, 'FALSE') 'ELSE' LOCP[K]:= BORDER 'FI' 'OD'; 'IF' I1 = I0 'AND' J1 /= J0 'THEN' LOCP:= POSITN[I0, ( J1 > J0 ! J0 ! J1 + 1 ) : ( J1 > J0 ! J1 - 1 ! J0 ) ]; TRACE 'ELIF' I1 /= I0 'AND' J1 = J0 'THEN' LOCP:= POSITN[ ( I1 > I0 ! I0 ! I1 + 1 ) : ( I1 > I0 ! I1 - 1 ! I0 ), J0]; TRACE 'ELIF' I0 /= 0 'AND' J0 /= 0 'THEN' PDERROR(202, 'FALSE') 'FI'; 'IF' POSITN[I1, J1] = BORDER 'THEN' I0:= 0; J0:= 0 'ELIF' I = UPB CX 'THEN' PDERROR(206, 'FALSE') 'ELSE' I0:= I1; J0:= J1 'FI' 'FI' 'OD'; 'FOR' I 'TO' IMAX # COMPUTE OUTSIDE ELEMENTS # 'DO''INT' LAST:= OUTSIDE, ALLAST:= OUTSIDE, 'REF'[ ]'INT' LOCP = POSITN[I, ]; 'FOR' J 'TO' JMAX 'DO' 'REF''INT' PRESENT = LOCP[J]; 'CASE' ALLAST + 2 'IN''IF' LAST = OUTSIDE 'THEN' PRESENT:= - PRESENT 'FI', 'CASE' LAST + 2 'IN' PRESENT:= - PRESENT, 'IF' PRESENT /= BORDER 'THEN''IF' I = 1 'THEN' PRESENT:= OUTSIDE 'ELIF''REF'[ ]'INT' LCG = POSITN[I-1,J-2 : J]; 'INT' TEMP = LCG[3]; TEMP /= BORDER 'THEN' PRESENT:= TEMP 'ELIF' 'INT' TMP1 = LCG[2]; TMP1 /= BORDER 'THEN' PRESENT:= TMP1 'ELIF' LCG[1] = INSIDE 'THEN' PRESENT:= OUTSIDE 'FI' 'FI', 'SKIP' 'ESAC', 'IF' LAST = BORDER 'THEN' PRESENT:= - PRESENT 'FI' 'ESAC'; ALLAST:= LAST; LAST:= PRESENT; 'IF' PRESENT = OUTSIDE 'THEN' NUMGP -:= 1 'FI' 'OD' 'OD'; # COPY COORDINATES # 'CASE' R 'OF' DGRID 'IN' ( 'REF'[ , ]'POINT' AR ): 'IF' 1 'LWB' AR - SHI /= 1 'OR' 2 'LWB' AR - SHJ /= 1 'OR' 2 'UPB' AR - SHI /= IMAX 'OR' 2 'UPB' AR - SHJ /= JMAX 'THEN' PDERROR(220, 'TRUE') 'ELSE' GRID:= AR['AT' 1, 'AT' 1] 'FI', ( 'PROC'('INT', 'INT')'POINT' PR ): 'BEGIN' GRID:= 'HEAP'[1 : IMAX, 1 : JMAX]'POINT'; 'FOR' I 'TO' IMAX 'DO''REF'[ ]'POINT' LOCG = GRID[I, ], 'REF'[ ]'INT' LOCP = POSITN[I, ]; 'FOR' J 'TO' JMAX 'DO''IF' LOCP[J] >= BORDER 'THEN' LOCG[J]:= PR(I + SHI, J + SHJ) 'FI' 'OD' 'OD' 'END' 'ESAC'; # CHECK ON CONSISTENT COORDINATES INSIDE GRID, VIZ. ALONG A GRID LINE EACH POINT LIES 'BETWEEN' ITS TWO NEIGHBOURS # 'PROC' DIST = ('POINT' Q1, Q2)'REAL' : ((XC 'OF' Q1) - (XC 'OF' Q2)) ** 2 + ((YC 'OF' Q1) - (YC 'OF' Q2)) ** 2; 'PROC' CHECK COORD = ('REF'[ ]'POINT' LOCG, 'REF'[ ]'INT' LOCP )'VOID' : 'BEGIN''INT' NSUCC:= 0, 'REAL' D12, D13, D23, 'REF''POINT' P1, P2, P3; 'FOR' J 'TO' 'UPB' LOCP 'DO' 'IF' LOCP[J] > OUTSIDE 'THEN' NSUCC+:=1 'ELSE' NSUCC:= 0 'FI'; 'CASE' NSUCC 'IN' P1:= LOCG[J], 'BEGIN' P2:= LOCG[J]; D12:= DIST(P1, P2) 'END', 'BEGIN' P3:= LOCG[J]; D23:= DIST(P2, P3); D13:= DIST(P1, P3); 'IF' D13 <= D12 'OR' D13 <= D23 'THEN' PDERROR(230, 'FALSE') 'FI'; P1:= P2; P2:= P3; D12:= D23; NSUCC:= 2 'END' 'OUT' 'SKIP' 'ESAC' 'OD' 'END' # CHECK COORDINATES #; 'FOR' I 'TO' IMAX 'DO' CHECK COORD(GRID[I, ], POSITN[I, ]) 'OD'; 'FOR' J 'TO' JMAX 'DO' CHECK COORD(GRID[, J], POSITN[, J]) 'OD'; 'IF' ERRONEOUS 'THEN' PDERROR(999, 'TRUE') 'FI'; NUMGP # RESULT # 'END' # OF TFM GRID # 'PR' FEDX 'PR', # PRINTING OF GRID. # 'PROC' PRINT GRID = ('REF'[,]'INT' POSITN, 'INT' SHI, SHJ, PAGLIM )'VOID' : 'PR' XDEF PRINTGR 'PR' 'BEGIN''INT' IMAX = 1 'UPB' POSITN, JMAX = 2 'UPB' POSITN; 'PROC' OUTC = ('INT' POS, MULT, 'BOOL' ACTIVE) [ ]'CHAR' : 'IF' 'NOT' ACTIVE 'THEN' " " 'ELSE' ( ( POS <= - MULT 'AND' POS > - 10 * MULT ! "-" ! " " ) , ( POS = 0 'AND' MULT = 1 ! "0" !: 'ABS' POS < MULT ! " " ! 'REPR'('ABS' POS 'OVER' MULT 'MOD' 10 + 48) ) ) 'FI' # OUT C #; 'INT' I1:= 1, IN, MULT, SEGM:= 1; 'WHILE' IN:= I1 + PAGLIM; 'IF' IN > IMAX 'THEN' IN:= IMAX 'FI'; PRINT((NEWLINE, " GRID : SEGMENT ", WHOLE(SEGM, - 2), NEWLINE)); MULT:= 10000; 'WHILE' MULT > 0 'DO' PRINT(" "); 'FOR' I 'FROM' I1 'TO' IN 'DO' PRINT(OUTC(I + SHI, MULT, I = I1 'OR' I = IN 'OR' (I + SHI) 'MOD' 10 = 0)) 'OD'; PRINT(NEWLINE); MULT 'OVERAB' 10 'OD'; 'FOR' J 'FROM' JMAX 'BY' - 1 'TO' 1 'DO''INT' J1 = J + SHJ, 'REF'[ ]'INT' LOCP = POSITN[I1:IN, J]; [ ]'CHAR' NUM = (J = 1 'OR' J = JMAX 'OR' J1 'MOD' 10 = 0 ! WHOLE(J1, - 5) ! " " ); PRINT((" ", NUM)); 'FOR' I 'TO' 'UPB' LOCP 'DO' PRINT((" ", " $."[LOCP[I] + 2])) 'OD'; PRINT((NUM, NEWLINE)) 'OD'; I1:= IN; SEGM +:= 1; I1 < IMAX 'DO''SKIP''OD'; PRINT((NEWLINE, " - - - END OF LISTING GRID", NEWLINE)) 'END' # PRINT GRID # 'PR' FEDX 'PR', 'PROC' UPRINT = ('MAT' U, 'INT' SHI, SHJ, 'REF'[,]'INT' POSIT )'VOID' : 'PR' XDEF UPRINT 'PR' 'BEGIN' 'INT' NL:= 0, NN:= 0, SEG:= 1, 'INT' KOLL = 7, IMAX = 1 'UPB' U, JMAX = 2 'UPB' U; 'WHILE' NN+:= KOLL; 'IF' NN > IMAX 'THEN' NN:= IMAX 'FI'; PRINT((NEWLINE, " SEGMENT #", WHOLE(SEG, -3), " OF U-FIELD", NEWLINE)); 'FOR' I 'FROM' NL + 1 + SHI 'TO' NN + SHI 'DO' PRINT(WHOLE(I, -17)) 'OD'; 'FOR' J 'FROM' JMAX 'BY' - 1 'TO' 1 'DO' 'REF'[ ]'REAL' LOCU = U[NL + 1 : NN, J], 'REF'[ ]'INT' LOCP = POSIT[NL + 1 : NN, J]; PRINT((NEWLINE, " ", WHOLE(J + SHJ, - 4), " ")); 'FOR' I 'TO' 'UPB' LOCP 'DO' PRINT((" ", ( LOCP[I] > OUTSIDE ! FLOAT(LOCU[I], 16, 10, 2) ! " . . . . . . . " ) )) 'OD'; PRINT((" ", WHOLE(J + SHJ, - 4) )) 'OD'; PRINT(NEWLINE); 'FOR' I 'FROM' NL + 1 + SHI 'TO' NN + SHI 'DO' PRINT(WHOLE(I, -17)) 'OD'; PRINT(NEWLINE); NN < IMAX 'DO' NL:= NN; SEG+:= 1 'OD'; PRINT((NEWLINE, " - - - END OF LAST SEGMENT OF U", NEWLINE)) 'END' # U PRINT # 'PR' FEDX 'PR'; 'SKIP' 'END' # OF LIBRARY 2 # ################################################################################ IBVPLB4 : # 771208 JK # 'BEGIN' 'COMMENT' THE INTERFACE FOR SEMIDISCRETIZATION OF INITIAL BOUNDARY VALUE PROBLEMS. THIS PART BY : P.H.M. WOLKENFELT. UPDATE : 771208. CONTROL CARD : A68,I=**,P=IBVPLIB/IBVPPR. (AND EDITLIB-RUN) 'COMMENT' 'PROC' RETRIEVE DATA = ('INT' K,R, 'MOLSMAT' MASTOR,'REF''MOLS' DATA)'VOID': 'PR' XDEF RETRDAT 'PR' ( DATA:= MASTOR[K,R] ) 'PR' FEDX 'PR'; 'PROC' FORM MOLECULES = ( 'MOLS' DATA, 'MAT' DDX,DDY,DDXX,DDXY,DDYY )'VOID': 'PR' XDEF FORMMOL 'PR' ( 'REAL' AX,AY,Z; AY:= DATA[1]; AX:= DATA[2]; DDX := ( ( 0 , AY, 0 ), (-AX, 0 , AX), ( 0 ,-AY, 0 ) ); AY:= DATA[3]; AX:= DATA[4]; DDY := ( ( 0 , AY, 0 ), (-AX, 0 , AX), ( 0 ,-AY, 0 ) ); Z:= DATA[5]; DDXX:= ( (-Z,DATA[ 6], Z), DATA[ 7 : 9 ] , ( Z,DATA[10],-Z) ); Z:= DATA[11]; DDXY:= ( (-Z,DATA[12], Z), DATA[13 : 15] , ( Z,DATA[16],-Z) ); Z:= DATA[17]; DDYY:= ( (-Z,DATA[18], Z), DATA[19 : 21] , ( Z,DATA[22],-Z) ) ) 'PR' FEDX 'PR' # END OF FORM MOLECULES #; 'PROC' COMPUTE DATA = ( 'MOLSMAT' MASTOR, 'REF'[ , ]'POINT' GRID, 'REF'[ , ]'INT' POSITION )'VOID' : 'PR' XDEF COMPDAT 'PR' 'BEGIN' 'INT' KMAX= 1 'UPB' POSITION, RMAX= 2 'UPB' POSITION; 'PROC' LAGRANGE = ('REAL' X,X1,F1,X2,F2,X3,F3, 'REF''REAL' FX,DFX,DDFX) 'VOID': # THIS PROCEDURE COMPUTES AN APPROXIMATION OF THE FUNCTION F AND ITS FIRST AND SECOND DERIVATIVE AT THE POINT X BY MEANS OF QUADRATIC INTERPOLATION # ( 'REAL' DX1:= X1-X2, DX2:= X1-X3, DX3:= X2-X3; 'REAL' C1:= F1/DX1/DX2, C2:= -F2/DX1/DX3, C3:= F3/DX2/DX3; DX1:= X-X1; DX2:= X-X2; DX3:= X-X3; FX:= DX2*DX3 *C1+ DX1*DX3 *C2+ DX1*DX2 *C3; DFX:= (DX2+DX3)*C1+(DX1+DX3)*C2+(DX1+DX2)*C3; DDFX:= 2*(C1+C2+C3) ); 'PROC' GENERATE MOLECULES = ('INT' K,R) 'VOID': ( 'REF' 'POINT' P1 = GRID [K-1,R+1], P2 = GRID [ K ,R+1], P3 = GRID [K+1,R+1], # P1 P2 P3 # P4 = GRID [K-1, R ], P5 = GRID [ K , R ], # P4 P5 P6 # P6 = GRID [K+1, R ], P7 = GRID [K-1,R-1], # P7 P8 P9 # P8 = GRID [ K ,R-1], P9 = GRID [K+1,R-1]; 'REAL' GKM1,DGKM1,DDGKM1,GK,DGK,DDGK,GKP1,DGKP1,DDGKP1, FRM1,DFRM1,DDFRM1,FR,DFR,DDFR,FRP1,DFRP1,DDFRP1; LAGRANGE( YC 'OF' P5, YC 'OF' P7,XC 'OF' P7,YC 'OF' P4,XC 'OF' P4, YC 'OF' P1,XC 'OF' P1, GKM1,DGKM1,DDGKM1); LAGRANGE( YC 'OF' P5, YC 'OF' P8,XC 'OF' P8,YC 'OF' P5,XC 'OF' P5, YC 'OF' P2,XC 'OF' P2, GK,DGK,DDGK); LAGRANGE( YC 'OF' P5, YC 'OF' P9,XC 'OF' P9,YC 'OF' P6,XC 'OF' P6, YC 'OF' P3,XC 'OF' P3, GKP1,DGKP1,DDGKP1); LAGRANGE( XC 'OF' P5, XC 'OF' P7,YC 'OF' P7,XC 'OF' P8,YC 'OF' P8, XC 'OF' P9,YC 'OF' P9, FRM1,DFRM1,DDFRM1); LAGRANGE( XC 'OF' P5, XC 'OF' P4,YC 'OF' P4,XC 'OF' P5,YC 'OF' P5, XC 'OF' P6,YC 'OF' P6, FR,DFR,DDFR); LAGRANGE( XC 'OF' P5, XC 'OF' P1,YC 'OF' P1,XC 'OF' P2,YC 'OF' P2, XC 'OF' P3,YC 'OF' P3, FRP1,DFRP1,DDFRP1); 'REAL' X1,X2,X11,X12,X22, Y1,Y2,Y11,Y12,Y22; X1:= 2/(GKP1-GKM1); X2:= -DGK*X1; X11:= -(GKP1+GKM1-2*GK)*X1*X1*X1; X12:= -DGK*X11-X1*X1*0.5*(DGKP1-DGKM1); X22:= -(DGK*DGK*X11+2*DGK*X12+DDGK*X1); Y2:= 2/(FRP1-FRM1); Y1:= -DFR*Y2; Y22:= -(FRP1+FRM1-2*FR)*Y2*Y2*Y2; Y12:= -DFR*Y22-Y2*Y2*0.5*(DFRP1-DFRM1); Y11:= -(DFR*DFR*Y22+2*DFR*Y12+DDFR*Y2); 'REAL' AX,AXX,AY,AYY,Z; 'MOLS' DATA = 'HEAP'[1 : 22]'REAL'; AX:= X1*0.5; AY:= Y1*0.5; # 0 AY 0 DDX = -AX 0 AX 0 -AY 0 # # ONLY STORE AY, AX # DATA[1:2]:= (AY,AX); AX:= X2*0.5; AY:= Y2*0.5; # 0 AY 0 DDY = -AX 0 AX 0 -AY 0 # # ONLY STORE AY, AX # DATA[3:4]:= (AY,AX); AX:= X11*0.5; AXX:= X1*X1; AY:= Y11*0.5; AYY:= Y1*Y1; Z:= X1*Y1*0.5; # - Z AYY + AY Z DDXX = AXX - AX -2*(AXX+AYY) AXX + AX Z AYY - AY - Z STORE RELEVANT ENTRIES # DATA[5:10]:= (Z,AYY+AY,AXX-AX,-2*(AXX+AYY),AXX+AX,AYY-AY); AX:= X12*0.5; AXX:= X1*X2; AY:= Y12*0.5; AYY:= Y1*Y2; Z:= ( X1*Y2 + X2*Y1 )*0.25; # - Z AYY + AY Z DDXY = AXX - AX -2*(AXX+AYY) AXX + AX Z AYY - AY - Z STORE RELEVANT ENTRIES # DATA[11:16]:= (Z,AYY+AY,AXX-AX,-2*(AXX+AYY),AXX+AX,AYY-AY); AX:= X22*0.5; AXX:= X2*X2; AY:= Y22*0.5; AYY:= Y2*Y2; Z:= X2*Y2*0.5; # - Z AYY + AY Z DDYY = AXX - AX -2*(AXX+AYY) AXX + AX Z AYY - AY - Z STORE RELEVANT ENTRIES # DATA[17:22]:= (Z,AYY+AY,AXX-AX,-2*(AXX+AYY),AXX+AX,AYY-AY); # SEND DATA TO MASS STORAGE # MASTOR[K,R]:= DATA ) # END OF GENERATE MOLECULES # ; 'FOR' K 'TO' KMAX 'DO' 'FOR' R 'TO' RMAX 'DO' 'IF' POSITION [K,R] = INSIDE 'THEN' GENERATE MOLECULES (K,R) 'ELSE' MASTOR[K,R]:= 'NIL' 'FI' 'OD' 'OD' 'END' 'PR' FEDX 'PR' # COMPUTE DATA #; 'SKIP' 'END' # OF LIBRARY PART 4 # ################################################################################ IBVPSOL : # 771104 JK # 'BEGIN' 'COMMENT' THE INTERFACE FOR SEMIDISCRETIZATION OF INITIAL BOUNDARY VALUE PROBLEMS. UPDATE : 780203. TO BE USED WITH A PRELUDE, NAMED IBVPPR, CONTAINING GLOBAL MODE DEFINITIONS (VEC, MAT, TOLS, INFO, RHSFU, BOUNDFU, POINT, DEFGRID, ETC.), CONSTANTS (INSIDE, BORDER AND OUTSIDE), OPERATORS(REAL * VEC, VEC * VEC, VEC + VEC, AND VEC - VEC) AND PROCS (TFM GRID, PRINT GRID, ETC.). CONTROL CARD : A68,I=**,P=IBVPLIB/IBVPPR. CHAPTER 1. MODES. IN THIS CHAPTER SEVERAL MODES, OPERATORS AND AUXILIARY PROCEDURES TO BE USED IN THE I B V P S O L V E R ARE DECLARED. THE CHAPTER HAS BEEN PLACED IN THE LIBRARY IBVPLIB. CHAPTER 2. THE I B V P S O L V E R . *** ********************* THE IBVP SOLVER FOR SEMIDISCRETIZATION OF INITIAL BOUNDARY VALUE PROBLEMS IS A PROCEDURE WHICH IS USED WITH ACTUAL PARAMETERS : A. THE METHOD OF INTEGRATION OF THE O D E RESULTING FROM THE SEMI-DISCRETIZATION, B. THE RIGHT HAND SIDE, A FUNCTION OF THE PARAMETERS T, X, Y, U, UX, UY, UXX, UXY AND UYY DELIVERING A REAL, C. A BOUNDARY CONDITION, I.E. AN IMPLICIT CONDITION FOR U GIVEN AS A FUNCTION OF THE PARAMETERS T, X, Y AND U (EVENTUALLY AN IMPLICIT FUNCTION OF T, X, Y, U, UX AND UY), D. A REPRESENTATION OF THE GRID AND ITS BOUNDARY, E. AN ARRAY FOR THE SOLUTION OF THE PDE, ON ENTRY CONTAINING THE INITIAL VALUE, F. THE INTERVAL OF INTEGRATION (TSTART IS A VARIABLE, TEND IS A [ ]'REAL' CONTAINING SUCCESSIVE END POINTS), G. MISCELLANEOUS PARAMETERS FOR CONTROL. THE IBVP SOLVER COMPUTES ANOTHER REPRESENTATION OF THE GRID, STORES INFORMATION ABOUT THE WAY OF DISCRETIZATION INTO A MOLECULE TO BE USED BY THE INTEGRATOR, AND CALLS THE INTEGRATOR WITH LOCAL PROCEDURES GDISCR AND BDISCR (BY P.H.M.WOLKENFELT) FOR DISCRETIZING THE RIGHT HAND SIDE OF THE P D E INTO A PROPER RIGHT HAND SIDE OF AN O D E THAT IS SOLVED BY THE INTEGRATOR; HERE THE BOUNDARY CONDITION IS USED FOR COMPUTING U[ , ] AT THE BOUNDARY POINTS, AS THESE VALUES ARE USED BY THE DISCRETIZER. RESTRICTION ON THE REPRESENTATION OF THE GRID : AN INTERIOR ELEMENTARY SQUARE HAVING FOUR BOUNDARY POINTS AS ITS CORNERS IS NOT ALLOWED. SEE PRELUDE FOR EXTERNAL PROCEDURES. 'COMMENT' 'PROC' I B V P S O L V E R = ('INTEGRATOR' INTEGRATOR, 'RHSFU' G # RIGHT HAND SIDE #, 'BOUNDFU' BV # BOUNDARY CONDITION #, 'DEFGRID' DGRID # USER'S REPRESENTATION OF GRID AND BORDER #, 'REF''MAT' U, 'REF''REAL' T START, [ ]'REAL' T END, 'REF''INFO' INFO )'VOID' : 'PR' XDEF IBVPSOL 'PR' 'BEGIN' # BODY OF IBVP SOLVER # 'INT' SHI = 1 'LWB' U - 1, SHJ = 2 'LWB' U - 1; 'INT' IMAX = 1 'UPB' U - SHI, JMAX = 2 'UPB' U - SHJ; [1 : IMAX, 1 : JMAX]'INT' POSITN, 'REF'[ , ]'POINT' GRID; ERRONEOUS:= 'FALSE'; 'COMMENT' CHAPTER 3. COMPUTATION OF GRID FROM THE USER SUPPLIED INFORMATION IN DGRID. NOTE THAT THE NEW GRID HAS LOWER BOUNDS 1. U WILL HAVE REVISED BOUNDS IN THE CALL OF THE INTEGRATOR. 'COMMENT' # COMPUTE PATTERN OF THE GRID : # NUMGP 'OF' INFO:= TFM GRID(DGRID, SHI, SHJ, POSITN, GRID); 'COMMENT' CHAPTER 4. THE SEMI-DISCRETIZATION. THE PROCEDURES COMPUTE DATA, RETRIEVE DATA AND FORM MOLECULES ARE CALLED FROM THE LIBRARY. 'COMMENT' 'OP' * = ('MAT' A, B) 'REAL': ( 'REAL' S:= 0; 'FOR' I 'TO' 1 'UPB' A 'DO''FOR' J 'TO' 2 'UPB' A 'DO' S+:= A[I,J] * B[I,J] 'OD''OD'; S ); 'PROC' GDISCR = ('INT' K, R, 'REAL' T,'MAT' U) 'REAL': ( 'IF' POSITN[K,R] = INSIDE 'THEN''MOLS' DATA; RETRIEVE DATA(K,R,MASTOR,DATA); 'MAT' DDX = 'LOC'[1 : 3, 1 : 3]'REAL', DDY = 'LOC'[1 : 3, 1 : 3]'REAL', DDXX = 'LOC'[1 : 3, 1 : 3]'REAL', DDXY = 'LOC'[1 : 3, 1 : 3]'REAL', DDYY = 'LOC'[1 : 3, 1 : 3]'REAL', UKR = 'LOC'[1 : 3, 1 : 3]'REAL'; FORM MOLECULES(DATA,DDX,DDY,DDXX,DDXY,DDYY); UKR:= ( U[K-1:K+1,R+1],U[K-1:K+1,R],U[K-1:K+1,R-1] ); G('REAL' : T,'REAL' : XC 'OF' GRID [K,R],'REAL' : YC 'OF' GRID [K,R], 'REAL' : U[K,R], 'REAL' : DDX * UKR, 'REAL' : DDY * UKR, 'REAL' : DDXX * UKR, 'REAL' : DDXY * UKR, 'REAL' : DDYY * UKR) 'ELSE' 0 'FI' ); 'PROC' BDISCR = ('INT' K,R,'REAL' T,'MAT' U) 'REAL': ( 'IF' POSITN [K,R] = BORDER 'THEN' BV('REAL' : T, 'REAL' : XC 'OF' GRID [K,R], 'REAL' : YC 'OF' GRID [K,R], 'REAL' : U[K, R]) 'ELSE' PDERROR(2, 'FALSE'); 0 'FI' ); 'MOLSMAT' MASTOR = 'LOC' [1 : IMAX, 1 : JMAX]'MOLS'; COMPUTE DATA(MASTOR, GRID, POSITN); 'COMMENT' CHAPTER 5. OTHER INITIALIZATIONS. 'COMMENT' 'REAL' HMIN = HMIN 'OF' INFO, 'REF''PROC'('REAL')'REAL' NEXTH = NEXTH 'OF' INFO, 'REF''PROC'('INT')'BOOL' CONTROL = PRINTSOME 'OF' INFO, 'INFOINT' INFOI:= (LOCERRTOL 'OF' INFO, NUMGP 'OF' INFO, 'TRUE', 'TRUE', 0, 'SKIP', 'SKIP'); 'MAT' UACTUAL:= U['AT' 1, 'AT' 1]; 'BOOL' FAIL:= 'FALSE', 'MAT' UCOPY:= UACTUAL # SAME REF #, 'REF''INT' ITER1= NSTEPSPERF 'OF' INFO:= 0, ITER2= NSTEPSREJ 'OF' INFO:= 0, 'REF''BOOL' LAST OK = LAST STEP OK 'OF' INFOI, COMPUTEH = COMPUTE H 'OF' INFOI, 'REAL' OLD H, HNEW:= NEXTH(TSTART), 'REF''PROC'('INT', 'REAL', 'REAL', 'MAT')'VOID' MONIT = MONITOR 'OF' INFO; 'IF' CONTROL(0) 'THEN' 'FOR' N 'TO' 4 'DO''IF' CONTROL(N) 'THEN''CASE' N 'IN' UPRINT(U['AT' 1, 'AT' 1], SHI, SHJ, POSITN), PRINT GRID(POSITN, SHI, SHJ, 60), 'SKIP', # PRINT GRID COORDINATES # 'SKIP' # PRINT INFO INPUT # 'ESAC' 'FI' 'OD'; PDERROR(0, 'TRUE') 'ELIF' CONTROL(2) 'THEN' PRINT GRID(POSITN, SHI, SHJ, 60) 'FI'; 'COMMENT' CHAPTER 6. CHECK ACCURACY. 'COMMENT' 'PROC' CHECK ACCURACY = ('MAT' U, 'REF''REAL' FACTOR)'VOID' : 'IF' LOCAL ERROR 'OF' INFOI = 0 'THEN' FACTOR:= 1 'ELSE' 'REAL' NORMY:= ('REAL' S:= 0; 'FOR' I 'TO' IMAX 'DO''FOR' J 'TO' JMAX 'DO''IF' POSITN[I, J] > OUTSIDE 'THEN' S +:= U[I, J] **2 'FI' 'OD' 'OD'; SQRT( S / (NUMGP 'OF' INFOI) ) ); FACTOR:= EXP(LN((LOCERRTOL 'OF' INFOI) * (1 + NORMY) / (LOCALERROR 'OF' INFOI)) / ((ORDER 'OF' INFOI) + 1)) * 0.9 'FI' # END CHECK ACCURACY #; 'COMMENT' START OF IBVP SOLVER : CHAPTER 7. THE CALL OF THE INTEGRATOR IN THE IBVP SOLVER. AFTER COMPUTATION OF THE GRID AND OF THE EXPLICIT CONDITION FOR U IN THE BOUNDARY CONDITION, THE INTEGRATOR IS CALLED ITERATIVELY (SEE FLOW CHART IN DIAGRAM 1). 'COMMENT' 'FOR' ISTEP 'TO' 'UPB' TEND 'WHILE' 'NOT' FAIL 'DO''REAL' TE = TEND[ISTEP], 'REAL' ALPHA, 'BOOL' LAST:= TE - TSTART - HMIN < HNEW * 1.01; 'IF' LAST 'THEN' HNEW:= TE - TSTART 'FI'; 'WHILE' # TILL T E # 'BOOL' ENDLOOP:= LAST; LAST OK:= 'TRUE'; 'WHILE' # LOOP FOR STEP REJECTION # OLDH:= HNEW; INTEGRATOR (TSTART, OLDH, UACTUAL# AFTERWARDS TO UNEW #, INFOI, # ! # GDISCR, BDISCR, # ! # POSITN ); 'IF' 'NOT' LAST O K 'THEN''IF' OLDH = HMIN 'OR' 'NOT' COMPUTE H 'THEN' FAIL:= 'TRUE'; PDERROR(50, 'FALSE') 'FI'; HNEW:= ( OLDH < 4 * HMIN ! HMIN ! OLDH / 4 ); 'NOT' FAIL 'ELIF' 'NOT' COMPUTE H 'THEN' 'FALSE' 'ELIF' CHECK ACCURACY(UACTUAL, ALPHA); ALPHA <= 0.9 'THEN''IF' OLDH = HMIN 'THEN' FAIL:= 'TRUE'; PDERROR(51, 'FALSE') 'FI'; HNEW:= ALPHA * OLDH; 'IF' HNEW < HMIN 'THEN' HNEW:= HMIN 'FI'; UACTUAL:= UCOPY # SAME REF #; 'NOT' FAIL 'ELSE' HNEW:= ( ALPHA > 3.0 ! 3.0 !: ALPHA < 1.1 ! 1.0 ! ALPHA ) * OLDH; 'FALSE' 'FI' 'DO' ENDLOOP:= 'FALSE'; ITER2 +:= 1; LAST OK:= 'FALSE'; MONIT(3, TSTART, OLDH, U) 'OD'; TSTART +:= OLDH; 'IF' 'NOT' COMPUTE H 'THEN' HNEW:= NEXTH(TSTART); 'IF' HNEW < HMIN 'THEN' PDERROR(52, 'FALSE') 'FI' 'FI'; UCOPY:= UACTUAL; # SAME REF # 'IF' CONTROL(1) 'THEN' UPRINT(UACTUAL,SHI,SHJ, POSITN)'FI'; U:= UACTUAL['AT' (SHI + 1), 'AT' (SHJ + 1)]; # SAME REF # LOCAL ERROR 'OF' INFO:= LOCAL ERROR 'OF' INFOI; LAST:= 1.01 * HNEW + TSTART + HMIN > TE; 'IF' FAIL 'THEN' ITER2 +:= 1 'ELSE' ITER1 +:= 1 'FI'; 'NOT' (ENDLOOP 'OR' FAIL) 'DO''IF' LAST 'THEN' HNEW:= TE - TSTART 'FI'; MONIT(2, TSTART, OLDH, U) 'OD' # END OF LOOP. RESULTS ARE IN PARAMETER U, UNLESS FAIL IS 'TRUE' #; 'IF' 'NOT' FAIL 'THEN' MONIT(1, TSTART, OLDH, U) 'ELSE' MONIT(4, TSTART - OLDH, OLDH, U); U:= 'NIL' 'FI' 'OD' 'END' # OF I B V P S O L V E R # 'PR' FEDX 'PR'; 'SKIP' 'END' # OF LIBRARY PART IBVPSOLVER # ################################################################################ TESTPRG : # 771206 JK # 'BEGIN' 'COMMENT' EXAMPLE OF USE BY P.J. VAN DER HOUWEN, FOR : THE INTERFACE FOR SEMIDISCRETIZATION OF INITIAL BOUNDARY VALUE PROBLEMS. UPDATE : 780203. TO BE USED WITH A PRELUDE, NAMED INTPRL, CONTAINING THE INTEGRATOR AND ITS GLOBAL MODES AND VARIABLES. CONTROL CARD : A68,I=**,P=INTLIB/INTPRL. CHAPTER 8. EXAMPLE OF A CALL OF I B V P S O L V E R . LET THE RIGHT HAND SIDE OF THE PDE DU/DT = G(U) BE DECLARED AS FOLLOWS : 'COMMENT' # EMPTY INTEGRATOR DECLARATION FOR TESTING PRINTING PROC AND ERROR CHECKS # 'INTEGRATOR' INTEGRATOR = ('REAL' T, H, 'REF''MAT' U, 'REF''INFOINT' INF, 'PROC'('INT', 'INT', 'REAL', 'MAT')'REAL' G, B, 'REF'[ , ]'INT' POS )'VOID' : 'BEGIN''INT' IMAX = 1 'UPB' U, JMAX = 2 'UPB' U; 'MAT' UNEW = 'HEAP'[1 : IMAX, 1 : JMAX]'REAL' := U; LAST STEP OK 'OF' INF:= 'TRUE'; COMPUTE H 'OF' INF:= 'FALSE'; LOCAL ERROR 'OF' INF:= 0; ORDER 'OF' INF:= 1; U:= UNEW 'END' # OF EMPTY INTEGRATOR #; 'PROC'('REAL')'MAT' Y EXACT; 'PROC'('INT', 'INT')'POINT' GRID; 'DEFGRID' DG; 'MAT' U; 'REAL' EPS = 0.05; PRINT((NEWLINE, " PROBLEM 1 BY VANDERHOUWEN WITH EPS = ", EPS, NEWLINE)); 'PROC' SOLUTION = ('REAL' T, X, Y)'REAL' : ( EXP(- T) * (1 / (X + EPS) + EXP(Y)) ); 'PROC' F = ('REAL' X) 'STRING' : (" " + FLOAT(X, 16, 10, 2)); 'PROC' DISPLAY U = ('REAL' T, 'MAT' U)'VOID' : 'IF' U :=: 'MAT'('NIL') 'THEN' PRINT((" NO OUTPUT", NEWLINE)) 'ELSE''FOR' J 'FROM' 2 'UPB' U 'BY' -1 'TO' 2 'LWB' U 'DO' PRINT(WHOLE(J, -5)); 'FOR' I 'FROM' 1 'LWB' U 'TO' 1 'UPB' U 'DO' 'POINT' P:= 'CASE' R 'OF' DG 'IN' ('PROC'('INT', 'INT')'POINT' PR) : PR(I, J), ('REF'[ , ]'POINT' RP) : RP[I, J] 'ESAC'; PRINT(F(U[I, J] - SOLUTION(T, XC 'OF' P, YC 'OF' P))) 'OD'; PRINT(NEWLINE) 'OD' 'FI' # OF DISPLAY U #; 'REAL' LAST T:= 0, T END:= 0.02, 'INT' G EVAL:= 0, 'INFO' INFO; 'PROC' MONITOR = ('REAL' T, X, Y)'VOID' : 'BEGIN' PRINT((NEWLINE, " MONITORING THE IBVPSOLVER AT ", F(LASTT), " STEPS : ", WHOLE(NSTEPSPERF 'OF' INFO, -5), WHOLE(NSTEPSREJ 'OF' INFO, -5))); LAST T:= T 'END'; 'RHSFU' G = ('PROC''REAL' T, X, Y, U, UX, UY, UXX, UXY, UYY)'REAL' : ( # BODY OF G # GEVAL+:= 1; 'REAL' UU = U; 'REAL' U2 = UU * UU, XX = X; U2 * (UXX + UYY) + 2 * UU * UXY - UU - U2 * UY + 2 * U2 * UX / (XX + EPS) ); 'CO' AND THE BOUNDARY : 'CO' 'BOUNDFU' UB = ('PROC''REAL' T, X, Y, U)'REAL' : ( # BODY OF UB # EXP(- T) * (1 / (X + EPS) + EXP(Y)) - U ); # DECLARATION OF GRID AND U # 'INT' CASE; READ(CASE); 'CASE' CASE 'IN' ( GRID:= ('INT' K, R)'POINT' : ( 'REAL' X = 'CASE' K 'IN' 0, 1 / 6 'OUT' (K - 2) / 3 'ESAC'; ( X, (R - 1) / 4 + 'IF' R < 5 'THEN' (5 - R) * X * (20 - X) / 400 'ELSE' 0 'FI' ) ); DG := ( GRID, 'LOC'[1 : 7]'INT':= (1, 1, 5, 5, 8, 8, 1), 'LOC'[1 : 7]'INT':= (1, 9, 9, 5, 5, 1, 1) ); U:= 'HEAP'[1 : 8, 1 : 9]'REAL' ), ( # DECLARATION OF GRID AND U FOR THE EXAMPLE IN THE PAPER : # GRID:= ('INT' IX, IY)'POINT' : (( IX, IY )); DG:= ( GRID, 'LOC'[1 : 23]'INT':= (0, 0, 28, 28, 0, 4, 24, 24, 4, 4, 8, 8, 20, 20, 8, 8, 4, 4, 12, 16, 16, 12, 12), 'LOC'[1 : 23]'INT':= (0, 45, 45, 0, 0, 5, 5, 40, 40, 25, 25, 35, 35, 10, 10, 20, 20, 5, 15, 15, 30, 30, 15) ); U := 'HEAP' [0 : 28, 0 : 45]'REAL' ), ( GRID:= ('INT' I, J)'POINT' : (( I / 20, J / 20)); 'INT' CLENG; READ(CLENG); [1 : CLENG]'INT' CX, CY; 'FOR' I 'TO' CLENG 'DO' READ(CX[I]) 'OD'; 'FOR' I 'TO' CLENG 'DO' READ(CY[I]) 'OD'; DG := ( GRID, CX, CY ); U:= 'HEAP'[0 : 20, 0 : 20]'REAL' ) 'ESAC'; 'FOR' I 'FROM' 1 'LWB' U 'TO' 1 'UPB' U 'DO''FOR' J 'FROM' 2 'LWB' U 'TO' 2 'UPB' U 'DO' 'POINT' P = GRID(I, J); U[I, J]:= 1 / ((XC 'OF' P) + EPS) + EXP(YC 'OF' P) 'OD' 'OD'; YEXACT # THE GLOBAL IN THE INTEGRATOR PRELUDE # := ('REAL' T) 'MAT' : 'SKIP' ; INFO:= (0.01, 0, 0.0001, ('REAL' T)'REAL' : T END, ('INT' CASE)'BOOL' : 'TRUE', 0, 0, 0, ('INT' N, 'REAL' T, H, 'MAT' U)'VOID' : 'BEGIN' PRINT((NEWLINE, " INFO-MONITOR: N, T, H:", N, F(T), F(H), NEWLINE, " LOCAL ERROR = ", F(LOCAL ERROR 'OF' INFO))); MONITOR(T, 0, 0); 'IF' N = 1 'THEN' PDERROR(0, 'TRUE') 'FI' 'END'); PRINT((" INPUT : LOC ERR TOL = ", F(LOCERRTOL 'OF' INFO), " H START = ", F((NEXTH 'OF' INFO)(LASTT)), " H MIN = ", F(H MIN 'OF' INFO), NEWLINE)); IBVP SOLVER ( INTEGRATOR, G, UB, DG, U, 'LOC''REAL' := LASTT, ( TEND ), INFO ); # OUTPUT # PRINT((NEWLINE, NEWLINE, " RESULTS FROM I B V P S O L V E R :", NEWLINE, " INFO :", NEWLINE," NSTEPSPERF, ..REJ, NUMGP, LOCALERROR, LOCERRTOL, HMIN", NEWLINE, WHOLE(NSTEPSPERF 'OF' INFO, -5), WHOLE(NSTEPSREJ 'OF' INFO, -5), WHOLE(NUMGP 'OF' INFO, -5), F(LOCAL ERROR 'OF' INFO), F(LOCERRTOL 'OF' INFO), F(HMIN 'OF' INFO), NEWLINE, NEWLINE, " G EVALS. :", WHOLE(GEVAL, -4), NEWLINE, " U :", NEWLINE)); DISPLAY U (TEND, U) 'END' # OF PROGRAM # ################################################################################ # COST OF ADDING TAGS TO BINARY TREES FOR THUMB INDICES SIMPLE VERSION, WORST CASE AND BEST CASE ONLY. # 'BEGIN' 'INT' MAX = 1000 # SIZE OF LARGEST TREE EXAMINED #; 'INT' MU = 4 # DUPLICATION FACTOR #; [ 0 : MAX ] 'REAL' BTO # COST OF OLD TAGS #, BTN # ID. NEW TAGS # ; 'BEGIN' # INITIALIZE BTO AND BTN # 'REAL' INV SUM := 0; BTO[0]:= BTN[0]:= 0; 'FOR' I 'TO' MAX 'DO' INV SUM +:= 1/I; BTO[I]:= 2 * (I+1) / I * INV SUM - 3; BTN[I]:= 2 * INV SUM - 2 * I / (I+1) 'OD' 'END'; 'PROC' TREE = ('INT' SIZE, 'BOOL' CHEAP) 'REAL': 'BEGIN' 'INT' TAGS = SIZE * MU; 'INT' T:= TAGS, I:= 0; 'REAL' COMP:= 0; 'WHILE' T /= 0 'DO' 'IF' # TAGS LOST # I * MU < TAGS - T 'THEN' ERROR 'ELIF' ( # NO OLD LEFT # I * MU = TAGS - T ! 'TRUE' !: # NO NEW LEFT # I = SIZE ! 'FALSE' ! 'NOT' CHEAP ) 'THEN' # ENTER NEW # COMP +:= ( CHEAP ! BTN[I] ! I ); I +:= 1; T -:= 1 'ELSE' # ENTER OLD # COMP +:= ( CHEAP ! BTO[I] ! (I + 1) / 2); T -:= 1 'FI' 'OD'; COMP 'END' # TREE #; 'REAL' LOW:= 0, HIGH:= 0, 'INT' TOT := 0; ON LOGICAL FILE END(STAND IN, ('REF''FILE' F)'BOOL': LOW AND HIGH SET ); 'DO' 'INT' FR; READ(FR); LOW +:= TREE(FR, 'TRUE'); HIGH +:= TREE(FR, 'FALSE'); TOT +:= FR 'OD' 'EXIT' LOW AND HIGH SET: PRINT(( "COST OF CONSTRUCTING BINARY TREES FOR THUMB INDICES ON THE ", "FIRST TWO LETTERS,", NEWLINE, "OVER A SAMPLE CONTAINING ", FIXED(MU * TOT, 0, 0), " TAGS OF WHICH ", FIXED(TOT, 0, 0), " ARE DIFFERENT:", NEWLINE, NEWLINE)); PRINT(( " MIXED INPUT ORDERED INPUT", NEWLINE, " #COMP #COMP", NEWLINE, FIXED(LOW, -13, 2), FIXED(HIGH, -13, 2), NEWLINE)) 'END' ################################################################################ # COST OF ADDING TAGS TO ORDERED LINEAR LISTS FOR THUMB INDICES. SIMPLE VERSION, WORST CASE AND BEST CASE ONLY. # 'BEGIN' 'INT' MU = 4 # DUPLICATION FACTOR #; 'PROC' LIST = ('INT' SIZE, 'BOOL' CHEAP) 'REAL': 'BEGIN' 'INT' TAGS = MU * SIZE; 'INT' T:= TAGS, I:= 0; 'REAL' COMP:= 0; 'WHILE' T /= 0 'DO' 'IF' # TAGS LOST # I * MU < TAGS - T 'THEN' ERROR 'ELIF' ( # NO OLD LEFT # I * MU = TAGS - T ! 'TRUE' !: # NO NEW LEFT # I = SIZE ! 'FALSE' ! 'NOT' CHEAP ) 'THEN' # ENTER NEW # COMP +:= ( CHEAP ! I * (I + 3) / 2 / (I + 1) ! I ); I +:= 1; T -:= 1 'ELSE' # ENTER OLD # COMP +:= (I + 1) / 2; T -:= 1 'FI' 'OD'; COMP 'END' # LIST #; 'REAL' LOW := 0, HIGH := 0, 'INT' TOT := 0; ON LOGICAL FILE END(STAND IN, ('REF''FILE' F)'BOOL': LOW AND HIGH SET ); 'DO' 'INT' FR := 0; READ( FR); LOW +:= LIST(FR, 'TRUE'); HIGH +:= LIST(FR, 'FALSE'); TOT +:= FR 'OD' 'EXIT' LOW AND HIGH SET: PRINT(( "COST OF CONSTRUCTING ORDERED LISTS FOR THUMB INDICES ON THE ", "FIRST TWO LETTERS,", NEWLINE, "OVER A SAMPLE CONTAINING ", FIXED(MU * TOT, 0, 0), " TAGS OF WHICH ", FIXED(TOT, 0, 0), " ARE DIFFERENT:", NEWLINE, NEWLINE)); PRINT(( " MIXED INPUT ORDERED INPUT", NEWLINE, " #COMP #COMP", NEWLINE, FIXED(LOW, -13, 2), FIXED(HIGH, -13, 2), NEWLINE)) 'END' ################################################################################ # COST OF ADDING 'TAGS' TAGS TO AN OPEN EXTENDING HASH, IF THERE ARE 'MAX' DIFFERENT TAGS AMONG THEM. # 'BEGIN' 'INT' MAX = 1000, 'INT' MU = 4 # DUPLICATION FACTOR #; 'PROC' PRINT HASH = ('REAL' MAX F, 'INT' BEG) 'VOID': 'BEGIN' 'REAL' COMP:= 0, HASH:= 0, 'INT' TAB SIZE:= 2 ** BEG; 'FOR' I 'TO' MAX 'DO' 'IF' (I-1)/TAB SIZE > MAX F 'THEN' # REHASH # TAB SIZE *:= 2; 'FOR' J 'TO' I 'DO' (HASH +:= 1, COMP +:= ((1 / (1-(J-1)/TABSIZE)) ** 2 - 1) / 2) 'OD' 'FI'; (HASH +:= 1, COMP +:= ((1 / (1-(I-1)/TABSIZE)) ** 2 - 1) / 2) 'OD'; (HASH +:= 1 * (MU - 1) * MAX, COMP +:= (1 + (1 / (1-MAX/TABSIZE))) / 2 * (MU-1) * MAX); PRINT((FIXED(COMP,-13, 2), WHOLE(HASH, -13), WHOLE(TAB SIZE,-13), NEWLINE)) 'END' # PRINT HASH #; PRINT(( "COST OF CONSTRUCTING AN OPEN EXTENDING HASH TABLE CONTAINING ", FIXED(MAX*MU, 0, 0), " TAGS OF WHICH ", FIXED(MAX, 0, 0), " ARE DIFFERENT:", NEWLINE, NEWLINE)); [] 'REAL' MAX F = (1/2, 2/3, 3/4); [] 'INT' BEG = (9, 8, 7); PRINT(( " MAX INITIAL NUMBER NUMBER MAXIMUM", NEWLINE, "FILLING TABSIZE OF COMP OF HASH TAB SIZE", NEWLINE)); 'FOR' MF 'TO' 'UPB' MAX F 'DO' PRINT(NEWLINE); 'FOR' BG 'TO' 'UPB' BEG 'DO' PRINT((FIXED(MAX F[MF], -6, 2), WHOLE(2 ** BEG[BG], -9))); PRINT HASH(MAX F[MF], BEG[BG]) 'OD''OD' 'END' ################################################################################ 'PROC' BINOMIAL DISTRIBUTION = ('INT' N, 'REAL' P) []'REAL': 'IF' P > .4 'THEN' [ 0 : N ] 'REAL' PROB, 'INT' TOP = 'ENTIER'((N + 1) * P - 1); PROB[TOP]:= ('REAL' PROB := 1, 'INT' COEFF:= N; 'FOR' I 'TO' TOP 'DO' PROB *:= COEFF / I * P; COEFF -:= 1 'OD'; 'FOR' I 'FROM' TOP + 1 'TO' N 'DO' PROB *:= 1 - P 'OD'; PROB ); 'REAL' SLOPE = (1-P) / P; ( 'FOR' I 'FROM' TOP - 1 'BY' -1 'TO' 0 'DO' PROB[I]:= PROB[I+1] * (I+1) / (N-I) * SLOPE 'OD', 'FOR' I 'FROM' TOP + 1 'TO' N 'DO' PROB[I]:= PROB[I-1] / I * (N-I+1) / SLOPE 'OD' ); PROB 'ELSE' [ 0 :N ] 'REAL' PROB := BINOMIAL DISTRIBUTION (N, 1 - P), 'INT' L := 0, R := N; 'WHILE' L < R 'DO' 'REF' 'REAL' PROB L = PROB[L], PROB R = PROB[R]; (('REAL' P = PROB L; PROB L:= PROB R; PROB R:= P), L +:= 1, R -:= 1) 'OD'; PROB 'FI' # BINOMIAL DISTRIBUTION # ; ################################################################################ 'BEGIN' # PARITY FUNCTION, I.E., A TAYLOR SERIES THE COEFFICIENTS OF WHICH ARE 1, -1, -1, 1, -1, 1, 1, -1, ..... # 'INT' GRID = 100; [-GRID : GRID] 'REAL' F; 'FOR' I 'FROM' 0 'TO' GRID 'DO' 'REAL' X = I/GRID; 'REAL' XN:= X, FN:= 1; 'WHILE' XN > SMALL REAL 'AND' FN > SMALL REAL 'DO' FN *:= (1 - XN); XN *:= XN 'OD'; 'IF' FN <= SMALL REAL 'THEN' F[-I]:= F[I]:= 0 'ELSE' F[-I]:= (1+X)/(1-X) * (F[I]:= FN) 'FI' 'OD'; 'FOR' I 'FROM' -GRID 'TO' GRID 'DO' PRINT((NEWLINE, WHOLE(I,-4), FIXED(F[I],-8,4), 'ENTIER' (F[I]*50) * " ", "*" )) 'OD' 'END' ################################################################################ 'FOR' N 'WHILE' CLOCK < 20 'DO' 'INT' TOT := 0; 'FOR' I 'TO' N 'DO' TOT +:= I*I*I 'OD'; 'IF' 'NOT' 'ODD' TOT 'THEN' TOT 'OVERAB' 2; 'PROC' ADD = ('INT' BL, LEFT) 'VOID': 'IF' LEFT = 0 'THEN' PRINT((N, BLS, N-BLS, " ", SOL, NEWLINE)) 'ELIF' BL < 1 'OR' LEFT < 0 'THEN' 'SKIP' 'ELSE' ADD(BL-1, LEFT); SOL[BL]:= 'TRUE'; BLS +:= 1; ADD(BL-1, LEFT - BL*BL*BL); SOL[BL]:= 'FALSE'; BLS -:= 1 'FI'; [1:N] 'BOOL' SOL; 'FOR' I 'TO' N 'DO' SOL[I]:= 'FALSE' 'OD'; SOL[N]:= 'TRUE'; 'INT' BLS := 1; ADD(N - 1, TOT - N*N*N) 'FI' 'OD' ################################################################################ 'BEGIN' 'PROC' CONV = ('INT' VAL, WIDTH, BASE) 'STRING': ( 'STRING' S := " "; 'INT' N := VAL; 'TO' WIDTH 'DO' 'INT' M = N 'OVER' BASE; "0123456789"[ N - M * BASE + 1] +=: S; N := M 'OD'; S ); PRINT(" "); 'FOR' I 'FROM' 0 'BY' 200 'TO' 1800 'DO' PRINT((" ", CONV(I, 4, 10))) 'OD'; PRINT(NEWLINE); 'FOR' I 'FROM' 0 'BY' 2000 'TO' 100000 'DO' PRINT((NEWLINE, CONV(I, 6, 10))); 'FOR' J 'FROM' 0 'BY' 200 'TO' 1800 'DO' PRINT(CONV(I + J, 6, 8)) 'OD' 'OD' 'END' ################################################################################ 'BEGIN' []'CHAR' RC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ*"; [0:MAX ABS CHAR] 'INT' RI; 'FOR' K 'FROM' 0 'TO' MAX ABS CHAR 'DO' RI[K]:= 27 'OD'; 'FOR' K 'TO' 26 'DO' RI['ABS' RC[K]]:= K 'OD'; [1:27, 1:27] 'INT' AB; 'FOR' I 'TO' 27 'DO' 'FOR' J 'TO' 27 'DO' AB[I, J]:= 0 'OD' 'OD'; 'INT' A:= 27, B; 'CHAR' C; 'WHILE' READ(C); B:= RI['ABS' C]; AB[A, B] +:= 1; C/= "@" 'DO' PRINT(C); A:= B 'OD'; 'FOR' I 'TO' 27 'DO' 'FOR' J 'TO' 27 'DO' 'IF' AB[I, J] > 0 'THEN' PRINT((NEWLINE, RC[I], RC[J], AB[I, J])) 'FI' 'OD' 'OD' 'END' ################################################################################ ( 'INT' MAX # LINE LENGTH # =136; 'FILE' IN, OUT; 'INT' LEFT, RIGHT; 'STRING' F1, F2; MAKE TERM(STAND IN, " "); READ((F1, 'LOC''CHAR', F2, 'LOC''CHAR', LEFT, RIGHT)); ESTABLISH(IN, F1, Z TYPE CHANNEL, 1, 10000, MAX); ESTABLISH(OUT, F2, Z TYPE CHANNEL, 1, 10000, MAX); [1 : MAX] 'CHAR' LINE; 'DO' GET (IN, LINE); PUT (OUT, (LINE[1: LEFT-1], LINE[RIGHT+1 : MAX], NEWLINE)); GET (IN, NEWLINE) 'OD' ) ################################################################################ LSQPRL : # JK 780227 # 'BEGIN' # JKOK, 730620, PRELUDE LEAST SQUARES PROCEDURES. UPDATE : 780227 # 'MODE' 'LSQEPS' = 'STRUCT'('REAL' PREC, MAX, 'INT' RNK); 'PROC' LSQDEC = ('MAT' A, 'VEC' AID, 'REF'[]'INT' CI, 'REF''LSQEPS' AUX)'INT' : 'PR' XREF LSQDEC 'PR' 'SKIP', 'PROC' LSQSOL = ('MAT' A, 'VEC' AID, 'REF'[]'INT' CI, 'VEC' B)'VEC': 'PR' XREF LSQSOL 'PR' 'SKIP', 'PROC' MININVERSE = ('MAT' A, 'INT' L)'MAT' : 'PR' XREF MININVE 'PR' 'SKIP'; 'PR' PROG 'PR' 'SKIP' 'END' # OF INVERSE PART OF LIBRARY # ################################################################################ LSQDEC : # JK 780217 # 'BEGIN' # JKOK, 730620, TEST LEAST SQUARES PROCEDURES, 741121, TORRIX VERSION. UPDATE : 780227 # 'PROC' LSQDEC = ('MAT' A, 'VEC' AID, 'REF'[]'INT' CI, 'REF''LSQEPS' AUX)'INT' : 'PR' XDEF LSQDEC 'PR' 'IF''INT' N = 1 'UPB' A, M = 2 'UPB' A; 'UPB' AID /= M 'OR' 'UPB' CI /= M 'THEN' - 1 'ELSE''INT' R:= 0, MINMN:= (M < N ! M ! N), PK:= 1, 'REAL' W, EPS, SIGMA:= 0, AIDK, BETA, 'VEC' SUM = 'HEAP'[1 : M]'REAL'; 'FOR' K 'TO' M 'DO''IF' (W:= SUM[K]:= 'SQR' A[ ,K]) > SIGMA 'THEN' SIGMA:= W; PK:= K 'FI' 'OD'; W:= MAX 'OF' AUX:= SQRT(SIGMA); EPS:= (PREC 'OF' AUX) * W; 'FOR' K 'TO' MINMN 'WHILE' W > EPS 'DO' 'VEC' AK = A[K : , K], 'REAL' AKK = A[K,PK]; R:= K; CI[K]:= PK; 'IF' PK /= K 'THEN' []'REAL' H= A[ ,K]; A[ ,K]:= A[ ,PK]; A[ ,PK]:= H; SUM[PK]:= SUM[K] 'FI'; AIDK:= AID[K]:= (AKK < 0 ! W ! - W); AK[1]:= AKK - AIDK; BETA:= - 1 / (SIGMA - AKK * AIDK); PK:= K; SIGMA:= 0; 'FOR' J 'FROM' K + 1 'TO' M 'DO' A[K : ,J] +:= BETA * (AK * A[K : ,J]) * AK; 'IF' (W:= SUM[J] -:= 'SQR' A[K,J]) > SIGMA 'THEN' PK:= J; SIGMA:= W 'FI' 'OD'; W:= SQRT(SIGMA) 'OD'; R 'FI' # END OF HOUSEHOLDER TRIANGULARIZATION # 'PR' FEDX 'PR' , 'PROC' LSQSOL = ('MAT' A, 'VEC' AID, 'REF'[]'INT' CI, 'VEC' B)'VEC': 'PR' XDEF LSQSOL 'PR' 'BEGIN' 'INT' N = 1 'UPB' A, M = 2 'UPB' A, 'INT' CIK; 'VEC' BB = 'HEAP'[1 : N]'REAL' := B; 'IF' M <= N 'THEN''FOR' K 'TO' M 'DO' BB[K: ] +:= A[K: ,K] * BB[K: ] / (AID[K] * A[K,K]) * A[K: ,K] 'OD'; 'FOR' K 'FROM' M 'BY' - 1 'TO' 1 'DO' BB[K] := (BB[K] - A[K,K+1: ] * BB[K+1:M]) / AID[K] 'OD'; 'FOR' K 'FROM' M - 1 'BY' - 1 'TO' 1 'DO''IF' CIK:= CI[K]; CIK /= K 'THEN''REAL' W= BB[K]; BB[K]:= BB[CIK]; BB[CIK]:= W 'FI' 'OD' 'FI'; BB 'END' # OF COMPUTATION OF LEAST SQUARES SOLUTION # 'PR' FEDX 'PR'; 'SKIP' 'END' # OF LIBRARY PART LSQ DEC # ################################################################################ MINIINV : # JK 780217 # 'BEGIN''CO' OPTIMAL INVERSE OF NON-SQUARE MATRIX ROUTINE USING LEAST SQUARES SOLUTION ROUTINES. UPDATE : 780227 'CO' 'PROC' MININVERSE = ('MAT' A, 'INT' L)'MAT' : 'PR' XDEF MININVE 'PR' 'BEGIN''INT' M = 1 'UPB' A, N = 2 'UPB' A; 'IF' L > M 'OR' N < M 'THEN' PRINT((NEWLINE, " BOUNDS OF MATRIX ARE ", WHOLE(M, -3), " ,", WHOLE(N, -3), " , L = ", WHOLE(L, -3), NEWLINE)); PDERROR(150, 'TRUE') 'FI'; # COMPUTE W WITH L ROWS : W * A = ( I (L * L) ! MINIMAL (L * (N - L)) MATRIX ) # 'MAT' U = 'HEAP'[1 : M, 1 : M]'REAL', 'VEC' DIAG = 'HEAP'[1 : M]'REAL', 'LSQEPS' AUX:= (1.0E-14, 0, 0), [1 : M]'INT' PIV; U[ , 1 : L]:= A[, 1 : L]; 'MAT' A2 = A[ , L + 1 : N]; 'IF' LSQDEC(U[ , : L], DIAG[:L], PIV[:L], AUX) /= L 'THEN' PDERROR(151, 'TRUE') 'FI'; # FORM R(INV) IN UPPER TRIANGLE, MIND DIAG # 'FOR' I 'FROM' L - 1 'BY' -1 'TO' 1 'DO''REAL' XII = 1 / DIAG[I], 'VEC' AI = U[I, I + 1 : L]; 'FOR' J 'FROM' L - I 'BY' -1 'TO' 1 'DO' AI[J]:= - (AI[ : J - 1] * U[I + 1 : J + I - 1, J + I] + AI[J] * DIAG[J + I] ) * XII 'OD' 'OD'; # COMPUTE R(INV)(M * M) * Q(TRANSP) = R(INV) * Q(L) * Q(L-1) * ... * Q(2) * Q(1) # 'VEC' V = 'HEAP'[1 : M]'REAL'; 'VEC' VL = V[L : M]; VL:= U[L : M, L]; 'REAL' S:= 1 / (DIAG[L] * VL[1]); 'FOR' I 'TO' L 'DO' 'REAL' AIL = ( I = L ! 1 / DIAG[L] ! U[I, L] ); U[I, L : M]:= ( VL[1] * AIL * S ) * VL; U[I, L]+:= AIL 'OD'; 'FOR' I 'FROM' L + 1 'TO' M 'DO' U[I, L : M]:= S * V[I] * VL 'OD'; 'FOR' K 'FROM' L - 1 'BY' -1 'TO' 1 'DO' 'VEC' VK = V[K : M]; VK:= U[K : M, K]; U[K, K]:= 1 / DIAG[K]; 'FOR' I 'FROM' K + 1 'TO' M 'DO' U[I, K]:= 0 'OD'; S:= 1 / (DIAG[K] * VK[1]); 'FOR' I 'TO' M 'DO''VEC' UI = U[I, K : M]; UI +:= VK * UI * S * VK 'OD' 'OD'; # BACK CHANGES (USING PIV) OF FIRST L ROWS # 'FOR' K 'FROM' L - 1 'BY' -1 'TO' 1 'DO''IF' 'INT' CIK = PIV[K]; CIK /= K 'THEN' 'VEC' H = 'HEAP'[1 : M]'REAL' := U[K, ]; U[K, ]:= U[CIK, ]; U[CIK, ]:= H 'FI' 'OD'; 'MAT' A1INV = U[ : L, ], A1ORTHTRP = U[L + 1 : M, ], H1 = 'HEAP'[1 : N - L, 1 : M]'REAL'; 'MAT' H2 = H1[ , M - L + 1 : M]; 'FOR' I 'TO' N - L 'DO''FOR' J 'TO' M 'DO' H1[I, J]:= A2[, I] * U[J, ] 'OD''OD'; # H2 ALSO FORMED INSIDE H1 # 'IF' LSQDEC(H1[, : M - L], DIAG[:M-L], PIV[:M-L], AUX) /= M - L 'THEN' PDERROR(152, 'TRUE') 'FI'; 'FOR' J 'TO' L 'DO' LSQSOL(H1[, : M - L], DIAG[:M-L], PIV[:M-L], H2[, J]) 'OD'; 'MAT' X = H2[ : M - L, ], W = A1INV; 'FOR' I 'TO' L 'DO' 'FOR' J 'TO' M 'DO' W[I, J] -:= X[, I] * A1ORTHTRP[, J] 'OD' 'OD'; W 'END' # MIN INVERSE # 'PR' FEDX 'PR'; 'SKIP' 'END' # OF INVERSE PART OF LIBRARY # ################################################################################ TESTLSQ : # JK 780217 # 'BEGIN' # TEST # 'FOR' N 'FROM' 4 'TO' 6 'DO' 'FOR' M 'TO' N 'DO' [1:N,1:M]'REAL' A, [1:N]'REAL' B, [1:M]'REAL' AID, [1:M] 'INT' PIV, 'LSQEPS' AUX; 'FOR' I 'TO' N 'DO' 'FOR' J 'TO' M 'DO' A[I,J]:= I**(J-1)'OD''OD'; 'FOR' I 'TO' N 'DO' B[I]:= I**(N-1)'OD'; PREC 'OF' AUX:= 1E-10; PRINT( ( NEWLINE, "N =", N, " M =", M, NEWLINE) ); 'IF' LSQDEC(A, AID, PIV, AUX) < M 'THEN' PRINT(" RANK < NUMBER OF COLUMNS") 'ELSE' 'VEC' SOL:= LSQSOL(A, AID, PIV, B); PRINT(" SOLUTION :"); 'FOR' K 'TO' M 'DO' PRINT(SOL[K]) 'OD'; PRINT( ( " RESIDUAL : ", 'SQR' SOL[M + 1 : ], NEWLINE ) ) 'FI' # OUTPUT APPROXIMATELY: SOL: 25.0 RES: 2390.0 SOL: -27.0 20.8 RES: 226.8 SOL: 10.5 -16.7 7.5 RES: 1.8 SOL: 0.0 0.0 0.0 1.0 RES: 0.0 SOL: 195.8 RES: 271290.8 SOL: -250.6 148.8 RES: 49876.4 SOL: 158.4 -201.77 58.43 RES: 2081.83 SOL: -43.2 81.43 -49.57 12.0 RES: 8.23 SOL: 0.0 0.0 0.0 0.0 1.0 RES: 0.0 SOL: 2033.5 RES: 46529717.5 SOL: -2860.0 1398.14 RES: 12320657.14 SOL: 2250.0 -2434.36 547.5 RES: 1129757.14 SOL: -1040.0 1704.25 -823.3 130.56 RES: 25257.14 SOL: 220.0 -465.75 344.17 -114.44 17.50 RES: 57.14 SOL: 0.0 0.0 0.0 0.0 0.0 1.0 RES: 0.0 # 'OD' 'OD' 'END' ################################################################################ TESTINV : # JK 780228 # 'BEGIN' # TEST # 'FOR' M 'TO' 6 'DO' 'FOR' N 'FROM' M 'TO' M + 4 'DO' 'MAT' A = 'HEAP'[1 : M, 1 : N]'REAL'; 'FOR' I 'TO' M 'DO' 'FOR' J 'TO' N 'DO' A[I,J]:= I**(J-1)'OD''OD'; PRINT( ( NEWLINE, "M =", M, " N =", N, NEWLINE) ); 'FOR' L 'TO' M 'DO' PRINT((" SOLUTION : FOR L = ", WHOLE(L , -5), NEWLINE)); 'MAT' W = MININVERSE(A, L); PRINT(NEWLINE); 'FOR' S 'TO' L 'DO' PRINT((WHOLE(S, -4), " ")); 'FOR' T 'TO' M 'DO' PRINT((FLOAT(W[S, T], 14, 6, 2), " ")) 'OD'; PRINT(NEWLINE) 'OD'; PRINT((NEWLINE, " CHECK : PRINT W * A", NEWLINE)); 'FOR' S 'TO' L 'DO' PRINT((WHOLE(S, -4), " ")); 'VEC' WS = W[S, ]; 'FOR' T 'TO' N 'DO' PRINT((FLOAT(WS * A[, T], 14, 6, 2), " ")) 'OD'; PRINT(NEWLINE) 'OD' 'OD' 'OD' 'OD' 'END' ################################################################################ 'BEGIN' # TEST PROVED VERSION OF "FIXED" # 'PROC' FIXED1 = ('NUMBER' V, 'INT' WIDTH, AFTER) 'STRING': 'IF' AFTER < 0 'THEN' 'ABS' WIDTH * ERROR CHAR 'ELSE' 'INT' POINT, 'BOOL' NEG; 'STRING' S:= SUBFIXED(V, AFTER, POINT, NEG, 'FALSE'); 'STRING' SIGN = (NEG ! "-" !: WIDTH > 0 ! "+" ! "" ); 'INT' W = 'ABS' WIDTH - 'UPB' SIGN; 'INT' TAIL = ('INT' LIM = W - POINT - 1 + (W=POINT & POINT>0 ! 1 ! 0); (LIM < AFTER ! LIM ! AFTER) ); 'IF' TAIL < 0 'THEN' 'ABS' WIDTH * ERROR CHAR 'ELSE' S:= S[ : POINT + TAIL + 1]; ( ROUND('UPB'S-1, S) ! POINT +:= 1 ); ( 'UPB' S = 0 ! S:= "0"; POINT:= 1); 'INT' SPACE = W - 'UPB' S - (POINT = 'UPB' S ! 0 ! 1); 'IF' SPACE < 0 & TAIL = 0 'THEN' 'ABS' WIDTH * ERROR CHAR 'ELSE' 'IF' SPACE < 0 'THEN' S:= S[ : 'UPB'S - 1] 'ELIF' SPACE >= 1 & POINT = 0 'THEN' "0" 'PLUSTO' S; POINT +:= 1 'FI'; S:= SIGN + (POINT = 'UPB'S ! S ! S[:POINT] + "." + S[POINT+1:]); ('ABS' WIDTH - 'UPB' S) * " " + S 'FI' 'FI' 'FI'; 'MODE' 'NUMBER' = 'STRUCT'('STRING' VALUE, 'BOOL' NEG, 'INT' POINT); 'OP' - = ('NUMBER' X) 'NUMBER': (VALUE 'OF' X, 'NOT' NEG 'OF' X, POINT 'OF' X); 'PROC' SUBFIXED = ('NUMBER' V, 'INT' AFTER, 'REF''INT' POINT, 'REF''BOOL' NEG, 'BOOL' TYPE) 'STRING': ( POINT:= POINT 'OF' V; NEG:= NEG 'OF' V; (VALUE 'OF' V + (AFTER + 1) * "0")[ : POINT + AFTER + 1] ); 'PROC' ROUND = ('INT' K, 'REF''STRING' S) 'BOOL': 'IF' 'BOOL' CARRY:= CHAR DIG(S[K+1]) >= 5; S:= S[:K]; CARRY 'THEN' 'FOR' J 'FROM' K 'BY' -1 'TO' 1 'WHILE' CARRY 'DO' 'INT' D = CHAR DIG(S[J]) + 1; CARRY:= D = 10; S[J]:= (CARRY ! "0" ! "0123456789"[D+1]) 'OD'; (CARRY ! "1" 'PLUSTO' S); CARRY 'ELSE' 'FALSE' 'FI'; 'PROC' CHAR DIG = ('CHAR' C) 'INT' : 'ABS' C - 'ABS' "0"; 'PROC' T = ('NUMBER' V, 'INT' WIDTH, AFTER) 'VOID': ( PRINT((WHOLE(WIDTH, -4), WHOLE(AFTER, -4), " !", VALUE 'OF' V, WHOLE(POINT 'OF' V, -4), "!", " /", FIXED1(V,WIDTH,AFTER), "/", " /", FIXED1(-V,WIDTH,AFTER), "/", NEWLINE)) ); [] 'NUMBER' VALS = ( ("", 'TRUE', 0), ("01", 'TRUE', 0), ("0449", 'TRUE', 0), ("4449", 'TRUE', 0), ("9945", 'TRUE', 0), ("9945", 'TRUE', 1), ("9945", 'TRUE', 2), ("100", 'TRUE', 3) ); 'FOR' VALUE 'TO' 'UPB' VALS 'DO' 'FOR' WIDTH 'FROM' 1 'TO' 9 'DO' 'FOR' AFTER 'FROM' -1 'TO' 4 'DO' T(VALS[VALUE],-WIDTH,AFTER)'OD''OD''OD' 'END' ################################################################################ 'BEGIN' 60 'PROC' BACKWARD DIFFERENTIATION SCHEME FOR SECOND KIND VOLTERRA 70 INTEGRAL EQUATION = 80 ('INT' ORDER, 'REF''REAL' X, 'REAL' XE, 'REAL' H, 90 'PROC'('REAL','REAL','REAL')'REAL' KER, 'PROC'('REAL')'REAL' G, 100 'PROC'('REAL','REAL','REAL')'REAL' DKERDF, 110 'REF'[]'REAL' F, 'REF''INT' NMB NEWTON IT)'VOID': 120 'BEGIN' 130 'INT' ORDERP1 = ORDER+1, ORDERM1 = ORDER-1; 'INT' N, N1, INIT; 140 'REAL' B0, XTN1, FF, JAC, KK, SH, SS; 150 [1:ORDER]'REAL' A, DELTW, 160 [1:ORDERP1]'REAL' S, [1:ORDER,1:ORDER]'REAL' B, 170 [0:'UPB' F]'REAL' XT, W; 180 190 'PROC' SCHEME = 'VOID': 200 'BEGIN' 210 N1:=N+1; X:=XTN1:=XT[N1]; 220 # FILL S[1:ORDER] # 230 'FOR' I 'TO' ORDER 'DO' S[I]:=B[I,1]; 240 'FOR' J 'TO' ORDERM1 'DO' 250 S[I]+:=DELTW[J]*B[I,J+1] 260 'OD''OD'; 270 280 # SHIFTS IN B # 290 'FOR' I 'TO' ORDERM1 'DO' 300 'FOR' J 'FROM' 2 'TO' ORDERM1 'DO' B[I,J]:=B[I+1,J+1] 310 'OD''OD'; 320 330 # UPDATE THE WEIGHTS W # 340 'FOR' I 'TO' ORDER 'DO' W[N1-ORDER+I]+:=DELTW[I] 'OD'; 350 360 # FILL S[ORDER+1] AND AT THE SAME TIME B[ORDER,2:ORDER-1] # 370 S[ORDERP1]:=G(XTN1); 380 'FOR' J 'FROM' 0 'TO' N+2-ORDER 'DO' 390 S[ORDERP1]+:=W[J]*KER(XTN1,XT[J],F[J]) 'OD'; 400 'FOR' J 'FROM' N+3-ORDER 'TO' N 'DO' 410 S[ORDERP1]+:=W[J]* 420 (KK:=KER(XTN1,XT[J],F[J]); B[ORDER,ORDER+J-N1]:=KK; KK)'OD'; 430 440 # COMPUTE F[N+1] WITH MODIFIED NEWTON RAPHSON # 450 MODIFIED NEWTON RAPHSON; 460 470 'IF' 'ABS'(FF) > 1000 'THEN' STOP BDSCHEME 480 'FI'; 490 500 # FILL THE FIRST AND LAST COLUMN OF B # 510 'FOR' I 'TO' ORDER 'DO' 520 B[I,ORDER]:=KER(XT[N1+I-ORDER],XTN1,FF); 530 B[I,1]:=S[I+1]+W[N1]*B[I,ORDER] 540 'OD' 550 'END' # SCHEME # ; 560 570 'PROC' STARTPVDH = 'VOID': 580 'BEGIN' 590 'REAL' C1, C2, FI, XI, CORR, X0, H2, FOLD, DIFF; 600 'INT' NIT; 610 [0:ORDERM1] 'REAL' FH, [0:2*ORDERM1] 'REAL' FH2; 620 630 'PROC' GAUSSNEWTON = 'VOID': 640 FI-:=(CORR:=(FI-C1-C2*KER(XI,XI,FI))/ 650 (1.0-C2*DKERDF(XI,XI,FI)); 0.578*CORR) 660 # GAUSSNEWTON # ; 670 680 'PROC' NEWTON = 'VOID': 690 (INIT:=0; CORR:=1.0; 700 'WHILE' 'ABS'(CORR) > 1.E-13 'DO' 710 FI-:=(CORR:=(FI-C1-C2*KER(XI,XI,FI))/ 720 (1.0-C2*DKERDF(XI,XI,FI)); CORR); 730 INIT+:=1; 740 'IF' INIT=13 'THEN' 750 PRINTF(($ L " # NEWTONITERATIONS IN START", 760 "PROCEDURE > 12", L "XI= ",2Z-D.8D, 770 L "FI =",2Z-D.8D$,XI,FI)); STOP BDSCHEME 'FI' 780 'OD') # NEWTON # ; 790 800 H2:=H/2.0; 810 X0:=XT[0]; F[0]:=FH[0]:=FH2[0]:=G(X0); 820 830 'FOR' N 'TO' ORDERM1 'DO' 840 FI:=FH[N-1]; XI:=XT[N]; 850 C1:=G(XI)+H2*KER(XI,0.0,F[0]); 860 'FOR' J 'TO' N-1 'DO' C1+:=H*KER(XI,XT[J],FH[J]) 'OD'; 870 C2:=H2; NEWTON; FH[N]:=FI 880 'OD' # N # ; 890 'FOR' N 'TO' 2*ORDERM1 'DO' 900 FI:=FH2[N-1]; XI:=X0+N*H2; 910 C1:=G(XI)+H2/2.0*KER(XI,0.0,F[0]); 920 'FOR' J 'TO' N-1 'DO' C1+:=H2*KER(XI,X0+J*H2,FH2[J]) 'OD'; 930 C2:=H2/2.0; NEWTON; FH2[N]:=FI 940 'OD' # N WITH H/2 # ; 950 960 # EXTRAPOLATION TO O(H**5) # 970 'FOR' N 'TO' ORDERM1 'DO' 980 F[N]:=(4.0*FH2[2*N]-FH[N])/3.0 'OD'; 990 1000 # IMPROVEMENT TO O(H**6) # 1010 'IF' ORDER=6 'THEN' 1020 PRINT((NEWLINE,F[1],F[2],F[3],F[4],F[5])); 1030 FOLD:=F[5]; DIFF:=1.0; NIT:=0; 1040 'WHILE' DIFF > 1.0E-13 'DO' 1050 NIT+:=1; 1060 FI:=F[1]; XI:=XT[1]; 1070 C1:=G(XI)+H/1440.0*(475.0*KER(XI,XT[0],F[0]) 1080 -798.0*KER(XI,XT[2],F[2])+482.0*KER(XI,XT[3],F[3]) 1090 -173.0*KER(XI,XT[4],F[4])+27.0*KER(XI,XT[5],F[5])); 1100 C2:=1427.0*H/1440.0; GAUSSNEWTON; F[1]:=FI; 1110 FI:=F[2]; XI:=XT[2]; 1120 C1:=G(XI)+H/1440.0*(448.0*KER(XI,XT[0],F[0]) 1130 +2064.0*KER(XI,XT[1],F[1])+224.0*KER(XI,XT[3],F[3]) 1140 -96.0*KER(XI,XT[4],F[4])+16.0*KER(XI,XT[5],F[5])); 1150 C2:=224.0*H/1440.0; GAUSSNEWTON; F[2]:=FI; 1160 FI:=F[3]; XI:=XT[3]; 1170 C1:=G(XI)+H/1440.0*(459.0*KER(XI,XT[0],F[0]) 1180 +1971.0*KER(XI,XT[1],F[1])+1026.0*KER(XI,XT[2],F[2]) 1190 -189.0*KER(XI,XT[4],F[4])+27.0*KER(XI,XT[5],F[5])); 1200 C2:=1026.0*H/1440.0; GAUSSNEWTON; F[3]:=FI; 1210 FI:=F[4]; XI:=XT[4]; 1220 C1:=G(XI)+H/1440.0*(448.0*KER(XI,XT[0],F[0]) 1230 +2048.0*KER(XI,XT[1],F[1])+768.0*KER(XI,XT[2],F[2]) 1240 +2048.0*KER(XI,XT[3],F[3])); 1250 C2:=448.0*H/1440.0; GAUSSNEWTON; F[4]:=FI; 1260 FI:=F[5]; XI:=XT[5]; 1270 C1:=G(XI)+H/1440.0*(475.0*KER(XI,XT[0],F[0]) 1280 +1875.0*KER(XI,XT[1],F[1])+1250.0*KER(XI,XT[2],F[2]) 1290 +1250.0*KER(XI,XT[3],F[3])+1875.0*KER(XI,XT[4],F[4])); 1300 C2:=475.0*H/1440.0; GAUSSNEWTON; F[5]:=FI; 1310 DIFF:='ABS'(FI-FOLD); FOLD:=FI 1320 'OD' 'FI' 1330 ;PRINT((NEWLINE,NIT,F[1],F[2],F[3],F[4],F[5])) 1340 'END' # STARTPVDH #; 1350 1360 'PROC' MODIFIED NEWTON RAPHSON = 'VOID': 1370 'BEGIN' 1380 'REAL' WLAST = W[N1]; 1390 # PREPARATION # 1400 SH:=S[ORDERP1]; 1410 'FOR' I 'TO' ORDER 'DO' 1420 SH+:=A[I]*(F[N1-I]-S[ORDERP1-I]) 'OD'; 1430 FF:=F[N]; 1440 JAC:=1-(WLAST+B0*H)*DKERDF(XTN1,XTN1,FF); 1450 'FOR' I 'TO' ORDER 'DO' 1460 JAC+:=A[I]*WLAST*DKERDF(XT[N1-I],XTN1,FF) 'OD'; 1470 'IF' JAC=0.0 'THEN' PRINTF(($ 4L " JAC=0.0, XT[N]=", 1480 2Z-D.6D$,XT[N])); ERROR 1490 'FI'; 1500 1510 # ITERATION # 1520 SS:=1.0E10; INIT:=0; 1530 'WHILE' 'ABS'(SS/('ABS'(FF)+1)) > 1.0E-13 'DO' 1540 INIT+:=1; 1550 'IF' INIT > 12 'THEN' 1560 PRINTF(($ 4L " NMB OF NEWTONITERATIONS>12", L " XT[N1]=", 1570 2Z-D.6D$,X+H)); STOP BDSCHEME 'FI'; 1580 SS:=FF-SH; 1590 'FOR' I 'TO' ORDER 'DO' 1600 SS+:=A[I]*WLAST*KER(XT[N1-I],XTN1,FF) 'OD'; 1610 SS-:=(WLAST+B0*H)*KER(XTN1,XTN1,FF); 1620 SS/:=JAC; FF-:=SS 1630 'OD' # END WHILE #; 1640 1650 F[N1]:=FF; NMB NEWTON IT+:=INIT 1660 'END' # MODIFIED NEWTON RAPHSON #; 1670 1680 # INITIALIZE # 1690 'FOR' I 'FROM' 0 'TO' 'UPB' F 'DO' XT[I]:=X+I*H 'OD'; 1700 A:='CASE' ORDERM1 1710 'IN' (4/3,-1/3), 1720 (18/11,-9/11,2/11), 1730 (48/25,-36/25,16/25,-3/25), 1740 (300/137,-300/137,200/137,-75/137,12/137), 1750 (360/147,-450/147,400/147,-225/147,72/147,-10/147) 1760 'ESAC'; 1770 B0:='CASE' ORDERM1 'IN' 2/3,6/11,12/25,60/137,60/147 'ESAC'; 1780 [1:ORDER]'REAL' WW; 1790 WW:='CASE' ORDERM1 1800 'IN' (H/2,H/2), 1810 (H/3,4*H/3,H/3), 1820 (3*H/8,9*H/8,9*H/8,3*H/8), 1830 (14*H/45,64*H/45,24*H/45,64*H/45,14*H/45), 1840 (95*H/288,375*H/288,250*H/288, 1850 250*H/288,375*H/288,95*H/288) 1860 'ESAC'; 1870 'FOR' I 'TO' ORDER 'DO' W[I-1]:=WW[I] 'OD'; 1880 'FOR' I 'FROM' ORDER 'TO' 'UPB' F 'DO' W[I]:=0.0 'OD'; 1890 DELTW:='CASE' ORDERM1 1900 'IN' (H/2,H/2), 1910 (-H/12,8*H/12,5*H/12), 1920 (H/24,-5*H/24,19*H/24,9*H/24), 1930 (-19*H/720,106*H/720,-264*H/720, 1940 646*H/720,251*H/720), 1950 (27*H/1440,-173*H/1440,482*H/1440, 1960 -798*H/1440,1427*H/1440,475*H/1440) 1970 'ESAC'; 1980 1990 # ASSIGN STARTING VALUES F[0:ORDER-1] # 2000 STARTPVDH; 2010 2020 # FILL B[1:ORDER,1:ORDER] # 2030 'FOR' I 'TO' ORDER 'DO' 2040 B[I,1]:=G(XT[I-1])+W[0]*KER(XT[I-1],XT[0],F[0]); 2050 'FOR' J 'TO' ORDERM1 'DO' 2060 B[I,1]+:=(KK:=KER(XT[I-1],XT[J],F[J]); 2070 B[I,J+1]:=KK; KK)*W[J] 2080 'OD''OD'; 2090 2100 # PERFORM THE INTEGRATION STEPS # 2110 N:=ORDER-2; 2120 'WHILE' N < 'UPB' F -1 'DO' N+:=1; SCHEME 'OD'; 2130 2140 STOP BDSCHEME: 'SKIP' 2150 'END' # BACKWARD DIFFERENTIATION SCHEME FOR SECOND KIND VOLTERRA 2160 INTEGRAL EQUATIONS # ; 2170 2180 'INT' ORDER, NMB KER EV, NMB NEWTON IT, INCR; 2190 'REAL' TIME, X, XH, H, FUX, FX, A; 2200 'REAL' XS = 0.0, XE = 2.0, LN10 = LN(10.0); 2210 'PROC' KER=('REAL'X,'REAL'KSI,'REAL'F)'REAL': 2220 (NMB KER EV+:=1; -A*(1.0+X)*F*F/(1.0+KSI)); 2230 'PROC' DKERDF=('REAL'X,'REAL'KSI,'REAL'F)'REAL': 2240 (1000.*(KER(X,KSI,F+.001)-KER(X,KSI,F))); 2250 'PROC' D2KERDFDX=('REAL'X,'REAL'KSI,'REAL'F)'REAL': 2260 -2.0*A*F/(1.0+KSI); 2270 'PROC' G=('REAL'X)'REAL':SQRT(1.0+(1.0+X)*EXP(-10.0*X))+ 2280 A/10.0*(1.0+X)*(1.0-EXP(-10.0*X)+10.0*LN(1.0+X)); 2290 'PROC' FU=('REAL'X)'REAL':SQRT(1.0+(1.0+X)*EXP(-10.0*X)); 2300 A:=100.0; 2310 'WHILE' A<1001.0 'DO' 2320 A*:=10.0; 2330 'FOR' ORDER 'FROM' 6 'TO' 6 'DO' 2340 PRINTF(($ P " ORDER =" ZD $,ORDER)); H:=0.4; 2350 'TO' 5 'DO' 2360 H/:=2.0; PRINTF(($ 3L " STEP =" Z.8D L$,H)); 2370 [0:'ROUND'((XE-XS)/H)]'REAL' F; 2380 'FOR' I 'TO' 'UPB'F 'DO' F[I]:=0.0 'OD'; 2390 X:=XS; NMB KER EV:=NMB NEWTON IT:=0; TIME:=CLOCK; 2400 BACKWARD DIFFERENTIATION SCHEME FOR SECOND KIND 2410 VOLTERRA INTEGRAL EQUATION 2420 (ORDER,X,XE,H,KER,G,DKERDF,F,NMB NEWTON IT); 2430 TIME:=CLOCK-TIME; 2440 PRINTF(($ 2L5Q"X"8Q"F(X) EXACT"9Q"F(X) COMPUTED"7Q 2450 "ABS. ERROR"5Q"# CORR"5Q"H*DKDF"5Q"H*H*D2KDFDX",ZL$,0)); 2460 XH:=0.0; INCR:='ROUND'('UPB' F/10); 2470 'FOR'I'FROM'0'BY'INCR'TO''UPB'F'WHILE'XH'LE'X'DO' 2480 FUX:=FU(XH); FX:=F[I]; 2490 PRINTF(($ L 2Z-D.6D,3(2Z-D.14D),2Z-D.D,2(4Z-D.5D)$, 2500 XH,FUX,FX,'ABS'(FUX-FX),(FUX=FX!14!: 2510 FUX=0.0!-LN('ABS'(FX))/LN10! 2520 -LN('ABS'((FUX-FX)/FUX))/LN10), 2530 H*DKERDF(XH,XH,FX),H*H*D2KERDFDX(XH,XH,FX))); 2540 XH+:=INCR*H 2550 'OD'; 2560 PRINTF(($ L" TIME =" 4ZD.3D," SEC." L 2570 " NMB KER EV =" 4ZD," 10 LOG = " 3ZD.DL, 2580 " NMB NEWTON IT =" 4ZD$,TIME,NMB KER EV, 2590 LN(NMB KER EV)/LN10,NMB NEWTON IT )) 2600 'OD' # H # 2610 'OD' # ORDER # 2620 'OD' # A # 2630 'END' # PROGRAM # 2640 ################################################################################ CEPREL: (# PRELUDE FOR DETERMINING CHARACTERISTIC EQUATIONS OF BLOCKMETHODS # 'MODE' 'MATRIX' = 'REF' [,] 'REAL'; 'MODE' 'ELEMENT' = 'STRUCT'('REAL' VALUE, 'REF''ELEMENT' NEXT); 'MODE' 'LIST' = 'STRUCT'('INT' NUMBER, 'REF''ELEMENT' LAST); 'MODE' 'ALGVAR' = 'STRUCT'('INT' NR, 'STRING' NAME); 'MODE' 'FACTOR' = 'STRUCT'('REF''ALGVAR' AJ, 'INT' TTPJ, 'REFFACT' NEXT); 'MODE' 'TERM' = 'STRUCT'('REAL' CI, 'REFFACT' FI, 'REFTERM' NEXT); 'MODE' 'REFFACT' = 'REF''FACTOR'; 'MODE' 'WOFACT' = 'REF''FACTOR'; 'MODE' 'REFTERM' = 'REF''TERM'; 'MODE' 'WOTERM' = 'REF''TERM'; 'MODE' 'MATTERM' = 'REF' [,] 'REFTERM'; # DETERMINE COEFFICIENT MATRIX FROM THE ABSCISSAS # 'PROC' COEFMAT = ('REF''LIST' U) 'MATRIX': 'PR' XREF COEFMAT 'PR' 'SKIP'; # ROUTINES FOR FORMULA MANIPULATION # 'OP' 'PRINT' = ('REF' 'ALGVAR' X) 'VOID': 'PR' XREF PRALG 'PR' 'SKIP'; 'OP' 'PRINT' = ('REFFACT' F) 'VOID': 'PR' XREF PRFAC 'PR' 'SKIP'; 'OP' 'PRINT' = ('REFTERM' T) 'VOID': 'PR' XREF PRTER 'PR' 'SKIP'; 'OP' 'COPY' = ('REFFACT' F) 'REFFACT': 'PR' XREF COFAC 'PR' 'SKIP'; 'OP' 'COPY' = ('REFTERM' T) 'REFTERM': 'PR' XREF COTER 'PR' 'SKIP'; 'OP' > = ('REF' 'ALGVAR' AL,AR) 'BOOL': 'PR' XREF GRALG 'PR' 'SKIP'; 'OP' = = ('REF' 'ALGVAR' AL,AR) 'BOOL': 'PR' XREF EQALG 'PR' 'SKIP'; 'OP' > = ('REFFACT' FL,FR) 'BOOL': 'PR' XREF GRFAC 'PR' 'SKIP'; 'OP' = = ('REFFACT' FL,FR) 'BOOL': 'PR' XREF EQFAC 'PR' 'SKIP'; 'OP' > = ('REFTERM' TL,TR) 'BOOL': 'PR' XREF GRTER 'PR' 'SKIP'; 'OP' = = ('REFTERM' TL,TR) 'BOOL': 'PR' XREF EQTER 'PR' 'SKIP'; 'PROC' MERGEFACT = ('REF' 'WOFACT' F1,F2) 'VOID': 'PR' XREF MERGEFACT 'PR' 'SKIP'; 'PROC' WOFACT = ('REF''WOFACT' F) 'VOID':'PR' XREF WOFACT 'PR' 'SKIP'; 'PROC' ELIMFACT = ('REF' 'REFFACT' F) 'VOID': 'PR' XREF ELIMFACT 'PR' 'SKIP'; 'PROC' MERGETERM = ('REF' 'WOTERM' T1,T2) 'VOID': 'PR' XREF MERGETERM 'PR' 'SKIP'; 'PROC' WOTERM = ('REF' 'REFTERM' T) 'VOID': 'PR' XREF WOTERM 'PR' 'SKIP'; 'PROC' WOTERM1= ('REF' 'REFTERM' T) 'VOID': 'PR' XREF WOTERM1 'PR' 'SKIP'; 'PROC' ELIMTERM = ('REF' 'REFTERM' T) 'VOID': 'PR' XREF ELIMTERM 'PR' 'SKIP'; 'OP' 'WIDEN' = ('REF' 'ALGVAR' AJ) 'WOFACT': 'PR' XREF WIDALG 'PR' 'SKIP'; 'OP' 'WIDEN' = ('WOFACT' F) 'WOTERM': 'PR' XREF WIDFAC 'PR' 'SKIP'; 'OP' *:= = ('REF' 'WOFACT' F1,'WOFACT' F2) 'REF' 'WOFACT': 'PR' XREF ADMUFAC 'PR' 'SKIP'; 'OP' * = ('WOFACT' F1,F2) 'WOFACT': 'PR' XREF MULFAC 'PR' 'SKIP'; 'OP' *:= = ('WOTERM' T,'REAL' I)'WOTERM': 'PR' XREF ADMUTI 'PR''SKIP'; 'OP' * = ('WOTERM' T,'REAL' I) 'WOTERM': 'PR' XREF MULTI 'PR' 'SKIP'; 'OP' * = ('REAL' I,'WOTERM' T) 'WOTERM': 'PR' XREF MULIT 'PR' 'SKIP'; 'OP' *:= = ('WOTERM' T,'WOFACT' F)'WOTERM':'PR'XREF ADMUTF 'PR''SKIP'; 'OP' * = ('WOTERM' T,'WOFACT' F) 'WOTERM':'PR' XREF MULTF 'PR' 'SKIP'; 'OP' * = ('WOFACT' F,'WOTERM' T) 'WOTERM':'PR' XREF MULFT 'PR' 'SKIP'; 'OP' +:= = ('REF' 'WOTERM' T1,'WOTERM' T2) 'REF' 'WOTERM': 'PR' XREF ADADTT 'PR' 'SKIP'; 'OP' -:= = ('REF' 'WOTERM' T1,'WOTERM' T2) 'REF' 'WOTERM': 'PR' XREF ADSUTT 'PR' 'SKIP'; 'OP' + = ('WOTERM' T1,T2) 'WOTERM': 'PR' XREF ADDTT 'PR' 'SKIP'; 'OP' - = ('WOTERM' T1,T2) 'WOTERM': 'PR' XREF SUBTT 'PR' 'SKIP'; 'OP' * = ('WOTERM' T1,T2) 'WOTERM': 'PR' XREF MULTT 'PR' 'SKIP'; # DETERMINE THE MATRIX B - LABDA*A CORRESPONDING TO BLOCKMETHODS # 'ALGVAR' AL:=(3, "L"), AY:=(2, "Y"), AZ:=(1, "Z"); 'TERM' L:='WIDEN''WIDEN'AL, Y:='WIDEN''WIDEN'AY, Z:='WIDEN''WIDEN'AZ, ONE:=(1, 'NIL', 'NIL'), ZERO:=(0, 'NIL', 'NIL'); 'PROC' B MIN LA = ('MATRIX' W, 'REF''LIST' U) 'MATTERM': 'PR' XREF BMINLA 'PR' 'SKIP'; # COMPUTE THE DETERMINANT OF B - LABDA*A # 'PROC' DETERMINANT = ('MATTERM' A) 'REFTERM': 'PR' XREF DETERMINANT 'PR' 'SKIP'; # PRINT AND WRITE ON FILE 'F' THE CHARACTERISTIC EQUATION # 'PROC' WRITE OUT = ('REFTERM' CE, 'REF''FILE' F) 'VOID': 'PR' XREF WRITEOUT 'PR' 'SKIP'; 'PR' PROG 'PR' 'SKIP' ) ################################################################################ ( # ***** 2 PRINTING AND COPYING ***** # 'OP' 'PRINT' = ('REF' 'ALGVAR' X) 'VOID': 'PR' XDEF PRALG 'PR' (PRINT(NAME 'OF' X)) 'PR' FEDX 'PR'; 'OP' 'PRINT' = ('REFFACT' F) 'VOID': 'PR' XDEF PRFAC 'PR' ( 'REFFACT' FL:=F; 'BOOL' GOON:='REFFACT'(FL) 'ISNT' 'NIL'; 'WHILE' GOON 'DO' 'PRINT' AJ 'OF' FL; ('INT' TJ=TTPJ 'OF' FL;TJ/=1 ! PRINT(("^",WHOLE(TJ,0)))); FL:=NEXT 'OF' FL; GOON:='REFFACT'(FL) 'ISNT' 'NIL'; 'IF' GOON 'THEN' PRINT("*") 'FI' 'OD'; PRINT(" ") ) 'PR' FEDX 'PR'; 'OP' 'PRINT' = ('REFTERM' T) 'VOID': 'PR' XDEF PRTER 'PR' ( 'REFTERM' TL:=T; 'BOOL' GOON:='REFTERM' (TL) 'ISNT' 'NIL'; 'WHILE' GOON 'DO' PRINT((CI 'OF' TL,"*")); 'PRINT' FI 'OF' TL; TL:=NEXT 'OF' TL; GOON:='REFTERM' (TL) 'ISNT' 'NIL'; 'IF' GOON 'THEN' PRINT("+ ") 'FI' 'OD'; PRINT(NEWLINE) ) 'PR' FEDX 'PR'; 'OP' 'COPY' = ('REFFACT' F) 'REFFACT': 'PR' XDEF COFAC 'PR' ( 'REFFACT' FL:=F; 'IF' 'REFFACT'(FL) 'IS' 'NIL' 'THEN' 'NIL' 'ELSE' 'HEAP' 'FACTOR' START:=FL; 'REFFACT' END:=START; 'WHILE' FL:=NEXT 'OF' FL; 'REFFACT' (FL) 'ISNT' 'NIL' 'DO' NEXT 'OF' END:='HEAP' 'FACTOR':=FL; END:=NEXT 'OF' END 'OD'; START 'FI') 'PR' FEDX 'PR'; 'OP' 'COPY' = ('REFTERM' T) 'REFTERM': 'PR' XDEF COTER 'PR' ( 'REFTERM' TL:=T; 'IF' 'REFTERM'(TL) 'IS' 'NIL' 'THEN' 'NIL' 'ELSE' 'HEAP' 'TERM' START:=TL; 'REFTERM' END:=START; 'WHILE' FI 'OF' END:='COPY' FI 'OF' END; TL:=NEXT 'OF' TL; 'REFTERM' (TL) 'ISNT' 'NIL' 'DO' NEXT 'OF' END:='HEAP' 'TERM':=TL; END:=NEXT 'OF' END 'OD'; START 'FI') 'PR' FEDX 'PR'; # ***** 3 RELATIONAL OPERATORS ***** # 'OP' > = ('REF' 'ALGVAR' AL,AR) 'BOOL': 'PR' XDEF GRALG 'PR' (NR 'OF' AL > NR 'OF' AR) 'PR' FEDX 'PR'; 'OP' = = ('REF' 'ALGVAR' AL,AR) 'BOOL': 'PR' XDEF EQALG 'PR' (NR 'OF' AL = NR 'OF' AR) 'PR' FEDX 'PR'; 'OP' > = ('REFFACT' FL,FR) 'BOOL': 'PR' XDEF GRFAC 'PR' ( 'BOOL' BL='REFFACT'(FL) 'IS' 'NIL', BR='REFFACT'(FR) 'IS' 'NIL'; 'IF' BL 'OR' BR 'THEN' BR 'AND' 'NOT' BL 'ELSE' (AJ 'OF' FL>AJ 'OF' FR ! 'TRUE' !: AJ 'OF' FL=AJ 'OF' FR ! TTPJ 'OF' FL>TTPJ 'OF' FR ! 'FALSE') 'FI') 'PR' FEDX 'PR'; 'OP' = = ('REFFACT' FL,FR) 'BOOL': 'PR' XDEF EQFAC 'PR' ( 'BOOL' BL='REFFACT'(FL) 'IS' 'NIL', BR='REFFACT'(FR) 'IS' 'NIL'; 'IF' BL 'OR' BR 'THEN' BR=BL 'ELSE' (AJ 'OF' FL=AJ 'OF' FR ! TTPJ 'OF' FL=TTPJ 'OF' FR ! 'FALSE') 'FI') 'PR' FEDX 'PR'; 'OP' > = ('REFTERM' TL,TR) 'BOOL': 'PR' XDEF GRTER 'PR' ( 'REFTERM'(TR) 'IS' 'NIL' ! 'REFTERM'(TL) 'ISNT' 'NIL' ! 'REFFACT' FL:=('REFTERM' (TL) 'IS' 'NIL' ! 'NIL' ! FI 'OF' TL), FR:=FI 'OF' TR; 'WHILE' (FL=FR) 'AND' ('REFFACT'(FR) 'ISNT' 'NIL') 'DO' FL:=NEXT 'OF' FL; FR:=NEXT 'OF' FR 'OD'; FL>FR) 'PR' FEDX 'PR'; 'OP' = = ('REFTERM' TL,TR) 'BOOL': 'PR' XDEF EQTER 'PR' ( 'REFTERM'(TR) 'IS' 'NIL' ! 'REFTERM'(TL) 'IS' 'NIL' ! 'REFFACT' FL:=('REFTERM' (TL) 'IS' 'NIL' ! 'NIL' ! FI 'OF' TL), FR:=FI 'OF' TR; 'WHILE' (FL=FR) 'AND' ('REFFACT'(FR) 'ISNT' 'NIL') 'DO' FL:=NEXT 'OF' FL; FR:=NEXT 'OF' FR 'OD'; FL=FR) 'PR' FEDX 'PR'; 'SKIP') ################################################################################ ( # ***** 4A MERGING AND WELL ORDERING OF FACTORS ***** # 'PROC' MERGEFACT = ('REF' 'WOFACT' F1,F2) 'VOID': 'PR' XDEF MERGEFACT 'PR' ( 'WOFACT' START:='NIL'; 'REF' 'WOFACT' END:=START; 'WHILE' 'REF' 'WOFACT' NEXT:=(F1>F2 ! F1 ! F2); 'WOFACT' (NEXT) 'ISNT' 'NIL' 'DO' 'REF' 'WOFACT'(END):=NEXT; END:=NEXT 'OF' END; 'REF' 'WOFACT'(NEXT):=NEXT 'OF' NEXT 'OD'; F1:=START; ELIMFACT(F1); F2:='NIL') 'PR' FEDX 'PR'; 'PROC' WOFACT = ('REF' 'WOFACT' F) 'VOID': 'PR' XDEF WOFACT 'PR' 'IF' 'REFFACT' FI:=F; 'REFFACT' (FI) 'ISNT' 'NIL' 'THEN' 'IF' 'REFFACT' SE:=NEXT 'OF' FI; 'REFFACT'(SE) 'ISNT' 'NIL' 'THEN' 'REF' 'REFFACT' END:=NEXT 'OF' FI; 'WHILE' 'REFFACT' (END) 'ISNT' 'NIL' 'DO' 'REF' 'REFFACT' SAVE:=NEXT 'OF' END; 'REF' 'REFFACT'(END):=SAVE; END:=SAVE 'OD'; WOFACT(FI); WOFACT(SE); MERGEFACT(FI,SE); F:=FI 'FI' 'FI' 'PR' FEDX 'PR'; 'PROC' ELIMFACT = ('REF' 'REFFACT' F) 'VOID': 'PR' XDEF ELIMFACT 'PR' ( 'REF' 'REFFACT' END:=F; 'WHILE' 'REFFACT' (END) 'ISNT' 'NIL' 'DO' 'REFFACT' FI:=END; 'WHILE' 'REFFACT' SE:=NEXT 'OF' FI; ('REFFACT' (SE) 'IS' 'NIL' ! 'FALSE' ! AJ 'OF' FI=AJ 'OF' SE) 'DO' TTPJ 'OF' FI+:=TTPJ 'OF' SE; NEXT 'OF' FI:=NEXT 'OF' SE 'OD'; (TTPJ 'OF' FI=0 ! 'REF' 'REFFACT'(END):=NEXT 'OF' FI ! END:=NEXT 'OF' FI) 'OD') 'PR' FEDX 'PR'; # ***** 4B MERGING AND WELL ORDERING OF TERMS ***** # 'PROC' MERGETERM = ('REF' 'WOTERM' T1,T2) 'VOID': 'PR' XDEF MERGETERM 'PR' ( 'WOTERM' START:='NIL'; 'REF' 'WOTERM' END:=START; 'WHILE' 'REF' 'WOTERM' NEXT:=(T1>T2 ! T1 ! T2); 'WOTERM' (NEXT) 'ISNT' 'NIL' 'DO' 'REF' 'WOTERM'(END):=NEXT; END:=NEXT 'OF' END; 'REF' 'WOTERM'(NEXT):=NEXT 'OF' NEXT 'OD'; T1:=START; ELIMTERM(T1); T2:='NIL') 'PR' FEDX 'PR'; 'PROC' WOTERM = ('REF' 'REFTERM' T) 'VOID': 'PR' XDEF WOTERM 'PR' ( 'REFTERM' TL:=T; 'WHILE' 'REFTERM'(TL) 'ISNT' 'NIL' 'DO' WOFACT(FI 'OF' TL); TL:=NEXT 'OF' TL 'OD'; WOTERM1(T) ) 'PR' FEDX 'PR'; 'PROC' WOTERM1= ('REF' 'REFTERM' T) 'VOID': 'PR' XDEF WOTERM1 'PR' 'IF' 'REFTERM' FI:=T; 'REFTERM' (FI) 'ISNT' 'NIL' 'THEN' 'IF' 'REFTERM' SE:=NEXT 'OF' FI; 'REFTERM'(SE) 'ISNT' 'NIL' 'THEN' 'REF' 'REFTERM' END:=NEXT 'OF' FI; 'WHILE' 'REFTERM' (END) 'ISNT' 'NIL' 'DO' 'REF' 'REFTERM' SAVE:=NEXT 'OF' END; 'REF' 'REFTERM'(END):=SAVE; END:=SAVE 'OD'; WOTERM1(FI); WOTERM1(SE); MERGETERM(FI,SE); T:=FI 'FI' 'FI' 'PR' FEDX 'PR'; 'PROC' ELIMTERM = ('REF' 'REFTERM' T) 'VOID': 'PR' XDEF ELIMTERM 'PR' ( 'REF' 'REFTERM' END:=T; 'WHILE' 'REFTERM' (END) 'ISNT' 'NIL' 'DO' 'REFTERM' FI:=END; 'WHILE' 'REFTERM' SE:=NEXT 'OF' FI; ('REFTERM'(SE) 'IS' 'NIL' ! 'FALSE' ! FI=SE) 'DO' CI 'OF' FI+:=CI 'OF' SE; NEXT 'OF' FI:=NEXT 'OF' SE 'OD'; ( CI 'OF' FI=0 ! 'REF' 'REFTERM'(END):=NEXT 'OF' FI ! END:=NEXT 'OF' FI ) 'OD') 'PR' FEDX 'PR'; # ***** 5 WIDENING ***** # 'OP' 'WIDEN' = ('REF' 'ALGVAR' AJ) 'WOFACT': 'PR' XDEF WIDALG 'PR' ( 'HEAP' 'FACTOR' F:=(AJ,1,'NIL'); F) 'PR' FEDX 'PR'; 'OP' 'WIDEN' = ('WOFACT' F) 'WOTERM': 'PR' XDEF WIDFAC 'PR' ( 'HEAP' 'TERM' T:=(1,F,'NIL'); T) 'PR' FEDX 'PR'; 'SKIP') ################################################################################ ( # ***** 6A MULTIPLICATION OF FACTORS ***** # 'OP' *:= = ('REF' 'WOFACT' F1,'WOFACT' F2) 'REF' 'WOFACT': 'PR' XDEF ADMUFAC 'PR' ( 'WOFACT' F2L:='COPY' F2; MERGEFACT(F1,F2L); F1) 'PR' FEDX 'PR'; 'OP' * = ('WOFACT' F1,F2) 'WOFACT': 'PR' XDEF MULFAC 'PR' ( 'WOFACT' F1L:='COPY' F1; F1L*:=F2) 'PR' FEDX 'PR'; # ***** 6B MULTIPLICATION OF TERMS WITH INTEGERS AND FACTORS ***** # 'OP' *:= = ('WOTERM' T,'REAL' I) 'WOTERM': 'PR' XDEF ADMUTI 'PR' ('WOTERM' TL:=T; 'WHILE' 'REFTERM'(TL) 'ISNT' 'NIL' 'DO' CI 'OF' TL*:=I; TL:=NEXT 'OF' TL 'OD'; T) 'PR' FEDX 'PR'; 'OP' * = ('WOTERM' T,'REAL' I) 'WOTERM': 'PR' XDEF MULTI 'PR' ('WOTERM' TL:='COPY' T;TL*:=I) 'PR' FEDX 'PR'; 'OP' * = ('REAL' I,'WOTERM' T) 'WOTERM': 'PR' XDEF MULIT 'PR' ('WOTERM' TL:='COPY' T;TL*:=I) 'PR' FEDX 'PR'; 'OP' *:= = ('WOTERM' T,'WOFACT' F) 'WOTERM': 'PR' XDEF ADMUTF 'PR' ('WOTERM' TL:=T; 'WHILE' 'REFTERM'(TL) 'ISNT' 'NIL' 'DO' FI 'OF' TL*:=F; TL:=NEXT 'OF' TL 'OD'; T) 'PR' FEDX 'PR'; 'OP' * = ('WOTERM' T,'WOFACT' F) 'WOTERM': 'PR' XDEF MULTF 'PR' ('WOTERM' TL:='COPY' T; TL*:=F) 'PR' FEDX 'PR'; 'OP' * = ('WOFACT' F,'WOTERM' T) 'WOTERM': 'PR' XDEF MULFT 'PR' ('WOTERM' TL:='COPY' T; TL*:=F) 'PR' FEDX 'PR'; # ***** 7 ADDING OPERATORS ON TERMS ***** # 'OP' +:= = ('REF' 'WOTERM' T1,'WOTERM' T2) 'REF' 'WOTERM': 'PR' XDEF ADADTT 'PR' ( 'WOTERM' T2L:='COPY' T2; MERGETERM(T1,T2L); T1) 'PR' FEDX 'PR'; 'OP' -:= = ('REF' 'WOTERM' T1,'WOTERM' T2) 'REF' 'WOTERM': 'PR' XDEF ADSUTT 'PR' ( 'WOTERM' T2L:=T2*-1.0; MERGETERM(T1,T2L); T1) 'PR' FEDX 'PR'; 'OP' + = ('WOTERM' T1,T2) 'WOTERM': 'PR' XDEF ADDTT 'PR' ('WOTERM' T1L:='COPY' T1;T1L+:=T2) 'PR' FEDX 'PR'; 'OP' - = ('WOTERM' T1,T2) 'WOTERM': 'PR' XDEF SUBTT 'PR' ('WOTERM' T1L:='COPY' T1;T1L-:=T2) 'PR' FEDX 'PR'; # ***** 8 MULTIPLICATION OF TERMS ***** # 'OP' * = ('WOTERM' T1,T2) 'WOTERM': 'PR' XDEF MULTT 'PR' ( 'WOTERM' T2L:=T2,SOM:='NIL',T3; 'WHILE' 'REFTERM'(T2L) 'ISNT' 'NIL' 'DO' (T3:=FI 'OF' T2L * T1) *:= CI 'OF' T2L; SOM+:=T3; T2L:=NEXT 'OF' T2L 'OD'; SOM) 'PR' FEDX 'PR'; 'SKIP') ################################################################################ WEIGHTS: ( 'PROC' COEFMAT = ('REF''LIST' U) 'MATRIX': 'PR' XDEF COEFMAT 'PR' ( 'REAL' EPS=1.0 E-13; # IF A MATRIXELEMENT < EPS THEN IT IS SET EQUAL TO ZERO # 'INT' K = NUMBER 'OF' U; # K IS THE NUMBER OF ABSCISSAS # 'MODE' 'VECTOR' = [1:K] 'REAL'; 'MODE' 'INTEGRAND' = 'STRUCT'('REAL' DENOMINATOR, 'REF''VECTOR' NOMINATOR); 'PROC' LAGRANGE = ('LIST' U) 'INTEGRAND': ( 'INTEGRAND' L; 'REF''ELEMENT' PU:=LAST 'OF' U; 'REAL' U1=VALUE 'OF' (PU:=NEXT 'OF' PU); 'REAL' D:=U1-VALUE 'OF' (PU:=NEXT 'OF' PU); 'FOR' I 'FROM' 3 'TO' K 'DO' D*:=U1-VALUE 'OF' (PU:=NEXT 'OF' PU) 'OD'; DENOMINATOR 'OF' L:=D; 'PROC' WT = ('VECTOR' COEF, 'REAL' X, 'INT' K) 'VECTOR': ( 'VECTOR' C; C[2:K+1]:=COEF[1:K]; C[1]:=0; 'FOR' I 'TO' K 'DO' C[I]+:=COEF[I]*X 'OD'; C ); # WT # 'VECTOR' NOM; PU:=NEXT 'OF' (LAST 'OF' U); NOM[1]:=VALUE 'OF' (PU:=NEXT 'OF' PU); NOM[2]:=1; 'FOR' I 'FROM' 3 'TO' K 'DO' NOM:=WT(NOM, VALUE 'OF' (PU:=NEXT 'OF' PU), I-1) 'OD'; NOMINATOR 'OF' L:=NOM; L ); # LAGRANGE # 'REF''ELEMENT' P=LAST 'OF' U; 'INT' N=(VALUE 'OF' (NEXT 'OF' P)=0! K-1! K); # N IS THE NUMBER OF ABSCISSAS /= 0 # 'MATRIX' B:='HEAP' [1:N,0:N] 'REAL'; 'IF' K=N 'THEN' # RADAU # 'FOR' I 'TO' N 'DO' B[I,0]:=0 'OD' 'ELSE' # EQUIDISTANT # 'INTEGRAND' L0:=LAGRANGE(U); 'REF''ELEMENT' PU:=NEXT 'OF' P; 'FOR' I 'TO' N 'DO' 'REAL' UI=VALUE 'OF' (PU:=NEXT 'OF' PU); 'REAL' X:=UI/K; 'INT' S:=1; 'FOR' PI 'FROM' K-1 'BY' -1 'TO' 1 'DO' X:=(X+(S:=-S)*(NOMINATOR 'OF' L0)[PI]/PI)*UI 'OD'; X/:=DENOMINATOR 'OF' L0; B[I,0]:=( 'ABS'X>EPS! X! 0 ) # THE INTEGRAL OVER L0 FROM 0 TO UI # 'OD'; LAST 'OF' U:=NEXT 'OF' (LAST 'OF' U) 'FI'; 'FOR' J 'TO' N 'DO' 'INTEGRAND' LJ:=LAGRANGE(U); 'REF''ELEMENT' PU:=(K=N! P! NEXT 'OF' P); 'FOR' I 'TO' N 'DO' 'REAL' UI=VALUE 'OF' (PU:=NEXT 'OF' PU); 'REAL' X:=UI/K; 'INT' S:=1; 'FOR' PI 'FROM' K-1 'BY' -1 'TO' 1 'DO' X:=(X+(S:=-S)*(NOMINATOR 'OF' LJ)[PI]/PI)*UI 'OD'; X/:=DENOMINATOR 'OF' LJ; B[I,J]:=( 'ABS'X>EPS! X! 0 ) # THE INTEGRAL OVER LJ FROM 0 TO UI # 'OD'; LAST 'OF' U:=NEXT 'OF' (LAST 'OF' U) # TAKE NEXT ABSCISSA TO CALCULATE L(J+1) # 'OD'; # IN CASE OF EQUIDISTANT ABSCISSAE SKIP THE CEL WITH U0=0 AND CHANGE NUMBER 'OF' U ACCORDING TO THIS DELETION # (K/=N! NEXT 'OF' (LAST 'OF' U):=NEXT 'OF' (NEXT 'OF' (LAST 'OF' U)); NUMBER 'OF' U:=N); B ) 'PR' FEDX 'PR'; # COEFMAT # 'SKIP' ) ################################################################################ CHAREQ: ( 'PROC' B MIN LA = ('MATRIX' W, 'REF''LIST' U) 'MATTERM': 'PR' XDEF BMINLA 'PR' ( # K WILL BE THE NUMBER OF ABSCISSAS /=0; THE LIST U DOESN'T CONTAIN THE ABSCISSA U0 # 'INT' K=NUMBER 'OF' U; 'MATTERM' B:='HEAP' [1:K+1,1:K+1] 'REFTERM'; 'REF''ELEMENT' PU:=LAST 'OF' U; 'FOR' I 'TO' K 'DO' 'REAL' UI=VALUE 'OF' (PU:=NEXT 'OF' PU); 'FOR' J 'TO' K 'DO' B[I,J]:=W[I,J]*(Z*L+UI*Y*L) 'OD'; B[I,K]+:=W[I,0]*(Z+UI*Y)+ONE; B[I,K+1]:=UI*ONE; B[I,I]-:=L 'OD'; 'FOR' J 'TO' K 'DO' B[K+1,J]:=W[K,J]*Y*L 'OD'; B[K+1,K]+:=W[K,0]*Y; B[K+1,K+1]:=ONE-L; B ) 'PR' FEDX 'PR'; # B MIN LA # 'PROC' DETERMINANT = ('MATTERM' A) 'REFTERM': 'PR' XDEF DETERMINANT 'PR' 'BEGIN' 'INT' LB='LWB'A, UB='UPB'A; 'IF' UB-LB=1 'THEN' 'REFTERM' X:=A[LB,LB]*A[UB,UB]-A[LB,UB]*A[UB,LB]; X 'ELSE' [LB:UB-1,LB:UB-1] 'REFTERM' B; 'REFTERM' X:=ZERO; 'REAL' SIGN:=-1; 'FOR' I 'FROM' LB 'TO' UB 'DO' 'IF' (CI 'OF' A[LB,I]) = 0 'THEN' SIGN:=-SIGN 'ELSE' B[LB:UB-1,LB:I-1]:=A[LB+1:UB,LB:I-1]; B[LB:UB-1,I:UB-1]:=A[LB+1:UB,I+1:UB]; X+:=DETERMINANT(B)*A[LB,I]*(SIGN:=-SIGN) 'FI' 'OD'; X 'FI' 'END' 'PR' FEDX 'PR'; # DETERMINANT # 'PROC' WRITE OUT = ('REFTERM' CE, 'REF''FILE' RF) 'VOID': 'PR' XDEF WRITEOUT 'PR' ( # WRITE CHARACTERISTIC EQUATION TO FILE OUTPUT # 'PRINT' CE; # WRITE REDUCED DEGREE OF THE CHARACTERISTIC EQUATION TO FILE F EACH TERM WITH COEFFICIENT EPS! F:=FI 'OF' T; WRITE POWER(AL, LOWPOW); WRITE POWER(AY, 0); WRITE POWER(AZ, 0); PUT(RF, (X, NEWLINE)) ); T:=NEXT 'OF' T 'OD'; PUT(RF, -1) ) 'PR' FEDX 'PR'; # WRITE OUT # 'SKIP' ) ################################################################################ CHEQ: ( # PROGRAM TO CALCULATE THE CHARACTERISTIC EQUATION OF A BLOCKMETHOD. THE POINTS OF THE BLOCK ARE: 0=1 'DO' 'REAL' A0, 'INT' K:=-1; 'WHILE' K+:=1; A0:=A[K]; A0=0 'AND' KK 'DO' 'SKIP' 'OD'; ( L=K! TRUE ); N:=L-K; B[0:N]:=A[K:K+N]; ( 'ABS'AN<='ABS'A0! FALSE ); ( N=1! TRUE ); 'FOR' J 'FROM' N 'BY' -1 'TO' 1 'DO' A[J-1]:=AN*B[J]-A0*B[N-J] 'OD'; N-:=1 'OD'; TRUE: 'TRUE' 'EXIT' FALSE: 'FALSE' ); # SCHUR # 'PRIO' ** = 8; 'OP' ** = ('REAL' A, 'INT' B) 'REAL': ( 'REAL' P:=1; 'TO' B 'DO' P*:=A 'OD'; P ); # READ NUMBER OF PICTURES AND CORRESPONDING MAZES # [0:DEGREE] 'REAL' A, 'INT' LBY, UBY, LBZ, UBZ, 'REAL' SY, SZ, PY, PZ; ON LOGICAL FILE END (STAND IN, ('REF''FILE' F) 'BOOL': READY); 'DO' READ((LBY, UBY, SY, NEWLINE, LBZ, UBZ, SZ, NEWLINE)); 'STRING' BLANKS = ((136-(UBZ-LBZ+1))'OVER'2)*" "; 'INT' NOR; READ((NOR, NEWLINE)); 'REAL' RHO, PR; 'TO' NOR 'DO' READ(RHO); PRINT((NEWPAGE, BLANKS, "STABILITY REGION IN THE (Z,Y) ", "PLANE WITH", NEWLINE, BLANKS, "Y=H**2*H ON THE INTERVAL (", FIXED(LBY*SY,0,3), ",", FIXED(UBY*SY,0,3), ") WITH ", "STEPSIZE ", FIXED(SY,0,3), " AND", NEWLINE, BLANKS, "Z=H*J ON THE INTERVAL (", FIXED(LBZ*SZ,0,3), ",", FIXED(UBZ*SZ,0,3), ") WITH ", "STEPSIZE ", FIXED(SZ,0,3), NEWLINE, BLANKS, "ABSOLUTE VALUE OF THE ROOTS OF ", "THE CHARACTERISTIC POLYNOMIAL LESS THAN RHO=", FIXED(RHO,0,5), NEWLINE,NEWLINE)); 'FOR' J 'FROM' UBY 'BY' -1 'TO' LBY 'DO' 'REAL' Y=J*SY; PRINT(BLANKS); 'FOR' I 'FROM' LBZ 'TO' UBZ 'DO' 'REAL' Z=I*SZ; PR:=1; 'FOR' POWL 'FROM' 0 'TO' DEGREE 'DO' PE:=C[POWL]; 'REAL' X:=0; 'WHILE' 'REF''ELEMENT'(PE) 'ISNT' 'NIL' 'DO' X+:=COEF 'OF' PE*Y**POWY 'OF' PE* Z**POWZ 'OF' PE; PE:=NEXT 'OF' PE 'OD'; A[POWL]:=X*PR; PR*:=RHO 'OD'; 'BOOL' STABLE = SCHUR(A); ( I=0!( STABLE! PRINT("X")! PRINT("I") ) !: J=0! PRINT("-") !: STABLE! PRINT("X")! PRINT(" ") ) 'OD'; PRINT(NEWLINE) 'OD' 'OD' 'OD'; READY: 'SKIP' ) ################################################################################ 'BEGIN' 'INT' N = 1, ALFA = 1; PRINT((NEWLINE," PROBLEM 1 WITH INTEGRATOR FOURSTEPLHS AND N=", N," ALFA=",ALFA,NEWLINE)); NONLINEAR 'OF' SPLINFO :='TRUE'; ITERLIMIT 'OF' SPLINFO := 10; 'PROC' SOLUTION = ('REAL' T, X, Y)'REAL': ( T ** ALFA * ( ( X * X + Y ) * SIN(10*PI*T) + X * Y * Y ) ); 'REAL' T := 0.03, TEND := 1.0, 'INT' G EVAL := 0; 'RHSFU' G = ( 'PROC''REAL' T, X, Y, U, UX, UY, UXX, UXY, UYY)'REAL': ( G EVAL +:=1; 'REAL' XX = X, YY = Y, TT = T; 'REAL' TA = TT ** ALFA, ST = SIN( 10.0 * PI * TT); U ** ( 2 * N ) * ( UXX + UYY - 2 * TA * ( ST + XX ) ) + TA * ( XX * XX + YY ) * ( ALFA * ST / TT + 10.0 * PI * COS(10*PI*TT) ) + ALFA * TA / TT * XX * YY * YY ); 'BOUNDFU' B = ( 'PROC''REAL' T, X, Y, U)'REAL': ( 'REAL' TT = T, XX = X, YY = Y; TT ** ALFA * ( ( XX * XX + YY ) * SIN(10*PI*TT) + XX * YY * YY ) - U ); 'PROC' GRID = ('INT' K, R)'POINT': ( (K - 1) / 7, (R - 1) / 7 ); 'DEFGRID' DG := ( GRID, 'LOC' [1 : 7]'INT' := ( 1, 8, 8, 5, 5, 1, 1 ), 'LOC' [1 : 7]'INT' := ( 1, 1, 4, 4, 8, 8, 1 ) ); 'PROC' DISPLAY = ('REAL' T, 'MAT' U, 'INT' CASE)'VOID': # CASE = 0 MEANS: DISPLAY U, 1 MEANS: DISPLAY (U - SOLUTION), 2 MEANS: DISPLAY (U - SOLUTION) / SOLUTION # 'IF' U :=: 'MAT'('NIL')'THEN' PRINT((NEWLINE," NO OUTPUT",NEWLINE)) 'ELSE' PRINT((NEWLINE, 'CASE' CASE + 1 'IN' " SOLUTION U AT T = ", " ABS. ERRORS AT T = ", " REL. ERRORS AT T = " 'ESAC', T,NEWLINE)); 'REAL' MAX := -1; 'FOR' J 'FROM' 2'UPB'U - 1 'BY' -1 'TO' 2'LWB'U + 1 'DO' PRINT( WHOLE(J, -5)); 'FOR' I 'FROM' 'LWB'U + 1 'TO' ( J>3 ! 4 ! 'UPB'U - 1 ) 'DO' 'IF' CASE = 0 'THEN' PRINT( U[I,J] ) 'ELSE' 'POINT' P = 'CASE' R 'OF' DG 'IN' ('PROC'('INT','INT')'POINT' PR): PR(I, J), ('REF' [ , ]'POINT' RP) : RP[I, J] 'ESAC'; 'REAL' S=SOLUTION(T, XC 'OF' P, YC 'OF' P); 'IF' CASE = 1 'THEN' PRINTF(($ 2Q+D.2DE+ZD $,U[I,J] - S)) 'ELIF' S = 0 'THEN' PRINT( "***********") 'ELSE' PRINTF(($ 2Q+D.2DE+ZD $,('REAL' RE= 'ABS'((U[I,J]-S)/S);(RE>MAX! MAX:=RE);RE))) 'FI' 'FI' 'OD'; PRINT(NEWLINE) 'OD'; (CASE=2!PRINTF(($ L," MIN.SIGN.DIGITS:",+2Z.2D,L $, -LN(MAX)/LN(10.0)))) 'FI'; Y EXACT := ('REAL' T)'MAT': 'BEGIN' 'MAT' YE = 'HEAP'[1 : 8, 1 : 8]'REAL'; 'FOR' K 'TO' 8 'DO' 'FOR' R 'TO' 8 'DO' YE[K, R]:= 'IF' K>5 'AND' R>4 'THEN' 0.0 'ELSE' 'POINT' P = GRID(K,R); SOLUTION ( T, XC 'OF' P, YC 'OF' P) 'FI' 'OD' 'OD'; YE 'END'; 'MAT' U := Y EXACT ( T ); 'INFO' INFO := (1.0E-2, 0.0, 1.0E-3, ('REAL' T)'REAL': 0.01, ('INT' CASE)'BOOL':CASE=1'OR'CASE=2,0,0,0, ('INT' N, 'REAL' T, H, 'MAT' U)'VOID': 'BEGIN' PRINT((NEWLINE," INFO-MONITOR", NEWLINE)); 'FOR' CASE 'TO' 2 'DO' DISPLAY( T, U, CASE ) 'OD' 'END' ); IBVP SOLVER ( FOURSTEPLHS, G, B, DG, U, T, ( TEND ), INFO ); PRINT((NEWLINE,NEWLINE, " RESULTS FROM INTEGRATION:",NEWLINE, " INFO:",NEWLINE," STEPS PERF. , NUMGP", WHOLE( NSTEPSPERF 'OF' INFO, -5), WHOLE( NUMGP 'OF' INFO, -5), NEWLINE," G-EVALS", WHOLE (G EVAL, -10),NEWLINE, " ITERATIONS PERFORMED:",WHOLE(ITER 'OF' SPLINFO, -4), NEWLINE)); PRINTF(( $ L," 10 LOG G-EVALS",+5Z.2D,L $, LN(G EVAL)/LN(10.0))); 'FOR' CASE 'TO' 2 'DO' DISPLAY ( TEND, U, CASE) 'OD' 'END' ################################################################################ 'BEGIN' # IMPLEMENTATION RESTRICTIONS # 'INT' SPOOLSIZE = 400, STLIM = 50, ARGLIM = 5, RSLIM = 80, PSLIM = 20, FTLIM = 10 ; # ABSTRACT MACHINE # 'MODE' 'ITEM' = 'UNION' ('INT', 'REF''STRINGITEM', 'PATTERN'), 'STRINGITEM' = 'STRUCT' ('STRING' VAL, 'REF''ITEM' REF), 'PATTERN' = 'REF'[]'COMPONENT', 'COMPONENT' = 'STRUCT' ('INT' ROUTINE, SUBSEQUENT, ALTERNATE, EXTRA, 'REF''ITEM' ARG), 'MODE' 'PSENTRY' = 'STRUCT' ('INT' CURSOR, ALTERNATE), 'RSENTRY' = 'REF''ITEM', 'FTENTRY' = 'STRUCT' ('REF''ITEM' FNNAME, ENTRY NAME, 'REF'[]'REF''ITEM' PARAMS, LOCALS) ; [1:SPOOLSIZE] 'REF''ITEM' SPOOL, 'INT' NIN, 'BOOL' FAILED := 'FALSE', [1:PSLIM] 'PSENTRY' PATTERN STACK, 'INT' PSP, [1:RSLIM] 'RSENTRY' RUN STACK, 'INT' RSP := 0, [1:FTLIM] 'FTENTRY' FUNCTION TABLE, 'INT' FTP := 0 ; 'INT' MSTR = 1, MLEN = 2, MBRK = 3, MSPN = 4, MANY = 5, MNUL = 6, MIV1 = 7, MIV2 = 8, M1 = 9, MAT = 10, MPOS = 11, MTAB = 12, MRPOS = 13, MRTAB = 14, MNTY = 15 ; # INTERNAL FORM OF PROGRAMS # 'MODE' 'STMT' = 'STRUCT' ('REF''IDR' LABEL, 'UNION' ('REF''ASMT', 'REF''MATCH', 'REF''REPL', 'REF''EXPR') STMT CORE, 'REF''GOTOFIELD' GOTO), 'IDR' = 'STRUCT' ('REF''ITEM' IDR ADDR), 'NUM' = 'STRUCT' ('REF''ITEM' NUM ADDR), 'LSTR' = 'STRUCT' ('REF''ITEM' LSTR ADDR), 'ASMT' = 'STRUCT' ('REF''EXPR' SUBJECT, OBJECT), 'MATCH' = 'STRUCT' ('REF''EXPR' SUBJECT, PATTERN), 'REPL' = 'STRUCT' ('REF''EXPR' SUBJECT, PATTERN, OBJECT), 'EXPR' = 'UNION' ('REF''UNARYEXPR', 'REF''BINARYEXPR', 'IDR', 'NUM', 'LSTR', 'REF''CALL'), 'GOTOFIELD' = 'STRUCT' ('REF''DEST' UPART, SPART, FPART), 'DEST' = 'UNION' ('REF''EXPR', 'CHAR'), 'UNARYEXPR' = 'STRUCT' ('REF''EXPR' OPERAND, 'CHAR' OPERATOR), 'BINARYEXPR' = 'STRUCT' ('REF''EXPR' OPERAND1, OPERAND2, 'CHAR' OPERATOR), 'CALL' = 'STRUCT' ('IDR' FNNAME, 'REF'[]'REF''EXPR' ARGS) ; 'REF'[]'STMT' T , 'REF''ITEM' PROG ENTRY := 'NIL' ; 'PROC' ERROR = ('STRING' MESS) 'VOID' : ( PRINT ((NEWLINE, NEWLINE, "---", MESS, "---")) ; STOP ) ; 'BEGIN' # TRANSLATION PHASE # # DECLARATIONS FOR SCANNER # [1:80] 'CHAR' CARD, 'INT' CP, # SOURCE LINE AND POINTER # 'CHAR' CH, # SOURCE CHARACTER # [1:80] 'CHAR' STR, 'INT' SP, # STRING BUFFER AND POINTER # 'CHAR' TOK, # TOKEN CODE # 'REF''ITEM' PSN, # POSITION OF A CREATED VALUE # 'INT' NV, # NUMERIC VALUE OF CONSTANT # 'INT' STN, # SOURCE STATEMENT NUMBER # 'BOOL' LISTING, # FLAG FOR SOURCE LISTING # 'CHAR' C ; # TEMPORARY # # TOKEN MNEMONICS # 'CHAR' DOLL = "$", BDOLL = "D", PLUS = "+", BPLUS = "P", MINUS = "-", BMINUS = "M", AT = "@", BBAR = "!", BSTAR = "*", BSLASH = "/", LPAR = "(", RPAR = ")", COMMA = ",", COLON = ":", EQUAL = "=", BLANK = " ", EOS = ";", NAME = "A", LSTRING = "L", NUMBER = "U", ENDT = "E", RET = "R", FRET = "F", STOK = "Y", FTOK = "Z" ; 'PROC' GET CARD = 'VOID' : ( CP := 0 ; 'WHILE' READ (CARD) ; C := CARD[1] ; 'IF' C /= "." 'AND' C /= "+" 'AND' C /= "-" 'AND' C /= "*" 'THEN' STN := STN + 1 'FI' ; 'IF' LISTING 'THEN' PRINT ((STN, " ", CARD, NEWLINE)) 'FI' ; 'IF' C = "-" 'THEN' 'IF' CARD[2:5] = "LIST" 'THEN' LISTING := 'TRUE' 'ELIF' CARD[2:7] = "UNLIST" 'THEN' LISTING := 'FALSE' 'FI' 'FI' ; C = "-" 'OR' C = "*" 'DO' 'SKIP' 'OD' ) ; 'PROC' NEXT CH = 'VOID' : 'IF' CP = 80 'THEN' GET CARD ; 'IF' C = "." 'OR' C = "+" 'THEN' CH := " " ; CP := 1 'ELSE' CH := "#" # END OF LINE AND STATEMENT # 'FI' 'ELSE' CH := CARD [CP +:= 1] 'FI' ; 'PROC' LOOKUP = ('STRING' SV) 'REF''ITEM' : ( 'INT' I := 0, 'BOOL' NF := 'TRUE' ; 'WHILE' 'IF' (I +:= 1) <= NIN 'THEN' NF := SV /= VAL 'OF' (SPOOL[I] ! ('REF''STRINGITEM' S) : S) 'ELSE' 'FALSE' 'FI' 'DO' 'SKIP' 'OD' ; 'IF' NF 'THEN' 'IF' NIN = SPOOLSIZE 'THEN' ERROR ("TOO MANY STRINGS") 'FI' ; SPOOL [NIN +:= 1] := 'HEAP''ITEM' := 'HEAP''STRINGITEM' := (SV, 'NIL') 'FI' ; SPOOL[I] ) ; 'PROC' SCAN = 'VOID' : 'IF' CH = " " # BLANKS AND BINARY OPERATORS # 'THEN' 'WHILE' NEXT CH ; CH = " " 'DO' 'SKIP' 'OD' ; # IGNORE TRAILING BLANKS IN A STATEMENT # 'IF' CH = ";" 'THEN' NEXT CH ; STN := STN + 1 ; TOK := EOS 'ELIF' CH = "#" 'THEN' NEXT CH ; TOK := EOS 'ELIF' CH = "!" 'OR' CH = "$" 'OR' CH = "+" 'OR' CH = "-" 'OR' CH = "*" 'OR' CH = "/" 'THEN' 'IF' CARD[CP+1] = " " 'THEN' C := CH ; 'WHILE' NEXT CH ; CH = " " 'DO' 'SKIP' 'OD' ; TOK := (C = "!" ! BBAR !: C = "$" ! BDOLL !: C = "-" ! BMINUS !: C = "+" ! BPLUS !: C = "*" ! BSTAR ! BSLASH) 'ELSE' TOK := BLANK 'FI' 'ELSE' TOK := BLANK 'FI' 'ELIF' CH = "'" 'OR' CH = """" # LITERAL STRINGS # 'THEN' C := CH ; SP := 0 ; 'WHILE' NEXT CH ; 'IF' CH = "#" 'THEN' ERROR ("UNTERMINATED LITERAL") 'FI' ; (STR [SP +:= 1] := CH) /= C 'DO' 'SKIP' 'OD' ; NEXT CH ; TOK := LSTRING ; 'IF' SP = 1 'THEN' PSN := 'NIL' 'ELSE' 'STRING' S = STR[1:SP-1] ; PSN := LOOKUP (S) 'FI' 'ELIF' CH >= "0" 'AND' CH <= "9" # NUMBERS # 'THEN' NV := 0 ; 'WHILE' NV := NV * 10 + 'ABS' CH - 'ABS' "0" ; NEXT CH ; CH >= "0" 'AND' CH <= "9" 'DO' 'SKIP' 'OD' ; TOK := NUMBER ; PSN := 'HEAP''ITEM' := NV 'ELIF' CH >= "A" 'AND' CH <= "Z" # NAMES # 'THEN' SP := 0 ; 'WHILE' STR [SP +:= 1] := CH ; NEXT CH ; CH = "." 'OR' CH >= "A" 'AND' CH <= "Z" 'OR' CH >= "0" 'AND' CH <= "9" 'DO' 'SKIP' 'OD' ; 'STRING' S = STR[1:SP] ; TOK := (S = "S" ! STOK !: S = "F" ! FTOK !: S = "END" ! ENDT !: S = "RETURN" ! RET !: S = "FRETURN" ! FRET ! PSN := LOOKUP (S) ; NAME) 'ELIF' CH = ";" 'THEN' NEXT CH ; STN := STN + 1 ; TOK := EOS 'ELIF' CH = "#" 'THEN' NEXT CH ; TOK := EOS 'ELSE' # ( ) , : = @ $ + - # TOK := CH ; NEXT CH 'FI' ; 'PROC' INIT = 'VOID' : ( STN := 0 ; LISTING := 'TRUE' ; SPOOL [NIN := 1] := 'HEAP''ITEM' := 'HEAP''STRINGITEM' := ("ARB", 'HEAP''ITEM' := 'HEAP'[1:3]'COMPONENT' := ( (MNUL, 2, 0, 'SKIP', 'NIL'), (MNUL, 0, 3, 'SKIP', 'NIL'), (M1, 2, 0, 'SKIP', 'NIL') ) ) ; GET CARD ; NEXT CH ; SCAN ) ; 'PROC' VERIFY = ('CHAR' TOKEN) 'VOID' : 'IF' TOK = TOKEN 'THEN' SCAN 'ELSE' 'STRING' S := "TOKEN "" "" DOES NOT OCCUR WHERE EXPECTED" ; S[8] := TOKEN ; ERROR (S) 'FI' ; 'PROC' TRANSLATE = 'VOID' : ( 'HEAP'[1:STLIM]'STMT' SS, 'INT' SSC := 0 ; 'WHILE' 'IF' SSC = STLIM 'THEN' ERROR ("TOO MANY STATEMENTS") 'FI' ; TOK /= ENDT 'DO' SS[SSC +:= 1] := TRANS STMT 'OD' ; SCAN ; 'IF' TOK = BLANK 'THEN' SCAN ; 'IF' TOK = NAME 'THEN' PROG ENTRY := PSN 'FI' 'FI' ; T := SS[1:SSC] ) ; 'PROC' TRANS STMT = 'STMT' : ( 'REF''IDR' LAB := 'NIL', 'REF''EXPR' SUBJ, PAT, OBJ := 'NIL', 'REF' 'GOTOFIELD' GO := 'NIL', 'BOOL' ASGN ; 'PROC' MOVE TO OBJ = 'STMT' : ( 'IF' TOK = BLANK 'THEN' SCAN ; 'IF' TOK = COLON 'THEN' GO := TRANS GOFIELD 'ELSE' OBJ := TRANS EXPR ; 'IF' TOK = COLON 'THEN' GO := TRANS GOFIELD 'ELSE' VERIFY (EOS) 'FI' 'FI' 'ELSE' VERIFY (EOS) 'FI' ; 'IF' ASGN 'THEN' 'STMT' (LAB, 'HEAP''ASMT' := (SUBJ, OBJ), GO) 'ELSE' 'STMT' (LAB, 'HEAP''REPL' := (SUBJ, PAT, OBJ), GO) 'FI' ) ; 'PROC' MOVE TO SUBJ = 'STMT' : ( SCAN ; 'IF' TOK = COLON 'THEN' 'STMT' (LAB, 'REF''EXPR' ('NIL'), TRANS GOFIELD) 'ELSE' SUBJ := TRANS ELEM ; 'IF' TOK = BLANK 'THEN' SCAN ; 'IF' TOK = COLON 'THEN' 'STMT' (LAB, 'REF''EXPR' (SUBJ), TRANS GOFIELD) 'ELIF' TOK = EQUAL 'THEN' ASGN := 'TRUE' ; SCAN ; MOVE TO OBJ 'ELSE' PAT := TRANS EXPR ; 'IF' TOK = COLON 'THEN' 'STMT' (LAB, 'HEAP''MATCH' := (SUBJ, PAT), TRANS GOFIELD) 'ELIF' TOK = EQUAL 'THEN' ASGN := 'FALSE' ; SCAN ; MOVE TO OBJ 'ELSE' VERIFY (EOS) ; 'STMT' (LAB, 'HEAP''MATCH' := (SUBJ, PAT), 'NIL') 'FI' 'FI' 'ELSE' VERIFY (EOS) ; 'STMT' (LAB, 'REF''EXPR' (SUBJ), 'NIL') 'FI' 'FI' ) ; # BODY OF TRANS STMT # 'IF' TOK = NAME 'THEN' LAB := 'HEAP''IDR' ; IDR ADDR 'OF' LAB := PSN ; SCAN ; 'IF' TOK = BLANK 'THEN' MOVE TO SUBJ 'ELSE' VERIFY (EOS) ; 'STMT' (LAB, 'REF''EXPR' ('NIL'), 'NIL') 'FI' 'ELIF' TOK = BLANK 'THEN' MOVE TO SUBJ 'ELSE' VERIFY (EOS) ; 'STMT' (LAB, 'REF''EXPR' ('NIL'), 'NIL') 'FI' ) ; 'PROC' TRANS GOFIELD = 'REF''GOTOFIELD' : ( 'PROC' WHERE = 'REF''DEST' : ( 'HEAP''DEST' D ; VERIFY (LPAR) ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ; D := (TOK = ENDT ! SCAN ; "E" !: TOK = RET ! SCAN ; "R" !: TOK = FRET ! SCAN ; "F" ! TRANS EXPR) ; VERIFY (RPAR) ; D ) ; 'REF''DEST' UNCOND := 'NIL', SUCC := 'NIL', FAIL := 'NIL' ; SCAN ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ; 'IF' TOK = STOK 'THEN' SCAN ; SUCC := WHERE ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ; 'IF' TOK = FTOK 'THEN' SCAN ; FAIL := WHERE 'FI' ; VERIFY (EOS) 'ELIF' TOK = FTOK 'THEN' SCAN ; FAIL := WHERE ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ; 'IF' TOK = STOK 'THEN' SCAN ; SUCC := WHERE 'FI' ; VERIFY (EOS) 'ELSE' UNCOND := WHERE ; VERIFY (EOS) 'FI' ; 'HEAP''GOTOFIELD' := (UNCOND, SUCC, FAIL) ) ; 'PROC' TRANS EXPR = 'REF''EXPR' : ( 'REF''EXPR' E := TRANS EXPR1 ; 'WHILE' TOK = BBAR 'DO' SCAN ; E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS EXPR1, "!") 'OD' ; E ) ; 'PROC' TRANS EXPR1 = 'REF''EXPR' : ( 'REF''EXPR' E := TRANS EXPR2 ; 'WHILE' TOK = BLANK 'DO' SCAN; 'IF' TOK /= COLON 'AND' TOK /= RPAR 'AND' TOK /= COMMA 'AND' TOK /= EQUAL 'THEN' E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS EXPR2, "C") 'FI' 'OD' ; E ) ; 'PROC' TRANS EXPR2 = 'REF''EXPR' : ( 'REF''EXPR' E := TRANS TERM ; 'CHAR' OPR ; 'WHILE' TOK = BPLUS 'OR' TOK = BMINUS 'DO' OPR := (TOK = BPLUS ! "+" ! "-") ; SCAN ; E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS TERM, OPR) 'OD' ; E ) ; 'PROC' TRANS TERM = 'REF''EXPR' : ( 'REF''EXPR' E := TRANS TERM1 ; 'WHILE' TOK = BSLASH 'DO' SCAN ; E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS TERM1, "/") 'OD' ; E ) ; 'PROC' TRANS TERM1 = 'REF''EXPR' : ( 'REF''EXPR' E := TRANS TERM2 ; 'WHILE' TOK = BSTAR 'DO' SCAN ; E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS TERM2, "*") 'OD' ; E ) ; 'PROC' TRANS TERM2 = 'REF''EXPR' : ( 'REF''EXPR' E := TRANS ELEM ; 'WHILE' TOK = BDOLL 'DO' SCAN ; E := 'HEAP''EXPR' := 'HEAP''BINARYEXPR' := (E, TRANS ELEM, "$") 'OD' ; E ) ; 'PROC' TRANS ELEM = 'REF''EXPR' : 'IF' TOK = DOLL 'OR' TOK = PLUS 'OR' TOK = MINUS 'OR' TOK = AT 'THEN' 'CHAR' OPR = TOK ; SCAN ; 'HEAP''EXPR' := 'HEAP''UNARYEXPR' := (TRANS ELEMENT, OPR) 'ELSE' TRANS ELEMENT 'FI' ; 'PROC' TRANS ELEMENT = 'REF''EXPR' : 'IF' TOK = NAME 'THEN' 'IDR' N ; IDR ADDR 'OF' N := PSN ; SCAN ; 'IF' TOK /= LPAR 'THEN' 'HEAP''EXPR' := N 'ELSE' 'HEAP'[1:ARGLIM]'REF''EXPR' A, 'INT' AC := 0 ; 'WHILE' SCAN ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ; 'IF' AC = ARGLIM 'THEN' ERROR ( "TOO MANY ARGUMENTS IN FUNCTION CALL") 'FI' ; 'IF' 'NOT' (AC = 0 'AND' TOK = RPAR) 'THEN' A[AC +:= 1] := (TOK = COMMA 'OR' TOK = RPAR ! 'NIL' ! TRANS EXPR) 'FI' ; 'IF' TOK /= COMMA 'AND' TOK /= RPAR 'THEN' ERROR ( "ERROR IN ARGUMENT LIST") 'FI' ; TOK = COMMA 'DO' 'SKIP' 'OD' ; SCAN ; 'HEAP''EXPR' := 'HEAP''CALL' := (N, A[1:AC]) 'FI' 'ELIF' TOK = LSTRING 'THEN' 'LSTR' LS ; LSTR ADDR 'OF' LS := PSN ; SCAN ; 'HEAP''EXPR' := LS 'ELIF' TOK = NUMBER 'THEN' 'NUM' NU ; NUM ADDR 'OF' NU := PSN ; SCAN ; 'HEAP''EXPR' := NU 'ELSE' VERIFY (LPAR) ; 'IF' TOK = BLANK 'THEN' SCAN 'FI' ; 'REF''EXPR' E = TRANS EXPR ; VERIFY (RPAR) ; E 'FI' ; INIT ; TRANSLATE 'END' # TRANSLATION PHASE # ; 'BEGIN' # INTERPRETATION PHASE # 'OP' 'INTG' = ('REF''ITEM' A) 'INT' : (A ! ('INT' I) : I), 'STR' = ('REF''ITEM' A) 'REF''STRINGITEM' : (A ! ('REF''STRINGITEM' S) : S), 'PAT' = ('REF''ITEM' A) 'PATTERN' : (A ! ('PATTERN' P) : P) ; 'BOOL' FN SUCCESS ; 'PROC' INTERPRET = ('INT' STMT NO) 'VOID' : ( 'INT' SN := STMT NO ; 'BOOL' CYCLING := 'TRUE' ; 'PROC' JUMP = ('REF''DEST' DEST) 'VOID' : ( FAILED := 'FALSE' ; 'CASE' DEST 'IN' ('REF''EXPR' E) : SN := FIND LABEL (EVAL SOFTLY (E)), ('CHAR' C) : 'IF' C = "E" 'THEN' SN := 'UPB' T + 1 'ELIF' C = "R" 'THEN' FN SUCCESS := 'TRUE' ; CYCLING := 'FALSE' 'ELSE' # C = "F" # FN SUCCESS := CYCLING := 'FALSE' 'FI' 'ESAC' ) ; 'WHILE' CYCLING 'DO' 'IF' SN > 'UPB' T 'THEN' STOP 'FI' ; FAILED := 'FALSE' ; # EXECUTE STATEMENT CORE # 'CASE' STMT CORE 'OF' T[SN] 'IN' ('REF''ASMT' A) : ( 'REF''ITEM' SP = EVAL SOFTLY (SUBJECT 'OF' A) ; ASSIGN (SP, EVAL STRONGLY (OBJECT 'OF' A)) ), ('REF''MATCH' M) : ( 'REF''ITEM' SVP = EVAL STRONGLY (SUBJECT 'OF' M) ; MATCH (CONVERT TO STR (SVP), CONVERT TO PAT ( EVAL STRONGLY (PATTERN 'OF' M))) ), ('REF''REPL' R) : ( 'REF''ITEM' SP = EVAL SOFTLY (SUBJECT 'OF' R) ; 'REF''ITEM' PP = CONVERT TO PAT (EVAL STRONGLY ( PATTERN 'OF' R)) ; 'REF''ITEM' SVP = CONVERT TO STR (REF 'OF' ('STR' SP)) ; 'INT' C = MATCH (SVP, PP) ; 'REF''ITEM' B = (SVP 'IS' 'NIL' ! 'NIL' ! MAKE STR ((VAL 'OF' ('STR' SVP)) [C+1:])) ; 'REF''ITEM' OBP = EVAL STRONGLY (OBJECT 'OF' R) ; ASSIGN (SP, CONCATENATE (OBP, B)) ), ('REF''EXPR' E) : EVAL STRONGLY (E) 'ESAC' ; # PROCESS GOTO FIELD # 'REF''GOTOFIELD' GO = GOTO 'OF' T[SN] ; 'IF' GO 'IS' 'NIL' 'THEN' SN := SN + 1 'ELIF' 'REF''DEST' (UPART 'OF' GO) 'ISNT' 'NIL' 'THEN' JUMP (UPART 'OF' GO) 'ELIF' 'NOT' FAILED 'AND' ('REF''DEST' (SPART 'OF' GO) 'ISNT' 'NIL') 'THEN' JUMP (SPART 'OF' GO) 'ELIF' FAILED 'AND' ('REF''DEST' (FPART 'OF' GO) 'ISNT' 'NIL') 'THEN' JUMP (FPART 'OF' GO) 'ELSE' SN := SN + 1 'FI' 'OD' ) # END OF INTERPRET # ; 'PROC' FIND LABEL = ('REF''ITEM' LABEL PTR) 'INT' : ( 'INT' STMT NO := 0 ; 'IF' FAILED 'THEN' ERROR ("FAILURE IN GOTO FIELD") 'FI' ; 'FOR' I 'TO' 'UPB' T 'WHILE' STMT NO = 0 'DO' 'IF' ('REF''IDR' (LABEL 'OF' T[I]) 'IS' 'NIL' ! 'FALSE' ! LABEL PTR 'IS' IDR ADDR 'OF' LABEL 'OF' T[I]) 'THEN' STMT NO := I 'FI' 'OD' ; 'IF' STMT NO = 0 'THEN' ERROR ("UNDEFINED LABEL") 'FI' ; STMT NO ) ; 'PROC' MATCH = ('REF''ITEM' SUBJECT PTR, PATTERN PTR) 'INT' : 'IF' FAILED 'THEN' 0 'ELSE' 'PATTERN' P = 'PAT' PATTERN PTR ; 'STRING' SUBJ = (SUBJECT PTR 'IS' 'NIL' ! "" ! VAL 'OF' ('STR' SUBJECT PTR)) ; 'INT' U = 'UPB' SUBJ ; 'INT' IARG # INTEGER COMPONENT ARGUMENT # , 'STRING' SARG # STRING COMPONENT ARGUMENT # , 'INT' L # LENGTH OF SARG # ; 'INT' CN := 1 # COMPONENT NUMBER # , C := 0 # CURSOR # , CODE # NEW CURSOR OR -1 IF COMPONENT NO-MATCH # ; 'BOOL' MATCHING := 'TRUE' ; PSP := 0 # CLEAR PATTERN STACK # ; 'WHILE' MATCHING 'DO' 'IF' ALTERNATE 'OF' P[CN] /= 0 'THEN' # PUSH PATTERN STACK # PATTERN STACK [PSP +:= 1] := (C, ALTERNATE 'OF' P[CN]) 'FI' ; 'IF' 'REF''ITEM' (ARG 'OF' P[CN]) 'ISNT' 'NIL' 'THEN' 'CASE' ARG 'OF' P[CN] 'IN' ('INT' I) : IARG := I, ('REF''STRINGITEM' S) : ( SARG := VAL 'OF' S ; L := 'UPB' SARG ) 'ESAC' 'FI' ; # EXECUTE INDICATED MATCHING ROUTINE # 'CASE' ROUTINE 'OF' P[CN] 'IN' #MSTR # 'IF' 'REF''ITEM'(ARG 'OF' P[CN]) 'IS' 'NIL' 'THEN' CODE := C 'ELIF' C + L > U 'THEN' CODE := -1 'ELSE' CODE := (SARG = SUBJ[C+1:C+L] ! C + L ! -1) 'FI', # MLEN # CODE := (IARG <= U - C ! C + IARG ! -1), # MBRK # 'IF' C >= U 'THEN' CODE := -1 'ELSE' 'INT' N = BREAK SCAN (SUBJ[C+1:], SARG) ; CODE := (N < U - C ! C + N ! -1) 'FI', # MSPN # 'IF' C >= U 'THEN' CODE := -1 'ELIF' ANY (SARG, SUBJ[C+1]) 'THEN' 'INT' J := C + 1 ; 'FOR' I 'FROM' C + 2 'TO' U 'WHILE' ANY (SARG, SUBJ[I]) 'DO' J := I 'OD' ; CODE := J 'ELSE' CODE := -1 'FI', # MANY # 'IF' C >= U 'THEN' CODE := -1 'ELSE' CODE := (ANY (SARG, SUBJ[C+1]) ! C + 1 ! -1) 'FI', # MNUL # CODE := C, # MIV1 # CODE := EXTRA 'OF' P[CN] := C, # MIV2 # ( 'INT' M = EXTRA 'OF' P [CN - EXTRA 'OF' P[CN]] + 1 ; ASSIGN (ARG 'OF' P[CN], MAKE STR (SUBJ[M:C])) ; CODE := C ) , # M1 # CODE := (1 <= U - C ! C + 1 ! -1), # MAT # ( ASSIGN (ARG 'OF' P[CN], MAKE INT (C)) ; CODE := C ), # MPOS # CODE := (C = IARG ! C ! -1), # MTAB # CODE := (C <= IARG 'AND' IARG <= U ! IARG ! -1), # MRPOS # CODE := (U - C = IARG ! C ! -1), # MRTAB # CODE := (U - C >= IARG ! U - IARG ! -1), # MNTY # 'IF' C >= U 'THEN' CODE := -1 'ELSE' CODE := (ANY (SARG, SUBJ[C+1]) ! -1 ! C + 1) 'FI' 'ESAC' ; # DECIDE WHAT TO DO NEXT # 'IF' CODE >= 0 'THEN' 'IF' SUBSEQUENT 'OF' P[CN] = 0 'THEN' MATCHING := 'FALSE' #SUCCESSFUL TERMINATION # 'ELSE' CN := SUBSEQUENT 'OF' P[CN] ; C := CODE # CONTINUE # 'FI' 'ELIF' PSP = 0 'THEN' FAILED := 'TRUE' ; MATCHING := 'FALSE' # STMT FAILURE # 'ELSE' # POP PATTERN STACK TO BACKTRACK # CN := ALTERNATE 'OF' PATTERN STACK [PSP] ; C := CURSOR 'OF' PATTERN STACK [PSP] ; PSP := PSP - 1 'FI' 'OD' ; (FAILED ! 0 ! CODE) 'FI' # END OF MATCH PROCEDURE # ; 'PROC' ASSIGN = ('REF''ITEM' SUBJECT PTR, OBJECT PTR) 'VOID' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'REF''STRINGITEM' S = 'STR' SUBJECT PTR ; REF 'OF' S := OBJECT PTR ; 'IF' VAL 'OF' S = "OUTPUT" 'THEN' PRINT ( 'IF' OBJECT PTR 'IS' 'NIL' 'THEN' NEWLINE 'ELSE' 'CASE' OBJECT PTR 'IN' ('REF''STRINGITEM' R) : (VAL 'OF' R, NEWLINE), ('INT' I) : (WHOLE (I, 0), NEWLINE), ('PATTERN') : (ERROR ("ATTEMPT TO OUTPUT PATTERN") ; 'SKIP') 'ESAC' 'FI' ) 'FI' 'FI' ; 'PROC' EVAL SOFTLY = ('REF''EXPR' EXPRESSION) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'CASE' EXPRESSION # CAN NEVER BE NIL # 'IN' ('IDR' ID) : IDR ADDR 'OF' ID, ('REF''UNARYEXPR' UE) : 'IF' OPERATOR 'OF' UE = "$" 'THEN' 'REF''ITEM' R = CONVERT TO STR (EVAL STRONGLY ( OPERAND 'OF' UE)) ; 'IF' R 'IS' 'NIL' 'THEN' ERROR ("NULL RESULT WHERE VAR REQUIRED") ; 'SKIP' 'ELSE' R 'FI' 'ELSE' ERROR ("INAPPROPRIATE UNARY EXPR WHERE VAR REQUIRED") ; 'SKIP' 'FI' 'OUT' ERROR ("INAPPROPRIATE EXPR WHERE VAR REQUIRED") ; 'SKIP' 'ESAC' 'FI' ; 'PROC' EVAL STRONGLY = ('REF''EXPR' EXPRESSION) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELIF' EXPRESSION 'IS' 'NIL' 'THEN' 'NIL' 'ELSE' 'CASE' EXPRESSION 'IN' ('IDR' ID) : ( 'REF''STRINGITEM' S = 'STR' (IDR ADDR 'OF' ID) ; 'IF' VAL 'OF' S = "INPUT" 'THEN' 'STRING' LINE; 'FILE' STIN := STANDIN ; ON LOGICAL FILE END (STIN, ('REF''FILE' F) 'BOOL' : ( FAILED := 'TRUE' ; 'GOTO' EOF ; 'SKIP')) ; GET (STIN, (NEWLINE, LINE)) ; ASSIGN (IDR ADDR 'OF' ID, MAKE STR (LINE)) ; EOF : 'SKIP' 'FI' ; REF 'OF' S ), ('NUM' NBR) : NUM ADDR 'OF' NBR, ('LSTR' LS) : LSTR ADDR 'OF' LS, ('REF''UNARYEXPR' UE) : ( 'REF' 'ITEM' ARG PTR = (OPERATOR 'OF' UE = "@" ! EVAL SOFTLY ( OPERAND 'OF' UE) ! EVAL STRONGLY (OPERAND 'OF' UE)) ; EVAL UNARY (ARG PTR, OPERATOR 'OF' UE) ), ('REF''BINARYEXPR' BE) : ( 'REF''ITEM' ARG1 PTR = EVAL STRONGLY (OPERAND1 'OF' BE) ; 'REF''ITEM' ARG2 PTR = (OPERATOR 'OF' BE = "$" ! EVAL SOFTLY ( OPERAND2 'OF' BE) ! EVAL STRONGLY (OPERAND2 'OF' BE)) ; EVAL BINARY (ARG1 PTR, ARG2 PTR, OPERATOR 'OF' BE) ), ('REF''CALL' CL) : ( 'INT' N = 'UPB' ARGS 'OF' CL ; [1:N]'REF''ITEM' ARGLIST ; 'FOR' I 'TO' N 'DO' ARGLIST[I] := EVAL STRONGLY ((ARGS 'OF' CL)[I]) 'OD' ; EVAL CALL (IDR ADDR 'OF' FNNAME 'OF' CL, ARGLIST) ) 'ESAC' 'FI' ; 'PROC' EVAL UNARY = ('REF''ITEM' ARG PTR, 'CHAR' OPR) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'IF' OPR = "$" 'THEN' 'IF' ARG PTR 'IS' 'NIL' 'THEN' ERROR ("INDIRECTION APPLIED TO NULL STRING") ; 'SKIP' 'ELSE' REF 'OF' ('STR' CONVERT TO STR (ARG PTR)) 'FI' 'ELIF' OPR = "+" 'THEN' CONVERT TO INT (ARG PTR) 'ELIF' OPR = "-" 'THEN' 'INT' K = 'INTG' CONVERT TO INT (ARG PTR) ; MAKE INT (-K) 'ELSE' # OPR = "@" # MAKE PAT COMP (MAT, ARG PTR) 'FI' 'FI' ; 'PROC' EVAL BINARY = ('REF''ITEM' ARG1 PTR, ARG2 PTR, 'CHAR' OPR) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'IF' OPR = "$" 'THEN' 'REF''ITEM' C = CONCATENATE (MAKE PAT COMP (MIV1, 'NIL'), ARG1 PTR) ; CONCATENATE (C, MAKE PAT COMP (MIV2, ARG2 PTR)) 'ELIF' OPR = "*" 'OR' OPR = "/" 'OR' OPR = "+" 'OR' OPR = "-" 'THEN' 'INT' M = 'INTG' CONVERT TO INT (ARG1 PTR), N = 'INTG' CONVERT TO INT (ARG2 PTR) ; MAKE INT ((OPR = "*" ! M * N !: OPR = "/" ! M 'OVER' N !: OPR = "+" ! M + N ! M - N )) 'ELIF' OPR = "C" 'THEN' CONCATENATE (ARG1 PTR, ARG2 PTR) 'ELSE' # OPR = "!" # 'PATTERN' P1 = 'PAT' CONVERT TO PAT (ARG1 PTR), P2 = 'PAT' CONVERT TO PAT (ARG2 PTR) ; 'INT' U1 = 'UPB' P1, U2 = 'UPB' P2 ; 'PATTERN' P = 'HEAP'[U1 + U2]'COMPONENT', 'INT' OFFSET = U1 + 1, 'INT' J := 1 ; P[1:U1] := P1[1:U1]; 'WHILE' ALTERNATE 'OF' P[J] /= 0 'DO' J := ALTERNATE 'OF' P[J] 'OD' ; ALTERNATE 'OF' P[J] := OFFSET ; 'FOR' I 'FROM' OFFSET 'TO' U1 + U2 'DO' P[I] := P2 [I - U1] ; 'IF' SUBSEQUENT 'OF' P[I] /= 0 'THEN' SUBSEQUENT 'OF' P[I] +:= U1 'FI' ; 'IF' ALTERNATE 'OF' P[I] /= 0 'THEN' ALTERNATE 'OF' P[I] +:= U1 'FI' 'OD' ; 'HEAP''ITEM' := P 'FI' 'FI' ; 'PROC' EVAL CALL = ('REF''ITEM' NAME PTR, 'REF'[]'REF''ITEM' ARGLIST) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' # SEARCH FUNCTION TABLE FOR NAME # 'BOOL' NOT FOUND := 'TRUE', 'INT' J ; 'FOR' I 'TO' FTP 'WHILE' NOT FOUND 'DO' 'IF' NAME PTR 'IS' FNNAME 'OF' FUNCTION TABLE [I] 'THEN' J := I ; NOT FOUND := 'FALSE' 'FI' 'OD' ; 'IF' NOT FOUND 'THEN' EXEC PRIM FN (NAME PTR, ARGLIST) 'ELSE' #PROGRAMMER-DEFINED FUNCTION # 'PROC' STACK = ('REF''ITEM' A) 'VOID' : ( 'IF' RSP = RSLIM 'THEN' ERROR ("RUN STACK OVERFLOW") 'FI' ; RUN STACK [RSP +:= 1] := A ) ; 'PROC' UNSTACK = 'REF''ITEM' : ( 'IF' RSP = 0 'THEN' ERROR ("RETURN FROM LEVEL 0") 'FI' ; RUN STACK [(RSP -:= 1) + 1] ) ; 'REF''STRINGITEM' NAME = 'STR' NAME PTR ; # ENTRY PROTOCOL # STACK (REF 'OF' NAME) ; ASSIGN (NAME PTR, 'NIL') ; 'REF'[]'REF''ITEM' PARAMS = PARAMS 'OF' FUNCTION TABLE [J], 'INT' N = 'UPB' ARGLIST ; 'IF' 'UPB' PARAMS /= N 'THEN' ERROR ( "WRONG NUMBER OF ARGUMENTS IN CALL") 'FI' ; 'FOR' I 'TO' N 'DO' STACK (REF 'OF' ('STR' PARAMS[I])) ; ASSIGN (PARAMS[I], ARGLIST[I]) 'OD' ; 'REF'[]'REF''ITEM' LOCALS = LOCALS 'OF' FUNCTION TABLE [J] ; 'FOR' I 'TO' 'UPB' LOCALS 'DO' STACK (REF 'OF' ('STR' LOCALS[I])) ; ASSIGN (LOCALS[I], 'NIL') 'OD' ; INTERPRET (FIND LABEL (ENTRY NAME 'OF' FUNCTION TABLE [J])) ; # RETURN PROTOCOL # 'FOR' I 'FROM' 'UPB' LOCALS 'BY' -1 'TO' 1 'DO' ASSIGN (LOCALS[I], UNSTACK) 'OD' ; 'FOR' I 'FROM' N 'BY' -1 'TO' 1 'DO' ASSIGN (PARAMS[I], UNSTACK) 'OD' ; 'REF''ITEM' RESULT = REF 'OF' NAME ; ASSIGN (NAME PTR, UNSTACK) ; (FN SUCCESS ! RESULT ! FAILED := 'TRUE' ; 'SKIP') 'FI' 'FI' ; 'PROC' EXEC PRIM FN = ('REF''ITEM' NAME PTR, 'REF'[]'REF''ITEM' ARGLIST) 'REF''ITEM' : ( 'PROC' GEN1 = ('INT' ROUTINE) 'REF''ITEM' : ( # CREATE PATTERN COMPONENT WITH STRING ARGUMENT # 'REF''ITEM' ARG = CONVERT TO STR (ARGLIST[1]) ; 'IF' ARG 'IS' 'NIL' 'THEN' ERROR ( "NULL ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION" ) 'FI' ; MAKE PAT COMP (ROUTINE, ARG) ) ; 'PROC' GEN2 = ('INT' ROUTINE) 'REF''ITEM' : ( # CREATE PATTERN COMPONENT WITH INTEGER ARGUMENT # 'REF''ITEM' ARG = CONVERT TO INT (ARGLIST[1]) ; 'IF' 'INTG' ARG < 0 'THEN' ERROR ( "NEGATIVE ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION") 'FI' ; MAKE PAT COMP (ROUTINE, ARG) ) ; 'STRING' FN = VAL 'OF' ('STR' NAME PTR), 'INT' N = 'UPB' ARGLIST ; 'IF' FN = "LE" 'AND' N = 2 'THEN' 'IF' 'INTG' CONVERT TO INT (ARGLIST[1]) <= 'INTG' CONVERT TO INT ( ARGLIST[2]) 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI' 'ELIF' FN = "EQ" 'AND' N = 2 'THEN' 'IF' 'INTG' CONVERT TO INT (ARGLIST[1]) = 'INTG' CONVERT TO INT ( ARGLIST[2]) 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI' 'ELIF' FN = "NE" 'AND' N = 2 'THEN' 'IF' 'INTG' CONVERT TO INT (ARGLIST[1]) /= 'INTG' CONVERT TO INT ( ARGLIST[2]) 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI' 'ELIF' FN = "IDENT" 'AND' N = 2 'THEN' 'IF' 'REF''ITEM' (ARGLIST[1]) 'IS' ARGLIST[2] 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI' 'ELIF' FN = "DIFFER" 'AND' N = 2 'THEN' 'IF' 'REF''ITEM' (ARGLIST[1]) 'ISNT' ARGLIST[2] 'THEN' 'NIL' 'ELSE' FAILED := 'TRUE' ; 'SKIP' 'FI' 'ELIF' FN = "ANY" 'AND' N = 1 'THEN' GEN1 (MANY) 'ELIF' FN = "LEN" 'AND' N = 1 'THEN' GEN2 (MLEN) 'ELIF' FN = "POS" 'AND' N = 1 'THEN' GEN2 (MPOS) 'ELIF' FN = "TAB" 'AND' N = 1 'THEN' GEN2 (MTAB) 'ELIF' FN = "SPAN" 'AND' N = 1 'THEN' GEN1 (MSPN) 'ELIF' FN = "RPOS" 'AND' N = 1 'THEN' GEN2 (MRPOS) 'ELIF' FN = "RTAB" 'AND' N = 1 'THEN' GEN2 (MRTAB) 'ELIF' FN = "BREAK" 'AND' N = 1 'THEN' GEN1 (MBRK) 'ELIF' FN = "NOTANY" 'AND' N = 1 'THEN' GEN1 (MNTY) 'ELIF' FN = "SIZE" 'AND' N = 1 'THEN' MAKE INT ('UPB' VAL 'OF' ('STR' CONVERT TO STR (ARGLIST[1]))) 'ELIF' FN = "DEFINE" 'AND' N = 2 'THEN' 'IF' 'REF''ITEM' (ARGLIST[1]) 'IS' 'NIL' 'THEN' ERROR ( "NULL PROTOTYPE") 'FI' ; 'STRING' PROTOTYPE = VAL 'OF' ('STR' CONVERT TO STR (ARGLIST[1])); 'REF''ITEM' ENTRY = CONVERT TO STR (ARGLIST[2]) ; 'IF' ENTRY 'IS' 'NIL' 'THEN' ERROR ("NULL ENTRY LABEL") 'FI' ; 'PROC' CHECK AND FIND = ('STRING' STR) 'REF''ITEM' : ( 'IF' 'UPB' STR = 0 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' ; 'STRING' AN = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789." ; 'IF' 'NOT' ANY (AN[:26], STR[1]) 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' ; 'FOR' I 'FROM' 2 'TO' 'UPB' STR 'DO' 'IF' 'NOT' ANY (AN, STR[I]) 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' 'OD' ; MAKE STR (STR) ) ; 'PROC' BREAKUP = ('STRING' STR) 'REF'[]'REF''ITEM' : ( #ANALYZE A LIST OF IDENTIFIERS # [1:ARGLIM]'REF''ITEM' R, 'INT' P := 0, A := 1, B ; 'WHILE' A <= 'UPB' STR 'DO' B := BREAK SCAN (STR[A:], ",") ; 'IF' P >= ARGLIM 'THEN' ERROR ( "TOO MANY PARAMETERS OR LOCALS IN PROTOTYPE") 'FI' ; R [P +:= 1] := CHECK AND FIND (STR[A:A+B-1]) ; A := A + B + 1 'OD' ; 'HEAP'[1:P]'REF''ITEM' := R[:P] ) ; 'INT' LP = 'UPB' PROTOTYPE ; 'INT' A = BREAK SCAN (PROTOTYPE, "(") ; 'IF' A >= LP 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' ; 'REF''ITEM' NAME PTR = CHECK AND FIND (PROTOTYPE[:A]) ; 'INT' B = BREAK SCAN (PROTOTYPE[A+2:], ")") ; 'IF' B >= LP - A - 1 'THEN' ERROR ("ILLEGAL PROTOTYPE") 'FI' ; 'REF'[]'REF''ITEM' PARAMS = BREAKUP (PROTOTYPE[A+2:A+1+B]) ; 'REF'[]'REF''ITEM' LOCALS = BREAKUP (PROTOTYPE[A+B+3:]) ; 'BOOL' NOT FOUND := 'TRUE' ; 'FOR' I 'TO' FTP 'WHILE' NOT FOUND 'DO' 'IF' NAME PTR 'IS' FNNAME 'OF' FUNCTION TABLE [I] 'THEN' NOT FOUND := 'FALSE' ; FUNCTION TABLE [I] := (NAME PTR, ENTRY, PARAMS, LOCALS) 'FI' 'OD' ; 'IF' NOT FOUND 'THEN' 'IF' FTP = FTLIM 'THEN' ERROR ( "FUNCTION TABLE OVERFLOW") 'FI' ; FUNCTION TABLE [FTP +:= 1] := (NAME PTR, ENTRY, PARAMS, LOCALS) 'FI' ; 'NIL' # RESULT OF DEFINE(...) # 'ELSE' ERROR ("ILLEGAL FUNCTION CALL") ; 'SKIP' 'FI' ) ; 'PROC' CONCATENATE = ('REF''ITEM' PTR1, PTR2) 'REF''ITEM' : ( 'PROC' CONCAT PATTERNS = ('PATTERN' P1, P2) 'REF''ITEM' : ( 'INT' U1 = 'UPB' P1, U2 = 'UPB' P2 ; 'PATTERN' P = 'HEAP'[U1 + U2]'COMPONENT' ; 'INT' OFFSET = U1 + 1 ; 'FOR' I 'TO' U1 'DO' P[I] := P1[I] ; 'IF' SUBSEQUENT 'OF' P[I] = 0 'THEN' SUBSEQUENT 'OF' P[I] := OFFSET 'FI' 'OD' ; 'FOR' I 'FROM' OFFSET 'TO' U1 + U2 'DO' P[I] := P2 [I - U1] ; 'IF' SUBSEQUENT 'OF' P[I] /= 0 'THEN' SUBSEQUENT 'OF' P[I] +:= U1 'FI' ; 'IF' ALTERNATE 'OF' P[I] /= 0 'THEN' ALTERNATE 'OF' P[I] +:= U1 'FI' 'OD' ; 'IF' U2 = 1 'AND' ROUTINE 'OF' P[OFFSET] = MIV2 'THEN' EXTRA 'OF' P[OFFSET] := U1 'FI' ; 'HEAP''ITEM' := P ) ; 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'IF' PTR1 'IS' 'NIL' 'THEN' PTR2 'ELIF' PTR2 'IS' 'NIL' 'THEN' PTR1 'ELSE' 'CASE' PTR1 'IN' ('PATTERN' P1) : CONCAT PATTERNS (P1, 'PAT' CONVERT TO PAT (PTR2)) 'OUSE' PTR2 'IN' ('PATTERN' P2) : CONCAT PATTERNS ('PAT' CONVERT TO PAT (PTR1), P2) 'OUT' 'STRING' S1 = VAL 'OF' ('STR' CONVERT TO STR (PTR1)) ; MAKE STR (S1 + VAL 'OF' ('STR' CONVERT TO STR (PTR2))) 'ESAC' 'FI' 'FI' ) ; 'PROC' CONVERT TO INT = ('REF''ITEM' PTR) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'IF' PTR 'IS' 'NIL' 'THEN' MAKE INT (0) 'ELSE' 'CASE' PTR 'IN' ('INT') : PTR, ('PATTERN') : (ERROR ( "PATTERN VALUE WHERE INTEGER REQUIRED") ; 'SKIP'), ('REF''STRINGITEM' S) : ( 'INT' N := 0, D, Z := 'ABS' "0" ; 'FOR' I 'TO' 'UPB' VAL 'OF' S 'DO' D := 'ABS' (VAL 'OF' S)[I] - Z ; 'IF' D < 0 'OR' D > 9 'THEN' ERROR ( "STRING NOT CONVERTIBLE TO INTEGER") 'FI' ; N := N * 10 + D 'OD' ; MAKE INT (N) ) 'ESAC' 'FI' 'FI' ; 'PROC' CONVERT TO PAT = ('REF''ITEM' PTR) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'IF' PTR 'IS' 'NIL' 'THEN' MAKE PAT COMP (MSTR, 'NIL') 'ELSE' 'CASE' PTR 'IN' ('PATTERN') : PTR 'OUT' MAKE PAT COMP (MSTR, CONVERT TO STR (PTR)) 'ESAC' 'FI' 'FI' ; 'PROC' CONVERT TO STR = ('REF''ITEM' PTR) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'IF' PTR 'IS' 'NIL' 'THEN' PTR 'ELSE' 'CASE' PTR 'IN' ('REF''STRINGITEM') : PTR, ('PATTERN') : (ERROR ( "PATTERN VALUE WHERE STRING REQUIRED") ; 'SKIP'), ('INT' I) : MAKE STR (WHOLE (I, 0)) 'ESAC' 'FI' 'FI' ; 'PROC' MAKE INT = ('INT' VAL) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'HEAP''ITEM' := VAL 'FI' ; 'PROC' MAKE PAT COMP = ('INT' ROUTINE, 'REF''ITEM' ARG) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELSE' 'HEAP''ITEM' := 'HEAP'[1:1]'COMPONENT' := 'COMPONENT' (ROUTINE, 0, 0, 'SKIP', ARG) 'FI' ; 'PROC' MAKE STR = ('STRING' VAL) 'REF''ITEM' : 'IF' FAILED 'THEN' 'SKIP' 'ELIF' 'UPB' VAL = 0 'THEN' 'NIL' 'ELSE' 'INT' I := 0, 'BOOL' NF := 'TRUE' ; 'WHILE' 'IF' (I +:= 1) <= NIN 'THEN' NF := VAL /= VAL 'OF' ('STR' SPOOL[I]) 'ELSE' 'FALSE' 'FI' 'DO' 'SKIP' 'OD' ; 'IF' NF 'THEN' 'IF' NIN = SPOOLSIZE 'THEN' ERROR ("TOO MANY STRINGS") 'FI' ; SPOOL [NIN +:= 1] := 'HEAP''ITEM' := 'HEAP''STRINGITEM' := (VAL, 'NIL') 'FI' ; SPOOL[I] 'FI' ; 'PROC' BREAK SCAN = ('STRING' STR, ARG) 'INT' : ( # RESULT = 'UPB' STR IF NO BREAK CHAR, LESS OTHERWISE # 'INT' J := 0 ; 'FOR' I 'TO' 'UPB' STR 'WHILE' 'NOT' ANY (ARG, STR[I]) 'DO' J := I 'OD' ; J ) ; 'PROC' ANY = ('STRING' STR, 'CHAR' CH) 'BOOL' : ( 'BOOL' NF ; 'FOR' I 'TO' 'UPB' STR 'WHILE' NF := CH /= STR[I] 'DO' 'SKIP' 'OD' ; 'NOT' NF ) ; PRINT ((NEWLINE, NEWLINE, NEWLINE)) ; INTERPRET (('REF''ITEM'(PROG ENTRY) 'IS' 'NIL' ! 1 ! FIND LABEL (PROG ENTRY))) 'END' # INTERPRETATION PHASE # 'END'