SLIB77 Hied  SUBROUTINE VERSNC C Initializes the program versionC *CA IVERS  LSTMOD='MOD47 ' d LSTMOD='COBOL1 ' e LSTMOD='MOD49 ' f LSTMOD='MOD50 ' g LSTMOD='MOD51 ' hBATCH 6/14/82BUFA 3/22/82BUFI 3/22/82CONTRL 3/22/82CUREDT 3/22/82DATE 3/22/82 DECA 3/22/82!DECI 3/22/82#DECKS 3/22/82%DIRDIC 3/22/82(DIRSTA 3/22/82*EDIBKU 11/02/82+CEDITCO 6/14/82,IFSWI 3/22/820INISO 3/22/822INPERC 10/04/834fINREC 3/22/825IVERS 3/22/827LANGC 9/28/838dLIMITS 3/22/82:LOGU 3/22/82;MODCOM 3/22/82?MODKEY 3/22/82@MODNA 3/22/82BPARAMA 3/22/82CPARAMB 3/22/82HPRFX 3/22/82LSCAN 3/22/82MSEQCTL 3/08/83ORSWITCH 3/22/82PTYPDCK 3/22/82QWIDTH 3/08/83RRYANDEC 3/17/83SVYANPTR 3/17/83UVMAIN 3/22/82WCKDIR 3/22/82\CKDKMC 3/22/82bCKEDIT 6/14/82gCKINP 5/03/82o COMCHC 3/22/82 COMCHK 3/22/82 COMCHM 3/22/82COMPID 4/15/82CTLCRD 3/22/82-DIRCHK 8/26/82,EDIADD 6/14/82EDIADT 6/14/82EDIBOT 6/14/82EDICHA 6/14/82EDICH1 6/14/82EDICH2 6/14/82EDICON 6/14/82EDIDEL 6/14/82EDIDIR 6/14/82EDIEND 6/14/82EDIFIN 6/14/82EDIHEL 6/14/82EDIHE1 6/14/82EDIHE2 6/14/82EDIHE3 3/28/83XEDIINI 6/14/824EDIINS 6/14/82SEDILIS 6/14/82XEDIMIN 6/14/82`EDINEX 6/14/82cEDIPLS 6/23/82eEDIPOS 6/14/82gEDIPRI 6/14/82nEDIPRS 6/23/82pEDIPRT 6/22/82rEDIREC 6/14/82u EDIREP 6/14/82EDISER 6/14/82EDISID 6/14/82EDITOP 6/14/82EDITOR 6/14/82EDIVMD 6/14/82EXAL 3/22/82EXIN 3/22/82GETBUF 3/22/82GTFWD 3/22/82HEADER 3/22/82ICKDIC 3/22/82IFINDK 3/22/82IFINMD 3/22/82INAL 3/22/82INCHW 6/14/82ININ 3/22/82INITL 3/22/82INP 3/22/82 INPADD 11/22/82 HINSCOM 3/22/82KOMDEC 3/22/82KOMMOD 3/22/82KOMYAN 3/17/83VLISCOM 3/22/82LISCRD 3/22/82LISDCK 3/22/82LISERR 11/05/82ELISMOD 3/22/82LOCREC 3/22/82MODDCK 3/22/82 MOVDK 3/22/82)NAMCHK 3/17/83+UNXUNIN 3/22/82.OPNLNP 3/22/820#PADD 3/22/82S PDECK 3/22/82`PDEFIN 3/22/82cPDELET 3/22/82hPEDIT 3/22/82kPIDENT 3/22/82pPINSRT 3/22/82sPMOVE 3/22/82vPPURGE 3/22/82|PRENAM 5/03/82 PRESTO 3/22/82PROC3 3/22/82PROC4 3/22/82PYANK 3/17/83 VQIKSRT 3/22/82RDDK 3/22/82RDINP 3/22/82 RDOPA 3/22/82RDOPL 3/22/82RDOPLA 3/22/82 RDPLA 3/22/82RDPL1 3/22/82RDTERM 6/14/82RECADD 3/22/82RECDEL 3/22/82 RECMOV 3/22/82RECRES 3/22/82REPINC 8/03/82 %RVAL 3/22/82#SCAN1 3/22/82( SCAN2 3/22/822SRTMOD 3/22/827STATIS 3/22/82= PUPDAT 3/09/83G SUCASE 9/22/83RcVAXMOD 3/22/82T WRDK 3/22/82_VERSN 9/22/83acWRNPL 3/22/82c WRNPLA 3/22/82nWRPL1 3/22/82vWRPLA 3/22/82xXDATE 3/22/82z YADDA1 3/17/83VYADDA2 3/17/83VYINITP 3/17/83VYWRR 3/17/83V2000 CONTINUE o IDECP1=1 p DO 2100 I=1,NSWSL q NSWS=NSWS+1 r CALL EXAL(ADEC(IDECP1),IDECP1,SWITCH(NSWS)) s2100 CONTINUEt PRINT*,' SWITCHES SET FROM OLD LIBRARY',MOD1 3/22/82MOD2 3/22/82MOD7E 4/09/82MOD7F 4/15/82MOD7H 4/21/82MOD7G 4/26/82MOD7J 4/27/82MOD7K 4/27/82MOD7M 4/30/82MOD7N 4/30/82MOD7I 5/03/82MOD8A 5/03/82MOD8B 5/03/82MOD8C 5/05/82MOD8D 5/06/82MOD8E 5/06/82BPA1 5/12/82MOD9A 5/14/82EDT1 6/14/82MOD9B 6/21/82EDT2 6/21/82ED3 6/21/82MOD9C 6/22/82MOD9D 6/22/82MOD9E 6/22/82MOD9F 6/22/82MOD9G 6/23/82MOD9J 6/23/82MOD9K 6/24/82MOD9L 6/24/82MOD9M 6/25/82NOD9M 6/25/82MOD10 6/30/82MOD9H 7/01/82MOD10A 7/01/82MOD10B 7/02/82BPA2 8/03/82SRP1 8/06/82BASN1 8/18/82SRP2 8/20/82IFEDIT 8/23/82IFEDT2 8/24/82BASN2 8/24/82MOD11 8/26/82MODIF 9/01/82MODI4 9/01/82MOD12 9/01/82MOD13 9/01/82HARIS1 9/01/82HARIS2 9/02/82BASN3 9/07/82PRIX1 9/16/82IBMOPN 9/16/82EDT4 9/16/82ARGCAT 9/17/82MOD14 9/21/82HP11 9/29/82CDC0 9/29/82EDT5 10/04/82MOD15 10/06/82IBM1 10/07/82EDT6 10/14/82MOD16 10/15/82MOD17 10/18/82BPA3 10/22/82BASN4 10/28/82BPA4 11/02/82MOD18 11/03/82MOD19 11/05/82MOD20 11/05/82M21 11/19/82M22 11/22/82M23 11/29/82M24 12/23/82COS0 12/23/82M25 1/13/83M26 1/27/83M27 2/07/83M28 2/07/83M30 3/02/83M29 3/07/83M31 3/08/83M32 3/09/83M33 3/17/83NAMCHK 3/17/83M34 3/17/83MLO1 3/18/83M36 3/28/83M37 4/15/83M38 5/13/83M39 6/01/83M40 6/09/83M41 6/30/83BPA7 7/19/83MOD43 7/27/83IBMWID 8/05/83MOD45 9/02/83MOD46 9/06/83MOD47 9/22/83COBOL1 9/28/83MOD49 10/04/83MOD50 10/04/83MOD51 10/05/83MOD52 10/12/83MOD53 10/14/83 CALL LISCRD(ITD,IL,IAC,DCK,NSQ,A,LENA) i ENDIF C  IF(A(1:1).EQ.PRFX) THEN [  IF(ITD .NE. 0) THEN VAX REC4 TERM5 EDIT MOD2 3/22/82MOD7E 4/09/82MOD7F 4/15/82MOD7H 4/21/82MOD7G 4/26/82MOD7J 4/27/82MOD7K 4/27/82MOD7M 4/30/82MOD7N 4/30/82MOD7I 5/03/82MOD8A 5/03/82MOD8B 5/03/82MOD8C 5/05/82MOD8D 5/06/82MOD8E 5/06/82BATCH 6/14/82C  COMMON /BATC/ BATCH  LOGICAL BATCH C 4/26/82MOD7J 4/27/82MOD7K 4/27/82MOD7M 4/30/82MOD7N 4/30/82MOD7I 5/03/82MOD8A 5/03/82MOD8B 5/03/82MOD8C 5/05/82MOD8D 5/06/82MOD8E 5/06/82BUFA 3/22/82fR C BUFA.CMNC C INPUT RECORD BUFFER C  COMMON /INTXT/ BUF  CHARACTER*120 BUF R CHARACTER*(MAXWID) BUF  CHARACTER*(NCHRWD) BUF4 (MAXWID+NCHRWD-1/NCHRWD) CHARACTER *(NCHRWD) BUF4((MAXWID+NCHRWD-1)/NCHRWD)  EQUIVALENCE(BUF4,BUF) fC f COMMON /INRECN/ INRCN fC fC INRCN - Current input record numberfC  C BUFI 3/22/82 C BUFI.CMNC C INPUT RECORD BUFFER - INTEGER C  COMMON /INTXT/ IBUF(MAXWID+NCHRWD-1/NCHRWD) C CHARACTER*(NCHRWD) BUF4 (MAXWID+NCHRWD-1/NCHRWD)  EQUIVALENCE(BUF4,BUF)  C CONTRL 3/22/82 C CONTRL C C CONTROLS FOR RUNC  COMMON /CTRL/ ICF, ICQ, ICLO, ICC, ICL,  1 ICS, ICN, ICNA, ICP, ICPA C  LOGICAL ICF, ICQ, ICLO, ICC, ICL,  1 ICS, ICN, ICNA, ICP, ICPA  C  COMMON /CTRLI/ LSTA, LSTC, LSTD, LSTE,  1 LSTI, LSTM, LSTS, LSTT  C  LOGICAL LSTA, LSTC, LSTD, LSTE,  1 LSTI, LSTM, LSTS, LSTT C  LOGICAL ICLST(8)  EQUIVALENCE(ICLST,LSTA) C CUREDT 3/22/82C C CURRENT EDT RECORD BEING USED (INITIAL SORT KEY)C  COMMON /CURED/ NEDRCC  1 ICS, ICN, ICNA, ICP, ICPA C  LOGICAL ICF, ICQ, ICLO, ICC, ICL,  1 ICS, ICN, ICNA, ICP, ICPA  C  DATE 3/22/82 C DATE.CMNC  COMMON /DATEC/ DATE,TIMDAY  CHARACTER*8 DATE,TIMDAY C  1 ICS, ICN, ICNA, ICP, ICPA C  LOGICAL ICF, ICQ, ICLO, ICC, ICL,  1 ICS, ICN, ICNA, ICP, ICPA  C  DECA 3/22/82. C DECA.CMNC C WORK DECK ARAYS - CHARACTER C USED TO READ DECK INTO AND MODIFY DECK FROM C  COMMON /ADEC/ ADEC(MAXWRD)  CHARACTER*(NCHRWD) ADEC  COMMON /DECS/ ISDEC(2)  C  INTEGER*4 IDECP1,IDECP2 .*IF I4 . INTEGER*4 IDECP1,IDECP2,ISDEC .*ENDIF  COMMON /DECP/ IDECP1,IDECP2  INTEGER*4 ISDEC  C DECI 3/22/82. C DECI.CMNC C WORK DECK ARAYS - INTEGER C USED TO READ DECK INTO AND MODIFY DECK FROM C  COMMON /ADEC/ IDEC(MAXWRD)  INTEGER*4 IDEC  COMMON /DECS/ ISDEC(2)  INTEGER*4 ISDEC .*IF I4 . INTEGER*4 IDEC,ISDEC,IDECP1,IDECP2 .*ENDIF C  COMMON /DECP/ IDECP1,IDECP2  INTEGER*4 IDECP1,IDECP2  C DECKS 3/22/82C DECKS.CMN C  COMMON /DECKN/ NDCKS, ITYPE(MAXDCK),LOCF(MAXDCK),LOCB(MAXDCK),  1 NBLOK(MAXDCK),IIDENT(MAXDCK),  2 IPURGE(MAXDCK),IEDIT(MAXDCK)C  COMMON /DECKA/ DECK(MAXDCK), DATED(MAXDCK)  CHARACTER*8 DECK, DATED  C C NDCKS - NUMBER OF DECKS C DECK - DECK NAME C ITYPE - DECK TYPE C 0 - NORMAL C 1 - COMMON C LOCF - LOCATION -FILE NUMBER C LOCB - LOCATION - BLOCK ON FILE C IEDIT - EDIT SWITCH C 0 - DONT EDIT C 1 - DO EDIT C NBLOK - NUMBER OF BLOCKS FOR DECK C IIDENT - IDENT NO THAT ADDED DECK C IPURGE - DECK PURGE STATUS C 0 - DECK NOT PURGED C NOT 0 - IDENT NO TO HAVE PURGED DECKC DIRDIC 3/22/82C C C DIRECTIVE DICTIONARY (DIRDIS-SHORT)(DIRDIL-LONG)  PARAMETER (MAXDIR=18)  PARAMETER (MAXDIR=19) C  COMMON /DIRDIC/ DIRDIS(MAXDIR),DIRDIL(MAXDIR)  CHARACTER*10 DIRDIS,DIRDIL  CHARACTER DIRDIS*4, DIRDIL*10 C CC IDIRL - LENGTH OF EACH DIRDIL ENTRY C COMMON /DIRDIN/ IDIRL(MAXDIR) CC DIRSTA 3/22/82C C DIRECTIVE STATISTICSC  COMMON /DIRST/ NDITOT,NODIR(MAXDIR) C IRDIL(MAXDIR)  CHARACTER*10 DIRDIS,DIRDIL C C  COMMON /DECKA/ DECK(MAXDCK), DATED(MAXDCK)  CHARACTER*8 DECK, DATED  C C NDCKS - EDIBKU 11/02/82C  COMMON /EDIBKU/ LBAKUF  LOGICAL LBAKUF C LBAKUF - Backup File Writing switchC TRUE=write FALSE=dont write C 0/82MOD7I 5/03/82MOD8A 5/03/82MOD8B 5/03/82MOD8C 5/05/82MOD8D 5/06/82MOD8E 5/06/82EDITCO 6/14/82.C  COMMON /EDTCH/ EDECK  CHARACTER EDECK*8 C C EDECK - DECK TO BE EDITED C  COMMON /EDIIN/ IR(0:MAXREC),N(0:MAXREC),L(0:MAXREC) .*IF I4  INTEGER*4 IR.*ENDIF  C  C IR - POINT TO RECORD IN DEC ARAYS  C N - POINT TO NEXT RECORD IN IR ARAY C L - POINT TO LAST (PREVIOUS) RECORD IN IP ARAY  C  COMMON /EDIPOI/ IDECPN,IDECE,IREC,NRECI,NRECT,IDECI .*IF I4  INTEGER*4 IDECPN.*ENDIF C C IDECPN - NEXT WORD TO BE USED IN ADEC ARAYS C IDECE - DECK NUMBER BEING EDITEDC IREC - CURRENT RECORD POINTER C NRECI - NUMBER OF RECORDS INITIALLY C NRECT - NUMBER OF RECORDS CURRENTLY (TOTAL) C C IDECI - LENGTH OF DECK ARAY INITIALLY C C  COMMON /EDILOG/ LSTSEQ  LOGICAL LSTSEQ C C LSTSEQ - SWITCH FOR LISTING OF SEQUENCE INFO ON TERMINAL(EDIT) C .FALSE. (DEF) DONT PRINT SEQ. INFO C .TRUE. DO LIST SEQ. INFO C IFSWI 3/22/82d- C IFSW.CMNC C IFSWITCH (DETERMINES IF RECORDS ARE WRITTEN TO COMPILE FILE C  COMMON /IFSWI/ ISETIF - COMMON /IFSWI/ ISETIF, NIFS, ISIF(MAXSWI) -C -C NIFS DEPTH OF CURRENT IF'S -C -C ISIF() SETTING OS SWITCH AT THAT LEVEL (SAME AS FOR ISETIF) dC ISIF() SETTING OF SWITCH AT THAT LEVEL (SAME AS FOR ISETIF) C C ISETIF C 0 - SWITCH HAS BEEN SET  C 1 - SWITCH IS NOT SET  C INISO 3/22/82C C INITIAL SORT DATA C C USED TO SORT $DECK CARDSC  COMMON /INISO/ NINSO,INIDK(MAXMDK),INICD(MAXMDK)C C NINSO - NUMBER OF RECORDS IN INITIAL SORT ARRAYS C  C INIDK - DECK NUMBER OF RECORD  C  C INICD - LOCATION OF RECORD IN INS ARRAY  C C ITYPE - DECK TYPE C 0 - NORMAL C 1 - COMMON C LOCF - LOCATION -FILE NUMBER C LOCB - LOCATION - BLOCK ON FILE C IEDIT - EDIT SWITCH C 0 - DONT EDIT C 1 - DO EDIT C INPERC 10/04/83C C Input Error Count C  COMMON /INPERC/ INERRF C C INERRF - Number of input fatal errors C N 4/30/82MOD7I 5/03/82MOD8A 5/03/82MOD8B 5/03/82MOD8C 5/05/82MOD8D 5/06/82MOD8E 5/06/82INREC 3/22/82 C INREC.CMN C C INPUT RECORD COMMON C ...INITIAL INPUT RECORD KEYS...C  COMMON /INPTK/ NDIR,NIN,INLOC(MAXDRR),  1 INTYP(MAXDRR),IPRD(MAXDRR)  LOGICAL IPRD C BE MADE  C NIN - NUMBER OF RECORDS READ IN C INLOC - DIRECTIVE RECORD NUMBER C INTYP - DIRECTIVE TYPE  C NDIR - NUMBER OF DIRECTIVES C C IPRD - DIRECTIVE PROCESSED? C .FALSE.- NO C .TRUE. - YESC IEDIT - EDIT SWITCH C 0 - DONT EDIT C 1 - DO EDIT C IVERS 3/22/82bC C IVERS - CURRENT VERSION OF PROGRAM SET IN INITL bC LSTMOD - Latest mod to program C  COMMON /IVERSN/ IVERS b COMMON /LSMOD/ LSTMOD b CHARACTER*8 LSTMOD C LANGC 9/28/83C C --- LANG = Source LANGUAGE for library contents. C 0 = Not yet specified (FORTRAN assumed) C 1 = FORTRAN C 2 = COBOL C LANG flag applies to entire library. C Once set it cannot be changed.C  C --- LANGNM = Character name for language type (FORTRAN, COBOL) C COMMON /LANC/ LANG COMMON /LANGT/ LANGNM(2) CHARACTER*8 LANGNM C INREC 3/22/824IVERS 3/22/826LIMITS 3/22/827LOGU 3/22/828MODCOM 3/22/82;MODKEY 3/22/82<MODNA 3/22/82LIMITS 3/22/82 C LIMITS C  COMMON /LIMS/ LIMDCK, 1 LIMWRD, LIMMNA, LIMMKD, LIMMDD,  2 LIMSWI, LIMDRR, LIMDIR  3 ,LCHRWD, LWRDBK, LIMWID C LOGICAL IPRD C BE MADE  C NIN - NUMBER OF RECORDS READ INLOGU 3/22/82f C LOGUC C FILE COMMON BLOCK C  COMMON /LUNS/ LIN,LOP,LSO,LCO,LNP,LSR,LSI,  1 LIA,LOA,LOU  2 ,LBO,LBI,LTI,LDO,LDIf 2 ,LBO,LBI,LTI,LDO,LDI,LTOC C LOCATION FOR NEXT WRITE (RANDOM FILES - EOF) C  COMMON /LUNLOC/ LOCLNP, LOCLSR C ...DEFINITIONS...  C  C LIN - (51) INPUT(CARD IMAGE) C LOU - (13) LIST OUTPUT C LOP - (31) OLD LIBRARY C LSO - (12) SOURCE OUTPUT C LCO - (14) COMPILE C LNP - (11) NEW LIBRARY C LSR - (50) SCRATCH LIBRARY C LSI - (49) SCRATCH INPUTC LIA - (15) OLD LIBRARY (ASCII) fC LIA - (15) old library (compatible) C LOA - (16) NEW LIBRARY (ASCII) fC LOA - (16) new library (compatible) C LBO - (17) BACKUP OUTPUT (EDIT) C LBI - (18) BACKUP INPUT (EDIT) C LTI - (5) TERMINAL FOR INPUT (EDIT) fC LTO - (6) Terminal for output (both)C LDO - (19) DUMP FILE OUTPUT UNFORMATED (EDIT) fC LDO - (19) Continue file output unformated (EDIT) C LDI - (20) DUMP FILE INPUT UNFORMATED (EDIT)fC LDI - (20) continue file input unformated (EDIT)C MODCOM 3/22/82C MODCOM -COMMON DECKS THAT HAVE BEEN MODIFIED C  COMMON /MODCOM/ NMODC C O,LCO,LNP,LSR,LSI,  1 LIA,LOA,LOU C C LOCATION FOR NEXT WRITE (RANDOM FILES - EOF) C  COMMON /LUNLOC/ LOCLNP, LOCLSR C ...DEFINITIONS... MODKEY 3/22/82. C MODKEY.CMN C C KEYS TO MODIFICATIONS FOR ONE DECK C  COMMON /MODKEY/ NOMODS,MODIN(MAXMDD),  1 MODRC1(MAXMDD),MODRC2(MAXMDD)  COMMON /MODKE1/ NOMODS,MODIN(MAXMDD)C  COMMON /MODKE2/MODRC1(MAXMDD),MODRC2(MAXMDD).*IF I4  INTEGER*4 MODRC1,MODRC2 .*ENDIF C C NOMODS - NUMBER OF DIRECTIVES FOR THIS DECK  C MODIN - POINTER TO DIRECTIVE ARAYS  C MODRC1 - FIRST POINTER TO RECORD IN DECK (IDECP1)  C MODRC2 - SECOND POINTER TO RECORD IN DECK (IDECP1)  C C ARAYS C IDECE - DECK NUMBER BEING EDITEDMODNA 3/22/82 C MODNA.CMN C C MODNAME (IDENTS)C  COMMON /NMODNA/ NMODS, NMODOP C  COMMON /MODNAM/ MODNA(MAXMNA), DATEM(MAXMNA)  CHARACTER*8 MODNA,DATEM  C IRECTIVES FOR THIS DECK  C MODIN - POINTER TO DIRECTIVE ARAYS  C MODRPARAMA 3/22/82^R;% C PARAMA C PARAMETERS - SEE PARAMB FOR DESCRIPTION C  PARAMETER NCHRWD = 4  PARAMETER NWRDBK = 128 PARAMETER MAXWID = 72  PARAMETER MAXDCK = 500 PARAMETER MAXWRD = 8000   PARAMETER MAXMNA = 500  PARAMETER MAXMDK = 500  PARAMETER MAXMDD = 500  PARAMETER MAXSWI = 50   PARAMETER MAXDRR = 500 PARAMETER MAXDIR = 18  PARAMETER MAXMCM = 50  PARAMETER (NCHRWD=4)  PARAMETER (NWRDBK=128) PARAMETER (MAXWID=72) R PARAMETER (MAXWID = 160)  PARAMETER (MAXDCK=500) PARAMETER (MAXWRD=8000)  PARAMETER ( MAXWRD = 24000 ) % PARAMETER ( MAXWRD = 75000 )  PARAMETER (MAXMNA=500) PARAMETER (MAXMDK=500) PARAMETER (MAXMDD=500) PARAMETER (MAXSWI=50)   PARAMETER (MAXDRR=500)^ PARAMETER (MAXDRR=1000)  PARAMETER (MAXMCM=50)  PARAMETER (MAXREC=2000) ; PARAMETER (MAXREC=4000) C NW8C NUMBER OF WORDS IN 8 CHARACTERS  PARAMETER NW8C = (8+NCHRWD-1)/NCHRWD  PARAMETER (NW8C=(8+NCHRWD-1)/NCHRWD) C PARAMB 3/22/82; C PARAMB C C DESCRIPTION OF PARAMETER SEE PARAMA FOR PARAMETERS C C NCHRWD NO. OF CHARACTERS IN A WORD C C NWRDBK NO. OF WORDS IN ABLOCK C  C MAXWID MAXIMUM WIDTH OF INPUT RECORDS  C (WIDTH OF COMPILE FILE RECORDS EXCLUDING IDENT)  C  C MAXDCK NO. OF DECKS ALLOWED IN LIBRARY  C C MAXWRD NO. OF WORDS ALLOWED IN A DECK OR COMMON DECKC C MAXMNA NO. OF MOD DECKS ALLOWED IN LIBRARY C C MAXMDK NO. OF DECKS WHICH CAN BE MODIFIED IN A RUN C C MAXMDD NO. OF MOD. DIRECTIVES FOR ONE DECK IN A RUN C C MAXSWI NO. OF SWITCHES TO BE DEFINED IN A RUN C C MAXDRR NO. OF DIRECTIVES IN A RUN (EXCLUDING *CALL *IF *ENDIF ) C C MAXDIR NO. OF DIRECTIVE TYPES IN PROGRAMC C MAXMCM NO. OF MODIFIED COMMON DECKS IN A RUNC ;C MAXREC MAXIMUM NUMBER OF RECORDS IN AN EDITED DECK ;C PARAMETER (MAXDRR=500) PARAMETER (MAXMCM=50)  PARAMETER (MAXREC=2000) ; PARAMETER (MAXREC=4000) C NW8C NUMBER OF WORDS IN 8 CHARACTERS  PARAMETER NW8C = (8+NCHRWD-1)/NCHRWD  PARAMETER (NW8C=(8+NCHRWD-1)/NCHRWD) C PRFX 3/22/82C C PREFIX FOR DIRECTIVES (*) C INITIALIZED IN INITLC  COMMON /PRFIX/ PRFX  CHARACTER*1 PRFXC C NWRDBK NO. OF WORDS IN ABLOCK C  C MAXWID MAXIMUM WIDTH OF INPUT RECORDS  C (WIDTH OF COMPILE FILE RECORDS EXCLUDING IDENT) CKDIRD 3/22/82C C CKDIRD.CMN C C DATA FOR CKDIR  COMMON /SCANA/WORD(40)  CHARACTER*20 WORD C  COMMON /SCANI/ NWRD C CC CC for scanning use CC C COMMON /SCAN/ NWRD, ISS(72), ISL(72)CC CC NWRD - Number of words found CC ISS() - Start location of each scanned word found CC ISL() - Length of each scanned word found (characters)C C SEQCTL 3/08/83C C sequence control for compile file outputC  COMMON /SEQCTL/ LSEQC C C LSEQC = 1 Full C 2 Compressed C 3 None  C SWITCH 3/22/82C C SWITCHES SETC  COMMON/SWITCN/ NSWS C  COMMON/SWITCA/ SWITCH(MAXSWI)  CHARACTER*8 SWITCH C RDS IN ABLOCK C  C MAXWID MAXIMUM WIDTH OF INPUT RECORDS  C (WIDTH OF COMPILE FILE RECORDS EXCLUDING IDENT) TYPDCK 3/22/82 C TYPDCK.CMN C C TYPE OF DECKC  COMMON /TYPDCK/ITPDCK C  COMMON /DCKSTA/ NAC,NIA C  C NAC - NUMBER OF ACTIVE RECORDS  C NIA - NUMBER OF INACTIVE RECORDS C (WIDTH OF COMPILE FILE RECORDS EXCLUDING IDENT) WIDTH 3/08/83C  COMMON /WIDTH/ MWIDEC C MWIDE = Current Maximum Width of recordsC C LSEQC = 1 Full C 2 Compressed C 3 None  C YANDEC 3/17/83C  INTEGER YANMOD(MAXWRD/10)  INTEGER YANDCK(MAXWRD/10)  INTEGER YANRES(MAXWRD/10)  INTEGER YANREE(MAXWRD/10) C  EQUIVALENCE(YANMOD,IDEC(MAXWRD/2+1)) EQUIVALENCE(YANDCK,IDEC(MAXWRD/2+1 +MAXWRD/10))  EQUIVALENCE(YANRES,IDEC(MAXWRD/2+1+2*(MAXWRD/10)))  EQUIVALENCE(YANREE,IDEC(MAXWRD/2+1+3*(MAXWRD/10)))  C C YANMOD - MOD number C YANDCK - DECK numberC YANRES - random record starting locationC YANREE - random record ending location C YANDCK(J)=L  L=YANRES(I)  YANRES(I)=YANRES(J) YANPTR 3/17/83C C YANREC - Record to be written on random fileC  COMMON /YANRC/ YANREC  CHARACTER*(MAXWID) YANREC C  COMMON /YANREP/ IRECLO, LTYPE, NMODDK C  C IRECLO - next location on random file C LTYPE - current type of action  C 1 - Clear - no action being taken  C 2 - Delete being processed  C 3 - Restore being processed C 4 - Delete, Restore or Insert record writtenC NMODDK - Number of MOD-DECK entries in YANMOD tables C YANDCK(J)=L  L=YANRES(I)  YANRES(I)=YANRES(J) SLIB77 3/22/82fRC@+  PROGRAM SLIB77  PROGRAM MAINC C SLIB77 DEVELOPED BY THE WESTERN AREA POWER ADMINISTRATION C FOR ITS DIGITAL EQUIPMENT CORPORATION VAX11/780 COMPUTER C SYSTEMS AND PRIME 550/750/850 COMPUTER SYSTEMS. C *CA PARAMA *CA PARAMB *CA LOGU *CA CONTRL*CA BATCH  C CALL INITL  CALL CKEDIT  CALL INP IF(ICP) CALL RDOPL(LOP)  IF(ICPA) CALL RDOPLA(LIA)  CALL PROC3  CALL PROC4  IF(ICN) CALL WRNPL(LNP)  IF(ICNA) CALL WRNPLA(LOA)  IF(BATCH) THEN R CALL CTLCRD  CALL INP  IF(ICPA) CALL RDOPL(LIA)  IF(ICPA) CALL RDOPLA(LIA) IF(ICP) CALL RDOPL(LOP) R CALL INP  CALL PROC3  CALL PROC4  IF(ICN) CALL WRNPL(LNP)  IF(ICNA) CALL WRNPLA(LOA) + CALL PRSTAT  ELSE   CALL EDIINI   CALL EDITOR @ IEDECK=0 @100 CALL EDIINI(IEDECK) @ IF(IEDECK.GT.0) THEN @ CALL EDITOR CC Parameter for EDITOR is RECOVERC CALL EDITOR(.FALSE.) @ GOTO 100 @ ENDIF  ENDIF C  CALL PRSTAT  STOP 'NORMAL EXIT'  END CKDIR 3/22/82C SUBROUTINE CKDIR (BUF, ITL)  CHARACTER*(*) BUF C C CHECKS FIRST WORD IN BUF FOR DIRECTIVE C C BUF - INPUT CHARACTER STRINGC ITL - DIRECTIVE TYP FOUND (0 IF NOT DIRECTIVE) C *CA PARAMA *CA CKDIRD *CA DIRDIC  C C CHARACTER*4 WRDS C CHARACTER*10 WRDL CC  C  CALL SCAN2(BUF, WORD, NWRD)  DO 10 I=1,MAXDIRC C CHECK TO SEE WHICH COMMAND IT ISC  IF(WORD(1).EQ.DIRDIS(I)) THEN  IF( WORD(1)(1:4) .EQ. DIRDIS(I) ) THEN  ITL=I  GOTO 900  ENDIF 10 CONTINUEC C MAXDIR HAS A RANGE OF 1 TO 18 C  ITL = ICKDIC ( WORD, DIRDIL, MAXDIR ) CC ignore first character - it is an asterisk * C DO 10 I=2,LEN(BUF) C IF(INDEX(' ,!',BUF(I:I)).NE.0) GOTO 20 C10 CONTINUE C20 IF (I.LE.2) THEN C ITL=0 C GOTO 900 C ENDIF C C C LASTC=I-1 C LENW=I-2 C IF(LENW.LT.3) THEN CC C WRDS=BUF(2:LASTC)CC C DO 30 I=1,MAXDIR C IF(WRDS .EQ. DIRDIS(I)) THEN C ITL = I C GOTO 900 C ENDIF C30 CONTINUE C ELSE C WRDL=BUF(2:LASTC)CC C DO 100 I=1,MAXDIRC IF(LENW.LT.IDIRL(I)) GOTO 100 C IF(WRDL.EQ.DIRDIL(I)) THEN C ITL = I C GOTO 900 C! ENDIF C"100 CONTINUE C# ENDIF C$C C% ITL=0 C  900 RETURN  END CKDKMC 3/22/82a. SUBROUTINE CKDKMC(NDECK,IMCMN) C C CHECK DECK FOR MODIFIED COMMON CALLED C C NDECK - DECK NUMBER C IMCMN - DECK STATUS C 0 - NO MODIFIED COMMONS CALLED C 1 - YES MODIFIED COMMONS CALLED  C *CA PARAMA *CA DECA *CA PRFX DIMENSION IDR(5) EQUIVALENCE(LNX,IDR(1)),(IDEL,IDR(3)),(NMR,IDR(5))  EQUIVALENCE (LNX,IDR(1)), (IDEL,IDR(4)), (NMR,IDR(5)) C .*IF I4  INTEGER*4 ILX .*ENDIF C  IMCMN=0  CALL RDDK(1,NDECK)  IDECP1=1+2*NW8C+1  CALL EXIN(IDECP1,NMD,1)  IDECP1=IDECP1+NMD 100 CONTINUE  ILX=IDECP1  CALL EXIN(IDECP1,IDR,5) a CALL EXIN(IDECP1,IDR(1),5)  IF(LNX.EQ.0) GOTO 9000  IF(IDEL.EQ.0) THEN  IDECP1=IDECP1+NMR IF(ADEC(IDECP1)(1:1).EQ.PRFX) THEN  LENA=(ILX+LNX-IDECP1)*NCHRWD  CALL COMCHM(ADEC(IDECP1),LENA,ICOM)  IF(ICOM.NE.0) THEN  IMCMN=1 GOTO 9000 ! ENDIF " ENDIF # ENDIF $ IDECP2=ILX+LNX  IDECP1 = ILX + LNX %C & GOTO 100 '9000 CONTINUE ( RETURN ) END CKEDIT 6/14/82 bC+)%#  SUBROUTINE CKEDIT C C CHECK FOR AN INTERACTIVE/EDIT RUN C *CA BATCH *CA LOGUb*CA IVERS  CHARACTER*4 ANS C CHARACTER*80 ANSC C BATCH=.TRUE.)*IF EDIT PRINT*,'Is this an EDIT run? (YESH for help!)'  NTRY=0 10 PRINT*,'Is this an EDIT run?'  PRINT*,'YES/NO , HELP for help , CR for batch' # PRINT*,'YES for edit, NO for batch, HELP for help' % % 10 CONTINUE% % PRINT 20% 20 FORMAT( $,' Is this an interactive EDIT -(Yes,No,Help)? ') + 20 FORMAT( ' Is this an interactive EDIT -(Yes,No,Help)? ') b PRINT 20, LSTMODb20 FORMAT(' SLIB77 latest mod - ',A,/ b 1 ' Is this an interactive EDIT run (Yes,No,Help)? ')%  NTRY=NTRY+1  IF(NTRY.GT.3) THEN  BATCH=.TRUE.  RETURN C GOTO 60  ENDIF  READ11,ANS  READ(LTI,11,END=50,ERR=50)ANS 11 FORMAT(A)   IF(ANS(1:3).EQ.'YES') THEN  IF(ANS(1:3).EQ.'YES'.OR.ANS(1:3).EQ.'yes') THEN % % IANS = INDEX('NnYy',ANS(1:1)) % IF( IANS .GE. 3 ) THEN BATCH=.FALSE.  IF(ANS(1:4).EQ.'YESH') CALL EDIHEL(ANS(4:4))  IF(ANS(4:4).EQ.'H'.OR.ANS(4:4).EQ.'h') CALL EDIHEL(ANS(4:4))  ELSE  BATCH=.TRUE.  RETURN   ELSE IF (ANS(1:2).EQ.'NO'.OR.ANS(1:2).EQ.'no')THEN % ELSE IF ( IANS .GE. 1 ) THEN  BATCH=.TRUE.  ELSE  CALL EDIHEL(ANS)  GOTO 10  ENDIF 50 BATCH=.TRUE.  RETURN C GOTO 60 50 CONTINUE C60 IF(BATCH) THEN C PRINT61 C61 FORMAT(' Do you want to open INPUT file (51) with a NAME ?') C PRINT63 C 63 FORMAT(' If so enter the name - otherwise a carriage-return') C ANS=' ' C READ(LTI,11,END=100,ERR=100)ANS C IF(ANS(1:1).EQ.' ') GOTO 100 C ILEN=INDEX(ANS,' ') C CALL OPNINX(LIN,ANS(1:ILEN-1),IERR) C ENDIF )*ENDIF  BATCH=.TRUE. C100 CONTINUE  RETURN  RETURN  END CKINPN 5/03/82faEC SUBROUTINE CKINP(ITT) E SUBROUTINE CKINP(ITT,IWID) f SUBROUTINE CKINP(ITT,A) f CHARACTER*(*) A C fC fC ITT - type of directive (0 if not a directive) fC A - input record fC fC called by RDINP fC C CHECK INPUT DIRECTIVES FOR ERRORS C *CA PARAMA *CA BUFA *CA LOGU *CA INREC *CA CKDIRD C  C SET UP LONG AND SHORT DICTIONARIES  C  C *CA DIRDIC E*CALL PRFX C  CHARACTER*10 ORDDIL(MAXDIR) C DIRECTIVE DICTIONARY - LONG C  INTEGER ORDTBL(MAXDIR)  LOGICAL IFLD,IFLI C  DATA ORDDIL/'YANK','UPDATE','COMPILE','DEFINE','EDIT','MOVE',  1 'READ','RENAME','IDENT','PURGE','ADDDECK',  2 'ADDCOMP','DECK','CALL','DELETE','INSERT',  3 'RESTORE','IF','ENDIF'/ C  DATA ORDTBL/11,12,14,3,13,4,15,5,19,9,18,16,6,17,7,10,2,1,8/C C  IF(ITT .EQ. 0) THEN  WRITE(LOU,90) BUF  PRINT *, BUF ! 90 FORMAT(A)E WRITE(LOU,91) PRFX, BUF(1:IWID) E PRINT 91, PRFX,BUF(1:IWID) E 91 FORMAT(' WARNING... A record has the directive prefix ' E 1 ,A,' but is not a directive'/ E 1 10X,A) " RETURN #C $ ELSE IF(ORDTBL(ITT) .EQ. 9 .AND. .NOT. IFLI % 1 .AND. IFLD) THEN & WRITE(LOU,95)' 95 FORMAT(5X,'**** ERROR **** DECK CARD BEFORE IDENT ', ( 1 '...JOB ABORTED. ') ) PRINT 95 * STOP 'DECK BEFORE IDENT' +C , ELSE IF(ORDTBL(ITT) .EQ. 9 .AND. .NOT. IFLD - 1 .AND. IFLI) THEN .C / WRITE(LOU,97)0 97 FORMAT(5X,'**** ERROR **** TWO IDENTS TOGATHER ',1 1 'WITHOUT A DECK CARD. ') 2C 3 PRINT 97 4 STOP ' TWO IDENT CARDS TOGATHER' 5C 6 ELSE IF(ORDTBL(ITT) .GE. 14 .AND. ORDTBL(ITT) 7 1 .LE. 19 .AND. .NOT. IFLD .AND. .NOT. IFLI ) THEN 8 WRITE(LOU,100) 9 100 FORMAT(5X,' **** ERROR **** IDENT/DECK CARD ', : 1 'MISSING...JOB ABORTED. ') ;C < PRINT 100=C > STOP ' IDENT/DECK ' ?C @ ELSE IF(ORDTBL(ITT) .GE. 14 .AND. ORDTBL(ITT) .LE. A 1 19 .AND. IFLI .AND. .NOT. IFLD) THEN BC C WRITE(LOU,105) D 105 FORMAT(5X,'**** ERROR **** DECK CARD MISSING ', E 1 'BEHIND IDENT CARD...JOB ABORTED. ') FC G PRINT 105HC I STOP ' ////DECK CARD MISSING ' JC K ELSE IF(ORDTBL(ITT) .GE. 14 .AND. ORDTBL(ITT) L 1 .LE. 19 .AND. IFLD .AND. .NOT. IFLI) THENMC N WRITE(LOU,115) O 115 FORMAT(5X,'**** ERROR **** IDENT CARD MISSING ', P 1 '...JOB ABORTED. ') Q PRINT 115RC S STOP ' IDENT CARD MISSING' TC U ELSE IF(ORDTBL(ITT) .GE. 10 .AND. ORDTBL(ITT) .LE. V 1 12 .AND. IFLD .AND. .NOT. IFLI) THEN WC X WRITE(LOU,135) Y PRINT 135ZC [ STOP ' ILLEGAL ENTRY #2' \C ] ELSE IF(ORDTBL(ITT) .GE. 10 .AND. ^ 1 ORDTBL(ITT) .LE. 12 .AND. .NOT. IFLI) THEN _ WRITE(LOU,120) ` 120 FORMAT(5X,' **** ERROR **** IDENT CARD MISSING ',a 1 '...JOB ABORTED. ') bC c PRINT 120dC e STOP ' IDENT ' fC g ELSE IF(ORDTBL(ITT) .EQ. 9) THEN h IFLI = .TRUE. i RETURN jC k ELSE IF(ORDTBL(ITT) .LT. 9 .AND. IFLD l 1 .AND. .NOT. IFLI) THEN m WRITE(LOU,135) n 135 FORMAT(5X,'**** ERROR **** ILLEGAL ENTRY AFTER ' o 1 'DECK CARD...JOB ABORTED. ') a 1 ,'DECK CARD...JOB ABORTED. ')pC q PRINT 135r STOP ' ILLEGAL ENTRY #1' sC tC uC v ELSE IF(ORDTBL(ITT) .EQ. 13) THEN w IFLD = .TRUE. x RETURN yC z ELSE IF(IFLI .AND. ORDTBL(ITT) .GE. 10 { 1 .AND. ORDTBL(ITT) .LE. 12) THEN | RETURN }C ~C  ELSE IF(IFLI .AND. ORDTBL(ITT) .LT. 9  1 .OR. .NOT. IFLI .AND. ORDTBL(ITT) .LT. 9) THEN  RETURN  ENDIF f *CA INPERC f *CA BUFA f LOGICAL LID, LDK, LIM f C f C Logical Switches Indicating encountered directives fC LID - *IDENT fC LDK - *DECK fC LIM - indicates insert mode condition fC f DIMENSION IDMH(0:MAXDIR), IDCL(0:MAXDIR), IDIM(0:MAXDIR), f 1 IDST(0:MAXDIR)fC fC IDMH - type of check to be made for previous directive: fC 1 - no check fC 2 - must have previously encountered *ID fC 3 - must have previously encountered *DECKfC fC IDCL - type of directive switch clearing to be done fC 1 - none fC 2 - clear *DECK switchfC fC IDIM - type of action to be taken to insert mode switch fC 1 - none f C 2 - switch should have been previously setf!C 3 - set switchf"C 4 - turn off switch f#C f$C IDST - directive switch to be set f%C 1 - none f&C 2 - set *ID switchf'C 3 - set *DECK switch f(C f) DATA IDMH /1,2,2,1,1,2,1,3,1,1,1,1,3,1,3,1,1,1,1,1 /f* DATA IDCL /1,2,2,1,2,2,2,1,2,1,2,1,1,2,1,1,2,2,2,2 /f+ DATA IDIM /2,3,3,2,4,4,4,3,4,2,4,2,3,4,3,1,4,4,4,4 /f, DATA IDST /1,1,1,1,1,3,1,1,1,1,2,1,1,1,1,1,1,1,1,1 /f-C f. DATA LID, LDK, LIM /.FALSE., .FALSE., .FALSE. / f/C f0C ITTL - directive type of previous recordf1C f2 DATA ITTL /99/ f3C f4 IF(ITT.EQ.ITTL.AND.ITT.EQ.0) RETURN f5C f6C Check for previously encountered directivesf7C f8 GOTO (100, 20, 30) ,IDMH(ITT) f9C f:C f;20 IF(.NOT. LID) THEN f< WRITE(LOU,21) INRCN, A f= CALL LININC(2) f> PRINT 21, INRCN, A f?21 FORMAT(' The following record (',I5,') should have a', f@ 1 ' preceeding *ID directive',/1X,A) fA INERRF=INERRF+1 fB ENDIF fC GOTO 100fDC fEC fF30 IF(.NOT.LDK) THEN fG PRINT 31, INRCN,A fH WRITE(LOU,31) INRCN,A fI CALL LININC(2) fJ31 FORMAT(' The following record (',I5,') should have a', fK 1 ' preceeding *DECK directive',/1X,A) fL INERRF=INERRF+1 fM ENDIF fNC fOC fPC Check for switches to clearfQC fRC fS100 IF(IDCL(ITT).GT.1) LDK=.FALSE. fTC fUC fVC Check for action relative to insert mode fWC fX GOTO (300, 220, 230, 240) ,IDIM(ITT) fYC fZC f[220 IF(.NOT. LIM) THEN f\ PRINT 221, INRCN, A f] WRITE(LOU,221) INRCN, A f^ CALL LININC(2) f_221 FORMAT(' The following record (',I5,') is to be inserted', f` 1 ' but cannot be',/1X,A) fa INERRF=INERRF+1 fb ENDIF fc GOTO 300fdC feC ff230 LIM=.TRUE. fg GOTO 300fhC fiC fj240 LIM=.FALSE. fkC flC fmC Check for directive switches to setfnC fo300 GOTO (400, 320, 330) ,IDST(ITT) fpC fqC fr320 LID=.TRUE. fs GOTO 400ftC fu330 LDK=.TRUE. fvC fw400 CONTINUE fx ITTL=ITT RETURN  END COMCHC 3/22/82 RC- SUBROUTINE COMCHC(ALF,ILA,ICOM) - SUBROUTINE COMCHC(ALF,ILA,ITD) C C CHECK COMPILE FILE RECORD FOR C C 3 - CALL C 9 - ENDIF C 11 - IF C *CA PARAMA *CA CKDIRDC*CALL SCAN *CA SWITCH *CA IFSWI  C  CHARACTER*132 ALF C CHARACTER*120 ALF R CHARACTER*(MAXWID) ALF C CHARACTER*9 WOR9  CHARACTER*8 SWI C  ICOM=0 - LOGICAL MINUS,SET C  CALL CKDIR(ALF(2:ILA),ITD) C CALL CKDIR(ALF(1:ILA),ITD)  IF(ITD.EQ.3) THEN C C *CALL DIRECTIVE C  PRINT*,'CALL DIRECTIVE FOUND IN COMMON DECK-NOT ALLOWED'  GOTO 9000C  ELSE IF(ITD.EQ.9) THEN C C *ENDIF DIRECTIVEC  ICOM=1  ISETIF=0 ! GOTO 9000 - NIFS=MAX(0,NIFS-1) - IF(NIFS.GT.0) THEN - ISETIF=ISIF(NIFS) - ELSE - ISETIF=0 - ENDIF " ELSE IF(ITD.EQ.11) THEN #C $C *IF DIRECTIVE %C & ICOM=1 ' SWI=WORD(2) ( IF(ISETIF.NE.0) THEN ) PRINT*,' ERROR ISETIF ALLREADY INDICATES NOT SET',SWI * STOP 'COMCHC' + ENDIF , DO 200 L=1,NSWS - IF(SWI.EQ.SWITCH(L)) THEN . ISETIF=0 / GOTO 9000 0 ENDIF 1200 CONTINUE 2 ISETIF=1 3 GOTO 9000-  IF(WORD(2)(1:1).EQ.'-') THEN -  SWI=WORD(2)(2:9) C CALL SCAN2(ALF(1:ILA)) C WOR9=ALF(ISS(2):ISS(2)+ISL(2)-1) C IF(WOR9(1:1).EQ.'-') THEN C SWI=WOR9(2:9) - MINUS=.TRUE. - ELSE -  SWI=WORD(2) C SWI=WOR9(1:8) - MINUS=.FALSE. - ENDIF - DO 200 L=1,NSWS - IF(SWI.EQ.SWITCH(L)) THEN - SET=.TRUE. - GOTO 500 - ENDIF -200 CONTINUE - SET=.FALSE. -500 CONTINUE - IF(NIFS.EQ.0.OR.ISIF(NIFS).EQ.0) THEN - IF(SET) THEN - IF(MINUS) THEN - ISETIF=1 - ELSE - ISETIF=0 - ENDIF - ELSE - IF(MINUS) THEN -! ISETIF=0 -" ELSE -# ISETIF=1 -$ ENDIF -% ENDIF -& ELSE -' ISETIF=1 -( ENDIF -) NIFS=NIFS+1 -* ISIF(NIFS)=ISETIF 4 ENDIF 5C 69000 CONTINUE 7 RETURN 8 END COMCHK 3/22/82 dRC- SUBROUTINE COMCHK(ALF,N)d SUBROUTINE COMCHK (ITD,ALF,N) C C CHECK COMPILE FILE RECORD FOR C C 3 - CALL C 9 - ENDIF C 11 - IF C *CA PARAMA *CA DECA *CA PRFX *CA CKDIRDC*CALL LOGU C*CALL SCAN *CA DECKS *CA SWITCH *CA IFSWI C  CHARACTER*132 ALF C CHARACTER*120 ALF R CHARACTER*(MAXWID) ALF C CHARACTER*9 WOR9 C CHARACTER*8 WOR8  CHARACTER*8 SWI C  ICOM=0 - LOGICAL MINUS,SET C  CALL CKDIR(ALF(2:N),ITD)C CALL CKDIR(ALF(1:N),ITD)  IF(ITD.EQ.3) THEN C C *CALL DIRECTIVE C  IDK=IFINDK(WORD(2)) C CALL SCAN2(ALF(1:N)) C WOR8=ALF(ISS(2):ISS(2)+ISL(2)-1) C IDK=IFINDK(WOR8)  IF(IDK.LE.0.OR.ITYPE(IABS(IDK)).EQ.0) THEN  PRINT*,'COULDNT FIND COMDECK ',WORD(2) C PRINT 11,WOR8 C WRITE(LOU,11) WOR8C 11 FORMAT(' Could not find common deck ',A)  GOTO 9000  ENDIF C ! CALL INSCOM(IDK) " ICOM=1 # GOTO 9000 $ ELSE IF(ITD.EQ.9) THEN %C &C *ENDIF DIRECTIVE'C ( ICOM=1 ) ISETIF=0 * GOTO 9000 - NIFS=MAX(0,NIFS-1) - IF(NIFS.GT.0) THEN - ISETIF=ISIF(NIFS) - ELSE - ISETIF=0 - ENDIF + ELSE IF(ITD.EQ.11) THEN ,C -C *IF DIRECTIVE .C / ICOM=1 0 SWI=WORD(2) 1 IF(ISETIF.NE.0) THEN 2 PRINT*,' ERROR ISETIF ALLREADY INDICATES NOT SET',SWI 3 STOP 'COMCHK' 4 ENDIF 5 DO 200 L=1,NSWS 6 IF(SWI.EQ.SWITCH(L)) THEN 7 ISETIF=0 8 GOTO 9000 9 ENDIF :200 CONTINUE ; ISETIF=1 < GOTO 9000- IF(WORD(2)(1:1).EQ.'-') THEN -  SWI=WORD(2)(2:9) C CALL SCAN2(ALF(1:N)) C WOR9=ALF(ISS(2):ISS(2)+ISL(2)-1) C IF(WOR9(1:1).EQ.'-') THEN C SWI=WOR9(2:9) - MINUS=.TRUE. - ELSE -  SWI=WORD(2) C SWI=WOR9(1:8) - MINUS=.FALSE. - ENDIF - DO 200 L=1,NSWS - IF(SWI.EQ.SWITCH(L)) THEN - SET=.TRUE. - GOTO 500 - ENDIF -200 CONTINUE - SET=.FALSE. -500 CONTINUE - IF(NIFS.EQ.0.OR.ISIF(NIFS).EQ.0) THEN - IF(SET) THEN - IF(MINUS) THEN - ISETIF=1 - ELSE - ISETIF=0 - ENDIF - ELSE - IF(MINUS) THEN - ISETIF=0 -! ELSE -" ISETIF=1 -# ENDIF -$ ENDIF -% ELSE -& ISETIF=1 -' ENDIF -( NIFS=NIFS+1 -) ISIF(NIFS)=ISETIF = ENDIF >C ?9000 CONTINUE @ RETURN A END COMCHM 3/22/82RC SUBROUTINE COMCHM(ALF,ILA,ICOM) C C CHECK DECK RECORD FOR CALL TO COMDECK WHICH HAS BEEN MODIFIED C ICOM - 0 NO MOD COMDECKS CALLED C - 1 A MOD COMDECK CALLED C *CA PARAMA *CA DECA *CA PRFX  *CA DECKS *CA CKDIRDC*CALL SCAN *CA MODCOM C  CHARACTER*132 ALF C CHARACTER*120 ALF R CHARACTER*(MAXWID) ALF C CHARACTER*8 WOR8C C  CALL CKDIR(ALF(2:ILA),ITD) C CALL CKDIR(ALF(1:ILA),ITD)  IF(ITD.EQ.3) THEN C C *CALL DIRECTIVE C  IDK=IFINDK(WORD(2)) C CALL SCAN2(ALF(1:ILA)) C WOR8=ALF(ISS(2):ISS(2)+ISL(2)-1) C IDK=IFINDK(WOR8)  IF(IDK.GT.0) THEN  ICOM=IEDIT(IDK)  ELSE  ICOM=0  ENDIF  ENDIF  RETURN  END PRINT*,'COULDNT FIND COMDECK ',WORD(2) C PRINT 11,WOR8 C WRITE(LOU,11) WOR8C 11 FORMAT(' Could not find common deck ',A)  GOTO 9000  ENDIF C ! CALL INSCOM(IDK) COMPID 4/15/82 SUBROUTINE COMPID(NAM,NSQ,NAMSEQ) C C FROM DECK NAME AND SEQUENCE NUMBER C OBTAIN THE NAMSEQ TO BE USED ON THE COMPILE FILEC  CHARACTER*8 NAM,NAMSEQ C  WRITE(NAMSEQ,11) NSQ 11 FORMAT(I8)  C IF(NSQ.LT.10) THEN NC=7  ELSE IF (NSQ.LT.100) THEN  NC=6  ELSE IF (NSQ.LT.1000) THEN  NC=5  ELSE IF (NSQ.LT.10000) THEN  NC=4  ELSE  NC=3 C  ENDIF C  NAMSEQ(1:NC)=NAM(1:NC)  RETURN  END SWITCH 3/22/82/TYPDCK 3/22/820CKDIR 3/22/821CKDKMC 3/22/824CKINP 3/22/828 COMCHC 3/22/82DCOMCHK 3/22/82ICOMCHM 3/22/82OCTLCRD 3/22/82RCTLCRD 3/22/82-ihgfd]YXWRQIFDC  SUBROUTINE CTLCRD C C PROCESSES CONTROL CARD C *CA PARAMA *CA CONTRL *CA CKDIRDC*CALL SCAN *CA LOGU  C R*CA SEQCTL R*CA WIDTH d*CA LANGC f*CA BUFAf*CA DECAfC fC To store output records into until we know whether to write fC them or not we will use CTLLIS and count them with NCTLS fC iC We will make this a power of 2 for the Prime computer--alex f CHARACTER*132 CTLLIS(500) i CHARACTER*128 CTLLIS(500) f EQUIVALENCE (CTLLIS, BUF) i EQUIVALENCE (CTLLIS(1), ADEC(1)) h EQUIVALENCE (CTLLIS(1), ADEC(1)) CHARACTER*480 CCRD DIMENSION ICRDL(12)  CHARACTER*3 OPT(10) R CHARACTER*3 OPT(12) d CHARACTER*3 OPT(13) CHARACTER*8 LOPT  CHARACTER*20 NAM CHARACTER*20 NAMLCO,NAMLOU,NAMLOP C CHARACTER*72 NAM,NAMLCO,NAMLOU,NAMLOP f CHARACTER*72 NAM,NAMLCO,NAMLOU,NAMLOP,NAMLIA]C COMEXT - compile file name extension ] CHARACTER*4 COMEXT f CHARACTER*4 COMEXT(2) f C for blank lines in output will use BLKLIN f  CHARACTER*132 BLKLIN i CHARACTER*128 BLKLINf C f DATA BLKLIN /' '/ ]*IF -PRIME ] DATA COMEXT /'.FOR'/f DATA COMEXT /'.FOR','.COB'/ ]*ENDIF ]*IF PRIME ] DATA COMEXT /'.F77'/f DATA COMEXT /'.F77','.COB'/ ]*ENDIF  DATA NAMLCO /' '/  DATA NAMLOU /' '/  DATA NAMLOP /' '/ f DATA NAMLIA /' '/ I DATA IWLOU /1/ I DATA IWLCO /1/ I DATA IWLOP /1/ f DATA IWLIA /1/ C  DATA OPT/'F','Q','LO','C','L','S','N','NA','P','PA'/R DATA OPT/'F','Q','LO','C','L','S','N','NA','P','PA', R 1 'W','SQ'/ d 1 'W','SQ','LA'/ C  DATA LOPT /'ACDEIMST'/ C f NCTLS=0 C  READ(LIN,11) CCRD(1:80) f INRCN=INRCN+1 11 FORMAT(A)  NCCRD=0  IS=1 IF(CCRD(1:4).NE.'SLIB') THEN PRINT*,'FIRST (CONTROL) RECORD MUST BE SLIB IT IS ',CCRD(1:4) STOP 'FIRST INPUT RECORD BAD'f WRITE(LTO,13) , CCRD(1:4)i WRITE(LTO,13) CCRD(1:4) h WRITE(LTO,13) CCRD(1:4) f13 FORMAT(' First record on input file must be SLIB it is ',A) f STOP 'Improper CONTROL RECORD on input' ENDIF !C "20 DO 30 IC=IS+79,IS+1,-1 # IF(CCRD(IC:IC).NE.' ') GOTO 40 $30 CONTINUE % GOTO 60 &C '40 CONTINUE ( ILE=IC ) NCCRD=NCCRD+1 * PRINT*,'CONTROL CARD ',CCRD(IS:ILE) f WRITE(LTO,41) CCRD(IS:ILE) f NCTLS=NCTLS+1 f CTLLIS(NCTLS) = BLKLIN f WRITE(CTLLIS(NCTLS),41) CCRD(IS:ILE)f41 FORMAT(' Control record - ',A) f NCTLS=NCTLS+1 f CTLLIS(NCTLS) = BLKLIN + ICRDL(NCCRD)=ILE, IF(CCRD(ILE:ILE).NE.'-') GOTO 60-C . IS=ILE / READ(LIN,11) CCRD(IS:IS+79) f INRCN=INRCN+1 0 GOTO 20 1C 260 CONTINUE3 CALL SCAN1(CCRD(1:ILE),WORD,NWRD) F CALL SCAN1(CCRD(1:ILE)) 4C 5 NS=16C 7100 NS=NS+1 8 IF(NS.GT.NWRD) GOTO 9000 9 DO 200 NCC=1,10 R DO 200 NCC = 1,12 d DO 200 NCC = 1,13 : IF(WORD(NS).EQ.OPT(NCC)) GOTO 300C IF(CCRD(ISS(NS):ISS(NS)+ISL(NS)-1).EQ.OPT(NCC))GOTO 300 ;200 CONTINUERC R IES = ISS(NS) R  IF(NWRD.GT.NS .AND. CCRD(ISS(NS+1):ISS(NS+1)).EQ.'=') THEN X IF(NWRD.GT.NS) THEN X IF(CCRD(ISS(NS+1):ISS(NS+1)).EQ.'=') THEN R NS = MIN(NS+2,NWRD) X ENDIF R ENDIF < PRINT*,'CONTROL RECORD PARAMETER ',WORD(NS),C PRINT*,'Control Record Parameter ', C 1 CCRD(ISS(NS):ISS(NS)+ISL(NS)-1),R  1 CCRD(IES:ISS(NS)+ISL(NS)-1),= 1 ' NOT ALLOWED -IGNORED' R  1 ' Not allowed - ignored.' f WRITE(LTO,211) CCRD(IES:ISS(NS)+ISL(NS)-1) f! NCTLS=NCTLS+1 f" CTLLIS(NCTLS) = BLKLIN f# WRITE(CTLLIS(NCTLS),211) CCRD(IES:ISS(NS)+ISL(NS)-1)f$211 FORMAT(' Control record parameter ',A, f% 1 ' not recognized - (ignored)') f& NCTLS=NCTLS+1 f' CTLLIS(NCTLS) = BLKLIN > GOTO 100?C @300 CONTINUE A IC=NCC B IF(IC.LE.2) THEN C NAM=' ' C IWNAM=2 D ISW=0 E ELSEF IF(NWRD.GT.NS+1.AND.WORD(NS+1).EQ.'=') THEN G IF(WORD(NS+2).EQ.'0') THENC IF(NWRD.GT.NS+1.AND. C 1 CCRD(ISS(NS+1):ISS(NS+1)+ISL(NS+1)-1).EQ.'=') THEN X IF(IC.GT.2.AND.NWRD.GT.NS+1) THEN X IF(CCRD(ISS(NS+1):ISS(NS+1)).EQ.'=') THENC IF(CCRD(ISS(NS+2):ISS(NS+2)+ISL(NS+2)-1).EQ.'0')THEN H NAM=' ' C  IWNAM=2 I ISW=1 J ELSE K NAM=WORD(NS+2) C NAM=CCRD(ISS(NS+2):ISS(NS+2)+ISL(NS+2)-1) C IWNAM=ISL(NS+2) L ISW=2 M ENDIF N ELSE O NAM=' ' C  IWNAM=2 P ISW=0 Q ENDIF R ENDIF SC T GOTO(1100,1200,1300,1400,1500,1600,1700,1800,1900,2000),IC R GOTO(1100,1200,1300,1400,1500,1600,1700,1800,1900,2000, R 1 2100,2200),IC d 1 2100,2200,2300),IC UC VC F - FULLWC X1100 CONTINUE Y IF(ICQ) THENZ PRINT*,'F CONTROL REQUESTED AFTER Q WAS REQUESTED F IGNORED' f( WRITE(LTO,1111) f) NCTLS=NCTLS+1f* CTLLIS(NCTLS) = BLKLIN f+ WRITE(CTLLIS(NCTLS),1111)f,1111 FORMAT(' Control parameter F requested after ', f- 1 'Q - (F ignored)') f. NCTLS=NCTLS+1f/ CTLLIS(NCTLS) = BLKLIN [ ICF=.FALSE. \ ELSE ] ICF=.TRUE. ^ ENDIF _ GOTO 7000 `C aC Q - QUICK bC c1200 CONTINUE d ICQ=.TRUE. e IF(ICF) THENf PRINT*,'Q CONTROL REQUESTED AFTER F SET F DISABLED' f0 WRITE(LTO,2111) f1 NCTLS=NCTLS+1 f2 CTLLIS(NCTLS) = BLKLIN f3 WRITE(CTLLIS(NCTLS),2111) f42111 FORMAT(' Control parameter Q requested after F - (F disabled)') f5 NCTLS=NCTLS+1 f6 CTLLIS(NCTLS) = BLKLIN g ICF=.FALSE. h ENDIF i GOTO 7000 jC kC LO - LIST OPTIONS l1300 CONTINUE W IF (ISW.NE.2) GOTO 7000 m DO 1320 IL=1,8 n1320 ICLST(IL)=.FALSE. oC p DO 1330 IL=1,8 C DO 1330 IL=1,IWNAM q ILS=INDEX(LOPT,NAM(IL:IL)) r IF(ILS.NE.0) THEN s ICLST(ILS)=.TRUE. W ELSE W PRINT*,'Unrecognized LO option (',NAM(IL:IL),')', W 1 'In LO string- ',NAM(1:IWNAM) f7 WRITE(LTO,1323) NAM(IL:IL) f8 NCTLS=NCTLS+1 f9 CTLLIS(NCTLS) = BLKLINf: WRITE(CTLLIS(NCTLS),1323) NAM(IL:IL) f;1323 FORMAT(' Unrecognized control parameter LO option ', f< 1 A,' (ignored)') f= NCTLS=NCTLS+1 f> CTLLIS(NCTLS) = BLKLIN t ENDIF u1330 CONTINUE v GOTO 7000 wC xC C COMPILE yC z1400 CONTINUE { IF(ISW.EQ.0) THEN | NAM='COMPILE.FOR']  NAM='COMPILE'//COMEXT f? NAM='COMPILE' C IWNAM=11 } ICC=.TRUE. ~ ELSE IF (ISW.EQ.1) THEN  ICC=.FALSE. ENDIF NAMLCO=NAM C IWLCO=IWNAM GOTO 7000 C C L LIST C 1500 CONTINUE IF(ISW.EQ.1) THEN ICL=.FALSE.  ELSE NAMLOU=NAM C IWLOU=IWNAM ICL=.TRUE. ENDIF GOTO 7000 C C S SOURCEC 1600 CONTINUE IF(ISW.EQ.1) THEN ICS=.FALSE.  ELSE CALL OPNLSO(LSO,NAM) C CALL OPNLSO(LSO,NAM(1:IWNAM)) ICS=.TRUE. ENDIF GOTO 7000 C C N NEW LIBRARY C 1700 CONTINUE IF(ISW.EQ.1) THEN ICN=.FALSE.  ELSE CALL OPNLNP(LNP,NAM) C CALL OPNLNP(LNP,NAM(1:IWNAM)) ICN=.TRUE. ENDIF GOTO 7000 C C NA NEW LIBRARY ASCII C 1800 CONTINUE IF(ISW.EQ.1) THEN ICNA=.FALSE.  ELSE CALL OPNLOA(LOA,NAM) C CALL OPNLOU(LOU,NAM(1:IWNAM))D CALL OPNLOA(LOA,NAM(1:IWNAM)) ICNA=.TRUE. ENDIF GOTO 7000 C C P OLD LIBRARY C 1900 CONTINUE IF(ISW.EQ.1) THEN ICP=.FALSE.  ELSE NAMLOP=NAM C IWLOP=IWNAM ICP=.TRUE. ENDIF GOTO 7000 C C PA OLD LIBRARY ASCII C 2000 CONTINUE IF(ISW.EQ.1) THEN ICPA=.FALSE.  ELSE CALL OPNLIA(LIA,NAM) C CALL OPNLIA(LIA,NAM(1:IWNAM)) f@ NAMLIA=NAM fA IWLIA=IWNAM ICPA=.TRUE. ENDIF GOTO 7000 RC RC W - width RC R2100 CONTINUE R MWIDE = RVAL(NAM) R GOTO 7000 RC RC SQ - Sequence information control RC R2200 CONTINUER LSEQC = INDEX('FCN',NAM(1:1)) R IF(LSEQC.LT.1) THEN R PRINT*,'Bad Sequence Information Control (SQ) option'R PRINT*,'SQ option will be set to F (full)' fB WRITE(LTO,2211) NAM(1:1) fC NCTLS=NCTLS+1fD CTLLIS(NCTLS) = BLKLIN fE WRITE(CTLLIS(NCTLS),2211) NAM(1:1) fF2211 FORMAT(' Unrecognized control parameter SQ option ', fG 1 A,' (set to F)') fH NCTLS=NCTLS+1fI CTLLIS(NCTLS) = BLKLIN R LSEQC = 1 R ENDIF R GOTO 7000 dC dC LA - LANGUAGE SWITCH PROCESSING.dC d 2300 CONTINUEd LANGT=INDEX('FC',NAM(1:1)) d IF(LANGT.EQ.0)THEN d  PRINT*,'Incorrect LANGUAGE (LA=) option on control card.'d  PRINT*,'LA option ignored' fJ WRITE(LTO,2311) NAM(1:1) fK NCTLS=NCTLS+1fL CTLLIS(NCTLS) = BLKLIN fM WRITE(CTLLIS(NCTLS),2311) NAM(1:1) fN2311 FORMAT(' Unrecognized control parameter LA option ', fO 1 A,' (ignored)') fP NCTLS=NCTLS+1fQ CTLLIS(NCTLS) = BLKLIN d ELSE d LANG = LANGT d ENDIF d GOTO 7000 C 7000 CONTINUE IF(ISW.GT.0) NS=NS+2 GOTO 100C 9000 CONTINUEY IF(MWIDE.EQ.0 .AND. (.NOT.ICP)) THEN Y MWIDE=72 Y PRINT*,'Setting width to default value of 72' fR WRITE(LTO,9011) fS NCTLS=NCTLS+1fT CTLLIS(NCTLS) = BLKLIN fU WRITE(CTLLIS(NCTLS),9011)fV9011 FORMAT(' Setting width to default value of 72') fW NCTLS=NCTLS+1fX CTLLIS(NCTLS) = BLKLIN Y ENDIF  IF(ICC) CALL OPNLCO(LCO,NAMLCO) C IF(ICC) THENC CALL OPNLCO(LCO,NAMLCO(1:IWLCO)) C ENDIF IF(ICL) THEN CALL OPNLOU(LOU,NAMLOU) C CALL OPNLOU(LOU,NAMLOU(1:IWLOU)) fY CALL HEADER('Phase one processing') fZC f[ DO 9070 I=1,NCTLSf\ DO 9040 L=132,2,-1 i DO 9040 L=128,2,-1f] IF(CTLLIS(I)(L:L).NE.' ') GOTO 9060 f^9040 CONTINUE f_ L=1 f`C fa9060 WRITE(LOU,9061) CTLLIS(I)(1:L) fb9061 FORMAT(A) fc CALL LININC(1) fd9070 CONTINUE  ELSE DO 9200 I=1,8 ICLST(I)=.FALSE. 9200 CONTINUE ENDIF  IF(ICP) CALL OPNLOP(LOP,NAMLOP) C IF(ICP) THENC CALL OPNLOP(LOP,NAMLOP(1:IWLOP)) C ENDIF Q CALL HEADER('PHASE ONE PROCESSING')  IF(LSTT) THEN  CALL HEADER('INPUT DATA RECORDS')  IS=1  DO 9510 I=1,NCCRD-1  WRITE(LOU,9509) 'CONTROL CARD '//CCRD(IS:ICRDL(I)-1)//'-' 9509 FORMAT(9X,A) Q CALL LININC(1)  IS=ICRDL(I) 9510 CONTINUE C  WRITE(LOU,9509)'CONTROL CARD '//CCRD(IS:ICRDL(NCCRD)) Q CALL LININC(1)  ENDIF fe IF(ICPA) THEN ff CALL OPNLIA (LIA,NAMLIA(1:IWLIA)) fg CALL RDOPLA(LIA) fh ENDIF fiC fj IF(ICP) THENfk CALL OPNLOP (LOP,NAMLOP(1:IWLOP)) fl CALL RDOPL (LOP) fm ENDIF fnC fo IF (ICC) THEN fp IF(NAMLCO .EQ. 'COMPILE' ) THEN fq NAMLCO(8:11)=COMEXT(LANG) fr ENDIFfs CALL OPNLCO (LCO,NAMLCO(1:IWLCO)) ft ENDIF fuC fv IF(LANG.EQ.0) THEN fw LANG=1 fx IF(ICL) THEN fy WRITE(LOU,9511) LANGNM(LANG) fz CALL LININC(1) f{ ENDIFf|C f} WRITE(LTO,9511) LANGNM(LANG) f~9511 FORMAT(' Language being set to default ',A) f ENDIF gC g IF (ICC) THEN g IF(NAMLCO .EQ. 'COMPILE' ) THEN g NAMLCO(8:11)=COMEXT(LANG) g ENDIFg CALL OPNLCO (LCO,NAMLCO(1:IWLCO)) g ENDIF RETURN  END DIRCHK 8/26/82RDC SUBROUTINE DIRCHK(ALF,N,ITDIR)  CHARACTER*120 ALF C C CHECK RECORD FOR DIRECTIVE RETURN TYPE IN ITDIR C R*CA PARAMA R CHARACTER*(MAXWID) ALF  CALL CKDIR(ALF(2:N),ITDIR) C CHARACTER*120 ADUM C CALL CKDIR(ALF(1:N),ITDIR)  RETURN  END ACTER*3 OPT(10) R CHARACTER*3 OPT(12) CHARACTER*8 LOPT  CHARACTER*20 NAM CHARACTER*20 NAMLCO,NAMLOU,NAMLOP C CHARACTER*72 NAM,NAMLCO,NAMLOU,NAMLOP  DATA NAMLCO /' '/  DATA NAMLOU /' '/  DATA NAMLEDIADD 6/14/82aXC.)  SUBROUTINE EDIADD(A))*IF EDIT  CHARACTER*(*) A C C ADD STRING ONTO CURRENT RECORD C *CA PARAMA *CA EDITCO *CA DECAC*CALL EDIBKU C .*IF I4  INTEGER*4 ILX,IS,IL .*ENDIF DIMENSION IRD(5) C C CHECK FOR LEGAL RECORD C  IF(IREC.EQ.0.OR.IREC.EQ.NRECI) GOTO 1100  IDECP1=IR(IREC)  IF(IDECP1.LE.0) GOTO 1200  ILX=IDECP1  IF(ILX.LT.NRECI) THEN X IF (IDECP1.LE.0) GOTO 1100 X IF(IREC.LT.NRECI) THEN  CALL EXIN(IDECP1,IRD,5) a CALL EXIN(IDECP1,IRD(1),5)  IF(IRD(4).LT.0) GOTO 1200  IS=IDECP1+IRD(5) X IF(IRD(4).LT.0) GOTO 1100 X IDECP1=IDECP1+IRD(5)  NC=(IRD(1)-5-IRD(5))*NCHRWD  ELSE CALL EXIN(IDECP1,IRC,1)  IS=IDECP1  NC=IRC*NCHRWD  ENDIF  IR(IREC)=-IR(IREC)  CALL EDIADT(ADEC(IS),NC,A) X CALL EDIADT(ADEC(IDECP1),NC,A) C RETURN !C "1100 PRINT*,'CURRENT RECORD CANNOT BE ADDED TO' X1100 PRINT*,'Current record cannot be added to - command ignored' C LBAKUF=.FALSE. # RETURN $C %1200 PRINT*,'CURRENT RECORD DELETED/INACTIVE CANNOT ADD' C LBAKUF=.FALSE. X CALL EDIPOS )*ENDIF & RETURN ' END ( AND. IFLI) THEN .C /EDIADT 6/14/82R7) SUBROUTINE EDIADT(A1,N,A2) )*IF EDITR*CA PARAMA  CHARACTER*120 A1 R CHARACTER*(MAXWID) A1  CHARACTER*(*)A2 7 CHARACTER*120 BUX R CHARACTER*(MAXWID) BUX C C ADD TWO STRINGS TOGETHER TO MAKE A RECORD C (CALLED BY EDIADD) C  DO 100 I=N,2,-1  IF(A1(I:I).NE.' ') GOTO 200 100 CONTINUE I=1  200 CALL EDIINS(A1(1:I)//A2) 7200 LENA=I+LEN(A2) 7 BUX(1:LENA)=A1(1:I)//A2 7 CALL EDIINS(BUX(1:LENA)) CALL EDIPOS )*ENDIF  RETURN  END  DATA IWLCO /1/ I DATA IWLOP /1/ C  DATA OPT/'F','Q','LO','C','L','S','N','NA','P','PA'/R DATA OPT/'F','Q','LO','C','L','S','N','NA','P','PA', R 1 'W','SQ'/ C  DATA LOPT /'ACDEIMST'/ C C EDIBOT 6/14/82)  SUBROUTINE EDIBOT(A))*IF EDITC C SET POINTER TO BOTTOM C  CHARACTER*(*) A *CA PARAMA *CA EDITCO  IREC=NRECI CALL EDIPOS )*ENDIF RETURN  END 100 CONTINUEEDICHA 6/14/82C>;)  SUBROUTINE EDICHA(A))*IF EDIT  CHARACTER*(*)A C C C (S) CHANGE (DOES A SUBSTITUTE) C ACTUALLY FINDS THE RECORD WITH THE STRING-DELETES ITC AND THEN ADDS A NEW RECORD WITH THE SUBSTITUTIONC *CA PARAMA  *CA EDITCO C*CALL EDIBKU  LD=INDEX(A(2:),A(1:1))+1  IF(LD.LE.1) THEN > LENA=LEN(A) > IF(A(LENA:LENA).EQ.A(1:1)) THEN > LENA=LENA-1 > ENDIF > LD=INDEX(A(3:LENA),A(1:1))+2 > IF(LD.LT.3) THEN  PRINT*,'SECOND CHANGE DELIMITER NOT FOUND RE-ENTER' > PRINT*,'Second change delimeter not found re-enter' C LBAKUF=.FALSE. RETURN  ENDIF C > IF(LENA.LT.LD+1) THEN > PRINT*,' New string has no length re-enter' C LBAKUF=.FALSE. > RETURN > ENDIF  CALL EDICH1(A(2:LD-1),A(LD+1:)) ; LENA=LEN(A) ; IF(LENA.GT.4.AND.A(LENA:LENA).EQ.A(1:1)) THEN ; LENA=LENA-1 ; ENDIF ; CALL EDICH1(A(2:LD-1),A(LD+1:LENA)) )*ENDIF  RETURN  END END ( ICRDL(NCCRD)=ILE, IF(CCRD(ILE:ILE).NE.'-') GOTO 60EDICH1 6/14/82aC>6.)  SUBROUTINE EDICH1(AF,AS))*IF EDIT  CHARACTER*(*)AF,AS C C FINDS RECORD CONTAINING STRING AF C THEN DELETES THAT RECORD AND ADDS A NEW ONE C WITH AS SUBSTITUTED FOR AF C (CALLED FROM EDICHA)C  *CA PARAMA  *CA EDITCO  *CA DECAC*CALL EDIBKU.*IF I4 INTEGER*4 ILX,IS.*ENDIF DIMENSION IRD(5)  IRECS=IREC C 100 IF(IREC.EQ.NRECI) GOTO 500  IDECP1=IR(IREC)  IF(IDECP1.LE.0) GOTO 300  ILX=IDECP1  IF(IREC.LT.NRECI) THEN  CALL EXIN(IDECP1,IRD,5) a CALL EXIN(IDECP1,IRD(1),5)  IF(IRD(4).LT.0) GOTO 300 6 IF(IRD(4).GT.0) GOTO 300  IS=IDECP1+IRD(5)  NC=(IRD(1)-5-IRD(5))*NCHRWD  ELSE CALL EXIN(IDECP1,IRC,1)  IS=IDECP1  NC=IRC*NCHRWD  ENDIF  CALL EDISER(AF,ADEC(IS),NC,ILO)  IF(ILO.NE.0) THEN IR(IREC)=-IR(IREC) ! LAF=LEN(AF) " CALL EDICH2(ADEC(IS),NC,ILO,LAF,AS) # RETURN $ ENDIF %300 CONTINUE & IREC=N(IREC) ' GOTO 100(C )500 CONTINUE* PRINT*,'TEXT TO SUBSTITUTE FOR NOT FOUND' C LBAKUF=.FALSE. + IREC=IRECS > CALL EDIPOS )*ENDIF , RETURN - END & RETURN ' END ( AND. IFLI) THEN .C /EDICH2 6/14/82RJ7) SUBROUTINE EDICH2(A,NC,IP1,LAF,AS) )*IF EDIT  CHARACTER*120 A R*CA PARAMA R CHARACTER*(MAXWID) A  CHARACTER*(*) AS 7 CHARACTER*120 BUX R CHARACTER*(MAXWID) BUX C C ACTUALLY DOES SUBSTITUE AND ADDS NEW RECORD C (CALLED FROM EDICH1)C  CALL EDIINS(A(1:IP1-1)//AS//A(IP1+LAF:NC)) 7 LENA=LEN(AS)+NC-LAF 7 BUX(1:LENA)=(A(1:IP1-1)//AS//A(IP1+LAF:NC)) J IF(IP1.GT.1) THEN J IF(NC.GE.IP1+LAF) THEN J BUX(1:LENA)=A(1:IP1-1)//AS//A(IP1+LAF:NC) J ELSE J BUX(1:LENA)=A(1:IP1-1)//AS J ENDIFJ ELSEJ IF(NC.GE.IP1+LAF) THEN J BUX(1:LENA)=AS//A(IP1+LAF:NC) J ELSE J BUX(1:LENA)=AS J ENDIF J ENDIF 7 CALL EDIINS(BUX(1:LENA)) CALL EDIPOS )*ENDIF RETURN  END 11 FORMAT(A)  NCCRD=0  IS=1 IF(CCRD(1:4).NE.'SLIB') THEN PRINT*,'FIRST (CONTROL) RECORD MUST BE SLIB IT IS ',CCRD(1:4) STOP 'FIRST INPUT RECORD BAD' ENDIF !C "20 DO 30 IC=IS+79,IS+1,-1 # IF(CCRD(IC:ICEDICON 6/14/82)  SUBROUTINE EDICON )*IF EDITC C CONTINUE EDIT RUN C *CA PARAMA *CA EDITCO *CA LOGU*CA DECA C  READ(LDI) EDECK,IDECE,IDECPN,NRECI,NRECT,IDECI  C CALL RDDK(1,IDECE)  C  READ(LDI)(ADEC(I),I=IDECI+1,IDECPN-1)  READ(LDI)(IR(I),I=0,NRECT)  READ(LDI)(N(I),I=0,NRECT)  READ(LDI)(L(I),I=0,NRECT) )*ENDIF  RETURN  END ILX=IDECP1  IF(IREC.LT.NRECI) THEN  CALL EXIN(IDECP1,IRD,5)  IF(IREDIDEL 6/14/82C<)#  SUBROUTINE EDIDEL(A))*IF EDIT  CHARACTER*(*) A C C DELETE CURRENT RECORD C *CA PARAMA *CA EDITCO *CA DECAC*CALL EDIBKU DIMENSION IRD(5) C IDECP1=IR(IREC)  IF(IDECP1.LE.0) GOTO 1100   CALL EXIN(IDECP1,IRD,5)  IF(IRD(4).LT.0) GOTO 1100  IF(IRD(4).GT.0) GOTO 1100 # IF(IREC.LT.NRECI) THEN # CALL EXIN(IDECP1,IRD,5) # IF(IRD(4).LT.0) GOTO 1100 # ENDIF  IR(IREC)=-IR(IREC)  PRINT*,'[RECORD DELETED]' < PRINT*,''  CALL EDINEX(A)  CALL EDIPOS  RETURN 1100 PRINT*,'CURRENT RECORD IS NOT ACTIVE-CANNOT DELETE' C LBAKUF=.FALSE.  CALL EDIPOS )*ENDIF  RETURN  END HRWD  ENDIF EDIDIR 6/14/82) SUBROUTINE EDIDIR(IWID,J) )*IF EDITC C SEARCH EDIT DICTIONARY FOR FIRST CHARACTER IN INPUT STRING C *CA PARAMA *CA BUFA*CA EDITCO  CHARACTER*17 EDIDIC  CHARACTER*17 EDIDIC,EDIDIL  CHARACTER*18 EDIDIC,EDIDIL  DIMENSION JREF(0:17)  DIMENSION JREF(0:18) C   DATA EDIDIC /'TBF''"NP.AIDRCS-HE'/  DATA EDIDIC /'TBF''"NP.AIDRCS-HE+'/  DATA EDIDIL /'tbf''"np.aidrcs-he'/  DATA EDIDIL /'tbf''"np.aidrcs-he+'/   DATA JREF /0,1,2,3,3,3,4,5,5,6,7,8,9,10,10,11,12,13/ DATA JREF /0,1,2,3,3,3,4,5,5,6,7,8,9,10,10,11,12,13,14/  C  IF(IWID.EQ.0) THEN  J=4  IWID=1  ELSE J=JREF(INDEX(EDIDIC,BUF(1:1)))  IF(J.EQ.0)J=JREF(INDEX(EDIDIL,BUF(1:1)))  ENDIF )*ENDIF  RETURN  END !EDIEND 6/14/82 aXSRPH@.)  SUBROUTINE EDIEND(A))*IF EDITC C PROCESS FOR END OF RUN C WRITE COMPILE FILE C C WRITE SOURCE FILE FOR FUTURE BATCH INPUTC C WRITE DUMP FOR FUTURE INPUT  C  *CA PARAMA  *CA LOGU *CA EDITCO  *CA DECA*CA MODNA *CA DECKS  CHARACTER*(*)A C  DIMENSION IRD(5) EQUIVALENCE(LNX,IRD(1)),(IDK,IRD(2)),(NSQ,IRD(3)),  1 (IDEL,IRD(4)),(NMR,IRD(5)) .*IF I4  INTEGER*4 II.*ENDIF  CHARACTER*8 NAMSEC  CHARACTER*15 NAMSEQ  CHARACTER*8 DCK X CHARACTER*40 DELREC X CHARACTER*20 DELRE(2) X EQUIVALENCE(DELRE(1),DELREC)C XC LAST XC 1 - Normal statusXC 2 - Delete - 1st part of DELREC being writtenXC 3 - Delete - 2nd part of DELREC being written XC 4 - *D or *I written X C  WRITE(LSO,11)EDECK 11 FORMAT('*DECK ',A) S WRITE(LSO,111) '*DECK ',EDECK  LAST=0 X LAST=1  IREC=0 100 CONTINUE  IREC=N(IREC) IF(IREC.EQ.0) GOTO 900 ! IDECP1=IR(IREC) " IF(IDECP1.EQ.0) GOTO 900 # IF(IREC.GT.NRECI) THEN $C NEW % IF(IDECP1.LT.0) THEN &C DELETED ' GOTO 100 ( ELSE )C ACTIVE* CALL EXIN(IDECP1,IRC,1) + IF(LAST.NE.0) THEN X IF(LAST.EQ.1) THEN, CALL EDISID(DCK,NSQ,NAMSEQ)- WRITE(LSO,111)'*I ',NAMSEQ S IF(IDK.EQ.0) THEN S WRITE(LSO,211) '*I ',NSQ S ELSE S CALL EDISID(DCK,NSQ,NAMSEQ) S WRITE(LSO,111) '*I ',NAMSEQ S ENDIF X ELSE IF(LAST.EQ.2) THEN X WRITE(LSO,111) DELRE(1)X ELSE IF(LAST.EQ.3) THEN X WRITE(LSO,111) DELREC . LAST=0 / ENDIF X LAST=40 WRITE(LSO,111)(ADEC(II),II=IDECP1,IDECP1+IRC)  WRITE(LSO,111)(ADEC(II),II=IDECP1,IDECP1+IRC-1) 1111 FORMAT(60A) R111 FORMAT(80A) 2 CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------') H IF(ITYPE(IDECE).EQ.0) THENH CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------')P CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------',0) H ENDIF 3 ENDIF4 ELSE5C OLD 6 IF(IDECP1.GT.0) THEN 7C ACTIVE8 CALL EXIN(IDECP1,IRD,5) a CALL EXIN(IDECP1,IRD(1),5)XC X IF(IDEL.GT.0) GOTO 100XC X IF(LAST.EQ.2) THENX WRITE(LSO,111) DELRE(1)X ELSE IF(LAST.EQ.3) THEN X WRITE(LSO,111) DELREC X ENDIF X LAST=1 9 IDECP1=IDECP1+NMR : IF(IDK.EQ.0) THEN ; DCK=EDECK < ELSE = DCK=MODNA(IDK) > ENDIF ? LAST=1@ IF(IDEL.LT.0) GOTO 100 IF(IDEL.GT.0) GOTO 100A CALL COMPID(DCK,NSQ,NAMSEC) B NC=(LNX-5-NMR)*NCHRWD C CALL EDILIS(ADEC(IDECP1),NC,NAMSEC) H IF(ITYPE(IDECE).EQ.0) THENH CALL EDILIS(ADEC(IDECP1),NC,NAMSEC)P CALL EDILIS(ADEC(IDECP1),NC,DCK,NSQ) H ENDIF D ELSE EC DELETED F IDECP1=ABS(IDECP1)G CALL EXIN(IDECP1,IRD,5) a CALL EXIN(IDECP1,IRD(1),5) H LAST=0I IF(IRD(2).EQ.0) THEN JC MAIN K WRITE(LSO,211) IRD(3) L211 FORMAT('*D ',I6) S WRITE(LSO,211) '*D ',IRD(3)X IF(LAST.EQ.1.OR.LAST.EQ.4) THENX WRITE(DELRE(1),211) '*D ',IRD(3) X LAST=2 X ELSE X WRITE(DELRE(2),211) ',',IRD(3) X LAST=3 X ENDIF S 211 FORMAT(A,I6) M ELSE NC MOD O CALL EDISID(MODNA(IDK),NSQ,NAMSEQ) P WRITE(LSO,511) NAMSEQ Q511 FORMAT('*D ',A)S  WRITE(LSO,111) '*D ',NAMSEQX! IF(LAST.EQ.1.OR.LAST.EQ.4) THENX" WRITE(DELRE(1),111) '*D ',NAMSEQ X# LAST=2 X$ ELSE X% WRITE(DELRE(2),111) ',',NAMSEQ X& LAST=3 X' ENDIF R ENDIF S ENDIF T ENDIF U GOTO 100VC W900 CONTINUE X( IF(LAST.EQ.2) THEN X) WRITE(LSO,111) DELRE(1) X* ELSE IF(LAST.EQ.3) THEN X+ WRITE(LSO,111) DELREC X, ENDIF XC Y WRITE(LDO) EDECK,IDECE,IDECPN,NRECI,NRECT,IDECI ZC [ WRITE(LDO)(ADEC(I),I=IDECI+1,IDECPN-1) \ WRITE(LDO)(IR(I),I=0,NRECT) ] WRITE(LDO)(N(I),I=0,NRECT) ^ WRITE(LDO)(L(I),I=0,NRECT) @ PRINT*,' ' @ PRINT*,' ' @ PRINT*,' End of editing deck ',EDECK @ PRINT*,' ' @ PRINT*,' ' )*ENDIF _ RETURN ` END EDIFIN 6/14/82aC6.)  SUBROUTINE EDIFIN(A))*IF EDIT  CHARACTER*(*)A C C FINDS RECORD CONTAINING STRING C *CA PARAMA *CA EDITCO *CA DECAC*CALL EDIBKU.*IF I4 INTEGER*4 ILX,IS.*ENDIF DIMENSION IRD(5) IRECS=IREC  C  100 IF(IREC.EQ.NRECI) GOTO 500  IDECP1=IR(IREC)  IF(IDECP1.LE.0) GOTO 300  ILX=IDECP1  IF(IREC.LT.NRECI) THEN  CALL EXIN(IDECP1,IRD,5) a CALL EXIN(IDECP1,IRD(1),5)  IF(IRD(4).LT.0) GOTO 300 6 IF(IRD(4).GT.0) GOTO 300  IS=IDECP1+IRD(5)  NC=(IRD(1)-5-IRD(5))*NCHRWD  ELSE CALL EXIN(IDECP1,IRC,1)  IS=IDECP1  NC=IRC*NCHRWD  ENDIF  CALL EDISER(A,ADEC(IS),NC,ILO)  IF(ILO.NE.0) THEN  RETURN  ENDIF 300 CONTINUE IREC=N(IREC) ! GOTO 100"C #500 CONTINUE $ PRINT*,'TEXT NOT FOUND' C LBAKUF=.FALSE. % IREC=IRECS )*ENDIF & RETURN ' END IF(IREC.EQ.0) GOTO 900 EDIHEL 6/14/82XJ;)  SUBROUTINE EDIHEL(A))*IF EDIT  CHARACTER*(*) A C C PROCESS HELP REQUESTC *CA PARAMA *CA LOGU*CA BUFA C ; IF(LEN(A).GT.1.AND.INDEX('12',A(2:2)).NE.0) THENJ IF(LEN(A).LT.2) GOTO 8 X IF(LEN(A).GE.2) THEN; IF(A(2:2).EQ.'1') THEN ; CALL EDIHE1 ; ELSE X ELSE IF(A(2:2).EQ.'2') THEN ; CALL EDIHE2 X ELSE IF(A(2:2).EQ.'3') THEN X CALL EDIHE3 ; ENDIF ; RETURN ; ENDIF J8 CONTINUE X ENDIF XC  PRINT*,'You have obtained access to the HELP portion of' 1 ,' SLIB77'  PRINT*,'There are currently the following levels of HELP!'  PRINT*,' 1 - Overall description of SLIB77 editor.'  PRINT*,' 2 - General description of commands.' X PRINT*,' 3 - List of decks in current library.' C 10 PRINT*,' Enter desired level (CR to resume editing)' 100 CALL RDTERM(LTI,IWID)  IF(IWID.LT.1) RETURN ) IF(IWID.LT.1) GOTO 200  IF(BUF(1:1).EQ.'1') THEN ; 120 IF(BUF(1:1).EQ.'1') THEN  CALL EDIHE1  ELSE IF(BUF(1:1).EQ.'2') THEN  CALL EDIHE2 X ELSE IF(BUF(1:1).EQ.'3') THEN X CALL EDIHE3  ELSE PRINT*,'Improper entry enter 1 2 or CR' X PRINT*,'Improper entry enter 1, 2, 3 or CR'  GOTO 100  ENDIF  GOTO 10 )*ENDIF )200 RETURN  END ,NSQ,NAMSEQ)- WRITE(LSO,111)'*I ',NAMSEQ S IF(IDK.EQ.0) THEN S WRITE(LSO,211) '*I ',NSQ S ELSE S CALL EDISID(DCK,NSQ,NAMSEQ) S WRITE(LSO,111) '*I ',NAMSEQ S ENDIF X EDIHE1 6/14/82)  SUBROUTINE EDIHE1 )*IF EDITC C HELP PORTION 1 OVERALL DESCRIPTION C  CHARACTER*35 HEL1A(18)  CHARACTER*35 HEL1B(6)  DATA HEL1A/  1 'This editor is designed to allow th'  1 ,'e user to work with SLIB77 files'  2 ,'interactively to create "modificat-'  2 ,'ion" sets to be used in the "BATCH"'  3 ,'environment SLIB77 was designed for' 3 ,'.'  4 ,' The editor uses a BACKUP (17) file'  4 ,' to write all user input to in case'  5 ,' the machine goes down during the r'  5 ,'un.'  6 ,'The program also uses a DUMP (19) f'  6 ,'ile to allow the user to do some ed'  7 ,'iting - then end the program -test '  7 ,'the mods then re-enter the program '  8 ,'and CONTINUE with the same conditio'  8 ,'ns as previously.'  9 ,'The editor will not currently acces'  9 ,'s "DELETED" records in the file.' 2 /  DATA HEL1B/  1 'The editor reads only the first col'  1 ,'umn of each command to determine'  2 ,' the proper action to take.'  2 ,' '  3 ,' NOTE: all trailing blanks are ALWA' ! 3 ,'YS trimmed off of input!'" 1 / # PRINT11,HEL1A $11 FORMAT(1X,2A) % PRINT11,HEL1B )*ENDIF & RETURN ' END LSO,111)(ADEC(II),II=IDECP1,IDECP1+IRC-1) 1111 FORMAT(60A) 2 CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------') 3 ENDIF4 ELSE5C OLD 6 IF(IDECP1.GT.0) THEN 7C ACTIVE8EDIHE2 6/14/82;)   SUBROUTINE EDIHE2 )*IF EDITC C HELP PART 2 DESCRIPTION OF COMMANDS C  CHARACTER*35 HEL2A(18)  CHARACTER*35 HEL2B(8)  CHARACTER*35 HEL2B(12) ; CHARACTER*35 HEL2B(18)  DATA HEL2A / 1 'The following commands are currentl' 1 ,'y implemented:'  2 ,' T Top Pointer set to' 2 ,'p of deck'  3 ,' B Bottom pointer set to' 4 ,' bottom.' 4 ,' Fstr Find search for str'  4 ,'ing'  5 ,' N or CR Next set pointer to'  5 ,' next record' 6 ,' P or . Print print current '  6 ,' Pn or .n Print print n (no. ) '   6 ,' Pn or .n Print print n (no.) '  6 ,'record on terminal'  6 ,'recordson terminal'  7 ,' Astr Add add string to '  7 ,'current record(at the end)'  8 ,' Istr Insert insert new rec'  8 ,'ord (following current record)'  9 ,' D Delete delete current'  9 ,' record'  9 / C  DATA HEL2B /  1 ' H Help prints on term'  4 ' -n Set pointer n records '  4 ,'back '  5 ,' +n Set pointer n records '  5 ,'forward '  1 ,' H Help prints on term'  1 ,'inal these messages'  2 ,' E End end processing' 2 ,' of current deck'! 3 ,' C or S Change Substitute str' " 3 ,'2 for str1' # 4 ,' NOTE: FORMAT- C (delimiter) str1 ' $ 4 ,' (delimeter) str2' ; 4 ,' C FORMAT- C (del) str1 (del) ' ; 4 ,'str2 (del)' ; 5 ,' (Third delimeter (del) ca' ; 5 ,'n be omitted)' ; 6 ,' ' ; 6 ,' ' ; 7 ,' (A blank line can be inse' ; 7 ,'rted with an I# )' % 9 / & PRINT11,HEL2A '11 FORMAT(1X,2A) ( PRINT11,HEL2B )*ENDIF ) RETURN * END EDIHE3 3/28/83  SUBROUTINE EDIHE3 C C prints DECK names for current library C *CA PARAMA *CA DECKS  CHARACTER*8 IDA(7)  CHARACTER*2 ITP(7)  C  PRINT*,'You have obtained access to the library deck names' PRINT*,' ' IF(NDCKS.EQ.0) THEN  PRINT*,'There are no decks to list the names of'  PRINT*,'Before I can list the decks'  PRINT*,'the program must have read in a LIBRARY.' PRINT*,'To do this request a deck to edit (even garbage)' ELSE PRINT*,' (#=Purged deck, *=Common deck)'  ID=0  DO 200 I=1,NDCKS  ID=ID+1  IDA(ID)=DECK(I)  IF(ITYPE(I).NE.0) THEN  ITP(ID)=' *'  ELSE  ITP(ID)=' '  ENDIF C  IF(IPURGE(I).NE.0) THEN  ITP(ID)(1:1)='#'  ENDIF IF(ID.GT.6) THEN ! PRINT 121,(ITP(J),IDA(J),J=1,7)"121 FORMAT(7(1X,2A)) # ID=0 $ ENDIF %200 CONTINUE & IF(ID.GT.0) THEN ' PRINT 121, (ITP(I),IDA(I),I=1,ID) ( ENDIF ) PRINT*,' ' * ENDIF + RETURN , END EDICHA 6/14/82EDICH1 6/14/82EDICH2 6/14/82EDICON 6/14/82EDIDEL 6/14/82EDIDIR 6/14/82EDIEND 6/14/82 EDIFIN 6/14/82EDIINI 6/14/824ec]XPMGECB@<0)'  SUBROUTINE EDIINI @ SUBROUTINE EDIINI(IEDECK) )*IF EDITC C INITIALIZE INTERACTIVE/EDIT RUN C *CA PARAMA *CA LOGU*CA EDITCO *CA DECI  CHARACTER*10 BKUPO,BKUPI,OPLFIL,DUMPFI ' CHARACTER*10 BKUPO,BKUPI,OPLFIL,DUMFPI,DUMPFO 0 CHARACTER*10 BKUPO,BKUPI,OPLFIL,DUMPFI,DUMPFO   CHARACTER*10 SOU,COMP  CHARACTER*3 YESN C 11 FORMAT(A) C  PRINT*,'ENTER OLD LIBRARY FILE (CR=FOR031.DAT)'  ACCEPT 11,OPLFIL  READ(LTI,11)OPLFIL  CALL OPNLOP(LOP,OPLFIL)  CALL RDOPL(LOP) C  PRINT*,'IS THIS A CONTINUATION RUN?'  ACCEPT11,YESN  READ(LTI,11)YESNC  IF(YESN.EQ.'YES') THEN C  PRINT*,'ENTER DUMP FILE NAME AS INPUT (DEF=FOR020.DAT)'  ACCEPT11,DUMPFI  READ(LTI,11)DUMPFI  CALL OPNLDI(LDI,DUMPFI)  CALL EDICON  ELSEC 100 PRINT*,'ENTER DECK TO BE EDITED'   ACCEPT11,EDECK  READ(LTI,11)EDECK! IDECE=IFINDK(EDECK) " IF(IDECE.EQ.0) THEN # PRINT*,'DIDNT FIND DECK TO BE EDITED TRY AGAIN' $ GOTO 100 % ELSE IF(IDECE.LT.0) THEN & PRINT*,'DECK IS PURGED DO YOU STILL WISH TO EDIT IT?'' ACCEPT11,YESN  READ(LTI,11)YESN ( IF(YESN.NE.'YES') GOTO 100 ) ENDIF*C + CALL RDDK(1,IDECE)  PRINT*,'do you wish the sequence numbers listed?'  READ(LTI,11)YESN IF(YESN.EQ.'YES'.OR.YESN.EQ.'yes') THEN < IF(INDEX('Yy',YESN(1:1)).NE.0) THEN  LSTSEQ=.TRUE.  ELSE  LSTSEQ=.FALSE.  ENDIF @*CALL DECKS @*CALL MODNA @*CALL SWITCH@ CHARACTER*3 ACON,AREC,ASEQ @ CHARACTER*12 FI12,FI14,FI17,FI18,FI19,FI20 @ CHARACTER*12 ADCK,ALIB G CHARACTER*12 ADCK @ CHARACTER*80 ANS@  CHARACTER*12 BKUPO,BKUPI,OPLFIL,CONTI,CONTO,SOU,COMPG CHARACTER*72 BKUPO,BKUPI,OPLFIL,CONTI,CONTO,SOU,COMPBC B SAVE INAMTP,ASEQ,ISEQ,ALIB G SAVE INAMTP,ASEQ,ISEQ,OPLFIL,LOPLFI @ C @ C @ C INAMTP FILE NAME CONVENTION @ C 1 = deckname.xxx @c 2 = FOR0xx.dat GC 2 = FOR0xx @C 3 = INDIVIDUALLY SET BY USER @C ]C COMEXT - compile file name extension ] CHARACTER*4 COMEXT @ DATA INAMTP /1/ @ DATA ISEQ /0/ @ DATA ASEQ /'NO'/@C @ DATA ALIB /'FOR031.DAT' / G DATA OPLFIL /'FOR031' / G DATA LOPLFI /6/ ]*IF -PRIME ] DATA COMEXT /'.FOR'/]*ENDIF ]*IF PRIME ] DATA COMEXT /'.F77'/]*ENDIF @C @ SAVE INAMTP,ASEQ,ISEQ,ALIB @C @ @1 FORMAT (12A) @ @C BC TURN OFF BAKUP FILE B CALL SETBAK(.FALSE.) @ IEDCKO=IEDECK @*IF -IBM @ IF(IEDCKO.NE.0) THEN @ CLOSE(LBO) @! CLOSE(LCO) @" CLOSE(LSO) @# CLOSE(LDO) @$ ENDIF @%*ENDIF @&C @'100 PRINT*,' Enter deck to be edited (CR to end run)'X100 PRINT*,' Enter deck to be edited (CR=end, H=help)' @( READ(LTI,1) EDECK X IF(EDECK.EQ.'H ') THEN X CALL EDIHEL('H3') X GOTO 100 X ENDIF @) IBL=INDEX(EDECK,' ') @* IF(IBL.EQ.0) IBL=8 @+C @, IF(IBL.EQ.1) THEN @- IEDECK=0 @. RETURN @/ ELSE @0 IBL=IBL-1 @1 IEDECK=1 @2 ENDIF @3C @4 ADCK=EDECK(1:IBL)//'.XXX' @5C @6 IF(INAMTP.EQ.1) THEN @7 ADCK='FOR0XX.DAT' G ADCK='FOR0xx'@8 FI12=EDECK(1:IBL)//'.SRC'@9 FI14=EDECK(1:IBL)//'.FOR'@: FI17=EDECK(1:IBL)//'.BAK' @; FI18=FI17@< FI19=EDECK(1:IBL)//'.CNT' @= FI20=FI19 @> SOU=FI12 @? COMP=FI14 @@ BKUPO=FI17 @A CONTO=FI19 @B BKUPI=FI18 @C CONTI=FI20 G SOU = EDECK(1:IBL)//'.SRC' G LSOU = IBL+4 G  COMP = EDECK(1:IBL)//'.FOR' ] COMP = EDECK(1:IBL)//COMEXT G LCOMP = IBL+4G BKUPO = EDECK(1:IBL)//'.BAK' G LBKUPO = IBL+4 G CONTO = EDECK(1:IBL)//'.CNT' G LCONTO = IBL+4 G BKUPI = EDECK(1:IBL)//'.BAK' G LBKUPI = IBL+4 G CONTI = EDECK(1:IBL)//'.CNT' G LCONTI = IBL+4 @D ENDIF @EC @F OPLFIL=' ' @G IRECOV=0 @H AREC='NO' @I ICONT=0 @J ACON='NO' @KC @L10 PRINT1,' ' @M PRINT1,' ' @N PRINT1,' ' @O PRINT1,' ' @P PRINT1,' SLIB77 edit run controls' @Q PRINT1,' ' @R PRINT1,' currently To modify' @S PRINT1,' --------- ---------' @T PRINT1,' CONTINUATION run ',ACON,' C' @U PRINT1,' RECOVERY run ',AREC,' R' @V PRINT1,' Sequence numbers ',ASEQ,' S' @W PRINT1,' ' @X PRINT1,' O To change to ',ADCK, ' enter N'@Y PRINT1,' U F To enter separate names enter I' @Z PRINT1,' T I ',FI12,' source'G PRINT1,' T I ',SOU(1:LSOU),' source' @[ PRINT1,' P L ',FI14,' compile' G PRINT1,' P L ',COMP(1:LCOMP),' compile' @\ PRINT1,' U E ',FI19,' continuation' G PRINT1,' U E ',CONTO(1:LCONTO),' continuation' @] PRINT1,' T S ',FI17,' backup'G PRINT1,' T S ',BKUPO(1:LBKUPO),' backup' @^ PRINT1,' ' @_ PRINT1,' Library File ',ALIB,' to change enter L' G PRINT1,' Library File ',OPLFIL(1:LOPLFI),' to change enter L' @` PRINT1,' ' @a PRINT1,' ' @b PRINT1,' Enter selection (CR for no changes)-' @cC @d ANS=' ' @e READ(LTI,1) ANS @fC @g IF(ANS.EQ.' ') GOTO 400 @hC @i LENA=INDEX(ANS,' ') @j IF(LENA.EQ.0) GOTO 400 @kC @l DO 300 IC=1,LENA@m ITP = (INDEX('CRSNIL',ANS(IC:IC))) +1c ITP = INDEX('CRSNIL',ANS(IC:IC))c IF(ITP.EQ.0) ITP = INDEX('crsnil',ANS(IC:IC)) +1 e IF(ITP.EQ.0) ITP = INDEX('crsnil',ANS(IC:IC)) e ITP=ITP+1@nC @oC C R S N I L@p GOTO (300,210,220,230,240,250,260),ITP @qC @rC C - CONTINUATION@sC @t210 CONTINUE @u IF(ICONT.EQ.0) THEN @v PRINT*,' Enter file to continue with (def=',FI20 G PRINT*,' Enter file to continue with (def = FOR020)' @w CONTI=' ' @x READ(LTI,1) CONTI @y IF(CONTI.EQ.' ') CONTI=FI20 G IF(CONTI.EQ.' ') THEN G CONTI = 'FOR020' G ENDIF G LCONTI = INDEX(CONTI,' ')-1 @z ICONT=1 @{ ACON='YES' @| ELSE @} ICONT=0 @~ ACON='NO' @ ENDIF @ GOTO 300 @C @C R - RECOVERY @C @220 CONTINUE @ IF (IRECOV.EQ.0) THEN@ PRINT*,' Enter file to recover with (def=',FI18 G PRINT*,' Enter file to recover with (def = FOR018' @ BKUPI=' ' @ READ(LTI,1) BKUPI @ IF(BKUPI.EQ.' ') BKUPI=FI18 G IF(BKUPI.EQ.' ') THEN G BKUPI = 'FOR018' G! ENDIF G" LBKUPI = INDEX(BKUPI,' ')-1 @ IRECOV=1 @ AREC='YES' @ ELSE @ IRECOV=0 @ AREC='NO' @ ENDIF @ GOTO 300 @C @C S - SEQUENCE NUMBERS @C @230 CONTINUE @ IF(ISEQ.EQ.0) THEN @ ISEQ=1 @ ASEQ='YES' E LSTSEQ=.TRUE. @ ELSE @ ISEQ=0 @ ASEQ='NO' E LSTSEQ=.FALSE. @ ENDIF @ GOTO 300 @C @C N - REVERSE FILE NAMES @C @240 CONTINUE @ IF(INAMTP.EQ.1) THEN @ INAMTP=2 @ ADCK=EDECK(1:IBL)//'.XXX' @ FI12='FOR012.DAT' @ FI14='FOR014.DAT' @ FI17='FOR017.DAT' @ FI19='FOR019.DAT' @ FI18='FOR018.DAT' @ FI20='FOR020.DAT' @ SOU=' ' @ COMP=' ' @ BKUPO=' ' @ CONTO=' ' @ CONTI=' ' @ BKUPI=' ' G# SOU = 'FOR012' G$ LSOU = 6 G% COMP = 'FOR014' G& LCOMP = 6 G' BKUPO = 'FOR017' G( LBKUPO = 6 G) CONTO = 'FOR019' G* LCONTO = 6G+ CONTI = 'FOR020' G, LCONTI = 6G- BKUPI = 'FOR018' G. LBKUPI = 6 @ ELSE @ INAMTP=1 @ ADCK='FOR0XX.DAT' G/ ADCK='FOR0xx' @ FI12=EDECK(1:IBL)//'.SRC' @ FI14=EDECK(1:IBL)//'.FOR' @ FI17=EDECK(1:IBL)//'.BAK' @ FI18=FI17 @ FI19=EDECK(1:IBL)//'.CNT' @ FI20=FI19 @ SOU=FI12 @ COMP=FI14 @ BKUPO=FI17 @ CONTO=FI19 @ BKUPI=FI18 @ CONTI=FI20G0 SOU = EDECK(1:IBL)//'.SRC' G1 LSOU = IBL+4 G2 COMP = EDECK(1:IBL)//'.FOR' ] COMP = EDECK(1:IBL)//COMEXT G3 LCOMP = IBL+4 G4 BKUPO = EDECK(1:IBL)//'.BAK' G5 LBKUPO = IBL+4G6 CONTO = EDECK(1:IBL)//'.CNT' G7 LCONTO = IBL+4G8 BKUPI = EDECK(1:IBL)//'.BAK' G9 LBKUPI = IBL+4G: CONTI = EDECK(1:IBL)//'.CNT' G; LCONTI = IBL+4 @ ENDIF @ GOTO 300 @C @C I - ENTER SEPARATE FILE NAMES@C @250 CONTINUE @ INAMTP=3 @ PRINT*,' Enter backup output file (def=',FI17,')'G< PRINT*,' Enter backup output file (def = ',EDECK(1:IBL)//'.BAK)' @ BKUPO=' ' @ READ(LTI,1) BKUPO@ PRINT*,' Enter compile file (def=',FI14,')' G= IF(BKUPO.EQ.' ') THENG> BKUPO = EDECK(1:IBL)//'.BAK' G? ENDIFG@ LBKUPO = INDEX(BKUPO,' ')-1 GA PRINT*,' Enter compile file (def = ',EDECK(1:IBL)//'.FOR)' ] PRINT*,' Enter compile file (def = ',] 1 EDECK(1:IBL)//COMEXT,')' @ COMP=' ' @ READ(LTI,1) COMP @ PRINT*,' Enter source file (def=',FI12,')' GB IF(COMP.EQ.' ') THEN GC COMP = EDECK(1:IBL)//'.FOR' ] COMP = EDECK(1:IBL)//COMEXT GD ENDIFGE LCOMP = INDEX(COMP,' ')-1GF PRINT*,' Enter source file (def = ',EDECK(1:IBL)//'.SRC)' @ SOU=' ' @ READ(LTI,1) SOU @ PRINT*,' Enter continue output file (def=',FI19,')' GG IF(SOU.EQ.' ') THEN GH SOU = EDECK(1:IBL)//'.SRC' GI ENDIFGJ LSOU = INDEX(SOU,' ')-1 GK PRINT*,' Enter continue output file (def=',EDECK(1:IBL)//'.CNT)' @ CONTO=' ' @ READ(LTI,1) CONTO GL IF(CONTO.EQ.' ') THENGM CONTO = EDECK(1:IBL)//'.CNT' GN ENDIFGO LCONTO = INDEX(CONTO,' ')-1 @ GOTO 300 @C @C L - SELECT LIBRARY NAME @C @260 CONTINUE @ PRINT*,' Enter library file name (def= FOR031.DAT )' GP PRINT*,' Enter library file name (def= FOR031 )' @ OPLFIL=' ' @ READ(LTI,1) OPLFIL @ ALIB=OPLFIL @ IF(ALIB.EQ.' ')ALIB='FOR031.DAT' GQ IF( OPLFIL .EQ.' ') THEN GR OPLFIL = 'FOR031' GS ENDIFGT LOPLFI = INDEX(OPLFIL,' ')-1 @ IF(IEDCKO.NE.0) THEN @ CLOSE(LOP) @ IEDCKO=0 @ ENDIF @ GOTO 300 @C @300 CONTINUE @ GOTO 10 @C @400 IF(IEDCKO.EQ.0) THEN @ NDCKS=0 @ NSWS=0 @ NMODS=0 @ CALL OPNLOP(LOP,OPLFIL) GU CALL OPNLOP(LOP,OPLFIL(1:LOPLFI)) @ CALL RDOPL(LOP) @ ENDIF @C @ IDECE = IFINDK(EDECK) @C @ IF(IDECE.EQ.0) THEN @ PRINT*,' Deck ',EDECK,' not found try again.' @ GOTO 100 @ ELSE IF (IDECE.LT.0) THEN @ PRINT*,' Deck ',EDECK,' is purged do you wish to edit it?' @ READ(LTI,1) ANS @ IF(INDEX('Yy',ANS(1:1)).EQ.0) GOTO 100 @ IDECE=-IDECE @ IEDECK=IDECE @ ENDIF @C @ CALL OPNLCO(LCO,COMP) GV CALL OPNLCO(LCO,COMP(1:LCOMP)) @ CALL OPNLSO(LSO,SOU)GW CALL OPNLSO(LSO,SOU(1:LSOU))@C @ IF(ICONT.NE.0) THEN @ PRINT*,' ' @ PRINT*,' processing continue.' @ PRINT*,' ' @ CALL OPNLDI(LDI,CONTI) GX CALL OPNLDI(LDI,CONTI(1:LCONTI)) @ CALL EDICON @ ICONT=0 @ CLOSE(LDI) @ PRINT*,' continue processing completed.' @ ELSE @ CALL RDDK(1,IDECE) ,C - IDECP1=1+2*NW8C+1 . NMD=IDEC(IDECP1) / IDECP1=IDECP1+1+NMD 0C 1 IREC=0 2 IR(0)=0 3 N(0)=1 4 L(0)=0 5C 6300 CONTINUE @500 CONTINUE 7C 8 LNX=IDEC(IDECP1) 9 IREC=IREC+1 : IF(LNX.NE.0) THEN ; IR(IREC)=IDECP1 < N(IREC)=IREC+1 = L(IREC)=IREC-1 > IDECP1=IDECP1+LNX ? GOTO 300 @  GOTO 500 @ ENDIF A IR(IREC)=0 B N(IREC)=0 C L(IREC)=IREC-1 D NRECI=IREC E NRECT=NRECI F IDECI=IDECP1-1 G IREC=0 H IDECPN=IDECP1I PRINT*,NRECI-1,' RECORDS IN DECK ',EDECK J ENDIF @  PRINT*,NRECI-1,'Records in deck ',EDECK P PRINT*,NRECI-1,' Records in deck ',EDECK @  ENDIF @ C @ C @ IF(IRECOV.NE.0) THEN @ PRINT*,' ' @ PRINT*,' processing recovery.' @ PRINT*,' ' @ CALL OPNLBI(LBI,BKUPI) GY CALL OPNLBI(LBI,BKUPI(1:LBKUPI)) @ CALL EDIREC CC Parameter for EDITOR is RECOVER C CALL EDITOR(.TRUE.) @ CLOSE (LBI) @ PRINT*,' Recovery processing completed.' @ ENDIF @ CALL OPNLBO(LBO,BKUPO) GZ CALL OPNLBO(LBO,BKUPO(1:LBKUPO)) BC TURNON BAKUP FILE B CALL SETBAK(.TRUE.) @ CALL OPNLDO(LDO,CONTO) G[ CALL OPNLDO(LDO,CONTO(1:LCONTO))@C KC L PRINT*,'IS THIS A RECOVERY RUN?' M ACCEPT 11,YESN  READ(LTI,11)YESNN IF(YESN.EQ.'YES') THEN O PRINT*,'ENTER INPUT BACKUP FILE (DEF=FOR018.DAT)'P ACCEPT11,BKUPI  READ(LTI,11)BKUPIQ CALL OPNLBI(LBI,BKUPI) R CALL EDIREC S ENDIF TC U PRINT*,'ENTER OUTPUT BACKUP FILE (DEF=FOR017.DAT)' V ACCEPT11,BKUPO  READ(LTI,11)BKUPO W CALL OPNLBO(LBO,BKUPO) XC Y PRINT*,'ENTER COMPILE FILE (DEF=FOR014.DAT)' Z ACCEPT 11,COMP   READ(LTI,11)COMP[ CALL OPNLCO(LCO,COMP) \C ] PRINT*,'ENTER SOURCE FILE (DEF=FOR012.DAT)' ^ ACCEPT11,SOU   READ(LTI,11)SOU _ CALL OPNLSO(LSO,SOU)'C ' PRINT*,'ENTER DUMP OUTPUT FILE (DEF=FOR019.DAT)' ' READ(LTI,11) DUMPFO ' CALL OPNLDO(LDO,DUMPFO) 'C )*ENDIF ` RETURN a END EDIINS 6/14/82RGC7)&  SUBROUTINE EDIINS(A))*IF EDIT  CHARACTER*(*) A C C INSERT A NEW RECORD BEHIND CURRENT RECORD C *CA PARAMA *CA EDITCO *CA DECAC*CALL EDIBKU 7 CHARACTER*120 BUX R CHARACTER*(MAXWID) BUX IF(IREC.EQ.0) THEN  PRINT*,'CANNOT INSERT RECORD AT TOP' C LBAKUF=.FALSE. RETURN  ELSE IF(IREC.EQ.NRECI) THEN IREC=L(IREC)  ENDIF  NRECT=NRECT+1  NR=N(IREC)  LR=L(IREC)  N(IREC)=NRECT  N(NRECT)=NR  L(NR)=NRECT  L(NRECT)=IREC  IR(NRECT)=IDECPN NW=(LEN(A)+NCHRWD-1)/NCHRWD  IDECP1=IDECPN  CALL ININ(IDECPN,NW,1)  CALL INCHW(A//' ',ADEC(IDECPN),NW*NCHRWD)& CALL INCHW(A(1:LEN(A))//' ',ADEC(IDECPN),NW*NCHRWD) 7 BUX=A//' ' 7 CALL INCHW(BUX,ADEC(IDECPN),NW*NCHRWD) )*ENDIF *IF VAX  NCH=NW*NCHRWD  CALL EDIVMD(ADEC(IDECPN),NCH)  IF(NCH.NE.NW*NCHRWD) THEN  NW=NCH/NCHRWD CALL ININ(IDECP1,NW,1) ! IDECPN=IDECP1 " ENDIF #*ENDIF )*IF EDIT $ IDECPN=IDECPN+NW % IREC=N(IREC))*ENDIF & RETURN ' END ITE(LSO,111)(ADEC(II),II=IDECP1,IDECP1+IRC-1) 1111 FORMAT(60A) R111 FORMAT(80A) 2 CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------') H IF(ITYPE(IDECE).EQ.0) THENEDILIS 6/14/82id[RPA) SUBROUTINE EDILIS(A,LENA,NAMSEQ)P SUBROUTINE EDILIS(A,LENA,DCK,NSQ) )*IF EDITC C ACTUALLY DOES WRITE OF COMPILE FILE FOR EDIT RUNC AND CHECKS FOR COMMON DECK TO INSERTC *CA PARAMA *CA DECA*CA LOGU *CA PRFX *CA IFSWI  CHARACTER*(120)A R*CA WIDTH d*CA LANGC R CHARACTER*(MAXWID) A  CHARACTER*8 NAMSEQ P CHARACTER*8 DCK  CHARACTER*120 DUMT R CHARACTER*(MAXWID) DUMT  DATA DUMT/' '/dC dC IL- Logical array for LISCRD to turn on compile only dC d LOGICAL IL(3) d DATA IL /.FALSE. , .TRUE. , .FALSE./dC IAC = 1 (Indicates active record - for LISCRD d DATA IAC /1/d C C  IF(ISETIF.EQ.0) THEN [ ITD=0 [ IF(A(1:1).EQ.PRFX) THEN [ CALL CKDIR(A(1:LENA),ITD) [ ENDIF i IF(ISETIF.EQ.0.OR.ITD.EQ.9.OR.ITD.EQ.11) THEN [C [ IF(ISETIF .EQ. 0 .OR. ITD .EQ. 9 .OR. ITD .EQ. 11) THEN  LENDU=MAXWID-LENAR LENDU = MWIDE-LENA [C COMPS is left over - it will be needed if the compile file [C needs to be compressed. P*IF COMPS P CALL COMPID ( DCK, NSQ, NAMSEQ)  WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),NAMSEQ 121 FORMAT(A,A,A8) A IF(LENDU.GT.0) THEN A WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),NAMSEQ P121 FORMAT(3A) A ELSE A WRITE(LCO,121) A(1:LENA),NAMSEQ A ENDIF A121 FORMAT(3A) P*ENDIF P*IF -COMPS P IF(LENDU.GT.0) THEN P  WRITE(LCO,119) A(1:LENA),DUMT(1:LENDU),DCK,NSQP 119 FORMAT(3A,1X,I4) P  ELSE P  WRITE(LCO,121) A(1:LENA),DCK,NSQ P 121 FORMAT(2A,1X,I4) P ENDIFP*ENDIF  ENDIF d  CALL LISCRD(ITD,IL,IAC,DCK,NSQ,A,LENA) i CALL LISCRD(ITD,IL,IAC,DCK,NSQ,A,LENA) i ENDIF C  IF(A(1:1).EQ.PRFX) THEN [  IF(ITD .NE. 0) THEN  CALL COMCHK(ADEC(IDECP1),LENA) d IF(ITD.EQ.3.OR.ITD.EQ.9.OR.ITD.EQ.11) THEN d  CALL COMCHK(ITD,ADEC(IDECP1),LENA) i CALL COMCHK(ITD,A,LENA)  ENDIF C )*ENDIF  RETURN  END le must be SLIB it is ',A) f STOP 'Improper CONTROL RECORDEDIMIN 6/14/82)  SUBROUTINE EDIMIN(A))*IF EDIT  CHARACTER*(*) A C C SET POINTER TO PREVIOUS LINEC *CA PARAMA *CA EDITCO *CA DECI C  LN=LEN(A)  IF(LN.GT.1) THEN  NP=RVAL(A(2:LN))  NP=MAX(1,NP)  ELSE  NP=1  ENDIF C  DO 200 I=1,NP IF(IREC.EQ.0) GOTO 500 100 IREC=L(IREC) IF(IREC.EQ.0) GOTO 500 IDECP1=IR(IREC)  IF(IDECP1.LE.0) GOTO 100 IF(IREC.GT.NRECI) GOTO 500  IF(IREC.GT.NRECI) GOTO 200  IF(IDEC(IDECP1+3).LT.0) GOTO 100 IF(IDEC(IDECP1+3).GT.0) GOTO 100 500 CALL EDIPOS  200 CONTINUE  500 CONTINUE)*ENDIF  RETURN  END CALL EDIVMD(ADEC(IDECPN),NCH)  IF(NCH.NE.NW*NCHRWD) THEN EDINEX 6/14/82)  SUBROUTINE EDINEX(A))*IF EDIT  CHARACTER*(*) A C C SET POINTER TO NEXT LINEC *CA PARAMA *CA EDITCO *CA DECI C  IF(IREC.EQ.NRECI) GOTO 500 100 IREC=N(IREC) IF(IREC.EQ.NRECI) GOTO 500 IDECP1=IR(IREC)  IF(IDECP1.LE.0) GOTO 100 IF(IDEC(IDECP1+3).LT.0) GOTO 100 IF(IREC.GT.NRECI) GOTO 500  IF(IDEC(IDECP1+3).GT.0) GOTO 100 500 CALL EDIPOS 500 CONTINUE)*ENDIF  RETURN  END  IF(IREC.GT.NRECI) GOTO 500 EDIPLS 6/23/82)  SUBROUTINE EDIPLS(A))*IF EDITC C MOVES POINTER AHEAD DESIGNATED NO OF RECORDSC  CHARACTER*(*) A *CA PARAMA *CA EDITCO  LN=LEN(A) IF(LN.GT.1) THEN NP=RVAL(A(2:LN)) NP=MAX(1,NP)  ELSE NP=1  ENDIF C  DO 20 I=1,NP  CALL EDINEX(A)  IF(IREC.GE.NRECI) GOTO 30 IF(IREC.EQ.NRECI) GOTO 30 20 CONTINUE 30 CALL EDIPOS )*ENDIF  RETURN  END 00 EDIPOS 6/14/82a<.)  SUBROUTINE EDIPOS )*IF EDITC C PRINTS CURRENT RECORD TO TERMINAL C *CA PARAMA *CA EDITCO *CA DECA*CA MODNA  DIMENSION IRD(5) EQUIVALENCE(LNX,IRD(1)),(IDK,IRD(2)),(NSQ,IRD(3)),  1 (IDEL,IRD(4)),(NMR,IRD(5)) .*IF I4 INTEGER*4 IS.*ENDIF  CHARACTER*15 NAMSEQ  CHARACTER*8 DCK  C 10 CONTINUE IF(IREC.EQ.0) THEN  PRINT*,'[TOP]' < PRINT*,''  ELSE IF(IREC.EQ.NRECI) THEN  PRINT*,'[BOTTOM]' < PRINT*,'' ELSE  IDECP1=IR(IREC)  IF(IREC.LT.NRECI) THEN C OLD RECORD  CALL EXIN(IDECP1,IRD,5) a CALL EXIN(IDECP1,IRD(1),5) IF(IRD(4).GT.0) THEN  IF(IDEL.GT.0) THEN  IREC=N(IREC)  GOTO 10  ENDIF  IS=IDECP1+IRD(5)  IS=IDECP1+NMR  NC=(IRD(1)-5-IRD(5))*NCHRWD  NC=(LNX-5-NMR)*NCHRWD  IF(LSTSEQ) THEN  IF(IDK.EQ.0) THEN  DCK=EDECK  ELSE  DCK=MODNA(IDK)  ENDIF  CALL EDISID(DCK,NSQ,NAMSEQ) CALL EDIPRS(ADEC(IS),NC,NAMSEQ)  ELSE C NEW RECORD  CALL EDIPRI(ADEC(IS),NC)  ENDIF  ELSE  CALL EXIN(IDECP1,IRC,1)  IS=IDECP1  NC=IRC*NCHRWD  IF(LSTSEQ) THEN  NAMSEQ='--NEW--'  CALL EDIPRS(ADEC(IS),NC,NAMSEQ)  ELSE  CALL EDIPRI(ADEC(IS),NC)  ENDIF  ENDIF CALL EDIPRI(ADEC(IS),NC)  ENDIF )*ENDIF  RETURN  END X WRITE(LSO,111) DELREC . LAST=0 / ENDIF X LAST=40 WRITE(LSO,111)(ADEC(II),II=IDECP1,IDECP1+IRC)  WRITE(LSO,111)(ADEC(II),II=IDECP1,IDECP1+IEDIPRI 6/14/82R)  SUBROUTINE EDIPRI(A,N) )*IF EDITC C C PRINT ALFA PART OF RECORD ON TERMINAL C R*CA PARAMA  CHARACTER*120 A R CHARACTER*(MAXWID) AC  PRINT*,A(1:N) )*ENDIF RETURN  END  CHARACTER*(120)AR*CA WIDTH R CHARACTER*(MAXWID) A CHARACTER*8 NAMSEQ P CHARACTER*8 DCK  CHARACTER*120 DUMT R CHARACTER*(MAXWID) DUMT  DATA DUMT/' '/C  IF(ISETIF.EQ.0) THEN EDIPRS 6/23/82R<* SUBROUTINE EDIPRS(A,N,NAMSEQ) **IF EDITC C PRINT ALFA PART OF RECORD AND NAMSEQ ON TERMINALC R*CA PARAMA  CHARACTER*120 A R CHARACTER*(MAXWID) A  CHARACTER*(*)NAMSEQ C  DO 20 NCS=LEN(NAMSEQ),2,-1  IF(NAMSEQ(NCS:NCS).NE.' ') GOTO 30 20 CONTINUE 30 PRINT*,A(1:N)//'['//NAMSEQ(1:NCS)//']' <30 PRINT*,A(1:N)//'<'//NAMSEQ(1:NCS)//'>' **ENDIF RETURN  END D) DUMT  DATA DUMT/' '/C  IF(ISETIF.EQ.0) THEN EDIPRT 6/22/82*"  SUBROUTINE EDIPRT(A)**IF EDITC C PRINT RECORDS ON TERMINAL C  CHARACTER*(*) A *CA PARAMA *CA EDITCO  LN=LEN(A) IF(LN.GT.1) THEN NP=RVAL(A(2:LN))  ELSE NP=1 ENDIF  IRECC=IREC  CALL EDIPOS C  DO 20 I=2,NP  CALL EDINEX(A)  CALL EDIPOS  IF(IREC.GE.NRECI) GOTO 30" IF(IREC.EQ.NRECI) GOTO 30 20 CONTINUE 30 IREC=IRECC **ENDIF  RETURN  END EDIREC 6/14/82 4)  SUBROUTINE EDIREC )*IF EDITC C RECOVER FROM PREVIOUS ABORT C *CA PARAMA *CA BUFA*CA LOGU 4 CHARACTER*120 BUX C 10 CONTINUE READ(LBI,11,ERR=5000,END=5000) BUF 4 BUX=BUF(2:) 11 FORMAT(A) DO 20 IWID=120,1,-1  IF(BUF(IWID:IWID).NE.' ') GOTO 40 20 CONTINUE 30 IWID=0 40 CONTINUE CALL EDIDIR(IWID,J) C C T B F N P(.)A I D R C(S)  GOTO(100,200,300,400,500,600,700,800,900,1000, C - H E  1 1100,4000,5000),J  GOTO 10 C C T - TOP 100 CONTINUE CALL EDITOP(BUF(1:IWID))  GOTO 10 C C B - BOTTOM 200 CONTINUE CALL EDIBOT(BUF(1:IWID)) ! GOTO 10 "C #C F - FIND (') (") STRING SEARCH $300 CONTINUE % IF(IWID.LT.2) THEN & GOTO 10 ' ENDIF ( CALL EDIFIN(BUF(2:IWID),ICHP) 4 CALL EDIFIN(BUX(1:IWID-1),ICHP) ) CALL EDIPOS * GOTO 10 +C ,C N - NEXT (CR) -400 CONTINUE. CALL EDINEX(BUF(1:IWID))  CALL EDIPOS / GOTO 10 0C 1C P - PRINT (.) 2500 CONTINUE3 CALL EDIPOS(BUF(1:IWID)) 4 GOTO 10 5C 6C A - ADD TO END OF LINE 7600 CONTINUE8 CALL EDIADD(BUF(2:IWID))4 CALL EDIADD(BUX(1:IWID-1)) 9 GOTO 10 :C ;C I - INSERT NEW RECORD BEHIND CURRENT ONE <700 CONTINUE = IF(IWID.LT.2) THEN > GOTO 10 ? ENDIF @ CALL EDIINS(BUF(2:IWID)) 4 CALL EDIINS(BUX(1:IWID-1)) A CALL EDIPOS B GOTO 10 CC DC D - DELETE E800 CONTINUEF CALL EDIDEL(BUF(1:IWID)) G GOTO 10 HC IC R - REPLACE ENTIRE LINE J900 CONTINUE K IF(IWID.LT.2) THEN L GOTO 10 M ENDIF N CALL EDIREP(BUF(2:IWID))4 CALL EDIREP(BUX(1:IWID-1)) O GOTO 10 PC QC RC C - CHANGE (S) STRING SUBSTITUTION S1000 CONTINUE T IF(IWID.LT.4) THEN U GOTO 10 V ENDIF W CALL EDICHA(BUF(2:IWID))4 CALL EDICHA(BUX(1:IWID-1)) X GOTO 10 YC ZC - - MOVE POINTER UP [C \1100 CONTINUE] CALL EDIMIN(BUF(1:IWID))  CALL EDIPOS ^ GOTO 10 _C `C H - HELP a4000 CONTINUEb CALL EDIHEL(BUF(1:IWID)) c GOTO 10 dC eC END OF EDIT f5000 CONTINUE)*ENDIF g RETURN h END EDIREP 6/14/82)  SUBROUTINE EDIREP(A))*IF EDIT  CHARACTER*(*) A C C REPLACE RECORD (INSERT THEN DELETE) C *CA PARAMA *CA EDITCO *CA DECA C DIMENSION IRD(5) C C CHECK FOR LEGAL RECORD  C  IF(IREC.EQ.0.OR.IREC.EQ.NRECI) GOTO 1100  IF(IREC.LT.NRECI) THEN  DECP1=IR(IREC)  CALL EXIN(IDECP1,IRD,5)  IF(IRD(4).LT.0) GOTO 1200  ENDIF  IR(IREC)=-IR(IREC)  CALL EDIINS(A)  CALL EDIPOS C  RETURN C 1100 PRINT*,'CURRENT RECORD IS NOT A RECORD THAT CAN BE REPLACED'  RETURN C 1200 PRINT*,'CURRENT RECORD DELETED/INACTIVE RECORD-CANNOT REPLACE' )*ENDIF  RETURN  END EDIBOT(BUF(1:IWID)) ! GOTO 10 "C #C F - FIND (') (") STRING SEARCH EDISER 6/14/82R) SUBROUTINE EDISER(A,AA,N,ILO) )*IF EDIT  CHARACTER*(*)A  CHARACTER*120 AAC C SEARCH STRING AA(1:N) FOR A C R*CA PARAMA R CHARACTER*(*)A R CHARACTER*(MAXWID) AA  ILO=INDEX(AA(1:N),A))*ENDIF  RETURN  END CONTINUE 30 PRINT*,A(1:N)//'['//NAMSEQ(1:NCS)//']' <30 PRINT*,A(1:N)//'<'//NAMSEQ(1:NCS)//'>' **ENDIF RETURN  END D) DUMT  DATA DUMT/' '/C  IF(ISETIF.EQ.0) THEN EDISID 6/14/82R) SUBROUTINE EDISID(NAM,ISEQ,NAMSEQ) )*IF EDITC C CREATES NAME-SEQUENCE NO FOR USE AS FUTURE INPUT RECORD C  CHARACTER*15 NAMSEQ  CHARACTER*8 NAM  WRITE(NAMSEQ,11) NAM,ISEQ 11 FORMAT(A8,'.'I6)  N=1  DO 50 I=1,14  IF(NAMSEQ(N:N).EQ.' ')THEN   NAMSEQ(N:)=NAMSEQ(N+1:)//' '  ELSE  N=N+1  ENDIF 50 CONTINUE)*ENDIF  RETURN  END '/C  IF(ISETIF.EQ.0) THEN EDITOP 6/14/82)  SUBROUTINE EDITOP(A))*IF EDITC C SET POINTER TO TOP C  CHARACTER*(*) A *CA PARAMA *CA EDITCO  IREC=0 CALL EDIPOS )*ENDIF RETURN  END DO 50 I=EDITOR 6/14/82 XRDC>;4)"  SUBROUTINE EDITOR C SUBROUTINE EDITOR (RECOV) C LOGICAL RECOV )*IF EDITC C PROCESS ALL EDIT COMMANDS C *CA PARAMA *CA BUFA*CA LOGUC*CA EDIBKU 4 CHARACTER*120 BUX R CHARACTER*(MAXWID) BUX C C LBAKUF = .FALSE. CALL EDIPOS  C  10 CALL RDTERM(LTI,IWID) 4 BUX=BUF(2:)   CALL EDIDIR(IWID,J) C10 CONTINUE C IF(RECOV) THEN C READ(LBO,11,END=7040,ERR=7030) J,IWID,BUF(1:IWID)D READ(LBI,11,END=7040,ERR=7030) J,IWID,BUF(1:IWID) C11 FORMAT(I2,I3,A) C ELSE C IF(LBAKUF) THEN C WRITE(LBO,11) J,IWID,BUF(1:IWID) C ELSE C LBAKUF=.TRUE. C ENDIF C CALL RDTERM(LTI,IWID) C CALL EDIDIR(IWID,J) C ENDIF C BUX=BUF(2:)  C C T B F N P(.)A I D R C(S)  GOTO(100,200,300,400,500,600,700,800,900,1000, C - H E  1 1100,4000,5000),J  1 1100,4000,5000,1400),J  PRINT*,'INCORRECT INPUT TO SLIB77 EDITOR (H FOR HELP)' D LBAKUF=.FALSE.  GOTO 10 C C T - TOP 100 CONTINUE CALL EDITOP(BUF(1:IWID))  GOTO 10 C C B - BOTTOM 200 CONTINUE CALL EDIBOT(BUF(1:IWID))  GOTO 10 C C F - FIND (') (") STRING SEARCH 300 CONTINUE ! IF(IWID.LT.2) THEN " PRINT*,'NO TEXT TO FIND ENTER COMMAND AGAIN' X PRINT*,'No text string on FIND record command ignored' C LBAKUF=.FALSE. # GOTO 10 $ ENDIF X ELSE% CALL EDIFIN(BUF(2:IWID),ICHP)  CALL EDIFIN(BUF(2:IWID))4 CALL EDIFIN(BUX(1:IWID-1)) & CALL EDIPOS X CALL EDIFIN(BUX(1:IWID-1)) X CALL EDIPOS X ENDIF ' GOTO 10 (C )C N - NEXT (CR) *400 CONTINUE+ CALL EDINEX(BUF(1:IWID))  CALL EDIPOS , GOTO 10 -C .C P - PRINT (.) /500 CONTINUE 0 CALL EDIPOS  CALL EDIPRT(BUF(1:IWID)) 1 GOTO 10 2C 3C A - ADD TO END OF LINE 4600 CONTINUE X IF(IWID.LT.2) THEN X PRINT*,'No text to add on ADD record - command ignored' X LBAKUF=.FALSE. X ELSE5 CALL EDIADD(BUF(2:IWID))4 CALL EDIADD(BUX(1:IWID-1)) X CALL EDIADD(BUX(1:IWID-1)) X ENDIF 6 GOTO 10 7C 8C I - INSERT NEW RECORD BEHIND CURRENT ONE 9700 CONTINUE : IF(IWID.LT.2) THEN " PRINT*,'No text on insert-enter records CR to end insert' "710 CALL RDTERM(LTI,IWID)" IF(IWID.LE.0) GOTO 10; IF(IWID.LE.0) GOTO 720 ; IF(IWID.EQ.1.AND.BUF(1:1).EQ.'#') THEN ; IWID=NCHRWD ; BUF(1:NCHRWD)=' ' ; ENDIFC IF(LBAKUF) WRITE(LBO,11) J,IWID+1,'I'//BUF(1:79)" CALL EDIINS(BUF(1:IWID)) D IF(LBAKUF) WRITE(LBO,11) J,IWID+1,'I'//BUF(1:IWID) " CALL EDIPOS ; PRINT*,'NO TEXT TO FIND ENTER COMMAND AGAIN' < GOTO 10 " GOTO 710 = ENDIF ; IF(IWID.EQ.2.AND.BUF(2:2).EQ.'#') THEN ; IWID=NCHRWD+1 ; BUX(2:IWID-1)=' ' ; ENDIF > CALL EDIINS(BUF(2:IWID)) 4 CALL EDIINS(BUX(1:IWID-1)) ? CALL EDIPOS @ GOTO 10 ; C ; 720 CONTINUE ; PRINT*,'End INSERT' ; CALL EDIPOS C LBAKUF=.FALSE. ; GOTO 10 AC BC D - DELETE C800 CONTINUED CALL EDIDEL(BUF(1:IWID)) E GOTO 10 FC GC R - REPLACE ENTIRE LINE H900 CONTINUE I IF(IWID.LT.2) THEN J PRINT*,'NO TEXT TO REPLACE RECORD WITH ENTER COMMAND AGAIN' C LBAKUF=.FALSE. K GOTO 10 L ENDIF M CALL EDIREP(BUF(2:IWID))4 CALL EDIREP(BUX(1:IWID-1)) N GOTO 10 OC PC QC C - CHANGE (S) STRING SUBSTITUTION R1000 CONTINUE S IF(IWID.LT.4) THEN > IF(IWID.LT.5) THEN T PRINT*,'SUBSTITUTE STRING NOT LONG ENOUGH TO HAVE DELIMITERS'U PRINT*,'RE-ENTER COMMAND' C LBAKUF=.FALSE. V GOTO 10 W ENDIF X CALL EDICHA(BUF(2:IWID))4 CALL EDICHA(BUX(1:IWID-1)) Y GOTO 10 ZC [C - - MOVE POINTER UP \C ]1100 CONTINUE^ CALL EDIMIN(BUF(1:IWID))  CALL EDIPOS _ GOTO 10 C C + - PLUS (SET POINTER AHEAD N) C 1400 CONTINUE  CALL EDIPLS(BUF(1:IWID))  GOTO 10 `C aC H - HELP b4000 CONTINUE C LBAKUF=.FALSE. c CALL EDIHEL(BUF(1:IWID)) ; PRINT*,'End of HELP' ; CALL EDIPOS d GOTO 10 eC fC END OF EDIT g5000 CONTINUEh CALL EDIEND(BUF(1:IWID)) C RETURN CC CC ERROR IN BACKUP FILE C7030 PRINT*,'Error while reading backup file will stop reading' CC CC End of BACKUP file CC C 7040 PRINT*,'End of backup file' )*ENDIF i RETURN j END T1,' U E ',CONTO(1:LCONTO),' continuation' @] PRINT1,' T S ',FI17,' backup'G EDIVMD 6/14/82XR)$ SUBROUTINE EDIVMD(A,NCHRS) )*IF VAX  CHARACTER*120 A,B C THIS PROGRAM TURNS TABS INTO PROPER C NUMBER OF TABS C AND REPLACES CONTINUATION TAB/NU INTO COLUMN 6 NUMBER C *CA PARAMA R*CA WIDTH R CHARACTER*(MAXWID) A,B C ON THE VAX A TAB IS A 9  C AND AN APSOTROPHE IS A 39  C WHEN USING ICHAR AND CHAR  C DATA IPOS,ITAB /39,9/  C *IF VAX  B(1:NCHRS)=A(1:NCHRS) C ELIMINATES TABS C  J=1  N=0  M=NCHRS C THE FOLLOWING IS A CHECK FOR 'TAB'  IF(ICHAR(B(1:1)).EQ.ITAB.AND.  1 INDEX('123456789',B(2:2)).NE.0) THEN  A(1:9)=' '//B(2:2)//' ' $ A(1:8)=' '//B(2:2)//' '  N=9 $ N=8  J=3  ENDIF  DO 300 I=J,M IF(ICHAR(B(I:I)).EQ.ITAB) THEN 200 IF(N.GE.MAXWID) GOTO 260 R200 IF(N.GE.MWIDE) GOTO 260  N=N+1 X200 N=N+1 A(N:N)=' '! IF(MOD(N,8).NE.0) GOTO 200 " ELSE # IF(N.GE.MAXWID) THEN R IF(N.GE.MWIDE) THEN X IF(N.GE.MWIDE.AND.B(I:I).NE.' ') THEN $260 PRINT*,'VAX RECORD TOO LONG' % PRINT*,B & GOTO 310 ' ENDIF ( N=N+1 ) A(N:N)=B(I:I) * ENDIF + 300 CONTINUE ,310 CONTINUE- NCHRS=((N+NCHRWD-1)*NCHRWD)/NCHRWD . A(N+1:NCHRS)=' ' /C 0*ENDIF 1 RETURN 2 END o text string on FIND record command ignored' C LBAKUF=.FALSE. # GOTO 10 $ ENDIF X ELSE% CALL EDIFIN(BUF(2:IWID),EXAL 3/22/82. SUBROUTINE EXAL(A1,N1,A2) .*IF I4  INTEGER*4 N1.*ENDIF C C EXTRACTS CHARACTER DATA FROM DECK C *CA PARAMA C  CHARACTER*8 A1,A2 C A2=A1 N1=N1+NW8C RETURN  END INTEGER*4 IS.*ENDIF  CHARACTER*15 NAMSEQ  CHARACTER*8 DCK  C 10 CONTINUE IF(IREC.EQ.0) THEN PRINT*,'[TOP]'  ELSE IF(IREC.EQ.NRECI) THEN  PRINT*,'[BOTTOM]' ELSEEXIN 3/22/82.  SUBROUTINE EXIN(IP,IA,N)  DIMENSION IA(N) .*IF I4  INTEGER*4 IP.*ENDIF C C EXTRACTS INTEGER DATA FROM DECK C *CA PARAMA *CA DECI  DO 100 I=1,N IA(I)=IDEC(IP) IP=IP+1 100 CONTINUE RETURN  END *ENDIF  CHARACTER*15 NAMSEQ  CHARACTER*8 DCK  C 10 CONTINUE IF(IREC.EQ.0) THEN PRINT*,'[TOP]'  ELSE IF(IREC.EQ.NRECI) THEN  PRINT*,'[BOTTOM]' ELSEGETBUF 3/22/82R&  SUBROUTINE GETBUF(IN,IL)C C READS INPUT RECORD (IN) FROM SCRATCH FILE (LSI) C INTO BUF AND RETURNS LENGTH (WORDS) IN (IL) C *CA PARAMA *CA BUFA *CA LOGU R*CA WIDTH  C   READ(LSI'IN) BUF(1:MAXWID) & READ(LSI,REC=IN) BUF(1:MAXWID) R READ(LSI,REC=IN) BUF(1:MWIDE)  C   DO 100 I =( MAXWID+NCHRWD-1)/NCHRWD,2,-1R DO 100 I = ( MWIDE+NCHRWD-1)/NCHRWD,2,-1 IF(BUF4(I) .NE. ' ') GOTO 200  100 CONTINUEC  I = 1 200 IL=I*NCHRWD  RETURN  END C THE FOLLOWING IS A CHECK FOR 'TAB'  IF(ICHAR(B(1:1)).EQ.ITAB.AND.  1 INDEX('123456789',B(2:2)).NE.0) THEN  A(1:9)=' '//B(2:2)//' ' $ A(1:8)=' '//B(2:2)//' '  N=9 $ N=8  J=3  ENDIF GTFWD 3/22/82C  SUBROUTINE GTFWD(A,IN)  CHARACTER*(*) A  CHARACTER*(*) AA(20)  CHARACTER*20 AA(20)  CHARACTER*8 AA(20) C C C GETS 1ST WORD FROM DIRECTORY RECORD IN C C RETURNS IN A RETURNS ' ' IF NO WORDS C *CA PARAMA *CA INREC *CA BUFA  C  CHARACTER*20 WORD(40) C*CALL SCAN C  IDL=INLOC(IN)  CALL GETBUF(IDL,IL)  CALL SCAN2(BUF(2:IL*NCHRWD), WORD, NWRDS)  IF(NWRDS.GT.1 ) THEN  A=WORD(2) C CALL SCAN2(BUF(1:IL)) C IF(NWRD.GT.1) THEN C A=BUF(ISS(2):ISS(2)+ISL(2)-1) ELSE  A=' '  ENDIF  RETURN C C C  ENTRY GTAWD (AA,NW,IN) C C GETS ALL THE WORDS ON DIRECTIVE RECORD IN C IDL=INLOC(IN) ! CALL GETBUF(IDL,IL) " CALL SCAN2(BUF(2:IL*NCHRWD), WORD, NWRDS) # NW=NWRDS $ DO 100 I=1,NWRDS %100 AA(I)=WORD(I) C CALL SCAN2(BUF(1:IL)) C IF (NWRD.GT.0) THEN C AA(1)=BUF(ISS(1)+1:ISS(1)+ISL(1)-1) C DO 100 I=2,NWRD C AA(I)=BUF(ISS(I):ISS(I)+ISL(I)-1) C 100 CONTINUE C ENDIF C NW=NWRD & RETURN ' END C F - FIND (') (") STRING SEARCH 300 CONTINUE ! IF(IWID.LT.2) THEN " PRINT*,'NO TEXT TO FIND ENTER COMMAND AGAHEADER 3/22/82bZ  SUBROUTINE HEADER (A) C C SETS UP AND WRITES HEADER FOR PROGRAM C  CHARACTER*(*) A C *CA PARAMA *CA LOGU *CA DATE  *CA IVERS  C CHARACTER*132 HDR DATA HDR /' '/  DATA LINNO /1/  DATA IPAG /1/ C  HDR(2:60)=A  HDR(65:72)=DATE  HDR(78:85)=TIMDAY  HDR(90:105)='SLIB77 VERSION ' b HDR(80:95)='SLIB77 Version ' WRITE(HDR(106:110),111)IVERSb WRITE(HDR(96:100),111)IVERS b HDR(101:110) = '-'//LSTMOD  HDR(125:128)= 'PAGE'100 WRITE(HDR(129:),111) IPAG 111 FORMAT(I4)  IPAG=IPAG+1  WRITE(LOU,21) HDR 21 FORMAT('1',A)  WRITE(LOU,31) 31 FORMAT(' ')  LINNO=1  RETURN  C !C " ENTRY LININC(I) #C $ LINNO=LINNO+I % IF(LINNO.GT.55) GOTO 100 & RETURN ZC ZC Z ENTRY SUBHED(I)Z IF((LINNO + I) .GT. 55) GOTO 100 Z RETURN ' END ('NnYy',ANS(1:1)) % IF( IANS .GE. 3 ICKDIC 3/22/82A( FUNCTION ICKDIC(WORD,DICT,LD)C C This FUNCTION checks for the location of a STRING in "WORD" C in "WORD" in a dictionary array "DICT" of LD entries. C C The number of characters in "WORD" are matched against a like C number of characters in each "DICT" entry. C  C The position of "WORD" in "DICT" is returned when it is found,  C ELSE a zero is return when it is not found.  C  C CHARACTER*10 WORD, DICT  DIMENSION DICT(LD) C C ******************* C ******************* C C FIND THE NUM OF CHARACTERS IN WORD C  NCHR = 0C  10 NCHR = NCHR + 1  IF( NCHR.LE.10 .AND. WORD(NCHR:NCHR).NE.' ' ) GOTO 10 A IF(NCHR.LE.10) THEN A IF (WORD(NCHR:NCHR).NE.' ') GOTO 10 A ENDIF C  NCHR = NCHR - 1 ( IF(NCHR.LE.0) GOTO 150 C  DO 100 I = 1,LD  NC=INDEX(DICT(I),'*') - 1 IF(NC.LE.0.OR.NC.GT.NCHR) NC=NCHR IF(WORD(:NC).EQ.DICT(I)(:NC) ) GOTO 200 100 CONTINUE !C NOT FOUND " ICKDIC = 0 (150 ICKDIC=0 # GOTO 300 $C FOUND % 200 ICKDIC = I &C ' 300 RETURN (C ) END IFINDK 3/22/82c  FUNCTION IFINDK(A)  CHARACTER*8 A C C FIND DECK A IN DECKSC *CA PARAMA *CA DECKS C c CHARACTER*8 B cC DO 100 I=1,NDCKS IF(A.EQ.DECK(I)) GOTO 200 100 CONTINUEcC c CALL UCASE(A,B) cC c DO 110 I=1,NDCKSc IF(B.EQ.DECK(I)) GOTO 200 c110 CONTINUE IFINDK=0 RETURN C 200 IF(IPURGE(I).NE.0) I=-I  IFINDK=I  RETURN  END PT 11,OPLFIL IFINMD 3/22/82  FUNCTION IFINMD(A)  CHARACTER*8 A C C FIND MOD NAME IN MODNA TABLES C *CA PARAMA *CA MODNA C DO 100 I=1,NMODS IF(A.EQ.MODNA(I)) GOTO 200 100 CONTINUE I=0 200 IFINMD=I  RETURN  END  IFINDK=I  RETURN  END CHARACTER*10 WORD, DICT  DIMENSION DICT(LD) C C ******************* C ******************* C C FIND THE NUM OF CHARACTERS IN WORD INAL 3/22/82 SUBROUTINE INAL(A1,N1,A2) C C ADDS CHARACTER DATA TO DECK C *CA PARAMA C  CHARACTER*8 A1,A2 C A1=A2 N1=N1+NW8C RETURN  END  I=0 INCHW 6/14/82R SUBROUTINE INCHW(A1,A2,NC)  CHARACTER*120 A1,A2 C C ADD CHARACTER DATA TO DECK - NC CHARACTERS C USED IN EDIT MODE C R*CA PARAMA R CHARACTER*(MAXWID) A1,A2RC  A2(1:NC)=A1(1:NC)  RETURN  END READ(LSI,REC=IN) BUF(1:MAXWID) R READ(LSI,REC=IN) BUF(1:MWIDE)  C   DO 100 I =( MAXWID+NCHRWD-1)/NCHRWD,2,-1R DO 100 I = ( MWIDE+NCHRWD-1)/NCHRWD,2,-1 IF(BUF4(I) .NE. ' ') GOTO 200  100 CONTINUEC  I = 1 200 IL=I*NCHRWD  RETURN ININ 3/22/82.  SUBROUTINE ININ(IP,IA,N)  DIMENSION IA(N) .*IF I4 . INTEGER*4 IP.*ENDIF C C ADDS INTEGER DATA TO DECK C *CA PARAMA *CA DECI  DO 100 I=1,N IDEC(IP)=IA(I) IP=IP+1 100 CONTINUE RETURN  END END *ENDIF  CHARACTER*15 NAMSEQ  CHARACTER*8 DCK  C 10 CONTINUE IF(IREC.EQ.0) THEN PRINT*,'[TOP]'  ELSE IF(IREC.EQ.NRECI) THEN  PRINT*,'[BOTTOM]' ELSEINITL 3/22/82fdcbRJC?8'   SUBROUTINE INITLC C INITIALIZES PROGRAM C *CA PARAMA *CA PARAMB?*CA DECKS *CA LIMITS *CA DATE *CA LOGU *CA INREC *CA DIRSTA *CA MODNA *CA PRFX *CA IFSWI *CA CONTRL *CA MODCOM*CA DECA*CA IVERS C C VERSION OF PROGRAM C *CA DIRDIC R*CA SEQCTL R*CA WIDTH d*CA LANGC *CA DIRSTA f*CA BUFAf*CA INPERC C d LANG = 0 d LANGNM(1)='Fortran ' d LANGNM(2)='Cobol 'dC  IVERS=2 R IVERS = 3 b LSTMOD='MOD46 ' c CALL VERSN RC R MWIDE = 0 RC R LSEQC = 1 f INRCN=0 fC f INERRF=0fC d*IF -IBM d LSEQC=1 d*ENDIF d *IF IBM d LSEQC=2 d *ENDIF  CALL XDATE(DATE)  CALL TIME (TIMDAY) ' TIMDAY=' '  PRFX = '*'  LIN = 51  LOP = 31  LSO = 12  LOU = 13 LCO = 14 ! LNP = 11 " LSR = 50 # LSI = 49 $ LIA = 15 % LOA = 16  LBO=17  LBI=18 *IF TERM5  LTI=5 f LTO=6 *ENDIF *IF TERM1  LTI=1 f LTO=1 *ENDIF  LDO=19  LDI=20 & LOCLNP=1 ' LOCLSR=1 ( CALL OPNSPL (LSR) ) NIN = 0 * NDIR=0 + NDITOT = 0 , DO 100 I = 1,LDIR 8 DO 100 I = 1,MAXDIR -100 NODIR(I) = 0 ? NDCKS = 0 . NMODS = 0 / NMODOP = 0 0 NSWS = 0 1 ISDEC(1)=1 2 ISDEC(2)=MAXWRD/2+1 3 IDECP1=1 4 IDECP2=ISDEC(2) 5 ISETIF = 0 6C 7 LCHRWD = NCHRWD 8 LWRDBK = NWRDBK 9 LIMWID = MAXWID : LIMDCK = MAXDCK ; LIMWRD = MAXWRD < LIMMNA = MAXMNA = LIMMDK = MAMMDK J LIMMDK = MAXMDK > LIMMDD = MAXMDD ? LIMSWI = MAXSWI @ LIMDRR = MAXDRR A LIMDIR = MAXDIR B ICF=.FALSE. C ICQ=.FALSE. D ICLO=.FALSE. E ICC=.TRUE. F ICL=.TRUE. G ICS=.FALSE. H ICN=.FALSE. I ICNA=.FALSE. J ICP=.TRUE. K ICPA=.FALSE. L LSTA=.FALSE. M LSTC=.FALSE. N LSTE=.TRUE. O LSTI=.FALSE. P LSTM=.TRUE. Q LSTS=.FALSE.  LSTS=.TRUE. R LSTT=.FALSE. S LSTD=.TRUE. T NMODC=0 U DIRDIS(1)='A' V DIRDIS(2)='AC' W DIRDIS(3)='CA' X DIRDIS(4)='C' Y DIRDIS(5)='DK' Z DIRDIS(6)='DF' [ DIRDIS(7)='D' \ DIRDIS(8)='E' ] DIRDIS(9)='EI' ^ DIRDIS(10)='ID' _ DIRDIS(11)='IF' ` DIRDIS(12)='I' a DIRDIS(13)='M' b DIRDIS(14)='R' c DIRDIS(15)='RD' d DIRDIS(16)='PU' e DIRDIS(17)='UP' f DIRDIS(18)='Y'  DIRDIS(19)='RN' g DIRDIL(1)='ADDDECK' h DIRDIL(2)='ADDCOMD' i DIRDIL(3)='CALL' j DIRDIL(4)='COMPILE' k DIRDIL(5)='DECK' l DIRDIL(6)='DEFINE' m DIRDIL(7)='DELETE' n DIRDIL(8)='EDIT' o DIRDIL(9)='ENDIF' p DIRDIL(10)='IDENT' q DIRDIL(11)='IF' r DIRDIL(12)='INSERT' s DIRDIL(13)='MOVE' t DIRDIL(14)='RESTORE' u DIRDIL(15)='READ' v DIRDIL(16)='PURGE' w DIRDIL(17)='UPDATE' x DIRDIL(18)='YANK'  DIRDIL(19)='RENAME' C DO 400 I=1,MAXDIR C IL=INDEX(DIRDIL(I),' ')-1C IF(IL.EQ.0.OR.IL.GT.10) THEN C PRINT*,'ERROR IN INITL WORKING ON DICTIONARY' C STOP 'ERROR IN INITL' C ENDIF C IDIRL(I)=IL C400 CONTINUE y RETURN z END F IF(NWRD.GT.NS+1.AND.WORD(INP 3/22/82 fZRQH!  SUBROUTINE INP C C READS ALL INPUT CARDS WRITE THEM ON SCRATCH FILE C C PUTS SOME DIRECTIVES INTO INTYP INLOC ARAYS C PUTS TYPE OF DIRECTIVE INTO INTYP C NIN - NUMBER OF CARDS READ C NDIR - NUMBER OF DIRECTIVES IN ARAYS C *CA PARAMA *CA BUFA *CA INREC *CA LOGU *CA DIRDIC *CA DIRSTA *CA CONTRLR*CA WIDTH f*CA INPERC C  CALL OPNLSI(LSI)C  NC=0ZC Z IF(LSTT) THEN Z WRITE(LOU,90)Z 90 FORMAT(/,' Input Text Listing:') Z CALL LININC(2) Z ENDIF  CALL CTLCRD C C READ IN A CARD C  100 CALL RDINP(LIN,ITP,IWID) IF(ITP .GT. 100) GOTO 9000  IF(ITP.GT.0) THEN  NODIR(ITP)=NODIR(ITP)+1  ENDIF H110 IF(ITP.GT.100) GOTO 9000  IF(ITP.EQ.15) GOTO 1500 C C NIN = NIN + 1 ! WRITE(LSI'NIN) BUF  WRITE(LSI,REC=NIN) BUF  WRITE(LSI,REC=NIN)BUF4 R WRITE(LSI,REC=NIN)BUF(1:MWIDE) "C #C $C YANK/UNYANK %C & IF(ITP .EQ. 17 .OR. ITP .EQ. 18) THEN ' PRINT *,' **** ERROR **** YANK/UNYANK NOT YET IMPLEMENTED' ( GOTO 100 ) ENDIF * IF(ITP .EQ. 0 .OR. ITP .EQ. 3 .OR. + 1 ITP .EQ. 9 .OR. ITP .EQ. 11) GOTO 200 , NDIR = NDIR + 1 -C . INLOC(NDIR) = NIN / INTYP(NDIR) = ITP 0C 1200 CONTINUE 2 NC=NC+1 3 IF(LSTT) THEN 4 WRITE(LOU,211) NC,BUF(1:IWID)f WRITE(LOU,211) INRCN,BUF(1:IWID) 5211 FORMAT(1X,I7,1X,A) 6 CALL LININC(1) 7 ENDIF H IF(ITP.EQ.1.OR.ITP.EQ.2) THEN HC HC *ADDDECK - *COMDECK HC H WRITE(LOU,311) BUF(1:IWID) Q CALL LININC(1) H PRINT 311,BUF(1:IWID)H311 FORMAT(' Pre-processing ',A) H CALL INPADD(ITP,IWID) H GOTO 110 H ENDIF 8 GOTO 1009C :C $READ DIRECTIVE ;C <1500 CALL NXUNIN(BUF,LIN) = IF(LSTT) THEN > WRITE(LOU,1511) BUF(1:IWID) ?1511 FORMAT(1X,' ---- ',A) @ CALL LININC(1) f PRINT 1511, BUF(1:IWID) f1511 FORMAT(' begin reading ',A) A ENDIF B GOTO 100 C9000 CONTINUE D IF(LIN.GT.51) THEN E LIN=LIN-1 F GOTO 100 G ENDIF H INLOC(NDIR+1)=NIN+1 I CALL STATIS(7,NDIR) f IF(INERRF.GT.0) THENf WRITE(LOU,9011) INERRF f CALL LININC(1) f PRINT 9011, INERRF f 9011 FORMAT(' There were ',I5,' input errors run will', f 1 ' be terminated.') f STOP 'input errors' f ENDIF J RETURN K END IS(3)='CA' X DIRDIS(4)='C' Y DIRDIS(5)='DK' ZINPADD 11/22/82 faR SUBROUTINE INPADD(ITP,IWID) C C Process add directives and records in deck - C Puts deck in library format on scratch fileC *CA PARAMA *CA INREC *CA DECKS  *CA LOGU *CA DECA *CA BUFA *CA DATER*CA WIDTH f*CA CONTRL CHARACTER*8 DCKNAM  CHARACTER*(MAXWID) DUMREC C  DIMENSION IRC(5)  DIMENSION IDM(2)  DATA DCKNAM /'NEW DECK'/ DATA DUMREC /' '/  DATA IRC /5*0/ C *IF I4  INTEGER*4 ISL *ENDIF C C  IDECP1=1 CALL INAL(ADEC(IDECP1),IDECP1,DCKNAM)  CALL INAL(ADEC(IDECP1),IDECP1,DATE)  ISL=IDECP1  IDECP1=IDECP1+2 NSEQ=1 !C "C Sequence number for new record #C $C %200 CONTINUE & CALL RDINP(LIN,ITP,IWID)' IF(ITP.EQ.0.OR.ITP.EQ.3.OR.ITP.EQ.9.OR.ITP.EQ.11) THEN (C )C Record gets added to deck *C + NW=(IWID+NCHRWD-1)/NCHRWD , IRC(1)=5+NW - IRC(3)=NSEQ . CALL ININ(IDECP1,IRC,5) a CALL ININ(IDECP1,IRC(1),5) / DO 300 I=1,NW0 ADEC(IDECP1)=BUF4(I) 1 IDECP1=IDECP1+1 2300 CONTINUE 3 NSEQ=NSEQ+1 4 GOTO 200 5C 6 ELSE IF (ITP.EQ.15) THEN7C 8C *READ DIRECTIVE 9C : CALL NXUNIN(BUF,LIN) ; WRITE(LOU,1511) BUF(1:IWID) <1511 FORMAT(1X,' ---- ',A) = CALL LININC(1) > GOTO 200 f PRINT 1511,BUF(1:IWID) f1511 FORMAT(' begin reading ',A) f ELSE f GOTO 500 ? ENDIF f IF(LSTT) THEN f WRITE(LOU,311) INRCN,BUF(1:IWID) f311 FORMAT(1X,I7,1X,A) f CALL LININC(1) f ENDIF f GOTO 200@C AC NO MORE RECORDS FOR THIS DECK BC CC D500 CONTINUE E CALL ININ(IDECP1,0,1) F NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBKG CALL STATIS(2,NBLKS*NWRDBK) H IDM(1)=NBLKS I IDM(2)=0 J CALL ININ(ISL,IDM,2) a CALL ININ(ISL,IDM(1),2) K LOCDCK=LOCLSR L CALL WRDK(LSR,LOCLSR,1,NBLKS) MC NC Save the start location and the number of blocks for PADD OC P WRITE(DUMREC,511) LOCDCK,NBLKS Q511 FORMAT(2I13) R NIN=NIN+1 S WRITE(LSI,REC=NIN) DUMREC R WRITE(LSI,REC=NIN) DUMREC(1:MWIDE) TC U RETURN V END F H INLOC(NDIR+1)=NIN+1 I CALL STATIS(7,NDIR) f IF(INERRF.GT.0) THENf WRITE(LOU,9011) INERRF INSCOM 3/22/82da.-  SUBROUTINE INSCOM(NDCK) C C INSERTS COMMON DECK INTO COMPILE FILE C *CA PARAMA*CA DECA *CA DECKS *CA LOGU *CA MODNA *CA IFSWI *CA CONTRL  C CHARACTER*8 DCK CHARACTER*8 NAM,DATD  DIMENSION IDD(5) EQUIVALENCE(LNX,IDD(1)),(IDK,IDD(2)),(ISQ,IDD(3))  1 ,(IDEL,IDD(4)),(NMR,IDD(5)) C .*IF I4  INTEGER*4 ILX .*ENDIF C dC dC IL- Logical array for LISCRD to turn on compile only dC d LOGICAL IL(3) d DATA IL /.FALSE. , .TRUE. , .FALSE./dC IAC = 1 (Indicates active record - for LISCRD d DATA IAC /1/dC  CALL RDDK(2,NDCK)  IDECP2=ISDEC(2) C  CALL EXAL(ADEC(IDECP2),IDECP2,NAM)  CALL EXAL(ADEC(IDECP2),IDECP2,DATD)  IDECP2=IDECP2+1  CALL EXIN(IDECP2,NMD,1)  IDECP2=IDECP2+NMD 100 CONTINUE  ILX=IDECP2  CALL EXIN(IDECP2,IDD,5) a CALL EXIN(IDECP2,IDD(1),5)  IF(LNX.EQ.0) GOTO 9000  IF(IDEL.NE.0) GOTO 800 IDECP2=IDECP2+NMR ! LENA=(ILX+LNX-IDECP2)*NCHRWD" CALL COMCHC(ADEC(IDECP2),LENA,ICOM) - CALL COMCHC(ADEC(IDECP2),LENA,ITD) # IF(ICOM.EQ.0.AND.ISETIF.NE.0) GOTO 800  IF((.NOT. ICC) .OR. ISETIF .NE. 0) GOTO 800 -C INSURE THAT *IF AND *ENDIF GET WRITTEN ON COMPILE FILE - IF((ICC).AND.(ISETIF.EQ.0.OR.(ITD.EQ.9.OR.ITD.EQ.11))) THEN $ IF(IDK.EQ.0) THEN % DCK=NAM & ELSE ' DCK=MODNA(IDK) ( ENDIF) CALL LISCOM(ADEC(IDECP2),LENA,DCK,ISQ) d CALL LISCRD(ITD,IL,IAC,DCK,ISQ,ADEC(IDECP2),LENA) - ENDIF *800 CONTINUE + IDECP2=ILX+LNX , GOTO 100 -9000 CONTINUE-C -C ADD DUMMY RECORD TO SHOW END OF CALL -C - IF(ICC.AND.(ISETIF.EQ.0)) THEN -  CALL LISCOM('*END '//NAM,14,'........',0) d CALL LISCRD(1,IL,IAC,'........',0,'*END '//NAM,14) - ENDIF . RETURN / END LIMMNA = MAXMNA =KOMDEC 3/22/82R  FUNCTION KOMDEC(I,J)C C SORT DECK CARD ARAYSC R INTEGER SWADEC *CA PARAMA *CA INISO C  KOMDEC=INIDK(I)-INIDK(J) RETURN  C  C  ENTRY SWADEC(I,J)  C  L=INIDK(I)  INIDK(I)=INIDK(J)  INIDK(J)=L  L=INICD(I)  INICD(I)=INICD(J)  INICD(J)=L  RETURN  END IRC /5*0/ C *IF I4  INTEGER*4 ISL *ENDIF KOMMOD 3/22/82R  FUNCTION KOMMOD (I,J) C C SORT MODS FOR 1 DECKC R INTEGER SWAMOD *CA PARAMA *CA MODKEYC  KOMMOD=MODRC1(I)-MODRC1(J) RETURN  C  C  ENTRY SWAMOD (I,J)  C  L=MODIN(I)  MODIN(I)=MODIN(J)  MODIN(J)=L C  L=MODRC1(I)  MODRC1(I)=MODRC1(J)  MODRC1(J)=L C  L=MODRC2(I)  MODRC2(I)=MODRC2(J)  MODRC2(J)=L C  RETURN  END  CALL INAL(ADEC(IDECP1),IDECP1,DCKNAM)  CALL INAL(ADEC(IDECP1),IDECP1,DATE)  ISL=IDECP1  IDECP1=IDECP1+2 NSEQ=1 !C "C Sequence number for new record #C $C %200 CONTINUE &KOMYAN 3/17/83  FUNCTION KOMYAN(I,J)  INTEGER SWAYAN C C Sort yank records C *CA PARAMA *CA DECI*CA YANDEC  KOMYAN=YANMOD(I)-YANMOD(J) IF(KOMYAN.NE.0) RETURN  KOMYAN=YANDCK(I)-YANDCK(J) RETURN  C C  ENTRY SWAYAN(I,J) C  L=YANMOD(I)  YANMOD(I)=YANMOD(J)  YANMOD(J)=L  L=YANDCK(I)  YANDCK(I)=YANDCK(J)  YANDCK(J)=L  L=YANRES(I)  YANRES(I)=YANRES(J)  YANRES(J)=L  L=YANREE(I)  YANREE(I)=YANREE(J)  YANREE(J)=L  RETURN  END IF(IMOD.GT.0) GOTO 80 !C "10 PRINT 11,IDENT #11 FORMAT(' YANK directive ident ',A,' not found directive ignored') $ WRITE(LOU,11) IDENT % LISCOM 3/22/82RP= SUBROUTINE LISCOM(A,LENA,DCK,NSQ) C C WRITES COMMON DECK RECORDS ON COMPILE FILE C *CA PARAMA *CA LOGUR*CA SEQCTL R*CA WIDTH C  CHARACTER*8 DCK CHARACTER*(132) A  CHARACTER*8 NAMSEQ  C CHARACTER*132 DUMT  C  DATA DUMT /' '/ C  LENDU=MAXWID-LENA+1  WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),DCK,NSQ 121 FORMAT(A,A,A8,I5)  LENDU = MAXWID - LENA C P*IF COMPS  CALL COMPID(DCK,NSQ,NAMSEQ)  WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),NAMSEQ = IF(LENDU.GT.0) THEN = WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),NAMSEQ = ELSE= WRITE(LCO,121) A(1:LENA),NAMSEQ P121 FORMAT(3A) = ENDIF  121 FORMAT(A,A,A8) P*ENDIF P*IF -COMPS P IF(LENDU.GT.0) THEN P WRITE(LCO,119) A(1:LENA),DUMT(1:LENDU),DCK,NSQP119 FORMAT(3A,1X,I4) P ELSE P  WRITE(LCO,121) A(1:LENA),DCK,NSQ P 121 FORMAT(2A,1X,I4) P  ENDIFP *ENDIF R IF(LSEQC.EQ.1) THEN R LENDU = MWIDE-LENA R IF(LENDU.GT.0) THEN R WRITE(LCO,115) A(1:LENA),DUMT(1:LENDU),DCK,NSQ R115 FORMAT(3A,1X,I4) R ELSE R WRITE(LCO,117) A(1:LENA),DCK,NSQ R 117 FORMAT(2A,1X,I4) R ENDIFR C R ELSE IF(LSEQC.EQ.2) THENR CALL COMPID(DCK,NSQ,NAMSEQ) R LENDU = MWIDE-LENA R IF(LENDU.GT.0) THEN R WRITE(LCO,119) A(1:LENA),DUMT(1:LENDU),NAMSEQ R119 FORMAT(3A) R ELSE R WRITE(LCO,119) A(1:LENA),NAMSEQ R ENDIFR ELSER WRITE(LCO,119) A(1:LENA) R ENDIF C  RETURN  END CALL WRDK(LSR,LOCLSR,1,NBLKS) MC NC Save the start location and the number of blocks for PADD OC P WRITE(DUMREC,511) LOCDCK,NBLKS Q511 FORMAT(2I13) R NIN=NIN+1 S WRITE(LSI,REC=NILISCRD 3/22/82edRP=/ SUBROUTINE LISCRD(IL,IT,DCK,NSQ,A,LENA) d SUBROUTINE LISCRD(ITDIR,IL,IT,DCK,NSQ,A,LENA) C C ACTUALLY DOES LISTINGS - OUTPUT/COMPILE/SOURCE C dC ITDIR - Type of directive (0 if not directive dC C IL() -LOGICAL SWITCHES TRUE=LIST C 1-OUTPUT C 2-COMPILE C 3-SOURCE C C IT RECORD TYPE C 1-ACTIVE C 2-INACTIVE  C C DCK DECKNAME C NSQ SEQUENCE NUMBER C A CARD IMAGE C LENA LENGTH OF CARD C *CA PARAMA *CA LOGUR*CA SEQCTL R*CA WIDTH d*CA LANGC C  LOGICAL IL(3)  CHARACTER*8 DCK  CHARACTER*8 NAMSEQ  CHARACTER*(132) A R CHARACTER*(MAXWID) A d CHARACTER*(MAXWID) TEMPA d CHARACTER*5 SP5 e CHARACTER*6 SP6 dC C  CHARACTER*8 ITX(2)  CHARACTER*132 DUMT R CHARACTER*(MAXWID) DUMT C  DATA ITX /' ','INACTIVE'// DATA ITX /' ','INAC. '/ DATA DUMT /' '/ d DATA SP5 /' '/ e DATA SP6 /' '/ C IF(IL(1)) THEN ! WRITE(LOU,111) ITX(IT),DCK,NSQ,A(1:LENA) "111 FORMAT(1X,A8,A8,I5,1X,A) # ENDIF $C % IF(IL(2)) THEN & LENDU=MAXWID-LENA+1 ' WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),DCK,NSQ (121 FORMAT(A,A,A8,I5)  LENDU=MAXWID-LENA P*IF COMPS  CALL COMPID(DCK,NSQ,NAMSEQ)  WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),NAMSEQ= IF(LENDU.GT.0) THEN = WRITE(LCO,121) A(1:LENA),DUMT(1:LENDU),NAMSEQ = ELSE = WRITE(LCO,121) A(1:LENA),NAMSEQ = ENDIF 121 FORMAT(A,A,A8) P121 FORMAT(3A) P*ENDIF P*IF -COMPS P IF(LENDU.GT.0) THEN P WRITE(LCO,119) A(1:LENA),DUMT(1:LENDU),DCK,NSQP119 FORMAT(3A,1X,I4) P ELSE P  WRITE(LCO,121) A(1:LENA),DCK,NSQ P 121 FORMAT(2A,1X,I4) P  ENDIFP *ENDIF R IF(LSEQC.EQ.1) THEN R LENDU = MWIDE-LENAR IF(LENDU.GT.0) THEN R WRITE(LCO,115) A(1:LENA),DUMT(1:LENDU),DCK,NSQ R 115 FORMAT(3A,1X,I4) R  ELSE R  WRITE(LCO,117) A(1:LENA),DCK,NSQ R 117 FORMAT(2A,1X,I4) R  ENDIF RC R ELSE IF(LSEQC.EQ.2) THEN R CALL COMPID(DCK,NSQ,NAMSEQ) R LENDU = MWIDE-LENAR IF(LENDU.GT.0) THEN R WRITE(LCO,119) A(1:LENA),DUMT(1:LENDU),NAMSEQ R119 FORMAT(3A) R ELSE R WRITE(LCO,119) A(1:LENA),NAMSEQ R ENDIF R ELSE R WRITE(LCO,119) A(1:LENA) R ENDIFd IF(LANG.NE.2.OR.ITDIR.EQ.0) THEN d IF(LSEQC.EQ.1) THEN d LENDU = MWIDE-LENA d IF(LENDU.GT.0) THENd WRITE(LCO,115) A(1:LENA),DUMT(1:LENDU),DCK,NSQ d115 FORMAT(3A,I5) d ELSE d WRITE(LCO,117) A(1:LENA),DCK,NSQd117 FORMAT(2A,I5) d ENDIF dC d ELSE IF(LSEQC.EQ.2) THEN d CALL COMPID(DCK,NSQ,NAMSEQ)d LENDU = MWIDE-LENA d IF(LENDU.GT.0) THENd WRITE(LCO,115) A(1:LENA),DUMT(1:LENDU),NAMSEQ d ELSE d WRITE(LCO,115) A(1:LENA),NAMSEQ d ENDIF d ELSE d WRITE(LCO,115) A(1:LENA) d ENDIF d ELSE d C **** Cobol directive d!C d" TEMPA(1:MWIDE)=SP5//A(1:LENA)//DUMT e TEMPA(1:MWIDE)=SP6//A(1:LENA)//DUMT d# IF(LSEQC.EQ.1) THEN d$ WRITE(LCO,117) TEMPA(1:MWIDE),DCK,NSQ d%C d& ELSE IF(LSEQC.EQ.2) THEN d' CALL COMPID(DCK,NSQ,NAMSEQ)d( WRITE(LCO,115) TEMPA(1:MWIDE),NAMSEQ d) ELSE d* WRITE(LCO,115) TEMPA(1:LENA+5) d+ ENDIF d, ENDIF ) ENDIF *C + IF(IL(3)) THEN , WRITE(LSO,131) A(1:LENA) -131 FORMAT(A) . ENDIF /C 0 RETURN 1 END DECK(1:IBL)//'.FOR' ] COMP = EDECK(1:IBL)//COMEXT G LCOMP = IBL+4G BKUPO = EDECK(1:IBL)//'.BAK' G LBKUPO = IBL+4 G CONTO = EDECK(1:IBL)//'.CNT' G LCONTLISDCK 3/22/82 da[E/.-,*  SUBROUTINE LISDCK(NDECK)C C MAKES ALL LISTS OF DECK REQUESTED C *CA PARAMA *CA DECKS *CA DECA*CA IFSWI  *CA MODNA  *CA CONTRL  *CA PRFX CHARACTER*8 DCK,NAM,DATD  DIMENSION IMD(500)  DIMENSION IRD(5) EQUIVALENCE(LNX,IRD(1)),(IDK,IRD(2)),(NSQ,IRD(3)),  1 (IDEL,IRD(4)),(NMR,IRD(5)) C  LOGICAL IL(3)  LOGICAL ILA C .*IF I4  INTEGER*4 ILX .*ENDIF C - NIFS=0 * ISETIF=0  IDECP1=1 CALL EXAL(ADEC(IDECP1),IDECP1,NAM)  CALL EXAL(ADEC(IDECP1),IDECP1,DATD)  IDECP1=IDECP1+1  CALL EXIN(IDECP1,NMD,1)  IF(NMD.GT.0) THEN  CALL EXIN(IDECP1,IMD,NMD)  ENDIF [ IDECP1=IDECP1+NMD C 100 CONTINUEC  ILX=IDECP1   CALL EXIN(IDECP1,IRD,5) a CALL EXIN(IDECP1,IRD(1),5) ! IF(LNX.EQ.0) GOTO 2000 [ IDECP1=IDECP1+NMR [ LENA = (ILX+LNX-IDECP1)*NCHRWD " IF(ICL) THEN # IF(LSTI) THEN $ IT=2 % IL(1)=.TRUE. & ELSE ' IL(1)=.FALSE. ( ENDIF ) ELSE * IF(LSTA) THEN + IL(1)=.TRUE. , IT=1 - ELSE . IL(2)=.FALSE. / ENDIF 0 ENDIF / IL(1)=.FALSE. / IF(ICL) THEN / IF(IDEL.EQ.0) THEN / IF(LSTA) THEN / IT=1 / IL(1)=.TRUE. / ENDIF / ELSE / IF(LSTI) THEN / IT=2 / IL(1)=.TRUE. / ENDIF / ENDIF / ENDIF 1C 2 IF(ICC.AND.(IDEL.EQ.0.AND. 3 1 ITYPE(NDECK).EQ.0.AND.ISETIF.EQ.0)) THEN 4 IL(2)=.TRUE. 5 ELSE 6 IL(2)=.FALSE. 7 ENDIF 8C [ ITDIR=0 [ IL(2)=.FALSE. [ IF(ICC.AND.(IDEL.EQ.0.AND.ITYPE(NDECK).EQ.0)) THEN [ IF(ADEC(IDECP1)(1:1).EQ.PRFX) THEN [ CALL DIRCHK(ADEC(IDECP1),LENA,ITDIR) [ ENDIF[ C Force *IF and *ENDIF to compile file[ IF(ISETIF.EQ.0.OR.ITDIR.EQ.9.OR.ITDIR.EQ.11) THEN [ IL(2)=.TRUE. [ ENDIF [ ENDIF 9 IF(ICS.AND.(IDEL.EQ.0)) THEN : IL(3)=.TRUE. ; ELSE < IL(3)=.FALSE. = ENDIF >C ?C @ IF(NMR.GT.0) THEN A IDECP1=IDECP1+NMR B ENDIF CC D IF(IDK.EQ.0) THEN E DCK=NAM E DCK=DECK(NDECK) F ELSE G DCK=MODNA(IDK) H ENDIF IC J LENA=(ILX+LNX-IDECP1)*NCHRWD,C ,C FORCE NOT DELETED *ENDIF TO GET WRITTEN ON COMPILE FILE -C FORCE *ENDIF AND *IF TO BE WRITTEN ON COMPILE FILE ,C , ITDIR=0 , IF(ICC.AND.ITYPE(NDECK).EQ.0, 1 .AND. (IDEL.EQ.0.AND.ADEC(IDECP1)(1:1).EQ.PRFX)) THEN , CALL DIRCHK(ADEC(IDECP1),LENA,ITDIR) , IF(ITDIR.EQ.9) THEN - IF(ITDIR.EQ.9.OR.ITDIR.EQ.11) THEN ,  IL(2)=.TRUE. ,  ENDIF ,  ENDIF KC L ILA=IL(1).OR.IL(2).OR.IL(3) M IF(ILA) THEN [ IF(IDK.EQ.0) THEN [ DCK = DECK(NDECK) [ ELSE [ DCK = MODNA(IDK) [ ENDIFN CALL LISCRD(IL,IT,DCK,NSQ,ADEC(IDECP1),LENA) d CALL LISCRD(ITDIR,IL,IT,DCK,NSQ,ADEC(IDECP1),LENA) O ENDIF P IF(IDEL.EQ.0.AND.ADEC(IDECP1)(1:1).EQ.PRFX) THEN, IF(ITDIR.EQ.3.OR.ITDIR.EQ.9.OR.ITDIR.EQ.11) THENQ CALL COMCHK(ADEC(IDECP1),LENA) d CALL COMCHK(ITDIR,ADEC(IDECP1),LENA) R ENDIF S IDECP1=ILX+LNX T GOTO 100UC V2000 CONTINUE W RETURN X END , ENDIF ) ENDIF *C + IF(IL(3)) THEN , WRITE(LSO,131) A(1:LENA) -131 FORMAT(A) . ENDIF /C 0 RETURN 1 END LISERR 11/05/82  SUBROUTINE LISERR (IN) C C Print record (normally because of error) on output file C and terminal C *CALL PARAMA *CALL LOGU *CALL BUFA  C CALL GETBUF(IN,IL) PRINT11,BUF(1:IL) WRITE(LOU,11) BUF(1:IL) 11 FORMAT(' Record - ',A)  RETURN  END INISO 3/22/82-INREC 3/22/82/IVERS 3/22/821LIMITS 3/22/822LOGU 3/22/823MODCOM 3/22/826MODKEY 3/22/827MODNA 3/22/82LISMOD 3/22/82R SUBROUTINE LISMOD(IT,IRC,ALF,NCH) C C WRITES MODIFICATIONS ONTO OUTPUTC *CA PARAMA *CA DECKS *CA DECA*CA MODNA  *CA LOGU  CHARACTER*132 ALF R CHARACTER*(MAXWID) ALF CHARACTER*8 ITP(3),NAM DIMENSION IRC(5) DATA ITP /'ADD',' DEL','RESTORED'/C  IDK=IRC(2)  NSQ=IRC(3)  IF(IDK.EQ.0) THEN  IDU=1 CALL EXAL(ADEC(1),IDU,NAM)  ELSE  NAM=MODNA(IDK)  ENDIF C  WRITE(LOU,111)ITP(IT),NAM,NSQ,ALF(1:NCH)  CALL LININC(1) 111 FORMAT(1X,A,1X,A,I5,2X,A)  RETURN  END CHARACTER*8 ITX(2)  CHARACTER*132 DUMT R CHARACTER*(MAXWID) DUMT C  DATA ITX /' ','INACTIVE'// DATA ITX /' ','INAC. '/LOCREC 3/22/82_. SUBROUTINE LOCREC (NDECK,INPL,LOC1,LOC2)C C LOCATE RECORD POINTED TO BY DIRECTIVE RECORD INPL C C NDECK - DECK NUMBER C INPL - DIRECTIVE NUMBER C LOC1 - LOCATION OF FIRST ID ON RECORD C LOC2 - LOCATION OF SECOND ID ON RECORD  C *CA PARAMA *CA INREC *CA DECKS *CA DECI C  DIMENSION IDEK(2),ICRD(2),LOCC(2) .*IF I4  INTEGER*4 LOCC  INTEGER*4 IL,ISLOC,ILM .*ENDIF _ SAVE ISLOC  CHARACTER*8 ALF(20) C  INL=INPL  CALL GTAWD(ALF,NW,INL)  IF(NW.LT.2) GOTO 500  NDF=0  IW=2 100 NDF=NDF+1  IF(IW.LT.NW.AND.ALF(IW+1).EQ.'.') THEN  IF(IW+2.GT.NW) GOTO 500  ICRD(NDF)=RVAL(ALF(IW+2))  IF(ICRD(NDF).EQ.0) GOTO 500  IF(ALF(IW).EQ.DECK(NDECK)) THEN  IDEK(NDF)=0  ELSE IDEK(NDF)=IFINMD(ALF(IW))  IF(IDEK(NDF).EQ.0) GOTO 500 ! ENDIF " IW=IW+3 # ELSE$ ICRD(NDF)=RVAL(ALF(IW)) % IF(ICRD(NDF).EQ.0) GOTO 500 & IDEK(NDF)=0 ' IW=IW+1 ( ENDIF ) IF(IW.LE.NW.AND.NDF.LT.2) GOTO 100 *C + LOCC(1)=0 , LOCC(2)=0 - IL=ISLOC . DO 300 N=1,NDF /200 LNX=IDEC(IL)0 IF(LNX.EQ.0) GOTO 500 1 NDK=IDEC(IL+1) 2 NSQ=IDEC(IL+2) 3 IF(NDK.EQ.IDEK(N)) THEN 4 IF(NSQ.EQ.ICRD(N)) THEN 5 LOCC(N)=IL 6 GOTO 300 7 ELSE8 IF(NSQ.GT.ICRD(N)) GOTO 500 9 ENDIF : ENDIF ; IL=IL+LNX < GOTO 200 =300 CONTINUE > LOC1=LOCC(1) ? LOC2=LOCC(2) @ RETURN AC BC ERROR NOT FOUND CC D500 CONTINUEE PRINT*,'DIDNT FIND RECORD FOR INPUT RECORD NO ',INLOC(INPL) F LOC1=0 G LOC2=0 H RETURN IC JC K ENTRY INILOC(NDECK,ILM) LC MC INITIALIZE POINTER ILM TO POINT TO NMD NC AND ISLOC TO FIRST RECORD OC P IL=1 Q ILM=IL+2*NW8C+1 R ISLOC=ILM+1+IDEC(ILM) S RETURN T END MODDCK 3/22/82 JE. SUBROUTINE MODDCK(NDECK,IDNO,IDKDIR)C C MODIFY A DECK (NDECK) C *CA PARAMA *CA INREC *CA MODKEY *CA DECI *CA DECKS *CA LOGU *CA TYPDCK *CA MODCOM *CA CONTRL C .*IF I4  INTEGER*4 ILM .*ENDIF  CALL RDDK(1,NDECK) C ILM = LOCATION OF NMODS IN DECK  CALL INILOC (NDECK,ILM)  IDECP1=1  IDECP2=ISDEC(2)  NOMODS=0 IF(ITYPE(NDECK).NE.0) THEN  NMODC=NMODC+1  ENDIF C  CALL SRTMOD(NDECK,IDKDIR)  IF(NOMODS.EQ.0) RETURN  NSEQ=1 C  DO 600 I=1,ILM-1 IDEC(IDECP2)=IDEC(IDECP1)  IDECP1=IDECP1+1  IDECP2=IDECP2+1 600 CONTINUE ! IDEC(IDECP2)=IDEC(ILM)+1 " IDECP2=IDECP2+1 # IDECP1=IDECP1+1 $ IDEC(IDECP2)=IDNO % IDECP2=IDECP2+1 & DO 700 I=1,IDEC(ILM)' IDEC(IDECP2)=IDEC(IDECP1) ( IDECP1=IDECP1+1 ) IDECP2=IDECP2+1 *700 CONTINUE + DO 1000 I=1,NOMODS , MLOC=MODRC1(I) -800 IF(IDECP1.LT.MLOC) THEN . LNX=IDEC(IDECP1) / DO 840 J=1,LNX 0 IDEC(IDECP2)=IDEC(IDECP1) 1 IDECP1=IDECP1+1 2 IDECP2=IDECP2+1 3840 CONTINUE 4 GOTO 800 5 ENDIF E IF(IDECP1.GT.MLOC) THEN E IERREC=MODIN(I) E PRINT 861,DECK(NDECK),IERREC E WRITE(LOU,861) DECK(NDECK),IERRECE861 FORMAT(' Deck ',A,' has a directive (record no.',I5,') that' E 1 ,' refers to a record'/ E 1 ,'that cannot be reached. This occurs when changes overlap') E CALL LISERR(IERREC) E IF(I.GT.1) THEN E IERREC=MODIN(I-1) E PRINT 863 E WRITE(LOU,863)E 863 FORMAT(' The LAST PREVIOUSLY PROCESSED record was') E CALL LISERR(IERREC) E ENDIF E GOTO 1000 E ENDIF 6C 7 INREC=MODIN(I) 8 MTYP=INTYP(INREC) 9 IF(MTYP.EQ.7) THEN :C ;C DELETE <C = CALL PDELET(I,INREC,IDNO,NSEQ) >C ? ELSE IF(MTYP.EQ.12) THEN@C AC INSERT BC C CALL PINSRT(INREC,IDNO,NSEQ)D ELSE IF (MTYP.EQ.14) THEN EC FC RESTORE GC H CALL PRESTO(INREC,IDNO,NSEQ)J CALL PRESTO(I,INREC,IDNO,NSEQ) I ENDIF JC K1000 CONTINUELC M1500 CONTINUE N LNX=IDEC(IDECP1) O IF(LNX.EQ.0) GOTO 2000 PC Q DO 1520 J=1,LNX R IDEC(IDECP2)=IDEC(IDECP1) S IDECP1=IDECP1+1 T IDECP2=IDECP2+1 U1520 CONTINUE V GOTO 1500 WC X2000 CONTINUE Y IDEC(IDECP2)=0 Z CALL STATIS(2,IDECP2) [ NBLKS=(IDECP2+1-ISDEC(2)+NWRDBK-1)/NWRDBK \ LOCF(NDECK)=LSR ] LOCB(NDECK)=LOCLSR ^ NBLOK(NDECK)=NBLKS _ IDEC(ISDEC(2)+2*NW8C)=NBLKS `C a CALL WRDK(LSR,LOCLSR,ISDEC(2),NBLKS) CALL WRDK(LSR,LOCLSR,2,NBLKS) b3000 CONTINUE c RETURN d END DIRDIL(17)='UPDATE' x DIRDIL(18)='YANK'  DIRDMOVDK 3/22/82  SUBROUTINE MOVDK (I,J) C C MOVE DECK ARAY FROM I TO J C *CA PARAMA *CA DECKS C  DECK(J) = DECK(I) ITYPE(J) = ITYPE(I) DATED(J) = DATED(I) LOCF(J) = LOCF(I) LOCB(J) = LOCB(I) NBLOK(J)=NBLOK(I)  IIDENT(J)=IIDENT(I)  IPURGE(J)=IPURGE(I)  IEDIT(J) = IEDIT(I)  RETURN  END DS=0 IF(ITYPE(NDECK).NE.0) THEN  NMODC=NMODC+1  ENDIF C  CALL SRTMOD(NDECK,IDKDIR)  NAMCHK 3/17/83 SUBROUTINE NAMCHK(NU,NAM,NAML)C C CHECKS IF FILE NAM EXISTS, IF SO, CREATES NEW FILE WITH C VERSION NUMBERC C  CHARACTER*(*) NAM  CHARACTER*(*) NAML CHARACTER*3 VERSN  C LOGICAL*4 EX  C INTEGER*4 LNAM C C  NAML = NAM(1:)  IF(NAM .EQ. ' ') WRITE(NAML,11) NU 11 FORMAT('FOR',I3.3)  ISIZE = INDEX(NAML,' ') C *IF FILEVN  J = 120 INQUIRE(FILE=NAML,EXIST=EX,ERR=200)  IF(EX .EQV. .TRUE.) THEN  WRITE(UNIT=VERSN,FMT=30) J 30 FORMAT('.',I2.2)  NAML(ISIZE:ISIZE+2) = VERSN(1:3)  J=J+1  IF(J .GT. 99) GO TO 200  GO TO 20  ENDIF *ENDIF !200 RETURN " END 3/22/82MCKDIR 3/22/82RNXUNIN 3/22/82C  SUBROUTINE NXUNIN(A,LUN)C C OPENS NEXT INPUT UNIT C  CHARACTER*(*) A  CHARACTER*20 WORD(40) C*CALL SCAN C  CALL SCAN1(A,WORD,NW)   IF(NW.LT.2) GOTO 9000 C CALL SCAN1(A) C IF(NWRD.LT.2) GOTO 9000 LUN=LUN+1   CALL OPNINX(LUN,WORD(2),IER)C CALL OPNINX(LUN,A(ISS(2):ISS(2)+ISL(2)-1),IER) IF(IER.NE.0) GOTO 9000 RETURN 9000 PRINT*,'SOMETHING WRONG WITH READ COMMAND ',A  RETURN  END  CALL XDATE(DATE)  OPNLNP 3/22/82# a_^]TR5,  SUBROUTINE OPNLNP(NU,NAM) C C OPENS ALL FILES USED (EXCEPT ORIGINAL INPUT)C *CA PARAMAR*CA WIDTH C  CHARACTER*(*)NAMC C THE FOLLOWING ARE FOR DIRECT-ACCES UNFORMATED RECORD LENGTHSC LENLIB-LENGTH OF RECORD FOR LIBRARY FILES C LENSCI-LENGTH OF RECORD FOR SCRATCH INPUT FILE C *IF REC4C C THE VAX USES LENGTH IN LONGWORDS (4BYTES) FOR RECORD LENGTH  C  PARAMETER (LENLIB = (((NCHRWD*NWRDBK)+3)/4))  PARAMETER (LENSCI = ((MAXWID+3)/4))  C  *EI *IF REC1C C THE PRIME/IBM USE BYTES FOR THE RECORD LENGTH _C THE IBM USE BYTES FOR THE RECORD LENGTHC  DATA LENLIB / (NCHRWD*NWRDBK) /  DATE LENSCI / MAXWID /  PARAMETER (LENLIB = NCHRWD*NWRDBK )  PARAMETER (LENSCI = MAXWID )C *EI _*IF REC2_C _C The Prime manual says the record length is in bytes but the _C system is using words (2 bytes) for the record length- _C we will change the program so use the number of 2- byte words _C for the length!!!!! _C _ PARAMETER ( LENLIB = ( NCHRWD*NWRDBK/2 ) ) _ *ENDIF  CHARACTER*6 NAML T CHARACTER*20 NAML ^ CHARACTER*30 NAML C  IF(NAM.EQ.' ') THEN   OPEN(UNIT=NU,RECL=NWRDBK,STATUS='NEW',  WRITE(NAML,11) NU 11 FORMAT('FOR',I3.3)  C T CALL NAMCHK(NU,NAM,NAML)   OPEN(UNIT=NU,FILE=NAML,RECL=NWRDBK,STATUS='NEW',  OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB,STATUS='NEW', 5 OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB, 5*IF -IBM 5 1 STATUS='NEW',5*ENDIF 5*IF IBM 5 1 STATUS='OLD',5*ENDIF  1 ERR=100, 2 ACCESS='DIRECT')  ELSE  OPEN(UNIT=NU,FILE=NAM,RECL=NWRDBK,STATUS='NEW',  OPEN(UNIT=NU,FILE=NAM,RECL=LENLIB,STATUS='NEW', 5 OPEN(UNIT=NU,FILE=NAM,RECL=LENLIB, 5 *IF -IBM 5  1 STATUS='NEW',5 *ENDIF 5 *IF IBM 5  1 STATUS='OLD',5*ENDIF  1 ERR=100, 2 ACCESS='DIRECT')  ENDIF  RETURN C C  ENTRY OPNLOP(NU,NAM)C  IF(NAM.EQ.' ') THEN  OPEN(UNIT=NU,RECL=NWRDBK,STATUS='OLD',  WRITE(NAML,11)NU  C   OPEN(UNIT=NU,FILE=NAML,RECL=NWRDBK,STATUS='OLD',  OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB,STATUS='OLD', *IF VAX  1 READONLY, *EI  1 ACCESS='DIRECT',ERR=100 )  ELSE OPEN(UNIT=NU,FILE=NAM,RECL=NWRDBK,STATUS='OLD',  OPEN(UNIT=NU,FILE=NAM,RECL=LENLIB,STATUS='OLD', *IF VAX  1 READONLY, *EI  1 ACCESS='DIRECT',ERR=100 ) ! ENDIF " IERR=0 # RETURN $100 IERR=1  C  C 100 CONTINUE% PRINT*,'ATTEMPT TO OPEN FILE',NU,NAM,' FAILED' R PRINT*,'Attempt to open file ',NU,' Failed.' & STOP 'CANNOT OPEN FILE' 'C (C ) ENTRY OPNSPL(NU)*C + OPEN(UNIT=NU,STATUS='SCRATCH',RECL=NWRDBK,  WRITE(NAML,11) NU C   OPEN(UNIT=NU,FILE=NAML,RECL=NWRDBK,STATUS='SCRATCH',  OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB,STATUS='SCRATCH',  1 ERR=100,, 1 ACCESS='DIRECT'), OPEN(UNIT=NU,RECL=LENLIB,STATUS='SCRATCH',ERR=100, 5 OPEN(UNIT=NU,RECL=LENLIB,ERR=100,5*IF -IBM 5 1 STATUS='SCRATCH', 5*ENDIF 5*IF IBM 5 1 STATUS='OLD', 5*ENDIF ,*IF PRIME ]*IF -STRAT a*IF -SALFRD , 1 FILE=NAML,]*ENDIF ,*ENDIF , 1 ACCESS='DIRECT') - RETURN .C / 0C 1 ENTRY OPNLSI(NU)RC R*IF REC1RC RC The PRIME/IBM use bytes for the record length - direct access RC R LENSCI = MWIDE R *ENDIF R *IF REC4R C R C The VAX uses longwords for direct access record length R C R LENSCI = (MWIDE+3)/4R*ENDIF _ *IF REC2_ C _ C The Prime manual says the record length is in bytes but the _C system is using words (2 bytes) for the record length- _C we will change the program so use the number of 2- byte words _C for the length!!!!! _C _ LENSCI = ( MWIDE +1)/2 _*ENDIF RC 2 OPEN(UNIT=NU,ACCESS='DIRECT',RECL=MAXWID  WRITE(NAML,11) NU C   OPEN(UNIT=NU,FILE=NAML,ACCESS='DIRECT',RECL=MAXWID  OPEN(UNIT=NU,FILE=NAML,RECL=LENSCI,ACCESS='DIRECT'  1 ,ERR=1003 1 ,STATUS='SCRATCH') , OPEN(UNIT=NU,RECL=LENSCI,STATUS='SCRATCH',ERR=100, 5 OPEN(UNIT=NU,RECL=LENSCI,ERR=100,5*IF -IBM 5 1 STATUS='SCRATCH',5*ENDIF 5*IF IBM 5 1 STATUS='OLD',5*ENDIF ,*IF PRIME ]*IF -STRAT a*IF -SALFRD , 1 FILE=NAML,]*ENDIF , *ENDIF , 1 ACCESS='DIRECT') 4 RETURN 5C 6C 7 ENTRY OPNLCO (NU,NAM) 8C 9C OPEN COMPILE FILE :C 5*IF -IBMT CALL NAMCHK(NU,NAM,NAML) ; IF(NAM.EQ.' ') THEN < OPEN(UNIT=NU  WRITE(NAML,11) NU C   OPEN(UNIT=NU,FILE=NAML =*IF VAX > 1 ,CARRIAGECONTROL='LIST' ?*EI  1 ,ERR=100 @ 2 ,STATUS='NEW') A ELSEB OPEN(UNIT=NU,FILE=NAMC*IF VAX D 1 ,CARRIAGECONTROL='LIST' E*EI  1 ,ERR=100F 2 ,STATUS='NEW') G ENDIF 5*ENDIF H RETURN IC JC K ENTRY OPNLOU (NU,NAM) LC MC OPEN OUTPUT LIST FILE NC 5*IF -IBMT CALL NAMCHK(NU,NAM,NAML) O IF(NAM.EQ.' ') THEN P OPEN(UNIT=NU,STATUS='NEW')  WRITE(NAML,11) NU C   OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',ERR=100) Q ELSER OPEN(UNIT=NU,FILE=NAM,STATUS='NEW')   OPEN(UNIT=NU,FILE=NAM, STATUS='NEW',ERR=100) S ENDIF 5 *ENDIF T RETURN UC VC W ENTRY OPNLSO (NU,NAM) XC YC OPEN SOURCE FILEZC 5!*IF -IBMT CALL NAMCHK(NU,NAM,NAML) [ IF(NAM.EQ.' ') THEN \ OPEN(UNIT=NU  WRITE(NAML,11) NU C  ! OPEN(UNIT=NU,FILE=NAML ]*IF VAX ^ 1 ,CARRIAGECONTROL='LIST' _*EI " 1 ,ERR=100 ` 2 ,STATUS='NEW') a ELSEb OPEN(UNIT=NU,FILE=NAMc*IF VAX d 1 ,CARRIAGECONTROL='LIST' e*EI # 1 ,ERR=100f 2 ,STATUS='NEW') g ENDIF 5"*ENDIF h RETURN iC jC k ENTRY OPNLOA (NU,NAM) lC mC OPEN NEW ASCII LIBRARY FILE nC 5#*IF -IBM o IF(NAM.EQ.' ') THEN p OPEN(UNIT=NU $ WRITE(NAML,11) NUT CALL NAMCHK(NU,NAM,NAML)  %C  & OPEN(UNIT=NU,FILE=NAML q*IF VAX r 1 ,CARRIAGECONTROL='LIST' s*EI ' 1 ,ERR=100 t 2 ,STATUS='NEW') u ELSEv OPEN(UNIT=NU,FILE=NAMw*IF VAX x 1 ,CARRIAGECONTROL='LIST' y*EI ( 1 ,ERR=100z 2 ,STATUS='NEW') { ENDIF 5$*ENDIF | RETURN }C ~C  ENTRY OPNLIA (NU,NAM) C C OPEN OLD ASCII LIBRARY FILE C 5%*IF -IBM IF(NAM.EQ.' ') THEN  OPEN(UNIT=NU,STATUS='OLD') ) WRITE(NAML,11) NU *C  + OPEN(UNIT=NU,FILE=NAML,STATUS='OLD',ERR=100)  ELSE OPEN(UNIT=NU,FILE=NAM,STATUS='OLD')  , OPEN(UNIT=NU,FILE=NAM,STATUS='OLD',ERR=100) ENDIF 5&*ENDIF RETURN C C  ENTRY OPNINX (NU,NAM)  - ENTRY OPNINX(NU,NAM,IERR) C C OPEN INPUT FILE SPECIFIED BY *READ DIRECTIVEC 5'*IF -IBM OPEN(UNIT=NU,FILE=NAM,STATUS='OLD',ERR=100)  . OPEN(UNIT=NU,FILE=NAM,STATUS='OLD',ERR=200) IERR=0 5(*ENDIF RETURN C C  ENTRY OPNLBO(NU,NAM) C BACKUP-OUTPUT (EDIT)C 5)*IF -IBMT CALL NAMCHK(NU,NAM,NAML)  IF(NAM.EQ.' ') THEN  WRITE(NAML,11) NUC  OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',  *IF VAX  1 CARRIAGECONTROL='LIST',  *ENDIF  2 ERR=100)  ELSE OPEN(UNIT=NU,FILE=NAM,STATUS='NEW', *IF VAX  1 CARRIAGECONTROL='LIST', *ENDIF  2 ERR=100)  ENDIF 5**ENDIF  RETURN C C  ENTRY OPNLBI(NU,NAM) C BACKUP-INPUT (EDIT) C 5+*IF -IBM  IF(NAM.EQ.' ') THEN  WRITE(NAML,11) NUC  OPEN(UNIT=NU,FILE=NAML,STATUS='OLD',ERR=100)  ELSE OPEN(UNIT=NU,FILE=NAM,STATUS='OLD',ERR=100) ! ENDIF 5,*ENDIF " RETURN #C $C % ENTRY OPNLDO(NU,NAM) &C DUMP-OUTPUT (EDIT) 'C 5-*IF -IBMT CALL NAMCHK(NU,NAM,NAML) ( IF(NAM.EQ.' ') THEN ) WRITE(NAML,11) NU*C + OPEN(UNIT=NU,FILE=NAML,STATUS='NEW', , 1 FORM='UNFORMATTED',ERR=100) - ELSE. OPEN(UNIT=NU,FILE=NAM,STATUS='NEW', / 1 FORM='UNFORMATTED',ERR=100) 0 ENDIF 5.*ENDIF 1 RETURN 2C 3C 4 ENTRY OPNLDI(NU,NAM) 5C DUMP-INPUT (EDIT) 6C 5/*IF -IBM 7 IF(NAM.EQ.' ') THEN 8 WRITE(NAML,11) NU9C : OPEN(UNIT=NU,FILE=NAML,STATUS='OLD', ; 1 FORM='UNFORMATTED',ERR=100) < ELSE= OPEN(UNIT=NU,FILE=NAM,STATUS='OLD', > 1 FORM='UNFORMATTED',ERR=100) ? ENDIF 50*ENDIF @ RETURN AC BC /200 IERR=1  0 PRINT*,'ATTEMPT TO OPEN FILE',NU,NAM,' FAILED' 1 RETURN R GOTO 100 END PADD 3/22/82 JH.%!  SUBROUTINE PADD(IN,IDNO)C C PROCESS ADD DECK DIRECTIVES AND ALL CARDS IN DECK C C INTYP C IN - POINTER TO INLOC ARRAYS C C WHEN FINISHED THE FOLLOWING ARRAYS WILL HAVE BEEN  C UPDATED..............DECK  C .....................LTYPE  C .....................LOCF  C .....................LOCB  C C AND DECK WILL HAVE BEEN WRITTEN ON LSR (SCRATCH LIBRARY)C  CHARACTER*8 DCKNAM C *CA PARAMA *CA INREC *CA DECKS H*CA BUFAH*CA SCAN *CA LOGU *CA DECA *CA DATE  CHARACTER*8 WORD(40)C  DIMENSION IDM(2)C .*IF I4  INTEGER*4 ISL .*ENDIF C  CALL GTAWD(WORD,NW,IN)  DCKNAM=WORD(2) C  NDECK = IFINDK(DCKNAM) IF (NDECK.NE.0) THEN ! PRINT 90, DCKNAM" 90 FORMAT(2X,'**ERROR** ADD DECK ',A,' ALREADY EXISTS') % WRITE( LOU, 90 ) DCKNAM % CALL LININC(1) # IF(NDECK.LT.0) THEN $ PRINT*,' (THE OLD DECK HAS BEEN PURGED)' % PRINT 100 % WRITE( LOU,100 ) % 100 FORMAT( ' (The OLD DECK has been PURGED)' ) % CALL LININC(1) % ENDIF & GOTO 9000 ' ENDIF (C ) IF(NW.GT.2) THEN * INSL=IFINDK(WORD(3)) + IF(INSL.GT.0) THEN , DO 120 I=NDCKS,INSL,-1- CALL MOVDK(I,I+1) .120 CONTINUE / ELSE 0 INSL=NDCKS+1 1 ENDIF2 ELSE 3 INSL=NDCKS+1 4 ENDIF 5 NDCKS = NDCKS+1 6 CALL STATIS (1,NDCKS) ! PRINT*,' ADDING DECK ',DCKNAM ! WRITE(LOU,131)DCKNAM!131 FORMAT(10X'ADDING DECK ',A) H PRINT 131,DCKNAM H WRITE(LOU,131) DCKNAM H131 FORMAT(' Post-processing deck ',A) ! CALL LININC(1) 7 DECK(INSL)=DCKNAM 8 DATED(INSL)=DATE 9 IIDENT(INSL)=IDNO : IPURGE(INSL)=0 ; IF(INTYP(IN).EQ.2) THEN < ITYPE(INSL)=1= ELSE > ITYPE(INSL)=0 ? ENDIF @C H INCRD=INLOC(IN)+1 H CALL GETBUF(INCRD,IL) H CALL SCAN2(BUF(1:IL)) H LOCDCK=RVAL(BUF(ISS(1):ISS(1)+ISL(1)-1))H NBLKS=RVAL(BUF(ISS(2):ISS(2)+ISL(2)-1)) A LOCF(INSL)=LSR B LOCB(INSL)=LOCLSR H LOCB(INSL)=LOCDCK C IEDIT(INSL)=1 DC E IDECP1=1F CALL INAL(ADEC(IDECP1),IDECP1,DCKNAM) G CALL INAL(ADEC(IDECP1),IDECP1,DATE) H ISL=IDECP1 I IDECP1=IDECP1+2 J NSEQ=1 KC SEQUENCE NUMBER FOR CARDLC M IDIR = IN N INCRD=INLOC(IN) OC P INLAST = INLOC(IDIR+1)-1QC RC S 200 INCRD = INCRD + 1 T IF(INCRD.GT.INLAST) GOTO 500UC V CALL RECADD(IDECP1,0,NSEQ,INCRD) W NSEQ=NSEQ+1 X GOTO 200YC ZC [C NO MORE RECORDS FOR THIS DECK \C ]C ^500 CONTINUE_ CALL ININ(IDECP1,0,1) ` NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBKa CALL STATIS(2,NBLKS*NWRDBK) b IDM(1)=NBLKS c IDM(2)=0 d CALL ININ(ISL,IDM,2) H CALL RDPLA(LSR,LOCDCK,1)H CALL INAL(ADEC(IDECP1),IDECP1,DCKNAM) H CALL INAL(ADEC(IDECP1),IDECP1,DATE) e CALL WRDK(LSR,LOCLSR,1,NBLKS) H CALL WRPLA(LSR,LOCDCK,1) f NBLOK(INSL)=NBLKS g9000 CONTINUE h RETURN i END PDECK 3/22/82  SUBROUTINE PDECK(IN)C C PROCESS 5 - DECK DIRECTIVE C (SET UP PRESORT ARAYS) C *CA PARAMA *CA DECKS *CA INREC *CA INISO  C CHARACTER*8 DECNA  C INL=IN  CALL GTFWD(DECNA,INL) C  I=IFINDK(DECNA)  IF(I.GT.0) GOTO 1100  IF(I.LT.0) THEN  PRINT*,'DECK DIRECTIVE FOR ',DECNA,'DECK HAS BEEN PURGED'  STOP  ENDIF C  PRINT*,'DECK DIRECTIVE - DECK ',DECNA,' NOT FOUND RECORD ',IN  STOPC 1100 CONTINUEC  IEDIT(I)=1  NINSO = NINSO+1  INIDK(NINSO)=I  INICD(NINSO)=IN  C ! RETURN " END IF (NDECK.NE.0) THEN ! PRINT 90, DCKNAM" 90 FORMAT(2X,'**ERROR** ADD DECK PDEFIN 3/22/82  SUBROUTINE PDEFIN (IN) C C PROCESS 6 - DEFINE DIRECTIVEC *CA PARAMA *CA INREC *CA SWITCHC CHARACTER*9 SWII CHARACTER*8 SWI,SWIN EQUIVALENCE (SWI,SWII),(SWIN,SWII(2:))  C INL=IN  CALL GTFWD(SWII,INL)  IF(SWII.EQ.' ') THEN PRINT*,' BAD SWITCH CARD BLANK SWITCH'  GOTO 8000  ENDIF  IF(SWII(1:1).EQ.'-') GOTO 500  DO 100 I=1,NSWS  IF(SWI.EQ. SWITCH(I)) THEN PRINT*,'SWITCH ALLREADY SET ',SWI  GOTO 8000  ENDIF 100 CONTINUE  NSWS=NSWS+1  SWITCH(NSWS)=SWI  PRINT*,'SET SWITCH ',SWI  GOTO 8000 C C TURNOFF SWITCH  C !500 CONTINUE " DO 600 I=1,NSWS # IF(SWIN.EQ.SWITCH(I)) GOTO 700 $600 CONTINUE% PRINT*,' COULDNT FIND SWITCH TO TURN OFF ',SWII & GOTO 8000 '700 DO 800 L=I,NSWS-1 ( SWITCH(L)=SWITCH(L+1) )800 CONTINUE * NSWS=NSWS-1 + PRINT*,'TURNED OFF SWITCH ',SWI ,8000 CONTINUE - CALL STATIS(6,NSWS) . RETURN / END 1) .120 CONTINUE / ELSE 0 INSL=NDCKS+1 1 ENDIF2 ELSE 3 INSL=NDCKS+1 4 ENDIF 5 NDCKS = NDCKS+1 6 CALL STATIS (1,NDCKS) 7 DECK(INSL)=DCKNAM 8 DATED(INSL)=DATE 9PDELET 3/22/82. SUBROUTINE PDELET(IM,IN,IDNO,NSEQ) C C PROCESS DELETE DIRECTIVE AND ADD RECORDS FOLLOWING C C IM - POINTER TO SORTED MODKEY RECORDC C IN - DIRECTIVE C *CA PARAMA *CA INREC *CA MODKEY *CA DECI  C .*IF I4  INTEGER*4 MLAST .*ENDIF C IDIR - LOCAL POINTER TO DIRECTIVE KEYS C  IDIR=IN  MLAST = MODRC2(IM) C 100 CALL RECDEL(IDIR,IDNO)  IF(IDECP1.LE.MLAST) GOTO 100C  INCRD=INLOC(IN)  INLAST = INLOC(IDIR+1)-1C C  200 INCRD = INCRD + 1  IF(INCRD.GT.INLAST) GOTO 500C  CALL RECADD(IDECP2,IDNO,NSEQ,INCRD)  NSEQ=NSEQ+1  GOTO 200 C ! 500 CONTINUE " RETURN # END PEDIT 3/22/82J  SUBROUTINE PEDIT (IN) C C PROCESS DIRECTIVES C 4 - COMPILE C 5 - EDITC *CA PARAMA *CA DECKS *CA INREC  C CHARACTER*8 WORD(40) CHARACTER*8 DECKNA  C  INL=IN  CALL GTAWD(WORD,NW,INL) C  IF(NW.EQ.3 .AND. WORD(2).EQ.'.' ) GOTO 1000 C C FORM A,B,C,DC  DO 500 I=2,NW  DECKNA=WORD(I)  L=IFINDK(DECKNA)  IF(L.GT.0) THEN  IEDIT(L)=1  ELSEIF(L.LT.0) THEN  PRINT*,'DECK REQUESTED TO EDIT ',A,' HAS BEEN PURGED' J PRINT*,'Edit deck ',DECKNA,' has been purged'  ELSE  PRINT*,'DIDNT FIND EDIT DECK ',DECKNA,  1 ' DIRECTIVE RECORD NO ',IN  ENDIF 500 CONTINUE!C " RETURN #C $C FORM IS A.B %1000 CONTINUE & DECKNA=WORD(1) ' L1=IFINDK(DECKNA) ( DECKNA=WORD(3) ) L2=IFINDK(DECKNA) * IF(L2.LE.L1.OR.L1.EQ.0) GOTO 2000 + PRINT*,'EITHER DECK2 IS NOT BEHIND DECK1 OR DECK1 IS NOT', , 1 'FOUND '- PRINT*,WORD(1), ' DECK NO ',L1 . PRINT*,WORD(3), ' DECK NO ',L2 / RETURN 0C 12000 CONTINUE 2 DO 2010 I=L1,L2 3 IEDIT(I)=1 42010 CONTINUE 5 RETURN 6 END IFINDK(WORD(3)) + IF(INSL.GT.0) THEN , DO 120 I=NDCKSPIDENT 3/22/82R SUBROUTINE PIDENT(IN,IDNO) C C PROCESS IDENT DIRECTIVE C IN - POINTER TO INLOC FOR CARD IMAGEC *CA PARAMA *CA INREC *CA MODNA *CA BUFA *CA DATE R*CA WIDTH  C CHARACTER*8 IDENT  C  INL=IN  CALL GTFWD(IDENT,INL) C  IF(IDENT.EQ.' ') GOTO 1000 C  I=IFINMD(IDENT)  IF(I.GT.0) GOTO 1100C  NMODS=NMODS+1  MODNA(NMODS)=IDENT  DATEM(NMODS)=DATE  IDNO=NMODS  RETURN C 1000 PRINT*,'IDENT NOT GIVEN'  GOTO 1110 1100 PRINT*,'IDENT ALLREADY IN LIBRARY' 1110 PRINT*,'INPUT CARD NUMBER ',INLOC(IN),' ',BUF R1110 PRINT*,'Input record number ',INLOC(IN),' ',BUF(1:MWIDE) C ! STOP" END C PINSRT 3/22/82 SUBROUTINE PINSRT(IN,IDNO,NSEQ) C C PROCESS INSERT DIRECTIVE (IN) C ADD NEW RECORDS FOLLOWING C *CA PARAMA *CA INREC *CA DECI C IDIR=IN  C  C RECMOV WILL MOVE THE RECORD FROM ARAY1 TO ARAY2  C  CALL RECMOV C C  INCRD=INLOC(IN)  INLAST = INLOC(IDIR+1)-1C C  200 INCRD = INCRD + 1  IF(INCRD.GT.INLAST) GOTO 500C  CALL RECADD(IDECP2,IDNO,NSEQ,INCRD)  NSEQ=NSEQ+1  GOTO 200C  500 CONTINUE  RETURN  END 1100 PRINT*,'IDENT ALLREADY IN LIBRARY' 1110 PRINT*,'INPUT CARD NUMBER ',INLOC(IN),' ',BUF  C ! STOP" END CONTINUE!C " RETURN #C $C FORM IS A.B PMOVE 3/22/82C  SUBROUTINE PMOVE(IN)C C PROCESSES MOVE DIRECTIVEC IN - POINTER TO INLOC FOR CARD IMAGEC *CA PARAMA *CA BUFA *CA INREC *CA DECKS  C   CHARACTER*20 WORD(40) C*CALL SCAN CHARACTER*8 ID1,ID  C  INL = INLOC(IN)  CALL GETBUF(INL,IL) C  CALL SCAN2(BUF(2:IL*NCHRWD),WORD,NWRD) C CALL SCAN2(BUF(1:IL)) C  IF(NWRD.LT.2) GOTO 110  ID1=WORD(2) C ID1=BUF(ISS(2):ISS(2)+ISL(2)-1)  DO 100 NDL=1,NDCKS  IF(ID1.EQ.DECK(NDL)) GOTO 200 100 CONTINUE PRINT*,'DIDNT FIND DECK TO MOVE TO ',ID1 STOPC 110 PRINT*,'NO DECK NAMES ON MOVE DIRECTIVE' STOPC 200 CONTINUE  DO 400 N=3,NWRD  ID=WORD(N) C ID=BUF(ISS(N):ISS(N)+ISL(N)-1) ! NN=IFINDK(ID) " IF(NN.NE.0) GOTO 320# PRINT*,'DIDNT FIND DECK TO MOVE ',ID $ GOTO 400 %320 CONTINUE & NN=IABS(NN) ' CALL MOVDK(NN,NDCKS+1) ( IF(NN.LT.NDL) THEN ) DO 330 L=NN+1,NDL * CALL MOVDK(L,L-1) +330 CONTINUE, CALL MOVDK(NDCKS+1,NDL) - ELSE IF (NN.GT.NDL) THEN. DO 340 L=NN-1,NDL+1,-1 / CALL MOVDK(L,L+1) 0340 CONTINUE1 CALL MOVDK(NDCKS+1,NDL+1) 2 NDL=NDL+1 3 ENDIF 4400 CONTINUE 5 RETURN 6 END 9 LIMWID = MAXWID : LIMDCK = MAXDCK ; LIMWRD = MAXWRD < LIMMNA = MAXMNA = LIMMDK = MAMMDK > LIMMDD = MAXMDD ? LIMSWI = MAXSWI @ LIMDRR = MAXDRR A LIMDIR = MAXDIR PPURGE 3/22/82SHDC  SUBROUTINE PPURGE(IN) C C PROCESS PURGE DECK DIRECTIVES C C INTYP C IN - POINTER TO INLOC ARRAYS C C *CA PARAMA *CA DECKS  *CA CONTRL D*CALL LOGU C*CALL BUFA C*CALL INREC C*CALL SCAN CHARACTER*8 DCKNAM  C  CALL GTFWD(DCKNAM,IN) C IDL=INLOC(IN) C CALL GETBUF(IDL,IL) C CALL SCAN2(BUF(1:IL)) S IF(NWRD.LT.2) THEN S PRINT 51,IN S WRITE(LOU,51) IN S51 FORMAT(' Rcord no.',I5,' PURGE directive has no deck name' S 1 ,' Directive IGNORED') S RETURN S ENDIF C DO 200 I=2,NWRD C DCKNAM=BUF(ISS(I):ISS(I)+ISL(I)-1) C  NPURG = IFINDK(DCKNAM)  IF (NPURG.EQ.0) THEN  PRINT 91, DCKNAM H WRITE(LOU,91) DCKNAM  91 FORMAT(2X,'**ERROR** PURGE DECK ',A,' NOT FOUND') ELSEIF(NPURGE.LT.0) THEN H ELSEIF(NPURG.LT.0) THEN  PRINT*,'DECK ',DCKNAM,'HAS ALLREADY BEEN PURGED' H PRINT101,DCKNAM H101 FORMAT(' Deck ',A,' has allready been purged') H IF(LSTM) THENH WRITE(LOU,101) DCKNAM H CALL LININC(1) H ENDIF ELSE  IPURGE(NPURG)=1  PRINT*,'PURGED DECK ',DCKNAM H PRINT 111, DCKNAM  IF(ICM) THEN  IF(LSTM) THEN WRITE(LOU,111) DCKNAM 111 FORMAT('0PURGED DECK ',A)  CALL LININC(2)H 111 FORMAT(' Purged deck ',A) H CALL LININC(1)  ENDIF  ENDIF C 200 CONTINUE  RETURN  END ---') H IF(ITYPE(IDECE).EQ.0) THENH CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------')PRENAM 5/03/82SC?  SUBROUTINE PRENAM(IN) C C PROCESSES RENAME DIRECTIVE C IN - POINTER TO INLOC FOR CARD IMAGEC *CA PARAMA *CA BUFA *CA INREC *CA DECKS  C S*CALL DECA S*CALL LOGU   CHARACTER*20 WORD(40) C*CALL SCAN CHARACTER*8 ID1,ID2  C  INL = INLOC(IN)  CALL GETBUF(INL,IL) C  CALL SCAN2(BUF(2:IL*NCHRWD),WORD,NWRD) C CALL SCAN2(BUF(1:IL)) C  IF(NWRD.LT.3) THEN  PRINT*,'NOT ENOUGH DECK NAMES ON RENAME DIRECTIVE'  PRINT*,BUF(1:IL*NCHRWD) C PRINT*,BUF(1:IL)  STOP  ENDIF  ID1=WORD(2) C ID1=BUF(ISS(2):ISS(2)+ISL(2)-1)  NDR=IFINDK(ID1)  IF(NDR.LE.0) THEN  PRINT*,'DIDNT FIND DECK TO RENAME ',ID1  PRINT*,BUF(2:IL*NCHRWD) C PRINT*,BUF(1:IL)  STOP  ENDIF C  C ! ID2=WORD(3) C ID2=BUF(ISS(3):ISS(3)+ISL(3)-1) " NN=IFINDK(ID2) # IF(NN.EQ.0) THEN $ DECK(NDL)=ID2% PRINT*,'RENAMED DECK ',ID1,' TO ',DECK(NDL) ? DECK(NDR)=ID2 S ISDEC1=1 S CALL RDDK(1,NN) S CALL INAL(ADEC(IDECP1),IDECP1,DECK(NDR))S CALL WRDK(LSR,LOCLSR,1,NBLOK(NDR)) ? PRINT*,' Renamed deck',NDR,ID1,' to ',DECK(NDR) ? & ELSE' PRINT*,'NEW DECK NAME TO RENAME DECK ',ID1, ( 1 ' TO ALLREADY EXISTS ',ID2 ) STOP 'NEW NAME ALLREADY IN DECK' * ENDIF + RETURN , END ENDIF  ENDIF C 200 CONTINUE  RETURN  END ---') H IF(ITYPE(IDECE).EQ.0) THENH CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------')PRESTO 3/22/82 SUBROUTINE PRESTO (IM,IN,IDNO,NSEQ) C C PROCESS RESTORE DIRECTIVE AND ADD RECORDS FOLLOWING C C IM - POINTER TO SORT KEY RECORD C C IN - INPUT RECORD NUMBERC *CA PARAMA *CA INREC *CA MODKEY *CA DECI  C   IDIR = IN  MLAST = MODRC2(IM) C 100 CALL RECRES(IDIR,IDNO)  IF(IDECP1.LE.MLAST) GOTO 100C  INCRD=INLOC(IDIR)  INLAST = INLOC(IDIR+1)-1C C  200 INCRD = INCRD + 1  IF(INCRD.GT.INLAST) GOTO 500C  CALL RECADD(IDECP2,IDNO,NSEQ,INCRD)  NSEQ=NSEQ+1  GOTO 200C 500 CONTINUE ! RETURN " END  ENDIF  RETURN  END PRINT*,'DIDNT FIND DECK TO MOVE ',ID $ PROC3 3/22/82ZXVS  SUBROUTINE PROC3  EXTERNAL KOMDEC,SWADEC C C PROCESS DIRECTIVES THAT MODIFY THE DECKSC C 3 - CALL C 5 - DECK C 7 - DELETE C 9 - ENDIF C 11 - IF C 12 - INSERT C 14 - RESTORE C *CA PARAMA *CA DECKS *CA CUREDT *CA CONTRL *CA LOGU *CA INREC *CA INISO *CA TYPDCK C *CA MODNA  CHARACTER*8 STP,LTP C C C WE WILL SET UP SORT AND PROCESS C MODS FOR EACH IDENT SEPARATELY C SC Set up YANK and UPDATE switches S IYANK=0 S IUPDAT=0  IDNO=0  ID=0 50 ID=ID+1 ! IF(ID.GT.NDIR) THEN " IF(IDNO.NE.0) GOTO 500 # GOTO 9000 $ ENDIF % IT=INTYP(ID)& GOTO( 101, 101, 50, 104, 50, 106, 50, 104, 50, 110, 50  GOTO( 101, 101, 50, 104, 50, 106, 50, 104, 50, 210, 50 ' 1 , 50, 113, 50, 50, 116, 50, 50 ),IT   1 ,50,113,50,50,116,50,50,119),IT S 1 ,50,113,50,50,116,117,118,119),IT (C )C 1-ADD/ 2-ADDCOM *C +101 CALL PADD(ID,IDNO) , IPRD(ID)=.TRUE. - GOTO 50 .C /C 4 - COMPILE / 8 - EDIT 0C 1104 CALL PEDIT(ID) 2 IPRD(ID)=.TRUE. 3 GOTO 50 4C 5C 6 - DEFINE 6C 7106 CALL PDEFIN(ID) 8 IPRD(ID)=.TRUE. 9 GOTO 50 :C ;C 13 - MOVE <C =113 CALL PMOVE(ID) > IPRD(ID)=.TRUE. ? GOTO 50 @C AC 16 - PURGE BC C116 CALL PPURGE(ID) D IPRD(ID)=.TRUE. E GOTO 50 SC SC 17 - UPDATE SC S117 IF (ICN) THEN S IUPDAT=ID S IPRD(ID)=.TRUE. S ELSE S PRINT 1171 ,'UPDATE' S WRITE(LOU,1171) 'UPDATE' S1171 FORMAT(1X,A,' Directive encountered but new library not' S 1 ,' requested.',S 2 20X,'Directive will NOT be processed.') S ENDIF S GOTO 50 SC SC 18 - YANK SC S118 IF (ICN) THEN X IF(.NOT.ICS) THEN X WRITE(LOU,1181) X PRINT 1181X1181 FORMAT(' YANK Directive encountered but SOURCE file not' X 1 ,' requested.',20X,'Directive will NOT be processed.') X GOTO 50 X ENDIF S IYANK =ID S IPRD(ID)=.TRUE. S ELSE S PRINT 1171, 'YANK' S WRITE(LOU,1171) 'YANK' S ENDIF S GOTO 50 C C 19 - RENAME C 119 CALL PRENAM(ID)  IPRD(ID)=.TRUE.  GOTO 50 FC GC 10 - IDENT HC I110 CONTINUE 210 CONTINUE J IF(IDNO.EQ.0) THEN K CALL PIDENT(ID,IDNO) L IF(IDNO.NE.0) THEN M ISID=ID  GOTO 50 N ENDIF O GOTO 50 P ENDIF  GOTO 50  C C 19-RENAME  C 119 CALL PRENAM(ID)  IPRD(ID)=.TRUE.  GOTO 50 QC RC PROCESS DECK MODS SC T500 IFID=ID-1 U NINSO=0 V DO 1000 IN=ISID,IFID W IF(IPRD(IN)) GOTO 1000X IF(INTYP(IN).EQ.5) THEN Y CALL PDECK(IN) Z IPRD(IN)=.TRUE. [ ENDIF \1000 CONTINUE ]2000 CONTINUE ^ IF(NINSO.EQ.0) GOTO 8000 _ IF(NINSO.GT.1) THEN ` CALL QIKSRT(1,NINSO,KOMDEC,SWADEC) a ENDIF b IF(ICL) THENc CALL HEADER('MODIFICATIONS - IDENT -'//MODNA(IDNO)) d ENDIF eC fC FIND THE NEXT DECK TO BE EDIT/MODIFIED gC h IDKDIR=1 i3000 CONTINUE j NDECK=INIDK(IDKDIR) k IF(NDECK.EQ.0) GOTO 8000 l ITPDCK = ITYPE(NDECK) m IF(ITPDCK .EQ. 0) THEN n STP = '*A ' o LTP = ' DECK' p ELSE q STP = '*AC ' r LTP = 'COMDECK' s ENDIF tC u NIA = 0 v NAC = 0 wC x IF(ICL) THEN Z CALL SUBHED(6) y WRITE(LOU,111) z111 FORMAT(' ') { WRITE(LOU,115) LTP,DECK(NDECK) Z WRITE(LOU,115) LTP,DECK(NDECK) | 115 FORMAT(10X,A,'**** ',A,' ****') Z 115 FORMAT(10X,A,'**** ',A,' ****') } WRITE(LOU,111) ~ CALL LININC(3)  ENDIF  CALL MODDCK(NDECK,IDNO,IDKDIR)  IF(IDKDIR.LE.NINSO) GOTO 3000 C 8000 CONTINUE IF(ID.LE.NDIR) THEN IDNO=0  GOTO 110  GOTO 210 ENDIF 9000 CONTINUESC S IF(IUPDAT.NE.0) CALL PUPDAT(ID) V IF(IUPDAT.NE.0) CALL PUPDAT(IUPDAT) S C IF(IYANK.NE.0) CALL PYANK(ID) V IF(IYANK.NE.0) CALL PYANK(IYANK) RETURN  END PROC4 3/22/82  SUBROUTINE PROC4C C WRITES COMPILE/SOURCE AND OUTPUT AS REQUESTED C *CA PARAMA *CA DECKS *CA CONTRL *CA LOGU *CA MODCOM CHARACTER*4 ATP LOGICAL ILST C   ILST = ISL.AND.(LSTA.OR.LSTI)  ILST=ICL.AND.(LSTA.OR.LSTI) C  IF(ILST) THEN  CALL HEADER ('ACTIVE/INACTIVE RECORDS')  ENDIF C  DO 1000 N=1,NDCKS  IF(IPURGE(N).NE.0) GOTO 1000  IF(.NOT.ICF.AND.(IEDIT(N).EQ.0)) THEN IF(ICQ.OR.(NMODC.EQ.0)) GOTO 1000  CALL CKDKMC(N,IMCMN)  IF(IMCMN.EQ.0) GOTO 1000  ENDIF  IF(ILST) THEN  WRITE(LOU,111) 111 FORMAT(' ')  WRITE(LOU,115) DECK(N)115 FORMAT(20X,'DECK **** ',A,' ****')  WRITE(LOU,111) CALL LININC(3) ! ENDIF " IF(ICS) THEN # IF(ITYPE(N).EQ.0) THEN $ ATP='*A ' % ELSE & ATP='*AC ' ' ENDIF ( WRITE(LSO,117) ATP,DECK(N) )117 FORMAT(2A) * ENDIF + CALL RDDK(1,N) , CALL LISDCK(N) -1000 CONTINUE . RETURN / END NTINUE / ELSE 0 INSL=NDCKS+1 1 ENDIF2 ELSE 3 INSL=NDCKS+1 4 ENDIF 5 NDCKS = NDCKS+1 6 CALL STATIS (1,NDCKS) 7 DECKPYANK 3/17/83 a\X  SUBROUTINE PYANK (IN)  EXTERNAL KOMYAN,SWAYAN C C Deactivate modification setsC Mod sets written on source C New library written *CA PARAMA *CA CONTRL  *CA DATE *CA DECKS  *CA DECI *CA EDITCO  *CA INREC *CA LOGU*CA MODKEY *CA MODNA *CA WIDTH *CA YANDEC *CA YANPTR  LOGICAL NEWDK  CHARACTER*8 IDENT C C MN() - Mod number (used with current record being written) C MS() - Sequence number associated with MN C  INL=IN  CALL GTFWD(IDENT,INL) C  IF(IDENT.EQ.' ') GOTO 10C  IMOD=IFINMD(IDENT) IF(IMOD.GT.0) GOTO 80 !C "10 PRINT 11,IDENT #11 FORMAT(' YANK directive ident ',A,' not found directive ignored') $ WRITE(LOU,11) IDENT % IERREC=MODIN(IN) & CALL LISERR(IERREC) ' RETURN (C )80 CONTINUE * NEWDKS=0 + NMODDK=0 , IRECLO=NIN+1 - IRECLN=IRECLO .C Loop thru each deck /C 0 DO 5000 NDK=1,NDCKS 1 NEWDK=.FALSE. 2 CALL RDDK(1,NDK) 3C 4C Start of MODS5C 6 ISMOD = 1 + NW8C*2 +27C check to see if there are any yanked mods on this deck 8C or if this deck belongs to a yanked mod9 IF (IDEC(ISMOD-1) .EQ. 0 ) THEN : IF(IIDENT(NDK).LT.IMOD) GOTO 5000 ; ELSE IF (IDEC(ISMOD).LT.IMOD) THEN < GOTO 5000 = ENDIF>C X IEDIT(NDK)=1 XC ?C End of mods @C A NMODD=1 B NMD=IDEC(ISMOD-1)CC start of deck records D ISDECS = ISMOD + NMD EC last mod F IEMOD = ISDECS - 1 GC HC set up pointers to recordsIC (forward, backward, location) JC K IDECP1=ISDECS L IREC=0 M IR(0)=0 N N(0)=1 O L(0)=0 PC Q500 CONTINUE RC S LNX=IDEC(IDECP1) T IREC=IREC+1 U IF(LNX.NE.0) THEN V IR(IREC)=IDECP1 W N(IREC)=IREC+1 X L(IREC)=IREC-1 Y IDECP1=IDECP1+LNX Z GOTO 500 [ ENDIF \ IR(IREC)=0 ] N(IREC)=0 ^ L(IREC)=IREC-1 _ NRECI=IREC ` IREC=0 aC bC Loop thru the deck 1 mod at a time cC looking for records to processdC e DO 4000 NM = NMODS,IMOD,-1 fC g IF(IIDENT(NDK).EQ.NM) THEN h NEWDK=.TRUE. i NEWDKS=NEWDKS+1j IF( ITYPE(NDK).EQ.0) THEN k YANREC='*A '//DECK(NDK) l ELSE m YANREC='*AC '//DECK(NDK) n ENDIF oC p NDKN=NDK q1200 NDKN=NDKN+1r IF(NDKN.LE.NDKS) THEN X IF(NDKN.LE.NDCKS) THEN s IF(IIDENT(NDKN).GE.NM) THEN t GOTO 1200 u ENDIF v YANREC(13:)=','//DECK(NDKN) w ENDIF x CALL YWRR yC z ELSE IF(IDEC(ISMOD).NE.NM) THEN { GOTO 4000 | ELSE IF(IPURGE(NDK).EQ.NM) THEN } YANREC = '*PURGE '//DECK(NDK) ~ CALL YWRR  IPURGE(NDK)=0  GOTO 4000  ELSE IF (IPURGE(NDK).GT.0.AND. 1 IPURGE(NDK).LT.NM) THEN  GOTO 4000  ELSE  NMODD=NMODD+1  YANREC='*DECK '//DECK(NDK) CALL YWRR ENDIF X DO 1260 IQ=0,NMD-1X IF(IDEC(ISMOD+IQ).EQ.NM) GOTO 1280 X1260 CONTINUE X IF(NEWDK) GOTO 1360 X GOTO 4000 C  LTYPE=1 C X 1280 YANREC='*DECK '//DECK(NDK) X CALL YWRR X C X 1360 LTYPE=1 C this is start of loop thru deck records C IREC = 0 1400 CONTINUE IREC = N(IREC) IF(IREC.EQ.0.OR.IREC.EQ.NRECI) GOTO 3800 IDECP1 = IR(IREC) C IF(NEWDK) THEN CALL YADDRC(IREC) C  ELSE IF(IDEC(IDECP1+1).EQ.NM) THENC this record belongs to this mod IF(LTYPE.EQ.1) THEN CALL YINITP(1,L(IREC)) CALL YWRR  CALL YADDRC(IREC)  ELSE IF (LTYPE.EQ.2.OR.LTYPE.EQ.3) THEN CALL YWRR  CALL YADDRC(IREC)  ELSE IF (LTYPE.EQ.4) THEN  CALL YADDRC(IREC) ENDIF LTYPE=4C inactivate record completely NX=N(IREC) LA=L(IREC) N(LA)=NX L(NX)=LA C  ELSE IF( IDEC(IDECP1+4).GT.0 .AND. 1 ABS(IDEC(IDECP1+5)).EQ.NM) THEN C C this record was affected by this mod  IF( IDEC(IDECP1+5).GT.0) THEN C it was activated (restored)  IF (LTYPE.EQ.1 .OR. LTYPE .EQ. 4) THEN  CALL YINITP(3,IREC)  ELSE IF (LTYPE.EQ.2) THEN CALL YWRR CALL YINITP(3,IREC)  ELSE IF (LTYPE.EQ.3) THEN  CALL YADDTP(IREC) ENDIF LTYPE=3 ELSE C it was deleted  IF(LTYPE.EQ.1 .OR. LTYPE.EQ.4) THEN  CALL YINITP(2,IREC)  ELSE IF (LTYPE.EQ.3) THEN CALL YWRR CALL YINITP(2,IREC)  ELSE IF (LTYPE.EQ.2) THEN  CALL YADDTP(IREC) ENDIF LTYPE=2 ENDIF C IDECP1=IR(IREC) IDEC(IDECP1)=IDEC(IDECP1)-1 IDEC(IDECP1+3)=-IDEC(IDECP1+3) a IF(LTYPE.EQ.2) THENa IDEC(IDECP1+3)=0 a ELSE a IDEC(IDECP1+3)=1 a ENDIF  IDEC(IDECP1+4)=IDEC(IDECP1+4)-1 DO 1800 IQ=5,IDEC(IDECP1)-1 IDEC(IDECP1+IQ)=IDEC(IDECP1+IQ+1) 1800 CONTINUE C  ELSE IF (LTYPE.EQ.2.OR.LTYPE.EQ.3) THEN CALL YWRR LTYPE=1 ELSE IF (LTYPE.EQ.4) THEN LTYPE=1 ENDIF GOTO 1400 C 3800 CONTINUE C C this is the end of the deck C  IF(LTYPE.EQ.2.OR.LTYPE.EQ.3) THEN CALL YWRR ENDIFC  IF(IRECLO.GT.IRECLN) THENC add to the random array pointers NMODDK=NMODDK+1  YANMOD(NMODDK) = NM  YANDCK(NMODDK) = NDK  YANRES(NMODDK) = IRECLN  YANREE(NMODDK) = IRECLO-1 IRECLN = IRECLO ENDIF IF(NEWDK) GOTO 5000 4000 CONTINUE C C compress the deck and write it out IREC=0 IDECP1=ISMOD-1 IDECP2=ISMOD NMN=0 DO 4160 IQ=1,NMD  IF(IDEC(IDECP1+IQ).LT.IMOD) THEN  IDEC(IDECP2)=IDEC(IDECP1+IQ) IDECP2=IDECP2+1 NMN=NMN+1 ENDIF 4160 CONTINUE IDEC(ISMOD-1)=NMN C 4200 IREC=N(IREC)  IF(IREC.EQ.0.OR.IREC.EQ.NRECI) GOTO 4260 IDECP1=IR(IREC) LNX=IDEC(IDECP1) DO 4240 IQ=1,LNX  IDEC(IDECP2)=IDEC(IDECP1) IDECP2=IDECP2+1 IDECP1=IDECP1+1 4240 CONTINUE  GOTO 4200C 4260 IDEC(IDECP2)=0  NBLKS=(IDECP2+1-1+NWRDBK-1)/NWRDBK  LOCF (NDK) = LSR  LOCB (NDK) = LOCLSR  NBLOK(NDK) = NBLKS  IDEC(1+2*NW8C)=NBLKS  C   CALL WRDK(LSR,LOCLSR,1,NBLKS)  5000 CONTINUE C C decrement mods to indicate true number C  NMODS=IMOD-1C C get rid of decks that were new - if any C  IF(NEWDKS.GT.0) THEN  NDKN=0  DO 6000 I=1,NDCKS IF(IIDENT(I).LT.IMOD) THEN  NDKN=NDKN+1 IF(NDKN.NE.I) THEN  CALL MOVDK(I,NDKN)  ENDIF  ENDIF 6000 CONTINUE  NDCKS=NDKN  ENDIF   X C ! IF(NMODDK.GT.0) THEN " IF(NMODDK.GT.1) THEN # CALL QIKSRT(1,NMODDK,KOMYAN,SWAYAN) $ ENDIF %C & NML=0 ' DO 8000 I=1,NMODDK ( NM=YANMOD(I) ) IF(NM.NE.NML) THEN* WRITE(LSO,7001) '*IDENT ',MODNA(NM) +7001 FORMAT(10A) , NML=NM - ENDIF . DO 7100 NR=YANRES(I),YANREE(I) / CALL YRRR(NR) 0 DO 7080 NC=MWIDE,2,-1 1 IF(YANREC(NC:NC).NE.' ') GOTO 7090 27080 CONTINUE 37090 WRITE(LSO,7001) YANREC(1:NC) 47100 CONTINUE 58000 CONTINUE 6 ENDIF 7C X ICS=.FALSE. 8 RETURN 9 END 'C 5-*IF -IBMT CALL NAMCHK(NU,NAM,NAML) ( IF(NAM.EQ.' ') THEN ) WRITE(NAML,11) NU*C + OPEN(UNIT=NU,FILE=NAML,STATUS='NEW', , QIKSRT 3/22/82\ SUBROUTINE QIKSRT(MM,NN,KOMPAR,SWAP)C C ALGORITHM 271 (QUICKERSORT BY R.S. SCOWEN,) C MAR. 1965 COMMUNICATIONS OF THE ACM C C C THIS PROCEDURE USES A METHOD SIMILAR TO THAT OF QUICKSORT. C BY C.A.R. HOARE (ALGORITHMS 63,64, COMM.ACM 4 JULY 1961) C  C MODIFIED TO USE SHELL SORT ON PARTITIONS OF 15 OR LESS.  C (1/18/79 BY A.H. SCHMIDT,JR.)  C  DIMENSION MSTACK(20),NSTACK(20)  LOGICAL SORTED,EXCHGC  M=MM  N=NN  SORTED=.FALSE.  LEVEL=0 C C REPEAT-UNTIL(SORTED) PARTITION-AND-SORT C 5 IF (.NOT.SORTED) GOTO 10 C  RETURN C C C ******************************************************* C TO PARTITION-AND-SORT C 10 CONTINUE NUM=N-M+1!C " IF(NUM .GT. 15) THEN \ IF(NUM .GT. 15) GOTO 60 #C PARTITION-THE-ARRAY $ GO TO 60 \ GO TO 130%C PUSH-LARGEST-PARTITION-ON-STACK &20 GO TO 110 '30 CONTINUE (C ) ELSE *C SHELL-SORT-PARTITION-OF-15-OR-LESS + GO TO 130 ,40 IF(LEVEL .GT.0) THEN \40 IF(LEVEL .GT.0) GOTO 120 \ SORTED = .TRUE. -C POP-NEXT-PORTION-FROM-STACK . GO TO 120 /50 CONTINUE 0C 1 ELSE 2C 3 SORTED=.TRUE. 4C 5 ENDIF 6C 7 ENDIF8C 9C ENDTO : GOTO 5 ;C <C =C *************************************************** >C TO PARTITION-THE-ARRAY ?C @60 I=M A J=N B K= (M+N)/2 CC DC UNTIL (I.GE.J) E70 IF(I.GE.J) GO TO 20 \70 IF(I.GE.J) GO TO 110 FC GC LOCATE ITEM AT I END THAT SHOULD GO TO J END HC I80 IF (KOMPAR(I,K).GT.0.OR.I.GE.N) GO TO 90 J I=I + 1 K GO TO 80 LC MC LOCATE ITEM AT J END THAT SHOULD GO TO I END NC O90 IF(KOMPAR(J,K).LT.0.OR.J.LE.M) GO TO 100 P J=J-1 Q GO TO 90 RC SC SWAP MISPOSITIONED ITEMS TC U100 IF (I.LT.J) THEN V CALL SWAP(I,J) W J=J-1 X I=I+1 YC Z ELSE IF (I.LT.K) THEN [ CALL SWAP (I,K) \ I=I+1 ]C ^ ELSE IF (J.GT.K) THEN _ CALL SWAP (J,K) ` J=J-1 aC b ENDIF c GO TO 70 dC eC END UNTILfC gC ENDTO hC iC *************************************************** jC TO PUSH-LARGEST-PARTITION-ON-STACK kC l110 LEVEL=LEVEL + 1 mC n IF(J-M.LT.N-I) THEN o MSTACK(LEVEL)=I p NSTACK(LEVEL)=N q N=J rC s ELSE t MSTACK(LEVEL)=M u NSTACK(LEVEL)=J v M=I wC x ENDIFyC zC END-TO { GOTO 30 \ GOTO 5 |C }C *************************************************** ~C TO POP-NEXT-PORTION-FROM-STACK C 120 M=MSTACK(LEVEL) N=NSTACK(LEVEL) LEVEL=LEVEL-1C C END-TO  GOTO 50 \ GOTO 5 C C *************************************************** C TO SHELL-SORT-PARTITION-OF-15-OR-LESS C 130 IF(NUM.GT.1) THEN NUM=NUM/2 K=N-NUM J=M 140 I=J 150 EXCHG=.FALSE. IF(KOMPAR(I,I+NUM).GT.0) THEN CALL SWAP(I,I+NUM) EXCHG=.TRUE. I=I-NUM C ENDIFC  IF(EXCHG.AND.I.GE.M) GO TO 150 J=J+1 IF(J.LE.K) GO TO 140 GO TO 130C ENDIF C C ENDTO GO TO 40C  END IDECP1 = IR(IREC) C IF(NEWDK) THEN CALL YADDRC(IREC) C  ELSE IF(IDEC(IDECP1+1).EQ.NM) THENC this record belongs to this mod IF(LTYPE.EQ.1) THEN RDDK 3/22/82. SUBROUTINE RDDK(NA,NDECK) C C READ DECK IN FROM LIBRARY FILE C *CA PARAMA *CA DECKS *CA DECI C .*IF I4  INTEGER*4 NW.*ENDIF C LU= LOCF(NDECK) LO=LOCB(NDECK) NW=ISDEC(NA) NBLKS=NBLOK(NDECK) NR=LO  DO 100 I=1,NBLKS CALL RDPL1(LU,NR,IDEC(NW))  NR=NR+1  NW=NW+NWRDBK 100 CONTINUE  CALL STATIS(2,NW+NWRDBK)  RETURN  END INCRD=INLOC(IN) RDINP 3/22/82 f`\ZYRHEC SUBROUTINE RDINP(LI,IT,IWID)C C READ ONE RECORD FROM INPUT FILE "LI" INTO BUF C OUTPUTS-C IT - DIRECTIVE TYPE ( 0 IF NOT DIRECTIVE) C *CA PARAMA *CA BUFA *CA PRFX  C H*CA DIRDIC H*CA DIRSTA \*CA LOGUR*CA WIDTH   10 READ(LI,11,ERR=500,END=500) IWID,BUF  11 FORMAT(Q,A)  C C BLANK OUT REMAINDER OF RECORD C  BUF(IWID+1:120)=' '10 READ(LI,11,ERR=500,END=500) BUF R10 READ(LI,11,ERR=500,END=500) BUF(1:MWIDE)Y10 READ(LI,11,ERR=500,END=500) BUF(1:MAXWID) `10 READ(LI,11,ERR=500,END=500) BUF(1:MWIDE) f INRCN=INRCN+1 11 FORMAT(A)  DO 20 IWID=120,2,-1 R DO 20 IWID = MWIDE,2,-1 Y IF(BUF(MWIDE+1:MAXWID).EQ.' ') THEN Y MMWIDE=MWIDE Y ELSE Y MMWIDE=MAXWID Y ENDIF YC Y DO 20 IWID = MMWIDE,2,-1 ` DO 20 IWID = MWIDE,2,-1  IF(BUF(IWID:IWID).NE.' ') GOTO 30 20 CONTINUE  IWID=1 30 CONTINUE*IF VAX C  CALL VAXMOD(IWID) C *ENDIF Y IF(IWID.GT.MWIDE) THEN Y PRINT 61,'Input record is too wide - it will be shortened' Y 61 FORMAT(1X,A) Y PRINT 61, 'From -' Y ISPRT=1 Y62 PRINT 61, BUF(ISPRT:MIN0(IWID,ISPRT+78)) Y ISPRT=ISPRT+79 Y IF(ISPRT.LT.IWID) GOTO 62YC Y PRINT 61, 'To -' Y ISPRT=1 Y68 PRINT 61, BUF(ISPRT:MIN0(MWIDE,ISPRT+78)) Y ISPRT=ISPRT+79 Y IF(ISPRT.LT.MWIDE) GOTO 68 YC Y WRITE(LOU,61)Y 1 'Input record is too wide - it will be shortened' Y WRITE(LOU,61) 'From -' Y WRITE(LOU,61) BUF(1:IWID) Y WRITE(LOU,61) 'To -'Y WRITE(LOU,61) BUF(1:MWIDE) Y CALL LININC(5) Y BUF(MWIDE+1:IWID)=' ' Y IWID=MWIDE Y! ENDIF C C SEE IF THE CARD CONTAINS A COMMAND C  IF(BUF(1:1) .EQ. PRFX) THEN Z IF(BUF(1:1) .EQ. PRFX.AND.BUF(2:2).NE.' ') THEN  CALL CKDIR(BUF(2:IWID),ITT) C CALL CKDIR(BUF(1:IWID),ITT)  CALL CKINP(ITT) H IF(ITT.GT.0) THEN Z IF(ITT.GT.0) THENH NODIR(ITT)=NODIR(ITT)+1 Z NODIR(ITT)=NODIR(ITT)+1 H ENDIF Z ENDIFE CALL CKINP(ITT,IWID)  ELSE  ITT = 0  ENDIF f CALL CKINP(ITT,BUF(1:IWID)) C  IT = ITT RETURN !C "C ...END OF DATA... #C $ 500 CONTINUE % IT = 999 & RETURN ' END F f 9011 FORMAT(' There were ',I5,' input errors run will', f 1 ' be terminated.') f STOP 'input errors' f ENDIF J RETURN K END IS(3)='CA' X DIRDIS(4)='C' Y DIRDIS(5)='DK' ZRDOPA 3/22/82R  SUBROUTINE RDOPA(NU,A,N)C  CHARACTER*132 A R*CA PARAMA R CHARACTER*(MAXWID) AC  NM = MIN(N,80)  READ(NU,11) A(1:NM)  11 FORMAT(A) C  IF(NM .LT. N) THEN     READ(NU,11) A(NM+1:N) R IF (N.LE.80) THEN R READ(NU,11) A(1:N) R11 FORMAT(A)R ELSE R NL = N R IS = 1 R 20 NC = MIN(NL,80) R IF = IS+NC-1 R READ(NU,11) A(IS:IF) R NL = NL- 80 R IF(NL.GT.0) THEN R IS = IS + 80 R GOTO 20 R ENDIF ENDIF  C  RETURN C  ENTRY WROPA(NU,A,N) C  NM = MIN(N,80) C  WRITE(NU,11) (A(1:NM)) C  IF(NM .LT. N) THEN  WRITE(NU,11) A(NM+1:N) R IF (N.LE.80) THEN R WRITE(NU,11) A(1:N) R ELSE R NL = N R IS = 1 R30 NC = MIN(NL,80) R IF = IS+NC-1 R WRITE(NU,11) A(IS:IF) R NL = NL- 80 R IF(NL.GT.0) THEN R IS = IS + 80 R GOTO 30 R ENDIF  ENDIF C  RETURN  END INUE % IT = 999 & RETURN ' END UNIT=NU,FILE=NAM,RECL=LENLIB,STATUS='NEW', 5 OPEN(UNIT=NU,FILERDOPL 3/22/82dZXRQE  SUBROUTINE RDOPL(NU)C C THIS ROUTINE READS OLD PROGRAM LIBRARY(NU) HEADER, C DECK DIRECTORY, AND MOD DECK DIRECTORY C C *CA PARAMA *CA DECKS *CA MODNA  *CA DECA *CA SWITCHE*CALL LOGU E*CALL BATCH R*CA WIDTH d*CA LANGC CHARACTER*8 LABL DIMENSION IFD(8),IDD(8) C C C  NBLK = 1  IDECP1=1 CALL RDPLA(NU,NBLK,IDECP1)  CALL EXAL(ADEC(IDECP1),IDECP1,LABL)  CALL EXIN(IDECP1,IFD,8)  IVERSO=IFD(1) R IF(IVERSO.GE.3) THENR IF(MWIDE.EQ.0) THEN R MWIDE = IFD(2) R ELSE R MWIDE = IFD(2)X IF(MWIDE.NE.0.AND.MWIDE.NE.IFD(2)) THEN R PRINT*,'Attempt to change width failed' R PRINT*,'Width will be ',MWIDE,' That of the OLD LIBRARY' X PRINT*,'Width will be ',IFD(2),' ( from the OLD LIBRARY)' R ENDIF X MWIDE=IFD(2) R ELSER  IF(MWIDE.EQ.0) THEN R  MWIDE = 72 R  ELSE R MWIDE = 72X IF(MWIDE.NE.0.AND.MWIDE.NE.72) THEN R PRINT*,'Old version library only allowed width of 72' R PRINT*,'An attempt to change this has been rejected' R ENDIF X MWIDE=72 R ENDIF  NDCKL=IFD(3)  NMODSL=IFD(4)  NSWSL=IFD(5) d IF (IFD(6).EQ.0 )THEN d IF(LANG.EQ.0)THEN d LANG=1 d ENDIF d IFD(6)=LANG d ELSE IF(LANG.EQ.0) THEN d LANG=IFD(6) d ENDIF d C d IF (LANG.NE.IFD(6)) THENd PRINT*,'* ERROR * (subroutine RDOPL)'d PRINT*,' attempt to change Library LANGUAGE rejected.' d LANG=IFD(6) d PRINT*,' Language is ',LANGNM(LANG) d ENDIF  IF(IVERSO.GT.1) THEN IF(IFD(7).NE.NCHRWD.OR.IFD(8).NE.NWRDBK)THEN  PRINT*,'FILE NOT WRITTEN WITH SAME PROGRAM READING'  PRINT*,NCHRWD,NWRDBK  PRINT*,IFD(7),IFD(8)  ENDIF  ENDIF !C " IF(IVERSO.GT.1) GOTO 600 # IDECP1=NWRDBK+1 $C % DO 500 N = 1,NDCKL & IF(IDECP1.GT.NWRDBK) THEN ' IDECP1=1 ( NBLK=NBLK+1 ) CALL RDPLA(NU,NBLK,IDECP1) * ENDIF+ NDCKS = NDCKS + 1 , LOCF(NDCKS)=NU - CALL EXAL(ADEC(IDECP1),IDECP1,DECK(NDCKS)) . CALL EXIN(IDECP1,ITYPE(NDCKS),1) / CALL EXAL(ADEC(IDECP1),IDECP1,DATED(NDCKS)) 0 CALL EXIN(IDECP1,LOCB(NDCKS),1) 1 IIDENT(NDCKS)=1 2 IPURGE(NDCKS)=0 3 IDECP1=IDECP1+2 4 IDECP2=ISDEC(2) 5 CALL RDPLA(NU,LOCB(NDCKS),IDECP2)6 CALL EXIN(IDECP2+2*NW8C,NBLOK(NDCKS),1) 7 500 CONTINUE 8 GOTO 8009C :C ;600 CONTINUE< NBLKS=(NDCKL*(2*NW8C+8)+NWRDBK-1)/NWRDBK = IDECP1=1 > DO 620 I=1,NBLKS ? NBLK=NBLK+1 @ CALL RDPLA(NU,NBLK,IDECP1) A IDECP1=IDECP1+NWRDBK B620 CONTINUE C IDECP1=1 D DO 680 I=1,NDCKL E NDCKS=NDCKS+1 F LOCF(NDCKS)=NU G CALL EXAL(ADEC(IDECP1),IDECP1,DECK(NDCKS)) H CALL EXAL(ADEC(IDECP1),IDECP1,DATED(NDCKS)) I CALL EXIN(IDECP1,IDD,8) J ITYPE(NDCKS)=IDD(1) K LOCB(NDCKS)=IDD(2) L NBLOK(NDCKS)=IDD(3) M IIDENT(NDCKS)=IDD(4) N IPURGE(NDCKS)=IDD(5) O680 CONTINUEPC Q800 CONTINUERC SC TC CREATE MOD DECK ARRAY UC V IDECP1=NWRDBK+1 WC X DO 1500 N = 1,NMODSLY IF(IDECP1.GT.NWRDBK) THEN Z IDECP1=1 [ NBLK=NBLK+1 \ CALL RDPLA(NU,NBLK,IDECP1) ] ENDIF ^ NMODS=NMODS+1 _ CALL EXAL(ADEC(IDECP1),IDECP1,MODNA(NMODS)) ` IF(IVERSO.LT.2) IDECP1=IDECP1+1 a CALL EXAL(ADEC(IDECP1),IDECP1,DATEM(NMODS)) b IDECP1=IDECP1+4 c IF(IVERSO.LT.2) IDECP1=IDECP1-1 d 1500 CONTINUEeC fC CREATE SWITCH ARRAY gC h IDECP1=1i NRDS=(NW8C*NSWSL+NWRDBK-1)/NWRDBK j DO 2000 N=1,NRDS k NBLK=NBLK+1 l CALL RDPLA(NU,NBLK,IDECP1) m IDECP1=IDECP1+NWRDBK n2000 CONTINUE o IDECP1=1 p DO 2100 I=1,NSWSL q NSWS=NSWS+1 r CALL EXAL(ADEC(IDECP1),IDECP1,SWITCH(NSWS)) s2100 CONTINUEt PRINT*,' SWITCHES SET FROM OLD LIBRARY',u 1 (SWITCH(N),N=1,NSWS)E PRINT2111,NDCKS,NMODS,MODNA(NMODS),DATEM(NMODS),NSWS, d PRINT 2111,LANGNM(LANG),NDCKS,NMODS,MODNA(NMODS), d 1 DATEM(NMODS),NSWS, E 1 (SWITCH(N),N=1,NSWS) E2111 FORMAT(' Old library read in.'/ Z2111 FORMAT(/,' Old library read in.'/ d A ' Library LANGUAGE is ',A/ E 1 5X,I5,' decks',5X,I5,' mods - last one = ',2A9/ E 2 5X,I5,' switches set are ',/ (20X,6A9)) E IF(BATCH) THEN E  WRITE(LOU,2111)NDCKS,NMODS,MODNA(NMODS),DATEM(NMODS),NSWS, d WRITE(LOU,2111)LANGNM(LANG),NDCKS,NMODS,MODNA(NMODS),d A DATEM(NMODS),NSWS,E 1 (SWITCH(N),N=1,NSWS) Q CALL LININC(4) E ENDIF vC w NMODOP=NMODS x CALL STATIS (1,NDCKS) y CALL STATIS (3,NMODS) z CALL STATIS (6,NSWS) { RETURN | END ICL=.TRUE. ENDIF GOTO 7000 RDOPLA 3/22/82 da\SR<8  SUBROUTINE RDOPLA(NU) C C READS OLD PROGRAM LIBRARY FILE (ASCII) C *CA PARAMA *CA DECKS *CA MODNA *CA DECA *CA SWITCH *CA LOGU  CHARACTER*132 BUF *CA BUFAR*CA WIDTH d*CA LANGC  DIMENSION IRD(5),IRM(500),IDD(500) CHARACTER*8 NAM,DATDC  CHARACTER*8 SLIB77,DECKDU C C C FILE HEADER C  READ(NU,11) SLIB77,IVER,NDCKS,NMODS,NSWSR READ(NU,11) SLIB77,IVER,MWIDEO,NDCKS,NMODS,NSWS d READ(NU,11) SLIB77,IVER,MWIDEO,NDCKS,NMODS,NSWS,LANG 11 FORMAT(A8,5I8) d11 FORMAT(A8,6I8) R IF(IVER.LT.3) THEN R NSWS = NMODS R NMODS = NDCKS R NDCKS = IWIDEO \ NDCKS = MWIDEO R IF(MWIDE .EQ.0) THEN R MWIDE = 72 R ENDIF R ENDIF R IF(MWIDE.EQ.0) THEN R MWIDE = MWIDEO R ENDIF R IF(MWIDE.NE.MWIDEO) THENR PRINT*,'New width will be used' R ENDIF C C DECK DIRECTORY C  READ(NU,21)(DECK(I),DATED(I),ITYPE(I),I=1,NDCKS) 21 FORMAT(3(2A8,I8))  READ(NU,21) (DECK(I),DATED(I),ITYPE(I),  1 IIDENT(I),IPURGE(I),I=1,NDCKS) 21 FORMAT(2(2A8,3I8)) C C MODNAME DIRECTORY C  READ(NU,35)(MODNA(I),DATEM(I),I=1,NMODS)C C SWITCHES!C " READ(NU,35)(SWITCH(I),I=1,NSWS) #35 FORMAT(10A8)$C %C DECKS &C ' DO 3000 N=1,NDCKS ( READ(NU,41) NAM,DATD,NMD )41 FORMAT(2A8,I8) * IDECP1=1+ CALL INAL(ADEC(IDECP1),IDECP1,NAM) , CALL INAL(ADEC(IDECP1),IDECP1,DATD) S CALL INAL(ADEC(IDECP1),IDECP1,DECK(N)) S CALL INAL(ADEC(IDECP1),IDECP1,DATED(N)) - IDD(1)=0 . IDD(2)=NMD / ILEN=IDECP1 0 CALL ININ(IDECP1,IDD,2) a CALL ININ(IDECP1,IDD(1),2) 1 IF(NMD.GT.0) THEN 2 READ(NU,51)(IDD(I),I=1,NMD) 3 CALL ININ(IDECP1,IDD(1),NMD) 4 ENDIF 52600 CONTINUE 6 READ(NU,51) IRD 751 FORMAT(10I8) 861 FORMAT(5I8) 9 LNA=IRD(1) : IF(LNA.EQ.0) GOTO 2900 ; NMD=IRD(5) < IRD(1)=5+NMD+(LNA+NCHRWD-1)/NCHRWD  IF(NMD.GT.0) THEN  READ(NU,51)(IRM(I),I=1,NMD)  ENDIF  READ(NU,57) BUF(1:MAXWID) R READ(NU,57) BUF(1:MWIDE)  57 FORMAT(A)   DO 60 NW=(MAXWID+NCHRWD-1)/NCHRWD,2,-1 R DO 60 NW = (MWIDE+NCHRWD-1)/NCHRWD,2,-1  IF(BUF4(NW).NE.' ') GOTO 70  60 CONTINUE NW=1 70 LNW=NW  IRD(1)=5+NMD+LNW= CALL ININ(IDECP1,IRD,5) a CALL ININ(IDECP1,IRD(1),5) > IF(NMD.GT.0) THEN ? READ(NU,51)(IRM(I),I=1,NMD) @ CALL ININ(IDECP1,IRM,NMD)a CALL ININ(IDECP1,IRM(1),NMD) A ENDIF B READ(NU,81) BUF(1:LNA) C81 FORMAT(A) D CALL INAL(ADEC(IDECP1),IDECP1,BUF(1:LNA))  DO 2700 I=1,LNW  ADEC(IDECP1)=BUF4(I)  IDECP1=IDECP1+1 2700 CONTINUE E GOTO 2600 F2900 CONTINUEG NBLKS=(IDECP1+NWRDBK-1)/NWRDBK  CALL ININ(IDECP1,0,1) H LOCF(N)=LSR I LOCB(N)=LOCLSR J NBLOK(N)=NBLKS K CALL ININ(NBLKS,ILEN,1)  CALL ININ(ILEN,NBLKS,1) L CALL WRDK(LSR,LOCLSR,1,NBLKS) M3000 CONTINUEN PRINT*,'OLD ASCII PROGRAM LIBRARY FILE READ'd PRINT*,'Library LANGUAGE is ',LANGNM(LANG) O PRINT*,'NUMBER OF DECKS= ',NDCKS 8 CALL PRSTAT P RETURN Q END IDECP1=NWRDBK+1 WC X DO 1500 N = 1,NMODSLY IF(IDECP1.GT.NWRDBK) THEN Z IDECP1=1 [ NBLK=NBLK+1 \ CALL RDPLA(NU,NBLK,IDECP1) ] ENDIF ^ NMODS=NMODS+1 _ CALL EXAL(ADEC(IDECP1),IDECP1,MODNA(NMODS)) RDPLA 3/22/82. SUBROUTINE RDPLA(NU,NBLK,N) .*IF I4  INTEGER*4 N .*ENDIF C C READ BLOCK FROM LIBRARY C (CALLED FROM SUBR THAT DOESNT HAVE ARAYS AS INTEGER) C *CA PARAMA *CA DECI CALL RDPL1(NU,NBLK,IDEC(N)) RETURN  END NW=ISDEC(NA) NBLKS=NBLOK(NDECK) NR=LO  DO 100 I=1,NBLKS CALL RDPL1(LU,NR,IDEC(NW))  NR=NR+1  NW=NW+NWRDBK 100 CONTINUE  CALL STATIS(2,NW+NWRDBK)  RETURN  END INCRD=INLOC(IN) RDPL1 3/22/82<  SUBROUTINE RDPL1(LU,N,L)C C READS ONE BLOCK FROM PROGRAM LIBRARYC [RECORD NUMBER N INTO ARRAY L] <C RECORD NUMBER N INTO ARRAY LC *CA PARAMAC  DIMENSION L(NWRDBK)  C  READ(LU'N) L  READ(LU,REC=N) L C RETURN  END  CHARACTER*8 SLIB77,DECKDU C C C FILE HEADER C  READ(NU,11) SLIB77,IVER,NDCKS,NMODS,NSWS 11 FORMAT(A8,5I8) C C DECK DIRECTORY C RDTERM 6/14/82CB= SUBROUTINE RDTERM(LI,IWID) C C READ DATA FROM TERMINAL (EDIT) C *CA PARAMA *CA BUFA*CA LOGU=C IBM CANNOT READ MORE THAN 80 CHARACTERS FROM TERMINAL B SAVE WRBAKU B LOGICAL WRBAKU,SET = CHARACTER*80 BUF80 B DATA WRBAKU /.FALSE./ = EQUIVALENCE(BUF80,BUF)  PRINT*,'?'   READ(LI,11,ERR=30,END=30) BUF = READ(LI,11,ERR=30,END=30) BUF80 11 FORMAT(A)  DO 20 IWID=120,1,-1 = DO 20 IWID=80,1,-1  IF(BUF(IWID:IWID).NE.' ') GOTO 40 20 CONTINUE 30 IWID=0 40 CONTINUE WRITE(LBO,11) BUF(1:MAX(IWID,1))B IF(WRBAKU) WRITE(LBO,11) BUF(1:MAX(IWID,1))  RETURN BC BC TO TURN ON/OFF BAKUP FILE BC B ENTRY SETBAK(SET) B C B  WRBAKU=SET B  RETURN  END  ELSE  ITT = 0  ENDIF C  IT = ITT RETURN !C "C ...END OF DATA... #C $ 500 CONTINUE % IT = 999 & RETURN ' END  RECADD 3/22/82. SUBROUTINE RECADD(IDECP,NDK,NSEQ,INREC) .*IF I4  INTEGER*4 IDECP .*ENDIF C C C ADD INPUT RECORDS INTO ARAY2 C C NSEQ - SEQUENCE NUMBER C INREC - INPUT RECORD BEING ADDEDC *CA PARAMA *CA INREC *CA DECKS *CA DATE  *CA DECA *CA BUFA*CA CONTRL  DIMENSION IRC(5)  DATA IRC /5*0/ C  CALL GETBUF(INREC,LENR)  NW=(LENR+NCHRWD-1)/NCHRWD  IRC(1)=5+NW  IRC(2)=NDK  IRC(3)=NSEQ  CALL ININ(IDECP,IRC,5)  IREC=IDECP  DO 60 I=1,NW  ADEC(IDECP)=BUF4(I)  IDECP=IDECP+1 60 CONTINUEC  IF(LSTM.AND.(NDK.NE.0)) CALL LISMOD(1,IRC,ADEC(IREC),LENR)  RETURN  END # END RECDEL 3/22/82L SUBROUTINE RECDEL(IDIR,IDNO)C C MOVES RECORD FROM ARAY1 TO ARAY2 SETTING DELETE C BYTE UP C C IDIR - THE DIRECTIVE DOING THE DELETE C *CA PARAMA *CA DECA *CA CONTRL L*CA INREC  DIMENSION IRC(5),IMD(500) EQUIVALENCE(IRC,IMD) *CA INREC C  CALL EXIN(IDECP1,IRC,5) LC test for inactive record L IF(IRC(4).NE.0) GOTO 100  LCW=IRC(1)-IRC(5)-5  IRC(1)=IRC(1)+1  IRC(4)=1  IF(IRC(5).GT.0) THEN CALL EXIN(IDECP1,IMD(7),IRC(5))  ENDIF  IRC(5)=IRC(5)+1  IMD(6)=-IDNO CALL ININ(IDECP2,IRC,5+IRC(5))  IREC=IDECP2  DO 10 I=1,LCW  ADEC(IDECP2)=ADEC(IDECP1)  IDECP2=IDECP2+1  IDECP1=IDECP1+1 10 CONTINUEC  IF(LSTM) CALL LISMOD(2,IRC,ADEC(IREC),LCW*NCHRWD) ! RETURN LC LC record is allready inactive - do nothingLC L100 CONTINUE L IDECP1=IDECP1-5 L DO 110 J=1,IRC(1) L ADEC(IDECP2)=ADEC(IDECP1) L IDECP1 = IDECP1 + 1 L IDECP2 = IDECP2 + 1 L 110 CONTINUE L RETURN " END RECMOV 3/22/82  SUBROUTINE RECMOV C C MOVES RECORD FROM ARAY1 TI ARAY2C *CA PARAMA *CA DECI C  LNX=IDEC(IDECP1) C DO 100 I=1,LNX  IDEC(IDECP2)=IDEC(IDECP1) IDECP1=IDECP1+1 IDECP2=IDECP2+1 100 CONTINUE  RETURN  END  LCW=IRC(1)-IRC(5)-5  IRC(1)=IRC(1)+1  IRC(4)=1  IF(IRC(5).GT.0) THEN CALL EXIN(IDECP1,IMD(7),IRC(5))  ENDIF  IRC(5)=IRC(5)+1  IMD(6)=-IDNORECRES 3/22/82O SUBROUTINE RECRES (IN,IDNO )C C MOVES RECORD FROM IDEC1 TO IDEC2 RESTORING DELETE BYTE C C IN - THE DIRECTIVE DOING THE RESTOREC *CA PARAMA*CA DECA *CA CONTRL *CA INREC DIMENSION IRC(5),IRM(50) EQUIVALENCE(IRC,IRM) EQUIVALENCE(LNX,IRC(1)),(INAC,IRC(4)) O EQUIVALENCE(NMD,IRC(5)) C  IREC=IDECP2  CALL EXIN(IDECP1,IRC,5)  IF(INAC.EQ.0) GOTO 900  CALL EXIN(IDECP1,IRM(7),IRC(5)) O CALL EXIN(IDECP1,IRM(7),NMD) O NWR=LNX-5-NMD O LNX=LNX+1  INAC=0  IRC(5)=IRC(5)+1 O NMD=NMD+1  IRM(6)=IDNO  CALL ININ(IDECP2,IRC(1),5+IRC(5)) O CALL ININ(IDECP2,IRC(1),5+NMD)  IREC=IDECP2  DO 100 I=1,LNX-5-IRC(5)-1 O DO 100 I=1,NWR  ADEC(IDECP2)=ADEC(IDECP1)  IDECP1=IDECP1+1  IDECP2=IDECP2+1 100 CONTINUEC  IF(LSTM) THEN  LENR=(IDECP2-IREC)*NCHRWD  CALL LISMOD(3,IRC,ADEC(IREC),LENR) O CALL LISMOD(3,IRC,ADEC(IREC),NWR*NCHRWD) ! ENDIF "C # RETURN $C %C &900 CONTINUE ' IDECP1=IDECP1-5 ( PRINT*,' (RECRES) RECORD TO BE RESTORED IS ACTIVE' ) CALL RECMOV * RETURN + END REPINC 8/03/82 H>< SUBROUTINE REPINC (BUF,IWID) <C THIS SUBROUTINE IS USED ONLY ON VAX<*IF VAX C This routine searches for legitimate INCLUDE statements C INCLUDE 'NODE::disk:[dir]name.ext'C in the BUF string and converts them to *CALL name C ( node:: cannot be used with out [dir] ) *IF VAX  *CALL PRFX CHARACTER*(*) BUF  CHARACTER APOSTROPHE*1, FILE_NAME*40, DECK_NAME*9  INTEGER INCLUDE_PTR, LEFT_APOST_PTR, RIGHT_APOST_PTR INTEGER DECK_END, DECK_BEGIN, BRACKET_PTR, COLON_PTR  INTEGER DECIMAL_PTR  INTEGER IWID  DATA APOSTROPHE /''''/   C IF THIS IS NOT A COMMENT IF (INDEX('C*D',BUF(1:1)) .EQ. 0) THEN  C IF THIS HAS AN INCLUDE STRING  INCLUDE_PTR = INDEX(BUF,'INCLUDE') IF (INCLUDE_PTR .NE. 0) THEN  C IF THIS HAS ONLY BLANKS IN FRONT OF THE INCLUDE  IF (BUF(1:INCLUDE_PTR-1) .EQ. ' ') THEN  C FIND LEFT APOSTROPHE  LEFT_APOST_PTR = INDEX(BUF,APOSTROPHE) IF (LEFT_APOST_PTR .GT. 0 .AND. ! 1 BUF(INCLUDE_PTR+6:LEFT_APOST_PTR-1) .EQ. 'E ') THEN" #C FIND RIGHT APOSTROPHE $ RIGHT_APOST_PTR = INDEX( BUF(LEFT_APOST_PTR+1:), % 1 APOSTROPHE) & 'C IF RIGHT APOSTROPHE EXISTS( IF (RIGHT_APOST_PTR .NE. 0) THEN ) RIGHT_APOST_PTR = RIGHT_APOST_PTR + LEFT_APOST_PTR * +C GET FILE AND THEN DECK NAME , FILE_NAME = BUF(LEFT_APOST_PTR+1:RIGHT_APOST_PTR-1) - .C IF NOT AN INCLUDE 'SYS$....'/ IF (INDEX(FILE_NAME,'SYS$') .EQ. 0) THEN0 1C GET DECK NAME FROM FILE NAME 2C GET DECK NAME END POINTER 3 H BRACKET_PTR = INDEX(FILE_NAME,']')4 DECIMAL_PTR = INDEX(FILE_NAME,'.')H DECIMAL_PTR = INDEX(FILE_NAME(BRACKET_PTR+1:),'.')H IF(DECIMAL_PTR.GT.0) THEN H DECIMAL_PTR = DECIMAL_PTR+BRACKET_PTR H ENDIF H 5 6 IF (DECIMAL_PTR .GT. 0) THEN 7 DECK_END = DECIMAL_PTR-1 8 ELSE 9 DECK_END = RIGHT_APOST_PTR - LEFT_APOST_PTR - 1 : ENDIF ; <C GET DECK NAME BEGINNING POINTER = > BRACKET_PTR = INDEX(FILE_NAME,']')? IF (BRACKET_PTR .EQ. 0) THEN @C NO RIGHT BRACKET, LOOK FOR COLONA COLON_PTR = INDEX(FILE_NAME,':')B C IF (COLON_PTR .EQ. 0) THEN DC NO RIGHT BRACKET/COLON, USE NAME THAT'S THERE E DECK_BEGIN = 1 F ELSEGC COLON BUT NO RIGHT BRACKET, START AT COLONH DECK_BEGIN = COLON_PTR + 1 I ENDIF J K ELSE LC START AT RIGHT BRACKET M DECK_BEGIN = BRACKET_PTR + 1 N ENDIF O P DECK_NAME = FILE_NAME(DECK_BEGIN:DECK_END)Q RC ASSEMBLE NEW LINE S BUF = PRFX // 'CALL '// DECK_NAME T IWID = DECK_END - DECK_BEGIN + 7 U V ENDIF W X ENDIF Y Z ENDIF [ \ ENDIF ] ^ ENDIF _ ` ENDIF a b*ENDIF c RETURN d END CALL INAL(ADEC(IDECP1),IDECP1,DATE) e CALL WRDK(LSR,LOCLSR,1,NBLKS) H CALL WRPLA(LSR,LOCDCK,1) f NBLOK(INSL)=NBLKS g9000 CONTINUE h RETURVAL 3/22/82RJ  FUNCTION RVAL(ARG) C C RETURN THE REAL VALUE OF THE LEFT JUSTIFIED CHARACTER C ARGUMENT.C  LOGICAL FRACT,DONE  CHARACTER*10,ARG J CHARACTER*10 ARG R CHARACTER*(*) ARG C R LARG = LEN(ARG) NCHR=0 AMULT=0.1 SGN=+1.0 RVAL=0.0 FRACT=.FALSE.  DONE=.FALSE.C C WHILE(NCHR.LT.10) C  10 NCHR=NCHR+1  JVAL=INDEX('0123456789.-',ARG(NCHR:NCHR))  IF(JVAL.GT.0)THEN  IF(JVAL.LE.10)THEN  JVAL=JVAL-1  IF(.NOT.FRACT)THEN RVAL=RVAL*10.0+JVAL  ELSE  RVAL=RVAL+AMULT*JVAL  AMULT=AMULT*0.1  ENDIF C  ELSE IF (JVAL.EQ.11)THEN R ELSE IF (JVAL.GT.LARG)THEN  FRACT=.TRUE. ELSE ! SGN=-1.0 " ENDIF# ELSE $ DONE=.TRUE. % ENDIF &C ' IF(.NOT.DONE.AND.NCHR.LT.10) GO TO 10 R IF(.NOT.DONE.AND.NCHR.LT.LARG) GO TO 10 (C )C WHILE END *C + RVAL=RVAL*SGN , RETURN - END  READ(NU,35)(MODNA(I),DATEM(I),I=1,NMODS)C C SWITCHES!C " READ(NU,35)(SWITCH(I),I=1,NSWS) #35 FORMAT(10A8)$C %C DECKS &C ' DO 3000 N=1,NDCKS SCAN1 3/22/82 CA SUBROUTINE SCAN1(AIN,AOUT,NWD) C SUBROUTINE SCAN1(AIN)C C THIS SCANNER ALLOWS BLANK AND COMMA AS DELIMETERS C PASSES DECIMAL POINT THRU C PUTS EQUAL SIGN IN SEPARATE WORDC  CHARACTER*(*) AIN CHARACTER*20 AOUT(40) C*CALL SCAN C CHARACTER*5 ATYPCC C ATYP = '==, !' CC C10 CONTINUE CC  C LENI=LEN(AIN) NWRD=1 NCHR=0  AOUT(1)=' ' C  DO 100 I=1,LENI  ITYP=INDEX('=, ()',AIN(I:I))  IF(ITYP.GT.0) THEN  IF(ITYP.LT.2) THEN IF(NCHR.NE.0) THEN  NWRD=NWRD+1  IF(NWRD.GT.40) GOTO 150  ENDIF  AOUT(NWRD)=AIN(I:I)  NWRD=NWRD+1  IF(NWRD.GT.40) GOTO 150  NCHR=0  AOUT(NWRD)=' '  ELSE IF (ITYPE.GT.4) THEN  GOTO 150  ENDIF  IF(NCHR.EQ.0) GOTO 100  NWRD=NWRD+1 ! NCHR=0" IF(NWRD.GT.40 ) GOTO 150 # AOUT(NWRD)=' ' $ ELSE % NCHR=NCHR+1 & IF(NCHR.LE.40) AOUT(NWRD)(NCHR:NCHR)=AIN(I:I) A IF(NCHR.LE.20) AOUT(NWRD)(NCHR:NCHR)=AIN(I:I) ' ENDIF (100 CONTINUE )150 CONTINUE * NWD=NWRD+ IF(NCHR.EQ.0) NWD=NWRD-1 , RETURN C ITYP=INDEX( ATYP, AIN(I:I)) C IF(ITYP.EQ.0) THEN C C legal character for word C NCHR=NCHR+1 C IF(NCHR.EQ.1) ISS(NWRD)=I C ISL(NWRD)=NCHRCC C ELSEIF (ITYP.LT.3) THEN CC equal sign = (or period . for scan2) put in separate word C IF(NCHR.NE.0) THENC IF(NWRD.GT.71) GOTO 150 C NWRD=NWRD+1 C ENDIF C ISS(NWRD)=I C ISL(NWRD)=1 C NCHR=1C IF(NWRD.GT.71) GOTO 150 C NWRD=NWRD+1 C NCHR=0C ELSEIF (ITYP.LT.5) THEN CC comma or blank break word C IF(NCHR.GT.0) THEN C NCHR=0 C IF(NWRD.GT.71 ) GOTO 150 C! NWRD=NWRD+1 C" ENDIF C# ELSE C$C exclamation mark ! end of scan C% GOTO 150 C& ENDIF C'100 CONTINUE C(150 CONTINUEC)C C* IF(NCHR.EQ.0) THEN C+ NWRD=NWRD-1 C, ENDIF C- RETURN C.C C/C C0 ENTRY SCAN2 (AIN) C1C C2C THIS SCANNER ALLOWS BLANK AND COMMA AS DELIMETERS C3C PUTS DECIMAL POINT IN SEPARATE WORD C4C PUTS EQUAL SIGN IN SEPARATE WORDC5C C6C C7 ATYP = '.=, !' C8 GOTO 10 C9C - END l DIRDIL(6)='DEFINE' m DIRDIL(7)='DELETE' n DIRDIL(8)='EDIT' o DIRDIL(9)='ENDIF' SCAN2 3/22/82A SUBROUTINE SCAN2(AIN,AOUT,NWD) C C THIS SCANNER ALLOWS BLANK AND COMMA AS DELIMETERS C PUTS DECIMAL POINT IN SEPARATE WORD C PUTS EQUAL SIGN IN SEPARATE WORDC  CHARACTER*(*) AIN  CHARACTER*20 AOUT(40)  C LENI=LEN(AIN) NWRD=1 NCHR=0 AOUT(1)=' ' C  DO 100 I=1,LENI  ITYP=INDEX('.=, ()',AIN(I:I))  IF(ITYP.GT.0) THEN  IF(ITYP.LT.3) THEN IF(NCHR.NE.0) THEN  NWRD=NWRD+1  IF(NWRD.GT.40) GOTO 150  ENDIF  AOUT(NWRD)=AIN(I:I)  NWRD=NWRD+1  IF(NWRD.GT.40) GOTO 150  NCHR=0  AOUT(NWRD)=' '  ELSE IF(ITYP.GT.5) THEN  GOTO 150  ENDIF  IF(NCHR.EQ.0) GOTO 100 NWRD=NWRD+1 ! NCHR=0" IF(NWRD.GT.40 ) GOTO 150 # AOUT(NWRD)=' ' $ ELSE % NCHR=NCHR+1 & IF(NCHR.LE.40) AOUT(NWRD)(NCHR:NCHR)=AIN(I:I) A IF(NCHR.LE.20) AOUT(NWRD)(NCHR:NCHR)=AIN(I:I) ' ENDIF (100 CONTINUE )150 CONTINUE * NWD=NWRD + IF(NCHR.EQ.0) NWD=NWRD-1 , RETURN - END SRTMOD 3/22/82. SUBROUTINE SRTMOD(NDECK,IDKDIR) C C SORT MODS FOR DECK NDECKC *CA PARAMA *CA MODKEY *CA INREC *CA INISO  C C .*IF I4  INTEGER*4 LOC1,LOC2 .*ENDIF EXTERNAL KOMMOD,SWAMOD  C NOMODS=0 100 IF(IDKDIR.GT.NINSO) GOTO 2000  IF(INIDK(IDKDIR).NE.NDECK) GOTO 2000C C DECK DIRECTIVE IS NDECK C 1000 CONTINUEC C NEDRC NOW POINTS TO INITIAL SORTC ARAYS FOR DECK CARD FOR THE DECK C IN WORK ARAYC C FIND SUBSEQUENT MODS TO NDECK C  IDIR=INICD(IDKDIR)+1 1100 ITP=INTYP(IDIR) C C WE WILL STORE FOLLOWING DIRECTIVE TYPES IN MOD ARAY C 7 -DELETE C 12 - INSERT C 14 - RESTORE!C "C # IF(ITP.EQ.7.OR.ITP.EQ.12.OR.ITP.EQ.14) GOTO 1400 $ IDKDIR=IDKDIR+1 % GOTO 100&C 'C STORE DIRECTIVE (C )1400 CONTINUE* CALL LOCREC (NDECK,IDIR,LOC1,LOC2) + IF(LOC1.EQ.0) GOTO 1500 , NOMODS=NOMODS+1 - MODIN(NOMODS)=IDIR . MODRC1(NOMODS)=LOC1 / MODRC2(NOMODS)=LOC2 0C 11500 IDIR=IDIR+1 2 IF(IDIR.LE.NDIR) GOTO 1100 3 IDKDIR=IDKDIR+1 4 GOTO 1005C 6C END OF MODS FOR THIS DECK 7C 82000 CONTINUE9C : IF(NOMODS.GT.0) THEN; CALL STATIS( 5,NOMODS) < CALL QIKSRT(1,NOMODS,KOMMOD,SWAMOD) = ENDIF > RETURN ? END NDCKS+1 4 ENDIF 5 NDCKS = NDCKS+1 6 CALL STATIS (1,NDCKS) ! PRINT*,' ADDING DECK ',DCKNAM ! WRITE(LOU,131)DCKNAM!131 FORMAT(1STATIS 3/22/82 ZX<  SUBROUTINE STATIS (M,N) C C KEEPS STATISTICS FOR RUNC C M = TYPE OF STATISTIC (1-7) C N = NUMBER C *CA PARAMA *CA LOGU *CA CONTRL *CA DECKS  *CA MODNA  C  DIMENSION NUSTAT (7),MXSTAT(7)  CHARACTER*8 IDA(6)  CHARACTER*2 ITP(6)  DIMENSION NASTAT(7)  CHARACTER*8 NASTAT  DATA NASTAT /'MAXDCK','MAXWRD','MAXMNA','MAXMDK',  1 'MAXMDD','MAXSWI','MAXDRR'/  DATA NUSTAT /7*0/ C  NUSTAT(M)=MAX(NUSTAT(M),N)  RETURN C C  ENTRY PRSTATC C C  IF(LSTS) THEN  CALL HEADER('LIBRARY STATISTICS')! WRITE(LOU,111) 'DECKS' "111 FORMAT(6X,A) # WRITE(LOU,111)' (#=PURGED, *=COMMON)' $ CALL LININC(2) < ID=0 % DO 200 I=1,NDCKS & ID=ID+1 ' IDA(ID)=DECK(I)( IF(ITYPE(I).NE.0) THEN ) ITP(ID)=' *' * ELSE + ITP(ID)=' ' , ENDIF - IF(IPURGE(I).NE.0) THEN . ITP(ID)(1:1)='#' / ENDIF 0 IF(ID.GT.4) THEN 1 WRITE(LOU,121) (ITP(J),IDA(J),J=1,5)2121 FORMAT(5(6X,2A))3 CALL LININC(1) 4 ID=0 5 ENDIF 6200 CONTINUE 7 IF(ID.GT.0) THEN 8 WRITE(LOU,121) (ITP(I),IDA(I),I=1,ID) 9 CALL LININC(1) : ENDIF;C < WRITE(LOU,111)' ' = WRITE(LOU,111)' '> WRITE(LOU,111)'MODIFICATIONS' ? WRITE(LOU,111)' ' @ CALL LININC(4) A DO 300 I=1,NMODS,6 B WRITE(LOU,131)(MODNA(L),L=I,MIN(I+5,NMODS)) C131 FORMAT(6(6X,A)) X DO 300 I=1,NMODS,5 X WRITE(LOU,131)(MODNA(L),L=I,MIN(I+4,NMODS)) X131 FORMAT(5(8X,A)) D CALL LININC(1) E300 CONTINUE F ENDIF GC HC I MXSTAT(1)=MAXDCK J MXSTAT(2)=MAXWRD K MXSTAT(3)=MAXMNA L MXSTAT(4)=MAXMDK M MXSTAT(5)=MAXMDD N MXSTAT(6)=MAXSWI O MXSTAT(7)=MAXDRRP PRINT 11,(NASTAT(I),NUSTAT(I),MXSTAT(I),I=1,7) Q11 FORMAT(' STATISTICS FOR RUN'/ R 1 (1X,A8,2I6)) S IF(ICL) THEN Z CALL SUBHED(10) T WRITE(LOU,111)' ' U WRITE(LOU,111)' ' V WRITE(LOU,111)'RUN STATISTICS' W WRITE(LOU,111)' ' X WRITE(LOU,111)' ' Y CALL LININC(5) Z WRITE(LOU,21)(NASTAT(I),NUSTAT(I),MXSTAT(I),I=1,7) [21 FORMAT(10X,A8,2I6) \ ENDIF ] RETURN ^ END NDCKS=NDCKS+1 F LOCF(NDCKS)=NU G CALL EXAL(ADEC(IDECP1),IDECP1,DECK(NDCKS)) H CALL EXAL(ADEC(IDECP1),IDECP1,DATED(NDCKS)) I CALL EXIN(IDECP1,IDD,8) J ITYPE(NDCKS)=IDD(1) K LOCB(NDCKS)=IDD(2) L NBLOK(NDCKS)=IDD(3) M IIDENPUPDAT 3/09/83  SUBROUTINE PUPDAT(IN) C C Update the file - remove all deleted records from all C The decks - remove all mods (except the current one) C Remove all purged decksC *CA PARAMA *CA LOGU *CA CONTRL  *CA DATE *CA MODNA  *CA DECKS  *CA DECIC  CHARACTER*8 ADUMC  MODNA(1)=MODNA(NMODS)  DATEM(1)=DATE  NMODS=1 C  NDCKSO=NDCKS  NDCKS=0  DO 5000 N=1,NDCKSO  IF(IPURGE(N).NE.0) GOTO 5000  NDCKS=NDCKS+1  CALL RDDK(1,N) C C Start OLD and NEW decksC  IDECP1=1  IDECP2=ISDEC(2)  C !C transfer NAME and DATE "C # DO 400 I=1,NW8C*2$ IDEC(IDECP2)=IDEC(IDECP1) % IDECP2=IDECP2+1 & IDECP1=IDECP1+1 '400 CONTINUE (C )C Bypass Length of deck and get number of mods *C Then bypass mods +C , IDECP1=IDECP1+1 - NMOD=IDEC(IDECP1). IF(NMOD.EQ.0) GOTO 2000 / IDECP1=IDECP1+1+NMOD 0C 1C Leave room for length of deck 2C 3 IDECP2=IDECP2+1 4C 5C New deck doesn't have any mods 6C 7 IDEC(IDECP2)=0 8 IDECP2=IDECP2+1 9C :C Begin record processing loop ;C < NSEQ=1 =C >500 CONTINUE ? LNX=IDEC(IDECP1) @ IF(LNX.EQ.0) GOTO 1000 A IF(IDEC(IDECP1+3).GT.0) THEN B IDECP1=IDECP1+LNX C GOTO 500 D ENDIFEC F ISR=IDECP1+5+IDEC(IDECP1+4) G IER=IDECP1+LNX-1 HC I IDEC(IDECP2)=IER-ISR+1+5 J IDEC(IDECP2+1)=0 K IDEC(IDECP2+2)=NSEQ L NSEQ=NSEQ+1 M IDEC(IDECP2+3)=0 N IDEC(IDECP2+4)=0 OC P IDECP2=IDECP2+5 QC RC S DO 600 I=ISR,IER T IDEC(IDECP2)=IDEC(I) U IDECP2=IDECP2+1 V600 CONTINUE W IDECP1=IDECP1+LNXXC Y GOTO 500 ZC [C END OF DECK\C ]1000 CONTINUE ^ IDEC(IDECP2)=0 _ CALL STATIS(2,IDECP2)` NBLKS=(IDECP2+1-ISDEC(2)+NWRDBK-1)/NWRDBKa IDEC(ISDEC(2)+2*NW8C)=NBLKS b LOCF (NDCKS)= LSR c LOCB (NDCKS)= LOCLSR d NBLOK (NDCKS)= NBLKSe CALL WRDK(LSR,LOCLSR,2,NBLKS) f GOTO 3000gC hC If no mods are deleted the following are processed iC j2000 LOCF (NDCKS)= LOCF(N) k LOCB (NDCKS)= LOCB(N) l NBLOK (NDCKS)= NBLOK(N) mC nC If mods are deleted process the following oC p3000 DECK (NDCKS)= DECK(N) q DATED (NDCKS)= DATED(N) r ITYPE (NDCKS)= ITYPE(N) s IIDENT (NDCKS)= 1 t IPURGE (NDCKS)= 0 u5000 CONTINUE vC w RETURN x END PRENAM 5/03/82* PRESTO 3/22/82/PROC3 3/22/822 PROC4 3/22/82?QIKSRT 3/22/82DRDDK 3/22/82RRDINP 3/22/82TRDOPA 3/22/82YRDOPL 3/22/82^RDOPLA 3/22/82UCASE 9/22/83 SUBROUTINE UCASE(AIN,AOUT) C C Capitalizes string AIN and puts it in AOUT C  CHARACTER*(*) AIN, AOUT  CHARACTER*26 LOW,CAPC  DATA LOW /'abcdefghijklmnopqrstuvwxyz'/  DATA CAP /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/  C AOUT=AIN C DO 10 I = 1 , LEN(AIN)  L = INDEX(LOW,AIN(I:I))  IF(L.NE.0) AOUT(I:I)=CAP(L:L) 10 CONTINUE  RETURN  END TS 3/22/826LOGU 3/22/827MODCOM 3/22/82:MODKEY 3/22/82;MODNA 3/22/82VAXMOD 3/22/82 YRA%$!  SUBROUTINE VAXMOD(IWID) C THIS PROGRAM TURNS TABS INTO PROPER C NUMBER OF TABS AND CHANGES 'INCLUDES' INTO $CALLS C AND REPLACES CONTINUATION TAB/NU INTO COLUMN 6 NUMBER C *IF VAX *CA PARAMA *CA BUFA *CA PRFX !*CA LOGUR*CA WIDTH CHARACTER*(MAXWID) B C C ON THE VAX A TAB IS A 9  C AND AN APSOTROPHE IS A 39 C WHEN USING ICHAR AND CHAR C  DATA IPOS,ITAB /39,9/ C  M=IWID  IF(INDEX(BUF(1:M),'INCLUDE').EQ.0) GOTO 100 JJ=INDEX(BUF(1:M),'INCLUDE')  DO 10 IS=JJ+8,IWID C C CHECK FOR APOSTROPHYC  IF(ICHAR(BUF(IS:IS)).EQ.IPOS) GOTO 20 10 CONTINUE  GOTO 10020 DO 30 IF=IS+3,IWID !20 DO 30 IF=IWID,IS+3,-1  IF(ICHAR(BUF(IF:IF)).EQ.IPOS) GOTO 40 30 CONTINUE  GOTO 100 40 CONTINUE! BUF(1:IS)=PRFX//'CA' " BUF(IF-4:IF)=' ' ! IS=JJ+7 ! IE=IF-1 ! DO 50 I=IE,JJ+8,-1 ! IF(ICHAR(BUF(I:I)).EQ.IPOS) THEN ! IS=I+1 ! GOTO 60 !  ELSE IF(INDEX(']:',BUF(I:I)).NE.0) THEN !  IS=I+1 !  GOTO 60 !  ELSE IF(BUF(I:I).EQ.'.') THEN !  IE=I-1 ! ENDIF !50 CONTINUE !60 N=5+IE-IS ! B(1:N)=PRFX//'CA '//BUF(IS:IE) ! GOTO 310#C $C ELIMINATES TABS %C & 100 CONTINUE % DATA ITAB /9/ %C %C ELIMINATES TABS %C ' J=1 ( N=0 ) M=IWID *C THE FOLLOWING IS A CHECK FOR 'TAB' + IF(ICHAR(BUF(1:1)).EQ.ITAB.AND. , 1 INDEX('123456789',BUF(2:2)).NE.0) THEN- B(1:9)=' '//BUF(2:2)//' ' $ B(1:8)=' '//BUF(2:2)//' ' . N=9 $ N=8 / J=3 0 ENDIF 1 DO 300 I=J,M2 IF(ICHAR(BUF(I:I)).EQ.ITAB) THEN3200 IF(N.GE.MAXWID) GOTO 260 R200 IF(N.GE.MWIDE) GOTO 260 4 N=N+1 Y200 N=N+1 5 B(N:N)=' '6 IF(MOD(N,8).NE.0) GOTO 200 7 ELSE 8 IF(N.GE.MAXWID) THEN R IF(N.GE.MWIDE) THEN 9260 PRINT*,'VAX RECORD TOO LONG' : PRINT*,BUF ! PRINT*,BUF(1:IWID) ; PRINT*,B ! WRITE(LOU,263) BUF(1:IWID),B!263 FORMAT(' VAX RECORD TOO LONG'/1X,A/1X,A) ! CALL LININC(3) < GOTO 310 = ENDIF > N=N+1 ? B(N:N)=BUF(I:I) @ ENDIF A 300 CONTINUE B310 CONTINUE A IF(N.LT.MAXWID) THEN R IF(N.LT.MWIDE) THEN C B(N+1:MAXWID)=' ' R B(N+1:MWIDE) = ' ' DC A ENDIF E BUF = B FC G IWID=N %C %C REPLACE LEGIT INCLUDES WITH *CALL comdeck name %C % CALL REPINC( BUF, IWID )H*EI I RETURN J END  IWNAM=2 P ISW=0 Q ENDIF R ENDIF SC WRDK 3/22/82. SUBROUTINE WRDK(LU,LOCR,NS,NBLKS) C C WRITE A DECK C LU - FILE C LOCR - RECORD NO ON FILEC NS - START POINTER TO DATA C NBLKS - NO. OF BLOCKS C  *CA PARAMA  *CA DECI.*IF I4  NW=NS  INTEGER*4 NW.*ENDIF C  NW=ISDEC(NS) DO 100 I=1,NBLKS CALL WRPL1(LU,LOCR,IDEC(NW))  NW=NW+NWRDBK  LOCR=LOCR+1 100 CONTINUE  CALL STATIS(2,NW)  RETURN  END CK CARD FOR THE DECK VERSN 9/22/83ihgfed  SUBROUTINE VERSNC C Initializes the program versionC *CA IVERS  LSTMOD='MOD47 ' d LSTMOD='COBOL1 ' e LSTMOD='MOD49 ' f LSTMOD='MOD50 ' g LSTMOD='MOD51 ' h LSTMOD='MOD52 ' i LSTMOD='MOD53 '  RETURN  END LANGC R CHARACTER*(MAXWID) A  CHARACTER*8 NAMSEQ P CHARACTER*8 DCK  CHARACTER*120 DUMT R CHARACTER*(MAXWID) DUMT  DATA DUMT/' '/dWRNPL 3/22/82 dR.  SUBROUTINE WRNPL(NU)C C WRITE NEW PROGRAM LIBRARY FILE C *CA PARAMA *CA DECKS *CA MODNA *CA DECA *CA LOGU *CA SWITCH *CA IVERS R*CA WIDTH d*CA LANGC  DIMENSION IFD(8),IDD(8),IDM(4) CHARACTER*8 LABLC .*IF I4 . INTEGER*4 NR,N .*ENDIF  DATA IDD /8*0/  DATA IDM /4*0/ C C C FILE HEADER C  IDECP1=1  LABL='SLIB77 '  IFD(1)=IVERS  IFD(2)=0 R IFD(2) = MWIDE  IFD(3)=NDCKS  IFD(4)=NMODS  IFD(5)=NSWS  IFD(6)=0 d IFD(6)=LANG  IFD(7)=NCHRWD  IFD(8)=NWRDBK C  CALL INAL(ADEC(IDECP1),IDECP1,LABL) !C "C # CALL ININ(IDECP1,IFD,8) $C % NBLK=1 & CALL WRPLA(NU,NBLK,1) ' NBLK=NBLK+1 (C )C RESERVE ROOM FOR DECK HEADER*C + NWRTS=((8+2*NW8C)*NDCKS-1+NWRDBK)/NWRDBK , DO 100 N=1,NWRTS - CALL WRPLA(NU,NBLK,1) . NBLK=NBLK+1 /100 CONTINUE0C 1C MODNAME DIRECTORY 2C 3 IDECP1=1 4 DO 1500 N=1,NMODS 5 CALL INAL(ADEC(IDECP1),IDECP1,MODNA(N)) 6C 7 CALL INAL(ADEC(IDECP1),IDECP1,DATEM(N)) 8C 9 CALL ININ(IDECP1,IDM,4) :1500 CONTINUE; NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBK< NR=1 = DO 1510 I=1,NBLKS > CALL WRPLA(NU,NBLK,NR) ? NBLK=NBLK+1 @ NR=NR+NWRDBK A1510 CONTINUEBC CC SWITCHES D IDECP1=1 E DO 1580 I=1,NSWSF CALL INAL(ADEC(IDECP1),IDECP1,SWITCH(I)) G1580 CONTINUEH NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBKI NR=1 J DO 2000 I=1,NBLKS K CALL WRPLA(NU,NBLK,NR) L NBLK=NBLK+1 M NR=NR+NWRDBK N2000 CONTINUEOC PC DECKS QC R DO 3000 N=1,NDCKS S LOCN=NBLK T CALL RDDK(1,N) U NBLKS=NBLOK(N) V CALL WRDK(NU,NBLK,1,NBLKS) W LOCF(N)=NU X LOCB(N)=LOCN Y3000 CONTINUEZC [C REWRITE DECK HEADER \C ] ND=1 ^ LOCLNP=NBLK _ NBLK=2 ` IDECP1=1 a DO 5000 N=1,NDCKS b CALL INAL(ADEC(IDECP1),IDECP1,DECK(N)) c CALL INAL(ADEC(IDECP1),IDECP1,DATED(N)) dC e IDD(1)=ITYPE(N) f IDD(2)=LOCB(N) g IDD(3)=NBLOK(N) h IDD(4)=IIDENT(N) i IDD(5)=IPURGE(N) j CALL ININ(IDECP1,IDD,8) k5000 CONTINUEl NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBK m IF(NBLKS.NE.NWRTS) THEN n PRINT*,'IN WRNPL NBLKS.NE.NWRTS- IT SHOULD BE' o PRINT*,'NBLKS - ',NBLKS p PRINT*,'NWRTS - ',NWRTS q PRINT*,'NDCKS ',NDCKSr STOP'PROGRAM ERROR WRNPL' s ENDIF t N=1 u DO 5100 I=1,NBLKS v CALL WRPLA(NU,NBLK,N) w N=N+NWRDBK x NBLK=NBLK+1 y5100 CONTINUEz PRINT*,'NEW PROGRAM LIBRARY FILE WRITTEN' { RETURN | END -1)/NWRDBK  CALL ININ(IDECP1,0,1) H LOCF(N)=LSR I LOCB(N)=WRNPLA 3/22/82dSR  SUBROUTINE WRNPLA(NU) C C WRITE NEW PROGRAM LIBRARY FILE (ASCII) C *CA PARAMA *CA DECKS *CA MODNA *CA DECA *CA SWITCH *CA IVERS R*CA WIDTH d*CA LANGC  DIMENSION IDD(50), IRD(5) CHARACTER*8 NAM,DATD C C C FILE HEADER C  WRITE(NU,11) 'SLIB77 ',IVERS,NDCKS,NMODS,NSWS R WRITE(NU,11) 'SLIB77 ',IVERS,MWIDE,NDCKS,NMODS,NSWSd WRITE(NU,11) 'SLIB77 ',IVERS,MWIDE,NDCKS,NMODS,NSWS,LANG d11 FORMAT(A8,6I8) 11 FORMAT(A8,5I8) C C DECK DIRECTORY C  WRITE(NU,21)(DECK(I),DATED(I),ITYPE(I),I=1,NDCKS) 21 FORMAT(2(2A8,I8))  WRITE(NU,21) (DECK(I),DATED(I),ITYPE(I), 1 IIDENT(I),IPURGE(I),I=1,NDCKS) 21 FORMAT(2(2A8,3I8)) C C MODNAME DIRECTORY C  WRITE(NU,35)(MODNA(I),DATEM(I),I=1,NMODS) C C SWITCHESC  WRITE(NU,35)(SWITCH(I),I=1,NSWS) 35 FORMAT(10A8)!C "C DECKS #C $ DO 3000 N=1,NDCKS % IDECP1=1 & CALL RDDK(1,N) ' CALL EXAL(ADEC(IDECP1),IDECP1,NAM) ( CALL EXAL(ADEC(IDECP1),IDECP1,DATD) ) CALL EXIN(IDECP1,IDD,2) * NMD=IDD(2) + WRITE(NU,41) NAM,DATD,NMD S WRITE(NU,41) DECK(N),DATED(N),NMD ,41 FORMAT(2A8,I8) - IF(NMD.GT.0) THEN . CALL EXIN(IDECP1,IDD,NMD)/ WRITE(NU,51)(IDD(I),I=1,NMD) 0 ENDIF 151 FORMAT(10I8) 2 IDECP1=7+NMD 32600 CONTINUE 4 CALL EXIN(IDECP1,IRD,5) 5 LNX=IRD(1) 6 IF(LNX.EQ.0) GOTO 2900 7 NXT=IDECP1-5+LNX 8 WRITE(NU,51) IRD 9 NMO=IRD(5) : IF(NMO.GT.0) THEN ; CALL EXIN(IDECP1,IDD,NMO)< WRITE(NU,51)(IDD(I),I=1,NMO) = ENDIF > ISTRT=IDECP1 ? NCHRS=(NXT-ISTRT)*NCHRWD@ CALL WROPA(NU,ADEC(IDECP1),NCHRS) A IDECP1=NXT B GOTO 2600 C2900 WRITE(NU,51) LNX D3000 CONTINUEE PRINT*,'NEW ASCII PROGRAM LIBRARY FILE WRITTEN' F RETURN G END U NBLKS=NBLOK(N) V CALL WRDK(NU,NBLK,1,NBLKS) W LOCF(N)=NU X LOCB(N)=LOCN Y3000 CONTINUEZC [C REWRITE DECK HEADER \C ] ND=1 ^ LOCLNP=NBLK _ NBLK=2 WRPL1 3/22/82<  SUBROUTINE WRPL1(LU,N,L)C C WRITES ONE BLOCK TO PROGRAM LIBRARY C [RECORD NUMBER N FROM ARRAY L] <C RECORD NUMBER N FROM ARRAY LC *CA PARAMAC  DIMENSION L(NWRDBK)  C  WRITE(LU'N) L  WRITE(LU,REC=N) L  C RETURN  END R*2 ITP(6)  DIMENSION NASTAT(7)  CHARACTER*8 NASTAT  DATA NASTAT /'MAXDCK','MAXWRD','MAXMNA','MAXMDK',  1 'MAXMDD','MAXSWI','MAXDRR'/  DATA NUSTAT /7*0/ C  NUSTAT(M)=MAX(NUSTAT(M),N) WRPLA 3/22/82. SUBROUTINE WRPLA(NU,NBLK,N) .*IF I4 . INTEGER*4 N .*ENDIF C C WRITE BLOCK TO LIBRARY C (CALLED FROM SUBR THAT DOESNT HAVE ARAYS AS INTEGER) C *CA PARAMA *CA DECI CALL WRPL1(NU,NBLK,IDEC(N)) RETURN  END *IF I4 . INTEGER*4 NR,N .*ENDIF  DATA IDD /8*0/  DATA IDM /4*0/ C C C FILE HEADER C  IDECP1=1  LABL='SLIB77 '  IFD(1)=IVERS  IFD(2)=0  XDATE 3/22/82 `NKJ=:9321.' SUBROUTINE XDATE(DATE) 1 SUBROUTINE XDATE(CHDATE) C C THIS ROUTINE GETS THE CURRENT DATE FROM THE SYSTEM C AS :C IMON = MM C JDAY = DD C KYER = YY C  C AND REFORMATS IT AS THE CHARACTER STRING: 'C and returns it in DATE as MM:DD:YY 1C and returns it in CHDATE as MM/DD/YY 'C where MM=month, DD=day, YY=year  C  C 'MM/DD/YY'  C  CHARACTER*(*) DATE ' CHARACTER *8 DATE, UD1, UD2 1 CHARACTER *8 CHDATE, UD1, UD2 N CHARACTER *8 CHDATE N*IF UNIVAC N CHARACTER*8 UD1,UD2 N*ENDIF N*IF CDC : CHARACTER*10 CDCDAT N*ENDIF ' REAL*8 PRIMDY,PDUM(2) 3*IF PRIME 3 REAL*8 PRIMDY,PDUM(2),DATE$A3*ENDIF N*IF HARRIS 1 DIMENSION IHARIS(3) N*ENDIF N *IF HP1 9 DIMENSION IHP1(15) 9 CHARACTER*30 HP1CN *ENDIF .*IF I4 ' INTEGER*4 I,J,K .*ENDIF C '*IF VAX  CALL IDATE(I,J,K)C  WRITE (DATE,11) I,J,K 1 WRITE (CHDATE,11) I,J,K '*ENDIF '*IF IBM '  CALL SLDATE(I,J,K) = CALL CLDATE(I,J,K) '  WRITE(DATE,11)I,J,K 1 WRITE(CHDATE,11)I,J,K ' *ENDIF 1*IF HARRIS 1 CALL DATE(IHARIS) 1 WRITE(CHDATE,7) IHARIS(2) 1 7 FORMAT(A3) 1  MO=INDEX('JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC',DATE(1:3)) 2 MO=INDEX('JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC',CHDATE(1:3)) 1 MO=(MO/3)+1 1 WRITE(CHDATE,9) MO,IHARIS(1),IHARIS(3) 19 FORMAT(I2,'/',A2,,A3) J9 FORMAT(I2,'/',A2,'/',A2) 1 CHDATE(6:6)='/' 1*ENDIF 11 FORMAT(I2,'/',I2.2,'/',I2) C ' *IF PRIME ' PRIMDY=DATE$A(PDUM) ' WRITE(DATE,21) PRIMDY 1 WRITE(CHDATE,21) PRIMDY '21 FORMAT(A8) '*ENDIF '*IF UNIVAC ' CALL ADATE(UD1,UD2) ' DATE=UD1(1:2)//'/'//UD1(3:4)//'/'//UD1(5,6) 1 CHDATE=UD1(1:2)//'/'//UD1(3:4)//'/'//UD1(5,6) 'C '*ENDIF 9*IF HP1 9 CALL FTIME(IHP1) 9 WRITE(HP1C,31) IHP1 931 FORMAT(15A2) 9 MO=INDEX('JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC',HP1C(20:22)) 9 MO=(MO/3)+1 9 WRITE(CHDATE,33) MO,HP1C(17:18),HP1C(28:29) 9 33 FORMAT(I2,'/',A2,'/',A2) 9 *ENDIF :*IF CDC : CALL DATE(CDCDAT) : CHDATE=CDCDAT(2:9) :*ENDIF K*IF COS K CALL DATE(CHDATE) K*ENDIF `*IF DGEN ` CHDATE='NONE-YET' `*ENDIF  RETURN C  END END YADDA1 3/17/83 SUBROUTINE YADDA1(ISR,LENA) C C Performs the alfa add into YANREC so it can be written C *CA PARAMA *CA DECA CALL YADDA2(ADEC(ISR),LENA)  CALL YWRR RETURN  END C LTYPE - current type of action  YADDA2 3/17/83  SUBROUTINE YADDA2(A,NC) C C Actually does the alfa insertin for records going out C *CA PARAMA *CA YANPTR  CHARACTER*(MAXWID) A  YANREC=A(1:NC) RETURN  END C LTYPE - current type of action  YINITP 3/17/83 SUBROUTINE YINITP(IT,NREC) C C Initialize Yank control record to be writtenC C IT - Type of directive record C 1 - insert C 2 - delete C 3 - restore C  C NREC - pointer to IR() which then points to IDEC data  C  *CA PARAMA  *CA MODNA *CA EDITCO *CA DECI*CA YANPTR C  CHARACTER*4 TPREC(3) DATA TPREC /'*I ','*D ','*R '/ C  IDECP1=IR(NREC)+1  IDCK=IDEC(IDECP1)  NSQ=IDEC(IDECP1+1)  IF(IDCK.EQ.0) THEN  WRITE(YANREC,11) TPREC(IT),NSQ 11 FORMAT(A,I6)  ELSE WRITE(YANREC,13) TPREC(IT),MODNA(IDCK),NSQ 13 FORMAT(A,A,'.',I6)  ENDIF  RETURN  C !C " ENTRY YADDTP(NREC) #C $C Add second half of directive%C & IDECP1=IR(IREC)+1 ' IDCK=IDEC(IDECP1) ( NSQ=IDEC(IDECP1+1) ) IF(IDCK.EQ.0) THEN * WRITE(YANREC(20:39),21) NSQ +21 FORMAT(',',I6) , ELSE- WRITE(YANREC(20:39),23) MODNA(IDCK),NSQ .23 FORMAT(',',A,'.',I6) / ENDIF 0 RETURN 1C 2 ENTRY YADDRC(NREC) 3C 4C Add record (NREC) to file - it is an inserted record5C 6 IDECP1 = IR(NREC) 7 LNX= IDEC (IDECP1) 8 ISR = IDECP1+5+IDEC(IDECP1+4) 9 LENA = (IDECP1+LNX-ISR)*NCHRWD : CALL YADDA1(ISR,LENA) ; RETURN < END >C ?C End of mods @C A NMODD=1 B NMD=IDEC(ISMOD-1)CC start of deck records D ISDECS = ISMOD + NMD EC last mod F IEMOD = ISDECS - 1 YWRR 3/17/83  SUBROUTINE YWRR C C Writes YANREC on direct access scratch file C *CA PARAMA *CA DECI*CA LOGU*CA WIDTH  *CA YANPTR  WRITE(LSI,REC=IRECLO) YANREC(1:MWIDE) IRECLO=IRECLO+1 RETURN  C C  ENTRY YRRR (NREC) C C Read YANREC from dirrect access scratch fileC  READ(LSI,REC=NREC) YANREC(1:MWIDE)  RETURN  END  IDECP1=IR(NREC)+1  IDCK=IDEC(IDECP1)  NSQ=IDEC(IDECP1+1)  IF(IDCK.EQ.0