SLIB77 *H*sr`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 BATCH 6/14/82#BUFA 3/22/82%BUFI 3/22/82'CONTRL 3/22/82(CPLDIR 4/25/84-rCUREDT 3/22/82/DATE 3/22/820DECA 3/22/821DECI 3/22/829DECKS 3/22/82ADIRDIC 3/22/82DDIRSTA 3/22/82FEDIBKU 11/02/82GCEDIOPTS 8/31/84HEDITCO 6/14/82KERRMES 11/17/83QjFILEIDS 7/26/84RFNAMES 9/24/84WFSECOM 12/14/84YIFSWI 3/22/82_INISO 3/22/82bINPERC 10/04/83dfINREC 3/22/82eITABC 10/25/84hIVERS 3/22/82iLANGC 9/28/83jdLIMITS 3/22/82nLOGU 3/22/82oMODCOM 3/22/82wMODKEY 3/22/82xMODNA 3/22/82zNPSARG 7/26/84{PARAMA 3/22/82~ PARAMB 3/22/82PRFX 3/22/82SCAN 3/22/82SERCHC 2/28/85SEPCOM 3/13/85SEPFIC 9/24/84SEQCTL 3/08/83RSWITCH 3/22/82TYPDCK 3/22/82UPDATC 2/28/85WIDTH 3/08/83RYANDEC 3/17/83VYANKC 2/28/85YANPTR 3/17/83VMAIN 3/22/82CKDIR 3/22/82CKDKMC 3/22/82CKEDIT 6/14/82CKIF 2/13/84pCKINP 5/03/82" CKV3SW 2/13/84pCLSFIL 7/26/84COMCHC 3/22/82 COMCHD 11/19/84 COMCHK 3/22/82COMCHL 11/19/84(COMCHM 3/22/82/COMPID 4/15/823CTLCRD 3/22/826fCTLCRE 7/03/84~DELFIL 8/31/84DIRCHK 8/26/82,EDIADD 6/14/82EDIADT 6/14/82EDIBKI 12/06/84EDIBKO 12/06/84EDIBOT 6/14/82EDICHA 6/14/82EDICH1 6/14/82EDICH2 6/14/82EDICNS 11/19/84EDICON 6/14/82EDIDEL 6/14/82EDIDIR 6/14/82EDIEND 6/14/823EDIENL 11/19/84 EDIFIN 6/14/82!EDIHEL 6/14/82&&EDIHE1 6/14/82LEDIHE2 6/14/82REDIHE3 3/28/83Z XEDIINI 6/14/82ckEDIINS 6/14/82EDILIL 11/19/84EDILIS 6/14/82EDIMIN 6/14/82EDINEX 6/14/82EDIOPL 7/19/84EDIOPT 8/31/84$EDIPLS 6/23/82EDIPOS 6/14/82EDIPRI 6/14/82 EDIPRS 6/23/82"EDIPRT 6/22/82$EDIREC 6/14/82' EDIREP 6/14/821EDISER 6/14/825EDISID 6/14/827EDISWI 8/16/849EDITOP 6/14/82GEDITOR 6/14/82HEDIVMD 6/14/82dENDPRO 7/03/84k~EXAL 3/22/82nEXIN 3/22/82pFILECK 4/19/85rFILEID 7/26/84FSEADD 12/14/84FSECMD 12/14/84FSEDEL 12/14/84FSEDIT 12/14/84FSEDWN 12/14/84FSEEND 12/14/84FSEGET 12/14/84FSEHEL 12/14/849FSEIPL 12/14/84 FSELOC 12/14/84FSESCN 12/14/84 5FSETRM 12/14/84>FSEUP 12/14/84CFSEXEC 12/14/84G6GETBUF 3/22/82}GTFWD 3/22/82HEADER 3/22/82ICKDIC 3/22/82ICKGRP 8/28/84IFINDK 3/22/82IFINMD 3/22/82INAL 3/22/82INCHW 6/14/82ININ 3/22/82INITL 3/22/82.INP 3/22/82INPADD 11/22/82HINSCOL 11/19/84INSCOM 3/22/82INSGRL 11/19/84 INSGRP 8/28/84"ITRAIL 7/26/84<KOMDEC 3/22/82=KOMMOD 3/22/82?KOMYAN 3/17/83BVLISCOM 3/22/82ELISCRD 3/22/82LLISDCK 3/22/82_ LISERR 11/05/82ELISLEN 11/19/84 LISMOD 3/22/82LOCCNT 11/19/84 LOCREC 3/22/82MODDCK 3/22/82MOVCHR 12/14/84MOVDK 3/22/82NAMCHK 3/17/83UNPSEIO 7/26/84NXUNIN 3/22/82OPENER 7/26/84SOPNLNP 3/22/828-PADD 3/22/82ePDECK 3/22/82uPDEFIN 3/22/82{ PDELET 3/22/82PEDIT 3/22/82PIDENT 3/22/82PINSRT 3/22/82PMOVE 3/22/82PPURGE 3/22/82PRENAM 5/03/82 PRESTO 3/22/82PROC3 3/22/82PROC4 3/22/82PROFIL 11/20/84'PSERCH 2/13/85 PSERCX 2/13/85 PUPDAT 3/09/83#SPVLEVL 4/25/843rPYANK 3/17/839&VQIKSRT 3/22/82_RDBLKC 7/26/84{RDBLKI 7/26/84|RDDK 3/22/82}RDINP 3/22/82 RDOPA 3/22/82RDOPL 3/22/824RDOPLA 3/22/82RDPLA 3/22/82RDPL1 3/22/82RDTERM 6/14/82RDTIO 7/26/84RECADD 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/829SCANCC 9/24/84> SCANDI 9/24/84HSCANFS 12/14/84OSRTMOD 3/22/82VSTATIS 3/22/82]SWIDEF 8/16/84pTHEEND 7/26/84uTRDEC 6/04/84zzUCASE 9/22/83{cUPV3SW 2/13/84~pVAXMOD 3/22/82 VLEVEL 4/25/84rWRBLKC 7/26/84WRBLKI 7/26/84WRDK 3/22/82WRERR 11/17/83jWRMES 4/25/84rWRNPL 3/22/82WRNPLA 3/22/82 WROUT 4/25/84rWRPL1 3/22/82WRPLA 3/22/82WRSERC 2/13/85WRTIO 7/26/84XDATE 3/22/82XTIME 7/26/84YADDA1 3/17/83VYADDA2 3/17/83VYINITP 3/17/83VYWRR 3/17/83VVERSN 9/22/83c OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,FILE=FNAME, f $ FORM=TFORM,ERR=100) g ENDIF 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/83MOD54 11/17/83MOD55 12/08/83MOD56 12/16/83MOD57 12/19/83MOD58 1/23/84MOD59 1/27/84MOD60 2/13/84MOD61 2/29/84WAPA62 4/25/84WAPA63 4/25/84WAPA64 4/27/84WAPA65 5/07/84WAPA66 5/10/84WAPA67 5/22/84WAPA68 5/30/84MOBIL69 5/31/84SMALL70 6/04/84WAPA71 6/06/84WAPA72 6/18/84WAPA73 7/02/84WAPA74 7/03/84WAPA75 7/19/84IPCO76 7/26/84MOD77 8/14/84MOD78 8/16/84MOD79 8/28/84IPCO80 8/31/84IPCO81 9/07/84MOD82 9/24/84WAPA83 10/03/84WAPA84 10/11/84WAPA85 10/18/84WAPA86 10/25/84WAPA87 11/19/84WAPA88 11/20/84IPCO89 11/20/84MOD90 12/06/84WAPA91 12/14/84WAPA92 1/30/85WAPA93 2/13/85MOD94 2/28/85MOD95 3/13/85MOD96 4/19/85IPCO97 4/19/85SMALL98 4/26/85PRFX99 5/03/85MOD100 5/23/85MOD101 6/26/85MOD102 6/28/85MOD103 8/02/85IPCO104 8/22/85BPA105 8/22/85MOD106 8/22/85MOD107 9/30/85UNIX108 4/17/86VAX REC4 TERM5 EDIT I4 PRIME IBM TERM1 FILEVN REC1 REC2 SALFRD UNIVAC CDC HARRIS HP1 COS DGEN TERM57 APOLLO DEC20 NC4 NW128 NC2 NC3 NC5 NC8 NC10 NW32 NW112 NW256 NW512 SMALL NPS IBMVM IBMMVS NW1024 NUMREC PROFILE FSEDIT DOCUMENTUNIX BATCH 6/14/82C s COMMON /BATC/ BATCH s LOGICAL BATCH  COMMON /BATCHC/ PMODE, TMODE CHARACTER PMODE*8, TMODE*8 C qC PMODE - PROGRAM MODE SWITCH (NOTSET,BATCH,LEDIT,FSEDIT) C PMODE - PROGRAM MODE SWITCH (NOTSET,BATCH,SLEDIT,LEDIT,FSEDIT)C TMODE - TERMINAL OUTPUT MODE (TERMINAL,BATCH) C BUFA 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/82ro pC CONTRL pC pC CONTROLS FOR RUNpC p COMMON /CTRL/ ICF, ICQ, ICLO, ICC, ICL, p 1 ICS, ICN, ICNA, ICP, ICPA o 1 , ICCD rp 1 , ICCD, ICUC pC p LOGICAL ICF, ICQ, ICLO, ICC, ICL,  p 1 ICS, ICN, ICNA, ICP, ICPA o 1 , ICCD rp 1 , ICCD, ICUC  pC  p COMMON /CTRLI/ LSTA, LSTC, LSTD, LSTE,  p 1 LSTI, LSTM, LSTS, LSTT  pC p LOGICAL LSTA, LSTC, LSTD, LSTE, p 1 LSTI, LSTM, LSTS, LSTT pC p LOGICAL ICLST(8)p EQUIVALENCE(ICLST,LSTA) C Control statement switches C Parameters --- F Q LO C L S N NA  COMMON /CTRL/ ICF, ICQ, ICLO, ICC, ICL, ICS, ICN, ICNA, n 1 ICP, ICPA, ICCD, ICUC  1 ICP, ICPA, ICCD, ICUC, ICM nC Parameters --- P PA CD UC C Parameters --- P PA CD UC M C  LOGICAL ICF, ICQ, ICLO, ICC, ICL, ICS, ICN, ICNA, n 1 ICP, ICPA, ICCD, ICUC  1 ICP, ICPA, ICCD, ICUC, ICM  C  C LO options --- A C D E I M S T COMMON /CTRLI/ LSTA, LSTC, LSTD, LSTE, LSTI, LSTM, LSTS, LSTT  LOGICAL LSTA, LSTC, LSTD, LSTE, LSTI, LSTM, LSTS, LSTT C R . ENDIF /100 CONTINUE0C 1o150 IF (NCHR .EQ. 0) NWRD = NWRD - 1 150 IF(NCHR .EQ. 0) THEN CPLDIR 4/25/84C C used for compile directives data C  COMMON /CPLDIN/ NCPLDI C C NCPLDI = number of characters in CPLDI C  COMMON /CPLDIC/ CPLDI CHARACTER*72 CPLDI C  C CPLDI = characters to be inserted into all  C directives written on compile file  C 7/832jIFSWI 3/22/823INISO 3/22/826INPERC 10/04/838fINREC 3/22/829IVERS 3/22/82<LANGC 9/28/83=dLIMITS 3/22/82?LOGU 3/22/82CUREDT 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/82z. nC DECA.CMNnC nC WORK DECK ARAYS - CHARACTER nC USED TO READ DECK INTO AND MODIFY DECK FROM nC n COMMON /ADEC/ ADEC(MAXWRD) n CHARACTER*(NCHRWD) ADEC n COMMON /DECS/ ISDEC(2)  nC  INTEGER*4 IDECP1,IDECP2 .n*IF I4 . INTEGER*4 IDECP1,IDECP2,ISDEC zn INTEGER*4 IDECP1, IDECP2, ISDEC, IDECPT .n*ENDIF   COMMON /DECP/ IDECP1,IDECP2 zn COMMON /DECP/ IDECP1, IDECP2, IDECPT  INTEGER*4 ISDEC  nC C C work dec arrays - character - note there is DECI with integer C used to store decks into during processingC  COMMON /ADEC/ ADEC(MAXWRD)  CHARACTER*(NCHRWD) ADEC *IF DOCUMENTC  C  C work deck array pointers  C  C MAXDCM - number of decks which can be in memory  mC NDKMEM - number of decks currently in memory C NDKMEL - number of decks currently in lower memory C NDKMEU - number of decks currently in upper memory mC MEMDCK - deck number of deck in memory C MEMDCL - deck number of deck in lower memory C MEMDCU - deck number of deck in upper memory mC MEMSTR - starting location of each deck in memoryC MEMSTL - starting location of each deck in lower memory C MEMSTU - starting location of each deck in upper memory mC MEMEND - ending location of each deck in memory mC MEMCUR - current pointer location of each deck in memory C MEMCUL - current pointer location - each deck in lower memoryC MEMCUU - current pointer location - each deck in upper memory C NCALLD - call number indicator for upper memory only C is set in RDDK to NCALL indicates when called C *ENDIF DOCUMENT m COMMON/DECPT/NDKMEM, MEMDCK(MAXDCM), MEMSTR(MAXDCM), COMMON/DECPT/NDKMEL, MEMDCL(MAXDCL), MEMSTL(MAXDCL+1), m 1 MEMEND(MAXDCM), MEMCUR(MAXDCM)  1 MEMCUL(MAXDCL), 2 NDKMEU, MEMDCU(MAXDCU), MEMSTU(0:MAXDCU),  3 MEMCUU(MAXDCU), 4 NCALLD(MAXDCU) j COMMON /DECP12/ IDECP1, IDECP2  COMMON /DECP12/ IDECP1, IDECP2, IDECPT C *IF I4 m INTEGER*4 MEMSTR, MEMEND, MEMCUR, IDECP1, IDECP2  INTEGER*4 MEMSTL, MEMSTU, MEMCUL, MEMCUU, NCALLD j INTEGER*4 IDECP1, IDECP2  INTEGER*4 IDECP1, IDECP2,IDECPT*ENDIF C 3/22/82PINSRT 3/22/82#PMOVE 3/22/82'PPURGE 3/22/82.PRENAM 5/03/826 DECI 3/22/82z. nC DECI.CMNnC nC WORK DECK ARAYS - INTEGER nC USED TO READ DECK INTO AND MODIFY DECK FROM nC n COMMON /ADEC/ IDEC(MAXWRD)  INTEGER*4 IDEC n COMMON /DECS/ ISDEC(2)  INTEGER*4 ISDEC .n*IF I4 . INTEGER*4 IDEC,ISDEC,IDECP1,IDECP2 zn INTEGER*4 IDEC, ISDEC, IDECP1, IDECP2, IDECPT .n*ENDIF nC   COMMON /DECP/ IDECP1,IDECP2 zn COMMON /DECP/ IDECP1, IDECP2, IDECPT INTEGER*4 IDECP1,IDECP2  nC C C work dec arrays - integer - note there is DECA with character C used to store decks into during processingC  COMMON /ADEC/ IDEC(MAXWRD) *IF I4  INTEGER*4 IDEC *ENDIF  *IF DOCUMENT C  C  C work deck array pointers  C C MAXDCM - number of decks which can be in memory mC NDKMEM - number of decks currently in memory C NDKMEL - number of decks currently in lower memory C NDKMEU - number of decks currently in upper memory mC MEMDCK - deck number of deck in memory C MEMDCL - deck number of deck in lower memory C MEMDCU - deck number of deck in upper memory mC MEMSTR - starting location of each deck in memoryC MEMSTL - starting location of each deck in lower memory C MEMSTU - starting location of each deck in upper memory mC MEMEND - ending location of each deck in memory mC MEMCUR - current pointer location of each deck in memory C MEMCUL - current pointer location - each deck in lower memoryC MEMCUU - current pointer location - each deck in upper memory C NCALLD - call number indicator for upper memory only C is set in RDDK to NCALL indicates when called C *ENDIF DOCUMENT m COMMON/DECPT/NDKMEM, MEMDCK(MAXDCM), MEMSTR(MAXDCM), COMMON/DECPT/NDKMEL, MEMDCL(MAXDCL), MEMSTL(MAXDCL+1), m 1 MEMEND(MAXDCM), MEMCUR(MAXDCM)  1 MEMCUL(MAXDCL), 2 NDKMEU, MEMDCU(MAXDCU), MEMSTU(0:MAXDCU),  3 MEMCUU(MAXDCU), 4 NCALLD(MAXDCU) j COMMON /DECP12/ IDECP1, IDECP2  COMMON /DECP12/ IDECP1, IDECP2, IDECPT C *IF I4 m INTEGER*4 MEMSTR, MEMEND, MEMCUR, IDECP1, IDECP2  INTEGER*4 MEMSTL, MEMSTU, MEMCUL, MEMCUU, NCALLD j INTEGER*4 IDECP1, IDECP2  INTEGER*4 IDECP1, IDECP2, IDECPT *ENDIF C #PMOVE 3/22/82'PPURGE 3/22/82.PRENAM 5/03/826 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 *IF DOCUMENT 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 *ENDIF DOCUMENT each deck in memory C *ENDIF DOCUMENT  COMMON/DECPT/NDKMEM,DIRDIC 3/22/82rC C C DIRECTIVE DICTIONARY (DIRDIS-SHORT)(DIRDIL-LONG)  PARAMETER (MAXDIR=18)   PARAMETER (MAXDIR=19) r} PARAMETER (MAXDIR=20) p PARAMETER (MAXDIR=22) o PARAMETER (MAXDIR=23)  PARAMETER (MAXDIR=24) 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 ( ENDIF)C * IDECP1=IDECP1+NMR+ LDIRSTA 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/82EDIOPTS 8/31/84C C EDITOR OPTION TABLE uC u COMMON /EDOPTS/ UCASE u LOGICAL UCASE q COMMON /EDOPTS/ UPCASE, LSTSEQ, EDICON, EDIREC  COMMON /EDOPTS/ UPCASE, LSTSEQ, EDICON, EDIREC,  $ VIEW, FZONE, LZONE  INTEGER VIEW, FZONE, LZONE  LOGICAL UPCASE, LSTSEQ, EDICON, EDIREC C C UPCASE - Upper case only from terminal (default-.FALSE.) C LSTSEQ - sequencing info on screen (default - .FALSE.) C EDICON - Continue processing (default - .FALSE.) C EDIREC - Recovery processing (default - .FALSE.) C VIEW - FIRST COLUMN TO BE DISPLAYED AT TERMINAL C FZONE - FIRST COLUMN IN SOURCE TO BE SEARCHED C LZONE - LAST COLUMN IN SOURCE TO BE SEARCHED C EDITCO 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  1 , CHANGE, RCOUNT, COLPNT C  INTEGER CHANGE, RCOUNT, COLPNT .*IF I4  INTEGER*4 IDECPN.*ENDIF C qC IDECPN - NEXT WORD TO BE USED IN ADEC ARAYS qC IDECE - DECK NUMBER BEING EDITEDqC IREC - CURRENT RECORD POINTER qC NRECI - NUMBER OF RECORDS INITIALLY qC NRECT - NUMBER OF RECORDS CURRENTLY (TOTAL) qC qC IDECI - LENGTH OF DECK ARAY INITIALLY C IDECPN - NEXT WORD TO BE USED IN ADEC ARAYS C IDECE - DECK NUMBER BEING EDITED C IREC - Current record pointer C NRECI - Number of records initially (active and inactive) C NRECT - Number of records currently (active and inactive)  C IDECI - Length of deck arrays initially C CHANGE - Number of changes made to the deck  C RCOUNT - Number of active records in the deck  C COLPNT - Column pointer for the current record C uC u COMMON /EDILOG/ LSTSEQ u LOGICAL LSTSEQ uC uC LSTSEQ - SWITCH FOR LISTING OF SEQUENCE INFO ON TERMINAL(EDIT) uC .FALSE. (DEF) DONT PRINT SEQ. INFO uC .TRUE. DO LIST SEQ. INFO uC ERRMES 11/17/83C C ERRMSG = error message to be printed (written) C  COMMON /ERRMES/ ERRMSG  CHARACTER*132 ERRMSGC MOD7N 4/30/82MOD7I 5/03/82MOD8A 5/03/82MOD8B 5/03/82MOD8C 5/05/82MOD8D 5/06/82MOD8E 5/06/82FILEIDS 7/26/84  PARAMETER (MAXFIL=8)C C FILE ID COMMON BLOCK C  COMMON /FILIDN/ EXIST(MAXFIL) z COMMON /FILIDC/  COMMON /FILIDC/ PREID(MAXFIL), POSTID(MAXFIL) *IF IBMVM z $ RDISK, WDISK,  $ ,RDISK, WDISK  *ENDIF  z $ MACHID(MAXFIL), DIRTID(MAXFIL), FTYPE(MAXFIL),  z $ POSTID(MAXFIL)  C  z CHARACTER MACHID*20, DIRTID*20, FTYPE*20, POSTID*20  CHARACTER PREID*30, POSTID*30 z CHARACTER*3 SEQ,DIRECT,FORMAT,UNFORM *IF IBMVM  CHARACTER RDISK*3, WDISK*3 *ENDIF  INTEGER EXIST C C C NAME TYPE DESCRIPTION C ------ ---- ----------- C MACHID CHAR IDENTIFIES MACHINE OR ACCOUNTING GROUP. C DIRTID CHAR IDENTIFIES USER DIRECTORY.C FTYPE CHAR FILETYPE OR EXTENSION.C POSTID CHAR VERSION NUMBER OR OTHER ID REQUIRED BY SYSTEM.*IF IBMVM C RDISK CHAR READ ONLY DISK. C WDISK CHAR WRITEABLE DISK. *ENDIF C EXIST INT USED TO DETERMINE ACTION IF FILE EXISTS OR DOES  C NOT EXIST. IT HAS THREE STATES: !C -1 FILE MUST NOT EXIST AND CAN NOT BE REPLACED "C 0 FILE MAY EXIST AND WILL BE REPLACED #C 1 FILE MUST EXIST $C FNAMES 9/24/84C C filenames (and width of name)C  COMMON /FNAMEC/NAMLCO,NAMLOU,NAMLOP,NAMLIA,NAMLNP,NAMLOA,NAMLSO n 1 , NAMLBI, NAMLBO, NAMLCI 1 , NAMLBI, NAMLBO, NAMLCI, NAMLMO CHARACTER*72 NAMLCO,NAMLOU,NAMLOP,NAMLIA,NAMLNP,NAMLOA,NAMLSO n 1 , NAMLBI, NAMLBO, NAMLCI 1 , NAMLBI, NAMLBO, NAMLCI, NAMLMOC  COMMON /FNAMEW/ IWLCO, IWLOU, IWLOP, IWLIA, IWLNP, IWLOA, IWLSO n 1 , IWLBI, IWLBO, IWLCI 1 , IWLBI, IWLBO, IWLCI, IWLMO C C  COMMON /DECKA/ DECK(MAXDCK), DATED(MAXDCK)  CHARACTER*8 DECK, DATED *IF DOCUMENT C FSECOM 12/14/84C C FULL SCREEN EDITOR COMMONC  PARAMETER (MAXSLN=32) d PARAMETER (MAXBUT=12)  PARAMETER (MAXBUT=12) c PARAMETER (MAXFRM=11)  PARAMETER (MAXFRM=12)  PARAMETER (MAXTAG=50) C  COMMON /FSECOM/ NRHEAD, NRCMND, NRMSG, NRFLIN, NRLLIN, d $ NROW, NCOL, CURLIN, CURROW,  $ NROW, NCOL, CURLIN, CURROW, CURNUM,  $ TAGLIN(MAXTAG), NTAGS,  $ FSINIT, LPREFX, REFORM  d COMMON /FSECMC/ BUTTON(MAXBUT)  COMMON /FSECMC/ BUTTON(MAXBUT), FORMS(MAXFRM), LANGFM,  $ TAGNAM(MAXTAG)  CHARACTER*(MAXWID) BUTTON  CHARACTER FORMS*60, LANGFM*8, TAGNAM*8  INTEGER NRHEAD, NRCMND, NRMSG, NRFLIN, NRLLIN  d INTEGER NROW, NCOL, CURLIN, CURROW  INTEGER NROW, NCOL, CURLIN, CURROW, CURNUM INTEGER NTAGS, TAGLIN  LOGICAL FSINIT, LPREFX, REFORM C C NRHEAD - LINE NUMBER OF HEADING LINE C NRCMND - LINE NUMBER OF COMMAND LINE C NRMSG - LINE NUMBER OF MESSAGE LINE C NRFLIN - FIRST LINE OF DECK DISPLAYC NRLLIN - LAST LINE OF DECK DISPLAY C NROW - NUMBER OF ROWS ON THE TERMINALC NCOL - NUMBER OF COLUMNS ON THE TERMINAL C CURLIN - INDEX TO CURRENT LINE C CURROW - CURSOR POSITION  C CURNUM - CURRENT LINE NUMBER  C NTAGS - NUMBER OF TAGS CURRENTLY DEFINED  C TAGLIN - ARRAY OF TAGED LINES C TAGNAM - ARRAY OF TAG NAMESC FSINIT - FULL SCREEN INITIALIZED C LPREFX - PREFIX COLUMN SWITCH C REFORM - DISPLAY FORMATING SWITCH C BUTTON - BUTTON KEY BUFFERSC FORMS - DISPLAY FORMATS FOR FULL SCREEN EDITORC LANGFM - LANGUAGE DISPLAY FORMAT TO FULL SCREEN EDITINGC FSEUP 12/14/84<FSEXEC 12/14/84@6GETBUF 3/22/82vGTFWD 3/22/82yHEADER 3/22/82ICKDIC 3/22/82IFSWI 3/22/82pd- C IFSW.CMNC C IFSWITCH (DETERMINES IF RECORDS ARE WRITTEN TO COMPILE FILE C  COMMON /IFSWI/ ISETIF - COMMON /IFSWI/ ISETIF, NIFS, ISIF(MAXSWI) p COMMON /IFSW/ NIFS, ISETIF, ISIF (MAXSWI) p LOGICAL ISETIF, ISIF-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 pC .TRUE. - Switch is set pC .FALSE.- 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/82m 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) m 1 INRNO(MAXDRR), INTYP(MAXDRR), IPRD(MAXDRR)  LOGICAL IPRD C BE MADE  C NIN - NUMBER OF RECORDS READ IN C INLOC - DIRECTIVE RECORD NUMBER mC INRNO - Input record number  C INTYP - DIRECTIVE TYPE mC INTYP - Directive type  C NDIR - NUMBER OF DIRECTIVES mC NDIR - Number of directivesC C IPRD - DIRECTIVE PROCESSED? mC IPRD - Has directive been processed? C .FALSE.- NO C .TRUE. - YESC ITABC 10/25/84C  COMMON /TABC/ ITABC C ITABC = Integer representation of a TAB character C DGEN TERM57 APOLLO DEC20 NC4 NW128 NC2 NC3 NC5 NC8 NC10 NW32 NW112 NW256 NW512 SMALL NPS IBMVM IBMMVS NW1024 MOD8D 5/06/82MOD8E 5/06/82IVERS 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 3 = ASSEMBLE C 4 = DATA 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 C --- COMFID = compile file fileid (by language)C C --- BAKFID = backup file fileid C C --- MODFID = modify file fileid  C n PARAMETER (MXLANG=3)  PARAMETER (MXLANG=4) COMMON /LANC/ LANG   COMMON /LANGT/ LANGNM(2)n COMMON /LANGT/ CLANGF, LANGNM(MXLANG), COMEXT(MXLANG)  COMMON /LANGT/ CLANGF, LANGNM(MXLANG) z CHARACTER*(MXLANG) CLANGF, COMEXT*4 n CHARACTER*(MXLANG) CLANGF, COMEXT*12 CHARACTER*(MXLANG) CLANGF CHARACTER*8 LANGNM  COMMON /FILIDC/ COMFID(MXLANG), BAKFID, MODFID  CHARACTER*60 COMFID, BAKFID, MODFIDC 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 *ENDIF DOCUMENT each deck in memory C *ENDIF DOCUMENT  COMMON/DECPT/NDKMEM,LIMITS 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 pC FILE COMMON BLOCK pC p COMMON /LUNS/ LIN,LOP,LSO,LCO,LNP,LSR,LSI, p 1 LIA,LOA,LOU  2 ,LBO,LBI,LTI,LDO,LDIfu 2 ,LBO,LBI,LTI,LDO,LDI,LTOp 2 ,LBO,LBI,LTI,LCI,LTO pC pC LOCATION FOR NEXT WRITE (RANDOM FILES - EOF) pC  p COMMON /LUNLOC/ LOCLNP, LOCLSR pC ...DEFINITIONS...  pC  pC LIN - (51) INPUT(CARD IMAGE)pC LOU - (13) LIST OUTPUT pC LOP - (31) OLD LIBRARY pC LSO - (12) SOURCE OUTPUT pC LCO - (14) COMPILE pC LNP - (11) NEW LIBRARY pC LSR - (50) SCRATCH LIBRARY pC LSI - (49) SCRATCH INPUTC LIA - (15) OLD LIBRARY (ASCII) fpC LIA - (15) old library (compatible) C LOA - (16) NEW LIBRARY (ASCII) fpC LOA - (16) new library (compatible) pC LBO - (17) BACKUP OUTPUT (EDIT) pC LBI - (18) BACKUP INPUT (EDIT) pC LTI - (5) TERMINAL FOR INPUT (EDIT) fpC LTO - (6) Terminal for output (both)C LDO - (19) DUMP FILE OUTPUT UNFORMATED (EDIT) fuC LDO - (19) Continue file output unformated (EDIT) C LDI - (20) DUMP FILE INPUT UNFORMATED (EDIT)fuC LDI - (20) continue file input unformated (EDIT)pC LDO - (19) Continue output -(no longer user)pC LCI - (20) Continue input (uses source output) formattedpC nC  COMMON /LUNS/ LIN, LOP, LSO, LCO, LNP, LSR, LSI, LIA, n 1 LOA, LOU, LBO, LBI, LTI, LCI, LTO  1 LOA, LOU, LBO, LBI, LTI, LCI, LTO, LMO*IF DOCUMENT C File unit variables C C LIN - (51) input (card image) LOU - (13) list output C LOP - (31) old library LSO - (12) source output  C LCO - (14) compile LNP - (11) new library  C LSR - (50) scratch library LSI - (49) scratch library  C LIA - (15) old portable library LOA - (16) new portable library  C LBO - (17) edit backup output LBI - (18) edit backup input  C LTI - (5) terminal - input LTO - (6) terminal - output C LDO - (19) (no longer user) LCI - (20) (no longer used) C C LMO - (32) modify output ( from *YANK, *PUPDAT, *SEARCH, or editor) C LOCLNR - location of next write (new library) C LOCLSR - location of next write (scratch library) C *ENDIF DOCUMENT  COMMON /LUNLOC/ LOCLNP, LOCLSR C NXUNIN 3/22/82OPENER 7/26/84@OPNLNP 3/22/824-PADD 3/22/82aPDECK 3/22/82qPDEFIN 3/22/82w PDELET 3/22/82PEDIMODCOM 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 MODRNPSARG 7/26/84  PARAMETER (NPSDIM=5)C C NPS ARGUMENT VARIABLES C  COMMON /NPSERR/ LERROR(NPSDIM), NERROR, QREM, QREADY, QERROR,  $ LEVEL  COMMON /NPSCHR/ REMARK C CHARACTER REMARK*72 INTEGER LERROR, NERROR  LOGICAL QREM, QREADY, QERROR C  C C NAME TYPE DESCRIPTION C ------ ---- ----------- C NPSDIM INT MAXIMUM NUMBER OF ERRORS ALLOWED IN LERROR ARRAY. C NERROR INT NUMBER OF ERRORS IN LERROR. C LERROR INT ERROR ARRAY. C QREM LOG TRUE IF REMARK CONTAINS A COMMENT.C REMARK CHAR COMMENT RETURNED FROM THE NPS LAYER. C QERROR LOG TRUE IF AN ERROR HAS OCCURRED.C QREADY LOG TRUE IF NPS ROUTINE HAS BEEN IMPLEMENTED. C C POSTID CHAR VERSION NUMBER OR OTHER ID REQUIRED BY SYSTEM.*IF IBMVM C RDISK CHAR READ ONLY DISK. C WDISK CHAR WRITEABLE DISK. *ENDIF PARAMA 3/22/82 |ytsnk^R;% nC PARAMA nC 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) s*IF -DEC20 s PARAMETER (NCHRWD=4) s*ENDIF s*IF DEC20 s PARAMETER (NCHRWD=5) s*ENDIF  PARAMETER (NWRDBK=128)t*IF NC2 t PARAMETER (NCHRWD=2)t*ENDIF t*IF NC3 t PARAMETER (NCHRWD=3)t*ENDIF t*IF NC4 t PARAMETER (NCHRWD=4)t *ENDIF t *IF NC5 t PARAMETER (NCHRWD=5)t *ENDIF t *IF NC8 t PARAMETER (NCHRWD=8)t*ENDIF t*IF NC10 t PARAMETER (NCHRWD=10) t*ENDIF t*IF NW32 t PARAMETER (NWRDBK=32) t*ENDIF t*IF NW112 t PARAMETER (NWRDBK=112) t*ENDIF t*IF NW128 t PARAMETER (NWRDBK=128) t*ENDIF t*IF NW256 t PARAMETER (NWRDBK=256) t*ENDIF t*IF NW512 t PARAMETER (NWRDBK=512) t!*ENDIF *IF NW1024  PARAMETER (NWRDBK=1024) *ENDIF NW1024 m PARAMETER (MAXDCM=11) j PARAMETER (MAXDCL = 5)  PARAMETER (MAXDCL = 2)j PARAMETER (MAXDCU = 200) *IF -SMALL  PARAMETER (MAXDCU = 200)  PARAMETER (MAXWRD = 160000) *ENDIF -SMALL *IF SMALL  PARAMETER (MAXDCU = 9) PARAMETER (MAXWRD = (MAXDCL + MAXDCU)*NWRDBK*2)  *ENDIF SMALL PARAMETER (MAXWID=72) R PARAMETER (MAXWID = 160)  PARAMETER (MAXDCK=500)| PARAMETER (MAXDCK = 600)  PARAMETER (MAXWRD=8000)  PARAMETER ( MAXWRD = 24000 ) % PARAMETER ( MAXWRD = 75000 ) n PARAMETER ( MAXWRD = 95000 )  PARAMETER (MAXMNA=500) PARAMETER (MAXMDK=500) PARAMETER (MAXMDD=500)  PARAMETER (MAXSWI=50) n PARAMETER ( MAXSWI = 100 )  PARAMETER (MAXDRR=500)^ PARAMETER (MAXDRR=1000) k PARAMETER (MAXDRR=2000)  PARAMETER (MAXMCM=50)  PARAMETER (MAXREC=2000) ; PARAMETER (MAXREC=4000) yz PARAMETER (MAXWRD=120000) j PARAMETER (MAXWRD = 160000) y PARAMETER (MAXREC=6000) nC NW8C NUMBER OF WORDS IN 8 CHARACTERS  PARAMETER NW8C = (8+NCHRWD-1)/NCHRWD  PARAMETER (NW8C=(8+NCHRWD-1)/NCHRWD) nC Maxbyt - maximum number of bytes in an unformatted record m PARAMETER (MAXBYT=4096) C *IF DOCUMENTC C NCHRWD - number of characters in a word C C NWRDBK - number of words in a block (library file) C C MAXWID - maximum width of records in the library C  C MAXDCK - number of decks allowed in the program  C  C MAXWRD - number of words allowed in memory at one time  C C MAXMNA - number of modification sets allowedC C MAXMDK - number of decks which can be modified C per modification set C C MAXMDD - number of modification directives per deck C per modification set C C MAXSWI - number of switches allowed C C MAXDRR - number of directives in a run C (excluding imbedded directives) C C MAXREC - number of records in an edited deckC *ENDIF DOCUMENT 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 Co COMMON /SCAN/ NWRD, ISS(72), ISL(72) COMMON /SCAN/ NWRD, ISS(72), ISE(72)CC CC NWRD - Number of words found CC ISS() - Start location of each scanned word found CoC ISL() - Length of each scanned word found (characters)C ISE() - last position of each scanned word found C C IDECP1=IDECP1+NMR+ LSERCHC 2/28/85C  PARAMETER (MAXSER = 11)  COMMON /SERCHC/ SERCHS(MAXSER)  CHARACTER*(MAXWID) SERCHS C  COMMON /SERCHI/ NSERCH, LSERCH(MAXSER) C C NSERCH - number of search strings to process  C SERCHS - search strings  C LSERCH - length of each search string  C EDT1 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/82SEPCOM 3/13/85C C INCLDD - used to keep track of decks written as "includes"C when ** is used in compile file name C (used in LISDCK )  COMMON /SEPCOM/ INCLDD(MAXDCK) C 2 NW256 NW512 SMALL NPS IBMVM IBMMVS NW1024 NUMREC PROFILE FSEDIT DOCUMENT6/82SEPFIC 9/24/84C C Separate file control for COMPILE and SOURCE files C n COMMON /SEPFIC/ SCOMPF, SSOURF  COMMON /SEPFIC/ SCOMPF, SSOURF, SCALLF n LOGICAL SCOMPF, SSOURF  LOGICAL SCOMPF, SSOURF, SCALLF C C SCOMPF = .FALSE. 1 compile file for all decksC = .TRUE. separate compile file for each deck  C SSOURF = .FALSE. 1 source file for all decks  C = .TRUE. separated source file for each deck  C C SCALLF = .FALSE. normal handling of common decks C = .TRUE. change CALL to INCLUDE - write separate file PARAMETER (NWRDBK=32) t*ENDIF 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/82pC C SWITCHES SETC  COMMON/SWITCN/ NSWS p COMMON/SWITCN/ NSWS, LSWTCH (MAXSWI) p LOGICAL LSWTCH pC pC LSWTCH - Switch position pC T - Set pC F - Not set C  COMMON/SWITCA/ SWITCH(MAXSWI)  CHARACTER*8 SWITCH 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 pC .TRUE. - Switch is set pTYPDCK 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) UPDATC 2/28/85C  COMMON /UPDATC/ UPDATE  LOGICAL UPDATE C C UPDATE - TRUE if update is to be done C C HI/ NSERCH, LSERCH(MAXSER) C C NSERCH - number of search strings to process  C SERCHS - search strings  C LSERCH - length ofWIDTH 3/08/83C z COMMON /WIDTH/ MWIDE COMMON /WIDTH/ MWIDE, MWIDECC C MWIDE = Current Maximum Width of recordsC MWIDEC = maximum width of compile file (including sequencing) C MAXWID = 72  PARAMETER MAXDCK = 500 PARAMETER MAXWRD = 8000 YANDEC 3/17/83yC  INTEGER YANMOD(MAXWRD/10)  INTEGER YANDCK(MAXWRD/10)  INTEGER YANRES(MAXWRD/10)  INTEGER YANREE(MAXWRD/10) y PARAMETER (MAXWD1=MAXWRD/10) y PARAMETER (MAXWD5=5*MAXWD1+1) y PARAMETER (MAXWD6=6*MAXWD1+1) y PARAMETER (MAXWD7=7*MAXWD1+1) y PARAMETER (MAXWD8=8*MAXWD1+1) y INTEGER YANMOD(MAXWD1) y INTEGER YANDCK(MAXWD1) y INTEGER YANRES(MAXWD1) y INTEGER YANREE(MAXWD1) 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))) y EQUIVALENCE(YANMOD,IDEC(MAXWD5))y EQUIVALENCE(YANDCK,IDEC(MAXWD6))y EQUIVALENCE(YANRES,IDEC(MAXWD7))y EQUIVALENCE(YANREE,IDEC(MAXWD8)) C C YANMOD - MOD number C YANDCK - DECK numberC YANRES - random record starting locationC YANREE - random record ending location C t *ENDIF t *IF NC8 t PARAMETER (NCHRWD=8)t*ENDIF t*IF NC10 t PARAMETER (NCHRWD=10) t*ENDIF t*IF NW32 t PARAMETER (NWRDBK=32) t*ENDIF tYANKC 2/28/85C  COMMON /YANKC/ YANKID  CHARACTER YANKID*8 C C YANKID - blank if no *YANK otherwise mod ident C HI/ NSERCH, LSERCH(MAXSER) C C NSERCH - number of search strings to process  C SERCHS - search strings  C LSERCH - length ofYANPTR 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/82~rfRC@+  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 n*CA PARAMB *CA LOGU *CA CONTRL*CA BATCH *CALL SERCHC*CALL UPDATC*CALL ERRMES*CALL YANKC C NEXT - Record following *ENDDATA directive for a batch run  CHARACTER * 72 NEXT  C  NEXT=' ' CALL INITL s 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) s IF(BATCH) THEN  IF (PMODE .NE. 'BATCH') CALL CKEDIT p IF (PMODE .EQ. 'BATCH') THEN Rp CALL CTLCRD 10 IF (PMODE .EQ. 'BATCH') THEN  CALL CTLCRD(NEXT) CALL WRTIO(' Begin input')  CALL INP  IF(ICPA) CALL RDOPL(LIA)  IF(ICPA) CALL RDOPLA(LIA) IF(ICP) CALL RDOPL(LOP) Rp CALL INP  CALL INP(NEXT)  CALL WRTIO(' Begin modifications')  CALL PROC3 n CALL WRTIO(' Begin listings') n CALL PROC4  IF(YANKID.NE.' ' .AND. NSERCH.NE.0) THEN  ERRMSG = '**ERROR** both *YANK and *SEARCH requested'//  1 ' these are incompatible'  CALL WRERR CALL THEEND(2,'*YANK and *SEARCH both requested')  ELSEIF (YANKID.NE.' '.AND. UPDATE ) THEN ERRMSG = '**ERROR** both *YANK and *UPDATE requested'//  1 ' these are incompatible' CALL WRERR CALL THEEND(2,'*YANK and *UPDATE both requested')  ENDIFC  IF (NSERCH.GT.0) THEN CALL WRTIO(' Begin processing search')  CALL PSERCH  CALL WRTIO(' End search processing')  ENDIFC  IF (UPDATE) THEN  CALL WRTIO(' Begin processing update')  CALL PUPDAT  CALL WRTIO(' End update processing')  ENDIFC  IF (YANKID.NE.' ') THEN  CALL WRTIO(' Begin processing yank')  CALL PYANK(YANKID) CALL WRTIO(' End yank processing') ! ENDIF"C # CALL WRTIO(' Begin listings') $ CALL PROC4 p IF(ICN)CALL WRTIO(' Begin writing library file')  p IF(ICN) CALL WRNPL(LNP) p IF(ICNA)CALL WRTIO(' Begin writing portable library file')  p IF(ICNA) CALL WRNPLA(LOA)  IF(ICN) THEN  CALL WRTIO(' Begin writing library file.') CALL WRNPL(LNP) ENDIF IF(ICNA) THEN CALL WRTIO(' Begin writing portable library file.') CALL WRNPLA(LOA)  CALL CLSFIL(LOA)  ENDIF + CALL PRSTAT  CALL DELFIL(LSR)  CALL DELFIL(LSI)  IF(ICL) CALL CLSFIL(LOU) IF(ICN) CALL CLSFIL(LNP) IF(ICPA) CALL CLSFIL(LIA) IF(ICP) CALL CLSFIL(LOP)n CALL UCASE(NEXT(1:4),NEXT(1:4)) % CALL UCASE(NEXT(1:4)) IF(NEXT(1:5).EQ.'SLIB,') THEN  CALL INITL  PMODE='BATCH'  GOTO 10  ENDIF ELSE n CALL EDIOPL r~ ICL=.FALSE.   CALL EDIINI   CALL EDITOR @u IEDECK=0 @u100 CALL EDIINI(IEDECK) @u IF(IEDECK.GT.0) THEN @ CALL EDITOR CuC Parameter for EDITOR is RECOVERCu CALL EDITOR(.FALSE.) @u GOTO 100 @u ENDIF p CALL EDIINI  CALL EDIINI  ENDIF C  CALL PRSTAT  STOP 'NORMAL EXIT' ~ CALL ENDPRO(0)  CALL THEEND(0,' 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) Cv IF(INDEX(' ,!',BUF(I:I)).NE.0) GOTO 20  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 u 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  CALL EDITOR @u IEDECK=0 @u100 CALL EDIINI(IEDECK) @u IF(IEDECK.GT.0) THEN @ CALL EDITOR CuC Parameter for EDITOR is RECOVERCCKEDIT 6/14/82rqbC+)%#  SUBROUTINE CKEDIT C C CHECK FOR AN INTERACTIVE/EDIT RUN C *CA BATCH *CA LOGUb*CA IVERS q*CA CONTRL n*IF IBMVM n*CALL FILEIDS n*ENDIF IBMVM*CALL LANGC  CHARACTER*4 ANS C CHARACTER*80 ANS  CHARACTER FNAME*72  CHARACTER STATUS*8 C Cs 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, LSTMODr WRITE(LTO, 20) LSTMOD b20 FORMAT(' SLIB77 latest mod - ',A,/ r20 FORMAT(' SLIB77 latest mod - ',A,/, b 1 ' Is this an interactive EDIT run (Yes,No,Help)? ') CALL WRTIO(' SLIB77 lastest mod - '//LSTMOD)  ANS = ' '  CALL RDTIO('Is this an interactive EDIT (Yes,No,Help)? ',ANS,  $ .TRUE.) %  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 s BATCH=.FALSE. q LSTE = .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  s BATCH=.TRUE.  PMODE = 'BATCH'  ELSE  q CALL EDIHEL(ANS)  CALL WRTIO('1SLIB77 has both a Batch mode and an Edit mode')  CALL WRTIO(' ')  CALL WRTIO(' In the Edit Mode there are three editors:')  CALL WRTIO(' 1. The original line editor (SLEDIT).')  CALL WRTIO(' 2. A modified line editor (LEDIT).') CALL WRTIO(' 3. A Full Screen editor (FSEDIT).')  CALL WRTIO(' ')  CALL WRTIO(' All three editors write to a backup file which') CALL WRTIO(' is deleted upon normal exit.') CALL WRTIO(' All three editors allow a continuation from a')  CALL WRTIO(' normal batch type file.')  CALL WRTIO(' All three have on-line help available.') CALL WRTIO(' The FSEDIT editor requires the NPS switch and')  CALL WRTIO(' some special code - if it is not available')  CALL WRTIO(' the program will revert to the LEDIT')  CALL WRTIO(' ')  CALL WRTIO(' Read the SLIB77 USER MANUAL for more info')  CALL WRTIO(' or call Alex at 303-231-1723.')  GOTO 10  ENDIF 50 BATCH=.TRUE.  RETURN C GOTO 60 50 CONTINUE Cs60 IF(BATCH) THEN 60 IF (PMODE .EQ. 'BATCH') THEN C PRINT61 r WRITE(LTO,61)C61 FORMAT(' Do you want to open INPUT file (51) with a NAME ?') C PRINT63 r WRITE(LTO,63)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)  CALL WRTIO(' Do you want to open INPUT file (51) '//  $ 'with a name ?')  CALL WRTIO(' (If so enter fileid - otherwise a '//  $ 'carriage-return)') ANS = ' ' CALL RDTIO('?',ANS,.TRUE.)  n IF(ANS.EQ.' ') GOTO 100  n CALL FILEID(LIN,ANS,FNAME)  FNAME = ANS *ENDIF EDIT *IF -EDIT  FNAME = ' '  PMODE = 'BATCH' *ENDIF -EDIT n*IF IBMVM z FTYPE(4) = ' '//ANS n POSTID(4) = ' '//ANS n*ENDIF IBMVM  ICHARS = 80 k CALL OPENER(LIN,FNAME(1:ITRAIL(FNAME)),'OLD','SEQUENTIAL',  ILEN = ITRAIL(FNAME)  STATUS = 'OLD'  CALL FILECK(LIN,'INPUT',FNAME,ILEN,STATUS,IDDNAM) CALL OPENER(LIN,FNAME(1:ILEN),IDDNAM,STATUS,'SEQUENTIAL', $ 'FORMATTED',ICHARS,0,0,IERR)  IF(IERR.NE.0) THEN  CALL WRTIO(' **ERROR** (CKEDIT) unable to open INPUT file')  CALL THEEND(2,' couldnt open input file')  ENDIF *IF EDIT C ENDIF )*ENDIF  BATCH=.TRUE. C100 CONTINUE  RETURN  RETURN  END CKIF 2/13/84~  SUBROUTINE CKIF(ALF)  CHARACTER*(*) ALF C C Check *IF directive and set appropriate switches C *CA PARAMA *CA BUFA*CA SCAN *CA SWITCH  *CA IFSWI  *CA ERRMES CHARACTER*9 SWII CHARACTER*8 SWI  LOGICAL MINUS C z CALL SCAN2(ALF)  CALL SCANDI(ALF)  IF(NWRD.GT.1)THEN o SWII=ALF(ISS(2):ISS(2)+ISL(2)-1)  SWII=ALF(ISS(2):ISE(2))  ELSE ERRMSG='*IF directive with no switch on it - ignored'  CALL WRERR  RETURN  ENDIF C  IF(SWII(1:1).EQ.'-') THEN  MINUS=.TRUE.  SWI=SWII(2:)  ELSE  MINUS=.FALSE.  SWI=SWII  ENDIF  C ! DO 200 L=1,NSWS " IF(SWI.EQ.SWITCH(L)) GOTO 500 #200 CONTINUE$C ~ IF(NSWS.GE.MAXSWI) THEN ~ WRITE(ERRMSG,211) MAXSWI ~211 FORMAT('Too many switches for program maximum =',I5 ~ 1 ,'(parameter MAXSWI must be increased).') ~ CALL WRERR ~ ERRMSG='Error occurred in CKIF when switch '//SWI// ~ 1 ' was encountered' ~ CALL WRERR ~  CALL ENDPRO(2)  CALL THEEND(2,'Too many switches') ~ ENDIF % NSWS=NSWS+1 & SWITCH(NSWS)=SWI ' LSWTCH(NSWS)=.FALSE. ( CALL STATIS(6,NSWS) ) ERRMSG='Switch '//SWI//' added - (not set)' * CALL WRERR +C , L=NSWS -500 NIFS=NIFS+1 . IF(MINUS) THEN / ISIF(NIFS)=.NOT.LSWTCH(L)0 ELSE 1 ISIF(NIFS)=LSWTCH(L) 2 ENDIF 3C 4600 CONTINUE 5 DO 700 I=1,NIFS 6 IF(.NOT.ISIF(I)) THEN 7 ISETIF=.FALSE. 8 GOTO 9000 9 ENDIF :700 CONTINUE;C < ISETIF=.TRUE. =C >9000 CONTINUE ? RETURN @ END LOCCNT 11/19/84 LOCREC 3/22/82MODDCK 3/22/82MOVCHR 12/14/84CKINPN 5/03/82" trfaEC 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 BUFAr*CALL ERRMES f LOGICAL LID, LDK, LIM  SAVE LID, LDK, LIM f C f C Logical Switches Indicating encountered directives fC LID - *IDENT fC LDK - *DECK fC LIM - indicates insert mode condition C  SAVE ITTL C ITTL - directive type of previous record (initially 99)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 /r}C 1 1 1 1 1 1 1 1 1 1 2r}C 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0r}C - - - - - - - - - - - - - - - - - - - - -r} DATA IDMH /1,2,2,1,1,2,1,3,1,1,1,1,3,1,3,1,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 /r} DATA IDCL /1,2,2,1,2,2,2,1,2,1,2,1,1,2,1,1,2,2,2,2,1 / f+ DATA IDIM /2,3,3,2,4,4,4,3,4,2,4,2,3,4,3,1,4,4,4,4 /r} DATA IDIM /2,3,3,2,4,4,4,3,4,2,4,2,3,4,3,1,4,4,4,4,2 / f, DATA IDST /1,1,1,1,1,3,1,1,1,1,2,1,1,1,1,1,1,1,1,1 /r} DATA IDST /1,1,1,1,1,3,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1 / pC 1 1 1 1 1 1 1 1 1 1 2 2 2pC 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2pC - - - - - - - - - - - - - - - - - - - - - - -p DATA IDMH /1,2,2,1,1,2,1,3,1,1,1,1,3,1,3,1,1,1,1,1,1,1,1 / p DATA IDCL /1,2,2,1,2,2,2,1,2,1,2,1,1,2,1,1,2,2,2,2,1,1,1 / p DATA IDIM /2,3,3,2,4,4,4,3,4,2,4,2,3,4,3,1,4,4,4,4,2,2,2 / p DATA IDST /1,1,1,1,1,3,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1 / oC 1 1 1 1 1 1 1 1 1 1 2 2 2 2 oC 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 oC - - - - - - - - - - - - - - - - - - - - - - - - o DATA IDMH /1,2,2,1,1,2,1,3,1,1,1,1,3,1,3,1,1,1,1,1,1,1,1,1 / o DATA IDCL /1,2,2,1,2,2,2,1,2,1,2,1,1,2,1,1,2,2,2,2,1,1,1,1 / o DATA IDIM /2,3,3,2,4,4,4,3,4,2,4,2,3,4,3,1,4,4,4,4,2,2,2,4 / o DATA IDST /1,1,1,1,1,3,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1 /C 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2C 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4C - - - - - - - - - - - - - - - - - - - - - - - - - DATA IDMH /1,2,2,1,1,2,1,3,1,1,1,1,3,1,3,1,1,1,1,1,1,1,1,1,1 /  DATA IDCL /1,2,2,1,2,2,2,1,2,1,2,1,1,2,1,1,2,2,2,2,1,1,1,1,1 /  DATA IDIM /2,3,3,2,4,4,4,3,4,2,4,2,3,4,3,1,4,4,4,4,2,2,2,4,4 /  DATA IDST /1,1,1,1,1,3,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1 / f-C f.p DATA LID, LDK, LIM /.FALSE., .FALSE., .FALSE. / f/pC f0pC ITTL - directive type of previous recordf1C f2p DATA ITTL /99/ f3pC 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 r WRITE(ERRMSG,21) INRCN,'*ID' r CALL WRERR r ERRMSG = A r CALL WRERR f= CALL LININC(2) f> PRINT 21, INRCN, A f?21 FORMAT(' The following record (',I5,') should have a', r 21 FORMAT('The following record (',I5,') should have a',f@ 1 ' preceeding *ID directive',/1X,A)r 1 ' preceeding ',A' directive.')t 1 ' preceeding ',A,' directive.') fA INERRF=INERRF+1 fB ENDIF fC GOTO 100fDC fEC fF30 IF(.NOT.LDK) THEN fG PRINT 31, INRCN,Ar WRITE(ERRMSG, 21) INRCN,'*DECK' r CALL WRERR r ERRMSG = A r CALL WRERR 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 r WRITE(ERRMSG, 221) INRCN r CALL WRERR r ERRMSG= A r CALL WRERR f] WRITE(LOU,221) INRCN, A f^ CALL LININC(2) f_221 FORMAT(' The following record (',I5,') is to be inserted', r221 FORMAT('The following record (',I5,') is to be inserted',f` 1 ' but cannot be',/1X,A) r 1 ' but cannot be.') 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  C  C entry to initialize variablesC  ENTRY CKINPIC  LID=.FALSE.  LDK=.FALSE.  LIM=.FALSE.  ITTL=99  RETURN  END CKV3SW 2/13/84~ SUBROUTINE CKV3SW (ALF,N) C C Checks a record for *IF - used only by UPV3SW C to update the switch table C *CA PARAMA *CA BUFA*CA PRFX *CA LOGU *CA SCAN *CA SWITCH  *CA ERRMES  C  CHARACTER*(MAXWID) ALF  CHARACTER*9 SWII  CHARACTER*8 SWI C z CALL SCAN2(ALF(1:N))  CALL SCANDI(ALF(1:N))  IF(NWRD.GT.1)THEN o SWII=ALF(ISS(2):ISS(2)+ISL(2)-1)  SWII=ALF(ISS(2):ISE(2))  ELSE ERRMSG='*IF directive with no switch on it - ignored'  CALL WRERR  GOTO 500  ENDIF C  IF(SWII(1:1).EQ.'-') THEN  SWI=SWII(2:)  ELSE  SWI=SWII  ENDIF  C ! DO 200 L=1,NSWS " IF(SWI.EQ.SWITCH(L)) GOTO 500 #200 CONTINUE$C ~ IF(NSWS.GE.MAXSWI) THEN ~ WRITE(ERRMSG,211) MAXSWI ~211 FORMAT('Too many switches for program maximum =',I5 ~ 1 ,'(parameter MAXSWI must be increased).') ~ CALL WRERR ~ ERRMSG='Error occurred in CKV3SW when switch '//SWI//~ 1 ' was encountered' ~ CALL WRERR ~  CALL ENDPRO(2)  CALL THEEND(2,'Too many switches') ~ ENDIF % NSWS=NSWS+1 & SWITCH(NSWS)=SWI ' LSWTCH(NSWS)=.FALSE.( ERRMSG='Switch '//SWI//' added - (not set)' ) CALL WRERR ~ CALL STATIS(6,NSWS) *C +500 CONTINUE,C - RETURN . END SSING ',a 1 '...JOB ABORTED. ') bC c PRINT 120dC e STOP ' IDENT ' fC g ELSE IF(ORDTBL(ITT) .EQ. 9) THEN h IFLI = .TRUE. CLSFIL 7/26/84  SUBROUTINE CLSFIL(LUN) C C THIS SUBROUTINE CLOSES AN ATTACHED FILE.C  INTEGER LUN C *IF NPS *CALL NPSARG C  CHARACTER NPSREM*40 C CALL DETACH(LUN, $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) v IF (QREADY.AND.QERROR) CALL NPSEIO('DETACH VIA CLSFIL')  IF (QREADY.AND.QERROR) THEN  WRITE(NPSREM,'(A,I3)') 'DETACH called with LUN=',LUN  CALL NPSEIO('DETACH via CLSFIL',NPSREM(1:ITRAIL(NPSREM)))  ENDIF  IF (QERROR) CLOSE (UNIT=LUN)*ENDIF *IF -NPS*IF -IBM  CLOSE (UNIT=LUN)*ENDIF *ENDIF  RETURN  END 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 COMCHC 3/22/82 }rpRC- SUBROUTINE COMCHC(ALF,ILA,ICOM) - SUBROUTINE COMCHC(ALF,ILA,ITD) C }C CHECK COMPILE FILE RECORD FOR C Check common deck record for C C 3 - CALL C 9 - ENDIF C 11 - IF C 21 - CALLG C *CA PARAMA *CA CKDIRDC*CALL SCAN *CA SWITCH *CA IFSWI r*CALL ERRMES 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 p LOGICAL MINUSC  CALL CKDIR(ALF(2:ILA),ITD) C CALL CKDIR(ALF(1:ILA),ITD) } IF(ITD.EQ.3) THEN  IF(ITD .EQ. 3 .OR. ITD .EQ. 21 ) THEN C C *CALL DIRECTIVE C  PRINT*,'CALL DIRECTIVE FOUND IN COMMON DECK-NOT ALLOWED' r ERRMSG='**ERROR** The following CALL directive was found'// r 1 ' in a COMMON deck - and ignored' r CALL WRERR r ERRMSG = ALF(1:ILA) r CALL WRERR  GOTO 9000C  ELSE IF(ITD.EQ.9) THEN C C *ENDIF DIRECTIVEC } IF(NIFS.LT.1) THEN } ERRMSG='**ERROR** An extra *ENDIF directive was found'// } 1 ' in a COMMON deck' } CALL WRERR } ENDIF}C  ICOM=1  ISETIF=0 ! GOTO 9000 - NIFS=MAX(0,NIFS-1) - IF(NIFS.GT.0) THEN - ISETIF=ISIF(NIFS) - ELSE - ISETIF=0 p ISETIF=.TRUE. - ENDIF } ISETIF = .TRUE. } DO 100 I=1,NIFS } IF(.NOT.ISIF(I)) ISETIF = .FALSE. } 100 CONTINUE " 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 p CALL CKIF(ALF(1:ILA)) 4 ENDIF 5C 69000 CONTINUE 7 RETURN 8 END C 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 qCOMCHD 11/19/84 SUBROUTINE COMCHD(ALF,ILA,ITD) C C used during count of compile file records only C (derived from COMCHC) *IF NUMREC C Check common deck record for C C 9 - ENDIF C 11 - IF  C *CA PARAMA *CALL SCAN *CA SWITCH *CA IFSWI C  CHARACTER*(MAXWID) ALF  CHARACTER*9 WOR9  CHARACTER*8 SWI C  CALL CKDIR(ALF(1:ILA),ITD) C  IF(ITD.EQ.9) THEN C C *ENDIF DIRECTIVE C C  NIFS = MAX(0,NIFS-1)  ISETIF = .TRUE.  DO 100 I = 1,NIFS IF(.NOT.ISIF(I)) ISETIF = .FALSE. 100 CONTINUE  C ! ELSE IF(ITD.EQ.11) THEN "C #C *IF DIRECTIVE$C % CALL CKIF(ALF(1:ILA)) & ENDIF 'C (9000 CONTINUE )*ENDIF NUMREC * RETURN + END 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/82COMCHK 3/22/82 }rpdRC- SUBROUTINE COMCHK(ALF,N)dz SUBROUTINE COMCHK (ITD,ALF,N) n SUBROUTINE COMCHK (ITD,ALF,N,LDECK) nC nC CHECK COMPILE FILE RECORD FOR nC nC 3 - CALL nC 9 - ENDIF nC 11 - IF nC 21 - CALLG nC  SUBROUTINE COMCHK (ITD,ALF,N,LDECK,ICDK,DNAME,GNAME,COUNT) C C Process imbedded directives during list processing C (all except *VELEVEL - done by LISCRD) C ITD - directive type - inputC ALF(1:N) - directive record - input C LDECK - deck name containing directive - inputC ICDK - deck number called - output  C DNAME - deck name to be called - output  C GNAME - group name to be called - output  C *CA PARAMA *CA DECA *CA PRFX *CA CKDIRDC*CALL LOGU C*CALL SCAN *CA DECKS *CA SWITCH *CA IFSWI r*CA ERRMES C  CHARACTER*132 ALF C CHARACTER*120 ALF R CHARACTER*(MAXWID) ALF C} CHARACTER*9 WOR9 C} CHARACTER*8 WOR8 } CHARACTER*8 SWI z CHARACTER*8 DNAME, GNAME CHARACTER*8 DNAME, GNAME, LDECK LOGICAL COUNT C  ICOM=0 - LOGICAL MINUS,SET pn LOGICAL MINUSnC  CALL CKDIR(ALF(2:N),ITD)C CALL CKDIR(ALF(1:N),ITD) n IF(ITD.EQ.3) THEN nC nC *CALL DIRECTIVE nC  IDK=IFINDK(WORD(2)) Cz CALL SCAN2(ALF(1:N)) n CALL SCANDI(ALF(1:N))C} WOR8=ALF(ISS(2):ISS(2)+ISL(2)-1) o DNAME=ALF(ISS(2):ISS(2)+ISL(2)-1)n DNAME=ALF(ISS(2):ISE(2)) C } IDK=IFINDK(WOR8) n IDK=IFINDK(DNAME)n 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)r} ERRMSG = 'Could not find common deck '//WOR8// n ERRMSG = 'Could not find common deck '//DNAME// rz 1 ' requesting record ignored.' n 1 ' requesting record ignored (in deck '//LDECK//')' rn CALL WRERR n GOTO 9000 n ENDIF nC !n CALL INSCOM(IDK) "} ICOM=1 #n GOTO 9000$n ELSE IF(ITD.EQ.9) THEN IF(ITD.EQ.9) THEN %C &C *ENDIF DIRECTIVE'C }n IF(NIFS.LT.1) THEN  IF(NIFS.LT.1.AND..NOT.COUNT) THEN} ERRMSG='**ERROR** An extra *ENDIF directive was found'// }z 1 ' in a deck'  1 ' in deck '//LDECK } CALL WRERR } ENDIF}C ( ICOM=1 ) ISETIF=0 * GOTO 9000 - NIFS=MAX(0,NIFS-1) - IF(NIFS.GT.0) THEN - ISETIF=ISIF(NIFS) - ELSE - ISETIF=0 p ISETIF=.TRUE. - ENDIF } ISETIF = .TRUE. } DO 100 I=1,NIFS } IF(.NOT.ISIF(I)) ISETIF = .FALSE. } 100 CONTINUE C + 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 p CALL CKIF(ALF(1:N)) n ELSE IF (ITD .EQ. 21 ) THENC  ELSE IF (ISETIF .AND. (ITD.EQ.3.OR.ITD.EQ.21)) THENn C nC *CALLG Directive C *CALL or *CALLG directive  C  z CALL SCAN2(ALF(1:N))  CALL SCANDI(ALF(1:N)) C IF (NWRD.LT.2) THEN  IF(COUNT) GOTO 9000 z ERRMSG = 'Improper *CALLG directive in deck (will ignore)' ERRMSG = 'Improper *CALLG directive in deck '//LDECK// 1 ' (directive ignored)' n CALL WRERRn ERRMSG = ALF(1:N) n CALL WRERR n GOTO 9000  GOTO 9910  ENDIFC o DNAME=ALF(ISS(2):ISS(2)+ISL(2)-1) DNAME=ALF(ISS(2):ISE(2)) n IF(NWRD.GT.2) THEN o GNAME=ALF(ISS(3):ISS(3)+ISL(3)-1) n GNAME=ALF(ISS(3):ISE(3)) n ELSE n GNAME=' ' n ENDIFnC n IDK=IFINDK(DNAME)  ICDK=IFINDK(DNAME) n IF(IDK.LE.0.OR.ITYPE(IABS(IDK)).EQ.0) THEN  IF(ICDK.LE.0.OR.ITYPE(IABS(ICDK)).EQ.0) THEN  ICDK = 0  IF(COUNT) GOTO 9000  ERRMSG = 'Could not find common deck '//DNAME// z 1 ' requesting record ignored.'  1 ' requesting record ignored (in deck '//LDECK//')'  GOTO 9910  ENDIF  IF(NWRD.GT.2)THEN  GNAME=ALF(ISS(3):ISE(3))  ELSE  GNAME = ' '  ENDIF n CALL WRERR!n ERRMSG = ALF(1:N) "n CALL WRERR # ENDIF$nC %z CALL INSGRP(IDK,DNAME,GNAME,ALF(1:N)) n CALL INSGRP(IDK,DNAME,GNAME,ALF(1:N),LDECK) &C 'n ELSE IF (ITD .EQ. 22 ) THEN(nC )nC *GNAME DIRECTIVE *nC +z ERRMSG = '*GNAME directive improperly placed in deck -'// n ERRMSG = '*GNAME directive improperly placed in deck '// ,z 1 'will be ignored'  n 1 LDECK//' (will be ignored).' -n CALL WRERR =n ENDIF >nC ?9000 CONTINUE @ RETURN  C !9910 CALL WRERR " ERRMSG = ALF(1:N) # CALL WRERR $ RETURN A END COMCHL 11/19/84 SUBROUTINE COMCHL (ITD,ALF,N,NRECCF)C C check deck (and count compile file records) for: C (derived from COMCHK) *IF NUMREC C C 3 - CALL C 9 - ENDIF C 11 - IF C 21 - CALLG  C *CA PARAMA *CA DECA *CA PRFX *CALL LOGU *CALL SCAN *CA DECKS *CA SWITCH *CA IFSWI C  CHARACTER*(MAXWID) ALF  CHARACTER*8 DNAME, GNAMEC  LOGICAL MINUS C  IF(ITD.EQ.3) THEN C C *CALL DIRECTIVE C  CALL SCANDI(ALF(1:N))o DNAME = ALF(ISS(2):ISS(2)+ISL(2)-1)  DNAME = ALF(ISS(2):ISE(2)) IDK = IFINDK(DNAME) ! IF(IDK.LE.0) GOTO 9000 " IF(ITYPE(IDK).GT.0) CALL INSCOL(IDK,NRECCF) #C $ ELSE IF(ITD.EQ.9) THEN %C &C *ENDIF DIRECTIVE'C ( NIFS = MAX(0,NIFS-1) ) ISETIF = .TRUE. * DO 100 I = 1,NIFS+ IF(.NOT.ISIF(I)) ISETIF = .FALSE. ,100 CONTINUE -C . ELSE IF(ITD.EQ.11) THEN/C 0C *IF DIRECTIVE1C 2 CALL CKIF(ALF(1:N)) 3C 4 ELSE IF(ITD .EQ. 21 ) THEN 5 6C 7C *CALLG Directive 8C 9 CALL SCANDI(ALF(1:N)):C ; IF (NWRD.LT.2) GOTO 9000 <C =o DNAME = ALF(ISS(2):ISS(2)+ISL(2)-1)  DNAME = ALF(ISS(2):ISE(2)) > IF(NWRD.GT.2) THEN ?o GNAME = ALF(ISS(3):ISS(3)+ISL(3)-1)  GNAME = ALF(ISS(3):ISE(3)) @ ELSE A GNAME = ' ' B ENDIFCC D IDK = IFINDK(DNAME) EC F IF(IDK.LE.0) GOTO 9000 G IF(ITYPE(IDK).GT.0) THEN H CALL INSGRL(IDK,DNAME,GNAME,ALF(1:N),NRECCF) I ENDIF J ENDIF KC L9000 CONTINUE M*ENDIF NUMREC N RETURN O END -( NIFS=NIFS+1 -) ISIF(NIFS)=ISETIF pCOMCHM 3/22/82nRC 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  IF(ITD .EQ. 3 .OR. ITD .EQ. 21 ) THEN C C *CALL DIRECTIVE C  IDK=IFINDK(WORD(2)) Cz CALL SCAN2(ALF(1:ILA))  CALL SCANDI(ALF(1:ILA)) Co WOR8=ALF(ISS(2):ISS(2)+ISL(2)-1)  WOR8=ALF(ISS(2):ISE(2)) C IDK=IFINDK(WOR8)  IF(IDK.GT.0) THEN  ICOM=IEDIT(IDK)  ELSE  ICOM=0  ENDIFn ELSE n ICOM=0  ENDIF  RETURN  END C 21 - CALLG  C *CA PACOMPID 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/82f'~|{zxwuroihgfd]YXWRQIFDC p SUBROUTINE CTLCRD  SUBROUTINE CTLCRD (NEXT) 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 DECAz*CA DECKS r*CA CPLDIR r*CA ERRMES n*CALL FILEIDS *CALL SEPFIC*CALL FNAMES*CALL PRFX C C NEXT - record following *ED directive from previous run  CHARACTER * (*) NEXTC C ICLST - Dimensioned variable for LO options C LOGICAL ICLST(8) EQUIVALENCE(ICLST,LSTA)  C fC 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 ~C ~ PARAMETER (MAXCTL=25) ~C 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) z CHARACTER*128 CTLLIS(25)~ CHARACTER*128 CTLLIS(MAXCTL)f EQUIVALENCE (CTLLIS, BUF) i EQUIVALENCE (CTLLIS(1), ADEC(1)) z EQUIVALENCE (CTLLIS(1), DECK(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) o CHARACTER*3 OPT(14) rn CHARACTER*3 OPT(15) i PARAMETER (NOPTS=16)  PARAMETER (NOPTS=17)  CHARACTER*3 OPT(NOPTS) 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,NAMLIAz CHARACTER*72 NAM,NAMLCO,NAMLOU,NAMLOP,NAMLIA,NAMLNP,NAMLOA ]C COMEXT - compile file name extension ] CHARACTER*4 COMEXT f  CHARACTER*4 COMEXT(2) z CHARACTER FNAME*72 z CHARACTER*72 NAMLSO  CHARACTER*72 NAM, FNAME  CHARACTER STATUS*8 { CHARACTER*10 SEQTYP(3) 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 z DATA NAMLCO /' '/ z DATA NAMLOU /' '/ z DATA NAMLOP /' '/ fz DATA NAMLIA /' '/ z DATA NAMLNP /' '/ z DATA NAMLOA /' '/ Iz DATA IWLOU /1/ Iz DATA IWLCO /1/ Iz DATA IWLOP /1/ fz DATA IWLIA /1/ z DATA NAMLSO /' '/ z DATA IWLSO /1/ z DATA IWLNP /1/ z DATA IWLOA /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'/ o 1 'W','SQ','LA','CD'/ rn 1 'W','SQ','LA','CD','UC'/i 1 'W','SQ','LA','CD','UC','M'/ 1 'W','SQ','LA','CD','UC','M','PR'/ C  DATA LOPT /'ACDEIMST'/ {C { DATA SEQTYP /'FULL','COMPRESSED','NONE'/C f NCTLS=0 ~C Number of control errors ~ NCCERR=0C  READ(LIN,11) CCRD(1:80) y READ(LIN,11) CCRD(1:72) p READ(LIN,11,END=10000) CCRD(1:72) IF(NEXT.NE.' ') THEN CCRD(1:72)=NEXT  ELSE  READ(LIN,11,END=10000) CCRD(1:72)  ENDIF f INRCN=INRCN+1 11 FORMAT(A)  NCCRD=0  IS=1z IF(CCRD(1:4).NE.'SLIB') THENn CALL UCASE(CCRD(1:4),CCRD(1:4))  CALL UCASE(CCRD(1:4))  IF(CCRD(1:5).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' ~ CALL ENDPRO(2)z CALL WRTIO(' First record on input file must be SLIB, '// CALL WRTIO(' First record on input file must be "SLIB," '// z $ 'but -'//CCRD(1:4)//'- found.')  $ 'but -'//CCRD(1:5)//'- found.')  CALL THEEND(2,' Improper CONTROL RECORD on input.') ENDIF !C "20 DO 30 IC=IS+79,IS+1,-1 r20 IEXCLA = INDEX (CCRD(IS:IS+79),'!') |20 DO 22 IER = IS+79,IS+2, -1  20 DO 22 IER = IS+71,IS+2,-1 | IF(CCRD(IER:IER).NE.' ') GOTO 24 |22 CONTINUE | IER = IS+1 |v24 IEXCLA = INDEX (CCRD(IS:IER),'!') 24 IEXCLA = INDEX (CCRD(IS:IER),'''') r IF (IEXCLA.EQ.0) THEN r IEXCLA=IS+79 | IEXCLA = IER r ELSE r IEXCLA=IEXCLA+IS-2 r ENDIF r DO 30 IC=IEXCLA,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) | WRITE(LTO,41) CCRD(IS:IER) ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) f NCTLS=NCTLS+1 f CTLLIS(NCTLS) = BLKLIN f WRITE(CTLLIS(NCTLS),41) CCRD(IS:ILE)| WRITE(CTLLIS(NCTLS),41) CCRD(IS:IER)f41 FORMAT(' Control record - ',A)  { CALL WRTIO(CTLLIS(NCTLS))  LM=ITRAIL(CTLLIS(NCTLS)) CALL WRTIO(CTLLIS(NCTLS)(1:LM)) 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)  READ(LIN,11) CCRD(IS:IS+71) f INRCN=INRCN+1 0 GOTO 20 1C 260 CONTINUE3 CALL SCAN1(CCRD(1:ILE),WORD,NWRD) Fz CALL SCAN1(CCRD(1:ILE)) n CALL UCASE(CCRD(1:ILE),CCRD(1:ILE))  CALL UCASE(CCRD(1:ILE)) CALL SCANCC(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 o DO 200 NCC = 1,14 r n DO 200 NCC = 1,15  DO 200 NCC = 1, NOPTS : IF(WORD(NS).EQ.OPT(NCC)) GOTO 300Co IF(CCRD(ISS(NS):ISS(NS)+ISL(NS)-1).EQ.OPT(NCC))GOTO 300  IF(CCRD(ISS(NS):ISE(NS)).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) ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) f! NCTLS=NCTLS+1 f" CTLLIS(NCTLS) = BLKLIN f#o WRITE(CTLLIS(NCTLS),211) CCRD(IES:ISS(NS)+ISL(NS)-1) WRITE(CTLLIS(NCTLS),211) CCRD(IES:ISE(NS)) f$211 FORMAT(' Control record parameter ',A, f% 1 ' not recognized - (ignored)')  { CALL WRTIO(CTLLIS(NCTLS))  LM=ITRAIL(CTLLIS(NCTLS)) CALL WRTIO(CTLLIS(NCTLS)(1:LM)) 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 o IF(CCRD(ISS(NS+2):ISS(NS+2)+ISL(NS+2)-1).EQ.'0')THEN  IF(CCRD(ISS(NS+2):ISE(NS+2)).EQ.'0')THEN H NAM=' ' C  IWNAM=2 I ISW=1 J ELSE K NAM=WORD(NS+2) C o NAM=CCRD(ISS(NS+2):ISS(NS+2)+ISL(NS+2)-1)  NAM=CCRD(ISS(NS+2):ISE(NS+2)) C o IWNAM=ISL(NS+2) IWNAM=ISE(NS+2)-ISS(NS+2)+1 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 o 1 2100,2200,2300,2400),IC r n 1 2100,2200,2300,2400,2500),ICi 1 2100,2200,2300,2400,2500,2600),IC  1 2100,2200,2300,2400,2500,2600,2700),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) ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) 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)'){ CALL WRTIO(CTLLIS(NCTLS)) LM=ITRAIL(CTLLIS(NCTLS))  CALL WRTIO(CTLLIS(NCTLS)(1:LM)) 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) ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) f1 NCTLS=NCTLS+1 f2 CTLLIS(NCTLS) = BLKLIN f3 WRITE(CTLLIS(NCTLS),2111) f42111 FORMAT(' Control parameter Q requested after F - (F disabled)'){ CALL WRTIO(CTLLIS(NCTLS)) LM=ITRAIL(CTLLIS(NCTLS)) CALL WRTIO(CTLLIS(NCTLS)(1:LM)) 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)~ IF(NCTLS.GE.MAXCTL)CALL CTLCRE(CTLLIS(NCTLS),NCTLS,NCCERR) 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)') { CALL WRTIO(CTLLIS(NCTLS))  LM=ITRAIL(CTLLIS(NCTLS))  CALL WRTIO(CTLLIS(NCTLS)(1:LM)) f= NCTLS=NCTLS+1 f> CTLLIS(NCTLS) = BLKLIN t ENDIF u1330 CONTINUE v GOTO 7000 wC xC C COMPILE yC z1400 CONTINUE {n IF(ISW.EQ.0) THEN | NAM='COMPILE.FOR']  NAM='COMPILE'//COMEXT f?n NAM='COMPILE' Cn IWNAM=11 }n ICC=.TRUE. ~n ELSE IF (ISW.EQ.1) THEN  IF (ISW.EQ.1) THEN  ICC=.FALSE.  n ELSEIF (INDEX(NAM(1:IWNAM),'*').NE.0)THEN n SCOMPF = .TRUE.  n CALL FILEID(LCO,NAM,NAMLCO) n IWNAM = ITRAIL(NAMLCO) n ENDIF n NAMLCO=NAM Cn IWLCO=IWNAM ELSE ICC=.TRUE.  IF (INDEX(NAM(1:IWNAM),'*').NE.0)THEN SCOMPF = .TRUE.  IAA = INDEX(NAM(1:IWNAM),'**')  IF(IAA.NE.0) THEN  SCALLF = .TRUE. IWNAM = IWNAM - 1 i NAM(1:IWNAM) = NAM(1:I)//NAM(IAA+1:)  FNAME = NAMg NAM(1:IWNAM) = FNAME(1:I)//FNAME(IAA+1:)  IF(IAA.GT.1) THEN  NAM(1:IWNAM) = FNAME(1:IAA-1)//FNAME(IAA+1:)  ELSE  NAM(1:IWNAM) = FNAME(2:)  ENDIF  ELSE  SCALLF = .FALSE.  ENDIF  ELSE  SCOMPF = .FALSE.  ENDIF  ICC = .TRUE.  NAMLCO = NAM  IWLCO = IWNAM  ENDIF GOTO 7000 C C L LIST C 1500 CONTINUE IF(ISW.EQ.1) THEN ICL=.FALSE.  ELSE  NAMLOU=NAM C IWLOU=IWNAM n CALL FILEID(LOU,NAM,NAMLOU)  NAMLOU = NAM n IWLOU = ITRAIL(NAMLOU)  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))n CALL FILEID(LSO,NAM,NAMLSO)  NAMLSO = NAM n IWLSO=ITRAIL(NAMLSO)  IWLSO = IWNAM ICS=.TRUE.  IF (INDEX(NAM(1:IWNAM),'*').NE.0)THEN  SSOURF = .TRUE.  ENDIF 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)){ CALL FILEID(LNP,NAM,FNAME) n CALL FILEID(LNP,NAM,NAMLNP) NAMLNP = NAM n IWLNP=ITRAIL(NAMLNP) ! IWLNP = IWNAM { IRECS = 10 { MXRECS = 5000{ CALL OPENER(LNP,FNAME(1:ITRAIL(FNAME)),'NEW','DIRECT', { $ 'UNFORMATTED',NCHRWD*NWRDBK,IRECS,MXRECS,IERR) 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)){ CALL FILEID(LOA,NAM,FNAME) n CALL FILEID(LOA,NAM,NAMLOA) " NAMLOA = NAM n IWLOA=ITRAIL(NAMLOA) # IWLOA = IWNAM { ICHARS = 80 { IRECS = 10 { MXRECS = 5000{ CALL OPENER(LOA,FNAME(1:ITRAIL(FNAME)),'NEW','SEQUENTIAL', { $ 'FORMATTED',ICHARS,IRECS,MXRECS,IERR) 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  n CALL FILEID(LOP,NAM,NAMLOP) $ NAMLOP = NAM !n IWLOP = ITRAIL(NAMLOP) % 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 "n CALL FILEID(LIA,NAM,NAMLIA) & NAMLIA = NAM #n IWLIA = ITRAIL(NAMLIA) ' 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 { IF(ISW.EQ.0) THEN {C (SQ) { LSEQC=1 { ELSE IF (ISW.EQ.1) THEN {C (SQ=0) { LSEQC=3 { ELSE { C (SQ=F C or N) { LSEQC = INDEX('FCN',NAM(1:1)) { IF(LSEQC.LT.1) THEN { WRITE(LTO,2211) NAM(1:1) ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) { NCTLS=NCTLS+1 { WRITE(CTLLIS(NCTLS),2211) NAM(1:1){2211 FORMAT(' Unrecognized SQ control parameter option ', { 1 A,' (set to F)') ${ CALL WRTIO(CTLLIS(NCTLS))  LM=ITRAIL(CTLLIS(NCTLS))  CALL WRTIO(CTLLIS(NCTLS)(1:LM)) { LSEQC = 1 { ENDIF { ENDIF ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) { NCTLS=NCTLS+1 { CTLLIS(NCTLS)=' The compile file sequencing type will be - '// { 1 SEQTYP(LSEQC)  LM=ITRAIL(CTLLIS(NCTLS)) CALL WRTIO(CTLLIS(NCTLS)(1:LM)) R GOTO 7000 dC dC LA - LANGUAGE SWITCH PROCESSING.dC d 2300 CONTINUEd  LANGT=INDEX('FC',NAM(1:1)) % LANGT = INDEX(CLANGF,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) ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) 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)')&{ CALL WRTIO(CTLLIS(NCTLS)) LM=ITRAIL(CTLLIS(NCTLS))  CALL WRTIO(CTLLIS(NCTLS)(1:LM)) fP NCTLS=NCTLS+1fQ CTLLIS(NCTLS) = BLKLIN d ELSE d LANG = LANGT d ENDIF d GOTO 7000 C oC CD - Compile Directives Switch oC o2400 CONTINUE IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) o IF(ISW.EQ.2) THEN o  IF(NAM(1:1).EQ.'0') THEN o  ICCD=.FALSE. o  ELSE o  ICCD=.TRUE. rC rC any character other than 0 will be used ahead of directives rC on compile filerC r NCPLDI = IWNAM r CPLDI = NAM o  ENDIF o ELSE o ICCD=.TRUE. o ENDIF oC o NCTLS=NCTLS+1 o IF(ICCD) THEN o CTLLIS(NCTLS)=' Imbedded directives will be written'// o 1 ' on compile file' r 1 ' on compile file, preceeded with '//NAM(1:IWNAM) o ELSEo CTLLIS(NCTLS)=' Imbedded directives will NOT be written'// o 1 ' on compile file' { IF(ISW.EQ.0) THEN {C (CD) { ICCD = .TRUE.~{ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) { NCTLS=NCTLS+1{ CTLLIS(NCTLS)=' Imbedded directives will be written'// { 1 ' on compile file' { ELSEIF (ISW.EQ.1) THEN { C (CD = 0) {! ICCD = .FALSE. ~{ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) {" NCTLS=NCTLS+1{# CTLLIS(NCTLS)=' Imbedded directives will NOT be written'// {$ 1 ' on compile file' {% ELSE {&C (CD = str) {' ICCD = .TRUE. {( NCPLDI = IWNAM {)2410 ILBLP = INDEX(NAM(1:IWNAM),'#') {* IF(ILBLP.NE.0) THEN {+ NAM(ILBLP:ILBLP) = ' ' {, GOTO 2410 {- ENDIF {. CPLDI = NAM ~{ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) {/ NCTLS=NCTLS+1{0 CTLLIS(NCTLS)=' Imbedded directives will be written on'//{1 1 ' compile file, preceeded by ('//NAM(1:IWNAM)//')' o ENDIF  LM=ITRAIL(CTLLIS(NCTLS)) CALL WRTIO(CTLLIS(NCTLS)(1:LM)) o GOTO 7000 oC rC rC UC - Upper case for output rC r2500 CONTINUE r ICUC = .TRUE. r GOTO 7000 )C *C M modify file definition +C ,2600 CONTINUE - IF(ISW.EQ.1) THEN . ICM = .FALSE./ ELSE 0 NAMLMO = NAM 1 IWLMO = IWNAM 2 ICM = .TRUE. 3 ENDIF 4 GOTO 7000 5iC C C PR - change prefix character  C 2700 CONTINUE IF(NAM(1:1).EQ. ' ') THEN NCTLS = NCTLS + 1 CTLLIS(NCTLS) =  1 ' Improper PR (prefix) parameter (blank not allowed)'  LM = ITRAIL(CTLLIS(NCTLS))  CALL WRTIO(CTLLIS(NCTLS)(1:LM))  ELSE  PRFX = NAM(1:1)  NCTLS = NCTLS + 1 CTLLIS(NCTLS) = ' *** Prefix character being set to '//PRFX  LM = ITRAIL(CTLLIS(NCTLS))  CALL WRTIO(CTLLIS(NCTLS)(1:LM))  ENDIF  C  GOTO 7000 6C 7C 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) ~{ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) fS{ NCTLS=NCTLS+1fT CTLLIS(NCTLS) = BLKLIN fU{ WRITE(CTLLIS(NCTLS),9011)fV{9011 FORMAT(' Setting width to default value of 72') '{ CALL WRTIO(CTLLIS(NCTLS)) 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)) ( ICHARS = 133 ) IRECS = 10 *u MXRECS = 25000  MXRECS = 1000 +k CALL OPENER(LOU,NAMLOU(1:IWLOU),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LOU,'LISTING',NAMLOU,IWLOU,STATUS,IDDNAM) CALL OPENER(LOU,NAMLOU(1:IWLOU),IDDNAM,STATUS,'SEQUENTIAL', , $ 'LISTING',ICHARS,IRECS,MXRECS,IERR)  IF(IERR.NE.0) THEN j IF(NCTLS.GE.MAXCTL)CALL CTLCRE(CTLLIS(NCTLS),NCCERR)  IF(NCTLS.GE.MAXCTL)CALL CTLCRE(CTLLIS(NCTLS),NCTLS,NCCERR)  NCTLS=NCTLS+1  CTLLIS(NCTLS)=' Unable to open OUTPUT LISTING file '//! 1 NAMLOU(1:IWLOU) " NCCERR=NCCERR+1 # ICL=.FALSE.  DO 9020 I=1,8  ICLST(I)=.FALSE. 9020 CONTINUE $ LM=ITRAIL(CTLLIS(NCTLS)) % CALL WRTIO(CTLLIS(NCTLS)(1:LM)) & GOTO 9300 ' ENDIFfY CALL HEADER('Phase one processing') w CALL HEADER('Input data processing') fZC f[ DO 9070 I=1,NCTLSf\ DO 9040 L=132,2,-1i{ DO 9040 L=128,2,-1f]{ IF(CTLLIS(I)(L:L).NE.' ') GOTO 9060 f^{9040 CONTINUE f_{ L=1 ( L=ITRAIL(CTLLIS(I)) f`C fa9060 WRITE(LOU,9061) CTLLIS(I)(1:L)r9060 ERRMSG = CTLLIS(I)(1:L) rn IF (ICUC) CALL UCASE(ERRMSG(1:L),ERRMSG(1:L)) 8 IF (ICUC) CALL UCASE(ERRMSG(1:L)) r WRITE(LOU,9061) ERRMSG(1:L) fb9061 FORMAT(A) fc CALL LININC(1) fd9070 CONTINUE  ELSE DO 9200 I=1,8 ICLST(I)=.FALSE. 9200 CONTINUE ENDIF )9300 CONTINUE *w IF(ICN) THEN +w IRECS = 10 ,w MXRECS = 15000 -w CALL OPENER(LNP,NAMLNP(1:IWLNP),'NEW','DIRECT', .w $ 'UNFORMATTED',NCHRWD*NWRDBK,IRECS,MXRECS,IERR) /w IF(IERR.NE.0) THEN 0w ERRMSG=' Unable to open NEW LIBRARY file '// 1w 1 NAMLNP(1:IWLNP) 2w NCCERR=NCCERR+1 3wC 4w ICN=.FALSE. 5wC 6w ELSE7z ERRMSG=' Opened NEW LIBRAY file '// w ERRMSG=' Opened NEW LIBRARY file '// 8w 1 NAMLNP(1:IWLNP) 9w ENDIF :w CALL WRMES ;w ENDIF <wC = IF(ICNA) THEN > ICHARS = 80 ? IRECS = 10 @ MXRECS = 25000 Ak CALL OPENER(LOA,NAMLOA(1:IWLOA),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LOA,'NEW PORTABLE LIBRARY',NAMLOA,IWLOA,STATUS,  $ IDDNAM)  CALL OPENER(LOA,NAMLOA(1:IWLOA),IDDNAM,STATUS,'SEQUENTIAL', B $ 'FORMATTED',ICHARS,IRECS,MXRECS,IERR) C IF(IERR.NE.0) THEN Dz ERRMSG=' Unable to open NEW FORMATTED LIBRARY file '// ERRMSG=' Unable to open NEW PORTABLE LIBRARY file '// E 1 NAMLOA(1:IWLOA) F NCCERR=NCCERR+1 GC H ICNA = .FALSE.IC J ELSEKz ERRMSG=' Opened NEW FORMATTED LIBRARY file '// ERRMSG=' Opened NEW PORTABLE LIBRARY file '// L 1 NAMLOA(1:IWLOA) M ENDIF N CALL WRMES O ENDIF PC  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)) - ICHARS = 80 .k CALL OPENER(LIA,NAMLIA(1:IWLIA),'OLD','SEQUENTIAL', STATUS = 'OLD'  CALL FILECK(LIA,'OLD PORTABLE LIBRARY',NAMLIA,IWLIA,STATUS, $ IDDNAM)  CALL OPENER(LIA,NAMLIA(1:IWLIA),IDDNAM,STATUS,'SEQUENTIAL', / $ 'FORMATTED',ICHARS,0,0,IERR) fg{ CALL RDOPLA(LIA) Q IF(IERR.NE.0) THEN Rz ERRMSG=' Unable to open OLD FORMATTED LIBRARY file '// ERRMSG=' Unable to open OLD PORTABLE LIBRARY file '// S 1 NAMLIA(1:IWLIA) T NCCERR=NCCERR+1 U ICPA=.FALSE. V ELSEWz ERRMSG=' Opened OLD FORMATTED LIBRAY file '//  ERRMSG=' Opened OLD PORTABLE LIBRARY file '// X 1 NAMLIA(1:IWLIA) Y ENDIF Z CALL WRMES [C \ IF(ICPA) CALL RDOPLA (LIA) fh ENDIF fiC fj IF(ICP) THENfk CALL OPNLOP (LOP,NAMLOP(1:IWLOP))0k CALL OPENER(LOP,NAMLOP(1:IWLOP),'OLD','DIRECT', STATUS = 'OLD'  CALL FILECK(LOP,'OLD LIBRARY',NAMLOP,IWLOP,STATUS,IDDNAM) CALL OPENER(LOP,NAMLOP(1:IWLOP),IDDNAM,STATUS,'DIRECT', 1 $ 'UNFORMATTED',NCHRWD*NWRDBK,0,0,IERR) fl{ CALL RDOPL (LOP) ] IF(IERR.NE.0) THEN ^ ERRMSG=' Unable to open OLD LIBRARY file '// _ 1 NAMLOP(1:IWLOP) ` NCCERR=NCCERR+1 a ICP = .FALSE. b ELSEcz ERRMSG=' Opened OLD LIBRAY file '//  ERRMSG=' Opened OLD LIBRARY file '// d 1 NAMLOP(1:IWLOP) e ENDIF f CALL WRMES gC h IF (ICP) CALL RDOPL(LOP) iC 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{ ENDIFr ERRMSG=' Language being set to default '//LANGNM(LANG) r CALL WRMES f|iC f} WRITE(LTO,9511) LANGNM(LANG) f~9511 FORMAT(' Language being set to default ',A) f ENDIF C  IF(PRFX .EQ. ' ') THEN  PRFX = '*'  ENDIF gC j IF(MWIDE.EQ.0 ) THEN k MWIDE=72 l ERRMSG=' Setting width to default value of 72' m CALL WRMES n ENDIF oC g IF (ICC) THEN  IF(LSEQC.EQ.1) THEN u MWIDEC = MWIDE+15  MWIDEC = MWIDE+13  ELSE IF(LSEQC.EQ.2) THEN  MWIDEC = MWIDE+8  ELSE  MWIDEC = MWIDE  ENDIFg IF(NAMLCO .EQ. 'COMPILE' ) THEN g NAMLCO(8:11)=COMEXT(LANG) g ENDIF2z*IF IBM 3z*IF IBMVM 4z FTYPE(1) = ' '//LANGNM(LANG) 5z*ENDIF 6z*ENDIF 7z*IF -IBM8z FTYPE(1) = COMEXT(LANG) 9z*ENDIF n POSTID(1) = COMEXT(LANG) :n FNAME = NAMLCO ;n CALL FILEID(LCO,FNAME,NAMLCO)<n IWLCO = ITRAIL(NAMLCO) g CALL OPNLCO (LCO,NAMLCO(1:IWLCO)) =z ICHARS = MWIDE >z IF (LSEQC .EQ. 1) ICHARS = MWIDE + 15?z IF (LSEQC .EQ. 2) ICHARS = MWIDE + 8 @z IRECS = 10 Az MXRECS = 25000 Bz CALL OPENER(LCO,NAMLCO(1:IWLCO),'NEW','SEQUENTIAL', Cz $ 'FORMATTED',ICHARS,IRECS,MXRECS,IERR)pz IF(IERR.NE.0) THEN qz ERRMSG=' Unable to open COMPILE file '// rz 1 NAMLCO(1:IWLCO) sz NCCERR=NCCERR+1 tz ELSEuz ERRMSG=' Opened COMPILE file '// vz 1 NAMLCO(1:IWLCO) wz ENDIF xz CALL WRMES gz ENDIF DzC E{ IF (ICS) CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL',F{ $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR) yz IF (ICS) THEN zz CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL', {z $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR) |z IF(IERR.NE.0) THEN }z ERRMSG=' Unable to open SOURCE file '// ~z 1 NAMLSO(1:IWLSO) z NCCERR=NCCERR+1 z ELSEz ERRMSG=' Opened SOURCE file '// z 1 NAMLSO(1:IWLSO) z ENDIF z CALL WRMES ENDIF C ~ IF(NCCERR.GT.0) THEN ~ CALL ENDPRO(2)G{ CALL THEEND(2,'Control Statement error')  CALL THEEND(2,' Control Statement processing error') ~ ENDIF C  IF (LANG .EQ. 2 .AND. NCPLDI .EQ. 0 ) THEN  NCPLDI = 6  CPLDI = ' '  ENDIF C RETURN C END OF FILE ENCOUNTERED ON INPUT 10000 CALL THEEND(2,' END-OF-FILE encountered on INPUT file')  END CTLCRE 7/03/84 SUBROUTINE CTLCRE (A,NCTLS,NCCERR) C C Error subroutine for CTLCRD C A - character string to write message into C NCTLS - control output record count - to be decremented C NCCERR - count of errors in CTLCRD C C Will write error message into character argument  C CHARACTER*(*) A  C DATA NSKPD /0/  C  NSKPD=NSKPD+1 C  WRITE(A,11) NSKPD 11 FORMAT('***** NOTE ',I5,' Messages are missing here *****'  1 ,' there are too many messages (CTLCRD parameter MAXCTL).') C  NCTLS=NCTLS-1  NCCERR=NCCERR+1  RETURN  END BPA2 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/82DELFIL 8/31/84  SUBROUTINE DELFIL(LUN) C C THIS SUBROUTINE CLOSES AN ATTACHED FILE AND DELETES IT. C  INTEGER LUN C *IF NPS *CALL NPSARG v CHARACTER ACCESS*10, FORM*11, BLANK*4, FNAME*72  CHARACTER ACCESS*10, FORM*11, BLANK*4, FNAME*72, NPSREM*120 INTEGER NEXT LOGICAL QEXIST, QOPEN, QNAMED  C CALL BYUNIT(LUN, $ QEXIST,QOPEN,QNAMED,ACCESS,FORM,FNAME,NEXT,BLANK, $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)v IF (QREADY.AND.QERROR) CALL NPSEIO('BYUNIT VIA DELFIL')  IF (QREADY.AND.QERROR) THEN  WRITE (NPSREM,'(A,I5)') 'BYUNIT called with LUN=',LUN  CALL NPSEIO('BYUNIT via DELFIL',NPSREM(1:ITRAIL(NPSREM)))  ENDIF  IF (QERROR) GO TO 100 C  CALL DELETE(LUN,FNAME,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)v IF (QREADY.AND.QERROR) CALL NPSEIO('DELETE VIA DELFIL')  IF (QREADY.AND.QERROR) THEN  WRITE (NPSREM,'(A,I5,A,A)') 'DELETE called with LUN=',LUN, $ ' and FNAME=',FNAME(1:ITRAIL(FNAME))  CALL NPSEIO('DELETE via DELFIL',NPSREM(1:ITRAIL(NPSREM))) ENDIF 100 IF (QERROR) CLOSE (UNIT=LUN,STATUS='DELETE')*ENDIF NPS *IF -NPS CLOSE (UNIT=LUN,STATUS='DELETE')*ENDIF -NPS  RETURN  END 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,NAMLIAz CHARACTER*72 NAM,NAMLCO,NAMLOU,NAMLOP,NAMLIA,NAMLNP,NAMLOA ]C COMEXT - compileDIRCHK 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/82raXC.)  SUBROUTINE EDIADD(A))*IF EDIT  CHARACTER*(*) A C C ADD STRING ONTO CURRENT RECORD C *CA PARAMA *CA EDITCO *CA DECA Cr*CALL EDIBKUr*CA LOGU 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 EDIBKO('D',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' r3 FORMAT(1X,A)r1100 WRITE(LTO,3)'Record cannot be added to'  1100 CALL WRTIO(' Record cannot be added to.') Cr LBAKUF=.FALSE. # RETURN $C %1200 PRINT*,'CURRENT RECORD DELETED/INACTIVE CANNOT ADD' C LBAKUF=.FALSE. X CALL EDIPOS )*ENDIF & RETURN ' END ( 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 EDIBKI 12/06/84 SUBROUTINE EDIBKI(NADD,NDEL,IERR) C C process recover using new format C *IF EDIT*CA PARAMA *CA EDITCO *CA DECA *CA LOGU *CA ERRMES *CALL WIDTH CHARACTER*(MAXWID+8) BUF C IERR=0  NADD=0  NDEL=0 n10 READ(LBI,11,END=9000,ERR=8000) BUF 10 READ(LBI,11,END=9000,ERR=8000) BUF(1:MWIDE+8) 11 FORMAT(A) n NC=ITRAIL(BUF)  NC=ITRAIL(BUF(1:MWIDE+8))  IF(NC.LT.8) GOTO 8000  IF(NC.LT.9) NC=9  IREC=RVAL(BUF(2:8))  IF(IREC.LT.0) GOTO 8000 C  WRITE(LBO,11) BUF(1:NC) C  IF(BUF(1:1).EQ. 'D') THEN C delete record IREC  IR(IREC)=-IR(IREC)  RCOUNT = RCOUNT - 1  NDEL=NDEL+1  ELSEIF(BUF(1:1).EQ. 'I') THEN C insert record at IREC  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 )q L(NRECT)=IDECPN  L(NRECT)=IREC  IR(NRECT)=IDECPN * NW=(NC-8+NCHRWD-1)/NCHRWD + IDECP1=IDECPN, CALL ININ(IDECPN,NW,1) - CALL INCHW(BUF(9:),ADEC(IDECPN),NW*NCHRWD) . IDECPN=IDECPN+NW / NADD=NADD+1  RCOUNT = RCOUNT + 1 0 ELSE 1 GOTO 8000 2 ENDIF 3 GOTO 10 48000 IERR=1 5C 6C error condition7C 8 ERRMSG=' *ERROR* during recovery processsing.' 99000 CONTINUE:*ENDIF EDIT ; RETURN < END z IF(CCRD(1:4).NE.'SLIB') THENEDIBKO 12/06/84 SUBROUTINE EDIBKO (KEY,IREC,ALF)C C writes new backup file C *CA LOGU  CHARACTER KEY*1,ALF*(*) C  WRITE(LBO,11) KEY,IREC,ALF 11 FORMAT(A1,I7.7,A) RETURN  END IERR=0 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/82rC>;)  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 Cr*CALL EDIBKUr*CA LOGU  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' r WRITE(LTO,3)'Second change delimeter not found' r3 FORMAT(1X,A)  CALL WRTIO(' Second change delimeter not found.') Cr LBAKUF=.FALSE. RETURN  ENDIF C > IF(LENA.LT.LD+1) THEN >  PRINT*,' New string has no length re-enter' r WRITE(LTO,3)'New string has no length'  CALL WRTIO(' New string has no length.') Cr 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 ord cannot be added to.') Cr LBAKUF=.FALSE. # RETURN $C %1200 PRINT*,'CURRENT RECORD DEDICH1 6/14/82 raC>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 DECA Cr*CALL EDIBKUr*CA LOGU.*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)  CALL EDIBKO('D',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' r WRITE(LTO,501)'Text to substitute for not found' r501 FORMAT(1X,A) CALL WRTIO(' Text to substitute for not found.') Cr LBAKUF=.FALSE. + IREC=IRECS > CALL EDIPOS )*ENDIF , RETURN - END RETURN ' END ( 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:ICEDICNS 11/19/84p SUBROUTINE EDICNS (NDCK) SUBROUTINE EDICNS (NDCK, IERR) C C Continue from Source file C *IF EDIT*CALL PARAMA*CALL EDITCO*CALL BUFA  *CALL ERRMES *CALL LOGU  *CALL WIDTH  *CALL PRFX  *CALL SCAN C  CHARACTER*8 DNAME, AA(20)  DIMENSION IRD(5)C C number of records added/deleted C  IERR = 0  NRADD = 0  NRDEL = 0C C Look for proper DECK directive record C 100 READ(LCI,101,ERR=8000, END=7000 ) BUF(1:MWIDE) 101 FORMAT(A) C  LENB = ITRAIL(BUF(1:MWIDE)) C  IF(LENB.LT.5.OR.BUF(1:1).NE.PRFX) GOTO 100 C  CALL CKDIR(BUF(1:LENB),ITDIR) !C " IF(ITDIR.EQ.15) GOTO 3000 # IF(ITDIR.NE.5) GOTO 100 $C %C DECK DIRECTIVE &C '120 CALL SCANDI(BUF(1:LENB))(C ) IF(NWRD.LT.2) GOTO 100 *C +o DNAME = BUF(ISS(2):ISS(2)+ISL(2)-1)  DNAME = BUF(ISS(2):ISE(2)) , IF(DNAME .NE. EDECK) GOTO 100 -C .C Found DECK directive record for this deck /C 0150 IADD = 01200 READ(LCI,101,ERR=8000,END=7000) BUF(1:MWIDE)2 LENB=ITRAIL(BUF(1:MWIDE)) 3 IF(BUF(1:1).EQ.PRFX) THEN 4 IF(BUF(2:2).EQ.'''') GOTO 2005 CALL CKDIR(BUF(1:LENB),ITDIR) 6 ELSE 7 ITDIR=0 8 ENDIF 9C :C 0 *A *AC *CA *C *DK *DF *D *E *EI *ID *IF *I ; GOTO(1000,100,100,1000,100,120,100,2000,100,1000,100,1000,2000, < 1 100,900,3000,100,100,100,100,1000,1000,1000), ITDIR+1 =C *M *R *RD *PU *UP *Y *RN *VL *CG *GN >C ?C *RESTORE - ILLEGAL @C A900 ERRMSG='*ERROR* RESTORE directive encountered during recovery' B910 CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) C920 ERRMSG=' '//BUF D CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG)))E CALL THEEND(2,' Continue processing error')  IERR = 1  RETURN FC GC Record needs to be added HC I1000 IF(IADD.EQ.0) THEN J ERRMSG='*ERROR* Record to be added does not follow *D or *I' K GOTO 910 L ELSE M CALL EDIINS(BUF(1:LENB))  CHANGE = CHANGE + 1 N NRADD = NRADD + 1 O ENDIF P GOTO 200QC RC Insert or Delete directive SC T2000 IADD=1 U CALL SCANDI(BUF(1:LENB)) V IF(NWRD.GT.0) THEN Wo AA(1)=BUF(ISS(1)+1:ISS(1)+ISL(1)-1)  AA(1)=BUF(ISS(1)+1:ISE(1)) X DO 2020 I=2,NWRD Yo AA(I)=BUF(ISS(I):ISS(I)+ISL(I)-1)  AA(I)=BUF(ISS(I):ISE(I)) Z2020 CONTINUE [ ELSE \ ERRMSG='*ERROR* Improper insert directive during recovery' ] GOTO 910 ^ ENDIF _ CALL LOCCNT(ITDIR,NDCK,LOC1,LOC2,AA,NWRD) `t IF(LOC1.EQ.0) THEN at GOTO 920 bt ENDIF  IF(LOC1.LT.0) GOTO 920 cC set pointer to record d IREC=LOC1 e IF(ITDIR.EQ.12) GOTO 200fC delete g2200 IDECP1=IR(IREC) h IF(IDECP1.LT.0) GOTO 2400 i CALL EXIN(IDECP1,IRD,5) j IF(IRD(4).LT.0) GOTO 2400 k IR(IREC) = -IR(IREC)  CHANGE = CHANGE + 1  RCOUNT = RCOUNT - 1 q CALL EDIBKI('D',IREC,' ')  CALL EDIBKO('D',IREC,' ') l NRDEL = NRDEL+1 m2400 IF(IREC.GE.LOC2) GOTO 200 n NREC=N(IREC) o IF(NREC.GT.NRECI) THEN p ERRMSG='*ERROR* The following record is improperly placed:' q GOTO 910 r ENDIF s IREC=NREC t GOTO 2200 uC *READ directive v3000 CALL NXUNIN(BUF(1:LENB),LCI) w GOTO 100xC End-of-file y7000 IF(LCI.LE.51) GOTO 9000 z CALL CLSFIL(LCI) { LCI=LCI-1 | GOTO 100}C ***read error*** ~8000 WRITE(ERRMSG,8011) LCI 8011 FORMAT(' **ERROR** File read error encountered on unit',I5,  1 ' during CONTINUE processing')  CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG)))C ***end*** 9000 IREC=0  WRITE(ERRMSG,9911)NRDEL,NRADD 9911 FORMAT(I15,' Records deleted',I10,' Records added.') CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG)))*ENDIF EDIT RETURN  END IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) 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)'){ CALL EDICON 6/14/82)  SUBROUTINE EDICON )*IF EDITC C CONTINUE EDIT RUN C *CA PARAMA *CA EDITCO *CA LOGU*CA DECAC wC MAXBYT - Maximum number of bytes per record w PARAMETER (MAXBYT = 30000) C MAXWW - Number of words to read to get MAXBYT w PARAMETER (MAXWW = (30000 + NCHRWD-1)/NCHRWD)  PARAMETER (MAXWW = (MAXBYT + NCHRWD-1)/NCHRWD) C  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) 1000 IF((IDECPN-IDECI)*NCHRWD .LE. MAXBYT) THEN  CALL RDBLKC (LDI,ADEC(IDECI+1),IDECPN-IDECI) ELSE  CALL RDBLKC (LDI,ADEC(IDECI+1),MAXWW) IDECI=IDECI+MAXWW GOTO 1000 ENDIF C  INW=0 2000 IF((NRECT+1-INW)*NCHRWD .LE. MAXBYT) THEN  CALL RDBLKI (LDI,IR(INW),NRECT+1)  CALL RDBLKI (LDI,N(INW) ,NRECT+1)  CALL RDBLKI (LDI,L(INW), NRECT+1)  ELSE  CALL RDBLKI (LDI, IR(INW), MAXWW)  CALL RDBLKI (LDI, N(INW), MAXWW)  CALL RDBLKI (LDI, L(INW), MAXWW)  INW=INW+MAXWW  GOTO 2000  ENDIF )*ENDIF  RETURN  END CHARACTER*72 NAM,NAMLCO,NAMLOU,NAMLOP,NAMLIAz CHARACTER*72 NAM,NAMLCO,NAMLOU,NAMLOP,NAMLIA,NAMLNP,NAMLOA ]C COMEXT - compile filEDIDEL 6/14/82 rC<)#  SUBROUTINE EDIDEL(A))*IF EDIT  CHARACTER*(*) A C C DELETE CURRENT RECORD C *CA PARAMA *CA EDITCO *CA DECA Cr*CALL EDIBKUr*CA LOGU 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)  CALL EDIBKO('D',IREC,' ')  PRINT*,'[RECORD DELETED]' < PRINT*,'' r WRITE(LTO,3)'' r3 FORMAT(1X,A) CALL WRTIO(' ')  CALL EDINEX(A)  CALL EDIPOS  CHANGE = CHANGE + 1  RCOUNT = RCOUNT - 1  RETURN 1100 PRINT*,'CURRENT RECORD IS NOT ACTIVE-CANNOT DELETE' r1100 WRITE(LTO,3)'Current record is not active - cannot delete' 1100 CALL WRTIO(' Current record is not active - cannot delete.') Cr LBAKUF=.FALSE.  CALL EDIPOS )*ENDIF  RETURN  END 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) CHARACTER*20 EDIDIC,EDIDIL  DIMENSION JREF(0:20) 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/  DATA EDIDIC /'TBF''"NP.AIDRCS-HE+Q*'/  DATA EDIDIL /'tbf''"np.aidrcs-he+q*'/  DATA JREF /0,1,2,3,3,3,4,5,5,6,7,8,9,10,10,11,12,13,14,15,16/  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 CALL EDITOR @ IEDECK=0 @100 CALL EDIINI(IEDECK) @ IF(IEDECK.GT.0) THEN EDIEND 6/14/823vuraXSRPH@.) n SUBROUTINE EDIEND(A)  SUBROUTINE EDIEND )*IF EDITnC nC PROCESS FOR END OF RUN nC WRITE COMPILE FILE nC nC WRITE SOURCE FILE FOR FUTURE BATCH INPUTnC nC WRITE DUMP FOR FUTURE INPUT C C processing for end of edit run C Count and write compile and modify files for each deck C  C  *CA PARAMA  *CA LOGU *CA EDITCO  *CA DECA*CA MODNA *CA DECKS *CA FNAMES *CA SEQCTL *CA WIDTH *CA ERRMES *CA IFSWI n CHARACTER*(*)A C C WCOMPF - TRUE - write compile file FALSE - dont n LOGICAL WCOMPF  LOGICAL WCOMPF C C COUNT - TRUE - just counting FALSE - writing LOGICAL COUNT  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  CHARACTER STATUS*8 X CHARACTER*40 DELREC X CHARACTER*20 DELRE(2) X EQUIVALENCE(DELRE(1),DELREC)C wC MAXBYT - Maximum number of bytes per record w PARAMETER (MAXBYT = 30000) mC MAXWW - Number of words to write to get MAXBYT w PARAMETER (MAXWW = (30000 + NCHRWD-1)/NCHRWD) m PARAMETER (MAXWW = (MAXBYT + NCHRWD-1)/NCHRWD) C 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 m MEMEND(1) = IDECPN  MEMSTL(2) = IDECPN + 1  C  IF(ITYPE(IDECE).EQ.0) THEN  WCOMPF = .TRUE.  ELSE C WCOMPF = .FALSE.C we will set this so it writes the common deck compile  WCOMPF = .TRUE. ENDIF  NRECCF = 5000 n NRECSF = 5000 NRECMF = 5000 COUNT = .FALSE. *IF NUMREC  p CALL EDIENL(NRECCF,NRECSF)  n CALL EDIENL(NRECCF,NRECSF,WCOMPF)  COUNT = .TRUE.  n IF(NRECCF.EQ.0) WCOMPF = .FALSE. *ENDIF NUMREC  C n NIFS=0 10 NIFS = 0 ISETIF = .TRUE.  IF(COUNT) THEN  NRECCF = 0  NRECMF = 1  GOTO 98  ENDIF C IF(.NOT.WCOMPF) GOTO 96 k CALL OPENER(LCO,NAMLCO(1:IWLCO),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LCO,'COMPILE',NAMLCO,IWLCO,STATUS,IDDNAM)  CALL OPENER(LCO,NAMLCO(1:IWLCO),IDDNAM,STATUS,'SEQUENTIAL',  1 'FORMATTED',MWIDEC,NRECCF,NRECCF,IERR)  IF(IERR.NE.0) THEN  CALL WRTIO(' Cannot open compile file '//NAMLCO(1:IWLCO)) CALL THEEND(2,' CANNOT OPEN COMPILE FILE')  ELSE  WRITE(ERRMSG,91) 'compile',NAMLCO(1:IWLCO),NRECCF91 FORMAT(' Opened ',A,' file ',A,' for ',I5,' records') CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG)))  ENDIF C p CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL',  n96 CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL', k96 CALL OPENER(LMO,NAMLMO(1:IWLMO),'NEW','SEQUENTIAL', 96 STATUS = 'NEW'  CALL FILECK(LMO,'MODIFY',NAMLMO,IWLMO,STATUS,IDDNAM) CALL OPENER(LMO,NAMLMO(1:IWLMO),IDDNAM,STATUS,'SEQUENTIAL', n 1 'FORMATTED',MWIDE,NRECSF,NRECSF,IERR)  1 'FORMATTED',MWIDE,NRECMF,NRECMF,IERR)  IF(IERR.NE.0) THEN n CALL WRTIO(' Cannot open source file '//NAMLSO(1:IWLSO))  CALL WRTIO(' Cannot open modify output file ' 1 //NAMLMO(1:IWLMO))n CALL THEEND(2,' CANNOT OPEN SOURCE FILE') CALL THEEND(2,' Cannot open modify file')  ELSE  n WRITE(ERRMSG,91) 'source',NAMLSO(1:IWLSO),NRECSF  WRITE(ERRMSG,91) 'modify',NAMLMO(1:IWLMO),NRECMF ! CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) " ENDIF #C  WRITE(LSO,11)EDECK 11 FORMAT('*DECK ',A) Sn WRITE(LSO,111) '*DECK ',EDECK  WRITE(LMO,111) '*DECK ',EDECK  LAST=0 X n LAST=1 n IREC=0 n IF(N(IREC).NE.1) THEN n WRITE(LSO,211) '*I 0' n LAST=4 n ENDIF n100 CONTINUE n IREC=N(IREC) n IF(IREC.EQ.0) GOTO 900 !n IDECP1=IR(IREC) "n IF(IDECP1.EQ.0) GOTO 900#n IF(IREC.GT.NRECI) THEN $nC NEW %n IF(IDECP1.LT.0) THEN &nC DELETED 'n GOTO 100 (n ELSE )nC ACTIVE*n CALL EXIN(IDECP1,IRC,1) + IF(LAST.NE.0) THENX n IF(LAST.EQ.1) THEN, CALL EDISID(DCK,NSQ,NAMSEQ)- WRITE(LSO,111)'*I ',NAMSEQ Sn IF(IDK.EQ.0) THEN Sn WRITE(LSO,211) '*I ',NSQ Sn ELSE Sn CALL EDISID(DCK,NSQ,NAMSEQ) Sn WRITE(LSO,111) '*I ',NAMSEQ Sn ENDIF X n ELSE IF(LAST.EQ.2) THEN X n WRITE(LSO,111) DELRE(1)Xn ELSE IF(LAST.EQ.3) THEN Xn WRITE(LSO,111) DELREC . LAST=0 /n ENDIF Xn LAST=40 WRITE(LSO,111)(ADEC(II),II=IDECP1,IDECP1+IRC) n WRITE(LSO,111)(ADEC(II),II=IDECP1,IDECP1+IRC-1) 1111 FORMAT(60A) Rn111 FORMAT(80A) 2 CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------') Hp IF(ITYPE(IDECE).EQ.0) THENn IF(ITYPE(IDECE).EQ.0) THENH CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------')P CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD,'--------',0) un NBLK=0 un DO 120 LB=NCHRWD,2,-1 un IF(ADEC(IDECP1+IRC-1)(LB:LB).NE.' ') GOTO 130un NBLK=NBLK+1 un120 CONTINUE uz130 CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD-NBLK,'--------',0) n130 CALL EDILIS(ADEC(IDECP1),IRC*NCHRWD-NBLK,'--------',0, n 1 EDECK) Hn ENDIF 3n ENDIF 4n ELSE5nC OLD 6n IF(IDECP1.GT.0) THEN 7nC ACTIVE8 CALL EXIN(IDECP1,IRD,5) an CALL EXIN(IDECP1,IRD(1),5)XnC Xn IF(IDEL.GT.0) GOTO 100XnC Xn IF(LAST.EQ.2) THENXn WRITE(LSO,111) DELRE(1)Xn ELSE IF(LAST.EQ.3) THEN Xn WRITE(LSO,111) DELREC Xn ENDIF Xn LAST=19n IDECP1=IDECP1+NMR :n IF(IDK.EQ.0) THEN ;n DCK=EDECK <n ELSE =n DCK=MODNA(IDK) >n 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 un NBLK=0un DO 140 LB=NCHRWD,2,-1 u  IF(ADEC(ILX+LNX-1)(LB:LB).NE.' ') GOTO 160 vn IF(ADEC(IDECP1+LNX-5-NMR-1)(LB:LB).NE.' ') GOTO 160 u n NBLK=NBLK+1 u n140 CONTINUE u 160 NC = (ILX+LNX-IDECP1)*NCHRWD-NBLK vn160 NC = (LNX-5-NMR)*NCHRWD-NBLK C CALL EDILIS(ADEC(IDECP1),NC,NAMSEC) Hp IF(ITYPE(IDECE).EQ.0) THENn IF(WCOMPF) THEN H CALL EDILIS(ADEC(IDECP1),NC,NAMSEC)Pz CALL EDILIS(ADEC(IDECP1),NC,DCK,NSQ) n CALL EDILIS(ADEC(IDECP1),NC,DCK,NSQ,EDECK) Hn ENDIF Dn ELSE EnC DELETED Fn IDECP1=ABS(IDECP1)G CALL EXIN(IDECP1,IRD,5) an CALL EXIN(IDECP1,IRD(1),5) H LAST=0In IF(IRD(2).EQ.0) THEN JnC MAIN K WRITE(LSO,211) IRD(3) L211 FORMAT('*D ',I6) S WRITE(LSO,211) '*D ',IRD(3)Xn IF(LAST.EQ.1.OR.LAST.EQ.4) THENXn WRITE(DELRE(1),211) '*D ',IRD(3) Xn LAST=2 Xn ELSE Xn WRITE(DELRE(2),211) ',',IRD(3) Xn LAST=3 X n ENDIF S n211 FORMAT(A,I6) Mn ELSE NnC MOD On CALL EDISID(MODNA(IDK),NSQ,NAMSEQ) P WRITE(LSO,511) NAMSEQ Q511 FORMAT('*D ',A)S  WRITE(LSO,111) '*D ',NAMSEQX!n IF(LAST.EQ.1.OR.LAST.EQ.4) THENX"n WRITE(DELRE(1),111) '*D ',NAMSEQ X#n LAST=2 X$n ELSE X%n WRITE(DELRE(2),111) ',',NAMSEQ X&n LAST=3 X'n ENDIF Rn ENDIF Sn ENDIF Tn ENDIF Un GOTO 100VnC Wn900 CONTINUE X(n IF(LAST.EQ.2) THEN X)n WRITE(LSO,111) DELRE(1) X*n ELSE IF(LAST.EQ.3) THEN X+n WRITE(LSO,111) DELREC X,n ENDIF $nC C 98 LAST = 1  IREC = 0  IF(N(IREC).NE.1) THEN IF(COUNT) THEN ! NRECMF = NRECMF+1 " ELSE# WRITE(LMO,211) '*I 0' $ ENDIF % LAST = 4 & ENDIF '100 CONTINUE ( IREC = N(IREC) ) IF(IREC.EQ.0) GOTO 900 * IDECPL = IR(IREC) + IF(IDECPL.EQ.0) GOTO 900 , IF(IREC.GT.NRECI) THEN -C NEW . IF(IDECPL.LT.0) THEN /C DELETED 0 GOTO 100 1 ELSE 2C ACTIVE3 CALL EXIN(IDECPL,IRC,1) 4 IF(LAST.EQ.1) THEN 5 IF(COUNT) THEN 6 NRECMF = NRECMF+1 7 ELSE 8 IF(IDK.EQ.0) THEN 9 WRITE(LMO,211) '*I ',NSQ : ELSE ; CALL EDISID(DCK,NSQ,NAMSEQ) < WRITE(LMO,111) '*I ',NAMSEQ = ENDIF > ENDIF ? ELSE IF(LAST.EQ.2) THEN @ IF(COUNT) THEN A NRECMF = NRECMF+1 B ELSE C WRITE(LMO,111) DELRE(1) D ENDIF E ELSE IF(LAST.EQ.3) THEN F IF(COUNT) THEN G NRECMF = NRECMF+1 H ELSE I WRITE(LMO,111) DELREC J ENDIF K ENDIF L LAST = 4 M IF(COUNT) THENN NRECMF = NRECMF+1 O ELSE P WRITE(LMO,111)(ADEC(II),II = IDECPL,IDECPL+IRC-1) Q ENDIF R111 FORMAT(80A) S NBLK = 0 T DO 120 LB = NCHRWD,2,-1 U IF(ADEC(IDECPL+IRC-1)(LB:LB).NE.' ') GOTO 130 V NBLK = NBLK+1 W120 CONTINUE X130 CALL EDILIS(ADEC(IDECPL),IRC*NCHRWD-NBLK,'--------',0,Y 1 EDECK,COUNT,NRECCF) Z ENDIF[ ELSE\C OLD ] IF(IDECPL.GT.0) THEN ^C ACTIVE_ CALL EXIN(IDECPL,IRD(1),5)`C a IF(IDEL.GT.0) GOTO 100bC c IF(LAST.EQ.2) THEN d IF(COUNT) THEN e NRECMF = NRECMF+1 f ELSE g WRITE(LMO,111) DELRE(1) h ENDIF i ELSE IF(LAST.EQ.3) THEN j IF(COUNT) THEN k NRECMF = NRECMF+1 l ELSE m WRITE(LMO,111) DELREC n ENDIF o ENDIF p LAST = 1 q IDECPL = IDECPL+NMR r IF(IDK.EQ.0) THEN s DCK = EDECK t ELSE u DCK = MODNA(IDK) v ENDIF w NBLK = 0 x DO 140 LB = NCHRWD,2,-1 y IF(ADEC(IDECPL+LNX-5-NMR-1)(LB:LB).NE.' ') GOTO 160 z NBLK = NBLK+1 {140 CONTINUE |160 NC = (LNX-5-NMR)*NCHRWD-NBLK } IF(WCOMPF) THEN ~ CALL EDILIS(ADEC(IDECPL),NC,DCK,NSQ,EDECK  1 ,COUNT,NRECCF) ENDIF ELSE C DELETED  IDECPL = ABS(IDECPL)  CALL EXIN(IDECPL,IRD(1),5) IF(IRD(2).EQ.0) THEN C MAIN  IF(LAST.EQ.1.OR.LAST.EQ.4) THEN IF(.NOT.COUNT) THEN  WRITE(DELRE(1),211) '*D ',IRD(3) ENDIF LAST = 2 ELSE  IF(.NOT.COUNT) THEN  WRITE(DELRE(2),211) ',',IRD(3) ENDIF LAST = 3 ENDIF 211 FORMAT(A,I6) ELSE C MOD  IF(.NOT.COUNT) THEN CALL EDISID(MODNA(IDK),NSQ,NAMSEQ) ENDIF  IF(LAST.EQ.1.OR.LAST.EQ.4) THEN IF(.NOT.COUNT) THEN  WRITE(DELRE(1),111) '*D ',NAMSEQ ENDIF LAST = 2 ELSE  IF(.NOT.COUNT) THEN  WRITE(DELRE(2),111) ',',NAMSEQ ENDIF LAST = 3 ENDIF ENDIF ENDIF ENDIF GOTO 100C 900 CONTINUE IF(LAST.EQ.2) THEN IF(COUNT) THEN NRECMF = NRECMF+1 ELSE WRITE(LMO,111) DELRE(1) ENDIF ELSE IF(LAST.EQ.3) THEN IF(COUNT) THEN NRECMF = NRECMF+1 ELSE WRITE(LMO,111) DELREC ENDIF ENDIF C IF(COUNT) THEN COUNT = .FALSE. IF(NRECCF.EQ.0) THEN WCOMPF = .FALSE. ENDIF GOTO 10 ENDIF %p CALL CLSFIL(LCO) &n CALL CLSFIL(LSO) CALL CLSFIL(LMO)C n IF(.NOT.WCOMPF) RETURN nC n CALL CLSFIL(LCO) IF(WCOMPF) THEN CALL CLSFIL(LCO) ENDIF 'C ( IF(NIFS.NE.0) THEN ) CALL WRTIO(' **ERROR** Deck '//EDECK//' has mismatched '// * 1 '*IF/*ENDIF directives.') + ENDIF ,C XuC Yu WRITE(LDO) EDECK,IDECE,IDECPN,NRECI,NRECT,IDECI ZuC [ 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) u1000 IF((IDECPN-IDECI)*NCHRWD .LE. MAXBYT) THEN u CALL WRBLKC (LDO,ADEC(IDECI+1),IDECPN-IDECI) u ELSE  u CALL WRBLKC (LDO,ADEC(IDECI+1),MAXWW) u IDECI=IDECI+MAXWW u GOTO 1000 u ENDIF uC u INW=0 u2000 IF((NRECT+1-INW)*NCHRWD .LE. MAXBYT) THEN u CALL WRBLKI (LDO,IR(INW),NRECT+1) u CALL WRBLKI (LDO,N(INW) ,NRECT+1) u CALL WRBLKI (LDO,L(INW), NRECT+1) u ELSE u CALL WRBLKI (LDO, IR(INW), MAXWW) u CALL WRBLKI (LDO, N(INW), MAXWW) u CALL WRBLKI (LDO, L(INW), MAXWW) u INW=INW+MAXWW u GOTO 2000 u ENDIF @ PRINT*,' ' @ PRINT*,' ' @ PRINT*,' End of editing deck ',EDECK @ PRINT*,' ' @ PRINT*,' ' r WRITE(LTO,911) EDECKr911 FORMAT(/,' End of editing deck ',A,/) u CALL WRTIO(' ')u CALL WRTIO(' End of editing deck -'//EDECK) u CALL WRTIO(' '))*ENDIF _ RETURN ` END ) 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) o CHARACTER*3 EDIENL 11/19/84 p SUBROUTINE EDIENL(NRECCF,NRECSF) SUBROUTINE EDIENL(NRECCF,NRECSF,WCOMPF) *IF EDITC C count the number of records to be written onC compile and source files C (derived from EDIEND) *IF NUMREC C  *CA PARAMA  *CA LOGU *CA EDITCO  *CA DECA *CA MODNA *CA DECKS *CA IFSWI C C WCOMPF - TRUE - write compile file FALSE - dont  LOGICAL WCOMPF 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 I4  CHARACTER*8 DCK C C C LAST C 1 - Normal statusC 2 - Delete - 1st part of DELREC being writtenC 3 - Delete - 2nd part of DELREC being written C 4 - *D or *I written C ISETIF = .TRUE.  LAST = 1  IREC = 0 ! NRECCF = 0 " NRECSF = 1  IF(N(IREC).NE.1) THEN  NRECSF=NRECSF+1  LAST=4  ENDIF #r LAST = 1 $r 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 0C ACTIVE1 CALL EXIN(IDECP1,IRC,1) 2 IF(LAST.EQ.1) THEN3 NRECSF = NRECSF+1 4 ELSE IF(LAST.EQ.2) THEN 5 NRECSF = NRECSF+1 6 ELSE IF(LAST.EQ.3) THEN 7 NRECSF = NRECSF+1 8 ENDIF 9 LAST = 4 : NRECSF = NRECSF+1 ;p IF(ITYPE(IDECE).EQ.0) THEN  IF(WCOMPF) THEN < CALL EDILIL(ADEC(IDECP1),IRC*NCHRWD,'--------',0, = 1 NRECCF) > ENDIF ? ENDIF@ ELSEAC OLD B IF(IDECP1.GT.0) THEN CC ACTIVED CALL EXIN(IDECP1,IRD(1),5)EC F IF(IDEL.GT.0) GOTO 100GC H IF(LAST.EQ.2) THENI NRECSF = NRECSF+1 J ELSE IF(LAST.EQ.3) THEN K NRECSF = NRECSF+1 L ENDIF M LAST = 1 N IDECP1 = IDECP1+NMR O160 NC = (LNX-5-NMR)*NCHRWD Pp IF(ITYPE(IDECE).EQ.0) THEN  IF(WCOMPF) THEN Q CALL EDILIL(ADEC(IDECP1),NC,DCK,NSQ,NRECCF) R ENDIF S ELSE TC DELETED U IDECP1 = ABS(IDECP1) V CALL EXIN(IDECP1,IRD(1),5)W IF(IRD(2).EQ.0) THEN XC MAIN Y IF(LAST.EQ.1.OR.LAST.EQ.4) THEN Z LAST = 2 [ ELSE \ LAST = 3 ] ENDIF ^ ELSE _C MOD ` IF(LAST.EQ.1.OR.LAST.EQ.4) THEN a LAST = 2 b ELSE c LAST = 3 d ENDIF e ENDIF f ENDIF g ENDIF h GOTO 100iC j900 CONTINUE k IF(LAST.EQ.2) THEN l NRECSF = NRECSF+1 m ELSE IF(LAST.EQ.3) THEN n NRECSF = NRECSF+1 o ENDIF pC q*ENDIF NUMREC r*ENDIF EDIT s RETURN t END , 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 CALLEDIFIN 6/14/82raC6.)  SUBROUTINE EDIFIN(A))*IF EDIT  CHARACTER*(*)A C C FINDS RECORD CONTAINING STRING C *CA PARAMA *CA EDITCO *CA DECA Cr*CALL EDIBKUr*CA LOGU.*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' r WRITE(LTO,501)'Text not found' r501 FORMAT(1X,A) CALL WRTIO(' Text not found.') Cr LBAKUF=.FALSE. % IREC=IRECS )*ENDIF & RETURN ' END / ELSE 0C ACTIVE1 CALL EXIN(IDECP1,IRC,1) 2 IF(LAST.EQ.1) THEN3 NRECSF = NRECSF+1 4 ELSE IF(LAST.EQ.2) THEN 5 NRECSF = NRECSF+1 EDIHEL 6/14/82& {rXJ;) q SUBROUTINE EDIHEL(A)  SUBROUTINE EDIHEL )*IF EDIT q CHARACTER*(*) A  CHARACTER HELP(24)*80 C C C PROCESS HELP REQUESTC *CA PARAMA *CA LOGU*CA BUFA qC ; IF(LEN(A).GT.1.AND.INDEX('12',A(2:2)).NE.0) THENJ IF(LEN(A).LT.2) GOTO 8 Xq IF(LEN(A).GE.2) THEN;q IF(A(2:2).EQ.'1') THEN ;q CALL EDIHE1 ; ELSE Xq ELSE IF(A(2:2).EQ.'2') THEN ;q CALL EDIHE2 Xq ELSE IF(A(2:2).EQ.'3') THEN Xq CALL EDIHE3 ;q ENDIF ; RETURN ; ENDIF J8 CONTINUE Xq ENDIF XqC   PRINT*,'You have obtained access to the HELP portion of' r3 FORMAT(1X,A)r WRITE(LTO,3)'You have obtained access to the HELP portion of'  1 ,' SLIB77'   PRINT*,'There are currently the following levels of HELP!' r WRITE(LTO,3)'There are currently the following levels of HELP!'   PRINT*,' 1 - Overall description of SLIB77 editor.' r WRITE(LTO,3)' 1 - Overall description of SLIB77 editor.'  PRINT*,' 2 - General description of commands.' r WRITE(LTO,3)' 2 - General description of commands.' X PRINT*,' 3 - List of decks in current library.' r WRITE(LTO,3)' 3 - List of decks in current library.' C 10 PRINT*,' Enter desired level (CR to resume editing)'r10 WRITE(LTO,3)'Enter desired level (CR to resume editing)'100 CALL RDTERM(LTI,IWID) {100 CALL RDTERM('?',LTI,IWID) | CALL WRTIO('1You have obtained access to the HELP portion of'// q CALL WRTIO(' You have obtained access to the HELP portion of'// q $ ' SLIB77') q CALL WRTIO(' There are currently the following levels of HELP:')q CALL WRTIO(' 1 - Overall description of SLIB77 editor.') q CALL WRTIO(' 2 - General description of commands.') q CALL WRTIO(' 3 - List of decks in current library.') q 10 CALL WRTIO(' Enter desired level (CR to resume editing)') | 100 CALL RDTERM('?',IWID) q 100 CALL RDTERM('?',IWID,.TRUE.)  IF(IWID.LT.1) RETURN)q IF(IWID.LT.1) GOTO 200  IF(BUF(1:1).EQ.'1') THEN; q120 IF(BUF(1:1).EQ.'1') THEN q CALL EDIHE1 q ELSE IF(BUF(1:1).EQ.'2') THEN q CALL EDIHE2 Xq ELSE IF(BUF(1:1).EQ.'3') THEN X q CALL EDIHE3 q ELSE PRINT*,'Improper entry enter 1 2 or CR' X  PRINT*,'Improper entry enter 1, 2, 3 or CR' r WRITE(LTO,3)'Improper entry enter 1, 2, 3 or CR'  q CALL WRTIO(' Improper entry. Enter 1, 2, 3 or CR') q GOTO 100 q ENDIF q GOTO 10 )q*ENDIF )q200 RETURN 10 HELP(1) = ' Help Screen'  HELP(2) = ' '  HELP(3) = ' Available commands are:' 20 HELP(4) = ' '  HELP(5) = ' T - move to "TOP" of deck'  HELP(6) = ' B - move to "Bottom" of deck'  HELP(7) = ' Fa - find string a (also ''a or "a )'  HELP(8) = ' N - move 1 line down'  HELP(9) = ' Pn - display n lines (also .n)'  HELP(10)= ' Aa - append string a to the current line'  HELP(11)= ' Ia - insert a as a line after current line'  HELP(12)= ' D - delete current line'  HELP(13)= ' Ra - replace current line'  HELP(14)= ' C/a/x/ - change string a to string x (or S/a/x/)'  HELP(15)= ' -n - move towards top of deck n lines'  HELP(16)= ' H - general information about this editor'  HELP(17)= ' E - end editing of this deck'  HELP(18)= ' +n - move towards bottom of deck n lines'  HELP(19)= ' Q - exit editor without changing deck'  HELP(20)= ' * - call up an options menu'  HELP(21)= ' '  HELP(22)= ' Enter command for more info' HELP(23)= ' (Use quit to return to editor)'  LLINE = 24 30 CALL WRTIO('1 ')  DO 55 I = 3,LLINE-1 55 CALL WRTIO(' '//HELP(I)(1:ITRAIL(HELP(I)))) C  CALL RDTERM('H (Q to exit help)?',IWID,.TRUE.) ! CALL EDIDIR(IWID,ICMND) "* #* SCAN FOR ADDITION HELP INFORMATION REQUEST $* % HELP(3) = ' Available commands are:' & IF (ICMND .EQ. 0) THEN' HELP(3) = ' COMMAND NOT UNDERSTOOD' ( GOTO 20 ) ENDIF ** TOP BOTTOM FIND NEXT PRINT ADD INSERT DELETE REPLACE + GOTO ( 100, 200, 300, 400, 500, 600, 700, 800, 900, , $ 1000, 1100, 1200, 1300, 1400, 5000, 1600 ),ICMND -* CHANGE MINUS HELP END PLUS QUIT * . HELP(3) = ' ERROR AT COMPUTED GOTO' / GOTO 30 0* 1* 2100 HELP(2) = ' ' 3 HELP(3) = ' Top command:' 4 HELP(4) = ' ' 5 HELP(5) = ' Format is: Top Shortest form: T'6 HELP(6) = ' Default: none' 7 HELP(7) = ' ' 8 HELP(8) = ' Use to set pointer to top of deck and display .' 9 LLINE = 9 : GOTO 30 ;* <200 HELP(2) = ' ' = HELP(3) = ' Bottom command:' > HELP(4) = ' ' ? HELP(5) = ' Format is: Bottom Shortest form: B' @ HELP(6) = ' Default: none' A HELP(7) = ' ' B HELP(8) = ' Use to set to bottom of deck and display .' C LLINE = 9 D GOTO 30 E* F300 HELP(2) = ' ' G HELP(3) = ' Find command:' H HELP(4) = ' ' I HELP(5) = ' Format is: Faaa shortest form: Fa'J HELP(6) = ' Default: none' K HELP(7) = ' ' L HELP(8) = ' Alternate form: ''aaa' M HELP(9) = ' Alternate form: "aaa' N HELP(10)= ' ' O HELP(11)= ' Use to find the specified character string in the'P HELP(12)= ' deck, starting with the current line.' Q HELP(13)= ' ' R HELP(14)= ' where:'S HELP(15)= ' aaa is the character string you wish to find.' T HELP(16)= ' ' U HELP(17)= ' Example: FFIND THIS STRING IN THE DECK' V LLINE = 18 W GOTO 30 X* Y400 HELP(2) = ' ' Z HELP(3) = ' Next command:' [ HELP(4) = ' ' \ HELP(5) = ' Format is: Next Shortest form: N' ] HELP(6) = ' Default: none' ^ HELP(7) = ' ' _ HELP(8) = ' Alternate form: carriage-return' ` HELP(9) = ' ' a HELP(10)= ' Use to set the pointer to the next record.' b LLINE = 11 c GOTO 30 d* e500 HELP(2) = ' ' f HELP(3) = ' Print command:' g HELP(4) = ' ' h HELP(5) = ' Format is: Pn Shortest form: P' i HELP(6) = ' Default: 1' j HELP(7) = ' ' k HELP(8) = ' Alternate form: .n' l HELP(9) = ' ' m HELP(10)= ' Use to display n records from the deck at the'n HELP(11)= ' terminal. (POINTER IS NOT RESET)' o HELP(12)= ' ' p HELP(13)= ' where:'q HELP(14)= ' n is the number of line to be displayed' r HELP(15)= ' starting with the current line.' s LLINE = 16 t GOTO 30 u* v600 HELP(2) = ' ' w HELP(3) = ' Append command:' x HELP(4) = ' ' y HELP(5) = ' Format is: Aaaa Shortest form: Aa' z HELP(6) = ' Default: none' { HELP(7) = ' ' | HELP(8) = ' Use to append string aaa to end of current record.' } HELP(9) = ' ' ~ HELP(10)= ' where:' HELP(11)= ' aaa is the string to be appended. Note- the'  HELP(12)= ' Note - the string will be appended to the'  HELP(13)= ' last non-blank character of the record.' LLINE = 14 GOTO 30 * 700 HELP(2) = ' '  HELP(3) = ' Insert command:' HELP(4) = ' '  HELP(5) = ' Format is: Iaaa Shortest form: I'  HELP(6) = ' Default: multiple lines' HELP(7) = ' '  HELP(8) = ' Use to insert new record(s) after the current line.'  HELP(9) = ' To insert only a single line use Iaaa form - To'  HELP(10)= ' enter more than one line use the I form and then'  HELP(11)= ' type in each line ending with a carriage-return.'  HELP(12)= ' To enter a blank line use either I# or type a #'  HELP(13)= ' when entering a line.' HELP(14)= ' ' HELP(15)= ' where:' HELP(16)= ' aaa is the character string to be inserted.' LLINE = 17 GOTO 30 * 800 HELP(2) = ' '  HELP(3) = ' Delete command:' HELP(4) = ' '  HELP(5) = ' Format is: D Shortest form: D'  HELP(6) = ' Default: 1' HELP(7) = ' '  HELP(8) = ' Use to delete the current line.' HELP(9) = ' ' LLINE = 10 GOTO 30 * 900 HELP(2) = ' '  HELP(3) = ' Replace command:' HELP(4) = ' '  HELP(5) = ' Format is: Raaa Shortest form: Ra' HELP(6) = ' Default: none' HELP(7) = ' '  HELP(8) = ' Use to replace the current line.' HELP(9) = ' ' HELP(10)= ' where:' HELP(11)= ' aaa is the string to replace the current line.' LLINE = 12 GOTO 30 * 1000 HELP(2) = ' '  HELP(3) = ' Change command:' HELP(4) = ' '  HELP(5) = ' Format is: C/aaa/bbb/ short form: C/A/B'  HELP(7) = ' Default: none' HELP(8) = ' '  HELP(9) = ' Alternate form: S/aaa/bbb/' HELP(10)= ' '  HELP(9) = ' Use to change the specified character string in the'  HELP(10)= ' deck to another string, starting with the current' HELP(11)= ' line.' HELP(12)= ' ' HELP(13)= ' where:' HELP(14)= ' aaaa is the character string you wish to locate.' HELP(15)= ' bbbb replacement character string.'  HELP(18)= ' / delimiting character, can be any character.' HELP(19)= ' The trailing delimeter is not needed.' HELP(21)= ' '  HELP(22)= ' Example: C/SUBROUTINE/FUNCTION' LLINE = 23 GOTO 30 * 1100 HELP(2) = ' ' HELP(3) = ' - command:' HELP(4) = ' '  HELP(5) = ' Format is: -n Shortest form: -'  HELP(6) = ' Default: 1' HELP(7) = ' '  HELP(8) = ' Use to set the pointer towards the top of the deck a'  HELP(9) = ' specified number of lines.' HELP(10)= ' ' HELP(11)= ' where:' HELP(12)= ' n is the number of lines you wish to move up.' LLINE = 13 GOTO 30 * 1200 HELP(2) = ' '  HELP(3) = ' SLEDIT is the original SLIB77 line editor.'  HELP(4) = ' Each command is a single character followed'  HELP(5) = ' by a string or a number or (for the Change'  HELP(6) = ' command) strings separated by delimeters.' HELP(7) = ' Each entered command has ALL trailing blanks' HELP(8) = ' REMOVED.' LLINE = 9 GOTO 30 * 1300 HELP(2) = ' ' HELP(3) = ' End command:' HELP(4) = ' '  HELP(5) = ' Format is: End Shortest form: E'  HELP(6) = ' Default: none' HELP(7) = ' '  HELP(8) = ' Use to end editing of this deck and store the' HELP(9) = ' changes made to the appropriate disk files.' LLINE = 10 GOTO 30 * 1400 HELP(2) = ' ' HELP(3) = ' + command:' HELP(4) = ' '  HELP(5) = ' Format is: +n Shortest form: +'  HELP(6) = ' Default: 1' HELP(7) = ' '  HELP(8) = ' Use to set the pointer towards the bottom of the deck' HELP(9) = ' a specified number of lines.' HELP(10)= ' ' HELP(11)= ' where:' HELP(12)= ' n is the number of lines to move down.' LLINE = 13 GOTO 30 * 1600 HELP(2) = ' ' HELP(3) = ' * command:' HELP(4) = ' '  HELP(5) = ' Format is: * Shortest form: *'  HELP(6) = ' Default: none' HELP(7) = ' '  HELP(8) = ' Use to Bring up a menu which will allow you to change' HELP(9) = ' some of the operating conditions of the editor:'  HELP(10)= ' Upper/Lower case input, Switch settings,'  HELP(11)= ' Screen sequencing, Compile file sequencing,' HELP(12)= ' and compile and source file names.'  LLINE = 13  GOTO 30 * * 5000 CONTINUE *ENDIF EDIT  RETURN END EDIHE1 6/14/82r)  SUBROUTINE EDIHE1 )*IF EDITC C HELP PORTION 1 OVERALL DESCRIPTION C r*CA LOGU  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' !v 3 ,'YS trimmed off of input!' 3 ,'YS trimmed off of input.'" 1 / # PRINT11,HEL1A r WRITE(LTO,11) HEL1A $11 FORMAT(1X,2A) % PRINT11,HEL1B r WRITE(LTO,11) HEL1B  DO 10 I = 1,17,2 10 CALL WRTIO(' '//HEL1A(I)//HEL1A(I+1))  DO 20 I = 1,5,2  20 CALL WRTIO(' '//HEL1B(I)//HEL1B(I+1)) )*ENDIF & RETURN ' END f  CHARACTER*4 COMEXT(2) z CHARACTER FNAME*72 z CHARACTER*72 NAMLSO  CHARACTER*72 NAM, FNAME { CHARACTER*10 SEQTYP(3) f C for blank lines in output will use BLKLIN f  CHARACTER*132 BLKLIN i CHARACTEEDIHE2 6/14/82r;)   SUBROUTINE EDIHE2 )*IF EDITC C HELP PART 2 DESCRIPTION OF COMMANDS C r*CA LOGU  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 r WRITE(LTO,11) HEL2A '11 FORMAT(1X,2A) ( PRINT11,HEL2B r WRITE(LTO,11) HEL2B  DO 10 I = 1,17,2 10 CALL WRTIO(' '//HEL2A(I)//HEL2A(I+1))  DO 20 I = 1,17,2 20 CALL WRTIO(' '//HEL2B(I)//HEL2B(I+1)) )*ENDIF ) RETURN * END  PRINT*,'Improper entry enter 1, 2, 3 or CR' r WRITE(LTO,3)'Improper entry enter 1, 2, 3 or CR'  CALL WRTIO(' Improper entry. Enter 1, 2, 3 or CR')  GOTO 100  ENDIF  GOTO 10 )*ENDIF )EDIHE3 3/28/83 r  SUBROUTINE EDIHE3 C C prints DECK names for current library C *CA PARAMA *CA DECKS r*CA LOGU  CHARACTER OUTLIN*78  CHARACTER*8 IDA(7)  CHARACTER*2 ITP(7)  C   PRINT*,'You have obtained access to the library deck names' r3 FORMAT(1X,A)r WRITE(LTO,3)'You have obtained access to the library deck names'  PRINT*,' ' r WRITE(LTO,3)' ' q CALL WRTIO('1You have obtained access to the library '//q $ 'deck names') CALL WRTIO('1 The decks in the library are:') IF(NDCKS.EQ.0) THEN   PRINT*,'There are no decks to list the names of' r WRITE(LTO,3)'There are no decks to list the names of' PRINT*,'Before I can list the decks' r WRITE(LTO,3)'Before I can list the decks' PRINT*,'the program must have read in a LIBRARY.'r WRITE(LTO,3)'the program must have read in a LIBRARY.'  PRINT*,'To do this request a deck to edit (even garbage)'r WRITE(LTO,3)'To do this request a deck to edit (ANY deck)'  CALL WRTIO(' There are no decks to list the names of') q CALL WRTIO(' Before I can list the decks, the program')q CALL WRTIO(' must read in a LIBRARY. To do this, request')q CALL WRTIO(' a deck to edit (ANY deck)') ELSE PRINT*,' (#=Purged deck, *=Common deck)' r  WRITE(LTO,3)' (#=Purged deck, *=Common deck)'  CALL WRTIO(' (#=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)r  WRITE(LTO,121)(ITP(J),IDA(J),J=1,7) WRITE(OUTLIN,121) (ITP(J),IDA(J),J=1,7) CALL WRTIO(OUTLIN) "121 FORMAT(7(1X,2A)) # ID=0 $ ENDIF %200 CONTINUE & IF(ID.GT.0) THEN ' PRINT 121, (ITP(I),IDA(I),I=1,ID) r  WRITE(LTO,121) (ITP(I),IDA(I),I=1,ID)  WRITE(OUTLIN,121) (ITP(J),IDA(J),J=1,ID) CALL WRTIO(OUTLIN) ( ENDIF ) PRINT*,' ' r  WRITE(LTO,3)' ' CALL WRTIO(' ') * ENDIF + RETURN , END  PRINT*,'Improper entry enter 1, 2, 3 or CR' r WRITE(LTO,3)'Improper entry enter 1, 2, 3 or CR'  q CALL WRTIO(' Improper entry. Enter 1, 2, 3 or CR') q GOTO 100 q ENDIF q GOTO 10 )q*ENDIF )q200 RETURN 10 HELP(1) = ' Help Screen' EDIINI 6/14/82k!rec]XPMGECB@<0)'  SUBROUTINE EDIINI @u SUBROUTINE EDIINI(IEDECK)  SUBROUTINE EDIINI )*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 rn*CALL LANGC r*CALL CPLDIR*CALL SEQCTL*CALL WIDTH *CALL FNAMES *CALL EDIOPTS *CALL BATCH *CALL ERRMES*CALL LANGC @u CHARACTER*3 ACON,AREC,ASEQ @ CHARACTER*12 FI12,FI14,FI17,FI18,FI19,FI20 @ CHARACTER*12 ADCK,ALIB Gu CHARACTER*12 ADCK @ CHARACTER*80 ANS  CHARACTER CHKNAM*8 C LMODE - last editor mode  CHARACTER*8 LMODE  CHARACTER STATUS*8 u CHARACTER FNAME*72 @  CHARACTER*12 BKUPO,BKUPI,OPLFIL,CONTI,CONTO,SOU,COMPG CHARACTER*72 BKUPO,BKUPI,OPLFIL,CONTI,CONTO,SOU,COMPu CHARACTER*72 BKUPO,BKUPI,CONTI,CONTO,SOU,COMP BC 2 CALL EDIOPL B SAVE INAMTP,ASEQ,ISEQ,ALIB G SAVE INAMTP,ASEQ,ISEQ,OPLFIL,LOPLFI u SAVE INAMTP,ASEQ,ISEQ @ uC @ uC @ uC INAMTP FILE NAME CONVENTION @ uC 1 = deckname.xxx @c 2 = FOR0xx.dat GuC 2 = FOR0xx @uC 3 = INDIVIDUALLY SET BY USER @uC ]C COMEXT - compile file name extension ] CHARACTER*4 COMEXT @u DATA INAMTP /1/ @u DATA ISEQ /0/ @u 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 @uC @ SAVE INAMTP,ASEQ,ISEQ,ALIB @uC @u @1 FORMAT (12A) r3 FORMAT(1X,12A) @u @uC C 10 EDIREC = .FALSE. BC TURN OFF BAKUP FILE B CALL SETBAK(.FALSE.) @u IEDCKO=IEDECK @*IF -IBM @u IF(IEDCKO.NE.0) THEN @  CLOSE(LBO) @! CLOSE(LCO) @" CLOSE(LSO) @# CLOSE(LDO) u CALL CLSFIL(LBO) u CALL CLSFIL(LCO) u CALL CLSFIL(LSO) u CALL CLSFIL(LDO) @$u 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)' r100 WRITE(LTO,3)'Enter deck to be edited (CR=end, H=help)' @( READ(LTI,1) EDECK 100 EDECK = ' ' n CALL RDTIO('Enter name of deck to be edited '//  CALL WRTIO(' Enter name of deck to be edited - or'// 1 ' other option.' )~ $ '(CR=end, H=help)?',EDECK,.TRUE.)z $ '(* = Switches, "CR"=end, H=help)?',EDECK,.TRUE.)u $ '(* = Options, "CR" = End, H = Help)?',EDECK,.TRUE.) q 1 ' ("cr" - end) (H - Help):',EDECK,.TRUE.) n 1 '( "cr" - end edit) ( H - list decks):',EDECK,.TRUE.)  CALL RDTIO( b 1 ' ("cr" = end) (H = list decks) (* = different library):'  1 ' ("cr" = end) ( * = List decks/Editor/Library options):'  2 ,EDECK,.TRUE.) b IF(EDECK .EQ. '* ') GOTO 2 Xb IF(EDECK.EQ.'H ') THEN Xq CALL EDIHEL('H3') b CALL EDIHE3 Xb GOTO 100 X~ ENDIF u ELSE IF(EDECK.EQ.'* ') THEN z CALL EDISWI u CALL EDIOPT u GOTO 100 b ENDIF  IF(EDECK .EQ. '* ') THEN  ANS = ' ' CALL WRTIO(' H = list decks') CALL WRTIO(' L = request different library file') CALL WRTIO(' E = editor change/verification') CALL WRTIO(' "cr" = return to deck name request') CALL RDTIO(' ENTER OPTION:',ANS,.TRUE.) IF (ANS(1:1) .EQ. 'H') THEN  C list decks in library CALL EDIHE3  C  ELSEIF(ANS(1:1) .EQ. 'L') THEN C change library file  GOTO 2C  ELSEIF(ANS(1:1) .EQ. 'E') THEN C change editor  ANS=' '  CALL RDTIO(  1 ' Enter the editor desired (Original, New or Full)', 2 ANS,.TRUE.)  IF(ANS(1:1) .EQ. 'O') THEN  PMODE='SLEDIT' C  ELSEIF(ANS(1:1) .EQ. 'N') THEN  PMODE='LEDIT' C  ELSEIF(ANS(1:1) .EQ. 'F') THEN  PMODE='FSEDIT' C ENDIF !C " CALL WRTIO(' The current editor is '//PMODE) #C $ ENDIF % GOTO 100 & ENDIF @) IBL=INDEX(EDECK,' ') @* IF(IBL.EQ.0) IBL=8 @+C @, IF(IBL.EQ.1) THEN @-u IEDECK=0 @.u RETURN  GOTO 9000 @/u ELSE @0u IBL=IBL-1 @1u IEDECK=1 @2u ENDIF @3uC @4u ADCK=EDECK(1:IBL)//'.XXX' @5uC @6u IF(INAMTP.EQ.1) THEN @7 ADCK='FOR0XX.DAT' Gu 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  u CALL FILEID(LCO,EDECK,COMP)  u LCOMP = ITRAIL(COMP)  u CALL FILEID(LSO,EDECK,SOU)  u LSOU = ITRAIL(SOU)  u CALL FILEID(LBO,EDECK,BKUPO) u LBKUPO = ITRAIL(BKUPO) u CALL FILEID(LBI,EDECK,BKUPI) u LBKUPI = ITRAIL(BKUPI) u CALL FILEID(LDO,EDECK,CONTO) u LCONTO = ITRAIL(CONTO) u CALL FILEID(LDI,EDECK,CONTI) u LCONTI = ITRAIL(CONTI) @Du ENDIF @EuC @F OPLFIL=' ' @Gu IRECOV=0 @Hu AREC='NO' @Iu ICONT=0 @Ju ACON='NO' @KuC @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)-' r10 WRITE(LTO,3)' ' r WRITE(LTO,3)' ' r WRITE(LTO,3)' ' r WRITE(LTO,3)' ' r  WRITE(LTO,3)' SLIB77 edit run controls' r  WRITE(LTO,3)' ' r  WRITE(LTO,3)' currently To modify' r  WRITE(LTO,3)' --------- ---------' r  WRITE(LTO,3)'CONTINUATION run ',ACON,' C' r WRITE(LTO,3)'RECOVERY run ',AREC,' R' r WRITE(LTO,3)'Sequence numbers ',ASEQ,' S' r WRITE(LTO,3)' ' r WRITE(LTO,3)'O To change to ',ADCK, ' enter N'r WRITE(LTO,3)'U F To enter separate names enter I' r WRITE(LTO,3)'T I ',SOU(1:LSOU),' source' r WRITE(LTO,3)'P L ',COMP(1:LCOMP),' compile' r WRITE(LTO,3)'U E ',CONTO(1:LCONTO),' continuation' r WRITE(LTO,3)'T S ',BKUPO(1:LBKUPO),' backup' r WRITE(LTO,3)' ' r WRITE(LTO,3)'Library File ',OPLFIL(1:LOPLFI), r 1 ' to change enter L' r WRITE(LTO,3)' ' r WRITE(LTO,3)' ' r WRITE(LTO,3)'Enter selection (CR for no changes)-' @cC @d ANS=' ' @e READ(LTI,1) ANS u 10 CALL WRTIO('1 SLIB77 edit run controls') u CALL WRTIO(' ')u CALL WRTIO(' Currently To modify') u CALL WRTIO(' --------- ---------') u CALL WRTIO(' CONTINUATION run '//ACON//' C')u CALL WRTIO(' RECOVERY run '//AREC//' R')u CALL WRTIO(' Sequence numbers '//ASEQ//' S') u CALL WRTIO(' ')u CALL WRTIO(' O To change to '//ADCK//' enter N') u CALL WRTIO(' U F To enter seperate names enter I')u CALL WRTIO(' T I -'//SOU(1:LSOU)//'- source')  u CALL WRTIO(' P L -'//COMP(1:LCOMP)//'- compile') !u CALL WRTIO(' U E -'//CONTO(1:LCONTO)//'- continuation')"u CALL WRTIO(' T S -'//BKUPO(1:LBKUPO)//'- backup') #u CALL WRTIO(' ') $u ANS = ' ' %u CALL RDTIO('Enter selection (CR for no changes) ?',ANS,.TRUE.) &uC @fuC @gu IF(ANS.EQ.' ') GOTO 400 @huC @iu LENA=INDEX(ANS,' ') @ju IF(LENA.EQ.0) GOTO 400 @kuC @lu 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))u ITP = INDEX('CRSNI',ANS(IC:IC)) u IF(ITP.EQ.0) ITP = INDEX('crsni',ANS(IC:IC)) eu ITP=ITP+1@nuC @oC C R S N I L@p GOTO (300,210,220,230,240,250,260),ITP uC C R S N Iu GOTO (300,210,220,230,240,250),ITP @quC @ruC C - CONTINUATION@suC @tu210 CONTINUE @uu IF(ICONT.EQ.0) THEN @v PRINT*,' Enter file to continue with (def=',FI20 G PRINT*,' Enter file to continue with (def = FOR020)' r WRITE(LTO,3)'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 'u FNAME = ' ' (u CALL RDTIO('Enter file to CONTINUE with (def = '//)u $ CONTI(1:LCONTI)//') :',FNAME,.TRUE.) *u IF (FNAME .NE. ' ') THEN +u CONTI = FNAME ,u LCONTI = ITRAIL(CONTI) -u ENDIF @zu ICONT=1 @{u ACON='YES' @|u ELSE @}u ICONT=0 @~u ACON='NO' @u ENDIF @u GOTO 300 @uC @uC R - RECOVERY @uC @u220 CONTINUE @u IF (IRECOV.EQ.0) THEN@ PRINT*,' Enter file to recover with (def=',FI18 G PRINT*,' Enter file to recover with (def = FOR018'r WRITE(LTO,3)'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 .u FNAME = ' ' /u CALL RDTIO('Enter file to RECOVER with (def = '// 0u $ BKUPI(1:LBKUPI)//') :',FNAME,.TRUE.) 1u IF (FNAME .NE. ' ') THEN 2u BKUPI = FNAME 3u LBKUPI = ITRAIL(BKUPI) 4u ENDIF @u IRECOV=1 @u AREC='YES' @u ELSE @u IRECOV=0 @u AREC='NO' @u ENDIF @u GOTO 300 @uC @uC S - SEQUENCE NUMBERS @uC @u230 CONTINUE @u IF(ISEQ.EQ.0) THEN @u ISEQ=1 @u ASEQ='YES' Eu LSTSEQ=.TRUE. @u ELSE @u ISEQ=0 @u ASEQ='NO' Eu LSTSEQ=.FALSE. @u ENDIF @u GOTO 300 @uC @uC N - REVERSE FILE NAMES @uC @u240 CONTINUE @u IF(INAMTP.EQ.1) THEN @u INAMTP=2 @u 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#u SOU = 'FOR012' G$u LSOU = 6 G%u COMP = 'FOR014' G&u LCOMP = 6 G'u BKUPO = 'FOR017' G(u LBKUPO = 6G)u CONTO = 'FOR019' G*u LCONTO = 6G+ CONTI = 'FOR020' G, LCONTI = 6G- BKUPI = 'FOR018' G. LBKUPI = 6 @u ELSE @u INAMTP=1 @ ADCK='FOR0XX.DAT' G/u 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=FI20G0u SOU = EDECK(1:IBL)//'.SRC' G1u LSOU = IBL+4 G2 COMP = EDECK(1:IBL)//'.FOR' ]  COMP = EDECK(1:IBL)//COMEXT 5u COMP = EDECK(1:IBL)//COMEXT(LANG) G3u LCOMP = IBL+4 G4u BKUPO = EDECK(1:IBL)//'.BAK' G5u LBKUPO = IBL+4G6u CONTO = EDECK(1:IBL)//'.CNT' G7u LCONTO = IBL+4G8 BKUPI = EDECK(1:IBL)//'.BAK' G9 LBKUPI = IBL+4G: CONTI = EDECK(1:IBL)//'.CNT' G; LCONTI = IBL+4 @u ENDIF @u GOTO 300 @uC @uC I - ENTER SEPARATE FILE NAMES@uC @u250 CONTINUE @u INAMTP=3 @ PRINT*,' Enter backup output file (def=',FI17,')'G< PRINT*,' Enter backup output file (def = ',EDECK(1:IBL)//'.BAK)'r WRITE(LTO,3)'Enter backup output file (def = ', r  1 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 = ',r! WRITE(LTO,3)'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)'r" WRITE(LTO,3)'Enter source file (def = ', r# 1 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)'r$ WRITE(LTO,3)'Enter continue output file (def=', r% 1 EDECK(1:IBL),'.CNT)' @ CONTO=' ' @ READ(LTI,1) CONTOGL IF(CONTO.EQ.' ') THENGM CONTO = EDECK(1:IBL)//'.CNT' GN ENDIFGO LCONTO = INDEX(CONTO,' ')-1 6u FNAME = ' ' 7u CALL RDTIO('Enter backup output file name (def = '// 8u $ BKUPO(1:LBKUPO)//') :',FNAME,.TRUE.) 9u IF (FNAME .NE. ' ') THEN :u BKUPO = FNAME ;u LBKUPO = ITRAIL(BKUPO) <u ENDIF =u FNAME = ' ' >u CALL RDTIO('Enter compile file name (def = '// ?u $ COMP(1:LCOMP)//') :',FNAME,.TRUE.)@u IF (FNAME .NE. ' ') THEN Au COMP = FNAME Bu LCOMP = ITRAIL(COMP) Cu ENDIF Du FNAME = ' ' Eu CALL RDTIO('Enter source file name (def = '//Fu $ SOU(1:LSOU)//') :',FNAME,.TRUE.) Gu IF (FNAME .NE. ' ') THEN Hu SOU = FNAME Iu LSOU = ITRAIL(SOU) Ju ENDIF Ku FNAME = ' ' Lu CALL RDTIO('Enter continue output file name (def = '// Mu $ CONTO(1:LCONTO)//') :',FNAME,.TRUE.) Nu IF (FNAME .NE. ' ') THEN Ou CONTO = FNAME Pu LCONTO = ITRAIL(CONTO) Qu ENDIF @u 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 )' r& WRITE(LTO,3)'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 @uC @u300 CONTINUE @u GOTO 10 @uC @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) Ru400 CONTINUEr'u IF(LANG.EQ.2) THEN r(u NCPLDI=6 r)u CPLDI=' ' r*u ELSE r+u NCPLDI=0 r,u CPLDI=' ' r-u ENDIF  ENDIF @ ENDIF @C @ IDECE = IFINDK(EDECK) @C @ IF(IDECE.EQ.0) THEN @ PRINT*,' Deck ',EDECK,' not found try again.'r. WRITE(LTO,3)'Deck ',EDECK,' not found try again.'Su CALL WRTIO(' Deck -'//EDECK//'- not found try again.')  CALL WRTIO(' Deck -'//EDECK//'- not found try again'//  1 ' (Help will list deck names).') @ GOTO 100 @ ELSE IF (IDECE.LT.0) THEN @ PRINT*,' Deck ',EDECK,' is purged do you wish to edit it?' r/ WRITE(LTO,3)'Deck ',EDECK, r0 1 ' is purged do you wish to edit it?' @ READ(LTI,1) ANS T ANS = ' 'U CALL RDTIO('Deck -'//EDECK//'- is purged. Do you wish to'// V $ ' edit it (y/n) ?',ANS,.TRUE.)@ IF(INDEX('Yy',ANS(1:1)).EQ.0) GOTO 100 @ IDECE=-IDECE @ IEDECK=IDECE @ ENDIF  IF (NBLOK(IDECE)*NWRDBK .GE. MAXWRD) THEN  WRITE(ERRMSG,211) EDECK, MAXWRD  211 FORMAT(' Deck ',A,' is too large to edit with this program'  1 ,' the maximum number of words =',I8) CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG)))  GOTO 100  ENDIF  n300 CALL FILEID(LCO,EDECK,NAMLCO)  n CALL FILEID(LSO,EDECK,NAMLSO)  n CALL FILEID(LBO,EDECK,NAMLBO)  300 CALL FILEID(COMFID(LANG), NAMLCO, EDECK) CALL FILEID(MODFID, NAMLMO, EDECK)  CALL FILEID(BAKFID, NAMLBO, EDECK)  IWLCO=ITRAIL(NAMLCO) n IWLSO=ITRAIL(NAMLSO) IWLMO=ITRAIL(NAMLMO)  IWLBO=ITRAIL(NAMLBO) CALL WRTIO(' Deck '//EDECK//' to be edited.')  IF(EDIREC) THEN  CALL WRTIO(' ')  CALL WRTIO(' (Recovery is scheduled from file '//  1 NAMLBI(1:IWLBI)//')')  CALL WRTIO(' ')  ENDIF IF(EDICON) THEN CALL WRTIO(' ')  CALL WRTIO(' (Continuation is scheduled from file '//  1 NAMLCI(1:IWLCI)//')') CALL WRTIO(' ')  ENDIF  ANS=' '  CALL RDTIO(' Enter ("cr" - edit) (N - change deck name)'//  1 ' (* - options menu):',  1 ANS,.TRUE.)  IF(ANS.EQ.'*') THEN q CALL EDIOPT(.TRUE.)  CALL EDIOPT(.TRUE.,PMODE)  ELSEIF(ANS.NE.' ') THEN  GOTO 100  ENDIF C @C @ CALL OPNLCO(LCO,COMP) GV CALL OPNLCO(LCO,COMP(1:LCOMP)) @ CALL OPNLSO(LSO,SOU)GW CALL OPNLSO(LSO,SOU(1:LSOU)) W| MWIDE = ICHARS u ICHARS = MWIDE Xu IF (LSEQC .EQ. 1) ICHARS = MWIDE + 15Yu IF (LSEQC .EQ. 2) ICHARS = MWIDE + 8 Zu IRECS = 10 [u MXRECS = 25000 \u CALL OPENER(LCO,COMP(1:LCOMP),'NEW','SEQUENTIAL',]u $ 'FORMATTED',ICHARS,IRECS,MXRECS,IERR)^u CALL OPENER(LSO,SOU(1:LSOU),'NEW','SEQUENTIAL', _u $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR) @uC @u IF(ICONT.NE.0) THEN @ PRINT*,' ' r1 WRITE(LTO,3)' ' @ PRINT*,' processing continue.' r2 WRITE(LTO,3)'processing CONTINUE.' @ PRINT*,' ' r3 WRITE(LTO,3)' ' `u CALL WRTIO(' ') au CALL WRTIO(' processing CONTINUE.') bu CALL WRTIO(' ') @ CALL OPNLDI(LDI,CONTI) GX CALL OPNLDI(LDI,CONTI(1:LCONTI)) cw ICHARS = 30000 u ICHARS = MAXBYT du CALL OPENER(LDI,CONTI(1:LCONTI),'OLD','SEQUENTIAL', eu $ 'UNFORMATTED',ICHARS,0,0,IERR) @u CALL EDICON @u ICONT=0 @ CLOSE(LDI) @ PRINT*,' continue processing completed.' r4 WRITE(LTO,3)'CONTINUE processing completed.' fu CALL CLSFIL(LDI) gu CALL WRTIO(' CONTINUE processing completed.') @u ELSE@n CALL RDDK(1,IDECE) m NDKMEM=1 m CALL RDDK(IDECE)  NDKMEL = 0  NDKMEU = 0  CALL RDDK('L', IDECE, ILDECK, 0)C  *IF SMALL  IF(NBLOK(IDECE) .GT. 2) THEN LBLK = LOCB(IDECE) + 2  IDECPT = MEMSTL(ILDECK) + (NWRDBK * 2)  DO 410 IREC = 3, NBLOK(IDECE) CALL RDPL1 (LOCF(IDECE), LBLK, IDEC(IDECPT))  IDECPT = IDECPT + NWRDBK  LBLK = LBLK + 1  410 CONTINUE  ENDIF *ENDIF SMALL,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  RCOUNT = 0 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>p IDECP1=IDECP1+LNX ? GOTO 300 @ r GOTO 500 q GOTO 500  IF(IDEC(IDECP1+3) .EQ. 0) RCOUNT = RCOUNT + 1  IDECP1=IDECP1+LNX 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 r5 WRITE(LTO,413)NRECI-1,EDECK hq WRITE(ANS,413) NRECI-1, EDECK iq CALL WRTIO(ANS) r6q413 FORMAT(1X,I6,' Records (active and inactive) in deck ',A) C  WRITE(ANS,413) RCOUNT, NRECI-1-RCOUNT, EDECK 413 FORMAT(1X,I6,' Active records ', 1 I8,' Inactive records in deck ',A)  CALL WRTIO(ANS(1:ITRAIL(ANS))) @ u ENDIF C  IF(EDIREC) THEN k CALL OPENER(LBI,NAMLBI(1:IWLBI),'OLD','SEQUENTIAL',  STATUS = 'OLD'  CALL FILECK(LBI,'BACKUP INPUT',NAMLBI,IWLBI,STATUS,IDDNAM)  CALL OPENER(LBI,NAMLBI(1:IWLBI),IDDNAM,STATUS,'SEQUENTIAL',  $ 'FORMATTED',MWIDE,0,0,IERR)  IF(IERR.NE.0) THEN  CALL WRTIO(' Unable to open file '//NAMLBI(1:IWLBI))  GOTO 8000  ELSE CALL WRTIO(' Opened recover input file '//NAMLBI(1:IWLBI))  ENDIF  ENDIF C  IRECS = 10  MXRECS = 2500 k CALL OPENER(LBO,NAMLBO(1:IWLBO),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LBO,'BACKUP OUTPUT',NAMLBO,IWLBO,STATUS,IDDNAM)  CALL OPENER(LBO,NAMLBO(1:IWLBO),IDDNAM,STATUS,'SEQUENTIAL',  $ 'FORMATTED',MWIDE+8,IRECS,MXRECS,IERR)  IF(IERR.NE.0) THEN  CALL WRTIO(' Unable to open backup file '//  1 NAMLBO(1:IWLBO))  GOTO 8000  ENDIF C  CALL WRTIO(' Opened backup file '//NAMLBO(1:IWLBO)// 1 ' (will delete when finished with this deck)') C C Header record on backup fileC  WRITE(LBO,511) EDECK,NRECI 511 FORMAT(A8,I5) !C  IF(EDICON) THEN  CALL WRTIO(' ')  CALL WRTIO(' Processing continue (from source file).') CALL WRTIO(' ') !k CALL OPENER(LCI,NAMLCI(1:IWLCI),'OLD','SEQUENTIAL',  STATUS = 'OLD'  CALL FILECK(LCI,'CONTINUE',NAMLCI,IWLCI,STATUS,IDDNAM)  CALL OPENER(LCI,NAMLCI(1:IWLCI),IDDNAM,STATUS,'SEQUENTIAL', " 1 'FORMATTED',MWIDE,0,0,IERR) # IF(IERR.NE.0) THEN $ CALL WRTIO(' Unable to open file '//NAMLCI(1:IWLCI)) %r CALL THEEND(2,' Unable to open continue file') " GOTO 8000 & ENDIF'p CALL EDICNS(IDECE)  CALL EDICNS(IDECE, IERR)  IF(IERR.NE.0) THEN  GOTO 8000  ENDIF ( CALL CLSFIL(LCI) ) CALL WRTIO(' Continue processing finished') * ENDIF @ C  CHANGE = 0 @ C @u IF(IRECOV.NE.0) THEN +r IF (EDIREC) THEN # IF(EDIREC) THEN @ PRINT*,' ' r7 WRITE(LTO,3)' ' @ PRINT*,' processing recovery.' r8 WRITE(LTO,3)'processing recovery.' @ PRINT*,' ' r9 WRITE(LTO,3)' ' j CALL WRTIO(' ') k CALL WRTIO(' Processing RECOVERY.') l CALL WRTIO(' ') @ CALL OPNLBI(LBI,BKUPI) GY CALL OPNLBI(LBI,BKUPI(1:LBKUPI)) mu CALL OPENER(LBI,BKUPI(1:LBKUPI),'OLD','SEQUENTIAL', ,q CALL OPENER(LBI,NAMLBI(1:IWLBI),'OLD','SEQUENTIAL', nq $ 'FORMATTED',MWIDE,0,0,IERR) -q IF(IERR.NE.0) THEN .q CALL WRTIO(' Unable to open file '//NAMLBI(1:IWLBI)) /r CALL THEEND(2,' Unable to open recover file') $q GOTO 8000 0q ENDIF @ CALL EDIREC CrC Parameter for EDITOR is RECOVERCr CALL EDITOR(.TRUE.) @ CLOSE (LBI) @ PRINT*,' Recovery processing completed.' r: WRITE(LTO,3)'Recovery processing completed.' or CALL CLSFIL(LBI) pr CALL WRTIO(' RECOVERY processing completed.') @r ENDIF @ CALL OPNLBO(LBO,BKUPO) GZ CALL OPNLBO(LBO,BKUPO(1:LBKUPO)) qr IRECS = 10 rr MXRECS = 2500su CALL OPENER(LBO,BKUPO(1:LBKUPO),'NEW','SEQUENTIAL', 1r CALL OPENER(LBO,NAMLBO(1:IWLBO),'NEW','SEQUENTIAL', tr $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR) %C &C Check Header record 'C ( READ(LBI,511,ERR=7000,END=7000) CHKNAM,NRECTI) IF(CHKNAM.NE.EDECK.OR.NRECTI.NE.NRECT) THEN * CALL WRTIO(' Error reading recovery file header record') + WRITE(ERRMSG,611) 'Header needed to be -',EDECK,NRECT ,611 FORMAT(1X,A,I5) - CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) . WRITE(ERRMSG,611) 'Header That was read -',CHKNAM,NRECTI / CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) 0 GOTO 8000 1 ENDIF2C 3 CALL EDIBKI(NADD,NDEL,IERR) 4 CALL CLSFIL(LBI) 5 IF(IERR.NE.0) THEN 6 CALL WRTIO(' Error during recovery processing.') 7 GOTO 8000 8 ELSE9 WRITE(ERRMSG,9011) NDEL,NADD :9011 FORMAT(I15,' Records deleted',I10,' Records added.') ; CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) < ENDIF = ENDIF BC TURNON BAKUP FILE B CALL SETBAK(.TRUE.) @ CALL OPNLDO(LDO,CONTO) G[ CALL OPNLDO(LDO,CONTO(1:LCONTO)) uw ICHARS = 30000 u ICHARS = MAXBYT vu IRECS = 10 wu MXRECS = 200 xu CALL OPENER(LDO,CONTO(1:LCONTO),'NEW','SEQUENTIAL', yu $ 'UNFORMATTED',ICHARS,IRECS,MXRECS,IERR) @uC KC 2 IF(LSEQC.EQ.1)THEN 3 MWIDEC = MWIDE+13 4 ELSEIF(LSEQC.EQ.2)THEN 5 MWIDEC = MWIDE+8 6 ELSE 7 MWIDEC = MWIDE 8 ENDIF 9C :r CALL EDITOR(.FALSE.) > IREC=0 ?q CALL EDITOR  COLPNT = 0 6000 LMODE=PMODE  IF(PMODE.EQ.'LEDIT'.OR.PMODE.EQ.'FSEDIT') THEN  CALL FSEDIT(PMODE)  ELSE CALL EDITOR(PMODE) ! ENDIF "C # IF(PMODE.NE.LMODE) THEN $ GOTO 6000 % ENDIF ; GOTO 10 <C @7000 CALL WRTIO(' Error reading header record on recovery file') A8000 CONTINUEB CALL WRTIO(' (Sorry - must start over with deck name.)') C IF(EDIREC) THEN D CALL WRTIO(' (Recovery processing being turned off)') E ENDIF F GOTO 10 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 `u RETURN =9000 RETURN a END EDIINS 6/14/82 rRGC7)&  SUBROUTINE EDIINS(A))*IF EDIT  CHARACTER*(*) A C C INSERT A NEW RECORD BEHIND CURRENT RECORD C *CA PARAMA *CA EDITCO *CA DECA Cr*CALL EDIBKUr*CA LOGU 7 CHARACTER*120 BUX R CHARACTER*(MAXWID) BUX C  CHANGE = CHANGE +1 t IF(IREC.EQ.0) THEN   PRINT*,'CANNOT INSERT RECORD AT TOP' r3 FORMAT(1X,A) r WRITE(LTO,3)'Cannot insert record at top.' t CALL WRTIO(' Cannot insert record at top.') Ct LBAKUF=.FALSE. t RETURN  t ELSE IF(IREC.EQ.NRECI) THEN  IF(IREC.EQ.NRECI) THEN IREC=L(IREC) q CALL EDIBKO('I',IREC,A)  ENDIF  CALL EDIBKO('I', IREC, A)  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  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 < EDILIL 11/19/84 SUBROUTINE EDILIL(A,LENA,DCK,NSQ,NRECCF)C C Counts records to be written on compile file C (derived from EDILIS) *IF EDIT*IF NUMREC C *CA PARAMA  *CA PRFX *CA IFSWI  *CA CONTRL CHARACTER*(MAXWID) A CHARACTER*8 DCK C C C  ITD = 0  IF(A(1:1).EQ.PRFX) THEN  CALL CKDIR(A(1:LENA),ITD)  ENDIF r IF((ISETIF).OR.ITD.EQ.9.OR.ITD.EQ.11.OR.ITD.EQ.20) THEN  IF( (ICCD .AND. (ITD .EQ. 9 .OR. ITD .EQ. 11 .OR. 1 ITD .EQ. 21 .OR. ITD .EQ.22 ))  1 .OR. (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) THEN  NRECCF = NRECCF+1  ENDIF r IF( (ICCD .AND. (ITD .EQ. 9 .OR. ITD .EQ. 11 .OR.r 1 ITD .EQ. 21 .OR. ITD .EQ.22 )) r 1 .OR. (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) THEN IF( (ISETIF.AND.(ITD .EQ.3.OR.ITD.EQ.21)) .OR.  1 ITD.EQ. 9 .OR. ITD .EQ. 11 .OR. ITD .EQ. 22 ) THEN  CALL COMCHL(ITD,A,LENA,NRECCF)  ENDIF C *ENDIF NUMREC *ENDIF EDIT RETURN ! END BUX=A//' ' 7 CALL INCHW(BUX,ADEC(IDECPN),NW*NCHRWD) )*ENDIF EDILIS 6/14/82rpid[RPA) SUBROUTINE EDILIS(A,LENA,NAMSEQ)Pz SUBROUTINE EDILIS(A,LENA,DCK,NSQ) n SUBROUTINE EDILIS(A,LENA,DCK,NSQ,LDECK)  SUBROUTINE EDILIS(A,LENA,DCK,NSQ,LDECK,COUNT,NRECCF))*IF EDITC nC ACTUALLY DOES WRITE OF COMPILE FILE FOR EDIT RUNC Writes or counts compile file records for edit run C A - record C LENA - length of records (characters) C DCK - deck name C NSQ - sequence number C LDECK - name of calling deck C COUNT - Count control variable - TRUE = YES C NRECCF - count of records to be written on compile filenC AND CHECKS FOR COMMON DECK TO INSERTC *CA PARAMA *CA DECA*CA LOGU *CA PRFX *CA IFSWI *CALL CONTRL  CHARACTER*(120)A R*CA WIDTH d*CA LANGC R CHARACTER*(MAXWID) A  CHARACTER*8 NAMSEQ Pz CHARACTER*8 DCK  CHARACTER*8 DCK,LDECK LOGICAL COUNT CHARACTER*8 DNAME, GNAME C LOGICAL ISET  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  ISET = ISETIF [ IF(A(1:1).EQ.PRFX) THEN [ CALL CKDIR(A(1:LENA),ITD) [n ENDIF i IF(ISETIF.EQ.0.OR.ITD.EQ.9.OR.ITD.EQ.11) THEN p IF((ISETIF).OR.ITD.EQ.9.OR.ITD.EQ.11) THEN ru IF((ISETIF).OR.ITD.EQ.9.OR.ITD.EQ.11.OR.ITD.EQ.20) THEN n IF( (ICCD .AND. (ITD .EQ. 9 .OR. ITD .EQ. 11 .OR.n 1 ITD .EQ. 21 .OR. ITD .EQ.22 )) n 1 .OR. (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) 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) in CALL LISCRD(ITD,IL,IAC,DCK,NSQ,A,LENA) in ENDIF nC  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 u IF(ITD .EQ. 3.OR.ITD .EQ. 9.OR.ITD .EQ. 11 .OR. n IF( (ISETIF.AND.(ITD .EQ.3.OR.ITD.EQ.21)) .OR. u 1 ITD .EQ. 21 .OR. ITD .EQ. 22 ) THENn 1 ITD.EQ. 9 .OR. ITD .EQ. 11 .OR. ITD .EQ. 22 ) THEN d  CALL COMCHK(ITD,ADEC(IDECP1),LENA) iz CALL COMCHK(ITD,A,LENA) n CALL COMCHK(ITD,A,LENA,LDECK)  IF(ITD .NE. 0) THEN  CALL COMCHK(ITD, A, LENA, LDECK,  1 ICDECK, DNAME, GNAME, COUNT) ISET = ISET .OR. ISETIF  ENDIF  ENDIF C  IF(ISET .AND. (ITD .EQ. 0 .OR. ICCD .OR. ITD .EQ. 20)) THEN  IF (COUNT) THEN  NRECCF = NRECCF + 1  ELSE CALL LISCRD(ITD, IL, IAC, DCK, NSQ, A, LENA)  ENDIF  ENDIF C  IF(ITD .EQ. 3 .AND. ICDECK .GT. 0) THEN  CALL INSCOM (ICDECK, DNAME, COUNT, NRECCF)  ELSE IF(ITD .EQ. 21 .AND. ICDECK .GT. 0) THEN ! CALL INSGRP (ICDECK, DNAME, GNAME, A, LENA, "m 1 LDECK, COUNT, NRECCF)  1 LDECK, COUNT, NRECCF, 1)  ENDIF C )*ENDIF  RETURN  END C' r WRITE(LTO,3)'RECOVERY run ',AREC,' R' EDIMIN 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 EDIOPL 7/19/84  SUBROUTINE EDIOPL C C Opens the old library file and reads it in C for an EDIT runC *IF EDIT*CA PARAMA *CALL LOGU *CALL PRFX  CHARACTER*72 OPLFIL  CHARACTER*72 FNAME  CHARACTER STATUS*8  C DATA IOPEN /0/  C  C get old library file name  C  IF (IOPEN.NE.0) THEN  CLOSE(LOP)  CALL CLSFIL(LOP)  ENDIF C  WRITE(LTO,'(A)')' Enter library file name (def= FOR031 )'  OPLFIL=' '  READ(LTI,'(A)') OPLFIL  IF( OPLFIL .EQ.' ') THEN  OPLFIL = 'FOR031'  ENDIF C  LOPLFI = INDEX(OPLFIL,' ')-1 CALL OPNLOP(LOP,OPLFIL(1:LOPLFI)) | OPLFIL='FOR031' 100 OPLFIL='FOR031'  LOPLFI=6  FNAME = ' '  CALL RDTIO('Enter library file name (def = '//  $ OPLFIL(1:LOPLFI)//') :',FNAME,.TRUE.)  IF (FNAME .NE. ' ') THEN n CALL FILEID(LOP,FNAME,OPLFIL)  OPLFIL = FNAME  LOPLFI = ITRAIL(OPLFIL) ENDIF  k CALL OPENER(LOP,OPLFIL(1:LOPLFI),'OLD','DIRECT',  STATUS = 'OLD'  CALL FILECK(LOP,'OLD LIBRARY',OPLFIL,LOPLFI,STATUS,IDDNAM)  CALL OPENER(LOP,OPLFIL(1:LOPLFI),IDDNAM,STATUS,'DIRECT', $ 'UNFORMATTED',NCHRWD*NWRDBK,0,0,IERR)  IF(IERR.NE.0) THEN  CALL WRTIO(' Unable to open library file '  1 //OPLFIL(1:LOPLFI) ) y GOTO 100 v IOPEN = IOPEN + 1v IF(IOPEN .LT. 4) GOTO 100 CALL THEEND(2,' Unable to open OLD LIBRARY')  ELSE  CALL WRTIO(' Opened old library file '  1 //OPLFIL(1:LOPLFI) ) ENDIF C  PRFX = ' '  CALL RDOPL(LOP) C  IOPEN=1 *ENDIF  RETURN  END  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' ~ CALL ENDPRO(2)z CALL WRTIO(' First record on EDIOPT 8/31/84$ u SUBROUTINE EDIOPT uC uC EDITOR OPTION SELECTION SUBROUTINE uC uC u*CALL EDIOPTS u CHARACTER ANS*9 u CHARACTER OUTLIN*40  uC  u10 CALL WRTIO('1 Editor Option Menu (select option below)') u CALL WRTIO(' C - Alter Upper/Lower Case input option')  u CALL WRTIO(' S - Alter Switch settings') u CALL WRTIO(' ')u20 CALL WRTIO(' Enter "cr" to return') u ANS = ' ' u CALL RDTIO(':',ANS,UPCASE) u IF (ANS .EQ. ' ') RETURN u LENA = ITRAIL(ANS) u DO 30 I = 1,LENAu ITP = INDEX('CS',ANS(I:I)) u IF (ITP .NE. 0) GO TO 40 u30 CONTINUEu CALL WRTIO(' Option not recognized. Reenter option') u GO TO 20 u40 GO TO (50,60),ITP u GO TO 10uC uC CASE OPTION uC u50 CONTINUE u ANS = ' ' u IF (UCASE) THEN !u OUTLIN = ' Current case setting is "UPPER".' "u ELSE #u OUTLIN = ' Current case setting is "MIXED".' $u ENDIF %u CALL WRTIO(OUTLIN) &u CALL WRTIO(' ') 'u CALL RDTIO( (u $ 'Enter "U" for Upper case or "M" for Mixed case:', )u $ ANS,UPCASE) *u IF (ANS .NE. ' ') THEN +u UCASE = .TRUE.,u IF (INDEX(ANS,'M') .NE. 0) UCASE = .FALSE. -u ENDIF .u GO TO 10/uC 0uC SET SWITCHES 1uC 2u60 CALL EDISWI 3u GO TO 10q SUBROUTINE EDIOPT(INITAL)  SUBROUTINE EDIOPT(INITAL, EMODE)  LOGICAL INITAL  CHARACTER*(8) EMODE C C Set up edit optionsC C INITAL - .TRUE. - Not yet editing deck C .FALSE. - currently editing deck C  C  C Editor Option Selection control  C  C  *CALL PARAMA *CALL EDIOPTS *CALL CONTRL*CALL FNAMES*CALL LOGU *CALL SEQCTL  CHARACTER ANS*9  CHARACTER FNAME*72 C 10 CALL WRTIO('1 Editor Check/Alter Option Menu (select option).')  CALL WRTIO(' 1 - Upper/Lower Case input option.')  CALL WRTIO(' 2 - Switch Settings.') CALL WRTIO(' 3 - Edit Screen Sequencing data.') CALL WRTIO(' 4 - Compile file Sequencing data.')  CALL WRTIO(' 5 - Compile file Directives option.')  CALL WRTIO(' 6 - Compile file name.') n CALL WRTIO(' 7 - Source file name.')  CALL WRTIO(' 7 - modify file name.')  CALL WRTIO(' 8 - Change Editor.')  IF(.NOT.INITAL) GOTO 20  CALL WRTIO(' A - Continuation processing')  CALL WRTIO(' B - Recovery processing') ! CALL WRTIO(' C - Output backup file name.')"C #20 CALL WRTIO(' ') $ ANS=' ' % CALL RDTIO(' Enter option ("cr" - continue editing):'& 1 ,ANS,.TRUE.) ' IF (ANS .EQ. ' ') RETURN ( LENA = ITRAIL(ANS) ) DO 30 I = 1,LENA * IF(INITAL) THEN +q ITP = INDEX('1234567ABC',ANS(I:I))  ITP=INDEX('12345678ABC',ANS(I:I)) , ELSE -q ITP=INDEX('1234567',ANS(I:I)) ITP=INDEX('12345678',ANS(I:I)) . ENDIF / IF (ITP .NE. 0) GOTO 40 030 CONTINUE1 CALL WRTIO(' Option '//ANS(1:LENA)//2 1 ' not recognized Reenter option') 3 GOTO 20 4C 5q40 GOTO (100,200,300,400,500,600,700, 40 GOTO (100,200,300,400,500,600,700,800, 6 1 1100,1200,1300), ITP7C 8C CASE option 9C :100 IF (UPCASE) THEN; CALL WRTIO(' Current case setting is "UPPER".') < ELSE = CALL WRTIO(' Current case setting is "MIXED".') > ENDIF ? CALL WRTIO(' ') @ ANS=' ' A CALL RDTIO( B $ 'Enter ("U" - Upper case) ("M" - Mixed case):', C $ ANS,.TRUE.) D IF (ANS .NE. ' ') THEN E UPCASE = .TRUE. F IF (INDEX(ANS,'M') .NE. 0) UPCASE = .FALSE. G ENDIF HC I IF (UPCASE) THENJ CALL WRTIO(' Current case setting is "UPPER".') K ELSE L CALL WRTIO(' Current case setting is "MIXED".') M ENDIF N GOTO 10 OC PC SWITCH option QC R200 CALL EDISWI S GOTO 10 TC UC SCREEN SEQUENCING information VC W300 IF(LSTSEQ)THEN X CALL WRTIO(' Screen sequencing IS scheduled.') Y ELSE Z CALL WRTIO(' Screen sequencing is NOT scheduled.') [ ENDIF \C ] ANS = ' ' ^ CALL RDTIO(' Do you wish to change this (Y/N)?',ANS,.TRUE.) _ IF(ANS.EQ.'Y' ) THEN ` LSTSEQ=.NOT.LSTSEQ a ENDIF bC c IF(LSTSEQ)THEN d CALL WRTIO(' Screen sequencing IS scheduled.') e ELSE f CALL WRTIO(' Screen sequencing is NOT scheduled.') g ENDIF h GOTO 10 iC jC COMPILE FILE SEQUENCING information kC l400 IF(LSEQC.EQ.1)THEN m CALL WRTIO(' Compile file sequencing is FULL.') n ELSEIF(LSEQC.EQ.2) THENo CALL WRTIO(' Compile file sequencing is COMPRESSED.') p ELSEIF(LSEQC.EQ.3) THENq CALL WRTIO(' Compile file sequencing is NONE.') r ENDIF sC t ANS = ' ' u CALL RDTIO(' Enter (F - full) (C - compressed) (N - none):' v 1 ,ANS,.TRUE.) wC x IF (ANS.EQ.'F' ) THEN y LSEQC = 1z CALL WRTIO(' Compile file sequencing is FULL.') { ELSEIF(ANS.EQ.'C') THEN | LSEQC = 2} CALL WRTIO(' Compile file sequencing is COMPRESSED.') ~ ELSEIF(ANS.EQ.'N') THEN  LSEQC = 3 CALL WRTIO(' Compile file sequencing is NONE.') ENDIF GOTO 10 C C COMPILE FILE DIRECTIVE handlingC 500 IF(ICCD)THEN CALL WRTIO(' Compile file will have imbedded directives.') ELSE  CALL WRTIO(' Compile file will NOT have imbedded '//  1 'directives.') ENDIF C ANS = ' '  CALL RDTIO(' Do you wish to change this (Y/N)?',ANS,.TRUE.) IF(ANS.EQ.'Y' ) THEN ICCD=.NOT.ICCD ENDIF C IF(ICCD)THEN CALL WRTIO(' Compile file will have imbedded directives.') ELSE  CALL WRTIO(' Compile file will NOT have imbedded '//  1 'directives.') ENDIF GOTO 10 C C Change Compile file name C 600 CALL WRTIO(' The Compile file name is - '//NAMLCO(1:IWLCO)) FNAME = ' '  CALL RDTIO(' Enter new COMPILE file name: ',FNAME,.TRUE.) IF(FNAME.NE.' ') THEN NAMLCO=FNAME IWLCO=ITRAIL(NAMLCO) ENDIF C  CALL WRTIO(' The Compile file name is - '//NAMLCO(1:IWLCO)) GOTO 10 C nC Change Source file nameC Change modify file nameC n700 CALL WRTIO(' The Source file name is - '//NAMLSO(1:IWLSO)) 700 CALL WRTIO(' The modify file name is - '//NAMLMO(1:IWLMO)) FNAME = ' ' n CALL RDTIO(' Enter new SOURCE file name: ',FNAME,.TRUE.) CALL RDTIO(' Enter new modify file name: ',FNAME,.TRUE.) IF(FNAME.NE.' ') THEN n NAMLSO=FNAME  NAMLMO=FNAME n IWLSO=ITRAIL(NAMLSO)  IWLMO=ITRAIL(NAMLMO) ENDIF C n CALL WRTIO(' The Source file name is - '//NAMLSO(1:IWLSO))  CALL WRTIO(' The modify file name is - '//NAMLMO(1:IWLMO)) GOTO 10 C C Change editor C  800 CALL WRTIO(' The current editor is '//EMODE) ANS=' ' CALL RDTIO(  1 ' Enter the editor desired (Original, New or Full)',  2 ANS,.TRUE.)  IF(ANS(1:1).EQ.'O') THEN  EMODE='SLEDIT'  ELSEIF(ANS(1:1).EQ.'N') THEN  EMODE='LEDIT' ELSEIF(ANS(1:1).EQ.'F') THEN  EMODE='FSEDIT'  ENDIF C  CALL WRTIO(' The current editor is '//EMODE)  GOTO 10 C C CONTINUATION processing C 1100 IF(EDICON) THEN  CALL WRTIO(' Continue processing is scheduled to be done')  CALL WRTIO(' Using file '//NAMLCI(1:IWLCI)) ELSE  CALL WRTIO(' Continue processing is NOT scheduled') ENDIF ANS=' '  CALL RDTIO(' Enter (N - not continue) '//  1 ' (C - continue OR change file):',ANS,.TRUE.) IF(ANS.EQ.'N') THEN EDICON=.FALSE. ELSEIF(ANS.EQ.'C') THEN EDICON=.TRUE. FNAME=' ' CALL RDTIO(' Enter file to CONTINUE with:',FNAME,.TRUE.) IF(FNAME.NE.' ') THEN NAMLCI=FNAME  IWLCI=ITRAIL(NAMLCI) ENDIF ENDIF IF(EDICON) THEN  IF(EDIREC) THEN  CALL WRTIO(' (both recover and continue processing'//  1 ' are scheduled RECOVER will be turned off)')  EDIREC=.FALSE.  ENDIF CALL WRTIO(' Continue processing is scheduled to be done')  CALL WRTIO(' Using file '//NAMLCI(1:IWLCI)) ELSE  CALL WRTIO(' Continue processing is NOT scheduled') ENDIF GOTO 10 C C RECOVERY processing C 1200 IF(EDIREC) THEN  CALL WRTIO(' Recovery processing is scheduled to be done')  CALL WRTIO(' Using file '//NAMLBI(1:IWLBI)) ELSE  CALL WRTIO(' Recovery processing is NOT scheduled') ENDIF C ANS=' '  CALL RDTIO(' Enter (N - turn off recovery) '//  1 ' (R - recover OR change file):',ANS,.TRUE.) IF (ANS.EQ.'N') THEN EDIREC=.FALSE. ELSEIF(ANS.EQ.'R')THEN EDIREC=.TRUE. FNAME=' ' CALL RDTIO(' Enter file to RECOVER with:',FNAME,.TRUE.) IF(FNAME.NE.' ') THEN NAMLBI=FNAME  IWLBI=ITRAIL(NAMLBI) ENDIF ENDIF IF(EDIREC) THEN  IF(EDICON) THEN  CALL WRTIO(' (both recover and continue processing'//  1 ' are scheduled CONTINUE will be turned off)') EDICON=.FALSE. ENDIF CALL WRTIO(' Recovery processing is scheduled to be done')  CALL WRTIO(' Using file '//NAMLBI(1:IWLBI)) ELSE  CALL WRTIO(' Recovery processing is NOT scheduled') ENDIF GOTO 10 C C Change Output backup file name C 1300 CALL WRTIO(' The Backup output file name is - '//  1 NAMLBO(1:IWLBO)) FNAME = ' '  CALL RDTIO(' Enter new Backup output file name: ',FNAME,.TRUE.) IF(FNAME.NE.' ') THEN NAMLBO=FNAME IWLBO=ITRAIL(NAMLBO) ENDIF C  CALL WRTIO(' The Backup output file name is - '//  1 NAMLBO(1:IWLBO)) GOTO 10 4 END CALL OPNLDI(LDI,CONTI) GX CALL OPNLDI(LDI,CONTI(1:LCONTI)) cw ICHARS = 30000 u ICHARS = MAXBYT du CALL OPENER(LDI,CONTI(1:LCONTI),'OLD'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/82 ra<.)  SUBROUTINE EDIPOS )*IF EDITC C PRINTS CURRENT RECORD TO TERMINAL C *CA PARAMA *CA EDITCO *CA DECA*CA MODNA *CALL EDIOPTS r*CA LOGU  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*,'' r3 FORMAT(1X,A) r WRITE(LTO,3)''  CALL WRTIO(' ')  ELSE IF(IREC.EQ.NRECI) THEN  PRINT*,'[BOTTOM]' < PRINT*,''r WRITE(LTO,3)''  CALL WRTIO(' ')  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 CALL WRTIO(' 2 - Switch Settings.') CALL WRTIO(' 3 - Edit Screen Sequencing data.') CALL WRTIO(' 4 - Compile file Sequencing data.')  CALL WRTIO(' 5 - Compile file Directives option.')  CALL WRTIO(' 6 - Compile file name.')  CALL WRTIO(' 7 - Source file name.')  IF(.NOT.INITAL) GOTO 20 EDIPRI 6/14/82rR)  SUBROUTINE EDIPRI(A,N) )*IF EDITC C C PRINT ALFA PART OF RECORD ON TERMINAL C R*CA PARAMA r*CA LOGU  CHARACTER*120 A R CHARACTER*(MAXWID) AC  PRINT*,A(1:N) r3 FORMAT(1X,A) r WRITE(LTO,3)A(1:N)  CALL WRTIO(' '//A(1:N)) )*ENDIF RETURN  END  CHARACTER*8 DCK  C 10 CONTINUE IF(IREC.EQ.0) THEN  PRINT*,'[TOP]' < PRINT*,'' r3 EDIPRS 6/23/82rR<* SUBROUTINE EDIPRS(A,N,NAMSEQ) **IF EDITC C PRINT ALFA PART OF RECORD AND NAMSEQ ON TERMINALC R*CA PARAMA r*CALL ERRMES  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)//'>' r30 ERRMSG = A(1:N)//'<'//NAMSEQ(1:NCS)//'>' r CALL WRERR **ENDIF RETURN  END 3 FORMAT(1XEDIPRT 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/82r)  SUBROUTINE EDIREP(A))*IF EDIT  CHARACTER*(*) A C C REPLACE RECORD (INSERT THEN DELETE) C *CA PARAMA *CA EDITCO *CA DECAr*CA LOGU 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 EDIBKO('D',IREC,' ')  CALL EDIINS(A)  CALL EDIPOS C  RETURN C 1100 PRINT*,'CURRENT RECORD IS NOT A RECORD THAT CAN BE REPLACED'r1100 WRITE(LTO,1103)'Current record can not be replaced' r1103 FORMAT(1X,A) 1100 CALL WRTIO(' Current record can not be replaced.')  RETURN C 1200 PRINT*,'CURRENT RECORD DELETED/INACTIVE RECORD-CANNOT REPLACE' r1200 WRITE(LTO,1103)'Current record is INACTIVE cannot replace it'  1200 CALL WRTIO(' Current record is INACTIVE, cannot replace it.') )*ENDIF  RETURN  END %u CALL WRTIO(OUTLIN) &u CALL WRTIO(' ') 'u CALL RDTIO( (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/82rR) 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) r11 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 CALL EDIPOS C EDISWI 8/16/84  SUBROUTINE EDISWI C C EDIT SWITCH SETTINGS; C CHANGING CURRENT ONES C OR ADDING NEW SWITCHES C (SYNTAX: "ID", -"ID" OR /"ID", WHERE "ID": NUMBER OR NAME)C ( SET RESET DELETE )C  *CA PARAMA  *CA SWITCH *CALL EDIOPTS  INTEGER ISWI, IDIGIT, LENSWR CHARACTER*9 SWII, SWIREQ CHARACTER*80 OUTLIN  CHARACTER*3 SWINUM  INTEGER CP  CHARACTER*1 QANS, FCREQ, CHARI y LOGICAL RESET, DELETE, UPCASE  LOGICAL RESET, DELETE y PARAMETER (UPCASE= .TRUE.) C C DISPLAY CURRENT SETTINGSC  CALL WRTIO(  $ ' == SWITCHES == "id": either number or name, e.g. 1 or VAX')  CALL WRTIO(' ')  CALL WRTIO(' ') CALL WRTIO(' To add a switch: "name" or -"name"') CALL WRTIO(' To set all switches: * , to reset: -*')  CALL WRTIO(' ')  CALL WRTIO(' ') 10 CONTINUE  CP= 2  OUTLIN= ' '  DO 50 I= 1, NSWS WRITE(SWINUM, '(I3)') I ! OUTLIN(CP:CP+2)= SWINUM " CP= CP + 4 # IF (.NOT. LSWTCH(I)) THEN $ OUTLIN(CP:CP) = '-' % ENDIF & CP= CP + 1 ' OUTLIN(CP:CP+7) = SWITCH(I) ( CP= CP + 10 ) IF (MOD(I,5) .EQ. 0) THEN * CALL WRTIO(OUTLIN) + OUTLIN= ' ' , CP= 2 - ENDIF .50 CONTINUE/ IF(MOD(NSWS, 5) .NE. 0) CALL WRTIO(OUTLIN) 0C 1C SEE WHAT IS DESIRED 2C 3| CALL WRTIO(' ')  SWIREQ = ' '  CALL WRTIO(' ') 4 CALL RDTIO( 5 $ 'Enter "id" to toggle, /"id" to delete, "CR" to stop', 6y $ SWIREQ, UPCASE)  $ SWIREQ, .TRUE.) 7 LENSWR= INDEX(SWIREQ, ' ') - 1 8 IF (LENSWR .LT. 0) LENSWR= LEN(SWIREQ) 9 IF (LENSWR .LT. 1) GOTO 200 : RESET= .FALSE. ; DELETE= .FALSE. < CP= 1 = FCREQ= SWIREQ(CP:CP) > IF (FCREQ .EQ. '-') THEN ? CP= 2 @ RESET= .TRUE.A ELSE IF (FCREQ .EQ. '/') THEN B CP= 2 C DELETE= .TRUE. D ENDIF E CHARI= SWIREQ(CP:CP) F IF (CHARI .EQ. '*') THEN G CALL RDTIO( H $ '? Do you really want to change ALL the switches ?', I $ QANS, UPCASE)J IF (QANS .NE. 'Y') GOTO 10 K DO 105 I= 1,NSWS L105 LSWTCH(I)= .NOT. RESET M GOTO 10 N ENDIF O IF (CHARI .LE. '9') THEN P ISWI= 0 Q DO 110 I= CP, LENSWR R IDIGIT= INDEX('0123456789', SWIREQ(I:I)) - 1 S IF (IDIGIT .LT. 0) GOTO 130 T ISWI= ISWI * 10 + IDIGIT U110 CONTINUE V IF (ISWI .LT. 1 .OR. ISWI .GT. NSWS) GOTO 130W SWIREQ(CP:)= SWITCH(ISWI)X ELSE Y DO 120 I= 1, NSWSZ IF (SWIREQ(CP:) .EQ. SWITCH(I)) GOTO 125 [120 CONTINUE \ IF (NSWS .GE. MAXSWI) GOTO 135 ] CALL RDTIO('? Add '//SWIREQ//' (Y/N) ?', QANS, UPCASE) ^ IF (QANS .NE. 'Y') GOTO 10 _ I= NSWS + 1 ` LSWTCH(I)= .FALSE. a125 ISWI= I b ENDIF c IF (RESET .OR. LSWTCH(ISWI)) THEN d SWII= '-'//SWIREQ(CP:) e ELSE f SWII= SWIREQ(CP:) g ENDIF h IF (DELETE) THENi CALL RDTIO('? DELETE '//SWII//' (Y/N) ?', QANS, UPCASE) j IF (QANS .NE. 'Y') GOTO 10 k NSWS= NSWS - 1 l DO 128 I= ISWI, NSWS m IP1= I + 1n LSWTCH(I)= LSWTCH(IP1)o SWITCH(I)= SWITCH(IP1) p128 CONTINUE q ELSE r CALL SWIDEF (SWII) s ENDIF t GOTO 10 uC v130 CALL WRTIO('*** Not a valid switch') w| CALL WRTIO(' ')  CALL WRTIO(' ') x GOTO 10 yC z135 CALL WRTIO('*** Too many switches') {| CALL WRTIO(' ')  CALL WRTIO(' ') | GOTO 10 }C ~200 RETURN  END GOTO 10 TC UC SCREEN SEQUENCING information VC W300 IF(LSTSEQ)THEN X CALL WRTIO(' Screen sequencing IS scheduled.') Y ELSE Z CALL WRTIO(' Screen sequencing is NOT scheduled.') [ ENDIF \C ]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{yrXRDC>;4)"  SUBROUTINE EDITOR Cr SUBROUTINE EDITOR (RECOV) Cr LOGICAL RECOV q SUBROUTINE EDITOR  SUBROUTINE EDITOR (NMODE) )*IF EDITC C PROCESS ALL EDIT COMMANDS C *CA PARAMA *CA BUFA*CA LOGU Cr*CA EDIBKU *CALL EDIOPTS 4 CHARACTER*120 BUX R CHARACTER*(MAXWID) BUX  CHARACTER*1 QANSC NMODE - next mode of editor  CHARACTER*(*) NMODE  CHARACTER *8 CMODE C Cr LBAKUF = .FALSE. z UCASE = .TRUE. CALL EDIPOS  C  10 CALL RDTERM(LTI,IWID) 4 BUX=BUF(2:)   CALL EDIDIR(IWID,J) C10 CONTINUE Cr IF(RECOV) THEN C READ(LBO,11,END=7040,ERR=7030) J,IWID,BUF(1:IWID)Dr READ(LBI,11,END=7040,ERR=7030) J,IWID,BUF(1:IWID) Cr11 FORMAT(I2,I3,A) C r ELSE C r IF(LBAKUF) THEN C r WRITE(LBO,11) J,IWID,BUF(1:IWID) C r ELSE C r LBAKUF=.TRUE. Cr ENDIFC CALL RDTERM(LTI,IWID){ CALL RDTERM('?',LTI,IWID) | CALL RDTERM('?',IWID) u CALL RDTERM('?',IWID,UCASE)  CALL RDTERM('?',IWID,UPCASE) C CALL EDIDIR(IWID,J) Cr 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 y~C T B F N P(.)A I D R C(S) - H E + y~ GOTOy~ 1 (100,200,300,400,500,600,700,800,900,1000,1100,4000,5000,1400),JC T B F N P(.)A I D R C(S) - H E + C Q *  GOTO 1 (100,200,300,400,500,600,700,800,900,1000,1100,4000,5000,1400,  2 6000,8000), J  PRINT*,'INCORRECT INPUT TO SLIB77 EDITOR (H FOR HELP)' r WRITE(LTO,13)'Unrecognized editor command (H for help)' r13 FORMAT(1X,A) CALL WRTIO(' Unrecognized editor command (H for help).') Dr 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' r WRITE(LTO,13)'No text string on FIND command' CALL WRTIO(' No text string found on FIND command.') Cr 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' r WRITE(LTO,13)'No text to add on ADD command'  CALL WRTIO(' No text to add on ADD command.') Xr 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' r WRITE(LTO,13)r 1 'No text on insert enter multiple records (CR to end insert)' "710 CALL RDTERM(LTI,IWID){710 CALL RDTERM('+',LTI,IWID)  CALL WRTIO(' No text on insert. Enter multiple records '//  $ '(CR to end insert)') | 710 CALL RDTERM('+',IWID)u710 CALL RDTERM('+',IWID,UCASE) 710 CALL RDTERM('+',IWID,UPCASE) " 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)) Dr IF(LBAKUF) WRITE(LBO,11) J,IWID+1,'I'//BUF(1:IWID) " CALL EDIPOS  RCOUNT = RCOUNT + 1 ; 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  RCOUNT = RCOUNT + 1 @ GOTO 10 ; C ; 720 CONTINUE ;  PRINT*,'End INSERT' r WRITE(LTO,13)'End of INSERT' CALL WRTIO(' End INSERT.') ; CALL EDIPOS Cr 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' r WRITE(LTO,13)'No text to replace record with' CALL WRTIO(' No text to replace record with.') Cr 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'r  WRITE(LTO,13)'Substitute command improper'  CALL WRTIO(' Substitute command improper.') U PRINT*,'RE-ENTER COMMAND' Cr 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 CONTINUECr LBAKUF=.FALSE. cl CALL EDIHEL(BUF(1:IWID))  CALL EDIHEL ; PRINT*,'End of HELP'r  WRITE(LTO,13)'End of HELP'  CALL WRTIO(' End of HELP.') ; CALL EDIPOS d GOTO 10 eC fC END OF EDIT g5000 CONTINUEhm CALL EDIEND(BUF(1:IWID))  CALL EDIEND r CALL CLSFIL(LBO)  CALL DELFIL(LBO) C RETURN C CLOSE UP AND DELETE THE OUTPUT FILES 6000 CONTINUE CALL RDTIO(  $ '? Do you really want to Quit and DELETE the output files ?', $ QANS, .TRUE.)  IF (QANS .NE. 'Y') GOTO 100  | CLOSE(LBO, STATUS= 'DELETE')| CLOSE(LCO, STATUS= 'DELETE')| CLOSE(LSO, STATUS= 'DELETE')| CLOSE(LDO, STATUS= 'DELETE')  CALL DELFIL(LBO) u CALL DELFIL(LCO) u CALL DELFIL(LSO) u CALL DELFIL(LDO)  RETURN CrC CrC ERROR IN BACKUP FILE C7030 PRINT*,'Error while reading backup file will stop reading' r 7030 WRITE(LTO,13)'Error while reading backup file will continue' r7030 CALL WRTIO(' Error while reading backup file. Will continue.') CrC CrC End of BACKUP file CrC C 7040 PRINT*,'End of backup file' r 7040 WRITE(LTO,13)'End of backup file'  r7040 CALL WRTIO(' End of backup file.') )x*ENDIF ir RETURN 8000 CONTINUE | CALL EDISWI u CALL EDIOPT q CALL EDIOPT(.FALSE.)  CMODE=NMODE  CALL EDIOPT(.FALSE.,CMODE) IF(CMODE.NE.NMODE) THEN NMODE=CMODE RETURN ENDIF  GOTO 100*ENDIF EDIT j END { ENDIF ~ IF(NCTLS.GE.MAXCTL) CALL CTLCRE (CTLLIS(NCTLS),NCTLS,NCCERR) { NCTLS=NCTLS+1 { CTLLIS(NCTLS)=' The compile file sequencing type will be - '// { 1 SEQTYP(LSEQC) EDIVMD 6/14/82rXR)$ 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 *CALL ITABC r*CA LOGU R CHARACTER*(MAXWID) A,B vC ON THE VAX A TAB IS A 9  vC AND AN APSOTROPHE IS A 39  vC WHEN USING ICHAR AND CHAR  vC  v 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' v IF(ICHAR(B(1:1)).EQ.ITAB.AND.  IF(ICHAR(B(1:1)).EQ.ITABC.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,Mv IF(ICHAR(B(I:I)).EQ.ITAB) THEN  IF(ICHAR(B(I:I)).EQ.ITABC) 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' r260 WRITE(LTO,261)'vax record too long'r261 FORMAT(1X,A) % PRINT*,B r WRITE(LTO,261)B(1:N)  CALL WRTIO(' VAX record too long.') CALL WRTIO(' '//B(1:N)) & 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 ]*IF PRIME ] DATA COMEXT /'.F77'/f DATA COMEXT /'.F77','.COB'/ ]*ENDIF z DATAENDPRO 7/03/84  SUBROUTINE ENDPRO(NN) C C End of programC C NN - status indicator C 0 = normal end of runC 1 = end of run - with errors C 2 = abort because of catastrophic errors  C *IF PRIME C C Signal bad status (.ne.0) to system C otherwise, normal stop C  INTEGER*2 DUMMY  PARAMETER (DUMMY= 3) /* WHATEVER,... */C  *ENDIF IF ( NN.EQ.2) THEN  *IF PRIME  CALL SETRC$(DUMMY) *ENDIF  STOP 'Catastropic end of SLIB77 run' ELSEIF (NN.EQ. 1) THEN  *IF PRIME  CALL SETRC$(DUMMY)*ENDIF  STOP 'End of SLIB77 run with error'  ELSE STOP 'Normal end of SLIB77 run'  ENDIF  END  IF(YESN.EQ.'YES') THEN C  PRINTEXAL 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]' ELSEFILECK 4/19/85 SUBROUTINE FILECK(NU,FILTYP,NAM,IWNAM,STATUS,IDDNAM) C C Processes file name before opening file C C NU - file unit number C FILTYP - File description C NAM - Name of file C IWNAM - current width of name C STATUS - "OLD" OR "NEW'  C IDDNAM - Status of name used C 0 - Name is used C 1 - using DDNAME C *CALL BATCH *CALL ERRMES i*CALL LOGU  CHARACTER*(*) FILTYP  CHARACTER*(*) NAM  CHARACTER*(*) STATUS  LOGICAL EX  CHARACTER ANS*72  CHARACTER*3 VERSN *IF NPS *CALL NPSARG CHARACTER*3 SEQ,DIRECT,FORMAT,UNFORM INTEGER ICHARS, IWORDS, NUMBER  LOGICAL QREAD, QWRITE, QDELET, QCREAT, QOPEN*ENDIF NPS C i11 FORMAT('FOR',I3.3) 11 FORMAT(A, I3.3)  IDDNAM = 0  *IF VAX ! IF (NAM .EQ. ' ') THEN "i WRITE(NAM,11) NU  WRITE(NAM,11) 'FOR', NU # IWNAM = 6 $ ENDIF %*ENDIF VAX *IF APOLLO  IF (NAM .EQ. ' ') THEN  WRITE(NAM,11) 'FOR', NU  IWNAM = 6  ENDIF *ENDIF APOLLO  *IF CDC IF (NAM .EQ. ' ') THEN  WRITE(NAM,11) 'FOR', NU IWNAM = 6 ENDIF *ENDIF CDC *IF COS  IF (NAM .EQ. ' ') THEN  WRITE(NAM,11) 'FOR', NU  IWNAM = 6  ENDIF *ENDIF COS *IF DGEN  IF (NAM .EQ. ' ') THEN  WRITE(NAM,21) 'FT', NU 21 FORMAT(A,I2.2)  IWNAM = 4  ENDIF *ENDIF DGEN *IF HARRIS  IF (NAM .EQ. ' ') THEN  WRITE(NAM,11) 'FOR', NU  IWNAM = 6 ENDIF !*ENDIF HARRIS "*IF HP1 # IF (NAM .EQ. ' ') THEN $ WRITE(NAM,11) 'FOR', NU % IWNAM = 6 & ENDIF '*ENDIF HP1 (*IF UNIVAC ) IF (NAM .EQ. ' ') THEN * WRITE(NAM,11) 'FOR', NU + IWNAM = 6 , ENDIF -*ENDIF UNIVAC &*IF IBM ' IF (NAM .EQ. ' ') THEN ( IDDNAM = 1 )i WRITE(NAM,11) NU . WRITE(NAM,11) 'FOR', NU * IWNAM = 6 + RETURN , ENDIF -C . 100 CONTINUE/C 0*IF -NPS 1 EX = STATUS.EQ.'OLD'2*ENDIF -NPS 3*IF NPS 4 CALL BYFILE(NAM,5 $ EX,QOPEN,SEQ,DIRECT,FORMAT,UNFORM,ICHARS,IWORDS,NUMBER, 6 $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)7 IF (QREADY.AND.QERROR) THEN 8 ERRMSG = 'BYFILE called with NAM='//NAM 9 CALL NPSEIO('BYFILE via FILECK',ERRMSG(1:ITRAIL(ERRMSG))) : ENDIF ;*ENDIF NPS < IF (EX .AND. STATUS .EQ. 'NEW') THEN= ERRMSG = ' *ERROR* '//FILTYP//' file already exists ->'//NAM > CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) ? IF (TMODE .NE. 'BATCH') GO TO 200@ CALL THEEND(2,' Abort due to bad fileid.') A ENDIF B IF (.NOT.EX .AND. STATUS .EQ. 'OLD') THEN C ERRMSG = ' *ERROR* '//FILTYP//' file does not exist ->'//NAM D CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) E IF (TMODE .NE. 'BATCH') GO TO 300F CALL THEEND(2,' Abort due to bad fileid.') G ENDIF H RETURN IC J 200 ANS = ' ' K CALL RDTIO('Do you wish to write over file (Y/N) ?',ANS,.TRUE.) L IF (INDEX('Yy',ANS(1:1)) .NE. 0) THEN M STATUS = 'OLD' N RETURN O ENDIF P 300 ANS = ' ' Q CALL RDTIO('Do you wish to enter a different fileid (Y/N) ?'R $ ,ANS,.TRUE.)S IF (INDEX('Yy',ANS(1:1)) .NE. 0) THEN T ANS = ' 'U CALL RDTIO('Enter new fileid : ',ANS,.TRUE.) V IF (ANS .NE. ' ') THEN W NAM = ANS X IWNAM = ITRAIL(NAM) Y GO TO 100 Z ENDIF [ ELSE \ GO TO 9000 ] ENDIF ^*ENDIF IBM _*IF DEC20 ` IF (NAM .EQ. ' ') THEN ai WRITE(NAM,11) NU / WRITE(NAM,11) 'FOR', NU b IWNAM = 6 c ENDIF dC e ITYPE = INDEX(NAM,'.') f IF (ITYPE .EQ. 0) THEN g NAM(ISIZE:) = '.DAT.'//NVER h IWNAM = ITRAIL(NAM) i RETURNj ENDIFk IVERS = INDEX(NAM(ITYPE+1:),'.') l IF (IVERS .EQ. 0) THEN m NAM(ISIZE:) = '.'//NVER n IWNAM = ITRAIL(NAM) o ENDIFp*ENDIF DEC20qC r*IF PRIME s IF (NAM .EQ. ' ') THEN ti WRITE(NAM,11) NU 0 WRITE(NAM,11) 'FOR', NU u IWNAM = 6 v ENDIF wC xa ISIZE = INDEX(NAM,' ') ya J = 1 zg 20 INQUIRE(FILE=NAM,EXIST=EX,ERR=200) a 20 INQUIRE(FILE=NAM,EXIST=EX,ERR=9000) {a IF (EX .EQV. .TRUE.) THEN |a WRITE(VERSN,30) J INQUIRE(FILE=NAM,EXIST=EX,ERR=9000)  IF (EX .EQV. .TRUE. .AND. STATUS .EQ. 'NEW') THEN  J = 0 ISIZE = INDEX(NAM,' ') C  20 IF (J .GE. 99) GOTO 9000  J = J + 1  WRITE(VERSN,30) J } 30 FORMAT('.',I2.2) ~ NAM(ISIZE:ISIZE+2) = VERSN(1:3) a IWNAM = ISIZE + 2 a J = J + 1a IF (J .GT. 99) GO TO 9000 a GO TO 20 g IF (J .GT. 1) THEN g ERRMSG=' Replaced '//FILTYP//' file name '// g 1 NAM(1:ISIZE)//' with '//NAM(1:ISIZE+2)g CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) g ENDIF g ENDIF a ENDIF  C  INQUIRE(FILE=NAM,EXIST=EX,ERR=9000)  IF (EX .EQV. .TRUE.) GOTO 20  C a IF (J .GT. 1) THEN a ERRMSG=' Replaced '//FILTYP//' file name '// a 1 NAM(1:ISIZE)//' with '//NAM(1:ISIZE+2) a CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) a ENDIF IWNAM = ISIZE + 2 ERRMSG=' Replaced '//FILTYP//' file name '//  1 NAM(1:ISIZE)//' with '//NAM(1:IWNAM)  CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG)))  ENDIF *ENDIF PRIME RETURN C  9000 ERRMSG=' Must abort - bad '//FILTYP//' file name ->'//NAM  CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) CALL THEEND(2,' Abort due to bad fileid.')  STOP END FILEID 7/26/84n SUBROUTINE FILEID(NU,FNAME,OUTNAM) nC nC THIS SUBROUTINE FORMATS A FILEID FROM THE TYPE OF FILE AND THE nC FILE NAME PASSED. nC n CHARACTER FNAME*(*), OUTNAM*(*) n INTEGER NU nC The PRIME needs the following statement n EXTERNAL ITRAIL n  nC n*CALL FILEIDS n*CALL LOGU n CHARACTER ANS*72 n INTEGER TYPE n LOGICAL OUTPUT nC nC n10 OUTNAM = ' 'n IF (FNAME .EQ. ' ') RETURN z*IF -IBMVM z IF(INDEX(FNAME,'.').NE.0) THEN z OUTNAM=FNAME z RETURN z ENDIF z*ENDIF -IBMVM n IF (FNAME(1:1) .EQ. '/') THEN n IF (ITRAIL(FNAME) .NE. 1) OUTNAM = FNAME(2:) n RETURN n ENDIF nC n IF(NU.EQ.LCO) THEN n TYPE=1 n OUTPUT=.TRUE. n ELSEIF(NU.EQ.LOU) THEN n TYPE=2 n OUTPUT=.TRUE.  n ELSEIF(NU.EQ.LOP) THEN !n TYPE=3 "n OUTPUT=.FALSE.#n ELSEIF(NU.EQ.LNP) THEN $n TYPE=3 %n OUTPUT=.TRUE. &n ELSEIF(NU.GE.LIN) THEN 'n TYPE=4 (n OUTPUT=.FALSE.)n ELSEIF(NU.EQ.LSO) THEN *n TYPE=5 +n OUTPUT=.TRUE. ,n ELSEIF(NU.EQ.LIA) THEN -n TYPE=6 .n OUTPUT=.FALSE./n ELSEIF(NU.EQ.LOA) THEN 0n TYPE=6 1n OUTPUT=.TRUE. 2n ELSEIF(NU.EQ.LBI) THEN 3n TYPE=7 4n OUTPUT=.FALSE.5n ELSEIF(NU.EQ.LBO) THEN 6n TYPE=7 7n OUTPUT=.TRUE. 8u ELSEIF(NU.EQ.LDI) THEN n ELSEIF(NU.EQ.LCI) THEN 9n TYPE=8 :n OUTPUT=.FALSE.;u ELSEIF(NU.EQ.LDO) THEN <u TYPE=8 =u OUTPUT=.TRUE. >n ELSE ?| CALL WRTIO(' **ERROR** Logical unit no. invalid for '//FNAME) n ANS = FNAME n CALL WRTIO(' **ERROR** Logical unit no. invalid for '//ANS) @n RETURN An ENDIF BnC CzC processing FNAME into fileid by adding MACHID and DIRTID in front DzC of FNAME and appending FTYPE and POSTID to end of FNAME EzC This may be overkill but should be portable nC processing FNAME into fileid by adding PREID in front of FNAMEnC and appending POSTID to end of FNAME.FnC Gz OUTNAM = MACHID(TYPE) HzC Iz IF (DIRTID(TYPE) .NE. ' ') THEN Jz LENI = ITRAIL(OUTNAM)Kz IF (OUTNAM .NE. ' ') THENLz OUTNAM = OUTNAM(1:LENI)//DIRTID(TYPE) Mz ELSENz OUTNAM = DIRTID(TYPE) Oz ENDIF Pz ENDIF n J = INDEX(FNAME,'*') n IF (J .NE. 0) THEN  n IF (J .GT. 1) PREID(TYPE) = FNAME(1:J-1)  n IF (ITRAIL(FNAME) .GE. J+1) POSTID(TYPE) = FNAME(J+1:) n RETURN n*IF -IBMVM n ELSE n IF (INDEX(FNAME,'.') .NE. 0) THEN n OUTNAM = FNAME n RETURN n ENDIF n*ENDIF -IBMVM n ENDIF nC n OUTNAM = PREID(TYPE)QnC Rn IF (OUTNAM .NE. ' ') THEN Sn LENI = ITRAIL(OUTNAM)Tn OUTNAM = OUTNAM(1:LENI)//FNAME Un ELSE Vn OUTNAM = FNAME Wn ENDIF XzC Yz LENI = ITRAIL(OUTNAM) Zz IF (FTYPE(TYPE) .NE. ' ') OUTNAM = OUTNAM(1:LENI)//FTYPE(TYPE) [nC \n LENI = ITRAIL(OUTNAM) ]n IF (POSTID(TYPE) .NE. ' ') OUTNAM = OUTNAM(1:LENI)//POSTID(TYPE)^nC _n*IF IBMVM `n LENI = ITRAIL(OUTNAM) an IF (OUTPUT) THENbn OUTNAM = OUTNAM(1:LENI)//WDISK cn ELSE dn OUTNAM = OUTNAM(1:LENI)//RDISK en ENDIF fnC gn CALL UCASE(OUTNAM,ANS) hn OUTNAM=ANS in*ENDIF IBMVM SUBROUTINE FILEID ( ORIG, NEW, DECKN) C C Fileid used when user puts * in filenameC Creates file name from user input and deck name C C ORIG - name enterd by user (contains *) C NEW - name created (deckname replaces *) C DECKN - deck name  C  CHARACTER* (*) ORIG, NEW, DECKN  C LOCA = INDEX(ORIG,'*') IF (LOCA .EQ. 0) THEN  NEW = ORIG  RETURN  ENDIF  LENORI = LEN(ORIG)  LENAM = INDEX(DECKN,' ') - 1l IF(LENAM .LE. 0) LNAM = 8  IF(LENAM .LE. 0) LENAM = 8  IF(LOCA .LT. 2) THEN IF(LENORI .EQ. 1) THEN  NEW = DECKN  ELSE NEW = DECKN(1:LENAM)//ORIG(2:)  ENDIF  ELSE  IF(LOCA .EQ. LENORI) THEN NEW = ORIG(1:LOCA-1)//DECKN(1:LENAM)  ELSE NEW = ORIG(1:LOCA-1)//DECKN(1:LENAM)//ORIG(LOCA+1:)  ENDIF ENDIF j RETURN k END 400),J y~C T B F N P(.)A I D R C(S) - H E + y~ GOTOy~ 1 (100,200,300,400,500,600,700,800,900,1000,1100,4000,5000,1400),JC T B F N P(.)A I D R C(S) - H E + C Q FSEADD 12/14/84 SUBROUTINE FSEADD(LINE,DATA,MSGLIN,IERROR)C C FULL SCREEN EDIT ADD LINE ROUTINEC ADDS LINE AFTER SPECIFIED LINE C  CHARACTER DATA*(*), MSGLIN*(*)  INTEGER LINE, IERROR *IF EDIT C  *CALL PARAMA *CALL DECA  *CALL EDITCO C  CHARACTER TBUF*(MAXWID) C  IERROR = 0 IF (LINE .EQ. NRECI) LINE = L(LINE) p CALL EDIBKO('I', LINE, DATA)  CALL EDIBKO('I', LINE, DATA(1:ITRAIL(DATA)))  NRECT = NRECT + 1  NR = N(LINE)  N(LINE) = NRECT  N(NRECT) = NR  L(NR) = NRECT  L(NRECT) = LINE  IR(NRECT) = IDECPN NWORDS = (ITRAIL(DATA)+NCHRWD-1)/NCHRWD  CALL ININ(IDECPN,NWORDS,1)  TBUF = DATA  CALL INCHW(TBUF,ADEC(IDECPN),NWORDS*NCHRWD)  IDECPN = IDECPN + NWORDS *ENDIF EDIT  RETURN! END IF(YFSECMD 12/14/84 SUBROUTINE FSECMD(CMDLIN,ICMND) C C COMMAND LINE SCANER C SCANS COMMAND LINE FOR A VALID COMMAND AND RETURNS INTEGER C VALUE FOR COMMAND PLUS NEXT CHARACTER POSITION AFTER COMMAND. C  CHARACTER CMDLIN*(*)  INTEGER ICMND  *IF EDIT C  *CALL SCAN  C d PARAMETER (NCMNDS=17)  PARAMETER (NCMNDS=22)  CHARACTER CMNDS(NCMNDS)*8, CMND*8  INTEGER MINCHR(NCMNDS)C d DATA (CMNDS(I),MINCHR(I),I=1,NCMNDS) / DATA (CMNDS(I),MINCHR(I),I=1,15) /  $ 'FORWARD ' , 1,  $ 'BACKWARD' , 1,  $ 'UP ' , 1,  $ 'DOWN ' , 1,  $ 'ADD ' , 1,  $ 'DELETE ' , 3,  $ 'LOCATE ' , 1,  $ 'CHANGE ' , 1,  $ 'FILE ' , 4,  $ 'QUIT ' , 1, d $ 'QQUIT ' , 5,  $ 'QQUIT ' , 2,  $ 'HELP ' , 1,  $ 'TOP ' , 3,  $ 'BOTTOM ' , 3,  d $ 'SET ' , 1,  $ 'SET ' , 1 / DATA (CMNDS(I),MINCHR(I),I=16,NCMNDS) / ! $ 'INSERT ' , 1, "d $ 'TYPE ' , 1 /  $ 'TYPE ' , 1,  $ 'NAME ' , 3,  $ 'COPY ' , 3, $ 'MOVE ' , 3, $ ': ' , 1, $ '. ' , 1 /#C $ CALL SCANFS(CMDLIN) %C & IF (NWRD .EQ. 0) THEN ' ICMND = 0 ( RETURN ) ENDIF *C + IF (INDEX('/+-',CMDLIN(ISS(1):ISS(1))) .NE. 0) THEN , ICMND = -7 - RETURN . ENDIF /C 0o CALL UCASE(CMDLIN(ISS(1):ISS(1)+ISL(1)-1),CMND) n CALL UCASE(CMDLIN(ISS(1):ISE(1)),CMND) CMND = CMDLIN(ISS(1):ISE(1))  LENW=ISE(1)-ISS(1)+1  CALL UCASE(CMND(1:LENW)) 1 DO 70 ICMND = 1,NCMNDS2o IF (ISL(1).GE.MINCHR(ICMND) .AND.  IF (LENW.GE.MINCHR(ICMND) .AND. 3o $ CMNDS(ICMND)(1:ISL(1)).EQ.CMND(1:ISL(1))) GO TO 80  $ CMNDS(ICMND)(1:LENW).EQ.CMND(1:LENW)) GO TO 80 470 CONTINUE 5 ICMND = 0 680 CONTINUE 7*ENDIF EDIT 8 RETURN9 END INSGRP 8/28/84ITRAIL 7/26/84KOMDEC 3/22/82KOMMOD 3/22/82KOMYAN 3/17/83VLISCOM 3/22/82LISCRD 3/22/82LISDCK 3/22/82 LISERR 11/05/823ELISLEN 11/19/84FSEDEL 12/14/84 SUBROUTINE FSEDEL(LINE,MSGLIN,IERROR) C C FULL SCREEN EDIT ADD LINE ROUTINE C DELETES LINE C  CHARACTER MSGLIN*(*)  INTEGER LINE, IERROR *IF EDIT C  *CALL PARAMA *CALL DECA  *CALL EDITCO*CALL FSECOM C  INTEGER ITAG, TLINE  DIMENSION IRD(5) C  IERROR = 0  ITEMP = IR(LINE)  IF (ITEMP .LE. 0) THEN MSGLIN = 'RECORD DOES NOT EXIST'  IERROR = 1000  RETURN  ENDIF  IF (LINE .LT. NRECI) THEN  CALL EXIN(ITEMP,IRD,5)  IF (IRD(4) .LT. 0) THEN  MSGLIN = 'RECORD ALREADY DELETED'  IERROR = 1000  RETURN  ENDIF  ENDIF  IR(LINE) = -IR(LINE)  CALL EDIBKO('D', LINE, ' ')  TLINE = LINE !d CALL FSEDWN(LINE,1,MSGLIN,IERROR)  CALL FSEDWN(LINE,1,J,MSGLIN,IERROR) C C CHECK TAG TABLE TO SEE IF DELETED LINE WAS TAGED C  DO 10 ITAG = 1,NTAGS  IF (TAGLIN(ITAG) .EQ. TLINE) GO TO 20 10 CONTINUE  RETURN 20 NTAGS = NTAGS - 1 DO 30 I = ITAG,NTAGS  TAGLIN(I) = TAGLIN(I+1) 30 TAGNAM(I) = TAGNAM(I+1) "*ENDIF EDIT # RETURN$ END NDS=22)  CHARACTER CMNDS(NCMNDS)*8, CMND*8  INTEGER MINCHR(NCMNDS)C d DATA (CMNDS(I),MINCHR(I),I=1,NCMNDS) / DATA (CMNDS(I),MINCHR(I),I=1,15) /  $ 'FORWARD ' , 1,  $ 'BACKWARD' , 1, FSEDIT 12/14/84  SUBROUTINE FSEDIT(PMODE) C C FULL SCREEN EDITOR C  CHARACTER*(*) PMODE *IF EDITC *CALL PARAMA *CALL EDITCO *CALL EDIOPTS  *CALL FSECOM d*CALL NPSARG *CALL WIDTH C  CHARACTER*(MAXWID) LSTCMD, CMND, MSGLIN  CHARACTER*10 EMODE  INTEGER IQUERYC C INITIALIZE EDITOR AND FORMAT SCREEN C  EMODE = PMODE  IF (EMODE.NE.'FSEDIT' .AND. EMODE.NE.'LEDIT') THEN  I = 0 5 EMODE = ' '  CALL RDTIO('Which editor do you wish to use (FULL or LINE)?',  $ EMODE,.TRUE.)  I = I + 1  IF (I .GT. 3) RETURN IF (EMODE(1:1) .EQ. 'F') EMODE = 'FSEDIT'  IF (EMODE(1:1) .EQ. 'L') EMODE = 'LEDIT' IF (EMODE.NE.'FSEDIT' .AND. EMODE.NE.'LEDIT') GO TO 5  ENDIF ! CALL FSEIPL(EMODE) " MSGLIN = ' ' # LSTCMD = ' ' $ IQUERY = 0%C &C PROCESS ANY BUTTON KEYS THAT HAVE BEEN PUSHED'C (10 IF (IQUERY.NE.0) THEN ) CMND = BUTTON(IQUERY) * IQUERY = 0 + GO TO 30, ENDIF -C .C SETUP COMMAND LINE /C 015 IF (LSTCMD(1:1) .EQ. '&') THEN 1 CMND = LSTCMD 2 ELSE IF (CMND(1:1) .EQ. '?') THEN 3 CMND = LSTCMD 4 ELSE 5 CMND = ' ' 6 ENDIF 720 CONTINUE 8 IF (EMODE .EQ. 'FSEDIT') THEN 9 CALL FSESCN(CMND,MSGLIN,IQUERY) : ELSE ; CALL FSETRM(CMND,MSGLIN,IQUERY) < ENDIF =C >C PROCESS THE COMMAND LINE ?C @30 IF (CMND .EQ. ' ') GO TO 10 A IF (CMND(1:1) .EQ. '?') GO TO 15 B IF (CMND(1:1) .NE. '=') LSTCMD = CMND C ICOL = 1 D IF (LSTCMD(1:1) .EQ. '&') ICOL = 2E CALL FSEXEC(EMODE,LSTCMD(ICOL:),MSGLIN,IERROR)F IF (IERROR .GT. 8) GO TO 20 G IF (IERROR .GE. 0) GO TO 10 HC IC FILE CHANGES JC K IF (IERROR .EQ. -1) CALL FSEEND('FILE') LC MC QUIT AND PITCH CHANGES NC O IF (IERROR .EQ. -2) CALL FSEEND('QUIT') P*ENDIF EDIT Q*IF -EDIT R CALL WRTIO(' EDITOR not installed') S*ENDIF -EDITT RETURNU END "PDEFIN 3/22/82( PDELET 3/22/821PEDIT 3/22/825PIDENT 3/22/82<PINSRT 3/22/82BPMOVE 3/22/82FPPURGE 3/22/82MPRENAM 5/03/82U FSEDWN 12/14/84d SUBROUTINE FSEDWN(LINE,NLINES,MSGLIN,IERROR)  SUBROUTINE FSEDWN(LINE,NLINES,MOVED,MSGLIN,IERROR)C C FULL SCREEN EDIT MOVE DOWN NLINESC  CHARACTER MSGLIN*(*) d INTEGER LINE, NLINES, IERROR  INTEGER LINE, NLINES, MOVED, IERROR *IF EDITC  *CALL PARAMA *CALL EDITCO *CALL DECI  C IERROR = 0  IF (LINE .EQ. NRECI) THEN  MSGLIN = 'Bottom of deck reached'  MOVED = 0  IERROR = 2  RETURN  ENDIF  DO 20 I = 1,NLINES 10 LINE = N(LINE)  IF (LINE .EQ. NRECI) THEN  MSGLIN = 'Bottom of deck reached'  MOVED = I  IERROR = 2  RETURN  ENDIF  IF (IR(LINE) .LE. 0) GO TO 10  IF (LINE .GT. NRECI) GO TO 20  IF (IDEC(IR(LINE)+3) .GT. 0) GO TO 10 20 CONTINUE  MOVED = NLINES*ENDIF EDIT  RETURN END C IC FILE CHANGES JC K IF (IERROR .EQ. -1) CALL FSEEND('FILE') LC MC QUIT AND PITCH CHANGES NC O IF (IERROR .EQ. -2) CALL FSEEND('QUIT') P*ENDIF EDIT Q*IF -EDIT R CALL WRTIO(' EDITOR not installed'FSEEND 12/14/84  SUBROUTINE FSEEND(FSTAT) C C FULL SCREEN EDITOR TERMINATION C  CHARACTER*(*) FSTAT *IF EDITC *CALL PARAMA *CALL FSECOM *CALL NPSARG *CALL LOGU  C CHARACTER CMND*10  INTEGER IQUERY, CURCOLC C IF FMODE EQ 'FILE' SAVE CHANGES C  IF (FSTAT .EQ. 'FILE') THEN m CALL EDIEND(' ')  CALL EDIEND p CALL CLSFIL(LBO) p ELSE p CALL DELFIL(LBO) ENDIF C  CALL DELFIL(LBO) C C TERMINATE FULL SCREEN INTERFACE IF INITIALIZED C d IF (FSINIT) CALL FSCREN(2,1,1,1,CURROW,CURCOL,IQUERY,CMND, IF (FSINIT) CALL FSCREN(2,0,0,0,0,0,0,' ',' ', $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) *ENDIF EDIT  RETURN END  MOVED = NLINESFSEGET 12/14/84 SUBROUTINE FSEGET(LINE,DATA,MSGLIN,IERROR)C C FULL SCREEN EDITOR I/O ROUTINE C  CHARACTER DATA*(*), MSGLIN*(*)  INTEGER LINE, IERROR *IF EDITC  *CALL PARAMA *CALL EDITCO *CALL DECA  C DIMENSION IRD(5) C C PROCESS DATA REQUEST C  IERROR = 0 10 CONTINUE  IF (LINE .LT. 0) THEN  DATA = ' '  ELSE IF (LINE .EQ. 0) THEN  DATA = '* * * TOP OF DECK * * *'  IERROR = 1  ELSE IF (LINE .EQ. NRECI) THEN  DATA = '* * * BOTTOM OF DECK * * *'  IERROR = 2  ELSE C C DATA REQUEST IS WITHIN SCOPE OF DECK C  ITEMP = IR(LINE) IF (LINE .LT. NRECI) THEN !C --- OLD RECORD --- " CALL EXIN(ITEMP,IRD,5)# IF (IRD(4) .GT. 0) THEN $C --- LINE DELETED --- % LINE = N(LINE) & GO TO 10 ' ENDIF ( IRLOC = ITEMP + IRD(5)) NRCHAR = (IRD(1)-5-IRD(5))*NCHRWD * CALL MOVCHR(DATA,ADEC(IRLOC),NRCHAR) + ELSE ,C --- NEW RECORD --- - CALL EXIN(ITEMP,IRC,1) . IRLOC = ITEMP / NRCHAR = IRC*NCHRWD 0 CALL MOVCHR(DATA,ADEC(IRLOC),NRCHAR) 1 ENDIF 2 ENDIF 3*ENDIF EDIT 4 RETURN5 END IF (ISL(1).GE.MINCHR(ICMND) .AND. 3 $ CMNDS(ICMND)(1:ISL(1)).EQ.CMND(1:ISL(1))) GO TO 80 470 CONTINUE 5 ICMND = 0 680 CONTINUE 7FSEHEL 12/14/849  SUBROUTINE FSEHEL(EMODE) C C FULL SCREEN EDIT HELP ROUTINEC  CHARACTER*(*) EMODE *IF EDITC *CALL PARAMA *CALL FSECOM *CALL NPSARG C INTEGER CURR, CURCOL  C d CHARACTER HELP(MAXSLN)*80  CHARACTER HELP(MAXSLN)*79 C 10 HELP(1) = ' Help Screen'  HELP(2) = ' ' d HELP(3) = ' Available commands are:'  HELP(3) = ' Frequently used commands are:' 20 HELP(4) = ' '  HELP(5) = ' Add n - add n lines to deck' HELP(6) = ' Backward n - move towards top of deck n screens' d HELP(7) = ' BOTtom - move to "Bottom" of deck' d HELP(8) = ' Change /a/x/- change string a to string x'd HELP(9) = ' Down n - move towards bottom of deck n lines'd HELP(10)= ' DELete n - delete n lines starting at current line'd HELP(11)= ' FILE - file changes' d HELP(12)= ' Forward n - move towards bottom of deck n screens' d HELP(13)= ' Help - general information about FSEDIT' d HELP(14)= ' Insert a - insert string a after current line' d HELP(15)= ' Locate /a/ - locate string a'd HELP(16)= ' Quit - exit editor without changing deck'  d HELP(17)= ' Set - set editor options' !d HELP(18)= ' TOP - move to "TOP" of deck' "d HELP(19)= ' Type n - display n lines when in line edit mode' #d HELP(20)= ' Up n - move towards top of deck n lines' $d HELP(21)= ' ' %d HELP(22)= ' Enter command on command line for more info'&d HELP(23)= ' (Use quit to return to editor)' 'd LLINE = 24 (d30 DO 40 I = LLINE,NROW )d40 HELP(I) = ' '  HELP(7) = ' Change /a/x/- change string a to string x' HELP(8) = ' Down n - move towards bottom of deck n lines' HELP(9) = ' DELete n - delete n lines starting at current line' HELP(10)= ' FILE - file changes'  HELP(11)= ' Forward n - move towards bottom of deck n screens'  HELP(12)= ' Help - general information about FSEDIT'  HELP(13)= ' Locate /a/ - locate string a' HELP(14)= ' Quit - exit editor without changing deck'  HELP(15)= ' Up n - move towards top of deck n lines' HELP(16)= ' '  HELP(17)= ' Other commands that are available are:'  HELP(18)= ' Insert Set Type TOP BOTtom'  HELP(19)= ' '  HELP(20)= ' Enter command on command line for more info' HELP(21)= ' (Use quit to return to editor)'  LLINE = 22 *d50 CURR = 0 30 CURR = 0 + CURCOL = 0, IF (EMODE .EQ. 'FSEDIT') THEN -d CALL FSCREN(0,NROW,NCOL,1,CURR,CURCOL,IQUERY,HELP,  CALL FSCREN(6,0,0,0,0,0,0,' ',' ',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) CALL FSCREN(6,1,1,1,79,1,IQUERY,HELP(1),'HEADER', . $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)/d IF (QREM) WRITE(6,*) REMARK  CALL FSCREN(6,2,2,1,79,1,IQUERY,HELP(2),'COMMAND',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  DO 40 I = 3,LLINE-1 40 CALL FSCREN(6,I,I,1,79,1,IQUERY,HELP(I),'DEFAULT',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  II = 0  JJ = 0  CALL FSCREN(0,0,II,JJ,0,0,IQUERY,' ',' ',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) CALL FSCREN(7,2,2,1,79,1,J,HELP(2),'COMMAND', ! $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)0 ELSE 1 CALL WRTIO('1 ') 2 DO 55 I = 3,LLINE-1 355 CALL WRTIO(' '//HELP(I)(1:ITRAIL(HELP(I))))4 CALL RDTIO('H?',HELP(2),.FALSE.)5 ENDIF 6* 7* SCAN COMMAND LINE FOR ADDITION HELP INFORMATION REQUEST 8* 9 HELP(3) = ' Available commands are:' : IF (HELP(2) .EQ. ' ') GO TO 20; CALL FSECMD(HELP(2),ICMND,ICHAR) < IF (ICMND .EQ. 0) THEN= HELP(3) = ' COMMAND NOT UNDERSTOOD' > GO TO 20? ENDIF @* FORWARD BACKWARD UP DOWN ADD DELETE LOCATE CHANGEA GO TO ( 70, 80, 90, 100, 110, 120, 130, 140,B* FILE QUIT QQUIT HELP TOP BOTTOM SET INSERT C $ 150, 1000, 1000, 160, 170, 180, 190, 200, Dd* TYPEEd $ 210 ),ABS(ICMND)"* TYPE NAME COPY MOVE : .# $ 210, 220, 230, 240, 250, 260 ),ABS(ICMND) F HELP(3) = ' ERROR AT COMPUTED GOTO' Gd GO TO 50 $ GO TO 30 H* I60 HELP(2) = ' ' J HELP(3) = ' Additional HELP Screen not available at this time' K LLINE = 4 L GO TO 30 M* N70 HELP(2) = ' ' O HELP(3) = ' Forward command:' P HELP(4) = ' ' Q HELP(5) = ' Format is: Forward Shortest form: F'R HELP(6) = ' Default: 1' S HELP(7) = ' ' T HELP(8) = ' Use to scroll towards the bottom of the deck a' U HELP(9) = ' specified number of screens.' V HELP(10)= ' ' W HELP(11)= ' where:'X HELP(12)= ' n is the number of screen displays you wish' Y HELP(13)= ' to scroll forward. If "n" is omitted, the' Z HELP(14)= ' screen is scrolled forward one display.'[ HELP(15)= ' Initially the "forward" command is assigned'\ HELP(16)= ' to button key "8".' ] LLINE = 17 ^ GO TO 30 _* `80 HELP(2) = ' ' a HELP(3) = ' Backward command:' b HELP(4) = ' ' c HELP(5) = ' Format is: Backward Shortest form: B'd HELP(6) = ' Default: 1' e HELP(7) = ' ' f HELP(8) = ' Use to scroll towards the top of the deck a specified'g HELP(9) = ' number of screens.' h HELP(10)= ' ' i HELP(11)= ' where:'j HELP(12)= ' n is the number of screen displays you wish' k HELP(13)= ' to scroll Backward. If "n" is omitted, the'l HELP(14)= ' screen is scrolled backward one display.' m HELP(15)= ' Initially the "backward" command is'n HELP(16)= ' assigned to button key "7".' o LLINE = 17 p GO TO 30 q* r90 HELP(2) = ' ' s HELP(3) = ' Up command:' t HELP(4) = ' ' u HELP(5) = ' Format is: Up Shortest form: U'v HELP(6) = ' Default: 1' w HELP(7) = ' ' x HELP(8) = ' Use to scroll towards the top of the deck a specified'y HELP(9) = ' number of lines.' z HELP(10)= ' ' { HELP(11)= ' where:'| HELP(12)= ' n is the number of screen lines you wish to' } HELP(13)= ' scroll up. If "n" is omitted, the screen is'~ HELP(14)= ' scrolled towards the top one line.'  LLINE = 15 GO TO 30 * 100 HELP(2) = ' ' HELP(3) = ' Down command:' HELP(4) = ' '  HELP(5) = ' Format is: Down Shortest form: D'  HELP(6) = ' Default: 1' HELP(7) = ' '  HELP(8) = ' Use to scroll towards the bottom of the deck a'  HELP(9) = ' specified number of lines.' HELP(10)= ' ' HELP(11)= ' where:' HELP(12)= ' n is the number of screen lines you wish to'  HELP(13)= ' scroll down. If "n" is omitted, the screen'  HELP(14)= ' is scrolled towards the bottom one line.' LLINE = 15 GO TO 30 * 110 HELP(2) = ' ' HELP(3) = ' Add command:' HELP(4) = ' '  HELP(5) = ' Format is: Add Shortest form: A'  HELP(6) = ' Default: 1' HELP(7) = ' '  HELP(8) = ' Use to add a blank line after the current line at the' HELP(9) = ' top of the screen.' HELP(10)= ' ' HELP(11)= ' where:' HELP(12)= ' n is the number of blank lines you wish to'  HELP(13)= ' add. If "n" is omitted, one blank line is'  HELP(14)= ' after the current line.' LLINE = 15 GO TO 30 * 120 HELP(2) = ' '  HELP(3) = ' Delete command:' HELP(4) = ' '  HELP(5) = ' Format is: DELete Shortest form: DEL'  HELP(6) = ' Default: 1' HELP(7) = ' '  HELP(8) = ' Use to delete the current line and a specified number' HELP(9) = ' from the top of the screen.' HELP(10)= ' ' HELP(11)= ' where:' HELP(12)= ' n is the number of lines you wish to delete.'  HELP(13)= ' If "n" is omitted, the current line is'  HELP(14)= ' deleted from the screen.' LLINE = 15 GO TO 30 * 130 HELP(2) = ' '  HELP(3) = ' Locate command:' HELP(4) = ' '  HELP(5) = ' Format is: Locate <-+>/aaaa/ Shortest form: L' HELP(6) = ' Default: none' HELP(7) = ' '  HELP(8) = ' Use to locate the specified character string in the'  HELP(9) = ' deck, starting with the line after the current line.' HELP(10)= ' ' HELP(11)= ' where:' HELP(12)= ' aaaa is the character string you wish to locate.' HELP(13)= ' - Search towards the top of the deck.' HELP(14)= ' + Search towards the bottom of the deck.'  HELP(15)= ' / delimiting character, can be any character'  HELP(16)= ' not contained within the string "aaaa".' HELP(17)= ' If "/" is used, no need to specify "LOCATE"' HELP(18)= ' '  HELP(19)= ' Example: LOC -*FIND THIS STRING IN THE DECK *' LLINE = 20 GO TO 30 * 140 HELP(2) = ' '  HELP(3) = ' Change command:' HELP(4) = ' '  HELP(5) = ' Format is: Change <-+>/aaaa/bbbb/'  HELP(6) = ' short form: C'  HELP(7) = ' Default: none' HELP(8) = ' '  HELP(9) = ' Use to change the specified character string in the'  HELP(10)= ' deck to another string, starting with the current' HELP(11)= ' line.' HELP(12)= ' ' HELP(13)= ' where:' HELP(14)= ' aaaa is the character string you wish to locate.' HELP(15)= ' bbbb replacment character string.'  HELP(16)= ' - Search towards the top of the deck.' HELP(17)= ' + Search towards the bottom of the deck.'  HELP(18)= ' / delimiting character, can be any character'  HELP(19)= ' not contained within the string "aaaa" or'  HELP(20)= ' string "bbbb".' HELP(21)= ' '  HELP(22)= ' Example: C -/SUBROUTINE/FUNCTION/' LLINE = 23 GO TO 30 * 150 HELP(2) = ' ' HELP(3) = ' File command:' HELP(4) = ' '  HELP(5) = ' Format is: FILE Shortest form: FILE'  HELP(6) = ' Default: none' HELP(7) = ' '  HELP(8) = ' Use to store the changes made during this editing' HELP(9) = ' sesson to the appropriate disk files.' LLINE = 10 GO TO 30 * 160 HELP(2) = ' '  HELP(3) = ' FSEDIT is a full screen editor which displays a deck' HELP(4) = 'to the screen for modification. The editor is' HELP(5) = 'designed to work in an overstrike mode, that is any'  HELP(6) = 'changes in the screen are reflected in the deck.' HELP(7) = ' '  HELP(8) = ' The editor screen has five different lines or areas'  HELP(9) = 'controlling the actions of the editor:' HELP(10)= ' Heading line - display status of the editor.'  HELP(11)= ' Command line - line used to enter editor commands.' HELP(12)= ' Message line - displays errors or a column ruler.'  HELP(13)= ' Data lines - lines used to display file.' HELP(14)= ' first line of display is called the' HELP(15)= ' current line.'  HELP(16)= ' Prefix column- first two columns of the data line,' HELP(17)= ' they can be used to add (a), delete' HELP(18)= ' (d), copy ("), block move (mm),' HELP(19)= ' block copy (cc) or make that data'  HELP(20)= ' the current line (/) on the next'  HELP(21)= ' display. This column can be turned' HELP(22)= ' off using the "set prefix" command.' LLINE = 23  GO TO 30 * 170 HELP(2) = ' '  HELP(3) = ' Top command:'  HELP(4) = ' '  HELP(5) = ' Format is: TOP Shortest form: TOP'  HELP(6) = ' Default: none'  HELP(7) = ' '  HELP(8) = ' Use to display the "top of deck". Top is the initial'  HELP(9) = ' setting for button key "11".'  LLINE = 10  GO TO 30  * 180 HELP(2) = ' '  HELP(3) = ' Bottom command:'  HELP(4) = ' '  HELP(5) = ' Format is: BOTtom Shortest form: BOT'  HELP(6) = ' Default: none'  HELP(7) = ' '  HELP(8) = ' Use to display the "bottom of deck". Bottom is the'  HELP(9) = ' initial setting for button key "12".'  LLINE = 10  GO TO 30 * 190 HELP(2) = ' '  HELP(3) = ' Set command:'  HELP(4) = ' '  HELP(5) = ' Format is: Set Button n aaaa Shortest form: S' HELP(6) = ' Case U/M'  HELP(7) = ' CMdline TOP/BOT' HELP(8) = ' Prefix ON/OFF'  HELP(9) = ' View n'   HELP(10)= ' Zone first last'! HELP(11)= ' Default: none' " HELP(12)= ' ' # HELP(13)= ' Use to change the editor configuration:' $ HELP(14)= ' Button n aaaa -set button key "n" to string "aaaa".'% HELP(15)= ' Case U/M -set Upper or Mixed character set.' & HELP(16)= ' CMdline TOP/BOT-place command line at top or bottom.'' HELP(17)= ' Prefix ON/OFF -set Prefix column checking on or off'( HELP(18)= ' View n -View data starting in column "n".' ) HELP(19)= ' Zone first last-limit "Locate" search to columns'* HELP(20)= ' "first" thru "last".' + LLINE = 21 , GO TO 30 -* .200 HELP(2) = ' ' / HELP(3) = ' Insert command:' 0 HELP(4) = ' ' 1 HELP(5) = ' Format is: Insert Shortest form: I'2 HELP(6) = ' Default: blanks' 3 HELP(7) = ' ' 4 HELP(8) = ' Use to insert a character string after the current' 5d HELP(9) = ' line at the top of the screen.' 6d HELP(10)= ' ' 7d HELP(11)= ' where:'8d HELP(12)= ' aaaa is the character string to be inserted.'9d HELP(13)= ' The string begins with one blank character' :d HELP(14)= ' after the Insert command.' ;d LLINE = 15% HELP(9) = ' line at the top of the screen. The inserted line'& HELP(10)= ' becomes the new current line.' ' HELP(11)= ' ' ( HELP(12)= ' where:') HELP(13)= ' aaaa is the character string to be inserted.'* HELP(14)= ' The string begins with one blank character' + HELP(15)= ' after the Insert command.' , LLINE = 16 < GO TO 30 =* >210 HELP(2) = ' ' ? HELP(3) = ' Type command:' @ HELP(4) = ' ' A HELP(5) = ' Format is: Type Shortest form: T'B HELP(6) = ' Default: 1' C HELP(7) = ' ' D HELP(8) = ' Use to display n records from the deck at the'E HELP(9) = ' terminal when in the line editing display mode.' F HELP(10)= ' ' G HELP(11)= ' where:'H HELP(12)= ' n is the number of line to be displayed' I HELP(13)= ' starting with the current line.' J LLINE = 14 K GO TO 30 -* .220 HELP(2) = ' ' / HELP(3) = ' Name command:' 0 HELP(4) = ' ' 1 HELP(5) = ' Format is: NAMe aaaaaaaa Shortest form: NAM' 2 HELP(6) = ' Default: none' 3 HELP(7) = ' ' 4 HELP(8) = ' Use to assign a logical name or tag to the current' 5 HELP(9) = ' line. If the name is already defined, it is moved' 6 HELP(10)= ' to the current line. If the current line is already' 7 HELP(11)= ' named, the old name is dropped.' 8 HELP(12)= ' ' 9 HELP(13)= ' where:': HELP(14)= ' aaaaaaaa is the character string to be assigned to' ; HELP(15)= ' the current line. Maximum name length is' < HELP(16)= ' 8 and the maximum number of names is' = HELP(17)= ' currently set to 50.' > LLINE = 18 ? GO TO 30 @* A230 HELP(2) = ' ' B HELP(3) = ' Copy command:' C HELP(4) = ' ' D HELP(5) = ' Format is: COPy a target Shortest form: COP' E HELP(6) = ' Default: none' F HELP(7) = ' ' G HELP(8) = ' Use to copy a single line or a block of lines from' H HELP(9) = ' one place to another. The parameters for this' I HELP(10)= ' command are tags set by the NAME command.' J HELP(11)= ' ' K HELP(12)= ' where:'L HELP(13)= ' a is a named line which indicates where the' M HELP(14)= ' COPY will begin copying from.' N HELP(15)= ' b is a named line which indicates the last' O HELP(16)= ' to be copied. The order of "a" and "b" is' P HELP(17)= ' NOT significant. "b" is optional, if not' Q HELP(18)= ' specified a single line copy is assumed.' R HELP(19)= ' target is a named line which indicates the line' S HELP(20)= ' where the copied lines will be placed after' T LLINE = 21 U GO TO 30 V* W240 HELP(2) = ' ' X HELP(3) = ' Move command:' Y HELP(4) = ' ' Z HELP(5) = ' Format is: MOVe a target Shortest form: MOV' [ HELP(6) = ' Default: none' \ HELP(7) = ' ' ] HELP(8) = ' Use to move a single line or a block of lines from' ^ HELP(9) = ' one place to another. The parameters for this' _ HELP(10)= ' command are tags set by the NAME command.' ` HELP(11)= ' ' a HELP(12)= ' where:'b HELP(13)= ' a is a named line which indicates where the' c HELP(14)= ' MOVE will begin copying from.' d HELP(15)= ' b is a named line which indicates the last' e HELP(16)= ' to be moved. The order of "a" and "b" is' f HELP(17)= ' NOT significant. "b" is optional, if not' g HELP(18)= ' specified a single line move is assumed.' h HELP(19)= ' target is a named line which indicates the line' i HELP(20)= ' where the moved lines will be placed after.' j LLINE = 21 k GO TO 30 l* m250 HELP(2) = ' ' n HELP(3) = ' ":" command:' o HELP(4) = ' ' p HELP(5) = ' Format is: :n' q HELP(6) = ' Default: none' r HELP(7) = ' ' s HELP(8) = ' Use to position the display to the specified line.' t HELP(9) = ' ' u HELP(10)= ' where:'v HELP(11)= ' n is the line number to move to.' w LLINE = 12 x GO TO 30 y* z260 HELP(2) = ' ' { HELP(3) = ' "." command:' | HELP(4) = ' ' } HELP(5) = ' Format is: .aaaa' ~ HELP(6) = ' Default: none'  HELP(7) = ' '  HELP(8) = ' Use to position the display to the specified named' HELP(9) = ' line.' HELP(10)= ' ' HELP(11)= ' where:' HELP(12)= ' aaaa is the tag defined by the NAME command.' LLINE = 13 GO TO 30 L* M1000 CONTINUE  CALL FSCREN(6,0,0,0,0,0,IQUERY,' ',' ',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)N*ENDIF EDIT O RETURNP END FSEIPL 12/14/84   SUBROUTINE FSEIPL(EMODE) C C FULL SCREEN EDITOR INITIALIZATIONC  CHARACTER EMODE*(*) C *IF EDITC  *CALL PARAMA *CALL EDITCO *CALL EDIOPTS  *CALL FSECOM*CALL LANGC  *CALL NPSARG*CALL WIDTH C C INITIALIZE EDITOR AND FORMAT SCREEN C  FSINIT = .FALSE. d CURROW = 0 IF (EMODE .EQ. 'FSEDIT') THEN d CALL FSCREN(1,1,1,1,CURROW,CURCOL,IQUERY,MSGLIN,c CALL FSCREN(1,0,0,0,0,0,0,' ',' ',  CALL FSCREN(1,0,NROW,NCOL,0,0,0,' ',' ', $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  IF (QREADY) THEN IF (QREM) WRITE(6,*) REMARK  FSINIT = .TRUE.  ELSE  EMODE = 'LEDIT'  CALL WRTIO(' Full screen terminal interface not available.')  CALL WRTIO(' Line edit mode will be used.')  ENDIF  ENDIF  C !C INITIALIZE FULL SCREEN TERMINAL INTERFACE"C # IF (FSINIT) THEN $ CURCOL = 0 %d CALL FSCREN(3,1,1,1,CURROW,CURCOL,NROW,MSGLIN,  CALL FSCREN(3,0,NROW,NCOL,0,0,0,' ',' ',& $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) ' IF (QREM) WRITE(6,*) REMARK (d CALL FSCREN(4,1,1,1,CURROW,CURCOL,NCOL,MSGLIN, )d $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) *d IF (QREM) WRITE(6,*) REMARK  CALL FSCREN(5,MAXFRM,0,0,0,0,0,FORMS,' ',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  IF (QREM) WRITE(6,*) REMARK + NROW = MIN(NROW,MAXSLN) , NRHEAD = 1 - NRCMND = 2 . NRMSG = 3 / NRFLIN = 4 0 NRLLIN = NROW 1 LPREFX = .TRUE. 2 REFORM = .TRUE.  LANGFM = 'DEFAULT'  IF (LANG .EQ. 1) LANGFM = 'FORTRAN'  IF (LANG .EQ. 2) LANGFM = 'COBOL' 3 ELSE 4 NROW = 1 5 NCOL = MWIDE6 ENDIF CURROW = 0 CURNUM = 0 7 CURLIN = 0 8 VIEW = 1 9 FZONE = 1 : LZONE = MWIDE ;d BUTTON(1) = 'HELP'<d BUTTON(2) = 'SET VIEW 1' =d BUTTON(3) = 'QUIT'>d BUTTON(4) = 'SET CASE M' ?d BUTTON(5) = 'SET CASE U' @d BUTTON(6) = '?' Ad BUTTON(7) = 'BACKWARD' Bd BUTTON(8) = 'FORWARD' Cd BUTTON(9) = ' ' Dd BUTTON(10)= '=' Ed BUTTON(11)= 'TOP' Fd BUTTON(12)= 'BOTTOM' G*ENDIF EDIT H RETURNIC The following is SUBROUTINE FSCREN to be inserted JC if the FSEDIT swith is not set - otherwise you only get KC these comments L*IF -FSEDIT M END N SUBROUTINE FSCREN Od $ (ICODE,NROWS,NCOLS,FCOL,CURROW,CURCOL, Pd $ IQUERY,DATA,  $ (ICODE,IRECRD,ROW,COLUMN,LENGTH,VIEW, $ IQUERY,DATA,FORM, Q $ NDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) RC SC this is a dummy routine to set the QREADY switch to tell TC the program that the FULL SCREEN EDITOR is not implemented UC VC THIS IS AT THE END OF DECK FSEIPL and is onlyWC available if the FSEDIT switch is NOT turned on.X*-----------------------------------------------------------------------Y* ARGUMENTS Z*-----------------------------------------------------------------------[* \d CHARACTER DATA*(*), REMARK*(*) CHARACTER DATA*(*), FORM*(*), REMARK*(*) ] ^d INTEGER ICODE, NROWS, NCOLS, FCOL, CURROW, CURCOL, IQUERY  INTEGER ICODE, IRECRD, ROW, COLUMN, LENGTH, VIEW, IQUERY _ INTEGER LERROR, LEVEL, LUN, NDIM, NERROR ` a LOGICAL QERROR, QREADY, QREM, QUPPER b* cd DIMENSION LERROR(NDIM), DATA(NROWS)  DIMENSION LERROR(NDIM)d* e QREADY = .FALSE.fC g RETURN h*ENDIF -IFEDIT i END FSELOC 12/14/84d SUBROUTINE FSELOC(LINE,DIRECT,SKIP,WRAP,DATA,MSGLIN,IERROR)  SUBROUTINE FSELOC(LINE,LINNUM,DIRECT,SKIP,WRAP,DATA,MSGLIN,IERROR)C C FULL SCREEN EDITOR STRING LOCATION ROUTINE C  CHARACTER DATA*(*), MSGLIN*(*)d INTEGER LINE, DIRECT, IERROR  INTEGER LINE, LINNUM, DIRECT, IERROR  LOGICAL SKIP, WRAP*IF EDIT C  *CALL PARAMA *CALL EDITCO *CALL EDIOPTS *CALL FSECOM C  CHARACTER COMDAT*(MAXWID) d INTEGER TLINE  INTEGER TLINE, TNUM C  TLINE = LINE  IF (.NOT.SKIP) GO TO 20 10 IF (DIRECT .GE. 0) THEN d CALL FSEDWN(TLINE,1,MSGLIN,IERROR)  CALL FSEDWN(TLINE,1,J,MSGLIN,IERROR)  TNUM = TNUM + J  ELSE d CALL FSEUP (TLINE,1,MSGLIN,IERROR)  CALL FSEUP (TLINE,1,J,MSGLIN,IERROR)  TNUM = TNUM - J  ENDIF 15 IF (TLINE .EQ. LINE) THEN  MSGLIN = 'STRING /'//DATA//'/ NOT FOUND'  IERROR = 8  RETURN  ENDIF 20 CALL FSEGET(TLINE,COMDAT,MSGLIN,IERROR)  IF (DIRECT .GE. 0) THEN  IF (IERROR .EQ. 2) THEN IF (WRAP) THEN ! MSGLIN = 'WRAPPED' " IERROR = 3 # TLINE = 0 TNUM = 0 $ GO TO 15 % ELSE & MSGLIN = 'STRING /'//DATA//'/ NOT FOUND' ' IERROR = 8 ( RETURN ) ENDIF * ENDIF + ELSE , IF (IERROR .EQ. 1) THEN - IF (WRAP) THEN . MSGLIN = 'WRAPPED' / IERROR = 3 0 TLINE = NRECI TNUM = RCOUNT + 1 1 GO TO 15 2 ELSE 3 MSGLIN = 'STRING /'//DATA//'/ NOT FOUND' 4 IERROR = 8 5 RETURN 6 ENDIF 7 ENDIF 8 ENDIF 9 : IF (INDEX(COMDAT(FZONE:LZONE),DATA) .EQ. 0) GO TO 10 ; IERROR = 0 < LINE = TLINE LINNUM = TNUM =*ENDIF EDIT > RETURN? END  CALL WRTIO(' Line edit mode will be used.')  ENDIF  ENDIF  C !C IFSESCN 12/14/845 SUBROUTINE FSESCN(CMND,MSGLIN,IQUERY) C C FULL SCREEN DISPLAY INTERFACEC  CHARACTER*(*) CMND, MSGLIN  INTEGER IQUERY*IF EDITC  *CALL PARAMA *CALL EDITCO *CALL EDIOPTS  *CALL FSECOM *CALL NPSARG*CALL WIDTH C d CHARACTER*(MAXWID) LINE(MAXSLN), COMDAT, SCALEd CHARACTER PREFIX*2, CASE*1, MSG*80, TEMP*2 CHARACTER*(MAXWID) DATA, COMDAT, SCALE, LINE  CHARACTER PREFIX*2, CASE*1, MSG*80, TEMP*2, HEADER*79  INTEGER CURCOL, IERROR, TARGET, LINE1, LINE2, NLINES d INTEGER TOP, BOTTOM, TCOL  INTEGER TOP, BOTTOM, TVIEW LOGICAL MPEND, COPY, BLOCK, FSIPL C d CHARACTER*80 FORM1, FORM2, FORM3, FORM4  CHARACTER*8 FORMATC d DATA FORM1, FORM2, FORM3, FORM4/ d $ 'TYPE PROTECTED INTENSITY NORMAL HIGHLIGHT NORMAL COLOR WHITE',d $ 'TYPE OPEN INTENSITY NORMAL HIGHLIGHT NORMAL COLOR RED CURSOR',d $ 'TYPE PROTECTED INTENSITY NORMAL HIGHLIGHT NORMAL COLOR WHITE',d $ 'TYPE OPEN INTENSITY NORMAL HIGHLIGHT NORMAL COLOR GREEN'/ DATA SCALE/'!...+....1....+....2....+....3....+....4....+....5.... $+....6....+....7....+....8....+....9....+...10....+...11....+...12 $....+...13....+...14....+...15....+...16'/ DATA FSIPL/.TRUE./!C "C INITIALIZE FULL SCREEN TERMINAL INTERFACE#C $ IF (FSIPL) THEN % FSIPL = .FALSE. & MPEND = .FALSE. ' TARGET = -1 ( LINE1 = -1 ) LINE2 = -1 * ENDIF +C ,C FORMAT SCREEN-C . IF (REFORM) THEN / REFORM = .FALSE. 0d LINE(NRHEAD) = FORM1 1d LINE(NRCMND) = FORM2 2d LINE(NRMSG ) = FORM3 3d IF (LPREFX) THEN4d TCOL = MIN(NCOL,MWIDE+2) 5d ELSE 6d TCOL = MIN(NCOL,MWIDE) 7d ENDIF 8d DO 5 I = NRFLIN,NRLLIN 9d5 LINE(I) = FORM4 :d CALL FSCREN(5,NROW,TCOL,1,CURROW,CURCOL,IQUERY,LINE,;d $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)<d IF (QREM) WRITE(6,*) REMARK  CALL FSCREN(6,0,0,0,0,0,0,' ',' ',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  IF (LPREFX) THEN*IF IBM ICOL = 4  *ENDIF IBM  *IF -IBM ICOL = 3  *ENDIF -IBM  LENGTH = MIN(MWIDE-VIEW+1,NCOL-ICOL+1)  ELSE  ICOL = 1  LENGTH = MIN(MWIDE-VIEW+1,NCOL)  ENDIF = ENDIF >C ?C READ DATA INTO EDITOR LINE ARRAY, SET UP SCREEN AND DISPLAY @C Ad IQUERY = 0B IF (CURLIN .LT. 0) CURLIN = 0 C BOTTOM = 0 D ILINE = CURLINE IF (MPEND .AND. LPREFX) THEN Fd IF (LINE1 .LE. 0) THEN  IF (LINE1 .LT. 0) THEN G MSGLIN = 'move or copy pending' H ELSEIF (COPY) THEN I TEMP = 'cc' J IF (BLOCK) THEN K MSGLIN = 'block copy pending' L ELSE M MSGLIN = 'single line copy pending' N ENDIF O ELSE P TEMP = 'mm' Q IF (BLOCK) THEN R MSGLIN = 'block move pending' S ELSE T MSGLIN = 'single line move pending' U ENDIF V ENDIF W ENDIF C  CASE = 'M'  IF (UPCASE) CASE = 'U' WRITE(HEADER,10) EDECK, RCOUNT, CURNUM, CHANGE, CASE,  $ FZONE, LZONE 10 FORMAT('>',A,'< Count=',I4,' Line=',I4,' Alts=',I4, $ ' Case=',A,' Zone=',I3,I3)  DO 15 I = 1,NTAGS  IF (TAGLIN(I) .EQ. CURLIN) THEN  HEADER(68:) = 'Tag='//TAGNAM(I)  GO TO 16 ENDIF 15 CONTINUE !16 CALL FSCREN(6,1,NRHEAD,1,LEN(HEADER),1, " $ 0,HEADER,'HEADER', # $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) $C % CALL FSCREN(6,2,NRCMND,1,NCOL,1,0,CMND,'COMMAND', & $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) 'C  CALL FSCREN(6,3,NRMSG,1,6,1, $ 0,'>>>>>>','SCALE', $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) C ( IF (MSGLIN .EQ. ' ') THEN ) CALL FSCREN(6,3,NRMSG,ICOL,LENGTH,VIEW, * $ 0,SCALE(VIEW:),'SCALE',+ $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) , ELSE - CALL FSCREN(6,3,NRMSG,1,NCOL,1, . $ 0,MSGLIN,'SCALE', / $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) 0 ENDIF 1C 2 IRECRD = 3 X DO 30 I = NRFLIN,NRLLIN 3 IRECRD = IRECRD + 1 Y IF (BOTTOM .NE. 0) THEN Zd LINE(I) = ' ' 4 COMDAT = ' ' 5 IF (LPREFX) THEN6 CALL FSCREN(6,IRECRD,I,1,2,1,0,COMDAT,'HEADER', 7 $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) 8 IRECRD = IRECRD + 1 9 ENDIF : CALL FSCREN(6,IRECRD,I,ICOL,LENGTH,1,0,COMDAT,'HEADER', ; $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) [ ELSE \ CALL FSEGET(ILINE,COMDAT,MSG,IERROR) ]d IF (LPREFX) THEN^d IF (VIEW .GT. 1) THEN _d LINE(I) = COMDAT(1:VIEW-1)//'=='//COMDAT(VIEW:) `d ELSE ad LINE(I) = '=='//COMDAT bd ENDIF cd ELSE dd LINE(I) = COMDAT ed ENDIF fd IF (MPEND .AND. LPREFX) THENgd IF (TARGET .EQ. ILINE) THEN hd LINE(I)(VIEW:VIEW) = 'f' id TARGET = -1 jd ENDIF kd IF (LINE1 .EQ. ILINE) THEN ld IF (BLOCK) THEN md LINE(I)(VIEW:VIEW+1) = TEMP nd IF (LINE2 .LE. 0) BLOCK = .FALSE. od ELSE pd LINE(I)(VIEW:VIEW) = TEMP qd ENDIF rd LINE1 = -1 sd ENDIF td IF (LINE2 .EQ. ILINE) THEN ud IF (BLOCK) THEN vd LINE(I)(VIEW:VIEW+1) = TEMP wd IF (LINE1 .LE. 0) BLOCK = .FALSE. xd ELSE yd LINE(I)(VIEW:VIEW) = TEMP zd ENDIF {d LINE2 = -1 |d ENDIF }d IF (BLOCK) THEN ~d IF (TARGET.LE.0 .AND. LINE1.LE.0 .AND. LINE2.LE.0) d $ MPEND = .FALSE. d ELSE d IF (TARGET.LE.0 .AND. LINE1.LE.0) MPEND = .FALSE. d ENDIF < = FORMAT = LANGFM > IF (IERROR .EQ. 1) FORMAT = 'HEADER' ? IF (IERROR .EQ. 2) THEN @ BOTTOM = I A FORMAT = 'HEADER' B ENDIF C IF (LPREFX) THEN D PREFIX = '==' E IF (MPEND) THEN F IF (TARGET .EQ. ILINE) THEN G PREFIX(1:1) = 'f' H TARGET = -1 I ENDIF J IF (LINE1 .EQ. ILINE) THEN K IF (BLOCK) THEN L PREFIX = TEMP M IF (LINE2 .LT. 0) BLOCK = .FALSE. N ELSE O PREFIX(1:1) = TEMP P ENDIF Q LINE1 = -1 R ENDIF S IF (LINE2 .EQ. ILINE) THEN T IF (BLOCK) THEN U PREFIX = TEMP V IF (LINE1 .LT. 0) BLOCK = .FALSE. W ELSE X PREFIX(1:1) = TEMP Y ENDIF Z LINE2 = -1 [ ENDIF \ IF (BLOCK) THEN ] IF (TARGET.LT.0 .AND. LINE1.LT.0 .AND. LINE2.LT.0)^ $ MPEND = .FALSE. _ ELSE ` IF (TARGET.LT.0 .AND. LINE1.LT.0) MPEND = .FALSE. a ENDIF b ENDIF c CALL FSCREN(6,IRECRD,I,1,2,1,0,PREFIX,'PREFIX', d $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) e IRECRD = IRECRD + 1 ENDIF f TVIEW = VIEWg IF (FORMAT .EQ. 'HEADER') TVIEW = 1 h CALL FSCREN(6,IRECRD,I,ICOL,LENGTH,TVIEW, i $ 0,COMDAT(TVIEW:),FORMAT, j $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) IF (CURROW.LT.0 .AND. ABS(CURROW).EQ.ILINE) CURROW = I d IF (IERROR .EQ. 2) BOTTOM = I d CALL FSEDWN(ILINE,1,MSG,IERROR) k CALL FSEDWN(ILINE,1,J,MSG,IERROR)  ENDIF 30 CONTINUE d CASE = 'M' d IF (UPCASE) CASE = 'U'd WRITE(LINE(NRHEAD)(VIEW:),'(A,A,A,I5,A,I4,A,A,A,I3,I3)') d $ 'DECK >',EDECK,'< RECORDS=',RCOUNT, d $ ' ALTS=',CHANGE,' CASE=',CASE,' ZONE=',FZONE,LZONE d IF (MSGLIN .EQ. ' ') THEN d IF (LPREFX) THENd IF (VIEW .GT. 1) THEN d LINE(NRMSG) = SCALE(1:VIEW-1)//' '//SCALE(VIEW:) d ELSE d LINE(NRMSG) = ' '//SCALE(VIEW:) d ENDIF d ELSE d LINE(NRMSG) = SCALE d ENDIF d ELSE d LINE(NRMSG)(VIEW:) = MSGLIN d ENDIF d LINE(NRCMND)(VIEW:) = CMNDC d IF (CURROW .EQ. 0) THEN lC DISPLAY SCREEN mC n IF (CURROW .LE. 0) THEN CURCOL = 0  ELSE CURCOL = 1 d IF (LPREFX) CURCOL = 3 o IF (LPREFX .AND. CURROW.NE.NRCMND) CURCOL = ICOL ENDIF d CALL FSCREN(0,NROW,NCOL,VIEW,CURROW,CURCOL,IQUERY,LINE, p CALL FSCREN(0,0,CURROW,CURCOL,0,0,IQUERY,' ',' ',  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  IF (QREM) WRITE(6,*) REMARK MSGLIN = ' ' d CMND = LINE(NRCMND)(VIEW:)qC r CALL FSCREN(7,2,NRCMND,1,NCOL,0,J,CMND,'COMMAND', s $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) C C CHECK DATA LINES FOR PREFIX COMMANDS '/ " A D' C ILINE = CURLIN I = NRFLINd40 IF (ILINE .EQ. 0) GO TO 90d IF (BOTTOM.EQ.I) GO TO 105d CALL FSEGET(ILINE,COMDAT,MSG,IERROR) d IF (LPREFX) THEN d PREFIX = LINE(I)(VIEW:VIEW+1) d IF (VIEW .GT. 1) THEN d LINE(I) = LINE(I)(1:VIEW-1)//LINE(I)(VIEW+2:) d ELSE d LINE(I) = LINE(I)(VIEW+2:) d ENDIF d ENDIF d IF (COMDAT.NE.LINE(I)) THEN d CHANGE = CHANGE + 1 d IF (UPCASE) THENn CALL UCASE(LINE(I),COMDAT) n LINE(I) = COMDAT d CALL UCASE(LINE(I)) d COMDAT = LINE(I) d ENDIF t IRECRD = 4 u40 IF (LPREFX) THEN v CALL FSCREN(7,IRECRD,I,1,2,0,J,PREFIX,' ', w $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) x IRECRD = IRECRD + 1 y ENDIF z IF (ILINE .EQ. 0) GO TO 45 { IF (BOTTOM.EQ. I) GO TO 45| CALL FSCREN(7,IRECRD,I,ICOL,LENGTH,0,J,LINE,' ', } $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)~ CALL FSEGET(ILINE,COMDAT,MSG,IERROR)  IF (VIEW .GT. 1) THEN  IF (LENGTH .LT. MWIDE-VIEW+1) THEN  DATA = COMDAT(1:VIEW-1)//LINE(1:LENGTH)//COMDAT(VIEW+LENGTH:) ELSE  DATA = COMDAT(1:VIEW-1)//LINE ENDIF  ELSE  IF (LENGTH .LT. MWIDE-VIEW+1) THEN  DATA = LINE(1:LENGTH)//COMDAT(LENGTH+1:) ELSE DATA = LINE ENDIF  ENDIF IF (COMDAT.NE.DATA) THEN CHANGE = CHANGE + 1  IF (UPCASE) CALL UCASE(DATA) JLINE = ILINE d CALL FSEADD(ILINE,LINE(I),MSGLIN,IERROR) CALL FSEADD(ILINE,DATA,MSGLIN,IERROR)  CALL FSEDEL(ILINE,MSGLIN,IERROR) IF (JLINE .EQ. CURLIN) CURLIN = ILINE CURROW = -ILINE  ENDIF d IF (LPREFX) THEN 45 IF (LPREFX) THEN  IF (PREFIX.NE.'==' .AND. PREFIX.NE.' ') THEN IF (PREFIX(1:1) .EQ. '/') THENC --- MAKE THIS LINE THE CURRENT LINE ON NEXT DISPLAY --- CURLIN = ILINE CURROW = -ILINE  CURNUM = CURNUM + I - NRFLIN ELSE IF (PREFIX(1:1) .EQ. '"') THEN  IF (ILINE .EQ. 0) GO TO 90 C --- COPY THIS LINE AFTER THIS LINE --- NLINES = 1  IF (PREFIX(2:2) .NE. '=') NLINES = RVAL(PREFIX(2:2)) IF (NLINES .LE. 0) NLINES = 1 DO 50 J = 1,NLINES d CALL FSEADD(ILINE,LINE(I),MSGLIN,IERROR)d CALL FSEDWN(ILINE,1,MSGLIN,IERROR)  CALL FSEADD(ILINE,DATA,MSGLIN,IERROR)  CALL FSEDWN(ILINE,1,K,MSGLIN,IERROR) IF (CURROW .GT. 0) CURROW = -ILINE RCOUNT = RCOUNT + 1 50 CHANGE = CHANGE + 1 d CURROW = -ILINE  ELSE IF (PREFIX(1:1).EQ.'A' .OR. PREFIX(1:1).EQ.'a') THENC --- ADD A BLANK LINE AFTER THIS LINE ON NEXT DISPLAY --- NLINES = 1  IF (PREFIX(2:2) .NE. '=') NLINES = RVAL(PREFIX(2:2)) IF (NLINES .LE. 0) NLINES = 1 DO 60 J = 1,NLINES  CALL FSEADD(ILINE,' ',MSGLIN,IERROR)d CALL FSEDWN(ILINE,1,MSGLIN,IERROR)  CALL FSEDWN(ILINE,1,K,MSGLIN,IERROR) IF (CURROW .GT. 0) CURROW = -ILINE RCOUNT = RCOUNT + 1 60 CHANGE = CHANGE + 1 d CURROW = -ILINE  ELSE IF (PREFIX(1:1).EQ.'D' .OR. PREFIX(1:1).EQ.'d') THENC --- DELETE THIS LINE --- NLINES = 1  IF (PREFIX(2:2) .NE. '=') NLINES = RVAL(PREFIX(2:2)) IF (NLINES .LE. 0) NLINES = 1  IF (ILINE .EQ. 0) GO TO 90 DO 70 J = 1,NLINES  IF (BOTTOM .EQ. I) GO TO 105 JLINE = ILINE  CALL FSEDEL(ILINE,MSGLIN,IERROR) IF (IERROR .EQ. 2) GO TO 105 IF (JLINE .EQ. CURLIN) CURLIN = ILINE RCOUNT = RCOUNT - 1 CHANGE = CHANGE + 1 IRECRD = IRECRD + 1  IF (J .GT. 1) IRECRD = IRECRD + 1 70 I = I + 1 CURROW = -ILINE GO TO 100  ELSE IF (PREFIX(1:1).EQ.'F' .OR. PREFIX(1:1).EQ.'f') THENC --- MOVE OR COPY TARGET FOLLOWING THIS LINE --- TARGET = ILINE MPEND = .TRUE.  ELSE IF (PREFIX(1:1).EQ.'P' .OR. PREFIX(1:1).EQ.'p') THENC --- MOVE OR COPY TARGET PRECEEDING THIS LINE --- TARGET = ILINE d CALL FSEUP(TARGET,1,MSGLIN,IERROR)  CALL FSEUP(TARGET,1,J,MSGLIN,IERROR) MPEND = .TRUE.  ELSE IF (PREFIX(1:1).EQ.'M' .OR. PREFIX(1:1).EQ.'m') THENC --- SINGLE OR BLOCK MOVE --- IF (PREFIX(2:2).EQ.'M'.OR.PREFIX(2:2).EQ.'m')  $ BLOCK = .TRUE.  IF (LINE1 .LT. 0) THEN LINE1 = ILINE ELSE LINE2 = ILINE  ENDIF  COPY = .FALSE.  MPEND = .TRUE.  ELSE IF (PREFIX(1:1).EQ.'C' .OR. PREFIX(1:1).EQ.'c') THENC --- SINGLE OR BLOCK COPY --- IF (PREFIX(2:2).EQ.'C'.OR.PREFIX(2:2).EQ.'c')  $ BLOCK = .TRUE.  IF (LINE1 .LT. 0) THEN  LINE1 = ILINE  ELSE  LINE2 = ILINE  ENDIF  COPY = .TRUE.  MPEND = .TRUE.  ENDIF  ENDIF  ENDIF d90 CALL FSEDWN(ILINE,1,MSG,IERROR) 90 IF (BOTTOM .EQ. I) GO TO 105  CALL FSEDWN(ILINE,1,J,MSG,IERROR) IRECRD = IRECRD + 1  I = I + 1 100 IF (I .LE. NRLLIN) GO TO 40 C C IF MOVE OR COPY PENDING C 105 IF (MPEND) THEN  TOP = 0  BOTTOM = 0 d IF (LINE1 .LE. 0) GO TO 200 d IF (TARGET .LE. 0) GO TO 200d IF (BLOCK .AND. LINE2 .LE. 0) GO TO 200 d110 CALL FSEDWN(TOP,1,MSG,IERROR)  IF (LINE1 .LT. 0) GO TO 200  IF (TARGET .LT. 0) GO TO 200 IF (BLOCK .AND. LINE2 .LT. 0) GO TO 200 110 CALL FSEDWN(TOP,1,J,MSG,IERROR)  IF (TOP.EQ.LINE1) GO TO 120  IF (TOP.EQ.LINE2) GO TO 120  GO TO 110 !120 IF (.NOT.BLOCK) GO TO 150 " BOTTOM = TOP#d130 CALL FSEDWN(BOTTOM,1,MSG,IERROR)130 CALL FSEDWN(BOTTOM,1,J,MSG,IERROR) $ IF (BOTTOM.EQ.LINE1) GO TO 140 % IF (BOTTOM.EQ.LINE2) GO TO 140 & IF (BOTTOM .EQ. TARGET) THEN' MSGLIN = 'Target imbedded in block move/copy' ( GO TO 200 ) ENDIF * GO TO 130 +140 LINE2 = 0 ,150 CALL FSEGET(TOP,COMDAT,MSG,IERROR) - CALL FSEADD(TARGET,COMDAT,MSGLIN,IERROR). IF (IERROR .NE. 0) GO TO 200 / RCOUNT = RCOUNT + 1 0 CHANGE = CHANGE + 1 1 IF (BLOCK .AND. TOP.EQ.BOTTOM) LINE2 = -1 2 IF (COPY) THEN 3d CALL FSEDWN(TOP,1,MSG,IERROR)  CALL FSEDWN(TOP,1,J,MSG,IERROR) 4 ELSE JLINE = TOP 5 CALL FSEDEL(TOP,MSG,IERROR)  IF (JLINE .EQ. CURLIN) CURLIN = TOP 6 RCOUNT = RCOUNT - 1 7 ENDIF 8d CALL FSEDWN(TARGET,1,MSG,IERROR) CALL FSEDWN(TARGET,1,J,MSG,IERROR) 9 IF (BLOCK .AND. LINE2.EQ.0) GO TO 150 :160 MPEND = .FALSE. ; BLOCK = .FALSE. < COPY = .FALSE. = TARGET = -1 > LINE1 = -1 ? LINE2 = -1 @200 CONTINUEA ENDIF BC CC COMPLETED PROCESSING DISPLAY, RETURN TO PROCESS COMMAND LINE DC E*ENDIF EDIT F RETURNG END FSETRM 12/14/84 SUBROUTINE FSETRM(CMND,MSGLIN,IQUERY) C C LINE DISPLAY INTERFACE C  CHARACTER*(*) CMND, MSGLIN  INTEGER IQUERY*IF EDITC  *CALL PARAMA *CALL EDIOPTS  *CALL FSECOM C  CHARACTER*(MAXWID) COMDAT, SCALE  CHARACTER MSG*80  CHARACTER*3 MSGPAD, CURPAD  INTEGER IERROR, MAXCOLC  DATA SCALE/'!...+....1....+....2....+....3....+....4....+....5.... $+....6....+....7....+....8....+....9....+...10....+...11....+...12 $....+...13....+...14....+...15....+...16'/  DATA MSGPAD /' E>'/  DATA CURPAD /' C>'/ C C DISPLAY ANY ERROR MSGAGESC g IF (MSGLIN .NE. ' ') CALL WRTIO(MSGPAD//MSGLIN(1:ITRAIL(MSGLIN))) g MSGLIN = ' '  IF (MSGLIN .NE. ' ') THEN  MSG = MSGPAD//MSGLIN CALL WRTIO(MSG(1:ITRAIL(MSG)))  MSGLIN = ' ' ENDIF C C DISPLAY CURRENT LINE C  CALL FSEGET(CURLIN,COMDAT,MSG,IERROR)  MAXCOL = MAX(ITRAIL(COMDAT),VIEW) ! CALL WRTIO(CURPAD//COMDAT(VIEW:MAXCOL)) "C #C READ COMMAND FROM TERMINAL $C %10 CMND = ' '& CALL RDTIO('?',CMND,.FALSE.) ' IF (CMND .EQ. ' ') CMND = 'DOWN 1'( IF (CMND.EQ.'SCALE' .OR. CMND.EQ.'scale') THEN) CALL WRTIO(' '//SCALE(VIEW:NCOL)) * GO TO 10+ ENDIF ,C -C COMPLETED PROCESSING DISPLAY, RETURN TO PROCESS COMMAND LINE .C /*ENDIF EDIT 0 RETURN1 END B IF (.NOT.EX .AND. STATUS .EQ. 'OLD') THEN CFSEUP 12/14/84d SUBROUTINE FSEUP (LINE,NLINES,MSGLIN,IERROR)  SUBROUTINE FSEUP (LINE,NLINES,MOVED,MSGLIN,IERROR)C C FULL SCREEN EDIT MOVE UP NLINES C  CHARACTER MSGLIN*(*) d INTEGER LINE, NLINES, IERROR  INTEGER LINE, NLINES, MOVED, IERROR *IF EDITC  *CALL PARAMA *CALL EDITCO *CALL DECI  C IERROR = 0  IF (LINE .LE. 0) THEN  MSGLIN = 'top of deck reached'  MOVED = 0  IERROR = 1  RETURN  ENDIF  DO 20 I = 1,NLINES 10 LINE = L(LINE)  IF (LINE .LE. 0) THEN  MSGLIN = 'top of deck reached'  MOVED = I  IERROR = 1  RETURN  ENDIF  IF (IR(LINE) .LE. 0) GO TO 10  IF (LINE .GT. NRECI) GO TO 20  IF (IDEC(IR(LINE)+3) .GT. 0) GO TO 10 20 CONTINUE  MOVED = NLINES*ENDIF EDIT  RETURN END A IQUERY = 0B IF (CURLIN .LT. 0) CURLIN = 0 C BOTTOM = 0 D ILINE = CURLINE IF (MPEND .AND. LPREFX) THEN F IF (LINE1 .LE. 0) THEN G MSGLIN = 'move or copy pending' H ELSEIF (COPY) THEN I TEMP = 'cc' FSEXEC 12/14/846 SUBROUTINE FSEXEC(EMODE,CMND,MSGLIN,IERROR) C C FULL SCREEN EDITOR COMMAND PROCESSOR C  CHARACTER EMODE*(*), CMND*(*), MSGLIN*(*)  INTEGER IERROR*IF EDITC  *CALL PARAMA *CALL EDITCO *CALL EDIOPTS  *CALL FSECOM *CALL LOGU *CALL SCAN *CALL WIDTH C  CHARACTER*(MAXWID) COMDAT, BUFFER, TEMPLN  CHARACTER LSCAN*1, TEMP*10  CHARACTER*3 TPAD  CHARACTER*10 SETCMD(6) INTEGER LDIRCT, NLINES, MAXCOL d LOGICAL SKIP, WRAP INTEGER TARGET, TOP, BOTTOM, LINE1, LINE2  LOGICAL SKIP, WRAP, COPY, BLOCK C  DATA SETCMD / 'BUTTON', 'CASE', 'CMDLINE', 'VIEW', 'ZONE',  $ 'PREFIX' /  DATA TPAD /' T>'/ C C SCAN FOR VALID FSEDIT COMMANDC  IERROR = 0 d CURROW = 0 CALL FSECMD(CMND,ICMND) ! IF (ICMND .EQ. 0) THEN" MSGLIN = ' COMMAND NOT UNDERSTOOD' # IERROR = 28 $ RETURN % ENDIF &C FORWARD BACKWARD UP DOWN ADD DELETE LOCATE CHANGE' GO TO ( 1100, 1200, 1300, 1400, 1500, 1600, 1700, 1800,(C FILE QUIT QQUIT HELP TOP BOTTOM SET INSERT ) $ 1900, 2000, 2100, 2200, 2300, 2400, 2500, 2600, *dC TYPE+d $ 2700 ),ABS(ICMND)C TYPE NAME COPY MOVE : . $ 2700, 2800, 2900, 3000, 3100, 3200 ),ABS(ICMND) , MSGLIN = ' ERROR AT COMPUTED GOTO' - IERROR = 1000 . RETURN/C 0C FORWARD COMMAND 1C 21100 IF (EMODE .NE. 'FSEDIT') GO TO 1400 3 I = 1 4o IF (NWRD .GE. 2) I = RVAL(CMND(ISS(2):ISS(2)+ISL(2)-1))  IF (NWRD .GE. 2) I = RVAL(CMND(ISS(2):ISE(2))) 5 IF (I .LE. 0) I = 1 6 NLINES = (NROW-4)*I 7d CALL FSEDWN(CURLIN,NLINES,MSGLIN,IERROR)  CALL FSEDWN(CURLIN,NLINES,NLINES,MSGLIN,IERROR)  CURNUM = CURNUM + NLINES  CURROW = 08 RETURN9C :C BACKWARD COMMAND ;C <1200 IF (EMODE .NE. 'FSEDIT') GO TO 1300 = I = 1 >o IF (NWRD .GE. 2) I = RVAL(CMND(ISS(2):ISS(2)+ISL(2)-1))  IF (NWRD .GE. 2) I = RVAL(CMND(ISS(2):ISE(2))) ? IF (I .LE. 0) I = 1 @ NLINES = (NROW-4)*I Ad CALL FSEUP (CURLIN,NLINES,MSGLIN,IERROR)  CALL FSEUP (CURLIN,NLINES,NLINES,MSGLIN,IERROR) CURNUM = CURNUM - NLINES CURROW = 0B RETURNCC DC UP COMMAND EC F1300 NLINES = 1Go IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISS(2)+ISL(2)-1))  IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISE(2))) H IF (NLINES .LE. 0) NLINES = 1 Id CALL FSEUP (CURLIN,NLINES,MSGLIN,IERROR)  CALL FSEUP (CURLIN,NLINES,NLINES,MSGLIN,IERROR) CURNUM = CURNUM - NLINES CURROW = 0J RETURNKC LC DOWN COMMAND MC N1400 NLINES = 1Oo IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISS(2)+ISL(2)-1))  IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISE(2))) P IF (NLINES .LE. 0) NLINES = 1 Qd CALL FSEDWN(CURLIN,NLINES,MSGLIN,IERROR)  CALL FSEDWN(CURLIN,NLINES,NLINES,MSGLIN,IERROR)  CURNUM = CURNUM + NLINES  CURROW = 0R RETURNSC TC ADD COMMAND UC V1500 NLINES = 1Wo IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISS(2)+ISL(2)-1))  IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISE(2))) X IF (NLINES .LE. 0) NLINES = 1 Y DO 1510 I = 1,NLINES Z CALL FSEADD(CURLIN,' ',MSGLIN,IERROR) [ IF (IERROR .EQ. 0) THEN \ CHANGE = CHANGE + 1 ] RCOUNT = RCOUNT + 1 ^ ELSE _ RETURN ` ENDIF a1510 CONTINUE b RETURNcC dC DELETE COMMAND eC f1600 NLINES = 1go IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISS(2)+ISL(2)-1))  IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISE(2))) h IF (NLINES .LE. 0) NLINES = 1 i DO 1610 I = 1,NLINES j CALL FSEDEL(CURLIN,MSGLIN,IERROR) k IF (IERROR .EQ. 0) THEN l CHANGE = CHANGE + 1 m RCOUNT = RCOUNT - 1 n ELSE o RETURN p ENDIF q1610 CONTINUE r RETURNsC tC LOCATE COMMAND uC v1700 IF (ICMND.GT.0 .AND. NWRD.LT.2) THEN w MSGLIN = 'LOCATE STRING NOT FOUND - INVALID SPECIFICATION' x IERROR = 20 y RETURN z ENDIF { IFCHAR = ISS(2) | IF (ICMND .LT. 0) IFCHAR = ISS(1) } LSCAN = CMND(IFCHAR:IFCHAR) ~ IF (LSCAN .EQ. '-') THEN  LDIRCT = -1 IFCHAR = IFCHAR + 1  LSCAN = CMND(IFCHAR:IFCHAR)  ELSE IF (LSCAN .EQ. '+') THEN LDIRCT = +1 IFCHAR = IFCHAR + 1  LSCAN = CMND(IFCHAR:IFCHAR)  ELSE LDIRCT = +1  ENDIF IFCHAR = IFCHAR + 1  ILCHAR = INDEX(CMND(IFCHAR:),LSCAN) + IFCHAR - 2  IF (ILCHAR .EQ. IFCHAR-2) ILCHAR = ITRAIL(CMND) COMDAT = CMND n IF (UPCASE) CALL UCASE(CMND,COMDAT)  IF (UPCASE) CALL UCASE(COMDAT) SKIP = .TRUE. WRAP = .TRUE. d CALL FSELOC(CURLIN,LDIRCT,SKIP,WRAP,COMDAT(IFCHAR:ILCHAR),MSGLIN, d $ IERROR)  CALL FSELOC(CURLIN,CURNUM,LDIRCT,SKIP,WRAP,COMDAT(IFCHAR:ILCHAR),  $ MSGLIN,IERROR)  CURROW = 0 RETURNC C CHANGE COMMAND C 1800 IF (NWRD.LT.2) THEN  MSGLIN = 'LOCATE STRING NOT FOUND' IERROR = 20 RETURN  ENDIF IFCHAR = ISS(2)  IF (ICMND .LT. 0) IFCHAR = ISS(1)  LSCAN = CMND(IFCHAR:IFCHAR) IF (LSCAN .EQ. '-') THEN LDIRCT = -1 IFCHAR = IFCHAR + 1  LSCAN = CMND(IFCHAR:IFCHAR)  ELSE IF (LSCAN .EQ. '+') THEN LDIRCT = +1 IFCHAR = IFCHAR + 1  LSCAN = CMND(IFCHAR:IFCHAR)  ELSE LDIRCT = +1  ENDIF IFCHAR = IFCHAR + 1  IMCHAR = INDEX(CMND(IFCHAR:),LSCAN) + IFCHAR - 1  IF (IMCHAR .EQ. IFCHAR-1) THEN MSGLIN = ' INVALID CHANGE SPECIFICATION' IERROR = 20 RETURN  ENDIF COMDAT = CMND n IF (UPCASE) CALL UCASE(CMND,COMDAT)  IF (UPCASE) CALL UCASE(COMDAT) SKIP = .FALSE. WRAP = .FALSE.d CALL FSELOC(CURLIN,LDIRCT,SKIP,WRAP,COMDAT(IFCHAR:IMCHAR-1), d $ MSGLIN,IERROR) CALL FSELOC(CURLIN,CURNUM,LDIRCT,SKIP,WRAP,  $ COMDAT(IFCHAR:IMCHAR-1),MSGLIN,IERROR) IF (IERROR .NE. 0) RETURN  ILCHAR = INDEX(CMND(IMCHAR+1:),LSCAN) + IMCHAR - 1 IF (ILCHAR .EQ. IMCHAR-1) ILCHAR = ITRAIL(CMND)  CALL FSEGET(CURLIN,BUFFER,MSGLIN,IERROR)  IFOUND = INDEX(BUFFER,COMDAT(IFCHAR:IMCHAR-1)) IF (IFOUND .EQ. 0) THEN  MSGLIN = 'ERROR IN CHANGE LOCATE FUNCTION - STRING NOT FOUND' IERROR = 1000 RETURN  ENDIF LENGTH = IMCHAR - IFCHAR IF (IFOUND .NE. 1) THEN  IF (ILCHAR .GT. IMCHAR) THEN TEMPLN = BUFFER(1:IFOUND-1)//COMDAT(IMCHAR+1:ILCHAR)// $ BUFFER(IFOUND+LENGTH:)  MSGLIN = 'STRING /'//CMND(IFCHAR:IMCHAR-1)//'/ CHANGED TO /'// $ CMND(IMCHAR+1:ILCHAR)//'/' ELSE  TEMPLN = BUFFER(1:IFOUND-1)//BUFFER(IFOUND+LENGTH:)  MSGLIN = 'STRING /'//CMND(IFCHAR:IMCHAR-1)//'/ CHANGED TO //' ENDIF  ELSE  IF (ILCHAR .GT. IMCHAR) THEN TEMPLN = COMDAT(IMCHAR+1:ILCHAR)//BUFFER(IFOUND+LENGTH:)  MSGLIN = 'STRING /'//CMND(IFCHAR:IMCHAR-1)//'/ CHANGED TO /'// $ CMND(IMCHAR+1:ILCHAR)//'/' ELSE  TEMPLN = BUFFER(IFOUND+LENGTH:)  MSGLIN = 'STRING /'//CMND(IFCHAR:IMCHAR-1)//'/ CHANGED TO //' ENDIF  ENDIF  CALL FSEADD(CURLIN,TEMPLN,MSGLIN,IERROR)  CALL FSEDEL(CURLIN,MSGLIN,IERROR) CHANGE = CHANGE + 1  CURROW = 0 RETURNC C FILE COMMAND C 1900 IERROR = -1  RETURNC C QUIT AND QQUIT COMMAND C 2000 IF (CHANGE .GE.1) THEN MSGLIN = ' deck changed, must type "QQUIT" to exit' IERROR = 4 RETURN  ENDIF 2100 IERROR = -2  RETURNC C HELP COMMAND C 2200 CALL FSEHEL(EMODE)  CURROW = 0 RETURNC C TOP COMMAND C 2300 CURLIN = 0  CURNUM = 0  CURROW = 0 RETURNC C BOTTOM COMMAND C 2400 CURLIN = NRECI NLINES = 1 IF (EMODE .EQ. 'FSEDIT') NLINES = NROW - 4d CALL FSEUP (CURLIN,NLINES,MSGLIN,IERROR)  CALL FSEUP (CURLIN,NLINES,NLINES,MSGLIN,IERROR)  CURNUM = RCOUNT - NLINES + 1  CURROW = 0 RETURNC C SET COMMAND C n2500 CALL UCASE(CMND,COMDAT) 2500 COMDAT = CMND  CALL UCASE(COMDAT) IF (NWRD .LT. 2) THEN  MSGLIN = ' INVALID SET SPECIFICATION'  IERROR = 20  RETURN  ENDIF o TEMP = COMDAT(ISS(2):ISS(2)+ISL(2)-1)  TEMP = COMDAT(ISS(2):ISE(2))  LENW = ISE(2)-ISS(2)+1o IF (TEMP(1:ISL(2)) .EQ. SETCMD(1)(1:ISL(2))) THEN  IF (TEMP(1:LENW) .EQ. SETCMD(1)(1:LENW)) THEN C --- BUTTON SUBCOMMAND ---  I = 0 o IF (NWRD .GE. 3) I = RVAL(COMDAT(ISS(3):ISS(3)+ISL(3)-1))  IF (NWRD .GE. 3) I = RVAL(COMDAT(ISS(3):ISE(3))) IF (I.GT.0 .AND. I.LE.MAXBUT) THEN  BUTTON(I) = ' '   IF (NWRD .GE. 4) BUTTON(I) = COMDAT(ISS(4):)  ELSE   MSGLIN = ' INVALID BUTTON SPECIFICATION'  IERROR = 20  RETURN  ENDIF o ELSE IF (TEMP(1:ISL(2)) .EQ. SETCMD(2)(1:ISL(2))) THEN  ELSE IF (TEMP(1:LENW) .EQ. SETCMD(2)(1:LENW)) THEN C --- CASE SUBCOMMAND ---  UPCASE = .TRUE.  IF (NWRD.GE.3 .AND. COMDAT(ISS(3):ISS(3)).EQ.'M')  $ UPCASE = .FALSE. o ELSE IF (TEMP(1:ISL(2)) .EQ. SETCMD(3)(1:ISL(2))) THEN  ELSE IF (TEMP(1:LENW) .EQ. SETCMD(3)(1:LENW)) THEN C --- CMDLINE SUBCOMMAND ---  IF (NWRD.GE.3 .AND. COMDAT(ISS(3):ISS(3)).EQ.'B') THEN  NRHEAD = NROW - 1  NRCMND = NROW  NRMSG = 1  NRFLIN = 2  NRLLIN = NROW - 2  ELSE  NRHEAD = 1  NRCMND = 2  NRMSG = 3 ! NRFLIN = 4 " NRLLIN = NROW # ENDIF $ REFORM = .TRUE.  CURROW = 0 % RETURN &o ELSE IF (TEMP(1:ISL(2)) .EQ. SETCMD(4)(1:ISL(2))) THEN  ELSE IF (TEMP(1:LENW) .EQ. SETCMD(4)(1:LENW)) THEN 'C --- VIEW SUBCOMMAND --- ( I = 0 )o IF (NWRD .GE. 3) I = RVAL(COMDAT(ISS(3):ISS(3)+ISL(3)-1))  IF (NWRD .GE. 3) I = RVAL(COMDAT(ISS(3):ISE(3)))* IF (I.GT.0 .AND. I.LE.MWIDE) VIEW = I  REFORM = .TRUE. +o ELSE IF (TEMP(1:ISL(2)) .EQ. SETCMD(5)(1:ISL(2))) THEN  ELSE IF (TEMP(1:LENW) .EQ. SETCMD(5)(1:LENW)) THEN ,C --- ZONE SUBCOMMAND --- - I = 0 .o IF (NWRD .GE. 3) I = RVAL(COMDAT(ISS(3):ISS(3)+ISL(3)-1))  IF (NWRD .GE. 3) I = RVAL(COMDAT(ISS(3):ISE(3)))/ IF (I.GT.0 .AND. I.LE.MWIDE) THEN 0k J = 0  J = MWIDE 1o IF (NWRD .GE. 4) J = RVAL(COMDAT(ISS(4):ISS(4)+ISL(4)-1))  IF (NWRD .GE. 4) J = RVAL(COMDAT(ISS(4):ISE(4))) 2 IF (J.GE.I .AND. J.LE.MWIDE) THEN 3 FZONE = I 4 LZONE = J 5 ELSE 6 MSGLIN = ' INVALID ZONE SPECIFICATION' 7 IERROR = 20 8 RETURN 9 ENDIF : ELSE ; MSGLIN = ' INVALID ZONE SPECIFICATION' < IERROR = 20 = RETURN > ENDIF ?o ELSE IF (TEMP(1:ISL(2)) .EQ. SETCMD(6)(1:ISL(2))) THEN  ELSE IF (TEMP(1:LENW) .EQ. SETCMD(6)(1:LENW)) THEN @C --- PREFIX SUBCOMMAND --- A LPREFX = .FALSE.B IF (NWRD.GE.3 .AND. COMDAT(ISS(3):ISS(3)+1).EQ.'ON')C $ LPREFX = .TRUE.  REFORM = .TRUE. D ELSE E MSGLIN = ' INVALID SET SPECIFICATION' F IERROR = 20 G ENDIF H RETURNIC JC INSERT COMMAND KC L2600 CHANGE = CHANGE + 1 M RCOUNT = RCOUNT + 1 N COMDAT = CMND On IF (UPCASE) CALL UCASE(CMND,COMDAT)  IF (UPCASE) CALL UCASE(COMDAT)Po CALL FSEADD(CURLIN,COMDAT(ISS(1)+ISL(1)+1:),MSGLIN,IERROR) CALL FSEADD(CURLIN,COMDAT(ISE(1)+2:),MSGLIN,IERROR) Q RETURNRC SC TYPE COMMAND TC U2700 IF (EMODE .EQ. 'FSEDIT') THEN V MSGLIN = 'TYPE COMMAND NOT VALID IN FULL SCREEN EDIT MODE' W IERROR = 8 X RETURN Y ENDIF Z NLINES = 1[o IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISS(2)+ISL(2)-1))  IF (NWRD .GE. 2) NLINES = RVAL(CMND(ISS(2):ISE(2))) \ IF (NLINES .LE. 0) NLINES = 1 ] ILINE = CURLIN ^ DO 2710 I = 1,NLINES _ CALL FSEGET(ILINE,COMDAT,MSGLIN,IERROR) ` MAXCOL = MAX(ITRAIL(COMDAT),VIEW) a CALL WRTIO(TPAD//COMDAT(VIEW:MAXCOL)) bd CALL FSEDWN(ILINE,1,MSGLIN,IERROR) CALL FSEDWN(ILINE,1,J,MSGLIN,IERROR) c IF (IERROR .NE. 0) RETURN d2710 CONTINUE ! CURROW = 0" RETURN#C $C NAME COMMAND %C &2800 IF (NWRD .LT. 2) THEN ' MSGLIN = 'Tag string not found - INVALID specification' ( IERROR = 20 ) RETURN * ENDIF + CALL UCASE(CMND) , DO 2810 I = 1,NTAGS - IF (CMND(ISS(2):ISE(2)) .EQ. TAGNAM(I)) GO TO 2830. IF (CURLIN .EQ. TAGLIN(I)) GO TO 2820 /2810 CONTINUE 0 IF (NTAGS .GE. MAXTAG) THEN 1 WRITE(MSGLIN,'(A,I5)') 'Maximum number of tags exceeded, '//2 $ ' Maximum number of TAGS set to ',MAXTAG 3 IERROR = 20 4 RETURN 5 ENDIF 6 NTAGS = NTAGS + 1 7 I = NTAGS 82820 TAGNAM(I) = CMND(ISS(2):ISE(2)) 92830 TAGLIN(I) = CURLIN: RETURN;C <C COPY COMMAND =C >2900 COPY = .TRUE. ? GO TO 3005@C AC MOVE COMMAND BC C3000 COPY = .FALSE.D3005 IF (NWRD.NE.3 .AND. NWRD.NE.4) THEN E MSGLIN = 'Incorrect number of TAGS specified' F IERROR = 20 G RETURN H ENDIF I CALL UCASE(CMND) J DO 3010 I = 1,NTAGS K IF (TAGNAM(I) .EQ. CMND(ISS(2):ISE(2))) GO TO 3015 L3010 CONTINUE M MSGLIN = 'Tag >'//CMND(ISS(2):ISE(2))//'< not set' N IERROR = 12 O RETURN P3015 LINE1 = TAGLIN(I) Q DO 3020 I = 1,NTAGS R IF (TAGNAM(I) .EQ. CMND(ISS(3):ISE(3))) GO TO 3025 S3020 CONTINUE T MSGLIN = 'Tag >'//CMND(ISS(3):ISE(3))//'< not set' U IERROR = 12 V RETURN W3025 IF (NWRD .EQ. 3) THEN X TARGET = TAGLIN(I) Y BLOCK = .FALSE. Z ELSE [ LINE2 = TAGLIN(I) \ DO 3030 I = 1,NTAGS ] IF (TAGNAM(I) .EQ. CMND(ISS(4):ISE(4))) GO TO 3035 ^3030 CONTINUE_ MSGLIN = 'Tag >'//CMND(ISS(4):ISE(4))//'< not set' ` IERROR = 12 a RETURN b3035 TARGET = TAGLIN(I) c BLOCK = .TRUE. d ENDIF e TOP = 0 f BOTTOM = 0g3060 CALL FSEDWN(TOP,1,J,BUFFER,IERROR)h IF (TOP .EQ. LINE1) GO TO 3065i IF (TOP .EQ. LINE2) GO TO 3065 j GO TO 3060 k3065 IF (.NOT.BLOCK) GO TO 3080 l BOTTOM = TOP m3070 CALL FSEDWN(BOTTOM,1,J,BUFFER,IERROR) n IF (BOTTOM .EQ. LINE1) GO TO 3075 o IF (BOTTOM .EQ. LINE2) GO TO 3075 p IF (BOTTOM .EQ. TARGET) THEN q MSGLIN = 'Target imbedded in block move/copy' r IERROR = 12 s RETURN t ENDIF u GO TO 3070 v3075 LINE2 = 0 w3080 CALL FSEGET(TOP,COMDAT,BUFFER,IERROR) x CALL FSEADD(TARGET,COMDAT,MSGLIN,IERROR) y IF (IERROR .NE. 0) RETURN z CHANGE = CHANGE + 1 { IF (BLOCK .AND. TOP.EQ.BOTTOM) LINE2 = -1 | IF (COPY) THEN} CALL FSEDWN(TOP,1,J,BUFFER,IERROR) ~ ELSE  CALL FSEDEL(TOP,BUFFER,IERROR)  ENDIF  CALL FSEDWN(TARGET,1,J,BUFFER,IERROR)  IF (BLOCK .AND. LINE2.EQ. 0) GO TO 3080  RETURNC C ':' COMMAND (MOVE TO SPECIFIED LINE) C 3100 IF (NWRD .LT. 2) THEN  MSGLIN = '":" command requires line number specified' IERROR = 20 RETURN  ENDIF  NLINES = RVAL(CMND(ISS(2):ISE(2))) CURLIN = 0 CURNUM = 0 CALL FSEDWN(CURLIN,NLINES,NLINES,MSGLIN,IERROR) CURNUM = CURNUM + NLINES  RETURNC C "." COMMAND (MOVE TO THE SPECIFIED TAGED LINE) C 3200 IF (NWRD .LT. 2) THEN  MSGLIN = '"." command requires a TAG specified' IERROR = 20 RETURN  ENDIF CALL UCASE(CMND) DO 3210 I = 1,NTAGS  IF (CMND(ISS(2):ISE(2)) .EQ. TAGNAM(I)) GO TO 32203210 IF (NLINES .LE. 0) NLINES = 1  MSGLIN = 'Tag >'//CMND(ISS(2):ISE(2))//'< not set' IERROR = 20  RETURN 3220 CURLIN = 0 CURNUM = 03230 IF (CURLIN .NE. TAGLIN(I)) THEN  CALL FSEDWN(CURLIN,1,NLINES,MSGLIN,IERROR) CURNUM = CURNUM + NLINES GO TO 3230  ENDIF eC f*ENDIF EDIT g RETURNh END HELP(13)= ' a is a named line which indicates where the' c HELP(14)= ' MOVE will begin GETBUF 3/22/82lR&  SUBROUTINE GETBUF(IN,IL)C C READS INPUT RECORD (IN) FROM SCRATCH FILE (LSI) C INTO BUF AND RETURNS LENGTH (WORDS) IN (IL) lC INTO BUF AND RETURNS LENGTH (characters) 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 l DO 100 I = MWIDE,2,-1   IF(BUF4(I) .NE. ' ') GOTO 200l IF(BUF(I:I) .NE. ' ') GOTO 200  100 CONTINUEC  I = 1 200 IL=I*NCHRWD l200 IL=I  RETURN  END 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) Cz CALL SCAN2(BUF(1:IL))  CALL SCANDI(BUF(1:IL)) C IF(NWRD.GT.1) THEN Co A=BUF(ISS(2):ISS(2)+ISL(2)-1)  A=BUF(ISS(2):ISE(2))  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) Cz CALL SCAN2(BUF(1:IL))  CALL SCANDI(BUF(1:IL)) C IF (NWRD.GT.0) THEN Co AA(1)=BUF(ISS(1)+1:ISS(1)+ISL(1)-1)  AA(1)=BUF(ISS(1)+1:ISE(1)) C DO 100 I=2,NWRD C o AA(I)=BUF(ISS(I):ISS(I)+ISL(I)-1)  AA(I)=BUF(ISS(I):ISE(I)) C 100 CONTINUE C ENDIF C NW=NWRD & RETURN ' END tC LOCATE COMMAND uC v1700 IF (ICMND.GT.0 .AND. NWRD.LT.2) THEN w MSGLIN = 'LOCATE STRING NOT FOUND - INVALID SPECIFICATION' x IERROR = 20 y RETURN z ENDIF { IFCHAR = ISS(2) | IF (ICMND .LT. 0) HEADER 3/22/82rbZ  SUBROUTINE HEADER (A) C C SETS UP AND WRITES HEADER FOR PROGRAM C  CHARACTER*(*) A C *CA PARAMA *CA LOGU *CA DATE  *CA IVERS r*CA CONTRL  C CHARACTER*132 HDR p DATA HDR /' '/ p DATA LINNO /1/ p DATA IPAG /1/  SAVE HDR, LINNO, IPAG C  HDR(2:60)=A  HDR(65:72)=DATE  HDR(78:85)=TIMDAY  HDR(2:49) = A  HDR(58:65) = DATE  HDR(68:75) = 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' r HDR(124:127)= 'Page'rn IF(ICUC) CALL UCASE(HDR,HDR)  IF(ICUC) CALL UCASE(HDR)100 WRITE(HDR(129:),111) IPAG r100 WRITE(HDR(128:),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 C C Entry HEADI initialize header variables C  ENTRY HEADI C  HDR = ' '  LINNO = 1 IPAG = 1 RETURN  l C C Entry HEADCH - change header - do not page C  ENTRY HEADCH (A)C  HDR(2:49) = A  RETURN ' END n IF (OUTPUT) THENbn OUTNAM = OUTNAM(1:LENI)//WDISK cn ELSE dn OUTNAM = OUTNAM(1:LENI)//RDISK en ENDIF fnC gn CALL UCASE(OUTNAM,ANS) hn OUTNAM=ANS in*ENDIF IBMVM SUBRICKDIC 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 ICKGRP 8/28/84 FUNCTION ICKGRP(GNAME,ALF,LENA) C C Checks *GNAME directive in record to see if it C matches GNAME from *CALLG directive C *CA PARAMA *CA SCAN  CHARACTER*(*) GNAME CHARACTER*(MAXWID) ALF  C  z CALL SCAN2 (ALF(1:LENA)) CALL SCANDI (ALF(1:LENA))  C ICKGRP=0  IF(NWRD.LT.2) RETURNC o IF(GNAME.EQ.ALF(ISS(2):ISS(2)+ISL(2)-1)) THEN  IF(GNAME.EQ.ALF(ISS(2):ISE(2))) THEN  ICKGRP=1  ENDIF  RETURN  END CALL SCANDI(BUF(1:ILIFINDK 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 cn CALL UCASE(A,B)  B = A  CALL UCASE(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 INNO.GT.55) GOTO 100 & RETURN ZC ZC Z ENTRY SUBHED(I)Z IF((LINNO + I) .GT. 55) GOTO 100 Z RETURN C C Entry HEADI initialize header variables C  ENTRY HEADI 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/82.'urpofdcbRJC?8'   SUBROUTINE INITLC C INITIALIZES PROGRAM C *CA PARAMA n*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 nC nC VERSION OF PROGRAM nC *CA DIRDIC R*CA SEQCTL R*CA WIDTH d*CA LANGC *CA DIRSTA f*CA BUFAf*CA INPERC r*CA CPLDIR n*CALL FILEIDS *CALL BATCH *CA FNAMES *CA EDIOPTS *CA FSECOM *CALL SWITCH*CALL SEPCOM*CALL SEPFIC*CALL SERCHC*CALL UPDATC*CALL YANKC *IF VAX *CALL ITABC *ENDIF VAX  CHARACTER FNAME*72 , STATUS*8 *IF NPS *CALL NPSARGC  CALL NPS(0,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)v IF (QREADY.AND.QERROR) CALL NPSEIO('NPS VIA INITL')  IF (QREADY.AND.QERROR) CALL NPSEIO('NPS via INITL',  $ 'NPS called with ICODE=0') *ENDIF C C C Initialize CKINP local variables C  CALL CKINPI C C Initialize HEADER local variables C CALL HEADI u BUF = ' ' u CPLDI = ' ' d LANG = 0 d LANGNM(1)='Fortran ' d LANGNM(2)='Cobol ' LANGNM(3)= 'Assemble'  LANGNM(4) = 'Data' n CLANGF = 'SCA'  CLANGF = 'FCAD'  SCOMPF = .FALSE.  SSOURF = .FALSE.  SCALLF = .FALSE. z*IF -PRIME z COMEXT(1) = '.FOR' z*ENDIF -PRIME z*IF PRIME z COMEXT(1) = '.F77' z*ENDIF PRIME z COMEXT(2) = '.COB' z COMEXT(3) = '.MAR' dC  IVERS=2 R IVERS = 3 p IVERS = 4 b LSTMOD='MOD46 ' c CALL VERSN r CALL VLEVEL RC R MWIDE = 0 RC R LSEQC = 1 f INRCN=0  NDKMEL = 0  NDKMEU = 0  MEMSTL(1) = 1  MEMSTU(0) = MAXWRD+1fC f INERRF=0fC  PMODE = 'NOTSET'  TMODE = 'TERMINAL' d*IF -IBM d LSEQC=1 d*ENDIF d *IF IBM d LSEQC=2 d *ENDIF  CALL XDATE(DATE)  CALL TIME (TIMDAY) ' TIMDAY=' '  CALL XTIME(TIMDAY) i PRFX = '*'  PRFX = ' ' *IF VAX  ITABC=9 *ENDIF  LIN = 51  LOP = 31  LSO = 12  LOU = 13 LCO = 14 ! LNP = 11 " LSR = 50 # LSI = 49 $ LIA = 15 % LOA = 16  LBO=17  LBI=18 LMO = 32*IF UNIX  LIN = 7  LOP = 19  LSR = 3  LSI = 2  LMO = 4 *ENDIF UNIX *IF TERM5  LTI=5 f LTO=6 *ENDIF r*IF TERM57 r LTI=5 r LTO=7 r*ENDIF *IF TERM1  LTI=1 f LTO=1 *ENDIF u LDO=19 u LDI=20  LCI=51 & LOCLNP=1 ' LOCLSR=1  NAMLCO = ' '  NAMLOU = ' '  NAMLOP = ' '  NAMLIA = ' '  NAMLNP = ' '  NAMLOA = ' ' NAMLSO = ' ' IWLCO = 1 IWLOU = 1 IWLOP = 1 IWLIA = 1  IWLNP = 1  IWLOA = 1  IWLSO = 1 u UCASE = .FALSE.  UPCASE = .FALSE. NSERCH = 0 UPDATE = .FALSE. YANKID = ' ' ( CALL OPNSPL (LSR)  IRECS = 10  MXRECS = 9000k CALL OPENER(LSR,' ','SCRATCH','DIRECT','UNFORMATTED',  STATUS = 'NEW'  ITEMP = 1  FNAME = ' '  CALL FILECK(LSR,'SCRATCH 50',FNAME,ITEMP,STATUS,IDDNAM)  CALL OPENER(LSR,FNAME(1:ITEMP),IDDNAM,'SCRATCH','DIRECT', $ 'UNFORMATTED',  $ NCHRWD*NWRDBK,IRECS,MXRECS,IERR)  IF(IERR.NE.0) THEN  CALL WRTIO(  1 ' Error in INITL opening SCRATCH LIBRARY file (50)') CALL THEEND(2, ' Cannot open SCRATCH LIBRARY file (50)')  ENDIF ) NIN = 0 * NDIR=0 + NDITOT = 0 , DO 100 I = 1,LDIR 8 DO 100 I = 1,MAXDIR -100 NODIR(I) = 0  DO 200 I=1,MAXDCK  INCLDD(I) = 0  IEDIT(I) = 0 200 CONTINUE ? NDCKS = 0 . NMODS = 0 / NMODOP = 0 0 NSWS = 0 1n ISDEC(1)=1 2n ISDEC(2)=MAXWRD/2+1 3n IDECP1=1 4n IDECP2=ISDEC(2) 5 ISETIF = 0 p ISETIF=.TRUE. 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.  ICL=.FALSE. G ICS=.FALSE. H ICN=.FALSE. I ICNA=.FALSE. J ICP=.TRUE. K ICPA=.FALSE. o ICCD=.TRUE. r ICUC=.FALSE. ICM = .FALSE. r NCPLDI=0 L LSTA=.FALSE. M LSTC=.FALSE. N LSTE=.TRUE. O LSTI=.FALSE. P LSTM=.TRUE. Q LSTS=.FALSE. p LSTS=.TRUE. LSTS=.FALSE. LSTD=.FALSE. R LSTT=.FALSE. Sp 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' r DIRDIS(20)='VL'  DIRDIS(21)='CG'  DIRDIS(22)='GN' DIRDIS(23)='ED'  DIRDIS(24)='S' 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' r DIRDIL(20)='VLEVEL'  DIRDIL(21)='CALLG'  DIRDIL(22)='GNAME' DIRDIL(23)='ENDDATA'  DIRDIL(24)='SEARCH' 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' r  WRITE(LTO,391)'Error in INITL working on dictionary' r 391 FORMAT(1X,A) C STOP 'ERROR IN INITL'  CALL WRTIO(' Error in INITL working on dictionary.')  CALL THEEND(2,' Stopping in INITL.') C ENDIF C IDIRL(I)=IL C400 CONTINUE * BUTTON KEY SETUP  BUTTON(1) = 'HELP'  BUTTON(2) = 'SET VIEW 1'  BUTTON(3) = 'QUIT'  BUTTON(4) = 'SET CASE M'  BUTTON(5) = 'SET CASE U'  BUTTON(6) = '?' BUTTON(7) = 'BACKWARD' BUTTON(8) = 'FORWARD' BUTTON(9) = ' ' BUTTON(10)= '=' BUTTON(11)= 'TOP'  BUTTON(12)= 'BOTTOM' * DEFAULT FORMS SETUP c FORMS(1) ='DEFAULT 1 * TN IN HN CG (A) DEFAULT ' c FORMS(2) ='HEADER 1 * TP CW (A) HEADING ' c FORMS(3) ='COMMAND 1 * 3 CR KH (A) COMMAND ' c FORMS(4) ='SCALE 1 * TP CW (A) SCALE ' c FORMS(5) ='PREFIX 1 2 HR (A) PREFIX ' c FORMS(6) ='COBOL 1 5 (A5) SEQUENCE COL' c FORMS(7) ='COBOL 6 6 HR (A1) COMMENT ' c FORMS(8) ='COBOL 7 72 (A66) COBOL TEXT ' c FORMS(9) ='FORTRAN 1 5 (A5) STMT LABEL ' c FORMS(10)='FORTRAN 6 6 HR (A1) CONT FLAG ' c FORMS(11)='FORTRAN 7 72 3 (A66) FORTRAN TEXT' *  FORMS(1) = 'DEFAULT,1,*,*,(TN/IN/HN/CG),(A),DEFAULT,*,*,*,'  FORMS(2) = 'HEADER,1,*,*,(TP/CW),(A),HEADING,*,*,*,'  FORMS(3) = 'COMMAND,1,*,3,(CR/KH),(A),COMMAND,*,*,*,'  FORMS(4) = 'SCALE,1,*,*,(TP/CW),(A),SCALE,*,*,*,'  FORMS(5) = 'PREFIX,1,2,*,(HR),(A),PREFIX,*,*,*,'  FORMS(6) = 'COBOL,1,5,*,*,(A5),SEQUENCE COL,*,*,*,'  FORMS(7) = 'COBOL,6,6,*,(HR),(A1),COMMENT,*,*,*,'  FORMS(8) = 'COBOL,7,72,*,*,(A66),COBOL TEXT,*,*,*,'  FORMS(9) = 'FORTRAN,1,5,*,*,(A5),STMT LABEL,*,*,*,'  FORMS(10) = 'FORTRAN,6,6,*,(HR),(A1),CONT FLAG,*,*,*,' FORMS(11) = 'FORTRAN,7,72,3,*,(A66),FORTRAN TEXT,*,*,*,'  FORMS(12) = 'FORTRAN,73,80,*,(TP/HR),(A8),SEQ. ID,*,*,*,' * n*IF IBM  COMFID(1) = ' '  COMFID(2) = ' '  COMFID(3) = ' '  COMFID(4) = ' '  MODFID = ' '  BAKFID = ' ' *IF IBMMVS C FILEID DEFAULTS n DO 500 I = 1,MAXFIL n 500 PREID(I) = 'SPIP.' n COMEXT(1) = '.FORT' n COMEXT(2) = '.COBL' n COMEXT(3) = '.ASSM' n POSTID(1) = '.FORT' n EXIST(1) = -1 n POSTID(2) = '.LIST' n EXIST(2) = -1 n POSTID(3) = '.SLIB' n EXIST(3) = -1 n POSTID(4) = '.UPDT' n EXIST(4) = 1 n POSTID(5) = '.TEXT' !n EXIST(5) = -1 "n POSTID(6) = '.PLIB' #n EXIST(6) = -1 $n POSTID(7) = '.SBUP'  COMFID(1) = 'SPIP.*.FORT'  COMFID(2) = 'SPIP.*.COBL'  COMFID(3) = 'SPIP.*.ASSM'  COMFID(4) = 'SPIP.*.DATA'  MODFID = 'SPIP.*.TEXT'  BAKFID = 'SPIP.*.SBUP' % EXIST(7) = -1 &u POSTID(8) = '.CONT'  POSTID(8) = '.UPDT' 'u EXIST(8) = -1  EXIST(8) = 1*ENDIF *IF IBMVM C FILEID DEFAULTS n DO 500 I = 1,MAXFIL z MACHID(I) = ' ' !z DIRTID(I) = ' ' "z POSTID(I) = ' ' (n 500 PREID(I) = ' ' #z 500 CONTINUE $n RDISK = ' *' %n WDISK = ' Z'&z FTYPE(1) = ' FORTRAN' )n COMEXT(1) = ' FORTRAN ' *y COMEXT(2) = ' COBAL ' n COMEXT(2) = ' COBOL ' +n COMEXT(3) = ' ASSEMBLE' ,n POSTID(1) = ' FORTRAN' 'n EXIST(1) = -1 (z FTYPE(2) = ' LISTING' -n POSTID(2) = ' LISTING' )n EXIST(2) = -1 *z FTYPE(3) = ' SLIBRARY' .n POSTID(3) = ' SLIBRARY' +n EXIST(3) = -1 ,z FTYPE(4) = ' SLIBUPDT' /n POSTID(4) = ' SLIBUPDT' -n EXIST(4) = 1 .z FTYPE(5) = ' SOURCE'0n POSTID(5) = ' SOURCE' /n EXIST(5) = -1 0z FTYPE(6) = ' PORTLIB' 1n POSTID(6) = ' PORTLIB' 1n EXIST(6) = -1 2z FTYPE(7) = ' BACKUP'2n POSTID(7) = ' BACKUP' 3n EXIST(7) = -1 4z FTYPE(8) = ' CONTINUE' 3u POSTID(8) = ' CONTINUE' n POSTID(8) = ' SLIBUPDT' 5u EXIST(8) = -1 n EXIST(8) = 1 COMFID(1) = '* FORTRAN A'  COMFID(2) = '* COBOL A'  COMFID(3) = '* ASSEMBLE A'  COMFID(4) = '* DATA A'  MODFID = '* MODIFY A'  BAKFID = '* BACKUP A'6*ENDIF 7n*ENDIF 8n*IF -IBM9nC FILEID DEFAULTS FOR NON-IBM :n DO 500 I = 1,MAXFIL ;z MACHID(I) = ' ' <z DIRTID(I) = ' ' =z POSTID(I) = ' ' 4n PREID(I) = ' ' >n 500 CONTINUE ?n*IF -PRIME @z FTYPE(1) = '.FOR' 5n COMEXT(1) = '.FOR' 6n COMEXT(2) = '.COB' 7n COMEXT(3) = '.MAR' 8n POSTID(1) = '.FOR' An*ENDIF B*IF PRIME Cz FTYPE(1) = '.F77' 9n COMEXT(1) = '.F77' :n COMEXT(2) = '.CBL' ;n COMEXT(3) = '.PMA' <n POSTID(1) = '.F77' Dn*ENDIF En EXIST(1) = 0 Fz FTYPE(2) = '.LIS' =n POSTID(2) = '.LIS' Gn EXIST(2) = 0 Hz FTYPE(3) = ' ' >n POSTID(3) = '.L77' In EXIST(3) = 0 Jz FTYPE(4) = ' ' ?n POSTID(4) = '.DAT' Kn EXIST(4) = 1 Lz FTYPE(5) = '.SRC' @n POSTID(5) = '.SRC' Mn EXIST(5) = 0 Nz FTYPE(6) = ' ' An POSTID(6) = '.NAF' On EXIST(6) = 0 Pz FTYPE(7) = '.BAK' Bn POSTID(7) = '.BAK' Qn EXIST(7) = 0 Rz FTYPE(8) = '.CNT' Cu POSTID(8) = '.CNT' n POSTID(8) = '.DAT' Su EXIST(8) = 0 n EXIST(8) = 1 Tn*ENDIF COMFID(1) = '*.F77' ! COMFID(2) = '*.CBL' " COMFID(3) = '*.PMA' # COMFID(4) = '*.DAT' $ MODFID = '*.MOD' % BAKFID = '*.BAK' &*ENDIF PRIME'*IF VAX ( COMFID(1) = '*.FOR' ) COMFID(2) = '*.COB' * COMFID(3) = '*.MAR' + COMFID(4) = '*.DAT' , MODFID = '*.MOD' - BAKFID = '*.BAK' .*ENDIF VAX  CALL PROFIL y RETURN z END INP 3/22/82~|rmlfZRQH! p SUBROUTINE INP  SUBROUTINE INP(NEXT)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 r*CA ERRMES *CALL SEPFIC*CALL SCAN *CALL SERCHC*CALL YANKC *CALL UPDATC*CALL FNAMESC NEXT - record after *ENDDATA on input file  CHARACTER * (*) NEXT CHARACTER FNAME*72 , STATUS*8 C nC n CHARACTER*(MAXWID) SERCHS(5) n DIMENSION LSERCH(5) n INTEGER NSERCH nc NSERCH - number of search strings ( from *SEARCH directive) nC SERCHS - holds string to search for  nC LSERCH - length of each search string  nC  NEXT=' '  CALL OPNLSI(LSI)  IRECS = 10  MXRECS = 9000k CALL OPENER(LSI,' ','SCRATCH','DIRECT','UNFORMATTED',  STATUS = 'NEW'  ITEMP = 1  FNAME = ' '  CALL FILECK(LSI,'SCRATCH 49',FNAME,ITEMP,STATUS,IDDNAM)  CALL OPENER(LSI,FNAME(1:ITEMP),IDDNAM,'SCRATCH','DIRECT', $ 'UNFORMATTED',  $ MWIDE,IRECS,MXRECS,IERR) C  NC=0ZC Z IF(LSTT) THEN Z WRITE(LOU,90)Z 90 FORMAT(/,' Input Text Listing:') Z CALL LININC(2) r ERRMSG=' ' r CALL WROUT r ERRMSG='Input Text Listing:' r CALL WROUT Z ENDIF  CALL CTLCRD C C READ IN A CARD C  100 CALL RDINP(LIN,ITP,IWID)|C ITP set to 999 at E-O-F  IF(ITP .GT. 100) GOTO 9000  IF(ITP.GT.0) THEN  NODIR(ITP)=NODIR(ITP)+1  ENDIF H110 IF(ITP.GT.100) GOTO 9000C 23 is ENDDATA directive  IF(ITP.EQ.23) THEN  IF(LSTT) THEN WRITE(ERRMSG,211) INRCN,BUF(1:IWID) CALL WROUT ENDIF IF(LIN.GT.51) GOTO 9000  READ(LIN,'(A)',ERR=112,END=112) NEXT GOTO 9000 112 NEXT=' '  GOTO 9000  ENDIF |C 15 is $READ directive  IF(ITP.EQ.15) GOTO 1500 C 17 is *UPDATE  IF(ITP.EQ.17) GOTO 1700 C 18 is *YANK  IF(ITP.EQ.18) GOTO 1800  C 24 is *SEARCH directive IF(ITP.EQ.24) GOTO 2400 |vC MAXDIR+1 is comment (asterisk-exclamation) *! C MAXDIR+1 is comment (asterisk-quote) *' | IF(ITP.GT.MAXDIR) GOTO 200 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 200r} 1 ITP .EQ. 9 .OR. ITP .EQ. 11 .OR. ITP .EQ. 20) GOTO 200  1 ITP .EQ. 9 .OR. ITP .EQ. 11 .OR. ITP .EQ. 20  1 .OR. ITP .EQ. 21 .OR. ITP .EQ. 22 ) GOTO 200 ~ IF (NDIR.GE.MAXDRR-1) THEN ~ WRITE(ERRMSG,113) MAXDRR ~113 FORMAT('Too many directives for program maximum =',I5,~ 1 ' (parameter MAXDRR must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,' Stopping in INP - too many directives.') ~ ENDIF , NDIR = NDIR + 1 -C . INLOC(NDIR) = NIN m INRNO(NDIR)=INRCN / INTYP(NDIR) = ITP l IPRD(NDIR)=.FALSE. 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) r WRITE(ERRMSG,211) INRCN,BUF(1:IWID) 5211 FORMAT(1X,I7,1X,A) 6 CALL LININC(1) r CALL WROUT 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) r ERRMSG='Pre-processing '//BUF(1:IWID) r CALL WRMES 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) r ERRMSG='Begin reading '//BUF(1:IWID) r CALL WRMES A ENDIF B GOTO 100 C C *UPDATE directive C 1700 CONTINUE UPDATE = .TRUE.  GOTO 200C C *YANK directive C 1800 IF(.NOT.ICM .OR. .NOT.ICN ) THEN ERRMSG='**ERROR** YANK requires MODIFY and NEW LIBRARY'// 1 ' file one or both of these files not requested.'  CALL WRERR  INERRF=INERRF + 1  GOTO 200  ENDIF C  CALL SCANDI(BUF(1:IWID))  IF(NWRD.LT.2) THEN  ERRMSG='**ERROR** YANK directive does not have ident.'  CALL WRERR  INERRF=INERRF + 1  GOTO 200 ENDIF ! YANKID = BUF(ISS(2):ISE(2)) " GOTO 200 C C *SEARCH directive C 2400 IERR24=0 n IF(.NOT.ICS) THEN # IF(.NOT.ICM) THEN n ERRMSG='**ERROR** SEARCH requested but not source file.' $ ERRMSG='**ERROR** SEARCH requested but not modify file.'  CALL WRERR  IERR24 = IERR24 + 1  ENDIF n IF(SSOURF) THEN n ERRMSG='**ERROR** SEARCH requested and separate source '// n 1 ' files for each deck - program doesnt do both' n CALL WRERR n IERR24 = IERR24 + 1 n ENDIF n IF(.NOT.(ICP.OR.ICTPA)) THENn ERRMSG='**ERROR** SEARCH requested but no old library.' n CALL WRERR n IERR24 = IERR24 + 1 n ENDIF ! LSTART=INDEX(BUF(1:IWID),'"') +1 " IF(LSTART.LT.IWID) THEN # LEND=INDEX(BUF(LSTART+1:IWID),'"')+LSTART-1 $ ELSE % LEND=0 & ENDIF ' IF(LEND.LT.LSTART) THEN ( ERRMSG='**ERROR** SEARCH directive improperly constructed'// ) 1 ' consult User Guide.' * CALL WRERR + IERR24 = IERR24 + 1 , ENDIF -n IF(NSERCH.GT.4) THEN% IF(NSERCH .GE. MAXSER) THEN .n ERRMSG='Too many SEARCH directives - max = 5'& ERRMSG='Too many SEARCH directives (MAXSER)' / CALL WRERR 0 IERR24 = IERR24 + 1 1 ENDIF 2 IF(IERR24.NE.0)THEN 3 ERRMSG='Improper directive - '//BUF(1:IWID) 4 CALL WRERR 5 INERRF = INERRF +IERR24 6 IERR24=0 7 ENDIF 8 NSERCH = NSERCH + 1 9 SERCHS(NSERCH) = BUF(LSTART:LEND) : LSERCH(NSERCH) = LEND - LSTART + 1 ; GOTO 200 C9000 CONTINUE D IF(LIN.GT.51) THEN  CALL CLSFIL(LIN) 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 r WRITE(ERRMSG,9011) INERRF r CALL WRERR f 9011 FORMAT(' There were ',I5,' input errors run will', f 1 ' be terminated.')f  STOP 'input errors' ~ CALL ENDPRO(1) CALL THEEND(1,' Stopping in INP because of input errors.') f ENDIF <n IF(NSERCH.GT.0) THEN=n CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL', >n $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR) ?n IF(IERR.NE.0) THEN @n ERRMSG = ' Unable to open SOURCE file '// An 1 NAMLSO(1:IWLSO) Bn CALL WRMESCn CALL THEEND(2, ' Couldnt open source file') Dn ENDIFEnC Fn CALL PSERCH (NSERCH,SERCHS,LSERCH) Gn CALL CLSFIL(LSO) HnC In ENDIF J RETURN K END > LIMMINPADD 11/22/82~|zrfaR 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 r*CA ERRMES |*CALL DIRDIC 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 o INTEGER*4 ISL  INTEGER*4 ILX *ENDIF C C z LOCDCK=LOCLSR m NDKMEM = 1 m MEMSTR(NDKMEM) = 1  NDKMEL = 1  MEMSTL(NDKMEL) = 1  IDECP1=1 CALL INAL(ADEC(IDECP1),IDECP1,DCKNAM)  CALL INAL(ADEC(IDECP1),IDECP1,DATE) o ISL=IDECP1  ILX=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 r IF(ITP .EQ. 0 .OR. ITP .EQ. 3 .OR. ITP .EQ. 9 .OR. r} 1 ITP .EQ. 11 .OR. ITP .EQ. 20) THEN  1 ITP .EQ. 11 .OR. ITP .EQ. 20 .OR.  2 ITP .EQ. 21 .OR. ITP .EQ. 22 ) THEN (C )C Record gets added to deck *C + NW=(IWID+NCHRWD-1)/NCHRWD , IRC(1)=5+NW - IRC(3)=NSEQ ~ IF(IDECP1+NW+5 .GT. MAXWRD ) THEN~ ERRMSG='Add deck '//DCKNAM//' Too large for program' ~ 1 //' (parameter MAXWRD must be increased).' ~ CALL WRERR ~ CALL ENDPRO(2)  CALL THEEND(2,'Deck too large') ~ ENDIF. 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 zn*IF SMALL zn IF(IDECP1.GT.NWRDBK) THENzn CALL WRPLA(LSR,LOCLSR,1) zn LOCLSR=LOCLSR + 1 zn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,IDECP1-1) zn ENDIF*ENDIF SMALLz n*ENDIF 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) r ERRMSG='Begin reading '//BUF(1:IWID) r CALL WRMES | ELSEIF (ITP.EQ.MAXDIR+1) THEN |vC *! -------- comment - ignoreC *' -------- comment - ignore | GOTO 310 f ELSE f GOTO 500 ? ENDIF f IF(LSTT) THEN |310 IF(LSTT) THEN f WRITE(LOU,311) INRCN,BUF(1:IWID) r WRITE(ERRMSG,311) INRCN,BUF(1:IWID) f311 FORMAT(1X,I7,1X,A) f  CALL LININC(1) r CALL WROUT f ENDIF f GOTO 200@C AC NO MORE RECORDS FOR THIS DECK BC CC D500 CONTINUE E CALL ININ(IDECP1,0,1) *IF SMALL  CALL WRPLA(LSR,LOCLSR,1)  LOCLSR=LOCLSR + 1  NBLKS=LOCLSR-LOCDCK  CALL RDPLA(LSR,LOCDCK,1) CALL STATIS(2,NBLKS*NWRDBK)  IDM(1)=NBLKS IDM(2)=0 CALL ININ(ILX,IDM(1),2) CALL WRPLA(LSR,LOCDCK,1) GOTO 510 *ENDIF SMALL 502 CONTINUE z n*IF -SMALL F NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBK~n IF (NBLKS*NWRDBK .GT. ISDEC(2) ) THEN  IF (NBLKS*NWRDBK .GT. MAXWRD ) THEN ~ ERRMSG='Add deck '//DCKNAM//' Too large for program' ~ 1 //' (parameter MAXWRD must be increased).' ~ CALL WRERR ~  CALL ENDPRO(2)  CALL THEEND(2,'Deck too large') ~ ENDIF z n*ENDIF z n*IF SMALL z n CALL WRPLA(LSR,LOCLSR,1) zn LOCLSR=LOCLSR+1 zn NBLKS=LOCLSR-LOCDCK zn CALL RDPLA(LSR,LOCDCK,1)zn*ENDIF G CALL STATIS(2,NBLKS*NWRDBK) H IDM(1)=NBLKS I IDM(2)=0 J CALL ININ(ISL,IDM,2)ao CALL ININ(ISL,IDM(1),2)  CALL ININ(ILX,IDM(1),2) zn*IF -SMALL K LOCDCK=LOCLSR Lm CALL WRDK(LSR,LOCLSR,1,NBLKS)  CALL WRDK('L',LSR,LOCLSR,1,NBLKS) zn*ENDIF zn*IF SMALL zn CALL WRPLA(LSR,LOCDCK,1)zn*ENDIF MC NC Save the start location and the number of blocks for PADD OC 510 CONTINUEP 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 u CALL WRTIO(' U E -'//CONTO(1:LCONTO)//'- continuation')"u CALL WRTIO(' T S -'//BKUPO(1:LBKUPO)//'- backup') #u CALL WRTIO(' ') $u ANS = ' ' %u CALL RDTIO('Enter selection (CR for no cINSCOL 11/19/84 SUBROUTINE INSCOL(NDCK,NRECCF) C C Count number of common deck records for compile file C (derived from INSCOM) *IF NUMREC 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 I4 C C  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 " IDECPT = IDECP2 #C $100 CONTINUE % ILX = IDECP2& 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 COMCHD(ADEC(IDECP2),LENA,ITD) ,C Insure that imbedded directives get written on compile file -C if switches are set .C / IF(.NOT.ICC) GOTO 800 0 IF( (ICCD .AND. (ITD.EQ.9.OR.ITD.EQ.11)) .OR. 1 1 (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) THEN 2 NRECCF = NRECCF+1 3 ENDIF 4800 CONTINUE 5 IDECP2 = ILX+LNX 6 GOTO 100 79000 CONTINUE8C 9C ADD DUMMY RECORD TO SHOW END OF CALL :C ; IF(ICC .AND. ICCD .AND. ISETIF) NRECCF = NRECCF+1 <*ENDIF NUMREC = RETURN > END DIF ? ENDIF@ ELSEAC OLD B IF(IDECP1.GT.0) THEN CC ACTIVED CALL EXIN(IDECP1,IRD(1),5)EC FINSCOM 3/22/82zutpoda.-n SUBROUTINE INSCOM(NDCK) nC nC INSERTS COMMON DECK INTO COMPILE FILE nC  SUBROUTINE INSCOM(ICDECK, DNAME, COUNT, NRECCF) C C Inserts common deck(s) into compile fileC C ICDECK - common deck number to be inserted - input C DNAME - called deck name - inputC COUNT - logical switch .TRUE. if only to count records -input C NRECCF - count of records to be written on compile file  C *CA PARAMA*CA DECA *CA DECKS *CA LOGU *CA MODNA *CA IFSWI *CA CONTRL  *CALL PRFX  C n CHARACTER*8 DCK  C CHARACTER*8 DCK, DNAME CHARACTER*8 NAM,DATD LOGICAL COUNT C  CHARACTER*8 DNAMEC, GNAMEC, LDECKC  LOGICAL ISETC NESTD - numbers of nested common decks  DIMENSION NESTD(10)  DIMENSION IDD(5) EQUIVALENCE(LNX,IDD(1)),(IDK,IDD(2)),(ISQ,IDD(3))  1 ,(IDEL,IDD(4)),(NMR,IDD(5)) C .*IF I4 n INTEGER*4 ILX  INTEGER*4 ILX,IDECPL.*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 n CALL RDDK(2,NDCK) n IDECP2=ISDEC(2) nC n CALL EXAL(ADEC(IDECP2),IDECP2,NAM) n CALL EXAL(ADEC(IDECP2),IDECP2,DATD) n IDECP2=IDECP2+1 n CALL EXIN(IDECP2,NMD,1) n IDECP2=IDECP2+NMD zn IDECPT=IDECP2 n100 CONTINUE n ILX=IDECP2  CALL EXIN(IDECP2,IDD,5) an CALL EXIN(IDECP2,IDD(1),5) n IF(LNX.EQ.0) GOTO 9000 n IF(IDEL.NE.0) GOTO 800 n IDECP2=IDECP2+NMR ! LENA=(ILX+LNX-IDECP2)*NCHRWD un NBLK=0 un DO 120 LB=NCHRWD,2,-1 un IF(ADEC(ILX+LNX-1)(LB:LB).NE.' ') GOTO 130 un NBLK=NBLK+1 un120 CONTINUEun130 LENA = (ILX+LNX-IDECP2)*NCHRWD-NBLK " CALL COMCHC(ADEC(IDECP2),LENA,ICOM) -n 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 onC Insure that imbedded directives get written on compile file onC if switches are set onC - IF((ICC).AND.(ISETIF.EQ.0.OR.(ITD.EQ.9.OR.ITD.EQ.11))) THEN o IF( ICC .AND. (ISETIF.EQ.0 .AND. (ITD.EQ.0 .OR. ICCD) ) ) THEN p IF(ICC .AND. (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) THEN tn IF(.NOT.ICC) GOTO 800 tn IF( (ICCD .AND. (ITD.EQ.9.OR.ITD.EQ.11)) .OR. tn 1 (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) THEN $n IF(IDK.EQ.0) THEN %n DCK=NAM &n ELSE 'n DCK=MODNA(IDK) (n ENDIF) CALL LISCOM(ADEC(IDECP2),LENA,DCK,ISQ) d n CALL LISCRD(ITD,IL,IAC,DCK,ISQ,ADEC(IDECP2),LENA) -n ENDIF *n800 CONTINUE +n IDECP2=ILX+LNX zn*IF SMALL zn IDECPT=IDECPT+LNX zn IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENzn IDECP2=IDECP2-NWRDBK zn CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) zn CALL RDNEXR(2) zn ENDIF z n*ENDIF ,n GOTO 100 -n9000 CONTINUE-nC -nC ADD DUMMY RECORD TO SHOW END OF CALL -nC - IF(ICC.AND.(ISETIF.EQ.0)) THEN o IF(ICC .AND. ICCD .AND. (ISETIF.EQ.0)) THEN pn IF(ICC .AND. ICCD .AND. ISETIF) THEN-  CALL LISCOM('*END '//NAM,14,'........',0) d n CALL LISCRD(1,IL,IAC,'........',0,'*END '//NAM,14) - n ENDIF C C NCDKP - current number of common decks nested  NCDKP = 0  ICDECC = ICDECK 10 LDECKC = DECK(ICDECC) m NDKMEM = NDKMEM + 1 m CALL RDDK(ICDECC) m IDECPL=MEMSTR(NDKMEM) mC  IF(NCDKP.GT.9) THEN  CALL WRTIO(' Common decks nested too deep - max=9')  CALL THEEND(2,' Common decks nested too deep max=9')  ENDIF NCDKP = NCDKP + 1 NESTD(NCDKP) = ICDECC  CALL RDDK('U', ICDECC, ILCDK, NCDKP) IDECPL=MEMSTU(ILCDK) CALL EXAL(ADEC(IDECPL),IDECPL,NAM)  CALL EXAL(ADEC(IDECPL),IDECPL,DATD)  IDECPL=IDECPL+1  CALL EXIN(IDECPL,NMD,1)  IDECPL=IDECPL+NMD C 100 CONTINUE ILX = IDECPL! CALL EXIN(IDECPL,IDD(1),5) "C # IF(LNX.EQ.0) GOTO 900 $C % IF(ICC .AND. (IDEL .EQ. 0) ) THEN & IDECPL=IDECPL+NMR ' NBLK=0 ( DO 120 LB=NCHRWD,2,-1) IF(ADEC(ILX+LNX-1)(LB:LB).NE.' ') GOTO 130 * NBLK=NBLK+1 +120 CONTINUE ,130 LENA = (ILX+LNX-IDECPL)*NCHRWD-NBLK - ITD = 0 . ISET = ISETIF/ IF(ADEC(IDECPL)(1:1).EQ.PRFX) THEN 0 CALL DIRCHK(ADEC(IDECPL),LENA,ITD) 1 IF(ITD.NE.0) THEN 2 CALL COMCHK(ITD, ADEC(IDECPL), LENA, LDECKC, 3 1 ICDECN, DNAMEC, GNAMEC,COUNT) 4 ISET = ISET .OR. ISETIF 5 ENDIF 6 ENDIF7C 8 IF( ISET .AND. (ITD .EQ. 0 .OR. ICCD .OR. ITD .EQ. 20 )) THEN 9 IF (COUNT) THEN : NRECCF = NRECCF + 1 ; ELSE < IF(IDK.EQ.0) THEN = DCK=LDECKC > ELSE ? DCK=MODNA(IDK) @ ENDIF A CALL LISCRD(ITD,IL,IAC,DCK,ISQ,ADEC(IDECPL),LENA) B ENDIF C ENDIF D ENDIF EC F IF (ISETIF) THENGC H IF(ITD .EQ. 21 .AND. ICDECN .GT. 0) THEN I CALL INSGRP (ICDECN, DNAMEC, GNAMEC, ADEC(IDECPL), LENA, Jm 1 LDECKC, COUNT, NRECCF) 1 LDECKC, COUNT, NRECCF, NCDKP+1) K ELSEIF(ITD .EQ. 3 .AND. ICDECN .GT. 0) THEN L ICDECC = ICDECN Mm MEMCUR(NDKMEM) = ILX + LNX MEMCUU(ILCDK) = ILX + LNX N GOTO 10 O ENDIF P ENDIF Q IDECPL = ILX + LNX *IF SMALL  IF (IDECPL .GE. MEMSTU(ILCDK) + NWRDBK) THEN IDECPL = IDECPL - NWRDBK  CALL TRDEC (MEMSTU(ILCDK) + NWRDBK, MEMSTU(ILCDK),NWRDBK) CALL RDNEXR ('U', ILCDK)  ENDIF *ENDIF SMALL R GOTO 100SC TC end of deck - add dummy record UC V900 CONTINUE W IF(ISETIF .AND. ICCD) THEN X IF(COUNT) THEN Y NRECCF=NRECCF+1 Z ELSE[ CALL LISCRD(1,IL,IAC,'........',0,\h 1 '*END '//LDECKC,14) 1 PRFX//'END '//LDECKC,14) ] ENDIF ^ ENDIF _C `m NDKMEM = NDKMEM - 1 am IF(NDKMEM.GT.1) THENbm IDECPL = MEMCUR(NDKMEM) cm ICDECC = MEMDCK(NDKMEM) dm LDECKC = DECK(ICDECC) em GOTO 100 fm ENDIF  NCDKP = NCDKP - 1 l IF(NCDKP.GT.1) THEN  IF(NCDKP.GT.0) THEN  ICDECC = NESTD(NCDKP)  DO 1100 I = 1, NDKMEU IF(MEMDCU(I).EQ.ICDECC) GOTO 1200 1100 CONTINUE  CALL WRTIO(' **ERROR** Program error in INSCOM')  CALL THEEND(2,' PROGRAM ERROR IN INSCOM') 1200 ILCDK = I IDECPL = MEMCUU(ILCDK)  LDECKC = DECK (ICDECC)  GOTO 100  ENDIF . RETURN / END INSGRL 11/19/84  SUBROUTINE INSGRL(NDCK,DNAME,GNAME,ALF,NRECCF) C C Count the number of compile file records to be written C from a *CALLG directive C (derived from INSGRP) *IF NUMREC C C NDCK - deck number  C NRECCF - number of records to be written to compile file C  *CA PARAMA  *CA DECA *CA DECKS *CA LOGU*CA MODNA *CA IFSWI *CA CONTRL *CA SCANC C DNAME - deck name C GNAME - group name (start of group if blank)C ALF - record calling group  CHARACTER*8 DNAME, GNAME  CHARACTER*(*) ALF  CHARACTER*8 NAM,DATD  CHARACTER*8 DCK C  LOGICAL FOUND C  DIMENSION IDD(5) EQUIVALENCE(LNX,IDD(1)),(IDK,IDD(2)),(ISQ,IDD(3))  1 ,(IDEL,IDD(4)),(NMR,IDD(5))  DATA NDCKL /0/  DATA NAM /' '/ C !C "C IDECPS - start location of first record #C $C FOUND %C - TRUE - inserting a group &C - FALSE- looking for a group'C (*IF I4 ) INTEGER*4 ILX,IDECPS**ENDIF I4 +C ,C -C If there is no name it means to do the starting records.C / IF(GNAME .EQ. ' ') THEN 0 FOUND = .TRUE. 1 ELSE 2 FOUND = .FALSE. 3 ENDIF 4C 5 IDECP2 = ISDEC(2) 6 CALL EXAL(ADEC(IDECP2),IDECP2,NAM) 7C 8r IF(NAM.NE.DNAME) THEN  IF(DNAME.NE.NAM.OR.NDCK.NE.NDCKL) THEN  NDCKL=NDCK 9 CALL RDDK(2,NDCK) : IDECP2 = ISDEC(2); CALL EXAL(ADEC(IDECP2),IDECP2,NAM) < CALL EXAL(ADEC(IDECP2),IDECP2,DATD) = IDECP2 = IDECP2+1> CALL EXIN(IDECP2,NMD,1) ? IDECPS = IDECP2+NMD @ ENDIF AC B IDECPT = IDECPS C IDECP2 = IDECPT DC E100 CONTINUE F ILX = IDECP2G CALL EXIN(IDECP2,IDD(1),5) H IF(LNX.EQ.0) GOTO 9000 I IF(IDEL.NE.0) GOTO 800 J IDECP2 = IDECP2+NMR K LENA = (ILX+LNX-IDECP2)*NCHRWD LC Mr CALL COMCHL(ADEC(IDECP2),LENA,ITD,NRECCF)  CALL COMCHD(ADEC(IDECP2),LENA,ITD) NC O IF(.NOT.FOUND) THEN P IF(ITD.NE.22) GOTO 800 Q IEQU = ICKGRP(GNAME,ADEC(IDECP2),LENA) R IF(IEQU.EQ.0) GOTO 800 S FOUND = .TRUE. T ELSE U IF(ITD.EQ.22) GOTO 9000 V ENDIF WC XC Insure that imbedded directives get written on compile file YC if switches are set ZC [ IF(.NOT.ICC) GOTO 800 \ IF( (ICCD .AND. (ITD.EQ.9.OR.ITD.EQ.11)) .OR. ] 1 (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) NRECCF=NRECCF+1 ^800 CONTINUE _ IDECP2 = ILX+LNX ` GOTO 100aC b9000 CONTINUEcC d IF( FOUND) THEN e IF(ICC.AND.ICCD.AND.ISETIF) NRECCF = NRECCF+1 f ENDIF gC h*ENDIF NUMREC i RETURN j END , GOTO 10 -INSGRP 8/28/84z SUBROUTINE INSGRP(NDCK,DNAME,GNAME,ALF) n SUBROUTINE INSGRP(NDCK,DNAME,GNAME,ALF,LDECK) nC nC processes *CALLG directive nC Copies a GROUP from a common deck into a deck nC nC NDCK - deck number  SUBROUTINE INSGRP(NDCK, DNAME, GNAME, m 1 ALF, LENALF, LDECK, COUNT, NRECCF)  1 ALF, LENALF, LDECK, COUNT, NRECCF, LCALL) C C processes *CALLG directive C Copies a GROUP from a common deck into a deck C C ICDECK - deck number C DNAME - name of deck C GNAME - group name C ALF - calling record C LENALF - length (characters) of calling record  C LDECK - name of calling deck C COUNT - switch for counting only TRUE = YES C NRECCF - number of records counted C *CA PARAMA *CA DECA *CA DECKS  *CA LOGU *CA MODNA  *CA IFSWI  *CA CONTRL *CA ERRMES *CA SCAN*CALL PRFX C nC DNAME - deck name nC GNAME - group name (start of group if blank)nC ALF - record calling group z CHARACTER*8 DNAME, GNAME CHARACTER*8 DNAME, GNAME, LDECK n CHARACTER*(*) ALF  CHARACTER*(MAXWID) ALF  CHARACTER*8 NAM,DATD  CHARACTER*8 DCK  CHARACTER*8 DNAMEC, GNAMEC, LDECKC  LOGICAL COUNT C  LOGICAL FOUND C  DIMENSION IDD(5) EQUIVALENCE(LNX,IDD(1)),(IDK,IDD(2)),(ISQ,IDD(3))  1 ,(IDEL,IDD(4)),(NMR,IDD(5)) C nC IDECPS - start location of first record  C !C FOUND "C - TRUE - inserting a group #C - FALSE- looking for a group$C %*IF I4 &n INTEGER*4 ILX,IDECPS  INTEGER*4 ILX,IDECPL'*ENDIF I4 (C )C IL- Logical array for LISCRD to turn on compile only *C + LOGICAL IL(3) , DATA IL /.FALSE. , .TRUE. , .FALSE./-C IAC = 1 (Indicates active record - for LISCRD . DATA IAC /1//C  DATA NDCKL /0/  DATA NAM /' '/ C 0C If there is no name it means to do the starting records1C 2 IF(GNAME .EQ. ' ') THEN 3 FOUND = .TRUE. 4 ELSE 5 FOUND = .FALSE. 6 ENDIF 7C m NDKMEM = NDKMEM + 1 mC mC we will check and see if this deck is the same one as last time mC if so we wont read it inmC 8n IDECP2=ISDEC(2) m IDECPL=MEMSTR(NDKMEM) 9n CALL EXAL(ADEC(IDECP2),IDECP2,NAM) m CALL EXAL(ADEC(IDECPL),IDECPL,NAM) :mC ;n*IF SMALL <n NAM=' ' =n*ENDIF SMALL>r IF(NAM.NE.DNAME) THEN m IF(DNAME.NE.NAM.OR.NDCK.NE.NDCKL) THEN m NDCKL=NDCK ?n CALL RDDK(2,NDCK) m CALL RDDK(NDCK) m ENDIF @n IDECP2=ISDEC(2) m IDECPL=MEMSTR(NDKMEM)  CALL RDDK('U', NDCK, ILDECK, LCALL)  IDECPL=MEMSTU(ILDECK) An CALL EXAL(ADEC(IDECP2),IDECP2,NAM)  CALL EXAL(ADEC(IDECPL),IDECPL,NAM) Bn CALL EXAL(ADEC(IDECP2),IDECP2,DATD)  CALL EXAL(ADEC(IDECPL),IDECPL,DATD) Cn IDECP2=IDECP2+1 ! IDECPL=IDECPL+1 Dn CALL EXIN(IDECP2,NMD,1) " CALL EXIN(IDECPL,NMD,1) En IDECPS=IDECP2+NMD # IDECPL=IDECPL+NMD Fn ENDIF $ ILX = IDECPLGC Hn IDECPT=IDECPS In IDECP2=IDECPT JC K100 CONTINUE Ln ILX=IDECP2 % IDECPL = ILXMn CALL EXIN(IDECP2,IDD(1),5) & CALL EXIN(IDECPL,IDD(1),5) N IF(LNX.EQ.0) GOTO 9000 O IF(IDEL.NE.0) GOTO 800 Pn IDECP2=IDECP2+NMR ' IDECPL=IDECPL+NMR Q NBLK=0 R DO 120 LB=NCHRWD,2,-1 S IF(ADEC(ILX+LNX-1)(LB:LB).NE.' ') GOTO 130 T NBLK=NBLK+1 U120 CONTINUEVn130 LENA = (ILX+LNX-IDECP2)*NCHRWD-NBLK (130 LENA = (ILX+LNX-IDECPL)*NCHRWD-NBLK WC Xn CALL COMCHC(ADEC(IDECP2),LENA,ITD) ) ITD=0 * IF(ADEC(IDECPL)(1:1).EQ.PRFX) THEN + CALL DIRCHK(ADEC(IDECPL),LENA,ITD) , ENDIF YC Z IF(.NOT.FOUND) THEN [ IF(ITD.NE.22) GOTO 800 \n IEQU = ICKGRP(GNAME,ADEC(IDECP2),LENA) - IEQU = ICKGRP(GNAME,ADEC(IDECPL),LENA) ] IF(IEQU.EQ.0) GOTO 800 ^ FOUND = .TRUE. _ ELSE ` IF(ITD.EQ.22) GOTO 9000 a ENDIF bC cnC Insure that imbedded directives get written on compile file dnC if switches are set enC fn IF(.NOT.ICC) GOTO 800 gn IF( (ICCD .AND. (ITD.EQ.9.OR.ITD.EQ.11)) .OR. hn 1 (ISETIF.AND.(ITD.EQ.0.OR.ICCD)) ) THEN in IF(IDK.EQ.0) THEN jn DCK=NAM kn ELSE ln DCK=MODNA(IDK) mn ENDIFnn CALL LISCRD(ITD,IL,IAC,DCK,ISQ,ADEC(IDECP2),LENA) on ENDIF pn800 CONTINUE qn IDECP2=ILX+LNX rn*IF SMALL sn IDECPT=IDECPT+LNX tn IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENun IDECP2=IDECP2-NWRDBK vn CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) wn CALL RDNEXR(2) xn ENDIF yn*ENDIF SMALL zn GOTO 100{nC |n9000 CONTINUE}nC ~x IF(.NOT.FOUND) THEN n IF( FOUND) THEN n IF(ICC.AND.ICCD.AND.ISETIF) THEN n CALL LISCRD(1,IL,IAC,'........',0,n 1 '*END '//DNAME//' '//GNAME,24) n ENDIF n ELSE n ERRMSG = '*CALLG group '//GNAME//' not found in common deck 'z 1 //DNAME//' for following record'n 1 //DNAME//' for following record (deck '//LDECK//')' n CALL WRERR n ERRMSG = ALF n CALL WRERR .C Insure that imbedded directives get written on compile file /C if switches are set 0C 1 IF(.NOT.ICC) GOTO 800 2e IF( ISETIF .AND. (ITD.EQ.0.OR.ICCD) ) THEN  IF( ISETIF.AND.(ITD.EQ.0.OR.ICCD) .OR.  $ (ITD.EQ.9.AND.ICCD).AND..NOT.ISETIF) THEN 3 IF (COUNT) THEN 4 NRECCF=NRECCF+1 5 ELSE 6 IF(IDK.EQ.0) THEN 7 DCK=NAM 8 ELSE 9 DCK=MODNA(IDK) : ENDIF ; CALL LISCRD(ITD,IL,IAC,DCK,ISQ,ADEC(IDECPL),LENA) < ENDIF = ENDIF >800 CONTINUE ? ILX = ILX + LNX *IF SMALL  IF (ILX .GE. MEMSTU(ILDECK) + NWRDBK) THEN  ILX = ILX - NWRDBK  CALL TRDEC (MEMSTU(ILDECK) + NWRDBK, MEMSTU(ILDECK),NWRDBK)  CALL RDNEXR ('U', ILDECK)  ENDIF *ENDIF SMALL@C Ae IF (.NOT.ISETIF) GOTO 100  IF (.NOT.ISETIF .AND. ITD.NE.9) GOTO 100 B IF(ITD.NE.0) THEN C CALL COMCHK(ITD, ADEC(IDECPL), LENA, LDECKC, D 1 ICDECN, DNAMEC, GNAMEC,COUNT) E ENDIF F GOTO 100GC H9000 CONTINUEIC J IF( FOUND) THEN K IF(ISETIF .AND. (ICC.AND.ICCD) ) THEN L IF(COUNT) THEN M NRECCF=NRECCF+1 N ELSE O CALL LISCRD(1,IL,IAC,'........',0, Ph 1 '*END '//DNAME//' '//GNAME,24)  1 PRFX//'END '//DNAME//' '//GNAME,24) Q ENDIF R ENDIF S ELSEIF(.NOT.COUNT) THENTh ERRMSG = '*CALLG group '//GNAME//' not found in common deck ' ERRMSG = 'Called group '//GNAME//' not found in common deck' U 1 //DNAME//' for following record (deck '//LDECK//')' V CALL WRERR W ERRMSG = ALF(1:LENALF) X CALL WRERR ENDIF YC Zm NDKMEM = NDKMEM - 1 C RETURN  END ITRAIL 7/26/84 INTEGER FUNCTION ITRAIL(STRING)  CHARACTER STRING*(*) DO 10 I = LEN(STRING),1,-1  IF (STRING(I:I) .NE. ' ') GOTO 20  10 CONTINUE  I = 1  20 ITRAIL = I  RETURN  END *CALL FILEIDS  *CALL LOGU 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/82 redRP=/ 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 dn*CA LANGC r*CA CPLDIR r*CA ERRMES C  LOGICAL IL(3)  CHARACTER*8 DCK  CHARACTER*8 NAMSEQ  CHARACTER*(132) A R CHARACTER*(MAXWID) Ad CHARACTER*(MAXWID) TEMPA r CHARACTER*(MAXWID) X 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) r WRITE(ERRMSG,111) ITX(IT),DCK,NSQ,A(1:LENA) "111 FORMAT(1X,A8,A8,I5,1X,A) r CALL WROUT # ENDIF rC r IF(IL(3)) THEN r WRITE(LSO,113) A(1:LENA) r 113 FORMAT(A) r ENDIF r C $C % IF(IL(2)) THEN r IF(ITDIR .EQ. 20 ) THEN r C *VL OR VLEVEL directive - processrC r CALL PVLEVL(A(1:LENA),X,LENX) r IF(LSEQC.EQ.1) THEN r LENDU = MWIDE-LENX r IF(LENDU.GT.0) THENr WRITE(LCO,115) X(1:LENX),DUMT(1:LENDU),DCK,NSQ r ELSE r WRITE(LCO,117) X(1:LENX),DCK,NSQ r ENDIF rC r ELSE IF(LSEQC.EQ.2) THEN r CALL COMPID(DCK,NSQ,NAMSEQ)r LENDU = MWIDE-LENX r IF(LENDU.GT.0) THENr WRITE(LCO,115) X(1:LENX),DUMT(1:LENDU),NAMSEQ r ELSE r WRITE(LCO,115) X(1:LENX),NAMSEQ r ENDIF r ELSE r! WRITE(LCO,115) X(1:LENX) r" ENDIF & 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 r# ELSE IF(ITDIR.EQ.0.OR.NCPLDI.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 r$C **** directive - and insert characters d!C d" TEMPA(1:MWIDE)=SP5//A(1:LENA)//DUMT e TEMPA(1:MWIDE)=SP6//A(1:LENA)//DUMT r% X(1:MWIDE)=CPLDI(1:NCPLDI)//A(1:LENA)//DUMT d# IF(LSEQC.EQ.1) THEN d$ WRITE(LCO,117) TEMPA(1:MWIDE),DCK,NSQ r& WRITE(LCO,117) X(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 r' WRITE(LCO,115) X(1:MWIDE),NAMSEQ d) ELSE d* WRITE(LCO,115) TEMPA(1:LENA+5) r( WRITE(LCO,115) X(1:LENA+NCPLDI) 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 FORMAT(' Pre-processing ',A) r ERRMSG='Pre-processing '//BUF(1:IWID) r LISDCK 3/22/82 zutrpoda[E/.-,*n SUBROUTINE LISDCK(NDECK) SUBROUTINE LISDCK(NDECK,COUNT,NRECCF,NRECSF)C nC MAKES ALL LISTS OF DECK REQUESTED C makes all lists for one deck C C NDECK - Deck number C COUNT - switch for counting only TRUE = yesC NRECCF - count of records for compile file C NRECSF - count of records for source file C *CA PARAMA *CA DECKS *CA DECA*CA IFSWI  *CA MODNA  *CA CONTRL  *CA PRFXr*CALL ERRMES*CALL SEPFIC*CALL FNAMES*CALL SEPCOM z CHARACTER*8 DCK,NAM,DATDn CHARACTER*8 DCK,NAM,DATD,LDECK  LOGICAL COUNT  CHARACTER*8 DCK,NAM,DATD,LDECK  C CHARACTER*8 DNAME, GNAME  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 ISET  LOGICAL ILA C .*IF I4 n INTEGER*4 ILX INTEGER*4 ILX, IDECPL .*ENDIF uC u CALL RDDK(1,NDECK) C  CHARACTER*72 NAMTMP  CHARACTER*72 DUMREC  LOGICAL ILT(3) C  DATA ILT /.FALSE.,.TRUE.,.FALSE./  LDECK=DECK(NDECK) - NIFS=0 * ISETIF=0 p ISETIF = .TRUE. n IDECP1=1n CALL EXAL(ADEC(IDECP1),IDECP1,NAM) n CALL EXAL(ADEC(IDECP1),IDECP1,DATD) n IDECP1=IDECP1+1 n CALL EXIN(IDECP1,NMD,1)  IF(NMD.GT.0) THEN  CALL EXIN(IDECP1,IMD,NMD)  ENDIF [n IDECP1=IDECP1+NMD zn IDECPT=IDECP1 m IDECPL=MEMSTR(NDKMEM) IDECPL=MEMSTL(1) CALL EXAL(ADEC(IDECPL), IDECPL, NAM) CALL EXAL(ADEC(IDECPL), IDECPL, DATD)  IDECPL=IDECPL+1  CALL EXIN(IDECPL, NMD, 1)  IDECPL=IDECPL+NMD C 100 CONTINUEC n ILX=IDECP1   CALL EXIN(IDECP1,IRD,5) an CALL EXIN(IDECP1,IRD(1),5)  ILX=IDECPL  CALL EXIN(IDECPL,IRD(1),5) ! IF(LNX.EQ.0) GOTO 2000 [n IDECP1=IDECP1+NMR  IDECPL=IDECPL+NMR [ LENA = (ILX+LNX-IDECP1)*NCHRWD u NBLK=0 u DO 120 LB=NCHRWD,2,-1 u IF(ADEC(ILX+LNX-1)(LB:LB).NE.' ') GOTO 130 u NBLK=NBLK+1 u120 CONTINUEun130 LENA = (ILX+LNX-IDECP1)*NCHRWD-NBLK 130 LENA = (ILX+LNX-IDECPL)*NCHRWD-NBLK " 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 [n ITDIR=0  ITD = 0 [ IL(2)=.FALSE. [n IF(ICC.AND.(IDEL.EQ.0.AND.ITYPE(NDECK).EQ.0)) THEN [n IF(ADEC(IDECP1)(1:1).EQ.PRFX) THEN [n CALL DIRCHK(ADEC(IDECP1),LENA,ITDIR) [ n 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. [  ENDIFopC Force *IF and *ENDIF to compile file if switches seto IF( ISETIF.EQ.0 .AND. (ITDIR.EQ.0 .OR. ICCD) ) THEN p IF(ISETIF .AND. (ITDIR.EQ.0 .OR. ICCD) ) THENt} IF( (ICCD .AND. (ITDIR.EQ.9.OR.ITDIR.EQ.11)) .OR.p IF( (ICCD .AND. (ITDIR .EQ. 9 .OR. ITDIR .EQ. 11 .OR.p 1 ITDIR .EQ. 21 .OR. ITDIR .EQ.22 )) t} 1 (ISETIF.AND.(ITDIR.EQ.0.OR.ICCD)) ) THENp 1 .OR. (ISETIF.AND.(ITDIR.EQ.0.OR.ICCD)) ) THEN nC nC send imbedded directives to compile file if ISETIFnC and ICCD or a *VLEVEL (20) n IF ( ISETIF .AND.n 1 (ITDIR.EQ.0 .OR. ITDIR.EQ.20 .OR. ICCD)) THEN on IL(2)=.TRUE. C l IF(ICC.AND. (IDEL.EQ.0) ) THEN  IF(ICC .AND. (IDEL.EQ.0) .AND.  1 (ITYPE(NDECK) .EQ. 0 .OR. SCOMPF) ) THEN  ISET = ISETIF IF(ADEC(IDECPL)(1:1).EQ.PRFX) THEN  CALL DIRCHK(ADEC(IDECPL),LENA,ITD)C  IF( ITD .NE. 0) THEN  CALL COMCHK(ITD,ADEC(IDECPL),LENA,LDECK, ! 1 ICDECK,DNAME,GNAME,COUNT) " ISET = ISET .OR. ISETIF # ENDIF $ ENDIF%C & IF( ISET .AND. (ITD.EQ.0.OR.ICCD.OR.ITD.EQ.20)) THEN ' IL(2)=.TRUE. o 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) THENp IF( IL(1) .OR. IL(2) .OR. IL(3) ) THEN [n IF(IDK.EQ.0) THEN[n DCK = DECK(NDECK) [n ELSE [n DCK = MODNA(IDK) [n ENDIFN CALL LISCRD(IL,IT,DCK,NSQ,ADEC(IDECP1),LENA) dn CALL LISCRD(ITDIR,IL,IT,DCK,NSQ,ADEC(IDECP1),LENA) On 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) THENu IF(ITDIR .EQ. 3 .OR. ITDIR .EQ. 9 .OR. ITDIR .EQ. 11n IF( (ISETIF.AND.(ITDIR .EQ.3.OR.ITDIR.EQ.21)) .OR. u 1 .OR. ITDIR .EQ. 21 .OR. ITDIR .EQ. 22 ) THENn 1 ITDIR.EQ. 9 .OR. ITDIR .EQ. 11 .OR. ITDIR .EQ. 22 ) THEN Q CALL COMCHK(ADEC(IDECP1),LENA) dz CALL COMCHK(ITDIR,ADEC(IDECP1),LENA) n CALL COMCHK(ITDIR,ADEC(IDECP1),LENA,LDECK) Rn ENDIF Sn IDECP1=ILX+LNX zn*IF SMALL zn IDECPT=IDECPT+LNX zn IF(IDECP1.GT.NWRDBK) THEN zn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,NWRDBK) zn CALL RDNEXR(1) zn ENDIF z n*ENDIF ( IF(COUNT) THEN ) IF(IL(2)) NRECCF=NRECCF+1 * IF(IL(3)) NRECSF=NRECSF+1 + ELSE , IF(IDK.EQ.0) THEN - DCK = LDECK . ELSE / DCK = MODNA(IDK) 0 ENDIF 1 CALL LISCRD(ITD,IL,IT,DCK,NSQ,ADEC(IDECPL),LENA) 2 ENDIF3mC 4m IF(ITD .EQ. 3 .AND. ICDECK .GT. 0) THEN 5m CALL INSCOM (ICDECK, DNAME, COUNT, NRECCF)6m ELSE IF(ITD .EQ. 21 .AND. ICDECK .GT. 0) THEN 7m CALL INSGRP (ICDECK, DNAME, GNAME, ADEC(IDECPL), LENA,8m 1 LDECK, COUNT, NRECCF) 9m ENDIF ENDIF  C  IF(ISET.AND.ICDECK.GT.0.AND.(ITD.EQ.3.OR.ITD.EQ.21)) THEN IF(SCALLF) THEN  IF(COUNT) THEN IF(INCLDD(ICDECK).NE.-NDECK)THEN  NRECCF = NRECCF + 1  INCLDD(ICDECK) = -NDECK  ENDIF  ELSE  IF(INCLDD(ICDECK).NE.NDECK) THEN  INCLDD(ICDECK) = NDECK  CALL FILEID(NAMLCO(1:IWLCO),NAMTMP,DECK(ICDECK)) IWTMP = ITRAIL(NAMTMP) *IF VAX  DUMREC=' INCLUDE '''//NAMTMP(1:IWTMP)//''''*ENDIF VAX *IF IBM  DUMREC=' INCLUDE ('//NAMTMP(1:IWTMP)//')' *ENDIF IBM *IF PRIME  DUMREC=' $INSERT '//NAMTMP(1:IWTMP) *ENDIF PRIME! IWTMP=ITRAIL(DUMREC)" CALL LISCRD(0,ILT,1,'........',0,DUMREC,IWTMP) # ENDIF $ ENDIF % ELSE& IF(ITD .EQ. 3 ) THEN ' CALL INSCOM (ICDECK, DNAME, COUNT, NRECCF) ( ELSE ) CALL INSGRP (ICDECK, DNAME, GNAME, ADEC(IDECPL), * 1 LENA, LDECK, COUNT, NRECCF, 1) + ENDIF , ENDIF-C . ICDECK = 0 : ENDIF ; IDECPL = ILX + LNX *IF SMALL  IF (IDECPL .GE. MEMSTL(1) + NWRDBK) THEN IDECPL = IDECPL - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1),NWRDBK)  CALL RDNEXR ('L', 1)  ENDIF *ENDIF SMALL T GOTO 100UC V2000 CONTINUE r IF( NIFS.NE.0) THEN rz ERRMSG='**ERROR** Deck '//NAM//  ERRMSG='**ERROR** Deck '//LDECK//r 1 ' has mismatched *IF/*ENDIF directives.' r CALL WRERR r ENDIF W RETURN X END =0 r,u CPLDI=' ' r-u ENDIF  ENDIF @ ENDIF @C @ IDECE = IFINDK(EDECK) @C @ IF(IDECE.EQ.0) THEN LISERR 11/05/82nmj SUBROUTINE LISERR (IN) n SUBROUTINE LISERR (IDIR)C C Print record (normally because of error) on output file C and terminal nC Print directive record (normally due to error) nC nC IDIR - Directive number C *CALL PARAMA *CALL LOGU j*CA ERRMES *CALL BUFA m*CA INREC  C  CALL GETBUF(IN,IL)  PRINT11,BUF(1:IL)   WRITE(LOU,11) BUF(1:IL)  11 FORMAT(' Record - ',A) j ERRMSG=' Record - '//BUF(1:IL) m WRITE(ERRMSG,11) INRNO(IN) n WRITE(ERRMSG,11) INRNO(IDIR)m11 FORMAT(' (Input record number',I6,') -') m CALL WRERR mC n CALL GETBUF(INLOC(IDIR),IL) m ERRMSG=' '//BUF(1:IL) j CALL WRERR  RETURN  END ICOM=IEDIT(IDK)  ELSE  ICOM=0 LISLEN 11/19/84  SUBROUTINE LISLEN(NDECK,NRECCF,NRECSF) C C Counts the number of records for the compile and source filesC (Deck NDECK must already be in memory) C (derived from LISDCK) *IF NUMREC C NRECCF - number of records for compile file C NRECSF - number of records for source file  C  *CA PARAMA  *CA DECKS  *CA DECA *CA IFSWI *CA CONTRL *CA PRFX  CHARACTER*8 NAM,DATD  DIMENSION IRD(5) EQUIVALENCE(LNX,IRD(1)),(IDK,IRD(2)),(NSQ,IRD(3)),  1 (IDEL,IRD(4)),(NMR,IRD(5)) C  LOGICAL IL(3) C *IF I4  INTEGER*4 ILX *ENDIF I4 C  NRECCF = 0  NRECSF = 1 C  NIFS = 0  ISETIF = .TRUE. IDECP1 = 1 ! CALL EXAL(ADEC(IDECP1),IDECP1,NAM) " CALL EXAL(ADEC(IDECP1),IDECP1,DATD) # IDECP1 = IDECP1+1 $ CALL EXIN(IDECP1,NMD,1) % IDECP1 = IDECP1+NMD & IDECPT = IDECP1 'C (100 CONTINUE)C * ILX = IDECP1+ CALL EXIN(IDECP1,IRD(1),5) , IF(LNX.EQ.0) GOTO 2000 - IDECP1 = IDECP1+NMR . LENA = (ILX+LNX-IDECP1)*NCHRWD /C 0 ITDIR = 0 1 IL(2) = .FALSE. 2 IF(ICC.AND.(IDEL.EQ.0.AND.ITYPE(NDECK).EQ.0)) THEN 3 IF(ADEC(IDECP1)(1:1).EQ.PRFX) THEN 4 CALL DIRCHK(ADEC(IDECP1),LENA,ITDIR) 5 ENDIF6pC Force *IF and *ENDIF to compile file if switches set7p IF( (ICCD .AND. (ITDIR .EQ. 9 .OR. ITDIR .EQ. 11 .OR.8p 1 ITDIR .EQ. 21 .OR. ITDIR .EQ.22 )) 9p 1 .OR. (ISETIF.AND.(ITDIR.EQ.0.OR.ICCD)) ) THEN C C send imbedded directives to compile file if ISETIFC and ICCD or a *VLEVEL (20)  IF ( ISETIF .AND. 1 (ITDIR.EQ.0 .OR. ITDIR.EQ.20 .OR. ICCD)) THEN : IL(2) = .TRUE. ; ENDIF < ENDIF = IF(ICS.AND.(IDEL.EQ.0)) THEN > IL(3) = .TRUE. ? ELSE @ IL(3) = .FALSE. A ENDIF BC C IF( IL(2)) NRECCF = NRECCF+1D IF( IL(3)) NRECSF = NRECSF+1EC F IF( (ISETIF.AND.(ITDIR .EQ.3.OR.ITDIR.EQ.21)) .OR. G 1 ITDIR.EQ. 9 .OR. ITDIR .EQ. 11 .OR. ITDIR .EQ. 22 ) THEN H CALL COMCHL(ITDIR,ADEC(IDECP1),LENA,NRECCF) I ENDIF J IDECP1 = ILX+LNX K GOTO 100LC M2000 CONTINUENC O*ENDIF NUMREC P RETURN Q END 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[ LISMOD 3/22/82rR SUBROUTINE LISMOD(IT,IRC,ALF,NCH) C C WRITES MODIFICATIONS ONTO OUTPUTC *CA PARAMA *CA DECKS *CA DECA*CA MODNA  *CA LOGUr*CA ERRMES  CHARACTER*132 ALF R CHARACTER*(MAXWID) ALF CHARACTER*8 ITP(3),NAM DIMENSION IRC(5)  DATA ITP /'ADD',' DEL','RESTORED'/r DATA ITP /'add',' del','restored'/C  IDK=IRC(2)  NSQ=IRC(3)  IF(IDK.EQ.0) THEN j IDU=1j CALL EXAL(ADEC(1),IDU,NAM)  NAM = ' '  ELSE  NAM=MODNA(IDK)  ENDIF C  WRITE(LOU,111)ITP(IT),NAM,NSQ,ALF(1:NCH)r WRITE(ERRMSG,111)ITP(IT),NAM,NSQ,ALF(1:NCH)  CALL LININC(1) r CALL WROUT 111 FORMAT(1X,A,1X,A,I5,2X,A)  RETURN  END LOCCNT 11/19/84  SUBROUTINE LOCCNT (ITP,NDECK,LOC1,LOC2,ALF,NW) C C Locate record(s) refered to by directive C NW directive words are in ALF *IF EDITC C ITP - type of directive C 7=DELETE C 12=INSERT C NDECK - deck number C LOC1 - Location of first ID on record  C LOC2 - Location of second ID on record  C *CALL PARAMA*CALL DECKS *CALL DECI *CALL ERRMES*CALL EDITCOC  CHARACTER*8 ALF(NW)  DIMENSION IDEK(2),ICRD(2),LOCC(2)  DIMENSION IERR(2) *IF I4  INTEGER*4 LOCC  INTEGER*4 IL,ILM*ENDIF C  NDF=0  IW=2  IERR(1)=9  IERR(2)=9 100 NDF=NDF+1 ! IF(IW.GE.NW) GOTO 160 " IF(ALF(IW+1).NE.'.') GOTO 160  IF(IW+2 .GT. NW) GOTO 310 # ICRD(NDF)=RVAL(ALF(IW+2)) $ IF(ICRD(NDF).EQ.0) GOTO 310 % IF(ALF(IW).EQ.DECK(NDECK)) THEN & IDEK(NDF)=0 ' ELSE ( IDEK(NDF)=IFINMD(ALF(IW))) IF(IDEK(NDF).EQ.0) GOTO 310 * ENDIF + IW=IW+3 , GOTO 180-C .160 ICRD(NDF)=RVAL(ALF(IW)) /t IF(ICRD(NDF).EQ.0) GOTO 310 0t IDEK(NDF)=0  IF(ICRD(NDF).NE.0) GOTO 170  IF(NDF .GT. 1) GOTO 310  IF(ITP .NE. 12) GOTO 310 IF(ALF(IW)(1:2) .NE. '0 ') GOTO 310  IF(NW .GT. IW) GOTO 310 170 IDEK(NDF)=0 1 IW=IW+1 2180 IF(IW.LE.NW.AND.NDF.LT.2) GOTO 100 3C 4t LOCC(1)=0  LOCC(1)=-1 5 LOCC(2)=0 6 IERR(1) = 0 7 IERR(2) = 0 8 IREC=1 9 IL=IABS(IR(IREC)) : DO 300 NN=1,NDF ;200 LNX=IDEC(IL) < IF(LNX.EQ.0) GOTO 350 = NDK=IDEC(IL+1) > NSQ=IDEC(IL+2) ? IF(NDK.EQ.IDEK(NN)) THEN @ IF(NSQ.EQ.ICRD(NN)) THEN A IF (IDEC(IL+3).NE.0) THEN B IERR(NN)=2 C GOTO 300 D ENDIF E LOCC(NN)=IREC F GOTO 300 G ELSE Ht IF(NSQ.GT.ICRD(NN)) THEN It IERR(NN)=1 Jt GOTO 300 Kt ENDIF  IF(NSQ.GT.ICRD(NN)) THEN  IF(ICRD(NN).NE.0) THEN  IERR(NN)=1 GOTO 300 ENDIF  LOCC(NN)=0  GOTO 300  ENDIF L ENDIF M ENDIF N IREC=IREC+1 O IL=IABS(IR(IREC)) P GOTO 200 QC R300 CONTINUESC TC Check for errorUC V310 CONTINUEW IF(IERR(1)+IERR(2).EQ.0) THEN X LOC1=LOCC(1) Y LOC2=LOCC(2) Z RETURN [ ENDIF \C ]C Error ^C _350 WRITE(ERRMSG,351) IERR `351 FORMAT('*ERROR* unable to process the following directive', a 1 ' during continue processing',2I5) b CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) ct LOC1=0  LOC1 = -1 d LOC2=0 e*ENDIF EDIT f RETURN g END SEQ S ENDIF X ELSE IF(LAST.EQ.2) THEN X WRITE(LSO,111) LOCREC 3/22/82 znj_. SUBROUTINE LOCREC (NDECK,INPL,LOC1,LOC2)j SUBROUTINE LOCREC (ITP,NDECK,INPL,LOC1,LOC2)C C LOCATE RECORD POINTED TO BY DIRECTIVE RECORD INPL C jC ITP - type of directive jC 7=DELETE jC 12=INSERT jC 14=RESTORE 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 j*CALL ERRMESC  DIMENSION IDEK(2),ICRD(2),LOCC(2) .*IF I4  INTEGER*4 LOCC  INTEGER*4 IL,ISLOC,ILM .*ENDIF _ SAVE ISLOC zn*IF SMALL zn SAVE ICLOC, ILX *ENDIF SMALLzn*ENDIF  CHARACTER*8 ALF(20) C j CHARACTER*6 FIRSEC(2) j DATA FIRSEC /'FIRST','SECOND'/ j C  INL=INPL  CALL GTAWD(ALF,NW,INL)  IF(NW.LT.2) GOTO 500 j IF(NW.LT.2) THEN j WRITE(ERRMSG,51) j 51 FORMAT(' (LOCREC)- The following directive is improperly ', j 1 'formed - cannot identify record to access') j GOTO 520 j ENDIF  NDF=0  IW=2 100 NDF=NDF+1 t IF(IW.LT.NW.AND.ALF(IW+1).EQ.'.') THEN t IF(IW+2.GT.NW) GOTO 500 t ICRD(NDF)=RVAL(ALF(IW+2)) t IF(ICRD(NDF).EQ.0) GOTO 500 t IF(ALF(IW).EQ.DECK(NDECK)) THEN t IDEK(NDF)=0 t ELSEt IDEK(NDF)=IFINMD(ALF(IW))  t IF(IDEK(NDF).EQ.0) GOTO 500 !t ENDIF "t IW=IW+3 #t ELSE$t ICRD(NDF)=RVAL(ALF(IW)) %t IF(ICRD(NDF).EQ.0) GOTO 500 &t IDEK(NDF)=0 't IW=IW+1 (t ENDIF )t IF(IW.LE.NW.AND.NDF.LT.2) GOTO 100  IF(IW .GE. NW) GOTO 160  IF(ALF(IW+1) .NE. '.') GOTO 160  IF(IW+2 .GT. NW) GOTO 500  ICRD(NDF) = RVAL(ALF(IW+2))  IF(ICRD(NDF) .EQ. 0) GOTO 500 C  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  GOTO 180C 160 ICRD(NDF) = RVAL(ALF(IW))  IF(ICRD(NDF) .NE. 0) GOTO 170  IF(NDF .GT. 1) GOTO 500  IF(ITP .NE. 12) GOTO 500 IF(ALF(IW)(1:2) .NE. '0 ') GOTO 500  IF(NW .GT. IW) GOTO 500 170 IDEK(NDF) = 0  IW = IW + 1 180 IF(IW.LE.NW.AND.NDF.LT.2) GOTO 100 *C + LOCC(1)=0 , LOCC(2)=0 - IL=ISLOC zn*IF SMALL zn IL=ICLOC zn IPASS=0 *ENDIF SMALLzn*ENDIF . DO 300 N=1,NDF /200 LNX=IDEC(IL)0 IF(LNX.EQ.0) GOTO 500 j IF(LNX.EQ.0) GOTO 250 1 NDK=IDEC(IL+1) 2 NSQ=IDEC(IL+2) 3 IF(NDK.EQ.IDEK(N)) THEN 4 IF(NSQ.EQ.ICRD(N)) THEN j IF(ITP.EQ.14) THEN j IF(IDEC(IL+3).EQ.0) THEN j GOTO 270 j ENDIF jC j ELSE IF (IDEC(IL+3).NE.0) THEN j GOTO 280 j ENDIF 5 LOCC(N)=IL zn*IF SMALL z n LOCC(N)=LOCC(N)+ILX *ENDIF SMALLz n*ENDIF 6 GOTO 300 7 ELSE8 IF(NSQ.GT.ICRD(N)) GOTO 500 jt IF(NSQ.GT.ICRD(N)) GOTO 250  IF(NSQ.GT.ICRD(N)) THEN  IF(ICRD(N).NE.0) GOTO 250  LOCC(N)=ISLOC-1  GOTO 300  ENDIF 9 ENDIF : ENDIF ; IL=IL+LNX z n*IF SMALL z n IF(IL.GT.NWRDBK) THEN z n CALL TRDEC(NWRDBK+1,1,NWRDBK)  CALL RDNEXR('L',1) zn CALL RDNEXR(1) zn ILX=ILX+NWRDBK zn IL=IL-NWRDBK zn ENDIF *ENDIF SMALLzn*ENDIF < GOTO 200jC j250 WRITE(ERRMSG,251) FIRSEC(N) z250 CONTINUE zn*IF SMALL zn IF(IPASS.EQ.0) THEN zn IPASS=1 zn IL=ISLOC zn ILX=0  NDKMEL = 0  CALL RDDK ('L', NDECK, ILDECK, 0)zn CALL RDDK(1,NDECK) zn GOTO 200 zn ENDIF *ENDIF SMALLzn*ENDIF z WRITE(ERRMSG,251) FIRSEC(N) j251 FORMAT(' (LOCREC)- The ',A,' Record refered to by the ',j 1 'following directive was not found') j GOTO 290jC j 270 WRITE(ERRMSG,271) FIRSEC(N) j!271 FORMAT(' (LOCREC)-The ',A,' Record refered to by following ', j" 1 'RESTORE directive is active') j# GOTO 290j$C j%280 WRITE(ERRMSG,273) FIRSEC(N) j&273 FORMAT(' (LOCREC)- The ',A,' Record refered to by the ',j' 1 'following INSERT or DELETE directive is inactive') j(C j)290 CALL WRERR j* CALL LISERR(INLOC(INPL)) n CALL LISERR(INPL) j+C =300 CONTINUE > LOC1=LOCC(1) ? LOC2=LOCC(2) zn*IF SMALL zn ICLOC=IL *ENDIF SMALLz n*ENDIF @ RETURN AC BC ERROR NOT FOUND CC D500 CONTINUEE PRINT*,'DIDNT FIND RECORD FOR INPUT RECORD NO ',INLOC(INPL) j, WRITE(ERRMSG,251) FIRSEC(NDF) j-520 CALL WRERR j. CALL LISERR(INLOC(INPL)) n CALL LISERR(INPL) F LOC1=0 G LOC2=0 z!n*IF SMALL z"n ICLOC=IL *ENDIF SMALLz#n*ENDIF 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) z$n*IF SMALL z%n ILX=0 z&n ICLOC=ISLOC  *ENDIF SMALLz'n*ENDIF S RETURN T END 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(LSTMODDCK 3/22/82 znJE. 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 n*CA ERRMES C .*IF I4  INTEGER*4 ILM zn*IF SMALL zn INTEGER*4 IDECPTzn*ENDIF .*ENDIF m NDKMEM = 1 n CALL RDDK(1,NDECK) m CALL RDDK(NDECK)  NDKMEL = 0  CALL RDDK('L', NDECK, ILDECK, 0)C ILM = LOCATION OF NMODS IN DECK  CALL INILOC (NDECK,ILM) n IDECP1=1 m IDECP1 = MEMSTR(1)  IDECP1 = MEMSTL(1) n IDECP2=ISDEC(2) m MEMSTR(2) = MEMEND(1) + 1 m IDECP2 = MEMSTR(2)  IDECP2 = MEMSTL(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 zC *IF SMALL  NDKMEL = 0  CALL RDDK('L', NDECK, ILDECK, 0)  LOCDN = LOCLSR *ENDIF SMALL zn*IF SMALL zn CALL RDDK(1,NDECK) zn LOCDN=LOCLSRzn CALL WRDK(LSR,LOCDN,2) z n*ENDIF 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 z n*IF SMALL z n IDECPT = IDECP1 *ENDIF SMALLz n*ENDIF +t DO 1000 I=1,NOMODS  NM=1720 IF(MODRC1(NM).NE.IDECP1-1) GOTO 780  INREC=MODIN(NM)  CALL PINSRT(INREC,IDNO,NSEQ,.FALSE.)  NM=NM+1  GOTO 720C 780 DO 1000 I=NM,NOMODS , MLOC=MODRC1(I) -800 IF(IDECP1.LT.MLOC) THEN z n*IF -SMALL z800 IF(IDECP1.LT.MLOC) THEN zn*ENDIF zn*IF SMALL zn800 IF(IDECPT.LT.MLOC) THEN *ENDIF SMALLzn*ENDIF . LNX=IDEC(IDECP1) / DO 840 J=1,LNX 0 IDEC(IDECP2)=IDEC(IDECP1) 1 IDECP1=IDECP1+1 2 IDECP2=IDECP2+1 3840 CONTINUE *IF SMALL IDECPT = IDECPT + LNX  IF (IDECP1 .GE. MEMSTL(1) + NWRDBK ) THEN  IDECP1 = IDECP1 - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1), NWRDBK) CALL RDNEXR ('L', 1)  ENDIF  IF (IDECP2 .GE. MEMSTL(2) + NWRDBK) THEN IDECP2 = IDECP2 - NWRDBK  CALL WRPL1 (LSR, LOCLSR, IDEC(MEMSTL(2)))  LOCLSR = LOCLSR + 1  CALL TRDEC (MEMSTL(2) + NWRDBK, MEMSTL(2), NWRDBK)  ENDIF *ENDIF SMALL zn*IF SMALL zn IDECPT=IDECPT+LNX zn IF(IDECP1.GT.NWRDBK) THEN zn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,NWRDBK) zn CALL RDNEXR(1) zn ENDIF zn IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENzn CALL WRNEXR(LOCLSR) zn IDECP2=IDECP2-NWRDBK zn CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) zn ENDIF zn*ENDIF 4 GOTO 800 5 ENDIF E IF(IDECP1.GT.MLOC) THEN z n*IF -SMALL z! IF(IDECP1.GT.MLOC) THEN z"n*ENDIF z#n*IF SMALL z$n IF(IDECPT.GT.MLOC) THEN *ENDIF SMALLz%n*ENDIF 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') n ERRMSG='Directive for deck '//DECK(NDECK)//' refers to a ' n 1 //'record that cannot be reached' n CALL WRERR n ERRMSG='This generally occurs when changes overlap' n CALL WRERR 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 Ct CALL PINSRT(INREC,IDNO,NSEQ) CALL PINSRT(INREC,IDNO,NSEQ,.TRUE.) 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*IF SMALL  IDECPT = IDECPT + LNX  IF (IDECP1 .GE. MEMSTL(1) + NWRDBK ) THEN  IDECP1 = IDECP1 - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1), NWRDBK)  CALL RDNEXR ('L', 1)  ENDIF  IF (IDECP2 .GE. MEMSTL(2) + NWRDBK) THEN IDECP2 = IDECP2 - NWRDBK  CALL WRPL1 (LSR, LOCLSR, IDEC(MEMSTL(2))) ! LOCLSR = LOCLSR + 1 " CALL TRDEC (MEMSTL(2) + NWRDBK, MEMSTL(2), NWRDBK) # ENDIF $*ENDIF SMALL z&n*IF SMALL z'n IDECPT=IDECPT+LNX z(n IF(IDECP1.GT.NWRDBK) THEN z)n IDECP1=IDECP1-NWRDBK z*n CALL TRDEC(NWRDBK+1,1,NWRDBK) z+n CALL RDNEXR(1) z,n ENDIF z-n IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENz.n CALL WRNEXR(LOCLSR) z/n IDECP2=IDECP2-NWRDBK z0n CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) z1n ENDIF z2n*ENDIF V GOTO 1500 WC X2000 CONTINUE Y IDEC(IDECP2)=0 %*IF SMALL & CALL WRPL1 (LSR, LOCLSR, IDEC(MEMSTL(2))) ' LOCLSR = LOCLSR + 1 ( NBLKS = LOCLSR - LOCDN ) LOCB(NDECK) = LOCDN * IF(NBLKS.GT.1) THEN + CALL RDPL1 (LSR, LOCDN, IDEC(MEMSTL(2))) , ENDIF - GOTO 2010 .2002 CONTINUE/*ENDIF SMALL z3n*IF SMALL z4n CALL WRNEXR(LOCLSR) z5n NBLKS=LOCLSR-LOCDN z6n LOCB(NDECK)=LOCDN z7n*ENDIF z8n*IF -SMALL Z CALL STATIS(2,IDECP2) [n NBLKS=(IDECP2+1-ISDEC(2)+NWRDBK-1)/NWRDBK m NBLKS=(IDECP2+1-MEMSTR(2)+NWRDBK-1)/NWRDBK  NBLKS=(IDECP2+1-MEMSTL(2)+NWRDBK-1)/NWRDBK z9 LOCB(NDECK)=LOCLSR 02010 CONTINUEz:n*ENDIF \ LOCF(NDECK)=LSR ] LOCB(NDECK)=LOCLSR ^ NBLOK(NDECK)=NBLKS _n IDEC(ISDEC(2)+2*NW8C)=NBLKS m IDEC(MEMSTR(2)+2*NW8C)=NBLKS IDEC(MEMSTL(2)+2*NW8C)=NBLKS1*IF SMALL 2 CALL WRPL1 (LSR, LOCDN, IDEC(MEMSTL(2))) 3 GOTO 3000 42020 CONTINUE5*ENDIF SMALL`C z;n*IF -SMALL a CALL WRDK(LSR,LOCLSR,ISDEC(2),NBLKS)m CALL WRDK(LSR,LOCLSR,2,NBLKS)  CALL WRDK('L',LSR,LOCLSR,2,NBLKS) z<n*ENDIF b3000 CONTINUE c RETURN d END 1 ITDIR .EQ. 21 .OR. ITDIR .EQ.22 )) t} 1 (ISETIF.AND.(ITDIR.EQ.0.OR.ICCD)) ) THENMOVCHR 12/14/84 SUBROUTINE MOVCHR(TARGET,SOURCE,LENSRC) C C UTILITY ROUTINE TO MOVE CHARACTERS TO AND FROM COMMONC *CALL PARAMAC  CHARACTER SOURCE*(MAXWID), TARGET*(*)  INTEGER LENSRC TARGET = SOURCE(1:LENSRC)  RETURN END  MOVDK 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 yr SUBROUTINE NAMCHK(NU,NAM,NAML) y*IF DEC20 yw SUBROUTINE NAMCHK(NU,NAM,NAML,NVER)  SUBROUTINE NAMCHK(NU,NAM,NAML,STATUS,NVER)y*ENDIF y*IF -DEC20 y SUBROUTINE NAMCHK(NU,NAM,NAML)y*ENDIF C C CHECKS IF FILE NAM EXISTS, IF SO, CREATES NEW FILE WITH C VERSION NUMBERC C  CHARACTER*(*) NAM  CHARACTER*(*) NAML y*IF DEC20 y CHARACTER*(*) NVER  CHARACTER*(*) STATUS y *ENDIF y *IF FILEVN CHARACTER*3 VERSN y *ENDIF  C  LOGICAL*4 EX r LOGICAL EX  C  INTEGER*4 LNAM C *CALL ERRMES n*CALL FILEIDS *CALL LOGU  CHARACTER ANS*72 n INTEGER IEXIST *IF NPS *CALL NPSARG CHARACTER*3 SEQ,DIRECT,FORMAT,UNFORM INTEGER ICHARS, IWORDS, NUMBER  LOGICAL QREAD, QWRITE, QDELET, QCREAT, QOPEN *ENDIF NPS C  NAML = NAM(1:)  IF(NAM .EQ. ' ') WRITE(NAML,11) NU 11 FORMAT('FOR',I3.3) *IF IBM  IF (NAM .EQ. ' ') RETURN *ENDIF IBM  ISIZE = INDEX(NAML,' ') y *IF DEC20 y ITYPE = INDEX(NAML,'.') y IF (ITYPE .EQ. 0) THEN y NAML(ISIZE:) = '.DAT.'//NVER y RETURN y ENDIFy IVERS = INDEX(NAML(ITYPE+1:),'.') y IF (IVERS .NE. 0) RETURN y NAML(ISIZE:) = '.'//NVER y*ENDIF 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 l GO TO 20  IF(J.GT.1) THEN  ERRMSG=' Replace file name '//NAML(1:ISIZE)//  1 ' with '//NAML(1:ISIZE+2)  CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG)))  ENDIF  GOTO 20  ENDIF *ENDIF  *IF -FILEVN  *IF -DEC20 n IF(NU.EQ.LCO) THEN n IEXIST=EXIST(1) n ELSEIF(NU.EQ.LOU) THEN n IEXIST=EXIST(2) n ELSEIF(NU.EQ.LOP) THEN n IEXIST=EXIST(3) n IF(IEXIST.LT.0) IEXIST = 1 n ELSEIF(NU.EQ.LNP) THEN n IEXIST=EXIST(3) n ELSEIF(NU.GE.LIN) THEN n IEXIST=EXIST(4) n ELSEIF(NU.EQ.LSO) THEN n IEXIST=EXIST(5) n ELSEIF(NU.EQ.LIA) THEN n IEXIST=EXIST(6) n IF(IEXIST.LT.0) IEXIST =1 n ELSEIF(NU.EQ.LOA) THEN n IEXIST=EXIST(6) n ELSEIF(NU.EQ.LBI) THEN n IEXIST=EXIST(7) !n IF (IEXIST.LT.0) IEXIST = 1 "n ELSEIF(NU.EQ.LBO) THEN #n IEXIST=EXIST(7) $u ELSEIF(NU.EQ.LBI) THEN n ELSEIF(NU.EQ.LCI) THEN %n IEXIST=EXIST(8) &n IF(IEXIST.LT.0) IEXIST =1 'u ELSEIF(NU.EQ.LDO) THEN (u IEXIST=EXIST(8) )n ELSE *| CALL WRTIO(' **ERROR** Logical unit no. invalid for '//NAM) n ANS = NAMn CALL WRTIO(' **ERROR** Logical unit no. invalid for '//ANS) +n RETURN ,n ENDIF -C .1000 CONTINUE/*IF -NPS*IF -IBM0 INQUIRE (FILE=NAML,EXIST=EX,ERR=200)*ENDIF -IBM *IF IBM n EX = IEXIST.EQ.1  EX = STATUS.EQ.'OLD'*ENDIF IBM 1*ENDIF -NPS 2*IF NPS 3 CALL BYFILE(NAML, 4 $ EX,QOPEN,SEQ,DIRECT,FORMAT,UNFORM,ICHARS,IWORDS,NUMBER, 5 $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)6v IF (QREADY.AND.QERROR) CALL NPSEIO('BYFILE VIA NAMCHK')  IF (QREADY.AND.QERROR) THEN  ERRMSG = 'BYFILE called with NAML='//NAML  CALL NPSEIO('BYFILE via NAMCHK',ERRMSG(1:ITRAIL(ERRMSG)))  ENDIF 7*ENDIF NPS 8n IF (EX .AND. IEXIST .EQ. -1) THEN  IF (EX .AND. STATUS .EQ. 'NEW') THEN9v ERRMSG = ' *ERROR* file -'//NAML//'- already exists.' :v CALL WRERR  ERRMSG = ' *ERROR* file already exists -'//NAML  CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) ; GO TO 2000 < ENDIF =n IF (.NOT.EX .AND. IEXIST .EQ. 1) THEN  IF (.NOT.EX .AND. STATUS .EQ. 'OLD') THEN >v ERRMSG = ' *ERROR* file -'//NAML//'- does not exist.' ?v CALL WRERR  ERRMSG = ' *ERROR* file does not exist -'//NAML  CALL WRTIO(ERRMSG(1:ITRAIL(ERRMSG))) @ GO TO 3000 A ENDIF B RETURN CC D 2000 ANS = ' ' E CALL RDTIO('Do you wish to write over file (Y/N) ?',ANS,.TRUE.) F| IF (INDEX(ANS(1:1),'Yy') .NE. 0) return { IF (INDEX(ANS(1:1),'Yy') .NE. 0) RETURN w IF (INDEX('Yy',ANS(1:1)) .NE. 0) RETURN  IF (INDEX('Yy',ANS(1:1)) .NE. 0) THEN  STATUS = 'OLD'  RETURN  ENDIF G 3000 ANS = ' ' H CALL RDTIO('Do you wish to enter a different fileid (Y/N) ?'I $ ,ANS,.TRUE.)J{ IF (INDEX(ANS(1:1),'Yy') .NE. 0) THEN  IF (INDEX('Yy',ANS(1:1)) .NE. 0) THEN K ANS = ' ' L CALL RDTIO('Enter new fileid : ',ANS,.TRUE.) M IF(ANS.NE.' ') THEN N NAML = ANS O GOTO 1000 P ENDIF Q ELSE Rp CALL WRTIO('Original fileid will be used.')  CALL WRTIO(' Must abort - bad fileid.')  CALL THEEND(2,' Abort due to bad fileid.') S ENDIF T*ENDIF -DEC20 Un*ENDIF -FILEID *ENDIF -FILEVN !200 RETURN " END CALL EXAL(ADEC(IDECP1),IDECP1,NAM) nNPSEIO 7/26/84v SUBROUTINE NPSEIO(ROUTIN) v CHARACTER ROUTIN*(*) SUBROUTINE NPSEIO(ROUTIN,ARGUMT) CHARACTER ROUTIN*(*), ARGUMT*(*)*IF NPS C C THIS SUBROUTINE WRITES ANY NPS ERRORS TO THE TERMINAL LOGICAL UNIT C RATHER THAN USE THE NPS TUBE ROUTINE SINCE ERROR CAN ORIGINATEC THERE.*CALL LOGU  *CALL NPSARG C IF (.NOT.QERROR) RETURN  y WRITE (LTO,'(1X,A)') 'ERRORS IN ROUTINE '//ROUTIN  WRITE (LTO,'(1X,2A)') 'ERRORS IN ROUTINE ',ROUTIN  WRITE (LTO,'(1X,2A)') 'ROUTINE ',ARGUMT y IF (QREM) WRITE (LTO,'(1X,A)') ' NPS REMARK :'//REMARK  IF (QREM) WRITE (LTO,'(1X,2A)') ' NPS REMARK :',REMARK  IF (LEVEL .GT. 0 ) WRITE (LTO,10) LEVEL  10 FORMAT(' NPS ERROR LEVEL = ', I3)  IF (NERROR .GT. 0 ) WRITE(LTO,20) (LERROR(I),I=1,NERROR) 20 FORMAT(' NPS ERRORS = ',10I5) *ENDIF  RETURN  END *CALL NPSARG CHARACTER*3 SEQ,DIRECT,FORMAT,UNFORMNXUNIN 3/22/82 rC  SUBROUTINE NXUNIN(A,LUN)C C OPENS NEXT INPUT UNIT C  CHARACTER*(*) A  CHARACTER*20 WORD(40) C*CALL SCAN C r*CA ERRMES  CHARACTER FNAME*72  CHARACTER STATUS*8  CALL SCAN1(A,WORD,NW)   IF(NW.LT.2) GOTO 9000 Cz CALL SCAN1(A) Cz IF(NWRD.LT.2) GOTO 9000  IB = INDEX(A,' ')  IF (IB .LT. 3) GO TO 9000  CALL SCANCC(A(IB:))  IF(NWRD.LT.1) GOTO 9000  LUNMAX = 91 *IF UNIX  LUNMAX = 9 *ENDIF UNIX  IF(LUN .GE. LUNMAX) THEN WRITE(ERRMSG,11) LUNMAX  11 FORMAT('**ERROR** READ directives nested too deep'  1 ,' Maximum unit number is =',I5) CALL WRERR GOTO 9000 ENDIF LUN=LUN+1   CALL OPNINX(LUN,WORD(2),IER)C CALL OPNINX(LUN,A(ISS(2):ISS(2)+ISL(2)-1),IER) z CALL FILEID(LUN,A(ISS(2):ISS(2)+ISL(2)-1),FNAME) o IC = ISS(1) + IB - 1o CALL FILEID(LUN,A(IC:IC+ISL(1)-1),FNAME)  IC = IB -1 n CALL FILEID(LUN,A(ISS(1)+IC:ISE(1)+IC),FNAME)  FNAME = A(ISS(1)+IC:ISE(1)+IC)  ICHARS = 80 k CALL OPENER(LUN,FNAME(1:ITRAIL(FNAME)),'OLD','SEQUENTIAL',  ILEN = ITRAIL(FNAME)  STATUS = 'OLD'  CALL FILECK(LUN,'INPUT',FNAME,ILEN,STATUS,IDDNAM) CALL OPENER(LUN,FNAME(1:ILEN),IDDNAM,STATUS,'SEQUENTIAL', $ 'FORMATTED',ICHARS,0,0,IERR)  u IF(IER.NE.0) GOTO 9000  IF(IERR.NE.0) THEN  LUN=LUN-1  GOTO 9000  ENDIF RETURN 9000 PRINT*,'SOMETHING WRONG WITH READ COMMAND ',A r9000 ERRMSG='**ERROR** Improper READ directive '//A//r 1 ' (ignored)' r CALL WRERR  RETURN  END OPENER 7/26/84S w SUBROUTINE OPENER(LUN,FNAME,STATUS,ACCESS,FORM,LRECL,IRECS, k SUBROUTINE OPENER(LUN,FNAME,TSTATS,ACCESS,FORM,LRECL,IRECS,  SUBROUTINE OPENER(LUN,FNAME,IDDNAM,TSTATS,ACCESS,FORM,LRECL,k $ MXRECS,IERROR) $ IRECS,MXRECS,IERROR) C C C THIS SUBROUTINE OPENS A SLIB77 FILE.C w CHARACTER*(*) FNAME, STATUS, ACCESS, FORM  CHARACTER*(*) FNAME, TSTATS, ACCESS, FORM k INTEGER LUN, LRECL, IRECS, MXREC, IERROR INTEGER LUN, IDDNAM, LRECL, IRECS, MXREC, IERROR C  *CALL PARAMA C LOCAL VARIABLES  w CHARACTER TFORM*11, TNAME*72v CHARACTER TFORM*11, TNAME*72, STATUS*7 k CHARACTER TFORM*11, TNAME*72, STATUS*7, NPSREM*120  CHARACTER TFORM*11, STATUS*7, NPSREM*120 INTEGER NCHARS *IF NPS *CALL NPSARG CHARACTER*3 SEQ, DIRECT, FORMAT, UNFORM  INTEGER IUNIT, NWORDS  LOGICAL QEXIST, QOPEN C *ENDIF NPS *IF -NPS  LOGICAL QERROR *ENDIF -NPS  IERROR = 0  NCHARS = LRECL  TFORM = FORM  STATUS = TSTATS  IF (TFORM .EQ. 'LISTING') TFORM = 'FORMATTED' *IF VAX *IF -NPS IF (ACCESS .EQ. 'DIRECT'  1 .AND. TFORM .EQ. 'UNFORMATTED') THEN NCHARS = (LRECL+NCHRWD-1)/NCHRWD  ENDIF *ENDIF -NPS *ENDIF VAX *IF NPS  NWORDS = 0  IF (TFORM .EQ. 'UNFORMATTED') THEN  NWORDS = (LRECL+NCHRWD-1)/NCHRWD  NCHARS = NWORDS*NCHRWD ! ENDIF "*ENDIF NPS #*IF IBM w CALL NAMCHK(LUN,FNAME,TNAME,' ')k CALL NAMCHK(LUN,FNAME,TNAME,STATUS,' ') $ IF (STATUS .EQ. 'SCRATCH') THEN %*IF NPS *IF -IBMMVS & CALL WORK(LUN,ACCESS,TFORM,'ZERO', ' $ NCHARS,NWORDS,NCHARS*IRECS,NCHARS*MXRECS, ( $ NWORDS*IRECS,NWORDS*MXRECS, ) $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR)*v IF (QREADY.AND.QERROR) CALL NPSEIO('WORK VIA OPENER') IF (QREADY.AND.QERROR) THEN  WRITE (NPSREM,'(A,I5,A,A,A,A)') 'WORK called with'//  $ ' LUN=',LUN,', ACCESS=',ACCESS,', FORM=',TFORM  CALL NPSEIO('WORK via OPENER',NPSREM(1:ITRAIL(NPSREM)))  ENDIF w RETURN *ENDIF -IBMMVS *IF IBMMVS  IF (ACCESS .EQ. 'DIRECT') THEN  OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ELSE OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,ERR=100)  ENDIF *ENDIF IBMMVS +y IF (QERROR) THEN ,*ENDIF NPS *IF -NPS- IF (ACCESS .EQ. 'DIRECT') THEN .z OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, w OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,FILE=TNAME, OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, / $ ACCESS=ACCESS,FORM=TFORM,ERR=100) 0 ELSE 1z OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, w OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,FILE=TNAME,  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, 2 $ FORM=TFORM,ERR=100) 3 ENDIF *ENDIF -NPS 4y*IF NPS 5y ENDIF 6y*ENDIF NPS 7 ELSEIF (STATUS .EQ. 'NEW') THEN8*IF NPS 9k IF (FNAME .NE. ' ') THEN  IF (IDDNAM .EQ. 0) THEN :z CALL NAMCHK(LUN,FNAME,TNAME,' ') ;k CALL CREATE(LUN,TNAME,ACCESS,TFORM,'ZERO', CALL CREATE(LUN,FNAME,ACCESS,TFORM,'ZERO',< $ NCHARS,NWORDS,NCHARS*IRECS,NCHARS*MXRECS, = $ NWORDS*IRECS,NWORDS*MXRECS, > $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) ?v IF (QREADY.AND.QERROR) CALL NPSEIO('CREATE VIA OPENER')  IF (QREADY.AND.QERROR) THEN  WRITE (NPSREM,'(A,I5,A,A,A,A,A,A)') 'CREATE called'// k $ ' with LUN=',LUN,', TNAME=',TNAME(1:ITRAIL(TNAME)), $ ' with LUN=',LUN,', FNAME=',FNAME(1:ITRAIL(FNAME)), $ ', ACCESS=',ACCESS,', FORM=',TFORM  CALL NPSEIO('CREATE via OPENER', $ NPSREM(1:ITRAIL(NPSREM)))  ENDIF  RETURN @y ELSEAy QERROR = .TRUE. B ENDIF Cy IF (QERROR) THEN D*ENDIF NPS E IF (ACCESS .EQ. 'DIRECT') THEN Fz OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, k OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,FILE=TNAME, OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,FILE=FNAME,G $ ACCESS=ACCESS,FORM=TFORM,ERR=100) H ELSE Iz OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, k OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,FILE=TNAME,  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,FILE=FNAME, J $ FORM=TFORM,ERR=100) K ENDIF Ly*IF NPS My ENDIF Ny*ENDIF NPS O ELSEIF (STATUS .EQ. 'OLD') THENP*IF NPS Qk IF (FNAME .NE. ' ') THEN  IF (IDDNAM .EQ. 0) THEN Rz CALL NAMCHK(LUN,FNAME,TNAME,' ') Sk CALL BYFILE(TNAME,QEXIST,QOPEN,  CALL BYFILE(FNAME,QEXIST,QOPEN, T $ SEQ,DIRECT,FORMAT,UNFORM,NCHARS,NWORDS,IUNIT, U $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) Vv IF (QREADY.AND.QERROR) CALL NPSEIO('BYFILE VIA OPENER')  IF (QREADY.AND.QERROR) THEN k WRITE (NPSREM,'(A,A)') 'BYFILE called with TNAME=',  WRITE (NPSREM,'(A,A)') 'BYFILE called with FNAME=', k $ TNAME(1:ITRAIL(TNAME))  $ FNAME(1:ITRAIL(FNAME))  CALL NPSEIO('BYFILE via OPENER', $ NPSREM(1:ITRAIL(NPSREM)))  ENDIF W IF (QERROR) GOTO 100 Xk CALL ATTACH(LUN,TNAME,ACCESS,TFORM,'ZERO', CALL ATTACH(LUN,FNAME,ACCESS,TFORM,'ZERO', Y $ NCHARS,NWORDS, Z $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) [v IF (QREADY.AND.QERROR) CALL NPSEIO('ATTACH VIA OPENER')  IF (QREADY.AND.QERROR) THEN  WRITE (NPSREM,'(A,I5,A,A,A,A,A,A)') 'ATTACH called'// k $ ' with LUN=',LUN,', TNAME=',TNAME(1:ITRAIL(TNAME)), $ ' with LUN=',LUN,', FNAME=',FNAME(1:ITRAIL(FNAME)), $ ', ACCESS=',ACCESS,', FORM=',TFORM ! CALL NPSEIO('ATTACH via OPENER'," $ NPSREM(1:ITRAIL(NPSREM))) # ENDIF  RETURN \y ELSE]y QERROR = .TRUE. ^ ENDIF _y IF (QERROR) THEN `*ENDIF NPS a IF (ACCESS .EQ. 'DIRECT') THEN bz OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, k OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,FILE=TNAME, OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,FILE=FNAME,c $ ACCESS=ACCESS,FORM=TFORM,ERR=100) d ELSE ez OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, k OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,FILE=TNAME,  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,FILE=FNAME, f $ FORM=TFORM,ERR=100) g ENDIF hy*IF NPS iy ENDIF jy*ENDIF NPS k ELSE l IERROR = 3 m ENDIF n*ENDIF IBM o*IF VAX p IF (STATUS .EQ. 'SCRATCH') THEN q*IF NPS r CALL WORK(LUN,ACCESS,TFORM,'ZERO', s $ NCHARS,NWORDS,NCHARS*IRECS,NCHARS*MXRECS, t $ NWORDS*IRECS,NWORDS*MXRECS, u $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR)vv IF (QREADY.AND.QERROR) CALL NPSEIO('WORK VIA OPENER')$ IF (QREADY.AND.QERROR) THEN % WRITE (NPSREM,'(A,I5,A,A,A,A)') 'WORK called with'// & $ ' LUN=',LUN,', ACCESS=',ACCESS,', FORM=',TFORM ' CALL NPSEIO('WORK via OPENER',NPSREM(1:ITRAIL(NPSREM))) ( ENDIF  RETURN wy IF (QERROR) THEN x*ENDIF NPS *IF -NPSy IF (ACCESS .EQ. 'DIRECT') THEN zg IF (TFORM .EQ. 'UNFORMATTED') {g $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD| OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, } $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ~ ELSE  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,ERR=100) ENDIF *ENDIF -NPS y*IF NPS y ENDIF y*ENDIF NPS  ELSEIF (STATUS .EQ. 'NEW') THENk IF (FNAME .NE. ' ') THEN  IF (IDDNAM .EQ. 0) THEN *IF NPS  CALL CREATE(LUN,FNAME,ACCESS,TFORM,'ZERO', $ NCHARS,NWORDS,NCHARS*IRECS,NCHARS*MXRECS,  $ NWORDS*IRECS,NWORDS*MXRECS,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) v IF (QREADY.AND.QERROR) CALL NPSEIO('CREATE VIA OPENER') ) IF (QREADY.AND.QERROR) THEN * WRITE (NPSREM,'(A,I5,A,A,A,A,A,A)') 'CREATE called'// +k $ ' with LUN=',LUN,', TNAME=',TNAME(1:ITRAIL(TNAME)), $ ' with LUN=',LUN,', FNAME=',FNAME(1:ITRAIL(FNAME)),, $ ', ACCESS=',ACCESS,', FORM=',TFORM - CALL NPSEIO('CREATE via OPENER',. $ NPSREM(1:ITRAIL(NPSREM))) / ENDIF *ENDIF NPS *IF -NPS IF (ACCESS .EQ. 'DIRECT') THENg IF (TFORM .EQ. 'UNFORMATTED') g $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD  OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ELSE  IF (FORM .EQ. 'LISTING') THEN  OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS, $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ELSE  OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS, $ ACCESS=ACCESS,FORM=TFORM,ERR=100,  $ CARRIAGECONTROL='LIST') ENDIF ENDIF *ENDIF -NPS ELSEy QERROR = .TRUE. y ENDIF y IF (QERROR) THEN  IF (ACCESS .EQ. 'DIRECT') THENg IF (TFORM .EQ. 'UNFORMATTED') g $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD  OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ELSE  IF (FORM .EQ. 'LISTING') THEN  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,ERR=100) ELSE  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,ERR=100,CARRIAGECONTROL='LIST') ENDIF ENDIF ENDIF ELSEIF (STATUS .EQ. 'OLD') THENk IF (FNAME .NE. ' ') THEN  IF (IDDNAM .EQ. 0) THEN *IF NPS  CALL BYFILE(FNAME,QEXIST,QOPEN,  $ SEQ,DIRECT,FORMAT,UNFORM,NCHARS,NWORDS,IUNIT,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) v IF (QREADY.AND.QERROR) CALL NPSEIO('BYFILE VIA OPENER') 0 IF (QREADY.AND.QERROR) THEN 1k WRITE (NPSREM,'(A,A)') 'BYFILE called with TNAME=',  WRITE (NPSREM,'(A,A)') 'BYFILE called with FNAME=', 2k $ TNAME(1:ITRAIL(TNAME))  $ FNAME(1:ITRAIL(FNAME)) 3 CALL NPSEIO('BYFILE via OPENER',4 $ NPSREM(1:ITRAIL(NPSREM))) 5 ENDIF  IF (QERROR) GOTO 100  CALL ATTACH(LUN,FNAME,ACCESS,TFORM,'ZERO', $ NCHARS,NWORDS,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) v IF (QREADY.AND.QERROR) CALL NPSEIO('ATTACH VIA OPENER') 6 IF (QREADY.AND.QERROR) THEN 7 WRITE (NPSREM,'(A,I5,A,A,A,A,A,A)') 'ATTACH called'// 8k $ ' with LUN=',LUN,', TNAME=',TNAME(1:ITRAIL(TNAME)), $ ' with LUN=',LUN,', FNAME=',FNAME(1:ITRAIL(FNAME)),9 $ ', ACCESS=',ACCESS,', FORM=',TFORM : CALL NPSEIO('ATTACH via OPENER',; $ NPSREM(1:ITRAIL(NPSREM))) < ENDIF *ENDIF NPS *IF -NPS IF (ACCESS .EQ. 'DIRECT') THENg IF (TFORM .EQ. 'UNFORMATTED') g $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD  OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,READONLY,ERR=100) ELSE  OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,READONLY,ERR=100) ENDIF *ENDIF -NPS ELSEy QERROR = .TRUE. y ENDIF y IF (QERROR) THEN  IF (ACCESS .EQ. 'DIRECT') THEN g IF (TFORM .EQ. 'UNFORMATTED') g $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,READONLY,ERR=100) ELSE  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,READONLY,ERR=100) ENDIF ENDIF ELSE IERROR = 3 ENDIF *ENDIF VAX *IF PRIME k TNAME = FNAME k*IF -SALFRD w IF (FNAME .EQ. ' ') CALL NAMCHK(LUN,' ',TNAME,' ')  k IF (FNAME .EQ. ' ') CALL NAMCHK(LUN,' ',TNAME,STATUS,' ') k*ENDIF -SALFRD  IF (STATUS .EQ. 'SCRATCH') THEN *IF NPS  CALL WORK(LUN,ACCESS,TFORM,'ZERO',  $ NCHARS,NWORDS,NCHARS*IRECS,NCHARS*MXRECS,  $ NWORDS*IRECS,NWORDS*MXRECS,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR)v IF (QREADY.AND.QERROR) CALL NPSEIO('WORK VIA OPENER')= IF (QREADY.AND.QERROR) THEN > WRITE (NPSREM,'(A,I5,A,A,A,A)') 'WORK called with'// ? $ ' LUN=',LUN,', ACCESS=',ACCESS,', FORM=',TFORM @ CALL NPSEIO('WORK via OPENER',NPSREM(1:ITRAIL(NPSREM))) A ENDIF y IF (QERROR) THEN *ENDIF NPS  *IF -NPS IF (ACCESS .EQ. 'DIRECT') THEN  IF (TFORM .EQ. 'UNFORMATTED')  $ NCHARS = (LRECL+1)/2x OPEN (UNIT=LUN,FILE=TNAME,RECL=NCHARS,STATUS=STATUS, OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ELSE x OPEN (UNIT=LUN,FILE=TNAME,STATUS=STATUS,ACCESS=ACCESS,  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,ERR=100) ENDIF  *ENDIF -NPS y*IF NPS y ENDIF y*ENDIF NPS  ELSEIF (STATUS .EQ. 'NEW') THEN*IF NPS k IF (FNAME .NE. ' ') THEN  IF (IDDNAM .EQ. 0) THEN  CALL CREATE(LUN,FNAME,ACCESS,TFORM,'ZERO', $ NCHARS,NWORDS,NCHARS*IRECS,NCHARS*MXRECS,  $ NWORDS*IRECS,NWORDS*MXRECS,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) v IF (QREADY.AND.QERROR) CALL NPSEIO('CREATE VIA OPENER') B IF (QREADY.AND.QERROR) THEN C WRITE (NPSREM,'(A,I5,A,A,A,A,A,A)') 'CREATE called'// Dk $ ' with LUN=',LUN,', TNAME=',TNAME(1:ITRAIL(TNAME)), $ ' with LUN=',LUN,', FNAME=',FNAME(1:ITRAIL(FNAME)),E $ ', ACCESS=',ACCESS,', FORM=',TFORM F CALL NPSEIO('CREATE via OPENER',G $ NPSREM(1:ITRAIL(NPSREM))) H ENDIF RETURN y ELSEy QERROR = .TRUE.  ENDIF y IF (QERROR) THEN *ENDIF NPS k*IF FILEVN w CALL NAMCHK(LUN, FNAME, TNAME, ' ')  k CALL NAMCHK(LUN, FNAME, TNAME, STATUS, ' ') k*ENDIF FILEVN  IF (ACCESS .EQ. 'DIRECT') THEN IF (TFORM .EQ. 'UNFORMATTED')  $ NCHARS = (LRECL+1)/2 ~ OPEN (UNIT=LUN,FILE=TNAME,RECL=NCHARS,STATUS=STATUS, k OPEN (UNIT=LUN,FILE=TNAME,RECL=NCHARS,STATUS='UNKNOWN', OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS='UNKNOWN', $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ELSE  ~ OPEN (UNIT=LUN,FILE=TNAME,STATUS=STATUS, k OPEN (UNIT=LUN,FILE=TNAME,STATUS='UNKNOWN', OPEN (UNIT=LUN,FILE=FNAME,STATUS='UNKNOWN',  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ENDIF  y*IF NPS y ENDIF y*ENDIF NPS  ELSEIF (STATUS .EQ. 'OLD') THEN*IF NPS k IF (FNAME .NE. ' ') THEN  IF (IDDNAM .EQ. 0) THEN  CALL BYFILE(FNAME,QEXIST,QOPEN,  $ SEQ,DIRECT,FORMAT,UNFORM,NCHARS,NWORDS,IUNIT,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) v IF (QREADY.AND.QERROR) CALL NPSEIO('BYFILE VIA OPENER') I IF (QREADY.AND.QERROR) THEN Jk WRITE (NPSREM,'(A,A)') 'BYFILE called with TNAME=',  WRITE (NPSREM,'(A,A)') 'BYFILE called with FNAME=', Kk $ TNAME(1:ITRAIL(TNAME))  $ FNAME(1:ITRAIL(FNAME)) L CALL NPSEIO('BYFILE via OPENER',M $ NPSREM(1:ITRAIL(NPSREM))) N ENDIF  IF (QERROR) GOTO 100  CALL ATTACH(LUN,FNAME,ACCESS,TFORM,'ZERO',  $ NCHARS,NWORDS,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,IERROR) v IF (QREADY.AND.QERROR) CALL NPSEIO('ATTACH VIA OPENER') O IF (QREADY.AND.QERROR) THEN P WRITE (NPSREM,'(A,I5,A,A,A,A,A,A)') 'ATTACH called'// Qk $ ' with LUN=',LUN,', TNAME=',TNAME(1:ITRAIL(TNAME)), $ ' with LUN=',LUN,', FNAME=',FNAME(1:ITRAIL(FNAME)),R $ ', ACCESS=',ACCESS,', FORM=',TFORM S CALL NPSEIO('ATTACH via OPENER',T $ NPSREM(1:ITRAIL(NPSREM))) U ENDIF RETURN y ELSEy QERROR = .TRUE.  ENDIF y IF (QERROR) THEN *ENDIF NPS   IF (ACCESS .EQ. 'DIRECT') THEN! IF (TFORM .EQ. 'UNFORMATTED') " $ NCHARS = (LRECL+1)/2 #k OPEN (UNIT=LUN,FILE=TNAME,RECL=NCHARS,STATUS=STATUS,  OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS, $ $ ACCESS=ACCESS,FORM=TFORM,ERR=100) % ELSE &k OPEN (UNIT=LUN,FILE=TNAME,STATUS=STATUS, ! OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS, ' $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ( ENDIF )y*IF NPS *y ENDIF +y*ENDIF NPS , ELSE - IERROR = 3 . ENDIF /*ENDIF PRIME0*IF APOLLO 1 IF (STATUS .EQ. 'SCRATCH') THEN 2 IF (ACCESS .EQ. 'DIRECT') THEN 3 OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, 4 $ ACCESS=ACCESS,FORM=TFORM,ERR=100) 5 ELSE6 OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, 7 $ FORM=TFORM,ERR=100) 8 ENDIF9 ELSEIF (STATUS .EQ. 'NEW') THEN:k IF (FNAME .NE. ' ') THEN " IF (IDDNAM .EQ. 0) THEN ; IF (ACCESS .EQ. 'DIRECT') THEN< OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS, = $ ACCESS=ACCESS,FORM=TFORM,ERR=100) > ELSE ? OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS, @ $ ACCESS=ACCESS,FORM=TFORM,ERR=100) A ENDIF B ELSE C QERROR = .TRUE. D ENDIF E IF (QERROR) THEN F IF (ACCESS .EQ. 'DIRECT') THENG OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, H $ ACCESS=ACCESS,FORM=TFORM,ERR=100) I ELSE J OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,K $ FORM=TFORM,ERR=100) L ENDIF M ENDIFN ELSEIF (STATUS .EQ. 'OLD') THENOk IF (FNAME .NE. ' ') THEN # IF (IDDNAM .EQ. 0) THEN P IF (ACCESS .EQ. 'DIRECT') THENQ OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,ACCESS=ACCESS, R $ STATUS='READONLY',FORM=TFORM,ERR=100) S ELSE T OPEN (UNIT=LUN,FILE=FNAME,STATUS='READONLY', U $ ACCESS=ACCESS,FORM=TFORM,ERR=100) V ENDIF W ELSE X QERROR = .TRUE. Y ENDIF Z IF (QERROR) THEN [ IF (ACCESS .EQ. 'DIRECT') THEN \ OPEN (UNIT=LUN,RECL=NCHARS,STATUS='READONLY', ] $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ^ ELSE _ OPEN (UNIT=LUN,STATUS='READONLY',ACCESS=ACCESS, ` $ FORM=TFORM,ERR=100) a ENDIF b ENDIF c ELSE d IERROR = 3 e ENDIF f*ENDIF APOLLO g*IF DEC20 h IF (STATUS .EQ. 'SCRATCH') THEN i IF (ACCESS .EQ. 'DIRECT') THEN j IF (TFORM .EQ. 'UNFORMATTED') k $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD l OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, m $ ACCESS=ACCESS,FORM=TFORM,ERR=100) n ELSEo OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, p $ FORM=TFORM,ERR=100) q ENDIFr ELSEIF (STATUS .EQ. 'NEW') THENsw CALL NAMCHK(LUN,FNAME,TNAME,'-1') k CALL NAMCHK(LUN,FNAME,TNAME,STATUS,'-1') t IF (ACCESS .EQ. 'DIRECT') THEN u IF (TFORM .EQ. 'UNFORMATTED') v $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD wk OPEN (UNIT=LUN,FILE=TNAME,RECL=NCHARS,STATUS=STATUS, $ OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS, x $ ACCESS=ACCESS,FORM=TFORM,ERR=100) y ELSEzk OPEN (UNIT=LUN,FILE=TNAME,STATUS=STATUS, % OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS, { $ ACCESS=ACCESS,FORM=TFORM,ERR=100) | ENDIF} ELSEIF (STATUS .EQ. 'OLD') THEN~w CALL NAMCHK(LUN,FNAME,TNAME,'0')  k CALL NAMCHK(LUN,FNAME,TNAME,STATUS,'0')  IF (ACCESS .EQ. 'DIRECT') THEN  IF (TFORM .EQ. 'UNFORMATTED')  $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD k OPEN (UNIT=LUN,FILE=TNAME,RECL=NCHARS,ACCESS=ACCESS, & OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,ACCESS=ACCESS,  $ STATUS=STATUS,FORM=TFORM,ERR=100)  ELSEk OPEN (UNIT=LUN,FILE=TNAME,STATUS=STATUS, ' OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ENDIF  ELSE  IERROR = 3  ENDIF *ENDIF DEC20i*IF -IBMi*IF -VAX i*IF -PRIME i*IF -APOLLO i*IF -DEC20 i IF (ACCESS .EQ. 'DIRECT') THEN i*IF UNIVAC i IF (TFORM .EQ. 'UNFORMATTED') i $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD i*ENDIF UNIVAC i OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, i $ ACCESS=ACCESS,FORM=TFORM,ERR=100) i ELSEi OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, i $ FORM=TFORM,ERR=100) i ENDIF i*ENDIF -DEC20 i*ENDIF -APOLLO i*ENDIF -PRIME i*ENDIF -VAX i*ENDIF -IBM *IF CDC  IF (ACCESS .EQ. 'DIRECT') THEN  OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ELSE OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,ACCESS=ACCESS, $ FORM=TFORM,ERR=100)  ENDIF *ENDIF CDC  *IF COS  IF (ACCESS .EQ. 'DIRECT') THEN  OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ELSE OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,ACCESS=ACCESS, $ FORM=TFORM,ERR=100)  ENDIF*ENDIF COS *IF DGEN IF (ACCESS .EQ. 'DIRECT') THEN  OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ELSE OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,ACCESS=ACCESS, $ FORM=TFORM,ERR=100)  ENDIF*ENDIF DGEN *IF HARRIS  IF (ACCESS .EQ. 'DIRECT') THEN  OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ELSE! OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,ACCESS=ACCESS," $ FORM=TFORM,ERR=100) # ENDIF $*ENDIF HARRIS %*IF HP1 & IF (ACCESS .EQ. 'DIRECT') THEN ' OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS, ( $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ) ELSE* OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,ACCESS=ACCESS,+ $ FORM=TFORM,ERR=100) , ENDIF-*ENDIF HP1 .*IF UNIVAC / IF (ACCESS .EQ. 'DIRECT') THEN 0 IF (TFORM .EQ. 'UNFORMATTED') 1 $ NCHARS = (LRECL+NCHRWD-1)/NCHRWD 2 OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, 3 $ ACCESS=ACCESS,FORM=TFORM,ERR=100) 4 ELSE5 OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS, 6 $ FORM=TFORM,ERR=100) 7 ENDIF 8*ENDIF UNIVAC *IF UNIX IF (STATUS .EQ. 'SCRATCH') THEN  IF (ACCESS .EQ. 'DIRECT') THEN  OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ELSE OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,ERR=100) ENDIF ELSEIF (STATUS .EQ. 'NEW') THEN IF (IDDNAM .EQ. 0) THEN  IF (ACCESS .EQ. 'DIRECT') THEN OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ELSE  OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ENDIF  ELSE IF (ACCESS .EQ. 'DIRECT') THEN  OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100)  ELSE  OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,  $ FORM=TFORM,ERR=100)  ENDIF  ENDIF ELSEIF (STATUS .EQ. 'OLD') THEN IF (IDDNAM .EQ. 0) THEN  IF (ACCESS .EQ. 'DIRECT') THEN OPEN (UNIT=LUN,FILE=FNAME,RECL=NCHARS,STATUS=STATUS,  $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ! ELSE " OPEN (UNIT=LUN,FILE=FNAME,STATUS=STATUS, # $ ACCESS=ACCESS,FORM=TFORM,ERR=100) $ ENDIF % ELSE& IF (ACCESS .EQ. 'DIRECT') THEN' OPEN (UNIT=LUN,RECL=NCHARS,STATUS=STATUS, ( $ ACCESS=ACCESS,FORM=TFORM,ERR=100) ) ELSE * OPEN (UNIT=LUN,STATUS=STATUS,ACCESS=ACCESS,+ $ FORM=TFORM,ERR=100) , ENDIF - ENDIF . ELSE / IERROR = 3 0 ENDIF 1*ENDIF UNIX  RETURN C 100 IERROR = 2  RETURN  END OPNLNP 3/22/82-yxtsra_^]TR5,  SUBROUTINE OPNLNP(NU,NAM) C C OPENS ALL FILES USED (EXCEPT ORIGINAL INPUT)C *CA PARAMAR*CA WIDTH t*CA ERRMES t 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 sC The VAX and others use the length in longwords sC (the length of the standard integer word)  C   PARAMETER (LENLIB = (((NCHRWD*NWRDBK)+3)/4))s PARAMETER (LENLIB = (NCHRWD*NWRDBK+NCHRWD-1)/NCHRWD )   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 y*IF DEC20 y CALL NAMCHK(NU,NAM,NAML,'-1')y OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB,STATUS='NEW', y 1 ACCESS='DIRECT',ERR=100)y*ENDIF y*IF -DEC20 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')y*ENDIF  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 y*IF DEC20 y CALL NAMCHK(NU,NAM,NAML,'0')y OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB,STATUS='OLD',y 1 ACCESS='DIRECT',ERR=100) y *ENDIF y *IF -DEC20  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', r*IF -APOLLO r OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB,STATUS='OLD',r*ENDIF r*IF APOLLO r OPEN(UNIT=NU,FILE=NAML,RECL=LENLIB,STATUS='READONLY', r*ENDIF *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', r*IF -APOLLO r OPEN(UNIT=NU,FILE=NAM,RECL=LENLIB,STATUS='OLD', r *ENDIF r *IF APOLLO r OPEN(UNIT=NU,FILE=NAM,RECL=LENLIB,STATUS='READONLY',r *ENDIF *IF VAX  1 READONLY, *EI  1 ACCESS='DIRECT',ERR=100 ) ! ENDIF y*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.' r WRITE(ERRMSG,101) NUr101 FORMAT('**ERROR** Attempt to open file ',I5,' failed.') r CALL WRERR & STOP 'CANNOT OPEN FILE' 'C (C ) ENTRY OPNSPL(NU)*C y*IF DEC20 y OPEN(UNIT=NU,RECL=LENLIB,STATUS='SCRATCH', y 1 ACCESS='DIRECT',ERR=100)y*ENDIF y*IF -DEC20 + 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')y*ENDIF - 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)/4y LENSCI = (MWIDE + NCHRWD -1) / NCHRWD R*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 y*IF DEC20 y OPEN(UNIT=NU,RECL=LENSCI,STATUS='SCRATCH', y 1 ACCESS='DIRECT',ERR=100)y*ENDIF y*IF -DEC20 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')y*ENDIF 4 RETURN 5C 6C 7 ENTRY OPNLCO (NU,NAM) 8C 9C OPEN COMPILE FILE :C 5*IF -IBMy*IF DEC20 y CALL NAMCHK(NU,NAM,NAML,'-1')y OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',ERR=100) y*ENDIF y *IF -DEC20 T 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 y!*ENDIF H RETURN IC JC K ENTRY OPNLOU (NU,NAM) LC MC OPEN OUTPUT LIST FILE NC 5*IF -IBMy"*IF DEC20 y# CALL NAMCHK(NU,NAM,NAML,'-1')y$ OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',ERR=100) y%*ENDIF y&*IF -DEC20 T 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 y'*ENDIF T RETURN UC VC W ENTRY OPNLSO (NU,NAM) XC YC OPEN SOURCE FILEZC 5!*IF -IBMy(*IF DEC20 y) CALL NAMCHK(NU,NAM,NAML,'-1')y* OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',ERR=100) y+*ENDIF y,*IF -DEC20 T 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 y-*ENDIF h RETURN iC jC k ENTRY OPNLOA (NU,NAM) lC mC OPEN NEW ASCII LIBRARY FILE nC 5#*IF -IBMy.*IF DEC20 y/ CALL NAMCHK(NU,NAM,NAML,'-1')y0 OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',ERR=100) y1*ENDIF y2*IF -DEC20 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 y3*ENDIF | RETURN }C ~C  ENTRY OPNLIA (NU,NAM) C C OPEN OLD ASCII LIBRARY FILE C 5%*IF -IBMy4*IF DEC20 y5 CALL NAMCHK(NU,NAM,NAML,'0') y6 OPEN(UNIT=NU,FILE=NAML,STATUS='OLD',ERR=100) y7*ENDIF y8*IF -DEC20 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 y9*ENDIF RETURN C C  ENTRY OPNINX (NU,NAM)  - ENTRY OPNINX(NU,NAM,IERR) C C OPEN INPUT FILE SPECIFIED BY *READ DIRECTIVEC 5'*IF -IBMy:*IF DEC20 y; CALL NAMCHK(NU,NAM,NAML,'0') y< OPEN(UNIT=NU,FILE=NAML,STATUS='OLD',ERR=100) y=*ENDIF y>*IF -DEC20  OPEN(UNIT=NU,FILE=NAM,STATUS='OLD',ERR=100)  . OPEN(UNIT=NU,FILE=NAM,STATUS='OLD',ERR=200) x OPEN(UNIT=NU,FILE=NAM,STATUS='OLD' x*IF VAX x 1 ,READONLY x*ENDIF x 1 ,ERR=200) y?*ENDIF IERR=0 5(*ENDIF RETURN C C  ENTRY OPNLBO(NU,NAM) C BACKUP-OUTPUT (EDIT)C 5)*IF -IBMy@*IF DEC20 yA CALL NAMCHK(NU,NAM,NAML,'-1')yB OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',ERR=100) yC*ENDIF yD*IF -DEC20 T 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 yE*ENDIF  RETURN C C  ENTRY OPNLBI(NU,NAM) C BACKUP-INPUT (EDIT) C 5+*IF -IBMyF*IF DEC20 yG CALL NAMCHK(NU,NAM,NAML,'0') yH OPEN(UNIT=NU,FILE=NAML,STATUS='OLD',ERR=100) yI*ENDIF yJ*IF -DEC20  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 yK*ENDIF " RETURN #C $C % ENTRY OPNLDO(NU,NAM) &C DUMP-OUTPUT (EDIT) 'C 5-*IF -IBMyL*IF DEC20 yM CALL NAMCHK(NU,NAM,NAML,'-1')yN OPEN(UNIT=NU,FILE=NAML,STATUS='NEW',ERR=100) yO*ENDIF yP*IF -DEC20 T 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 yQ*ENDIF 1 RETURN 2C 3C 4 ENTRY OPNLDI(NU,NAM) 5C DUMP-INPUT (EDIT) 6C 5/*IF -IBMyR*IF DEC20 yS CALL NAMCHK(NU,NAM,NAML,'0') yT OPEN(UNIT=NU,FILE=NAML,STATUS='OLD',ERR=100) yU*ENDIF yV*IF -DEC20 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 yW*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 ~|rJH.%!  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 r*CA ERRMES  CHARACTER*8 WORD(40)C  DIMENSION IDM(2)oC .o*IF I4 o INTEGER*4 ISL .o*ENDIF C  CALL GTAWD(WORD,NW,IN)  DCKNAM=WORD(2) C | ID=IFINMD(DCKNAM) | IF(ID.NE.0) THEN| ERRMSG='**ERROR** ADD deck name '//DCKNAM//' has been used'//| 1 'as a Modification Ident - cannot also be used as deck name.' | CALL WRERR | CALL LISERR(IN) | GOTO 9000 | ENDIF | 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) r ERRMSG = '**ERROR** ADD deck '//DCKNAM//' allready exists.' r CALL WRERR # 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)r ERRMSG = ' (The OLD deck has been PURGED)' r CALL WRERR % ENDIF r CALL LISERR(IN) & GOTO 9000 ' ENDIF (C ) IF(NW.GT.2) THEN*z INSL=IFINDK(WORD(3))  INSL=IABS(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 ~ IF(NDCKS.GE.MAXDCK) THEN~ WRITE(ERRMSG,131) MAXDCK ~131 FORMAT('Too many decks for program maximum = ',I5 ~ 1 ,'(parameter MAXDCK must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Too many decks') ~ ENDIF 6 CALL STATIS (1,NDCKS) ! PRINT*,' ADDING DECK ',DCKNAM ! WRITE(LOU,131)DCKNAM!131 FORMAT(10X'ADDING DECK ',A) H PRINT 131,DCKNAMH WRITE(LOU,131) DCKNAM H131 FORMAT(' Post-processing deck ',A) ! CALL LININC(1) r ERRMSG = 'Post-processing deck '//DCKNAM r CALL WRMES 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) Hz CALL SCAN2(BUF(1:IL))  CALL SCANDI(BUF(1:IL)) H o LOCDCK=RVAL(BUF(ISS(1):ISS(1)+ISL(1)-1)) LOCDCK=RVAL(BUF(ISS(1):ISE(1))) H o NBLKS=RVAL(BUF(ISS(2):ISS(2)+ISL(2)-1))  NBLKS=RVAL(BUF(ISS(2):ISE(2))) 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 file.'  CALL WRERR  IERR24 = IERR24 + 1  ENDIF  IF(SSOURF) THEN  ERRMSG='**ERROR** SEARCH requested and separate source '// PDECK 3/22/82~zr  SUBROUTINE PDECK(IN)C C PROCESS 5 - DECK DIRECTIVE C (SET UP PRESORT ARAYS) C *CA PARAMA *CA DECKS *CA INREC *CA INISO r*CA ERRMES  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'r ERRMSG='**ERROR** Deck '//DECNA//' is purged' r CALL WRERR r CALL LISERR(IN)  STOP  CALL THEEND(1,' Stopping in PDECK.')  ENDIF C  PRINT*,'DECK DIRECTIVE - DECK ',DECNA,' NOT FOUND RECORD ',IN r ERRMSG='**ERROR** Deck '//DECNA//' not found' r CALL WRERR r CALL LISERR(IN)  STOP CALL THEEND(1,' Stopping in PDECK.')C 1100 CONTINUEC  IEDIT(I)=1 ~ IF(NINSO.GE.MAXMDK) THEN~ WRITE(ERRMSG,991) MAXMDK ~991 FORMAT('Too many decks being modified within a mod', ~ 1 ' set maximum =',I5,' (parameter MAXMDK must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,' Stopping in PDECK.') ~ ENDIF  NINSO = NINSO+1  INIDK(NINSO)=I z IF(NINSO.GT.MAXMDK) THENz WRITE(ERRMSG,991) MAXMDK z991 FORMAT('**ERROR** too many decks being modified maximum =', z 1 I6, ' (parameter MAXMDK)') z CALL WRERR z STOP z ENDIF z CALL STATIS(4,NINSO)  INICD(NINSO)=IN  C ! RETURN " END DECK has been PURGED)' ) % CALL LININC(1)r ERRMSG = ' (The OLD deck has been PURGED)' r CALL WRERR % ENDIF PDEFIN 3/22/82 ~rp  SUBROUTINE PDEFIN (IN) C C PROCESS 6 - DEFINE DIRECTIVEC *CA PARAMA *CA INREC *CA SWITCHp*CA ERRMES C CHARACTER*9 SWII  CHARACTER*8 SWI,SWIN p CHARACTER*8 SWI p LOGICAL SET   EQUIVALENCE (SWI,SWII),(SWIN,SWII(2:))  C INL=IN  CALL GTFWD(SWII,INL)  IF(SWII.EQ.' ') THEN PRINT*,' BAD SWITCH CARD BLANK SWITCH' p ERRMSG='Improper DEFINE directive (no switch) - ignored' p CALL WRERR r CALL LISERR(IN)  GOTO 8000  ENDIF C  CALL SWIDEF (SWII)  IF(SWII(1:1).EQ.'-') GOTO 500 p~ IF(SWII(1:1).EQ.'-') THEN p~ SET=.FALSE. p~ SWI=SWII(2:) p ~ ELSE p ~ SET=.TRUE. p ~ SWI=SWII p ~ ENDIF ~ DO 100 I=1,NSWS  IF(SWI.EQ. SWITCH(I)) THENp ~ IF(SWI.EQ. SWITCH(I)) GOTO 500 PRINT*,'SWITCH ALLREADY SET ',SWI  GOTO 8000  ENDIF ~100 CONTINUE ~~ IF(NSWS.GE.MAXSWI) THEN ~~ WRITE(ERRMSG,211) MAXSWI ~~211 FORMAT('Too many switches for program maximum =',I5 ~~ 1 ,'(parameter MAXSWI must be increased).') ~~ CALL WRERR ~~ ERRMSG='Error occurred in PDEFIN when switch '//SWI//~~ 1 ' was encountered' ~~ CALL WRERR ~  CALL ENDPRO(2) ~ CALL THEEND(2,'Too many switches') ~ ~ ENDIF ~ NSWS=NSWS+1 ~ SWITCH(NSWS)=SWIp~ LSWTCH(NSWS)=.NOT.SET p~ I=NSWS p~ CALL STATIS(6,NSWS)  PRINT*,'SET SWITCH ',SWI  GOTO 8000 ~C C TURNOFF SWITCH  C !~500 CONTINUEp IF(LSWTCH(I).EQ.SET) THEN r~ IF(LSWTCH(I).EQV.SET) THEN p~ WRITE(ERRMSG,511)SWI,SET p~511 FORMAT('Switch ',A,' was allready ',L2) p~ ELSEp~ WRITE(ERRMSG,513)SWI,SET p~513 FORMAT('Switch ',A,' Changed to ',L2) p~ LSWTCH(I)=SET p~ ENDIF p~ CALL WRERR " 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 CALL EDIFIN(BUX(1:IWID-1)) X CALL EDIPOS X ENDIF ' GOTO 10 (C )C N - NEXT (CR) *PDELET 3/22/82z. 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 100 zn*IF -SMALL z IF(IDECP1.LE.MLAST) GOTO 100 zn*ENDIF zn*IF SMALL zn IF(IDECPT.LE.MLAST) GOTO 100 zn*ENDIF 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) z CALL RECADD(IDNO,NSEQ,INCRD)  NSEQ=NSEQ+1  GOTO 200 C ! 500 CONTINUE " RETURN # END 2 IDECP2=IDECP2+1 3840 CONTINUE zn*IF SMALL zn IDECPT=IDECPT+LNX PEDIT 3/22/82rJ  SUBROUTINE PEDIT (IN) C C PROCESS DIRECTIVES C 4 - COMPILE C 5 - EDITC *CA PARAMA *CA DECKS *CA INREC r*CA ERRMES  C CHARACTER*8 WORD(40) CHARACTER*8 DECKNA  C  INL=IN  CALL GTAWD(WORD,NW,INL) C y IF(NW.EQ.3 .AND. WORD(2).EQ.'.' ) GOTO 1000  IF(NW.EQ.4 .AND. WORD(3).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' r ERRMSG='**ERROR** Edit deck '//DECKNA//' has been purged' r CALL WRERR r CALL LISERR(IN)  ELSE  PRINT*,'DIDNT FIND EDIT DECK ',DECKNA,  1 ' DIRECTIVE RECORD NO ',IN r ERRMSG='**ERROR** Did not find EDIT deck '//DECKNA r CALL WRERR r CALL LISERR(IN)  ENDIF 500 CONTINUE!C " RETURN #C $C FORM IS A.B %1000 CONTINUE &y DECKNA=WORD(1)  DECKNA=WORD(2) ' L1=IFINDK(DECKNA) (y DECKNA=WORD(3)  DECKNA=WORD(4) ) L2=IFINDK(DECKNA) *y IF(L2.LE.L1.OR.L1.EQ.0) GOTO 2000  IF(L2.GT.L1.AND.L1.GT.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 r ERRMSG='**ERROR** Either DECK2 does not follow DECK1 or DECK1'// r 1 ' was not found' r CALL WRERR r CALL LISERR(IN) / RETURN 0C 12000 CONTINUE 2 DO 2010 I=L1,L2 3 IEDIT(I)=1 42010 CONTINUE 5 RETURN 6 END RO',< $ NCHARS,NWORDS,NCHARS*IRECS,NCHARS*MXRECS, = $ NWORDS*IRECS,NWORDS*MXRECS, > $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADYPIDENT 3/22/82~|rR 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 r*CA ERRMES  C CHARACTER*8 IDENT  C  INL=IN  CALL GTFWD(IDENT,INL) C  IF(IDENT.EQ.' ') GOTO 1000 |C | I=IFINDK(IDENT) | IF(I.NE.0) THEN | ERRMSG='**ERROR** Modification ident '//IDENT//' has been '//| 1 'used as a deck name - cannot also be used as modification'// | 2 ' ident.' | GOTO 1110 | ENDIF C  I=IFINMD(IDENT)  IF(I.GT.0) GOTO 1100C ~ IF(NMODS.GE.MAXMNA) THEN~ WRITE(ERRMSG,211) MAXMNA ~211 FORMAT('Too many modification names for program maximum =',I5~ 1 ,'(parameter MAXMNA must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2)  CALL THEEND(2,'Too many mod names') ~ ENDIF  NMODS=NMODS+1  MODNA(NMODS)=IDENT  DATEM(NMODS)=DATE  IDNO=NMODS  RETURN C 1000 PRINT*,'IDENT NOT GIVEN'r1000 ERRMSG='**ERROR** Ident not given'  GOTO 1110 1100 PRINT*,'IDENT ALLREADY IN LIBRARY' r1100 ERRMSG='**ERROR** Ident allready used in library' r 1110 PRINT*,'INPUT CARD NUMBER ',INLOC(IN),' ',BUF R1110 PRINT*,'Input record number ',INLOC(IN),' ',BUF(1:MWIDE) r1110 CALL WRERR r CALL LISERR(IN)  C ! STOP CALL THEEND(1,' Stopping in PIDENT.')  RETURN " END C TURNOFF SWITCH  C !500 CONTINUEp IF(LSWTCH(I).EQ.SET) THEN r IF(LSWTCH(I).EQV.SET) THEN pPINSRT 3/22/82zt SUBROUTINE PINSRT(IN,IDNO,NSEQ)  SUBROUTINE PINSRT(IN,IDNO,NSEQ,MOVOLD) C C PROCESS INSERT DIRECTIVE (IN) C ADD NEW RECORDS FOLLOWING C IN - directive pointer to record C IDNO - modification ident number C NSEQ - current sequence number to use C MOVOLD - logical - .TRUE. = move old record C .FALSE. = dont move old record C *CA PARAMA *CA INREC *CA DECI  LOGICAL MOVOLD  C IDIR=IN  C  C RECMOV WILL MOVE THE RECORD FROM ARAY1 TO ARAY2  C t CALL RECMOV  IF(MOVOLD) 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) z CALL RECADD(IDNO,NSEQ,INCRD)  NSEQ=NSEQ+1  GOTO 200C  500 CONTINUE  RETURN  END IDECP2=IDECP2+1 600 CONTINUE ! IDEC(IDECP2)=IDEC(ILM)+1 " IDECP2=IDECP2+1 # IDECP1=IDECP1+1 $ IDEC(IDECP2)=IDNO PMOVE 3/22/82rC  SUBROUTINE PMOVE(IN)C C PROCESSES MOVE DIRECTIVEC IN - POINTER TO INLOC FOR CARD IMAGEC *CA PARAMA *CA BUFA *CA INREC *CA DECKS r*CA ERRMES  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) Cz CALL SCAN2(BUF(1:IL))  CALL SCANDI(BUF(1:IL)) C  IF(NWRD.LT.2) GOTO 110  ID1=WORD(2) Co ID1=BUF(ISS(2):ISS(2)+ISL(2)-1)  ID1=BUF(ISS(2):ISE(2))  DO 100 NDL=1,NDCKS  IF(ID1.EQ.DECK(NDL)) GOTO 200 100 CONTINUE PRINT*,'DIDNT FIND DECK TO MOVE TO ',ID1  STOPr ERRMSG='**ERROR** Did not find deck to move '//ID1 r CALL WRERR r CALL LISERR(IN) r RETURN C 110 PRINT*,'NO DECK NAMES ON MOVE DIRECTIVE'  STOPr110 ERRMSG='**ERROR** Move directive with no names' r CALL WRERR r CALL LISERR(IN) r RETURN C 200 CONTINUE  DO 400 N=3,NWRD  ID=WORD(N) Co ID=BUF(ISS(N):ISS(N)+ISL(N)-1)  ID=BUF(ISS(N):ISE(N)) ! NN=IFINDK(ID) " IF(NN.NE.0) GOTO 320# PRINT*,'DIDNT FIND DECK TO MOVE ',IDr ERRMSG='**ERROR** Did not find deck '//ID//' to move' r CALL WRERR r CALL LISERR(IN) $ 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 NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBKa CALL STATIS(2,NBLKS*NWRDBK) bPPURGE 3/22/82 rSHDCi SUBROUTINE PPURGE(IN)  SUBROUTINE PPURGE(IN,IDNO) C C PROCESS PURGE DECK DIRECTIVES C iC INTYP C IN - POINTER TO INLOC ARRAYS C IDNO - ident number doing the purging C C *CA PARAMA *CA DECKS  *CA CONTRL D*CALL LOGU C*CALL BUFA C*CALL INREC C*CALL SCAN r*CA ERRMES CHARACTER*8 DCKNAM  C  CALL GTFWD(DCKNAM,IN) C IDL=INLOC(IN) C CALL GETBUF(IDL,IL) Cz CALL SCAN2(BUF(1:IL))  CALL SCANDI(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') r ERRMSG='**ERROR** Purge directive has no deck name' r CALL WRERR r CALL LISERR(IN) S RETURN S ENDIF C DO 200 I=2,NWRD Co DCKNAM=BUF(ISS(I):ISS(I)+ISL(I)-1)  DCKNAM=BUF(ISS(I):ISE(I))C  NPURG = IFINDK(DCKNAM)  IF (NPURG.EQ.0) THEN  PRINT 91, DCKNAMH WRITE(LOU,91) DCKNAM  91 FORMAT(2X,'**ERROR** PURGE DECK ',A,' NOT FOUND')r ERRMSG='**ERROR** Purge deck '//DCKNAM//' not found' r CALL WRERR r CALL LISERR(IN)  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 ENDIFr ERRMSG='**ERROR** Purge deck '//DCKNAM//' allready purged' r CALL WRERR r CALL LISERR(IN)  ELSE i IPURGE(NPURG)=1  IPURGE(NPURG)=IDNO  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)  ENDIFr ERRMSG='Purged deck '//DCKNAM r CALL WRMES  ENDIF C 200 CONTINUE  RETURN  END Vv IF (QREADY.AND.QERROR) CALL NPSEIO('BYFILE VIA OPENER')  PRENAM 5/03/82 rSC?  SUBROUTINE PRENAM(IN) C C PROCESSES RENAME DIRECTIVE C IN - POINTER TO INLOC FOR CARD IMAGEC *CA PARAMA *CA BUFA *CA INREC *CA DECKS r*CA ERRMES  C S*CALL DECA S*CALL LOGU   CHARACTER*20 WORD(40) C*CALL SCAN *CA MODNA CHARACTER*8 ID1,ID2  C  INL = INLOC(IN)  CALL GETBUF(INL,IL) C  CALL SCAN2(BUF(2:IL*NCHRWD),WORD,NWRD) Cz CALL SCAN2(BUF(1:IL))  CALL SCANDI(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 r ERRMSG='**ERROR** Improper RENAME directive' rr CALL WRERR rr CALL LISERR(IN) rr RETURN  GOTO 200  ENDIF  ID1=WORD(2) Co ID1=BUF(ISS(2):ISS(2)+ISL(2)-1)  ID1=BUF(ISS(2):ISE(2)) r NDR=IFINDK(ID1) r IF(NDR.LE.0) THEN  PRINT*,'DIDNT FIND DECK TO RENAME ',ID1  PRINT*,BUF(2:IL*NCHRWD) C PRINT*,BUF(1:IL)  STOP rr ERRMSG='**ERROR** Deck '//ID1//' not found to rename' rr CALL WRERR rr CALL LISERR(IN) r r RETURN r ENDIF rC  rC ! ID2=WORD(3) Cr ID2=BUF(ISS(3):ISS(3)+ISL(3)-1) "r NN=IFINDK(ID2) #r IF(NN.EQ.0) THEN $ DECK(NDL)=ID2% PRINT*,'RENAMED DECK ',ID1,' TO ',DECK(NDL) ?r DECK(NDR)=ID2 S ISDEC1=1 r r ISDEC1=1 S CALL RDDK(1,NN) r r CALL RDDK(1,NDR) S CALL INAL(ADEC(IDECP1),IDECP1,DECK(NDR))r r CALL INAL(ADEC(IDECP1),IDECP1,DECK(NDR)) S CALL WRDK(LSR,LOCLSR,1,NBLOK(NDR)) r r CALL WRDK(LSR,LOCLSR,1,NBLOK(NDR)) ? PRINT*,' Renamed deck',NDR,ID1,' to ',DECK(NDR) rr ERRMSG='Renamed deck '//ID1//' to '//DECK(NDR) rr CALL WRMES ?r &r ELSE' PRINT*,'NEW DECK NAME TO RENAME DECK ',ID1, ( 1 ' TO ALLREADY EXISTS ',ID2 ) STOP 'NEW NAME ALLREADY IN DECK' rr ERRMSG='**ERROR** Rename name '//ID1//' allready exists' rr CALL WRERR rr CALL LISERR(IN) *r ENDIF  ND1=IABS(IFINDK(ID1))  NM1=IFINMD(ID1) C  IF(ND1.EQ.0.AND. NM1.EQ.0) THEN  ERRMSG='**ERROR** Deck ( or modifiction set) '//  1 ID1//' not found to rename' GOTO 200 ENDIF  C  o ID2=BUF(ISS(3):ISS(3)+ISL(3)-1)  ID2=BUF(ISS(3):ISE(3))  C  ND2=IFINDK(ID2)  NM2=IFINMD(ID2) C  IF(ND2.NE.0.OR.NM2.NE.0)THEN ERRMSG='**ERROR** New name on RENAME directive '//ID2//  1 ' Allready used on deck or modification set'  GOTO 200  ENDIF C  IF(ND1.NE.0) THEN C  DECK(ND1)=ID2  ISDEC1=1 n CALL RDDK(1,ND1) m CALL RDDK(ND1) m NDKMEM=1  NDKMEL = 0  CALL RDDK('L', ND1, ILDECK, 0)  CALL INAL(ADEC(IDECP1),IDECP1,DECK(ND1)) m CALL WRDK(LSR,LOCLSR,1,NBLOK(ND1))  CALL WRDK('L',LSR,LOCLSR,1,NBLOK(ND1))  ERRMSG='Renamed deck '//ID1//' to '//DECK(ND1)  CALL WRMES  C ! ELSE "C # MODNA(NM1)=ID2 $ ERRMSG='Renamed modification set '//ID1//' to '//MODNA(NM1) % CALL WRMES & ENDIF + RETURN '200 CALL WRERR ( CALL LISERR(IN) ) RETURN , END ECP1+1 ) IDECP2=IDECP2+1 *700 CONTINUE z n*IF SMALL z n IDECPT = IDECP1 z n*ENDIF +t DO 1000 I=1,NOMODS  NM=1720 IF(MODRC1(NM).NEPRESTO 3/22/82z 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 n  IDIR = IN  MLAST = MODRC2(IM) C 100 CALL RECRES(IDIR,IDNO)  IF(IDECP1.LE.MLAST) GOTO 100 zn*IF -SMALL z IF(IDECP1.LE.MLAST) GOTO 100 zn*ENDIF zn*IF SMALL zn IF(IDECPT.LE.MLAST) GOTO 100 zn*ENDIF C  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) z CALL RECADD(IDNO,NSEQ,INCRD)  NSEQ=NSEQ+1  GOTO 200C 500 CONTINUE ! RETURN " END  GOTO 200 C ! 500 CONTINUE " RETURN # END 2 IDECP2=IDECP2+1 3840 CONTINUE zn*IF SMALL zn IDECPT=IDECPT+LNX PROC3 3/22/82zwrZXVS  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 r*CA ERRMES C *CA MODNA *CALL SEPFIC  CHARACTER*8 STP,LTP w CHARACTER STP*8, LTP*12 C C C WE WILL SET UP SORT AND PROCESS C MODS FOR EACH IDENT SEPARATELY C SnC Set up YANK and UPDATE switches Sn IYANK=0 Sn 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 o GOTO( 101, 101, 50, 104, 50, 106, 50, 104, 50, 210, 50  GOTO( 101, 101, 50, 104, 50, 106, 50, 104, 50, 210, 50, 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 ro 1 , 50, 113, 50, 50, 116, 117, 118, 119, 50), IT n 1 113, 50, 50, 116, 117, 118, 119, 50, 50, 50, 50), IT  1 113, 50, 50, 116, 50, 50, 119, 50, 50, 50, 50, 50), 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 Ci116 CALL PPURGE(ID) 116 CALL PPURGE(ID,IDNO) D IPRD(ID)=.TRUE. E GOTO 50 SiC SiC 17 - UPDATE SiC Si117 IF (ICN) THEN S i IUPDAT=ID S i IPRD(ID)=.TRUE. S i ELSES  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.') ri ERRMSG='**ERROR** UPDATE requested but no new library '//ri 1 '- ignored' ri CALL WRERR ri CALL LISERR(IN) Si ENDIF Si GOTO 50 SiC SiC 18 - YANK SiC Si118 IF (ICN) THEN Xi IF(.NOT.ICS) THENX WRITE(LOU,1181) X PRINT 1181X1181 FORMAT(' YANK Directive encountered but SOURCE file not' X 1 ,' requested.',20X,'Directive will NOT be processed.') ri ERRMSG='**ERROR** YANK requested but not source file '// ri 1 '- ignored' r i CALL WRERRr i CALL LISERR(IN) Xi GOTO 50 i ELSE IF(SSOURF) THENi ERRMSG='**ERROR** YANK requested and separate source' i 1 //' files also - program doesnt do both will stop' i CALL WRERRi CALL LISERR(IN) i CALL THEEND(2,' YANK and separate source files') Xi ENDIF Si IYANK =ID Si IPRD(ID)=.TRUE. zi*IF SMALL zi ERRMSG='**ERROR** YANK requested which cannot be processed'//zi 1 ' by this program - ignored' zi CALL WRERR zi CALL LISERR(IN) zi*ENDIF Si ELSES PRINT 1171, 'YANK' S WRITE(LOU,1171) 'YANK' r i ERRMSG='**ERROR** YANK requested but no new library '// r i 1 '- ignored' r i CALL WRERR ri CALL LISERR(IN) Si ENDIF Si 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)) w CALL HEADER('Modifications - '//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' w LTP = ' Deck ' p ELSE q STP = '*AC ' r LTP = 'COMDECK' w LTP = 'Common deck ' s ENDIF tC u NIA = 0 v NAC = 0 wC x IF(ICL) THEN C change header h CALL HEADCH( 'Modifications - '//MODNA(IDNO)//DECK(NDECK) )  CALL HEADCH('Modifications - '//MODNA(IDNO)// 1 ' '//DECK(NDECK)) 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) r ERRMSG=' ' r CALL WROUT r ERRMSG=' '//LTP//'**** '//DECK(NDECK)//' ****' w ERRMSG=' '//LTP//'**** '//DECK(NDECK)//' **** '//w 1 'being modified/edited' r CALL WROUT  CALL WRMES r ERRMSG=' ' r CALL WROUT r CALL WROUT  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 n9000 CONTINUESnC S IF(IUPDAT.NE.0) CALL PUPDAT(ID) Vn IF(IUPDAT.NE.0) CALL PUPDAT(IUPDAT) S C IF(IYANK.NE.0) CALL PYANK(ID) V IF(IYANK.NE.0) CALL PYANK(IYANK) zn IF(IYANK.NE.0) THEN zn*IF -SMALL z n CALL PYANK(IYANK)z n*ENDIF z n ENDIF z n 9000 CONTINUE RETURN  END 1 '*END '//DNAME//' '//GNAME,24)  1 PRFX//'END '//DNAME//' '//GNAME,24) Q ENDIF R ENDIF S ELSEIF(.NOT.COUNT) THENTh ERRMSG = '*CALLG group '//GNAME//' not found in common deck ' ERRMSG = 'Called group '//GNAME//' not found in common deck' U 1 PROC4 3/22/82{wtr  SUBROUTINE PROC4C C WRITES COMPILE/SOURCE AND OUTPUT AS REQUESTED C *CA PARAMA *CA DECKS *CA CONTRL *CA LOGU *CA MODCOM r*CA CPLDIR r*CA LANGC r*CA ERRMES *CA SEPFIC *CA FNAMES *CA WIDTH *CALL DIRDIC*CALL DIRSTA*CALL DECA CHARACTER*4 ATP  CHARACTER*72 NAMTMP  CHARACTER STATUS*8 n LOGICAL ILST  LOGICAL ILST, ILSTC C   ILST = ISL.AND.(LSTA.OR.LSTI)  ILST=ICL.AND.(LSTA.OR.LSTI)  ILSTC = ILST .OR. ICS .OR. SCALLF  IF(.NOT.ILST .AND..NOT.ICC .AND..NOT. ICS ) THEN CALL WRTIO (' No listing requested')  RETURN  ENDIF w IHEAD = 0C r IF (LANG .EQ. 2 .AND. IWNAM .EQ. 0 ) THEN tl IF (LANG .EQ. 2 .AND. NCPLDI .EQ. 0 ) THEN rl NCPLDI = 6 rl CPLDI = ' ' rl ENDIF  IRECS = 10 u MXRECS = 25000  MXRECS = 5000 C  IF(ICC.AND..NOT.SCOMPF) THENk CALL OPENER(LCO,NAMLCO(1:IWLCO),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LCO,'COMPILE',NAMLCO,IWLCO,STATUS,IDDNAM) CALL OPENER(LCO,NAMLCO(1:IWLCO),IDDNAM,STATUS,'SEQUENTIAL',  $ 'FORMATTED',MWIDEC,IRECS,MXRECS,IERR) IF(IERR.NE.0) THEN  ERRMSG = ' Unable to open COMPILE file '// 1 NAMLCO(1:IWLCO) CALL WRMES CALL THEEND(2, ' Couldnt open compile file')  ENDIF  ENDIF C  IF(ICS.AND..NOT.SSOURF) THENk CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LSO,'SOURCE',NAMLSO,IWLSO,STATUS,IDDNAM)  CALL OPENER(LSO,NAMLSO(1:IWLSO),IDDNAM,STATUS,'SEQUENTIAL',  $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR)  IF(IERR.NE.0) THEN  ERRMSG = ' Unable to open SOURCE file '//  1 NAMLSO(1:IWLSO)  CALL WRMES CALL THEEND(2, ' Couldnt open source file')  ENDIF  ENDIF rC h IF(ILST) THEN  CALL HEADER ('ACTIVE/INACTIVE RECORDS') wh CALL HEADER ('Deck list processing') wh IHEAD = 1 h ENDIF C  DO 1000 N=1,NDCKS  IF(IPURGE(N).NE.0) GOTO 1000 r  IF(ITYPE(N).EQ.0.AND.DECK(N).EQ.'VLEVEL') IEDIT(N)=1 wp IF(ITYPE(N).EQ.0.AND.DECK(N).EQ.'VLEVEL') IEDIT(N)=2 C do not edit VLEVEL unless an *ID was readn IF(DECK(N).EQ.'VLEVEL'.AND. n 1 ITYPE(N).EQ.0 .AND. NODIR(10).GT.0) IEDIT(N)=2 IF(DECK(N).EQ.'VLEVEL'.AND. ITYPE(N).EQ.0 1 .AND. IEDIT(N).EQ.0 .AND. NODIR(10).GT.0) IEDIT(N)=2  IF(.NOT.ICF.AND.(IEDIT(N).EQ.0)) THEN {n IF(ICF) THEN {n IEDIT(N)=1 n CALL RDDK(1,N){n ELSEIF(IEDIT(N).EQ.0) THEN n IF(ICQ.OR.(NMODC.EQ.0)) GOTO 1000 n CALL RDDK(1,N)n CALL CKDKMC(N,IMCMN) n IF(IMCMN.EQ.0) GOTO 1000 n ELSE n CALL RDDK(1,N) n ENDIF IF(ITYPE(N) .NE. 0 ) THEN IF(.NOT.ILSTC ) GOTO 1000 IF(IEDIT(N).EQ.0 .AND. .NOT.ICF) GOTO 1000  ENDIF  IF(ICF) THEN  IEDIT(N)=1 m NDKMEM = 1 m CALL RDDK(N)  NDKMEL = 0 CALL RDDK('L', N, ILDECK, 0)  ELSEIF(IEDIT(N) .EQ. 0 .AND. ITYPE(N) .EQ.0) THEN  IF(ICQ.OR.(NMODC.EQ.0)) GOTO 1000 m NDKMEM = 1 m CALL RDDK(N)  NDKMEL = 0 CALL RDDK('L', N, ILDECK, 0)  CALL CKDKMC(N,IMCMN)  IF(IMCMN.EQ.0) GOTO 1000  ELSE m NDKMEM = 1 m CALL RDDK(N)  NDKMEL = 0 CALL RDDK('L', N, ILDECK, 0)  ENDIF  IF(ILST) THEN IF( IHEAD.EQ.0) THEN  CALL HEADER ('Lists processing '//DECK(N) )  IHEAD = 1  ELSE  CALL HEADCH ('Lists processing '//DECK(N) )  ENDIF  WRITE(LOU,111) 111 FORMAT(' ')  WRITE(LOU,115) DECK(N)115 FORMAT(20X,'DECK **** ',A,' ****')  WRITE(LOU,111)  CALL LININC(3) r ERRMSG=' ' r CALL WROUTr ERRMSG=' Deck **** '//DECK(N)//' ****' r CALL WROUT r ERRMSG=' ' r CALL WROUTw ELSEIF ( (ICL) .AND. (IEDIT(N).NE.1) ) THEN { ELSEIF (ICL.AND.ITYPE(N).EQ.0.AND.(IEDIT(N).NE.1)) THEN wC w IF( IHEAD .EQ. 0 ) THEN wh CALL HEADER('Listings processing')  CALL HEADER('Lists processing '//DECK(N)) w IHEAD=1  ELSE  CALL HEADCH ('Lists processing '//DECK(N) ) w ENDIF w C w ERRMSG=' ' w CALL WROUTw ERRMSG=' Deck **** '//DECK(N)//' ****'// w 1 ' (automatically edited by program)' w CALL WROUT w ERRMSG = ' ' w CALL WROUT ! ENDIF  NRECCF = MXRECS  NRECSF = MXRECS *IF NUMREC  n IF( (ICC.AND.SCOMPF.AND.ITYPE(N).EQ.0) .OR.  IF( (ICC.AND.SCOMPF .AND. (ITYPE(N).EQ.0.OR.SCALLF)) .OR. 1 (ICS.AND.SSOURF) ) THEN  n CALL LISLEN(N,NRECCF,NRECSF)  CALL LISDCK(N,.TRUE.,NRECCF,NRECSF) *IF SMALL  NDKMEL = 0  CALL RDDK('L', N, ILDECK, 0) *ENDIF SMALL ENDIF *ENDIF NUMREC x IF(ICC.AND.SCOMPF) THEN n IF(ICC.AND.SCOMPF.AND.ITYPE(N).EQ.0) THEN IF(ICC.AND.SCOMPF .AND. (ITYPE(N).EQ.0.OR.SCALLF) ) THEN n CALL FILEID(LCO,DECK(N),NAMLCO)  CALL FILEID(NAMLCO(1:IWLCO), NAMTMP, DECK(N)) n IWLCO = ITRAIL(NAMLCO)! IWTMP = ITRAIL(NAMTMP)n CALL OPENER(LCO,NAMLCO(1:IWLCO),'NEW','SEQUENTIAL', "k CALL OPENER(LCO,NAMTMP(1:IWTMP),'NEW','SEQUENTIAL',  STATUS = 'NEW' CALL FILECK(LCO,'COMPILE',NAMTMP,IWTMP,STATUS,IDDNAM)  CALL OPENER(LCO,NAMTMP(1:IWTMP),IDDNAM,STATUS, $ 'SEQUENTIAL',  u $ 'FORMATTED',MWIDEC,IRECS,MXRECS,IERR) $ 'FORMATTED',MWIDEC,NRECCF,NRECCF,IERR) ! IF(IERR.NE.0) THEN" ERRMSG = ' Unable to open COMPILE file '// #n 1 NAMLCO(1:IWLCO) # 1 NAMTMP(1:IWTMP) $ CALL WRMES % CALL THEEND(2, ' Couldnt open compile file') & ENDIF ' ENDIF(C ) IF(ICS.AND.SSOURF) THEN *n CALL FILEID(LSO,DECK(N),NAMLSO) $ CALL FILEID(NAMLSO(1:IWLSO), NAMTMP, DECK(N)) +n IWLSO = ITRAIL(NAMLSO)% IWTMP = ITRAIL(NAMTMP),n CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL', &k CALL OPENER(LSO,NAMTMP(1:IWTMP),'NEW','SEQUENTIAL', STATUS = 'NEW' CALL FILECK(LSO,'SOURCE',NAMTMP,IWTMP,STATUS,IDDNAM)  CALL OPENER(LSO,NAMTMP(1:IWTMP),IDDNAM,STATUS, $ 'SEQUENTIAL', -u $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR)  $ 'FORMATTED',MWIDE,NRECSF,NRECSF,IERR) . IF(IERR.NE.0) THEN/ ERRMSG = ' Unable to open SOURCE file '// 0n 1 NAMLSO(1:IWLSO) ' 1 NAMTMP(1:IWTMP) 1 CALL WRMES 2 CALL THEEND(2, ' Couldnt open source file') 3 ENDIF 4 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 WRTIO(' Begin list processing of '//DECK(N)) +z CALL RDDK(1,N) ,n CALL LISDCK(N) ( CALL LISDCK(N,.FALSE.,NRECCF,NRECSF) 5x IF(ICC.AND.SCOMPF) THEN  IF(ICC.AND.SCOMPF.AND.ITYPE(N).EQ.0) THEN 6 CALL CLSFIL(LCO) 7 ENDIF8C 9 IF(ICS.AND.SSOURF) THEN : CALL CLSFIL(LSO) ; ENDIF -1000 CONTINUE . RETURN / END PROFIL 11/20/84'  SUBROUTINE PROFIL C C SETUP SUBROUTINE WHICH READS A STARTUP FILE TO CONFIGURE THE C SLIB77 PROGRAM C *IF PROFILE *CALL PARAMA*CALL BATCH *CALL EDIOPTS *CALL FSECOM n*CALL FILEIDS  *CALL LANGC  *CALL SCAN  *CALL SEQCTL*CALL WIDTH C  CHARACTER CARD*72, CMND*20, CCASE*5  INTEGER LPI   LPI = 10  REWIND (UNIT=LPI)  REWIND (UNIT=LPI) C C READ FIRST LINE OF PROFILE, IF NO FILE ATTACHED GO WRITE ONE C  READ(LPI,2010,END=2000,ERR=2000) CARD  GOTO 100C C READ NEXT LINE OF PROFILEC 10 READ(LPI,2010,END=9000) CARDC C DECODE PROFILE COMMAND C 100 CALL SCANDI(CARD) !o CMND = CARD(ISS(1):ISS(1)+ISL(1)-1)  CMND = CARD(ISS(1):ISE(1)) " IF (CMND .EQ. 'MODE') THEN # IF (CARD(ISS(2):ISS(2)) .NE. '=') GOTO 10 $o IF (CARD(ISS(3):ISS(3)+ISL(3)-1) .EQ. 'NOTSET') THEN  IF (CARD(ISS(3):ISE(3)) .EQ. 'NOTSET') THEN % PMODE = 'NOTSET'&o ELSEIF (CARD(ISS(3):ISS(3)+ISL(3)-1) .EQ. 'BATCH') THEN  ELSEIF (CARD(ISS(3):ISE(3)) .EQ. 'BATCH') THEN ' PMODE = 'BATCH' ( TMODE = 'BATCH' )o ELSEIF (CARD(ISS(3):ISS(3)+ISL(3)-1) .EQ. 'LEDIT') THEN  ELSEIF (CARD(ISS(3):ISE(3)) .EQ. 'LEDIT') THEN * PMODE = 'LEDIT' +o ELSEIF (CARD(ISS(3):ISS(3)+ISL(3)-1) .EQ. 'FSEDIT') THEN  ELSEIF (CARD(ISS(3):ISE(3)) .EQ. 'FSEDIT') THEN , PMODE = 'FSEDIT' - ELSE . CALL WRTIO(' *PROFILE ERROR* invalid program MODE '// /o $ CARD(ISS(3):ISS(3)+ISL(3)-1)) $ CARD(ISS(3):ISE(3))) 0 ENDIF 1 GOTO 10 2 ENDIF 3 IF (CMND .EQ. 'EDIT') THEN 4 IF (CARD(ISS(3):ISS(3)) .NE. '=') GOTO 10 5 UPCASE = .TRUE. 6o IF (CARD(ISS(4):ISS(4)+ISL(4)-1) .EQ. 'MIXED') UPCASE=.FALSE.  IF (CARD(ISS(4):ISE(4)) .EQ. 'MIXED') UPCASE=.FALSE. 7 GOTO 10 8 ENDIF 9 IF (CMND .EQ. 'SEQUENCING') THEN: IF (CARD(ISS(2):ISS(2)) .NE. '=') GOTO 10 ;o LSEQC = RVAL(CARD(ISS(3):ISS(3)+ISL(3)-1)) LSEQC = RVAL(CARD(ISS(3):ISE(3))) < GOTO 10 = ENDIF  IF (CMND .EQ. 'BUTTON') THEN IF (CARD(ISS(3):ISS(3)) .NE. '=') GOTO 10  IFORM = RVAL(CARD(ISS(2):ISE(2)))  IF (IFORM.LE.0 .OR. IFORM.GT.MAXBUT) THEN  CALL WRTIO(' *PROFILE ERROR* invalid BUTTON index '//  $ CARD(ISS(2):ISE(2))) ELSE  BUTTON(IFORM) = CARD(ISS(3)+1:) ENDIF GOTO 10 ENDIF  IF (CMND .EQ. 'FORMS') THEN  IF (CARD(ISS(3):ISS(3)) .NE. '=') GOTO 10  IFORM = RVAL(CARD(ISS(2):ISE(2)))  IF (IFORM.LE.0 .OR. IFORM.GT.MAXFRM) THEN  CALL WRTIO(' *PROFILE ERROR* invalid FORMS index '//  $ CARD(ISS(2):ISE(2)))  ELSE  FORMS(IFORM) = CARD(ISS(3)+1:)  ENDIF  GOTO 10  ENDIF >n*IF IBMVM ?n IF (CMND .EQ. 'READDISK') THEN @n IF (CARD(ISS(2):ISS(2)) .NE. '=') GOTO 10 An RDISK = CARD(ISS(2)+1:) Bn GOTO 10 Cn ENDIF Dn IF (CMND .EQ. 'WRITEDISK') THEN En IF (CARD(ISS(2):ISS(2)) .NE. '=') GOTO 10 Fn WDISK = CARD(ISS(2)+1:) Gn GOTO 10 Hn ENDIF In*ENDIF IBMVMJn IF (CMND .EQ. 'COMEXT') THEN IF (CMND .EQ. 'FILEID') THENK IF (CARD(ISS(3):ISS(3)) .NE. '=') GOTO 10 Lo IF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'FORTRAN') THEN  n IF (CARD(ISS(2):ISE(2)) .EQ. 'FORTRAN') THEN  IF (CARD(ISS(2):ISE(2)) .EQ. 'FORTRAN') THEN Mn COMEXT(1) = CARD(ISS(3)+1:)  COMFID(1) = CARD(ISS(3)+1:) No ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'COBOL') THEN  ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'COBOL') THEN On COMEXT(2) = CARD(ISS(3)+1:)  COMFID(2) = CARD(ISS(3)+1:) Po ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'ASSEMBLE') THEN  ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'ASSEMBLE') THENQn COMEXT(3) = CARD(ISS(3)+1:) Rn ELSE Sn CALL WRTIO(' *PROFILE ERROR* invalid LANGUAGE '// To $ CARD(ISS(2):ISS(2)+ISL(2)-1)) n $ CARD(ISS(2):ISE(2))) Un ENDIF Vn GOTO 10 Wn ENDIF Xn IF (CMND .EQ. 'PREID') THEN Yn IF (CARD(ISS(3):ISS(3)) .NE. '=') GOTO 10 Zo IF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'COMPILE') THEN  n IF (CARD(ISS(2):ISE(2)) .EQ. 'COMPILE') THEN [n PREID(1) = CARD(ISS(3)+1:) \o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'LISTING') THENn ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'LISTING') THEN ]n PREID(2) = CARD(ISS(3)+1:) ^o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'SLIBRARY') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'SLIBRARY') THEN_n PREID(3) = CARD(ISS(3)+1:) `o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'COMMANDS') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'COMMANDS') THENan PREID(4) = CARD(ISS(3)+1:) bo ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'SOURCE') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'SOURCE') THEN cn PREID(5) = CARD(ISS(3)+1:) do ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'PORTLIB') THENn ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'PORTLIB') THEN en PREID(6) = CARD(ISS(3)+1:) fo ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'BACKUP') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'BACKUP') THEN gn PREID(7) = CARD(ISS(3)+1:) ho ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'CONTINUE') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'CONTINUE') THENin PREID(8) = CARD(ISS(3)+1:) jn ELSE kn CALL WRTIO(' *PROFILE ERROR* invalid PREID type '// COMFID(3) = CARD(ISS(3)+1:)  ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'DATA') THEN COMFID(4) = CARD(ISS(3)+1:)  ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'MODIFY') THEN  MODFID = CARD(ISS(3)+1:) ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'BACKUP') THEN  BAKFID = CARD(ISS(3)+1:) ELSE  CALL WRTIO(' *PROFILE ERROR* invalid FILEID type '// lo $ CARD(ISS(2):ISS(2)+ISL(2)-1)) $ CARD(ISS(2):ISE(2))) m ENDIF n GOTO 10 o ENDIF pn IF (CMND .EQ. 'POSTID') THENqn IF (CARD(ISS(3):ISS(3)) .NE. '=') GOTO 10 ro IF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'COMPILE') THEN n IF (CARD(ISS(2):ISE(2)) .EQ. 'COMPILE') THEN sn POSTID(1) = CARD(ISS(3)+1:) to ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'LISTING') THENn ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'LISTING') THEN un POSTID(2) = CARD(ISS(3)+1:) vo ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'SLIBRARY') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'SLIBRARY') THENwn POSTID(3) = CARD(ISS(3)+1:) xo ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'COMMANDS') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'COMMANDS') THENyn POSTID(4) = CARD(ISS(3)+1:) zo ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'SOURCE') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'SOURCE') THEN {n POSTID(5) = CARD(ISS(3)+1:) |o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'PORTLIB') THENn ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'PORTLIB') THEN }n POSTID(6) = CARD(ISS(3)+1:) ~o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'BACKUP') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'BACKUP') THEN n POSTID(7) = CARD(ISS(3)+1:) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'CONTINUE') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'CONTINUE') THENn POSTID(8) = CARD(ISS(3)+1:) n ELSE n CALL WRTIO(' *PROFILE ERROR* invalid POSTID type '// o $ CARD(ISS(2):ISS(2)+ISL(2)-1))n $ CARD(ISS(2):ISE(2))) n ENDIF n GOTO 10 n ENDIF n IF (CMND .EQ. 'EXIST') THEN n IF (CARD(ISS(3):ISS(3)) .NE. '=') GOTO 10 o IF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'COMPILE') THEN n IF (CARD(ISS(2):ISE(2)) .EQ. 'COMPILE') THEN r EXIST(1) = RVAL(CARD(ISS(4)+1:))n EXIST(1) = RVAL(CARD(ISS(4):)) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'LISTING') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'LISTING') THEN r EXIST(2) = RVAL(CARD(ISS(4)+1:))n EXIST(2) = RVAL(CARD(ISS(4):)) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'SLIBRARY') THEN !n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'SLIBRARY') THENr EXIST(3) = RVAL(CARD(ISS(4)+1:))n EXIST(3) = RVAL(CARD(ISS(4):)) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'COMMANDS') THEN "n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'COMMANDS') THENr EXIST(4) = RVAL(CARD(ISS(4)+1:))n EXIST(4) = RVAL(CARD(ISS(4):)) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'SOURCE') THEN #n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'SOURCE') THEN r EXIST(5) = RVAL(CARD(ISS(4)+1:))n EXIST(5) = RVAL(CARD(ISS(4):)) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'PORTLIB') THEN$n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'PORTLIB') THEN r EXIST(6) = RVAL(CARD(ISS(4)+1:))n EXIST(6) = RVAL(CARD(ISS(4):)) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'BACKUP') THEN %n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'BACKUP') THEN r EXIST(7) = RVAL(CARD(ISS(4)+1:))n EXIST(7) = RVAL(CARD(ISS(4):)) o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'CONTINUE') THEN &n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'CONTINUE') THENr EXIST(8) = RVAL(CARD(ISS(4)+1:))n EXIST(8) = RVAL(CARD(ISS(4):)) n ELSE n CALL WRTIO(' *PROFILE ERROR* invalid EXIST type '//o $ CARD(ISS(2):ISS(2)+ISL(2)-1))'n $ CARD(ISS(2):ISE(2))) n ENDIF n GOTO 10 n ENDIF C C INVALID PROFILE COMMAND C  CALL WRTIO(' *PROFILE ERROR* invalid command '//CMND) GOTO 10 C C PROFILE NOT FOUND, WRITE ONE C 2000 CALL WRTIO(' *PROFILE* STARTUP file (10) not found,'//  $ ' one will be written.') CALL CLSFIL(LPI) WRITE(LPI,2010) 'MODE =', PMODE CCASE = 'MIXED'  IF (UPCASE) CCASE = 'UPPER'  WRITE(LPI,2010) 'EDIT CASE =', CCASE WRITE(LPI,2020) 'SEQUENCING =',LSEQC  DO 2100 I = 1,MAXBUT2100 WRITE(LPI,2020) 'BUTTON ',I,' ='//BUTTON(I)(1:ITRAIL(BUTTON(I)))  DO 2110 I = 1,MAXFRM2110 WRITE(LPI,2020) 'FORMS ',I,' ='//FORMS(I)(1:ITRAIL(FORMS(I))) n*IF IBMVM n WRITE(LPI,2010) 'READDISK =', RDISKn WRITE(LPI,2010) 'WRITEDISK =', WDISK n*ENDIF IBMVMn WRITE(LPI,2010) 'COMEXT FORTRAN =', COMEXT(1) n WRITE(LPI,2010) 'COMEXT COBOL =', COMEXT(2) n WRITE(LPI,2010) 'COMEXT ASSEMBLE =', COMEXT(3) n WRITE(LPI,2010) 'PREID COMPILE =', PREID(1) n WRITE(LPI,2010) 'POSTID COMPILE =', POSTID(1) n WRITE(LPI,2020) 'EXIST COMPILE =',EXIST(1)n WRITE(LPI,2010) 'PREID LISTING =', PREID(2) n WRITE(LPI,2010) 'POSTID LISTING =', POSTID(2) n WRITE(LPI,2020) 'EXIST LISTING =',EXIST(2)n WRITE(LPI,2010) 'PREID SLIBRARY =', PREID(3) n WRITE(LPI,2010) 'POSTID SLIBRARY =', POSTID(3) n WRITE(LPI,2020) 'EXIST SLIBRARY =',EXIST(3)n WRITE(LPI,2010) 'PREID COMMANDS =', PREID(4) n WRITE(LPI,2010) 'POSTID COMMANDS =', POSTID(4) n WRITE(LPI,2020) 'EXIST COMMANDS =',EXIST(4)n WRITE(LPI,2010) 'PREID SOURCE =', PREID(5) n WRITE(LPI,2010) 'POSTID SOURCE =', POSTID(5) n WRITE(LPI,2020) 'EXIST SOURCE =',EXIST(5)n WRITE(LPI,2010) 'PREID PORTLIB =', PREID(6) n WRITE(LPI,2010) 'POSTID PORTLIB =', POSTID(6) n WRITE(LPI,2020) 'EXIST PORTLIB =',EXIST(6)n WRITE(LPI,2010) 'PREID BACKUP =', PREID(7) n WRITE(LPI,2010) 'POSTID BACKUP =', POSTID(7) n WRITE(LPI,2020) 'EXIST BACKUP =',EXIST(7)n WRITE(LPI,2010) 'PREID CONTINUE =', PREID(8) n WRITE(LPI,2010) 'POSTID CONTINUE =', POSTID(8) n WRITE(LPI,2020) 'EXIST CONTINUE =',EXIST(8) WRITE(LPI,2010) 'FILEID FORTRAN =', COMFID(1)  WRITE(LPI,2010) 'FILEID COBOL =', COMFID(2)  WRITE(LPI,2010) 'FILEID ASSEMBLE =', COMFID(3)  WRITE(LPI,2010) 'FILEID DATA =', COMFID(4)  WRITE(LPI,2010) 'FILEID BACKUP =', BAKFID WRITE(LPI,2010) 'FILEID MODIFY =', MODFID 2010 FORMAT(2A) d2020 FORMAT(A,I8) 2020 FORMAT(A,I8,A) CALL CLSFIL(LPI)C C FINISHED READING PROFILE C *ENDIF PROFILE 9000 RETURN  END = ' SOURCE'0n POSTID(5) = ' SOURCE' /PSERCH 2/13/85 n SUBROUTINE PSERCH(NSERCH,SERCHS,LSERCH)  SUBROUTINE PSERCH C nC Process SEARCH directives (called from INP) nC NSERCH - number of search stringsnC SERCHS - search string nC LSERCH - length of each search stringC Process SEARCH directivesC C *CA PARAMA  *CA MODNA  *CA DECKS  *CA LOGU *CA DECA*CALL SERCHC*CALL FNAMES*CALL ERRMES*CALL WIDTH  nC n CHARACTER*(MAXWID) SERCHS (NSERCH) n DIMENSION LSERCH(NSERCH)C  CHARACTER*8 NAM, DATD, DCK  CHARACTER STATUS*8  LOGICAL FOUND  DIMENSION IDD(5) EQUIVALENCE(LNX, IDD(1)),(IDK,IDD(2)),(ISQ,IDD(3))  1 ,(IDEL,IDD(4)),(NMR,IDD(5)) C C  IRECS=10 MXRECS = 5000  k CALL OPENER(LMO,NAMLMO(1:IWLMO),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LMO,'MODIFY',NAMLMO,IWLMO,STATUS,IDDNAM) CALL OPENER(LMO,NAMLMO(1:IWLMO),IDDNAM,STATUS,'SEQUENTIAL',  $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR) IF(IERR.NE.0) THEN  ERRMSG = ' Unable to open modify file '// 1 NAMLMO(1:IWLMO)  CALL WRMES  CALL THEEND(2,'Couldnt open modify file')  ENDIF  DO 5000 N=1,NDCKS  IF(IPURGE(N).NE.0) GOTO 5000 n CALL RDDK(1,N) m NDKMEM = 1 m CALL RDDK(N)  NDKMEL = 0  CALL RDDK('L', N, ILDECK, 0)  NWRITS = 0 n IDECP1=ISDEC(1) m IDECP1=MEMSTR(1)  IDECP1=MEMSTL(1)  CALL EXAL(ADEC(IDECP1),IDECP1,NAM)  CALL EXAL(ADEC(IDECP1),IDECP1,DATD)  IDECP1 = IDECP1 + 1  CALL EXIN(IDECP1,NMD,1) IDECP1 = IDECP1 + NMD!C "500 IDECPT=IDECP1# CALL EXIN(IDECP1,IDD(1),5) $ IF(LNX.EQ.0) GOTO 5000 % IF(IDEL.GT.0) THEN &j IDECP1=IDECPT+LNX 'j GOTO 500  GOTO 1000 ( ENDIF)C * IDECP1=IDECP1+NMR+ LENA=(LNX-NMR-5)*NCHRWD , CALL PSERCX (ADEC(IDECP1),LENA, - 1 NSERCH,SERCHS,LSERCH,FOUND) . IF(.NOT.FOUND) THEN /j IDECP1=IDECPT+LNX 0j GOTO 500  GOTO 1000 1 ENDIF 2 IF(NWRITS.EQ.0) THEN 3n WRITE(LSO,115)'*DECK ',DECK(N) WRITE(LMO,115)'*DECK ',DECK(N) 4115 FORMAT(60A) 5 NWRITS=NWRITS+1 6 ENDIF 7 IF(IDK.EQ.0) THEN8n WRITE(LSO,121) ISQ  WRITE(LMO,121) ISQ 9121 FORMAT('*D ',I6) : ELSE;n WRITE(LSO,131)MODNA(IDK),ISQ  WRITE(LMO,131)MODNA(IDK),ISQ <131 FORMAT('*D ',A,'.',I6) = ENDIF>n CALL WRSERC(LSO,ADEC(IDECP1),LENA,DCK) a CALL WRSERC(LMO,ADEC(IDECP1),LENA,DCK)  CALL WRSERC(LMO,ADEC(IDECP1),LENA) ? NWRITS=NWRITS+2 @j IDECP1=IDECPT+LNX 1000 IDECP1=IDECPT+LNX*IF SMALL  IF (IDECP1 .GE. MEMSTL(1) + NWRDBK ) THEN  IDECP1 = IDECP1 - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1), NWRDBK)  CALL RDNEXR ('L', 1) ENDIF  *ENDIF SMALL A GOTO 500 B5000 CONTINUE  CALL CLSFIL(LMO) C RETURN D END i WRITE(NAM,11) NU  WRITE(NAM,11) 'FOR', NU # IWNAM = 6 $ ENDIF %*ENDIF VAX *IF APOLLO  IF (NAM .EQ. ' ') THEN  WRITE(NAM,11) 'FOR', NU  IWNAM = 6  ENDIF *ENDIF APOLLO PSERCX 2/13/85 SUBROUTINE PSERCX (A,LENA,NSERCH,SERCHS,LSERCH,FOUND)C C Search string A for each search string C A - record to search C NSERCH - number of search stringsC SERCHS - search string C LSERCH - length of each search stringC FOUND - true if match is found false if not  C  *CA PARAMA CHARACTER*(MAXWID) A CHARACTER*(MAXWID) SERCHS (NSERCH) DIMENSION LSERCH(NSERCH)C  LOGICAL FOUND C  DO 100 I=1,NSERCH  IF(INDEX( A(1:LENA), SERCHS(I)(1:LSERCH(I))).NE.0) THEN  FOUND = .TRUE.  RETURN  ENDIF 100 CONTINUE  FOUND = .FALSE.  RETURN  END  IDECP1=ISDEC(1)  CALL EXAL(ADEC(IDECP1),IDECP1,NAM)  CALL EXAL(ADEC(IDECP1),IDECP1,DATD)  IDECP1 = IDECP1 + 1  CALL EXIN(IDECP1,NMD,1) PUPDAT 3/09/83n SUBROUTINE PUPDAT(IN)  SUBROUTINE PUPDAT 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 *IF SMALL  LOCDN = LOCLSR *ENDIF SMALL  NDCKS=NDCKS+1 n CALL RDDK(1,N) m NDKMEM=1 m CALL RDDK(N)  NDKMEL = 0  CALL RDDK('L', N, ILDECK, 0) C C Start OLD and NEW decksC n IDECP1=1 m IDECP1 = MEMSTR(1)  IDECP1 = MEMSTL(1) n IDECP2=ISDEC(2) m IDECP2=MEMSTR(2)  IDECP2 = MEMSTL(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 Bj IDECP1=IDECP1+LNX Cj GOTO 500  GOTO 700 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 Wj IDECP1=IDECP1+LNX 700 IDECP1=IDECP1+LNX*IF SMALL  IF (IDECP1 .GE. MEMSTL(1) + NWRDBK ) THEN  IDECP1 = IDECP1 - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1), NWRDBK) CALL RDNEXR ('L', 1) ENDIF  IF (IDECP2 .GE. MEMSTL(2) + NWRDBK) THEN IDECP2 = IDECP2 - NWRDBK  CALL WRPL1 (LSR, LOCLSR, IDEC(MEMSTL(2)))  LOCLSR = LOCLSR + 1  CALL TRDEC (MEMSTL(2) + NWRDBK, MEMSTL(2), NWRDBK)  ENDIF *ENDIF SMALLXC Y GOTO 500 ZC [C END OF DECK\C ]1000 CONTINUE ^ IDEC(IDECP2)=0 *IF SMALL  CALL WRPL1 (LSR, LOCLSR, IDEC(MEMSTL(2)))  LOCLSR = LOCLSR + 1  NBLKS = LOCLSR - LOCDN  LOCB(NDECK) = LOCDN  IF(NBLKS.GT.1) THEN  CALL RDPL1 (LSR, LOCDN, IDEC(MEMSTL(2)))  ENDIF  GOTO 1010 1002 CONTINUE*ENDIF SMALL _ CALL STATIS(2,IDECP2)`n NBLKS=(IDECP2+1-ISDEC(2)+NWRDBK-1)/NWRDBKm NBLKS=(IDECP2+1-MEMSTR(2)+NWRDBK-1)/NWRDBK  NBLKS=(IDECP2+1-MEMSTL(2)+NWRDBK-1)/NWRDBK  LOCB (NDCKS) = LOCLSR 1010 CONTINUE an IDEC(ISDEC(2)+2*NW8C)=NBLKS m IDEC(MEMSTR(2)+2*NW8C)=NBLKS  IDEC(MEMSTL(2)+2*NW8C)=NBLKS  IEDIT(N) = 1 b LOCF (NDCKS)= LSR c LOCB (NDCKS)= LOCLSR d NBLOK (NDCKS)= NBLKS *IF SMALL ! CALL WRPL1 (LSR, LOCDN, IDEC(MEMSTL(2))) " GOTO 3000 #1020 CONTINUE $*ENDIF SMALLem CALL WRDK(LSR,LOCLSR,2,NBLKS) CALL WRDK('L',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)  IEDIT(NDCKS) = IEDIT(N) s IIDENT (NDCKS)= 1 t IPURGE (NDCKS)= 0 u5000 CONTINUE vC w RETURN x END listing requested')  RETURN  ENDIF w IHEAD = 0C r IF (LANG .EQ. 2 .AND. IWNAM .EQ. 0 ) THEN tl IF (LANGPVLEVL 4/25/84t SUBROUTINE PVLEVL(A,X,LENX) C C Moves character string A into XC substituting latest modname for $ID$ C and date of latest modname for $DA$ C Thus creating X of Length LENX *CA PARAMA *CA MODNA  *CA ERRMES  *CA WIDTH CHARACTER*(*) A x CHARACTER*(MAXWID) X  CHARACTER*(MAXWID) X, Y  C  LBL=INDEX(A,' ')C  IF (LBL.NE.4.AND.LBL.NE.8) GOTO 900 C  X=A(LBL+1:) x LX=LEN(A)  LX = LEN(A) - LBL  IF (LX.LT.1) GOTO 900  Y = X(1:LX) 10 LID=INDEX(X(1:LX),'$ID$')  IF(LID.NE.0) THEN  LX=LX+4 x X(LID:LX)=MODNA(NMODS)//X(LID+4:) X(LID:LX)=MODNA(NMODS)//Y(LID+4:)  Y = X(1:LX)  GOTO 10  ENDIF 20 LDA=INDEX(X(1:LX),'$DA$')  IF(LDA.NE.0) THEN  LX=LX+4 x X(LDA:LX)=DATEM(NMODS)//X(LDA+4:) X(LDA:LX)=DATEM(NMODS)//Y(LDA+4:)  Y = X(1:LX)  GOTO 20  ENDIF LENX=LX ! IF(LENX.GT.MWIDE) THEN " ERRMSG='**ERROR** VLEVEL record too wide - was shortened to:' # CALL WRERR $ LENX=MWIDE % ERRMSG=X(1:LENX) & CALL WRERR ' ENDIF ( RETURN )C *900 ERRMSG='**ERROR** Improper *VLEVEL record - no action taken' + CALL WRERR , ERRMSG=A - CALL WRERR t LENX=LEN(A) . X(1:LENA)=A t X(1:LENX)=A / LENX=LEN(A) 0 RETURN 1 END ENDIF C  DO 1000 N=1,NDCKS  IF(IPURGE(N).NE.0) GOTO 1000 r  IF(ITYPE(N).EQ.0.AND.DECK(N).EQ.'VLEVEL') IEDIT(N)=1 w IF(ITYPE(N).EQ.0.AND.DECK(N).EQ.'VLEVEL') IEDIT(N)=2 PYANK 3/17/83&zna\Xn SUBROUTINE PYANK (IN)  SUBROUTINE PYANK (IDENT)  EXTERNAL KOMYAN,SWAYAN C C Deactivate modification setsC Mod sets written on source C New library written zn*IF -SMALL *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 n*CA ERRMES n*CA SEPFIC *CA FNAMES  LOGICAL NEWDK  CHARACTER*8 IDENT  CHARACTER STATUS*8 C C MN() - Mod number (used with current record being written) C MS() - Sequence number associated with MN C n INL=IN n CALL GTFWD(IDENT,INL) nC n IF(IDENT.EQ.' ') GOTO 10nC  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) n10 CONTINUEn ERRMSG='(PYANK) - YANK directive ident '//IDENT//' not found ' nn 1 //'record ignored'  1 //'run aborted' n CALL WRERR nn CALL LISERR(INL) CALL THEEND(2,'Yank IDENT not found') ' RETURN (C )80 CONTINUEC  IRECS=10 u MXRECS=25000  MXRECS = 5000 n CALL OPENER(LSO,NAMLSO(1:IWLSO),'NEW','SEQUENTIAL', k CALL OPENER(LMO,NAMLMO(1:IWLMO),'NEW','SEQUENTIAL',  STATUS = 'NEW'  CALL FILECK(LMO,'MODIFY',NAMLMO,IWLMO,STATUS,IDDNAM) CALL OPENER(LMO,NAMLMO(1:IWLMO),IDDNAM,STATUS,'SEQUENTIAL',  $ 'FORMATTED',MWIDE,IRECS,MXRECS,IERR)  IF(IERR.NE.0) THEN  n ERRMSG = ' Unable to open SOURCE file '// ERRMSG = ' Unable to open modify file '// n 1 NAMLSO(1:IWLSO)  1 NAMLMO(1:IWLMO) CALL WRMES  n CALL THEEND(2, ' Couldnt open source file')  CALL THEEND(2,'Couldnt open modify file') ENDIF * NEWDKS=0 + NMODDK=0 , IRECLO=NIN+1 - IRECLN=IRECLO .C Loop thru each deck /C 0 DO 5000 NDK=1,NDCKS 1 NEWDK=.FALSE. 2n CALL RDDK(1,NDK) m NDKMEM=1 m CALL RDDK(NDK)  NDKMEL = 0  CALL RDDK('L', NDK, ILDECK, 0) 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 mod IF(IPURGE(NDK) .GE. IMOD) GOTO 100 9 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 Xi IEDIT(NDK)=1 100 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 i YANREC='*DECK '//DECK(NDK) i CALL YWRR  GOTO 3900 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) IEDIT(NDK) = 2 X CALL YWRR X C X 1360 LTYPE=1 C this is start of loop thru deck records C IREC = 0 r IF(.NOT.NEWDCK.AND.IDEC(IR(N(IREC))+1).EQ.NM) THEN IF(.NOT.NEWDK.AND.IDEC(IR(N(IREC))+1).EQ.NM) THEN  YANREC='*I 0'  CALL YWRR  LTYPE=4  ENDIF 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 i IF(IRECLO.GT.IRECLN) THEN 3900 IF(IRECLO .GT. IRECLN) THEN C 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  m CALL WRDK(LSR,LOCLSR,1,NBLKS) CALL WRDK('L',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*n WRITE(LSO,7001) '*IDENT ',MODNA(NM) WRITE(LMO,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 3n7090 WRITE(LSO,7001) YANREC(1:NC)  7090 WRITE(LMO,7001) YANREC(1:NC) 47100 CONTINUE 58000 CONTINUE 6 ENDIF 7C Xn ICS=.FALSE. zn*ENDIF n CALL CLSFIL(LSO) CALL CLSFIL(LMO)*ENDIF SMALL 8 RETURN 9 END IF NPS #*IF IBM w CALL NAMCHK(LUN,FNAME,TNAME,' ')k CALL NAMCHK(LUN,FNAME,TNAME,STATUS,' ') $ IF (STATUS .EQ. 'SCRATCH') THEN %*IF NPS *IF -IBMMVS QIKSRT 3/22/82\h SUBROUTINE QIKSRT(MM,NN,KOMPAR,SWAP)hC hC ALGORITHM 271 (QUICKERSORT BY R.S. SCOWEN,) hC MAR. 1965 COMMUNICATIONS OF THE ACM hC hC hC THIS PROCEDURE USES A METHOD SIMILAR TO THAT OF QUICKSORT. hC BY C.A.R. HOARE (ALGORITHMS 63,64, COMM.ACM 4 JULY 1961) hC  hC MODIFIED TO USE SHELL SORT ON PARTITIONS OF 15 OR LESS.  hC (1/18/79 BY A.H. SCHMIDT,JR.)  hC  h DIMENSION MSTACK(20),NSTACK(20) h LOGICAL SORTED,EXCHGhC h M=MM h N=NN h SORTED=.FALSE. h LEVEL=0 hC hC REPEAT-UNTIL(SORTED) PARTITION-AND-SORT hC h5 IF (.NOT.SORTED) GOTO 10 hC h RETURN hC hC hC ******************************************************* hC TO PARTITION-AND-SORT hC h10 CONTINUE h NUM=N-M+1!hC " IF(NUM .GT. 15) THEN \h IF(NUM .GT. 15) GOTO 60 #hC PARTITION-THE-ARRAY $ GO TO 60 \h 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 \h40 IF(LEVEL .GT.0) GOTO 120 \h 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 :h GOTO 5 ;hC <hC =hC *************************************************** >hC TO PARTITION-THE-ARRAY ?hC @h60 I=M Ah J=N Bh K= (M+N)/2 ChC DhC UNTIL (I.GE.J) E70 IF(I.GE.J) GO TO 20 \h70 IF(I.GE.J) GO TO 110 FhC GhC LOCATE ITEM AT I END THAT SHOULD GO TO J END HhC Ih80 IF (KOMPAR(I,K).GT.0.OR.I.GE.N) GO TO 90 Jh I=I + 1 Kh GO TO 80 LhC MhC LOCATE ITEM AT J END THAT SHOULD GO TO I END NhC Oh90 IF(KOMPAR(J,K).LT.0.OR.J.LE.M) GO TO 100 Ph J=J-1 Qh GO TO 90 RhC ShC SWAP MISPOSITIONED ITEMS ThC Uh100 IF (I.LT.J) THEN Vh CALL SWAP(I,J) Wh J=J-1 Xh I=I+1 YhC Zh ELSE IF (I.LT.K) THEN [h CALL SWAP (I,K) \h I=I+1 ]hC ^h ELSE IF (J.GT.K) THEN _h CALL SWAP (J,K) `h J=J-1 ahC bh ENDIF ch GO TO 70 dhC ehC END UNTILfhC ghC ENDTO hhC ihC *************************************************** jhC TO PUSH-LARGEST-PARTITION-ON-STACK khC lh110 LEVEL=LEVEL + 1 mhC nh IF(J-M.LT.N-I) THEN oh MSTACK(LEVEL)=I ph NSTACK(LEVEL)=N qh N=J rhC sh ELSE th MSTACK(LEVEL)=M uh NSTACK(LEVEL)=J vh M=I whC xh ENDIFyhC zhC END-TO { GOTO 30 \h GOTO 5 |hC }hC *************************************************** ~hC TO POP-NEXT-PORTION-FROM-STACK hC h120 M=MSTACK(LEVEL) h N=NSTACK(LEVEL) h LEVEL=LEVEL-1hC hC END-TO  GOTO 50 \h GOTO 5 hC hC *************************************************** hC TO SHELL-SORT-PARTITION-OF-15-OR-LESS hC h130 IF(NUM.GT.1) THEN h NUM=NUM/2 h K=N-NUM h J=M h140 I=J h150 EXCHG=.FALSE.h IF(KOMPAR(I,I+NUM).GT.0) THENh CALL SWAP(I,I+NUM) h EXCHG=.TRUE. h I=I-NUM hC h ENDIFhC h IF(EXCHG.AND.I.GE.M) GO TO 150 h J=J+1h IF(J.LE.K) GO TO 140 h GO TO 130hC h ENDIF hC hC ENDTO h GO TO 40hC h END  SUBROUTINE QIKSRT(ISTART,ISTOP,KOMPAR,SWAP) C C Algorithm 271 (QUICKSORT by R.S. Scowen)C Mar. 1965 Communications of the ACM C This procedure uses a method similar to that of QUICKSORT C by C.A.R. Hoare (alforithms 63,64 - COMM.ACM July 4, 1961 C Modified to use shell sort on partitions of 15 or less C (1/18/79 by A.H.Schmidt jr.) C  C ARGUMENTS C INTEGER ISTART, ISTOP  C C ISTART -- beginning array location to sortC ISTOP -- ending array location to sort C C C LOCAL VARIABLES C  PARAMETER (MAXSTK=20)  INTEGER LEVEL, BSTACK(MAXSTK),ESTACK(MAXSTK)  INTEGER BEGIN, IEND, NUM, MIDDLE g LOGICAL EXCHG C C MAXSTK -- MAXIMUM NUMBER OF ITEMS IN SORT STACK C LEVEL -- CURRENT NUMBER OF PARTITIONSC BSTACK -- ARRAY OF BEGINNING LOCATIONS OF SUBARRAYS TO SORT C ESTACK -- ARRAY OF ENDING LOCATIONS OF SUBARRAYS TO SORT C BEGIN -- CURRENT STARTING LOCATION OF SORT PARTITION C IEND -- CURRENT ENDING LOCATION OF SORT PARTITION C NUM -- NUMBER OF ITEMS TO SORT IN PARTITION C MIDDLE -- HALFWAY POSITION IN SORT PARTITION !gC EXCHG -- TRUE IF ITEM SHOULD BE SWAPPED "C #C $C INITIALIZE %C & BEGIN = ISTART ' IEND = ISTOP ( LEVEL = 0 )C *C Partition array and sort small sections +C ,10 NUM = IEND - BEGIN + 1 - IF (NUM .GT. 15) THEN .C /C --- partition the array to sort .LE. 15 elements with SHELL sort0C sort partition into more or less general order 1C 2 I = BEGIN 3 J = IEND 4 MIDDLE = (BEGIN+IEND)/2 5 20 IF (I .LT. J) THEN 6C locate item at I end that should go to J end 7 30 IF (KOMPAR(I,MIDDLE).LE.0 .AND. I.LT.IEND) THEN 8 I = I + 1 9 GOTO 30 : ENDIF ;C locate item at J end that should go to I end < 40 IF (KOMPAR(J,MIDDLE).GE.0 .AND. J.GT.BEGIN) THEN = J = J - 1 > GOTO 40 ? ENDIF @C swap mispositioned items A IF (I .LT. J) THEN B CALL SWAP(I,J) C J = J - 1 D I = I + 1 E ELSE IF (I .LT. MIDDLE) THEN F CALL SWAP(I,MIDDLE) G I = I + 1 H ELSE IF (J .GT. MIDDLE) THEN I CALL SWAP (J,MIDDLE) J J = J - 1 K ENDIF L GOTO 20 M ENDIF NC save largest partition on stack O IF (LEVEL .GE. MAXSTK) THEN PC exceeds maximum number of items in sort stack - abort Qg J = I/0  LEVEL=0  J = I/LEVEL R ENDIF SC T LEVEL = LEVEL + 1 U IF (J-BEGIN .LT. IEND-I) THEN V BSTACK(LEVEL) = I W ESTACK(LEVEL) = IEND X IEND = J Y ELSE Z BSTACK(LEVEL) = BEGIN [ ESTACK(LEVEL) = J \ BEGIN = I ] ENDIF ^C return to beginning to sort smaller partition _ ELSE `C SHELL sort a 50 IF (NUM .GT. 1) THEN b NUM = NUM / 2 c MIDDLE = IEND - NUM d J = BEGIN e 60 I = J fg 70 EXCHG = .FALSE. gg IF (KOMPAR(I,I+NUM) .GT. 0) THEN  70 IF (KOMPAR(I,I+NUM) .GT. 0) THEN h CALL SWAP(I,I+NUM) ig EXCHG = .TRUE. j I = I - NUM  IF (I.GE.BEGIN) GOTO 70 k ENDIF lg IF (EXCHG .AND. I.GE.BEGIN) GOTO 70 m J = J + 1 n IF (J .LE. MIDDLE) GOTO 60 o GOTO 50 p ENDIF qC completed sorting those items r IF (LEVEL .GT. 0) THEN sC pop next partition from stack t BEGIN = BSTACK(LEVEL) u IEND = ESTACK(LEVEL) v LEVEL = LEVEL - 1 w ELSE xC sorted all items in list y RETURN z ENDIF { ENDIF | GOTO 10 } END 3RDBLKC 7/26/84 SUBROUTINE RDBLKC ( LUN, IARAY, NW) C C reads a block of character data from file C  CHARACTER*(*) IARAY(NW) C  READ (LUN) IARAY  RETURN  END INTEGER LUN, LRECL, IRECS, MXREC, IERROR C  *CALL PARAMA RDBLKI 7/26/84 SUBROUTINE RDBLKI ( LUN, IARAY, NW) C C reads a block of integer (or real) data from file C  DIMENSION IARAY(NW) C  READ (LUN) IARAY  RETURN  END INTEGER LUN, LRECL, IRECS, MXREC, IERROR C  *CALL PARAMA RDDK 3/22/82 ~zx.n SUBROUTINE RDDK(NA,NDECK) m SUBROUTINE RDDK(NDECK)  SUBROUTINE RDDK(UPLOW, NDECK, ILDECK, LCALL)C nC READ DECK IN FROM LIBRARY FILE C read deck NDECK in from library fileC C UPLOW U or L for upper or lower C NDECK - Deck numberC ILDECK - pointer to deck memory number C LCALL - level of calling C 0 = deckC 1 = common from deck C 2 = common from common etc.  C C *CA PARAMA *CA DECKS *CA DECI ~*CALL ERRMESC .*IF I4 n INTEGER*4 NW m INTEGER*4 NW, NWS  INTEGER*4 MLOC, ISTART, IEND, NCALL, NREAD .*ENDIF C *IF SMALL  DIMENSION LBLKRL(MAXDCU),LBLKRU(MAXDCL) C C LBLKRU - last block read - upper C LBLKRL - last block read - lower C *ENDIF SMALL CHARACTER*(*) UPLOW  C  DATA NCALL /0/  DATA NREAD /0/ C  NCALL = NCALL + 1 C zn*IF -SMALL LU= LOCF(NDECK)  LO=LOCB(NDECK) x NR = LOCB(NDECK) n NW=ISDEC(NA) NBLKS=NBLOK(NDECK) *IF SMALL NBLKS = MIN0(NBLKS,2)  *ENDIF SMALL~n IF (NBLKS*NWRDBK.GT. ISDEC(2) ) THEN  NWRDS = NBLKS * NWRDBK m IF (NDKMEM.EQ.1) THEN m NWS = 1 m ELSE m DO 20 I = 1, NDKMEM-1 m IF(NDECK.EQ.MEMDCK(I)) THEN  m ERRMSG='**ERROR** Deck '//DECK(NDECK)// m 1 ' is being read in and it is allready in' m CALL WRERR  m CALL THEEND(2,'Deck in memory twice') m ENDIF m20 CONTINUE m NWS = MEMEND(NDKMEM-1) + 1 m ENDIF mC m MEMDCK(NDKMEM) = NDECK mC m MEMSTR(NDKMEM) = NWSm MEMEND(NDKMEM) = NWS + NWRDS m NW = NWSm IF (MEMEND(NDKMEM) .GT. MAXWRD ) THEN ~m ERRMSG='Deck '//DECK(NDECK)//' Too large for program' ~m 1 //' (parameter MAXWRD must be increased).' ~m CALL WRERR ~ CALL ENDPRO(2) n CALL THEEND(2,'Deck too large')m CALL THEEND(2,'Insufficient array size (MAXWRD)') ~m ENDIF  NR=LO m DO 100 I=1,NBLKSm CALL RDPL1(LU,NR,IDEC(NW)) n NR=NR+1 m NR = NR + 1 n NW=NW+NWRDBK m NW = NW + NWRDBK m100 CONTINUEm CALL STATIS(2,NW+NWRDBK)  IF(UPLOW .EQ. 'L') THEN C C lower ****************************************** LOWER C  NDKMEL = NDKMEL + 1  IF(NDKMEL .GT. MAXDCL) THEN  ERRMSG = 'Too many decks for low memory (MAXDCL)'  CALL WRERR CALL THEEND(2,' Too many decks for low memory (MAXDCL)')  ENDIFC ILDECK = NDKMEL  MEMDCL(NDKMEL) = NDECK  ISTART = MEMSTL(NDKMEL)  IEND = ISTART + NWRDS - 1! MEMSTL(NDKMEL+1) = IEND + 1 "C # IF(NDKMEU.EQ.0) GOTO 110 $ NTEMP = NDKMEU % DO 100 I=NTEMP , 1, -1 & IF(IEND .GE. MEMSTU(I)) THEN ' NDKMEU = NDKMEU - 1 ( ELSE ) GOTO 2000 * ENDIF +100 CONTINUE ,C -110 IF(IEND .GT. MAXWRD) THEN. ERRMSG = '**ERROR** Insufficient memory for deck'// / 1 DECK(NDECK) 0 CALL WRERR1 CALL THEEND(2,' Insufficient memory (MAXWRD)') 2 ENDIF 3 GOTO 20004C 5 ELSE 6C 7C upper ************************** UPPER8C  *IF SMALL  IF (LCALL .LT. 2) NDKMEU = 0 *ENDIF SMALL*IF PRIME C until Prime fixes the segment problem we will not allow C multiple decks in memory  IF(LCALL.EQ.0) NDKMEU = 0*ENDIF PRIME 9 DO 500 I = 1, NDKMEU : IF(NDECK .EQ. MEMDCU(I)) THEN ; ILDECK = I < NCALLD(I) = NCALL = RETURN > ENDIF ?500 CONTINUE @C A IENDLO = MEMSTL(NDKMEL+1) - 1BC C600 IF(NDKMEU .GE. MAXDCU .OR. D 1 IENDLO + NWRDS .GT. MEMSTU(NDKMEU)) GOTO 900EC F NDKMEU = NDKMEU + 1 G ILDECK = NDKMEU H MEMDCU(NDKMEU) = NDECK I ISTART = MEMSTU(NDKMEU-1) - NWRDSJ MEMSTU(NDKMEU) = ISTART K NCALLD(NDKMEU) = NCALL L GOTO 2000MC NC Need room for deck -get rid of one not needed OC P900 CONTINUE Q NDUM = NDKMEUR DO 1000 I = NDUM, 1, -1 S IF(NCALLD(I) .GT. NCALL-LCALL) GOTO 1000 TC UC get rid of this deckVC W IF(I .EQ. NDKMEU) THENX NDKMEU = NDKMEU - 1 Y GOTO 600 Z ENDIF [C \ NWRMOV = MEMSTU(I-1) - MEMSTU(I) ]C ^ DO 930 J = MEMSTU(I)-1, MEMSTU(NDKMEU), -1_ IDEC(J-NWRMOV) = IDEC(J) `930 CONTINUE aC b DO 950 J = I+1, NDKMEUc MEMDCU(J-1) = MEMDCU(J)d MEMSTU(J-1) = MEMSTU(J) - NWRMOV e MEMCUU(J-1) = MEMCUU(J) - NWRMOV f NCALLD(J-1) = NCALLD(J) g950 CONTINUE h NDKMEU = NDKMEU-1 i GOTO 600 j1000 CONTINUE k ERRMSG = '**ERROR** Insufficient memory for deck'// l 1 ' and its common decks' m CALL WRERR n CALL THEEND(2,' Insufficient memory (MAXWRD)') oC pC q ENDIF rC sC t2000 NREAD = NREAD + 1 u MLOC = ISTART v DO 4000 I=1,NBLKS w CALL RDPL1(LU,NR,IDEC(MLOC)) x NR = NR + 1 y MLOC = MLOC + NWRDBK z4000 CONTINUE*IF SMALL C  IF (UPLOW .EQ. 'L' ) THEN  LBLKRL(ILDECK) = NR - 1  ELSE  LBLKRU(ILDECK) = NR - 1  ENDIF C *ENDIF SMALL  RETURN *IF SMALL C  ENTRY RDNEXR (UPLOW,ILDECK) C C read the next record into the appropriate IDEC arrayC  IF (UPLOW .EQ. 'L' ) THEN  NBLKR = LBLKRL(ILDECK) + 1  IDECK = MEMDCL(ILDECK) ! MLOC = MEMSTL(ILDECK) + NWRDBK " ELSE # NBLKR = LBLKRU(ILDECK) + 1 $ IDECK = MEMDCU(ILDECK) % MLOC = MEMSTU(ILDECK) + NWRDBK & ENDIF 'C ( IF (NBLKR .LT. LOCB(IDECK) + NBLOK(IDECK)) THEN ) CALL RDPL1(LOCF(IDECK),NBLKR,IDEC(MLOC)) * ENDIF +C , IF (UPLOW .EQ. 'L' ) THEN - LBLKRL(ILDECK) = NBLKR . ELSE / LBLKRU(ILDECK) = NBLKR 0 ENDIF 1C 2 RETURN 3*ENDIF SMALLzn*ENDIF zn*IF SMALL zn SAVE LU,NR,NBLKT,IRELOC,NREAD zn DIMENSION LU(2),NR(2),NBLKT(2),IRELOC(2),NREAD(2) znC zn LU(NA) = LOCF(NDECK) zn NR(NA)=LOCB(NDECK) z n IRELOC(NA)=ISDEC(NA)+NWRDBK z n NBLKT(NA)=NBLOK(NDECK) z n NBLKS=MIN0(NBLKT(NA),2) z n NREAD(NA)=NBLKS z nC zn CALL RDPL1(LU(NA),NR(NA),IDEC(ISDEC(NA))) zn NR(NA)=NR(NA)+1 zn IF(NBLKS.GT.1) THEN zn CALL RDPL1(LU(NA),NR(NA),IDEC(IRELOC(NA))) zn NR(NA)=NR(NA)+1 zn ENDIF zn RETURN znC zn ENTRY RDNEXR (NA) znC znC Read the next record into The appropriat IDEC array znC (for SMALL only) znC zn IF(NREAD(NA).LT.NBLKT(NA)) THEN zn CALL RDPL1(LU(NA),NR(NA),IDEC(IRELOC(NA))) zn NR(NA)=NR(NA)+1 zn NREAD(NA)=NREAD(NA)+1 zn ENDIF z n RETURN z!n*ENDIF  END 1 U IF (J-BEGIN .LT. IENRDINP 3/22/82 |rf`\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 r*CA ERRMES \*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) r ERRMSG='**ERROR** Input record too wide - it ' r 1 //'will be shortened' r CALL WRERR Y  PRINT 61, 'From -' r ERRMSG='From -' r CALL WRERR Y ISPRT=1 Y62 PRINT 61, BUF(ISPRT:MIN0(IWID,ISPRT+78)) r62 ERRMSG= BUF(ISPRT:MIN0(IWID,ISPRT+78)) r CALL WRERR Y ISPRT=ISPRT+79 Y IF(ISPRT.LT.IWID) GOTO 62YC Y PRINT 61, 'To -' r ERRMSG='To -' r CALL WRERR Y ISPRT=1 Y68 PRINT 61, BUF(ISPRT:MIN0(MWIDE,ISPRT+78))r 68 ERRMSG=BUF(ISPRT:MIN0(MWIDE,ISPRT+78)) r CALL WRERR 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) C C 23 is *ENDDATA directiveC  IF(ITT.EQ.23) GOTO 100  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 |v ELSEIF(BUF(2:2).EQ.'!' ) THEN  ELSEIF(BUF(2:2).EQ.'''' ) THEN | ITT = MAXDIR+1 | GOTO 100 H ENDIF Z ENDIFE CALL CKINP(ITT,IWID)  ELSE  ITT = 0  ENDIF f CALL CKINP(ITT,BUF(1:IWID)) C  IT = ITT |100 IT = ITT RETURN !C "C ...END OF DATA... #C $ 500 CONTINUE % IT = 999 & RETURN ' END YANREC='*A '//DECK(NDK) l ELSE m YANREC='*AC '//DECK(NDK) n ENDIF oC p NDKN=NDK q1200 NDKRDOPA 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/824~zxrpodZXRQE  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 Ey*CALL BATCH R*CA WIDTH d*CA LANGC p*CA ERRMES *CALL CPLDIR*CALL PRFX CHARACTER*8 LABL DIMENSION IFD(8),IDD(8) C C C  NDCKS = 0  NSWS = 0  NMODS = 0  NBLK = 1  IDECP1=1 CALL RDPLA(NU,NBLK,IDECP1)  CALL EXAL(ADEC(IDECP1),IDECP1,LABL)  CALL EXIN(IDECP1,IFD,8) r CALL EXIN(IDECP1,IFD(1),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' p ERRMSG='Attempt to change width failed' p CALL WRERRR PRINT*,'Width will be ',MWIDE,' That of the OLD LIBRARY' X PRINT*,'Width will be ',IFD(2),' ( from the OLD LIBRARY)' p WRITE(ERRMSG,21) IFD(2) p21 FORMAT('Width will be ',I3,' ( from the OLD Library)') p CALL WRERR 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' p ERRMSG='Old version library only allowed width of 72' p CALL WRERRR PRINT*,'An attempt to change this has been rejected' p ERRMSG='An attempt to change this has been rejected' p CALL WRERR R ENDIF X MWIDE=72 R ENDIF  IF (LABL(8:8).EQ.' ' ) THEN  IF (PRFX .EQ. ' ') THEN  PRFX = '*'  ELSE ERRMSG = ' User defined prefix ='//PRFX  CALL WRMES  ENDIF ELSE  IF (PRFX .EQ. ' ') THEN PRFX = LABL(8:8)  ELSEIF (PRFX .NE. LABL(8:8)) THEN  ERRMSG = ' User defined prefix ='//PRFX//  1 ' will override old library prefix ='//LABL(8:8)  CALL WRMES  ENDIF  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.'p ERRMSG='*ERROR* (RDOPL) Attempt to change Library LANGUAGE' p 1 //'rejected.' p CALL WRERR d LANG=IFD(6) d PRINT*,' Language is ',LANGNM(LANG) p ERRMSG=' Language is '//LANGNM(LANG) p CALL WRERR r CALL WRMES 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' pv ERRMSG='*FATAL* (RDOPL) File was not written with the ' pv 1 //'same program reading'  ERRMSG='*FATAL* (RDOPL) The old library file was written ' 1 //'differently than this program can read'  CALL WRERR ERRMSG='The library must be written as a Portable library' 1 //' before it can be read by this program.' p CALL WRERR PRINT*,NCHRWD,NWRDBK pv WRITE(ERRMSG,41) NCHRWD,NWRDBK WRITE(ERRMSG,41) ' Program- ',NCHRWD,NWRDBK pv41 FORMAT(2I5) 41 FORMAT(1X,A,I10,' Characters/word',I10,' Words/block') p CALL WRERR PRINT*,IFD(7),IFD(8) pv WRITE(ERRMSG,41) IFD(7), IFD(8)  WRITE(ERRMSG,41) ' Old library-',IFD(7), IFD(8) p CALL WRERR CALL THEEND(2, ' Cannot read OLD LIBRARY')  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 ;j600 CONTINUE C number of blocks allowed  NBLKAL = MAXWRD/NWRDBK < NBLKS=(NDCKL*(2*NW8C+8)+NWRDBK-1)/NWRDBKx NBLKD=(NDCKL*(2*NW8C+8)+NWRDBK-1)/NWRDBK IF (NBLKD .GT. NBLKAL) THEN  WRITE(ERRMSG,601) 'Deck Header',NBLKD,NBLKAL  CALL WRERR  CALL THEEND(2,'Too many deck header blocks')  ENDIF  601 FORMAT('*ERROR* Too many blocks in ',A,' for program'  i 1 ,' number = 'I5,' allowed = ',I5)  1 ,' number = ',I5,' allowed = ',I5) x NBLK=1 = IDECP1=1 zn*IF -SMALL > DO 620 I=1,NBLKS x DO 620 I=1,NBLKDzn*ENDIF zn*IF SMALL zn DO 620 I=1,MIN0(NBLKD,2)zn*ENDIF ? NBLK=NBLK+1 @ CALL RDPLA(NU,NBLK,IDECP1) A IDECP1=IDECP1+NWRDBK B620 CONTINUE C IDECP1=1 D DO 680 I=1,NDCKL ~ IF(NDCKS.GE.MAXDCK) THEN~ WRITE(ERRMSG,621) MAXDCK ~621 FORMAT('Too many decks for program maximum = ',I5 ~ 1 ,'(parameter MAXDCK must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Too many decks') ~ ENDIF 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) r CALL EXIN(IDECP1,IDD(1),8) J ITYPE(NDCKS)=IDD(1) K LOCB(NDCKS)=IDD(2) L NBLOK(NDCKS)=IDD(3)  *IF -SMALL ~n IF(NBLOK(NDCKS)*NWRDBK.GT.ISDEC(2)) THEN  IF(NBLOK(NDCKS)*NWRDBK.GT.MAXWRD) THEN *IF PRIME  IF(NBLOK(NDCKS)*NWRD .GT. 32768) THEN  ERRMSG='Deck '//DECK(NDCKS)//' Too large for PRIME'  1 //' (Errors may occur SLIB77 needs to be modified.'  CALL WRERR  ENDIF *ENDIF PRIME~ ERRMSG='Deck '//DECK(NDCKS)//' Too large for program'~ 1 //' (parameter MAXWRD must be increased).' ~ CALL WRERR ~  CALL ENDPRO(2)  CALL THEEND(2,'Deck too large') ~ ENDIF  *ENDIF SMALL M IIDENT(NDCKS)=IDD(4) N IPURGE(NDCKS)=IDD(5) zn*IF SMALL zn IF(IDECP1.GT.NWRDBK) THENzn IDECP1=IDECP1-NWRDBK z n CALL TRDEC(NWRDBK+1,1,NWRDBK) z n NBLK=NBLK+1 z n CALL RDPLA(NU,NBLK,NWRDBK+1) z n ENDIFz n*ENDIF O680 CONTINUEPC Q800 CONTINUERC SC TC CREATE MOD DECK ARRAY UC V IDECP1=NWRDBK+1 x NBLKM=(NMODSL*(2*NW8C+4)+NWRDBK-1)/NWRDBK  IF (NBLKM .GT. NBLKAL) THEN  WRITE(ERRMSG,601) 'Modification Header',NBLKM,NBLKAL  CALL WRERR  CALL THEEND(2,'Too many modification header blocks')  ENDIF x NBLK=1+NBLKD x IDECP1=1xC zn*IF -SMALL x DO 900 I=1,NBLKMzn*ENDIF zn*IF SMALL zn DO 900 I = 1 , MIN0(NBLKM,2)zn*ENDIF x NBLK=NBLK+1 x CALL RDPLA(NU,NBLK,IDECP1) x IDECP1=IDECP1+NWRDBK x 900 CONTINUEx C x IDECP1=1WC X DO 1500 N = 1,NMODSL ~ IF(NMODS.GE.MAXMNA) THEN~ WRITE(ERRMSG,911) MAXMNA ~911 FORMAT('Too many modification names for program maximum =',I5~ 1 ,'(parameter MAXMNA must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2)  CALL THEEND(2,'Too many decks') ~ ENDIF Y 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 zn*IF SMALL zn IF(IDECP1.GT.NWRDBK) THENzn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,NWRDBK) zn NBLK=NBLK+1 zn CALL RDPLA(NU,NBLK,NWRDBK+1) zn ENDIFzn*ENDIF c IF(IVERSO.LT.2) IDECP1=IDECP1-1 d 1500 CONTINUEeC fC CREATE SWITCH ARRAY gC p IF(IVERSO.GT.3) GOTO 3000 pC old version (3 or less) only had switches if setpC new version keeps track of them all pC h IDECP1=1i NRDS=(NW8C*NSWSL+NWRDBK-1)/NWRDBK x NBLKS=(NW8C*NSWSL+NWRDBK-1)/NWRDBK  IF (NBLKS .GT. NBLKAL) THEN  WRITE(ERRMSG,601) 'Switch Header',NBLKS,NBLKAL  CALL WRERR  CALL THEEND(2,'Too many switch header blocks')  ENDIF x NBLK=1+NBLKD+NBLKM zn*IF -SMALL j DO 2000 N=1,NRDS x DO 2000 N=1,NBLKS zn*ENDIF zn*IF SMALL zn DO 2000 N = 1 , MIN0(NBLKS,2) zn*ENDIF 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 ~ IF(NSWS.GE.MAXSWI) THEN ~ WRITE(ERRMSG,2011) MAXSWI~2011 FORMAT('Too many switches for program maximum =',I5 ~ 1 ,'(parameter MAXSWI must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2)  CALL THEEND(2,'Too many switches') ~ ENDIF q NSWS=NSWS+1 p LSWTCH(NSWS)=.TRUE. r CALL EXAL(ADEC(IDECP1),IDECP1,SWITCH(NSWS)) z n*IF SMALL z!n IF(IDECP1.GT.NWRDBK) THENz"n IDECP1=IDECP1-NWRDBK z#n CALL TRDEC(NWRDBK+1,1,NWRDBK) z$n NBLK=NBLK+1 z%n CALL RDPLA(NU,NBLK,NWRDBK+1) z&n ENDIFz'n*ENDIF s2100 CONTINUEC  ERRMSG='Old program version read - will automatically'// 1 ' update switches'  CALL WRMES  CALL UPV3SW C p GOTO 4000 p3000 CONTINUE p IDECP1=1p  NRDS=((NW8C+1)*NSWSL+NWRDBK-1)/NWRDBK x NBLKS=((NW8C+1)*NSWSL+NWRDBK-1)/NWRDBK  IF (NBLKS .GT. NBLKAL) THEN  WRITE(ERRMSG,601) 'Switch Header',NBLKS,NBLKAL  CALL WRERR  CALL THEEND(2,'Too many switch header blocks')  ENDIF x NBLK=1+NBLKD+NBLKM p! DO 3020 N=1,NRDS x DO 3020 N=1,NBLKS p" NBLK=NBLK+1 p# CALL RDPLA(NU,NBLK,IDECP1) p$ IDECP1=IDECP1+NWRDBK p%3020 CONTINUE p& IDECP1=1 p' DO 3040 I=1,NSWSL p( NSWS=NSWS+1 p) CALL EXAL(ADEC(IDECP1),IDECP1,SWITCH(NSWS)) p* CALL EXIN(IDECP1,ISWL,1) p+ IF(ISWL.EQ.0) THEN p, LSWTCH(NSWS)=.FALSE. p- ELSE p. LSWTCH(NSWS)=.TRUE. p/ ENDIF z(n*IF SMALL z)n IF(IDECP1.GT.NWRDBK) THENz*n IDECP1=IDECP1-NWRDBK z+n CALL TRDEC(NWRDBK+1,1,NWRDBK) z,n NBLK=NBLK+1 z-n CALL RDPLA(NU,NBLK,NWRDBK+1) z.n ENDIFz/n*ENDIF p03040 CONTINUE p14000 CONTINUEp2iC p3i IF(IVERSO.LT.4) THENp4i ERRMSG='Old program version read - will automatically'// p5i 1 ' update switches' p6 CALL WRERR ri CALL WRMES p7i CALL UPV3SW p8i ENDIF t 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)) o PRINT 2113,LOCB(NDCKS)+NBLOK(NDCKS)-1 o2113 FORMAT(' Number of blocks on this file = ',I5) 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) o WRITE(LOU,2113) LOCB(NDCKS)+NBLOK(NDCKS)-1 o CALL LININC(1) E  ENDIF p9p ERRMSG='Old library read in.' p: CALL WRERR rp CALL WRMES p;z ERRMSG='Library language is '//LANGNM(LANG) p WRITE(ERRMSG,4099) LANGNM(LANG),MWIDE p4099 FORMAT('Library language is ',A8,' Width =',I4) WRITE(ERRMSG,4099) LANGNM(LANG),MWIDE  1 ,LOCB(NDCKS)+NBLOK(NDCKS)-1 4099 FORMAT('Old Library readied, Language is ',A8,' Width =',I4  1 ,I7,' blocks.') p< CALL WRERR r CALL WRMES p=p WRITE(ERRMSG,4111) NDCKS,NMODS,MODNA(NMODS),DATEM(NMODS)p>p4111 FORMAT(1X,I5,' decks ',I5,' Mods - last one = ',2A9)  WRITE(ERRMSG,4111) NDCKS,NSWS,NMODS,MODNA(NMODS),DATEM(NMODS) 4111 FORMAT(1X,I5,' Decks ',I5,' Switches'  1 ,I5,' Mods - last one = ',2A9) p? CALL WRERR r CALL WRMES rp WRITE(ERRMSG,4113) LOCB(NDCKS)+NBLOK(NDCKS)-1 r p4113 FORMAT(I6,' blocks on old library file') r p CALL WRMES p@p WRITE(ERRMSG,4115) NSWS pAp4115 FORMAT(1X,I5,' Switches') pB CALL WRERR r p CALL WRMES pC IF(NSWS.EQ.0) GOTO 4150 pD DO 4142 L=1,2 pE IF(L.EQ.1) THEN pF ERRMSG=' Switches SET'r p ERRMSG=' set'  ERRMSG=' switches set' pG ELSE pH ERRMSG=' Switches NOT SET'r p ERRMSG=' not set'  ERRMSG=' switches not set' pI ENDIF pJ CALL WRERR r CALL WRMES pK ERRMSG=' 'pLC pM LL=1 r LL=8 pN DO 4140 I=1,NSWS pO IF(L.EQ.1.AND.LSWTCH(I)) THEN pP ERRMSG(LL:LL+12)=' '//SWITCH(I)r ERRMSG(LL:LL+9)=' '//SWITCH(I) pQ LL=LL+13 r LL=LL+10 pR ELSE IF(L.EQ.2.AND..NOT.LSWTCH(I)) THEN pS ERRMSG(LL:LL+12)=' '//SWITCH(I)r ERRMSG(LL:LL+9)=' '//SWITCH(I) pT LL=LL+13 r LL=LL+10 pU ENDIF pV IF(LL.GT.70) THEN r IF(LL.GT.60) THEN pW CALL WRERR r CALL WRMES pX ERRMSG=' ' pY LL=1 r LL=8 pZ ENDIF p[4140 CONTINUE p\ IF(LL.GT.1) THEN r IF(LL.GT.8) THEN p] CALL WRERR r CALL WRMESp^ ERRMSG=' ' p_ LL=1 r LL=8 p` ENDIF pa4142 CONTINUE pb4150 CONTINUE pc CALL WRERR rp ERRMSG=' ' rp CALL WRMES vC  IF (LANG .EQ. 2 .AND. NCPLDI .EQ. 0 ) THEN  NCPLDI = 6  CPLDI = ' '  ENDIF C w NMODOP=NMODS x CALL STATIS (1,NDCKS) y CALL STATIS (3,NMODS) z CALL STATIS (6,NSWS) { RETURN | END RDOPLA 3/22/82~trpda\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 p*CA ERRMES *CALL CPLDIR*CALL PRFX  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  IF (SLIB77(8:8).EQ.' ' ) THEN  IF (PRFX .EQ. ' ') THEN  PRFX = '*'  ELSE ERRMSG = ' User defined prefix ='//PRFX  CALL WRMES  ENDIF ELSE  IF (PRFX .EQ. ' ') THEN PRFX = SLIB77(8:8) ELSEIF (PRFX .NE. SLIB77(8:8)) THEN  ERRMSG = ' User defined prefix ='//PRFX//  1 ' will override old library prefix ='//SLIB77(8:8)  CALL WRMES  ENDIF  ENDIF ~ IF(NSWS.GE.MAXSWI) THEN ~ WRITE(ERRMSG,13) MAXSWI ~13 FORMAT('Too many switches for program maximum =',I5 ~ 1 ,'(parameter MAXSWI must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2)  CALL THEEND(2,'Too many switches') ~ ENDIF ~ IF(NMODS.GE.MAXMNA) THEN~ WRITE(ERRMSG,15) MAXMNA ~ 15 FORMAT('Too many modification names for program maximum =',I5~ 1 ,'(parameter MAXMNA must be increased).') ~ CALL WRERR ~  CALL ENDPRO(2)  CALL THEEND(2,'Too many mod names') ~ ENDIF ~ IF(NDCKS.GE.MAXDCK) THEN~ WRITE(ERRMSG,17) MAXDCK ~17 FORMAT('Too many decks for program maximum = ',I5 ~ 1 ,'(parameter MAXDCK must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Too many decks') ~ ENDIF R IF(MWIDE.EQ.0) THEN R MWIDE = MWIDEO R ENDIF R IF(MWIDE.NE.MWIDEO) THENR PRINT*,'New width will be used' p ERRMSG='New width will be used.' p CALL WRERR 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 p IF(IVERSO.GT.3) GOTO 38 t IF(IVER.GT.3) GOTO 38 " READ(NU,35)(SWITCH(I),I=1,NSWS) #35 FORMAT(10A8) p DO 36 I=1,NSWS p LSWTCH(I)=.TRUE. p36 CONTINUE p GOTO 40 p C p 38 CONTINUEp READ(NU,39)(SWITCH(I),LSWTCH(I),I=1,NSWS) p 39 FORMAT(8(A8,L2))p C pC p40 CONTINUE$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 ~n IF(NBLKS*NWRDBK.GT.ISDEC(2)) THEN  IF(NBLKS*NWRDBK.GT.MAXWRD) THEN ~ ERRMSG='Deck '//DECK(N)//' Too large for program' ~ 1 //' (parameter MAXWRD must be increased).' ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Deck too large') ~ ENDIF  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) Lm CALL WRDK(LSR,LOCLSR,1,NBLKS)  CALL WRDK('L',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= ',NDCKSpy ERRMSG='Old formatted library file read' ERRMSG='Old portable library file read' p CALL WRERR pz ERRMSG='Library LANGUAGE is '//LANGNM(LANG)  WRITE(ERRMSG,3009) LANGNM(LANG),MWIDE 3009 FORMAT('Library language is ',A8,' Width =',I4) p CALL WRERR p WRITE(ERRMSG,3011),NDCKS r WRITE(ERRMSG,3011) NDCKSp3011 FORMAT('Number of decks = ',I5) p CALL WRERR pC p IF(IVERSO.LT.4) THEN t IF(IVER.LT.4) THEN p ERRMSG='Old program version read - will automatically'// p 1 ' update switches' p CALL WRERR p CALL UPV3SW p ENDIF  IF (LANG .EQ. 2 .AND. NCPLDI .EQ. 0 ) THEN  NCPLDI = 6  CPLDI = ' '  ENDIF 8 CALL PRSTAT P RETURN Q END ,4113) LOCB(NDCKS)+NBLOK(NDCKS)-1 r p4113 FORMAT(I6,' blocks on old library file') r p CALL WRMES p@p WRITE(ERRMSG,4115) NSWS pARDPLA 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/82{rCB= SUBROUTINE RDTERM(LI,IWID) { SUBROUTINE RDTERM (PROMPT,LI,IWID) | SUBROUTINE RDTERM(PROMPT,IWID)  SUBROUTINE RDTERM(PROMPT,IWID,UCASE)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*,'?' r WRITE(LI,9)'?' {q CHARACTER*1 PROMPT  CHARACTER*(*) PROMPT  LOGICAL UCASE {C { WRITE(LI,9) PROMPT r9 FORMAT(1X,A)  READ(LI,11,ERR=30,END=30) BUF = READ(LI,11,ERR=30,END=30) BUF80 11 FORMAT(A)  BUF80 = ' ' | CALL RDTIO(PROMPT,BUF80,.FALSE.) CALL RDTIO(PROMPT,BUF80,UCASE)  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 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, RDTIO 7/26/84 SUBROUTINE RDTIO(PCHARS,ANS,LUCASE) C C THIS SUBROUTINE READS A LINE FROM THE TERMINAL DEVICE C  CHARACTER PCHARS*(*), ANS*(*)  LOGICAL LUCASE *CALL LOGU *CALL PARAMA CHARACTER*(MAXWID) TEMP  *IF NPS  *CALL NPSARG INTEGER IQUERY  C  CALL PROMPT(0,PCHARS,LTI,LUCASE,1,ANS,IQUERY,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) v IF (QREADY.AND.QERROR) CALL NPSEIO('PROMPT VIA RDTIO')  IF (QREADY.AND.QERROR) THEN  WRITE (TEMP,'(A,A,A,I5,A,L5)') 'PROMPT called with PCHARS=',  $ PCHARS,', LTI=',LTI,', LUCASE=',LUCASE CALL NPSEIO('PROMPT via RDTIO',TEMP(1:ITRAIL(TEMP)))  ENDIF  IF (QERROR) THEN IF (PCHARS .NE. ' ') WRITE (LTO,'(1X,A)') PCHARS  ANS = ' '  READ (LTI,'(A)',END=30,ERR=30) ANS  IF (LUCASE) THEN n CALL UCASE(ANS,TEMP) n ANS = TEMP  CALL UCASE(ANS)  ENDIF  ENDIF *ENDIF *IF -NPSC  IF (PCHARS .NE. ' ') WRITE (LTO,'(1X,A)') PCHARS  ANS = ' '  READ (LTI,'(A)',END=30,ERR=30) ANS IF (LUCASE) THEN!n CALL UCASE(ANS,TEMP) "n ANS = TEMP  CALL UCASE(ANS) # ENDIF $*ENDIF % 30 RETURN & END &C ' DO 3000 N=1,NDCKS ( READ(NU,41) NAM,DATD,NMD )41 FORMAT(2A8,I8) * IDECP1=1+ CALL INAL(ADEC(IDECP1),IDECP1,NAM) , RECADD 3/22/82~z. SUBROUTINE RECADD(IDECP,NDK,NSEQ,INREC) z SUBROUTINE RECADD(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~*CALL ERRMES*CA CONTRL *CALL LOGU  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 ~ IF(IDECP2+NW+5 .GT. MAXWRD) THEN~ ERRMSG='Deck too large for program when record is added' ~ 1 //' (parameter MAXWRD must be increased).' ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Deck too large when modified') ~ ENDIF  CALL ININ(IDECP,IRC,5) z CALL ININ(IDECP2,IRC,5)  IREC=IDECP z IREC=IDECP2  DO 60 I=1,NW ADEC(IDECP)=BUF4(I) z ADEC(IDECP2)=BUF4(I)  IDECP=IDECP+1 z IDECP2=IDECP2+1 60 CONTINUEC  IF(LSTM.AND.(NDK.NE.0)) CALL LISMOD(1,IRC,ADEC(IREC),LENR) *IF SMALL  IF (IDECP2 .GE. MEMSTL(2) + NWRDBK) THEN IDECP2 = IDECP2 - NWRDBK  CALL WRPLA (LSR, LOCLSR, MEMSTL(2))  LOCLSR = LOCLSR + 1  CALL TRDEC (MEMSTL(2) + NWRDBK, MEMSTL(2), NWRDBK)  ENDIF  *ENDIF SMALL zn*IF SMALL zn IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENzn CALL WRNEXR(LOCLSR) z n IDECP2=IDECP2-NWRDBK z n CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) z n ENDIF z n*ENDIF  RETURN  END 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 -RECDEL 3/22/82 ~zL 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 ~*CALL ERRMES*CALL LOGU  DIMENSION IRC(5),IMD(500) EQUIVALENCE(IRC,IMD) *CA INREC C  CALL EXIN(IDECP1,IRC,5) z LNX=IRC(1) 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~ IF(IDECP2+LNX+1 .GT.MAXWRD) THEN~ ERRMSG='Deck too large for program when record is deleted'~ 1 //' (parameter MAXWRD must be increased).' ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Deck too large when modified') ~ ENDIF  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) zC ! RETURN z GOTO 200LC 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 z200 CONTINUE*IF SMALL  IDECPT = IDECPT + LNX  IF (IDECP1 .GE. MEMSTL(1) + NWRDBK ) THEN  IDECP1 = IDECP1 - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1), NWRDBK)  CALL RDNEXR ('L', 1)  ENDIF  IF (IDECP2 .GE. MEMSTL(2) + NWRDBK) THEN IDECP2 = IDECP2 - NWRDBK  CALL WRPLA (LSR, LOCLSR, MEMSTL(2)) LOCLSR = LOCLSR + 1  CALL TRDEC (MEMSTL(2) + NWRDBK, MEMSTL(2), NWRDBK)  ENDIF *ENDIF SMALL zn*IF SMALL zn IDECPT=IDECPT+LNX zn IF(IDECP1.GT.NWRDBK) THEN zn IDECP1=IDECP1-NWRDBK z n CALL TRDEC(NWRDBK+1,1,NWRDBK) z n CALL RDNEXR(1) z n ENDIF z n IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENz n CALL WRNEXR(LOCLSR) zn IDECP2=IDECP2-NWRDBK zn CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) zn ENDIF zn*ENDIF L RETURN " END *IF SMALL zn DO 620 I=1,MIN0(NBLKD,2)zn*ENDIF ? NBLK=NBLK+1 @ CALL RDPLA(NU,NBLK,IDECP1) A IDECP1=IDECP1+NWRDBK B620 CONTINUE C IDECP1=1 DRECMOV 3/22/82~z  SUBROUTINE RECMOV C C MOVES RECORD FROM ARAY1 TI ARAY2C *CA PARAMA *CA DECI ~*CALL ERRMES*CALL LOGU C  LNX=IDEC(IDECP1) C ~ IF(IDECP2+LNX.GT.MAXWRD) THEN ~ ERRMSG='Deck too large for program during modifications' ~ 1 //' (parameter MAXWRD must be increased).' ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Deck too large when modified') ~ ENDIF DO 100 I=1,LNX  IDEC(IDECP2)=IDEC(IDECP1) IDECP1=IDECP1+1 IDECP2=IDECP2+1 100 CONTINUEzC *IF SMALL  IDECPT = IDECPT + LNX  IF (IDECP1 .GE. MEMSTL(1) + NWRDBK ) THEN  IDECP1 = IDECP1 - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1), NWRDBK)  CALL RDNEXR ('L', 1)  ENDIF  IF (IDECP2 .GE. MEMSTL(2) + NWRDBK) THEN IDECP2 = IDECP2 - NWRDBK  CALL WRPL1 (LSR, LOCLSR, IDEC(MEMSTL(2))) LOCLSR = LOCLSR + 1  CALL TRDEC (MEMSTL(2) + NWRDBK, MEMSTL(2), NWRDBK)  ENDIF *ENDIF SMALL zn*IF SMALL zn IDECPT=IDECPT+LNX zn IF(IDECP1.GT.NWRDBK) THEN zn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,NWRDBK) zn CALL RDNEXR(1) zn ENDIF z n IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENz n CALL WRNEXR(LOCLSR) z n IDECP2=IDECP2-NWRDBK z n CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) z n ENDIF zn*ENDIF  RETURN  END ALL EXIN(IDECP1,IMD(7),IRC(5))  ENDIF  IRC(5)=IRC(5)+1  IMD(6)=-IDNO~ IF(IDECP2+LNX+1 .GT.MAXWRD) THEN~ ERRMSG='Deck too large for program when record is deleted'~ 1 //' (parameter MAXWRD must be increased).' ~ RECRES 3/22/82zrO 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 r*CA ERRMES *CALL LOGU 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 zC *IF SMALL  IDECPT = IDECPT + LNX -1 IF (IDECP1 .GE. MEMSTL(1) + NWRDBK ) THEN  IDECP1 = IDECP1 - NWRDBK  CALL TRDEC (MEMSTL(1) + NWRDBK, MEMSTL(1), NWRDBK)  CALL RDNEXR ('L', 1)  ENDIF  IF (IDECP2 .GE. MEMSTL(2) + NWRDBK) THEN IDECP2 = IDECP2 - NWRDBK  CALL WRPLA (LSR, LOCLSR, MEMSTL(2)) LOCLSR = LOCLSR + 1  CALL TRDEC (MEMSTL(2) + NWRDBK, MEMSTL(2), NWRDBK)  ENDIF *ENDIF SMALL zn*IF SMALL zn IDECPT=IDECPT+LNX-1 zn IF(IDECP1.GT.NWRDBK) THEN zn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,NWRDBK) zn CALL RDNEXR(1) zn ENDIF z n IF(IDECP2.GT.ISDEC(2)+NWRDBK-1) THENz n CALL WRNEXR(LOCLSR) z n IDECP2=IDECP2-NWRDBK z n CALL TRDEC(ISDEC(2)+NWRDBK,ISDEC(2),NWRDBK) z n ENDIF zn*ENDIF "C # RETURN $C %C &900 CONTINUE ' IDECP1=IDECP1-5 ( PRINT*,' (RECRES) RECORD TO BE RESTORED IS ACTIVE' r ERRMSG='**ERROR** Record to be restored is active' r CALL WRERR r CALL LISERR(IN) ) CALL RECMOV * RETURN + END DEC(2)+NREPINC 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 Rg ELSE IF (JVAL.GT.LARG)THEN  ELSEIF (JVAL .EQ. 11) 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 ed.'p ERRMSG='*ERROR* (RDOPL) Attempt to change Library LANGUAGE' p 1 //'rejected.' p CALL WRERR d LANG=IFD(6) d PRINT*,' Language is ',LANGNM(LANG) pSCAN1 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 SCANCC 9/24/84   SUBROUTINE SCANCC(AIN) C C SCAN CONTROL CARD C Scan AIN string for words C C Delimeters is comma - end of scan is exclamation mark C Decimal point and blank are ignored C Puts Equal sign in separate word C leading and trailing blanks are omitted  C CHARACTER*(*) AIN *CALL SCAN *IF VAX *CALL ITABC *ENDIF VAX CHARACTER*4 ATYP v DATA ATYP /' =,!'/  DATA ATYP /' =,'''/ C C NWRD = number of words currently found C NCHR = number of characters in current word (including blanks) C NBLK = current number of blanks on the end of the word C  NWRD = 1  NCHR = 0  NBLK = 0C  DO 100 I = 1,LEN(AIN)  L = I - 1 ITYP = INDEX( ATYP, AIN(I:I))*IF VAX  IF(ITYP.EQ.0.AND.ICHAR(AIN(I:I)).EQ.ITABC) THEN  AIN(I:I)=' '  ITYP=1 ENDIF *ENDIF VAX C  IF(ITYP.EQ.0) THEN C legal character for word (non blank)  NCHR = NCHR+1  IF(NCHR.EQ.1) ISS(NWRD) = I o ISL(NWRD) = NCHR NBLK = 0 !C " ELSEIF (ITYP .EQ. 1) THEN #C blank $ IF(NCHR.NE.0) THEN % NCHR = NCHR+1 &o ISL(NWRD) = NCHR ' NBLK = NBLK+1 ( ENDIF )C * ELSEIF (ITYP.EQ.2) THEN +C equal sign put in separate word , IF(NCHR.NE.0) THEN ISE(NWRD) = L - NBLK - IF(NWRD.GT.71) GOTO 150.o IF(NBLK.GT.0) THEN /o ISL(NWRD) = ISL(NWRD)-NBLK 0o NBLK = 0 1o ENDIF  NBLK = 0 2 NWRD = NWRD+1 3 ENDIF 4 ISS(NWRD) = I 5o ISL(NWRD) = 1 6o NCHR = 1  ISE(NWRD) = I 7 IF(NWRD.GT.71) GOTO 150 8 NWRD = NWRD+1 9 NCHR = 0 : ELSEIF (ITYP.EQ.3) THEN ;C comma break word < IF(NCHR.GT.0) THEN ISE(NWRD) = L - NBLK = IF(NWRD.GT.71) GOTO 150>o IF(NBLK.GT.0) THEN ?o ISL(NWRD) = ISL(NWRD)-NBLK @o NBLK = 0 Ao ENDIF  NBLK = 0 B NWRD = NWRD+1 C NCHR = 0 D ENDIF E ELSEFvC exclamation mark ! end of scan C quote mark ' end of scan G GOTO 150 H ENDIF I100 CONTINUE n L = I  L = LEN(AIN)JC K150 IF(NCHR.EQ.0) THEN L NWRD = NWRD-1Mo ELSEIF(NBLK.GT.0) THEN No ISL(NWRD) = ISL(NWRD)-NBLK Oo NBLK = 0  ELSE ISE(NWRD) = L - NBLK P ENDIF Q RETURN R END DO 1500 N = 1,NMODSL ~ IF(NMODS.GE.xSCANDI 9/24/84  SUBROUTINE SCANDI(AIN)  CHARACTER*(*) AINC C SCAN DIRECTIVES C Scans array AIN looking for words C Delimeters are BLANK and COMMA C Equal sign and period are put in a separate word C  *CALL SCAN *IF VAX *CALL ITABC *ENDIF VAX CHARACTER*5 ATYP v DATA ATYP /'.=, !'/  DATA ATYP /'.=, '''/ C LENI = LEN(AIN)  NWRD = 1  NCHR = 0C  DO 100 I = 1,LEN(AIN)  L = I ITYP = INDEX( ATYP, AIN(I:I))*IF VAX  IF(ITYP.EQ.0.AND.ICHAR(AIN(I:I)).EQ.ITABC) THEN  AIN(I:I)=' '  ITYP=1 ENDIF *ENDIF VAX  IF(ITYP.EQ.0) THEN C legal character for word  NCHR = NCHR+1  IF(NCHR.EQ.1) ISS(NWRD) = I o ISL(NWRD) = NCHR C  ELSEIF (ITYP.LT.3) THEN C Period or Equal sign put in separate word  ISE(NWRD) = L - 1  IF(NCHR.NE.0) THEN IF(NWRD.GT.71) GOTO 150  NWRD = NWRD+1  ENDIF  ISS(NWRD) = I o ISL(NWRD) = 1  ISE(NWRD) = L ! NCHR = 1 " IF(NWRD.GT.71) GOTO 150 # NWRD = NWRD+1 $ NCHR = 0 % ELSEIF (ITYP.LT.5) THEN &C comma or blank break word ' IF(NCHR.GT.0) THEN ISE(NWRD) = L - 1 ( NCHR = 0 ) IF(NWRD.GT.71 ) GOTO 150 * NWRD = NWRD+1 + ENDIF , ELSE-vC exclamation mark ! end of scan  C quote mark ' end of scan  L = L - 1 . GOTO 150 / ENDIF 0100 CONTINUE1C 2150 IF(NCHR.EQ.0) THEN 3 NWRD = NWRD-1  ELSE  ISE(NWRD) = L 4 ENDIF 5 RETURN 6 END (non blank)  NCHR = NCHR+1  IF(NCHR.EQ.1) ISS(NWRD) = I o ISL(NWRD) = NCHR NBLK =SCANFS 12/14/84  SUBROUTINE SCANFS(AIN) C C SCAN FSEDIT COMMANDS C Scans array AIN looking for words C Delimeters are BLANK for all words dC '+-/0123456789' are delimiters for the initial word as wellC ':.+-/0123456789' are delimiters for the initial word as well C  CHARACTER*(*) AIN  *IF EDIT C  *CALL SCAN d CHARACTER*14 ATYP  CHARACTER*16 ATYP  d DATA ATYP /' +-/0123456789'/  DATA ATYP /' :.+-/0123456789'/ C  NWRD = 1  NCHR = 0 C  DO 100 I = 1,LEN(AIN)  L = I ITYP = INDEX(ATYP,AIN(I:I))  IF (ITYP .EQ. 1) THEN C blank break word  IF (NCHR .GT. 0) THEN  NCHR = 0  ISE(NWRD) = L - 1 IF (NWRD .GT. 71) GOTO 150  NWRD = NWRD + 1  ENDIF C  ELSEIF (ITYP.GE.2 .AND. NWRD.EQ.1) THEN C initial word break  IF (NCHR .GT. 0) THEN  ISE(NWRD) = L - 1 IF (NWRD .GT. 71) GOTO 150 NCHR = 1 ! NWRD = NWRD + 1 " ISS(NWRD) = I#o ISL(NWRD) = NCHR $ ELSE % NCHR = 1 & ISS(NWRD) = I IF (ITYP .LE. 3) THEN  NWRD = NWRD + 1  NCHR = 0  ENDIF'o ISL(NWRD) = NCHR ( ENDIF ) ELSE*C legal character for word + NCHR = NCHR + 1, IF (NCHR .EQ. 1) ISS(NWRD) = I -o ISL(NWRD) = NCHR . ENDIF /100 CONTINUE0C 1o150 IF (NCHR .EQ. 0) NWRD = NWRD - 1 150 IF(NCHR .EQ. 0) THEN  NWRD = NWRD - 1  ELSE  ISE(NWRD) = L  ENDIF 2*ENDIF EDIT 3 RETURN 4 END 2):ISE(2)) .EQ. 'LISTING') THEN ]n PREID(2) = CARD(ISS(3)+1:) ^o ELSEIF (CARD(ISS(2):ISS(2)+ISL(2)-1) .EQ. 'SLIBRARY') THEN n ELSEIF (CARD(ISS(2):ISE(2)) .EQ. 'SLIBRARY') THEN_n PREID(3) = CARD(ISS(3)+1:) `SRTMOD 3/22/82~j. SUBROUTINE SRTMOD(NDECK,IDKDIR) C C SORT MODS FOR DECK NDECKC *CA PARAMA *CA MODKEY *CA INREC *CA INISO *CA ERRMES  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) j CALL LOCREC (ITP,NDECK,IDIR,LOC1,LOC2) + IF(LOC1.EQ.0) GOTO 1500 ~ IF (NOMODS.GE.MAXMDD) THEN ~ WRITE(ERRMSG,113) MAXMDD ~113 FORMAT('Too many directives in one deck for program ',~ 1 'maximum =',I5,' (parameter MAXMDD must be increased).') ~ CALL WRERR ~ CALL ENDPRO(2) CALL THEEND(2,'Too many directives in a deck') ~ ENDIF , 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 LIA = 15 % LOA = 16  LBO=17  LBI=18 *IF TERM5  LTI=5 STATIS 3/22/82 trZX<  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 r*CA ERRMES  C v DIMENSION NUSTAT (7),MXSTAT(7)  DIMENSION NUSTAT(7)  CHARACTER*8 IDA(6)  CHARACTER*8 IDL(6)  CHARACTER*2 ITP(6) v DIMENSION NASTAT(7) v CHARACTER*8 NASTAT v DATA NASTAT /'MAXDCK','MAXWRD','MAXMNA','MAXMDK', v 1 'MAXMDD','MAXSWI','MAXDRR'/  DATA NUSTAT /7*0/  DATA IDL /6*' '/ 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) r CALL HEADER('Deck/modification Statistics') rv ERRMSG=' Decks-' WRITE(ERRMSG,111) NDCKS m111 FORMAT('Decks - (#=Purged, *=Common)',I10)111 FORMAT('Decks -',I6,' (#=Purged, *=Common)', 1 ' length is given in blocks') r CALL WROUT rv ERRMSG=' (#=Purged, *=Common)'  ERRMSG=' ' r CALL WROUT < ID=0 % DO 200 I=1,NDCKS & ID=ID+1 ' IDA(ID)=DECK(I) WRITE(IDL(ID),'(I5)') NBLOK(I) ( IF(ITYPE(I).NE.0) THEN ) ITP(ID)=' *' r 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) rm WRITE(ERRMSG,121) (ITP(J),IDA(J),J=1,5)  WRITE(ERRMSG,121) (ITP(J),IDA(J),IDL(J),J=1,5) r m121 FORMAT(5(6X,2A))121 FORMAT(6X,5(3A)) r CALL WROUT 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) r ERRMSG=' 'r m WRITE(ERRMSG,121) (ITP(I),IDA(I),I=1,ID)  WRITE(ERRMSG,121) (ITP(I),IDA(I),IDL(I),I=1,ID) r CALL WROUT : ENDIF;C < WRITE(LOU,111)' ' = WRITE(LOU,111)' '> WRITE(LOU,111)'MODIFICATIONS' ? WRITE(LOU,111)' ' @ CALL LININC(4) r ERRMSG=' ' r CALL WROUT rv CALL WROUT rv ERRMSG='Modification idents'  WRITE(ERRMSG,211) NMODS 211 FORMAT('Modification idents -',I10) r CALL WROUT r ERRMSG=' ' r CALL WROUT 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)) rm WRITE(ERRMSG,131)(MODNA(L),L=I,MIN(I+4,NMODS)) WRITE(ERRMSG,131)(DATEM(L),MODNA(L),L=I,MIN(I+4,NMODS)) X131 FORMAT(5(8X,A)) rm131 FORMAT(5(8X,A))  131 FORMAT(8X,5(A,1X,A,3X)) D CALL LININC(1) r CALL WROUT E300 CONTINUE F ENDIF GC HC Iv MXSTAT(1)=MAXDCK Jv MXSTAT(2)=MAXWRD Kv MXSTAT(3)=MAXMNA Lv MXSTAT(4)=MAXMDK Mv MXSTAT(5)=MAXMDD Nv MXSTAT(6)=MAXSWI Ov MXSTAT(7)=MAXDRRP PRINT 11,(NASTAT(I),NUSTAT(I),MXSTAT(I),I=1,7) Q11 FORMAT(' STATISTICS FOR RUN'/ R 1 (1X,A8,2I6)) Su IF(ICL) THEN  IF(.NOT.ICL) RETURN 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) \u ENDIF rv ERRMSG='Run Statistics' rv CALL WRMES rv ERRMSG=' '  ERRMSG=' ' u CALL WRMES  CALL WROUT  ERRMSG='Program Limitation Statistics-' ru CALL WRMES  CALL WROUT rv DO 40 I=1,7 r WRITE(ERRMSG,11)(NASTAT(I),NUSTAT(I),MXSTAT(I)) tv WRITE(ERRMSG,11) NASTAT(I),NUSTAT(I),MXSTAT(I) rv11 FORMAT(A8,2I6) rv CALL WRMES r v40 CONTINUE ERRMSG=' Parameter used maximum description ' u CALL WRMES  CALL WROUT  11 FORMAT(2X,A6,2X,2I9,2X,A)  WRITE(ERRMSG,11) 'MAXDCK',NUSTAT(1),MAXDCK,  1 'No. of decks.' u CALL WRMES  CALL WROUT  WRITE(ERRMSG,11) 'MAXSWI',NUSTAT(6),MAXSWI,  1 'No. of switches.' u CALL WRMES  CALL WROUT  WRITE(ERRMSG,11) 'MAXMNA',NUSTAT(3),MAXMNA,  1 'No. of modification sets.' u CALL WRMES  CALL WROUT  WRITE(ERRMSG,11) 'MAXMDK',NUSTAT(4),MAXMDK,  1 'No. of decks which can be modified per Modification set.' u CALL WRMES  CALL WROUT  WRITE(ERRMSG,11) 'MAXMDD',NUSTAT(5),MAXMDD,  1 'No. of modification directives per deck per modification set.' u CALL WRMES CALL WROUT  WRITE(ERRMSG,11) 'MAXDRR',NUSTAT(7),MAXDRR,  1 'No. of directives in a run (excluding those in decks).' u CALL WRMES CALL WROUT  DO 500 I=1,7  NUSTAT(I)=0 500 CONTINUE ] RETURN ^ END PRINT*,'Library LANGUAGE is ',LANGNM(LANG) SWIDEF 8/16/84  SUBROUTINE SWIDEF (SWII)C C SWITCH DEFINITION C *CA PARAMA *CA SWITCH*CA ERRMES C CHARACTER*9 SWII CHARACTER*8 SWI LOGICAL SET  C  IF(SWII(1:1).EQ.'-') THEN  SET=.FALSE.  SWI=SWII(2:)  ELSE  SET=.TRUE.  SWI=SWII  ENDIF C  DO 100 I=1,NSWS  IF(SWI.EQ. SWITCH(I)) GOTO 500 100 CONTINUE  IF(NSWS.GE.MAXSWI) THEN  WRITE(ERRMSG,211) MAXSWI 211 FORMAT('Too many switches for program maximum =',I5  1 ,'(parameter MAXSWI must be increased).')  CALL WRERR  ERRMSG='Error occurred in SWIDEF when switch '//SWI// 1 ' was encountered'  CALL WRERR  CALL THEEND(2,'Too many switches') ! ENDIF " NSWS=NSWS+1 # SWITCH(NSWS)=SWI $ LSWTCH(NSWS)=.NOT.SET % I=NSWS & CALL STATIS(6,NSWS) 'C (500 CONTINUE) IF(LSWTCH(I).EQV.SET) THEN * WRITE(ERRMSG,511)SWI,SET +511 FORMAT('Switch ',A,' was already ',L2) , ELSE- WRITE(ERRMSG,513)SWI,SET .513 FORMAT('Switch ',A,' Changed to ',L2) / LSWTCH(I)=SET 0 ENDIF 1 CALL WRERR 2 RETURN 3 END SWS, 5) .NE. 0) CALL WRTIO(OUTLIN) 0C 1C SEE WHAT IS DESIRED 2C 3 CALL WRTIO(' ') 4 CALL RDTIO( 5THEEND 7/26/84 SUBROUTINE THEEND(NN,LINE) C C THIS SUBROUTINE DOES ANY SLIB77 TERMINATION PROCESSING C  CHARACTER LINE*(*) C C NN - status indicator C 0 = normal end of run C 1 = end of run - with errors  C 2 = abort because of catastrophic errors  C  *IF -NPS *IF PRIME C  INTEGER*2 DUMMY  PARAMETER (DUMMY= 3) /* WHATEVER,... */C *ENDIF *ENDIF *IF NPS *CALL LOGU *CALL NPSARG*ENDIF  CALL WRTIO(LINE)*IF NPS C NOTE NPSEIO NOT CALLED HERE BECAUSE DON'T CARE IF THERE ARE ERRORS  CALL FREE(LSI,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  CALL FREE(LSR,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  CALL NPS(1,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) !*ENDIF "*IF -NPS # IF ( NN.EQ.2) THEN $*IF PRIME % CALL SETRC$(DUMMY)&*ENDIF ' ELSEIF (NN.EQ. 1) THEN (*IF PRIME ) CALL SETRC$(DUMMY)**ENDIF + ENDIF ,*ENDIF - IF ( NN.EQ.2) THEN .l STOP 'Catastropic end of SLIB77 run'  STOP 'Catastrophic end of SLIB77 run' / ELSEIF (NN.EQ. 1) THEN 0 STOP 'End of SLIB77 run with error' 1 ELSE2 STOP 'Normal end of SLIB77 run' 3 ENDIF 4 END * IDECP1=1+ CALL INAL(ADEC(IDECP1),IDECP1,NAM) ,TRDEC 6/04/84  SUBROUTINE TRDEC(J,K,N) C C transfers N words from IDEC(J) to IDEC(K) C *CALL PARAMA*CALL DECI  DO 10 I = 0, N-1  IDEC(K+I)=IDEC(J+I) 10 CONTINUE RETURN  END MOD8E 5/06/82UCASE 9/22/83n SUBROUTINE UCASE(AIN,AOUT)  SUBROUTINE UCASE(AIN) C nC Capitalizes string AIN and puts it in AOUT C Capitalizes string AINC n CHARACTER*(*) AIN, AOUT  CHARACTER*(*) AIN  CHARACTER*26 LOW,CAPC  DATA LOW /'abcdefghijklmnopqrstuvwxyz'/  DATA CAP /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/  C n AOUT=AIN C  | DO 10 I = 1 , LEN(AIN) n LE = MIN0(LEN(AIN),LEN(AOUT)) nC n DO 10 I = 1 , LE  DO 10 I = 1 , LEN(AIN)  L = INDEX(LOW,AIN(I:I)) n IF(L.NE.0) AOUT(I:I)=CAP(L:L) IF(L.NE.0) AIN(I:I) = CAP(L:L) 10 CONTINUE  RETURN  END &o ISL(NWRD) = NCHR ' NBLK = NBLK+1 ( ENDIF )C * ELSEIF (ITYP.EQ.2) THEN +C equal sigUPV3SW 2/13/84  SUBROUTINE UPV3SW C C This subroutine is used ONLY to search all the decks forC *IF directives and update the SWITCH table - used C to convert VERSION 3 files to VERSION 4.C It is called from RDOPL and RDOPLA and can be eliminatedC when there are no more old library files... C  *CA PARAMA  *CA DECKS  *CA CONTRL  *CA LOGU *CA MODCOM *CA DECA*CA PRFX  CHARACTER*8 DCK,NAM,DATD  DIMENSION IRD(5) EQUIVALENCE(LNX,IRD(1)),(IDK,IRD(2)),(NSQ,IRD(3)),  1 (IDEL,IRD(4)),(NMR,IRD(5)) C C *IF I4  INTEGER*4 ILX *ENDIF C  DO 1000 N=1,NDCKS n CALL RDDK(1,N) m NDKMEM=1 m CALL RDDK(N)  NDKMEL = 0  CALL RDDK('L', N, ILDECK, 0)  IDECP1=1  CALL EXAL(ADEC(IDECP1),IDECP1,NAM)  CALL EXAL(ADEC(IDECP1),IDECP1,DATD)  IDECP1=IDECP1+1  CALL EXIN(IDECP1,NMD,1) ! IDECP1=IDECP1+NMD"C #100 CONTINUE $C % ILX=IDECP1 & CALL EXIN(IDECP1,IRD(1),5) ' IF(LNX.EQ.0) GOTO 1000 ( IF(IDEL.GT.0) THEN ) IDECP1=ILX+LNX * GOTO 100 + ENDIF,C - IDECP1=IDECP1+NMR. LENA = (ILX+LNX-IDECP1)*NCHRWD / IF(ADEC(IDECP1)(1:1).EQ.PRFX) THEN 0 CALL DIRCHK(ADEC(IDECP1),LENA,ITDIR) 1 IF(ITDIR.EQ.11) THEN 2 CALL CKV3SW(ADEC(IDECP1),LENA) 3 ENDIF 4 ENDIF 5 IDECP1=ILX+LNX 6 GOTO 100 7C 81000 CONTINUE9C :2000 CONTINUE ; RETURN < END WRITE(LOU,111)'RUN STATISTICS' W WRITE(LOU,111)' ' X VAXMOD 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 *CALL ITABC 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 %v DATA ITAB /9/ %C %C ELIMINATES TABS %C ' J=1 ( N=0 ) M=IWID *C THE FOLLOWING IS A CHECK FOR 'TAB' +v IF(ICHAR(BUF(1:1)).EQ.ITAB.AND.  IF(ICHAR(BUF(1:1)).EQ.ITABC.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,M2v IF(ICHAR(BUF(I:I)).EQ.ITAB) THEN IF(ICHAR(BUF(I:I)).EQ.ITABC) THEN 3200 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 I=1,VLEVEL 4/25/84  SUBROUTINE VLEVEL C C Initializes the program versionC (replaces VERSN to use new *VLEVEL directive)C *CA IVERS *VLEVEL LSTMOD='$ID$'  RETURN  END ) GOTO 20 10 CONTINUE C 20 IF (WRBLKC 7/26/84 SUBROUTINE WRBLKC ( LUN, IARAY, NW) C C writes a block of character data to fileC  CHARACTER*(*) IARAY(NW) C  WRITE(LUN) IARAY  RETURN  END END INTEGER LUN, LRECL, IRECS, MXREC, IERROR C  *CALL PARAMA WRBLKI 7/26/84 SUBROUTINE WRBLKI ( LUN, IARAY, NW) C C writes a block of integer (or real) data to fileC  DIMENSION IARAY(NW) C  WRITE(LUN) IARAY  RETURN  END INTEGER LUN, LRECL, IRECS, MXREC, IERROR C  *CALL PARAMA WRDK 3/22/82z.m SUBROUTINE WRDK(LU,LOCR,NS,NBLKS)  SUBROUTINE WRDK(UPLOW, LU, LOCR, NS, NBLKS) C C WRITE A DECKC UPLOW - U or L for upper or lower memory location C LU - FILE C LOCR - RECORD NO ON FILEC NS - START POINTER TO DATA C NBLKS - NO. OF BLOCKS C  *CA PARAMA  *CA DECI  CHARACTER*(*) UPLOW .*IF I4  NW=NS  INTEGER*4 NW.*ENDIF C znC zn*IF SMALL zn SAVE LUN,NW,NR znC zn LUN = LU zn NW=ISDEC(NS) zn NR=LOCR zn*ENDIF z nC z n*IF -SMALL n NW=ISDEC(NS) m NW=MEMSTR(NS)  IF(UPLOW .EQ. 'L') THEN  NW = MEMSTL(NS)  ELSE  NW = MEMSTU(NS)  ENDIF DO 100 I=1,NBLKS CALL WRPL1(LU,LOCR,IDEC(NW))  NW=NW+NWRDBK  LOCR=LOCR+1 100 CONTINUE m CALL STATIS(2,NW) z n*ENDIF  RETURN z n*IF SMALL z nC zn ENTRY WRNEXR(NEXR) znC znC Write the next record znC (for SMALL only) znC zn CALL WRPL1(LUN,NR,IDEC(NW)) zn NR=NR+1 zn NEXR=NR zn RETURN zn*ENDIF  END NDKMEL = 0  CALL RDDK('L', N, ILDECK, 0)  IDECP1=1  CALL EXAL(ADEC(IDECP1),IDWRERR 11/17/83rn  SUBROUTINE WRERR C C prints and/or writes error messages C *CA PARAMA *CA LOGU*CA CONTRL *CA ERRMES  C DO 10 L=132,2,-1 IF(ERRMSG(L:L).NE.' ') GOTO 20 10 CONTINUE C 20 WRITE(LTO,91) ERRMSG(1:L)  20 CALL WRTIO(' '//ERRMSG(1:L))C  IF(LSTE) THEN rn IF (ICUC) CALL UCASE(ERRMSG(1:L),ERRMSG(1:L)) IF (ICUC) CALL UCASE(ERRMSG(1:L)) WRITE(LOU,91) ERRMSG(1:L)  CALL LININC(1)  ENDIF 91 FORMAT(A) n91 FORMAT(1X,A)  RETURN  END nC zn*IF SMALL zn SAVE LUN,NW,NR znC zn LUN = LU zn NW=ISDEC(NS) zn NR=LOCR zn*ENDIF z nC z n*IF -SMALL n NW=ISDEC(NS) WRMES 4/25/84  SUBROUTINE WRMES C C prints and/or writes messages C *CA PARAMA *CA LOGU*CA CONTRL *CA ERRMES  C DO 10 L=132,2,-1 IF(ERRMSG(L:L).NE.' ') GOTO 20 10 CONTINUE C 20 WRITE(LTO,91) ERRMSG(1:L)  20 CALL WRTIO(' '//ERRMSG(1:L))C  IF(ICL) THENn IF (ICUC) CALL UCASE(ERRMSG(1:L),ERRMSG(1:L)) IF (ICUC) CALL UCASE(ERRMSG(1:L)) WRITE(LOU,91) ERRMSG(1:L)  CALL LININC(1)  ENDIF 91 FORMAT(1X,A)  RETURN  END RMSG(1:L)  20 CALL WRTIO(' '//ERRMSG(1:L))C  IF(LSTE) THEN rn IF (ICUC) CALL UCASE(ERRMSG(1:L),ERRMSG(1:L)) IF (ICUC) CALL UCASE(ERRMSG(1:L)) WRITE(LOU,91) ERRMSG(1:L)  CALL LININC(1)  ENDIF 91 FORMAT(AWRNPL 3/22/82 zrpdR.  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 p*CA ERRMES *CALL FNAMES*CALL PRFX  DIMENSION IFD(8),IDD(8),IDM(4) CHARACTER*8 LABL  CHARACTER STATUS*8 C .*IF I4 . INTEGER*4 NR,N .*ENDIF  DATA IDD /8*0/  DATA IDM /4*0/ C C C FILE HEADER C  IDECP1=1 i LABL='SLIB77 '  LABL='SLIB77 '//PRFX  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 Calculate the number of blocks in the new library  NBLKT = 1  NBLKT = NBLKT+((8+2*NW8C)*NDCKS-1+NWRDBK)/NWRDBK NBLKT = NBLKT+((4+2*NW8C)*NMODS-1+NWRDBK)/NWRDBK NBLKT = NBLKT+((1+ NW8C)*NSWS -1+NWRDBK)/NWRDBK  DO 10 I = 1,NDCKS  NBLKT = NBLKT+NBLOK(I) 10 CONTINUE IRECS = 10 MXRECS = NBLKT  k CALL OPENER(LNP,NAMLNP(1:IWLNP),'NEW','DIRECT',  STATUS = 'NEW'  CALL FILECK(LNP,'NEW LIBRARY',NAMLNP,IWLNP,STATUS,IDDNAM)  CALL OPENER(LNP,NAMLNP(1:IWLNP),IDDNAM,STATUS,'DIRECT',  $ 'UNFORMATTED',NCHRWD*NWRDBK,IRECS,MXRECS,IERR)  IF(IERR.NE.0) THEN  ERRMSG=' Unable to open NEW LIBRARY file '//  1 NAMLNP(1:IWLNP)  CALL WRMES  CALL THEEND(2, ' Couldnt open new library') C  ELSE p ERRMSG=' Opened NEW LIBRARY file '// p 1 NAMLNP(1:IWLNP)  WRITE(ERRMSG,21) NAMLNP(1:IWLNP),NBLKT 21 FORMAT('Opened new library file ',A,' for',I6,' blocks.')  CALL WRMES  ENDIF C C  CALL INAL(ADEC(IDECP1),IDECP1,LABL) !C "C # CALL ININ(IDECP1,IFD,8) r CALL ININ(IDECP1,IFD(1),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) r CALL ININ(IDECP1,IDM(1),4) zn*IF SMALL zn IF(IDECP1.GT.NWRDBK) THEN zn NBLK=NBLK+1 zn CALL WRPLA(NU,NBLK,1)  NBLK = NBLK + 1 zn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,IDECP1-1) zn ENDIF *ENDIF SMALLzn*ENDIF :1500 CONTINUE; NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBK< NR=1 z n*IF SMALL z n IF (IDECP1.GT.1) THEN z n NBLKS=1 z n ELSE z n NBLKS=0 zn ENDIF zn*ENDIF = 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)) p IF(LSWTCH(I)) THEN p CALL ININ(IDECP1,1,1) p ELSE p CALL ININ(IDECP1,0,1) p ENDIF zn*IF SMALL zn IF(IDECP1.GT.NWRDBK) THEN  NBLK = NBLK + 1 zn NBLK=NBLK+1 zn CALL WRPLA(NU,NBLK,1) zn IDECP1=IDECP1-NWRDBK zn CALL TRDEC(NWRDBK+1,1,IDECP1-1) zn ENDIF*ENDIF SMALLzn*ENDIF G1580 CONTINUEH NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBKI NR=1 zn*IF SMALL zn IF (IDECP1.GT.1) THEN zn NBLKS=1 zn ELSE zn NBLKS=0 zn ENDIF zn*ENDIF 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 Tn CALL RDDK(1,N) m NDKMEM=1 m CALL RDDK(N) j NDKMEL = 0 j CALL RDDK('L', N, ILDECK, 0) Uj NBLKS=NBLOK(N) zn*IF -SMALL Vm CALL WRDK(NU,NBLK,1,NBLKS) j CALL WRDK('L', NU, NBLK, 1, NBLKS) z n*ENDIF z!n*IF SMALL z"n LU = LOCF(N) z#n LBLK=LOCB(N)  DO 2990 I = 1, NBLOK(N) z$n DO 2990 I = 1,NBLKS z%n CALL RDPLA(LU,LBLK,1) z&n LBLK=LBLK+1 z'n CALL WRPLA(NU,NBLK,1) z(n NBLK=NBLK+1 z)n2990 CONTINUE z*n*ENDIF 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) r CALL ININ(IDECP1,IDD(1),8) *IF SMALL  IF(IDECP1.GT.NWRDBK) THEN  CALL WRPLA(NU,NBLK,1) NBLK=NBLK+1 IDECP1=IDECP1-NWRDBK  CALL TRDEC(NWRDBK+1,1,IDECP1-1) ENDIF  *ENDIF SMALL z+n*IF SMALL z,n IF(IDECP1.GT.NWRDBK) THEN z-n NBLK=NBLK+1 z.n CALL WRPLA(NU,NBLK,1) z/n IDECP1=IDECP1-NWRDBK z0n CALL TRDEC(NWRDBK+1,1,IDECP1-1) z1n ENDIFz2n*ENDIF k5000 CONTINUEl NBLKS=(IDECP1-1+NWRDBK-1)/NWRDBKm 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 z3n*IF SMALL z4n IF (IDECP1.GT.1) THEN z5n NBLKS=1 z6n ELSE z7n NBLKS=0 z8n ENDIF z9n*ENDIF u DO 5100 I=1,NBLKS v CALL WRPLA(NU,NBLK,N) w N=N+NWRDBK x NBLK=NBLK+1 y5100 CONTINUE m CALL CLSFIL(NU) z PRINT*,'NEW PROGRAM LIBRARY FILE WRITTEN' pp ERRMSG='New library file written.' p CALL WRERR rp CALL WRMES rp WRITE(ERRMSG,5113) LOCB(NDCKS)+NBLOK(NDCKS)-1 rp5113 FORMAT(I6,' blocks on new library file') WRITE(ERRMSG,5113) LOCB(NDCKS)+NBLOK(NDCKS)-1 5113 FORMAT('New library file written (',I6,' blocks).') r CALL WRMES { RETURN | END EN  NCPLDI = 6  CPLDI = ' '  ENDIF C w NMODOP=NMODS x CALL STATIS (1,NDCKS) y WRNPLA 3/22/82 rqpdSR  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 p*CA ERRMES *CALL PRFX  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,NSWSdi WRITE(NU,11) 'SLIB77 ',IVERS,MWIDE,NDCKS,NMODS,NSWS,LANG  NAM = 'SLIB77 '//PRFX  WRITE(NU,11) NAM,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) q WRITE(NU,31)(MODNA(I),DATEM(I),I=1,NMODS) q31 FORMAT(10A8)C C SWITCHESC  WRITE(NU,35)(SWITCH(I),I=1,NSWS)p WRITE(NU,35)(SWITCH(I),LSWTCH(I),I=1,NSWS) 35 FORMAT(10A8) p35 FORMAT(8(A8,L2))!C "C DECKS #C $ DO 3000 N=1,NDCKS % IDECP1=1 &n CALL RDDK(1,N) m NDKMEM=1 m CALL RDDK(N)  NDKMEL = 0  CALL RDDK('L', N, ILDECK, 0)' 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' py ERRMSG='New formatted library file written.' ERRMSG='New portable library file written.' p CALL WRERR r CALL WRMES F RETURN G END g IDD(3)=NBLOK(N) h WROUT 4/25/84  SUBROUTINE WROUT C C writes messages C *CA PARAMA *CA LOGU*CA CONTRL *CA ERRMES  C DO 10 L=132,2,-1 IF(ERRMSG(L:L).NE.' ') GOTO 20 10 CONTINUE C n20 IF (ICUC) CALL UCASE(ERRMSG(1:L),ERRMSG(1:L)) 20 IF (ICUC) CALL UCASE(ERRMSG(1:L))  WRITE(LOU,91) ERRMSG(1:L)  CALL LININC(1) 91 FORMAT(1X,A)  RETURN  END C  WRITE(NU,35)(SWITCH(I),I=1,NSWS)p WRITE(NU,35)(SWITCH(I),LSWTCH(I),I=1,NSWS) 35 FORMAT(10A8)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  WRSERC 2/13/85 SUBROUTINE WRSERC(LU,A,LENA)*CA PARAMA  CHARACTER*(MAXWID) AC C writes records from SEARCH directive on source fileC  WRITE(LU,1) A(1:LENA) 1 FORMAT(A) RETURN  END *CA MODNA  *CA DECKS  WRTIO 7/26/84  SUBROUTINE WRTIO(LINE) C C THIS SUBROUTINE WRITES A LINE TO THE TERMINAL DEVICEC  CHARACTER LINE*(*) *CALL LOGU *CALL BATCH *IF NPS *CALL NPSARG  CHARACTER NPSREM*120 INTEGER IQUERY  C  IF (TMODE .NE. 'BATCH') THEN CALL TUBE(0,LTO,1,LINE,IQUERY,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL)  v IF (QREADY.AND.QERROR) CALL NPSEIO('TUBE VIA WRTIO') IF (QREADY.AND.QERROR) THEN  WRITE (NPSREM,'(A,I5,A,A)') 'TUBE called with LTO=',LTO,  $ ', LINE=',LINE(1:ITRAIL(LINE)) CALL NPSEIO('TUBE via WRTIO',NPSREM(1:ITRAIL(NPSREM)))  ENDIF  IF (QERROR) WRITE (LTO,'(1X,A)') LINE  ELSE  WRITE(LTO,'(A)') LINE  ENDIF *ENDIF *IF -NPS  WRITE(LTO,'(A)') LINE *ENDIF  RETURN  END  $ NXDATE 3/22/82ysr`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 *IF NPS *CALL NPSARG  CALL DATE(CHDATE,  $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) v IF (QREADY.AND.QERROR) CALL NPSEIO('DATE VIA XDATE') IF (QREADY.AND.QERROR) CALL NPSEIO('DATE via XDATE', $ 'XDATE called with CHDATE='//CHDATE)  IF (QERROR) CHDATE = 'NOT SET' *ENDIF *IF -NPSr*IF APOLLO r r INTEGER*2 TIMEDATE(6) , YEAR, MONTH, DAYrC (1) = YEAR, I4rC (2) = MONTH, I2 rC (3) = DAY, I2 rC (4) = HOURrC (5) = MINUTE r C (6) = SECOND r EQUIVALENCE (YEAR,TIMEDATE(1)), r 1 (MONTH,TIMEDATE(2)),r 2 (DAY,TIMEDATE(3)) r r%INCLUDE '/SYS/INS/CAL.INS.FTN' r r*ENDIF 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 s*IF DEC20 s CHARACTER*10 DEC20 s*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 r r*IF APOLLO r r CALL CAL_$DECODE_LOCAL_TIME(TIMEDATE) r YEAR = YEAR - 1900 r IF ( YEAR .GT. 100 ) YEAR = YEAR - 100 r r WRITE (CHDATE,11) MONTH,DAY,YEAR r r*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 s*IF DEC20 s CALL DATE(DEC20)s MO=INDEX('JanFebMarAprMayJunJulAugSepOctNovDec',DEC20(4:6)) s MO=(MO/3)+1 s WRITE(CHDATE,9) MO,DEC20(1:2),DEC20(9:10) y WRITE(CHDATE,9) MO,DEC20(1:2),DEC20(8:9) s 9 FORMAT(I2,'/',A2,'/',A2)s *ENDIF  *ENDIF *IF UNIX  CALL IDATE(I,J,K)  WRITE (CHDATE,11) I,J,K *ENDIF UNIX  RETURN C  END ACCESS=',ACCESS,', FORM=',TFORM - XTIME 7/26/84  SUBROUTINE XTIME(CHTIME)C C THIS SUBROUTINE RETURNS THE CURRENT TIME AS: C HH:MM:SS C  CHARACTER CHTIME*(*)*IF NPS *CALL NPSARG C CHARACTER TEMP*8 y REAL*8 DTIME  DOUBLE PRECISION DTIME CALL TIME(DTIME, $ NPSDIM,LERROR,NERROR,REMARK,QREM,QREADY,QERROR,LEVEL) v IF (QREADY.AND.QERROR) CALL NPSEIO('TIME VIA XTIME') IF (QREADY.AND.QERROR) THEN  WRITE (TEMP,'(F8.5)') DTIME  CALL NPSEIO('TIME via XTIME','XTIME called with DTIME='//  $ TEMP)  ENDIF  IF (.NOT.QERROR) THEN  I = DTIME  J = (DTIME - I) * 60.0 K = (DTIME - I - J/60.0) * 3600.0  WRITE(TEMP,10) I,J,K 10 FORMAT(I2,':',I2.2,':',I2.2)  ELSE  TEMP = ' '  ENDIF  CHTIME = TEMP *ENDIF *IF -NPS  CHTIME = ' '*ENDIF  RETURN  END *ENDIF *IF -NPSr*IF APOLLO r r INTEGER*2 TIMEDATE(6) , YEAR, MONTH, DAYrC (1) = YEAR, I4rC (2) = MONTH, I2 rC (3) = DAY,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.0VERSN 9/22/83qponmlkjihgfed  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 ' j LSTMOD='MOD54 ' k LSTMOD='MOD55 ' l LSTMOD='MOD56 ' m LSTMOD='MOD57 ' n LSTMOD='MOD58 ' o LSTMOD='MOD59 ' p LSTMOD='MOD60 ' q LSTMOD='MOD61 '  RETURN  END + 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