%BEGIN ! ! THIS PROGRAM PERFORMS A COMBINATION OF TWO ACTIONS DEPENDING ON ! THE VALUE OF THE CONTROL ARGUMENT ACT. ! ! ACT=1 CREATES A NEW PROFILE FILE FROM THE INPUT STREAM SPECIFIED ! AS THE SECOND ARGUMENT AND WRITES IT TO THE SEQUENTIAL FILE ! SPECIFIED ON LUN 20. ! ! ACT=2 THE SAME AS FOR ACT=1, BUTN THE PROFILE FILE CREATED IS ! PRINTED FOR REFERENCE PURPOSES. ! ! ACT=3 THE PROFILE FILE IS READ FROM THE SEQUENTIAL FILE SPECIFIED ! AS LUN 20 AND THE CONTENTS ARE PRINTED. ! %ROUTINESPEC CREATE PROFILES (%INTEGERNAME PISTRM,MAX, %C 00001600 %BYTEINTEGERARRAYNAME PROFIL) %ROUTINESPEC READ PROFILES (%INTEGERNAME UNIT,MAX, %C 00001800 %BYTEINTEGERARRAYNAME PROF) %ROUTINESPEC SORT(%BYTEINTEGERARRAYNAME AX, %INTEGERARRAYNAME PTR,N, %C %INTEGER P1,P2) %ROUTINESPEC COPYTEXT(%BYTEINTEGERARRAYNAME SOURCE, %INTEGER SSTRT, %C %BYTEINTEGERARRAYNAME DEST, %INTEGER DSTRT,L) %ROUTINESPEC RDRAR(%INTEGER UNIT,BLOCK,POSN,NO, %C %BYTEINTEGERARRAYNAME TO, %INTEGERNAME LENG) %ROUTINESPEC WRITE PROFILES(%INTEGER UNIT,MAX, %C %BYTEINTEGERARRAYNAME PROF) ! %BYTEINTEGERARRAY PROFIL (1:25000) ;! PROFILE DETAILS %BYTEINTEGERARRAY PRTEXT (1:600) ;! TEXT OF CURRENT RECORD ! %INTEGER ACT ;! I/P ARG SPECIFYING ACTION REQ %INTEGER DISP ;! DISPLACEMENT OF NEXT RECORD %INTEGER ENO ;! NUMBER OF ITEMS IN PROFILE %INTEGER I ;! LOOP VARIABLE %INTEGER IP ;!POINTER TO PROFILE ARRAY %INTEGER J ;! LOOP VARIABLE %INTEGER LIM ;! LOOP LIMIT %INTEGER MAX ;! EXTENT OF PROF ARRAY USED %INTEGER MXBUFS ;! SIZE OF I/O BUFFERS %INTEGER NO ;! ROUTINE ENTRY NUMBER %INTEGER NT ;! NUMBER OF TERMS IN PROFILE %INTEGER PDSP ;! WD CONTAINING DISPLACEMENT %INTEGER PDUNIT ;! LUN OF PROFILE DISC FILE %INTEGER PISTRM ;! PROFILE I/P STREAM NUMBER %INTEGER PNXP ;! WD POINTING TO NEXT PROFILE %INTEGER PNXU ;! WD POINTING TO NEXT USER %INTEGER PRLENG ;! LENGTH OF CURRENT PROFILE %INTEGER UNBL ;! USER NAME/ADDR BLOCK POINTER %INTEGER UNPS ;! USER NAME/ADDR POSITION PTR %INTEGER USCT ;! NO OF USER PROFILES %INTEGER USUNIT ;! USER NAME/ADDR UNIT NUMBER ! %BYTEINTEGER CODE ;! CODE OF CURRENT PROFILE ! %OWNINTEGER YES=1 ;! CONSTANT ! %OWNBYTEINTEGER AC='A' ;! AUTHOR CODE (POSITIVE) %OWNBYTEINTEGER BC='B' ;! AUTHOR CODE (NEGATIVE) %OWNBYTEINTEGER BLNK=' ' ;! BLANK %OWNBYTEINTEGER JC='J' ;! JOURNAL CODE (NEGATIVE) %OWNBYTEINTEGER KC='K' ;! JOURNAL CODE (POSITIVE) %OWNBYTEINTEGER MC='-' ;! SECONDARY 'NOT' CODE %OWNBYTEINTEGER NC='N' ;! PRIMARY 'NOT' CODE %OWNBYTEINTEGER NINE='9' ;! MAX NUMERIC CONSTANT %OWNBYTEINTEGER NL=X'0A' ;! NEWLINE CHARACTER 00006550 %OWNBYTEINTEGER PC='+' ;! 'AND' CODE %OWNBYTEINTEGER SC='*' ;! END OF PROFILE CODE %OWNBYTEINTEGER SMK='@' ;! SEQUENCE MARK %OWNBYTEINTEGER TWO='2' ;! MIN NUMERIC CONSTANT %OWNBYTEINTEGER UC='%' ;! USER RECORD CODE %OWNBYTEINTEGER XC='X' ;! SINGLE PROFILE RECORD CODE %OWNBYTEINTEGER ZC='Z' ;! START OF NEXT PROFILE CODE ! USUNIT=10 PDUNIT=20 NO=1 MXBUFS=1000 USCT=0 ;! ZEROISE COUNT ! READ (ACT) ;! READ ACTION PARAMETER %IF ACT=3 %THEN READ PROFILES (PDUNIT,MAX,PROFIL) %ELSEC %START ;! ACT=1 OR 2 READ (PISTRM) CREATE PROFILES (PISTRM,MAX,PROFIL) %FINISH %IF ACT=1 %THENC %START ;! PRINT OF PROFS NOT REQUIRED WRITE PROFILES (PDUNIT,MAX,PROFIL) %STOP %FINISH ! NEWPAGE SPACES(20) PRINTSTRING('PROFILES CREATED BY INPUT ROUTINE') NEWLINE SPACES(20) PRINTSTRING('*********************************') NEWLINE PNXU=1 ! NXUS:NEWLINES(3) IP=PNXU UNBL=HALFINTEGER(ADDR(PROFIL(IP))); !?? WAS SHORTINTEGER UNPS=HALFINTEGER(ADDR(PROFIL(IP+2))); !?? WAS SHORTINTEGER RDRAR (USUNIT,UNBL,UNPS,NO,PRTEXT,PRLENG) USCT=USCT+1 ;! INCREMENT USER COUNT 00010625 WRITE(USCT,3) 00010650 PRINTSTRING(') ') 00010675 %CYCLE I=1,1,PRLENG %IF PRTEXT(I)=NL %THENC 00010750 %START 00010775 NEWLINE 00010800 SPACES(6) 00010825 %FINISH %ELSE PRINT SYMBOL(PRTEXT(I)) 00010850 %REPEAT NEWLINES(2) NO=2 WRITE(IP,5) PRINTSTRING('. ') WRITE(UNBL,3) WRITE(UNPS,4) PNXU=INTEGER(ADDR(PROFIL(IP+4))) WRITE(PNXU,6) WRITE(INTEGER(ADDR(PROFIL(IP+8))),6) WRITE(INTEGER(ADDR(PROFIL(IP+12))),1) PNXP=IP+16 ! NXPR:NEWLINE IP=PNXP PNXP=INTEGER(ADDR(PROFIL(IP))) WRITE(IP,5) PRINTSTRING('. (') WRITE(PNXP,5) PRINTSTRING(' )') IP=IP+4 ! NXSB:CODE=PROFIL(IP) ENO=PROFIL(IP+1) PRINT SYMBOL(CODE) WRITE(ENO,2) IP=IP+2 %IF CODE=ZC %OR CODE=PC %OR TWO<=CODE<=NINE %THENC %START DISP=HALFINTEGER(ADDR(PROFIL(IP))); !?? WAS SHORTINTEGER WRITE(DISP,3) DISP=DISP+IP IP=IP+2 SPACE %FINISH %ELSEC %START DISP=0 SPACES(5) %FINISH ! %CYCLE I=1,1,ENO LIM=PROFIL(IP) SPACE %CYCLE J=1,1,LIM PRINT SYMBOL(PROFIL(IP+J)) %REPEAT IP=IP+LIM+1 %REPEAT ! %IF DISP\=0 %THENC %START NEWLINE SPACES(19) IP=DISP -> NXSB %FINISH %IF PNXP\=0 %THEN -> NXPR %IF PNXU\=0 %THEN -> NXUS NEWLINES(5) PRINTSTRING(' NUMBER OF USERS =') WRITE(USCT,3) NEWLINES(2) PRINTSTRING(' SIZE OF PROFILE ARRAY =') WRITE(IP,6) ! %IF ACT=3 %THEN -> ENDJ ;! NEW FILE NOT CREATED WRITE PROFILES(PDUNIT,IP,PROFIL) ! ENDJ:NEWLINES(5) SPACES(30) PRINTSTRING('END OF JOB') NEWLINE SPACES(30) PRINTSTRING('**********') %STOP ! %ROUTINE CREATE PROFILES (%INTEGERNAME PISTRM,MAX, %C 00018200 %BYTEINTEGERARRAYNAME PROFIL) ! ! ********************************************************************* ! ! CREATE PROFILES ! ! ********************************************************************* ! ! THIS ROUTINE READS THE USER PROFILES FROM THE UNIT SPECIFIED ! AND CREATES THE INTERNAL RECORD WHICH IS USED TO EXTRACT RECORDS ! FOR THE SDI PRODUCTION PROGRAM. ! %ROUTINESPEC FETCH PROFILE(%INTEGER UNIT,%BYTEINTEGERARRAYNAME TEXT, %C %INTEGERNAME LENG,TYPE,NXTYPE,END) %ROUTINESPEC MARKPTERMS(%BYTEINTEGERARRAYNAME ARR,%INTEGER ST,MAX, %C 00029000 %INTEGERNAME NT) %ROUTINESPEC WRUNA (%INTEGERNAME UNIT,BLOCK,POSN, %C 00032000 %BYTEINTEGERARRAYNAME FROM, %INTEGER LENG,NO) 00032050 %INTEGERFNSPEC ALIGN (%INTEGER PTR,WIDTH) ! %INTEGERARRAY TBGN(1:50) ;! POINTERS TO START OF TERMS %INTEGERARRAY TLNG(1:50) ;! LENGTH OF TERMS ! %OWNINTEGER ECODE=0 ;! SWITCH VARIABLE %OWNINTEGER EOF=0 ;! END OF FILE INDIC - OFF %OWNINTEGER IP=1 ;! POINTER TO PROFILE RECORD %OWNINTEGER NO=1 ;! ENTRYPOINT INDICATOR ! %INTEGER I ;! LOOP VARIABLE %INTEGER NXTYPE ;! TYPE OF NEXT I/P RECORD %INTEGER TYPE ;! CURRENT I/P RECORD TYPE ! %SWITCH END(1:2) ;! END OF I/P FOUND %SWITCH ENTER(0:3) ;! TYPE OF ENTRY REQUIRED %SWITCH NOTP(1:2) ;! ACTION REQUIRED 00030700 ! ! THE NEXT PROFILE RECORD IS READ FROM THE I/P MEDIUM ! NOTP(1):FETCH PROFILE(PISTRM,PRTEXT,PRLENG,TYPE,NXTYPE,EOF) %IF EOF=YES %THEN -> END(NO) ;! EXIT IF END OF FILE %IF TYPE\=1 %THEN -> NOTP(NO) ;! JUMP IF OT START OF USER WRUNA(USUNIT,UNBL,UNPS,PRTEXT,PRLENG,NO) ;! WRITE DETS TO DISC 00034400 NO=2 ;! ENSURE SWITCH CORRECTLY SET -> NOTP(1) ;! READ NEXT RECORD ! ! THE PROFILE IS ANALYSED AND THE INTERNAL PROFILE FOR THIS USER ! IS CREATED FROM THE INPUT DETAILS ! NOTP(2):MARKPTERMS(PRTEXT,2,PRLENG,NT) ;! SET POINTERS TO TERMS 00032300 SORT(PRTEXT,TBGN,TLNG,1,NT) ;! SORT TERMS TO ASCENDING ORDER -> ENTER(ECODE) ;! JUMP TO ENTER DETAILS ! ! NEW USER - LINK FORWARD FROM PREVIOUS PROFILE (OMITTED FOR FIRST ! ENTRY ONLY), STORE REFERENCE TO USER NAME AND ADDRESS DETAILS ! STORED ON DISC AND SET UP OTHER HEADER INFORMATION. ! ENTER(1):INTEGER(ADDR(PROFIL(PNXU)))=IP ENTER(0):HALFINTEGER(ADDR(PROFIL(IP)))=UNBL; !?? WAS SHORTINTEGER HALFINTEGER(ADDR(PROFIL(IP+2)))=UNPS; !?? WAS SHORTINTEGER PNXU=IP+4 ;! STORE POSN OF PTR TO NEXT USER INTEGER(ADDR(PROFIL(IP+8)))=0 ;! ZEROISEE CONCORDANCE POINTERS INTEGER(ADDR(PROFIL(IP+12)))=0 ;! FOR SDI REFERENCES IP=IP+16 ;! UPDATE PROFILE POINTER ! ! START OF NEW PROFILE ! ENTER(2):PNXP=IP ;! SET CURRENT PPTR TO PROF LINK IP=IP+4 ;! UPDATE POINTER ! ! NEXT RECORD - DETAILS EXTRACTED AND STORED ! ENTER(3):PROFIL(IP)=PRTEXT(1) ;! STORE RECORD TYPE CODE PROFIL(IP+1)=NT ;! STORE NUMBER OF TERMS IP=IP+2 ;! UPDATE POINTER %IF TYPE=3 %OR TYPE=5 %THENC %START ;! MORE RECORDS FOLLOW PDSP=IP ;! SET DISPLACEMENT POINTER IP=IP+2 ;! ALLOW SPACE FOR THIS %FINISH %CYCLE I=1,1,NT ;! MOVE TERMS TO PROFILE PROFIL(IP)=TLNG(I) ;! EACH PRECEDED BY ITS LENGTH COPYTEXT(PRTEXT,TBGN(I),PROFIL,IP+1,TLNG(I)) IP=IP+TLNG(I)+1 ;! UPDATE POINTER %REPEAT ! %IF TYPE=3 %OR TYPE=5 %THENC %START IP=ALIGN(IP,2)+1 ;! ALIGN IP TO 1/2 WORD HALFINTEGER(ADDR(PROFIL(PDSP)))=IP-PDSP; !?? WAS SHORTINTEGER ECODE=3 ;! SET SWITCH VARIABLE -> NOTP(1) ;! READ NEXT RECORD %FINISH IP=ALIGN(IP,4)+1 ;! ALIGN IP ON FULL WORD %IF NXTYPE=1 %THENC %START ;! LAST RECORD FOR THIS USER ECODE=1 ;! SET SWITCH IN READINESS INTEGER(ADDR(PROFIL(PNXP)))=0 ;! SET LAST PROFILE INDIC %FINISH %ELSEC %START ;! MORE PROFILES FOR THIS USER ECODE=2 ;! SET SWITCH VARIABLE INTEGER(ADDR(PROFIL(PNXP)))=IP %FINISH -> NOTP(1) ;! JUMP TO FETCH NEXT RECORD ! ! END OF FILE FOUND BEFORE ANY VALID RECORD READ ! END(1):NEWLINES(3) PRINTSTRING('NO VALID PROFILE FOUND IN FILE - JOB TERMINATED') %STOP ! ! NORMAL END OF FILE - LAST ENTRY TO DISC O/P ROUTINE TO TIDY ! END(2):NO=3 WRUNA(USUNIT,UNBL,UNPS,PRTEXT,PRLENG,NO) ;! CLOSE FILE 00041600 INTEGER(ADDR(PROFIL(PNXU)))=0 ;! MARK END OF PROFILES MAX=IP-1 ;! SET EXTENT OF ARRAY %RETURN %ROUTINE MARKPTERMS(%BYTEINTEGERARRAYNAME ARR, %INTEGER ST,MAX, %C 00039400 %INTEGERNAME NT) ! ! ********************************************************************* ! ! MARKPTERMS ! ! ********************************************************************* ! ! ROUTINE TO MARK START AND LENGTH OF VALID TERMS IN I/P PROFILE 00039700 ! %ROUTINESPEC MARKPTERM (%BYTEINTEGERARRAYNAME ARR, %INTEGER MXA, %C 00039900 %INTEGERNAME ST,LN,IA) %INTEGER NB ;! START OF WORD %INTEGER NL ;! LENGTH OF WORD ! NT=0 ;! ZEROISE WORD POINTER MKTM:MARKPTERM(ARR,MAX,NB,NL,ST) 00040500 %IF NB=0 %THEN %RETURN ;! RETURN WHEN END REACHED NT=NT+1 ;! UPDATE WORD POINTER TBGN(NT)=NB TLNG(NT)=NL ;! STORE WORD DETAILS -> MKTM %ROUTINE MARKPTERM(%BYTEINTEGERARRAYNAME ARR, %INTEGER MXA, %C 00041400 %INTEGERNAME ST,LN,IA) ! ! ********************************************************************* ! ! MARKPTERM ! ! ********************************************************************* ! ! THIS ROUTINE FINDS THE START AND LENGTH OF THE NEXT SEQUENCE OF ! NON-BLANK CHARACTERS IN THE ARRAY ARR(MXA) STARTING FROM THE ! POSITION IA. IF A SEQUENCE IS FOUND, ST IS SET TO THE VALUE OF ! IA WHEN THE FIRST CHARACTER IS FOUND, LN IS SET TO THE LENGTH OF ! THE SEQUENCE. ON EXIT IA POINTS IMMEDIATELY PAST THE LAST CHAR. ! %INTEGER IND ;! SWITCH VARIABLE %BYTEINTEGER DEL ;! DELIMITER CHARACTER %SWITCH S1,S2(1:2) ! DEL=' ' ;! NORMAL DELIMITER IS BLANK ST=0 ;! SET START VALUE TO ZERO IND=1 ;! SET SWITCH VARIABLE -> CHCK ;! JUMP TO CHECK FIRST CHAR ! S1(1):S2(2):IA=IA+1 ;! INCREMENT POINTER CHCK:%IF IA > MXA %THENC %START ;! END OF ARRAY REACHED %IF ST=0 %THEN %RETURN ;! ERROR EXIT IF NO WORD FOUND -> S1(2) ;! ELSE SET LENGTH ETC. %FINISH %IF ARR(IA)=DEL %THEN -> S1(IND) ;! JUMP IF DELIMITER FOUND -> S2(IND) ;! TO S1 ELSE JUMP TO S2 ! ! WHEN FIRST NON-BLANK FOUND THE SWITCH VARIABLE IS ALTERED SO THAT ! THE NEXT DELIMITER FOUND ACTS AS A TERMINATOR. ! S2(1):IND=2 ;! CHANGE INDICATOR %IF ARR(IA)=SMK %THENC %START ;! START SEQ MARK FOUND DEL=SMK ;! DELIMITER IS RESET ST=IA+1 ;! START ADDRESS IS SET %FINISH %ELSE ST=IA -> S1(1) ;! CONTINUE ! ! THE FIRST DELIMITER FOUND TERMINATES THE CURRENT TERM ! S1(2):LN=IA-ST ;! SET LENGTH OF WORD %IF DEL\=' ' %THEN IA=IA+1 ;! MOVE IA PAST DELIM IF NEC ! %END ;! MARKPTERM 00045700 ! %END ;! MARKPTERMS 00045900 %ROUTINE FETCH PROFILE (%INTEGER UNIT, %BYTEINTEGERARRAYNAME TEXT, %C %INTEGERNAME LENG,TYPE,NXTYPE,EOF) ! ! ********************************************************************* ! ! FETCH PROFILE ! ! ********************************************************************* ! ! THIS ROUTINE READS THE NEXT RECORD FROM THE INPUT UNIT, CHECKS ! THE VALIDITY OF THE CODE, SETS THE RECORD TYPE AND RETURNS IT ! TO THE CALLING ROUTINE ! %INTEGER IT ;! POINTER TO ARRAY TEXT %OWNINTEGER ENO=1 ;! ENTRY POINT INDIC %BYTEINTEGER CODE ;! CODE LETTER OF CURRENT RECORD %OWNBYTEINTEGER NXCD ;! CODE OF FOLLOWING RECORD ! %SWITCH ENTRY(1:2) ;! ENTRY SWITCH ! ! ENSURE CORRECT INPUT STREAM SELECTED ! -> ENTRY(ENO) ! ENTRY(1):ENO=2 ;! RESET SWITCH VARIABLE SELECT INPUT (UNIT) READ SYMBOL(NXCD) ;! SET NEXT CODE ENTRY(2):CODE=NXCD ;! SET CODE CHARACTER 00040300 %IF CODE=UC %THENC %START ;! USER NAME/ADDR CARDS %IF NEXT SYMBOL=UC %THENC %START ;! END OF PROFILES FOUND EOF=1 ;! SET FILE END INDICATOR %RETURN %FINISH TEXT(1)=BLNK ;! CLEAR FIRST CHARACTER %FINISH %ELSEC %START ;! NON-USER CARD TEXT(1)=CODE ;! STORE CODE IN RECORD %FINISH IT=2 ;! SET POINTER RDSM:READ SYMBOL (TEXT(IT)) ;! READ NEXT CHARACTER %IF TEXT(IT)=NL %THENC %START ;! NEWLINE FOUND %IF NEXT SYMBOL \= BLNK %THEN -> DECI %IF CODE=UC %THEN IT=IT+1 %FINISH %ELSE IT=IT+1 ;! UPDATE POINTER -> RDSM ! DECI:IT=IT-1 ;! REMOVE TRAILING BLANKS %IF TEXT(IT)=BLNK %THEN -> DECI LENG=IT ;! SET LENGTH READ SYMBOL(NXCD) ;! READ CODE OF NEXT RECORD ! ! TYPE MUST NOW BE CALCULATED FROM THE CODE CHARACTERS ! %IF CODE =PC %THENC %START ;! + %IF NXCD\=PC %AND NXCD\=NC %THENC %START ;! LAST + CARD OF PROFILE CODE=SC ;! SET * CODE TYPE=4 ;! SET TYPE %FINISH %ELSE TYPE=5 -> NTYP %FINISH ! %IF CODE=ZC %THENC %START ;! Z CODE %IF NXCD\=PC %AND NXCD\=NC %THENC %START CODE=XC ;! CHANGE CODE TO X TYPE=2 ;! SET TYPE %FINISH %ELSE TYPE=3 -> NTYP %FINISH ! %IF CODE=NC %THENC %START ;! N CODE TYPE=4 ;! ALWAYS TYPE 4 -> NTYP %FINISH ! %IF CODE=AC %OR CODE =JC %THENC %START ;! CODE A OR J TYPE=2 ;! SET TYPE 2 %IF TEXT(2)=PC %OR TEXT(2)=MC %THENC %START ;! + OR - FOLLOWS CODE %IF CODE=AC %AND TEXT(2)=MC %THEN CODE=BC %IF CODE=JC %AND TEXT(2)=PC %THEN CODE=KC TEXT(2)=BLNK ;! CLEAR COL 2 %FINISH -> NTYP %FINISH ! %IF CODE=UC %THENC %START ;! % CODE TYPE=1 ;! SET TYPE -> NTYP %FINISH ! %IF TWO<=CODE<=NINE %THENC %START TYPE=3 ;! NUMERIC CODE SET TYPE -> NTYP %FINISH ! ! UNRECOGNISABLE CODE - PRINT RECORD WITH MESSAGE ! NEWLINES(2) PRINTSTRING('CODE NOT RECOGNISED - PROFILE RECORD IGNORED') NEWLINE %CYCLE IT=1,1,LENG PRINT SYMBOL(TEXT(IT)) %REPEAT -> ENTRY(2) ;! JUMP TO CHECK NEXT 00049000 ! ! CODE IS RESTORED TO ARRAY AND NEXT TYPE SET BEFORE RETURNING ! NTYP:%IF CODE\=UC %THEN TEXT(1)=CODE %IF NXCD=UC %THEN NXTYPE=1 %ELSE NXTYPE=0 ! %END ;! FETCH PROFILE %INTEGERFN ALIGN (%INTEGER PTR,WIDTH) ! ! ********************************************************************* ! ! ALIGN ! ! ********************************************************************* ! ! ROUNDS THE PTR UP TO THE NEXT MULTIPLE OF WIDTH - THE VALUE ! OF WHICH MUST BE A POWER OF 2. ! %RESULT=(PTR-1)!(WIDTH-1)+1 %END ;! ALIGN %ROUTINE WRUNA (%INTEGERNAME UNIT,BLOCK,POSN, %C %BYTEINTEGERARRAYNAME FROM, %INTEGER LENG,NO) ! ! ********************************************************************* ! ! WRUNA ! ! ********************************************************************* ! ! ROUTINE WRITES THE RECORD OF LENGTH 'LENG' FROM THE ARRAY 'FROM' ! TO THE NEXT AVAILABLE POSITION ON DISC 'UNIT'. THE 'BLOCK' AND ! 'POSN' OF THE START POINT ARE RETURNED TO THE CALLING ROUTINE. ! A RECORD IS ALWAYS CONTAINED IN A SINGLE BLOCK FOR SPEED WHEN ! READING THE RECORDS BACK IN RANDOM ORDER. ! %EXTERNALROUTINESPEC OPENDA (%INTEGER CHANNEL) %EXTERNALROUTINESPEC CLOSEDA (%INTEGER CHANNEL) %EXTERNALROUTINESPEC WRITEDA (%INTEGER CHANNEL,%INTEGERNAME BLOCK, %C %NAME BEGIN,END) ! %OWNINTEGER IB=1 ;! POINTER TO CURRENT BLOCK %OWNINTEGER IP=1 ;! POINTER TO CURRENT POSITION %OWNBYTEINTEGERARRAY BUF(1:1000) ;! OUTPUT AREA %INTEGER I ;! LOOP VARIABLE %SWITCH ENTRY(1:3) 00065150 ! -> ENTRY(NO) ! ENTRY(1):OPENDA(UNIT) ! ENTRY(2):%IF IP+LENG+1 > MXBUFS %THENC %START ;! BUFFER FULL WRITEDA(UNIT,IB,BUF(1),BUF(MXBUFS)) 00065900 IB=IB+1 ;! INCREMENT BLOCK POINTER IP=1 ;! RESET POSITION POINTER %FINISH BLOCK=IB ;! RETURN BLOCK AND POSITN PTRS POSN=IP ;! TO CURRENT RECORD BUF(IP)=LENG>>8&X'FF' ;! LENGTH OF RECORD IS STORED BUF(IP+1)<-LENG ;! IN FIRST TWO BYTES POINTED TO IP=IP+1 %CYCLE I=1,1,LENG BUF(IP+I)=FROM(I) ;! TRANSFER TEXT TO BUFFER %REPEAT IP=IP+LENG+2 ;! INCREMENT POSITION POINTER %RETURN ! ENTRY(3):WRITEDA(UNIT,IB,BUF(1),BUF(MXBUFS)) ;! EMPTY LAST BUFFER CLOSEDA(UNIT) ! %END ;! WRUNA ! %END ;! CREATE PROFILES %ROUTINE SORT(%BYTEINTEGERARRAYNAME AX,%INTEGERARRAYNAME PTR,N, %C %INTEGER P1,P2) ! ! ********************************************************************* ! ! SORT ! ! ********************************************************************* ! %INTEGERFNSPEC LEXISIGN(%BYTEINTEGERARRAYNAME B1,%INTEGER S1,L1, %C %BYTEINTEGERARRAYNAME B2,%INTEGER S2,L2) %INTEGERARRAY UT(1:20), LT(1:20) %INTEGER Q,M,P,T,X,I,J,K,NT ! I=P1 J=P2 ;! INITIALISE ARRAY VARIABLES M=1 ! START: %IF J-I < 1 %THEN -> ENDCHK %IF J-I = 1 %THEN -> LSTCHK ! P=(J+I)//2 ;! SET MID-POINT T=PTR(P) NT=N(P) PTR(P)=PTR(I) N(P)=N(I) Q=J K=I+1 ! NEXT:%IF LEXISIGN(AX,PTR(K),N(K),AX,T,NT)>0 %THENC %START LIMCHK: %IF Q CHANGE %FINISH %IF LEXISIGN(AX,PTR(Q),N(Q),AX,T,NT)<0 %THENC %START ;! SWOP POINTERS X=PTR(K) PTR(K)=PTR(Q) PTR(Q)=X X=N(K) ;! SWOP LENGTHS N(K)=N(Q) N(Q)=X Q=Q-1 %FINISH %ELSEC %START Q=Q-1 -> LIMCHK %FINISH %FINISH K=K+1 %IF K <= Q %THEN -> NEXT ! CHANGE:PTR(I)=PTR(Q) N(I)=N(Q) PTR(Q)=T N(Q)=NT %IF Q > P %THENC %START LT(M)=I UT(M)=Q-1 I=Q+1 %FINISH %ELSEC %START LT(M)=Q+1 UT(M)=J J=Q-1 %FINISH M=M+1 -> START ! LSTCHK:%IF LEXISIGN(AX,PTR(I),N(I),AX,PTR(J),N(J))>0 %THENC %START X=PTR(I) PTR(I)=PTR(J) PTR(J)=X X=N(I) N(I)=N(J) N(J)=X %FINISH ! ENDCHK:M=M-1 %IF M> 0 %THENC %START I=LT(M) J=UT(M) -> START %FINISH %INTEGERFN LEXISIGN (%BYTEINTEGERARRAYNAME B1, %INTEGER S1,L1, %C %BYTEINTEGERARRAYNAME B2, %INTEGER S2,L2) ! ! ********************************************************************* ! ! LEXISIGN ! ! ********************************************************************* ! ! RETURNS +VE VALUE IF WORD1>WORD2, -VE IF WORD1 UNEQUAL %REPEAT %RESULT=L1-L2 UNEQUAL:%RESULT=B1(I1+I)-B2(I2+I) %END ;! LEXISIGN ! %END ;! SORT %ROUTINE RDRAR (%INTEGER UNIT,BLOCK,POSN,NO, %C %BYTEINTEGERARRAYNAME TO, %INTEGERNAME LENG) ! ! ********************************************************************* ! ! RDRAR ! ! ********************************************************************* ! ! THIS ROUTINE READS A RECORD FROM THE RANDOM ACCESS DEVICE 'UNIT' ! TO THE ARRAY 'TO' FROM THE POSITION 'POSN' IN 'BLOCK'. THE LENGTH ! OF THE RECORD IS EXPEXTED TO APPEAR IN THE FIRST TWO BYTES OF THE ! RECORD (THIS IS NOT ALIGNED) ! ! THE ROUTINE IS USED TO READ FROM THE USER NAME AND ADDRESS FILE ! AND FROM THE MASTER JOURNAL TITLE FILE. ! %EXTERNALROUTINESPEC OPENDA(%INTEGER CHANNEL) %EXTERNALROUTINESPEC CLOSEDA(%INTEGER CHANNEL) %EXTERNALROUTINESPEC READDA(%INTEGER CHANNEL, %INTEGERNAME BLOCK, %C %NAME BEGIN,END) ! %BYTEINTEGERARRAY BUF(1:MXBUFS) ;! I/P AREA ! %INTEGER I %INTEGER IB ;! BLOCK POINTER 00131130 %INTEGER IP ;! POSITION POINTER 00131160 ! %SWITCH ENTRY(1:3) 00131250 -> ENTRY(NO) ! ENTRY(1):OPENDA(UNIT) ! ENTRY(2):IB=BLOCK ;! SET REQUIRED BLOCK READDA(UNIT,BLOCK,BUF(1),BUF(MXBUFS)) IP=POSN LENG=BUF(IP)<<8!BUF(IP+1) ;! EXTRACT LENGTH IP=IP+1 %CYCLE I=1,1,LENG TO(I)=BUF(IP+I) ;! TRANSFER RECORD TEXT %REPEAT %RETURN ! ENTRY(3):CLOSEDA(UNIT) ! %END ;! RDRAR %ROUTINE COPYTEXT(%BYTEINTEGERARRAYNAME SOURCE,%INTEGER SSTRT, %C %BYTEINTEGERARRAYNAME DEST,%INTEGER DSTRT,L) ! ! ********************************************************************* ! ! COPYTEXT ! ! ********************************************************************* ! ! MOVES L BYTES FROM SOURCE(SSTRT) ET SEQ. TO DEST(DSTRT) ET SEQ. %INTEGER I ! %IF L<= 0 %THEN %RETURN %CYCLE I=SSTRT,1,SSTRT+L-1 DEST(DSTRT)=SOURCE(I) DSTRT=DSTRT+1 %REPEAT %END;! COPYTEXT ! %ROUTINE WRITE PROFILES (%INTEGER UNIT,MAX,%BYTEINTEGERARRAYNAME PROF) ! ! ********************************************************************* ! ! WRITE PROFILES ! ! ********************************************************************* ! %EXTERNALROUTINESPEC OPENDA (%INTEGER CHANNEL) %EXTERNALROUTINESPEC CLOSEDA(%INTEGER CHANNEL) %EXTERNALROUTINESPEC WRITEDA(%INTEGER CHANNEL,%INTEGERNAME SECTOR %C %NAME BEGIN,END) ! %INTEGERARRAY MX(1:1) ;! DUMMY ARRAY FOR O/P %INTEGER BLOCK ! OPENDA(UNIT) MX(1)=MAX ;! STORE MAX BLOCK=1 WRITEDA (UNIT,BLOCK,MX(1),MX(1)) BLOCK=BLOCK+1 WRITEDA (UNIT,BLOCK,PROF(1),PROF(MAX)) CLOSEDA(UNIT) ! %END ;! WRITE PROFILES %ROUTINE READ PROFILES (%INTEGERNAME UNIT,MAX, %C 00076400 %BYTEINTEGERARRAYNAME PROF) 00076450 ! ! ********************************************************************* ! ! READ PROFILES ! ! ********************************************************************* ! %EXTERNALROUTINESPEC OPENDA (%INTEGER CHANNEL) %EXTERNALROUTINESPEC CLOSEDA(%INTEGER CHANNEL) %EXTERNALROUTINESPEC READDA(%INTEGER CHANNEL,%INTEGERNAME SECTOR %C %NAME BEGIN,END) ! %INTEGER BLOCK %INTEGERARRAY MX(1:1) ;! I/P AREA ! OPENDA(UNIT) BLOCK=1 READDA(UNIT,BLOCK,MX(1),MX(1)) ;! READ SIZE OF ARRAY MAX=MX(1) ;! RETURN MAX VALUE BLOCK=BLOCK+1 READDA(UNIT,BLOCK,PROF(1),PROF(MAX)) CLOSEDA(UNIT) ! %END ;! READ PROFILES %ENDOFPROGRAM 2 98 //