C ALGORITHM 628 COLLECTED ALGORITHMS FROM ACM. C ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.11, NO. 1, C MAR., 1985, P. 66. C*-*-*-*-*-*ADD3 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ADD 10 SUBROUTINE ADD3(A, B, C) ADD 20 COMMON /TR3/ BETA, THETA INTEGER BETA, THETA, A, B, C, D D = A + B + C A = D/BETA B = MOD(D,BETA) RETURN END C*-*-*-*-*-*ALTER *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ALT 10 SUBROUTINE ALTER(A, L) ALT 20 COMMON /S/ SPACE(20000) INTEGER SPACE, A, L SPACE(L+1) = A RETURN END C*-*-*-*-*-*AND *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-AND 10 INTEGER FUNCTION AND(XX, YY) AND 20 INTEGER B, X, XB, XX, X1, Y, YB, YY, Y1, Z X = XX Y = YY Z = 0 B = 1 10 IF (X.EQ.0 .OR. Y.EQ.0) GO TO 20 X1 = X/2 XB = X - 2*X1 Y1 = Y/2 YB = Y - 2*Y1 IF (XB*YB.GT.0) Z = Z + B X = X1 Y = Y1 B = 2*B GO TO 10 20 AND = Z RETURN END C*-*-*-*-*-*BEGIN *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-BEG 10 SUBROUTINE BEGIN BEG 20 COMMON /S/ SPACE(20000) COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER SPACE, AVAIL, STAK, RECORD I = 19999 10 SPACE(I) = I + 2 SPACE(I+1) = 0 I = I - 2 IF (I.GT.0) GO TO 10 SPACE(19999) = 0 AVAIL = 1 STAK = 0 RETURN END C*-*-*-*-*-*COUNT *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-COU 10 INTEGER FUNCTION COUNT(L) COU 20 COMMON /S/ SPACE(20000) INTEGER SPACE, L, W, W1 W = SPACE(L) W1 = W/1048576 COUNT = MOD(W1,1024) RETURN END C*-*-*-*-*-*DLREAD *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-DLR 10 INTEGER FUNCTION DLREAD(U) DLR 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER A, C, P, S, T, U, PFA, PFL L = 0 M = 0 I = 1 CALL READ(U, RECORD) C = RECORD(1) DLREAD = -1 IF (C.EQ.-1) RETURN IF (C.NE.40) GO TO 130 10 P = C I = I + 1 IF (I.LE.72) GO TO 20 I = 1 CALL READ(U, RECORD) 20 C = RECORD(I) IF (C.EQ.40) GO TO 30 IF (C.EQ.41) GO TO 40 IF (C.EQ.42) GO TO 50 IF (C.EQ.36 .OR. C.EQ.37) GO TO 60 IF (C.LE.9) GO TO 70 GO TO 130 30 IF (P.EQ.40 .OR. P.EQ.42) GO TO 80 GO TO 130 40 IF (P.EQ.40 .OR. P.EQ.41) GO TO 90 IF (P.LE.9) GO TO 120 GO TO 130 50 IF (P.LE.9) GO TO 120 IF (P.EQ.41) GO TO 10 GO TO 130 60 IF (P.EQ.40 .OR. P.EQ.42) GO TO 100 GO TO 130 70 IF (P.LE.9 .OR. P.EQ.36 .OR. P.EQ.37) GO TO 110 IF (P.EQ.40 .OR. P.EQ.42) GO TO 100 GO TO 130 80 M = PFL(L,M) L = 0 GO TO 10 90 L = INV(L) DLREAD = L IF (M.EQ.0) RETURN CALL DECAP(T, M) L = PFL(L,T) GO TO 10 100 S = 1 IF (C.EQ.37) S = -1 A = 0 IF (C.LE.9) A = C GO TO 10 110 A = 10*A + C GO TO 10 120 A = S*A L = PFA(A,L) IF (C.EQ.41) GO TO 90 GO TO 10 130 CALL ERASE(L) CALL ERASE(M) DLREAD = -2 RETURN END C*-*-*-*-*-*DLWRIT *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-DLW 10 SUBROUTINE DLWRIT(U, L) DLW 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER C, E, T, U, PFA, PFL, TYPE K = L M = 0 I = 1 C = 40 GO TO 80 10 IF (K.NE.0) GO TO 20 C = 41 GO TO 80 20 T = TYPE(K) CALL ADV(E, K) IF (T.EQ.0) GO TO 50 M = PFL(K,M) K = E C = 40 GO TO 80 30 IF (M.EQ.0) GO TO 100 CALL DECAP(K, M) 40 IF (K.EQ.0) C = 41 IF (K.NE.0) C = 42 GO TO 80 50 C = 36 IF (E.LT.0) C = 37 IF (E.LT.0) E = -E T = 0 GO TO 80 60 C = MOD(E,10) T = PFA(C,T) E = E/10 IF (E.NE.0) GO TO 60 70 IF (T.EQ.0) GO TO 40 CALL DECAP(C, T) 80 IF (I.LE.72) GO TO 90 CALL WRITE(U, RECORD) I = 1 90 RECORD(I) = C I = I + 1 IF (C.LE.9) GO TO 70 IF (C.EQ.36 .OR. C.EQ.37) GO TO 60 IF (C.EQ.40) GO TO 10 IF (C.EQ.41) GO TO 30 GO TO 20 100 IF (I.EQ.73) GO TO 110 RECORD(I) = 44 I = I + 1 GO TO 100 110 CALL WRITE(U, RECORD) RETURN END C*-*-*-*-*-*FIRST *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-FIR 10 INTEGER FUNCTION FIRST(L) FIR 20 COMMON /S/ SPACE(20000) INTEGER SPACE, L FIRST = SPACE(L+1) RETURN END C*-*-*-*-*-*INITIO *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-INI 10 SUBROUTINE INITIO(U) INI 20 COMMON /PR1/ MCODE(47), SCODE(47), TABLE(47) INTEGER U, MCODE, SCODE, TABLE, PRINT, S, C DATA S /0/ DATA PRINT /6/ 99999 FORMAT (47A1) 99998 FORMAT (20H INCORRECT CODE CARD) IF (S.NE.0) RETURN S = 1 READ (U,99999) MCODE DO 10 I=1,47 SCODE(I) = I - 1 10 CONTINUE J = 46 20 DO 40 I=1,J IF (MCODE(I).LT.0 .AND. MCODE(I+1).GT.0) GO TO 40 IF (MCODE(I).GT.0 .AND. MCODE(I+1).LT.0) GO TO 30 IF (MCODE(I).LE.MCODE(I+1)) GO TO 40 30 C = MCODE(I) MCODE(I) = MCODE(I+1) MCODE(I+1) = C C = SCODE(I) SCODE(I) = SCODE(I+1) SCODE(I+1) = C 40 CONTINUE J = J - 1 IF (J.GE.1) GO TO 20 DO 50 I=1,46 IF (MCODE(I).EQ.MCODE(I+1)) GO TO 70 50 CONTINUE DO 60 I=1,47 J = SCODE(I) + 1 TABLE(J) = MCODE(I) 60 CONTINUE RETURN 70 WRITE (PRINT,99998) STOP END C*-*-*-*-*-*MPY *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-MPY 10 SUBROUTINE MPY(A, B) MPY 20 COMMON /TR3/ BETA, THETA INTEGER BETA, THETA, A, B, C C = A*B A = C/BETA B = MOD(C,BETA) RETURN END C*-*-*-*-*-*OR *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-OR 10 INTEGER FUNCTION OR(XX, YY) OR 20 INTEGER B, X, XB, XX, X1, Y, YB, YY, Y1, Z X = XX Y = YY Z = 0 B = 1 10 IF (X.EQ.0) GO TO 20 IF (Y.EQ.0) GO TO 30 X1 = X/2 XB = X - 2*X1 Y1 = Y/2 YB = Y - 2*Y1 IF (XB+YB.GT.0) Z = Z + B X = X1 Y = Y1 B = 2*B GO TO 10 20 OR = Z + Y*B RETURN 30 OR = Z + X*B RETURN END C*-*-*-*-*-*QR *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-QR 10 SUBROUTINE QR(A, B, C) QR 20 COMMON /TR3/ BETA, THETA INTEGER BETA, THETA, A, B, C, D D = A*BETA + B A = D/C B = MOD(D,C) RETURN END C*-*-*-*-*-*READ *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-REA 10 SUBROUTINE READ(U, A) REA 20 COMMON /PR1/ MCODE(47), SCODE(47), TABLE(47) DIMENSION A(72) INTEGER U, A, MCODE, SCODE, TABLE, PRINT, C DATA PRINT /6/ 99999 FORMAT (72A1) 99998 FORMAT (24H INVALID INPUT CHARACTER) CALL INITIO(U) READ (U,99999) A DO 40 I=1,72 C = A(I) J = 1 K = 32 10 L = J + K IF (L.GT.47) GO TO 30 IF (C.LT.0 .AND. MCODE(L).GT.0) GO TO 30 IF (C.GT.0 .AND. MCODE(L).LT.0) GO TO 20 IF (C.LT.MCODE(L)) GO TO 30 20 J = L 30 K = K/2 IF (K.NE.0) GO TO 10 IF (C.NE.MCODE(J)) GO TO 50 A(I) = SCODE(J) 40 CONTINUE RETURN 50 WRITE (PRINT,99998) STOP END C*-*-*-*-*-*SCOUNT *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-SCO 10 SUBROUTINE SCOUNT(C, L) SCO 20 COMMON /S/ SPACE(20000) INTEGER SPACE, C, L, W, S, T, W1 W = SPACE(L) S = MOD(W,1048576) T = W/1073741824 W1 = 1024*T + C W = 1048576*W1 + S SPACE(L) = W RETURN END C*-*-*-*-*-*SSUCC *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-SSU 10 SUBROUTINE SSUCC(S, L) SSU 20 COMMON /S/ SPACE(20000) INTEGER SPACE, S, L, W, T W = SPACE(L) T = W/1048576 W = 1048576*T + S SPACE(L) = W RETURN END C*-*-*-*-*-*STYPE *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-STY 10 SUBROUTINE STYPE(T, L) STY 20 COMMON /S/ SPACE(20000) INTEGER SPACE, T, L, W, W1 W = SPACE(L) W1 = MOD(W,1073741824) W = 1073741824*T + W1 SPACE(L) = W RETURN END C*-*-*-*-*-*TAIL *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-TAI 10 INTEGER FUNCTION TAIL(L) TAI 20 COMMON /S/ SPACE(20000) INTEGER SPACE, L, W W = SPACE(L) TAIL = MOD(W,1048576) RETURN END C*-*-*-*-*-*TYPE *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-TYP 10 INTEGER FUNCTION TYPE(L) TYP 20 COMMON /S/ SPACE(20000) INTEGER SPACE, L, W W = SPACE(L) TYPE = W/1073741824 RETURN END C*-*-*-*-*-*WRITE *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-WRI 10 SUBROUTINE WRITE(U, A) WRI 20 COMMON /PR1/ MCODE(47), SCODE(47), TABLE(47) DIMENSION A(72) INTEGER U, A, MCODE, SCODE, TABLE, PRINT DATA PRINT /6/ 99999 FORMAT (72A1) 99998 FORMAT (73A1) 99997 FORMAT (25H INVALID OUTPUT CHARACTER) CALL INITIO(U) DO 20 I=1,72 J = A(I) IF (J.GE.0 .AND. J.LE.46) GO TO 10 WRITE (PRINT,99997) STOP 10 J = J + 1 A(I) = TABLE(J) 20 CONTINUE IF (U.EQ.PRINT) GO TO 30 WRITE (U,99999) A RETURN 30 WRITE (PRINT,99998) TABLE(45), A RETURN END C*-*-*-*-*-*ADV *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ADV 10 SUBROUTINE ADV(EL, LOC) ADV 20 INTEGER EL, LOC, L, TAIL, FIRST L = LOC EL = FIRST(L) LOC = TAIL(L) RETURN END C*-*-*-*-*-*ADV2 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ADV 10 SUBROUTINE ADV2(A, B, L) ADV 20 INTEGER A, B CALL ADV(A, L) CALL ADV(B, L) RETURN END C*-*-*-*-*-*BORROW *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-BOR 10 INTEGER FUNCTION BORROW(LIST) BOR 20 INTEGER COUNT BORROW = LIST IF (BORROW.EQ.0) RETURN CALL SCOUNT(COUNT(BORROW)+1, BORROW) RETURN END C*-*-*-*-*-*CINV *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-CIN 10 INTEGER FUNCTION CINV(X) CIN 20 INTEGER TYPE, PFA, PFL, BORROW INTEGER X, Z, R, E, T Z = 0 R = X 10 IF (R.EQ.0) GO TO 30 T = TYPE(R) CALL ADV(E, R) IF (T.EQ.1) GO TO 20 Z = PFA(E,Z) GO TO 10 20 Z = PFL(BORROW(E),Z) GO TO 10 30 CINV = Z RETURN END C*-*-*-*-*-*CONC *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-CON 10 INTEGER FUNCTION CONC(X, Y) CON 20 INTEGER X, Y, XAD, XNEXT, XSUC, TAIL CONC = Y XSUC = CONC XNEXT = X IF (XNEXT.EQ.0) RETURN CONC = XNEXT IF (XSUC.EQ.0) RETURN 10 XAD = XNEXT XNEXT = TAIL(XNEXT) IF (XNEXT.NE.0) GO TO 10 CALL SSUCC(XSUC, XAD) RETURN END C*-*-*-*-*-*DECAP *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-DEC 10 SUBROUTINE DECAP(EL, LOC) DEC 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER B, EL, TAIL, FIRST B = AVAIL AVAIL = LOC EL = FIRST(AVAIL) LOC = TAIL(AVAIL) CALL SSUCC(B, AVAIL) CALL SCOUNT(0, AVAIL) RETURN END C*-*-*-*-*-*DECAP2 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-DEC 10 SUBROUTINE DECAP2(A, B, L) DEC 20 INTEGER A, B CALL DECAP(A, L) CALL DECAP(B, L) RETURN END C*-*-*-*-*-*ERASE *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ERA 10 SUBROUTINE ERASE(XX) ERA 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER COUNT, FIRST, TAIL, TYPE INTEGER X, XX, T, BIN X = XX BIN = 0 10 IF (X.EQ.0) GO TO 20 K = COUNT(X) - 1 CALL SCOUNT(K, X) IF (K.GT.0) GO TO 20 IF (TYPE(X).EQ.1) GO TO 30 T = TAIL(X) CALL SSUCC(AVAIL, X) AVAIL = X X = T GO TO 10 20 IF (BIN.EQ.0) RETURN X = FIRST(BIN) T = TAIL(BIN) CALL SSUCC(AVAIL, BIN) AVAIL = BIN BIN = T GO TO 10 30 T = TAIL(X) CALL SSUCC(BIN, X) BIN = X X = T GO TO 10 END C*-*-*-*-*-*ERLA *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ERL 10 SUBROUTINE ERLA(X) ERL 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER X, U, V, TAIL, COUNT IF (X.EQ.0) GO TO 30 U = 0 V = X 10 N = COUNT(V) - 1 CALL SCOUNT(N, V) IF (N.NE.0) GO TO 20 U = V V = TAIL(V) IF (V.NE.0) GO TO 10 20 IF (U.EQ.0) GO TO 30 CALL SSUCC(AVAIL, U) AVAIL = X 30 RETURN END C*-*-*-*-*-*FIRST2 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-FIR 10 SUBROUTINE FIRST2(A, B, L) FIR 20 C FIRST 2 ELEMENTS OF L C L IS A LIST (A1, A2, ..., AN) OF LENGTH N .GE. 2. A IS SET TO A1 C AND B IS SET TO A2. C INTEGER A, B, L, T INTEGER FIRST C T = L CALL ADV(A, T) B = FIRST(T) RETURN END C*-*-*-*-*-*INV *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-INV 10 FUNCTION INV(LIST) INV 20 INTEGER TAIL INV = 0 NEXT = LIST IF (NEXT.EQ.0) RETURN 10 ISTORE = NEXT NEXT = TAIL(ISTORE) CALL SSUCC(INV, ISTORE) INV = ISTORE IF (NEXT.NE.0) GO TO 10 RETURN END C*-*-*-*-*-*LENGTH *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-LEN 10 FUNCTION LENGTH(LIST) LEN 20 INTEGER TAIL LENGTH = 0 K = LIST 10 IF (K.EQ.0) RETURN K = TAIL(K) LENGTH = LENGTH + 1 GO TO 10 END C*-*-*-*-*-*NOAVLS *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-NOA 10 SUBROUTINE NOAVLS NOA 20 PRINT 99999 STOP 99999 FORMAT (23H OUT OF AVAILABLE SPACE) END C*-*-*-*-*-*PFA *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-PFA 10 INTEGER FUNCTION PFA(ATOM, LIST) PFA 20 INTEGER AVAIL, STAK, RECORD INTEGER ATOM, TAIL COMMON /TR1/ AVAIL, STAK, RECORD(72) PFA = AVAIL IF (PFA.EQ.0) CALL NOAVLS AVAIL = TAIL(AVAIL) CALL SSUCC(LIST, PFA) CALL STYPE(0, PFA) CALL SCOUNT(1, PFA) CALL ALTER(ATOM, PFA) RETURN END C*-*-*-*-*-*PFL *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-PFL 10 INTEGER FUNCTION PFL(LIST1, LIST) PFL 20 INTEGER AVAIL, STAK, RECORD INTEGER TAIL COMMON /TR1/ AVAIL, STAK, RECORD(72) PFL = AVAIL IF (PFL.EQ.0) CALL NOAVLS AVAIL = TAIL(AVAIL) CALL SSUCC(LIST, PFL) CALL STYPE(1, PFL) CALL SCOUNT(1, PFL) CALL ALTER(LIST1, PFL) RETURN END C*-*-*-*-*-*SECOND *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-SEC 10 INTEGER FUNCTION SECOND(B) SEC 20 INTEGER FIRST, TAIL INTEGER ALC, B ALC = FIRST(TAIL(B)) SECOND = ALC RETURN END C*-*-*-*-*-*STACK2 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-STA 10 SUBROUTINE STACK2(X, Y) STA 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER X, Y, PFA STAK = PFA(Y,PFA(X,STAK)) RETURN END C*-*-*-*-*-*STACK3 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-STA 10 SUBROUTINE STACK3(X, Y, Z) STA 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER X, Y, Z, PFA STAK = PFA(Z,PFA(Y,PFA(X,STAK))) RETURN END C*-*-*-*-*-*UNSTK2 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-UNS 10 SUBROUTINE UNSTK2(X, Y) UNS 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER X, Y CALL DECAP(Y, STAK) CALL DECAP(X, STAK) RETURN END C*-*-*-*-*-*UNSTK3 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-UNS 10 SUBROUTINE UNSTK3(X, Y, Z) UNS 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER X, Y, Z CALL DECAP(Z, STAK) CALL DECAP(Y, STAK) CALL DECAP(X, STAK) RETURN END INTEGER FUNCTION LEQUAL(X, Y) LEQ 10 INTEGER X, Y INTEGER FIRST, PFA, TAIL, TYPE INTEGER STAK, XDP, XP, YDP, YP, Z C SAVE POINTERS AND SET UP BRANCH STACK. XP = X YP = Y STAK = 0 C TEST FOR END. 10 IF (XP.NE.YP) GO TO 30 IF (STAK.NE.0) GO TO 20 LEQUAL = 1 RETURN 20 CALL DECAP(XP, STAK) CALL DECAP(YP, STAK) C TEST NEXT NODE 30 IF (XP.LE.0 .OR. YP.LE.0) GO TO 50 Z = TYPE(XP) IF (Z.NE.TYPE(YP)) GO TO 50 XDP = FIRST(XP) YDP = FIRST(YP) IF (XDP.EQ.YDP) GO TO 40 IF (Z.EQ.0) GO TO 50 STAK = PFA(XDP,PFA(YDP,STAK)) 40 YP = TAIL(YP) XP = TAIL(XP) GO TO 10 50 LEQUAL = 0 CALL ERLA(STAK) RETURN END C*-*-*-*-*-*COMPAT *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-COM 10 SUBROUTINE COMPAT(S, A, B) COM 20 COMMON /TR3/ BETA, THETA INTEGER S, A, B, BETA B = A + B IF (S.LT.0) GO TO 10 IF (B.GE.0) GO TO 20 B = B + BETA A = -1 RETURN 10 IF (B.LE.0) GO TO 20 B = B - BETA A = 1 RETURN 20 A = 0 RETURN END C*-*-*-*-*-*ELPOF2 *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ELP 10 SUBROUTINE ELPOF2(X, EFLR, ECEIL) ELP 20 INTEGER ECEIL, EFLR, Q, R, RP, V, X, Z INTEGER IABSL, IQRS V = X EFLR = 0 ECEIL = 0 IF (V.EQ.0) RETURN Q = IABSL(V) RP = 0 10 Z = IQRS(Q,2) CALL ERLA(Q) CALL DECAP(Q, Z) CALL DECAP(R, Z) IF (R.EQ.0) GO TO 20 RP = RP + 1 20 IF (Q.EQ.0) GO TO 30 EFLR = EFLR + 1 GO TO 10 30 IF (RP.GT.1) ECEIL = 1 ECEIL = EFLR + ECEIL RETURN END C*-*-*-*-*-*IABSL *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IAB 10 INTEGER FUNCTION IABSL(A) IAB 20 INTEGER A, B, S, BORROW, INEG, ISIGNL S = ISIGNL(A) IF (S.LT.0) GO TO 10 B = BORROW(A) GO TO 20 10 B = INEG(A) 20 IABSL = B RETURN END C*-*-*-*-*-*IBTOD *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IBT 10 INTEGER FUNCTION IBTOD(A) IBT 20 INTEGER A, C C = IBTOH(A) IBTOD = IHTOD(C) CALL ERLA(C) RETURN END C*-*-*-*-*-*IBTOH *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IBT 10 INTEGER FUNCTION IBTOH(A) IBT 20 COMMON /TR3/ BETA, THETA INTEGER A, B, BETA, BI, Q, THETA, BORROW, PFA B = 0 Q = BORROW(A) 10 IF (Q.EQ.0) GO TO 20 L = IQRS(Q,THETA) CALL ERLA(Q) CALL DECAP(Q, L) CALL DECAP(BI, L) B = PFA(BI,B) GO TO 10 20 IBTOH = B RETURN END C*-*-*-*-*-*ICOMP *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ICO 10 INTEGER FUNCTION ICOMP(A, B) ICO 20 INTEGER A, B, S, T, U, V, X, Y INTEGER FIRST, TAIL, ISIGNL U = ISIGNL(A) V = ISIGNL(B) S = U - V IF (U.EQ.0 .OR. V.EQ.0) GO TO 40 IF (S.NE.0) GO TO 30 X = A Y = B 10 T = FIRST(X) - FIRST(Y) IF (T.NE.0) S = T X = TAIL(X) Y = TAIL(Y) IF (X.EQ.0) GO TO 20 IF (Y.NE.0) GO TO 10 S = U GO TO 40 20 IF (Y.EQ.0) GO TO 30 S = -U GO TO 40 30 IF (S.GT.0) S = 1 IF (S.LT.0) S = -1 40 ICOMP = S RETURN END C*-*-*-*-*-*IDIF *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IDI 10 INTEGER FUNCTION IDIF(A, B) IDI 20 INTEGER A, B, C, F, G, AI, BI, DI, EI, S, T, U, V INTEGER BORROW, FIRST, INV, PFA, TAIL, ISIGNL, INEG IF (A.NE.0) GO TO 10 C = INEG(B) GO TO 140 10 IF (B.NE.0) GO TO 20 C = BORROW(A) GO TO 140 20 C = 0 U = A V = B S = ISIGNL(A) T = ISIGNL(B) IF (S+T.NE.0) GO TO 70 DI = 0 30 CALL ADV(AI, U) CALL ADV(BI, V) BI = -BI CALL ADD3(DI, AI, BI) C = PFA(AI,C) IF (U.EQ.0) GO TO 50 IF (V.NE.0) GO TO 30 40 CALL ADV(AI, U) CALL ADD3(DI, AI, 0) C = PFA(AI,C) IF (U.NE.0) GO TO 40 GO TO 60 50 IF (V.EQ.0) GO TO 60 CALL ADV(BI, V) BI = -BI CALL ADD3(DI, BI, 0) C = PFA(BI,C) GO TO 50 60 IF (DI.NE.0) C = PFA(DI,C) C = INV(C) GO TO 140 70 F = 0 80 CALL ADV(AI, U) CALL ADV(BI, V) DI = AI - BI IF (DI.NE.0) F = DI C = PFA(DI,C) IF (U.EQ.0) GO TO 100 IF (V.NE.0) GO TO 80 90 CALL ADV(DI, U) IF (DI.NE.0) F = DI C = PFA(DI,C) IF (U.NE.0) GO TO 90 GO TO 110 100 IF (V.EQ.0) GO TO 110 CALL ADV(DI, V) DI = -DI IF (DI.NE.0) F = DI C = PFA(DI,C) GO TO 100 110 IF (F.NE.0) GO TO 120 CALL ERLA(C) C = 0 GO TO 140 120 C = INV(C) S = 1 IF (F.LT.0) S = -1 F = 0 EI = 0 U = C 130 DI = FIRST(U) CALL COMPAT(S, EI, DI) IF (DI.NE.0) F = U CALL ALTER(DI, U) U = TAIL(U) IF (U.NE.0) GO TO 130 G = TAIL(F) CALL SSUCC(0, F) CALL ERLA(G) 140 IDIF = C RETURN END C*-*-*-*-*-*IDTOB *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IDT 10 INTEGER FUNCTION IDTOB(A) IDT 20 INTEGER A, C C = IDTOH(A) IDTOB = IHTOB(C) CALL ERLA(C) RETURN END C*-*-*-*-*-*IDTOH *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IDT 10 INTEGER FUNCTION IDTOH(A) IDT 20 COMMON /TR3/ BETA, THETA INTEGER BETA, THETA, A INTEGER FIRST, PFA, INV INTEGER U, S, BI, M, AI, V U = A IDTOH = 0 S = 1 IF (FIRST(U).LT.10) GO TO 10 CALL ADV(V, U) IF (V.EQ.37) S = -1 10 IF (FIRST(U).EQ.0) RETURN V = INV(U) U = V 20 BI = 0 M = 1 30 CALL ADV(AI, U) BI = AI*M + BI M = 10*M IF (M.NE.THETA .AND. U.NE.0) GO TO 30 IDTOH = PFA(S*BI,IDTOH) IF (U.NE.0) GO TO 20 U = INV(V) RETURN END C*-*-*-*-*-*IGCD *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IGC 10 INTEGER FUNCTION IGCD(I, J) IGC 20 COMMON /TR3/ BETA, THETA INTEGER BETA, THETA INTEGER FIRST, PFA, TAIL INTEGER A, A1, A2, ADPRIM, APRIME, B, BDPRIM, BPRIME INTEGER C, C1, C2, D, E, E1, E2, F, F1, F2, G, QDPRIM, QPRIME INTEGER S, T, T1, T2, U, U1, U2, V, X, Y IF (I.NE.0) GO TO 10 IGCD = IABSL(J) RETURN 10 IF (J.NE.0) GO TO 20 IGCD = IABSL(I) RETURN 20 A = 0 T = I 30 CALL ADV(D, T) A = PFA(IABS(D),A) IF (T.NE.0) GO TO 30 A = INV(A) B = 0 T = J 40 CALL ADV(D, T) B = PFA(IABS(D),B) IF (T.NE.0) GO TO 40 B = INV(B) S = ICOMP(A,B) IF (S.NE.0) GO TO 50 CALL ERLA(A) IGCD = B RETURN 50 IF (S.GE.0) GO TO 60 T = A A = B B = T 60 IF (B.NE.0) GO TO 70 IGCD = A RETURN 70 IF (TAIL(B).NE.0) GO TO 100 C = IREM(A,B) CALL ERLA(A) IF (C.NE.0) GO TO 80 IGCD = B RETURN 80 CALL DECAP(A, B) CALL DECAP(B, C) 90 C = A - A/B*B A = B B = C IF (B.NE.0) GO TO 90 IGCD = PFA(A,0) RETURN 100 T = A 110 CALL ADV(F, T) IF (T.NE.0) GO TO 110 D = 1 E = 0 F = F + 1 IF (F.NE.BETA) CALL QR(D, E, F) T = A N = 0 C = 0 G = 0 120 CALL ADV(E, T) F = D CALL MPY(E, F) CALL ADD3(C, F, G) G = E N = N + 1 IF (T.NE.0) GO TO 120 APRIME = F ADPRIM = APRIME + 1 T = B M = 0 C = 0 G = 0 130 CALL ADV(E, T) F = D CALL MPY(E, F) CALL ADD3(C, F, G) G = E M = M + 1 IF (T.NE.0) GO TO 130 BDPRIM = F IF (M.LT.N) BDPRIM = C + G IF (M.LT.N-1) BDPRIM = 0 BPRIME = BDPRIM + 1 IF (BDPRIM.EQ.0 .OR. APRIME.LT.BPRIME .OR. ADPRIM.EQ.BETA) GO TO * 160 X = 1 Y = 0 U = 0 V = 1 140 IF (BPRIME.EQ.0 .OR. BDPRIM.EQ.0) GO TO 170 IF (BPRIME.EQ.0 .OR. BDPRIM.EQ.0) GO TO 170 QPRIME = APRIME/BPRIME QDPRIM = ADPRIM/BDPRIM IF (QPRIME.EQ.QDPRIM) GO TO 150 IF (Y.EQ.0) GO TO 160 GO TO 170 150 T = APRIME - QPRIME*BPRIME APRIME = BPRIME BPRIME = T T = ADPRIM - QPRIME*BDPRIM ADPRIM = BDPRIM BDPRIM = T T = X - QPRIME*U X = U U = T T = Y - QPRIME*V Y = V V = T GO TO 140 160 T = IREM(A,B) CALL ERLA(A) A = B B = T GO TO 60 170 T1 = A T2 = B C1 = 0 C2 = 0 L1 = 0 L2 = 0 180 A1 = FIRST(T1) A2 = FIRST(T2) E1 = A1 F1 = X CALL MPY(E1, F1) E2 = A2 F2 = Y CALL MPY(E2, F2) CALL ADD3(C1, F1, F2) C1 = C1 + E1 + E2 IF (F1.GE.0) GO TO 190 F1 = F1 + BETA C1 = C1 - 1 190 CALL ALTER(F1, T1) IF (F1.NE.0) L1 = T1 E1 = A1 F1 = U CALL MPY(E1, F1) E2 = A2 F2 = V CALL MPY(E2, F2) CALL ADD3(C2, F1, F2) C2 = C2 + E1 + E2 IF (F1.GE.0) GO TO 200 F1 = F1 + BETA C2 = C2 - 1 200 CALL ALTER(F1, T2) IF (F1.NE.0) L2 = T2 U1 = TAIL(T1) U2 = TAIL(T2) IF (U1.EQ.0 .OR. U2.NE.0) GO TO 210 U2 = PFA(0,0) CALL SSUCC(U2, T2) 210 T1 = U1 T2 = U2 IF (T1.NE.0) GO TO 180 U1 = TAIL(L1) CALL SSUCC(0, L1) CALL ERLA(U1) IF (L2.EQ.0) GO TO 60 U2 = TAIL(L2) CALL SSUCC(0, L2) CALL ERLA(U2) GO TO 60 END C*-*-*-*-*-*IGCDCF *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IGC 10 SUBROUTINE IGCDCF(A, B, C, ABAR, BBAR) IGC 20 INTEGER A, ABAR, B, BBAR, C, BORROW, FIRST, TAIL C = IGCD(A,B) IF (FIRST(C).NE.1 .OR. TAIL(C).NE.0) GO TO 10 ABAR = BORROW(A) BBAR = BORROW(B) RETURN 10 ABAR = IQ(A,C) BBAR = IQ(B,C) RETURN END C*-*-*-*-*-*IHTOB *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IHT 10 INTEGER FUNCTION IHTOB(A) IHT 20 COMMON /TR3/ BETA, THETA INTEGER A, AI, B, BETA, THETA, U, PFA U = A B = 0 IF (U.EQ.0) GO TO 20 CALL ADV(AI, U) B = PFA(AI,0) 10 IF (U.EQ.0) GO TO 20 CALL ADV(AI, U) B = IMADD(B,THETA,AI) GO TO 10 20 IHTOB = B RETURN END C*-*-*-*-*-*IHTOD *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IHT 10 INTEGER FUNCTION IHTOD(A) IHT 20 COMMON /TR3/ BETA, THETA INTEGER BETA, THETA, A INTEGER PFA, FIRST, INV INTEGER U, S, AI, M, BI IF (A.NE.0) GO TO 10 IHTOD = PFA(36,PFA(0,0)) RETURN 10 IHTOD = 0 U = A S = FIRST(A) 20 IF (U.EQ.0) GO TO 40 CALL ADV(AI, U) M = THETA/10 30 BI = AI/M AI = AI - BI*M IF (IHTOD.NE.0 .OR. BI.NE.0) IHTOD = PFA(IABS(BI),IHTOD) M = M/10 IF (M) 30, 20, 30 40 IF (S.GT.0) S = 36 IF (S.LT.0) S = 37 IHTOD = PFA(S,INV(IHTOD)) RETURN END C*-*-*-*-*-*ILCM *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ILC 10 INTEGER FUNCTION ILCM(A, B) ILC 20 INTEGER A, B, D, E, F ILCM = 0 IF (A.EQ.0) RETURN IF (B.EQ.0) RETURN D = IGCD(A,B) E = IQ(B,D) CALL ERLA(D) F = IPROD(A,E) CALL ERLA(E) ILCM = IABSL(F) CALL ERLA(F) RETURN END C*-*-*-*-*-*IMADD *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IMA 10 INTEGER FUNCTION IMADD(A, B, C) IMA 20 INTEGER A, B, C, D, E, F, G, H, T INTEGER FIRST, TAIL, PFA T = A G = C H = 0 10 F = FIRST(T) E = B CALL MPY(E, F) CALL ADD3(G, F, H) CALL ALTER(F, T) H = E E = T T = TAIL(T) IF (T.NE.0) GO TO 10 D = A G = G + H IF (G.EQ.0) GO TO 20 F = PFA(G,0) CALL SSUCC(F, E) 20 IMADD = D RETURN END C*-*-*-*-*-*INEG *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-INE 10 INTEGER FUNCTION INEG(A) INE 20 INTEGER A, AI, B, U, INV, PFA B = 0 IF (A.EQ.0) GO TO 20 U = A 10 CALL ADV(AI, U) B = PFA(-AI,B) IF (U.NE.0) GO TO 10 B = INV(B) 20 INEG = B RETURN END C*-*-*-*-*-*IPOWER *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IPO 10 INTEGER FUNCTION IPOWER(A, N) IPO 20 INTEGER A, B, C, BORROW, PFA, IPROD IF (N.NE.0) GO TO 10 B = PFA(1,0) GO TO 30 10 B = BORROW(A) IF (A.EQ.0) GO TO 30 J = 1 20 IF (J.EQ.N) GO TO 30 C = IPROD(B,A) CALL ERLA(B) B = C J = J + 1 GO TO 20 30 IPOWER = B RETURN END C*-*-*-*-*-*IPROD *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IPR 10 INTEGER FUNCTION IPROD(A, B) IPR 20 INTEGER A, B, C, E, F, G, S, T, U, V, W, X, Z, AI, BJ INTEGER FIRST, TAIL, PFA, LENGTH C = 0 IF (A.EQ.0 .OR. B.EQ.0) GO TO 50 S = PFA(0,0) T = PFA(0,S) M = LENGTH(A) + LENGTH(B) - 2 C = T IF (M.EQ.0) GO TO 20 DO 10 I=1,M C = PFA(0,C) 10 CONTINUE 20 V = B W = C 30 X = A CALL ADV(BJ, V) Z = W G = 0 40 CALL ADV(AI, X) F = BJ CALL MPY(AI, F) E = FIRST(Z) CALL ADD3(G, E, F) CALL ALTER(E, Z) G = AI + G Z = TAIL(Z) IF (X.NE.0) GO TO 40 CALL ALTER(G, Z) W = TAIL(W) IF (V.NE.0) GO TO 30 IF (G.NE.0) GO TO 50 CALL SSUCC(0, T) CALL DECAP(G, S) 50 IPROD = C RETURN END C*-*-*-*-*-*IQ *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IQ 10 INTEGER FUNCTION IQ(A, B) IQ 20 INTEGER A, B, L, Q, R, IQR L = IQR(A,B) CALL DECAP(Q, L) CALL DECAP(R, L) CALL ERLA(R) IQ = Q RETURN END C*-*-*-*-*-*IQR *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IQR 10 INTEGER FUNCTION IQR(A, B) IQR 20 COMMON /TR3/ BETA, THETA INTEGER BETA, THETA INTEGER BORROW, FIRST, IPROD, IQRS, ISIGNL, LENGTH, PFA, PFL, TAIL INTEGER A, A1, A2, A3, ABAR, B, B1, B2, BBAR, C, C1, C2, D, E, F, * I, J, K INTEGER L, L1, L2, M, N, Q, QBAR, R, R1, R2, S, T, U, V, W, X Q = 0 IF (A.NE.0 .AND. B.NE.0) GO TO 10 R = BORROW(A) GO TO 210 10 IF (TAIL(B).NE.0) GO TO 20 B1 = FIRST(B) L = IQRS(A,B1) CALL DECAP(Q, L) CALL DECAP(R, L) IF (R.NE.0) R = PFA(R,0) GO TO 210 20 M = LENGTH(A) N = LENGTH(B) K = M - N IF (K.GE.0) GO TO 30 R = BORROW(A) GO TO 210 30 S = ISIGNL(A) U = B J = N - 1 DO 40 I=1,J U = TAIL(U) 40 CONTINUE C = FIRST(U) T = 1 IF (C.GE.0) GO TO 50 T = -1 C = -C 50 D = BETA/(C+1) W = S*T E = PFA(S*D,0) ABAR = IPROD(A,E) CALL ALTER(T*D, E) BBAR = IPROD(B,E) CALL ERLA(E) U = ABAR L1 = 0 J = K + 1 DO 60 I=1,J L1 = PFA(U,L1) U = TAIL(U) 60 CONTINUE L2 = L1 J = N - 2 IF (J.EQ.0) GO TO 80 DO 70 I=1,J L2 = PFA(U,L2) U = TAIL(U) 70 CONTINUE 80 IF (TAIL(U).NE.0) GO TO 90 V = PFA(0,0) CALL SSUCC(V, U) 90 U = BBAR J = N - 2 IF (J.EQ.0) GO TO 110 DO 100 I=1,J U = TAIL(U) 100 CONTINUE 110 CALL ADV(B2, U) CALL ADV(B1, U) 120 U = FIRST(L2) CALL ADV(A3, U) CALL ADV(A2, U) CALL ADV(A1, U) IF (A1.LT.B1) GO TO 130 QBAR = BETA - 1 GO TO 140 130 E = A1 F = A2 CALL QR(E, F, B1) QBAR = E 140 C1 = QBAR C2 = B1 CALL MPY(C1, C2) R1 = A1 - C1 R2 = A2 - C2 IF (R2.GE.0) GO TO 150 R2 = R2 + BETA R1 = R1 - 1 150 IF (R1.GT.0) GO TO 160 C1 = QBAR C2 = B2 CALL MPY(C1, C2) R1 = R2 - C1 IF (R1.GT.0) GO TO 160 R2 = A3 - C2 IF (R1.GE.0 .AND. R2.GE.0) GO TO 160 QBAR = QBAR - 1 GO TO 140 160 U = FIRST(L1) V = BBAR C1 = 0 170 E = -QBAR CALL ADV(F, V) CALL MPY(E, F) A1 = FIRST(U) CALL ADD3(C1, A1, F) IF (A1.GE.0) GO TO 180 A1 = A1 + BETA C1 = C1 - 1 180 C1 = C1 + E CALL ALTER(A1, U) X = U U = TAIL(U) IF (V.NE.0) GO TO 170 CALL DECAP(A1, U) CALL SSUCC(0, X) A1 = A1 + C1 IF (A1.EQ.0) GO TO 200 U = FIRST(L1) V = BBAR C1 = 0 QBAR = QBAR - 1 190 A1 = FIRST(U) CALL ADV(B1, V) CALL ADD3(C1, A1, B1) CALL ALTER(A1, U) U = TAIL(U) IF (V.NE.0) GO TO 190 200 IF (QBAR.NE.0 .OR. Q.NE.0) Q = PFA(W*QBAR,Q) L1 = TAIL(L1) CALL DECAP(U, L2) IF (L1.NE.0) GO TO 120 L = IQRS(ABAR,S*D) CALL DECAP(R, L) CALL DECAP(U, L) CALL ERLA(BBAR) CALL ERLA(L2) CALL ERLA(ABAR) 210 IQR = PFL(Q,PFL(R,0)) RETURN END C*-*-*-*-*-*IQRS *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IQR 10 INTEGER FUNCTION IQRS(A, B) IQR 20 INTEGER A, B, C, E, F, Q INTEGER CINV, PFA, PFL Q = 0 E = 0 IF (A.EQ.0) GO TO 20 C = CINV(A) 10 CALL DECAP(F, C) CALL QR(E, F, B) IF (Q.NE.0 .OR. E.NE.0) Q = PFA(E,Q) E = F IF (C.NE.0) GO TO 10 20 IQRS = PFL(Q,PFA(E,0)) RETURN END C*-*-*-*-*-*IREAD *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IRE 10 INTEGER FUNCTION IREAD(U) IRE 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD, U INTEGER PFA, IDTOB, INV INTEGER B, N B = 0 CALL READ(U, RECORD) IF (RECORD(1).NE.-1) GO TO 10 IREAD = -1 RETURN 10 DO 20 N=1,72 IF (RECORD(N).EQ.44) GO TO 30 B = PFA(RECORD(N),B) 20 CONTINUE CALL READ(U, RECORD) IF (RECORD(1).GE.0) GO TO 10 30 B = INV(B) IREAD = IDTOB(B) CALL ERLA(B) RETURN END C*-*-*-*-*-*IREM *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IRE 10 INTEGER FUNCTION IREM(A, B) IRE 20 INTEGER A, B, L, Q, R L = IQR(A,B) CALL DECAP(Q, L) CALL DECAP(R, L) CALL ERLA(Q) IREM = R RETURN END C*-*-*-*-*-*ISIGNL *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ISI 10 INTEGER FUNCTION ISIGNL(A) ISI 20 INTEGER A, B, S, T S = 0 IF (A.EQ.0) GO TO 20 T = A 10 CALL ADV(B, T) IF (B.EQ.0) GO TO 10 S = 1 IF (B.LT.0) S = -1 20 ISIGNL = S RETURN END C*-*-*-*-*-*ISUM *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-ISU 10 INTEGER FUNCTION ISUM(A, B) ISU 20 INTEGER A, B, C, F, G, AI, BI, DI, EI, S, T, U, V INTEGER BORROW, FIRST, INV, PFA, TAIL, ISIGNL IF (A.NE.0) GO TO 10 C = BORROW(B) GO TO 140 10 IF (B.NE.0) GO TO 20 C = BORROW(A) GO TO 140 20 C = 0 U = A V = B S = ISIGNL(A) T = ISIGNL(B) IF (S+T.EQ.0) GO TO 70 DI = 0 30 CALL ADV(AI, U) CALL ADV(BI, V) CALL ADD3(DI, AI, BI) C = PFA(AI,C) IF (U.NE.0) GO TO 40 U = V GO TO 60 40 IF (V.NE.0) GO TO 30 50 CALL ADV(AI, U) CALL ADD3(DI, AI, 0) C = PFA(AI,C) 60 IF (U.NE.0) GO TO 50 IF (DI.NE.0) C = PFA(DI,C) C = INV(C) GO TO 140 70 F = 0 80 CALL ADV(AI, U) CALL ADV(BI, V) DI = AI + BI IF (DI.NE.0) F = DI C = PFA(DI,C) IF (U.NE.0) GO TO 90 U = V GO TO 110 90 IF (V.NE.0) GO TO 80 100 CALL ADV(F, U) C = PFA(F,C) 110 IF (U.NE.0) GO TO 100 IF (F.NE.0) GO TO 120 CALL ERLA(C) C = 0 GO TO 140 120 C = INV(C) S = 1 IF (F.LT.0) S = -1 F = 0 EI = 0 U = C 130 DI = FIRST(U) CALL COMPAT(S, EI, DI) IF (DI.NE.0) F = U CALL ALTER(DI, U) U = TAIL(U) IF (U.NE.0) GO TO 130 G = TAIL(F) IF (G.EQ.0) GO TO 140 CALL SSUCC(0, F) CALL ERLA(G) 140 ISUM = C RETURN END C*-*-*-*-*-*IWRITE *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-IWR 10 SUBROUTINE IWRITE(U, A) IWR 20 COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD, U, A INTEGER IBTOD, N, B, C B = IBTOD(A) 10 DO 20 N=1,72 IF (B.EQ.0) GO TO 30 CALL DECAP(C, B) RECORD(N) = C 20 CONTINUE CALL WRITE(U, RECORD) GO TO 10 30 DO 40 I=N,72 RECORD(I) = 44 40 CONTINUE CALL WRITE(U, RECORD) RETURN END C PROGRAM GROEB C MAN 10 C MAN 20 C MAN 30 C GROEB MAN 40 C MAN 50 C A PROGRAM PACKAGE FOR COMPUTING GROEBNER-BASES OF POLYNOMIAL MAN 60 C IDEALS OVER THE FIELD OF RATIONAL INTEGERS MAN 70 C MAN 80 C MAN 90 C FRANZ WINKLER MAN 100 C INSTITUT FUER MATHEMATIK MAN 110 C JOHANNES KEPLER UNIVERSITAET MAN 120 C A-4040 LINZ, AUSTRIA MAN 130 C MAN 140 C MAN 150 C MAN 160 C THE PACKAGE IS BUILT ON TOP OF THE SAC-1 SYSTEM, WHICH HAS BEEN MAN 170 C DEVELOPED AT THE UNIVERSITY OF WISCONSIN, MADISON, FOR SYMBOLIC MAN 180 C AND ALGEBRAIC COMPUTATION. FROM THE SAC-1 SYSTEM ONLY THE SUB- MAN 190 C SYSTEMS CONCERNING LIST PROCESSING AND INTEGER ARITHMETIC ARE USEDMAN 200 C (SEE MAN 210 C G.E. COLLINS: THE SAC-1 LEST PROCESSING SYSTEM, MAN 220 C TECHN. REP. NR. 129, COMP. SCI. DEPT., MAN 230 C UNIV. OF WISCONSIN, MADISON (1971) MAN 240 C AND MAN 250 C G.E. COLLINS: THE SAC-1 INTEGER ARITHMETIC SYSTEM, MAN 260 C TECHN. REP. NR. 156, COMP. SCI. DEPT., MAN 270 C UNIV. OF WISCONSIN, MADISON (1971) MAN 280 C FOR AN INTRODUCTION). MAN 290 C THUS, BEFORE STARTING TO CALL GBASIS WE HAVE TO INITIATE SOME OF MAN 300 C THE SYSTEM VARIABLES OF SAC-1. MAN 310 C MAN 320 C MAN 330 C MAN 340 C MAN 350 C THE MAIN PROGRAM KEEPS MAN 360 C - READING IN A SEQUENCE OF POLYNOMIALS MAN 370 C - COMPUTING THE GROEBNER-BASIS MAN 380 C - PRINTING THE GROEBNER-BASIS MAN 390 C UNTIL THE NUMBER OF VARIABLES IS SET TO 0. MAN 400 C MAN 410 C MAN 420 C MAN 430 C MAN 440 C A SEQUENCE OF POLYNOMIALS HAS TO BE PRESENTED FOR INPUT IN THE MAN 450 C FOLLOWING FORMAT: MAN 460 C NUMBER OF VARIABLES (FORMAT I2) MAN 470 C NUMBER OF POLYNOMIALS IN THE BASIS (FORMAT I2) MAN 480 C FOR EACH POLYNOMIAL: MAN 490 C NUMBER OF TERMS (FORMAT I2) MAN 500 C FOR EACH TERM (ORDERED WITH RESPECT TO LINORD): MAN 510 C NUMERATOR OF THE COEFFICIENT MAN 520 C DENOMINATOR OF THE COEFFICIENT MAN 530 C EXPONENTS (FORMAT NI3, IF N IS THE NUMBER OF VARIABLES). MAN 540 C MAN 550 C MAN 560 C EXAMPLE: MAN 570 C THE SEQUENCE MAN 580 C 2 MAN 590 C F1 = X Y - XY MAN 600 C MAN 610 C 2 MAN 620 C F2 = XY + XY + Y MAN 630 C MAN 640 C HAS TO BE PRESENTED AS MAN 650 C 2 MAN 660 C 2 MAN 670 C 2 MAN 680 C +1 MAN 690 C +1 MAN 700 C 2 1 MAN 710 C -1 MAN 720 C +1 MAN 730 C 1 1 MAN 740 C 3 MAN 750 C +1 MAN 760 C +1 MAN 770 C 1 2 MAN 780 C +1 MAN 790 C +1 MAN 800 C 1 1 MAN 810 C +1 MAN 820 C +1 MAN 830 C 0 1 MAN 840 C MAN 850 C MAN 860 C MAN 870 C MAN 880 C THE FIRST CARD READ BY THE PROGRAM HAS TO BE THE CHARACTER MAN 890 C CONTROL CARD, CONSISTING OF THE SAC-1 CHARACTERS: MAN 900 C 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+-*/(),. =\$ MAN 910 C MAN 920 C MAN 930 C MAN 940 C MAN 950 INTEGER AVAIL, STACK, RECORD, SYMLST, BETA, THETA, OUT MAN 960 INTEGER SPACE, F, G, READLP MAN 970 COMMON /TR1/ AVAIL, STAK, RECORD(72) MAN 980 COMMON /TR2/ SYMLST MAN 990 COMMON /TR3/ BETA, THETA MAN 1000 COMMON /S/ SPACE(20000) MAN 1010 COMMON /VAR/ N MAN 1020 COMMON /OUTPUT/ OUT MAN 1030 IN = 5 MAN 1040 OUT = 6 MAN 1050 CALL INITIO(IN) MAN 1060 CALL BEGIN MAN 1070 SYMLST = 0 MAN 1080 BETA = 2**14 MAN 1090 THETA = 10**5 MAN 1100 10 READ (IN,99999) N MAN 1110 99999 FORMAT (I2) MAN 1120 IF (N.EQ.0) STOP MAN 1130 F = READLP(IN) MAN 1140 WRITE (OUT,99998) MAN 1150 99998 FORMAT (1H1, 1HG, 1HI, 1HV, 1HE, 1HN, 1H , 1HB, 1HA, 1HS, 1HI, MAN 1160 * 1HS, 1H , 1HF) MAN 1170 CALL WRITLP(OUT, F) MAN 1180 CALL GBASIS(F, G, N) MAN 1190 WRITE (OUT,99997) MAN 1200 99997 FORMAT (1H1, 1HG, 1HR, 1HO, 1HE, 1HB, 1HN, 1HE, 1HR, 1HB, 1HA, MAN 1210 * 1HS, 1HI, 1HS, 1H , 1HG) MAN 1220 CALL WRITLP(OUT, G) MAN 1230 CALL ERASE(F) MAN 1240 CALL ERASE(G) MAN 1250 GO TO 10 MAN 1260 END MAN 1270 C GBA 10 C GBA 20 C GBA 30 C GBA 40 C GBA 50 C GBA 60 SUBROUTINE GBASIS(F, G, N) GBA 70 C FOR THE INPUT C F ... A FINITE SEQUENCE OF MULTIVARIATE POLYNOMIALS C N ... NUMBER OF VARIABLES C GBASIS COMPUTES THE OUTPUT C G ... A FINITE SEQUENCE OF MULTIVARIATE POLYNOMIALS C SUCH THAT C THE IDEAL GENERATED BY F = C THE IDEAL GENERATED BY G, AND C G IS A (MINIMAL NORMED) GROEBNER-BASIS. C C REFERENCE TO LITERATURE: C A COMPLETE REFERENCE TO THE THEORETICAL WORK ON WHICH THE C ALGORITHM IS BASED IS GIVEN IN THE ACCOMPANYING PAPER. C C THE SUBROUTINE GROEB USES THE SUBROUTINES FROM THE C SAC-1 LIST PROCESSING SYSTEM AND THE SAC-1 INTEGER ARITHMETIC C SYSTEM, WHICH WE DO NOT INCLUDE IN THE FOLLOWING LISTING. C (CORRESPONDINGLY, A CALL OF THE SUBROUTINE ERASE WILL C APPEAR ON NUMEROUS PLACES IN THE PROGRAM FOR GARBAGE C COLLECTION PURPOSES.) C C THE OVERALL LOGICAL STRUCTURE OF THE PROGRAM GROEB EXACTLY C CORRESPONDS TO THE DESCRIPTION IN SECTION 1. SOME STRAIGHT- C FORWARD MODIFICATIONS ARE DUE TO THE USE OF FORTRAN C LANGUAGE FEATURES AND THE NEED FOR GENERATING THE AUXILIARY C ARRAY AUX (SEE THE INSTRUCTION CALL CREAUX(G,AUX) ). C C INTEGER F, G, B, AUX, OUT, H1, H2, H, GM INTEGER COPY, CRIT, SPOL, CONC, PFL, AVAIL COMMON /OUTPUT/ OUT COMMON /TR1/ AVAIL, STAK, RECORD(72) DIMENSION B(40,40), AUX(40) G = COPY(F) CALL CREAUX(G, AUX) CALL BINIT(G, B) 10 CALL SELB(B, G, AUX, I, J) IF (I.EQ.0) GO TO 30 B(I,J) = 0 IF (CRIT(G,AUX,B,I,J).EQ.0) GO TO 10 H1 = SPOL(AUX(I),AUX(J)) H2 = NORMF(G,AUX,H1) H = NORM(H2) CALL ERASE(H1) CALL ERASE(H2) IF (H.EQ.0) GO TO 10 G = CONC(G,PFL(H,0)) L = LENGTH(G) IF (L.LE.40) GO TO 20 WRITE (OUT,99999) 99999 FORMAT (1H1, 1HL, 1HE, 1HN, 1HG, 1HT, 1HH, 1H , 1HO, 1HF, 1H , * 1HS, 1HE, 1HQ, 1HU, 1HE, 1HN, 1HC, 1HE, 1H , 1HO, 1HF, 1H , 1HP, * 1HO, 1HL, 1HI, 1HN, 1HO, 1HM, 1HI, 1HA, 1HL, 1HS, 1H , 1HE, 1HX, * 1HC, 1HE, 1HE, 1HD, 1HS, 1H , 1H4, 1H0) STOP 20 AUX(L) = H CALL COMPL(B, L) GO TO 10 30 CONTINUE GM = MINOR(G) CALL ERASE(G) G = GM RETURN END C COP 10 C COP 20 C COP 30 C COP 40 C COP 50 C COP 60 INTEGER FUNCTION COPY(X) COP 70 C FOR THE INPUT C X ... A SAC-1 LIST (IN PARTICULAR A SEQUENCE OF C POLYNOMIALS) C COPY(X) IS A COPY OF THE LIST X (REFERENCE COUNTS IN C THE SENSE OF SAC-1 ARE SET TO 1). C C COMMON /TR1/ AVAIL, STAK, RECORD(72) INTEGER AVAIL, STAK, RECORD INTEGER FIRST, TAIL, TYPE, PFL, PFA INTEGER X, ARG, OLDSTK, RET, H1 ARG = X OLDSTK = STAK 10 IF (ARG.NE.0) GO TO 20 RET = 0 GO TO 60 20 CALL STACK3(ARG, 0, 1) ARG = TAIL(ARG) GO TO 10 30 H1 = RET IF (TYPE(ARG).EQ.1) GO TO 40 RET = PFA(FIRST(ARG),H1) GO TO 60 40 CALL STACK3(ARG, H1, 2) ARG = FIRST(ARG) GO TO 10 50 RET = PFL(RET,H1) GO TO 60 60 IF (STAK.EQ.OLDSTK) GO TO 70 CALL UNSTK3(ARG, H1, I) GO TO (30, 50), I 70 COPY = RET RETURN END C CRE 10 C CRE 20 C CRE 30 C CRE 40 C CRE 50 C CRE 60 SUBROUTINE CREAUX(PLIST, AUX) CRE 70 C FOR THE INPUT C PLIST ... A FINITE SEQUENCE OF POLYNOMIALS C CREAUX COMPUTES THE OUTPUT C AUX ..... A ONE-DIMENSIONAL INTEGER ARRAY C SUCH THAT C AUX(I) IS THE POINTER TO THE I-TH POLYNOMIAL IN PLIST C FOR ALL 1 <= I <= LENGTH OF PLIST. C C INTEGER PLIST, AUX, OUT, PL, FIRST, TAIL COMMON /OUTPUT/ OUT DIMENSION AUX(40) L = LENGTH(PLIST) IF (L.EQ.0) RETURN IF (L.LE.40) GO TO 10 WRITE (OUT,99999) 99999 FORMAT (1H1, 1HL, 1HE, 1HN, 1HG, 1HT, 1HH, 1H , 1HO, 1HF, 1H , * 1HS, 1HE, 1HQ, 1HU, 1HE, 1HN, 1HC, 1HE, 1H , 1HO, 1HF, 1H , 1HP, * 1HO, 1HL, 1HI, 1HN, 1HO, 1HM, 1HI, 1HA, 1HL, 1HS, 1H , 1HE, 1HX, * 1HC, 1HE, 1HE, 1HD, 1HS, 1H , 1H4, 1HO) STOP 10 PL = PLIST DO 20 I=1,L AUX(I) = FIRST(PL) PL = TAIL(PL) 20 CONTINUE RETURN END C SEL 10 C SEL 20 C SEL 30 C SEL 40 C SEL 50 C SEL 60 SUBROUTINE SELB(B, PLIST, AUX, I, J) SEL 70 C FOR THE INPUT C B ....... AN INTEGER ARRAY OF DIMENSION C (LENGTH OF PLIST,LENGTH OF PLIST) C PLIST ... A FINITE SEQUENCE OF POLYNOMIALS C AUX ..... A ONE-DIMENSIONAL INTEGER ARRAY POINTING TO C THE POLYNOMIALS IN PLIST C SELB IN THE NORMAL CASE COMPUTES THE OUTPUT C I ....... AN INTEGER (1<=I<=LENGTH OF PLIST) C J ....... AN INTEGER (1<=J<=LENGTH OF PLIST) C SUCH THAT C I < J, C B(I,J) = 1 (I.E. THE REDUCTION CORRESPONDING TO THE C INDICES I AND J HAS NOT YET BEEN CARRIED OUT), C LEAST COMMON MULTIPLE OF THE HEADTERMS OF THE I-TH AND C J-TH POLYNOMIAL IS MINIMAL (WITH RESPECT TO THE C TERM ORDERING) AMONG THE LEAST COMMON MULTIPLES C OF THE HEADTERMS OF THE I'-TH AND J'-TH POLYNOMIAL C FOR ALL REMAINING I',J' WITH B(I',J')=1. C (IF NO SUCH I,J EXIST, SELB RETURNS I=0). C C INTEGER B, PLIST, AUX, EXP, EXPK, EXP1 INTEGER BORROW, FIRST DIMENSION B(40,40), AUX(40) L = LENGTH(PLIST) I = 0 IF (L.LE.1) RETURN L1 = L - 1 DO 40 K=1,L1 K1 = K + 1 EXPK = FIRST(FIRST(AUX(K))) DO 30 M=K1,L IF (B(K,M).EQ.0) GO TO 30 IF (I.NE.0) GO TO 10 I = K J = M EXP = LCM(EXPK,FIRST(FIRST(AUX(M)))) GO TO 30 10 EXP1 = LCM(EXPK,FIRST(FIRST(AUX(M)))) IF (LINORD(EXP1,EXP).NE.2) GO TO 20 I = K J = M CALL ERASE(EXP) EXP = EXP1 GO TO 30 20 CALL ERASE(EXP1) 30 CONTINUE 40 CONTINUE IF (I.NE.0) CALL ERASE(EXP) RETURN END C SPO 10 C SPO 20 C SPO 30 C SPO 40 C SPO 50 C SPO 60 INTEGER FUNCTION SPOL(P, Q) SPO 70 C FOR THE INPUT C P ... A POLYNOMIAL C Q ... A POLYNOMIAL C SPOL(P,Q) IS THE S-POLYNOMIAL OF P AND Q (SEE /4/). C C INTEGER P, Q, RP, RQ, HEXP, HEXQ, HEXPQ, MEXP, MEXQ, PE, QE, SP, * SQ INTEGER TAIL, FIRST, QUOTEE, PRODPE, PRODPR, DIFFPP RP = TAIL(FIRST(P)) RQ = TAIL(FIRST(Q)) HEXP = FIRST(FIRST(P)) HEXQ = FIRST(FIRST(Q)) HEXPQ = LCM(HEXP,HEXQ) MEXP = QUOTEE(HEXPQ,HEXP) MEXQ = QUOTEE(HEXPQ,HEXQ) PE = PRODPE(P,MEXP) QE = PRODPE(Q,MEXQ) SP = PRODPR(PE,RQ) SQ = PRODPR(QE,RP) SPOL = DIFFPP(SP,SQ) CALL ERASE(HEXPQ) CALL ERASE(MEXP) CALL ERASE(MEXQ) CALL ERASE(PE) CALL ERASE(QE) CALL ERASE(SP) CALL ERASE(SQ) RETURN END C NOR 10 C NOR 20 C NOR 30 C NOR 40 C NOR 50 C NOR 60 INTEGER FUNCTION NORMF(PLIST, AUX, P) NOR 70 C FOR THE INPUT C PLIST ... A FINITE SEQUENCE OF POLYNOMIALS C AUX ..... A ONE-DIMENSIONAL INTEGER ARRAY POINTING TO C THE POLYNOMIALS IN PLIST C P ....... A POLYNOMIAL C NORMF(PLIST,P) IS A POLYNOMIAL SUCH THAT C P IS REDUCIBLE TO NORMF(PLIST,P) MODULO PLIST AND C NORMF(PLIST,P) IS IN NORMALFORM WITH RESPECT TO PLIST. C C INTEGER PLIST, AUX, P, POINT, T, Q, S, HCQ, A, R, H1, H INTEGER BORROW, QUOTEE, FIRST, TAIL, QUOT, PRODPE, PRODPR, DIFFPP DIMENSION AUX(40) NORMF = BORROW(P) POINT = 0 10 CALL SEL(PLIST, AUX, NORMF, POINT, T, Q) IF (T.EQ.0) RETURN S = QUOTEE(FIRST(T),FIRST(FIRST(Q))) HCQ = TAIL(FIRST(Q)) A = QUOT(TAIL(T),HCQ) R = PRODPE(Q,S) H1 = PRODPR(R,A) H = DIFFPP(NORMF,H1) CALL ERASE(S) CALL ERASE(A) CALL ERASE(R) CALL ERASE(H1) CALL ERASE(NORMF) NORMF = H GO TO 10 END C NOR 10 C NOR 20 C NOR 30 C NOR 40 C NOR 50 C NOR 60 INTEGER FUNCTION NORM(P) NOR 70 C FOR THE INPUT C P ... A POLYNOMIAL C NORM(P) IS THE POLYNOMIAL WHICH RESULTS FROM DIVIDING C P BY ITS HEADCOEFFICIENT. C C INTEGER P INTEGER CINV, FIRST, TAIL, PRODPR IF (P.NE.0) GO TO 10 NORM = 0 RETURN 10 INVHC = CINV(TAIL(FIRST(P))) NORM = PRODPR(P,INVHC) CALL ERASE(INVHC) RETURN END C MIN 10 C MIN 20 C MIN 30 C MIN 40 C MIN 50 C MIN 60 INTEGER FUNCTION MINOR(PLIST) MIN 70 C FOR THE INPUT C PLIST ... A GROEBNER-BASIS C MINOR(PLIST) IS THE UNIQUE MINIMAL NORMED AND ORDERED C GROEBNER-BASIS EQUIVALENT TO PLIST (SEE /5/). C C INTEGER PLIST, AUX, DEL, AUXM, ORD, EP, EQ, P, P1, P1N, PN, Q INTEGER BORROW, FIRST, TAIL, PFL INTEGER AVAIL COMMON /TR1/ AVAIL, STAK, RECORD(72) DIMENSION AUX(40), DEL(40), AUXM(40), ORD(40) L = LENGTH(PLIST) IF (L.GT.1) GO TO 10 MINOR = BORROW(PLIST) RETURN 10 CALL CREAUX(PLIST, AUX) DO 20 I=1,L DEL(I) = 0 20 CONTINUE DO 50 I=1,L P = AUX(I) IF (P.NE.0) GO TO 30 DEL(I) = 1 GO TO 50 30 EP = FIRST(FIRST(P)) DO 40 J=1,L IF (I.EQ.J .OR. DEL(J).EQ.1) GO TO 40 Q = AUX(J) EQ = FIRST(FIRST(Q)) M = MORD(EP,EQ) IF (M.NE.1) GO TO 40 DEL(I) = 1 GO TO 50 40 CONTINUE 50 CONTINUE MI = 0 DO 60 I=1,L IF (DEL(I).EQ.0) MI = PFL(BORROW(AUX(I)),MI) 60 CONTINUE MI = INV(MI) LMI = LENGTH(MI) IF (LMI.GT.1) GO TO 70 MINOR = MI RETURN 70 MIN = 0 CALL CREAUX(MI, AUXM) DO 80 I=1,LMI P = AUXM(I) P1 = TAIL(P) P1N = NORMF(MI,AUXM,P1) PN = PFL(BORROW(FIRST(P)),P1N) MIN = PFL(PN,MIN) 80 CONTINUE CALL ERASE(MI) MIN = INV(MIN) CALL CREAUX(MIN, AUXM) DO 90 I=1,LMI ORD(I) = I 90 CONTINUE LMI1 = LMI - 1 DO 110 J=1,LMI1 DO 100 I=1,LMI1 K = ORD(I) M = ORD(I+1) L = LINORD(FIRST(FIRST(AUXM(K))),FIRST(FIRST(AUXM(M)))) IF (L.NE.1) GO TO 100 ORD(I) = M ORD(I+1) = K 100 CONTINUE 110 CONTINUE MINOR = 0 DO 120 I=1,LMI MINOR = PFL(BORROW(AUXM(ORD(I))),MINOR) 120 CONTINUE MINOR = INV(MINOR) CALL ERASE(MIN) RETURN END C BIN 10 C BIN 20 C BIN 30 C BIN 40 C BIN 50 C BIN 60 SUBROUTINE BINIT(PLIST, B) BIN 70 C FOR THE INPUT C PLIST ... A FINITE SEQUENCE OF POLYNOMIALS C BINIT COMPUTES THE OUTPUT C B ....... AN INTEGER ARRAY OF DIMENSION C (LENGTH OF PLIST,LENGTH OF PLIST) C SUCH THAT C B(I,J) = 1, IF 1<=I