!* MODIFIED 20/02/78 ERROR MESSAGE VALUES !* MODIFIED 17/2/77 LAB (APPENDED SQ & DA FILE ROUTINES AND ! DATE AND TIME ROUTINES FOR IMP AND FORTE) !* MODIFIED 16/12/76 GEM (RANDOM) SYSTEMROUTINESPEC IOCP(INTEGER EP,N) !******** MODIFIED 02:07:76 15.15 LCG (ALGLRTS,MATHFNS CONCATONATED ! ,COMPLEX ROUTINES ! & DUPLICATES FOR FORTRAN) SYSTEMLONGREALFNSPEC ISIN(LONGREAL X) SYSTEMLONGREALFNSPEC ICOS(LONGREAL X) SYSTEMLONGREALFNSPEC IEXP(LONGREAL X) SYSTEMLONGREALFNSPEC ISQRT(LONGREAL X) SYSTEMLONGREALFNSPEC ILOG(LONGREAL X) SYSTEMROUTINESPEC MLIBERR(INTEGER ERR) CONSTLONGREAL LOG10A=2.3025850929940456840179914546843642076011 OWNLONGREAL PI=3.141592653589793238462643 CONSTLONGREAL R1=R'41C98867F42983DF' CONSTLONGREAL R2=R'C2562FB2813C6014' CONSTLONGREAL R3=R'C1146D547FED8A3D' CONSTLONGREAL R4=R'C0157BD961F06C89' CONSTLONGREAL S1=R'421B189E39236635' CONSTLONGREAL S2=R'4168EE1BDE0C3700' CONSTLONGREAL S3=R'41224E7F3CBDFE41' CONSTLONGREAL S4=R'41144831DAFBF542' CONSTLONGREAL RT3=R'411BB67AE8584CAA' CONSTLONGREAL PIBY6=R'40860A91C16B9B2C' CONSTLONGREAL PIBY2M1=R'40921FB54442D184' CONSTLONGREAL RT3M1=R'40BB67AE8584CAA7' CONSTLONGREAL TANPIBY12=R'404498517A7B3559' SYSTEMLONGREALFN IARCTAN(LONGREAL X2, X1) LONGREAL XSQ, CONSTANT LONGREAL Y, YSQ, X INTEGER SIGN, INV, SIGN1, SIGN2 SIGN=1; SIGN1=1; SIGN2=1 CONSTANT=0 IF X2<0 THEN SIGN2=-1 AND X2=-X2 IF X1<0 THEN SIGN1=-1 AND X1=-X1 IF X1=0 AND X2=0 START MLIBERR(71); ! ERROR(1, 38, 1, 0, 1, 0) X=0 FINISHELSESTART IF X1>X2 START SIGN=-1 Y=X2/X1 FINISHELSE Y=X1/X2 IF Y>TANPIBY12 THEN Y=(RT3M1*Y-1.0+Y)/(Y+RT3) AND C CONSTANT=PIBY6 YSQ=Y*Y X=Y*(R1/(YSQ+S1+(R2/(YSQ+S2+(R3/(YSQ+S3+(R4/(YSQ+S4))))))) C )+CONSTANT IF SIGN=-1 THEN X=1.0-X+PIBY2M1 IF SIGN1=1 START IF SIGN2=-1 THEN X=PI-X FINISHELSESTART IF SIGN2=-1 THEN X=X-PI ELSE X=-X FINISH FINISH RESULT =X END EXTERNALLONGREALFN IHYPTAN(LONGREAL X) CONSTLONGREAL A1=676440.765 CONSTLONGREAL A2=45092.124 CONSTLONGREAL A3=594.459 CONSTLONGREAL B1=2029322.295 CONSTLONGREAL B2=947005.29 CONSTLONGREAL B3=52028.55 CONSTLONGREAL B4=630.476 LONGREAL XSQ, NUM, DENOM, RES INTEGER MINUS MINUS=0 IF X<=-0.54931 THEN MINUS=1 AND X=-X ELSE MINUS=0 IF (X>=0.54931 AND X<20.101) START RES=1-(2.0/(IEXP(2.0*X)+1.0)) IF MINUS=1 THEN RESULT =-RES ELSE RESULT =RES FINISH IF X>=20.101 START IF MINUS=1 THEN RESULT =-1.0 ELSE RESULT =1.0 FINISH XSQ=X*X NUM=XSQ*(A1+XSQ*(A2+XSQ*(A3+XSQ))) DENOM=B1+XSQ*(B2+XSQ*(B3+XSQ*(B4+XSQ))) RESULT =(1-NUM/DENOM)*X END EXTERNALLONGREALFN ICOT(LONGREAL X) LONGREAL DENOM CONSTLONGREAL MAX=1.0@15 CONSTLONGREAL NZERO=0.00000000000001;!@-14 IF X>MAX THEN MLIBERR(66) ELSESTART DENOM=ISIN(X) IF MOD(DENOM)<=NZERO THEN MLIBERR(67) ELSE RESULT =ICOS(X)/DENOM FINISH STOP END SYSTEMLONGREALFN IRADIUS(LONGREAL X, Y) ! %IF X*X>7@75 %OR X*X+Y*Y>7@75 %THEN MLIBERR(70) ! IMERR(25, 10) RESULT =ISQRT(X*X+Y*Y) END SYSTEMLONGREALFN IARCSIN(LONGREAL X) LONGREAL ARKSN, G, F, Q, Y, Y2 LONGREALARRAY DT(1:42) INTEGER I, J, M, M2 CONSTLONGREAL DROOT=1.4142135623730950488 CONSTLONGREALARRAY DA(0:21)=0.0, 1.48666649328710346896, 0.03885303371652290716, 0.00288544142208447113, 0.00028842183344755366, 0.00003322367192785279, 0.00000415847787805283, 0.00000054965045259742, 0.00000007550078449372, 0.00000001067193805630, 0.00000000154218037928, 0.00000000022681145985, 0.00000000003383885639, 0.00000000000510893752, 0.00000000000077911392, 0.00000000000011983786, .00000000000001856973, .00000000000000289619, .00000000000000045428, .00000000000000007162, .00000000000000001134, .00000000000000000180 ARKSN=0.0 G=0.0 F=0.0 Q=0.0 I=0 J=1 DT(1)=1.0 IF MOD(X)>1.0 THEN MLIBERR(72) ! IMERR(25, 1) IF (MOD(X)>=1./DROOT AND MOD(X)<=1.0) THEN C Y=ISQRT(1.0-X*X)*DROOT ELSE Y=X*DROOT DT(2)=Y ARKSN=ARKSN+0.74333324664350173448 Y2=Y*2 CYCLE M=2, 1, 21 G=ARKSN M2=M<<1 DT(M2-1)=Y2*DT(M2-2)-DT(M2-3) DT(M2)=Y2*DT(M2-1)-DT(M2-2) ARKSN=ARKSN+DA(M)*DT(M2-1) IF MOD(G-ARKSN)<0.0000000000000000005 THEN ->RESULT REPEAT RESULT: IF 1.0/DROOT<=MOD(X)<=1.0 START ARKSN=PI/2.0-ARKSN*Y IF X<0.0 THEN RESULT =-ARKSN ELSE RESULT =ARKSN FINISHELSERESULT =Y*ARKSN END SYSTEMLONGREALFN IARCCOS(LONGREAL X) IF MOD(X)>1.0 THEN MLIBERR(73) ! IMERR(25, 2) RESULT =PI/2.0-IARCSIN(X) END EXTERNALLONGREALFN IHYPSIN(LONGREAL X) LONGREAL Y, Z, XPOW IF MOD(X)>172.694 THEN MLIBERR(60) ! IMERR(25, 4) IF MOD(X)<0.3465736 THEN XPOW=X*X AND C RESULT =X*(1.0+XPOW*(0.16666505+0.00836915*XPOW)) Y=0.5*IEXP(X) Z=0.5*IEXP(-X) RESULT =Y-Z END EXTERNALLONGREALFN IHYPCOS(LONGREAL X) LONGREAL Y, Z IF MOD(X)>172.694 THEN MLIBERR(74) ! IMERR(25, 5) Y=0.5*IEXP(X) Z=0.5*IEXP(-X) RESULT =Y+Z END EXTERNALLONGREALFN IEXPTEN(LONGREAL X) INTEGER I I=INTPT(X) IF X-I=0.0 THENRESULT =10.0**I !10@XZ=E@(X*LN10) RESULT =IEXP(LOG10A*X) END EXTERNALLONGREALFN ILOGTEN(LONGREAL X) IF X=1.0 THENRESULT =0.0 RESULT =0.4342944819032518276511289*ILOG(X) END EXTERNAL LONG REAL FN GAMMAFN(LONG REAL X) LONG REAL RX,G,RT INTEGER K CONST LONG REAL ARRAY A(1:15)=0.99999999999999990, 0.42278433509851812, 0.41184033042198148, 0.08157691940138868, 0.07424900794340127, -0.00026695102875553, 0.01115381967190670, -0.00285150124303465, 0.00209975903507706, -0.00090834655742005, 0.00046776781149650, -0.00020644763191593, 0.00008155304980664, -0.00002484100538487, 0.00000510635920726 IF X > 57 THEN MLIBERR(65) RX = 1 IF 2 <= X <= 3 THEN -> G2 IF X < 2 THEN -> G3 G1: X = X-1 RX = RX*X IF X < 3 THEN -> G2 -> G1 G3: IF MOD(X) < 1@-11 THEN MLIBERR(63) RX = RX/X X = X+1 IF X < 2 THEN -> G3 G2: G = -0.00000051132627267 RT = X-2 CYCLE K=15,-1,1 G = G*RT+A(K) REPEAT RESULT = RX*G END EXTERNALLONGREALFN LOGGAMMA(LONGREAL X) LONGREAL U,YT,YR,FX,LX,MODD,SX INTEGER IND,K CONST LONGREAL ARRAY A(1:7)=0.083333333333333, -0.002777777777778, 0.000793650793651, -0.000595238095238, 0.000841750841751, -0.001917520917527, 0.006410256410256 YT=0.0 YR=4.2913@73 IF X<=YT THEN MLIBERR(64) IF X>=YR THEN MLIBERR(66) U=X FX=0 IF X< 0 THEN IND=1 ELSE IND=-1 X=MOD(X) IF X>=13 THEN -> G1 IF X<2@-10 THEN ->G6 G2: LX=LOG(X*X)/2 FX=FX+LX X=X+1 IF X<13 THEN ->G2 G1: IF IND =-1 THEN -> G5 K=INTPT(X+5@-8) IF MOD(X-K) <2@-10 THEN -> G6 G5: MODD=X*X LX=-2.955065359477124@-2 SX=LX*X/MODD CYCLE K=7,-1,1 LX=(SX*X)/MODD+A(K) SX=(LX*X)/MODD REPEAT SX=SX-X-FX+0.918938533204673 LX=LOG(X*X)/2 SX=SX+(X-0.5)*LX IF IND=1 THEN START FX=SIN(PI*U) X=U*FX MODD=PI/(X*X) LX=LOG(X*MODD*X*MODD)/2 SX=LX-SX FINISH RESULT =SX -> G7 G6: RESULT =1@17 G7: END EXTERNALLONGREALFN ERFN(LONGREAL X) LONGREAL A0, A1, B0, B1, Z, SUM, T, SA, SB, TEMP INTEGER S, N, SC CONSTLONGREAL EPS=0.0000000000000001;!@-16 CONSTLONGREAL SQPI=1.772453850905516 IF X=0 THEN RESULT =0 IF X>0 THEN S=1 ELSE S=-1 AND X=MOD(X) Z=X*X IF X<1 THENSTART SUM=X T=X N=0 E1: N=N+1 T=-T*Z*(2*N-1)/(N*(2*N+1)) SUM=SUM+T IF MOD(T)>EPS THEN ->E1 SUM=2*SUM/SQPI FINISHELSESTART A0=0 A1=1 B0=1 B1=X SUM=A1/B1 N=1 E2: N=N+1 SB=1 E3: TEMP=X*A1+(N-1)*A0/2 IF MOD(TEMP)>1000 THEN SA=1000 ELSE SA=1 A0=A1/SA A1=TEMP/SA TEMP=X*B1+(N-1)*B0/2 IF MOD(TEMP)>1000 THEN SB=1000 ELSE SB=0 B0=B1/SB B0=TEMP/SB N=N+SC IF SC=1 THEN SC=0 AND ->E3 T=(A1/B1)*(SA/SB) IF MOD(SUM-T)>EPS THENSTART SUM=T ->E2 FINISH SUM=1-IEXP(-Z)*T/SQPI FINISH RESULT =S*SUM END EXTERNALLONGREALFN ERFNC(LONGREAL X) RESULT =1-ERFN(X) END EXTERNALINTEGERFN BITS(INTEGER X) INTEGER I, J J=0 WHILE X#0 THEN J=J+X&1 AND X=X>>1 RESULT =J END EXTERNALINTEGERFN PARITY(INTEGER I) RESULT =1-(I&1)*2 END EXTERNALINTEGERFN SHIFTC(INTEGER X, Y) INTEGER Z IF -32<=Y<=32 THEN ->L3 PRINTSTRING(' ILLEGAL SHIFTC') MONITOR STOP L3: ->L2 IF Y<=0 *LSS_X *ROT_Y *EXIT_-64 L2: RESULT =X IF Y=0 *LSS_X *LUH_X *USH_Y *STUH_ B *EXIT_-64 END ! %EXTERNALINTEGERFN IFDBINARY(%SHORTINTEGERARRAYNAME CARD, %INTEGER %C ! COL1, COL2, %INTEGERNAME ERROR) ! %INTEGER I, J, K, L, RES ! %INTEGER M ! %INTEGER SIGN ! ->L1 %IF COL1>COL2 ! RES=0 ! M=1 ! ERROR=0 ! SIGN=0 ! J=1 ! %CYCLE I=COL1, 1, COL2 ! K=CARD(I) ! L=BITS(K) ! ->L5 %IF L=0 ! ->L2 %IF L#1 ! L=BITS(K-1) ! ->L6 %IF L=11 ! ->L4 %IF L=10 ! RES=10*RES+9-L ! M=0 ! ->L3 ! L5: ->L3 %IF M=1 ! ERROR=1 ! RES=10*RES ! ->L3 ! L4: J=-1 ! L6: ->L7 %IF SIGN=1 %OR M=0 ! SIGN=1 ! L3: %REPEAT ! ERROR=ERROR!M ! %RESULT =J*RES ! L1: ERROR=3 ! %RESULT =0 ! L2: ->L6 %IF K=2058 ! L7: ERROR=2 ! %RESULT =I ! %END ! ! ! %EXTERNALLONGREALFN RFDBINARY(%SHORTINTEGERARRAYNAME CARD, %INTEGER %C ! COL1, COL2, %INTEGERNAME ERROR) ! %INTEGER I, J, K, L, M, SCALE ! %INTEGER SIGN ! SIGN=0 ! %REAL RES ! M=1 ! ERROR=0 ! RES=0 ! SCALE=0 ! J=1 ! ->L1 %IF COL1>COL2 ! %CYCLE I=COL1, 1, COL2 ! L=BITS(CARD(I)) ! ->L5 %IF L=0 ! ->L2 %IF L#1 ! K=BITS(CARD(I)-1) ! ->L7 %IF K=11 ! ->L4 %IF K=10 ! RES=10*RES+9-K ! SCALE=10*SCALE ! M=0 ! ->L3 ! L5: ->L3 %IF M=1 ! ERROR=1 ! RES=10*RES ! SCALE=10*SCALE ! ->L3 ! L4: J=-1 ! L7: ->L8 %IF SIGN=1 %OR M=0 ! SIGN=1 ! L3: %REPEAT ! ERROR=M!ERROR ! %RESULT =J*RES %UNLESS SCALE#0 ! %RESULT =J*RES/SCALE ! L1: ERROR=3 ! %RESULT =0 ! L2: ->L7 %IF CARD(I)=2058 ! ->L6 %IF CARD(I)=2114 ! L8: ERROR=2 ! %RESULT =I ! L6: ->L8 %IF SCALE#0 ! SCALE=1 ! ->L3 ! %END EXTERNALROUTINE ISOCARD(BYTEINTEGERARRAYNAME CARD) IOCP(10, ADDR(CARD(1))) END EXTERNALLONGREALFN RFDISO(BYTEINTEGERARRAYNAME CARD, INTEGER COL1 C , COL2, INTEGERNAME ERROR) INTEGER I, J, K, L, M, SCALE INTEGER SIGN REAL RES SIGN=0 ->L1 IF COL1>COL2 M=1; ERROR=0; RES=0; SCALE=0; J=1 CYCLE I=COL1, 1, COL2 K=CARD(I) ->L5 IF K=' ' ->L7 IF K='+' ->L4 IF K='-' ->L2 UNLESS '0'<=K<='9' RES=RES*10+(K&15) SCALE=10*SCALE M=0 ->L3 L5: ->L3 IF M=1 ERROR=1 RES=10*RES SCALE=10*SCALE ->L3 L4: J=-1 L7: ->L8 IF SIGN=1 OR M=0; SIGN=1 L3: REPEAT ERROR=M!ERROR RESULT =J*RES UNLESS SCALE#0 RESULT =J*RES/SCALE L1: ERROR=3 RESULT =0 L2: ->L7 IF CARD(I)='&' ->L6 IF CARD(I)='.' L8: ERROR=2 RESULT =I L6: ->L8 IF SCALE#0; SCALE=1 ->L3 END EXTERNALINTEGERFN IFDISO(BYTEINTEGERARRAYNAME CARD, INTEGER COL1, C COL2, INTEGERNAME ERROR) INTEGER I, J, K, RES INTEGER SIGN INTEGER M ->L1 IF COL1>COL2 RES=0 ERROR=0 SIGN=0 M=1 J=1 CYCLE I=COL1, 1, COL2 K=CARD(I) ->L5 IF K=' ' ->L6 IF K='+' ->L4 IF K='-' ->L2 UNLESS '0'<=K<='9' RES=10*RES+K&15 M=0 ->L3 L5: ->L3 IF M=1 ERROR=1 RES=10*RES ->L3 L4: J=-1 L6: ->L7 IF SIGN=1 OR M=0 SIGN=1 L3: REPEAT ERROR=M!ERROR RESULT =J*RES L1: ERROR=3 RESULT =0 L2: ->L6 IF K='&' L7: ERROR=2 RESULT =I END EXTERNALROUTINE SOLVE LN EQ(LONGREALARRAYNAME A, B, INTEGER N, C LONGREALNAME DET) LONGREAL AMAX, CH INTEGER I, J, J MAX, S ->L3 IF N>0 PRINTSTRING(' SOLVE LN EQ DATA FAULT: N=') WRITE(N, 2); NEWLINE; STOP L3: ->L1 IF N>1 DET=A(1, 1) ->L2 IF DET=0 B(1)=B(1)/DET ->L2 L1: DET=1 CYCLE I=1, 1, N-1 A MAX=0; J MAX=0 CYCLE J=I, 1, N ->L4 IF MOD(A(J, I))<=AMAX AMAX=MOD(A(J, I)); JMAX=J L4: REPEAT ->L5 IF J MAX=I DET=-DET ->L6 IF J MAX#0 DET=0; ->L2 L6: CYCLE J=I, 1, N CH=A(I, J) A(I, J)=A(J MAX, J) A(J MAX, J)=CH REPEAT CH=B(I) B(I)=B(J MAX) B(J MAX)=CH L5: CH=A(I, I) DET=DET*CH CYCLE J=I+1, 1, N A MAX=A(J, I)/CH CYCLE S=I+1, 1, N A(J, S)=A(J, S)-A(I, S)*A MAX REPEAT B(J)=B(J)-B(I)*A MAX REPEAT REPEAT CH=A(N, N) DET=DET*CH ->L2 IF DET=0 B(N)=B(N)/CH CYCLE I=N-1, -1, 1 CH=B(I) CYCLE J=I+1, 1, N CH=CH-A(I, J)*B(J) REPEAT B(I)=CH/A(I, I) REPEAT L2: END EXTERNALROUTINE DIV MATRIX(LONGREALARRAYNAME A, B, INTEGER N, M, C LONGREALNAME DET) COMMENT A=INV(B)A:BNXN, ANXM LONGREAL AMAX, CH INTEGER I, J, JMAX, S, K ->L3 IF N>0 PRINTSTRING(' DIV MATRIX DATA FAULT N=') WRITE(N, 2) NEWLINE; STOP L3: ->L1 IF N>1 DET=B(1, 1) ->L2 IF DET=0 CYCLE I=1, 1, M A(1, I)=A(1, I)/DET REPEAT ->L2 L1: DET=1 CYCLE I=1, 1, N-1 AMAX=0; JMAX=0 CYCLE J=I, 1, N ->L4 IF MOD(B(J, I))<=AMAX AMAX=MOD(B(J, I)); JMAX=J L4: REPEAT ->L5 IF J MAX=I DET=-DET ->L6 IF JMAX#0 DET=0; ->L2 L6: CYCLE J=I, 1, N CH=B(I, J) B(I, J)=B(JMAX, J) B(JMAX, J)=CH REPEAT CYCLE K=1, 1, M CH=A(I, K) A(I, K)=A(JMAX, K) A(JMAX, K)=CH REPEAT L5: CH=B(I, I) DET=DET*CH CYCLE J=I+1, 1, N AMAX=B(J, I)/CH CYCLE S=I+1, 1, N B(J, S)=B(J, S)-B(I, S)*AMAX REPEAT CYCLE K=1, 1, M A(J, K)=A(J, K)-A(I, K)*AMAX REPEAT REPEAT REPEAT CH=B(N, N) DET=DET*CH ->L2 IF DET=0 CYCLE K=1, 1, M A(N, K)=A(N, K)/CH REPEAT CYCLE I=N-1, -1, 1 AMAX=B(I, I) CYCLE K=1, 1, M CH=A(I, K) CYCLE J=I+1, 1, N CH=CH-B(I, J)*A(J, K) REPEAT A(I, K)=CH/AMAX REPEAT REPEAT L2: END EXTERNALROUTINE UNIT(LONGREALARRAYNAME A, INTEGER N) INTEGER I, J ->L10 IF N>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, N A(I, J)=0 REPEAT A(I, I)=1 REPEAT END EXTERNALROUTINE INVERT(LONGREALARRAYNAME A, B, INTEGER N, C LONGREALNAME DET) COMMENT A=INV B USING DIV MATRIX ->L3 IF N>0 PRINTSTRING(' INVERT DATA FAULT N=') WRITE(N, 2); NEWLINE; STOP L3: UNIT(A, N) DIV MATRIX(A, B, N, N, DET) END EXTERNALLONGREALFN DET(LONGREALARRAYNAME A, INTEGER N) LONGREALARRAY B(1:N); LONGREAL DET INTEGER I ->L10 IF N>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N B(I)=0 REPEAT SOLVE LN EQ(A, B, N, DET) RESULT =DET END EXTERNALROUTINE NULL(LONGREALARRAYNAME A, INTEGER N, M) INTEGER I, J ->L10 IF N>0 AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, M A(I, J)=0 REPEAT REPEAT END EXTERNALROUTINE ADD MATRIX(LONGREALARRAYNAME A, B, C, INTEGER N, M) INTEGER I, J ->L10 IF N>0 AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, M A(I, J)=B(I, J)+C(I, J) REPEAT REPEAT END EXTERNALROUTINE SUB MATRIX(LONGREALARRAYNAME A, B, C, INTEGER N, M) INTEGER I, J ->L10 IF N>0 AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, M A(I, J)=B(I, J)-C(I, J) REPEAT REPEAT END EXTERNALROUTINE COPY MATRIX(LONGREALARRAYNAME A, B, INTEGER N, M) INTEGER I, J ->L10 IF N>0 AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, M A(I, J)=B(I, J) REPEAT REPEAT END EXTERNALROUTINE MULT MATRIX(LONGREALARRAYNAME A, B, C, INTEGER N, C P, M) COMMENT A=B*C, A IS N X M INTEGER I, J, K LONGREAL R ->L10 IF N>0 AND M>0 AND P>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, M R=0 CYCLE K=1, 1, P R=R+B(I, K)*C(K, J) REPEAT A(I, J)=R REPEAT REPEAT END EXTERNALROUTINE MULT TR MATRIX(LONGREALARRAYNAME A, B, C, INTEGER C N, P, M) LONGREAL R COMMENT A=B*C, A IS N X M INTEGER I, J, K ->L10 IF N>0 AND M>0 AND P>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, M R=0 CYCLE K=1, 1, P R=R+B(I, K)*C(J, K) REPEAT A(I, J)=R REPEAT REPEAT END EXTERNALROUTINE TRANS MATRIX(LONGREALARRAYNAME A, B, INTEGER N, M) COMMENT AN X M, B M X N INTEGER I, J ->L10 IF N>0 AND M>0 PRINTSTRING(' MATRIX BOUND ZERO OR NEGATIVE') NEWLINE MONITOR STOP L10: CYCLE I=1, 1, N CYCLE J=1, 1, M A(I, J)=B(J, I) REPEAT REPEAT END EXTERNALREALFN RANDOM(INTEGERNAME I, INTEGER N) REAL X INTEGER J ->L2 IF N<0; ->L1 IF N>1 ! %CONTROL 0;! I=(65539*I)&X'7FFFFFFF';! %CONTROL X'1111' J=I *LSS_65539 *IMYD_J *AND_X'000000007FFFFFFF' *STUH_B *ST_J I=J RESULT =0.0000000004656613*I L1: X=0 CYCLE N=1, 1, N; X=X+RANDOM(I, 1); REPEAT ; RESULT =X L2: PRINTSTRING('NEGATIVE ARGUMENT IN RANDOM'); MONITOR STOP END RECORDFORMAT NRFDFMT(INTEGER LINK,DSNUM, C BYTEINTEGER STATUS, ACCESS ROUTE, VALID ACTION, CUR STATE, C BYTEINTEGER MODEOFUSE, MODE, FILE ORG, DEV CLASS, C BYTEINTEGER REC TYPE, FLAGS, LM, RM, C INTEGER ASVAR, AREC, RECSIZE, MINREC, MAXREC, MAXSIZE,ROUTECCY, C INTEGER C0, C1, C2, C3, TRANSFERS, C INTEGER DARECNUM,SPARE1,SPARE2, C STRING (31) IDEN) !* SYSTEMROUTINESPEC DATE AND TIME (STRINGNAME DATE , TIME) SYSTEMROUTINESPEC SIGNAL (INTEGER EP , P1 , P2 , INTEGERNAME F) SYSTEMINTEGERFNSPEC FORTRANDF(INTEGER DSNUM, NUMBLOCKS, BLKSIZE, C ASVARD) SYSTEMINTEGERFNSPEC OUTREC(INTEGER LENGTH) SYSTEMINTEGERFNSPEC INREC SYSTEMINTEGERFNSPEC NEW FILE OP(INTEGER DSNUM, ACTION, TYPE, C INTEGERNAME AFD) SYSTEMINTEGERMAPSPEC COMREG(INTEGER N) SYSTEMROUTINESPEC SSERR(INTEGER ERROR) CONSTINTEGERARRAY BYTES(3:7)=1, 2, 4, 8, 16 OWNINTEGER SQL ! !* ROUTINE MOVE(INTEGER LENGTH, FROM, TO) INTEGER I RETURNIF LENGTH <= 0 I = X'18000000'!LENGTH *LSS_FROM *LUH_I *LDTB_I *LDA_TO *MV_L =DR END ; !OF MOVE !* ROUTINE FILL(INTEGER LENGTH, FROM,FILLER) INTEGER I RETURNIF LENGTH <= 0 I = X'18000000'!LENGTH *LDTB_I *LDA_FROM *LB_FILLER *MVL_L =DR END !* ! EXTERNALROUTINE OPENSQ(INTEGER CHAN) SYSTEMROUTINESPEC OPENSQ (INTEGER CHANNEL) OPENSQ(CHAN) END ! ! EXTERNALROUTINE READSQ(INTEGER CHAN, BD1, BD2, ED1, ED2) RECORDNAME SQFD(NRFDFMT) INTEGER START, FINISH, SIZE, AFD, FLAG, LENGTH SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID DATA SET NUMBER FLAG=NEW FILE OP(CHAN, 1, 2, AFD) ! OPEN FILE SSERR(FLAG) IF FLAG>0; ! INVALID OPERATION ON FILE SQFD==RECORD(AFD) SSERR(178) IF SQFD_STATUS<2 SIZE=(BD1&X'38000000')>>27 START=BD2 FINISH=ED2+BYTES(SIZE) LENGTH=FINISH-START IF LENGTH<=0 THEN SSERR(177); ! ADDRESS INSIDE OUT FLAG=INREC; ! READ RECORD INTO BUFFER IF FLAG>0 THEN START ; ! INPUT FILE ENDED SIGNAL(2,140,0,FLAG) STOP FINISH IF SQFD_RECSIZE<LENGTH START MOVE(SQFD_RECSIZE, SQFD_AREC, START) FILL(LENGTH-SQFD_RECSIZE, START+SQFD_RECSIZE,0) LENGTH=SQFD_RECSIZE FINISHELSE MOVE(LENGTH, SQFD_AREC, START) SQL=LENGTH RETURN END ! ! EXTERNALROUTINE WRITESQ(INTEGER CHAN, BD1, BD2, ED1, ED2) RECORDNAME SQFD(NRFDFMT) INTEGER START, FINISH, SIZE, AFD, FLAG, LENGTH SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID DATA SET NUMBER FLAG=NEW FILE OP(CHAN, 2, 2, AFD) ! OPEN FILE SSERR(FLAG) UNLESS FLAG <= 0 SIZE=(BD1&X'38000000')>>27 START=BD2 FINISH=ED2+BYTES(SIZE) LENGTH=FINISH-START IF LENGTH<=0 THEN SSERR(177); ! ADDRESS INSIDE OUT SQFD==RECORD(AFD) UNLESS SQFD_MINREC<=LENGTH<=SQFD_MAXREC THEN SSERR(161) !INVALID RECORD SIZE MOVE(LENGTH, START, SQFD_AREC) FLAG=OUTREC(LENGTH); ! OUTPUT RECORD SSERR(FLAG) UNLESS FLAG<=0; ! INVALID OPERATION ON FILE RETURN END ! ! EXTERNALROUTINE READLSQ(INTEGER CHAN, BD1, BD2, ED1, ED2, C INTEGERNAME SQLEN) READSQ(CHAN, BD1, BD2, ED1, ED2) SQLEN=SQL END ! ! EXTERNALINTEGERFN LENGTHSQ RESULT =SQL END ! ! EXTERNALROUTINE CLOSESQ(INTEGER CHAN) SYSTEMROUTINESPEC CLOSESQ (INTEGER CHANNEL) CLOSESQ (CHAN) END ! ! EXTERNALROUTINE OPENDA(INTEGER CHAN) SYSTEMROUTINESPEC OPENDA (INTEGER CHANNEL) OPENDA(CHAN) END ! ! EXTERNALROUTINE READDA(INTEGER CHAN, INTEGERNAME SECT, INTEGER C BD1, BD2, ED1, ED2) OWNINTEGER FSECT LONGINTEGER ADFSECT RECORDNAME DAFD(NRFDFMT) INTEGER START, FINISH, AFD, FLAG, SIZE, LEN SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID FILE NUMBER FLAG=NEW FILE OP(CHAN, 1, 3, AFD) SSERR(FLAG) IF FLAG>0 DAFD==RECORD(AFD) SSERR(178) UNLESS DAFD_STATUS>=2 SIZE=(BD1&X'38000000')>>27 START=BD2 FINISH=ED2+BYTES(SIZE) IF FINISH<=START THEN SSERR(177) FSECT=SECT ADFSECT=ADDR(FSECT) FLAG=FORTRANDF(CHAN, -1, 1024, ADDR(ADFSECT)) SSERR(FLAG) IF FLAG>0 LEN = 1024 WHILE START<FINISH THENCYCLE IF START + LEN > FINISH THEN LEN = FINISH - START DAFD_DARECNUM=FSECT FLAG=INREC SSERR(FLAG) IF FLAG>0 MOVE(LEN,DAFD_AREC,START) START=START+LEN REPEAT SECT=FSECT END ! ! EXTERNALROUTINE WRITEDA(INTEGER CHAN, INTEGERNAME SECT, INTEGER C BD1, BD2, ED1, ED2) OWNINTEGER FSECT LONGINTEGER ADFSECT RECORDNAME DAFD(NRFDFMT) INTEGER START, FINISH, AFD, FLAG, SIZE SSERR(164) UNLESS 1<=CHAN<=99; ! INVALID FILE NUMBER FLAG=NEW FILE OP(CHAN, 2, 3, AFD) SSERR(FLAG) IF FLAG>0 DAFD==RECORD(AFD) SSERR(178) UNLESS DAFD_STATUS>=2 SIZE=(BD1&X'38000000')>>27 START=BD2 FINISH=ED2+BYTES(SIZE) IF FINISH<=START THEN SSERR(177) FSECT=SECT ADFSECT=ADDR(FSECT) FLAG=FORTRANDF(CHAN, -1, 1024, ADDR(ADFSECT)) SSERR(FLAG) IF FLAG>0 WHILE START<FINISH THENCYCLE DAFD_DARECNUM=FSECT MOVE(1024,START,DAFD_AREC) FLAG=OUTREC(1024) SSERR(FLAG) IF FLAG>0 START=START+1024 REPEAT SECT=FSECT END ! ! EXTERNALROUTINE CLOSEDA(INTEGER CHAN) SYSTEMROUTINESPEC CLOSEDA (INTEGER CHANNEL) CLOSEDA (CHAN) END ! ! ! IMP ROUTINES FOR DATE AND TIME EXTERNALLONGREALFN CPUTIME SYSTEMLONGREALFNSPEC CPUTIME RESULT = CPUTIME END ; ! CPUTIME !* EXTERNALSTRINGFN DATE STRING (10) D, T, U, V D='YYYY.MM.DD' T='HH:MM:SS' DATE AND TIME(D,T) IF D -> ("19").T.("/").U.("/").V C THEN D = V."/".U."/".T RESULT = D END ; ! DATE !* EXTERNALSTRINGFN TIME STRING (10) D, T D='DD.MM.YY' T='HH:MM:SS' DATE AND TIME(D,T) RESULT = T END !* ! FORTRAN ROUTINES FOR DATE AND TIME CALLABLE ONLY FROM FORTE !* EXTERNALROUTINE CPUTIM(LONGREALNAME X) X=CPUTIME END EXTERNALROUTINE CTIME(LONGREALNAME X) STRING (10) T T=TIME MOVE(8,ADDR(T)+1,ADDR(X)) BYTEINTEGER(ADDR(X)+2)=':' BYTEINTEGER(ADDR(X)+5)=':' END EXTERNALROUTINE HDATE(LONGREALNAME X) STRING (10) D D=DATE MOVE(8,ADDR(D)+1,ADDR(X)) END !* EXTERNALROUTINE SET MARGINS(INTEGER STREAM, LHM, RHM) IF STREAM > 98 OR STREAM < 1 THEN -> F1 IF LHM > RHM AND RHM#0 THEN -> F2 IF COMREG(22) = STREAM THEN -> IP IF COMREG(23) ¬= STREAM THEN -> F1 IF LHM < 1 OR RHM > 132 THEN -> F2 IOCP(13,(LHM<<16)!RHM) RETURN IP: IF LHM < 1 OR RHM > 160 THEN -> F2 IF RHM=0 THEN ->F2 IOCP(12,(LHM<<16)!RHM) RETURN F1:SSERR(24) F2:SSERR(33) END EXTERNALROUTINE READ STRING(STRINGNAME S) INTEGER I; STRING (2) T L1: READSYMBOL(I) -> L1 IF I = 10 OR I = 32 OR I = 25 -> L2 IF I = '''' OR I='"' SSERR(34) L2: S = 0 L3: -> L4 IF NEXT SYMBOL = '''' L5: READ ITEM(T) S = S.T; -> L3 L4: SKIP SYMBOL -> L5 IF NEXT SYMBOL = '''' END EXTERNALSTRINGFN FROM STRING(STRING (255) S, INTEGER I, J) STRING (255) T INTEGER N, P N = LENGTH(S); IF J > N THEN J = N -> L1 IF I <= J AND J <= 255 AND 1 <= I SSERR(35) L1: P = ADDR(T)+1 CYCLE N = I,1,J BYTEINTEGER(P) = BYTEINTEGER(ADDR(S)+N) P = P+1 REPEAT BYTEINTEGER(ADDR(T)) = J-I+1 RESULT = T END ! EXTERNALROUTINE CLOSE STREAM(INTEGER STREAM) IF STREAM>98 OR STREAM<1 OR COMREG(22)=STREAM C OR COMREG(23)=STREAM THEN SSERR(24) IOCP(16,STREAM) END !* EXTERNALLONGREALFN LRANDOM(INTEGERNAME I, INTEGER N) LONGREAL X INTEGER J ->L2 IF N<0; ->L1 IF N>1 ! %CONTROL 0;! I=(65539*I)&X'7FFFFFFF';! %CONTROL X'1111' J=I *LSS_65539 *IMYD_J *AND_X'000000007FFFFFFF' *STUH_B *ST_J I=J RESULT =0.0000000004656613*I L1: X=0 CYCLE N=1, 1, N; X=X+LRANDOM(I, 1); REPEAT ; RESULT =X L2: PRINTSTRING("NEGATIVE ARGUMENT IN LRANDOM"); MONITOR STOP END ; !OF LRANDOM ENDOFFILE