PATCHY 5.05 /3 1996/06/29 17.00 +PATCH, *PATCHY. Pilot for Patchy version 5 +USE, MACHINE. +USE, PATCHY_GO. +USE, AUXIL_GO. +USE, NOOPT. +PATCH, *INSTAL, T=JOIN. Pilot to get the installation job +USE, MACHINE. +USE, INSTAL. +SELF, IF=-*INSTAL. To extract the installation job for a given machine: #!/bin/csh -f -v nypatchy patchy.car job.sh .go <= 2) exit chmod 755 *.sh* rm p5boot.log #------------- doing Kernlib if (-d wk_kern) rm -r wk_kern mkdir wk_kern cd wk_kern nypatchy $P5PAM .go <<\\ &USE, ${MACHINE}. &ASM, FORT, T=SPLIT, LOG .p5kern.log &ASM, FORT, T=EXT, IF=APOLLO ..ftn &EXE. &USE, MACHINE. &PAM, RETURN=MACHINE. &USE, P5BOOT. &USE, *KAMX, IF=AMIGAUX. &USE, *KAPO, IF=QF_APO &USE, *KAPOF77, IF=QF_APOF77. &USE, *KCRU, IF=QMCRY. &USE, *KCVY, IF=QMCVY. &USE, *KDOS, IF=MSDOS. &USE, *KHPX, IF=QMHPX. &USE, *KIBX, IF=QMIBX. &USE, *KIRT, IF=QMIRT. &USE, *KLNX, IF=LINUX. &USE, *KMPW, IF=MACMPW. &USE, *KNSX, IF=NECSX. &USE, *KNXT, IF=NEXT. &USE, *KSGI, IF=QMSGI. &USE, *KSUN, IF=QMSUN. &USE, *KTMO, IF=TMO. &USE, *KVAOS, IF=QMVAO. &USE, *KVMI, IF=QMVMI. &USE, *KVAX, IF=QMVAX,IF=-QMALPH. &USE, *KALPH, IF=QMVAX,IF= QMALPH. &USE, *KUUX, IF=QMUUX. .OPTION, VERBOSE. &PAM, T=ATT, IF=QMAPO .${KERN}/kernapo &PAM, T=ATT, IF=QMCRY .${KERN}/kerncry &PAM, T=ATT, IF=QMCVY .${KERN}/kerncvx &PAM, T=ATT, IF=QMHPX .${KERN}/kernhpx &PAM, T=ATT, IF=QMIBX .${KERN}/kernibx &PAM, T=ATT, IF=QMIRT .${KERN}/kernirt &PAM, T=ATT, IF=QMLNX .${KERN}/kernlnx &PAM, T=ATT, IF=QMSGI .${KERN}/kernsgi &PAM, T=ATT, IF=QMSUN .${KERN}/kernsun &PAM, T=ATT, IF=QMVAX .${KERN}/kernvax &PAM, T=ATT, IF=QMVMI .${KERN}/kernvmi &PAM, T=ATT .${KERN}/kernfor &QUIT. \\ set rc = $status if ($rc != 0) exit nyshell p5kern.log a ../export.cra .go set rckern = $status if ($rckern >= 2) exit 7 chmod 755 *.sh* rm p5kern.log cd ../ rm export.cra #------------- make the tar file tar -cf ../p5boot$code.tar * cd ../ compress p5boot$code.tar #--- remove everything except the tar file rm -r wk_p5boot exit #------------- if one wanted to check the result: #- but only on the target machine mkdir wk_p5boot cd wk_p5boot cp ../p5boot$code.tar.Z p5boot.tar.Z uncompress p5boot.tar tar -xf p5boot.tar csh -f -v p5boot.shfca cd wk_kern csh -f -v p5kern.shfca cd ../ csh -f -v p5create.sh cd ../ rm -r wk_p5boot +PATCH, PATCHY_GO. Select Patchy and the Auxiliaries +USE, BACKCOMP. +USE, PCDE, FLDIALG. +USE, RUN, ACSORT, DOMAP, DOXQT, DOFORG. +USE, ARRIVE, DEPART, PUTIL. +USE, SERVICE, NAMING. +USE, *HYDRA. +USE, QDEBUG, TESTR, IF=QDIAG. +USE, YINDEX, IF=AUXIL_GO. +USE, YLIST, IF=AUXIL_GO. +USE, YSYNOPT, IF=AUXIL_GO. +USE, YCHECK, IF=AUXIL_GO. +USE, YTIDY, IF=AUXIL_GO. +USE, YMERGE, IF=AUXIL_GO. +USE, YDIFF, IF=AUXIL_GO. +USE, YSHELL, IF=AUXIL_GO. +USE, AUXIL, IF=AUXIL_GO. +DECK, APO, T=JOIN, IF=QMAPO. version for APOLLO +SELF. +USE, QFIO. !!! to try +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +KEEP, Q_AND. IAND (IZV,IZW) = AND (IZV, IZW) +KEEP, Q_OR. IOR (IZV,IZW) = OR (IZV, IZW) +KEEP, Q_XOR. IEOR (IZV,IZW) = XOR (IZV, IZW) +KEEP, Q_SHIFTL. ISHFTL (IZW,NZB) = LSHFT (IZW, NZB) +KEEP, Q_SHIFTR. ISHFTR (IZW,NZB) = RSHFT (IZW, NZB) +KEEP, Q_JBIT. JBIT (IZW,IZP) = AND (RSHFT(IZW,IZP-1), 1) +KEEP, Q_JBYT. JBYT (IZW,IZP,NZB)= RSHFT (LSHFT(IZW,33-IZP-NZB), 32-NZB) +KEEP, PGMSTOP. CALL PGM_$EXIT +DECK, HPX, T=JOIN, IF=QMHPX. version for HP Unix +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +KEEP, Q_JBIT. JBIT (IZW,IZP) = IBITS (IZW,IZP-1,1) +KEEP, Q_JBYT. JBYT (IZW,IZP,NZB) = IBITS (IZW,IZP-1,NZB) +DECK, IBM, T=JOIN, IF=QMIBM. version for IBM +USE, QFIO. Fortran I/O +USE, INITRH. create routine header lines +USE, YSHELL, T=INH. for the time being +DECK, IRT, T=JOIN, IF=QMIRT. version for IBM RS 6000 +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +DECK, LNX, T=JOIN, IF=QMLNX. version for LINUX +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +DECK, MPW, T=JOIN, IF=QMMPW. version for Mac with MPW +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +KEEP, Q_JBIT. JBIT (IZW,IZP) = IBITS (IZW,IZP-1,1) +KEEP, Q_JBYT. JBYT (IZW,IZP,NZB) = IBITS (IZW,IZP-1,NZB) +SELF, IF=-QMMPW. +DECK, NXT, T=JOIN, IF=QMNXT. version for NEXT +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +DECK, SGI, T=JOIN, IF=QMSGI. version for Silicon Graphics +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +KEEP, Q_SHIFTL. ISHFTL (IZW,NZB) = LSHIFT (IZW, NZB) +KEEP, Q_SHIFTR. ISHFTR (IZW,NZB) = RSHIFT (IZW, NZB) +KEEP, Q_JBIT. JBIT (IZW,IZP) = IAND (RSHIFT(IZW,IZP-1), 1) +KEEP, Q_JBYT. JBYT (IZW,IZP,NZB)= RSHIFT (LSHIFT(IZW,33-IZP-NZB), 32-NZB) +DECK, SUN, T=JOIN, IF=QMSUN. version for SUN +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +KEEP, Q_AND. IAND (IZV,IZW) = AND (IZV, IZW) +KEEP, Q_OR. IOR (IZV,IZW) = OR (IZV, IZW) +KEEP, Q_XOR. IEOR (IZV,IZW) = XOR (IZV, IZW) +KEEP, Q_SHIFTL. ISHFTL (IZW,NZB) = LSHIFT (IZW, NZB) +KEEP, Q_SHIFTR, IF=-BUGLRSHFT. not usable with f77 3.0 ISHFTR (IZW,NZB) = lrshft (IZW, NZB) +KEEP, Q_JBIT, IF=-BUGLRSHFT. JBIT (IZW,IZP) = AND (lrshft(IZW,IZP-1), 1) +KEEP, Q_JBYT, IF=-BUGLRSHFT. JBYT (IZW,IZP,NZB)= lrshft (LSHIFT(IZW,33-IZP-NZB),32-NZB) +DECK, VAX, T=JOIN, IF=QMVAX. version for VAX +USE, QFIO. Fortran I/O +USE, INITRH. create routine header lines +DECK, VAO, T=JOIN, IF=QMVAO. version for Alpha with OSF +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +DECK, VMI, T=JOIN, IF=QMVMI. version for DECstation MIPS +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +DECK, UUX, T=JOIN, IF=QMUUX. version for an Unknown UniX machine +USE, QNEWLINE. newlines are in memory +USE, INITRH. create routine header lines +DECK, F2C, T=JOIN, IF=QF_F2C. code for f2c +KEEP, Q_AND. IAND(IZV,IZW) = AND(IZV,IZW) +KEEP, Q_OR. IOR(IZV,IZW) = OR(IZV,IZW) +KEEP, Q_XOR. IEOR(IZV,IZW) = XOR(IZV,IZW) +KEEP, Q_SHIFTL. ISHFTL (IZW,NZB) = LSHIFT (IZW,NZB) +KEEP, Q_SHIFTR. +KEEP, Q_JBIT. JBIT(IZW,IZP) = AND(ISHFTR(IZW,IZP-1),1) +KEEP, Q_JBYT. JBYT(IZW,IZP,NZB) = ISHFTR(LSHIFT(IZW,33-IZP-NZB),32-NZB) +DECK, ALL, T=JOIN. +USE, QCIO, IF=-QFIO. Use C for I/O +KEEP, Q_SHIFTL. ISHFTL (IZW,NZB) = ISHFT (IZW, NZB) +KEEP, Q_SHIFTR. ISHFTR (IZW,NZB) = ISHFT (IZW, -NZB) +KEEP, Q_AND, T=NOLIST. +KEEP, Q_OR, T=NOLIST. +KEEP, Q_NOT, T=NOLIST. +KEEP, Q_XOR, T=NOLIST. +KEEP, Q_JBIT, T=NOLIST. +KEEP, Q_JBYT, T=NOLIST. +KEEP, QCARDL, T=NOLIST. +PATCH, PATCHY_LIB. to make the library without main programs +USE, RUN, D=NPATCH, T=INH. +USE, YINDEX, D=NINDEX, T=INH. +USE, YLIST, D=NLIST, T=INH. +USE, YSYNOPT, D=NLIST, T=INH. +USE, YCHECK, D=NCHECK, T=INH. +USE, YMERGE, D=NMERGE, T=INH. +USE, YTIDY, D=NTIDY, T=INH. +USE, YDIFF, D=NDIFF, T=INH. +USE, YSHELL, D=NSHELL, T=INH. +PATCH, *HYDRA, T=JOIN. Hydra pilot +USE, QCDE, MQ, QUTIL, KERN. +USE, DQ, IF=QDEBUG. +PATCH, PCDE. Patchy CDE's +DECK, PCDE. +KEEP, NAMEC. COMMON /NAMEC/ NA_OCC, NA_CUT, NA_MXSL, NA_MXTX +KEEP, JSPSEQ. PARAMETER (JSPSEQ1=3, JSPDATE=9, JSPSEQL=15) +KEEP, ARRCOM. COMMON /ARRCOM/IN_LUN, IN_FD, IN_FIO, IN_EOF +, IN_DOX, IN_DO1, IN_DO2 +KEEP, CCTYPE. PARAMETER (MCCNIL=1, MCCKIL=2, MCCINC=3, MCCCDE=4, MCCSEQ=5, + MCCXSQ=6, MCCTRU=7, MCCFAL=8, MCCELS=9, MCCEND=10, + MCCSEL=11, MCCSES=12, MCCFAU=13, MCCSKI=14, + MCCKEE=15, MCCDEL=16, MCCREP=17, MCCADB=18, MCCADD=19, + MCCUSE=20, MCCXDI=21, MCCDIV=22, MCCLIS=23, MCCEXE=24, MCCIMI=25, + MCCASM=26, MCCUPD=27, MCCNAM=28, MCCGAP=29, MCCMOR=30, MCCONL=31, + MCCFOR=32, MCCSUS=33, MCCOPT=34, MCCOP2=35, MCCSHO=36, MCCPAM=37, + MCCQUI=38, MCCEOD=39, MCCDEC=40, MCCPAT=41, MCCTIT=42) +KEEP, CCPARA. CHARACTER CCKORG*256, CCKARD*256, CCCOMF*256 COMMON /CCPARA/NCHCCD,NCHCCT, JCCTYP,JCCLEV,JCCSL,MCCPAR(240) +, NCCPAR,MXCCIF,JCCIFV,JCCBAD,JCCWAR,ICCSUB,JCCWK(4) +, JCCPP,JCCPD,JCCPZ,JCCPT,JCCPIF,JCCPC,JCCPN +, NCCPP,NCCPD,NCCPZ,NCCPT,NCCPIF,NCCPC,NCCPN +, JCCEND, NCHCCC,IXCCC, CCKORG, CCKARD, CCCOMF +KEEP, CHEXC. CHARACTER CHEXPD*68 COMMON /CHEXC/ IXEXPAM, IXEXPAT,IXEXDEC,IXEXID, NCHEPD, CHEXPD +KEEP, CM_TYP. PARAMETER (JFO_TYP=1, JCC_TYP=2, JAS_TYP=3, JDA_TYP=4, + JSH_TYP=5, JCR_TYP=6, JIN_TYP=7, MAX_TYP=100) CHARACTER*16 CH_TYP(MAX_TYP), ACT_TYP COMMON /CM_TYP/ LUN_TYP, N_TYP, NAL_TYP, NDV_TYP, JBK_TYP +, JU_TYP(MAX_TYP), CH_TYP, ACT_TYP +KEEP, DEPCOM. COMMON /DEPCOM/JD_NEW, JD_DTN, JD_DTP, JD_DTD, JD_DIV +, JD_SML, JD_SMP, JD_SMX, JDP_DT, JDP_DV +, JD_SPL, JD_MOD, JD_LUN, JD_LOG, JD_NLI, JD_MULT +, IX_EXT, IX_RH, IX_SUB +KEEP, DEPMOD. COMMON /DEPMOD/MO_JSA, MO_JSL, MO_JSE +KEEP, DEPSUB. CHARACTER*8 CH_SUBS, CH_SUBT COMMON /DEPSUB/NCH_SUB, CH_SUBS, CH_SUBT +KEEP, DIFFC. COMMON /DIFFC/ NFAID, JFAIDA, JFAIDE +KEEP, FTNLUN, IF=QFIO. Active Fortran logical input units PARAMETER (NSFTN=20) COMMON /FTNLUN/LUNFRS(NSFTN) +KEEP, FLINKC. PARAMETER (NSLIFI=128) CHARACTER CHLIFI*(NSLIFI), CHLIEX*8 COMMON /FLINKC/LUNOP,LUNFD,LUNOLD,LUNSIZ +, IXFLUN, NLIFI,CHLIFI,CHLIEX +KEEP, INCLC. COMMON /INCLC/ N_INCL, IX_INCL(100) +KEEP, LUNSLN. COMMON /LUNSLN/IFLAUX, IXLUN(12) +KEEP, NCNAME. PARAMETER (NCNAME=32) +KEEP, TAGC. CHARACTER CHTAG*80, CHWYL*16 COMMON /TAGC/ LLORG,LNORG,LLACT,LNACT, LALTN,LMODE,NCHTAG +, CHTAG,CHWYL +KEEP, TITLEC. PARAMETER (NFIMAX=100) COMMON /TITLEC/ NFILET, JTIPAM(NFIMAX) +KEEP, USETTC. CHARACTER CHTTNA*10, CHTTDT*20 COMMON /USETTC/ JTTNAM,JTTVER,JTTSLA,JTTDAT,JTTCOM +, NTTNA(5), NTTDT, NTTNORM, NTTALL +, CHTTNA(5), CHTTDT +KEEP, M_ANAC. COMMON /M_ANAC/LOWAN,KDOAN,LDOAN,LUPAN,MODEAN,MEXAN,LEVAN,KKM5AN +, NEWDEC,NEWCTL,NEWFOR,NEWNIL,NEWINC +KEEP, KQADR. PARAMETER (KQGARB=1,KQARRV=3,KQKEEP=4,KQPREP=5,KQMAIN=6,KQPAST=8) +KEEP, KQUSER. PARAMETER (KQUSER=9) +KEEP, PY. +, LEXP,LLPAST,LQPAST, LQUSER(4), LHASM,LRPAM,LPAM, LQINCL +, LACRAD,LARRV, LPCRA,LDCRAB, LEXD,LDECO, LCRP,LCRD, LSERV +, INCRAD, IFLGAR, JANSW, IFMODIF, IFALTN +, JDKNEX,JDKTYP, JSLZER,NSLORG,JSLORG +, MOPTIO(34), MOPUPD, NCLASH, IFLMERG,IFLDISP, NSLFRE,NTXFRE +, NVGAP(4), NVGARB(6), NVIMAT(4), NVUTY(4), LASTWK +KEEP, MUSEBC. COMMON /MUSEBC/ MX_FORC, MU_GLOB, MU_PAT, MU_DECK, MU_INH, MU_FORG +, MX_TRAN, MX_FORG, MX_SINH, MX_SELF, NVEXDK(6) +KEEP, SLATLN. CHARACTER SLLINE*512, SLERRM*256 COMMON /SLATLN/ SLLINE, SLERRM +DECK, PEXPL, IF=DOCUMENT, DOC_INL. explain the COMMON variables +KEEP, xARRCOM. C-- ARRIVE parameters: C- IN_LUN LUN of currently arriving material C- IN_FD C file descriptor of currently arriving material C- IN_FIO 0/1 if no/yes Fortran input C- IN_EOF 0/1 if EoF seen C- IN_DOX action request to ARRINC C- = -1 close C- 0 rewind C- +1 reposition file such that line in slot IN_DO1 C- is the next line to be read C- +2 read starting at slot LQLEND(2), C- at most IN_DO1 lines, IN_DO2 characters C- IN_DO1 auxiliary parameters C- IN_DO2 +KEEP, xCCTYPE. c/line type codes C- PARAMETER (MCCxxx see: D=CCKRAK +KEEP, xCCPARA. C-- Control-line kracking parameters: C- NCHCCD number of char. in c/l up to incl. terminating "." C- NCHCCT total number of char. in current c/l C- JCCTYP c/l type of current c/line C- JCCLEV number of underscores in current +_IF etc C- JCCSL slot number of the current control line C: MCCPAR(240) the c/l parameter vector C- the following words are pre-zeroed with VZERO: C- NCCPAR number of entries C- MXCCIF EXE bits of all patches referenced with IF= C- JCCIFV 0/1 true/false result of IF= (done in CCPROC) C- JCCBAD non-zero if syntax error C- JCCWAR = zero if no warning, C- = 1 obscured terminating dot C- = 2 trailing comma C- ICCSUB non-zero if envir. var. substitution done and result C- not yet printed C- JCCWK(4) pre-zeroed local variables of CCKRAK C- JCCPP access to the first parameter of type X, = 0 if none C- JCCPD C- JCCPZ C- JCCPT C- JCCPIF C- JCCPC C- JCCPN C- NCCPP number of parameters of type X C- NCCPD C- NCCPZ C- NCCPT C- NCCPIF C- NCCPC C- NCCPN C- JCCEND first unused word in MCCPAR, set to zero C- NCHCCC number of characters ready in CCCOMF C- IXCCC the name-index of the comment-field in CCCOMF C- stored into the name-stack C- CCKORG*256 the original of the current c/l, unchanged C- CCKARD*256 the current c/l, blank squeezed, C- converted to upper case C- CCCOMF*256 the comment-field of the current c/c copied C- to here by CALL CCCOMG C- each entry in the MCCPAR() parameter vector has 3 words, C- the N'th parameter of key x is accessed via: C- J = JCCPx + 3*(N-1) [but for T= : J=JCCPT + 3*N ] C- as: MCCPAR(J) = jtyp C- MCCPAR(J+1)= jval1 C- MCCPAR(J+2)= jval2 C: special preset : MCCPAR (1)= zero, (2)= -1, (3)= (zero) C- for J = 0: J+1 J+2 C: "jtyp" indicates the separator type just preceding, C- set -ve if parameter starts with "-" C- 1 comma only 5 ,T= or ,X= C- 2 ,P= or ,S= 6 ,IF= or ,&= C- 3 ,D= or ,R= 7 ,C= or ,L= C- 4 ,Z= or ,F= 8 ,N= C: "jval1" and "jval2" indicate the parameter value, C- depending on the parameter type: C- P=,D=,Z=,IF= : jval1 = name index of the name C- jval2 = jval1 C- C=, N= : jval1 = first integer value C- jval2 = second, of N1-N2 C- T= : for J=JCCPT, summary of all parameter values: C- jval1= bit set for each value occuring C- jval2= jval1 initially, reset by CCOPT in C- the order of the argument list C- for J=JCCPT + 3*N, whereabouts of the parameter: C- jval1= JPOS, CCOL(JPOS) first character C- jval2= NCH, length of the parameter string C: The values for C= are changed for C- +DEL, or +REPL,..., C=x: jval1 = x, jval2 = x C- +ADB, pname, dname, C=x: jval1 = x, jval2 = x C- +ADD, pname, dname, C=x: jval1 = x+1, jval2 = x C: Note for defaults, for example if JCCPD is zero: C- JVAL = MCCPAR(JCCPD+1) C- gives zero for "no D=" and for D=, C- index for D=name C- JVAL = MCCPAR(JCCPD+2) C- gives -1 for "no D=" C- zero for D=, C- index for D=name +KEEP, xCHEXC. C-- Current deck / patch / PAM: C- IXEXPAM current PAM name index C- IXEXPAT current patch name index C- IXEXDEC current deck name index C- IXEXID current thing name index: deck, or patch if blank deck C- NCHEPD number of characters in the current P/D identifier C- CHEXPD*68 current P/D identifier constructed by DPHEAD +KEEP, xCM_TYP. data-type handling C- MAX_TYP maximum number of data types C- LUN_TYP highest LUN used for ASM, = 32, 33, 34,... C- N_TYP number of data types established C- NAL_TYP number of aliases defined (including REPEAT + JOIN) C- NDV_TYP = i from ASMNAME cracking of type:i C- JBK_TYP > 0 if ASMNAME did back-compatibility data-type conversion C- JU_TYP(j) = i: alias j referes to ASM stream i C- CH_TYP(n)*16 table of data type codes C- ACT_TYP*16 = type from ASMNAME cracking of type:i C: preset: CH_TYP(1) = 'FORT ' C- CH_TYP(2) = 'CC ' C- CH_TYP(3) = 'AS ' C- CH_TYP(4) = 'DATA ' C- CH_TYP(5) = 'SHELL ' C- CH_TYP(6) = 'CRAD ' C- CH_TYP(7) = 'INCL ' JU_TYP C- CH_TYP(n-5) = 'CO*MPILE' 1 C- CH_TYP(n-4) = 'XCC ' 2 C- CH_TYP(n-3) = 'AS** ' 3 C- CH_TYP(n-2) = 'DA*TA ' 4 C- CH_TYP(n-1) = 'R*EPEAT ' -1 C- CH_TYP(n-0) = 'J*OIN ' -2 +KEEP, xDEPCOM. C-- Depart parameters C- JD_NEW flag: 0 output for current deck running C- +1 output for new deck has to be started C- -1 output for new routine has to be started C- JD_DTN data type of the deck about to be processed C- JD_DTP data type of the current patch C- JD_DTD data type of the current deck C- 1 FORT, 2 CC, 3 AS, 4 DATA, 5 SHELL, 6 INCL C- 7 user data type 1, 8 ... C- JD_DIV diversion status of current deck C- 1 normal, 2 divert, 3 xdiv/normal, 4 xdiv/divert C- JD_SML adr of the ASML bank for the current logical stream C- JD_SMP adr of the ASML bank for the current physical stream C- JD_SMX adr of the ASMX bank for the current physical stream C- JDP_DT stream number of the ASML for the physical stream C- JDP_DV and its diversion number C- JD_SPL departure mode: C- 0 bypass C- 1 normal sequential output C- 2 split mode C- 3 modify mode C- JD_MOD not zero if MODIFY is running, C- set or reset to zero for normal output C- JD_LUN Fortran logical unit / C file descriptor for the ASM file C- JD_LOG Fortran logical unit / C file descriptor for the log file C- JD_NLI number of lines written for current deck/routine C- JD_MULT number of files written for this deck C- IX_EXT name index for default extension C- IX_RH name index to the routine-header line mask C- IX_SUB name index to the control-character substitution string +KEEP, xDEPMOD. C-- Depart parameter for T=MODIFY C- MO_JSA slot number of first line in store C- MO_JSL slot number of current line C- MO_JSE slot number of last line in store +KEEP, xDEPSUB. C-- Control-character substitution for Depart C- NCH_SUB number of possible c/ch C- CH_SUBS*8 source c/ch's C- CH_SUBT*8 target c/ch's +KEEP, xDIFFC. C-- Difference processing, result from DIF_XQT C- NFAID number of entries in the failure list C- JFAIDA start adr of the failure list produced by DIF_XQT C- JFAIDE end+1 adr of this list C- one entry in this list is : C- MFAID(J + 0 : code -1 pure delete C- 0 delete / insert C- +1 pure insert C- + 1 : n of failure-start line for "old" C- + 2 : n of failure-start line for "new" C- + 3 : no. of lines deleted C- + 4 : no. of lines inserted +KEEP, xFLINKC. file linking parameters C- PARAMETER (NSLIFI=128) length of CHLIFI C- LUNOP Fortran logical unit number C- LUNFD C file descriptor, returned from FLINK C- LUNOLD = 0/1 returned from FLINK: file did not/did pre-exist C- LUNSIZ file size measured by FLINK, =0 if not poss. C- IXFLUN name index of the file name, as returned by FLKRAK C- if non-zero on entry to FLINK: get the name into CHLIFI C- NLIFI number of significant characters in CHLIFI C- CHLIFI*() the file name, may be preloaded before entry to FLINK C- CHLIEX*8 the default extension, may be preloaded before C- entry to FLKRAK +KEEP, xJSPSEQ. C---- Special sequence calls (see D=NA_INPY and D=INISEQ): C- JSPSEQ1+ C-- special actions C-. +0 -1 QCARD1, R=name. start new sub-deck C-. +1 0 QEJECT, N=n. conditional page eject C-- generate for each call C-. +2 1 QFTITLE, N=n. gives: +nHtitle C-. +3 2 QFTITLCH, N=n. gives: + 'title' C-. +4 3 QFHEAD, S=symb, L=lim, N=n .txb?txa C-. +5 4 QFNAME, S=symb, L=lim, N=n .txb?txa C-. +6 5 QFVERS, S=symb, L=lim, N=n .txb?txa C-. +7 6 QFVSNUM, S=symb, L=lim, N=n .txb?txa C-. +8 7 QFVPRIM, S=symb, L=lim, N=n .txb?txa C-. +9 8 QFVSEC, S=symb, L=lim, N=n .txb?txa C-. +10 9 QDATE, S=symb .txb?txa C-. +11 10 QTIME, S=symb .txb?txa C-. +12 11 QENVIR .text C-- constants of the run C-. +13 QTERMHD gives: \\ or \ C-. +14 DATEQQ gives: IDATQQ = yymmdd C-. +15 TIMEQQ gives: ITIMQQ = hhmm +KEEP, xLUNSLN. MAIN connection C-- Passing the command-line/dialog parameters to MAIN: C- IFLAUX non-zero if an Auxiliary is executing C- IXLUN(J) name index to file-name / opt string for J'th param. +KEEP, xM_ANAC. C-- DOMAP communication: C- LDOAN L of current PREP/MAT bank C- KDOAN K-adr of LDOAN C- LOWAN L of PREP bank sending to LUPAN C- LUPAN L of current ACT bank if doing foreign material C- into current deck C- = zero: doing PREP banks C- MODEAN material type being currently processed: C- = 0 ordinary self 1 IF-conditional self C- 2 +SELF,sname 3 +KEEP 4 +REPL,+ADB,+ADD C- MEXAN cumulating EXE bits for self material of current deck C- LEVAN IF level indication offset = (level) - (no of underscores) C- KKM5AN zero if bit 5 not set set in current PREP bank at LDOAN C- NEWDEC number of +DECK etc seen in current deck C- NEWCTL current deck has hard c/lines C- NEWFOR current deck generates foreign material C- NEWNIL current deck has f/material killed from outside C- NEWINC current deck calls a modified include file +KEEP, xMUSEBC. C-- USE and EXE bits: C- MX_FORC EXE bits for +FORCE/+SUSP (6-9 SUSP, 15-18 FORCE) C- MU_GLOB USE bits global C- MU_PAT USE bits for current patch, taken from IQ(LEXP) C- MU_DECK USE bits for current deck C- bits 5-1: USE bits for foreign + self C- 5 USE, 4 XDIV, 3 DIV, 2 LIST, 1 EXE C- 10-6: INHIBIT bits, =0 inhibited, =1 allowed C- 14-11: TRANS bits C- 18-15: EXE bits for self only C- blowing MU_DECK into 4 words right-justified: C- MX_FORG EXE-bits for FOREIGN+SELF material, copy of bits 1-4 C- MU_FORG USE-bits for FOREIGN+SELF material, copy of bits 1-5 C- MU_INH USE-bits for INHIBIT copy of bits 6-10 C- MX_TRAN EXE-bits for TRANSmission by +USE copy of bits 11-14 C- MX_SINH INHIBIT bits for self: logical AND of MU_DECK + MX_FORC C- MX_SELF EXE-bits for SELF-material collected from all sources C- NVEXDK() operation mode for SELF of current deck C- = 0/1 no/yes for processing mode : C- NVEXDK(1) EXE for self material of current deck C- NVEXDK(2) LIST for self material of current deck C- NVEXDK(3) DIVERT for self material of current deck C- NVEXDK(4) XDIV for self material of current deck C- NVEXDK(5) EXE or LIST: = NVEXDK(1) + NVEXDK(2) C- NVEXDK(6) FULL-list for control lines: NVEXDK(2) && option F +KEEP, xNAMEC. C-- Name handler controls, see doc: the name handler C- NA_OCC slot JSL of the last name in the table C- NA_CUT number of significant char. in P/D/Z names C- NA_MXSL maximum number of name slots available C- NA_MXTX max. number of characters for all names C- ie. the size of text division 5 C- access to the text of the name with index IXNAME is: C- slot: JSL = LQLSTA(5) + IXNAME C- start: JTX = MLIAD(JSL) C- length: NCH = MLIAD(JSL+1) - JTX +KEEP, xTAGC. C-- Tag for next line to be printed C- LLORG the LNORG of the previous call to DPTAG C- LNORG the LORG of the current P/D tag to be made C- LLACT the LNACT of the previous call to DPTAG C- LNACT the ACT bank active, if not zero C- LALTN the value of IFALTN at the previous call to DPTAG C- LMODE the MODE parameter of the previous call to DPTAG C- NCHTAG length of the tag, = zero if none pending C- CHTAG the tag text C- CHWYL Wylbur tag printed in DPLINE if NQWYLDO non-zero: C- if NQWYLDO > 0: line-number constructed to here C- = -1: text preset by calling program, C- stepped to -2 after the line is printed C- = -2: text cleared by DPLINE before printing, C- stepped to -3 after the line is printed C- < -2: text used as is +KEEP, xTITLEC. C-- PAM file titles saved: C- PARAMETER (NFIMAX=100) C- NFILET number of files seen so far C- JTIPAM(J) slot number of the file title of PAM-file J +KEEP, xUSETTC. C-- PAM file title analysed into components and stored into SLERRM C- PATCHY 5.00 /72 1994/05/24 21.00 text C- _:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: 4_:.=+=.: 5_:.= C- CHTTNA(1) = name PATCHY C- CHTTNA(2) = version 5.00 /72 C- CHTTNA(3) = numeric vs 50072 C- CHTTNA(4) = primary vs 5.00 C- CHTTNA(5) = secondary vs 72 C- CHTTDT = date/time 1994/05/24 21.00 C- NTTNA(J) number of characters in CHTTNA(J) C- NTTNORM standard name/vs/date/time is in SLERRM(1:NTTNORM) C- NTTALL complete title is in SLERRM(1:NTTALL) C- start column of fields: C- JTTNAM name C- JTTVER primary version C- JTTSLA the / of the secondary version C- JTTDAT date + time C- JTTCOM free comment +KEEP, xKQADR. K-adr of data structures C- PARAMETER (KQGARB=1,KQARRV=3,KQKEEP=4,KQPREP=5,KQMAIN=6,KQPAST=8) +KEEP, xPY. Hydra links and wsp C- LQGARB garbage d/s, banks in division 1 to be collected C- LQHOLD adr of the HOLD bank, see storage C- LQARRV d/s of ARRV banks, the first is the active PAM C- LQKEEP d/s of global sequences C- LQPREP d/s PREP in division 2 for doing the current deck C- LEXP the main d/s "future" PAT / DECK / ACT C- also: adr of the PAT bank of the current patch C- LLPAST adr of the link-bank between "future" and "past" C- LQPAST d/s "past" PAT / DECK C- LQUSER support links for 4 data structures for the Auxilliaries C- LHASM master bank for all ASM streams C- LRPAM last RPAM bank created: current PAM file C- LPAM bank to receive the parameters from c/line +PAM, ... C- holds also the statistics of cradle and PAM input C- LQINCL linear structure of INCL banks, remembering C- the include files generated C- LACRAD the ARRV bank controlling cradle input C- LARRV the currently active input stream, points C- to LACRAD during cradle input, and C- to LQARRV during PAM input C- LPCRA L of PAT of the last P=CRA* C- LDCRAB L of DECK of the blank deck of CRA* C- LEXD L of DECK of the current deck C- LDECO L of the ORG bank for the current deck, C- = 0 if not yet lifted C- LCRP L of PAT used in CREAPD C- LCRD L of DECK used in CREAPD C- LSERV L of the permanent MAT bank for temporary service C- INCRAD 0/>0 for no/yes cradle processing C- = 3 processing the blank deck of P=CRA* C- 2 processing deck CRA* of P=CRA* C- 1 other cradle material C- IFLGAR if zero: garbage collection has not yet been C- done for the current deck C- JANSW status answer between some routines C- IFMODIF 0/1 if no/yes +ASM, T=MODIF present in this run C- IFALTN non-zero only if further alternative sequence expansions C are being listed by Nysynopt C- JDKNEX DK-type of pending unit header : C- JDKTYP DK-type of current unit header: C- = 0 not a unit header C- 1 +DECK C- 2 +PATCH C- 3 +TITLE C- 4 +PAM C- 5 +QUIT C- 6 End-of-File C- -1 +MORE C- JSLZER slot number of the first line of the current lot C- of the current deck (normally there is only one C- lot in each deck, except after IF deselected +PAM) C- NSLORG = 0 normally, if not: offset for JSLORG C- JSLORG = JSLZER-NSLORG, slot number of the first line of C- the current deck for line-number printing only C- MOPTIO (1) 0/1 if A option no/yes set C- (2) B C- ... C- (26) Z C- (27) 0 C- (28) 1 C- (29) 2 C- (30) 3 C- (31) 4 C- MOPTIO(33) options 1-31 packed C- MOPTIO(34) option code translated for the Auxiliaries C- MOPUPD = 0 not running update C- > 0 update mode, but not under +PAM, T=UPD. C- < 0 update for +PAM, T=UPDATE C- NCLASH print warnings at or above this clash level C- default = zero (meaning 1 in fact) C- IFLMERG != 0 if T=MERGE on the last +PAM c/l C- IFLDISP != 0 if T=DISPLAY on the last +PAM c/l C- NSLFRE number of free line slots C- NTXFRE number of TEXT characters free trigger garbage collection if not available: C- NVGAP(1) number of words in control division 2 C- NVGAP(2) number of lines in text divisions 3+4 parameters to control the look-ahead: C- NVGAP(3) maximum number of lines expected in any deck C- NVGAP(4) mean number of characters per line C- NVGARB(6) - unused - C- NVIMAT(1) L of the target PAT bank of the last +ADD etc C- if zero: implied P/D not allowed for next +ADD etc C- (2) L of the target DECK bank C- NVUTY(1) K-adr of PAT bank returned by CREAPD C- (2) K-adr of DECK bank C- LASTWK last word of working-space for MQWORK +DECK, BANK_DESC, IF=DOCUMENT, DOC_INL. Patchy bank descriptions +KEEP, bkYINDEX. C- .NYINDEX special usage of some banks C- ---------------------------------- C- C- PAT bank linear structure supported by LQUSER(1) C- C- link 1: next C- status: bit 6 set if patch name quoted in IF= C- word 1: deck-number of the blank deck C- = -1 if patch not physically present C- 2: patch name index C- C- DECK bank linear structure supported by LQUSER(2) C- C- 2: zero (for DOMAPA) C- link 1: next C- status: C- word 1: deck name index C- 2: patch name index C- 3: deck-number C- C- KEEP bank linear structure supported by LQKEEP C- C- link 2: PAT or DECK bank of origin C- 1: next C- status: bit 1 set if link 2 points to a PAT bank C- word 1: sequence name index C- +SELF, NEWPG. +KEEP, bkYDIFF. C- .NYDIFF special usage of some banks C- ---------------------------------- C- C- FILE bank 2 linear structures supported C- by LQUSER(1) for "old", LQUSER(2) for "new" C- C- 4: linear structure of PAT banks belonging C- 3: next ! C- 2: matching bank in the other structure C- link 1: zero ! C- status: C- rest like PAT bank C- C- PAT bank linear structure supported by LQ(LFILE-4) C- C- 4: linear structure of DECK banks belonging C- 3: FILE origin C- 2: matching bank in the other structure C- link 1: next C- status: bit 1 set if the DECK structure is an exact match C- 2 set if there are no unmatched decks left C- 3 set if no re-ordering needed C- 4 set if a deck from some other patch C- to be moved into this patch C- rest like DECK bank C- C- DECK bank linear structure supported by LQ(PAT-4) C- C- 3: PAT origin C- 2: matching bank in the other structure C- link 1: next C- status: C- word 1: JSL of the first line in memory, zero if out-of-memory C- 2: NSL number of lines in this deck/patch/file C- 3: NCH number of characters in this d/p/f C- 4: deck/patch/file name index C- 5: "old": ordinal number of the bank in its structure C- "new": ordinal number of the matching "old" bank C- 6: matching status: C- = 0 normal C- 1 new deck / patch C- old: 4 deck is done for DICRAD C- new: 4+IXP deck to be moved to here from patch IXP C- C- 7: JSL of the first line on the file, =0 is first C- 8: JTX of the first character on the file, =0 is first C- C- 9: normally zero C- "new" only: =N in the first bank of a string of N+1 banks C- with a contiguous match (N further banks) C- "old" only: -ve if the bank is a proxy for a new patch C- C- 10: = 0 normally if no duplicates, = n if n'th duplicate +SELF, NEWPG. +KEEP, bkKEEP. C- .KEEP bank : sequence material C- ----------------------------- C- C- 4 : Nysynopt only: further variants of same sequence C- link 3 : origin pointer to ORG, deck-patch origin of this material. C- link 2 : linear chain of associated MAT banks C- link 1 : next KEEP bank C- status : bits 1-4: attached EXE-bits: XDIV DIV LIST EXE C- 5: usage processing done if set C- 6: all lower sequences are global and attached C- 7: =0 if new sequence pre-lifted not yet ready C- =1 completed by DOFORG C- 8: C- 9-11: ACT-type: zero C- 12: set if NIL sequence (i.e. deleted) C- Nysynopt: seq. not to be expanded C- 13: set if special sequence like QCARD1 etc C- 14: Nysynopt: seq. with T=SINGLE in the cradle C- 15: Nysynopt: first seq. stored for T=SINGLE C- C- 16: set if T=NOLIST C- 17: set if global and single line (direct substitution) C- 18: set if material from the cradle C- 19: set if APPEND done C- C- word 1 : slot-number of the first line (just after the +KEEP) C- 2 : number of lines supported by this bank C- 3 : origin line-count of first line C- 4 : sequence name index C- +KEEP, bkACT. C- .ACT bank : action control C- ------------------------- C- C- link 3 : origin pointer to ORG, deck-patch origin of this material C- link 2 : linear chain of associated MAT banks C- link 1 : next ACT bank for this deck C- status : bits 1-4: attached EXE-bits: 4 XDIV 3 DIV 2 LIST 1 EXE C- 5-6: C- 7-8: C- 9-11: ACT-type: 0 DEL, 1 REP, 2 ADB, 3 ADD C- 12: set if NIL action (i.e. deleted) C- 13: set if clash-deselected C- 14-15: clash level C- 16: C- 17: (set if IF-conditional) C- 18: same target deck as previous action C- word 1 : slot-number of the control-line +REPL etc C- 2 : number of lines supported by this bank: =1 C- 3 : origin line-count of the control-line C- 4 : action target line number: C- +DEL/+REPL start, +ADB it, +ADD it+1 C- 5 : action target line number: C- +DEL/+REPL end, +ADB/+ADD it C- +KEEP, bkMAT. C- .MAT bank : foreign material continued C- ------------------------------------- C- C- link 3 : present only if the first c/l is a delayed +KEEP, REPL, etc C- if present: significance as for PREP C- link 2 : origin pointer to ORG, deck-patch origin of this material C- link 1 : next MAT bank C- status : matching with PREP: C- bits 1-4: attached EXE bits C- 5-6: PREP status: 0 active, 1 deselected, 2 deleted C- 7: C- 8: if type is KEEP or action: set if NIL seq or action C- 9-14: JCTYPE of first line C- 15: the first line is a delayed control-line C- 16: C- 17: set if start of +IFx at basic level C- 18: C- 21-25: action level number C- word 1 : slot-number of first line C- 2 : number of lines supported by this bank C- 3 : origin line-count of first line of text C- +SELF, NEWPG. +KEEP, bkCSEQ. C- .XSQ bank : sequence calls ready for use C- ---------------------------------------- C- C- link j : +ve: reference to KEEP-bank of global sequence called C- 0: unsatisfied sequence call C- -ve: reference to KEEP of non-global sequence C- link 2 : in MAT chain : origin pointer C- in PREP chain : = zero C- link 1 : next MAT or PREP bank C- status : bits 1-4: EXE bits of all ready global sequences attached C- 5-6: PREP status: 0 active, 1 deselected, 2 deleted C- 7: deleted by +DEL or +REPL action C- 9-14: JCTYPE: =MCCCDE or MCCSEQ if result of and C- containing +CDE +SEQ (in MAT and PREP) C- =MCCSES if result of and containing C- +SELF,sname (both in MAT and PREP) C- =MCCXSQ if follow on +ADD,Z=sname (MAT) C- 15: set if delayed control-line C- 16: set if T=PASS C- 17: set if all sequences attached and global C- 21-25: action level number C- word 1 : slot-number of original line +SEQ C- word 2 : number of lines supported, =0 if type MCCXSQ, C- =1 if type MCCDE or MCCSEQ C- =n if type MCCSES C- word 3 : line number of original +CDE or +SEQ or +SELF C- word 4 : n, number of sequences called C- word j : name index of sequence j-4 (j=5,...,n+4) C- link j-2 points to the corresponding KEEP bank C- +KEEP, bkPREP. C- .PREP bank : content analysis bank C- ---------------------------------- C- C- link 3 : for +REPL etc: pointer to target deck C- for +KEEP: +ve: pointer to preliminary KEEP bank C- -ve: for T=APPEND, pointer to KEEP for the C- sequence to be appended to C- link 2 : pointer to foreign material to be inserted at this point C- link 1 : next C- status : matching with MAT C- bits 1-4: attached EXE bits C- 5-6: PREP status: 0 active, 1 deselected, 2 deleted C- 7: deleted by +DEL or +REPL action C- 8: if type is KEEP or action: set if NIL seq or action C- 9-14: JCTYPE of first line C- 15: C- 17: set if start of +IFx at basic level C- 18: if set: same target deck as previous action C- 21-26: data-type number if +DECK or +PATCH C- word 1 : slot-number of first line of text supported C- 2 : number of lines supported by this bank, zero if link 2 not zero C- +SELF, IF=-PCDE. C- Notes : C- C- For context see P=DOCUMENT C- C- About KEEP or ACT banks C- ----------------------- C- NIL keep or action is a keep or an action which has been deleted either C- by a +DEL or +REPL action upstream, or which has been de-selected by IF=. C- Its bank carries the EXE-bits (processing mode selection bits) to C- the next true keep or to the deck addressed by the action. C- A NIL-bank is created only if its EXE-bits are different from those C- of the addressed deck; it does not support text material. C- C- About the PREP bank C- ------------------- C- If link 2 is non-zero this PREP is only a sentinel pointing to the C- action to be inserted at this point. In this case it has no supported C- text, word 2 is zero, but word 1 gives the slot number of the next C- line for sequential search and JCTYPE on bits 9-14 of the status C- gives the c/c-type of this next line just after the insertion point. C- +SELF, NEWPG. +KEEP, bkHOLD. C- .HOLD bank: remaining material in memory to be done C- ---------------------------------------------------- C- supporting link: LQHOLD in LQ C- C- status : bit 1 set if new instalment has been read C- from file to memory C- word 1 : slot-number of the first line of unprocessed material C- and of the first line of the current deck always C- 2 : number of lines of unprocessed material C- if zero: no material to be saved C- 3 : number of lines in current deck C- +SELF, IF=-PCDE. C- This bank serves also as a delimiter between the old and the new foreign C- material in division 1 : C- C- |----------------------------------| C- banks : | old banks | HOLD | new banks | C- |----------------------------------| C- |LQCSTA(1) |LQCEND(1) C- C- |----------------|--------------------------------------| C- text : | old material | new material | unprocessed material | C- |----------------|--------------------------------------| C- |LQLSTA(1) |LQLEND(1) |LQLEND(2) C- |LQLSTA(2) C- C- 'Old banks' have all their associated text material already shifted into C- text division 1; the text associated to 'new banks' is still resident C- in text division 2. C- C- Garbage collection, triggered either by 'space full' or when starting C- a new PAM file is initiated by calling MQSHIFT. This has these steps: C- C- 1) garbage collection (MQGARB) of material no longer needed C- in bank division 1, a linear structure supported by LQGARB; C- this will squeeze bank and text divisions 1. C- C- 2) left shift text material in text division 2 supported by 'new banks' C- by appending to text division 1. This requires the new banks C- to be in the same order as the new text material. C- Material in text division 2 not supported by new banks or by HOLD C- (normally self-material) disappears automatically. C- C- 3) reset LQLEND(1) and LQLSTA(2) to the new limit of division 1. C- C- 4) left shift the 'unprocessed material" to the start of C- text division 2, reset LQLEND(2). C- C- 5) drop the old HOLD bank and lift the new one at the end of C- bank division 1. C- +SELF, NEWPG. +KEEP, bkPAT. C- .PAT bank : support all material for this patch C- ---------------------------------------------- C- C- link 4r: PAT, last USE or USE-inhibit for this patch from patch indicated C- link 3 : KEEP, patch-directed sequences for this patch C- link 2 : DECK, decks of this patch C- link 1 : PAT, next C- C- status : selection : 5 USE 4 XDIV 3 DIV 2 LIST 1 EXE C- bits 1-5 : for 'foreign + self', enabled if bit = 1; C- 6-10 : for 'inhibit', inhibited if bit = 0; C- 11-14 : for 'transmit via +USE', enabled if bit = 1 C- 15-18 : for 'self only', enabled if bit = 1. C- C- word 1 : status-word extension, flags : C- bit 1 : patch de-selected by +PATCH,...,IF=... C- 2 : patch de-selected by +IMITATE,... C- 3 : at least 1 deck written to ASM-file C- (this is cleared in PEND if EXE-bit is on) C- 4 : partial USE by +USE,...,D=... C- 5 : scattered patch signalled by T=REPEAT C- 6 : patch quoted in IF=... C- 7 : set if @file patch, ie. new PAM file C- 8 : set if PAM file skipped C- 13-32 : deck-number of the blank deck C- C- word 2 : patch name index, zero if this is the bank at LLPAST C- -ve if this is an RPAM bank C- +KEEP, bkDECK. C- .DECK bank : support all material for this deck C- ---------------------------------------------- C- C- link 4r: back-pointer to the PAT bank supporting this bank C- link 3 : KEEP, deck-directed sequences for this deck C- link 2 : ACT, actions into this deck C- link 1 : DECK, next C- C- status : bits 1-18 : processing-modes, U-selection, as for PAT bank C- C- word 1 : deck name index C- +KEEP, bkORG. C- .ORG bank : origin indication of foreign material C- ------------------------------------------------- C- C- status : bits 1-18 : deck-number of origin deck C- word 1 : deck name index of origin deck C- word 2 : patch name index of origin patch C- +KEEP, bkINCL. C- .INCL bank : remember the name of one include file C- -------------------------------------------------- C- linear structure supported by LQINCL C- C- status : bits 1-4 : attached EXE bits C- 5 : 0/1 file has not/yes been re-written C- word 1 : deck name index C- +SELF, NEWPG. +KEEP, bkARRV. C- .ARRV bank : currently arriving material C- --------------------------------------- C- C- One bank for each active multi-PAM file, and one bank for the cradle C- C- link 2 : ASAV bank, save pre-read material, = zero if none C- link 1 : next C- C- word 1 : LUN, logical unit number, set to = zero if the C- last file used through this bank has been closed C- C- word 2 : file descriptor for C input C- word 3 : label from +PAM, L=lab, = zero if unlabelled C- word 4 : name index of the path name of the attached file C- word 5 : Nysynopt: Wylbur line number remembered if file C- was halted because of call by +PAM,...,RETURN=pname C- C- word 6 : total size of the file in bytes, = zero if not known C- C- word 7 : NCHP : current file position from CITELL C- -ve if seek not possible (terminal, or VAX, IBM) C- = -1 : reading cradle from on-line user with prompt C- = -2 : otherwise C- C- word 8 : non-zero if EOF reached C- C- word 9 : deck position : C- = 0 file rewound or at EoF C- +ve deck-number of the last deck processed after processing C- was halted because of call by +PAM,...,RETURN=pname C- Nydiff: the file is positioned just after this line C- C- wd 10 : slot number of the current PAM file title C- wd 11 : name index of the current PAM file identifier C- wd 12 : number of lines read on this stream C- +KEEP, bkASAV. C- .ASAV bank : holding pre-read material of the cradle / PAM file C- --------------------------------------------------------------- C- C- word 1 : JSL - slot number of the first line, in text division 1 C- word 2 : NSL - number of lines, zero if none C- +SELF, IF=-PCDE. C- The ARRV banks for PAM files form a linear structure supported C- by the link LQARRV = LQ(KQARRV); the bank for the active PAM stream C- is shunted to the beginning. C- C- The ARRV bank for the cradle is supported by the link LACRAD. C- C- Link LARRV points to the stream, cradle or PAM, currently under input. +SELF, NEWPG. +KEEP, bkPAM. C- .PAM bank : parameters from c/line +PAM and statistic C- ---------------------------------------------------- C- supporting link: LPAM in LQ C- C- For: +PAM, LAB=lab, N=x,y, T=opt, RETURN=pname .fname C- C- word 1 : LUN, Fortran logical unit number C- if =zero: starting the very first PAM file C- 2 : C- 3 : label from L=lab C- 4 : number of Pam files to be skipped, default =zero C- 5 : number of PAM files to be read, default =999 C- 6 : option bit mask from T=opt C- 7 : name index of pname from R=pname C- 8 : name index of fname C- 11 : C- 12 : count total no. of lines on all PAM-files C- 13 : count total no. of PAM files C- 14 : count total no. of +PAM,... lines C- +KEEP, bkRPAM. C- .RPAM bank : PAM-file parameters registered - 1 bank for each PAM-file C- --------------------------------------------------------------------- C- C- link 1 : next PAT bank C- status : bits 1-17 : file-number = 100*n + m C- n'th line +PAM,...; m'th PAM-file read C- word 1 : slot number of the PAM file title C- 2 : -ve of the name index of the PAM file ID C- 3 : deck number of the first deck C- 4 : is -1 if the PAM file has been skipped C- +SELF, IF=-PCDE. C- Notes : C- C- 1) The PAM-bank receives the parameters from the current c/l +PAM. C- It also keeps the cumulative global statistics about PAM + cradle input. C- There is one single stand-alone PAM-bank, supported by LPAM. C- C- 2) The RPAM bank is imbedded in the linear structure of past PAT-banks C- at the place where this PAM has been started reading, C- to allow printing of the PAM-file identifier in the final summary. C- C- 3) One RPAM bank is created for every PAM-file on a PAM big-file, C- even for PAMs which have been skipped. C- Common link LRPAM always points to the last RPAM bank created. C- +SELF, NEWPG. +KEEP, bkASM. C- .ASMH bank : support ASMT banks for all ASM streams C- -------------------------------------------------- C- supporting link: LHASM in LQ C- C- link 1 : stream FORT JASM=1 C- 2 : CC 2 C- 3 : AS 3 C- 4 : SHELL 4 C- 5 : DATA 5 C- C- 6 : u/type 6 C- ... C- N : u/type N C- C- status : unused C- word 1 : = 30, LUN for output with SPLIT or MODIFY C- C- C- .ASMT bank : control ASM output for one data type C- ------------------------------------------------ C- C- link 1 : ASMX bank if this logical stream is also physical C- 2 : ASML bank for stream :1 normal C- 3 : for stream :2 divert C- 4 : :3 extra/normal C- 5 : :4 extra/divert C- C- status : like ASML C- C- words 1-10: like ASML C- C- C- .ASML bank : control ASM output for one particular logical stream C- ---------------------------------------------------------------- C- C- link 1 : ASMX bank if this logical stream is also physical C- C- status : C- C- word 1 : JUSE = 8*JASM + JSTR this stream is connected to (JASM,JSTR) C- the stream is independent only if JUSE= zero C- if -ve: use default connection, evaluated C- at the end of the blank deck of CRA* C- C- word 2 : output mode: 0 bypass C- 1 normal sequential C- 2 split mode C- 3 modify mode C- C- word 3 : name index of file name for T=ATTACH C- log file name for T=LOG C- 4 : name index of prefix for T=PREFIX C- C- 5 : name index of file-name extension, if non-zero C- 6 : name index for the routine header mask, zero if none C- 7 : name index of c/ch substitution string, if non-zero C- C- 8 : number of decks for this logical stream C- 9 : number of decks actually written for this logical stream C- 10 : number of lines written for this logical stream ? C- 11 : if non-zero: reassigned to log. stream JASM*8 + JDIV C- C- C- .ASMX bank : extra ASM parameters for one physical stream C- ---------------------------------------------------------------- C- C- link 1 : unused C- status : unused C- word 1 : unused C- word 2 : Fortran logical unit / C file descriptor C- if <0: file not yet opened C- C- 3 : number of decks actually written to this physical stream C- 4 : number of lines written to this physical stream C- +PATCH, QCDE. Hydra CDE's +DECK, QCDE. +KEEP, QBANKS. Patchy bank parameters PARAMETER (NBANKS=19,JBKPAT=1, JBKDEC=2, JBKORG=3, JBKINC=4, + JBKHOL=5, JBKKEE=6, JBKACT=7, JBKMAT=8, JBKXSQ=9, + JBKPRE=10,JBKGAR=11,JBKSMH=12,JBKSMT=13,JBKSML=14, + JBKSMX=15,JBKARR=16,JBKASA=17,JBKPAM=18,JBKRPA=19) COMMON /QBANKS/MMBANK(5,NBANKS) +KEEP, MQCM. Memory occupation parameters COMMON /MQCM/ NQSYSS,NQLINK, LQCSTA(3),LQCEND(3), NQMAX +, LQLSTA(5),LQLEND(5), LQADR,LQADR0,NQOFFS +KEEP, MQCT. Memory table parameters COMMON /MQCT/ LQTA,LQTB,LQTE,LQMTB,LQMTE,LQMTH +, JQDIVG,NQRESV(3),IQPART,NQFREE(3) +KEEP, MQCL. NAME parameters to be packed for MQLIFT COMMON /MQCL/ NQLST,NQLNA,NQID,NQTY,NQLI,NQNL,NQNS,NQND +KEEP, MQCN. Unpacked NAME parameters COMMON /MQCN/ IQLST,IQLNA,IQID,IQTY,IQLI,IQNL,IQNS,IQND +, IQLNX,IQFOUL +KEEP, QCHAR. Character constants CHARACTER CQBLAN*128, CQEQS*128, CQCETA*32 CHARACTER CQAPO*1, CQBSL*1, CQTAB*1 COMMON /QCHAR/ CQBLAN, CQEQS, CQCETA, CQAPO, CQBSL, CQTAB +KEEP, QMACHFIX. Machine parameters PARAMETER (NQBITW=32, NQBITC=8, NQCHAW=4) +KEEP, QMACH. +CDE, QMACHFIX. +KEEP, QPAGE. Page control COMMON /QPAGE/ NQLMAX,NQLTOL,NQLTOK,NQCMAX,NQCPGH,NQPAGE +, NQWYLDO,NQWYL,NQNEWH,NQJOIN,NQDKNO,NQDKPG +KEEP, QSTATE. Program status parameters CHARACTER CQDATEM*10, CQDATE*8, CQTIME*5 COMMON /QSTATE/NQERR,NQWARN,NQINFO,NQLOCK +, IQDATE,IQTIME, CQDATEM,CQDATE,CQTIME +KEEP, QSYSBITS. PARAMETER (IQDROP=31, IQMARK=30, KMDROP=1073741824) +KEEP, QUNIT. Logical unit numbers COMMON /QUNIT/ IQREAD,IQPRNT, IQTTIN,IQTYPE, IQOFFL,IQRTTY,IQRSAV +, IQRFD,IQRRD,IQRSIZ, NQLPAT,NQUSED,NQLLBL, NQINIT +KEEP, NEWLINE, IF=QNEWLINE. PARAMETER (NEWLN=10, NCHNEWL=1) +KEEP, NEWLINE. PARAMETER (NEWLN=10, NCHNEWL=0) +KEEP, NSIZEQ. Dimensions for the dynamic store PARAMETER (NSIZEQ=100000, NSIZELN=100000) +KEEP, Q. Dynamic store, full text +CDE, NEWLINE. +CDE, NSIZEQ. PARAMETER (NSIZETX=40*NSIZELN) CHARACTER TEXT(NSIZETX)*1 DIMENSION LQ(NSIZEQ), IQ(NSIZEQ), MLIAD(NSIZELN) EQUIVALENCE (LQ,IQ,LQGARB), (MLIAD(1),LQ(NSIZEQ)) EQUIVALENCE (TEXT(1), MLIAD(NSIZELN)) COMMON // IQUEST(100),LQGARB,LQHOLD,LQARRV,LQKEEP,LQPREP +KEEP, QSH. Dynamic store, Hydra store only +CDE, NSIZEQ. DIMENSION LQ(NSIZEQ), IQ(NSIZEQ) EQUIVALENCE (LQ,IQ,LQGARB) COMMON // IQUEST(100),LQGARB +KEEP, QTX. Dynamic store, line-store only +CDE, NEWLINE. +CDE, NSIZEQ. PARAMETER (NSIZETX=40*NSIZELN) CHARACTER TEXT(NSIZETX)*1 DIMENSION LQ(NSIZEQ), MLIAD(NSIZELN) EQUIVALENCE (LQ,LQGARB), (MLIAD(1),LQ(NSIZEQ)) EQUIVALENCE (TEXT(1), MLIAD(NSIZELN)) COMMON // IQUEST(100),LQGARB +KEEP, QUEST. Dynamic store, IQUEST only COMMON // IQUEST(100) +KEEP, SLATE. COMMON /SLATE/ NDSLAT,NESLAT,NFSLAT,NGSLAT,NUSLAT(2),DUMMY(34) +KEEP, MQCALL. All commons required by MQ +CDE, QBANKS, MQCM, MQCT, MQCN, QMACH, QSTATE, QUNIT. +KEEP, QBITS19. Masks for bits 1 to 19 PARAMETER (KM1=1,KM2=2,KM3=4,KM4=8,KM5=16,KM6=32,KM7=64,KM8=128, + KM9=256, KM10=512, KM11=1024, KM12=2048, KM13=4096, KM14=8192, + KM15=16384, KM16=32768, KM17=65536, KM18=131072, KM19=262144) +KEEP, QBITA19. Masks for bits 1 to 19 PARAMETER (KM1=1,KM2=2,KM3=4,KM4=8,KM5=16,KM6=32,KM7=64,KM8=128, + KM9=256, KM10=512, KM11=1024, KM12=2048, KM13=4096, KM14=8192, + KM15=16384, KM16=32768, KM17=65536, KM18=131072, KM19=262144) PARAMETER (KMA=1,KMB=2,KMC=4,KMD=8,KME=16,KMF=32,KMG=64,KMH=128, + KMI=256, KMJ=512, KMK=KM11, KML=KM12, KMM=KM13, KMN=KM14, + KMO=KM15, KMP=KM16, KMQ=KM17, KMR=KM18, KMS=KM19) +KEEP, QBITS31. Masks for bits 1 to 31 PARAMETER (KM1=1,KM2=2,KM3=4,KM4=8,KM5=16,KM6=32,KM7=64,KM8=128, + KM9=256, KM10=512, KM11=1024, KM12=2048, KM13=4096, KM14=8192, + KM15=16384, KM16=32768, KM17=65536, KM18=131072, KM19=262144, + KM20=524288, KM21=1048576, KM22=2097152, KM23=4194304, + KM24=8388608, KM25=16777216, KM26=33554432, KM27=67108864, + KM28=134217728, KM29=268435456, KM30=536870912, KM31=1073741824) +KEEP, QBITA31. Masks for bits 1 to 31 PARAMETER (KM1=1,KM2=2,KM3=4,KM4=8,KM5=16,KM6=32,KM7=64,KM8=128, + KM9=256, KM10=512, KM11=1024, KM12=2048, KM13=4096, KM14=8192, + KM15=16384, KM16=32768, KM17=65536, KM18=131072, KM19=262144, + KM20=524288, KM21=1048576, KM22=2097152, KM23=4194304, + KM24=8388608, KM25=16777216, KM26=33554432, KM27=67108864, + KM28=134217728, KM29=268435456, KM30=536870912, KM31=1073741824) PARAMETER (KMA=1,KMB=2,KMC=4,KMD=8,KME=16,KMF=32,KMG=64,KMH=128, + KMI=256, KMJ=512, KMK=KM11, KML=KM12, KMM=KM13, KMN=KM14, + KMO=KM15, KMP=KM16, KMQ=KM17, KMR=KM18, KMS=KM19, KMT=KM20, + KMU=KM21, KMV=KM22, KMW=KM23, KMX=KM24, KMY=KM25, KMZ=KM26) +DECK, QEXPL, IF=DOCUMENT, DOC_INL. explain the COMMON variables +KEEP, xQBANKS. Patchy bank parameters NBANKS=17 number of banks types known by PATCHY-HYDRA MMBANK(5,NBANKS) table of bank properties, look at D=MQINIT JBKxxx=nn index of type XXX into MMBANK +KEEP, xQCHAR. Character constants CQBLAN*128 string of all blanks CQEQS*128 string of all '=' CQCETA*32 A -> Z, 0 -> 5, the CETA order CQAPO*1 character 'apostrophe' CQBSL*1 character 'back slash' CQTAB*1 character 'horizontal tab' +KEEP, xQMACH. Machine properties PARAMETER normally NQBITW=32 number of bits per word NQBITC=8 number of bits per character NQCHAW=4 number of characters per word +KEEP, xQPAGE. Page control NQLMAX number of lines per page, default = 110 NQLTOL number of l/p/p to eject for new deck, = 103 NQLTOK number of l/p/p to eject for new group, = 106 NQCMAX number of columns accross the page, default = 120 NQCPGH page-width to be used for the page header NQPAGE current global page number NQWYLDO Wylbur line numbers to be printed if non-zero if >/< 0: do yes/no print Wylbur number on current line NQWYL Wylbur line number of last line printed NQNEWH 0/1 deck header is no/yes still to be printed NQJOIN 0/1 no/yes T=JOIN parameter present on current +DECK < 0 force JOIN on next patch if on same page as current NQDKNO current deck number NQDKPG local page number for current deck +KEEP, xQSTATE. Program status parameters NQERR number of errors in current run NQWARN number of warnings printed NQINFO number of info warnings printed NQLOCK IQDATE date of start of run: integer yymmdd IQTIME time hhmm CQDATEM*10 date character yyyy/mm/dd CQDATE*8 date character yyyymmdd CQTIME*5 time hh.mm +KEEP, xQUNIT. Logical unit numbers IQREAD used Fortran LUN for cradle input IQPRNT used Fortran LUN for printed output IQTTIN Fortran LUN for what would be terminal input IQTYPE Fortran LUN for what would be terminal output IQOFFL = 0/1 the job is no/yes running off-line IQRTTY = 0/IQTTIN cradle input is no/yes the user's terminal IQRSAV Fortran LUN for what would be off-line cradle input IQRFD used C file-descriptor for cradle input (if QCIO) IQRRD number of lines already read by FLPARA from re-directed standard input (if QCIO) IQRSIZ if QCIO and cradle input off-line: = pre-known size of the cradle file, = 0 if not NQLPAT value of NQUSED after the last line +PATCH has printed reset to zero before start of deck, or on page eject NQUSED number of lines used on current page NQLLBL 0/1 last line printed (is not / is) a blank line NQINIT not zero whilst initializing, set to zero as soon as the ouput print file is established +KEEP, xMQCL. NAME parameters to be packed for MQLIFT NQLST status-word adr of the bank NQLNA name-word adr of the bank NQID the 4 char. bank name in Hollerith NQTY the bank-type id, < 64 different types of banks NQLI 0/1 the bank is no/yes supporting line-slots NQNL total number of links, < 64 NQNS number of structural links, < 64 NQND number of data words, < 2048 +KEEP, xMQCN. Unpacked NAME parameters IQLST status-word adr of the bank IQLNA name-word adr of the bank IQID the 4 char. bank name in Hollerith IQTY the bank-type id, < 64 different types of banks IQLI 0/1 the bank is no/yes supporting line-slots IQNL total number of links, < 64 IQNS number of structural links, < 64 IQND number of data words, < 2048 IQLNX next-word adr, = IQLST + IQND + 1 IQFOUL = 0 bank is fine, != 0 bank chaining clobbered +KEEP, xMQCT. Memory table parameters LQTA LQTB LQTE LQMTB LQMTE LQMTH JQDIVG NQRESV(3) IQPART NQFREE(3) +KEEP, xMQCM. Memory occupation parameters NQSYSS number of permanent structural links NQLINK number of reference links LQCSTA(3) start adr of control divisions 1, 2, 3 LQCEND(3) end adr of ... NQMAX size of the control store LQ, without MLIAD LQLSTA(5) start adr in MLIAD of text division 1, 2, ... 5 LQLEND(5) end adr in ... LQADR = LOCF(LQ(1) LQADR0 = LQADR - 1 NQOFFS = LOCF(MLIAD(1)) - LOCF(LQ(1)) +KEEP, xQSYSBITS. Hydra system bits (IQDROP=31, KMDROP=1073741824) the drop bit +KEEP, xQ. Dynamic store, full text PARAMETER: NEWLN = 10 normally, = ICHAR(the newline character) NCHNEWL= 0/1 no/yes the newline is present in the TEXT store PARAMETER: NSIZEQ = like 100000 capacity words of store NSIZELN= like 100000 line slots NSIZETX= like 40*NSIZELN text store DIMENSION MLIAD(NSIZELN) the line-slot array CHARACTER TEXT(NSIZETX)*1 the text store DIMENSION LQ(NSIZEQ) the control store DIMENSION IQ(NSIZEQ) EQUIVALENCE (LQ, IQ, LQGARB) EQUIVALENCE (MLIAD(1), LQ(NSIZEQ)) EQUIVALENCE (TEXT(1), MLIAD(NSIZELN)) IQUEST(100) very temporary work area LQGARB d/s of banks to be garbage collected LQHOLD the current HOLD bank LQARRV d/s of ARRV banks LQKEEP d/s of global sequence definitions (KEEP banks) LQPREP d/s of PREP banks for the current deck +PATCH, DOCUMENT, T=DATA. Technical details +DECK, DU_STORE_TEXT. Patchy Version 5 27 July 93 .Text storage ------------- All lines from cradles and Pam files go into the TEXT store: CHARACTER TEXT(sizeTX)*1 The start position of each line is recorded in the line-address vector: DIMENSION MLIAD(sizeLN) Thus for the line in slot JSL the first and the last characters are: TEXT(JTXA) with JTXA = MLIAD(JSL) TEXT(JTXL) with JTXL = MLIAD(JSL+1) - 1 This implies that line storage within one division must be dense; no holes are allowed between lines. It also implies that the end+1 address of the last line in a division must be recorded in MLIAD. On machines under Unix complete Pam files are transfered into TEXT with one single 'read' system-call, and many lines are transfered from TEXT to the ASM file with a single 'write'. Therefore the 'newline' characters terminating each line are and have to be present in TEXT. On these machines the last true character of the line is in fact TEXT(JTXL-1), or more generally TEXT(JTXL-NCHNEWL), with the common parameter NCHNEWL being 0 or 1 depending on the machine. Similarly, +USE, QNEWLINE. selects the program version with newlines in the store. Since TEXT is a *1 array, handling of lines is not completely straightforward, access funtions GETLN and PUTLN are provided, and in time-critical parts of the program POINTER is used on those machines which have it. The MLIAD / TEXT store is divided into 5 divisions: | div 1 --> | div 2 -> | div 3 -> | <- div 4 | div 5 -> | | | | | | | | | | | | | | | | saved | PAM file | volatile | | perman. | naming | | foreign | being | made-up | | made-up | stack | | material | processed | material | | material | | |___________|___________|__________|____|___________|__________| | | | | | | | |LQLSTA(1) |LQLSTA(2) |LQLSTA(3) | |LQLSTA(4) |LQLSTA(5) | |LQLEND(1) |LQLEND(2) |LQLEND(3) |LQLEND(4) | LQLEND(5) Division 2 contains the PAM file (or cradle) currently being processed, either complete or by instalments. Division 1 contains the (foreign) material to be retained beyond the current PAM file, which is accumulated by a left squeeze of the material to be retained from division 2 just before reading the next PAM file (or the next instalment). Division 3 contains volatile constructed material, ie. material needed in the current deck which is not texto on the PAM file; this division is wiped clean for each new deck. Division 4 contains permanent foreign material which is not texto on the Pam file. Division 5 is the naming stack. The start and the end+1 addresses of the material in text division j is recorded in LQLSTA(j) and LQLEND(j), for example: slot JSL = LQLSTA(2) is the first line in division 2 slot JSL = LQLEND(2) -1 is the last line in division 2 For text division 5 this is slightly different in that LQLEND(5) is not the end of the occupied but of the available slots. +DECK, DU_STORE_CONTROL. Patchy Version 5 27 July 93 .Storage of the controls ----------------------- The significance of the information in TEXT is recorded as control-information in banks put into the control-store: DIMENSION LQ(sizeQ), IQ(sizeQ) EQUIVALENCE (LQ,IQ) This is a dynamic store managed by a tailored version of Hydra. It contains logical data-structures, and it is physically divided into 3 parts: | "wk. space" | division 1 --> | | div. 2 --> <-- div. 3 | | | | | | | | | | | | | | | | | saved | | mapping | | global | | links | data | material | | PREP | | material | | | collectable | | structure | | permanent | |_______________|_________________|__|_____________|__|______________| | | | | | | | | |LQCSTA(1) | |LQCSTA(2) | |LQCSTA(3) | |LQCEND(1) |LQCEND(2) | LQCEND(3)| The Hydra "working space", which is in fact fixed, has the link area with the links pointing into the data structures, and the data area with some control parameters. Division 1 contains the control-banks for patch/deck directed information which will be given up when used; garbage collection can operate only in division 1. Division 3 contains global information which has to stay in memory until the end of the run, but only banks without text pointers. Division 2 contains the temporary linear PREP structure into which the material of the current deck is mapped for processing. This division 2 is wiped clean without garbage collection for each deck. The start and the end+1 addresses of the material in division j is recorded in LQCSTA(j) and LQCEND(j) for the Hydra store LQ. +DECK, DU_BANKF, T=JOIN. Patchy Version 5 27 July 93 .Patchy-HYDRA bank format ------------------------- The Hydra bank format has been changed to match the Patchy requirements. On the one hand all banks in Patchy are quite small, so we can save bits, on the other hand we need relocatable line-slot numbers. The bank at L contains the following words: LQ(L-NL-1) 'name' word, with controls like NL, NS, ND LQ(L-NL) link NL ... reference links (if any) LQ(L-NS) link NS ... structural links (if any) LQ(L-2) link 2 LQ(L-1) link 1 'next' link IQ(L) status word, bits 27-32 contain NL again IQ(L+1) data word 1 ... IQ(L+ND) data word ND The 'name' word contains the bank parameters packed: bits 1-6 6 bits: TY bank type, up to 63 different kinds of banks 7-7 1 bit: LI bank with line-slot number, =1 if yes 8-13 6 bits: NL total number of links, 0 < NL < 64 14-19 6 bits: NS number of structural links, 0 < NS < 64 20-30 11 bits: ND number of data words, ND < 2048 31 1 bit: bank is dead if =1 32 1 bit: always zero The routine QLUMP constructs the name word from its components given in /MQCL/; the routines QBLOW and QNAME unpack the name word into /MQCN/ taking either the name-word or the status-word address. Comments 1) The Patchy modification of Hydra saves one word of overhead by not having the Hollerith ID of the bank, and 10 bits overhead in the status word by reduceing the system bits. NS is not present, but NL is instead, the limits on the sizes of NL,NS,ND are much reduced. The drop bit is moved from the status word to the name word. 2) To access the name word from the status word LST one could do LNA = LST - ISHFTR(IQ(LST),26) but calling QNAME is simpler and gives all information unpacked. 3) All banks which may be dropped must have the next-link; banks to be dropped are shunted into the garbage data-structure supported by LQGARB, they must not be dropped by simply setting the drop bit. This limitation is imposed by the algorithm for garbage collection in the MLIAD and TEXT stores. 4) A bank which points to material in TEXT must do so only with its data-word number 1 giving the line-slot number of the first line, data-word 2 must specify the number of lines. This is some kind of a link into TEXT, going via MLIAD; moreover this is a structural link in the sense that the material in TEXT and the associated slots in MLIAD are also collected if garbage collection removes the bank. Thus the relocation process has to update not only the normal Hydra links, but also the line-slot numbers. A bank so pointing to TEXT must have the LI flag in the name-word set to 1. +DECK, DU_RELOC, T=JOIN. Patchy Version 5 27 July 93 .Patchy-HYDRA link relocation table ----------------------------------- Garbage collection proper operates only for division 1, division 3 has permanent material only, division 2 is only wiped. The table starts in LQ(LQTA), its last word is LQ(LQTE+2). Each entry of 3 words represents one group of live banks, giving the start and the end+1 adr of the group, as well as its relocation constant. The first entry at LQTA marks the non-moving material, the next entry at LQTB=LQTA+3 marks the first moving group. LQTA+0 start adr of non-moving group 1 end+1 adr 2 (not used) LQTB+0 start adr of group 2: first moving 1 end+1 adr 2 relocation constant LQTB+3j+0 start adr of group j+2 1 end+1 adr 2 relocation constant LQTE-3+0 start adr of last moving group 1 end+1 adr 2 relocation constant LQTE+0 start adr of the non-moving high banks 1 (not used) 2 relocation constant for LQCEND(1) Cases: 1) the first bank is dead: LQ(LQTA+1) = LQ(LQTA) 2) no moving group, i.e. all dead banks are together at the end: LQTE = LQTA +3 .Patchy-HYDRA line-slot relocation table ---------------------------------------- Line-slot 1 is permanent, it belongs to nobody. LQTA+0 start adr of non-moving group 1 end+1 adr 2 (not used) LQTB+0 start adr of group 2: first moving 1 end+1 adr 2 relocation constant LQTB+3j+0 start adr of group j+2 1 end+1 adr 2 relocation constant LQTE-3+0 start adr of last moving group 1 end+1 adr 2 relocation constant LQTE+0 start adr of the non-moving high group 1 (not used) 2 relocation constant for LQLEND(1) Cases: 1) the first available line-slot is dead: LQ(LQTA) = 1 LQ(LQTA+1) = 2 2) no moving group, i.e. all dead slots are together at the end: LQTE = LQTA +3 +DECK, DU_MAINDS. Patchy version 5 Patchy's main data-structure: PATch /DECK /KEEP ------------------------------------------------ LEXP LQPAST KQMAIN LLPAST KQPAST | | | _|_______ ________ _|____ _|______ | | | \ | | | \ | PAT | | PAT \ | PAT | | PAT \ | present | --> | future / --> | link | --> | past / |_________| |________/ |______| |_________/ | | | | | R4-------> PAT USEd from | | __________________________ | | | \ | S3------> | KEEP patch-directed seqs \ | |___________________________/ | | | | | R3 ---> ORG p/d origin | S2 -----> MAT associated material S2 | _|________ | \ | DECK \ |___________/ | | | | | R4------> back pointer to supporting PAT | | _________________________ | | | \ | S3------> | KEEP deck-directed seqs \ | |__________________________/ | | | | | R3 ---> ORG p/d origin | S2 -----> MAT associated material | | ____________________________ | | \ S2--> | ACT actions into this deck \ |_____________________________/ __________________________ | \ LQKEEP ------> | KEEP global sequences \ KQKEEP |___________________________/ | | | R3 ---> ORG p/d origin S2 -----> MAT associated material The linear structure of PAT banks is a concatenation of these separate parts: 1) it starts with the PAT bank for the patch currently being processed; its adr is LEXP and its k-adr is KQMAIN, ie. LEXP is LQ(KQMAIN). 2) this first bank points with link 1 to the linear structure of PAT banks for the patches which have been addressed in some way, but which have not yet been processed; its last bank is a linking pseudo PAT bank, adr LLPAST, whose only purpose is to connect to the linear structure of "past" PAT banks. 3) the linear structure of PAT banks for the patches which have been processed, supported by the link LQPAST, whose k-adr is KQPAST. When the processing of the current patch is finished its PAT bank is shunted from LEXP to LQPAST, thus the order is time-reversed until QTOPSY is used in PEND to put it right. If a scan through the PAT structure is to look only at the "future" banks the program sets LQ(LLPAST-1)=0, for example when starting to process the next patch. If a scan has to go over all banks, past and future, it sets LQ(LLPAST-1)=LQPAST, for example for IF evaluation. +DECK, DU_NAMEH, T=JOIN. Patchy Version 5 26 July 93 The Name Handler ---------------- .Purpose -------- Because Patch/deck/seq etc identifiers no longer fit into 2 words it would be wasteful to reserve several words for the identifier in every Patch/Deck/Keep etc bank. Instead we accumulate a table of all names occurring during the run, and we store the index to the name in the table into 1 word in the bank which needs to hold the identifier. Having this facility we use it also to store text strings other than Patch/Deck/Seq names. .Storage -------- The name table resides in text division 5, starting at LQLSTA(5), ending on LQLEND(5). A given name is identified by its "name index" IXNAME; internal to the name handler the name is accessed as follows: slot: JSL = LQLSTA(5) + IXNAME start: JTXA = MLIAD(JSL) end: JTXE = MLIAD(JSL+1) - 1 Thus IXNAME is in fact the ordinal number of the name in the table, the first name has IXNAME = 0. Code outside the name handler sees only the name index IXNAME, so we can relocate this division. .Occupation control ------------------- Apart from LQLSTA(5) and LQLEND(5), the name table is governed by the following parameters: COMMON /NAMECO/ NA_OCC, NA_CUT, NA_MXSL, NA_MXTX NA_OCC the slot number of the last name in the table NA_CUT the significant length of a P/D/K name NA_MXSL the maximum number of name slots available NA_MXTX the maximum number of characters available for all names together, ie. the size of the text division The last 3 parameters are under user control with +NAME, ... which can only be given in the blank deck of P=CRA*. .Name interface routines ------------------------ CALL NA_INIT first initialization CALL NA_INPY add standard names for ypatchy CALL NA_REIN relocate if and when c/l +NAME,... has been read IXNAME = NA_NEW (LINE,JL,JR) register the name given in LINE(JL:JR-1), squeezing blanks; only the first NA_CUT characters are significant; return the name index, and in NDSLAT the length IXNAME = NA_LONG (LINE) register the long text LINE like NA_NEW but without cutting the string and without squeezing, trailing blanks ignored IXNAME = NA_CHK (LINE,JL,JR) check existence of the name given in LINE(JL:JR-1); only the first NA_CUT characters are significant; return the name index in IXNAME, or IXNAME = -1 if not existing +SELF, NEWPG. CALL NA_GET (IXNAME, LINE, JCOL) get the name this copies the text of the name IXNAME into LINE starting at column JCOL, but not beyond the passed length of LINE; it returns: NDSLAT = N, the length of the text stored NESLAT = JE = JCOL + N, the first col. after NFSLAT the length of the text in the stack JTX = NA_JTX (IXNAME) returns the adr of the first char. of the name to allow direct analysis of the string without copying; JTX must not be remembered beyond the local code using it. The length of the string is returned in NDSLAT. JWAY = NA_DIF (IXNA,IXNB) lexically compare the names at IXNA and IXNB for sorting, return zero if NAMEA = NAMEB -1 if NAMEA < NAMEB +1 if NAMEA > NAMEB CALL NA_FULL error exit to be called if name-stack full CALL NA_PRIX (MSG,IXNAME) error-message printing for IXNAME CALL NA_DUMP dump the name stack, for debugging +PATCH, MAINPRGS, T=JOIN. dummy +PATCH, FLDIALG. Initial user dialog and file opening +KEEP, PAMPUBLIC, P=FLDIALG. CHARACTER MPUBLI*(*) PARAMETER (MPUBLI = '/cern/pro/src/car/') +KEEP, FLKRAC. PARAMETER (NSLINE=256, NSTXKR=192) CHARACTER IDPROG*8, LINECC*(NSLINE) CHARACTER CHTERM*4, TXKR*(NSTXKR), TXKEY*8, CHWORK*4 COMMON /FLKRAC/NLCUM, JLINC,NLINT, IXHOME, JFAULT,IFLLIT +, IDPROG, LINECC, CHTERM, TXKR,TXKEY, CHWORK +DECK, FLPARA, T=JOIN. SUBROUTINE FLPARA (NFILEP,NAMEIP,CHTXOP) C- called from the Main programs to aquire the file names C. started 14-oct-91 +CDE, SLATLN, SLATE, QCHAR, QSTATE, QUNIT. +CDE, CCPARA, LUNSLN. +CDE, FLINKC. +CDE, FLKRAC. +CDE, NCNAME. CHARACTER NAMEIN(14)*(NCNAME) CHARACTER KEYSTO(14)*8 CHARACTER COMD*256, CHSTRM*6 +CDE, QSH. +, MPROTE(1000) +, LUNUSE,LUNDES,LUNFLG, MUSE(200) +, NAMEIN, KEYSTO, COMD, CHSTRM C-------------- End CDE -------------------------------- CHARACTER CHTXOP*(*), NAMEIP(NFILEP)*(NCNAME) PARAMETER (NWSTOR=3) LOGICAL DIALOG, ALSO, READY +SELF, IF=QS_IBMVM. PARAMETER (NCOST=8, NCOEX=16) +SELF, IF=-QS_IBMVM. PARAMETER (NCOST=6, NCOEX=14) +SELF, IF=-PY_VS5. CHARACTER VIDQQ*(*) PARAMETER (VIDQQ = '@(#)' // +SEQ, QFTITLCH, N=36. +) +SELF, IF=PY_VS5. CHARACTER VIDQQ*(48) +SEQ, QFHEAD . DATA VIDQQ /'@(#)?>'/ +SELF. +SEQ, xLUNSLN, IF=DOC_INL. +SEQ, QEJECT. +SELF, IF=QMIBX. CALL ERRSET (212, 300, -1,1,1) +SELF. NFILE = NFILEP DO 12 J=1,NFILE NAMEIN(J) = NAMEIP(J) IXLUN(J) = 0 12 CONTINUE CALL CLEFT (VIDQQ,1,0) JEOP = LEN(CHTXOP) JA = ICNEXT (CHTXOP,1,JEOP) NPID = NDSLAT JA = NESLAT JAOP = ICNEXT (CHTXOP,JA,JEOP) IDPROG = CHTXOP(1:NPID) +SEQ, MAILME, T=PASS. Register usage at CERN COMD = IDPROG NCMD = NPID + 2 COMD(NCMD:NCMD) = CQAPO CALL CUTOL (COMD(1:8)) IF (COMD(1:8).NE.'nypatchy') IFLAUX= 1 CCKARD = ' ' READY = .FALSE. INIPRO = 0 IFHELP = 0 NOEJ = 0 NREAD = 0 C-- Get the home directory SLLINE = ' ' CALL GETENVF ('HOME', SLLINE(1:128)) N = NDSLAT IF (N.GT.0) THEN IF (SLLINE(N:N).NE.'/') THEN N = N + 1 SLLINE(N:N) = '/' ENDIF ENDIF IXHOME = NA_LONG (SLLINE(1:N+1)) C-- Is the user on-line ? Yes if IQOFFL = 0 DIALOG = IQOFFL.EQ.0 C-- No dialogue printing if .GO on program statement NARGS = IARGC() IF (NARGS.EQ.0) GO TO 17 IF (NARGS.GE.NFILE) GO TO 16 LINECC = ' ' JARG = NARGS CALL GETARG (JARG,LINECC) NLINT = LENOCC (LINECC) IF (NLINT.LT.3) GO TO 17 CHWORK = LINECC(NLINT-2:NLINT) IF (CHWORK(1:1).EQ.':') CHWORK(1:1)='.' CALL CUTOL (CHWORK) IF (CHWORK.NE.'.go ') GO TO 17 16 DIALOG = .FALSE. READY = .TRUE. 17 IF (DIALOG) THEN WRITE (IQTYPE,9001) IDPROG(1:NPID) IF (JAOP.LT.JEOP) WRITE (IQTYPE,9002) CHTXOP(JAOP:JEOP) WRITE (IQTYPE,9004) (NAMEIN(J)(9:NCOEX),J=1,NFILE) IF (NARGS.GT.0) THEN +SELF, IF=-QS_IBMVM. WRITE (IQTYPE,9006) (NAMEIN(J)(1:NCOST),J=1,NFILE) +SELF, IF=QS_IBMVM. N = MIN (7,NFILE) IF (N.EQ.NFILE) THEN WRITE (IQTYPE,9006) (NAMEIN(J)(1:NCOST),J=1,N) ELSE WRITE (IQTYPE,9007) (NAMEIN(J)(1:NCOST),J=1,N) ENDIF +SELF. ENDIF ENDIF +SELF, QFVERS . 9001 FORMAT (1X,A,' ? executing') 9001 FORMAT (1X,A,' executing') +SELF, IF=-QS_IBMVM. 9002 FORMAT (' Options : ',A) 9004 FORMAT (' Default ext. : ',12A) 9006 FORMAT (' Stream names : ',12A) +SELF, IF=QS_IBMVM. 9002 FORMAT (' Options : ',A) 9004 FORMAT (' Default ext. : ',7A,:/40X,4A) 9006 FORMAT (' Stream names : ',12A) 9007 FORMAT (' Stream names : ',7A,' ...') +SELF. +SEQ, QEJECT. C-------- Aquire the program parameters CHTERM = ' ' NLCUM = 0 IQRFD = 0 JUREAD = 0 JUPRNT = 0 NFILEX = 0 JFILE = 1 JUSE = 1 C---- Take parameters from the command line JARG = 1 31 IF (NLCUM.GT.0) THEN COMD(NCMD+1:NCMD+NLCUM) = LINECC(1:NLCUM) CALL CSQMBL (COMD,1,NCMD+NLCUM) NCMD = NDSLAT + 1 NLCUM = 0 ENDIF LINECC = ' ' IF (JARG.GT.NARGS) GO TO 34 CALL GETARG (JARG,LINECC) NLINT = LENOCC (LINECC) JARG = JARG + 1 GO TO 38 C---- Take parameters from next input line 34 IF (DIALOG) THEN +SELF, IF=-QS_IBMVM. WRITE (IQTYPE,9006) (NAMEIN(J)(1:NCOST),J=JFILE,NFILE) +SELF, IF=QS_IBMVM. N = MIN (JFILE+6,NFILE) IF (N.EQ.NFILE) THEN WRITE (IQTYPE,9006) (NAMEIN(J)(1:NCOST),J=JFILE,N) ELSE WRITE (IQTYPE,9007) (NAMEIN(J)(1:NCOST),J=JFILE,N) ENDIF +SELF. IF (INIPRO.EQ.0) CALL TMINIT (INIPRO) CALL TMPRO (' ny> ') ENDIF CALL TMREAD (NSLINE, LINECC, NLINT, ISTAT) NREAD = NREAD + 1 IF (ISTAT.NE.0) GO TO 91 38 IF (NLINT.EQ.0) GO TO 31 JLINC = 0 IF (JFILE.GT.NFILE) GO TO 72 C---- Next parameter 41 IF (JLINC.GT.NLINT) GO TO 31 CHSTRM = NAMEIN(JFILE)(1:6) CHLIEX = NAMEIN(JFILE)(9:16) LUNUSE = ICDECI (NAMEIN(JFILE),18,19) LUNDES = ICDECI (NAMEIN(JFILE),22,23) LUNFLG = ICDECI (NAMEIN(JFILE),26,27) IFLSCR = 0 IF (CHLIEX.EQ.'.scr ') IFLSCR = 7 CALL FLKRAK (0,LUNDES) IF (JFAULT.NE.0) THEN WRITE (IQTYPE,9042) JFILE GO TO 49 ENDIF 9042 FORMAT (' Faulty parameter',I3) IF (TXKEY(1:4).EQ.' ') GO TO 31 IF (TXKEY(1:8).EQ.'help ') THEN CALL HELPPR GO TO 31 ENDIF IF (LUNUSE.GE.5) GO TO 61 GO TO (43,51,55,57), LUNUSE +SEQ, QEJECT. C-- Reader input 43 IF (IFHELP.NE.0) GO TO 64 IF (TXKEY(1:4).EQ.'- ') GO TO 44 IF (TXKEY(1:4).NE.'tty ') GO TO 45 44 TXKEY = '- ' TXKR(1:8) = 'tty ' IF (IQOFFL.EQ.0) THEN IF (INIPRO.EQ.0) CALL TMINIT (INIPRO) ENDIF IQREAD = IQTTIN LUNUSE = IQTTIN JUREAD = JUSE GO TO 64 45 LUNUSE = IQREAD IQRTTY = 0 IF (TXKEY(1:4).EQ.'eof ') GO TO 47 JUREAD = JUSE GO TO 64 47 IF (LUNFLG.EQ.0) GO TO 48 IQREAD = 0 LUNUSE = 0 GO TO 64 48 WRITE (IQTYPE,9048) IDPROG(1:NPID) 9048 FORMAT (' ***!!! EOF not allowed with ',A) 49 IF (IQOFFL.NE.0) CALL EXITRC (2) DIALOG = .TRUE. JARG = NARGS + 1 GO TO 31 C-- Printer output 51 IF (TXKEY(1:4).EQ.'- ') GO TO 52 IF (TXKEY(1:4).NE.'tty ') GO TO 54 52 TXKEY = '- ' TXKR(1:8) = 'tty ' IQPRNT = IQTYPE LUNUSE = IQTYPE GO TO 64 54 JUPRNT = JUSE JFPRNT = JFILE LUNUSE = IQPRNT GO TO 64 C-- Option string 55 IF (IXFLUN.EQ.0) GO TO 57 CALL NA_GET (IXFLUN, SLLINE,1) NOEJ = INDEX (SLLINE(1:NDSLAT),'+') IFHELP = INDEX (SLLINE(1:NDSLAT),'H') IF (IFHELP.EQ.0) GO TO 57 CHTERM = '.go' IQREAD = 0 JLINC = 1 READY = .TRUE. C-- CCH - string 57 LUNUSE = 0 GO TO 64 +SEQ, QEJECT. C-- Normal streams 61 CONTINUE C-- set scratch file IF (IFLSCR.NE.0) TXKR = '-temp.scr' C-- Store usage for final processing 64 NLCUM = JLINC NTXT = LENOCC (TXKR) IXLUN(JFILE) = IXFLUN KEYSTO(JFILE) = TXKR(1:8) CALL UCOPY (LUNUSE,MUSE(JUSE),NWSTOR) JUSE = JUSE + NWSTOR IF (.NOT.DIALOG) GO TO 68 IF (LUNUSE.EQ.0) THEN WRITE (IQTYPE,9085) CHSTRM,TXKR(1:NTXT) ELSE WRITE (IQTYPE,9087) JFILE,CHSTRM,TXKR(1:NTXT) ENDIF 68 JFILE = JFILE + 1 IF (TXKEY(5:8).NE.' ...') NFILEX = JFILE IF (JFILE.LE.NFILE) GO TO 41 C---- Start execution ? IF (READY) GO TO 83 IF (NLCUM.GT.0) THEN COMD(NCMD+1:NCMD+NLCUM) = LINECC(1:NLCUM) CALL CSQMBL (COMD,1,NCMD+NLCUM) NCMD = NDSLAT + 1 NLCUM = 0 ENDIF IF (CHTERM.NE.' ') GO TO 73 IF (JARG.LE.NARGS) THEN IF (JLINC.GE.NLINT) GO TO 31 ENDIF 72 CALL FLKRAK (-1,11) 73 COMD(NCMD+1:NCMD+4) = '.go' // CQAPO NCMD = NCMD + 4 IF (IQOFFL.EQ.0) WRITE (IQTYPE,9073) COMD(1:NCMD) 9073 FORMAT (/'. ',A/) IF (CHTERM(2:3).EQ.'go') GO TO 83 CHTERM = ' ' IF (INIPRO.EQ.0) CALL TMINIT (INIPRO) CALL TMPRO (' Type GO or stop ny> ') CALL TMREAD (4, CHTERM, NCH, ISTAT) IF (ISTAT.NE.0) GO TO 91 NREAD = NREAD + 1 CALL CUTOL (CHTERM) IF (CHTERM.EQ.'.go ') GO TO 83 IF (CHTERM.NE.'go ') STOP +SEQ, QEJECT. C-------- Final processing, OPEN standard input/output 83 IF (JUPRNT.NE.0) THEN CALL UCOPY (MUSE(JUPRNT),LUNUSE,NWSTOR) CALL FLINK (LUNUSE, 4, IXLUN(JFPRNT), 0) ENDIF ALSO = .NOT.DIALOG IF (IQTYPE.EQ.IQPRNT) THEN ALSO = .FALSE. NOEJ = 7 ENDIF IF (NOEJ.EQ.0) THEN WRITE (IQPRNT,9083) IDPROG(1:NPID) ELSE WRITE (IQPRNT,9084) IDPROG(1:NPID) ENDIF NQUSED = 3 IF (ALSO) WRITE (IQTYPE,9084) IDPROG(1:NPID) IF (NFILEX.EQ.NFILE) NFILEX = NFILE + 1 JUSE = 1 JFILE = 1 84 CALL UCOPY (MUSE(JUSE),LUNUSE,NWSTOR) CHLIFI = ' ' IXFLUN = IXLUN(JFILE) IF (IXFLUN.NE.0) THEN CALL NA_GET (IXFLUN, CHLIFI, 1) NLIFI = NDSLAT ELSE CHLIFI(1:8) = KEYSTO(JFILE) NLIFI = 8 IF (JFILE.NE.NFILEX) THEN IF (CHLIFI(5:8).EQ.' ...') NLIFI = 4 ENDIF NLIFI = LNBLNK(CHLIFI(1:NLIFI)) ENDIF CHSTRM = NAMEIN(JFILE)(1:8) NQUSED = NQUSED + 1 IF (LUNUSE.EQ.0) THEN WRITE (IQPRNT,9085) CHSTRM,CHLIFI(1:NLIFI) IF (ALSO) WRITE (IQTYPE,9085) CHSTRM,CHLIFI(1:NLIFI) GO TO 89 ENDIF WRITE (IQPRNT,9087) JFILE,CHSTRM,CHLIFI(1:NLIFI) IF (ALSO) WRITE (IQTYPE,9087) JFILE,CHSTRM,CHLIFI(1:NLIFI) C-- handle the cradle input stream IF (JUSE.NE.JUREAD) GO TO 89 +SELF, IF=XDEBUG, IF=XFLPARA, IF=QFIO. PRINT *, ' LUNUSE=',LUNUSE,' IQTTIN=',IQTTIN,' IQREAD=',IQREAD, + ' IQOFFL=',IQOFFL,' IQRTTY=',IQRTTY +SELF. IF (LUNUSE.NE.IQTTIN) GO TO 87 +SELF, IF=QCIO. C-- get the size of the here-document IF (IQOFFL.EQ.0) GO TO 89 CALL CITELL (IQRFD,JPOS,ISTAT) IF (ISTAT.NE.0) GO TO 89 CALL CISIZE (IQRFD,IQRSIZ,ISTAT) CALL CIREW (IQRFD) IQRRD = NREAD +SELF. GO TO 89 C-- open the file for stdin, if given 87 CALL FLINK (LUNUSE, 1, 0, LUNFLG) IF (IXFLUN.LT.0) THEN IQREAD = 0 ELSE IQRFD = LUNFD IQRSIZ = LUNSIZ ENDIF 89 IF (JFILE.EQ.NFILEX) JFILE=NFILE JUSE = JUSE + NWSTOR JFILE = JFILE + 1 IF (JFILE.LE.NFILE) GO TO 84 IF (ALSO) WRITE (IQTYPE,9089) CHTERM = ' ' WRITE (IQPRNT,9099) CQDATEM(3:),CQTIME NQUSED = NQUSED + 3 NQLLBL = 1 NQINIT = 0 +SELF, IF=XDEBUG. PRINT *, ' IQREAD=',IQREAD, ' IQTTIN=',IQTTIN, ' IQTYPE=',IQTYPE, + ' IQOFFL=',IQOFFL PRINT *, ' IQRTTY=',IQRTTY, ' IQRSAV=',IQRSAV PRINT *, ' IQRFD =',IQRFD, ' NREAD =',NREAD, ' IQRSIZ=',IQRSIZ +SELF. RETURN 91 CALL P_KILLM ('FLPARA - Trouble reading stdin') 9083 FORMAT (1H1,A,' executing with files / options'/) 9084 FORMAT (/1X,A,' executing with files / options'/) 9085 FORMAT (6X,A,3X,A) 9087 FORMAT (I4,2X,A,3X,A) 9089 FORMAT (1X) 9099 FORMAT (/' Version: ', +SEQ, QFTITLCH, N=38. F,'.RJP, today: ',A,1X,A +SELF, IF=QFIO, IF=QS_UNIX. F/' Operating with Fortran I/O' +SELF. F/) END +SEQ, QCARDL. ===================================================== +DECK, FLFIX, T=JOIN, IF=QS_IBMVM. SUBROUTINE FLFIX C- IBM: change "fn ft fm" into "fn.ft.fm" on +PAM or +ASM LINES C. started 26-oct-94 +CDE, SLATE, CCPARA. C-------------- End CDE -------------------------------- JG = ICNEXT (CCKARD,NCHCCD+1,NCHCCT) JE = NESLAT IF (JE.GE.NCHCCT) RETURN IF (INDEX(CCKARD(JG:JE),'.') .NE.0) RETURN CCKARD(JE:JE) = '.' JA = ICNEXT (CCKARD,JE+1,NCHCCT) JE = NESLAT IF (JE.GE.NCHCCT) GO TO 27 CCKARD(JE:JE) = '.' JA = ICNEXT (CCKARD,JE+1,NCHCCT) JE = NESLAT 27 CALL CLEFT (CCKARD,JG,JE-1) NCHCCT = NESLAT -1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, FLKRAK. SUBROUTINE FLKRAK (IPARA,LUNDES) C- Krack next parameter C- IPARA -ve : see whether .GO present C- 0 : called from FLPARA C- +ve : called from the running program C- LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C. started 14-oct-91 +CDE, SLATLN, SLATE, QUNIT. +CDE, CCPARA, FLINKC, FLKRAC. C-------------- End CDE -------------------------------- CHARACTER TXDO*(NSTXKR) CHARACTER COLCC(NSLINE)*1, COLDO(NSTXKR)*1 EQUIVALENCE (COLCC,LINECC), (COLDO,TXDO) +SEQ, PAMPUBLIC. TXKR = ' ' JFAULT = 0 IXFLUN = 0 MODEFI = LUNDES C-- Entry from running program IF (IPARA.LE.0) GO TO 21 +SELF, IF=QS_IBMVM. CALL FLFIX +SELF. LINECC = CCKARD JLINC = NCHCCD NLINT = NCHCCT IF (MODEFI.EQ.1) THEN CHLIEX = '.cra' ELSEIF (MODEFI.EQ.2) THEN CHLIEX = '.car' ENDIF GO TO 22 C-- Entry from FLPARA 21 IF (CHTERM.NE.' ') GO TO 39 NLCUM = JLINC C-- No more parameters 22 JLINC = ICNEXT (LINECC,JLINC+1,NLINT) IF (JLINC.GT.NLINT) GO TO 77 C---- Do parameter substitution JENDU = NESLAT NCHU = NDSLAT CALL CENVIR (LINECC(JLINC:),NCHU, TXDO,1,NSTXKR, 1) NCHU = NDSLAT IF (NFSLAT.NE.0) GO TO 91 TXDO(NCHU+1:NCHU+4) = ' ' C---- '-' for Skip next parameter IF (COLDO(1).NE.'-') GO TO 35 TXKR(1:1) = COLDO(1) IF (MODEFI.NE.12) GO TO 77 IF (COLDO(2).EQ.'-') GO TO 77 IF (COLDO(2).EQ.' ') GO TO 77 GO TO 41 +SEQ, QEJECT. C---- Skip Remaining parameters for ". ", ".go", ": ", ":go" C-- (but not "../name" or ":name") C-- exit for ".no" +SELF, IF=BACKCOMP. 35 IF (COLDO(1).NE.'.') THEN IF (COLDO(1).NE.':') GO TO 41 ENDIF +SELF, IF=-BACKCOMP. 35 IF (COLDO(1).NE.'.') GO TO 41 +SELF. CHWORK = TXDO(2:5) CALL CUTOL (CHWORK) IF (CHWORK.EQ.'go ') GO TO 38 IF (CHWORK.EQ.'no ') STOP IF (COLDO(2).NE.' ') GO TO 41 CHWORK = ' ' 38 CHTERM = '.' // CHWORK(1:3) JLINC = NLCUM 39 TXKR(1:8) = '- ...' GO TO 77 C------ Check special parameters 41 IFLLIT = 0 IF (IPARA.EQ.-1) GO TO 77 TXKR(1:NCHU) = TXDO(1:NCHU) TXKEY = TXKR(1:8) CALL CUTOL (TXKEY) IF (NCHU.LE.4) THEN IF (TXKEY(1:5).EQ.'help ') GO TO 78 IF (TXKEY(1:5).EQ.'tty ') GO TO 78 IF (TXKEY(1:5).EQ.'eof ') GO TO 78 ENDIF C-- Handle literal option parameter opened by /: IF (MODEFI.LT.11) GO TO 42 IF (TXDO(1:2).EQ.'/:') THEN IF (NCHU.LT.3) THEN TXKR(1:4) = '- ' GO TO 76 ENDIF TXKR(1:NCHU) = TXDO(3:NCHU) // ' ' NCHU = NCHU - 2 ENDIF IF (MODEFI.EQ.11) CALL CLTOU (TXKR(1:NCHU)) NTXU = NCHU GO TO 69 C------ Analyse file name 42 JDO = 1 NTXU = 0 TXKR(1:NCHU) = ' ' +SELF, IF=BACKCOMP. C-- ignore prefix = : 43 IF (INDEX ('=:', COLDO(JDO)).NE.0) THEN JDO = JDO + 1 GO TO 43 ENDIF +SELF. C-- check prefix + IF (COLDO(JDO).EQ.'+') THEN TXKR(1:1) = COLDO(JDO) JDO = JDO + 1 NTXU = 1 ENDIF C-- check prefix /: IF (TXDO(JDO:JDO+1).EQ.'/:') THEN N = NCHU+1 - JDO IF (N.LE.2) GO TO 91 TXKR(NTXU+1:NTXU+N) = TXDO(JDO:JDO+N-1) NTXU = NTXU+ N IFLLIT = 1 GO TO 67 ENDIF NTXU = MAX (NTXU,1) C-- is the file PUBLIC ? IF (TXDO(JDO:JDO+1).EQ.'_/') THEN N = LEN (MPUBLI) TXKR(NTXU+1:NTXU+N) = MPUBLI NTXU = NTXU + N JDO = JDO + 2 GO TO 48 ENDIF C-- does the file name start with '~/' ? C! IF (TXDO(JDO:JDO+1).EQ.'~/') THEN C! IF (IXHOME.GT.0) THEN C! CALL NA_GET (IXHOME, TXKR, NTXU+1) C! NTXU = NESLAT - 1 C! JDO = JDO + 2 C! GO TO 48 C! ENDIF C! ENDIF C-- is the file-name of the old form (X)/fname ? +SELF, IF=BACKCOMP. IF (COLDO(JDO).NE.'(') GO TO 48 JE = ICFIND (')', TXDO,JDO+2,NCHU) IF (NGSLAT.EQ.0) GO TO 48 N = JE - JDO - 1 SLLINE(1:N+3) = '${' // TXDO(JDO+1:JDO+N) // '}' N = N + 3 CALL CENVIR (SLLINE,N, TXKR,NTXU+1,NSTXKR, 0) IF (NFSLAT.NE.0) GO TO 48 NTXU = NTXU + NDSLAT JDO = JE + 1 +SELF. C-- copy the tail 48 N = NCHU+1 - JDO IF (N.GT.0) THEN TXKR(NTXU+1:NTXU+N) = TXDO(JDO:JDO+N-1) NTXU = NTXU + N ENDIF +SELF, IF=QS_VMS. C-- convert VAX-style file name to Unix style NLIFI = NTXU - 1 CHLIFI = TXKR(2:NTXU) CALL FFRVAX (CHLIFI,NLIFI) IF (NDSLAT.GT.0) THEN TXKR(2:NLIFI+1) = CHLIFI(1:NLIFI) NTXU = NLIFI + 1 ELSEIF (NDSLAT.LT.0) THEN TXKR(2:NLIFI+3) = '/:' // CHLIFI(1:NLIFI) NTXU = NLIFI + 3 IFLLIT = 1 GO TO 67 ENDIF +SELF. C---- Look for Directory and Extension JFILN = 2 J = ICFILA ('/', TXKR,JFILN,NTXU) IF (NGSLAT.NE.0) THEN IF (J.EQ.NTXU) GO TO 66 JFILN = J + 1 ENDIF JEXT = ICFILA ('.', TXKR,JFILN,NTXU) LEXT = NTXU+1 - JEXT LFILN = JEXT - JFILN C-- do the File extension IF (LEXT.EQ.0) THEN N = LNBLNK (CHLIEX) IF (N.EQ.0) GO TO 66 IF (CHLIEX(1:1).NE.'.') THEN NTXU = NTXU + 1 TXKR(NTXU:NTXU) = '.' ENDIF TXKR(NTXU+1:NTXU+N) = CHLIEX(1:N) NTXU = NTXU + N ELSEIF (LEXT.EQ.1) THEN TXKR(NTXU:NTXU) = ' ' NTXU = NTXU - 1 ENDIF 66 CALL CLEFT (TXKR,2,NTXU) NTXU = NESLAT - 1 67 IF (NTXU.GE.NSLIFI-4) GO TO 91 NLIFI = NTXU CHLIFI = TXKR(1:NTXU) 69 IXFLUN = NA_LONG (TXKR(1:NTXU)) C---- Done 76 JLINC = JENDU 77 TXKEY = TXKR(1:8) RETURN 78 JLINC = JENDU RETURN C---- Trouble 91 JFAULT = 7 IF (IPARA.LE.0) THEN IF (IQOFFL.EQ.0) RETURN ENDIF WRITE (IQPRNT,9092) IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9092) 9092 FORMAT (/' ***!!! Faulty file name syntax !!!***') CALL EXITRC (2) RETURN END +SEQ, QCARDL. ===================================================== +DECK, FLINK. SUBROUTINE FLINK (LUNP, LUNDES, IXNAME, IFLMEX) C- Open file (for unit LUNP) C- LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- -1 delete the file, only C- C- IXNAME = -1 use file name pointed to by IXFLUN C- 0 use file name as is in CHLIFI C- >0 use file name pointed to by IXNAME C- C- IFLMEX = 2 the input file does not need to exist C- 0 OPEN failure is fatal C- C- set LUNFD and the file name into /FLINKC/ C. started 14-oct-91 +CDE, SLATE, QUNIT, FLINKC. C-------------- End CDE -------------------------------- EQUIVALENCE (LUN,LUNOP), (NN,NLIFI) DIMENSION INFO(40) EQUIVALENCE (INFO(1),NDSLAT) +SELF, IF=QS_UNIX. INTEGER STATF +SELF. C! LOGICAL ACCESSF CHARACTER UST*8 CHARACTER*(*) CSOLD, CSNEW, CSAPP, CSRWR CHARACTER*(*) YFM, APX PARAMETER (YFM='FORMATTED') PARAMETER (APX='APPEND') +SELF, IF=QMAPO. PARAMETER (CSOLD='READONLY') PARAMETER (CSNEW='NEW') PARAMETER (CSAPP='APPEND') PARAMETER (CSRWR='UNKNOWN') +SELF, IF=QMCRU. PARAMETER (CSOLD='OLD') PARAMETER (CSNEW='NEW') PARAMETER (CSAPP='OLD') PARAMETER (CSRWR='UNKNOWN') +SELF, IF=QF_IBM. PARAMETER (CSOLD='OLD') PARAMETER (CSNEW='UNKNOWN') PARAMETER (CSAPP='UNKNOWN') PARAMETER (CSRWR='UNKNOWN') +SELF, IF=QS_IBMVM. CHARACTER CHEXT*8, CHDIR*8, ALTERN(4)*8, IBMLINE*(NSLIFI) EQUIVALENCE (CHEXT, CHLIFI(11:18)), (CHDIR, CHLIFI(20:27)) DATA ALTERN / 'CAR', 'CRA', 'CARDS', 'CRADLE' / +SELF, IF=QF_DEC, QF_F2C. PARAMETER (CSOLD='OLD') PARAMETER (CSNEW='NEW') PARAMETER (CSAPP='UNKNOWN') PARAMETER (CSRWR='UNKNOWN') +SELF, IF=QMALT,QMCVX,QMHPX,QMIBX,QMIRT,QMSGI,QMSUN,QMUUX. PARAMETER (CSOLD='OLD') PARAMETER (CSNEW='NEW') PARAMETER (CSAPP='UNKNOWN') PARAMETER (CSRWR='UNKNOWN') +SELF. LOGICAL THERE LUN = LUNP LUNFD = LUN LUNSIZ = 0 MODEFI = LUNDES IF (MODEFI.LT.0) MODEFI= 99 CALL FLNAME (IXNAME,IFLAPP) IXFLUN = MAX (IXFLUN,0) +SELF, IF=-QS_UNIX. INQUIRE (FILE=CHLIFI(1:NN),EXIST=THERE) +SELF, IF=QS_UNIX. ISTAT = STATF (CHLIFI(1:NN),INFO) THERE = .FALSE. IF (ISTAT.EQ.0) THEN IF (INFO(7).NE.0) THERE = .TRUE. ENDIF +SELF. IF (THERE) THEN LUNOLD = 1 ELSE LUNOLD = 0 IFLAPP = 0 ENDIF IF (MODEFI.GE.4) GO TO 41 C----------- OPEN cradle / PAM file ------------ 21 IF (LUNOLD.EQ.0) GO TO 36 +SELF, IF=QCIO. CALL CIOPEN (LUNFD, 'r', CHLIFI(1:NN), ISTAT) IF (ISTAT.NE.0) GO TO 37 CALL CISIZE (LUNFD, LUNSIZ, ISTAT) IF (ISTAT.NE.0) LUNSIZ= 0 CALL CIREW (LUNFD) +SELF, IF=QFIO, IF=QMCVX. OPEN (LUN,FILE=CHLIFI(1:NN), STATUS=CSOLD,ERR=37,FORM=YFM, + READONLY) +SELF, IF=QFIO, IF=QS_IBMVM. CALL FILEINF (IRC, 'RECFM','U', 'BLKSIZE',512) +SELF, IF=QFIO, IF=QF_IBM. OPEN (LUN,FILE=CHLIFI(1:NN), STATUS=CSOLD,ERR=37, + ACTION='READ', FORM='UNFORMATTED') +SELF, IF=QFIO, IF=QMIBX. OPEN (LUN,FILE=CHLIFI(1:NN), STATUS=CSOLD,ERR=37,FORM=YFM, + ACTION='READ') +SELF, IF=QFIO, IF=QF_DEC. OPEN (LUN,FILE=CHLIFI(1:NN), STATUS=CSOLD,ERR=37,FORM=YFM, + RECL=512, READONLY) +SELF, IF=QFIO,IF=QMALT,QMAPO,QMCRU,QMHPX,QMIRT,QMSGI,QMSUN,QMUUX. OPEN (LUN,FILE=CHLIFI(1:NN), STATUS=CSOLD,ERR=37,FORM=YFM) +SELF. GO TO 99 C---- OPEN failure 36 CONTINUE +SELF, IF=QS_IBMVM. JA = ICNTH (CHEXT,ALTERN,2) IF (JA.EQ.0) GO TO 37 CHEXT = ALTERN(JA+2) INQUIRE (FILE=CHLIFI(1:NN),EXIST=THERE) IF (THERE) THEN LUNOLD = 1 GO TO 21 ENDIF WRITE (IQTYPE,9037) CHLIFI(1:NN) CHEXT = ALTERN(JA) +SELF. 37 IF (IFLMEX.EQ.2) THEN WRITE (IQTYPE,9037) CHLIFI(1:NN) GO TO 39 ENDIF 38 WRITE (IQTYPE,9038) CHLIFI(1:NN) +SELF, IF=QS_UNIX. IF (LUNOLD.NE.0) CALL PERRORF (' System msg') +SELF. IF (NQINIT.EQ.0) THEN IF (IQPRNT.NE.IQTYPE) WRITE (IQPRNT,9038) CHLIFI(1:NN) ENDIF 39 IXFLUN = -1 IF (IFLMEX.EQ.0) CALL P_KILLM ('OPEN failure') RETURN 9037 FORMAT (16X,'(file ',A,' does not exist)') 9038 FORMAT (/' ***!!! OPEN fails for file: ',A) +SEQ, QEJECT. C----------- OPEN output file ------------ C-- MODEFI = 4 printer, 5 Fortran, 6 ASM write, 7 ASM read-write 41 IF (MODEFI.EQ.7) THEN IF (LUNOLD.EQ.0) MODEFI= 6 +SELF, IF=-QS_IBMVM. ELSE IF (LUNOLD.NE.0) THEN IF (IFLAPP.EQ.0) CALL UNLINKF (CHLIFI(1:NN)) ENDIF +SELF. ENDIF IF (MODEFI.GE.99) GO TO 99 +SELF, IF=QCIO, QS_VMS. IF (MODEFI.EQ.7) GO TO 21 +SELF, IF=QCIO. IF (MODEFI.LE.5) GO TO 51 IF (MODEFI.EQ.7) THEN UST = 'r+' ELSEIF (IFLAPP.NE.0) THEN UST = 'a' ELSE UST = 'w' ENDIF CALL CIOPEN (LUNFD, UST(1:2), CHLIFI(1:NN), ISTAT) IF (ISTAT.NE.0) GO TO 37 IF (MODEFI.NE.7) GO TO 99 CALL CISIZE (LUNFD, LUNSIZ, ISTAT) IF (ISTAT.NE.0) LUNSIZ= 0 CALL CIREW (LUNFD) GO TO 99 +SELF. C---- Fortran OPEN for output file 51 IF (MODEFI.EQ.7) THEN UST = CSRWR ELSEIF (IFLAPP.NE.0) THEN UST = CSAPP ELSE UST = CSNEW ENDIF +SELF, IF=QMAPO. OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM) +SELF, IF=QMCRU. IF (IFLAPP.NE.0) THEN OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM +, POSITION=APX) ELSE OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM) ENDIF +SELF, IF=QS_IBMVM. IF (IFLAPP.NE.0) GO TO 53 CALL FILEINF (IRC, 'RECFM','U', 'BLKSIZE',512) OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM +, ACTION='WRITE') GO TO 99 C- _:.=+=.: 1_:.=+=.: 2_: 27 ch max 53 IBMLINE = 'FILEDEF FT00F001 DISK ' // CHLIFI(2:NN) + // ' (RECFM U BLKSIZE 512 DISP MOD' C- _:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_ CALL CSETDI (LUN,IBMLINE,11,12) CALL VMCMS (IBMLINE,IRC) IF (IRC.NE.0) GO TO 38 C! OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM C! +, ACTION='READWRITE') C! 54 READ (LUN,FMT='(A)',END=99) C! GO TO 54 GO TO 99 +SELF, IF=QMIRT. OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM) IF (IFLAPP.EQ.0) REWIND LUN +SELF, IF=QF_DEC. IF (IFLAPP.NE.0) THEN OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM +, RECL=512,ACCESS=APX) ELSE OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM +, RECL=512) ENDIF +SELF, IF=QF_F2C. IF (IFLAPP.NE.0) THEN OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM +, ACCESS=APX) ELSE OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM) ENDIF +SELF, IF=QMALT, QMCVX, QMHPX, QMSGI, QMSUN, QMUUX. IF (IFLAPP.NE.0) THEN OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM +, ACCESS=APX) ELSE OPEN (LUN,FILE=CHLIFI(1:NN),STATUS=UST,ERR=38,FORM=YFM) ENDIF +SELF. 99 RETURN END +SEQ, QCARDL. ===================================================== +DECK, FLNAME. SUBROUTINE FLNAME (IXNAME, IFLAPP) C- Ready the file name for use in OPEN or UNLINKF C- C- IXNAME = -1 use file name pointed to by IXFLUN C- 0 use file name as is in CHLIFI C- >0 use file name pointed to by IXNAME C- C- return IFLAPP = 0/1 if no/yes append mode C. started 16-dec-93 +CDE, SLATE, FLKRAC, FLINKC. C-------------- End CDE -------------------------------- IF (IXNAME.GE.0) IXFLUN= IXNAME IF (IXFLUN.GT.0) THEN CHLIFI = ' ' CALL NA_GET (IXFLUN, CHLIFI, 1) NLIFI = NDSLAT ENDIF IFLAG = 0 IF (CHLIFI(1:1).EQ.' ') GO TO 23 21 IF (CHLIFI(1:1).EQ.'=') GO TO 22 IF (CHLIFI(1:1).EQ.':') GO TO 22 IF (CHLIFI(1:2).EQ.'/:') GO TO 31 IF (CHLIFI(1:1).NE.'+') GO TO 41 IFLAG = 1 22 CHLIFI(1:1) = ' ' 23 CALL CLEFT (CHLIFI,1,NLIFI) NLIFI = NDSLAT GO TO 21 C-- file name as is 31 CHLIFI(1:2) = ' ' CALL CLEFT (CHLIFI,1,NLIFI) NLIFI = NDSLAT +SELF, IF=-QS_IBMVM GO TO 47 +SELF, IF=QS_IBMVM. 41 CALL FTOIBM (CHLIFI,NLIFI) +SELF, IF=QS_UNIX. 41 IF (CHLIFI(1:2).EQ.'~/') THEN CALL NA_GET (IXHOME, TXKR, 1) N = NDSLAT TXKR(N+1:N+NLIFI-2) = CHLIFI(3:NLIFI) NLIFI = N + NLIFI - 2 CHLIFI(1:NLIFI) = TXKR(1:NLIFI) ENDIF +SELF, IF=QS_VMS. 41 CALL FTOVAX (CHLIFI,NLIFI) +SELF. 47 IFLAPP = IFLAG RETURN END +SEQ, QCARDL. ===================================================== +DECK, FLSPLIT, IF=-QS_IBMVM. SUBROUTINE FLSPLIT (IXFILE,IXDIR,IXFN,IXEXT) C- Split the input file name dir/fn.ext into its parts, C- return dir/ fn .ext as names with index IXDIR, IXFN, IXEXT C. started 17-apr-95 +CDE, SLATE, FLINKC. C-------------- End CDE -------------------------------- CALL FLNAME (IXFILE,JFN) +SELF, IF=QS_VMS. CALL FFRVAX (CHLIFI,NLIFI) +SELF. JSLA = ICFILA ('/', CHLIFI,1,NLIFI) JFN = NGSLAT + 1 JDOT = ICFILA ('.', CHLIFI,JFN,NLIFI) IF (JDOT.LT.JFN) JDOT = NLIFI + 1 IXD = 0 IXF = 0 IXX = 0 IF (JFN.GE.3) IXD = NA_LONG (CHLIFI(1:JSLA)) IF (JFN.LT.JDOT) IXF = NA_LONG (CHLIFI(JFN:JDOT-1)) IF (JDOT.LT.NLIFI) IXX = NA_LONG (CHLIFI(JDOT:NLIFI)) IXDIR = IXD IXFN = IXF IXEXT = IXX RETURN END +SEQ, QCARDL. ===================================================== +DECK, FLJOIN, T=JOIN, IF=-QS_IBMVM. SUBROUTINE FLJOIN (IXDIR,IXFN,IXEXT,IXFILE) C- Compose a path name from the 3 parts, return its index C. started 17-may-95 +CDE, SLATE, SLATLN. C-------------- End CDE -------------------------------- N = 1 IF (IXDIR.NE.0) THEN CALL NA_GET (IXDIR, SLLINE,1) N = NESLAT ENDIF IF (IXFN.NE.0) THEN CALL NA_GET (IXFN, SLLINE,N) N = NESLAT ENDIF IF (IXEXT.NE.0) THEN CALL NA_GET (IXEXT, SLLINE,N) N = NESLAT ENDIF IXFILE = NA_LONG (SLLINE(1:N-1)) RETURN END +SEQ, QCARDL. ===================================================== +DECK, FLSPLIT_IBM, IF=QS_IBMVM. +SEQ, QCARD1, R=FLSPLIT. SUBROUTINE FLSPLIT (IXFILE,IXDIR,IXFN,IXEXT) C- Return the parts of the input file name '/fn ext dir' C. started 26-apr-95 +CDE, SLATE, FLINKC. C-------------- End CDE -------------------------------- CHARACTER NAME*12 CALL FLNAME (IXFILE,N) IXD = 0 IXF = 0 IXX = 0 JA = ICNEXT (CHLIFI,1,NLIFI) NE = NESLAT N = NDSLAT - 1 IF (N.LT.1) GO TO 49 IXF = NA_LONG (CHLIFI(JA+1:JA+N)) JA = ICNEXT (CHLIFI,NE,NLIFI) NE = NESLAT N = NDSLAT IF (N.LT.1) GO TO 49 NAME = '.' // CHLIFI(JA:JA+N-1) IXX = NA_LONG (NAME(1:N+1)) JA = ICNEXT (CHLIFI,NE,NLIFI) N = NDSLAT IF (N.LT.1) GO TO 49 NAME = CHLIFI(JA:JA+N-1) // '/' IXD = NA_LONG (NAME(1:N+1)) 49 IXDIR = IXD IXFN = IXF IXEXT = IXX RETURN END +SEQ, QCARDL. ===================================================== +DECK, FLJOIN_IBM, T=JOIN, IF=QS_IBMVM. +SEQ, QCARD1, R=FLJOIN. SUBROUTINE FLJOIN (IXDIR,IXFN,IXEXT,IXFILE) C- Compose a path name from the 3 parts, return its index C. started 17-may-95 +CDE, SLATE, SLATLN. C-------------- End CDE -------------------------------- N = 1 IF (IXDIR.NE.0) THEN CALL NA_GET (IXDIR, SLLINE,1) N = NESLAT ENDIF IF (IXFN.NE.0) THEN CALL NA_GET (IXFN, SLLINE,N) N = NESLAT ENDIF IF (IXEXT.NE.0) THEN CALL NA_GET (IXEXT, SLLINE,N) N = NESLAT ENDIF IXFILE = NA_LONG (SLLINE(1:N-1)) RETURN END +SEQ, QCARDL. ===================================================== +DECK, HELPPR. SUBROUTINE HELPPR C- Print file-name syntax +CDE, QUNIT. +SEQ, PAMPUBLIC. WRITE (IQTYPE,9001) WRITE (IQTYPE,9002) MPUBLI WRITE (IQTYPE,9003) RETURN 9001 FORMAT (/' To get program specific help you can give the H option' F/' in the calls to the Patchy Auxiliary programs.' F/' What follows concerns the parameter acquisition dialog.'/ F/' For each remaining stream give the File-name/Option-string as' F/' parameter value in order. You may give 1 or more parameters' F/' on a line; the machine will keep displaying the remaining' F/' streams until its list is satisfied. The answer to the final' F/' confirmation query is GO, or NO to kill the run.'/ F/' Parameters must be separated by 1 or more blanks,' F/' except: multiple "-" do not need imbedded blanks.' / F/' Special parameter values :' F/' - : this stream is not used / option string void,' F/' except READ or PRINT : assume "TTY"' F/' . or .go : use "-" for this and all remaining streams' F/' TTY : use standard input/output (only for READ+PRINT),' F/' EOF : void input (only for READ)' F/' HELP : as you guessed.' ) 9002 FORMAT (/' Normal parameters values:' F/' File name (case-sensitive for UNIX):' F/' DIR/FN.EXT path name; DIR/ or .EXT may be omitted,' F/' a default extension is added to the' F/' path name unless it contains a dot.' +SELF, IF=-QS_IBMVM. F/' /:NAME use NAME exactly as typed' +SELF. F/' +DIR/FN.EXT open output file for Append' F/' =DIR/FN.EXT the = is ignored for back-compatibility' F/' :DIR/FN.EXT the : is ignored for back-compatibility' +SELF, IF=-QS_IBMVM. F/' ~/DIR/FN.EXT = $HOME/DIR/FN.EXT relative to the home dir.' F/' ../DIR/FN.EXT relative to the current wk directory' F/' _/DIR/FN.EXT = ',A,'DIR/FN.EXT public files' +SELF, IF=BACKCOMP. F/' (X)/FN.EXT = ${X}/FN.EXT env.variable for back-compat.' +SELF. F/' LNAME. Link name, no default extension added,' F/' terminating dot removed') 9003 FORMAT ( +SELF, IF=QS_UNIX. F/' ${X} or $X occuring in a file name is replaced by the' +SELF, IF=-QS_UNIX. F/' ${X} occuring in a file name is replaced by the' +SELF. F/' contents of environment variable X'/ +SELF, IF=QS_IBMVM. F/' for IBM VM: give Unix-like file names, like:' F/' X/ZEBRA.FORTRAN to mean "ZEBRA FORTRAN X"' F/' but ZEBRA.FORTRAN.X is also accepted'/ +SELF, IF=QS_VMS. F/' on the VAX you may give Unix style file names:' F/' Unix: //node/log/dir/a/name.ext;v' F/' Vax: node::log:[dir.a]name.ext;v'/ F/' Unix: /log/dir/a/name.ext;v also: /(dir/nm.e;v' F/' Vax: log:[dir.a]name.ext;v [dir]nm.e;v'/ F/' forms like dir/name ../name ~/dir/name are also handled'/ F/' unless given as a literal with /: Patchy will convert VAX' F/' names to UNIX style, be careful with unusal file names.'/ +SELF. F/' Option string:' F/' OPT string of characters, maybe prefixed by /:' F/' each character selecting one option.'/) END +SEQ, QCARDL. ===================================================== +PATCH, RUN. Running Nypatchy +DECK, NPATCH. PROGRAM NPATCH +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=11) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'PAM .car 9 2 0 !ff' +, 'FORT .f 9 6 0 !ff' +, 'read .cra 1 1 0 !ff' +, 'print .lis 2 4 0 !ff' +, 'CC .c 9 6 0 !ff' +, 'AS .s 9 6 0 !ff' +, 'DATA .dat 9 6 0 !ff' +, 'FO:2 .f 9 6 0 !ff' +, 'CC:2 .c 9 6 0 !ff' +, 'AS:2 .s 9 6 0 !ff' +, 'DA:2 .dat 9 6 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist +SELF, IF=QMAPO. NAME(2)(9:12) = '.ftn' NAME(8)(9:12) = '.ftn' +SELF, IF=QS_IBMVM. for IBM VM NAME(2)(9:16) = '.fortran' NAME(4)(9:16) = '.listing' NAME(8)(9:16) = '.fortran' NAME(6)(9:16) = 'assemble' NAME(10)(9:16) = 'assemble' +SELF, IF=QS_VMS. for VAX + Alpha with VMS NAME(2)(9:12) = '.for' NAME(8)(9:12) = '.for' NAME(6)(9:12) = '.mar' NAME(10)(9:12) = '.mar' +SELF. CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nypatchy') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL PSTEER C! CALL NA_DUMP +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, PSTEER. SUBROUTINE PSTEER C- Running Patchy C. started 7-feb-92 +CDE, QSTATE, Q, PY. C-------------- End CDE -------------------------------- CALL PINIT (0) C-- Get the cradle into memory INCRAD = 3 CALL ARRIVE (0) C-- Complete the initialization CALL PINIT (1) C-- Do the cradle initially CALL DOCRAD IF (JANSW.NE.0) GO TO 89 C-- Do next PAM file 41 INCRAD = 0 CALL DOPAM C-- Do cradle continuation INCRAD = 2 CALL DOCRAD IF (JANSW.EQ.0) GO TO 41 89 IF (NQERR.NE.0) CALL PABEND CALL PEND RETURN END +SEQ, QCARDL. ===================================================== +DECK, PINIT. SUBROUTINE PINIT (JSTAGE) C- Initialize PATCHY C. started 10-feb-92 +CDE, QBANKS, QUNIT. +CDE, TITLEC, Q, PY. C-------------- End CDE -------------------------------- IF (JSTAGE.NE.0) GO TO 31 C-------- Start initialization before reading the cradle -------- CALL MQWORK (LACRAD,INCRAD,LASTWK) NFILET = 0 NVGAP(1) = 4000 NVGAP(2) = 200 NVGAP(3) = 5000 NVGAP(4) = 40 C-- Pre-lift the banks for I/O handling CALL MQLIFT (LACRAD, 0,7, JBKARR,3) CALL MQLIFT (LPAM, 0,7, JBKPAM,3) CALL MQLIFT (LQARRV, 0,7, JBKARR,3) CALL MQLIFT (LQHOLD, 0,7, JBKHOL,1) RETURN C-------- Finish initialization with the cradle in memory ------- C-- preset options COMPACT FULL VERBOSE 31 MOPTIO(2) = 1 MOPTIO(3) = 1 MOPTIO(6) = 1 IF (IQTYPE.NE.IQPRNT) MOPTIO(22)= 1 CALL PKBYT (MOPTIO(1),MOPTIO(33),1,32,0) CALL PINIT2 C-- Ready the ASM structure and connect pre-opened files CALL ASMINI RETURN END +SEQ, QCARDL. ===================================================== +DECK, PINIT2. SUBROUTINE PINIT2 C- Initialization for Nypatchy and Nysynopt C. split off from PINIT 19-july-95 +CDE, QBITS19, QBANKS, CCTYPE, CCPARA, CHEXC. +CDE, MUSEBC, MQCM, Q, PY. C-------------- End CDE -------------------------------- PARAMETER (IXCRA=2) +SEQ, Q_OR. JSLA = IQ(LQHOLD+1) NSLE = IQ(LQHOLD+3) JSLE = JSLA + NSLE IF (NSLE.LE.0) GO TO 41 C---- +NAMES, length, slots, text CALL NEXTXX ('+NAM', JSLA,JSLE,JSLF) IF (JSLF.EQ.0) GO TO 34 JCCTYP = MCCNAM CALL CCKRAK (JSLF) IF (JCCBAD.NE.0) CALL P_KILL ('faulty line +NAMES') CALL NA_REIN C---- +GAP, gap1, ... 34 CALL NEXTXX ('+GAP', JSLA,JSLE,JSLF) IF (JSLF.EQ.0) GO TO 36 JCCTYP = MCCGAP CALL CCKRAK (JSLF) IF (JCCBAD.NE.0) CALL P_KILL ('faulty line +GAP') CALL VZERO (IQUEST,12) CALL UCOCOP (MCCPAR(JCCPN+1),IQUEST,NCCPN,1,3,1) IF (IQUEST(1).GT.0) IQUEST(1)= MAX (IQUEST(1), 1000) IF (IQUEST(2).GT.0) IQUEST(2)= MAX (IQUEST(2), 100) IF (IQUEST(3).GT.0) IQUEST(3)= MAX (IQUEST(3), 2000) IF (IQUEST(4).GT.0) IQUEST(4)= MAX (IQUEST(4), 20) IF (IQUEST(1).GT.0) NVGAP(1) = MIN (IQUEST(1), LQCEND(3)/10) IF (IQUEST(2).GT.0) NVGAP(2) = MIN (IQUEST(2), 400) IF (IQUEST(3).GT.0) NVGAP(3) = MIN (IQUEST(3), LQLSTA(5)/10) IF (IQUEST(4).GT.0) NVGAP(4) = MIN (IQUEST(4), 80) C---- +UPDATE 36 CALL NEXTXX ('+UPD', JSLA,JSLE,JSLF) IF (JSLF.EQ.0) GO TO 41 JCCTYP = MCCUPD CALL CCKRAK (JSLF) IF (JCCBAD.NE.0) CALL P_KILL ('faulty line +UPDATE') MOPUPD = 1 +SEQ, QEJECT. C-- USE bits for global and P=CRA* and D=blank 41 MX_FORC = KM6 + KM7 + KM8 + KM9 MU_GLOB = MX_FORC + KM10 MU_PAT = MU_GLOB + KM5 MU_DECK = MU_PAT CALL MXOPER (0) C-- lift PAT and DECK banks for P=CRA*,D=blank CALL MQLIFT (LPCRA, LEXP,1, JBKPAT,3) LQ(LPCRA-4) = LPCRA IQ(LPCRA) = IOR (IQ(LPCRA),MU_PAT) IQ(LPCRA+1) = KM5 IQ(LPCRA+2) = IXCRA CALL MQLIFT (LDCRAB, LPCRA,-2, JBKDEC,3) LEXD = LDCRAB LQ(LDCRAB-4) = LPCRA IQ(LDCRAB) = IOR (IQ(LDCRAB),MU_DECK) IXEXPAM = 0 IXEXPAT = IXCRA IXEXDEC = 0 IXEXID = IXCRA C-- lift the dummy PAT bank connecting the past to the future CALL MQLIFT (LLPAST,LEXP,-1,JBKPAT,3) C-- lift PAT bank for PY_VS5 used CALL MQLIFT (L,LEXP,-1,JBKPAT,3) LQ(L-4) = LPCRA IQ(L) = IOR (IQ(L), MU_PAT) IQ(L+2) = NA_LONG ('PY_VS5') C-- create the service MAT bank at LSERV CALL MQLIFT (LSERV, 0,7, JBKMAT,3) C-- Lift the preset sequence definitions CALL CRDECO CALL INISEQ RETURN END +SEQ, QCARDL. ===================================================== +DECK, P_CRASH. SUBROUTINE P_CRASH (MSG) +CDE, QUNIT. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) IF (NQINIT.NE.0) IQPRNT= IQTYPE WRITE (IQTYPE,9000) IF (IQPRNT.NE.IQTYPE) WRITE (IQPRNT,9000) CALL P_KILL (MSG) 9000 FORMAT (/' ****!!!!! Patchy crashing on a bug !!!!!****' F/' please call for help: zoll@cern.ch') END +SEQ, QCARDL. ===================================================== +DECK, P_KILLM, T=JOIN. SUBROUTINE P_KILLM (MSG) CHARACTER MSG*(*) +SELF, IF=QS_UNIX. CALL PERRORF (' Perror has') +SELF. CALL P_KILL (MSG) END +SEQ, QCARDL. ===================================================== +DECK, P_KILL, T=JOIN. SUBROUTINE P_KILL (MSG) +CDE, QUNIT. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) IF (NQINIT.NE.0) IQPRNT= IQTYPE WRITE (IQTYPE,9011) MSG IF (IQPRNT.NE.IQTYPE) WRITE (IQPRNT,9011) MSG +SELF, IF=QDIAG. CALL TRACEQ (IQTYPE,12) WRITE (IQTYPE,*) +SELF. CALL EXITRC (2) 9011 FORMAT (/' ***!!! Kill the run for: ',A,' !!!***') END +SEQ, QCARDL. ===================================================== +DECK, EXITRC, T=JOIN. SUBROUTINE EXITRC (INRC) JRC = INRC +SELF, IF=QS_IBMVM. IF (JRC.GE.2) JRC = 4 +SELF, IF=QS_VMS. IF (JRC.EQ.1) THEN JRC = 9 ELSEIF (JRC.GE.2) THEN JRC = 4 ENDIF +SELF. CALL EXITF (JRC) END +SEQ, QCARDL. ===================================================== +DECK, P_FATAM. SUBROUTINE P_FATAM (MSG) CHARACTER MSG*(*) +SELF, IF=QS_UNIX. CALL PERRORF ('Perror has') +SELF. CALL P_FATAL (MSG) END +SEQ, QCARDL. ===================================================== +DECK, P_FATAL, T=JOIN. SUBROUTINE P_FATAL (MSG) +CDE, QUNIT. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) IF (NQINIT.NE.0) IQPRNT= IQTYPE WRITE (IQTYPE,9011) MSG IF (IQPRNT.NE.IQTYPE) WRITE (IQPRNT,9011) MSG +SELF, IF=QDIAG. CALL TRACEQ (IQTYPE,12) WRITE (IQTYPE,*) +SELF. CALL PABEND 9011 FORMAT (/' ***!!! Fatal error for ',A,' !!!***') END +SEQ, QCARDL. ===================================================== +DECK, PABEND, T=JOIN. SUBROUTINE PABEND C- Nypatchy run termination with errors C. started 16-dec-93 +CDE, QUNIT, QSTATE, LUNSLN. +CDE, Q, PY. C-------------- End CDE -------------------------------- IF (NQINIT.NE.0) GO TO 28 IF (IFLAUX.NE.0) GO TO 28 IF (NQERR.EQ.0) NQERR= 1 IF (INCRAD.NE.3) GO TO 49 WRITE (IQPRNT,9011) IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9011) 9011 FORMAT (/' ***!!! No operation !!!***'/) 28 CALL EXITRC (2) 49 CALL PEND END +SEQ, QCARDL. ===================================================== +DECK, PEND. SUBROUTINE PEND C- Print the run summary C. started 11-feb-92 +CDE, SLATE, SLATLN, QBITS19, QPAGE, QUNIT, QSTATE. +CDE, MQCM, MQCN, KQADR, Q, PY. +CDE, CM_TYP, NAMEC. C-------------- End CDE -------------------------------- CHARACTER LINE*128, COL(128)*1 EQUIVALENCE (LINE,COL,SLLINE) PARAMETER (KI=21, KF=29, KT=36, KS=43, KO=51) +SEQ, Q_AND, Q_JBYT. C| Processing mode selections Other status bits for P=X C| C| U - use F - skipped by +PATCH,X,IF=... C| L - list M - skipped by +IMITATE,X C| E - exe X - at least 1 deck to ASM C| D - divert P - partial +USE,X,D=... C| X - xdivert Self + Self R - P=X,T=REPEAT C| Inhibit Foreign Trans only Q - quoted in IF=X C| ------- ------- ------ ------ C|_:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: 4_:.=+=.: 5_:.=+=.: 6_:.=+=.: 7_ C| Patch ULEDX ULEDX LEDX LEDX FMXPRQ Used from P= C| C| 0 CRA* . ULE . . LE . R CRA* C| P5MODEL /20 931111 21.50 C| 0 @P5MODEL . LE . . LE . C| 1 *MO . ULE . . LE . CRA* C| 2 ACTZ . ULE . . LE . *MO C| 16 VCDE . ULE . . LE . Q *MO C| 19 ALPHA . ULE . . LE . Q *MO C| 23 BETA . ULE . . LE . Q ALPHA C| 30 CRA* . ULE . . LE . R CRA* C| C| Quoted patches not seen on the PAM files C| C| 0 NEWF . ULED . . LED . Q *MO C| 0 QMSUN . LE . . LE . Q C| C| Other patches not seen C| C| 0 ZLONGNAME012 U . LE . . LE . CRA* C| 0 ZLONGNAME01..U . LE . . LE . CRA* C|_:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: 4_:.=+=.: 5_:.=+=.: 6_:.=+=.: 7_ +SELF, IF=QMVAX. C-- on the VAX: terminate the ASSEMBLE streams CALL VAXASMT +SELF. IF (NQERR.NE.0) MOPTIO(22)= 1 IF (MOPTIO(22).EQ.0) GO TO 51 +SEQ, QEJECT. IF (NQPAGE.EQ.1) THEN CALL DPBLAN (1) LINE(1:1) = ' ' ELSE LINE(1:1) = '1' ENDIF WRITE (IQPRNT, 9001) LINE(1:1) 9001 FORMAT (A,'--------------------------------------' F/' Summary of patches in processing order'/ F/' Processing mode selections',24X,'Other status bits for P=X'/ F/' U - use ',42X,'F - skipped by +PATCH,X,IF=...' F/' L - list ',42X,'M - skipped by +IMITATE,X' F/' E - exe ',42X,'X - not +EXE but deck to ASM' F/' D - divert ',42X,'P - partial +USE,X,D=...' F/' X - xdivert',16X,'Self +',9X,'Self',8X,'R - P=X,T=REPEAT' F/19X,' Inhibit Foreign Trans only',7X,'Q - quoted in IF=X' F/19X,' ------- ------- ------ ------', F/8X,'Patch',6X, F ' ULEDX ULEDX LEDX LEDX FMXPRQ Used from P='/) 9000 FORMAT (A) CALL QSHUNT (KQMAIN,KQPAST) CALL QTOPSY (KQPAST) LQ(LLPAST-1) = 0 LBK = LQPAST MODE = 0 C------ Do one list of patch summary 21 MST = IQ(LBK) MW1 = IQ(LBK+1) IXNAME = IQ(LBK+2) +SELF, IF=QDEBUG. CALL QNAMEX (LBK) IF (IQFOUL.NE.0) THEN WRITE (IQPRNT,9822) LBK CALL P_CRASH ('trouble in PEND') ENDIF 9822 FORMAT (' ***!!! Trouble at LBK =',I9) +SELF. C-- check to be printed in secondary lists IF (MODE.NE.0) THEN IF (IXNAME.EQ.0) GO TO 29 MM = IAND (MW1,KM6) IF (MODE.EQ.1) THEN IF (MM.EQ.0) THEN NOTHER = 7 GO TO 29 ENDIF ELSE IF (MM.NE.0) GO TO 29 ENDIF GO TO 26 ENDIF C---- doing the primary list IF (IXNAME.GE.0) GO TO 26 C-- bank RPAM LINE(1:4) = ' ' CALL LN_GET (MW1, LINE(2:), 40) N = NDSLAT + 1 CALL CSQMBL (LINE,2,N) N = NESLAT - 1 WRITE (IQPRNT,9000) GO TO 28 C-- bank PAT 26 NDKNO = JBYT (MW1,13,20) LINE = ' ' CALL CSETDI (NDKNO,LINE,2,7) CALL NA_GET (IXNAME,LINE(1:21),9) IF (NFSLAT.GT.12) LINE(20:21) = '..' LINE(28:50) = '. . . .' IF (IAND(MST,KM10) .EQ.0) COL(KI+1) = 'U' IF (IAND(MST,KM7) .EQ.0) COL(KI+2) = 'L' IF (IAND(MST,KM6) .EQ.0) COL(KI+3) = 'E' IF (IAND(MST,KM8) .EQ.0) COL(KI+4) = 'D' IF (IAND(MST,KM9) .EQ.0) COL(KI+5) = 'X' IF (IAND(MST,KM5) .NE.0) COL(KF+1) = 'U' IF (IAND(MST,KM2) .NE.0) COL(KF+2) = 'L' IF (IAND(MST,KM1) .NE.0) COL(KF+3) = 'E' IF (IAND(MST,KM3) .NE.0) COL(KF+4) = 'D' IF (IAND(MST,KM4) .NE.0) COL(KF+5) = 'X' IF (IAND(MST,KM12) .NE.0) COL(KT+2) = 'L' IF (IAND(MST,KM11) .NE.0) COL(KT+3) = 'E' IF (IAND(MST,KM13) .NE.0) COL(KT+4) = 'D' IF (IAND(MST,KM14) .NE.0) COL(KT+5) = 'X' IF (IAND(MST,KM16) .NE.0) COL(KS+2) = 'L' IF (IAND(MST,KM15) .NE.0) COL(KS+3) = 'E' IF (IAND(MST,KM17) .NE.0) COL(KS+4) = 'D' IF (IAND(MST,KM18) .NE.0) COL(KS+5) = 'X' +SEQ, QEJECT. IF (IAND(MW1,KM1) .NE.0) COL(KO+1) = 'F' IF (IAND(MW1,KM2) .NE.0) COL(KO+2) = 'M' IF (IAND(MW1,KM3) .NE.0) COL(KO+3) = 'X' IF (IAND(MW1,KM4) .NE.0) COL(KO+4) = 'P' IF (IAND(MW1,KM5) .NE.0) COL(KO+5) = 'R' IF (IAND(MW1,KM6) .NE.0) COL(KO+6) = 'Q' C-- add "used from" IX = LQ(LBK-4) IF (IX.NE.0) IX= IQ(IX+2) IF (IX.EQ.0) THEN N = LENOCC (LINE(1:60)) ELSE CALL NA_GET (IX,LINE,60) N = NESLAT - 1 ENDIF C-- print the line and loop 28 WRITE (IQPRNT,9000) LINE(1:N) 29 LBK = LQ(LBK-1) IF (LBK.NE.0) GO TO 21 C-- End of the list IF (MODE.EQ.2) GO TO 39 IF (MODE.EQ.1) GO TO 38 C-- remove bank for p=PY_VS5 if not quoted IXU = NA_LONG ('PY_VS5') L = KQFIND (IXU,2, KQMAIN,K) IF (L.NE.0) THEN IF (IAND(IQ(L+1),KM6).EQ.0) LQ(K)= LQ(L-1) ENDIF IF (LEXP.EQ.LLPAST) GO TO 39 WRITE (IQPRNT,9037) 9037 FORMAT (/' Quoted patches not seen on the PAM files'/) CALL QSORTN (2,KQMAIN) NOTHER = 0 LBK = LEXP MODE = 1 GO TO 21 38 IF (NOTHER.EQ.0) GO TO 39 WRITE (IQPRNT,9038) 9038 FORMAT (/' Other patches not seen'/) LBK = LEXP MODE = 2 GO TO 21 39 CONTINUE C------ Name stack occupation JSL = LQLSTA(5) JSLE = NA_OCC + 1 JTX = MLIAD(JSL) JTXE = MLIAD(JSLE) NSLOCC = JSLE - JSL NTXOCC = JTXE - JTX NSLAV = LQLEND(5) - JSL NTXAV = NSIZETX - JTX NSLPRO = (100 * NSLOCC) / NSLAV NTXPRO = (100 * NTXOCC) / NTXAV WRITE (IQPRNT,9050) NA_CUT, NSLPRO,NSLAV, NTXPRO,NTXAV NQLLBL = 0 9050 FORMAT (/' Name stack:',7X, F 'significant name length is',I3,' characters' F/ 12X,I5,'% used of',I7,' name slots available' F/ 12X,I5,'% used of',I7,' bytes of text available') +SEQ, QEJECT. C------ Input summary 51 CALL DPBLAN (1) WRITE (IQPRNT,9051) IQ(LACRAD+12) 9051 FORMAT (' Read:',6X,I6,' lines from the cradle') WRITE (IQPRNT,9052) IQ(LPAM+12), IQ(LPAM+13), IQ(LPAM+14) 9052 FORMAT (10X,I8,' lines from',I4,' PAM files for',I3, F' lines +PAM') C------ ASM output summary WRITE (IQPRNT,9061) IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9061) 9061 FORMAT (/' Written:') C---- print all active physical streams JASM = 0 62 JASM = JASM + 1 IF (JASM.GT.N_TYP) GO TO 71 LASMT = LQ(LHASM-JASM) LASML = LASMT JDIV = 0 63 IF (IQ(LASML+1).NE.0) GO TO 69 LXASM = LQ(LASML-1) MODE = IQ(LASML+2) NDK = IQ(LXASM+3) NLI = IQ(LXASM+4) IF (MODE.NE.3) THEN IF (NDK.EQ.0) GO TO 69 ENDIF LINE = ' physical' CALL STRMID (JASM,JDIV,LINE,13) JP = MAX (NESLAT,24) CALL CSETDI (NDK, LINE,JP+1,JP+5) JP = JP + 6 IF (MODE.EQ.0) THEN LINE(JP+1:JP+5) = 'decks' ELSEIF (MODE.EQ.1) THEN LINE(JP+1:JP+5) = 'units' ELSE LINE(JP+1:JP+5) = 'files' ENDIF JP = JP + 6 IF (MODE.EQ.0) THEN LINE(JP+1:JP+8) = 'bypassed' JP = JP + 8 GO TO 68 ENDIF CALL CSETDI (NLI, LINE,JP+1,JP+6) JP = JP + 7 LINE(JP+1:JP+5) = 'lines' JP = JP + 6 IF (MODE.EQ.1) THEN LINE(JP+1:JP+7) = 'to file' JP = JP + 9 CALL NA_GET (IQ(LASML+3), LINE,JP) JP = NESLAT - 1 GO TO 68 ENDIF IF (MODE.EQ.2) THEN LINE(JP+1:JP+22) = ' written in SPLIT mode' ELSE LINE(JP+1:JP+22) = 'written in MODIFY mode' ENDIF JP = JP + 22 68 WRITE (IQPRNT,9000) WRITE (IQPRNT,9000) LINE(1:JP) IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9000) LINE(1:JP) IF (MODE.LT.2) GO TO 69 IXU = IQ(LASML+3) IF (IXU.NE.0) THEN CALL NA_GET (IXU,LINE,1) N = NDSLAT WRITE (IQPRNT,9067) LINE(1:N) ENDIF IXU = IQ(LASML+4) IF (IXU.NE.0) THEN CALL NA_GET (IXU,LINE,1) N = NDSLAT WRITE (IQPRNT,9068) LINE(1:N) ENDIF 9067 FORMAT (' log file name is ',A) 9068 FORMAT (' file name prefix: ',A) 69 IF (JDIV.EQ.4) GO TO 62 JDIV = JDIV + 1 LASML = LQ(LASMT-JDIV-1) GO TO 63 +SEQ, QEJECT. C---- print all active logical streams 71 WRITE (IQPRNT,9000) JASM = 0 72 JASM = JASM + 1 IF (JASM.GT.N_TYP) GO TO 81 LASMT = LQ(LHASM-JASM) LASML = LASMT JDIV = 0 73 NDKG = IQ(LASML+8) NDKW = IQ(LASML+9) IF (NDKG.EQ.0) GO TO 79 MUSE = IQ(LASML+1) LINE = ' logical' CALL STRMID (JASM,JDIV,LINE,13) JP = MAX (NESLAT,24) CALL CSETDI (NDKG, LINE,JP+1,JP+5) JP = JP + 6 LINE(JP+1:JP+5) = 'decks' JP = JP + 6 IF (NDKW.EQ.NDKG) GO TO 76 LINE(JP+1:JP+5) = 'done,' JP = JP + 6 CALL CSETDI (NDKW, LINE,JP+1,JP+5) JP = JP + 6 LINE(JP+1:JP+5) = 'decks' JP = JP + 6 76 LINE(JP+1:JP+7) = 'written' JP = JP + 7 IF (MUSE.EQ.0) GO TO 78 LINE(JP+1:JP+4) = ' via' JP = JP + 6 JASMP = MUSE / 8 JDIVP = MOD (MUSE,8) LINE(JP:JP+15) = CH_TYP(JASMP) JP = LNBLNK (LINE(1:JP+15)) + 1 LINE(JP:JP) = ':' JP = JP + 1 CALL CSETDI (JDIVP, LINE,JP,JP) 78 WRITE (IQPRNT,9000) LINE(1:JP) 79 IF (JDIV.EQ.4) GO TO 72 JDIV = JDIV + 1 LASML = LQ(LASMT-JDIV-1) GO TO 73 C---- Print number of warnings and errors 81 IF (NQERR+NQWARN.EQ.0) THEN WRITE (IQPRNT,9081) ELSE IF (NQERR.EQ.0) THEN WRITE (IQPRNT,9082) NQWARN IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9082) NQWARN ELSE WRITE (IQPRNT,9082) NQWARN,NQERR IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9082) NQWARN,NQERR ENDIF ENDIF +SELF, IF=XDEBUG, IF=XDDSNAP. CALL DDSNAP ('PEND',0,1) CALL DDSNAP ('PEND',0,3) +SELF, IF=XDEBUG, IF=XNAMES. CALL NA_DUMP +SELF. IF (NQERR.EQ.0) RETURN CALL EXITRC (2) 9081 FORMAT (/' No errors, no warnings.'/) 9082 FORMAT (/' **!!', I5,' warnings !!**'/ F :,' ***!!!',I4,' errors !!!***'/) END +SEQ, QCARDL. ===================================================== +DECK, DOCRAD. SUBROUTINE DOCRAD C- Process the cradle C. started 27-feb-92 +CDE, QBITS19, QBANKS, QPAGE. +CDE, ARRCOM, CCTYPE, CCPARA, CHEXC, DEPCOM, MUSEBC. +CDE, MQCM, Q, PY. C-------------- End CDE -------------------------------- PARAMETER (IXCRA=2) CHARACTER MARK*4 +SEQ, Q_AND. LARRV = LACRAD JREADY = 1 NSLORG = 1 NDKOFF = 0 JD_DTP = 1 JD_DTN = 0 JD_NEW = 1 IFLMERG = 0 IFLDISP = 0 IXEXPAM = 0 IF (INCRAD.EQ.3) GO TO 31 C------ Restart the cradle after having read a PAM file CALL VZERO (IQ(LQHOLD+1),3) CALL ARRIVE (1) IF (JDKTYP.EQ.2) GO TO 27 C-- lift PAT bank for P=CRA* 24 CALL CREAPD (IXCRA,-1,1) CALL SBYT (NQDKNO, IQ(LEXP+1),13,20) LPCRA = LEXP 25 LEXD = 0 MU_PAT = IAND (IQ(LEXP), KM19-1) MU_DECK = MU_PAT CALL MXOPER (0) IXEXPAT = IXCRA IXEXDEC = IXCRA IXEXID = IXCRA LDECO = 0 NQNEWH = 1 NQJOIN = -1 NSLORG = 1 INCRAD = 2 +SEQ, QEJECT. 27 IF (JDKTYP.GE.6) GO TO 79 IF (JDKTYP.GE.4) GO TO 42 IF (JDKTYP.EQ.0) GO TO 29 INCRAD = 1 JREADY = 0 NSLORG = 0 NDKOFF = 0 IF (JDKTYP.GE.2) GO TO 34 GO TO 31 C-- Do next deck 29 NQDKNO = NQDKNO - NDKOFF JREADY = 1 31 JDKTYP = 1 CALL DODECK (JREADY) GO TO 37 C-- do next patch 34 INCRAD = 1 IF (JDKTYP.EQ.2) THEN CALL DOPAT ELSE C-- skip for +TITLE JDKTYP = 2 CALL ARRSKP ENDIF 37 IF (JDKTYP.GE.6) GO TO 79 IF (JDKTYP.LE.3) GO TO 34 C---- Handle +PAM or +QUIT NSLORG = IQ(LQHOLD+1) - JSLORG NDKOFF = 1 42 JSLCRA = IQ(LQHOLD+1) NSLCRA = IQ(LQHOLD+2) JTXCRA = MLIAD(JSLCRA) NTX = MLIAD(JSLCRA+1) - JTXCRA - NCHNEWL JCCTYP = JPTYPE (TEXT(JTXCRA)) CALL CCKRAK (JSLCRA) IF (JCCBAD.NE.0) THEN MARK = ' *! ' GO TO 44 ENDIF CALL CCPROC IF (JCCIFV.EQ.0) THEN MARK = ' + ' ELSE MARK = ' ( ' ENDIF C-- print the c/line 44 IF (INCRAD.GE.2) THEN LINUM = NSLORG ELSE LINUM = 1 ENDIF CALL DPBLAN (1) CALL DPLINE (LINUM,MARK,NTX,TEXT(JTXCRA)) C-- exit if faulty c/line IF (JCCBAD.NE.0) GO TO 91 C-- continue deck if IF deselected c/line IF (JCCIFV.EQ.0) GO TO 61 IQ(LQHOLD+1) = IQ(LQHOLD+1) + 1 IQ(LQHOLD+2) = IQ(LQHOLD+2) - 1 NSLORG = NSLORG + 1 IF (IQ(LQHOLD+2).EQ.0) THEN CALL ARRIVE (1) ELSE CALL ARRNXD (-1) ENDIF IF (INCRAD.GE.2) GO TO 27 IF (JDKTYP.GE.1) GO TO 27 NDKOFF = 0 IF (IXEXPAT.NE.IXCRA) GO TO 24 GO TO 25 +SEQ, QEJECT. C------ Accepted control line +PAM or +QUIT 61 IF (JCCTYP.EQ.MCCQUI) GO TO 79 NSLORG = 0 C-- Digest the +PAM parameters to bank at LPAM CALL DOAPAM IF (JCCBAD.NE.0) GO TO 91 C-- Save cradle material after +PAM, ... JSLCRA = JSLCRA + 1 NSLCRA = NSLCRA - 1 IF (NSLCRA.EQ.0) GO TO 77 +SELF, IF=QCIO. IF (IQ(LARRV+7).LT.0) GO TO 76 JSLE = JSLCRA + NSLCRA CALL NEXTDE (JSLCRA,JSLE,JSLF,JTYP,-2) IF (JTYP.EQ.0) GO TO 76 C-- reposition the cradle file to the start of next deck IN_DOX = 1 IN_DO1 = JSLF CALL ARRIN NSLCRA = JSLF - JSLCRA IF (NSLCRA.EQ.0) GO TO 77 +SELF. 76 CALL MQLIFT (LASAV, LACRAD,-2, JBKASA,1) IQ(LASAV+1) = JSLCRA IQ(LASAV+2) = NSLCRA +SELF, IF=XDEBUG, IF=XSAVE. CALL DUMPSL (JSLCRA,NSLCRA,'being connected to ASAV bank') +SELF. 77 IQ(LQHOLD+2) = 0 IQ(LPAM+14) = IQ(LPAM+14) + 1 JANSW = 0 RETURN C-- +QUIT or EOF reached 79 JANSW = 1 RETURN C---- Trouble 91 IF (JCCTYP.EQ.MCCQUI) GO TO 79 CALL P_FATAL ('faulty line +PAM,...') END +SEQ, QCARDL. ===================================================== +DECK, DOAPAM. SUBROUTINE DOAPAM C- Gather the parameters of the c/line +PAM currently in CCKARD C- and store them into the PAM bank; position the wanted ARRV bank C- at LQARRV C. started 3-aug-93 +CDE, QBITS19, QBANKS, ARRCOM, CCPARA. +CDE, KQADR, Q, PY. +CDE, LUNSLN, FLINKC. C-------------- End CDE -------------------------------- PARAMETER (NPOSOP=10) CHARACTER POSOP(NPOSOP)*6 DATA POSOP / 'A*TTAC' +, 'H*OLD ' +, 'R*ESUM' +, 'U*PDAT' +, 'MER*GE' +, 'DIS*PL' +, 'LIS*T ' +, 'IND*IV' +, 'C*AR* ' +, 'D*ETAC' / +SEQ, Q_AND, Q_OR. C-- Analyse +PAM, LAB=lab, N=x,y, T=opt, RETURN=pname .fnname C- C- L=lab lab (integer) identify the file C- default: zero C- N=x do x files C- N=x,y skip x files, do y files C- C- T=ATTACH attach file fname C- HOLD do not release the file C- RESUME continue file "lab" C- UPDATE process this file in update mode C- (old: CARDS, DETACH) C- C- R=pname stop after P=pname complete +SEQ, bkPAM, IF=DOC_INL. +SEQ, QEJECT. CALL CCOPT (POSOP,NPOSOP) IF (JCCBAD.NE.0) RETURN LASTLU = IQ(LPAM+1) CALL VZERO (IQ(LPAM+1),8) LABEL = MCCPAR(JCCPC+1) IF (NCCPN.GE.2) THEN IQ(LPAM+4) = ABS(MCCPAR(JCCPN+1)) IQ(LPAM+5) = MCCPAR(JCCPN+4) ELSEIF (NCCPN.EQ.1) THEN IQ(LPAM+5) = ABS(MCCPAR(JCCPN+1)) ELSE IQ(LPAM+5) = 999 ENDIF IF (NCCPT.GT.0) IQ(LPAM+6) = MCCPAR(JCCPT+2) IQ(LPAM+7) = MCCPAR(JCCPD+1) C-- find a free logical unit number +SELF, IF=QCIO. LUNX = 11 +SELF, IF=QFIO. LUNX = LUNFREE (0) +SELF. C-- if labelled, find its ARRV bank IFLPRE = 1 IF (LABEL.NE.0) THEN LXX = KQFIND (LABEL,3,KQARRV,KXX) IF (LXX.NE.0) GO TO 31 ENDIF C-- get an empty ARRV bank IFLPRE = 0 KXX = KQARRV 24 LXX = LQ(KXX) IF (LXX.EQ.0) GO TO 26 IF (IQ(LXX+1)+IQ(LXX+3).EQ.0) GO TO 27 KXX = LXX - 1 GO TO 24 26 CALL MQLIFT (LXX, KXX,0, JBKARR,3) 27 CALL VZERO (IQ(LXX+1), 11) C------ New file to be opened -------------- 31 IXFLUN = 0 IF (IAND(IQ(LPAM+6),KM1).NE.0) GO TO 34 IF (LASTLU.NE.0) GO TO 41 IQ(LPAM+6) = IOR (IQ(LPAM+6),KM1) IXFLUN = IXLUN(1) GO TO 35 34 CALL FLKRAK (1,2) 35 IF (IXFLUN.EQ.0) GO TO 91 IF (IQ(LXX+1).EQ.0) GO TO 47 C-- the file connected is still active, close it LUNX = IQ(LXX+1) LSAVE = LARRV LARRV = LXX IN_DOX = -1 CALL ARRIN LARRV = LSAVE GO TO 47 C------ File to be resumed -------------- 41 IF (LABEL.EQ.0) THEN KXX = KQARRV LXX = LQARRV ELSE IF (IFLPRE.EQ.0) GO TO 91 ENDIF IF (IQ(LXX+1).NE.0) LUNX= IQ(LXX+1) 47 IF (KXX.NE.KQARRV) CALL QSHUNT (KXX,KQARRV) IQ(LPAM+1) = LUNX IQ(LPAM+3) = LABEL IQ(LPAM+8) = IXFLUN RETURN C-- Trouble 91 JCCBAD = 7 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DOPAMCO. SUBROUTINE DOPAMCO C- Connect the next multi-PAM file C. started 19-July-95 +CDE, SLATE, SLATLN, QBITS19, QPAGE, QUNIT. +CDE, ARRCOM, Q, PY. +CDE, FLINKC. C-------------- End CDE -------------------------------- +SEQ, Q_AND. +SEQ, bkPAM, IF=DOC_INL. +SEQ, bkARRV, IF=DOC_INL. +SEQ, QEJECT. C---- Garbage collection CALL MQSHIFT JDKTYP = 3 JDKNEX = 0 C---- Connect the PAM file LARRV = LQARRV IN_LUN = IQ(LPAM+1) LABEL = IQ(LPAM+3) MOPT = IQ(LPAM+6) IXFLUN = IQ(LPAM+8) IFLATT = IAND (MOPT,KM1) C IFLHOL = IAND (MOPT,KM2) IFLRES = IAND (MOPT,KM3) IFLUPD = IAND (MOPT,KM4) IFLREW = 1 IF (IFLATT.NE.0) GO TO 23 C---- Use connected file LUNPRE = IQ(LARRV+1) IXFLUN = IQ(LARRV+4) IF (LUNPRE.EQ.0) GO TO 23 IF (IFLRES.NE.0) THEN IFLREW = 0 SLLINE(1:12) = ' ---> resume' J = 12 ELSE SLLINE(1:13) = ' ---> restart' J = 13 ENDIF GO TO 24 C---- Attach the file 23 CALL FLINK (IN_LUN, 2, -1, 0) IQ(LARRV+2) = LUNFD IQ(LARRV+4) = IXFLUN IQ(LARRV+6) = LUNSIZ IQ(LARRV+7) = -2 +SELF, IF=QCIO. IF (LUNSIZ.GT.0) IQ(LARRV+7)= 0 +SELF, IF=QFIO. CALL LUNRESV (IN_LUN, IXFLUN) +SELF. SLLINE(1:11) = ' ---> start' J = 11 C-- Print log of file reading 24 SLLINE(J+1:J+14) = ' reading file ' J = J + 15 CALL NA_GET (IXFLUN,SLLINE,J) NTXT = NESLAT - 1 CALL DPBLAN (0) WRITE (IQPRNT,9027) SLLINE(1:NTXT) NQUSED = NQUSED + 2 IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9027) SLLINE(1:NTXT) 9027 FORMAT (A/) C-- finalize the ARRV bank IQ(LARRV+1) = IN_LUN IQ(LARRV+3) = LABEL IQ(LARRV+12) = 0 C-- rewind unless option T=RESUME IF (IFLREW.NE.0) THEN IN_DOX = 0 CALL ARRIN NQWYL = 0 ENDIF RETURN END +SEQ, QCARDL. ===================================================== +DECK, DOPAM. SUBROUTINE DOPAM C- Process the next multi-PAM file C. started 27-feb-92 +CDE, SLATE, SLATLN. +CDE, QBITS19, QBANKS, QPAGE, QUNIT. +CDE, ARRCOM, CCTYPE, CCPARA, CHEXC, DEPCOM, MUSEBC, TITLEC. +CDE, MQCM, KQADR, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_NOT. +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: arriving in DOPAM' +SELF. +SEQ, QEJECT. C---- Connect the PAM file CALL DOPAMCO JDKSUB = 0 MXFOSV = MX_FORC MOPT = IQ(LPAM+6) IFLHOL = IAND (MOPT,KM2) IFLUPD = IAND (MOPT,KM4) IFLMERG = IAND (MOPT,KM5) IFLDISP = IAND (MOPT,KM6) C-- Handle UPDATE mode IF (MOPUPD.NE.0) THEN IF (IFLUPD.NE.0) THEN MOPUPD = -1 ELSE C- suspend EXE mode for self on this PAM file MX_FORC = IAND (MX_FORC, NOT(KM6)) ENDIF ENDIF NHOLD = IQ(LARRV+9) IF (NHOLD.EQ.0) GO TO 31 C---- Resume input of the PAM file IQ(LARRV+9) = 0 CALL ARRIVE (1) JSLTTL = IQ(LARRV+10) IXEXPAM = IQ(LARRV+11) IF (IQ(LPAM+4).GT.0) GO TO 42 NCENT = NQDKNO / 100 NNUM = MOD (NHOLD,100) NNEW = 100*NCENT + NNUM IF (NNEW.LT.NQDKNO) NNEW= NNEW + 100 NQDKNO = NNEW JDKTYP = 2 GO TO 42 C------ Load the title deck to memory ------------ 31 IF (JDKNEX.EQ.0) CALL ARRIVE (2) C---- Handle the PAM-file title JCCTYP = 0 JD_DTP = 1 JD_DTN = 1 CALL KRTITL IF (JCCTYP.EQ.MCCPAT) JDKSUB= 2 JSLTTL = IQ(LARRV+10) IQ(LPAM+13) = IQ(LPAM+13) + 1 IF (IQ(LPAM+4).GT.0) GO TO 42 IF (NQDKNO.GE.2) THEN NQDKNO = ((NQDKNO-1)/100 + 1) *100 ELSE NQDKNO = 0 ENDIF JDKTYP = 3 C-- create RPAM bank 42 CALL QSHUNT (KQMAIN,KQPAST) CALL MQLIFT (LRPAM, LEXP,1, JBKRPA,3) IQ(LRPAM+1) = JSLTTL IQ(LRPAM+2) = -IXEXPAM IQ(LRPAM+3) = NQDKNO CALL LN_GET (JSLTTL, SLLINE, 60) NTXT = NDSLAT C-- PAM file to be read, not skipped IF (IQ(LPAM+4).GT.0) GO TO 71 CALL DPBLAN (0) WRITE (IQPRNT,9043) SLLINE(1:NTXT) NQUSED = NQUSED + 2 IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9043) SLLINE(1:NTXT) 9043 FORMAT (' Read Pam file: ',A/) IF (NFILET.LT.NFIMAX) NFILET= NFILET + 1 JTIPAM(NFILET) = JSLTTL +SEQ, QEJECT. C------ Loop over all patches IF (JDKSUB.NE.0) JDKTYP= 2 JDKSUB = 0 JD_DTP = 1 JD_DTN = 1 44 CALL DOPAT IF (JDKTYP.EQ.6) GO TO 81 IF (IQ(LEXP+2).EQ.IQ(LPAM+7)) GO TO 61 IF (JDKTYP.EQ.2) GO TO 44 C---- +TITLE seen, do next PAM file IQ(LPAM+5) = IQ(LPAM+5) - 1 IF (IQ(LPAM+5).LE.0) GO TO 62 GO TO 31 C---- Stop input from PAM C- for RETURN=name reached C- for number of PAM files to be done exhausted 61 IF (JDKTYP.EQ.2) IQ(LARRV+9)= NQDKNO 62 JSLSAV = IQ(LQHOLD+1) NSLSAV = IQ(LQHOLD+2) IF (IFLHOL.EQ.0) THEN LQLEND(2) = JSLSAV LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) GO TO 82 ENDIF IF (NSLSAV.EQ.0) GO TO 88 +SELF, IF=QCIO. IF (IQ(LARRV+7).GT.0) THEN IN_DOX = 1 IN_DO1 = JSLSAV CALL ARRIN GO TO 88 ENDIF +SELF. CALL MQLIFT (LASAV,LARRV,-2,JBKASA,1) IQ(LASAV+1) = JSLSAV IQ(LASAV+2) = NSLSAV GO TO 88 C------ Skip the PAM file 71 IQ(LPAM+4) = IQ(LPAM+4) - 1 IQ(LRPAM+4) = -1 CALL DPBLAN (0) WRITE (IQPRNT,9072) SLLINE(1:NTXT) NQUSED = NQUSED + 2 9072 FORMAT (' Skip Pam file: ',A/) JDKTYP = 3 CALL ARRSKP IF (JDKTYP.LT.6) GO TO 31 C------ End of multi-PAM reached 81 CONTINUE C-- Detach or Rewind 82 IF (IFLHOL.EQ.0) THEN IN_DOX = -1 ELSE IN_DOX = 0 ENDIF CALL ARRIN 88 IQ(LQHOLD+2) = 0 IQ(LPAM+12) = IQ(LPAM+12) + IQ(LARRV+12) IQ(LARRV+12) = 0 MOPUPD = ABS(MOPUPD) MX_FORC = MXFOSV RETURN END +SEQ, QCARDL. ===================================================== +DECK, DOPAT. SUBROUTINE DOPAT C- Process the current patch C. started 27-feb-92 +CDE, QBITS19, QPAGE. +CDE, CCTYPE, CCPARA, CHEXC, MUSEBC. +CDE, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_NOT. +SEQ, QEJECT. IFLGAR = 0 MUGLOB = MU_GLOB JCCBAD = 0 IF (JDKTYP.EQ.3) GO TO 26 JSLF = IQ(LQHOLD+1) JCCTYP = MCCPAT +SELF, IF=QDEBUG. JTX = MLIAD(JSLF) J = JPTYPE (TEXT(JTX)) IF (J.NE.JCCTYP) THEN NTX = MLIAD(JSLF+1) - JTX CALL DPLMSG ('Trouble with:',NTX,TEXT(JTX)) CALL P_CRASH ('trouble in DOPAT') ENDIF +SELF. CALL CCKRAK (JSLF) C-- get the name IXEXPAT = MCCPAR(JCCPP+1) IF (IXEXPAT.EQ.0) IXEXPAT= 1 C-- check the patch is already kown, if not it C- cannot have been USE selected IF (JCCBAD.NE.0) GO TO 27 IF (IAND(MU_GLOB,KM5).NE.0) GO TO 27 IF (MOPTIO(1).NE.0) GO TO 27 IF (LOCPAT(IXEXPAT).NE.0) GO TO 27 JDKTYP = 2 CALL ARRSKP RETURN C-- find/create the patch bank 26 IF (MOPUPD.GE.0) MU_GLOB= IAND (MU_GLOB,NOT(KM5)) 27 CALL CREAPD (IXEXPAT,-1,7) MU_GLOB = MUGLOB IXEXDEC = 0 IXEXID = IXEXPAT CALL SBYT (NQDKNO, IQ(LEXP+1),13,20) MU_PAT = IAND (IQ(LEXP),KM19-1) IF (JCCBAD.NE.0) GO TO 44 IF (IAND(MU_PAT,KM10).EQ.0) GO TO 47 IF (IAND(IQ(LEXP+1),KM2).NE.0) GO TO 47 IF (IAND(IQ(LEXP+1),KM4).NE.0) GO TO 44 IF (IAND(MU_PAT,KM5).EQ.0) GO TO 47 44 CALL DODECK (0) GO TO 48 47 JDKTYP = 2 CALL ARRSKP 48 IF (IAND(IQ(LEXP+1),KM5).NE.0) RETURN IF (MOPUPD.LT.0) RETURN IF (LQ(LEXP-2).NE.0) CALL TOGARB (LEXP-2,7) IF (LQ(LEXP-3).NE.0) CALL TOGARB (LEXP-3,7) +SELF, IF=XDEBUG, IF=XCOLLECT. C! IXBR = NA_NEW ('ACTX',1,5) C! IF (IXBR.NE.IXEXPAT) RETURN +SELF, IF=XDEBUG, IF=XCOLLECT, IF=XDDSNAP. IXBR = NA_NEW ('ACTX',1,5) IF (IXBR.EQ.IXEXPAT) THEN CALL DDSNAP ('DOPAT before shift',0,1) CALL DDSNAP ('DOPAT before shift',0,3) ENDIF +SELF, IF=XDEBUG, IF=XCOLLECT. CALL MQSHIFT +SELF, IF=XDEBUG, IF=XCOLLECT, IF=XDDSNAP. IF (IXBR.EQ.IXEXPAT) THEN CALL DDSNAP ('DOPAT after shift',0,1) CALL DDSNAP ('DOPAT after shift',0,3) ENDIF +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, DODECK. SUBROUTINE DODECK (JREADY) C- Process the next decks until end of patch C- JREADY = 0 c/l +DECK to be analysed C- 1 ready to run C. started 27-feb-92 +CDE, SLATE, SLATLN, QBITS19, QPAGE, QSTATE. +CDE, CCTYPE, CCPARA, CHEXC, DEPCOM, MUSEBC, TAGC. +CDE, MQCM, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_AND. +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: arriving in DODECK, JREADY= ',JREADY CALL PRHOLD +SELF. +SEQ, QEJECT. IFLRDY = JREADY NCHTAG = 0 LLORG = 0 LLACT = 0 LMODE = 0 C-- Check enough space 21 IFLGAR = 0 CALL SETGAP C------ Ready the deck parameters IF (IFLRDY.NE.0) GO TO 62 JD_NEW = 1 JD_MULT = 0 IF (JDKTYP.NE.1) GO TO 47 C---- Deck header is +DECK, name 42 INCRAD = MIN (INCRAD,1) JSLF = IQ(LQHOLD+1) JCCTYP = MCCDEC CALL CCKRAK (JSLF) C-- get the name IXEXDEC = MCCPAR(JCCPD+1) IF (IXEXDEC.EQ.0) IXEXDEC= 1 IXEXID = IXEXDEC C-- find the deck bank, set operation mode 47 LEXD = KQFIND (IXEXDEC,1, LEXP-2,KEXD) IF (LEXD.NE.0) THEN MU_DECK = IAND (IQ(LEXD),KM19-1) ELSE MU_DECK = MU_PAT ENDIF CALL MXOPER (0) IF (JDKTYP.NE.1) GO TO 61 IF (IAND(MU_DECK,KM5).EQ.0) GO TO 85 +SEQ, QEJECT. C------ Process the deck 61 NQNEWH = 7 LDECO = 0 NSLORG = 0 62 IFLRDY = 0 IF (JDKNEX.EQ.0) CALL ARRIVE (2) +SELF, IF=XDEBUG, IF=XSHOWDK. IF (JDKTYP.EQ.1) THEN SLLINE(1:48) = 'd=' IX = IXEXDEC ELSEIF (JDKTYP.EQ.2) THEN SLLINE(1:48) = 'p=' IX = IXEXPAT ELSE SLLINE(1:48) = 'f=' IX = IXEXPAM ENDIF CALL NA_GET (IX, SLLINE, 3) N = NESLAT - 1 PRINT *, 'Xdebug: DODECK doing ', SLLINE(1:N) +SELF, IF=XDEBUG, IF=-XDEBUG. C! IXBR = NA_NEW ('TCGEN',1,6) C! IF (IXBR.EQ.IXEXPAT) CALL CATCH (0) C! IXBR = NA_NEW ('VCDE',1,5) C! IF (IXBR.EQ.IXEXPAT) CALL CATCH (0) +SELF. C-- ready the foreign material into this deck CALL ACSORT C-- analyse the contents CALL DOMAP IF (JANSW.LT.0) GO TO 84 C-- process the contents IF (JANSW.NE.0) CALL DOXQT LQCEND(2) = LQCSTA(2) C------ Processing complete NQDKNO = NQDKNO + 1 C-- send the DECK bank to garbage collection C- unless it is the blank deck of P=CRA* IF (LEXD.NE.0) THEN L = KQFIND (IXEXDEC,1, LEXP-2, KEXD) IF (L.NE.0) THEN IF (L.EQ.LDCRAB) GO TO 67 CALL TOGARB (KEXD,0) ENDIF ENDIF IF (NVEXDK(1).EQ.0) GO TO 88 IF (JD_NEW.EQ.0) CALL DPEXTM (1) GO TO 88 C-- End of blank deck of P=CRA* 67 IF (NQERR.NE.0) + CALL P_KILL ('errors in the blank deck of the cradle') CALL ASMUSE LQ(KEXD) = LQ(LEXD-1) IF (NCLASH.EQ.0) THEN IF (MOPUPD.EQ.0) NCLASH= 2 ENDIF GO TO 88 C---- Skip patch or deck 84 JDKTYP = 2 85 CALL ARRSKP GO TO 89 C-- step to the next deck 88 CALL ARRNXD (1) 89 CONTINUE +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: end of deck, JDKTYP,JDKNEX=',JDKTYP,JDKNEX CALL PRHOLD +SELF. IF (JDKTYP.EQ.1) GO TO 21 RETURN END +SEQ, QCARDL. ===================================================== +PATCH, ACSORT. Sort the actions into the current deck +DECK, ACSORT. SUBROUTINE ACSORT C- Sort the action banks for current deck, mark clash levels C- Called from DODECK when processing of a new deck is started +CDE, QBITS19, Q, PY. C-------------- End CDE -------------------------------- DIMENSION MBIAS(12) +SEQ, Q_JBYT, Q_OR, Q_SHIFTL, Q_SHIFTR. DATA MBIAS / 5, 5, 3, 1, 0, 0, 0, 0, 4, 4, 2, 0 / C- DEL REP ADB ADD DEL REP ADB ADD C- 0 1 2 3 4 5 6 7 8 9 10 11 IF (LEXD.EQ.0) RETURN KACTEX = LEXD-2 L = LQ(KACTEX) IF (L.EQ.0) RETURN CALL QTOPSY (KACTEX) C-- Construct new target line numbers: LIIN = 8*LI + bias L = LQ(KACTEX) 24 JACT = JBYT (IQ(L),9,4) IQ(L+4) = ISHFTL(IQ(L+4),3) + MBIAS(JACT+1) L = LQ(L-1) IF (L.NE.0) GO TO 24 C-- Sort the list for starting target line numbers CALL QSORTI (4,KACTEX) C------ Scan for clash LBKF = KACTEX + 1 C-- new first bank 32 LBKF = LQ(LBKF-1) IF (LBKF.EQ.0) GO TO 41 JACTF = JBYT (IQ(LBKF),9,4) IF (JACTF.GE.8) GO TO 32 LBKN = LQ(LBKF-1) IF (LBKN.EQ.0) GO TO 41 IF (JACTF.LT.2) GO TO 34 IF (IQ(LBKF+4).NE.IQ(LBKN+4)) GO TO 32 IQ(LBKF) = IOR (IQ(LBKF), KM14) IQ(LBKN) = IOR (IQ(LBKN), KM14) GO TO 32 C-- and its next banks 34 JTGFE = ISHFTL (IQ(LBKF+5),3) + 7 36 IF (IQ(LBKN+4).GT.JTGFE) GO TO 32 JACTN = JBYT (IQ(LBKN),9,4) IF (JACTN.GE.8) GO TO 37 IF (IFLMERG.EQ.0) THEN MSKF = KM14 IF (LBKF.GT.LBKN) MSKF= KM15 MSKN = KM13 + MSKF ELSE MSKF = KM15 MSKN = KM15 ENDIF IQ(LBKF) = IOR (IQ(LBKF), MSKF) IQ(LBKN) = IOR (IQ(LBKN), MSKN) 37 LBKN = LQ(LBKN-1) IF (LBKN.EQ.0) GO TO 32 GO TO 36 C------ Reset the line numbers 41 L = LQ(KACTEX) 44 IQ(L+4) = ISHFTR(IQ(L+4),3) L = LQ(L-1) IF (L.NE.0) GO TO 44 RETURN END +SEQ, QCARDL. ===================================================== +PATCH, DOMAP. Map the current deck into the PREP structure +DECK, DOMAP. SUBROUTINE DOMAP C- Content analysis of the next deck, C- map the description of this deck's material C- into the control-banks of the linear PREP structure. C. started 9-jan-92 +CDE, QBANKS, Q, PY. +CDE, INCLC, M_ANAC. C-------------- End CDE -------------------------------- NEWDEC = 0 NEWCTL = 0 NEWFOR = 0 NEWNIL = 0 NEWINC = 0 MEXAN = 0 N_INCL = 0 JSLZER = IQ(LQHOLD+1) JSLORG = JSLZER - NSLORG C-- create the PREP seedling CALL MQLIFT (LQPREP, 0,7, JBKPRE,2) IQ(LQPREP+1) = JSLZER IQ(LQPREP+2) = IQ(LQHOLD+3) C---- stage 1 : delimit control lines, create PREP structure IF (MOPUPD.GE.0) CALL M_ANA1 C---- stage 2 : connect actions into this deck IF (LEXD.EQ.0) GO TO 31 IF (LQ(LEXD-2).EQ.0) GO TO 31 CALL M_ANA2 C-- create NIL sequences or actions IF (NEWNIL.NE.0) CALL MK_NIL C---- stage 3 : ready effective self-material and new foreign material C- return JANSW = -1 skip patch, 0 skip deck, 1 process 31 CALL M_HEAD IF (JANSW.GT.0) CALL M_ANA3 RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_ANA1. SUBROUTINE M_ANA1 C- Content analysis, stage 1: C- find all control lines present in the current deck; C- each control line starts a new PREP bank, unless it is C- a soft c/line covered by a +KEEP +REPL etc. in update mode; C- c/lines without associated text are held in a 1-line PREP bank. C- - this is not called if the deck is processed under +PAM, T=UPD C- and hence all c/l's in the deck are treated as ordinary lines C. started 11-dec-91 +CDE, CCTYPE, CCPARA, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_OR, Q_SHIFTL. LDO = LQPREP JSLA = IQ(LDO+1) JSLE = JSLA + IQ(LDO+2) JSLG = JSLA C---- Find next control line, split on it 21 IF (JSLG.GE.JSLE) RETURN CALL NEXTCC ('+',JSLG,JSLE,JSLF,JCCTYP) IF (JCCTYP.EQ.0) RETURN 22 IF (JSLF.GT.JSLA) LDO= M_SPLIT (LDO,JSLF) IQ(LDO) = IOR (IQ(LDO), ISHFTL(JCCTYP,8)) JSLA = IQ(LDO+1) JSLG = JSLA + 1 C-- control-lines with associated material are: C-- +_xxx +SELF +SKIP +KEEP +REPL +ADB +ADD IF (JCCTYP.LT.MCCTRU) GO TO 27 IF (JCCTYP.LE.MCCEND) GO TO 21 IF (JCCTYP.GE.MCCUSE) GO TO 27 IF (JCCTYP.GE.MCCKEE) GO TO 31 IF (JCCTYP.NE.MCCSEL) GO TO 21 C-- for +SELF, sname change the type to MCCSES CALL CCKRAK (JSLA) IF (NCCPZ.EQ.0) GO TO 21 CALL SBYT (MCCSES, IQ(LDO),9,6) GO TO 21 C-- stand-alone control-line 27 IF (JSLG.GE.JSLE) RETURN LDO = M_SPLIT (LDO,JSLG) JSLA = JSLG GO TO 21 C---- Found the start of an action, if Update mode: C-- handle all soft c/lines inside as ordinary lines 31 IF (JCCTYP.EQ.MCCDEL) GO TO 27 IF (MOPUPD.EQ.0) GO TO 21 37 CALL NEXTCC ('+',JSLG,JSLE,JSLF,JCCTYP) IF (JCCTYP.EQ.0) RETURN IF (JCCTYP.GE.MCCSEL) GO TO 22 JSLG = JSLF + 1 IF (JSLG.LT.JSLE) GO TO 37 RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_ANA2. SUBROUTINE M_ANA2 C- Content analysis stage 2: C- 1.1) for each action insert a zero-line PREP bank into the chain C- of PREP banks with a reference to the ACT bank acting into C- the current deck; C- 1.2) split the target PREP bank containing the end of C- a DELETE or REPLACE range; C- 2.1) transfer the action EXE bits into the new PREP bank; C- 2.2) for the PREP banks covered by a DEL or REPL transfer the C- EXE bits of the action, and mark as deleted (unless nil) C- 3) add one zero-line PREP bank for each trailing action; C- - called also if PAM update mode - C. started 11-nov-91 +CDE, QBITS19, QBANKS, CCTYPE, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT, Q_AND, Q_OR. C---------- Split PREP banks on all action limits ----------- LDO = LQPREP LACT = LEXD - 1 C---- Next action 21 LACT = LQ(LACT-1) IF (LACT.EQ.0) GO TO 40 C- JACT = 0 DEL, 1 REP, 2 ADB, 3 ADD JACT = JBYT (IQ(LACT),9,3) JSLX = IQ(LACT+4) + JSLZER C- break at the insertion point LDO = M_SPLIT (LDO,JSLX) IF (LDO.EQ.0) GO TO 40 C- zero-line PREP bank with reference to ACT LX = LDO LDO = M_SPLIT (LDO,0) LQ(LX-2) = LACT IF (JACT.GE.2) GO TO 21 C---- +DEL, +REPL: split at end of delete JSLD = IQ(LACT+5) + JSLZER + 1 LNX = M_SPLIT (LDO,JSLD) GO TO 21 +SEQ, QEJECT, N=40. C---------- Set EXE bits and mark deleted material ---------- 40 KMDEL = KM6 + KM7 IF (IFLDISP.NE.0) KMDEL= KM5 + KM7 LDO = LQPREP LACT = LEXD - 1 C---- Next action 41 LACT = LQ(LACT-1) IF (LACT.EQ.0) RETURN C- JACT = 0 DEL, 1 REP, 2 ADB, 3 ADD JACT = JBYT (IQ(LACT),9,3) NIL = IAND (IQ(LACT),KM12) NDEL = IAND (IQ(LACT),KM12+KM13) MEXE = IAND (IQ(LACT),15) MEXAN = IOR (MEXAN,MEXE) C-- Find the PREP bank for this action 43 IF (LQ(LDO-2).NE.LACT) THEN LSV = LDO LDO = LQ(LDO-1) IF (LDO.EQ.0) GO TO 61 GO TO 43 ENDIF MAB = MEXE IF (NDEL.NE.0) MAB = MAB + KM6 IQ(LDO) = IOR (IQ(LDO),MAB) IF (JACT.GE.2) GO TO 41 C---- +DEL, +REPL: mark deleted section JSLD = IQ(LACT+5) + JSLZER + 1 LNX = LDO 47 LNX = LQ(LNX-1) IF (LNX.EQ.0) GO TO 41 JSLA = IQ(LNX+1) IF (JSLA.GE.JSLD) GO TO 41 IQ(LNX) = IOR (IQ(LNX),MEXE) IF (NIL.NE.0) GO TO 47 IF (LQ(LNX-2).NE.0) GO TO 47 IQ(LNX) = IOR (IQ(LNX),KMDEL) C-- deleted action? JTYP = JBYT (IQ(LNX),9,6) IF (JTYP.LT.MCCKEE) GO TO 47 IF (JTYP.GE.MCCUSE) GO TO 47 NEWNIL = NEWNIL + 1 GO TO 47 C---- Add trailing actions 61 JSLSV = IQ(LSV+1) + IQ(LSV+2) 62 MEXAN = IOR (MEXAN,MEXE) IF (NDEL.EQ.0) THEN IF (JACT.LT.2) GO TO 67 ELSE MEXE = MEXE + KM6 ENDIF CALL MQLIFT (LNEW,LSV,-1,JBKPRE,2) LSV = LNEW LQ(LSV-2) = LACT IQ(LSV) = IOR (IQ(LSV),MEXE) IQ(LSV+1) = JSLSV 64 LACT = LQ(LACT-1) IF (LACT.EQ.0) RETURN JACT = JBYT (IQ(LACT),9,3) MEXE = IAND (IQ(LACT),15) NDEL = IAND (IQ(LACT),KM12+KM13) GO TO 62 C: DATA CHER( 1) /'illegal action after end-of-deck'/ 67 CALL FAILLN (1,LQ(LACT-3),IQ(LACT+3),IQ(LACT+1), + 'Illegal action after end-of-deck') GO TO 64 END +SEQ, QCARDL. ===================================================== +DECK, M_HEAD. SUBROUTINE M_HEAD C- Content analysis between stages 2 and 3: C- check patch/deck is accepted or not, C- evaluate data type, C- return JANSW = -1 skip patch, 0 skip deck, 1 process C. started 11-july-94 +CDE, QBITS19, QPAGE, CCTYPE, CCPARA, DEPCOM. +CDE, KQADR, Q, PY, MUSEBC. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. +SEQ, QEJECT. JCCIFV = 0 IFREP = 0 JANSW = 1 LUPAN = 0 LDOAN = KQPREP + 1 CALL M_A3NX IF (LDOAN.EQ.0) GO TO 24 IF (JCCTYP.LT.MCCDEC) GO TO 24 IF (JCCTYP.GT.MCCPAT) GO TO 24 CALL CCKRAK (IQ(LDOAN+1)) IF (JCCBAD.NE.0) THEN CALL M_FAIL ('Syntax error') ELSE IF (NCCPIF.NE.0) CALL CCPROC ENDIF IF (NCCPT.NE.0) THEN CALL CCDOPT (1, JD_DTN) IF (NQJOIN.GE.0) NQJOIN = IAND (MCCPAR(JCCPT+2),2) IFREP = IAND (MCCPAR(JCCPT+2),1) ELSE JD_DTN = 0 NQJOIN = MIN(NQJOIN,0) ENDIF C-- line is +DECK, name, T=type, IF=... IF (JCCTYP.NE.MCCDEC) GO TO 31 JDKTYP = 1 IF (JD_DTN.EQ.0) JD_DTN= JD_DTP IF (JCCIFV.NE.0) GO TO 49 GO TO 47 C-- not a c/line to be looked at (mainly update mode) 24 JD_DTN = JD_DTP IF (JDKTYP.EQ.1) GO TO 47 GO TO 34 C-- line is +PATCH, name, T=type, IF=... 31 JD_DTN = MAX (JD_DTN,1) JD_DTP = JD_DTN IF (JDKTYP.EQ.1) GO TO 44 IF (IFREP.NE.0) IQ(LEXP+1)= IOR (IQ(LEXP+1),KM5) 34 IF (IAND(MU_PAT,KM10).EQ.0) GO TO 39 IF (JCCIFV.NE.0) GO TO 38 IF (IAND(IQ(LEXP+1),KM4).NE.0) GO TO 47 IF (IAND(MU_PAT,KM5).EQ.0) GO TO 39 GO TO 47 38 IQ(LEXP+1) = IOR(IQ(LEXP+1),KM1) 39 JANSW = -1 RETURN C-- but the original was +DECK, ... 44 IF (JCCIFV.NE.0) GO TO 49 47 IF (IAND(MU_DECK,KM5).NE.0) RETURN 49 JANSW = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_ANA3. SUBROUTINE M_ANA3 C- Content analysis stage 3: C- ready effective self-material for use C- activating delayed control lines C- evaluating IF selection C- resolving sequence calls C- collecting EXE bits from called sqs and IF= params C- ready new effective foreign material for use C- activating delayed control lines C- evaluating initial IF selection C- - called also if PAM update mode - C. started 25-nov-91 +CDE, SLATE, QBITA19, QBANKS, QSTATE. +CDE, CCTYPE, CCPARA. +CDE, KQADR, Q, PY, MUSEBC. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR, Q_NOT, Q_SHIFTL. MUPASV = MU_PAT MUDKSV = MU_DECK LEVSK = MCCSEL NONACT = 7 LEVAN = 7 LUPAN = 0 LDOAN = KQPREP + 1 GO TO 21 +SEQ, QEJECT, N=60. C---------- Scan ordinary self-material --------- C-- MODEAN = 0 ordinary self 1 IF-conditional self C-- 2 +SELF,sname 3 +KEEP 4 +REPL,+ADB,+ADD 21 CALL M_A3NX IF (LDOAN.EQ.0) GO TO 61 22 IF (JCCTYP.LE.MCCNIL) GO TO 21 IF (JCCTYP.EQ.MCCTIT) GO TO 43 IF (JCCTYP.EQ.MCCXSQ) GO TO 37 CALL M_KRAK (1) JACT = 0 MODEAN = 0 IF (JCCTYP.GE.MCCUSE) GO TO 51 IF (JCCTYP.GE.MCCDEL) GO TO 71 NONACT = 7 IF (JCCTYP.EQ.MCCKEE) GO TO 73 IF (JCCTYP.EQ.MCCSKI) GO TO 40 IF (JCCTYP.GE.MCCSEL) GO TO 41 IF (JCCTYP.LT.MCCTRU) GO TO 31 C---------- Handle +_IF etc IF (JCCBAD.NE.0) GO TO 45 IFSTEP = 1 CALL M_A3IF (IFSTEP) IF (JCCBAD.NE.0) GO TO 45 IF (IFSTEP.NE.0) GO TO 21 IF (LDOAN.NE.0) GO TO 22 GO TO 61 C---------- Handle +CDE or +SEQ C-- check +CDE, T=DUMMY 31 IF (JCCBAD.NE.0) GO TO 21 MEXAN = IOR (MEXAN,MXCCIF) IF (IAND(MCCPAR(JCCPT+1),KMD).NE.0) JCCIFV= 1 CALL M_A3SQ GO TO 21 C-- link all seqences for XSQ bank 37 MX = LINKSQ (LDOAN,0) MEXAN = IOR (MEXAN,MX) GO TO 21 C---------- +SELF c/c seen 40 IF (MOPUPD.EQ.0) JCCIFV= 1 - JCCIFV 41 MEXAN = IOR (MEXAN,MXCCIF) IF (JCCBAD.NE.0) GO TO 45 IF (JCCIFV.NE.0) GO TO 45 IF (JCCTYP.NE.MCCSES) GO TO 21 C-- handle +SELF, seqname MODEAN = 2 CALL M_A3SQ IF (JCCBAD.NE.0) GO TO 45 IF (IQUEST(1).EQ.0) GO TO 21 GO TO 46 C-- deleted material 43 JCCTYP = MCCPAT 44 LEVSK = JCCTYP 45 IQ(LDOAN) = IOR (IQ(LDOAN), KM5) 46 CALL M_A3NX IF (LDOAN.EQ.0) GO TO 61 IF (JCCTYP.LT.LEVSK) THEN IQ(LDOAN) = IOR (IQ(LDOAN), KM6) GO TO 46 ENDIF JCCBAD = 0 LEVSK = MCCSEL GO TO 22 48 IF (JACT.NE.1) GO TO 45 49 IQ(LDOAN) = IOR (IQ(LDOAN), KM5) GO TO 21 +SEQ, QEJECT. C---------- Control lines +USE etc 51 NONACT = 7 IF (JCCTYP.GE.MCCDEC) GO TO 56 IF (JCCBAD.NE.0) GO TO 21 IF (JCCTYP.GE.MCCASM) GO TO 52 IF (JCCTYP.GT.MCCEXE) GO TO 53 IF (JCCIFV.NE.0) GO TO 49 CALL X_USE GO TO 21 C-- c/l allowed only in the cradle 52 IF (JCCTYP.EQ.MCCEOD) GO TO 49 IF (JCCTYP.EQ.MCCONL) GO TO 91 IF (LEXD.NE.LDCRAB) THEN IF (JCCTYP.LE.MCCONL) GO TO 94 IF (INCRAD.EQ.0) GO TO 94 ENDIF IF (JCCTYP.GE.MCCPAM) GO TO 49 53 IF (JCCIFV.NE.0) GO TO 49 NEWCTL = 7 GO TO 21 C---------- Control lines +DECK or +PATCH 56 IF (JCCBAD.NE.0) GO TO 44 MEXAN = IOR (MEXAN,MXCCIF) LEVAN = 7 NEWDEC = NEWDEC + 1 IF (JCCIFV.NE.0) GO TO 44 CALL CCDOPT (1, JASM) IF (NDSLAT.NE.0) THEN CALL M_FAIL ('Multiple data type') GO TO 44 ENDIF CALL SBYT (JASM,IQ(LDOAN),21,6) GO TO 21 C---------- End of processing 61 JANSW = 0 MEXAN = IAND (MEXAN,15) IF (MEXAN.NE.0) CALL MXOPER (MEXAN) IF (NQERR.NE.0) THEN NVEXDK(1) = 0 NVEXDK(5) = NVEXDK(2) ENDIF IF (NEWCTL+NEWFOR+NVEXDK(5).EQ.0) RETURN JANSW = 1 IF (INCRAD.LT.2) RETURN CALL SBYT (MUPASV, IQ(LEXP),1,18) IF (LEXD.NE.0) CALL SBYT (MUDKSV, IQ(LEXD),1,18) CALL X_UDECK (0) RETURN +SEQ, QEJECT. C---------- New foreign material being defined --------- C- JACT = 0 KEEP 1 DEL 2 REPL 3 ADB 4 ADD 71 IF (JCCBAD.NE.0) GO TO 45 JACT = JCCTYP - MCCKEE MODEAN = 4 IQ(LDOAN) = IOR (IQ(LDOAN), MXCCIF) IF (NONACT.NE.0) THEN NVIMAT(1) = 0 LASTDK = 0 NONACT = 0 ENDIF CALL CREACT IF (LCRD.EQ.0) GO TO 95 IF (LCRD.EQ.LASTDK) IQ(LDOAN)= IOR (IQ(LDOAN),KM18) LQ(LDOAN-3) = LCRD LASTDK = LCRD C---- Create NIL action IF (JCCIFV.NE.0) THEN IF (IAND(MXCCIF,NOT(IQ(LCRD))).EQ.0) GO TO 48 IQ(LDOAN) = IOR (IQ(LDOAN), KM8) NEWFOR = NEWFOR + 1 GO TO 48 ENDIF C---- Accepted action C- JACT = 0 KEEP 1 DEL 2 REPL 3 ADB 4 ADD NEWFOR = NEWFOR + 1 IF (JACT.EQ.1) GO TO 21 CALL M_A3AC IF (LDOAN.EQ.0) GO TO 61 IF (JCCBAD.NE.0) GO TO 45 GO TO 22 C------ +KEEP definition 73 IF (JCCBAD.NE.0) GO TO 45 MODEAN = 3 IF (IAND(MCCPAR(JCCPT+1),KMD).NE.0) GO TO 45 IQ(LDOAN) = IOR (IQ(LDOAN), MXCCIF) C-- check sequence existing CALL LOCKEEP (LACT) KACT = IQUEST(1) C-- T=APPEND? IF (LACT.NE.0) THEN IF (IAND(MCCPAR(JCCPT+1),KMA).EQ.0) GO TO 45 IF (IAND(IQ(LACT+1),KM19).NE.0) GO TO 45 IF (JCCIFV.NE.0) GO TO 45 IQ(LACT+1) = IOR (IQ(LACT+1),KM19) LQ(LDOAN-3) = -LACT NEWFOR = NEWFOR + 1 GO TO 76 ENDIF C---- Create NIL sequence if IF deselected IFLNIL = 0 IF (JCCIFV.EQ.0) GO TO 74 IF (IAND(MXCCIF,NOT(MU_GLOB)).EQ.0) GO TO 45 LPD = IQUEST(11) IF (LPD.NE.0) THEN IF (IAND(MXCCIF,NOT(IQ(LPD))).EQ.0) GO TO 45 ENDIF IQ(LDOAN) = IOR (IQ(LDOAN), KM8) IFLNIL = KM12 C---- Accepted sequence definition 74 NEWFOR = NEWFOR + 1 IFLNOL = ISHFTL (IAND(MCCPAR(JCCPT+1),KMN),2) IXS = MCCPAR(JCCPZ+1) C-- we have to create the KEEP bank now to over-rule C- possible future re-definitions in the same deck CALL MQLIFT (LACT,KACT,0,JBKKEE,1) IQ(LACT) = IOR (IQ(LACT), IFLNIL+IFLNOL) IQ(LACT+4) = IXS LQ(LDOAN-3) = LACT IF (IFLNIL.NE.0) GO TO 45 76 CALL M_A3KE IF (LDOAN.EQ.0) GO TO 61 IF (JCCBAD.NE.0) GO TO 45 GO TO 22 +SEQ, QEJECT. C----- Trouble 91 CALL FAILCC (0, 'Obsolete feature not implemented') GO TO 49 94 CALL FAILCC (0, 'Control line not allowed here') GO TO 49 95 CALL M_FAIL ('Implied target deck for action not defined') GO TO 48 END +SEQ, QCARDL. ===================================================== +DECK, M_A3IF. SUBROUTINE M_A3IF (IFSTEP) C- Content analysis stage 3: C- scan the PREP/MAT structure from the current +_IF to its C- terminating +_ENDIF and decide accept/reject. C- On entry LDOAN points to this +_IF, it has already been cracked; C- return LDOAN pointing to the end, and IFSTEP = 1 if LDOAN C- does point to the terminating +_ENDIF (preset =1 by M_ANA3), C- but for some error LDOAN points to some c/line which must still C- be analysed in M_ANA3, in this case set IFSTEP = 0; C- also: JCCBAD non-zero signals c/line with syntax error C. started 6-july-93 +CDE, QBITA19, CCTYPE, CCPARA. +CDE, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. IF (JCCTYP.GE.MCCELS) GO TO 93 CALL CCIFLV IQ(LDOAN) = IOR (IQ(LDOAN), KM17) MODEAN = 1 MAXLEV = 36 LEVIF = 1 INCLEV = LEVIF - JCCLEV IF (INCLEV.EQ.LEVAN) GO TO 25 IF (LEVAN.EQ.7) THEN LEVAN = INCLEV GO TO 25 ELSE CALL M_WNIF (LEVAN-INCLEV) ENDIF GO TO 25 C------ accepted material 22 CALL M_A3NX IF (LDOAN.EQ.0) GO TO 94 IF (JCCTYP.GE.MCCSEL) GO TO 94 IF (JCCTYP.GE.MCCTRU) GO TO 24 IF (JCCTYP.LT.MCCCDE) GO TO 22 C-- handle accepted +CDE +SEQ IF (JCCTYP.NE.MCCXSQ) THEN CALL M_KRAK (1) IF (JCCBAD.NE.0) RETURN MEXAN = IOR (MEXAN,MXCCIF) IF (IAND(MCCPAR(JCCPT+1),KMD).NE.0) JCCIFV= 1 ENDIF CALL M_A3SQ IF (JCCBAD.EQ.0) GO TO 22 RETURN +SEQ, QEJECT. C-- new control 24 CALL M_KRAK (0) IF (JCCBAD.NE.0) RETURN CALL CCIFLV IF (JCCTYP.EQ.MCCELS) GO TO 26 IF (JCCTYP.EQ.MCCEND) GO TO 28 C-- handle +__IF CALL CCPROC LEVIF = LEVIF + 1 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) IF (LEVIF.GE.MAXLEV) GO TO 92 25 MEXAN = IOR (MEXAN,MXCCIF) IF (JCCTYP.EQ.MCCFAL) JCCIFV= MAX(0, 1-JCCIFV) IF (JCCIFV.EQ.0) GO TO 22 LVREND = LEVIF LVRELS = LEVIF + 1 GO TO 41 C-- handle +_ELSE, IF=xxx 26 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) LVREND = LEVIF LVRELS = LEVIF GO TO 41 C-- handle +_ENDIF 28 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) LEVIF = LEVIF - 1 IF (LEVIF.EQ.0) RETURN GO TO 22 C------ rejected material 41 MBUSE = KM5 42 IQ(LDOAN) = IOR (IQ(LDOAN), MBUSE) MBUSE = KM6 CALL M_A3NX IF (LDOAN.EQ.0) GO TO 94 IF (JCCTYP.GE.MCCSEL) GO TO 94 IF (JCCTYP.LT.MCCTRU) GO TO 42 C-- new control CALL M_KRAK (0) IF (JCCBAD.NE.0) RETURN CALL CCIFLV IF (JCCTYP.EQ.MCCELS) GO TO 46 IF (JCCTYP.EQ.MCCEND) GO TO 48 C-- handle +__IF LEVIF = LEVIF + 1 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) IF (LEVIF.GE.MAXLEV) GO TO 92 GO TO 42 C-- handle +_ELSE, IF=xxx 46 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) IF (LEVIF.GE.LVRELS) GO TO 42 CALL CCPROC MEXAN = IOR (MEXAN,MXCCIF) IF (JCCIFV.NE.0) GO TO 41 GO TO 22 C-- handle +_ENDIF 48 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) LEVIF = LEVIF - 1 IF (LEVIF.GE.LVREND) GO TO 42 IF (LEVIF.EQ.0) RETURN GO TO 22 C----- Trouble 94 CALL FAILCC (1, 'Non-terminated +_IF') IFSTEP = 0 RETURN 93 IF (JCCTYP.EQ.MCCEND) THEN CALL FAILCC (0, 'Redundant +_ENDIF') RETURN ENDIF CALL M_FAIL ('Unmatched +_ELSE') RETURN 92 CALL M_FAIL ('Maximum +_IF nesting level exceeded') RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_A3SQ. SUBROUTINE M_A3SQ C- Service routine to M_ANA3, content analysis stage 3: C- ready sequence call bank for +CDE +SEQ or +SELF,sname C- connecting the called sequences ready for use. C- Return IQUEST(1) zero except for +SELF, sname with C- sequence sname existing, when the default self material C- has to be ignored. C. started 15-dec-91 +CDE, QBITS19, CCTYPE, CCPARA, INCLC, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. C-- MODEAN = 0 ordinary self 1 IF-conditional self C-- 2 +SELF,sname (3 +REPL,+ADB,+ADD) ICODE = 0 IF (JCCTYP.EQ.MCCXSQ) GO TO 37 IF (JCCIFV.NE.0) THEN IQ(LDOAN) = IOR (IQ(LDOAN), KM5) IQUEST(1) = 1 RETURN ENDIF IF (JCCTYP.LE.MCCINC) GO TO 61 LOSTNZ = 0 IF (MODEAN.NE.2) GO TO 31 C---- handle +SELF, sname C- - if self material of this deck: C- "sname" exists: replace PREP bank by a new XSQ bank C- not existing: change type of the PREP bank to MCCSEL C- C- - if material into this deck: C- the MAT bank is already a XSQ C- "sname" exists: use it C- not existing: change type of the PREP bank to MCCSEL IF (LUPAN.NE.0) THEN IXSQ = IQ(LDOAN+5) ELSE IXSQ = MCCPAR(JCCPZ+1) ENDIF KP = LEXP - 3 KD = 0 IF (LEXD.NE.0) KD= LEXD-3 CALL LOCSEQ (L, IXSQ,KP,KD) IF (L.EQ.0) GO TO 49 C-- sequence exists ICODE = 7 +SEQ, QEJECT, N=17. C---- lift XSQ bank to replace the PREP bank C- LIFTSQ (kjoin, cc-type to be stored, C- JSL of line to be cracked if non-zero, division) 31 IF (LUPAN.NE.0) GO TO 37 LSQ = LIFTSQ (KDOAN, JCCTYP, 0,2) LOSTNZ = IQUEST(1) LQ(LSQ-1) = LQ(LDOAN-1) IQ(LSQ) = IOR (IQ(LSQ), IAND(IQ(LDOAN),KM5-1)) IQ(LSQ+1) = IQ(LDOAN+1) IQ(LSQ+2) = 1 IQ(LSQ+3) = IQ(LDOAN+1) - JSLORG LDOAN = LSQ IF (LOSTNZ.NE.0) GO TO 39 C-- connect all sequences called 37 MX = LINKSQ (LDOAN,0) MEXAN = IOR (MEXAN,MX) IQUEST(1) = ICODE RETURN C---- Trouble 39 CALL M_FAIL ('More than 61 sequence calls on this line') RETURN C---- sequence not defined, convert to ordinary +SELF 49 CALL SBYT (MCCSEL, IQ(LDOAN),9,6) IQUEST(1) = 0 RETURN C------ Handle +INCLUDE, sname 61 IF (JCCTYP.EQ.MCCKIL) RETURN 62 IXSQ = MCCPAR(JCCPZ+1) IF (N_INCL.GE.100) GO TO 66 N_INCL = N_INCL + 1 IX_INCL(N_INCL) = IXSQ LINCL = LQFIND (IXSQ,1,LQINCL) IF (LINCL.EQ.0) GO TO 66 MEXAN = IOR (MEXAN,IQ(LINCL)) IF (IAND(IQ(LINCL),KM5).EQ.0) GO TO 67 66 NEWINC = 1 67 JCCPZ = JCCPZ + 3 NCCPZ = NCCPZ - 1 IF (NCCPZ.GT.0) GO TO 62 RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_A3NX. SUBROUTINE M_A3NX C- Service routine to M_ANA3, content analysis stage 3: C- step to next non-deleted bank, set JCCTYP C- activating delayed control lines now used in self material. C. started 26-nov-91 +CDE, QBITS19, CCTYPE, CCPARA, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- PARAMETER (MASKTY=KM9+KM10+KM11+KM12+KM13+KM14) +SEQ, Q_JBYT, Q_AND, Q_OR, Q_NOT, Q_SHIFTL. +SEQ, xM_ANAC, IF=DOC_INL. C------ Next PREP bank IF (LUPAN.NE.0) GO TO 34 22 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) IF (LDOAN.EQ.0) RETURN IF (IAND(IQ(LDOAN),KM5+KM6).NE.0) GO TO 22 C-- next live PREP bank L = LQ(LDOAN-2) IF (L.NE.0) GO TO 31 JCCTYP = JBYT (IQ(LDOAN),9,6) RETURN +SEQ, QEJECT, N=56 C---- Follow reference to foreign material 31 LOWAN = LDOAN LUPAN = L LDOAN = LUPAN - 1 C------ Next MAT bank 34 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) IF (LDOAN.EQ.0) THEN C-- end of chain of MAT banks LDOAN = LOWAN LUPAN = 0 GO TO 22 ENDIF JCCTYP = JBYT (IQ(LDOAN),9,6) IF (MOPUPD.LT.0) GO TO 61 C! IF (MODEAN.EQ.4) RETURN C-- activate delayed c/l now used in self or KEEP material IF (IAND(IQ(LDOAN),KM15).EQ.0) RETURN JSLA = IQ(LDOAN+1) JTX = MLIAD(JSLA) TEXT(JTX) = '+' JTYPE = JPTYPE(TEXT(JTX)) IF (MOPUPD.NE.0) THEN IF (JTYPE.LT.MCCSEL) RETURN ENDIF JCCTYP = JTYPE IQ(LDOAN) = IOR (IQ(LDOAN),ISHFTL(JCCTYP,8)) RETURN C-- +PAM, T=UP update mode 61 IF (JCCTYP.EQ.0) GO TO 62 IF (JCCTYP.EQ.MCCXSQ) RETURN JCCTYP = 0 IQ(LDOAN) = IAND (IQ(LDOAN),NOT(MASKTY)) 62 JSLA = IQ(LDOAN+1) JSLE = IQ(LDOAN+2) + JSLA 64 CALL NEXTCC ('-',JSLA,JSLE,JSLF,JTYPE) IF (JTYPE.EQ.0) RETURN JTX = MLIAD(JSLF) TEXT(JTX) = '+' JSLA = JSLF + 1 IF (JSLA.LT.JSLE) GO TO 64 RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_A3KE. SUBROUTINE M_A3KE C- Content analysis stage 3: C- scan the material of the +KEEP being defined C- return JCCBAD non-zero to signal c/line with syntax error at LDOAN C. started 8-dec-93 +CDE, CCTYPE, CCPARA. +CDE, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- MAXLEV = 36 LEVIF = 0 22 CALL M_A3NX IF (LDOAN.EQ.0) GO TO 49 IF (JCCTYP.GE.MCCSEL) GO TO 49 IF (JCCTYP.LT.MCCCDE) GO TO 22 IF (JCCTYP.EQ.MCCXSQ) GO TO 22 CALL M_KRAK (0) IF (JCCBAD.NE.0) RETURN IF (JCCTYP.LT.MCCTRU) GO TO 22 C-- new control CALL CCIFLV IF (JCCTYP.EQ.MCCELS) GO TO 26 IF (JCCTYP.EQ.MCCEND) GO TO 28 C-- handle +__IF LEVIF = LEVIF + 1 IF (LEVIF.GE.2) GO TO 24 INCLEV = LEVIF - JCCLEV IF (INCLEV.EQ.LEVAN) GO TO 22 IF (LEVAN.EQ.7) THEN LEVAN = INCLEV ELSE CALL M_WNIF (LEVAN-INCLEV) ENDIF GO TO 22 24 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) IF (LEVIF.GE.MAXLEV) GO TO 91 GO TO 22 C-- handle +_ELSE, IF=xxx 26 IF (LEVIF.EQ.0) GO TO 92 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) GO TO 22 C-- handle +_ENDIF 28 IF (LEVIF.EQ.0) GO TO 93 N = JCCLEV+INCLEV - LEVIF IF (N.NE.0) CALL M_WNIF (N) LEVIF = LEVIF - 1 GO TO 22 +SEQ, QEJECT. C---- Done 49 IF (LEVIF.EQ.0) RETURN C----- Trouble CALL FAILCC (1, 'Non-terminated +_IF') RETURN 93 CALL FAILCC (0, 'Redundant +_ENDIF') GO TO 22 92 CALL M_FAIL ('Unmatched +_ELSE') RETURN 91 CALL M_FAIL ('Maximum +_IF nesting level exceeded') RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_A3AC. SUBROUTINE M_A3AC C- Content analysis stage 3: C- scan the material of the +REPL etc being defined C- return JCCBAD non-zero to signal c/line with syntax error at LDOAN C. started 8-dec-93 +CDE, CCTYPE, CCPARA. +CDE, Q. +CDE, M_ANAC. C-------------- End CDE -------------------------------- 22 CALL M_A3NX IF (LDOAN.EQ.0) RETURN IF (JCCTYP.GE.MCCSEL) RETURN IF (JCCTYP.LT.MCCKIL) GO TO 22 IF (JCCTYP.EQ.MCCXSQ) GO TO 22 CALL M_KRAK (0) IF (JCCBAD.NE.0) RETURN GO TO 22 C! C!- check delayed control-cards for +REPL +ADB +ADD C! C! 78 JSLA = IQ(LDOAN+1) C! JSLE = JSLA + IQ(LDOAN+2) C! JSLG = JSLA C! 79 IF (JSLG.GE.JSLE) GO TO 77 C! CALL NEXTCC ('-',JSLG,JSLE,JSLF,JCCTYP) C! IF (JCCTYP.EQ.0) GO TO 77 C! JSLG = JSLF + 1 C! IF (JCCTYP.EQ.MCCNIL) GO TO 79 C! CALL CCKRAK (JSLF) C! IF (JCCBAD.EQ.0) GO TO 79 C! IF (JSLF.NE.JSLA) LDOAN = M_SPLIT (LDOAN,JSLF) C! CALL FAILCC (1, 'Bad syntax for delayed c/l') C! GO TO 79 END +SEQ, QCARDL. ===================================================== +DECK, M_SPLIT. FUNCTION M_SPLIT (LDO,JSLN) C- Split PREP bank in division 2 into two: C- if JSLN not zero: scan the linear structure of PREP banks C- starting at LDO to find the bank which supports the line C- at slot JSLN; if this is not the first line split this C- bank into two to make JSLN the first line in the new bank; C- return the adr of the bank with JSLN, or zero if not found. C- if JSLN is zero: split the bank at LDO leaving zero lines C- in the old bank, transfer the properties of the old to the C- new bank; return the adr of the new bank. C# started 11-nov-91 +CDE, QBITS19, QBANKS. +CDE, QSH. C-------------- End CDE -------------------------------- L = LDO IF (JSLN.EQ.0) GO TO 41 GO TO 22 21 L = LQ(L-1) IF (L.EQ.0) GO TO 49 22 JSLA = IQ(L+1) JSLE = IQ(L+2) + JSLA IF (JSLN.GE.JSLE) GO TO 21 IF (JSLN.EQ.JSLA) GO TO 49 +SELF, IF=QDEBUG. IF (JSLN.LT.JSLA) CALL P_CRASH ('trouble in M_SPLIT') +SELF. NSLA = JSLN - JSLA NSLN = JSLE - JSLN CALL MQLIFT (LX,L,-1,JBKPRE,2) IQ(L+2) = NSLA L = LX IQ(L+1) = JSLN IQ(L+2) = NSLN GO TO 49 C-- split on first line with transfer of properties C- (to insert a zero-line PREP reference to ACT for +REPL etc) 41 CALL MQLIFT (LX,L,-1,JBKPRE,2) IQ(LX) = IQ(L) IQ(LX+1) = IQ(L+1) IQ(LX+2) = IQ(L+2) IQ(L+2) = 0 L = LX 49 M_SPLIT = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_KRAK. SUBROUTINE M_KRAK (IFPROC) C- Crack control line at LDOAN for M_ANA3 and M_A3IF; C- do not/do the IF= evaluation if IFPROC = 0/1 C- if faulty control found: C- change c/c type to FAULTY and print the line C. started 29-nov-93 +CDE, CCPARA, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- CALL CCKRAK (IQ(LDOAN+1)) IF (JCCBAD.NE.0) GO TO 41 IF (IFPROC.NE.0) THEN IF (NCCPIF.NE.0) CALL CCPROC ENDIF IF (JCCWAR.EQ.0) RETURN C: DATA CHWA( 1) /'obsured dot in control line'/ C: DATA CHWA( 2) /'control line ends on comma'/ IF (JCCWAR.EQ.1) THEN IF (MOPTIO(2).NE.0) RETURN CALL FAILCC (0, 'obsured dot in control line') ELSE CALL FAILCC (0, 'control line ends on comma') ENDIF RETURN C-- faulty c/line 41 CALL M_FAIL ('Syntax error') RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_FAIL. SUBROUTINE M_FAIL (MSG) C- Faulty control found with M_ANA3: C- print the line, change c/c type to FAULTY, set JCCBAD C. started 29-nov-93 +CDE, QBITS19, CCTYPE, CCPARA, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) +SEQ, Q_OR. CALL FAILCC (1,MSG) CALL SBYT (MCCFAU, IQ(LDOAN),9,6) IQ(LDOAN) = IOR (IQ(LDOAN),KM5) JCCBAD = 7 RETURN END +SEQ, QCARDL. ===================================================== +DECK, M_WNIF, T=JOIN. SUBROUTINE M_WNIF (NU) C- Print warning for wrong number of underscores C. started 9-dec-91 CHARACTER MSG*22 DATA MSG /' 0 underscore too many'/ C- DATA MSG /' 0 underscore missing '/ C- _:.=+=.: 1_:.=+=.: 2_:.= CALL DPHEAD N = NU IF (N.LT.0) THEN N = -N MSG(15:22) = 'missing ' ELSE MSG(15:22) = 'too many' ENDIF MSG(1:2) = ' ' CALL CSETDI (N,MSG,1,2) CALL FAILCC (0,MSG) END +SEQ, QCARDL. ===================================================== +DECK, MK_NIL. SUBROUTINE MK_NIL C- Store NIL sequences or actions into division 1 to carry the C- EXE bits of deleted material to the deck where it would have C- appeared. For this we have to scan the de-selected PREP banks. C. started 9-dec-91 +CDE, QBITA19, QBANKS, CCTYPE, CCPARA, MUSEBC. +CDE, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT, Q_AND, Q_OR, Q_NOT, Q_SHIFTL. LDO = KQPREP + 1 C------ Find next deleted foreign material 21 LDO = LQ(LDO-1) IF (LDO.EQ.0) RETURN IF (IQ(LDO+2).EQ.0) GO TO 21 IF (IAND(IQ(LDO),KM5+KM6).EQ.0) GO TO 21 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.LT.MCCKEE) GO TO 21 IF (JCCTYP.GE.MCCUSE) GO TO 21 CALL CCKRAK (IQ(LDO+1)) IF (JCCBAD.NE.0) GO TO 21 MEXACT = IAND (IQ(LDO),15) IF (JCCTYP.NE.MCCKEE) GO TO 41 +SEQ, QEJECT, N=32. C---------- Handle +KEEP -------------------- IF (IAND(MCCPAR(JCCPT+1),KMD).NE.0) GO TO 21 IF (IAND(MEXACT,NOT(MU_GLOB)).EQ.0) GO TO 21 C-- inquire existence, get the attachment adr if not pre-existing 34 CALL LOCKEEP (LSQ) IF (LSQ.NE.0) GO TO 21 KACT = IQUEST(1) LPD = IQUEST(11) IF (LPD.NE.0) THEN IF (IAND(MEXACT,NOT(IQ(LPD))).EQ.0) GO TO 21 ENDIF C-- lift the KEEP bank IF (LDECO.EQ.0) CALL CRDECO CALL MQLIFT (LACT,KACT,0,JBKKEE,1) IQ(LACT) = IOR (IQ(LACT), MEXACT+KM12) LQ(LACT-3) = LDECO IQ(LACT+3) = IQ(LDO+1) - JSLORG IQ(LACT+4) = MCCPAR(JCCPZ+1) GO TO 21 C---------- Handle +DEL +REPL +ADB +ADD -------------------- 41 LPD = LQ(LDO-3) IF (LPD.EQ.0) GO TO 21 IF (LPD.EQ.LEXD) GO TO 21 IF (IAND(MEXACT,NOT(IQ(LPD))).EQ.0) GO TO 21 JACT = JCCTYP - MCCDEL C-- lift the ACT bank IF (LDECO.EQ.0) CALL CRDECO 47 CALL MQLIFT (LACT,LPD,-2,JBKACT,1) IQ(LACT) = IOR (IQ(LACT), MEXACT+KM12) IQ(LACT) = IOR (IQ(LACT), ISHFTL(JACT,8)) LQ(LACT-3) = LDECO IQ(LACT+3) = IQ(LDO+1) - JSLORG IQ(LACT+4) = MCCPAR(JCCPC+1) IQ(LACT+5) = MCCPAR(JCCPC+2) IF (JCCTYP.EQ.MCCDEL) GO TO 48 C-- check whether the action starts with ordinary material JSLF = IQ(LDO+1) + 1 JTXF = MLIAD(JSLF) IF (TEXT(JTXF).NE.'-') GO TO 21 IF (JPTYPE(TEXT(JTXF)).LT.MCCSEL) GO TO 21 IQ(LACT) = IOR (IQ(LACT), KM16) GO TO 21 C-- handle multiple deletes 48 IQ(LACT) = IOR (IQ(LACT), KM16) NCCPC = NCCPC - 1 IF (NCCPC.EQ.0) GO TO 21 JCCPC = JCCPC + 3 GO TO 47 END +SEQ, QCARDL. ===================================================== +PATCH, DOXQT. Output control for the current deck +DECK, DOXQT. SUBROUTINE DOXQT C- Execute the material according to the map C. started 16-jan-92 +CDE, QBITS31, QUNIT. +CDE, CCTYPE, CCPARA, CHEXC, DEPCOM, MUSEBC. +CDE, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- PARAMETER (MASKCL=KM12+KM13+KM14+KM15) +SEQ, Q_JBYT, Q_AND. +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: arriving in DOXQT' +SELF, IF=XDEBUG, IF=XDDSNAP. CALL DDSNAP ('start of DOXQT',0,2) +SELF. C! NDONE = -1 LUPAN = 0 LDOAN = KQPREP + 1 C---- Next bank 20 MODEAN = 0 21 CALL X_NEXT C! NDONE = NDONE + 1 22 IF (LDOAN.EQ.0) GO TO 87 +SEQ, QEJECT. C-- MODEAN = 0 self material C- 1 CDE expansion C- 2 comment line C- 3 +SELF header line C- 4 +CDE call line C- 5 foreign material C- 6 control line JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.GE.MCCKEE) GO TO 51 IF (JCCTYP.EQ.MCCKIL) GO TO 51 C---------- Self material ---------------- IF (NVEXDK(5).EQ.0) GO TO 21 KKM5AN = IAND(IQ(LDOAN),KM5) IF (JCCTYP.EQ.0) GO TO 35 IF (JCCTYP.EQ.MCCNIL) GO TO 39 IF (JCCTYP.LE.MCCINC) GO TO 56 IF (JCCTYP.LE.MCCXSQ) GO TO 36 IF (JCCTYP.LT.MCCSEL) GO TO 35 C-- to here +SELF, +SKIP and fault IF (JCCTYP.EQ.MCCSES) GO TO 37 MODEAN = 3 C-- to here +_IF etc 35 IF (NVEXDK(2).NE.0) THEN CALL DPLIST (MODEAN,LDOAN,LUPAN,0) ENDIF IF (NVEXDK(1).EQ.0) GO TO 20 IF (KKM5AN.NE.0) GO TO 20 CALL DPEXE (LDOAN) GO TO 20 C-- sequence call 36 IF (JCCTYP.EQ.MCCXSQ) GO TO 38 37 IF (NVEXDK(6).NE.0) THEN MODEAN = 4 CALL DPLIST (MODEAN,LDOAN,LUPAN,0) ENDIF 38 IF (KKM5AN.NE.0) GO TO 20 MODEAN = 1 CALL X_SEQ (LDOAN) GO TO 20 C-- comment line 39 IF (NVEXDK(6).EQ.0) GO TO 21 CALL DPLIST (2,LDOAN,LUPAN,1) GO TO 21 C---------- New foreign material -------------- 51 KKM5AN = IAND(IQ(LDOAN),KM5) IF (JCCTYP.GE.MCCUSE) GO TO 56 IF (JCCTYP.LT.MCCKEE) GO TO 56 MODEAN = 5 IF (NVEXDK(2).NE.0) CALL DPLIST (MODEAN,LDOAN,LUPAN,1) CALL DOFORG (NSTEP) MODEAN = 0 IF (NSTEP.EQ.0) GO TO 22 GO TO 21 C---------- Lines +DECK or +PATCH -------------- 56 MODEAN = 6 CALL CCKRAK (IQ(LDOAN+1)) IF (NVEXDK(6).NE.0) THEN CALL DPLIST (MODEAN,LDOAN,LUPAN,1) IF (JCCTYP.GE.MCCPAT) NQLPAT = NQUSED ENDIF IF (KKM5AN.NE.0) GO TO 20 IF (JCCTYP.LT.MCCDEC) GO TO 61 C! IF (NDONE.EQ.0) GO TO 20 IF (NVEXDK(1).EQ.0) GO TO 20 IF (JD_NEW.EQ.0) CALL DPEXTM (1) JASM = JBYT (IQ(LDOAN),21,6) IF (JCCTYP.EQ.MCCPAT) THEN IXEXID = MCCPAR(JCCPP+1) JD_DTN = MAX (JASM,1) JD_DTP = JD_DTN ELSEIF (JCCTYP.EQ.MCCDEC) THEN IXEXID = MCCPAR(JCCPD+1) JD_DTN = JASM IF (JD_DTN.EQ.0) JD_DTN= JD_DTP ENDIF GO TO 20 +SEQ, QEJECT. C---------- Control lines +USE etc --------------- 61 IF (JCCTYP.GE.MCCUSE) GO TO 64 C-- Do : +INCLUDE IF (JCCTYP.EQ.MCCINC) THEN CALL X_INCL (0) GO TO 20 ENDIF C-- Do : +KILL CALL P_FATAL (CCKORG(1:NCHCCT)) C-- Done : +USE etc if not in CRA* 64 IF (JCCTYP.LE.MCCEXE) THEN IF (INCRAD.LT.2) GO TO 20 C-- Do : +USE +EXE +LIST +DIVERT +XDIV CALL X_USE GO TO 20 ENDIF C-- Do : +IMITATE IF (JCCTYP.EQ.MCCIMI) THEN CALL X_IMIT GO TO 20 ENDIF C-- Do : +ASM IF (JCCTYP.EQ.MCCASM) THEN CALL X_ASM GO TO 20 ENDIF C-- Done : +UPDATE +NAMES +GAPS +MORE IF (JCCTYP.LE.MCCMOR) GO TO 20 C!- Do : +ONLY C! C! IF (JCCTYP.EQ.MCCONL) THEN C! CALL X_ONLY (LDOAN) C! GO TO 20 C! ENDIF C-- Do : +FORCE +SUSPEND IF (JCCTYP.LE.MCCSUS) THEN CALL X_USE GO TO 20 ENDIF C-- Do : +OPTION +PARAMETER +SHOW IF (JCCTYP.LE.MCCSHO) THEN CALL X_OPT GO TO 20 ENDIF +SELF, IF=QDEBUG. CALL P_CRASH ('DOXQT should not reach this point') +SELF. C---- Done 87 CONTINUE +SELF, IF=XDEBUG, IF=XDDSNAP. PRINT *, 'Xdebug: deck processing complete, dump the result' IF (NEWFOR.EQ.0) RETURN CALL DDSNAP ('end of DOXQT',-1,1) C! CALL DDSNAP ('end of DOXQT',-1,3) +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, X_NEXT. SUBROUTINE X_NEXT C- Step to next bank in the PREP chain for DOXQT C. started 18-nov-93 +CDE, QBITS19, Q. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_AND. IF (LUPAN.NE.0) GO TO 34 22 LDOAN = LQ(LDOAN-1) IF (LDOAN.EQ.0) RETURN C-- next PREP bank L = LQ(LDOAN-2) IF (L.NE.0) GO TO 31 IF (IAND(IQ(LDOAN),KM6).NE.0) GO TO 22 RETURN C---- Follow reference to foreign material 31 LOWAN = LDOAN LUPAN = L C-- list what action CALL DPLACT IF (IAND(IQ(LDOAN),KM6).NE.0) GO TO 37 C-- Next MAT bank LDOAN = LUPAN - 1 34 LDOAN = LQ(LDOAN-1) IF (LDOAN.EQ.0) GO TO 37 IF (IAND(IQ(LDOAN),KM6).NE.0) GO TO 34 RETURN C-- restart on the PREP chain 37 LDOAN = LOWAN LUPAN = 0 GO TO 22 END +SEQ, QCARDL. ===================================================== +DECK, X_SEQ. SUBROUTINE X_SEQ (LXQT) C- Send the sequences called from bank LXQT to output. C. started 21-jan-92 +CDE, QBITS19, CCTYPE, CCPARA, MUSEBC, TAGC. +CDE, Q, PY. C-------------- End CDE -------------------------------- PARAMETER (NOFFLI=2, NOFFDA=4) PARAMETER (MAXLEV=36) COMMON /MSAVEC/ MSAVE(5,MAXLEV) +SEQ, Q_JBYT, Q_AND. IFLNHI = 0 IFLNOL = 1 - NVEXDK(2) LEVK = 0 LCSQ = LXQT LNACT = 0 LLACT = 0 C---- New XSQ bank 21 JSEQ = 0 NSEQ = IQ(LCSQ+NOFFDA) IFLPAS = IAND (IQ(LCSQ),KM16) 22 JSEQ = JSEQ + 1 IF (JSEQ.GT.NSEQ) GO TO 37 IXSEQ = IQ(LCSQ+JSEQ+NOFFDA) LKEEP = IABS (LQ(LCSQ-JSEQ-NOFFLI)) IF (LKEEP.NE.0) GO TO 24 C-- missing sequence IF (IFLPAS.NE.0) GO TO 22 CALL DPLMSQ (IXSEQ) GO TO 22 +SEQ, QEJECT. C-- Output of the KEEP bank itself 24 IF (NVEXDK(2).NE.0) IFLNOL= MAX (IFLNHI, IAND (IQ(LKEEP),KM16)) C-- ready special sequence IF (IAND(IQ(LKEEP),KM13).NE.0) THEN CALL X_SEQSP (IQ(LCSQ+1), IXSEQ, IFSEND) IF (IFSEND.EQ.0) GO TO 22 GO TO 25 ENDIF C-- be sure the sequence is ready for output IF (IAND(IQ(LKEEP),KM5).EQ.0) MX= LINKSQ (0,LKEEP) 25 JCCTYP = 0 IF (IFLNOL.EQ.0) THEN LLORG = 0 LNORG = LQ(LKEEP-3) CALL DPTAG (2,LEVK,IXSEQ) IF (IQ(LKEEP+2).NE.0) GO TO 27 LNX = LQ(LKEEP-2) IF (LNX.EQ.0) THEN NCHTAG = 0 GO TO 22 ENDIF IF (LQ(LNX-2).EQ.LLORG) THEN IFLST = LEVK+1 GO TO 28 ENDIF 27 IFLST = 0 CALL DPLIST (1,LKEEP,0,LEVK+1) ENDIF IF (NVEXDK(1).NE.0) CALL DPEXE (LKEEP) C-- Output of continuation MAT banks 28 LDO = LKEEP - 1 29 LDO = LQ(LDO-1) IF (LDO.EQ.0) GO TO 22 IF (IFLNOL.EQ.0) THEN LNORG = LQ(LDO-2) LVINC = JBYT(IQ(LDO),21,5) IF (LVINC.EQ.0) THEN IF (IFLST.EQ.0) CALL DPTAG (2,LEVK,0) ELSE IF (LNORG.NE.LLORG) THEN CALL DPTAG (0,LEVK+LVINC,0) ENDIF ENDIF CALL DPLIST (1,LDO,0,IFLST) IFLST = 0 ENDIF JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.GE.MCCCDE) GO TO 31 IF (NVEXDK(1).EQ.0) GO TO 29 IF (JCCTYP.EQ.MCCINC) GO TO 30 IF (JCCTYP.NE.0) GO TO 29 CALL DPEXE (LDO) GO TO 29 30 CALL X_INCL (LDO) GO TO 29 C---- new sequence call bank, step level up by one 31 LEVK = LEVK + 1 MSAVE(1,LEVK) = LCSQ MSAVE(2,LEVK) = LDO MSAVE(3,LEVK) = JSEQ MSAVE(4,LEVK) = IFLNHI MSAVE(5,LEVK) = IFLNOL IFLNHI = IFLNOL LCSQ = LDO GO TO 21 C---- end of doing this sequence call bank, step level down 37 IF (LEVK.EQ.0) GO TO 39 LCSQ = MSAVE(1,LEVK) LDO = MSAVE(2,LEVK) JSEQ = MSAVE(3,LEVK) IFLNHI = MSAVE(4,LEVK) IFLNOL = MSAVE(5,LEVK) LEVK = LEVK - 1 NSEQ = IQ(LCSQ+NOFFDA) IFLPAS = IAND (IQ(LCSQ),KM16) GO TO 29 39 NCHTAG = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, X_SEQSP. SUBROUTINE X_SEQSP (JSL,IXSEQ,IFSEND) C- Ready special sequence called C- input: JSL slot number of the calling control-line C- IXSEQ sequence name index C- output: IFSEND = 0 no output to be sent C- > 0 output C. split off from X_SEQ 23-aug-95 +CDE, SLATE, SLATLN, QCHAR, QPAGE, QUNIT, QSTATE. +CDE, CCPARA, CHEXC, DEPCOM, JSPSEQ, MUSEBC. +CDE, TITLEC, USETTC. +CDE, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*128, LIMSK*128, LITIT*128, CHESC*1 EQUIVALENCE (LINE,TEXT), (LIMSK,CCCOMF), (LITIT,SLERRM) +SEQ, xJSPSEQ, IF=DOC_INL. +SEQ, QEJECT. JTX = MLIAD(JSL) JCCTYP = JPTYPE (TEXT(JTX)) CALL CCKRAK (JSL) NNN = MCCPAR(JCCPN+1) LLL = MCCPAR(JCCPC+1) JCASE = IXSEQ - JSPSEQ1 - 1 IF (JCASE.GE.1) GO TO 51 IF (JCASE.EQ.0) GO TO 44 C-- handle +SEQ, QCARD1, R=name IF (JCCPD.EQ.0) GO TO 49 IX = MCCPAR(JCCPD+1) IF (IX.LE.2) GO TO 49 IF (NVEXDK(1).NE.0) THEN IF (JD_NEW.EQ.0) CALL DPEXTM (-1) ENDIF IXEXID = IX GO TO 49 C-- handle +SEQ, QEJECT, N=n 44 IF (NVEXDK(2).EQ.0) GO TO 49 IF (MOPTIO(5).EQ.0) GO TO 49 IF (MOPTIO(3).NE.0) GO TO 49 IF (NNN.LT.0) NNN = NQLMAX IF (NNN.EQ.0) NNN = NQLMAX - 6 IF (NQUSED+NNN.LE.NQLMAX) GO TO 49 NQUSED = NQLMAX 49 IFSEND = 0 RETURN C------ handle +SEQ, QFxxx, QDATE, QTIME 51 CHESC = '?' C---- ready LIMSK, the mask line, C-- for QFTITLE and QFTITLCH IF (JCASE.GE.3) GO TO 53 IF (JCASE.EQ.1) THEN LIMSK = ' + 8H' ELSE LIMSK = ' + ' // CQAPO ENDIF NMSK = LNBLNK (LIMSK(1:12)) LLL = MAX (NNN,LLL) IF (LLL.LE.0) LLL= 8 NNN = 0 GO TO 54 C-- for all others 53 CALL CCCOMG (0) NMSK = NCHCCC IF (NMSK.LE.0) GO TO 49 IF (JCASE.EQ.11) GO TO 76 IF (JCCPP.NE.0) THEN JTX = NA_JTX (MCCPAR(JCCPP+1)) CHESC = TEXT(JTX) ENDIF C-- find the escape symbol 54 LINE = LIMSK(1:NMSK) JESC = ICFIND (CHESC,LIMSK,1,NMSK) NAFT = NMSK - JESC IF (JCASE.GE.JSPDATE) GO TO 81 +SEQ, QEJECT. C---- ready the PAM file title JFILE = NFILET IF (NNN.GT.0) JFILE= NNN IF (NNN.LT.0) JFILE= MAX (1,NFILET+NNN) JFILE = MIN (JFILE,NFILET) JSL = 0 IF (JFILE.GT.0) JSL = JTIPAM(JFILE) CALL USETT (JSL) IF (JCASE.GE.4) GO TO 71 GO TO (61,63,65), JCASE C-- QFTITLE gives: +nnHWYLBUR 1.21 /77 930630 22.01 61 LLL = MIN (LLL,62) CALL CSETDI (LLL,LINE,8,9) LINE(11:10+LLL) = LITIT(1:LLL) LINE(77:80) = 'HOLD' NFIN = 80 GO TO 89 C-- QFTITLCH gives: + 'WYLBUR 1.21 /77 930630 22.01' 63 LLL = MIN (LLL,62) LINE(10:10+LLL) = LITIT(1:LLL) // CQAPO NFIN = 10+LLL GO TO 89 C-- QFHEAD gives: txb"WYLBUR 1.21 /77 930630 22.01"txa 65 IF (LLL.LE.0) LLL= NTTNORM LLL = MIN (LLL,NTTALL) LINE(JESC:JESC+LLL-1) = LITIT(1:LLL) NFIN = JESC+LLL-1 GO TO 88 C-- 4 QFNAME gives: txb"WYLBUR"txa C-- 5 QFVERS gives: txb"1.21 /77"txa C-- 6 QFVSNUM gives: txb"12177"txa C-- 7 QFVPRIM gives: txb"1.21"txa C-- 8 QFVSEC gives: txb"77"txa 71 JNA = JCASE - 3 IF (LLL.LE.0) LLL= NTTNA(JNA) LLL = MIN (LLL,NTTNA(JNA)) LINE(JESC:JESC+LLL-1) = CHTTNA(JNA)(1:LLL) NFIN = JESC+LLL-1 GO TO 88 C---- QENVIR gives text with substitution 76 CALL CENVIR (LIMSK,NMSK, LINE,1,256, 1) NFIN = NDSLAT GO TO 89 C---- QDATE gives: txb"19930802"txa 81 IF (JCASE.NE.JSPDATE) GO TO 83 LLL = LEN(CQDATE) LINE(JESC:JESC+LLL-1) = CQDATE NFIN = JESC+LLL-1 GO TO 88 C-- QTIME gives: txb"1107"txa 83 LINE(JESC:JESC+3) = CQTIME(1:2) // CQTIME(4:5) NFIN = JESC+3 C-- set the "after" text 88 IF (NAFT.GT.0) THEN LINE(NFIN+1:NFIN+NAFT)= LIMSK(JESC+1:JESC+NAFT) NFIN = NFIN + NAFT ENDIF C-- finalize the line in slot 1 89 JTX = NFIN + 1 +SELF, IF=QNEWLINE. TEXT(JTX) = CHAR (NEWLN) JTX = JTX + 1 +SELF. MLIAD(2) = JTX IFSEND = 7 RETURN END +SEQ, QCARDL. ===================================================== +DECK, X_ASM. SUBROUTINE X_ASM C- Analyse the current control line +ASM, ... C. started 23-jan-92 +CDE, SLATE, SLATLN, QBITS19. +CDE, CCPARA, LUNSLN, FLINKC, CM_TYP. +CDE, Q, PY. C-------------- End CDE -------------------------------- CHARACTER CCOL(256)*1, MSG*56, SLCOL(512)*1 EQUIVALENCE (CCOL,CCKARD), (MSG,SLERRM), (SLCOL,SLLINE) PARAMETER (KXBY=KM1, KXAT=KM2, KXSP=KM3, KXMO=KM4, KXAL=KM5, + KXBI=KM6, KXUS=KM7, KXEX=KM8, KXSU=KM9, KXRH=KM10, + KXPR=KM11, KXLO=KM12, KXRE=KM13) PARAMETER (NPOSS = 13) CHARACTER POSS(NPOSS)*8 DATA POSS / 'BY*PASS ' +, 'A*TTACH ' +, 'SPL*IT ' +, 'MOD*IFY ' +, 'ALI*AS ' +, 'BIN*D ' +, 'USE*D ' +, 'EXT*EN* ' +, 'CCH*SUBS' +, 'RH*EADER' +, 'PRE*FIX ' +, 'LOG ' +, 'REA*SSIG' / C- for +ASM, types, T=BYPASS C- +ASM, type, T=REASSIGN, S=type C- +ASM, types, T=ATTACH .fname C- +ASM, types, T=SPLIT C- +ASM, types, T=SPLIT, PREFIX .work/new_ C- +ASM, types, T=SPLIT, LOG .fname C- +ASM, types, T=SPLIT, PREFIX, LOG .work/fname C- +ASM, types, T=MODIF C- +ASM, types, T=MODIF, PREFIX .work/new_ C- +ASM, types, T=MODIF, LOG .fname C- +ASM, types, T=MODIF, PREFIX, LOG .work/fname C- +ASM, types, T=ALIAS C- +ASM, types, T=BIND C- +ASM, types, T=USED C- +ASM, types, T=EXTENSION .tex C- +ASM, types, T=CCHSUB .&+!+ C- +ASM, types, T=RHEAD, .text +SEQ, Q_AND, Q_NOT, Q_SHIFTR. +SEQ, QEJECT. JBK_TYP = 0 +SELF, IF=BACKCOMP. MASKOP = KXBI IF (NCCPT.EQ.0) GO TO 21 +SELF, IF=-BACKCOMP. IF (NCCPT.EQ.0) GO TO 92 +SELF. CALL CCOPT (POSS,NPOSS) IF (JCCBAD.NE.0) GO TO 91 MASKOP = MCCPAR(JCCPT+2) IF (MASKOP.EQ.0) GO TO 92 C---- handle T=ALIAS IF (IAND(MASKOP,KXAL).NE.0) THEN IF (IAND(MASKOP,NOT(KXAL)).NE.0) GO TO 92 CALL ASMALIA RETURN ENDIF C-- ready all needed ASMH and ASML banks 21 CALL ASMALL IF (JCCBAD.NE.0) GO TO 91 C- this routine analyses the NCCPD parameters at JCCPD C- it creates the needed ASMT & ASML banks C- it replaces: C- MCCPAR(JCCPD+1) = JASM C- +2) = JSTRM = 0 for type:0 C- 1 type:1 C- 2 type:2 C- same for JCCPP 3 type:3 C- 4 type:4 +SELF, IF=BACKCOMP. IF (JBK_TYP.EQ.0) THEN IF (NCCPT.EQ.0) GO TO 92 ENDIF +SELF. C---- handle T=REASSIGN, S=type IF (IAND(MASKOP,KXRE).EQ.0) GO TO 24 IF (IAND(MASKOP,NOT(KXRE)).NE.0) GO TO 92 IF (NCCPP.NE.1) GO TO 91 IF (NCCPD.NE.1) GO TO 91 JASMTG = MCCPAR(JCCPP+1) JSTRTG = MCCPAR(JCCPP+2) JASM = MCCPAR(JCCPD+1) JSTR = MCCPAR(JCCPD+2) LASMT = LQ(LHASM-JASM) IF (JSTR.EQ.0) THEN JA = 1 JE = 4 ELSE JA = JSTR JE = JSTR ENDIF DO 23 JL=JA,JE JS = JSTRTG IF (JS.EQ.0) JS= JL LASML = LQ(LASMT-JL-1) 23 IQ(LASML+11) = 8*JASMTG + JS RETURN C-- parameter S= illegal except for T=REASS 24 IF (NCCPP.NE.0) GO TO 91 C---- handle T=BYPASS IF (IAND(MASKOP,KXBY).EQ.0) GO TO 27 IF (IAND(MASKOP,NOT(KXBY)).NE.0) GO TO 92 DO 26 J=1,NCCPD JASM = MCCPAR(JCCPD+1) JSTR = MCCPAR(JCCPD+2) LASML = LQ(LHASM-JASM) IF (JSTR.NE.0) LASML= LQ(LASML-JSTR-1) IQ(LASML+1) = 0 IQ(LASML+2) = 0 26 JCCPD = JCCPD + 3 RETURN C---- handle T=USED 27 IF (IAND(MASKOP,KXUS).EQ.0) GO TO 30 IF (IAND(MASKOP,NOT(KXUS)).NE.0) GO TO 92 RETURN +SEQ, QEJECT. C------ Do all but T=ALIAS, T=REASS, T=BY, T=USED C-- ready the free-field parameter in the comment field 30 CALL CCCOMG (1) 31 JASMF = MCCPAR(JCCPD+1) JSTRF = MCCPAR(JCCPD+2) LASMT = LQ(LHASM-JASMF) LASML = LASMT IF (JSTRF.NE.0) LASML= LQ(LASML-JSTRF-1) C---- handle T=ATTACH IF (IAND(MASKOP,KXAT).EQ.0) GO TO 34 IF (IAND(MASKOP,NOT(KXAT)).NE.0) GO TO 92 IF (NCHCCC.EQ.0) GO TO 93 CHLIEX = ' ' IXEXT = IQ(LASML+5) IF (IXEXT.LT.0) IXEXT= IQ(LASMT+5) IF (IXEXT.GT.0) CALL NA_GET (IXEXT,CHLIEX,1) CALL CCCRAK (6) C-- unlink the output file if it exists already IQ(LASML+1) = 0 IQ(LASML+2) = 1 IQ(LASML+3) = IXCCC CALL FLINK (LUN_TYP+1, -1, IXCCC, 0) IF (NCCPD.GE.2) GO TO 42 RETURN C---- handle T=SPLIT and T=MODIFY 34 IF (IAND(MASKOP,KXSP).EQ.0) GO TO 36 IF (IAND(MASKOP,NOT(KXSP+KXPR+KXLO)).NE.0) GO TO 92 JMODE = 2 GO TO 37 36 IF (IAND(MASKOP,KXMO).EQ.0) GO TO 41 IF (IAND(MASKOP,NOT(KXMO+KXPR+KXLO)).NE.0) GO TO 92 JMODE = 3 37 IQ(LASML+1) = 0 IQ(LASML+2) = JMODE IF (NCCPD.GE.2) GO TO 42 GO TO 49 C---- handle T=BIND 41 IF (IAND(MASKOP,KXPR+KXLO).NE.0) GO TO 51 IF (IAND(MASKOP,KXBI).EQ.0) GO TO 61 IF (IAND(MASKOP,NOT(KXBI)).NE.0) GO TO 92 42 MBIND = 8*JASMF + JSTRF JC = JCCPD + 3 NC = NCCPD - 1 IF (NC.LE.0) RETURN DO 47 J=1,NC JASM = MCCPAR(JC+1) JSTR = MCCPAR(JC+2) LASM = LQ(LHASM-JASM) IF (JSTR.NE.0) LASM= LQ(LASM-JSTR-1) IF (IQ(LASM+1).EQ.0) GO TO 97 IQ(LASM+1) = MBIND 47 JC = JC + 3 49 IF (IAND(MASKOP,KXPR+KXLO).NE.0) GO TO 52 RETURN +SEQ, QEJECT. C---- handle T=PREFIX, LOG 51 IF (IAND(MASKOP,NOT(KXPR+KXLO)).NE.0) GO TO 92 52 MODE = IAND (ISHFTR(MASKOP,10), 3) IF (IQ(LASML+2).LT.2) GO TO 94 IF (NCHCCC.EQ.0) GO TO 53 CHLIEX = ' ' CALL CCCRAK (6) GO TO 54 C-- no file name on c/line, use command line parameter 53 IF (JSTRF.GE.3) GO TO 95 IF (JASMF.GT.JDA_TYP) GO TO 95 C- nypatchy pam fort read print cc as data f:2 c:2 a:2 d:2 C- JP= 1 2 3 4 5 6 7 8 9 10 11 C- JASMF= 1 2 3 4 1 2 3 4 IF (JSTRF.LT.2) THEN JP = 2 IF (JASMF.GE.2) JP= JASMF + 3 ELSE JP = JASMF + 7 ENDIF IXCCC = IXLUN(JP) IF (IXCCC.EQ.0) GO TO 95 CALL NA_GET (IXCCC,CCCOMF,1) NCHCCC = NDSLAT C-- change the extension to be .log JD = ICFILA ('/', CCCOMF,1,NCHCCC) JD = NGSLAT + 1 JD = ICFILA ('.', CCCOMF,JD,NCHCCC) CCCOMF(JD:JD+3) = '.log' NCHCCC = JD + 3 IXCCC = NA_LONG (CCCOMF(1:NCHCCC)) C-- for T=PREFIX (not LOG) 54 IF (MODE.GE.2) GO TO 57 IQ(LASML+4) = IXCCC RETURN C-- for T=LOG 57 IQ(LASML+3) = IXCCC CALL FLINK (LUN_TYP+1, -1, IXCCC, 0) IF (MODE.EQ.2) RETURN C- for T=PREFIX, LOG NPRE = ICFILA ('/',CCCOMF,1,NCHCCC) IF (NPRE.GE.NCHCCC) GO TO 96 IQ(LASML+4) = NA_LONG (CCCOMF(1:NPRE)) RETURN C---- handle T=EXTENSION 61 IF (IAND(MASKOP,KXEX).EQ.0) GO TO 63 IF (IAND(MASKOP,NOT(KXEX)).NE.0) GO TO 92 CALL CCCOIX (IQ(LASML+5)) GO TO 69 C---- handle T=CCHSUB 63 IF (IAND(MASKOP,KXSU).EQ.0) GO TO 64 IF (IAND(MASKOP,NOT(KXSU)).NE.0) GO TO 92 CALL CCCOIX (IQ(LASML+7)) GO TO 69 C---- handle T=RHEAD 64 IF (IAND(MASKOP,KXRH).EQ.0) GO TO 92 CALL CCCOIX (IQ(LASML+6)) 69 JCCPD = JCCPD + 3 NCCPD = NCCPD - 1 IF (NCCPD.NE.0) GO TO 31 RETURN C------ Trouble 91 MSG = 'Syntax error' GO TO 98 92 MSG = 'Illegal set of T= parameters' GO TO 98 93 MSG = 'Missing file name' GO TO 98 94 MSG = 'Only for streams in SPLIT or MODIFY mode' GO TO 98 95 MSG = 'The trailing free-field parameter is missing' GO TO 98 96 MSG = 'Illegal file name for T=PREFIX,LOG' GO TO 98 97 MSG = 'Trying to bind a stream which is already physical' 98 N = LNBLNK (MSG) CALL FAILCC (1, MSG(1:N)) RETURN END +SEQ, QCARDL. ===================================================== +DECK, X_IMIT. SUBROUTINE X_IMIT C- Process +IMITATE, P=... +CDE, QBITS19, CCPARA. +CDE, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. 24 IF (NCCPP.EQ.0) RETURN CALL CREAPD (MCCPAR(JCCPP+1),-1, 0) IF (IAND(IQ(LCRP),KM10).NE.0) THEN IQ(LCRP) = IOR (IQ(LCRP),KM5) IQ(LCRP+1) = IOR (IQ(LCRP+1),KM2) LQ(LCRP-4) = LEXP ENDIF NCCPP = NCCPP - 1 JCCPP = JCCPP + 3 GO TO 24 END +SEQ, QCARDL. ===================================================== +DECK, X_INCL. SUBROUTINE X_INCL (LDOSEQ) C- Process +INCLUDE, sname1, ... C- if LDOSEQ is zero this is called from DOXQT; C- otherwise the call is from X_SEQ giving the bank C- with the c/c +INCL +CDE, SLATE, SLATLN, CCPARA. +CDE, MUSEBC, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- CHARACTER LINE*80 EQUIVALENCE (LINE,TEXT) IF (LDOSEQ.NE.0) THEN LDO = LDOSEQ CALL CCKRAK (IQ(LDO+1)) ELSE LDO = LDOAN ENDIF JCCTYP = 0 22 IXNAME = MCCPAR(JCCPZ+1) LINE(1:10) = '#include "' C- _:.=+=.: 1_: CALL NA_GET (IXNAME,LINE,11) NTX = NESLAT CALL CUTOL (LINE(11:NTX)) LINE(NTX:NTX+2) = '.h"' NTX = NTX + 2 +SELF, IF=QNEWLINE. TEXT(NTX+1) = CHAR(NEWLN) +SELF. MLIAD(2) = NTX + 1 + NCHNEWL LQ(LSERV-2) = LQ(LDO-2) IQ(LSERV+1) = 1 IQ(LSERV+2) = 1 IQ(LSERV+3) = -99 IF (NVEXDK(2).NE.0) THEN CALL DPLINE (-1, ' ', NTX,LINE) ENDIF IF (NVEXDK(1).NE.0) CALL DPEXE (LSERV) JCCPZ = JCCPZ + 3 NCCPZ = NCCPZ - 1 IF (NCCPZ.GT.0) GO TO 22 RETURN END +SEQ, QCARDL. ===================================================== +DECK, X_OPT. SUBROUTINE X_OPT C- Process +OPTION, +PARAM, +SHOW +CDE, SLATLN, QBITA19, QCHAR, QPAGE, QUNIT. +CDE, CCTYPE, CCPARA, LUNSLN, MUSEBC. +CDE, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*30, COLS(30)*1 EQUIVALENCE (LINE,SLLINE) EQUIVALENCE (COLS,LINE) PARAMETER (NPOSS = 10, NPARA = 3, NSHOW=2) CHARACTER POSS(NPOSS)*8, PARA(NPARA)*8, SHOW(NSHOW)*8 PARAMETER (NPOSSX = 3) CHARACTER POSSX(NPOSSX)*8 DATA POSSX / 'OFF ' +, 'COM*PACT' +, 'EJE*CT ' / DATA POSS / 'OFF ' +, 'ALL ' +, 'BAC*KCOM' +, 'COM*PACT' +, 'EJE*CT ' +, 'FUL*L ' +, 'MAP*ASM ' +, 'URE*F ' +, 'VER*BOSE' +, 'XCR*OSS ' / DATA PARA / 'LIN*ES ' +, 'COL*UMNS' +, 'CLA*SH ' / DATA SHOW / 'ASM ' +, 'MEM*ORY ' / +SEQ, Q_AND, Q_OR, Q_NOT. +SEQ, QEJECT. C---- Do +OPTION IF (JCCTYP.NE.MCCOPT) GO TO 41 IF (NCCPT.EQ.0) GO TO 31 IF (IFLAUX.EQ.0) THEN CALL CCOPT (POSS,NPOSS) IF (JCCBAD.NE.0) GO TO 91 ELSE CALL CCOPT (POSSX,NPOSSX) IF (JCCBAD.NE.0) RETURN ENDIF MASKOP = MCCPAR(JCCPT+1) IF (IAND(MASKOP,KMO).EQ.0) THEN MOPTIO(33) = IOR (MOPTIO(33),MASKOP) ELSE MOPTIO(33) = IAND (MOPTIO(33),NOT(MASKOP)) ENDIF CALL UPKBYT (MOPTIO(33),1,MOPTIO(1),32,0) C-- print current state of options 31 DO 34 J=1,LEN(LINE) IF (MOPTIO(J).EQ.0) THEN COLS(J) = '.' ELSE COLS(J) = CQCETA(J:J) ENDIF 34 CONTINUE NQLLBL = 0 NQUSED = NQUSED + 1 WRITE (IQPRNT,9034) LINE 9034 FORMAT (10X,'Status of options: ',A) RETURN C---- Do +PARAM 41 IF (JCCTYP.NE.MCCOP2) GO TO 61 IF (NCCPT.EQ.0) RETURN CALL CCOPT (PARA,NPARA) IF (JCCBAD.NE.0) GO TO 91 MASKOP = MCCPAR(JCCPT+2) NVAL = MCCPAR(JCCPN+1) C-- +PARAM, LINES, N=n - n lines per page IF (IAND(MASKOP,KM1).EQ.0) GO TO 42 NQLMAX = MAX (NVAL,24) CALL MQPAGE RETURN C-- +PARAM, COL, N=n - n columns per page 42 IF (IAND(MASKOP,KM2).EQ.0) GO TO 44 NVAL = MIN (NVAL,140) IF (IFLAUX.NE.0) GO TO 43 NQCMAX = MAX (NVAL,90) NQCPGH = NQCMAX IF (IAND(MU_GLOB,KM2).NE.0) RETURN IF (NQCMAX.LT.102) RETURN NQCPGH = 100 + (NQCMAX-100)/2 RETURN 43 NQCMAX = MAX (NVAL,100) NQCPGH = NQCMAX IF (NQCMAX.LT.102) RETURN NQCPGH = 100 + (NQCMAX-100)/2 RETURN C-- +PARAM, CLASH, N=n - print clash at or above n 44 NCLASH = MAX (1,NVAL) RETURN C---- Do +SHOW 61 IF (NCCPT.EQ.0) RETURN CALL CCOPT (SHOW,NSHOW) IF (JCCBAD.NE.0) GO TO 91 MASKOP = MCCPAR(JCCPT+2) C-- +SHOW, ASM - display the ASM data structure IF (IAND(MASKOP,KM1).NE.0) THEN CALL ASMDUMP ('as requested') RETURN ENDIF C-- +SHOW, MEMORY - show memory occupation CALL MQSHOW RETURN C---- Trouble 91 CALL FAILCC (0, 'Unknown option') RETURN END +SEQ, QCARDL. ===================================================== +DECK, X_USE. SUBROUTINE X_USE C- Process +USE, +XDIV, +DIV, +LIST, +EXE C- +SUSPEND, +FORCE +CDE, QBITS19, CCTYPE, CCPARA, MUSEBC. +CDE, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- DIMENSION MV(2) EQUIVALENCE (MV(1),IQUEST(1)) PARAMETER (NPOSS = 10) CHARACTER POSS(NPOSS)*8 PARAMETER (KBOFF=KM8, KBREP=KM9) +SEQ, Q_AND, Q_OR, Q_SHIFTL, Q_SHIFTR. DATA POSS / 'E*XECUTE' +, 'L*IST ' +, 'D*IVERT ' +, 'X*DIVERT' +, 'ONL*Y ' +, 'T*RANSMI' +, 'I*NHIBIT' +, 'OFF ' +, 'R*EPEAT ' +, 'ENV*IRON' / MASKOP = 0 IF (NCCPT.NE.0) THEN CALL CCOPT (POSS,NPOSS) IF (JCCBAD.NE.0) GO TO 91 MASKOP = MCCPAR(JCCPT+2) ENDIF MXNEW = IAND (MASKOP,KM5-1) IF (JCCTYP.GE.MCCFOR) GO TO 71 +SEQ, QEJECT. C---------- Doing +USE, +EXE, etc --------- C-: MODE= 1 ONLY, 2 TRANS, 4 INHIBIT 31 MODE = ISHFTR (MASKOP,4) MODE = IAND (MODE,15) IF (MODE.EQ.3) GO TO 91 IF (MODE.GT.4) GO TO 91 J = MCCIMI - JCCTYP CALL SBIT1 (MXNEW,J) C-- Propagation permission filter IF (INCRAD.EQ.0) MXNEW= IAND (MXNEW, IOR(MU_DECK,KM3)) C------ Process global activation ------ IF (JCCPD.NE.0) GO TO 51 IF (JCCPP.NE.0) GO TO 41 IF (INCRAD.EQ.0) GO TO 92 IF (MODE.EQ.4) THEN IF (MXNEW.GE.16) GO TO 91 ENDIF IQUEST(11) = MXNEW IQUEST(12) = MODE IQUEST(13) = 0 CALL X_UPUT (MU_GLOB) C-- propagate through all patches and decks LQ(LLPAST-1) = 0 L = LEXP 34 CALL MXJOIN (MU_GLOB,IQ(L)) CALL X_UDECK (L) L = LQ(L-1) IF (L.NE.0) GO TO 34 RETURN C------ Process patch activation ------ 41 IXUPAT = MCCPAR(JCCPP+1) IF (IXUPAT.EQ.0) GO TO 48 CALL CREAPD (IXUPAT,-1, 0) IQUEST(11) = MXNEW IQUEST(12) = MODE IQUEST(13) = MX_TRAN CALL X_UPUT (IQ(LCRP)) IF (IAND(MASKOP,KBREP).NE.0) IQ(LCRP+1)= IOR (IQ(LCRP+1),KM5) C-- set "used from" IF (MXNEW.LT.16) GO TO 45 IF (MODE.EQ.4) GO TO 44 IF (IAND(IQ(LCRP),KM5).EQ.0) GO TO 45 44 LQ(LCRP-4) = LEXP C-- propagate through all decks 45 CALL X_UDECK (LCRP) 48 NCCPP = NCCPP - 1 IF (NCCPP.EQ.0) RETURN JCCPP = JCCPP + 3 GO TO 41 C------ Process deck activation ------ 51 IF (NCCPP.NE.1) GO TO 91 IXUPAT = MCCPAR(JCCPP+1) IF (IXUPAT.EQ.0) RETURN 54 IXUDEC = MCCPAR(JCCPD+1) CALL CREAPD (IXUPAT,IXUDEC, 0) IQUEST(11) = MXNEW IQUEST(12) = MODE IQUEST(13) = MX_TRAN CALL X_UPUT (IQ(LCRD)) C-- blank deck and D=CRA* of P=CRA* can change their own status IF (INCRAD.GE.2) THEN IF (LCRP.EQ.LEXP) CALL X_UDECK (0) ENDIF 58 NCCPD = NCCPD - 1 JCCPD = JCCPD + 3 IF (NCCPD.NE.0) GO TO 54 C-- set "used from" IF (MODE.EQ.4) RETURN IF (MXNEW.LT.16) RETURN IQ(LCRP+1) = IOR (IQ(LCRP+1),KM4) IF (LQ(LCRP-4).EQ.0) LQ(LCRP-4)=LEXP RETURN +SEQ, QEJECT. C---------- +FORCE, (OFF,) EXE, LIST, DIV, XDIV --------- C-- +SUSPEND, (OFF,) EXE, LIST, DIV, XDIV 71 MXNEG = KM5-1 - MXNEW MXOFF = IAND (MASKOP,KBOFF) MV(1) = IAND (ISHFTR(MX_FORC,5), KM5-1) MV(2) = IAND (ISHFTR(MX_FORC,14), KM5-1) +SELF, IF=XDEBUG, IF=XX_USE. PRINT *, ' X_USE: NEW=',MXNEW,' NEG=',MXNEG,' NO/YES=',MV +SELF. IF (JCCTYP.EQ.MCCFOR) THEN IF (MXOFF.EQ.0) MV(2) = IOR (MV(2),MXNEW) IF (MXOFF.NE.0) MV(2) = IAND (MV(2),MXNEG) ELSE IF (MXOFF.EQ.0) MV(1) = IAND (MV(1),MXNEG) IF (MXOFF.NE.0) MV(1) = IOR (MV(1),MXNEW) ENDIF +SELF, IF=XDEBUG, IF=XX_USE. PRINT *, ' NO/YES=',MV +SELF. MX_FORC = IOR (ISHFTL(MV(1),5), ISHFTL(MV(2),14)) RETURN C----- Faulty control line 91 CALL M_FAIL ('Bad syntax') RETURN 92 CALL M_FAIL ('This is allowed only in the cradle') RETURN END +SEQ, QCARDL. ===================================================== +DECK, X_UPUT. SUBROUTINE X_UPUT (MTARG) C- Update the activation bits in MTARG for X_USE +CDE, QBITS19, QUEST. C-------------- End CDE -------------------------------- DIMENSION MTARG(9) DIMENSION MV(4) EQUIVALENCE (MV(1),IQUEST(1)) EQUIVALENCE (MXNEW,IQUEST(11)), (MODE,IQUEST(12)) +, (MXTRAN,IQUEST(13)) +SEQ, Q_AND, Q_OR, Q_SHIFTL, Q_SHIFTR. C-- unpack MV( 1 self+forg 2 inhibit 3 trans 4 self only MXD = MTARG(1) MV(1) = IAND (MXD, KM6-1) MV(2) = IAND (ISHFTR(MXD,5), KM6-1) MV(3) = IAND (ISHFTR(MXD,10), KM5-1) MV(4) = IAND (ISHFTR(MXD,14), KM5-1) C- MODE: 1 ONLY, 2 TRANS, 4 INHIBIT IF (MODE.EQ.4) GO TO 28 C---- Activation IF (MODE.NE.1) MV(1) = IOR (MV(1), MXNEW) IF (MODE.EQ.2) MV(3) = IOR (MV(3), MXNEW) MV(4) = IOR (MV(4), MXNEW) C-- "TRANS" attachment to USE IF (MXTRAN.NE.0) THEN IF (MXNEW.GE.16) THEN MV(1) = IOR (MV(1), MXTRAN) MV(3) = IOR (MV(3), MXTRAN) MV(4) = IOR (MV(4), MXTRAN) ENDIF ENDIF C-- mask against inhibition bits 24 MV(1) = IAND (MV(1), MV(2)) MV(3) = IAND (MV(3), MV(2)) MV(4) = IAND (MV(4), MV(2)) C-- store MXWK = IOR (ISHFTL(MV(2),5), MV(1)) MXWK = IOR (ISHFTL(MV(3),10), MXWK) MXWK = IOR (ISHFTL(MV(4),14), MXWK) CALL SBYT (MXWK,MTARG(1),1,18) RETURN C---- Inhibition 28 MXWK = 127 - MXNEW MV(2) = IAND (MV(2), MXWK) GO TO 24 END +SEQ, QCARDL. ===================================================== +DECK, X_UDECK. SUBROUTINE X_UDECK (LPAT) C- Merge new USE/EXE-status of patch into all dependent decks C! if LPAT = zero: blank deck and D=CRA* of P=CRA* change C! their own status +CDE, QBITS19. +CDE, Q, PY, MUSEBC. C-------------- End CDE -------------------------------- PARAMETER (IXCRA=2) +SEQ, Q_AND. LP = LPAT IF (LP.EQ.0) GO TO 32 LD = LQ(LP-2) IF (LD.EQ.0) RETURN MXP = IQ(LP) 21 CALL MXJOIN (MXP,IQ(LD)) LD = LQ(LD-1) IF (LD.NE.0) GO TO 21 IF (INCRAD.LT.2) RETURN IF (LP.NE.LEXP) RETURN C-- Currently processing P=CRA*, D=blank or CRA*, whose mode C- may have changed: update the variables in MUSEBC C- note: name index =0 for blank, =2 for CRA* 32 MU_PAT = IAND (IQ(LEXP), KM19-1) IF (LEXD.EQ.0) LEXD= KQFIND (IXCRA,1,LEXP-2,KF) IF (LEXD.NE.0) THEN MU_DECK = IAND (IQ(LEXD), KM19-1) ELSE MU_DECK = MU_PAT ENDIF CALL MXOPER (0) END +SEQ, QCARDL. ===================================================== +PATCH, DOFORG. Foreign material from this deck to memory +DECK, DOFORG. SUBROUTINE DOFORG (IFTONX) C- Store new foreign material into division 1 C- IF-selection has been done by M_ANA3 C. started 1-dec-91 +CDE, QBITA19, QBANKS, CCTYPE, CCPARA. +CDE, MQCM, Q, PY. +CDE, MUSEBC, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT, Q_AND, Q_OR, Q_SHIFTL. +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: arriving in DOFORG' +SELF. IFTON = 1 IF (IAND(IQ(LDOAN),KM5).NE.0) THEN IFLNIL = IAND(IQ(LDOAN),KM8) IF (IFLNIL.EQ.0) GO TO 99 ELSE IFLNIL = 0 ENDIF IF (LDECO.EQ.0) CALL CRDECO CALL CCKRAK (IQ(LDOAN+1)) MEXAN = MX_FORG IF (JCCTYP.NE.MCCKEE) GO TO 41 +SEQ, QEJECT. C---------- Handle +KEEP -------------------- IFLSGL = KM5+KM6+KM17 IFLMSK = KM5+KM6 NSTEP = 0 LAST = 0 IXS = MCCPAR(JCCPZ+1) LACT = LQ(LDOAN-3) IF (LACT.GT.0) GO TO 24 C-- append to existing sequence LACT = -LACT IFLSGL = 0 IFTON = 0 KJOIN = KQLAST (LACT-2) JCCTYP = 0 IF (IQ(LDOAN+1).EQ.1) GO TO 31 NSTEP = 1 GO TO 32 C-- ready the KEEP bank 24 IF (NCCPP.NE.0) IFLSGL= 0 IQ(LACT) = IOR (IQ(LACT), KM7) IQ(LACT+1) = IQ(LDOAN+1) + 1 IQ(LACT+2) = IQ(LDOAN+2) - 1 C! IQ(LACT+4) = IXS IQ(LDOAN+2) = 1 IF (LUPAN.EQ.0) THEN LQ(LACT-3) = LDECO IQ(LACT+3) = IQ(LACT+1) - JSLORG LAST = LACT ELSE LQ(LACT-3) = LQ(LDOAN-2) IQ(LACT+3) = IQ(LDOAN+3) + 1 ENDIF C-- NIL sequence IF (IFLNIL.NE.0) GO TO 99 C------ create MAT continuation banks for KEEP IFTON = 0 KJOIN = LACT - 2 31 CALL MK_FNX IF (LDOAN.EQ.0) GO TO 39 IF (JCCTYP.GE.MCCSEL) GO TO 39 NSTEP = 0 32 IF (LUPAN.NE.0) GO TO 38 JSLNEW = IQ(LDOAN+1) + NSTEP NSLNEW = IQ(LDOAN+2) - NSTEP NUMNEW = JSLNEW - JSLORG IF (NSLNEW.EQ.0) GO TO 31 IF (JCCTYP.LT.MCCCDE) GO TO 36 IF (JCCTYP.GE.MCCXSQ) GO TO 35 C-- handle +CDE or +SEQ CALL CCKRAK (JSLNEW) C-- check +SEQ,..., T=DUMMY IF (IAND(MCCPAR(JCCPT+1),KMD).NE.0) GO TO 31 C---- try immediate substitution for +SEQ, single name IF (NCCPZ.NE.1) GO TO 34 IF (NCCPIF.NE.0) GO TO 34 IXC = MCCPAR(JCCPZ+1) CALL LOCSEQ (LSQF, IXC,0,0) IF (LSQF.EQ.0) GO TO 34 IF (IAND(IQ(LSQF),KM17).EQ.0) GO TO 34 C-- do the substitution JSLNEW = IQ(LSQF+1) IF (JSLNEW.LT.LQLSTA(4)) THEN JSLNEW = LN_COP4 (JSLNEW,1) IQ(LSQF+1) = JSLNEW ENDIF JCCTYP = 0 C-- does the KEEP bank have zero lines? IF (LAST.NE.LACT) GO TO 36 IF (IQ(LACT+3).NE.NUMNEW) GO TO 36 IQ(LACT+1) = JSLNEW IQ(LACT+2) = 1 GO TO 31 +SEQ, QEJECT. C---- lift XSQ bank for +CDE or +SEQ 34 LMAT = LIFTSQ (KJOIN,JCCTYP,0,1) IFLMSK = 0 GO TO 37 C---- lift new MAT bank 35 IFLMSK = 0 36 CALL MQLIFT (LMAT,KJOIN,0,JBKMAT,1) IQ(LMAT) = IOR (IQ(LMAT), ISHFTL(JCCTYP,8)) 37 LQ(LMAT-2) = LDECO IQ(LMAT+1) = JSLNEW IQ(LMAT+2) = NSLNEW IQ(LMAT+3) = NUMNEW LAST = LMAT KJOIN = LMAT - 1 GO TO 31 C---- shunt higher level MAT banks 38 LEV = JBYT (IQ(LDOAN),21,5) CALL SBYT (LEV+1,IQ(LDOAN),21,5) CALL QSHUNT (KDOAN,KJOIN) LAST = 0 KJOIN = LDOAN - 1 LDOAN = KDOAN + 1 IFLMSK = 0 GO TO 31 C---- End of material for KEEP, finalize 39 IF (LQ(LACT-2).NE.0) IFLSGL= 0 IF (IQ(LACT+2).NE.1) IFLSGL= 0 IFLMSK = IOR (IFLMSK, MEXAN) IFLMSK = IOR (IFLMSK, IFLSGL) IQ(LACT) = IOR (IQ(LACT), IFLMSK) GO TO 99 +SEQ, QEJECT. C---------- Handle +DEL +REPL +ADB +ADD ----------------- 41 LCRD = LQ(LDOAN-3) JSLCL = IQ(LDOAN+1) JACTU = ISHFTL (JCCTYP-MCCDEL,8) IF (LUPAN.EQ.0) THEN LORG = LDECO NUMORG = JSLCL - JSLORG ELSE LORG = LQ(LDOAN-2) NUMORG = IQ(LDOAN+3) ENDIF C-- lift the ACT bank 45 CALL MQLIFT (LACT,LCRD,-2,JBKACT,1) IQ(LACT) = IOR (IQ(LACT), JACTU) IQ(LACT) = IOR (IQ(LACT), MEXAN) LQ(LACT-3) = LORG IQ(LACT+1) = JSLCL IQ(LACT+2) = 1 IQ(LACT+3) = NUMORG IQ(LACT+4) = MCCPAR(JCCPC+1) IQ(LACT+5) = MCCPAR(JCCPC+2) C-- NIL action IF (IFLNIL.NE.0) THEN IQ(LACT) = IOR (IQ(LACT),KM12) IF (LUPAN.EQ.0) IQ(LACT+2) = 0 IF (JCCTYP.NE.MCCDEL) GO TO 99 JCCTYP = -1 GO TO 79 ENDIF C-- true action IF (JCCTYP.EQ.MCCDEL) THEN IF (NCCPC.GE.2) JSLCL= LN_COP4 (JSLCL,1) JCCTYP = -1 ENDIF IF (JCCTYP.EQ.-1) GO TO 79 IFTON = 0 KJOIN = LACT - 2 C-- handle +ADD, ..., Z=sname IF (NCCPZ.EQ.0) GO TO 47 LMAT = LIFTSQ (KJOIN,MCCXSQ,0,1) LQ(LMAT-2) = LORG IQ(LMAT+1) = JSLCL IQ(LMAT+2) = 0 IQ(LMAT+3) = NUMORG KJOIN = LMAT - 1 47 IF (LUPAN.NE.0) GO TO 51 JCCTYP = 0 NSTEP = 1 GO TO 53 C---- create MAT continuation banks for ACT 51 CALL MK_FNX IF (LDOAN.EQ.0) GO TO 79 IF (JCCTYP.GE.MCCSEL) GO TO 79 IF (IQ(LDOAN+2).EQ.0) GO TO 51 IF (LUPAN.NE.0) GO TO 77 NSTEP = 0 53 CALL MK_FRAG (KJOIN,NSTEP) GO TO 51 C---- shunt higher level MAT banks 77 LEV = JBYT (IQ(LDOAN),21,5) CALL SBYT (LEV+1,IQ(LDOAN),21,5) CALL QSHUNT (KDOAN,KJOIN) KJOIN = LDOAN - 1 LDOAN = KDOAN + 1 GO TO 51 C---- End of material for ACT, finalize 79 IQ(LACT) = IOR (IQ(LACT), MEXAN) IF (JCCTYP.NE.-1) GO TO 99 C-- iterate if multiple +DEL JCCPC = JCCPC + 3 NCCPC = NCCPC - 1 IF (NCCPC.NE.0) GO TO 45 99 IFTONX = IFTON +SELF, IF=XDEBUG, IF=XDOFORG. CALL DDSNAP ('end of DOFORG',-1,1) +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, MK_FRAG. SUBROUTINE MK_FRAG (KJOINX,NSTEP) C- Fragment the contents of the bank at LDOAN for DOFORG C- on the boundaries and according to the delayed control-lines C. started 15-jul-93 +CDE, QBITS19, QBANKS, CCTYPE, CCPARA, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_OR, Q_SHIFTL. KJOIN = KJOINX JSLA = IQ(LDOAN+1) JSLE = JSLA + IQ(LDOAN+2) JSLA = JSLA + NSTEP JCPUT = JCCTYP IF (JCCTYP.LT.MCCCDE) GO TO 20 IF (JCCTYP.GT.MCCSEQ) GO TO 20 C-- starting with +CDE or +SEQ, lift a call bank CALL CCKRAK (JSLA) GO TO 37 C-- Look for the next delayed c/line 20 JCLAST = 0 JSLG = JSLA 21 CALL NEXTCC ('-',JSLG,JSLE,JSLF,JCCTYP) 22 NLDO = JSLF - JSLA IF (NLDO.EQ.0) GO TO 27 C-- store the pending material CALL MQLIFT (LMAT,KJOIN,0,JBKMAT,1) MMBANK(3,JBKMAT) = 2 LQ(LMAT-2) = LDECO IQ(LMAT) = IOR (IQ(LMAT), MEXAN) IQ(LMAT+1) = JSLA IQ(LMAT+2) = NLDO IQ(LMAT+3) = JSLA - JSLORG IF (JCPUT.NE.0) THEN IQ(LMAT) = IOR (IQ(LMAT), ISHFTL(JCPUT,8)) ELSEIF (JCLAST.NE.0) THEN IQ(LMAT) = IOR (IQ(LMAT), KM15) ENDIF KJOIN = LMAT - 1 27 JCPUT = 0 JSLA = JSLF IF (JCCTYP.LT.0) GO TO 20 IF (JCCTYP.EQ.0) GO TO 99 +SEQ, QEJECT. C---- handle the new c/line JCLAST = JCCTYP JSLG = JSLA + 1 CALL CCKRAK (JSLA) IF (JCCBAD.NE.0) THEN NUM = JSLA - JSLORG CALL FAILLN (1, 0, NUM, JSLA, 'Bad syntax for delayed c/l') ENDIF C-- control-lines with associated material are: C-- +_xxx +SELF +SKIP +KEEP C-- soft c/lines IF (JCCTYP.GE.MCCSEL) GO TO 41 JTX = MLIAD(JSLA) TEXT(JTX) = '+' JCPUT = JCCTYP IF (JCCTYP.GE.MCCTRU) GO TO 21 IF (JCCTYP.LT.MCCCDE) GO TO 54 C-- do +CDE, +SEQ, lift a call bank 37 LMAT = LIFTSQ (KJOIN,JCCTYP,0,1) LQ(LMAT-2) = LDECO IQ(LMAT) = IOR (IQ(LMAT), MEXAN) IQ(LMAT+1) = JSLA IQ(LMAT+2) = 1 IQ(LMAT+3) = JSLA - JSLORG KJOIN = LMAT - 1 JSLA = JSLA + 1 JCPUT = 0 GO TO 20 C-- hard control lines 41 IF (JCCTYP.GE.MCCUSE) GO TO 54 IF (JCCTYP.GE.MCCKEE) GO TO 51 IF (JCCTYP.NE.MCCSEL) GO TO 21 C-- +SELF, sname IF (NCCPZ.EQ.0) GO TO 21 LMAT = LIFTSQ (KJOIN,MCCSES,0,1) LQ(LMAT-2) = LDECO IQ(LMAT) = IOR (IQ(LMAT), MEXAN) IQ(LMAT+1) = JSLA IQ(LMAT+3) = JSLA - JSLORG CALL NEXTCC ('-',JSLG,JSLE,JSLF,JCCTYP) IQ(LMAT+2) = JSLF - JSLA KJOIN = LMAT - 1 GO TO 27 C-- Action line +ADD etc, MAT bank needs 3 links 51 MMBANK(3,JBKMAT) = 3 IF (JCCTYP.EQ.MCCKEE) GO TO 21 C-- stand-alone control-line 54 JCCTYP = -1 JSLF = JSLA + 1 GO TO 22 C---- done 99 KJOINX = KJOIN RETURN END +SEQ, QCARDL. ===================================================== +DECK, MK_FNX. SUBROUTINE MK_FNX C- Step to next PREP / MAT bank for DOFORG C. started 1-dec-91 +CDE, QBITS19, CCTYPE, CCPARA, Q, MUSEBC. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT, Q_AND, Q_OR. MEXSUS = 0 IFLNEW = 0 21 IF (LUPAN.NE.0) GO TO 34 22 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) IF (LDOAN.EQ.0) GO TO 29 L = LQ(LDOAN-2) IF (L.NE.0) GO TO 31 24 JCCTYP = JBYT (IQ(LDOAN),9,6) IF (IAND(IQ(LDOAN),KM5+KM6).EQ.0) GO TO 28 C-- deleted PREP/MAT bank IF (JCCTYP.GE.MCCSEL) THEN IFLNEW= 7 IF (IAND(IQ(LDOAN),KM6+KM7).EQ.0) GO TO 29 ENDIF IF (IFLNEW.NE.0) THEN MEXSUS = IOR (MEXSUS, IQ(LDOAN)) ELSE MEXAN = IOR (MEXAN, IQ(LDOAN)) ENDIF GO TO 21 C-- accepted PREP/MAT bank 28 IF (JCCTYP.LT.MCCSEL) THEN IF (NVEXDK(2).NE.0) CALL DPLIST (MODEAN,LDOAN,LUPAN,0) MEXAN = IOR (MEXAN, IQ(LDOAN)) MEXAN = IOR (MEXAN, MEXSUS) ENDIF 29 MEXAN = IAND (MEXAN,15) RETURN C---- Follow reference to foreign material 31 LOWAN = LDOAN LUPAN = L C-- list what action CALL DPLACT IF (IAND(IQ(LOWAN),KM5+KM6).NE.0) GO TO 37 C-- next MAT bank LDOAN = LUPAN - 1 34 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) IF (LDOAN.NE.0) GO TO 24 36 LDOAN = LOWAN LUPAN = 0 GO TO 22 37 MEXSUS = IOR (MEXSUS, IQ(LOWAN)) MEXSUS = IOR (MEXSUS, IQ(LUPAN)) GO TO 36 END +SEQ, QCARDL. ===================================================== +PATCH, ARRIVE. Input routines +DECK, ARRSKPC, IF=QCIO. +SEQ, QCARD1, R=ARRSKP. SUBROUTINE ARRSKP C- Skip one PAM/Patch/Deck according to JDKTYP, using the C library C. started 16-mar-92 +CDE, QPAGE, CHEXC, MQCM, Q, PY. C-------------- End CDE -------------------------------- IXEXDEC = 0 NSLORG = 0 NDKSKP = 0 LEVEL = JDKTYP C-- Make sure the current deck is complete in memory IF (JDKNEX.EQ.0) CALL ARRNXD (0) 24 IF (JDKNEX.EQ.0) CALL ARRIVE (2) C-- Skip one deck, next -> current CALL ARRNXD (1) NDKSKP = NDKSKP + 1 IF (JDKTYP.LT.LEVEL) GO TO 24 C-- The now current deck is at the right level IF (LEVEL.GE.3) RETURN IF (LEVEL.EQ.2) IXEXPAT= 0 NQDKNO = NQDKNO + NDKSKP JSLZER = IQ(LQHOLD+1) JSLORG = JSLZER RETURN END +SEQ, QCARDL. ===================================================== +DECK, ARRSKPF, IF=QFIO. +SEQ, QCARD1, R=ARRSKP. SUBROUTINE ARRSKP C- Skip one PAM/Patch/Deck according to JDKTYP, using Fortran C. started 16-mar-92 +CDE, QPAGE, CHEXC, MQCM, Q, PY. +CDE, ARRCOM. C-------------- End CDE -------------------------------- IXEXDEC = 0 NSLORG = 0 NDKSKP = 0 NSLN = 0 LEVEL = JDKTYP IFTERM = IQ(LARRV+7) JSLGO = IQ(LQHOLD+1) C-- Is the current deck complete in memory? 24 IF (JDKNEX.EQ.0) THEN IF (IQ(LQHOLD+2).LE.1) THEN IF (IFTERM.NE.-1) GO TO 41 ELSE CALL ARRNXD (0) IF (JDKNEX.NE.0) GO TO 27 IF (IFTERM.NE.-1) GO TO 41 ENDIF CALL ARRIVE (2) ENDIF C-- Skip one deck, next -> current 27 CALL ARRNXD (1) NDKSKP = NDKSKP + 1 IF (JDKTYP.LT.LEVEL) GO TO 24 GO TO 67 C---- Hunt for next deck header line 41 IF (IQ(LARRV+8).NE.0) GO TO 61 IN_LUN = IQ(LARRV+1) IN_EOF = 0 JTXGO = MLIAD(JSLGO) 44 CALL ARRLN (IN_LUN, TEXT(JTXGO),NTXR) IF (NTXR.LT.0) GO TO 60 NSLN = NSLN + 1 IF (NTXR.LT.4) GO TO 44 IF (TEXT(JTXGO).NE.'+') GO TO 44 JTXU = JTXGO + NTXR +SELF, IF=QNEWLINE. TEXT(JTXU) = CHAR(NEWLN) JTXU = JTXU + 1 +SELF. MLIAD(JSLGO+1) = JTXU CALL NEXTSI (JSLGO,JDKTYP,INCRAD) IF (JDKTYP.EQ.0) GO TO 44 NDKSKP = NDKSKP + 1 IF (JDKTYP.LT.LEVEL) GO TO 44 LQLEND(2) = JSLGO + 1 LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) IQ(LQHOLD+1) = JSLGO IQ(LQHOLD+2) = 1 GO TO 67 C-- end-of-file 60 IN_EOF = -1 61 IQ(LQHOLD+2) = 0 JDKTYP = 6 JDKNEX = 6 67 IQ(LARRV+12) = IQ(LARRV+12) + NSLN IF (LEVEL.GE.3) RETURN IF (LEVEL.EQ.2) IXEXPAT= 0 NQDKNO = NQDKNO + NDKSKP JSLZER = IQ(LQHOLD+1) JSLORG = JSLZER RETURN END +SEQ, QCARDL. ===================================================== +DECK, ARRIVE. SUBROUTINE ARRIVE (MODEIN) C- Read input material to memory C- MODE = 0 : read the blank deck of the cradle C- 1 : make sure the beginning of the next deck is in memory C- 2 : make sure the complete deck is in memory C- 3 : read as much as you can C. started 11-mar-92 +CDE, QUNIT, CCTYPE, CCPARA, LUNSLN. +CDE, MQCM, Q, PY. +CDE, ARRCOM, FLINKC. C-------------- End CDE -------------------------------- MODE = MODEIN +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: arriving in ARRIVE, MODE= ',MODE +SELF, IF=QCIO. C-- collect garbage before reading next instalment from PAM IF (INCRAD.EQ.0) THEN IF (LQLEND(2).NE.LQLSTA(2)) GO TO 25 ENDIF +SELF. IF (MODE.NE.0) GO TO 21 C---- Start reading the blank deck of the cradle LARRV = LACRAD IQ(LARRV+1) = IQREAD IQ(LARRV+2) = IQRFD IQ(LARRV+6) = IQRSIZ JDKTYP = 0 +SELF, IF=QCIO. IF (IQRFD .NE.0) GO TO 21 IF (IQRSIZ.NE.0) GO TO 21 +SELF. IQ(LARRV+7) = -2 IF (IQRTTY.NE.0) IQ(LARRV+7)= -1 +SEQ, QEJECT, N=40. C---- Check enough space 21 NWFREE = LQCSTA(3) - LQCEND(2) JSLOCC = LQLSTA(4) JSLFRE = LQLEND(2) NSLFRE = JSLOCC - JSLFRE - 8 NTXFRE = MLIAD(JSLOCC) - MLIAD(JSLFRE) - 400 NSLRSV = NVGAP(2) NTXRSV = NSLRSV * NVGAP(4) NSLEXP = NVGAP(3) NTXEXP = NSLEXP * NVGAP(4) NSLMIN = 40 NTXMIN = NSLMIN * NVGAP(4) +SELF, IF=QCIO, QS_VMS. IF (IFMODIF.NE.0) THEN NSLRSV = NSLRSV + NSLEXP NTXRSV = NTXRSV + NTXEXP ENDIF +SELF. NSLWAN = NSLFRE - NSLRSV NTXWAN = NTXFRE - NTXRSV IF (NWFREE.LT.NVGAP(1)) GO TO 24 IF (NSLFRE.LT.NSLRSV+NSLEXP) GO TO 24 IF (NTXFRE.GE.NTXRSV+NTXEXP) GO TO 31 24 IF (IFLGAR.NE.0) GO TO 27 25 CALL MQSHIFT IFLGAR = 7 GO TO 21 C-- not plenty of space, try to do with half the reservation 27 IF (NSLFRE.GE.NSLRSV+NSLEXP) THEN IF (NTXFRE.GE.NTXRSV+NTXEXP) GO TO 31 ENDIF NSLWAN = NSLFRE - NSLRSV/2 NTXWAN = NTXFRE - NTXRSV/2 IF (NSLWAN.LT.NSLMIN) + CALL NOSPACE ('no line slots left for reading') IF (NTXWAN.LT.NTXMIN) + CALL NOSPACE ('no text store left for reading') C---- Handle pending material from the ASAV bank C- Note: this can happen only at the moment C- when resuming the cradle or a Pam file 31 LASAV = LQ(LARRV-2) IF (LASAV.EQ.0) GO TO 41 IQ(LQHOLD+1)= LQLEND(2) JSLTR = IQ(LASAV+1) NSLTR = IQ(LASAV+2) JSLE = JSLTR + NSLTR NTXTR = MLIAD(JSLE) - MLIAD(JSLTR) +SELF, IF=XDEBUG, IF=XSAVE. CALL DUMPSL (JSLTR,NSLTR,'are connected to ASAV bank') +SELF. IF (NSLTR.GT.NSLWAN) + CALL NOSPACE ('no line slots left for reading') IF (NTXTR.GT.NTXWAN) + CALL NOSPACE ('no text store left for reading') C-- transfer all pending material JSLTR = LN_COP2 (JSLTR,NSLTR) CALL TOGARB (LARRV-2,0) +SELF, IF=XDEBUG, IF=XSAVE. CALL DUMPSL (JSLTR,NSLTR,'stored into text division 2') +SELF. IQ(LQHOLD+2) = NSLTR CALL ARRNXD (-1) IF (JDKNEX.NE.0) RETURN IF (MODE.EQ.1) RETURN GO TO 21 +SEQ, QEJECT, N=40. C------ Read from the file 41 IF (IQ(LQHOLD+2).EQ.0) THEN IQ(LQHOLD+1) = LQLEND(2) JDKTYP = 0 ENDIF IN_DOX = 2 +SELF, IF=QCIO. C-- if file not seekable, dont read too much IF (IQ(LARRV+7).LT.-1) THEN NSLWAN = NSLMIN NTXWAN = NTXMIN ENDIF +SELF. IN_DO1 = NSLWAN IN_DO2 = NTXWAN JDKNEX = 0 IF (IQ(LARRV+7).EQ.-1) THEN CALL ARRTM ELSE CALL ARRIN ENDIF IF (JDKNEX.LT.0) GO TO 61 IF (MODE.NE.1) THEN IF (JDKNEX.EQ.0) GO TO 21 ENDIF IF (MODE.NE.0) RETURN C-- having read the blank deck of the cradle IF (IFLAUX.NE.0) RETURN IF (JDKTYP.LT.2) RETURN CALL P_KILL ('illegal start of the cradle') C---- Having read the start of the blank deck of the cradle C-- until a line +MORE : read the cradle continuation file 61 JDKNEX = 0 JSLM = IQ(LQHOLD+1) + IQ(LQHOLD+3) JCCTYP = MCCMOR CALL CCKRAK (JSLM) IF (NCHCCD.GE.NCHCCT) JCCBAD= 7 IF (JCCBAD.NE.0) CALL P_KILL ('faulty +MORE line') C-- close previous cradle file, if not terminal IF (IQ(LARRV+7).NE.-1) THEN IN_DOX = -1 CALL ARRIN ENDIF C-- attach the +MORE file IQREAD = IQRSAV IQRTTY = 0 CALL FLKRAK (1,1) CALL FLINK (IQREAD, 1, -1, 0) IQRFD = LUNFD IQRSIZ = LUNSIZ IQ(LARRV+1) = IQREAD IQ(LARRV+2) = IQRFD IQ(LARRV+4) = IXFLUN IQ(LARRV+6) = IQRSIZ +SELF, IF=QCIO. IQ(LARRV+7) = 0 +SELF, IF=QFIO. IQ(LARRV+7) = -2 +SELF. IQ(LARRV+8) = 0 LQLEND(2) = JSLM + 1 LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) GO TO 21 END +SEQ, QCARDL. ===================================================== +DECK, ARRTM. SUBROUTINE ARRTM C- Read cradle lines from the on-line user C. started 10-feb-92 +CDE, MQCM, Q, PY. +CDE, ARRCOM. C-------------- End CDE -------------------------------- JSLGO = IQ(LQHOLD+1) JSLU = LQLEND(2) JTXU = MLIAD(JSLU) JSLE = JSLU + IN_DO1 JTXE = JTXU + IN_DO2 24 JSLF = JSLU IF (JSLU.GE.JSLE) GO TO 37 IF (JTXU.GE.JTXE) GO TO 37 CALL TMPRO (' ny> ') CALL TMREAD (512,TEXT(JTXU),NTXR,IN_EOF) IF (IN_EOF.NE.0) GO TO 31 JTXF = JTXU JTXU = JTXU + NTXR +SELF, IF=QNEWLINE. TEXT(JTXU) = CHAR(NEWLN) JTXU = JTXU + 1 +SELF. JSLU = JSLU + 1 MLIAD(JSLU) = JTXU IF (NTXR.LT.4) GO TO 24 IF (TEXT(JTXF).NE.'+') GO TO 24 CALL NEXTSI (JSLF,JDKNEX,INCRAD) IF (JDKNEX.EQ.0) GO TO 24 IF (JSLF.NE.JSLGO) GO TO 37 IF (JDKNEX.LT.0) GO TO 37 JDKTYP = JDKNEX JDKNEX = 0 JSLF = JSLU GO TO 37 C---- EoF 31 IF (IN_EOF.GT.0) CALL P_KILLM ('terminal read fails') IQ(LARRV+8) = -1 JDKNEX = 6 IF (JSLU.EQ.JSLGO) JDKTYP = 6 C-- Done 37 IQ(LARRV+12) = IQ(LARRV+12) + (JSLU-LQLEND(2)) LQLEND(2) = JSLU LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) IQ(LQHOLD+2) = JSLU - JSLGO IQ(LQHOLD+3) = JSLF - JSLGO RETURN END +SEQ, QCARDL. ===================================================== +DECK, ARRINC, IF=QCIO. +SEQ, QCARD1, R=ARRIN. SUBROUTINE ARRIN C- Read / reposition current input file, using the C library, C- according to IN_DOX: C- = -1 close, 0 rewind, 1 reposition, 2 read C. started 10-feb-92 +CDE, QUNIT, MQCM, Q, PY. +CDE, ARRCOM. C-------------- End CDE -------------------------------- +SEQ, Q_OR. +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: arriving in ARRINc, IN_DOX= ',IN_DOX +SELF. IN_FD = IQ(LARRV+2) IF (IN_DOX.LT.2) GO TO 61 C---- Read JSLGO = IQ(LQHOLD+1) JSLNEW = LQLEND(2) JSLA = LQLEND(2) NSLN = IN_DO1 NTXN = IN_DO2 JTXA = MLIAD(JSLA) CALL CIGET (IN_FD,TEXT(JTXA),NTXN,NTXR,IN_EOF) IF (IN_EOF.NE.0) GO TO 41 C-- reading successful, get the current file position CALL CITELL (IN_FD,NCHPOS,ISTAT) IF (ISTAT.NE.0) CALL P_KILLM ('CIO tell fails') C-- construct the line directory JTXE = JTXA + NTXR JSLE = JSLA LIMIT = JSLA + NSLN DO 26 JTXU=JTXA,JTXE-1 IF (ICHAR(TEXT(JTXU)) .EQ. NEWLN) THEN JSLE = JSLE + 1 MLIAD(JSLE) = JTXU + 1 IF (JSLE.GT.LIMIT) GO TO 31 ENDIF 26 CONTINUE IF (NTXR.EQ.NTXN) GO TO 31 C-- file complete, make sure terminating NEWLINE present IF (MLIAD(JSLE).EQ.JTXE) GO TO 34 TEXT(JTXE) = CHAR(NEWLN) JTXE = JTXE + 1 JSLE = JSLE + 1 MLIAD(JSLE) = JTXE NCHPOS = NCHPOS + 1 GO TO 34 +SEQ, QEJECT, N=40. C---- file too big, reposition to complete line 31 JTXU = MLIAD(JSLE) N = JTXE - JTXU IF (N.EQ.0) GO TO 34 NCHPOS = NCHPOS - N CALL CISEEK (IN_FD,NCHPOS,ISTAT) IF (ISTAT.NE.0) CALL P_KILLM ('CIO seek fails') C-- is the end of the file in memory ? 34 NSIZE = IQ(LARRV+6) IF (NSIZE.GT.0) THEN IF (NCHPOS.GE.NSIZE) IN_EOF= 1 ENDIF C-- if IQRRD lines have been read already by FLPARA IF (IQRRD.NE.0) THEN JSLGO = JSLGO + IQRRD JSLNEW = MAX (JSLGO,LQLEND(2)) IQRRD = 0 IQ(LQHOLD+1) = JSLGO IF (JSLGO.GE.JSLE) CALL P_CRASH ('bad start of cradle') ENDIF C-- Done IQ(LARRV+7) = NCHPOS IQ(LARRV+8) = IN_EOF 37 CALL NEXTDE (JSLNEW,JSLE,JSLF,JDKNEX,INCRAD) IF (JSLF.EQ.JSLGO) THEN IF (JDKNEX.GT.0) THEN JSLNEW = JSLF + 1 JDKTYP = JDKNEX GO TO 37 ENDIF ENDIF IF (JDKNEX.EQ.0) THEN IF (IN_EOF.NE.0) JDKNEX= 6 ENDIF IQ(LQHOLD+2) = JSLE - JSLGO IQ(LQHOLD+3) = JSLF - JSLGO IQ(LQHOLD) = IOR (IQ(LQHOLD), 1) IQ(LARRV+12) = IQ(LARRV+12) + (JSLE-LQLEND(2)) LQLEND(2) = JSLE LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) RETURN C---- EoF read, no material has come to memory 41 IF (IN_EOF.NE.-1) CALL P_KILLM ('CIO read fails') IQ(LARRV+8) = -1 JDKNEX = 6 IF (JSLNEW.EQ.JSLGO) JDKTYP = 6 RETURN C---- Reposition the file 61 IF (IN_DOX.NE.1) GO TO 71 JSLN = IN_DO1 JSLE = LQLEND(2) NSLOV = JSLE - JSLN NTKOV = MLIAD(JSLE) - MLIAD(JSLN) NCHPOS = IQ(LARRV+7) NCHPOS = NCHPOS - NTKOV CALL CISEEK (IN_FD,NCHPOS,ISTAT) IF (ISTAT.NE.0) CALL P_KILLM ('CIO seek fails') IQ(LARRV+7) = NCHPOS IQ(LARRV+8) = 0 IQ(LARRV+12) = IQ(LARRV+12) - NSLOV LQLEND(2) = JSLN LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) RETURN C---- REWIND / CLOSE 71 IF (IN_DOX.EQ.0) THEN CALL CIREW (IN_FD) ELSE CALL CICLOS (IN_FD) IQ(LARRV+1) = 0 IQ(LARRV+2) = 0 ENDIF IF (IQ(LARRV+7).GE.0) IQ(LARRV+7)= 0 IQ(LARRV+5) = 0 IQ(LARRV+8) = 0 IQ(LARRV+9) = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, ARRINF, IF=QFIO. +SEQ, QCARD1, R=ARRIN. SUBROUTINE ARRIN C- Read / reposition current input file, using Fortran, C- according to IN_DOX: C- = -1 close, 0 rewind, 1 reposition, 2 read C. started 16-mar-92 +CDE, MQCM, Q, PY. +CDE, ARRCOM. C-------------- End CDE -------------------------------- +SEQ, Q_OR. +SELF, IF=XDEBUG, IF=XLOGCALL. PRINT *, 'Xdebug: arriving in ARRINf, IN_DOX= ',IN_DOX +SELF. IN_LUN = IQ(LARRV+1) IF (IN_DOX.LT.2) GO TO 61 C---- Read IN_EOF = 0 JSLGO = IQ(LQHOLD+1) JSLU = LQLEND(2) JTXU = MLIAD(JSLU) JSLE = JSLU + IN_DO1 JTXE = JTXU + IN_DO2 24 JSLF = JSLU IF (JSLU.GE.JSLE) GO TO 37 IF (JTXU.GE.JTXE) GO TO 37 CALL ARRLN (IN_LUN, TEXT(JTXU),NTXR) IF (NTXR.LT.0) GO TO 31 JTXF = JTXU JTXU = JTXU + NTXR +SELF, IF=QNEWLINE. TEXT(JTXU) = CHAR(NEWLN) JTXU = JTXU + 1 +SELF. JSLU = JSLU + 1 MLIAD(JSLU) = JTXU IF (NTXR.LT.4) GO TO 24 IF (TEXT(JTXF).NE.'+') GO TO 24 CALL NEXTSI (JSLF,JDKNEX,INCRAD) IF (JDKNEX.EQ.0) GO TO 24 IF (JSLF.NE.JSLGO) GO TO 37 IF (JDKNEX.LT.0) GO TO 37 JDKTYP = JDKNEX JDKNEX = 0 JSLF = JSLU GO TO 37 C-- Done 31 IN_EOF = -1 IQ(LARRV+8) = -1 JDKNEX = 6 IF (JSLU.EQ.JSLGO) JDKTYP = 6 37 IQ(LARRV+12) = IQ(LARRV+12) + (JSLU-LQLEND(2)) LQLEND(2) = JSLU LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) IQ(LQHOLD+2) = JSLU - JSLGO IQ(LQHOLD+3) = JSLF - JSLGO IQ(LQHOLD) = IOR (IQ(LQHOLD), 1) RETURN +SEQ, QEJECT, N=22. C---- Reposition the file 61 IF (IN_DOX.EQ.1) CALL P_KILL ('ARRINF - seek not allowed') C---- REWIND IF (IN_DOX.EQ.0) THEN REWIND IN_LUN ELSE CLOSE (IN_LUN) CALL LUNRESV (IN_LUN,0) IQ(LARRV+1) = 0 IQ(LARRV+2) = 0 ENDIF IF (IQ(LARRV+7).GE.0) IQ(LARRV+7)= 0 IQ(LARRV+5) = 0 IQ(LARRV+8) = 0 IQ(LARRV+9) = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, ARRLNF, T=JOIN, IF=QFIO. SUBROUTINE ARRLN (LUN,LINE,NTXR) C- Read one line of text, using Fortran C. started 16-mar-92 CHARACTER LINE*512 +SELF, IF=XDEBUG, IF=XARRLN. PRINT *, 'ARRLN - trying to read 1 line from LUN=',LUN +SELF, IF=QF_DEC. READ (LUN,8000,END=41) NCH, LINE(1:NCH) 8000 FORMAT (Q,A) +SELF, IF=QF_IBM. READ (LUN,NUM=NCH,END=41) LINE +SELF, IF=-QF_IBM, IF=-QF_DEC. READ (LUN,8000,END=41) LINE 8000 FORMAT (A) NCH = LENOCC (LINE) +SELF. NTXR = NCH RETURN C-- EoF 41 NTXR = -1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, ARRNXD. SUBROUTINE ARRNXD (JSTEP) C- Set the limit of the next deck, find type of the deck after C- JSTEP = 1 step to next deck C- 0 find the end of current deck only C- -1 determine also the type of the current deck C. started 5-mar-92 +CDE, Q, PY. C-------------- End CDE -------------------------------- JSLA = IQ(LQHOLD+1) JSLE = JSLA + IQ(LQHOLD+2) C-- JSTEP > 0: step to next deck IF (JSTEP.GT.0) THEN IF (JDKNEX.EQ.-13) CALL P_KILL ('Misplaced +MORE line') +SELF, IF=QDEBUG. IF (JDKNEX.LE.0) CALL P_CRASH ('trouble in ARRNXD') +SELF. JDKTYP = JDKNEX JSLA = JSLA + IQ(LQHOLD+3) IQ(LQHOLD+1) = JSLA IQ(LQHOLD+2) = JSLE - JSLA IF (JDKTYP.NE.6) GO TO 24 RETURN ENDIF C-- JSTEP = <0: type of current deck IF (JSTEP.LT.0) THEN CALL NEXTSI (JSLA,JDKTYP,INCRAD) ENDIF C-- find end of current deck 24 CALL NEXTDE (JSLA+1,JSLE,JSLF,JDKNEX,INCRAD) IQ(LQHOLD+3) = JSLF - JSLA IF (JDKNEX.NE.0) RETURN IF (IQ(LARRV+8).NE.0) JDKNEX= 6 RETURN END +SEQ, QCARDL. ===================================================== +PATCH, DEPART. Output routines +DECK, DPEXGO. SUBROUTINE DPEXGO C- Ready to write first line of new routine, C- called from DPEXE. C. started 21-jan-92 +CDE, SLATE, SLATLN, QBITS19, MQCM. +CDE, MUSEBC, Q, PY. +CDE, CHEXC, CM_TYP, DEPCOM, DEPMOD, DEPSUB, M_ANAC. +CDE, FLINKC. C-------------- End CDE -------------------------------- EQUIVALENCE (LASML,JD_SML), (LASMP,JD_SMP), (LXASM,JD_SMX) CHARACTER CHMARK*1, LINE*256, COLS(256)*1 EQUIVALENCE (LINE,SLLINE) EQUIVALENCE (COLS,LINE) IF (JD_NEW.LT.0) GO TO 29 C-- Decide logical stream at the start of deck JD_DTD = JD_DTN IF (JD_DTD.EQ.0) JD_DTD= JD_DTP JD_DIV = NVEXDK(3) + 2*NVEXDK(4) + 1 C- = 1 normal, 2 diverted, 3 xdiv/normal, 4 xdiv/diverted C-- Find the ASML bank for the logical stream LASMT = LQ(LHASM-JD_DTD) LASML = LQ(LASMT-JD_DIV-1) C-- do the re-assignment if requested J = IQ(LASML+11) IF (J.NE.0) THEN JD_DTD = J/8 J = MOD (J,8) IF (J.NE.0) JD_DIV= J LASMT = LQ(LHASM-JD_DTD) LASML = LQ(LASMT-JD_DIV-1) ENDIF +SEQ, QEJECT. C-- Find the ASML bank for the physical stream MUSE = IQ(LASML+1) IF (MUSE.EQ.0) THEN LASMP = LASML JDP_DT = JD_DTD JDP_DV = JD_DIV GO TO 24 ENDIF JDP_DT = MUSE / 8 JDP_DV = MOD (MUSE,8) LASM = LQ(LHASM-JDP_DT) IF (JDP_DV.NE.0) THEN LASMP = LQ(LASM-JDP_DV-1) ELSE LASMP = LASM ENDIF 24 LXASM = LQ(LASMP-1) C---- Decide the processing mode IQ(LASML+8) = IQ(LASML+8) + 1 JD_SPL = IQ(LASMP+2) JD_MOD = 0 C-- exit for T=BYPASS IF (JD_SPL.EQ.0) THEN NVEXDK(1) = 0 NVEXDK(5) = NVEXDK(2) IQ(LXASM+3) = IQ(LXASM+3) + 1 RETURN ENDIF IX_EXT = IQ(LASML+5) IX_RH = IQ(LASML+6) IX_SUB = IQ(LASML+7) IF (IX_SUB.EQ.0) GO TO 29 C-- prepare the control-character substitution ready for use CALL NA_GET (IX_SUB,LINE,1) NCH_SUB = MIN (8, NDSLAT/2) JJ = 0 DO 27 J=1,NCH_SUB CH_SUBS(J:J) = COLS(JJ+1) CH_SUBT(J:J) = COLS(JJ+2) 27 JJ = JJ + 2 C---- All mode parameters ready, start 29 JD_NEW = 0 JD_NLI = 0 JD_LUN = IQ(LXASM+2) JD_MOD = JD_SPL IF (NEWINC.NE.0) JD_MOD= 0 IF (JD_MOD.LT.3) JD_MOD= 0 IF (JD_SPL.GE.2) GO TO 41 +SEQ, QEJECT. C------ Normal sequential mode --------------- IF (JD_LUN.GT.0) GO TO 34 C-- open output file for first deck on this stream LUN_TYP = LUN_TYP + 1 JD_LUN = LUN_TYP IXFLUN = IQ(LASMP+3) IF (IXFLUN.EQ.0) + CALL P_FATAL ('output file name missing') CALL FLINK (JD_LUN, 6, -1, 0) IF (IXFLUN.LT.0) CALL P_FATAL ('OPEN failure') +SELF, IF=QCIO. JD_LUN = LUNFD +SELF. IQ(LXASM+2) = JD_LUN C-- Write routine header card if needed 34 IF (IX_RH.EQ.0) RETURN JTX = NA_JTX (IX_RH) NTX = NDSLAT CHMARK = TEXT(JTX) JTX = JTX + 1 NTX = NTX - 1 NPUT = 0 37 JF = ICFILA (CHMARK,TEXT(JTX),1,NTX) N = JF - 1 IF (N.GT.0) THEN CALL CCOPYL (TEXT(JTX),COLS(NPUT+1),N) NPUT = NPUT + N JTX = JTX + N NTX = NTX - N ENDIF IF (NTX.GT.0) THEN CALL NA_GET (IXEXID,LINE,NPUT+1) NPUT = NESLAT - 1 JTX = JTX + 1 NTX = NTX - 1 IF (NTX.GT.0) GO TO 37 ENDIF +SELF, IF=QCIO. NPUT = NPUT + 1 LINE(NPUT:NPUT) = CHAR(NEWLN) CALL CIPUT (JD_LUN,LINE,NPUT,ISTAT) IF (ISTAT.NE.0) CALL P_FATAM ('CIO write fails') +SELF, IF=QFIO. WRITE (JD_LUN, '(A)') LINE(1:NPUT) +SELF. JD_NLI = 1 RETURN +SEQ, QEJECT. C------ SPLIT mode --------------- 41 IF (JD_LUN.GE.0) GO TO 44 IQ(LXASM+2) = 0 IXFLUN = IQ(LASMP+3) IF (IXFLUN.EQ.0) GO TO 44 C-- open the log file for first deck on this stream LUN_TYP = LUN_TYP + 1 JD_LUN = LUN_TYP CALL FLINK (JD_LUN, 6, -1, 0) IF (IXFLUN.LT.0) CALL P_FATAL ('OPEN failure') +SELF, IF=QCIO. JD_LUN = LUNFD +SELF. IQ(LXASM+2) = JD_LUN C-- construct the file name for the split file 44 JD_LOG = JD_LUN JD_LUN = IQ(LHASM+1) CHLIFI = ' ' JP = 1 IX = IQ(LASMP+4) IF (IX.NE.0) THEN CALL NA_GET (IX, CHLIFI, JP) JP = NESLAT ENDIF CALL NA_GET (IXEXID, CHLIFI, JP) CALL CUTOL (CHLIFI(JP:NESLAT)) JP = NESLAT IF (IX_EXT.NE.0) THEN CALL NA_GET (IX_EXT, CHLIFI, JP) JP = NESLAT ENDIF NLIFI = JP - 1 MODEFI = 6 IF (JD_MOD.NE.0) MODEFI= 7 CALL FLINK (JD_LUN, MODEFI, 0, 0) IF (IXFLUN.LT.0) CALL P_FATAL ('OPEN failure') IF (LUNOLD.EQ.0) JD_MOD = 0 +SELF, IF=QCIO. JD_LUN = LUNFD +SELF. IF (JD_MOD.EQ.0) RETURN C------ Initiate processing for MODIFY --------------- MO_JSA = LQLEND(3) MO_JSL = MO_JSA MO_JSE = LQLSTA(4) +SELF, IF=QCIO. JTXA = MLIAD(MO_JSA) JTXE = MLIAD(MO_JSE) NMAX = JTXE - JTXA - 2048 IF (LUNSIZ.GE.NMAX) GO TO 79 CALL CIGET (JD_LUN, TEXT(JTXA), NMAX, NTXR, ISTAT) IF (ISTAT.NE.0) GO TO 79 JTXE = JTXA + NTXR JSLE = MO_JSL LIMIT = MO_JSE - 4 DO 54 JTX=JTXA,JTXE-1 IF (ICHAR(TEXT(JTX)).EQ.NEWLN) THEN JSLE = JSLE + 1 MLIAD(JSLE) = JTX + 1 IF (JSLE.GE.LIMIT) GO TO 79 ENDIF 54 CONTINUE IF (MLIAD(JSLE).NE.JTXE) THEN TEXT(JTXE) = CHAR(NEWLN) JTXE = JTXE + 1 JSLE = JSLE + 1 MLIAD(JSLE) = JTXE ENDIF MO_JSE = JSLE LQLEND(3) = JSLE RETURN 79 JD_MOD = 0 +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPEXE. SUBROUTINE DPEXE (LDO) C- EXE output of next lot C. started 21-jan-92 +CDE, CCPARA, MUSEBC, Q, PY. +CDE, DEPCOM, DEPSUB. C-------------- End CDE -------------------------------- JSLX = IQ(LDO+1) NSLX = IQ(LDO+2) IF (JCCTYP.NE.0) THEN JSLX = JSLX + 1 NSLX = NSLX - 1 ENDIF IF (NSLX.LE.0) RETURN IF (JD_NEW.NE.0) THEN CALL DPEXGO IF (NVEXDK(1).EQ.0) RETURN ENDIF JD_NLI= JD_NLI + NSLX C-- Control character substitution IF (IX_SUB.EQ.0) GO TO 31 JSL = JSLX N = NCH_SUB DO 24 JJ=1,NSLX JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.LT.4) GO TO 24 J = INDEX (CH_SUBS(1:N),TEXT(JTX)) IF (J.EQ.0) GO TO 24 IF (JPTYPE(TEXT(JTX)).EQ.0) GO TO 24 TEXT(JTX) = CH_SUBT(J:J) 24 JSL = JSL + 1 C---- Normal output without MODIFY check 31 IF (JD_MOD.NE.0) GO TO 41 +SELF, IF=QCIO. 32 JTX = MLIAD(JSLX) NTX = MLIAD(JSLX+NSLX) - JTX CALL CIPUT (JD_LUN,TEXT(JTX),NTX,ISTAT) IF (ISTAT.NE.0) CALL P_FATAM ('CIO write fails') +SELF, IF=QFIO. 32 JSL = JSLX DO 34 JJ=1,NSLX JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.NE.0) THEN +SELF, IF=QFIO, IF=QF_IBM. IF (JD_DTD.EQ.1) NTX= MIN(NTX,80) +SELF, IF=QFIO. CALL DPEXLN (TEXT(JTX), NTX) ELSE WRITE (JD_LUN, '(A)') ENDIF 34 JSL = JSL + 1 +SELF. RETURN C---- Output for MODIFY 41 CALL DPEXMO (JSLX,NSLX) IF (JD_MOD.EQ.0) GO TO 32 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPEXLNF, T=JOIN, IF=QFIO. SUBROUTINE DPEXLN (LINE,NTX) C- Write one line, using Fortran C. started 7-oct-93 +CDE, DEPCOM. C-------------- End CDE -------------------------------- CHARACTER LINE*512 WRITE (JD_LUN, '(A)') LINE(1:NTX) RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPEXMOC, IF=QCIO. +SEQ, QCARD1, R=DPEXMO. SUBROUTINE DPEXMO (JSLP,NSLP) C- MODIFY: check new lines against disk file C- if NSL zero: check we have actually reached the EoF C. started 7-OCT-93 +CDE, FLINKC, DEPCOM, DEPMOD, Q. C-------------- End CDE -------------------------------- JSLX = JSLP NSLX = NSLP IF (NSLX.EQ.0) GO TO 41 IF (MO_JSL+NSLX.GT.MO_JSE) GO TO 44 JTX = MLIAD(JSLX) JMO = MLIAD(MO_JSL) NTX = MLIAD(JSLX+NSLX) - JTX NMO = MLIAD(MO_JSL+NSLX) - JMO IF (NMO.NE.NTX) GO TO 44 IF (ICEQU(TEXT(JTX),TEXT(JMO),NTX).NE.0) GO TO 44 MO_JSL = MO_JSL + NSLX RETURN C-- Check Eof reached 41 IF (MO_JSL.EQ.MO_JSE) RETURN C-- Comparison failure, re-write the material up to now 44 JD_MOD = 0 CALL CICLOS (JD_LUN) CALL CIOPEN (JD_LUN, 'w', CHLIFI(1:NLIFI), ISTAT) IF (ISTAT.NE.0) CALL P_FATAM ('CIO open for re-write fails') JMO = MLIAD(MO_JSA) NMO = MLIAD(MO_JSL) - JMO IF (NMO.EQ.0) RETURN CALL CIPUT (JD_LUN,TEXT(JMO),NMO,ISTAT) IF (ISTAT.NE.0) CALL P_FATAM ('CIO write fails') RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPEXMOF, IF=QFIO, IF=-QS_VMS. +SEQ, QCARD1, R=DPEXMO. SUBROUTINE DPEXMO (JSLP,NSLP) C- MODIFY: check new lines against disk file C- if NSL zero: check we have actually reached the EoF C. started 8-Nov-93 +CDE, SLATLN, DEPCOM, DEPMOD, Q. C-------------- End CDE -------------------------------- JSLX = JSLP NSLX = NSLP IF (NSLX.EQ.0) GO TO 61 21 JMO = MLIAD(MO_JSL) CALL ARRLN (JD_LUN, TEXT(JMO), NTX) IF (NTX.LT.0) GO TO 41 JTX = MLIAD(JSLX) N = MLIAD(JSLX+1) - JTX - NCHNEWL IF (N.NE.NTX) GO TO 40 IF (NTX.NE.0) THEN IF (ICEQU(TEXT(JTX),TEXT(JMO),NTX).NE.0) GO TO 40 ENDIF MLIAD(MO_JSL+1) = JMO + NTX JSLX = JSLX + 1 NSLX = NSLX - 1 IF (NSLX.NE.0) GO TO 21 RETURN C-- Comparison failure, reposition 40 BACKSPACE JD_LUN 41 JSLP = JSLX NSLP = NSLX JD_MOD = 0 RETURN C-- Check EoF reached 61 CALL ARRLN (JD_LUN, SLLINE, NTX) IF (NTX.LT.0) RETURN BACKSPACE JD_LUN ENDFILE JD_LUN JD_MOD = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPEXMOX, IF=QFIO, IF=QS_VMS. SUBROUTINE DPEXMO (JSLP,NSLP) C- MODIFY: check new lines against disk file C- if NSL zero: check we have actually reached the EoF C. started 8-Nov-93 +CDE, SLATLN, DEPCOM, DEPMOD, Q. C-------------- End CDE -------------------------------- JSLX = JSLP NSLX = NSLP IF (NSLX.EQ.0) GO TO 41 JSLU = MO_JSL JMO = MLIAD(JSLU) 21 CALL ARRLN (JD_LUN, TEXT(JMO), NTX) IF (NTX.LT.0) GO TO 42 JTX = MLIAD(JSLX) N = MLIAD(JSLX+1) - JTX - NCHNEWL IF (N.NE.NTX) GO TO 42 IF (NTX.NE.0) THEN IF (ICEQU(TEXT(JTX),TEXT(JMO),NTX).NE.0) GO TO 42 ENDIF JMO = JMO + NTX +SELF, IF=QNEWLINE. TEXT(JMO) = CHAR(NEWLN) JMO = JMO + 1 +SELF. JSLU = JSLU + 1 MLIAD(JSLU) = JMO JSLX = JSLX + 1 NSLX = NSLX - 1 IF (NSLX.NE.0) GO TO 21 MO_JSL = JSLU RETURN C-- Check EoF reached 41 CALL ARRLN (JD_LUN, SLLINE, NTX) IF (NTX.LT.0) RETURN C-- Comparison failure, re-write the material up to now 42 JD_MOD = 0 CLOSE (JD_LUN) CALL FLINK (JD_LUN, 6, 0, 0) JSL = MO_JSA - 1 44 JSL = JSL + 1 IF (JSL.GE.MO_JSL) RETURN JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.NE.0) THEN CALL DPEXLN (TEXT(JTX), NTX) ELSE WRITE (JD_LUN, '(A)') ENDIF GO TO 44 END +SEQ, QCARDL. ===================================================== +DECK, DPEXTM. SUBROUTINE DPEXTM (JTERM) C- End of deck or routine C- JTERM = +1 end of deck C- -1 about to start a new routine in the same deck C. started 6-oct-93 +CDE, SLATLN, SLATE, QBITS19, QBANKS, QPAGE, QUNIT. +CDE, CHEXC, CM_TYP, DEPCOM, FLINKC, INCLC, MUSEBC, Q, PY. C-------------- End CDE -------------------------------- EQUIVALENCE (LASML,JD_SML), (LASMP,JD_SMP), (LXASM,JD_SMX) CHARACTER LINE*128 EQUIVALENCE (LINE,SLLINE) +SEQ, Q_OR. IF (JD_SPL.LT.2) GO TO 41 C------ SPLIT or MODIFY mode: close split file +SELF, IF=QMVAX. C-- if assembler: write .END line IF (JD_DTD.EQ.JAS_TYP) CALL DPEXVAX +SELF. C-- if MODIFY: check EoF reached IF (JD_MOD.NE.0) CALL DPEXMO (0,0) C-- register the name of the include file IF (JD_DTD.EQ.JIN_TYP) THEN CALL MQLIFT (L, LQINCL,1, JBKINC,3) IQ(L) = IOR (IQ(L), MX_SELF) IQ(L+1) = IXEXID IF (JD_MOD.EQ.0) IQ(L)= IOR (IQ(L),KM5) ENDIF +SELF, IF=QCIO. CALL CICLOS (JD_LUN) +SELF, IF=QFIO. CLOSE (JD_LUN) +SELF. +SEQ, QEJECT. C-- Write the entry into the log file IF (JD_LOG.LE.0) GO TO 37 LINE = ' ' CALL STRMID (JD_DTD, JD_DIV, LINE,2) N = MAX(NESLAT,12) + 1 CALL NA_GET (IXEXID, LINE,N) N = NESLAT IF (IX_EXT.NE.0) THEN CALL NA_GET (IX_EXT, LINE,N) N = NESLAT ENDIF C-- add the names of the called include files IF (JD_MOD.EQ.0) GO TO 33 LINE(N+3:N+6) = 'same' N = N + 6 33 JTK = 0 IF (N_INCL.EQ.0) GO TO 36 34 JTK = JTK + 1 CALL NA_GET (IX_INCL(JTK),LINE,N+2) N = NESLAT + 1 LINE(N-1:N) = '.h' IF (JTK.EQ.N_INCL) GO TO 36 IF (N.LT.72) GO TO 34 N = N + 2 LINE(N:N) = '+' 36 CALL CUTOL (LINE(1:N)) +SELF, IF=QCIO. N = N + 1 LINE(N:N) = CHAR(NEWLN) CALL CIPUT (JD_LOG, LINE,N, ISTAT) IF (ISTAT.NE.0) CALL P_FATAM ('CIO write fails') +SELF, IF=QFIO. WRITE (JD_LOG,9000) LINE(1:N) +SELF. IF (JTK.LT.N_INCL) THEN LINE = ' ' N = 10 GO TO 34 ENDIF 37 IF (JD_MOD.NE.0) GO TO 79 C------ Accounting 41 IQ(LXASM+4) = IQ(LXASM+4) + JD_NLI IQ(LASML+10) = IQ(LASML+10) + JD_NLI IQ(LXASM+3) = IQ(LXASM+3) + 1 IF (JD_MULT.EQ.0) THEN IQ(LASML+9) = IQ(LASML+9) + 1 ENDIF C-- Print the log line for option MAPASM IF (MOPTIO(13).EQ.0) GO TO 78 LINE = ' Written' CALL CSETDI (NQDKNO, LINE,10,17) LINE(19:20) = 'p=' CALL NA_GET (IXEXPAT,LINE,21) JP = MAX (NESLAT,29) LINE(JP+1:JP+2) = 'd=' CALL NA_GET (IXEXDEC,LINE,JP+3) JP = MAX (NESLAT,44) CALL CSETDI (JD_NLI, LINE,JP+1,JP+5) LINE(JP+7:JP+14) = 'lines to' JP = JP + 15 IF (JD_SPL.LT.2) THEN LINE(JP+1:JP+7) = 'logical' JP = JP + 9 CALL STRMID (JD_DTD, JD_DIV, LINE,JP) N = NESLAT - 1 ELSE LINE(JP+1:JP+4) = 'file' JP = JP + 5 LINE(JP+1:JP+NLIFI) = CHLIFI(1:NLIFI) N = JP + NLIFI ENDIF WRITE (IQPRNT,9000) LINE(1:N) NQUSED = NQUSED + 1 NQLLBL = 0 78 JD_MULT = JD_MULT + 1 79 JD_NLI = 0 JD_NEW = JTERM RETURN 9000 FORMAT (A) END +SEQ, QCARDL. ===================================================== +DECK, DPEXVAX, IF=QMVAX. SUBROUTINE DPEXVAX C- On the VAX at the end of an assembler routine in SPLIT mode: C- write a .END line to keep the assembler happy +CDE, CCPARA. +CDE, MUSEBC, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*80 EQUIVALENCE (LINE,TEXT) IF (MOPTIO(24).NE.0) RETURN C! IF (NVEXDK(5).EQ.0) RETURN IF (NVEXDK(1).EQ.0) RETURN LINE(1:10) = ' .END' C- _:.=+=.: 1 JTX = 6 +SELF, IF=QNEWLINE. TEXT(JTX) = CHAR(NEWLN) JTX = JTX + 1 +SELF. MLIAD(2) = JTX LQ(LSERV-2) = 0 IQ(LSERV+1) = 1 IQ(LSERV+2) = 1 IQ(LSERV+3) = -99 JCCTYP = 0 C! IF (NVEXDK(2).NE.0) THEN C! CALL DPLIST (0,LSERV,0,0) C! ENDIF C! IF (NVEXDK(1).EQ.0) RETURN CALL DPEXE (LSERV) RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPHEAD. SUBROUTINE DPHEAD C- LIST current deck/patch identifier if not yet done; C- if done but page almost full: page eject C. started 10-feb-92 +CDE, SLATE, QPAGE, QUNIT. +CDE, CHEXC, MUSEBC, Q, PY. C-------------- End CDE -------------------------------- IF (NQNEWH.NE.0) GO TO 21 IF (NQUSED.GE.NQLTOK) GO TO 32 RETURN C-- start ouput for new deck 21 NQDKPG = 0 CHEXPD = 'p=' CALL NA_GET (IXEXPAT,CHEXPD,3) IF (IXEXDEC.NE.0) THEN J = NESLAT + 3 CHEXPD(J-2:J-1) = 'd=' CALL NA_GET (IXEXDEC,CHEXPD,J) ENDIF NCHEPD = NESLAT - 1 IF (NVEXDK(2).EQ.0) GO TO 24 IF (MOPTIO(3).NE.0) GO TO 24 IF (NQJOIN.NE.0) GO TO 24 IF (NQUSED.LE.8) GO TO 32 C-- first deck in a patch with a short blank deck? IF (NQLPAT.EQ.0) GO TO 31 IF (IXEXDEC.EQ.0) GO TO 31 IF (NQUSED-NQLPAT.GT.8) GO TO 31 24 IF (NQUSED.LT.NQLTOL) GO TO 32 31 NQUSED = NQLMAX 32 CALL DPPAGE NQNEWH = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPPAGE. SUBROUTINE DPPAGE C- LIST current deck/patch identifier, with or without page eject C. started 10-sep-93 +CDE, SLATE, SLATLN. +CDE, QCHAR, QPAGE, QUNIT, CHEXC. C-------------- End CDE -------------------------------- CHARACTER TAIL*13 EQUIVALENCE (TAIL, SLLINE(161:)) NQJOIN = 0 NQLPAT = 0 IF (NQUSED.GT.NQLMAX) THEN NQUSED = NQUSED - NQLMAX RETURN ENDIF IF (NQUSED.LT.NQLTOL) THEN NEWPAG = 0 ELSE NEWPAG = 1 ENDIF NCOL = NQCPGH SLLINE(1:176) = ' ' C-- construct left edge: 167 PATCHY CALL CSETDI (NQDKNO, SLLINE, 2,6) CALL CLEFT (SLLINE, 3,6) J = NESLAT + 1 IF (IXEXPAM.NE.0) THEN CALL NA_GET (IXEXPAM, SLLINE(1:J+7), J) JEQ = NESLAT + 2 ELSE SLLINE(J:J+5) ='cradle' JEQ = J + 8 ENDIF C-- prepare right edge: P=pname dname 1 === pg 123 C- _:.=+=.: 1_:. NQDKPG = NQDKPG + 1 CALL CSETDI (NQDKPG, TAIL, 1,2) JID = NCOL - 13 - NCHEPD SLLINE(JID:JID+NCHEPD-1) = CHEXPD(1:NCHEPD) IF (NQNEWH.EQ.0) GO TO 27 C-- starting a new deck NEQ = JID - JEQ - 2 IF (NEQ.GT.0) SLLINE(JEQ:JEQ+NEQ-1)= CQEQS(1:NEQ) IF (NEWPAG.EQ.0) THEN TAIL(4:13)= CQEQS(1:10) ELSE TAIL(4:6)= CQEQS(1:3) ENDIF C-- page eject? 27 IF (NEWPAG.EQ.0) GO TO 31 SLLINE(1:1) = '1' NQPAGE = NQPAGE + 1 CALL CSETDI (NQPAGE, TAIL,11,13) J = NFSLAT - 2 TAIL(J:J+1) = 'pg' SLLINE(NCOL-12:NCOL) = TAIL WRITE (IQPRNT,9028) SLLINE(1:NCOL) NQUSED = 2 NQLLBL = 1 RETURN 31 CALL DPBLAN (0) SLLINE(NCOL-12:NCOL) = TAIL WRITE (IQPRNT,9028) SLLINE(1:NCOL) NQUSED = NQUSED + 2 RETURN 9028 FORMAT (A/) END +SEQ, QCARDL. ===================================================== +DECK, DPLIST. SUBROUTINE DPLIST (MODE,LDO,LACT,IFLSTA) C- LIST output of next lot for DOXQT C- MODE = 0 self material C- 1 CDE expansion called from X_SEQ C- 2 comment line C- 3 +SELF header line C- 4 +CDE call line C- 5 foreign material to be stored C- 6 control line C- LDO bank holding the lines to be listed C- LACT if = zero: material of this deck C- if /=zero: ACT bank driving the material into this deck C- IFLSTA if = zero: material group continued C- if > zero: start of a material group C- = 1: basic level, > 1: higher levels C- (used only for MODEAN = 1 and 5) C- also: JCCTYP in /CCPARA/ is the type of the first line in LDO C. started 21-jan-92 +CDE, QBITS19, QPAGE, QUNIT. +CDE, CCTYPE, CCPARA, MUSEBC, TAGC, MQCM, Q, PY. C-------------- End CDE -------------------------------- CHARACTER MASKF*4, MASKL*4, MASKK(4)*4 DATA MASKK / ' z ', ' .z ', ' y ', ' .y ' / +SEQ, Q_JBYT, Q_AND. IF (NQNEWH.NE.0) CALL DPHEAD IFLBL = 0 IFLAFT = 0 JSL = IQ(LDO+1) NSL = IQ(LDO+2) IF (NSL.LE.0) RETURN IF (MODE.EQ.1) GO TO 54 IFLDEL = IAND (IQ(LDO),KM5+KM6) IFLCUT = IFLDEL LNACT = LACT IF (LNACT.EQ.0) GO TO 38 LNORG = IQ(LDO-2) LINUM = IQ(LDO+3) LEVEL = JBYT (IQ(LDO),21,5) CALL DPTAG (0,LEVEL,0) GO TO 39 38 LLACT = 0 LLORG = 0 IF (JSL.LT.LQLEND(2)) THEN LINUM = JSL - JSLORG ELSE LINUM = -9999 ENDIF 39 JUMP = MODE + 1 GO TO (44, 54, 61, 41, 51, 71, 80), JUMP C- mode= 0 1 2 3 4 5 6 +SELF, IF=QDEBUG. CALL P_CRASH (' DPLIST - invalid MODE') +SELF. +SEQ, QEJECT. C---- Self material 41 IFLBL = 1 MASKF = ' + ' MASKL = ' - ' IF (JCCTYP.NE.MCCFAU) GO TO 81 MASKF= '!!!!' IFLCUT = 7 GO TO 81 44 MASKL = ' - ' IF (JCCTYP.EQ.0) GO TO 84 MASKF = ' -- ' IF (JCCTYP.EQ.MCCEND) THEN IFLAFT = IAND (IQ(LDO),KM17) ELSE IFLBL = IAND (IQ(LDO),KM17) ENDIF GO TO 81 C---- CDE expansion 51 MASKF = ' : ' GO TO 81 54 IFLDEL = 0 IFLCUT = 0 LINUM = -9999 MASKL = ' ' IF (IFLSTA.EQ.0) GO TO 84 J = MIN (IFLSTA,2) IF (IFALTN.NE.0) J= J+2 MASKF = MASKK(J) GO TO 81 C---- Comment 61 MASKF = ' c ' GO TO 81 C---- Foreign material out from this deck 71 MASKL = ' > ' IF (IFLSTA.EQ.0) GO TO 84 IFLBL = 1 IF (JCCTYP.EQ.MCCKEE) GO TO 80 IF (IAND(IQ(LDO),KM18).NE.0) GO TO 80 MASKF = ' ++ ' GO TO 81 C---- Stand-alone control line 80 MASKF = ' + ' IF (JCCTYP.GE.MCCDEC) IFLBL= 1 C---- list the control-line first 81 IF (NVEXDK(6).EQ.0) GO TO 82 IF (LNACT.NE.0) MASKF(1:1) = '<' IF (IFLDEL.NE.0) MASKF(3:3) = '(' IF (IFLBL.NE.0) THEN IF (NQUSED.GE.NQLTOK) THEN CALL DPPAGE ELSE CALL DPBLAN (1) ENDIF ENDIF JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL CALL DPLINE (LINUM, MASKF, NTX, TEXT(JTX)) C-- print line with env. variable substituition IF (ICCSUB.NE.0) CALL DPLINE (-1, ' ', NCHCCT, CCKORG) ICCSUB = 0 IF (IFLAFT.NE.0) CALL DPBLAN (-1) 82 JSL = JSL + 1 IF (IFLCUT.NE.0) RETURN NSL = NSL - 1 IF (NSL.LE.0) RETURN LINUM = LINUM + 1 C---- list the body of the lines 84 IF (LNACT.NE.0) MASKL(1:1) = '<' IF (IFLDEL.NE.0) MASKL(2:2) = '(' DO 87 JJ=1,NSL JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL CALL DPLINE (LINUM, MASKL, NTX, TEXT(JTX)) LINUM = LINUM + 1 87 JSL = JSL + 1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPLINE. SUBROUTINE DPLINE (LINUM,MASK,NCHL,LINE) C- Print one line for LIST C- LINUM is the line-number, not printed if -ve, C- MASK is the line-type identifier C- LINE of length NCHL is the text, void if NCHL <= 0 C. started 5-aug-93 +CDE, QCHAR, QPAGE, QUNIT, TAGC. C-------------- End CDE -------------------------------- CHARACTER CHNUM*6, MASK*4, LINE*512 IF (NQUSED.GE.NQLMAX) CALL DPPAGE IF (NQWYLDO.NE.0) GO TO 41 C------ Without Wylbur line-numbers IF (NCHTAG.NE.0) THEN IF (92+NCHTAG.GE.NQCMAX) GO TO 31 ENDIF 21 NQUSED = NQUSED + 1 NQLLBL = 0 C- _:.=+= CHNUM = ' ' IF (LINUM.GE.0) CALL CSETDI (LINUM,CHNUM,2,6) C-- LINE is void IF (NCHL .GT.0) GO TO 25 IF (NCHTAG.EQ.0) THEN WRITE (IQPRNT,9021) CHNUM,MASK ELSE WRITE (IQPRNT,9022) CHNUM,MASK,CHTAG(1:NCHTAG) NCHTAG = 0 ENDIF RETURN C-- LINE is present 25 JE = NCHL IF (JE.GT.80) JE= ICFILA(' ', LINE,60,80) - 1 IF (NCHTAG.EQ.0) THEN WRITE (IQPRNT,9025) CHNUM,MASK,LINE(1:JE) ELSE WRITE (IQPRNT,9026) CHNUM,MASK,LINE(1:JE),CHTAG(1:NCHTAG) NCHTAG = 0 ENDIF IF (JE.EQ.NCHL) RETURN C-- LINE is longer than 80 characters 28 JA = JE + 1 JE = NCHL IF (JE-JA.GE.72) JE= ICFILA(' ', LINE,JA+51,JA+71) - 1 WRITE (IQPRNT,9028) LINE(JA:JE) NQUSED = NQUSED + 1 IF (JE.LT.NCHL) GO TO 28 RETURN C-- Print the tag stand-alone, if too long 31 IF (NQUSED.GE.NQLTOK) CALL DPPAGE NBL = NQCMAX - NCHTAG WRITE (IQPRNT,9025) CQBLAN(1:NBL), CHTAG(1:NCHTAG) NQUSED = NQUSED + 1 NCHTAG = 0 IF (NQWYLDO.EQ.0) GO TO 21 +SEQ, QEJECT. C------ With Wylbur line-numbers 41 IF (NCHTAG.NE.0) THEN IF (102+NCHTAG.GE.NQCMAX) GO TO 31 ENDIF NQUSED = NQUSED + 1 NQLLBL = 0 IF (NQWYLDO.LT.0) THEN IF (NQWYLDO.LT.-2) GO TO 43 IF (NQWYLDO.EQ.-2) CHWYL = ' ' NQWYLDO = NQWYLDO - 1 GO TO 43 ENDIF IF (LINUM.LT.0) THEN CHWYL = ' ' GO TO 43 ENDIF C- _:.=+=.: 1_:.=+=.: 2 C- 123456. 12345 CHWYL = ' . ' NQWYL = NQWYL + 1 CALL CSETDI (NQWYL,CHWYL,2,9) CALL CSETDI (LINUM,CHWYL,11,16) C-- LINE is void 43 IF (NCHL .GT.0) GO TO 45 IF (NCHTAG.EQ.0) THEN WRITE (IQPRNT,9021) CHWYL,MASK ELSE WRITE (IQPRNT,9023) CHWYL,MASK,CHTAG(1:NCHTAG) NCHTAG = 0 ENDIF RETURN C-- LINE is present 45 JE = NCHL IF (JE.GT.80) JE= ICFILA(' ', LINE,60,80) - 1 IF (NCHTAG.EQ.0) THEN WRITE (IQPRNT,9025) CHWYL,MASK,LINE(1:JE) ELSE WRITE (IQPRNT,9027) CHWYL,MASK,LINE(1:JE),CHTAG(1:NCHTAG) NCHTAG = 0 ENDIF IF (JE.EQ.NCHL) RETURN C-- LINE is longer than 80 characters 48 JA = JE + 1 JE = NCHL IF (JE-JA.GE.72) JE= ICFILA(' ', LINE,JA+51,JA+71) - 1 WRITE (IQPRNT,9029) LINE(JA:JE) NQUSED = NQUSED + 1 IF (JE.LT.NCHL) GO TO 48 RETURN 9021 FORMAT (A,A) 9022 FORMAT (A,A,T92,A) 9023 FORMAT (A,A,T102,A) 9025 FORMAT (A,A,A) 9026 FORMAT (A,A,A,T92,A) 9027 FORMAT (A,A,A,T102,A) 9028 FORMAT (17X,'>',A) 9029 FORMAT (27X,'>',A) END +SEQ, QCARDL. ===================================================== +DECK, DPTAG. SUBROUTINE DPTAG (MODE,LEVEL,IXKEEP) C- Construct the next tail C- MODE = zero: normal P/D tag C- 1: action line C- = 2: KEEP tag C- C- LEVEL = 0, 1, 2, 3 ... foreign-in-foreign level C- C- IXKEEP the name index of the sequence for MODE 2 C- = 0 if material continued C. started 20-sept-93 +CDE, SLATE, QBITS19, QCHAR, QPAGE, QUNIT. +CDE, TAGC, Q, PY. C-------------- End CDE -------------------------------- CHARACTER MASK*4, MASKK(5)*4 DATA MASKK / ' x- ', ' z- ', ' .z-', ' y- ', ' .y-' / +SEQ, Q_JBYT, Q_AND. MODEX = MODE LEV = LEVEL IF (NCHTAG.LE.0) GO TO 29 IF (LMODE.LT.0) GO TO 29 C-- Print pending tag J = 1 IF (LMODE.GE.2) THEN J = MIN (LMODE,3) IF (LALTN.NE.0) J= J+2 ENDIF MASK = MASKK(J) NBL = NQCMAX - NCHTAG - 10 NBL = MIN (NBL,81) CALL DPHEAD NQUSED = NQUSED + 1 NQLLBL = 0 WRITE (IQPRNT,9024) MASK,CQBLAN(1:NBL),CHTAG(1:NCHTAG) 9024 FORMAT (6X,A,A,A) NCHTAG = 0 29 NUMORG = IAND (IQ(LNORG), KM19-1) CHTAG(1:10) = ' ' IF (MODEX.EQ.2) GO TO 61 C-- Check same tag again IF (LNORG.EQ.0) GO TO 49 IF (LNORG.NE.LLORG) GO TO 41 IF (LNACT.NE.LLACT) GO TO 41 IF (LMODE.GE.2) GO TO 41 RETURN C-- Ready new tag C-- normal P/D tag 41 IF (MODEX.EQ.0) CALL CSETDI (LEV+1,CHTAG,1,1) CALL CSETDI (NUMORG, CHTAG,4,9) CALL CLEFT (CHTAG,4,9) JP = NESLAT C-- P/D tag IXPAT = IQ(LNORG+1) IXDECK = IQ(LNORG+2) IF (LEV.NE.0) THEN CHTAG(2:2) = 'x' GO TO 47 ENDIF JTYPE = JBYT (IQ(LNACT),9,3) IF (JTYPE.EQ.0) THEN CHTAG(2:2) = 'D' ELSEIF (JTYPE.EQ.1) THEN CHTAG(2:2) = 'R' ELSEIF (JTYPE.EQ.2) THEN CHTAG(2:2) = 'B' ELSE CHTAG(2:2) = 'A' ENDIF 47 CHTAG(JP:JP) = '=' JP = JP + 1 CALL NA_GET (IXPAT,CHTAG,JP) JP = NESLAT CHTAG(JP:JP) = '.' JP = JP + 1 CALL NA_GET (IXDECK,CHTAG,JP) NCHTAG = NESLAT - 1 49 LLORG = LNORG LLACT = LNACT LMODE = MODEX RETURN C-- KEEP tag 61 IF (LEV.NE.0) CALL CSETDI (LEV+1,CHTAG,1,1) CHTAG(2:2) = 'Z' IF (IXKEEP.EQ.0) THEN IF (LNORG.EQ.LLORG) THEN IF (MODEX+LEV.EQ.LMODE) GO TO 69 ENDIF CHTAG(4:12) = 'continued' NCHTAG = 12 GO TO 69 ENDIF CALL CSETDI (NUMORG, CHTAG,4,9) CALL CLEFT (CHTAG,4,9) JP = NESLAT CHTAG(JP:JP) = ':' JP = JP + 1 CALL NA_GET (IXKEEP,CHTAG,JP) NCHTAG = NESLAT - 1 69 LLORG = LNORG LMODE = MODEX + LEV LALTN = IFALTN RETURN END +SEQ, QCARDL. ===================================================== +DECK, DPLACT. SUBROUTINE DPLACT C- LIST what action at LUPAN C. started 10-feb-92 +CDE, SLATLN, QBITS19. +CDE, TAGC, Q, PY, MUSEBC. +CDE, M_ANAC. C-------------- End CDE -------------------------------- CHARACTER LINE*80, MARK*18, MSG*14 EQUIVALENCE (LINE,SLLINE), (MSG,SLERRM) EQUIVALENCE (MARK,SLLINE(63:)) +SEQ, Q_JBYT, Q_AND. C-- Print clash warning LEVCL = JBYT (IQ(LUPAN),14,2) IF (LEVCL.EQ.0) GO TO 31 IF (LEVCL.LT.NCLASH) GO TO 31 MSG = 'Clash level 2:' C- _:.=+=.: 1_:.= IF (LEVCL.EQ.1) THEN MSG(13:13) = '1' JSEV = -1 ELSE JSEV = 0 ENDIF CALL FAILMSG (JSEV,4, 20,MSG) GO TO 32 C-- Ready the origin tag 31 IF (NVEXDK(2).EQ.0) RETURN CALL DPHEAD 32 NCHTAG = 0 LNACT = LUPAN LNORG = LQ(LUPAN-3) CALL DPTAG (1,0,0) IFLNLO = IAND (IQ(LOWAN),KM5+KM6) JTYPE = JBYT (IQ(LUPAN),9,3) LINUM = IQ(LUPAN+3) LINE = ' ' IF (IFLNLO.NE.0) THEN IF (IAND(IQ(LUPAN),KM12).NE.0) THEN LINE(1:6) = '0 number of lines needed together C- C- return NDSLAT >0 normal printing C- 0 suppress printing, maximum number passed +CDE, SLATE, QCHAR, QPAGE, QSTATE, QUNIT, LUNSLN. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) NN = NSPACE NB = MAX (NBLANK, 1) NDSLAT = 0 IF (JSEVER.LT.0) THEN NQINFO = MIN (NQINFO+1, 999) IF (NQINFO.GE.199) RETURN ELSEIF (JSEVER.EQ.0) THEN NQWARN = MIN (NQWARN+1, 999) IF (NQWARN.GE.199) RETURN ELSE NQERR = MIN (NQERR+1, 999) IF (NQERR.GE.199) THEN IF (JSEVER.EQ.1) RETURN ENDIF ENDIF IF (NN.LT.0) GO TO 41 IF (NQNEWH.NE.0) GO TO 31 IF (NN+1.LT.NQLTOK) GO TO 40 NQUSED = NQLTOK 31 CALL DPHEAD GO TO 41 40 IF (NN.NE.0) CALL DPBLAN (1) 41 IF (JSEVER.LT.0) THEN WRITE (IQPRNT,9041) CQBLAN(1:NB), NQINFO,MSG ELSEIF (JSEVER.EQ.0) THEN WRITE (IQPRNT,9042) CQBLAN(1:NB), NQWARN,MSG ELSE WRITE (IQPRNT,9043) CQBLAN(1:NB), NQERR,MSG ENDIF NQUSED = NQUSED + 1 NQLLBL = 0 NDSLAT = 7 IF (JSEVER.NE.1) RETURN IF (NQERR.NE.1) RETURN IF (IFLAUX.NE.0) RETURN WRITE (IQPRNT,9049) CQBLAN(1:NB) NQUSED = NQUSED + 1 RETURN 9041 FORMAT (A,'! Inform',I4,' *! ',A,' !*') 9042 FORMAT (A,'!! Warning',I4,' **!! ',A,' !!**') 9043 FORMAT (A,'!!! Error',I4,' ***!!! ',A,' !!!*** !!!!!!!!') 9049 FORMAT (A,'!!! EXE processing is inhibited from now on !!!') END +SEQ, QCARDL. ===================================================== +DECK, JPTYPE. FUNCTION JPTYPE (LINE) C- Find control-card type of line in LINE(1:N) C- without looking at the control-character in LINE(1:1) +CDE, CCTYPE. C-------------- End CDE -------------------------------- CHARACTER LINE(64)*1, CHWK*4, CHWK1*1, CHWK2*1, CHWK3*1 EQUIVALENCE (CHWK1,CHWK(1:1)),(CHWK2,CHWK(2:2)),(CHWK3,CHWK(3:3)) PARAMETER (NPOSSA = 39) CHARACTER POSS(NPOSSA)*4 DIMENSION MTYPE(NPOSSA) DATA POSS / '+CDE' , '+SEQ' , '+SEL' , '+NIL' , '+INC' +, '+IF,' , '+IFN' , '+ELS' , '+END' +, '+KEE' , '+REP' , '+ADD' , '+ADB' , '+DEL' +, '+DEC' , '+PAT' , '+TIT' , '+EOD' , '+SKI' +, '+USE' , '+EXE' , '+LIS' , '+DIV' , '+XDI' , '+IMI' +, '+OPT' , '+PAR' , '+SHO' +, '+ASM' , '+ONL' , '+FOR' , '+SUP' +, '+NAM' , '+GAP' , '+UPD' , '+MOR' +, '+PAM' , '+QUI' , '+KIL' / DATA MTYPE / MCCCDE , MCCSEQ , MCCSEL , MCCNIL , MCCINC +, MCCTRU , MCCFAL , MCCELS , MCCEND +, MCCKEE , MCCREP , MCCADD , MCCADB , MCCDEL +, MCCDEC , MCCPAT , MCCTIT , MCCEOD , MCCSKI +, MCCUSE , MCCEXE , MCCLIS , MCCDIV , MCCXDI , MCCIMI +, MCCOPT , MCCOP2 , MCCSHO +, MCCASM , MCCONL , MCCFOR , MCCSUS +, MCCNAM , MCCGAP , MCCUPD , MCCMOR +, MCCPAM , MCCQUI , MCCKIL / IF (LINE(2).EQ.'_') GO TO 61 C-- scan normal possibilities JPOSS = 0 22 JPOSS = JPOSS + 1 IF (JPOSS.GT.NPOSSA) GO TO 29 JC = 2 IVP = ICHAR(POSS(JPOSS)(2:2)) IVT = ICHAR(LINE(2)) 24 IF (IVT.NE.IVP) THEN +SELF, IF=QASCII. IF (IVT-IVP.NE.32) GO TO 22 +SELF, IF=QEBCDIC. IF (IVP-IVT.NE.64) GO TO 22 +SELF. ENDIF IF (JC.EQ.4) GO TO 41 JC = JC + 1 IVP = ICHAR(POSS(JPOSS)(JC:JC)) IVT = ICHAR(LINE(JC)) GO TO 24 C-- not a Patchy key 29 JTYPE = 0 GO TO 42 C---- return 41 JTYPE = MTYPE(JPOSS) 42 JPTYPE = JTYPE RETURN C-- handle +___IF, IFNOT, ELSE, ENDIF 61 JF = 2 62 JF = JF + 1 IF (LINE(JF).EQ.'_') GO TO 62 CHWK(1:1) = LINE(JF) CHWK(2:2) = LINE(JF+1) CHWK(3:3) = LINE(JF+2) IF (CHWK1.EQ.'I') GO TO 71 IF (CHWK1.EQ.'i') GO TO 71 IF (CHWK1.NE.'E') THEN IF (CHWK1.NE.'e') GO TO 29 ENDIF C-- ELSE or ENDIF IF (CHWK2.EQ.'L') GO TO 64 IF (CHWK2.EQ.'l') GO TO 64 IF (CHWK2.NE.'N') THEN IF (CHWK2.NE.'n') GO TO 29 ENDIF IF (CHWK3.NE.'D') THEN IF (CHWK3.NE.'d') GO TO 29 ENDIF JTYPE = MCCEND GO TO 42 C-- ELSE 64 IF (CHWK3.NE.'S') THEN IF (CHWK3.NE.'s') GO TO 29 ENDIF JTYPE = MCCELS GO TO 42 C-- IF or IFNOT 71 IF (CHWK2.NE.'F') THEN IF (CHWK2.NE.'f') GO TO 29 ENDIF IF (CHWK3.NE.'N') THEN IF (CHWK3.NE.'n') GO TO 74 ENDIF JTYPE = MCCFAL GO TO 42 C-- IF, 74 JF = JF + 1 75 JF = JF + 1 IF (LINE(JF).EQ.' ') GO TO 75 IF (LINE(JF).NE.',') GO TO 29 JTYPE = MCCTRU GO TO 42 END +SEQ, QCARDL. ===================================================== +DECK, KRTITL. SUBROUTINE KRTITL C- Krack the current title C. started 12-jan-94 +CDE, SLATE, CCTYPE, CCPARA, CHEXC. +CDE, Q, PY. C-------------- End CDE -------------------------------- JSLT = IQ(LQHOLD+1) JSLE = IQ(LQHOLD+3) + JSLT JTXT = MLIAD(JSLT) NTXT = MLIAD(JSLT+1) - JTXT - NCHNEWL C-- do +TITLE: name version /sub text JCCTYP = 0 IF (TEXT(JTXT).NE.'+') GO TO 33 JCCTYP = JPTYPE (TEXT(JTXT)) IF (JCCTYP.EQ.0) GO TO 33 IF (JCCTYP.NE.MCCTIT) GO TO 37 N = MIN (12,NTXT) JF = ICFIND (':',TEXT(JTXT),1,N) IF (JF.GT.N) GO TO 32 IF (JF.EQ.NTXT) GO TO 32 JF = ICNEXT (TEXT(JTXT),JF+1,NTXT) NCHNAM = NDSLAT IF (JF.LT.NTXT) GO TO 36 C-- take the title from the first non-blank line in the deck 32 JSLT = JSLT + 1 IF (JSLT.GE.JSLE) GO TO 37 JTXT = MLIAD(JSLT) NTXT = MLIAD(JSLT+1) - JTXT - NCHNEWL IF (TEXT(JTXT).NE.'+') GO TO 33 JCCTYP = JPTYPE (TEXT(JTXT)) IF (JCCTYP.NE.0) GO TO 37 33 JF = 0 34 JF = ICNEXT (TEXT(JTXT),JF+1,NTXT) IF (JF.GT.NTXT) GO TO 32 NCHNAM = NDSLAT IF (NCHNAM.EQ.1) THEN IF (TEXT(JTXT+JF-1).EQ.'C') GO TO 34 IF (TEXT(JTXT+JF-1).EQ.'*') GO TO 34 ENDIF C-- got the title 36 JTXT = JTXT + JF - 1 NTXT = NTXT - JF + 1 NTXT = MIN (NTXT, 80) CCKARD(1:1) = '@' CALL CCOPYL (TEXT(JTXT),CCKARD(2:NTXT+1),NTXT) CALL CLTOU (CCKARD(1:NCHNAM+1)) GO TO 38 C-- fake title for file starting with +PATCH or +DECK 37 CCKARD(1:8) = '@unknown' NCHNAM = 7 NTXT = 7 38 JSLTTL = LN_TO4 (CCKARD(2:), NTXT) IXEXPAM = NA_NEW (CCKARD,2,NCHNAM+2) IXEXPAT = NA_NEW (CCKARD,1,NCHNAM+2) IXEXID = IXEXPAT IQ(LARRV+10) = JSLTTL IQ(LARRV+11) = IXEXPAM RETURN END +SEQ, QCARDL. ===================================================== +DECK, LIFTSQ. FUNCTION LIFTSQ (KJOIN,JTYPE,JSLCL,JDIV) C- Lift a sequence call bank C- KJOIN K-adr of the bank to be lifted C- JTYPE CC type to be stored C- JSLCL slot number of the control-line C- if this is non-zero the line will be cracked C- but in this case it must be +SEQ C- JDIV division number for lifting C- C- Return adr of the bank lifted as function value C- and IQUEST(1) the number of sequence calls lost: C- Note that no bank may have more than 63 links! C# started 18-dec-91 +CDE, QBITA19, QBANKS, CCTYPE, CCPARA. +CDE, QSH. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR, Q_SHIFTL. IF (JSLCL.NE.0) THEN JCCTYP = MCCSEQ CALL CCKRAK (JSLCL) ENDIF NPZORG = NCCPZ NCCPZ = MIN (NCCPZ,61) MMBANK(3,JBKXSQ) = NCCPZ + 2 MMBANK(5,JBKXSQ) = NCCPZ + 4 CALL MQLIFT (LX,KJOIN,0,JBKXSQ,JDIV) IQ(LX) = IOR (IQ(LX), ISHFTL(JTYPE,8)) IQ(LX) = IOR (IQ(LX), IAND(MCCPAR(JCCPT+1),KMP)) IQ(LX+4) = NCCPZ CALL UCOCOP (MCCPAR(JCCPZ+1),IQ(LX+5),NCCPZ,1,3,1) IQUEST(1) = NPZORG - NCCPZ LIFTSQ = LX RETURN END +SEQ, QCARDL. ===================================================== +DECK, LINKSQ. FUNCTION LINKSQ (LXX,LYY) C- if LXX not zero: C- connect all KEEP banks of the sequences called by C- the call bank at LXX; C- if LXX is zero: C- finalize only the sequence whose KEEP bank is LYYY; C- finalizing all global KEEPs called directly or indirectly, C- collect EXE bits and return them as function value C. started 28-nov-91 +CDE, QBITS19, CCTYPE, CCPARA, Q, PY. C-------------- End CDE -------------------------------- PARAMETER (NOFFLI=2, NOFFDA=4) PARAMETER (MAXLEV=36) DIMENSION MSAVE(8,MAXLEV) +SEQ, Q_JBYT, Q_AND, Q_OR. LDO = LXX KP = LEXP - 3 KD = 0 IF (LEXD.NE.0) KD= LEXD - 3 MEXL = 0 MEXG = 0 IFL6 = 0 LKEEP = 0 LEVK = 0 IF (LDO.NE.0) GO TO 31 LKEEP = LYY C- MEXi are the cumulated EXE bits of: C- MEXL just all patch/deck directed sequences called C- MEXG all global seq called from the current KEEP C- MEXH all global seq called from the current call bank C----- Start new KEEP bank, is it ready for use? 21 IF (IAND(IQ(LKEEP),KM5).EQ.0) CALL LINKSU (LKEEP) IF (IAND(IQ(LKEEP),KM6).NE.0) GO TO 72 C---- the KEEP bank is not ready, scan its associated C-- structure for unsatisfied sequence call banks MEXG = IQ(LKEEP) IFL6 = KM6 LDO = LKEEP - 1 23 LDO = LQ(LDO-1) IF (LDO.EQ.0) GO TO 71 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.LT.MCCCDE) GO TO 23 IF (JCCTYP.GT.MCCXSQ) GO TO 23 +SEQ, QEJECT. C---- call bank reached, connect all sequences called 31 MEXH = IQ(LDO) IF (IAND(IQ(LDO),KM17).NE.0) GO TO 48 NSEQ = IQ(LDO+NOFFDA) IFL17 = KM17 C- bit 17 : all sequences are definitly connected C-- next call JSEQ = 1 34 LNEW = LQ(LDO-JSEQ-NOFFLI) IF (LNEW.GT.0) GO TO 47 C-- locate the KEEP bank IXSEQ = IQ(LDO+NOFFDA+JSEQ) CALL LOCSEQ (LNEW, IXSEQ, KP,KD) MEXH = IOR (MEXH,IQUEST(3)) MEXL = IOR (MEXL,IQUEST(4)) IF (LNEW.EQ.0) GO TO 45 IFLPDD = IQUEST(2) IF (JBYT(IQ(LNEW),5,2).NE.3) GO TO 61 C-- store the adr of the KEEP bank into XSQ 41 IF (IFLPDD.EQ.0) GO TO 46 LNEW = -LNEW 45 IFL17 = 0 IFL6 = 0 46 LQ(LDO-JSEQ-NOFFLI) = LNEW 47 JSEQ = JSEQ + 1 IF (JSEQ.LE.NSEQ) GO TO 34 IQ(LDO) = IOR (IQ(LDO), IAND(MEXH,15)) IQ(LDO) = IOR (IQ(LDO), IFL17) 48 MEXG = IOR (MEXG,MEXH) IF (LEVK.NE.0) GO TO 23 49 LINKSQ = IAND (IOR(MEXL,MEXG), 15) RETURN C------ new unready KEEP, go down one level 61 IF (IAND(IQ(LNEW),KM7).EQ.0) GO TO 67 LEVK = LEVK + 1 IF (LEVK.GT.MAXLEV) GO TO 91 MSAVE (1,LEVK) = LKEEP MSAVE (2,LEVK) = MEXG MSAVE (3,LEVK) = LDO MSAVE (4,LEVK) = MEXH MSAVE (5,LEVK) = IFL17 MSAVE (6,LEVK) = JSEQ MSAVE (7,LEVK) = IFLPDD MSAVE (8,LEVK) = IFL6 LKEEP = LNEW GO TO 21 C-- sequence definition not yet filled in 67 IFL17 = 0 IFL6 = 0 GO TO 41 C------ end of processing this KEEP, come back up one level 71 IQ(LKEEP) = IOR (IQ(LKEEP),IAND(MEXG,15)) IQ(LKEEP) = IOR (IQ(LKEEP),IFL6) 72 IF (LEVK.EQ.0) GO TO 49 LNEW = LKEEP LKEEP = MSAVE (1,LEVK) MEXG = MSAVE (2,LEVK) LDO = MSAVE (3,LEVK) MEXH = MSAVE (4,LEVK) IFL17 = MSAVE (5,LEVK) JSEQ = MSAVE (6,LEVK) IFLPDD = MSAVE (7,LEVK) IFL6 = MSAVE (8,LEVK) LEVK = LEVK -1 NSEQ = LQ(LDO+NOFFDA) IF (IAND(IQ(LNEW),KM6).EQ.0) IFLPDD= -1 IF (IFLPDD.EQ.0) THEN MEXH = IOR (MEXH,IQ(LNEW)) ELSE MEXL = IOR (MEXL,IQ(LNEW)) ENDIF GO TO 41 C----- Sequence call loop 91 CONTINUE CALL P_FATAL ('sequence call loop') LINKSQ = 0 END +SEQ, QCARDL. ===================================================== +DECK, LINKSU. SUBROUTINE LINKSU (LKEEPX) C- Initial processing of the sequence kept at LKEEP: C- evaluate all IF conditions, delink all deselected material C. started 14-july-93 +CDE, QBITS19, CCTYPE, CCPARA. +CDE, Q. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT, Q_AND, Q_OR. LKEEP = LKEEPX LEVIF = 0 MEXCUM = 0 IFLKM6 = KM6 KDO = LKEEP - 2 GO TO 23 C------ accepted material 21 IFLKM6 = 0 22 KDO = LDO - 1 23 LDO = LQ(KDO) IF (LDO.EQ.0) GO TO 71 MEXCUM = IOR (MEXCUM,IQ(LDO)) JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.LE.MCCNIL) GO TO 22 IF (JCCTYP.GE.MCCTRU) GO TO 25 C-- +CDE +SEQ: check IF condition is true IF (JCCTYP.EQ.MCCXSQ) GO TO 21 CALL CCKRAK (IQ(LDO+1)) CALL CCPROC MEXCUM = IOR (MEXCUM,MXCCIF) IF (JCCIFV.EQ.0) GO TO 21 24 CALL TOGARB (KDO,0) GO TO 23 C-- new control 25 IF (JCCTYP.EQ.MCCELS) GO TO 26 IF (JCCTYP.EQ.MCCEND) GO TO 28 C-- handle +__IF CALL CCKRAK (IQ(LDO+1)) CALL CCPROC MEXCUM = IOR (MEXCUM,MXCCIF) LEVIF = LEVIF + 1 IF (JCCTYP.EQ.MCCFAL) JCCIFV= MAX(0, 1-JCCIFV) IF (JCCIFV.EQ.0) GO TO 29 LVREND = LEVIF LVRELS = LEVIF + 1 GO TO 41 C-- handle +_ELSE, IF=xxx 26 LVREND = LEVIF LVRELS = LEVIF GO TO 41 C-- handle +_ENDIF 28 LEVIF = LEVIF - 1 29 IF (IQ(LDO+2).LT.2) GO TO 24 IQ(LDO+1) = IQ(LDO+1) + 1 IQ(LDO+2) = IQ(LDO+2) - 1 IQ(LDO+3) = IQ(LDO+3) + 1 CALL SBYT (0, IQ(LDO),9,6) GO TO 22 +SEQ, QEJECT, N=34. C------ rejected material 41 CALL TOGARB (KDO,0) LDO = LQ(KDO) IF (LDO.EQ.0) GO TO 71 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.LT.MCCTRU) GO TO 41 C-- new control IF (JCCTYP.EQ.MCCELS) GO TO 46 IF (JCCTYP.EQ.MCCEND) GO TO 48 C-- handle +__IF LEVIF = LEVIF + 1 GO TO 41 C-- handle +_ELSE, IF=xxx 46 IF (LEVIF.GE.LVRELS) GO TO 41 CALL CCKRAK (IQ(LDO+1)) CALL CCPROC MEXCUM = IOR (MEXCUM,MXCCIF) IF (JCCIFV.NE.0) GO TO 41 GO TO 29 C-- handle +_ENDIF 48 LEVIF = LEVIF - 1 IF (LEVIF.GE.LVREND) GO TO 41 GO TO 29 C------ done 71 MEXCUM = IAND (MEXCUM,15) MEXCUM = MEXCUM + KM5 + IFLKM6 IQ(LKEEP) = IOR (IQ(LKEEP),MEXCUM) RETURN END +SEQ, QCARDL. ===================================================== +DECK, LOCPAT. FUNCTION LOCPAT (IXPAT) C- Locate the PAT bank for patch IXPAT C- return the adr of the bank found as function value, C- or zero if not found C- if the bank has been found in the 'future' chain C- relink it to be just after LEXP +CDE, KQADR, Q, PY. C-------------- End CDE -------------------------------- C-- look in the 'future' chain LQ(LLPAST-1) = 0 LF = KQFIND (IXPAT,2,KQMAIN,KP) IF (LF.NE.0) THEN IF (LF.EQ.LEXP) GO TO 27 CALL QSHUNT (KP,LEXP-1) GO TO 27 ENDIF C-- look in the 'past' chain LF = LQFIND (IXPAT,2,LQPAST) 27 LOCPAT = LF RETURN END +SEQ, QCARDL. ===================================================== +DECK, LOCKEEP. SUBROUTINE LOCKEEP (LSEQ) C- Find the KEEP bank for the sequence decribed by C- the current +KEEP control line; C- create target PAT/DECK banks if local sequence. C- return LSEQ L-adr of the sequence found, or LSEQ=0 C- IQUEST(1) K-adr of the seq found, if found C- else: K-adr for attachment at end C- IQUEST(2) zero: sequence is global C- -ve: sequence is local C- IQUEST(3) EXE bits of global sequence C- IQUEST(4) EXE bits of sequence C- IQUEST(11) adr of P/D to which the sequence would have C- to be attached, if local and not existing C- (to have access to the EXE bits) C. started 7-jan-92 +CDE, CCPARA. +CDE, Q, PY. C-------------- End CDE -------------------------------- IXS = MCCPAR(JCCPZ+1) KP = 0 KD = 0 LPD = 0 IF (NCCPP.EQ.0) GO TO 24 IXP = MCCPAR(JCCPP+1) IXD = MCCPAR(JCCPD+2) CALL CREAPD (IXP, IXD, 0) KP = LCRP - 3 LPD = LCRP IF (LCRD.NE.0) THEN KD = LCRD - 3 LPD = LCRD ENDIF 24 CALL LOCSEQ (LSEQ, IXS,KP,KD) IQUEST(11) = LPD RETURN END +SEQ, QCARDL. ===================================================== +DECK, LOCSEQ. SUBROUTINE LOCSEQ (LSEQ, IXSEQ,KP,KD) C- Find KEEP bank for the sequence with the name index IXSEQ C- KP gives the patch-directed, KD the deck-directed sequences C- return LSEQ L-adr of the sequence found, or LSEQ=0 C- IQUEST(1) K-adr of the seq found, if found C- else: K-adr for attachment at end C- IQUEST(2) zero: sequence is global C- -ve: sequence is local C- IQUEST(3) EXE bits of global sequence C- IQUEST(4) EXE bits of sequence C- if the sequence has been found as global, it is re-linked C- to the start of the global structure +CDE, KQADR, Q, PY. C-------------- End CDE -------------------------------- EQUIVALENCE (KSQLOC,IQUEST(1)), (L,IQUEST(12)) DIMENSION IXSEQ(9) IQUEST(11) = IXSEQ(1) IQUEST(2) = 0 IQUEST(3) = 0 IQUEST(4) = 0 C-- Global set CALL LOCSQ2 (KQKEEP) IQUEST(3) = IQUEST(4) IF (L.EQ.0) GO TO 21 LQ(KSQLOC) = LQ(L-1) LQ(L-1) = LQKEEP LQKEEP = L KSQLOC = KQKEEP 19 LSEQ = L RETURN C-- Patch-directed set: if KP not zero 21 IF (KP.EQ.0) GO TO 19 IQUEST(2) = -1 CALL LOCSQ2 (KP) IF (L.NE.0) GO TO 19 C-- Deck-directed set: if KD not zero IF (KD.EQ.0) GO TO 19 CALL LOCSQ2 (KD) GO TO 19 END +SEQ, QCARDL. ===================================================== +DECK, LOCSQ2. SUBROUTINE LOCSQ2 (KPAR) C- Slave to LOCSEQ, search one particular linear structure C- Input: KPAR search the linear structure attached at LQ(KPAR) C- IQUEST(11) name index of sequence to be found C- Output: IQUEST(1) K-adr of sequence found, if found, or C- K-adr in last bank searched, if not found C- IQUEST(4) cummulated EXE bits C- IQUEST(12) L-adr of sequence found +CDE, QBITS19, Q. C-------------- End CDE -------------------------------- EQUIVALENCE (KSQLOC,IQUEST(1)), (L,IQUEST(12)) PARAMETER (LOCID=4) +SEQ, Q_AND, Q_OR. 21 KNIL = 0 K = KPAR 22 L = KQFIND (IQUEST(11),LOCID,K,KSQLOC) IF (L.EQ.0) RETURN IF (KNIL.NE.0) GO TO 27 IQUEST(4) = IOR (IQUEST(4),IQ(L)) IF (IAND(IQ(L),KM12).EQ.0) RETURN C-- NIL-sequence found, find true sequence KNIL = KSQLOC K = L-1 GO TO 22 C-- Found sequence covered by NIL, transmit EXE bits and de-link 27 IQ(L) = IOR (IQ(L), IAND(IQUEST(4),15)) CALL TOGARB (KNIL,0) GO TO 21 END +SEQ, QCARDL. ===================================================== +DECK, MXJOIN. SUBROUTINE MXJOIN (MPAT,MDEC) C- Join EXE bits from MPAT and MDEC into MDEC +SEQ, Q_SHIFTL, Q_SHIFTR, Q_AND, Q_OR. MOR = IOR (MPAT, MDEC) MAND = IAND (MPAT, MDEC) MINH = IAND (ISHFTR(MAND,5), 31) NEW = IAND (MINH, MOR) MUSE = IAND (MINH, ISHFTR(MOR,10)) MSEL = IAND (MINH, ISHFTR(MOR,14)) NEW = IOR (NEW, ISHFTL(MINH, 5)) NEW = IOR (NEW, ISHFTL(MUSE,10)) NEW = IOR (NEW, ISHFTL(MSEL,14)) CALL SBYT (NEW, MDEC,1,18) RETURN END +SEQ, QCARDL. ===================================================== +DECK, MXOPER. SUBROUTINE MXOPER (MERACT) C- Unpack the USE bits in MU_DECK ready for use C- MERACT = EXE bits from actions into the deck C- if zero: initial unpack, if not: merge MERACT C. started 3-mar-92 +CDE, QBITS19, QSTATE, Q, PY, MUSEBC. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR, Q_SHIFTR. +SEQ, xMUSEBC, IF=DOC_INL. C-- MERACT = O : initial split of MU_DECK IF (MERACT.NE.0) GO TO 21 MU_FORG = IAND (MU_DECK, KM6-1) MU_INH = IAND (ISHFTR(MU_DECK,5), KM6-1) MX_TRAN = IAND (ISHFTR(MU_DECK,10), KM5-1) MX_FORG = IAND (MU_FORG, KM5-1) MXOR = IOR (MX_FORC,MU_DECK) MXAND = IAND (MX_FORC,MU_DECK) MX_SINH = IAND (ISHFTR(MXAND,5), KM5-1) MX_SELF = IOR (ISHFTR(MXOR,14), MX_FORG) GO TO 22 C-- MERACT not zero, join it 21 MX_SELF = IOR (MX_SELF, MERACT) 22 MX_SELF = IAND (MX_SELF, MX_SINH) CALL UPKBYT (MX_SELF,1,NVEXDK,4,0) IF (NQERR.NE.0) NVEXDK(1)= 0 NVEXDK(5) = NVEXDK(1) + NVEXDK(2) NVEXDK(6) = IAND (NVEXDK(2), MOPTIO(6)) IF (INCRAD.LT.2) RETURN C-- ready for P=CRA*, D=blank or CRA* NVEXDK(1) = 0 NVEXDK(2) = 1 NVEXDK(5) = 1 NVEXDK(6) = 1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, NEXTDE. SUBROUTINE NEXTDE (JSLA,JSLE,JSLF,JTYPEF,NHOW) C- Find next line +DECK, etc. in line-range JSLA to JSLE-1 C- NHOW = 0 scanning for PAM, look at first 3 keys C- >0 scanning for cradle, look at all keys, ignore +TITle C- =3 blank deck of the cradle, recognize +MORE C- <0 look at first -NHOW keys C- return JTYPEF 1,2,3(,4,5) and JSLF if found C- return JTYPEF -13 if line +MORE in the blank deck of the cradle C- return JTYPEF zero if not found +CDE, QTX. C-------------- End CDE -------------------------------- PARAMETER (NPOSSA=6) CHARACTER POSS(NPOSSA)*4 DATA POSS / '+DEC', '+PAT', '+TIT', '+PAM', '+QUI', '+MOR' / IF (NHOW.EQ.0) THEN NPOSX = 3 ELSEIF (NHOW.EQ.3) THEN NPOSX = 6 ELSEIF (NHOW.GT.0) THEN NPOSX = 5 ELSE NPOSX = -NHOW ENDIF C-- next line JSL = JSLA - 1 11 JSL = JSL + 1 IF (JSL.GE.JSLE) GO TO 98 JTGO = MLIAD(JSL) IF (TEXT(JTGO).NE.'+') GO TO 11 NTX = MLIAD(JSL+1) - JTGO - NCHNEWL IF (NTX.LT.4) GO TO 11 C-- next possibility JPOSS = 0 21 JPOSS = JPOSS + 1 IF (JPOSS.GT.NPOSX) GO TO 11 JTX = JTGO + 1 JC = 2 IVP = ICHAR(POSS(JPOSS)(2:2)) 22 IVT = ICHAR(TEXT(JTX)) IF (IVT.NE.IVP) THEN +SELF, IF=QASCII. IF (IVT-IVP.NE.32) GO TO 21 +SELF, IF=QEBCDIC. IF (IVP-IVT.NE.64) GO TO 21 +SELF. ENDIF IF (JC.EQ.4) GO TO 28 JTX = JTX + 1 JC = JC + 1 IVP = ICHAR(POSS(JPOSS)(JC:JC)) GO TO 22 C---- return 28 IF (NPOSX.GE.5) GO TO 29 JSLF = JSL JTYPEF = JPOSS RETURN C-- cradle 29 IF (JPOSS.EQ.3) GO TO 11 IF (JPOSS.EQ.6) JPOSS= -13 JSLF = JSL JTYPEF = JPOSS RETURN 98 JSLF = JSLE JTYPEF = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, NEXTSI. SUBROUTINE NEXTSI (JSLA,JTYPEF,NHOW) C- Check single line at JSLA is a header +DECK, etc. C- NHOW = 0 scanning for PAM, look at first 3 keys C- >0 scanning for cradle, look at all keys, ignore +TITle C- =3: blank deck of cradle, +MORE allowed C- return JTYPEF 1,2,3(,4,5) if found C- return JTYPEF -13 if line +MORE in the blank deck of the cradle C- return JTYPEF zero if not found +CDE, QTX. C-------------- End CDE -------------------------------- PARAMETER (NPOSSA=6) CHARACTER POSS(NPOSSA)*4 DATA POSS / '+DEC', '+PAT', '+TIT', '+PAM', '+QUI', '+MOR' / IF (NHOW.EQ.0) THEN NPOSX = 3 ELSEIF (NHOW.EQ.3) THEN NPOSX = 6 ELSE NPOSX = 5 ENDIF JSL = JSLA JTGO = MLIAD(JSL) IF (TEXT(JTGO).NE.'+') GO TO 98 C-- next possibility JPOSS = 0 21 JPOSS = JPOSS + 1 IF (JPOSS.GT.NPOSX) GO TO 98 JTX = JTGO + 1 JC = 2 IVP = ICHAR(POSS(JPOSS)(2:2)) 22 IVT = ICHAR(TEXT(JTX)) IF (IVT.NE.IVP) THEN +SELF, IF=QASCII. IF (IVT-IVP.NE.32) GO TO 21 +SELF, IF=QEBCDIC. IF (IVP-IVT.NE.64) GO TO 21 +SELF. ENDIF IF (JC.EQ.4) GO TO 28 JTX = JTX + 1 JC = JC + 1 IVP = ICHAR(POSS(JPOSS)(JC:JC)) GO TO 22 C---- return 28 IF (NPOSX.GE.5) GO TO 29 JTYPEF = JPOSS RETURN C-- cradle 29 IF (JPOSS.EQ.3) GO TO 98 IF (JPOSS.EQ.6) JPOSS= -13 JTYPEF = JPOSS RETURN 98 JTYPEF = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, NEXTXX. SUBROUTINE NEXTXX (KEY,JSLA,JSLE,JSLF) C- Find next line with key= +XXX in line-range JSLA to JSLE-1 C- return JSLF if found, JSLF =zero if not found +CDE, QTX. C-------------- End CDE -------------------------------- CHARACTER KEY*4, UKEY*4 UKEY = KEY JSL = JSLA - 1 C-- next line 11 JSL = JSL + 1 IF (JSL.GE.JSLE) GO TO 98 JTX = MLIAD(JSL) IF (TEXT(JTX).NE.'+') GO TO 11 NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.LT.4) GO TO 11 JTX = JTX + 1 JKY = 2 IVK = ICHAR(UKEY(2:2)) 22 IVT = ICHAR(TEXT(JTX)) IF (IVT.NE.IVK) THEN +SELF, IF=QASCII. IF (IVT-IVK.NE.32) GO TO 11 +SELF, IF=QEBCDIC. IF (IVK-IVT.NE.64) GO TO 11 +SELF. ENDIF IF (JKY.EQ.4) GO TO 29 JTX = JTX + 1 JKY = JKY + 1 IVK = ICHAR(UKEY(JKY:JKY)) GO TO 22 C---- return 29 JSLF = JSL RETURN 98 JSLF = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, NEXTCC. SUBROUTINE NEXTCC (CHCC,JSLA,JSLE,JSLF,JTYPEF) C- Find next Patchy c/c line in line-range JSLA to JSLE-1 C- having control-character CHCC in column 1 C- return type number JTYPEF and JSLF if found C- return JTYPEF=zero and JSLF=JSLE if not found +CDE, QTX. C-------------- End CDE -------------------------------- CHARACTER CHCC*1, CHCCU*1 CHCCU = CHCC JSL = JSLA -1 C-- next line 11 JSL = JSL + 1 IF (JSL.GE.JSLE) GO TO 98 JTX = MLIAD(JSL) IF (TEXT(JTX).NE.CHCCU) GO TO 11 NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.LT.4) GO TO 11 JTYPE = JPTYPE (TEXT(JTX)) IF (JTYPE.EQ.0) GO TO 11 C---- return JTYPEF = JTYPE JSLF = JSL RETURN 98 JTYPEF = 0 JSLF = JSLE RETURN END +SEQ, QCARDL. ===================================================== +DECK, SETGAP. SUBROUTINE SETGAP C- Ready the gap for the next deck C. started 19-july-95 +CDE, MQCM, Q, PY. C-------------- End CDE -------------------------------- C-- Check enough space NWFREE = LQCSTA(3) - LQCEND(1) IF (NWFREE.LE.NVGAP(1)) GO TO 24 JSLOCC = LQLSTA(4) JSLFRE = LQLEND(2) NSLFRE = JSLOCC - JSLFRE NTXFRE = MLIAD(JSLOCC) - MLIAD(JSLFRE) NTXWAN = NVGAP(2) * NVGAP(4) IF (NSLFRE.LT.NVGAP(2)) GO TO 24 IF (NTXFRE.GE.NTXWAN) GO TO 29 24 IF (IFLGAR.EQ.0) CALL MQSHIFT IFLGAR = 7 NWFREE = LQCSTA(3) - LQCEND(1) C-- set limits of control division 2 29 LQCSTA(2) = LQCEND(1) + 5*(NWFREE/8) LQCEND(2) = LQCSTA(2) C-- clear text division 3 LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) RETURN END +SEQ, QCARDL. ===================================================== +DECK, STRMID, T=JOIN. SUBROUTINE STRMID (JASM,JDIV,LINE,JPUT) C- Construct stream ID like FORT:0 into LINE(JPUT:) C. started 13-nov-93 +CDE, SLATE, CM_TYP. C-------------- End CDE -------------------------------- CHARACTER LINE*128 JP = JPUT LINE(JP:JP+15) = CH_TYP(JASM) JP = LNBLNK (LINE(1:JP+15)) + 1 LINE(JP:JP) = ':' CALL CSETDI (JDIV, LINE,JP+1,JP+1) NESLAT = JP + 2 RETURN END +SEQ, QCARDL. ===================================================== +DECK, USETT. SUBROUTINE USETT (JSL) C- Ready a title line for usage C. started 26-may-94 +CDE, SLATE, SLATLN. +CDE, USETTC. +CDE, Q. C-------------- End CDE -------------------------------- CHARACTER LINE*128, KARD*128 EQUIVALENCE (LINE,SLERRM), (KARD,SLLINE) C- PATCHY 5.00 /72 1994/05/24 21.00 text C- _:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: 4_:.=+=.: 5_:.= C- C- start at col: C- JTTNAM CHTTNA(1) = name PATCHY C- JTTVER CHTTNA(2) = version 5.00 /72 C- CHTTNA(3) = numeric vs 50072 C- C- CHTTNA(4) = primary vs 5.00 C- JTTSLA CHTTNA(5) = secondary vs 72 C- C- JTTDAT CHTTDT = date/time 1994/05/24 21.00 C- JTTCOM comment C- CALL VZERO (JTTNAM,12) CHTTNA(2) = '1.00' CHTTNA(3) = '10000' CHTTNA(4) = '1.00' CHTTNA(5) = '0' CHTTDT = ' ' NTTNA(2) = 4 NTTNA(3) = 5 NTTNA(4) = 4 NTTNA(5) = 1 NTTDT = 0 NVPRIM = 100 NVSEC = 0 IF (JSL.GT.0) THEN LINE = ' ' CALL LN_GET (JSL, LINE, LEN(LINE)) NTIT = NDSLAT CALL CLTOU (LINE(1:NTIT)) ELSE LINE = 'unknown /1' NTIT = LNBLNK (LINE(1:16)) ENDIF C-- check start with +TITLE: or C JTK = 1 IF (LINE(1:4).EQ.'+TIT') THEN J = ICFIND (':', LINE,5,NTIT) IF (NGSLAT.NE.0) JTK= J + 1 ELSEIF (LINE(1:2).EQ.'C ') THEN JTK = 3 ENDIF C-- name JTK = ICNEXT (LINE,JTK,NTIT) N = MIN (10,NDSLAT) JNX = NESLAT NTTNA(1) = N CHTTNA(1) = LINE(JTK:JTK+N-1) JTTNAM = JTK IF (JSL.GT.0) CALL LN_GET (JSL, LINE, LEN(LINE)) +SEQ, QEJECT. C-- does the version start with "/" ? JTK = ICNEXT (LINE,JNX,NTIT) IF (JTK.GE.NTIT) RETURN N = NDSLAT JNX = NESLAT IF (LINE(JTK:JTK).NE.'/') GO TO 26 JTTSLA = JTK N = MIN (4,N) KARD(1:N) = LINE(JTK:JTK+N-1) IF (N.EQ.1) THEN KARD(2:2) = '1' N = 2 ENDIF NTTNA(2) = N NTTNA(5) = N - 1 CHTTNA(2) = KARD(1:N) CHTTNA(5) = KARD(2:N) NVSEC = ICDECI (KARD,2,N) GO TO 31 C-- primary version 26 JTTVER = JTK JMK = ICFIND ('/', LINE,JTK,JNX) IF (JMK.LT.JNX) THEN JNX = JMK N = JNX - JTK ENDIF N = MIN (6,N) NTTNA(2) = N NTTNA(4) = N KARD(1:N) = LINE(JTK:JTK+N-1) CHTTNA(2) = KARD(1:N) CHTTNA(4) = KARD(1:N) NVPRIM = ICDECI (KARD,1,N) * 100 JM = NESLAT + 1 IF (JM.LE.N) NVPRIM = NVPRIM + ICDECI(KARD,JM,N) C-- secondary version JTK = ICNEXT (LINE,JNX,NTIT) N = NDSLAT - 1 JNX = NESLAT IF (LINE(JTK:JTK).NE.'/') GO TO 34 JTTSLA = JTK IF (N.LE.0) GO TO 31 NTTNA(5) = N CHTTNA(5) = LINE(JTK+1:JTK+N) NSEC = ICDECI (CHTTNA(5),1,N) NP = NTTNA(4) CHTTNA(2) = CHTTNA(4)(1:NP) // ' /' // CHTTNA(5)(1:N) NTTNA(2) = LNBLNK (CHTTNA(2)) C-- PAM creation date + time 31 JTK = ICNEXT (LINE,JNX,NTIT) JNX = NESLAT 34 IF (JTK.GT.NTIT) GO TO 41 IF (ICTYPE(LINE(JTK:JTK)).NE.2) GO TO 41 JTM = ICNEXT (LINE,JNX,NTIT) IF (JTM.LE.NTIT) THEN IF (ICTYPE(LINE(JTM:JTM)).EQ.2) THEN JNX = NESLAT ENDIF ENDIF N = JNX - JTK KARD(1:N) = LINE(JTK:JTK+N-1) CALL CSQMBL (KARD,1,N) N = MIN (N,20) N = LNBLNK (KARD(1:N)) CHTTDT(1:N) = KARD(1:N) NTTDT = N JTK = ICFNBL (LINE,JNX,NTIT) C-- done 41 NTTALL = NTIT NTTNORM = NTIT IF (JTK.LE.NTIT) THEN NTTNORM = LNBLNK (LINE(1:JTK-1)) JTTCOM = JTK ENDIF KARD(1:6) = ' ' CALL CSETDI (100*NVPRIM+NVSEC, KARD,1,6) CALL CLEFT (KARD,1,6) NTTNA(3) = NDSLAT CHTTNA(3) = KARD(1:6) RETURN END +SEQ, QCARDL. ===================================================== +DECK, VAXASMT, IF=QMVAX. SUBROUTINE VAXASMT C- Write the final .END line on streams ASSEMBLE for VAX C- called from PEND C. started 1-july-94 +CDE, QSTATE, Q, PY. +CDE, CM_TYP. C-------------- End CDE -------------------------------- IF (NQERR.NE.0) RETURN IF (MOPTIO(24).NE.0) RETURN LASMT = LQ(LHASM-JAS_TYP) LASML = LASMT JDIV = 0 C---- do all physical streams 24 IF (JDIV.GT.4) RETURN IF (JDIV.NE.0) LASML= LQ(LASMT-JDIV-1) JDIV = JDIV + 1 IF (IQ(LASML+1).NE.0) GO TO 24 LASMX = LQ(LASML-1) IF (LASMX.EQ.0) GO TO 24 LUN = IQ(LASMX+2) IF (LUN.LE.0) GO TO 24 NL = IQ(LASMX+4) IF (NL.EQ.0) GO TO 24 IQ(LASMX+4) = NL + 1 WRITE (LUN,8001) GO TO 24 8001 FORMAT (' .END') END +SEQ, QCARDL. ===================================================== +PATCH, SERVICE. Service routines +DECK, INISEQ. SUBROUTINE INISEQ C- Initialize the built-in sequences C. started 12-jan-94 +CDE, QBITS19, QCHAR, QSTATE. +CDE, CCPARA, JSPSEQ, Q. C-------------- End CDE -------------------------------- CCKARD = ' ' CCKARD(1:1) = CQBSL CCKARD(2:2) = CQBSL N = LNBLNK (CCKARD(1:8)) JSLH = LN_TO4 (CCKARD,N) CCKARD(1:20) = ' IDATQQ= 00 ' C- _:.=+=.:_1_:.=+=.:_2 CALL CSETDI (IQDATE,CCKARD,15,20) JSLD = LN_TO4 (CCKARD,20) CCKARD(1:18) = ' ITIMQQ= ' C- _:.=+=.:_1_:.=+=.:_2 CALL CSETDI (IQTIME,CCKARD,15,18) JSLT = LN_TO4 (CCKARD,18) CALL INISQX ('QTERMHD', 0, JSLH, KM5+KM6) CALL INISQX ('DATEQQ', 0, JSLD, KM5+KM6) CALL INISQX ('TIMEQQ', 0, JSLT, KM5+KM6) MASK = KM13+KM5+KM6 DO 64 IX=JSPSEQ1,JSPSEQL 64 CALL INISQX (' ', IX, 1, MASK) RETURN +SEQ, xJSPSEQ, IF=DOC_INL. END +SEQ, QCARDL. ===================================================== +DECK, INISQX. SUBROUTINE INISQX (CHNAME,IXSEQ,JSL,MASK) C- Create KEEP bank for special sequence C. started 11-feb-92 +CDE, QBANKS, KQADR, Q, PY. C-------------- End CDE -------------------------------- CHARACTER CHNAME*(*) +SEQ, Q_OR. IXNAME = IXSEQ IF (IXNAME.EQ.0) IXNAME = NA_LONG (CHNAME) CALL MQLIFT (L,KQKEEP,0,JBKKEE,1) IQ(L) = IOR (IQ(L),MASK) LQ(L-3) = LDECO IQ(L+1) = JSL IQ(L+2) = 1 IQ(L+4) = IXNAME RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_EQU, T=JOIN. LOGICAL FUNCTION LN_EQU (LINEA,LINEB,NCH) C- Compare LINEA(1:NCH) with LINEB(1:NCH), C- return true if LINEA = LINEB CHARACTER*512 LINEA, LINEB LN_EQU = LINEA(1:NCH) .EQ. LINEB(1:NCH) RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_GET. SUBROUTINE LN_GET (JSL,LINE,NCH) C- Transfer the line at JSL from the store to local, C- NCH characters maximum, C- return NDSLAT # of chars. transferred, C- NESLAT # of chars. in store +CDE, SLATE, QTX. C-------------- End CDE -------------------------------- CHARACTER*512 LINE JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL NESLAT = NTX NTX = MIN (NCH,NTX) NDSLAT = NTX CALL CCOPYL (TEXT(JTX),LINE,NTX) RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_PUT, T=JOIN. SUBROUTINE LN_PUT (LINE,NCH,JSL) C- Transfer a line from local to the store at slot JSL +CDE, QTX. C-------------- End CDE -------------------------------- CHARACTER*512 LINE JTX = MLIAD(JSL) IF (NCH.GT.0) CALL CCOPYL (LINE,TEXT(JTX),NCH) JTX = JTX + NCH +SELF, IF=QNEWLINE. TEXT(JTX) = CHAR (NEWLN) JTX = JTX + 1 +SELF. MLIAD(JSL+1) = JTX RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_PUTR, T=JOIN. SUBROUTINE LN_PUTR (LINE,NCH,JSL) C- Transfer a line from local to the store, C- reverse at slot JSL-1 +CDE, QTX. C-------------- End CDE -------------------------------- CHARACTER*512 LINE JTX = MLIAD(JSL) - NCH - NCHNEWL MLIAD(JSL-1) = JTX IF (NCH.GT.0) CALL CCOPYL (LINE,TEXT(JTX),NCH) +SELF, IF=QNEWLINE. JTX = JTX + NCH TEXT(JTX) = CHAR (NEWLN) +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_COP2. FUNCTION LN_COP2 (JSL,NLI) C- Transfer: Copy NLI lines starting at slot JSL to division 2 C. started 27-feb-92 +CDE, MQCM, Q. C-------------- End CDE -------------------------------- JSLFR = JSL NSL = NLI JTXFR = MLIAD(JSLFR) NTX = MLIAD(JSLFR+NSL) - JTXFR JSLTO = LQLEND(2) JTXTO = MLIAD(JSLTO) NTXRE = JTXTO - JTXFR JSLLIM = LQLSTA(4) JTXLIM = MLIAD(JSLLIM) IF (JSLTO+NSL+4 .GE.JSLLIM) + CALL NOSPACE ('no line slots left in text division 2') IF (JTXTO+NTX+8 .GE.JTXLIM) + CALL NOSPACE ('no text store left in text division 2') DO 44 J=1,NSL 44 MLIAD(JSLTO+J) = MLIAD(JSLFR+J) + NTXRE CALL CCOPYL (TEXT(JTXFR),TEXT(JTXTO),NTX) LQLEND(2) = JSLTO + NSL LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) LN_COP2 = JSLTO RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_MOV2, T=JOIN. FUNCTION LN_MOV2 (JSL,NLI) C- Transfer: Move NLI lines at slot JSL from division 1 to division 2 C. started 27-feb-92 +CDE, MQCM, Q. C-------------- End CDE -------------------------------- JSLFR = JSL NSL = NLI JTXFR = MLIAD(JSLFR) NTX = MLIAD(JSLFR+NSL) - JTXFR JSLTO = LQLEND(2) JTXTO = MLIAD(JSLTO) NTXRE = JTXTO - JTXFR JSLLIM = LQLSTA(4) JTXLIM = MLIAD(JSLLIM) IF (JSLTO+NSL+4 .GE.JSLLIM) + CALL NOSPACE ('no line slots left in text division 2') IF (JTXTO+NTX+8 .GE.JTXLIM) + CALL NOSPACE ('no text store left in text division 2') DO 44 J=1,NSL 44 MLIAD(JSLTO+J) = MLIAD(JSLFR+J) + NTXRE CALL CCOPYL (TEXT(JTXFR),TEXT(JTXTO),NTX) IF (JSLFR.LT.LQLEND(1)) CALL TOGATX (JSLFR,NSL) LQLEND(2) = JSLTO + NSL LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) LN_MOV2 = JSLTO RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_TO3. FUNCTION LN_TO3 (LINE) C- Transfer: Set a line from local to division 3 C. started 22-jun-93 +CDE, MQCM, Q. C-------------- End CDE -------------------------------- CHARACTER LINE*(*) +SELF, IF=QDEBUG. IF (LQLSTA(3).NE.LQLEND(2)) THEN CALL P_CRASH ('LN_TO3: LQLSTA(3) not = LQLEND(2)') ENDIF +SELF. NCH = LNBLNK (LINE) JSLTO = LQLEND(3) JTXTO = MLIAD(JSLTO) JTXE = JTXTO + NCH JSLLIM = LQLSTA(4) JTXLIM = MLIAD(JSLLIM) IF (JSLTO+4 .GE.JSLLIM) + CALL NOSPACE ('no line slots left in text division 3') IF (JTXE+8 .GE.JTXLIM) + CALL NOSPACE ('no text store left in text division 3') IF (NCH.GT.0) CALL CCOPYL (LINE,TEXT(JTXTO),NCH) +SELF, IF=QNEWLINE. TEXT(JTXE) = CHAR (NEWLN) JTXE = JTXE + 1 +SELF. MLIAD(JSLTO+1) = JTXE LQLEND(3) = JSLTO + 1 LN_TO3 = JSLTO RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_COP3, T=JOIN. FUNCTION LN_COP3 (JSL,NLI) C- Transfer: Copy NLI lines starting at slot JSL into division 3 C. started 22-jun-93 +CDE, MQCM, Q. C-------------- End CDE -------------------------------- +SELF, IF=QDEBUG. IF (LQLSTA(3).NE.LQLEND(2)) THEN CALL P_CRASH ('LN_COP3: LQLSTA(3) not = LQLEND(2)') ENDIF +SELF. JSLFR = JSL NSL = NLI JTXFR = MLIAD(JSLFR) NTX = MLIAD(JSLFR+NSL) - JTXFR JSLTO = LQLEND(3) JTXTO = MLIAD(JSLTO) NTXRE = JTXTO - JTXFR JSLLIM = LQLSTA(4) JTXLIM = MLIAD(JSLLIM) IF (JSLTO+NSL+4 .GE.JSLLIM) + CALL NOSPACE ('no line slots left in text division 3') IF (JTXTO+NTX+8 .GE.JTXLIM) + CALL NOSPACE ('no text store left in text division 3') DO 44 J=1,NSL 44 MLIAD(JSLTO+J) = MLIAD(JSLFR+J) + NTXRE CALL CCOPYL (TEXT(JTXFR),TEXT(JTXTO),NTX) LQLEND(3) = JSLTO + NSL LN_COP3 = JSLTO RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_ENV3. FUNCTION LN_ENV3 (JSL) C- Copy the line at slot JSL to the end of division 3 with C- substitution of environment variables C. started 22-dec-93 +CDE, SLATE, MQCM, Q. C-------------- End CDE -------------------------------- +SELF, IF=QDEBUG. IF (LQLSTA(3).NE.LQLEND(2)) THEN CALL P_CRASH ('LN_ENV3: LQLSTA(3) not = LQLEND(2)') ENDIF +SELF. JSLFR = JSL JTXFR = MLIAD(JSLFR) NTXFR = MLIAD(JSLFR+1) - JTXFR - NCHNEWL JSLTO = LQLEND(3) JTXTO = MLIAD(JSLTO) JSLLIM = LQLSTA(4) JTXLIM = MLIAD(JSLLIM) NSLAV = JSLLIM - JSLTO - 2 NTXAV = JTXLIM - JTXTO - 400 IF (NSLAV.LT.2) + CALL NOSPACE ('no text store left in text division 3') IF (NTXAV.LT.NTXFR) + CALL NOSPACE ('no text store left in text division 3') CALL CENVIR (TEXT(JTXFR),NTXFR, TEXT(JTXTO),1,NTXAV,0) IF (NFSLAT.GE.4) + CALL NOSPACE ('no text store left in text division 3') IF (NFSLAT.GE.2) GO TO 91 IF (NGSLAT.EQ.0) GO TO 41 JTXE = JTXTO + NDSLAT +SELF, IF=QNEWLINE. TEXT(JTXE) = CHAR(NEWLN) JTXE = JTXE + 1 +SELF. MLIAD(JSLTO+1) = JTXE LQLEND(3) = JSLTO + 1 LN_ENV3 = JSLTO NGSLAT = 1 RETURN C-- no substitution, return NGSLAT = 0 41 NDSLAT = NTXFR LN_ENV3 = JSLFR RETURN C-- syntax problems 91 LN_ENV3 = -1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_TO4. FUNCTION LN_TO4 (LINE,NCH) C- Transfer: Set a line from local to the start of division 4 C. started 27-feb-92 +CDE, MQCM, Q. C-------------- End CDE -------------------------------- CHARACTER*512 LINE NTX = NCH + NCHNEWL JSLTO = LQLSTA(4) JTXTO = MLIAD(JSLTO) - NTX JSLTO = JSLTO - 1 JSLLIM = LQLEND(3) JTXLIM = MLIAD(JSLLIM) IF (JSLTO.LE.JSLLIM+4) + CALL NOSPACE ('no line slots left in text division 4') IF (JTXTO.LE.JTXLIM+8) + CALL NOSPACE ('no text store left in text division 4') IF (NCH.GT.0) CALL CCOPYL (LINE,TEXT(JTXTO),NCH) +SELF, IF=QNEWLINE. JTXE = JTXTO + NTX TEXT(JTXE-1) = CHAR (NEWLN) +SELF. MLIAD(JSLTO) = JTXTO LQLSTA(4) = JSLTO LN_TO4 = JSLTO RETURN END +SEQ, QCARDL. ===================================================== +DECK, LN_COP4, T=JOIN. FUNCTION LN_COP4 (JSL,NLI) C- Transfer: Copy NLI lines starting at slot JSL into division 4 C. started 19-dec-91 +CDE, MQCM, Q. C-------------- End CDE -------------------------------- JSLFR = JSL NSL = NLI JTXFR = MLIAD(JSLFR) NTX = MLIAD(JSLFR+NSL) - JTXFR JSLTO = LQLSTA(4) JTXTO = MLIAD(JSLTO) - NTX JSLTO = JSLTO - NSL NTXRE = JTXTO - JTXFR JSLLIM = LQLEND(3) JTXLIM = MLIAD(JSLLIM) IF (JSLTO.LE.JSLLIM+4) + CALL NOSPACE ('no line slots left in text division 4') IF (JTXTO.LE.JTXLIM+8) + CALL NOSPACE ('no text store left in text division 4') DO 44 J=0,NSL-1 44 MLIAD(JSLTO+J) = MLIAD(JSLFR+J) + NTXRE CALL CCOPYL (TEXT(JTXFR),TEXT(JTXTO),NTX) LQLSTA(4) = JSLTO LN_COP4 = JSLTO RETURN END +SEQ, QCARDL. ===================================================== +DECK, LUNFREE, IF=QFIO. FUNCTION LUNFREE (JOFFS) C- Find next free Fortran logical unit number, from LUN = 10 to 29 C. started 3-aug-93 +CDE, FTNLUN. C-------------- End CDE -------------------------------- DO 24 J=1+JOFFS,NSFTN IF (LUNFRS(J).EQ.0) GO TO 27 24 CONTINUE CALL P_KILL (' All Fortran logical unit numbers occupied.') 27 LUNFREE = J + 9 RETURN END +SEQ, QCARDL. ===================================================== +DECK, LUNINQ, T=JOIN, IF=QFIO. FUNCTION LUNINQ (LUN) C- Check connection status of LUN C. started 3-aug-93 +CDE, FTNLUN. C-------------- End CDE -------------------------------- LUNINQ = LUNFRS(LUN-9) RETURN END +SEQ, QCARDL. ===================================================== +DECK, LUNRESV, T=JOIN, IF=QFIO. SUBROUTINE LUNRESV (LUN,IXFN) C- Fortran logical unit number LUN is connected to file IXFN, C- if zero: LUN is now free C. started 3-aug-93 +CDE, FTNLUN. C-------------- End CDE -------------------------------- LUNFRS(LUN-9) = IXFN RETURN END +SEQ, QCARDL. ===================================================== +DECK, NOSPACE, T=JOIN. SUBROUTINE NOSPACE (ERRM) +CDE, QUNIT. C-------------- End CDE -------------------------------- CHARACTER ERRM*(*) IF (ERRM(1:1).NE.'-') THEN WRITE (IQPRNT,9001) ERRM IF (IQPRNT.NE.IQTYPE) WRITE (IQTYPE,9001) ERRM ENDIF CALL MQSHOW CALL P_KILL ('Space full') 9001 FORMAT (/'***!!! Memory problem because ',A) END +SEQ, QCARDL. ===================================================== +DECK, SEGVIOL, T=JOIN, IF=QDIAG, IF=QS_UNIX. SUBROUTINE SEGVIOL CALL PERRORF ('perrorf has') CALL P_KILL ('SEGVIOL reached') END +SEQ, QCARDL. ===================================================== +DECK, TOGARB. SUBROUTINE TOGARB (KDO,IFLAG) C- Shunt the single bank connected at KDO (if IFLAG.EQ.0) C- or the linear structure at KDO (if IFLAG.NE.0) C- to the garbage structure C. started 5-dec-91 +CDE, MQCM, Q, PY. C-------------- End CDE -------------------------------- LDO = LQ(KDO) IF (LDO.EQ.0) RETURN C-- single bank IF (IFLAG.NE.0) GO TO 21 LQ(KDO) = LQ(LDO-1) IF (LDO.GE.LQCSTA(2)) RETURN LQ(LDO-1) = LQGARB LQGARB = LDO RETURN C-- linear structure 21 KL = KDO 22 LL = LQ(KL) IF (LL.GT.0) THEN IF (LL.GE.LQCSTA(2)) THEN LQ(KL) = LQ(LL-1) GO TO 22 ELSE KL = LL - 1 GO TO 22 ENDIF ENDIF LDO = LQ(KDO) IF (LDO.EQ.0) RETURN LQ(KL) = LQGARB LQGARB = LDO LQ(KDO) = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, TOGATX, T=JOIN. SUBROUTINE TOGATX (JSL,NSL) C- Send the NSL lines at JSL in division 1 to garbage C. started 5-feb-92 +CDE, QBANKS, MQCM. +CDE, KQADR, QSH. C-------------- End CDE -------------------------------- IF (JSL.GE.LQLEND(1)) RETURN CALL MQLIFT (L,KQGARB,0,JBKGAR,1) LQ(L+1) = JSL LQ(L+2) = NSL RETURN END +SEQ, QCARDL. ===================================================== +PATCH, NAMING. Name Handler +DECK, NA_INIT. SUBROUTINE NA_INIT C- Pre-initialize the name stack C. started 1-oct-91 +CDE, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- +SEQ, xNAMEC, IF=DOC_INL. NA_CUT = 32 NA_MXSL = 6000 NA_MXTX = 8 * NA_MXSL JSLA = LQLEND(5) - NA_MXSL JTXA = NSIZETX - NA_MXTX LQLSTA(5) = JSLA LQLEND(4) = JSLA LQLSTA(4) = JSLA C-- preset slot 0 one blank C- 1 unknown TEXT(JTXA) = ' ' MLIAD(JSLA) = JTXA MLIAD(JSLA+1) = JTXA + 1 JTXA = JTXA + 1 JSLA = JSLA + 1 CALL CCOPYL ('unknown', TEXT(JTXA), 7) MLIAD(JSLA+1) = JTXA + 7 NA_OCC = JSLA RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_INPY. SUBROUTINE NA_INPY C- Pre-set the name stack for Patchy C. started 19-july-93 +CDE, NAMEC. C-------------- End CDE -------------------------------- C-- preset slot (0 one blank) C- (1 unknown) C- 2 CRA* +SEQ, JSPSEQ, xJSPSEQ, IF=DOC_INL. CALL NA_LONG ('CRA*') CALL NA_LONG ('QCARD1') CALL NA_LONG ('QEJECT') CALL NA_LONG ('QFTITLE') CALL NA_LONG ('QFTITLCH') CALL NA_LONG ('QFHEAD') CALL NA_LONG ('QFNAME') CALL NA_LONG ('QFVERS') CALL NA_LONG ('QFVSNUM') CALL NA_LONG ('QFVPRIM') CALL NA_LONG ('QFVSEC') CALL NA_LONG ('QDATE') CALL NA_LONG ('QTIME') CALL NA_LONG ('QENVIR') CALL NA_LONG ('QTERMHD') CALL NA_LONG ('DATEQQ') CALL NA_LONG ('TIMEQQ') RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_REIN. SUBROUTINE NA_REIN C- Re-initialize the name stack C- for c/l +NAMES, length, slots, text C. started 1-oct-91 +CDE, CCPARA, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- IF (NCCPN.EQ.0) RETURN NLE = MCCPAR(JCCPN+1) NSL = 0 NTX = 0 IF (NCCPN.GE.2) NSL = MCCPAR(JCCPN+4) IF (NCCPN.GE.3) NTX = MCCPAR(JCCPN+7) IF (NLE.GT.0) NA_CUT = NLE IF (NSL.GT.0) NA_MXSL = NSL NA_CUT = MAX (NA_CUT, 8) NA_CUT = MIN (NA_CUT, 32) NA_MXSL = MAX (NA_MXSL,200) IF (NTX.GT.0) THEN NA_MXTX = NTX ELSE NA_MXTX = 8 * NA_MXSL ENDIF NA_MXTX = MAX (NA_MXTX,1200) JSLN = LQLEND(5) - NA_MXSL JTXN = NSIZETX - NA_MXTX JSLO = LQLSTA(5) JTXO = MLIAD(JSLO) NSL = NA_OCC +1 - JSLO NTX = MLIAD(NA_OCC+1) - JTXO NSH = JTXN - JTXO CALL UCOPY2 (MLIAD(JSLO),MLIAD(JSLN), NSL+1) IF (NSH.EQ.0) GO TO 29 IF (NSH.LT.0) THEN CALL CCOPYL (TEXT(JTXO),TEXT(JTXN),NTX) ELSE CALL CCOPYR (TEXT(JTXO),TEXT(JTXN),NTX) ENDIF DO 24 J=JSLN,JSLN+NSL 24 MLIAD(J) = MLIAD(J) + NSH 29 LQLSTA(5) = JSLN LQLEND(4) = JSLN LQLSTA(4) = JSLN NA_OCC = JSLN + NSL -1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_NEW. FUNCTION NA_NEW (LINE,JL,JR) C- Register the P/D/Z name in LINE(JL:JR-1) and return its adr C- NDSLAT returns the length of the name C. started 1-oct-91 +CDE, SLATE, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- CHARACTER LINE*512, NAMEOP*64 NN = MIN (64, JR-JL) IF (NN.LE.0) GO TO 49 NAMEOP(1:NN) = LINE(JL:JL+NN-1) CALL CLEFT (NAMEOP,1,NN) NN = MIN (NDSLAT, NA_CUT) IF (NN.EQ.0) GO TO 49 C---- Find the name if it exists already JSL = LQLSTA(5) + 1 24 JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX IF (NTX.EQ.NN) THEN IF (ICEQU(NAMEOP,TEXT(JTX),NN) .EQ.0) GO TO 29 ENDIF JSL = JSL + 1 IF (JSL.LE.NA_OCC) GO TO 24 C---- Name does not exist, enter it IF (JSL+1 .GE.LQLEND(5)) GO TO 81 JTX = MLIAD(JSL) IF (JTX+NN+8.GE.NSIZETX) GO TO 81 CALL CCOPYL (NAMEOP,TEXT(JTX),NN) MLIAD(JSL+1) = JTX + NN NA_OCC = JSL 29 NDSLAT = NN NA_NEW = JSL - LQLSTA(5) RETURN C-- Zero-length string 49 NDSLAT = 0 NA_NEW = 0 RETURN C---- Space full 81 CALL NA_FUL NA_NEW = 0 END +SEQ, QCARDL. ===================================================== +DECK, NA_LONG. FUNCTION NA_LONG (NAMEOP) C- Register long string in NAMEOP as is and return its adr C- NDSLAT returns the length of the name C. started 1-oct-91 +CDE, SLATE, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- CHARACTER NAMEOP*(*) C---- Find the name if it exists already NN = LNBLNK(NAMEOP) JSL = LQLSTA(5) IF (NN.EQ.0) GO TO 999 24 JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX IF (NTX.EQ.NN) THEN IF (ICEQU(NAMEOP,TEXT(JTX),NN) .EQ.0) GO TO 999 ENDIF JSL = JSL + 1 IF (JSL.LE.NA_OCC) GO TO 24 C---- Name does not exist, enter it IF (JSL+1 .GE.LQLEND(5)) GO TO 81 JTX = MLIAD(JSL) IF (JTX+NN+8.GE.NSIZETX) GO TO 81 CALL CCOPYL (NAMEOP,TEXT(JTX),NN) MLIAD(JSL+1) = JTX + NN NA_OCC = JSL 999 NDSLAT = NN NA_LONG = JSL - LQLSTA(5) RETURN C---- Space full 81 CALL NA_FUL NA_LONG = 0 END +SEQ, QCARDL. ===================================================== +DECK, NA_GET. SUBROUTINE NA_GET (JNA,LINE,JCL) C- Transfer the text of name JNA into LINE at col. JCL C. started 1-oct-91 +CDE, SLATE, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- CHARACTER LINE*(*) JSL = JNA + LQLSTA(5) +SELF, IF=QDEBUG. IF (JNA.LT.0 .OR. JSL.GT.NA_OCC) + CALL P_CRASH ('name-index out of range') +SELF. JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX N = MIN (NTX, LEN(LINE)+1-JCL) CALL CCOPYL (TEXT(JTX),LINE(JCL:),N) NDSLAT = N NESLAT = JCL + N NFSLAT = NTX RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_JTX, T=JOIN. FUNCTION NA_JTX (JNA) C- Get the start adr of the text of name JNA C. started 27-jan-92 +CDE, SLATE, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- JSL = JNA + LQLSTA(5) +SELF, IF=QDEBUG. IF (JNA.LT.0 .OR. JSL.GT.NA_OCC) + CALL P_CRASH ('name-index out of range') +SELF. JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX NDSLAT = NTX NA_JTX = JTX RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_DIF. FUNCTION NA_DIF (JNA,JNB) C- Compare NAMEA at JNA with NAMEB at JNB, C- return zero if NAMEA = NAMEB C- -1 if NAMEA < NAMEB C- +1 if NAMEA > NAMEB C. started 12-feb-92 +CDE, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- IF (JNA.EQ.JNB) THEN NA_DIF = 0 RETURN ENDIF JSLA = JNA + LQLSTA(5) JSLB = JNB + LQLSTA(5) JTXA = MLIAD(JSLA) JTXB = MLIAD(JSLB) NTXA = MLIAD(JSLA+1) - JTXA NTXB = MLIAD(JSLB+1) - JTXB NA_DIF = NA_XCO (TEXT(JTXA),TEXT(JTXB),NTXA,NTXB) RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_CHK. FUNCTION NA_CHK (LINE,JL,JR) C- Find the P/D/Z name in LINE(JL:JR-1) and return its relative adr C- or -1 if not found C- NDSLAT returns the length of the name C. started 1-oct-91 +CDE, SLATE, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- CHARACTER LINE*512, NAMEOP*64 NN = MIN (64, JR-JL) IF (NN.NE.0) THEN NAMEOP(1:NN) = LINE(JL:JL+NN-1) CALL CLEFT (NAMEOP,1,NN) NN = MIN (NDSLAT, NA_CUT) ENDIF C---- Find the name JSL = LQLSTA(5) IF (NN.EQ.0) GO TO 29 24 JSL = JSL + 1 IF (JSL.GT.NA_OCC) GO TO 91 JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX IF (NTX.NE.NN) GO TO 24 IF (ICEQU(NAMEOP,TEXT(JTX),NN) .NE.0) GO TO 24 29 NA_CHK = JSL - LQLSTA(5) NDSLAT = NN RETURN 91 NA_CHK = -1 NDSLAT = NN RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_XCO. FUNCTION NA_XCO (NAMEA,NAMEB,NCHA,NCHB) C- Compare NAMEA(1:NCH) with NAMEB(1:NCH), C- return zero if NAMEA = NAMEB C- -1 if NAMEA < NAMEB C- +1 if NAMEA > NAMEB C- internal routine called only from NA_DIFF CHARACTER*512 NAMEA, NAMEB JVAL = 0 NCH = MIN (NCHA,NCHB) IF (NCH.EQ.0) THEN IF (NCHA.EQ.NCHB) GO TO 49 IF (NCHA.LT.NCHB) THEN JVAL = -1 ELSE JVAL = 1 ENDIF GO TO 49 ENDIF IF (NAMEA(1:NCH) .EQ. NAMEB(1:NCH)) THEN IF (NCHA.EQ.NCHB) GO TO 49 IF (NCHA.LT.NCHB) THEN JVAL = -1 ELSE JVAL = 1 ENDIF GO TO 49 ENDIF IF (LLT(NAMEA(1:NCH),NAMEB(1:NCH))) THEN JVAL = -1 ELSE JVAL = 1 ENDIF 49 NA_XCO = JVAL RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_FUL. SUBROUTINE NA_FUL C- Name stack full C. started 22-jan-92 +CDE, QUNIT, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- JSL = LQLSTA(5) JSLE = NA_OCC + 1 JTX = MLIAD(JSL) JTXE = MLIAD(JSLE) NSLOCC = JSLE - JSL NTXOCC = JTXE - JTX NSLAV = LQLEND(5) - JSL NTXAV = NSIZETX - JTX NSLPRO = (100 * NSLOCC) / NSLAV NTXPRO = (100 * NTXOCC) / NTXAV WRITE (IQPRNT,9082) NTXOCC,NTXPRO,NTXAV, + NSLOCC,NSLPRO,NSLAV 9082 FORMAT (/' ***!!! Name space full !!!***'/ F5X,'Name text ',I7,' or',I3,'% used of',I7,' bytes maximum'/ F5X,'Name slots',I7,' or',I3,'% used of',I7,' maximum') CALL NOSPACE ('-') END +SEQ, QCARDL. ===================================================== +DECK, NA_PRIX, T=JOIN. SUBROUTINE NA_PRIX (MSG,IX) C- Print content of index IX with message C. started 7-june-94 +CDE, SLATE, SLATLN, QUNIT. C-------------- End CDE -------------------------------- CHARACTER LINE*128, MSG*(*) EQUIVALENCE (LINE,SLERRM) CALL NA_GET (IX,LINE,1) WRITE (IQPRNT,9001) MSG,LINE(1:NDSLAT) NQUSED = NQUSED + 1 NQLLBL = 0 9001 FORMAT (A,A) RETURN END +SEQ, QCARDL. ===================================================== +DECK, NA_DUMP. SUBROUTINE NA_DUMP C- Dump the NAME stack +CDE, SLATE, QUNIT, MQCM, Q. +CDE, NAMEC. C-------------- End CDE -------------------------------- CHARACTER NAMEOP*80 WRITE (IQPRNT,9011) LQLSTA(5), NA_OCC, NA_CUT 9011 FORMAT (/'1Dump the NAME stack, start/end/cutat =',2I7,I3) IF (NA_OCC.EQ.0) RETURN IF (LQLSTA(5).LT.LQLEND(4)) GO TO 84 IF (NA_OCC.LT.LQLSTA(5)) GO TO 84 IF (NA_CUT.LT.6) GO TO 84 IF (NA_CUT.GT.32) GO TO 84 JSL = LQLSTA(5) JSLE = NA_OCC + 1 JTX = MLIAD(JSL) JTXE = MLIAD(JSLE) NSLOCC = JSLE - JSL NTXOCC = JTXE - JTX NSLAV = LQLEND(5) - JSL NTXAV = NSIZETX - JTX NSLPRO = (100 * NSLOCC) / NSLAV NTXPRO = (100 * NTXOCC) / NTXAV WRITE (IQPRNT,9017) NTXOCC,NTXPRO,NTXAV,JTX, + NSLOCC,NSLPRO,NSLAV 9017 FORMAT (/ F8X,'Name text ',I7,' or',I3,'% used of',I7,' bytes maximum at',I9/ F8X,'Name slots',I7,' or',I3,'% used of',I7,' maximum'// F7X,'J JSL JTX N name'/) JNA = 0 44 JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX IF (NTX.LE.0) GO TO 81 NAMEOP = ' ' CALL NA_GET (JNA,NAMEOP,1) IF (NDSLAT.NE.NTX) GO TO 82 WRITE (IQPRNT,9044) JNA,JSL,JTX,NTX,NAMEOP(1:NTX+1) 9044 FORMAT (1X,2I7,I9,I3,2X,A) IF (JSL.EQ.NA_OCC) RETURN JSL = JSL + 1 JNA = JNA + 1 GO TO 44 C---- Trouble 81 WRITE (IQPRNT,9081) JNA,JSL,JTX,NTX RETURN 82 WRITE (IQPRNT,9082) JNA,JSL,JTX,NTX,NDSLAT RETURN 84 WRITE (IQPRNT,9084) RETURN 9081 FORMAT (1X,2I7,I9,I3,' ***!!! faulty !!!***') 9082 FORMAT (1X,2I7,I9,2I3,' ***!!! faulty !!!***') 9084 FORMAT (40X,'***!!! Faulty !!!***') END +SEQ, QCARDL. ===================================================== +PATCH, MQ. Hydra memory management routines +DECK, MQINIT. SUBROUTINE MQINIT C- Initialise memory manager and some other COMMONs +CDE, FTNLUN, IF=QFIO. +CDE, CCPARA, LUNSLN. +CDE, QBANKS, QCHAR, QMACH, QPAGE, QSTATE, QUNIT. +CDE, MQCM, MQCT, MQCN, MQCL. +CDE, Q. +, MUSER(9) C-------------- End CDE -------------------------------- COMMON /SLATE/ ISLATE(40) LOGICAL INTRAC CHARACTER MMTOBK(NBANKS)*20 DATA MMTOBK / 'PAT 0 4 3 2' +, 'DECK 0 4 3 1' +, 'ORG 0 0 0 2' +, 'INCL 0 1 1 1' +, 'HOLD 1 1 1 5' +, 'KEEP 1 3 2 4' +, 'ACT 1 3 2 5' +, 'MAT 1 3 1 3' +, 'XSQ 1 3 1 5' +, 'PREP 1 3 1 2' +, 'GARB 0 1 1 2' +, 'ASMH 0 63 0 2' +, 'ASMT 0 5 1 11' +, 'ASML 0 1 1 11' +, 'ASMX 0 1 1 4' +, 'ARRV 0 2 2 14' +, 'ASAV 1 1 1 2' +, 'PAM 0 0 0 15' +, 'RPAM 0 1 1 4' / C- _:.=+=.: 1_:.=+=.: 2 C- ID LI NL NS ND +SEQ, QEJECT. C-- Ready common /QCHAR/ CQBLAN = ' ' CALL CFILL ('====', CQEQS, 1, LEN(CQEQS)) CQCETA = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345' +SELF, IF=QASCII. CQAPO = CHAR(39) CQBSL = CHAR(92) CQTAB = CHAR(9) +SELF, IF=QEBCDIC. CQAPO = CHAR(125) CQBSL = CHAR(61) CQTAB = CHAR(5) +SELF. C-- Ready common /QPAGE/ +SELF, MQINITLI. NQLMAX = 110 NQCMAX = 120 NQCPGH = 110 +SELF. CALL MQPAGE NQNEWH = 0 NQJOIN = 0 NQDKNO = 0 NQDKPG = 1 NQPAGE = 1 NQWYL = 0 NQWYLDO= 0 C-- Ready common /QSTATE/ CALL VZERO (NQERR,6) CALL DATIME (IQDATE,IQTIME) IQDATE = (ISLATE(1)*100 + ISLATE(2))*100 + ISLATE(3) ISL4 = ISLATE(4) ISL5 = ISLATE(5) CQDATE = '00000000' CALL CSETDI (IQDATE,CQDATE,1,8) CQDATEM = CQDATE(1:4) // '/' // CQDATE(5:6) // '/' // CQDATE(7:8) CQTIME = ' 0.0 ' CALL CSETDI (ISL4, CQTIME,1,2) CALL CSETDI (ISL5, CQTIME,4,5) C-- Ready common /QUNIT/ +SELF, MQINITUN. IQREAD = 2 IQPRNT = 3 IQTTIN = 5 IQTYPE = 6 +SELF. IQRSAV = IQREAD IQRFD = 0 IQRRD = 0 IQRSIZ = 0 NQLPAT = 0 NQUSED = 0 NQLLBL = 0 NQINIT = 7 IF (INTRAC()) THEN IQOFFL = 0 IQRTTY = IQTTIN ELSE IQOFFL = 1 IQRTTY = 0 ENDIF C-- Ready common /MQCM/ LQADR = LOCF (LQ(1)) LQADR0 = LQADR - 1 NQOFFS = LOCF (MLIAD(1)) - LQADR NQSYSS = 12 NQLINK = 24 NQMAX = NSIZEQ - 2 C-- Clear commons CALL VZERO (IQUEST,4000) CALL VZERO (LQTA,14) CALL VZERO (NQLST,8) CALL VZERO (IQLST,10) IFLAUX = 0 CALL VZERO (IXLUN,12) CALL VZERO (NCHCCD,269) CCKORG = ' ' CCKARD = ' ' MCCPAR(2) = -1 +SELF, IF=QFIO. CALL VZERO (LUNFRS, NSFTN) +SELF. +SEQ, QEJECT. C-- Ready control divisions LQCEND(3) = NQMAX - 1 LQCSTA(3) = LQCEND(3) LQCSTA(1) = NQLINK + 1 LQCEND(1) = LQCSTA(1) LQCSTA(2) = (LQCSTA(3)+LQCEND(1)) / 2 LQCEND(2) = LQCSTA(2) C-- Ready text divisions JTXL = NSIZETX - 12000 JSLL = NSIZELN - 2000 MLIAD(JSLL) = JTXL LQLSTA(4) = JSLL LQLEND(4) = JSLL LQLSTA(5) = JSLL LQLEND(5) = NSIZELN - 2 MLIAD(LQLEND(5)) = NSIZETX C-- slots 1+2 are used for constructing the line C-- for each special sequence DO 42 J=1,999 42 TEXT(J) = ' ' MLIAD(1) = 1 MLIAD(2) = 257 MLIAD(3) = 513 LQLSTA(1) = 1 LQLEND(1) = 3 LQLSTA(2) = LQLEND(1) LQLEND(2) = LQLSTA(2) LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) C-- Ready /QBANKS/ DO 47 J=1,NBANKS CALL UCTOH (MMTOBK(J),MMBANK(1,J),4,4) MMBANK(2,J) = ICDECI (MMTOBK(J), 6, 8) MMBANK(3,J) = ICDECI (MMTOBK(J),10,12) MMBANK(4,J) = ICDECI (MMTOBK(J),14,16) 47 MMBANK(5,J) = ICDECI (MMTOBK(J),18,20) C-- Initialize the name handler CALL NA_INIT CALL NA_INPY RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQPAGE, T=JOIN. SUBROUTINE MQPAGE C- Set derived page size parameters +CDE, QPAGE. C-------------- End CDE -------------------------------- NQLTOL = NQLMAX - 7 NQLTOK = NQLMAX - 4 RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQSHOW. SUBROUTINE MQSHOW C- Display current memory occupation +CDE, QUNIT, MQCM, Q, PY. C-------------- End CDE -------------------------------- CALL DPBLAN (0) WRITE (IQPRNT,9010) WRITE (IQPRNT,9011) (LQCSTA(J),LQCEND(J),J=1,3) WRITE (IQPRNT,9012) (LQLSTA(J),LQLEND(J),J=1,5) WRITE (IQPRNT,9013) (MLIAD(LQLSTA(J)),MLIAD(LQLEND(J)),J=1,5) WRITE (IQPRNT,9014) NVGAP NQUSED = NQUSED + 25 RETURN 9010 FORMAT (' Present state of memory,', F' start + end adrs of divisions:') 9011 FORMAT ( F/' control div 1: collectable foreign material',2I9 F/' control div 2: processing current deck ',2I9 F/' control div 3: permanent foreign material ',2I9) 9012 FORMAT ( F/' line slots of text div 1: foreign material ',2I9 F/' line slots of text div 2: PAM file in store ',2I9 F/' line slots of text div 3: volatile construction ',2I9 F/' line slots of text div 4: permanent construction',2I9 F/' line slots of text div 5: naming stack ',2I9) 9013 FORMAT ( F/' text div 1: foreign material ',2I9 F/' text div 2: PAM file in store ',2I9 F/' text div 3: volatile construction ',2I9 F/' text div 4: permanent construction',2I9 F/' text div 5: naming stack ',2I9) 9014 FORMAT (/' Gap parameters to control garbage collection:' F/' Min. number of words free for control division 2',I7 F/' Min. number of lines free for text divisions 3+4',I7 F/' Max. number of lines expected in any deck ',I7 F/' Mean number of characters per line ',I7/) END +SEQ, QCARDL. ===================================================== +DECK, MQWORK, T=JOIN. SUBROUTINE MQWORK (LREF,IDATA,IDATAL) C- Set working space limits and clear wsp to zero +CDE, MQCM, Q. C-------------- End CDE -------------------------------- DIMENSION IDATA(9),IDATAL(9) NS = IQLOCF(LREF) - 1 NL = IQLOCF(IDATA) - 1 NW = IQLOCF(IDATAL) + 1 NQSYSS = NS NQLINK = NL LQCSTA(1) = NW LQCEND(1) = NW CALL VZERO (IQUEST, NW+200) RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQLIFT. SUBROUTINE MQLIFT (L,K,N,JN,JD) C- Satisfy bank request C- Linkage control: if N.LE.0 connect at LQ(K-N) C- N.EQ.1 connect at K (top level) C- N.GE.2 no connection (stand alone) C- JN is the bank name index, JD is the division number C- return in L the adr of the bank lifted C. started 8-oct-91 +CDE, SLATLN. +CDE, QBANKS, MQCM, MQCT, MQCL, QUNIT. +CDE, QSH. C-------------- End CDE -------------------------------- DIMENSION L(9), K(9), JN(9), JD(9) KK = K(1) JBKIX = JN(1) JDIV = JD(1) IFORW = 3 - JDIV +SELF, IF=QDEBUG. IF ((JBKIX.LE.0).OR.(JBKIX.GT.NBANKS)) THEN CALL P_CRASH ('MQLIFT - faulty bank name index') ENDIF IF ((JDIV.LE.0).OR.(JDIV.GT.3)) THEN CALL P_CRASH ('MQLIFT - faulty division index') ENDIF +SELF. NQTY = JBKIX NQID = MMBANK(1,JBKIX) NQLI = MMBANK(2,JBKIX) NQNL = MMBANK(3,JBKIX) NQNS = MMBANK(4,JBKIX) NQND = MMBANK(5,JBKIX) NT = NQNL + NQND + 2 +SELF, IF=QDEBUG. IF ((NQNL.GE.64).OR.(NQNS.GT.NQNL).OR.(NQND.GE.2048)) THEN PRINT *, ' MQLIFT: NL/NS/ND=',NQNL,NQNS,NQND CALL P_CRASH ('MQLIFT - faulty bank parameters') ENDIF +SELF. IF (IFORW.NE.0) THEN NQLNA = LQCEND(JDIV) NQRESV(1) = LQCSTA(JDIV+1) - NQLNA - NT ELSE NQLNA = LQCSTA(JDIV) - NT NQRESV(1) = NQLNA - LQCEND(JDIV-1) ENDIF IF (NQRESV(1).LE.0) THEN SLERRM = 'no space in control division x' C- _:.=+=.: 1_:.=+=.: 2_:.=+=.: 3 CALL CSETDI (JDIV,SLERRM,30,30) CALL NOSPACE (SLERRM(1:30)) ENDIF IF (IFORW.NE.0) THEN LQCEND(JDIV) = LQCEND(JDIV) + NT ELSE LQCSTA(JDIV) = LQCSTA(JDIV) - NT ENDIF NQLST = NQLNA + NQNL + 1 CALL VZERO (LQ(NQLNA),NT) CALL QLUMP IF (N.LE.0) THEN KKN = KK + N LNX = LQ(KKN) LQ(KKN) = NQLST ELSEIF (N.EQ.1) THEN LNX = KK K(1) = NQLST ELSE LNX = 0 ENDIF IF (NQNS.GT.0) LQ(NQLST-1) = LNX L(1) = NQLST +SELF, IF=XDEBUG, IF=XMQLIFT. WRITE (IQPRNT,9899) NQID,NQLNA,NQLST, + NQTY,NQLI,NQNL,NQNS,NQND 9899 FORMAT (/' Xdebug MQLIFT: lift bank ',A4,' at LN/LST=',2I7/ F16X,'TY=',I2,' LI=',I1,' NL/NS=',2I3,' ND=',I5) +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQSHIFT. SUBROUTINE MQSHIFT C- Shift the TEXT material in division 2 (PAM) supported C- by the banks of control division 1 starting at LQHOLD C- from text division 1 to division 1 C- Called just before reading a new PAM (or PAM instalment) C. started 14-oct-91 C- LQHOLD is the adr of the first bank created after C- the last shift operation C- it decribes the trailing lines in text division 2 C- to be maintained in division 2, if non-zero +CDE, QBANKS, QUNIT. +CDE, MQCM, QSYSBITS, KQADR, Q, MQCN. C-------------- End CDE -------------------------------- +SELF, IF=XSHIFT. DIMENSION JTXSTA(5), JTXEND(5) +SELF. +SEQ, Q_OR. +SELF, IF=QDEBUG, IF=XWITHME. NQUSED = NQUSED + 2 WRITE (IQPRNT,9801) 9801 FORMAT (/' *** Debug: MQSHIFT operates') +SELF, IF=XSHIFT. WRITE (IQPRNT,9802) LQCSTA,LQCEND, LQLSTA, LQLEND 9802 FORMAT (/' LQCSTA(1-3) =',3I8/' LQCEND(1-3) =',3I8/ F /' LQLSTA(1-5) =',5I8/' LQLEND(1-5) =',5I8) DO 17 J=1,5 JTXSTA(J) = MLIAD(LQLSTA(J)) 17 JTXEND(J) = MLIAD(LQLEND(J)) WRITE (IQPRNT,9803) JTXSTA, JTXEND 9803 FORMAT ( ' JTXSTA(1-5) =',5I8/' JTXEND(1-5) =',5I8) +SELF. C---- Remove dead material if any IF (LQGARB.NE.0) CALL MQGARB C---- Shift new text material from text division 2 to 1 C-- is the HOLD bank the last bank in division 1 ? C- in which case there is no new text material CALL QNAME (LQHOLD) IF (IQLNX.EQ.LQCEND(1)) THEN IF (IQ(LQHOLD+2).EQ.0) THEN JSLTO = LQLEND(1) GO TO 41 ENDIF ENDIF C-- create the new HOLD bank LSAVE = LQHOLD CALL MQLIFT (LQHOLD,0,7,JBKHOL,1) IQ(LQHOLD+1) = IQ(LSAVE+1) IQ(LQHOLD+2) = IQ(LSAVE+2) IQ(LQHOLD+3) = IQ(LSAVE+3) IQ(LSAVE+1) = 0 IQ(LSAVE+2) = 0 +SEQ, QEJECT. C---- Create the linear structure of GARB banks LQCEND(2) = LQCSTA(2) LQPREP = 0 KJOIN = KQPREP CALL QNAME (LSAVE) LQ(IQLNA) = IOR (LQ(IQLNA),KMDROP) LNX = IQLNX C-- do the next bank, does it have lines attached? 22 IF (LNX.GE.LQCEND(1)) GO TO 31 CALL QBLOW (LNX) LNX = IQLNX LST = IQLST 24 IF (IQLI.EQ.0) GO TO 22 JSLFR = IQ(LST+1) IF (JSLFR.LT.LQLSTA(2)) GO TO 22 IF (JSLFR.GE.LQLEND(2)) GO TO 22 NSL = IQ(LST+2) IF (NSL.EQ.0) THEN IQ(LST+1) = 0 GO TO 22 ENDIF CALL MQLIFT (LP,KJOIN,0,JBKGAR,2) KJOIN = LP - 1 IQ(LP+1) = JSLFR IQ(LP+2) = LST GO TO 22 C---- Copy the material 31 JSLTO = LQLEND(1) JTXTO = MLIAD(JSLTO) IF (LQPREP.EQ.0) GO TO 41 CALL QSORTI (1,KQPREP) LP = KQPREP + 1 32 LP = LQ(LP-1) IF (LP.EQ.0) GO TO 41 LST = IQ(LP+2) JSLFR = IQ(LST+1) NSL = IQ(LST+2) +SELF, IF=XSHIFT. CALL DUMPSL (JSLFR,NSL,'about to be shifted') +SELF. IQ(LST+1) = JSLTO JTXFR = MLIAD(JSLFR) NTX = MLIAD(JSLFR+NSL) - JTXFR NTXRE = JTXTO - JTXFR DO 34 J=1,NSL 34 MLIAD(JSLTO+J) = MLIAD(JSLFR+J) + NTXRE CALL CCOPYL (TEXT(JTXFR),TEXT(JTXTO),NTX) +SELF, IF=XSHIFT. CALL DUMPSL (JSLTO,NSL,'having been shifted') +SELF. JTXTO = JTXTO + NTX JSLTO = JSLTO + NSL GO TO 32 C-- reset end of TEXT division 1 and division 2 41 IF (IQ(LQHOLD+2).EQ.0) THEN LQLEND(1) = JSLTO LQLSTA(2) = JSLTO LQLEND(2) = JSLTO IQ(LQHOLD+1) = JSLTO ELSE LQLEND(1) = IQ(LQHOLD+1) LQLSTA(2) = LQLEND(1) LQLEND(2) = LQLSTA(2) + IQ(LQHOLD+2) ENDIF LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) LQCEND(2) = LQCSTA(2) RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQGARB. SUBROUTINE MQGARB C- Garbage collector - control routine C. started 8-oct-91 +CDE, QUNIT, MQCM, MQCT. +CDE, QSH. C-------------- End CDE -------------------------------- PARAMETER (KQGARB=1) +SELF, IF=QDEBUG, IF=XWITHME. NQUSED = NQUSED + 1 WRITE (IQPRNT,9801) 9801 FORMAT (' *** Debug: garbage collection operates') +SELF. CALL VZERO (NQRESV,3) IF (LQGARB.EQ.0) GO TO 41 24 CALL MQKILL IF (LQGARB.EQ.0) GO TO 27 C---- Collect Text garbage CALL QSORTI (1,KQGARB) +SELF, IF=XDEBUG, IF=XMQGARB. CALL DDLINS ('Garbage d/s in MQGARB', LQGARB) +SELF. CALL MQLTAB +SELF, IF=XDEBUG, IF=XMQGARB. CALL DUMPTB ('after CALL MQLTAB') +SELF. CALL MQLREL CALL MQLMOV C---- Collect Control garbage 27 CALL MQTABL IF (NQFREE(1).EQ.0) GO TO 41 CALL MQRELC CALL MQMOVE IF (LQGARB.NE.0) GO TO 24 IF (IQPART.NE.0) GO TO 27 C---- Everbody happy? 41 IF (NQRESV(1).LT.0) GO TO 71 IF (NQRESV(2).LT.0) GO TO 71 IF (NQRESV(3).LT.0) GO TO 71 RETURN C--- Not enough space 71 IQUEST(1) = 99 IQUEST(2) = NQRESV(1) IQUEST(3) = NQRESV(2) IQUEST(4) = NQRESV(3) CALL P_KILL ('MQGARB, no space.') END +SEQ, QCARDL. ===================================================== +DECK, MQGETT. SUBROUTINE MQGETT C- Garbage collector - find biggest space for the relocation table C. started 8-oct-91 +CDE, MQCM, MQCT. +CDE, Q. C-------------- End CDE -------------------------------- C-- control division 2 empty LQTA = LQCEND(1) IF (LQCSTA(2).EQ.LQCEND(2)) THEN NWAV = LQCSTA(3) - LQTA GO TO 21 ENDIF C-- control division 1/2 NWAV = LQCSTA(2) - LQTA C-- control division 2/3 IF (NWAV.LT.LQCSTA(3)-LQCEND(2)) THEN LQTA = LQCEND(2) NWAV = LQCSTA(3) - LQTA ENDIF C-- text division 2/3 21 IF (NWAV+8.LT.LQLSTA(4)-LQLEND(2)) THEN LQTA = LQLEND(2) + 2 NWAV = LQLSTA(4) - LQTA - 2 LQTA = LQTA + NQOFFS ENDIF LQTE = LQTA + NWAV RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQTABL. SUBROUTINE MQTABL C- Garbage collector - relocation table building C- only banks in division 1 can be collected C. started 8-oct-91 +CDE, MQCM, MQCT, MQCN. +CDE, QSH. C-------------- End CDE -------------------------------- EQUIVALENCE (LS,IQLST) PARAMETER (IQTVAL=0) +SEQ, Q_SHIFTR. C---- Decide where to put the table CALL MQGETT LIMIT = LQTE - 8 LQTB = LQTA + 3 LQTE = LQTA NWFREE = 0 IQPART = 0 MODE = IQTVAL LQ(LQTA) = LQCSTA(1) LN = LQCSTA(1) LSTOP = LQCEND(1) GO TO 24 C------ Next bank 21 MODE = NEW 22 LN = IQLNX 24 IF (LN.GE.LSTOP) GO TO 39 CALL QBLOW (LN) NEW = ISHFTR (IQ(LN),30) IF (NEW.EQ.MODE) GO TO 22 IF (NEW.EQ.IQTVAL) GO TO 36 C-- start of a dead group LQ(LQTE+1) = LN LQTE = LQTE + 3 GO TO 21 C-- start of a live group 36 LQ(LQTE) = LN IF (LQTE.LT.LIMIT) GO TO 21 MODE = IQTVAL IQPART = 1 C------ End of table, C-- compute relocation constants 39 IF (MODE.EQ.IQTVAL) THEN LQ(LQTE+1) = LQCEND(1) LQTE = LQTE + 3 ENDIF LQ(LQTE) = LQCEND(1) DO 44 JTB=LQTB,LQTE,3 NWFREE = NWFREE + LQ(JTB) - LQ(JTB-2) 44 LQ(JTB+2) = -NWFREE LQ(LQTA+2) = 3 NQRESV(1) = NQRESV(1) + NWFREE NQFREE(1) = NWFREE LQMTB = LQTB LQMTE = LQTE RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQRELC. SUBROUTINE MQRELC C- Garbage collector - Relocator C- only links in banks in divisions 1 and 3 need relocation C. started 8-oct-91 +CDE, MQCM, MQCT, MQCN. +CDE, QSH. C-------------- End CDE -------------------------------- EQUIVALENCE (LS,IQLST) LKEEP = LQ(LQTB-2) LFIX = LQ(LQTE) NENTR = (LQTE-LQTB) / 3 JDIV = 1 GO TO 15 C-------------- Trigger control C-- What next ? 12 IF (LN.EQ.0) GO TO 17 IF (JDIV.EQ.3) RETURN JDIV = 3 LN = LQCSTA(JDIV) LDEAD = LQCEND(JDIV) LSTOP = LDEAD IF (LN.EQ.LSTOP) GO TO 12 IF (NENTR) 53,43,23 C-- Trigger structural permanent links 15 L1 = 0 L2 = 0 LN = 0 LSTOP= 0 LS = NQSYSS + 1 GO TO 19 C-- Trigger working space links and division 1 17 LS = NQLINK + 1 L2 = LS LMTB = LQMTB-3 LN = LQ(LMTB) LDEAD= LQ(LMTB+1) LSTOP= LQCEND(1) 19 IF (NENTR) 54,44,24 C-------------- 2 or more relocation intervals ------------- C------ Next bank, check if dead group 21 IF (LN.EQ.LSTOP) GO TO 12 IF (LN.NE.LDEAD) GO TO 23 LMTB = LMTB + 3 LN = LQ(LMTB) LDEAD= LQ(LMTB+1) GO TO 21 C-- Next bank, alive 23 CALL QBLOW (LN) L2 = LS - IQNS L1 = LN LN = IQLNX C---- Next link 24 L1 = L1 + 1 IF (L1.EQ.LS) GO TO 21 25 LINK = LQ(L1) IF (LINK.GE.LFIX) GO TO 24 IF (LINK.LT.LKEEP) GO TO 24 IF (LINK.LT.LQ(LQTB)) GO TO 31 JLOW = 0 JHI = NENTR + 1 C-- Binary search in relocator table 27 JEX = (JHI+JLOW) / 2 IF (JEX.EQ.JLOW) GO TO 29 IF (LINK.GE.LQ(LQTB+3*JEX)) GO TO 28 JHI = JEX GO TO 27 28 JLOW = JEX GO TO 27 29 JTB = LQTB + 3*JLOW IF (LINK.GE.LQ(JTB+1)) GO TO 31 LQ(L1) = LINK + LQ(JTB+2) GO TO 24 C-- Bridging for dead, structural link 31 IF (L1.LT.L2) GO TO 38 LQ(L1)= LQ(LINK-1) GO TO 25 38 LQ(L1)= 0 GO TO 24 C-------------- 1 relocation interval only ------------- C------ Next bank, check if dead group 41 IF (LN.EQ.LSTOP) GO TO 12 IF (LN.NE.LDEAD) GO TO 43 LMTB = LMTB + 3 LN = LQ(LMTB) LDEAD= LQ(LMTB+1) GO TO 41 C-- Next bank, alive 43 CALL QBLOW (LN) L2 = LS - IQNS L1 = LN LN = IQLNX C---- Next link 44 L1 = L1 + 1 IF (L1.EQ.LS) GO TO 41 45 LINK = LQ(L1) IF (LINK.GE.LFIX) GO TO 44 IF (LINK.LT.LKEEP) GO TO 44 IF (LINK.LT.LQ(LQTB)) GO TO 47 IF (LINK.GE.LQ(LQTB+1)) GO TO 47 LQ(L1) = LINK + LQ(LQTB+2) GO TO 44 C-- Bridging for dead, structural link 47 IF (L1.LT.L2) GO TO 48 LQ(L1)= LQ(LINK-1) GO TO 45 48 LQ(L1)= 0 GO TO 44 C-------------- No relocation interval ---------------- C------ Next bank, check if dead group 51 IF (LN.EQ.LSTOP) GO TO 12 IF (LN.NE.LDEAD) GO TO 53 LMTB = LMTB + 3 LN = LQ(LMTB) LDEAD= LQ(LMTB+1) GO TO 51 C-- Next bank, alive 53 CALL QBLOW (LN) L2 = LS - IQNS L1 = LN LN = IQLNX C---- Next link 54 L1 = L1 + 1 IF (L1.EQ.LS) GO TO 51 55 LINK= LQ(L1) IF (LINK.GE.LFIX) GO TO 54 IF (LINK.LT.LKEEP) GO TO 54 IF (L1.LT.L2) GO TO 58 C-- Bridging for dead, structural link 57 LINK = LQ(LINK-1) IF (LINK.GE.LFIX) GO TO 59 IF (LINK.LT.LKEEP) GO TO 59 GO TO 57 58 LQ(L1)= 0 GO TO 54 59 LQ(L1)= LINK GO TO 54 END +SEQ, QCARDL. ===================================================== +DECK, MQMOVE. SUBROUTINE MQMOVE C- Garbage collector - memory move C. started 8-oct-91 +CDE, MQCM, MQCT. +CDE, QSH. C-------------- End CDE -------------------------------- PARAMETER (NSTEP=3) C---- MOVE LOW BANKS IF (LQMTB.EQ.LQMTE) THEN LQCEND(1) = LQ(LQMTE-2) RETURN ENDIF LQCEND(1) = LQ(LQMTE-2) + LQ(LQMTE-1) JTB = LQMTB JEND = LQMTE 41 LOLD = LQ(JTB) LNEW = LQ(JTB+2) + LOLD N = LQ(JTB+1) - LOLD CALL UCOPY (LQ(LOLD),LQ(LNEW),N) JTB = JTB + NSTEP IF (JTB.NE.JEND) GO TO 41 RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQKILL. SUBROUTINE MQKILL C- Turn the garbage d/s into a flat linear structure C- mark banks in division 1 to be dead C- keep in the structure only banks in division 1 with line-numbers C. started 8-oct-91 +CDE, MQCM, MQCN, QSYSBITS, QSH. C-------------- End CDE -------------------------------- PARAMETER (KQGARB=1) +SEQ, Q_OR. KCUR = KQGARB 21 LCUR = LQ(KCUR) IF (LCUR.EQ.0) RETURN IF (LCUR.GE.LQCEND(1)) GO TO 49 CALL QNAME (LCUR) LQ(IQLNA) = IOR (LQ(IQLNA),KMDROP) IF (IQNS.LT.2) GO TO 41 C---- Bank with structural links reached KUSE = LCUR - IQNS -1 C-- Look at next link 24 KUSE = KUSE + 1 IF (KUSE.EQ.LCUR-1) GO TO 41 LNEW = LQ(KUSE) IF (LNEW.EQ.0) GO TO 24 IF (LNEW.GE.LQCEND(1)) THEN LQ(KUSE) = 0 GO TO 24 ENDIF C-- Shunt the linear structure at KUSE to LCUR-1 CALL QSHLIN (KUSE,LCUR-1) GO TO 24 C---- Keep current bank connected only if with line-number 41 IF (IQLI.EQ.0) GO TO 49 IF (IQ(LCUR+1).EQ.0) GO TO 49 IF (IQ(LCUR+1).GE.LQLSTA(2)) GO TO 49 IF (IQ(LCUR+2).EQ.0) GO TO 49 KCUR = LCUR - 1 GO TO 21 C-- bridge unwanted bank 49 LQ(KCUR) = LQ(LCUR-1) GO TO 21 END +SEQ, QCARDL. ===================================================== +DECK, MQLTAB. SUBROUTINE MQLTAB C- Garbage collector - relocation table building, line slot numbers C- run through all banks of the linear garbage structure, which C- at this point contains only banks with text pointers C. started 8-oct-91 +CDE, QUNIT, MQCM, MQCT, MQCN. +CDE, QSYSBITS, QSH. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_NOT. C---- Decide where to put the table CALL MQGETT LIMIT = LQTE - 8 LQTB = LQTA + 3 LQTE = LQTA NLFREE = 0 JSLL = 1 LNX = LQGARB C------ Do all banks 22 LS = LNX IF (LS.EQ.0) GO TO 37 LNX = LQ(LS-1) JSLA = IQ(LS+1) JSLE = JSLA + IQ(LS+2) IF (JSLA.LE.JSLL) THEN JSLL = JSLE GO TO 22 ENDIF C-- start of new dead region IF (LQTE.GE.LIMIT) GO TO 31 LQ(LQTE) = JSLL LQ(LQTE+1) = JSLA JSLL = JSLE LQTE = LQTE + 3 GO TO 22 C------ End of table C-- Not enough table space, partial collection 31 LQGARB = LS +SELF, IF=QDIAG. WRITE (IQPRNT,9801) 9801 FORMAT (' *** Debug: partial collection with MQLTAB') +SELF. 34 CALL QNAME (LS) LQ(IQLNA) = IAND (LQ(IQLNA), NOT(KMDROP)) LS = LQ(LS-1) IF (LS.NE.0) GO TO 34 LS = LQGARB C-- Normal end 37 LQGARB = LS LQ(LQTE) = JSLL IF (JSLL.NE.LQLEND(1)) THEN LQ(LQTE+1) = LQLEND(1) LQTE = LQTE + 3 LQ(LQTE) = LQLEND(1) ENDIF LQ(LQTA+2) = 0 LQ(LQTE+1) = 0 C-- compute relocation constants DO 44 JTB=LQTB,LQTE,3 NLFREE = NLFREE + LQ(JTB) - LQ(JTB-2) 44 LQ(JTB+2) = -NLFREE NQRESV(2) = NQRESV(2) + NLFREE NQFREE(2) = NLFREE RETURN END +SEQ, QCARDL. ===================================================== +DECK, MQLREL. SUBROUTINE MQLREL C- Garbage collector - Relocator, line slot numbers C. started 8-oct-91 +CDE, MQCM, MQCT, MQCN. +CDE, QSH. C-------------- End CDE -------------------------------- EQUIVALENCE (LS,IQLST) LKEEP = LQ(LQTB-2) LFIX = LQ(LQTE) NENTR = (LQTE-LQTB) / 3 JDIV = 0 C---- Do next division 12 IF (JDIV.EQ.1) RETURN JDIV = JDIV + 1 LN = LQCSTA(JDIV) LSTOP = LQCEND(JDIV) IF (NENTR) 51,41,21 C-------------- 2 or more relocation intervals ------------- C-- Next bank 21 IF (LN.EQ.LSTOP) GO TO 12 CALL QBLOW (LN) LN = IQLNX IF (IQLI.EQ.0) GO TO 21 JSL = IQ(LS+1) IF (JSL.GE.LFIX) GO TO 21 IF (JSL.LT.LKEEP) GO TO 21 IF (JSL.LT.LQ(LQTB)) GO TO 38 JLOW = 0 JHI = NENTR + 1 C-- Binary search in relocator table 27 JEX = (JHI+JLOW) / 2 IF (JEX.EQ.JLOW) GO TO 29 IF (JSL.GE.LQ(LQTB+3*JEX)) GO TO 28 JHI = JEX GO TO 27 28 JLOW = JEX GO TO 27 29 JTB = LQTB + 3*JLOW IF (JSL.GE.LQ(JTB+1)) GO TO 38 IQ(LS+1) = JSL + LQ(JTB+2) GO TO 21 38 IQ(LS+1) = 0 GO TO 21 C-------------- 1 relocation interval only ------------- C-- Next bank 41 IF (LN.EQ.LSTOP) GO TO 12 CALL QBLOW (LN) LN = IQLNX IF (IQLI.EQ.0) GO TO 41 JSL = IQ(LS+1) IF (JSL.GE.LFIX) GO TO 41 IF (JSL.LT.LKEEP) GO TO 41 IF (JSL.LT.LQ(LQTB)) GO TO 48 IF (JSL.GE.LQ(LQTB+1)) GO TO 48 IQ(LS+1) = JSL + LQ(LQTB+2) GO TO 41 48 IQ(LS+1) = 0 GO TO 41 C-------------- No relocation interval ---------------- C-- Next bank 51 IF (LN.EQ.LSTOP) GO TO 12 CALL QBLOW (LN) LN = IQLNX IF (IQLI.EQ.0) GO TO 51 JSL = IQ(LS+1) IF (JSL.GE.LFIX) GO TO 51 IF (JSL.LT.LKEEP) GO TO 51 IQ(LS+1) = 0 GO TO 51 END +SEQ, QCARDL. ===================================================== +DECK, MQLMOV. SUBROUTINE MQLMOV C- Garbage collector - memory move, line slot numbers + text C. started 8-oct-91 +CDE, MQCM, MQCT. +CDE, Q. C-------------- End CDE -------------------------------- PARAMETER (NSTEP=3) IF (LQTB.EQ.LQTE) THEN LQLEND(1) = LQ(LQTE-2) RETURN ENDIF JSLTO = LQ(LQTB-2) JTXTO = MLIAD(JSLTO) JTB = LQTB 41 JSLFR = LQ(JTB) NLI = LQ(JTB+1) - JSLFR +SELF, IF=QDEBUG. IF (JSLTO.NE.JSLFR+LQ(JTB+2)) CALL P_CRASH ('MQLMOV mismatch') +SELF. JTXFR = MLIAD(JSLFR) NTX = MLIAD(JSLFR+NLI) - JTXFR NTXRE = JTXTO - JTXFR DO 44 J=1,NLI 44 MLIAD(JSLTO+J) = MLIAD(JSLFR+J) + NTXRE CALL CCOPYL (TEXT(JTXFR),TEXT(JTXTO),NTX) JTXTO = JTXTO + NTX JSLTO = JSLTO + NLI JTB = JTB + NSTEP IF (JTB.NE.LQTE) GO TO 41 NTFREE = MLIAD(LQLEND(1)) - JTXTO LQLEND(1) = JSLTO NQRESV(3) = NQRESV(3) + NTFREE NQFREE(3) = NTFREE RETURN END +SEQ, QCARDL. ===================================================== +PATCH, QUTIL. Hydra utility routines +DECK, IQLOCF. FUNCTION IQLOCF (VAR) C- Return the address of VAR in LQ +CDE, MQCM, QSH. C-------------- End CDE -------------------------------- DIMENSION VAR(9) IQLOCF = LOCF(VAR(1)) - LQADR0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, KQLAST, T=JOIN. FUNCTION KQLAST (KGO) C-- Find the end of a linear structure attached to LQ(KGO) +CDE, QSH. C-------------- End CDE -------------------------------- L = KGO + 1 24 K = L-1 L = LQ(K) IF (L.NE.0) GO TO 24 KQLAST= K RETURN END +SEQ, QCARDL. ===================================================== +DECK, KQFIND, T=JOIN. FUNCTION KQFIND (IT,JWORD,KGO,KFOUND) C- Find first bank containing IT in word JWORD C- search linear structure attached at LQ(KGO) C- return its bank-adr as value, its K-adr in KFOUND C- if not found: KQFIND=0, KFOUND = L-1 of last bank +CDE, QSH. C-------------- End CDE -------------------------------- JW = JWORD L = KGO + 1 24 K = L-1 L = LQ(K) IF (L.EQ.0) GO TO 29 IF (IQ(L+JW).NE.IT) GO TO 24 29 KFOUND = K KQFIND = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, LQFIND. FUNCTION LQFIND (IT,JWORD,LGO) C- Find first bank containing IT in word JWORD C- in the linear structure supported by LGO; C- return its bank-adr as value, if not found: LQFIND=0 +CDE, QSH. C-------------- End CDE -------------------------------- JW = JWORD L = LGO 24 IF (L.EQ.0) GO TO 29 IF (IQ(L+JW).EQ.IT) GO TO 29 L = LQ(L-1) GO TO 24 29 LQFIND = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, LQSTEP, T=JOIN. FUNCTION LQSTEP (LBK,NSTEP) C- Step LBK by NSTEP steps through the linear structure C. started 17-june-94 +CDE, QSH. C-------------- End CDE -------------------------------- N = NSTEP L = LBK 24 IF (N.LE.0) GO TO 29 N = N - 1 IF (L.EQ.0) CALL P_KILL ('LQSTEP is in trouble') L = LQ(L-1) GO TO 24 29 LQSTEP = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, NQCOUNT, T=JOIN. FUNCTION NQCOUNT (LGO) C- Count the number of banks in the linear structure +CDE, QSH. C-------------- End CDE -------------------------------- N = 0 L = LGO 24 IF (L.NE.0) THEN N = N + 1 L = LQ(L-1) GO TO 24 ENDIF NQCOUNT = N RETURN END +SEQ, QCARDL. ===================================================== +DECK, QSHUNT. SUBROUTINE QSHUNT (KOLD,KNEW) C- Shunt the single bank at KOLD connecting it to KNEW +CDE, QSH. C-------------- End CDE -------------------------------- IF (KOLD.EQ.KNEW) RETURN L = LQ(KOLD) IF (L.EQ.0) RETURN LQ(KOLD) = LQ(L-1) LQ(L-1) = LQ(KNEW) LQ(KNEW) = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, QSHLIN, T=JOIN. SUBROUTINE QSHLIN (KOLD,KNEW) C- Disconnect the linear stucture from KOLD and insert it at KNEW +CDE, QSH. C-------------- End CDE -------------------------------- IF (KOLD.EQ.KNEW) RETURN LGO = LQ(KOLD) IF (LGO.EQ.0) RETURN LSV = LQ(KNEW) LNX = LGO 24 LL = LNX LNX = LQ(LL-1) IF (LNX.NE.0) GO TO 24 LQ(KOLD) = 0 LQ(KNEW) = LGO LQ(LL-1) = LSV RETURN END +SEQ, QCARDL. ===================================================== +DECK, QTOPSY, T=JOIN. SUBROUTINE QTOPSY (KGO) C- Invert order of banks in a linear stucture +CDE, QSH. C-------------- End CDE -------------------------------- LN = LQ(KGO) L = 0 11 IF (LN.EQ.0) GO TO 21 LL = L L = LN LN = LQ(L-1) LQ(L-1) = LL GO TO 11 21 LQ(KGO) = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, QSORTI. SUBROUTINE QSORTI (JWORD,KGO) C- Sort banks at KGO for words IQ(L+JWORD) to be in increasing order +CDE, QSH. C-------------- End CDE -------------------------------- LL = LQ(KGO) IF (LL.EQ.0) RETURN JW = JWORD 11 LN = LQ(LL-1) IF (LN.EQ.0) RETURN IF (IQ(LN+JW).LT.IQ(LL+JW)) GO TO 21 LL = LN GO TO 11 C-- BANK LN OUT OF SEQUENCE 21 LQ(LL-1)= LQ(LN-1) K = KGO 24 L = LQ(K) IF (IQ(LN+JW).LT.IQ(L+JW)) GO TO 29 K = L-1 GO TO 24 C-- PLACE FOR BANK LN FOUND 29 LQ(LN-1)= L LQ(K) = LN GO TO 11 END +SEQ, QCARDL. ===================================================== +DECK, QSORTN, T=JOIN. SUBROUTINE QSORTN (JWORD,KGO) C- Sort banks at KGO for the names pointed to C- by words IQ(L+JWORD) to be in increasing order +CDE, QSH. C-------------- End CDE -------------------------------- LL = LQ(KGO) IF (LL.EQ.0) RETURN JW = JWORD 11 LN = LQ(LL-1) IF (LN.EQ.0) RETURN IF (NA_DIF(IQ(LN+JW),IQ(LL+JW)).LT.0) GO TO 21 LL = LN GO TO 11 C-- BANK LN OUT OF SEQUENCE 21 LQ(LL-1)= LQ(LN-1) K = KGO 24 L = LQ(K) IF (NA_DIF(IQ(LN+JW),IQ(L+JW)).LT.0) GO TO 29 K = L-1 GO TO 24 C-- PLACE FOR BANK LN FOUND 29 LQ(LN-1)= L LQ(K) = LN GO TO 11 END +SEQ, QCARDL. ===================================================== +DECK, QLUMP. SUBROUTINE QLUMP C- Compact the NAME parameters in /MQCL/ into the name-word C- of the bank starting at NQLST +CDE, MQCL. +CDE, QSH. C-------------- End CDE -------------------------------- +SEQ, Q_SHIFTL. NACC = NQND NACC = ISHFTL(NACC,6) + NQNS NACC = ISHFTL(NACC,6) + NQNL NACC = ISHFTL(NACC,1) + NQLI NACC = ISHFTL(NACC,6) + NQTY LQ(NQLNA) = NACC IQ(NQLST) = ISHFTL(NQNL,26) RETURN END +SEQ, QCARDL. ===================================================== +DECK, QBLOW, T=JOIN. SUBROUTINE QBLOW (LN) C- Blow the name of the bank at LN, name-word adr +CDE, QBANKS, MQCM, MQCN, QSH. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_SHIFTR. IQLNA = LN M = LQ(IQLNA) IQTY= IAND (M,63) M = ISHFTR(M,6) IQLI= IAND (M,1) M = ISHFTR(M,1) IQNL= IAND (M,63) M = ISHFTR(M,6) IQNS= IAND (M,63) M = ISHFTR(M,6) IQND= IAND (M,2047) IQLST = IQLNA + IQNL + 1 +SELF, IF=QDEBUG. NL = ISHFTR(IQ(IQLST),26) IF (NL.NE.IQNL) GO TO 91 IF (IQNL.LT.IQNS) GO TO 91 IF (IQLST+IQND.GE.NQMAX) GO TO 91 IF (IQTY.EQ.0) GO TO 91 IF (IQTY.GT.NBANKS) GO TO 91 IF (IQNL+IQND.EQ.0) GO TO 91 +SELF. IQLNX = IQLST + IQND + 1 IQID = MMBANK(1,IQTY) RETURN +SELF, IF=QDEBUG 91 CALL DQCLOBB (IQLNA,0) RETURN +SELF. END +SEQ, QCARDL. ===================================================== +DECK, QNAME. SUBROUTINE QNAME (LS) C- Blow the name of the bank at LS, status word adr +CDE, QBANKS, MQCM, MQCN, QSH. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_SHIFTR. IQLST = LS +SELF, IF=QDEBUG. IF (IQLST.LT.LQCSTA(1)) GO TO 91 IF (IQLST.GE.NQMAX) GO TO 91 +SELF. NL = ISHFTR(LQ(IQLST),26) IQLNA = IQLST - NL - 1 M = LQ(IQLNA) IQTY= IAND (M,63) M = ISHFTR(M,6) IQLI= IAND (M,1) M = ISHFTR(M,1) IQNL= IAND (M,63) M = ISHFTR(M,6) IQNS= IAND (M,63) M = ISHFTR(M,6) IQND= IAND (M,2047) +SELF, IF=QDEBUG. IF (NL.NE.IQNL) GO TO 91 IF (IQNL.LT.IQNS) GO TO 91 IF (IQLST+IQND.GE.NQMAX) GO TO 91 IF (IQTY.EQ.0) GO TO 91 IF (IQTY.GT.NBANKS) GO TO 91 IF (IQNL+IQND.EQ.0) GO TO 91 +SELF. IQLNX = IQLST + IQND + 1 IQID = MMBANK(1,IQTY) RETURN +SELF, IF=QDEBUG. 91 CALL DQCLOBB (0,IQLST) RETURN +SELF. END +SEQ, QCARDL. ===================================================== +DECK, QBLOWX. SUBROUTINE QBLOWX (LN) C- QBLOW with legality check +CDE, QBANKS, MQCM, MQCN, QSH. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_SHIFTR. IQLNA = LN M = LQ(IQLNA) IQTY= IAND (M,63) M = ISHFTR(M,6) IQLI= IAND (M,1) M = ISHFTR(M,1) IQNL= IAND (M,63) M = ISHFTR(M,6) IQNS= IAND (M,63) M = ISHFTR(M,6) IQND= IAND (M,2047) IQLST = IQLNA + IQNL + 1 NL = ISHFTR(IQ(IQLST),26) IF (NL.NE.IQNL) GO TO 91 IF (IQNL.LT.IQNS) GO TO 91 IF (IQLST+IQND.GE.NQMAX) GO TO 91 IF (IQTY.EQ.0) GO TO 91 IF (IQTY.GT.NBANKS) GO TO 91 IF (IQNL+IQND.EQ.0) GO TO 91 IQFOUL = 0 IQLNX = IQLST + IQND + 1 IQID = MMBANK(1,IQTY) RETURN 91 IQFOUL= -1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, QNAMEX. SUBROUTINE QNAMEX (LS) C- QNAME with legality check +CDE, QBANKS, MQCM, MQCN, QSH. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_SHIFTR. IQLST = LS IF (IQLST.LT.LQCSTA(1)) GO TO 96 IF (IQLST.GE.NQMAX) GO TO 96 NL = ISHFTR(LQ(IQLST),26) IQLNA = IQLST - NL - 1 M = LQ(IQLNA) IQTY= IAND (M,63) M = ISHFTR(M,6) IQLI= IAND (M,1) M = ISHFTR(M,1) IQNL= IAND (M,63) M = ISHFTR(M,6) IQNS= IAND (M,63) M = ISHFTR(M,6) IQND= IAND (M,2047) IF (NL.NE.IQNL) GO TO 91 IF (IQNL.LT.IQNS) GO TO 91 IF (IQLST+IQND.GE.NQMAX) GO TO 91 IF (IQTY.EQ.0) GO TO 91 IF (IQTY.GT.NBANKS) GO TO 91 IF (IQNL+IQND.EQ.0) GO TO 91 IQFOUL = 0 IQLNX = IQLST + IQND + 1 IQID = MMBANK(1,IQTY) RETURN 91 IQFOUL = -1 RETURN 96 IQFOUL = 1 RETURN END +SEQ, QCARDL. ===================================================== +PATCH, YINDEX. for program Nyindex +DECK, NINDEX. PROGRAM NINDEX +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=3) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'PAM .car 9 2 0 !ff' +, 'opt 3 11 0 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist +SELF, IF=QS_IBMVM. NAME(3)(9:16) = '.listing' +SELF. CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nyindex Bare, ' // + 'Help, Ponly, Quick, Xpatch, Ydeck, Zseq, 0->4 pg size') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXINDEX +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXINDEX. SUBROUTINE EXINDEX C- Run nyindex C. started 12-jan-94 +CDE, SLATE, SLATLN, QBITA31, QBANKS, QPAGE, QSTATE, QUNIT. +CDE, CM_TYP, LUNSLN. +CDE, KQADR, KQUSER, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*110, LINETT*60 EQUIVALENCE (LINE, SLLINE) EQUIVALENCE (LINETT, LINE(47:)) PARAMETER (MASK= KMB + KMH + KMP + KMQ + KMX + KMY + KMZ) DIMENSION MMPAT(4), MMDECK(4), MMKEEP(4) DATA MMPAT / 0, 1, 1, 2 / DATA MMDECK / 0, 2, 1, 3 / DATA MMKEEP / 0, 2, 1, 1 / +SEQ, Q_AND. +SEQ, bkYINDEX, IF=DOC_INL. +SEQ, QEJECT. CALL INIAUX (LASTWK) CALL KROPT (IXLUN(2),MASK) CALL PGSIZE (0, IXLUN(2)) MOPTIO(16) = MAX (MOPTIO(16), MOPTIO(17)) IF (MOPTIO(8).NE.0) GO TO 81 NQCMAX = 100 NQCPGH = 100 CALL UCOPY (MMPAT, MMBANK(2,JBKPAT), 4) CALL UCOPY (MMDECK, MMBANK(2,JBKDEC), 4) CALL UCOPY (MMKEEP, MMBANK(2,JBKKEE), 4) CALL INIPAM (11, IXLUN(1), 1,0) C------ Load the title deck to memory ------------ 21 IF (JDKNEX.EQ.0) CALL ARRIVE (2) C---- Handle the PAM-file title line JDKTYP = 3 CALL KRTITL IF (NQDKNO.GE.2) THEN NQDKNO = ((NQDKNO-1)/100 + 1) *100 ELSE NQDKNO = 0 ENDIF C------ Loop over all decks until next title CALL INDDECK IF (JDKTYP.EQ.3) GO TO 21 CALL INIPAM (0,0, -1,0) C------- Input finished, print tables CALL QTOPSY (KQUSER) CALL QSORTN (2,KQUSER) KQDECK = KQUSER + 1 CALL QTOPSY (KQDECK) CALL QSORTN (2,KQDECK) CALL QSORTN (1,KQDECK) C---- Print list of data types WRITE (IQPRNT,9025) NQUSED = NQUSED + 3 DO 27 JASM=1,N_TYP LASMT = LQ(LHASM-JASM) NDK = IQ(LASMT+8) IF (NDK.EQ.0) GO TO 27 N = LNBLNK (CH_TYP(JASM)) WRITE (IQPRNT,9027) NDK, CH_TYP(JASM)(1:N) NQUSED = NQUSED + 1 27 CONTINUE NQLLBL = 0 C---- Print duplicates CALL DPBLAN (0) LN = LQUSER(1) 32 LA = LN LN = LQ(LA-1) IF (LN.EQ.0) GO TO 35 IF (IQ(LA+2).NE.IQ(LN+2)) GO TO 32 IXP = IQ(LA+2) LINE = 'p=' CALL NA_GET (IXP,LINE,3) N = NESLAT WRITE (IQPRNT,9032) LINE(1:N) NQWARN = NQWARN + 1 NQUSED = NQUSED + 1 NQLLBL = 0 33 LN = LQ(LN-1) IF (LN.EQ.0) GO TO 35 IF (IQ(LN+2).NE.IXP) GO TO 32 GO TO 33 C-- deck names 35 CALL DPBLAN (0) LN = LQUSER(2) 36 LA = LN LN = LQ(LA-1) IF (LN.EQ.0) GO TO 41 IF (IQ(LA+1).NE.IQ(LN+1)) GO TO 36 IF (IQ(LA+2).NE.IQ(LN+2)) GO TO 36 IXD = IQ(LA+1) IXP = IQ(LA+2) LINE = 'p=' CALL NA_GET (IXP,LINE,3) N = NESLAT LINE(N+1:N+2) = 'd=' N = N + 3 CALL NA_GET (IXD,LINE,N) N = NESLAT WRITE (IQPRNT,9032) LINE(1:N) NQWARN = NQWARN + 1 NQUSED = NQUSED + 1 NQLLBL = 0 37 LN = LQ(LN-1) IF (LN.EQ.0) GO TO 41 IF (IQ(LN+1).NE.IXD) GO TO 36 IF (IQ(LN+2).NE.IXP) GO TO 36 GO TO 37 C----- Print index of patches 41 IF (MOPTIO(24).NE.0) GO TO 88 NBK = NQCOUNT (LQUSER(1)) NQUSED = MOD (NQUSED, NQLMAX) IF (NQUSED+NBK+4.GE.NQLMAX) THEN WRITE (IQPRNT,9041) NQUSED = 3 ELSE WRITE (IQPRNT,9042) NQUSED = NQUSED + 3 ENDIF LP = LQUSER(1) 42 IF (LP.EQ.0) GO TO 45 NDK = IQ(LP+1) IXPAT = IQ(LP+2) IFLG = IAND (IQ(LP),KM6) LINE(1:13) = ' = ' C- ' if 123456 = pname C- _:.=+=.: 1_:.= IF (NDK.LT.0) THEN LINE(10:13) = '- ' ELSE CALL CSETDI (NDK,LINE,5,10) ENDIF IF (IFLG.NE.0) LINE(2:3)= 'If' CALL NA_GET (IXPAT,LINE,14) NN = NESLAT - 1 WRITE (IQPRNT,9008) LINE(1:NN) NQUSED = NQUSED + 1 LP = LQ(LP-1) GO TO 42 C---- Print index of decks 45 IF (MOPTIO(25).NE.0) GO TO 87 NBK = NQCOUNT (LQUSER(2)) NQUSED = MOD (NQUSED, NQLMAX) IF (NQUSED+NBK+4.GE.NQLMAX) THEN WRITE (IQPRNT,9045) NQUSED = 3 ELSE WRITE (IQPRNT,9046) NQUSED = NQUSED + 3 ENDIF LD = LQUSER(2) 46 IF (LD.EQ.0) GO TO 51 IXDEC = IQ(LD+1) IXPAT = IQ(LD+2) NDK = IQ(LD+3) LINE(1:26) = ' = .' C- ' 123456 = dname .pname C- _:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: CALL CSETDI (NDK,LINE,5,10) CALL NA_GET (IXDEC,LINE,14) NN = NESLAT NN = MAX (NN,26) LINE(NN:NN) = '.' CALL NA_GET (IXPAT,LINE,NN+1) NN = NESLAT - 1 WRITE (IQPRNT,9008) LINE(1:NN) NQUSED = NQUSED + 1 LD = LQ(LD-1) GO TO 46 +SEQ, QEJECT. C---- Print index of sequence definitions 51 IF (MOPTIO(26).NE.0) GO TO 87 CALL QTOPSY (KQKEEP) CALL QSORTN (1,KQKEEP) NBK = NQCOUNT (LQKEEP) NQUSED = MOD (NQUSED, NQLMAX) IF (NQUSED+NBK+4.GE.NQLMAX) THEN WRITE (IQPRNT,9051) NQUSED = 3 ELSE WRITE (IQPRNT,9052) NQUSED = NQUSED + 3 ENDIF LZ = LQKEEP 52 IF (LZ.EQ.0) GO TO 87 IXSEQ = IQ(LZ+1) LD = LQ(LZ-2) IF (IAND(IQ(LZ),1).EQ.0) THEN IXDEC = IQ(LD+1) IXPAT = IQ(LD+2) NDK = IQ(LD+3) ELSE IXDEC = 0 NDK = IQ(LD+1) IXPAT = IQ(LD+2) ENDIF LINE(1:41) = ' : ' C- ' 123456 : zname d=dname .pname C- _:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: 4_:.=+=.: 5 CALL CSETDI (NDK,LINE,5,10) CALL NA_GET (IXSEQ,LINE,14) NN = NESLAT NN = MAX (NN,26) + 1 LINE(NN:NN+1) = 'd=' CALL NA_GET (IXDEC,LINE,NN+2) NN = NESLAT NN = MAX (NN,41) LINE(NN:NN) = '.' CALL NA_GET (IXPAT,LINE,NN+1) NN = NESLAT - 1 WRITE (IQPRNT,9008) LINE(1:NN) NQUSED = NQUSED + 1 LZ = LQ(LZ-1) GO TO 52 C---- Help 81 WRITE (IQPRNT,9081) 87 CALL PGSIZE (1, 0) 88 IF (NQWARN.NE.0) THEN WRITE (IQPRNT,9088) CALL EXITRC (1) ENDIF RETURN 9008 FORMAT (A) 9025 FORMAT (/' Table of Data types'/) 9027 FORMAT (4X,I6,' decks of type ',A) 9032 FORMAT (' **!! Warn: duplicate ',A) 9041 FORMAT ( '1 Index of Patches'/) 9042 FORMAT (/' Index of Patches'/) 9045 FORMAT ( '1 Index of Decks'/) 9046 FORMAT (/' Index of Decks'/) 9051 FORMAT ( '1 Index of Sequences defined'/) 9052 FORMAT (/' Index of Sequences defined'/) 9081 FORMAT ( ' nyindex pam.car options print'/ F/' reads the "pam" file, printing on "print" a running' F/' table-of-content of the patches and decks encountered,' F/' and at the end it prints 3 sorted indices of the patches,' F/' decks and sequence definitions seen.' F/' A "duplicate" warning is given if there are two or more' F/' decks of the same name in the same patch.'/ F/' "options": B bare - comment fields of P/D lines not to' F/' appear in the table-of-content' F/' H help - print this help information only' F/' P patch only - suppress the deck names from' F/' the table-of-content' F/' Q quick - suppress the table-of-content' F/' X - suppress all sorted indices' F/' Y - suppress the sorted indices of decks and' F/' sequence definitions' F/' Z - suppress the sorted index of sequences' F/' 0 ... 4 - select page size by single digit option' F/' "n" - set page size to be n > 19') 9088 FORMAT (' **!! There are warnings !!**'/) END +SEQ, QCARDL. ===================================================== +DECK, INDDECK. SUBROUTINE INDDECK C- Handle all decks until next +TITLE for nyindex C. started 12-jan-94 +CDE, SLATE, SLATLN, QBITS19, QPAGE, QUNIT. +CDE, CCTYPE, CCPARA, CHEXC, DEPCOM. +CDE, MQCM, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*110, LINETT*60 EQUIVALENCE (LINE, SLLINE) EQUIVALENCE (LINETT, LINE(47:)) C-- set limits of control division 2 21 LQCSTA(2) = LQCEND(1) + 100 LQCEND(2) = LQCSTA(2) C-- clear text division 3 LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) C---- Ready the deck parameters IXEXDEC = 0 LEXD = 0 IF (JDKTYP.EQ.3) GO TO 46 LINE(1:68) = ' ' LINE(43:46) = '. d=' C- ' <<< pname nnnnnn . d= C- '_:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: 4_:.=+=.: 5_:.=+= C- ' nnnnnn . d=dname C- ' F=fname ---- nnnnnn . title JSLF = IQ(LQHOLD+1) IF (JDKTYP.EQ.1) GO TO 42 +SEQ, QEJECT. C-- deck header is +PATCH, name JCCTYP = MCCPAT CALL CCKRAK (JSLF) IXEXPAT = MCCPAR(JCCPP+1) IF (IXEXPAT.EQ.0) IXEXPAT= 1 JD_DTN = 0 IF (JCCBAD.EQ.0) CALL CCDOPT (1, JD_DTN) IF (JD_DTN.EQ.0) JD_DTN= 1 JD_DTP = JD_DTN LASMT = LQ(LHASM-JD_DTN) IQ(LASMT+8) = IQ(LASMT+8) + 1 CALL INDCRP (IXEXPAT,0) IF (MOPTIO(17).NE.0) GO TO 48 CALL NA_GET (IXEXPAT, LINE,3) CALL CRIGHT (LINE,3,34) N = 46 IF (MOPTIO(2).NE.0) GO TO 43 IF (NCHCCT.LE.NCHCCD) GO TO 43 CALL CCCOMG (1) IF (NCHCCC.EQ.0) GO TO 43 JP = N + 13 N = MIN (JP+NCHCCC, 110) NN = N - JP LINE(JP+1:JP+NN) = CCCOMF(1:NN) GO TO 43 C-- deck header is +DECK, name 42 JCCTYP = MCCDEC CALL CCKRAK (JSLF) IXEXDEC = MCCPAR(JCCPD+1) IF (IXEXDEC.EQ.0) IXEXDEC= 1 JD_DTN = 0 IF (JCCBAD.EQ.0) CALL CCDOPT (1, JD_DTN) IF (JD_DTN.EQ.0) JD_DTN= JD_DTP LASMT = LQ(LHASM-JD_DTN) IQ(LASMT+8) = IQ(LASMT+8) + 1 CALL INDCRD IF (MOPTIO(16).NE.0) GO TO 48 CALL NA_GET (IXEXDEC, LINE,47) N = NESLAT - 1 IF (MOPTIO(2).NE.0) GO TO 43 IF (NCHCCT.LE.NCHCCD) GO TO 43 CALL CCCOMG (1) IF (NCHCCC.EQ.0) GO TO 43 JP = MAX (N+1, 46+16) N = MIN (JP+NCHCCC, 110) NN = N - JP LINE(JP+1:JP+NN) = CCCOMF(1:NN) 43 CALL CSETDI (NQDKNO, LINE,36,41) WRITE (IQPRNT,9043) LINE(1:N) 9043 FORMAT (A) NQUSED = NQUSED + 1 GO TO 48 C-- deck header is +TITLE or start of PAM 46 JD_DTP = 1 CALL INDCRP (IXEXPAT,0) LINE(1:46) = ' F= ---- . ' C- ' F=fname ---- nnnnnn . title C- '_:.=+=.: 1_:.=+=.: 2_:.=+=.: 3_:.=+=.: 4_:.=+=.: 5_:.=+= JSLTTL = IQ(LARRV+10) CALL LN_GET (JSLTTL, LINETT, 60) NTTL = NDSLAT IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9046) LINETT(1:NTTL) 9046 FORMAT (' Read Pam file: ',A/) CALL CSETDI (NQDKNO, LINE,36,41) CALL NA_GET (IXEXPAM, LINE,4) N = NTTL + 46 IF (MOPTIO(17).EQ.0) THEN WRITE (IQPRNT,9047) LINE(1:N) ELSE WRITE (IQPRNT,9048) LINE(1:N) ENDIF NQUSED = NQUSED + 3 9047 FORMAT (/A/) 9048 FORMAT (/A) +SEQ, QEJECT. C------ Process the deck 48 IF (JDKNEX.EQ.0) CALL ARRIVE (2) IF (MOPTIO(24).NE.0) GO TO 88 C-- analyse the contents CALL DOMAPA (0) C-- process the contents CALL INDXQT C-- step to the next deck 88 CALL ARRNXD (1) NQDKNO = NQDKNO + 1 IFLGAR = 0 IF (JDKTYP.LT.3) GO TO 21 RETURN END +SEQ, QCARDL. ===================================================== +DECK, INDXQT. SUBROUTINE INDXQT C- Process the material according to the map for nyindex C. started 12-jan-94 +CDE, CCTYPE, CCPARA. +CDE, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT. LUPAN = 0 LDOAN = KQPREP + 1 C---- Next bank 21 LDOAN = LQ(LDOAN-1) IF (LDOAN.EQ.0) RETURN JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.LE.MCCNIL) GO TO 21 C-- Crack the c/line, register conditional patches CALL CCKRAK (IQ(LDOAN+1)) IF (JCCBAD.NE.0) GO TO 21 24 IF (NCCPIF.EQ.0) GO TO 31 IXCOND = MCCPAR(JCCPIF+1) CALL INDCRP (IXCOND,1) JCCPIF = JCCPIF + 3 NCCPIF = NCCPIF - 1 GO TO 24 C-- Sequence definition, register name 31 IF (JCCTYP.NE.MCCKEE) GO TO 21 IF (MOPTIO(26).NE.0) GO TO 21 IXSEQ = MCCPAR(JCCPZ+1) CALL INDCRZ (IXSEQ) GO TO 21 END +SEQ, QCARDL. ===================================================== +DECK, INDCRP. SUBROUTINE INDCRP (IXNAME,MODE) C- Register patch name IXNAME for nyindex, C- MODE = 0 this is the name of the current patch just starting C- 1 patch name quoted in IF= C. started 17-jan-94 +CDE, QBITS19, QBANKS, QPAGE. +CDE, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_OR. LPAT = LQFIND (IXNAME,2,LQUSER) IF (MODE.EQ.0) GO TO 21 IF (LPAT.EQ.0) GO TO 24 GO TO 27 C-- start of patch 21 IF (LPAT.EQ.0) GO TO 24 IF (IQ(LPAT+1).GE.0) GO TO 24 22 LEXP = LPAT IQ(LEXP+1) = NQDKNO RETURN C-- lift the PAT bank 24 CALL MQLIFT (LPAT, LQUSER(1),1, JBKPAT,3) IQ(LPAT+2) = IXNAME IF (MODE.EQ.0) GO TO 22 IQ(LPAT+1) = -1 C-- mark patch-name used in IF= 27 IQ(LPAT) = IOR (IQ(LPAT),KM6) RETURN END +SEQ, QCARDL. ===================================================== +DECK, INDCRD. SUBROUTINE INDCRD C- Register current deck name for nyindex C. started 17-jan-94 +CDE, CHEXC, QBANKS, QPAGE. +CDE, Q, PY. C-------------- End CDE -------------------------------- CALL MQLIFT (LEXD, LQUSER(2),1, JBKDEC,3) IQ(LEXD+1) = IXEXDEC IQ(LEXD+2) = IXEXPAT IQ(LEXD+3) = NQDKNO RETURN END +SEQ, QCARDL. ===================================================== +DECK, INDCRZ, T=JOIN. SUBROUTINE INDCRZ (IXNAME) C- Register sequence name IXNAME for nyindex C. started 17-jan-94 +CDE, QBANKS. +CDE, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_OR. CALL MQLIFT (LKEE, LQKEEP,1, JBKKEE,3) IQ(LKEE+1) = IXNAME IF (LEXD.NE.0) THEN LQ(LKEE-2) = LEXD RETURN ENDIF LQ(LKEE-2) = LEXP IQ(LKEE) = IOR (IQ(LKEE),1) RETURN END +SEQ, QCARDL. ===================================================== +PATCH, YLIST. for program Nylist +DECK, NLIST. PROGRAM NLIST +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=3) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'PAM .car 9 2 0 !ff' +, 'opt 3 11 0 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist +SELF, IF=QS_IBMVM. NAME(3)(9:16) = '.listing' +SELF. CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nylist Help, Eject, Start, 0->4 pg size') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXLIST +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXLIST. SUBROUTINE EXLIST C- Run nylist C. started 12-jan-94 +CDE, SLATE, SLATLN, QBITA19, QPAGE, QUNIT. +CDE, LUNSLN. +CDE, Q, PY. C-------------- End CDE -------------------------------- PARAMETER (MASK= KMH + KME + KMS) CALL INIAUX (LASTWK) CALL KROPT (IXLUN(2),MASK) CALL PGSIZE (0, IXLUN(2)) IF (MOPTIO(8).NE.0) GO TO 81 IF (MOPTIO(19).NE.0) THEN MOPTIO(19) = 0 ELSE MOPTIO(3) = 1 MOPTIO(5) = 0 ENDIF NQCMAX = 104 NQCPGH = 100 NQWYLDO = 7 CALL INIPAM (11, IXLUN(1), 1,0) NQJOIN = -1 C------ Load the title deck to memory ------------ 21 IF (JDKNEX.EQ.0) CALL ARRIVE (2) C---- Handle the PAM-file title line JDKTYP = 3 CALL KRTITL JSLTTL = IQ(LARRV+10) IF (NQDKNO.GE.2) THEN NQDKNO = ((NQDKNO-1)/100 + 1) *100 ELSE NQDKNO = 0 ENDIF CALL LN_GET (JSLTTL, SLLINE, 60) NTXT = NDSLAT IF (IQPRNT.NE.IQTYPE) WRITE (IQTYPE,9024) SLLINE(1:NTXT) 9024 FORMAT (' Read Pam file: ',A/) C------ Loop over all decks until next title CALL LIDECK IF (JDKTYP.EQ.3) GO TO 21 GO TO 89 +SEQ, QEJECT. C---- Help 81 WRITE (IQPRNT,9081) 89 CALL PGSIZE (1, 0) RETURN 9081 FORMAT (' nylist pam.car options print'/ F/' reads the "pam" file printing on "print" a numbered' F/' listing of the whole file. Line numbers both local to' F/' each deck and global in the file are shown. Page ejects' F/' can be controled with the option letters S and E, and' F/' also with T=JOIN given on any deck header line.'/ F/' "options": H help - print this help information only' F/' E eject - honor the pseudo sequence calls' F/' +SEQ, QEJECT, N=n.' F/' S start - start each deck on a new page,' F/' unless T=JOIN present' F/' 0 ... 4 - select page size by single digit option' F/' "n" - set page size to be n > 19') END +SEQ, QCARDL. ===================================================== +DECK, LIDECK. SUBROUTINE LIDECK C- List all decks until next +TITLE C. started 12-jan-94 +CDE, QBITS19, QPAGE. +CDE, CCTYPE, CCPARA, CHEXC, MUSEBC. +CDE, MQCM, Q, PY. C-------------- End CDE -------------------------------- C-- Check file starts with +PATCH or +DECK IF (JCCTYP.EQ.MCCDEC) JDKTYP= 1 IF (JCCTYP.EQ.MCCPAT) JDKTYP= 2 C-- set operation mode NVEXDK(1) = 0 NVEXDK(2) = 1 NVEXDK(5) = 1 NVEXDK(6) = 1 C-- set limits of control division 2 21 LQCSTA(2) = LQCEND(1) + 100 LQCEND(2) = LQCSTA(2) C-- clear text division 3 LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) +SEQ, QEJECT. C------ Ready the deck parameters NQNEWH = 7 IF (JDKTYP.EQ.1) GO TO 42 IXEXDEC = 0 IF (JDKTYP.EQ.2) GO TO 41 C-- deck header is +TITLE or start of PAM CALL DPHEAD NQJOIN = -1 GO TO 47 C-- deck header is +PATCH, name 41 JSLF = IQ(LQHOLD+1) JCCTYP = MCCPAT CALL CCKRAK (JSLF) IXEXPAT = MCCPAR(JCCPP+1) IF (IXEXPAT.EQ.0) IXEXPAT= 1 IXEXID = IXEXPAT GO TO 44 C-- deck header is +DECK, name 42 JSLF = IQ(LQHOLD+1) JCCTYP = MCCDEC CALL CCKRAK (JSLF) IXEXDEC = MCCPAR(JCCPD+1) IF (IXEXDEC.EQ.0) IXEXDEC= 1 IXEXID = IXEXDEC 44 CALL CCJOIN C------ Process the deck 47 LEXD = 0 NSLORG = 0 IF (JDKNEX.EQ.0) CALL ARRIVE (2) C-- analyse the contents CALL DOMAPA (0) C-- process the contents CALL LIXQT C-- step to the next deck 88 CALL ARRNXD (1) NQDKNO = NQDKNO + 1 IFLGAR = 0 IF (JDKTYP.LT.3) GO TO 21 RETURN END +SEQ, QCARDL. ===================================================== +DECK, LIXQT. SUBROUTINE LIXQT C- List the material according to the map C. started 12-jan-94 +CDE, QBITS31, QUNIT, CCTYPE, CCPARA. +CDE, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT, Q_OR. IXPL = -7 LEVIF = 0 LUPAN = 0 LDOAN = KQPREP + 1 C---- Next bank 20 MODEAN = 0 LDOAN = LQ(LDOAN-1) 22 IF (LDOAN.EQ.0) GO TO 87 +SEQ, QEJECT. C-- MODEAN = 0 self material C- 1 CDE expansion C- 2 comment line C- 3 +SELF header line C- 4 +CDE call line C- 5 foreign material C- 6 control line JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.GE.MCCDEL) GO TO 51 C---------- Self material ---------------- IF (JCCTYP.EQ.0) GO TO 39 IF (JCCTYP.EQ.MCCNIL) GO TO 38 IF (JCCTYP.LE.MCCINC) GO TO 71 IF (JCCTYP.LE.MCCXSQ) GO TO 36 IF (JCCTYP.LT.MCCSEL) GO TO 32 IXPL = -7 IF (JCCTYP.EQ.MCCKEE) GO TO 57 C-- to here +SELF, +SKIP and fault MODEAN = 3 GO TO 39 C-- to here +_IF etc 32 IF (JCCTYP.GE.MCCELS) GO TO 34 IF (LEVIF.EQ.0) IQ(LDOAN)= IOR (IQ(LDOAN), KM17) LEVIF = LEVIF + 1 GO TO 39 34 IF (JCCTYP.EQ.MCCELS) GO TO 39 LEVIF = MAX (LEVIF-1, 0) IF (LEVIF.EQ.0) IQ(LDOAN)= IOR (IQ(LDOAN), KM17) GO TO 39 C-- sequence call 36 MODEAN = 4 CALL DPLIST (MODEAN,LDOAN,LUPAN,0) IF (MOPTIO(5).NE.0) CALL XEJECT GO TO 20 C-- comment line 38 MODEAN = 2 39 CALL DPLIST (MODEAN,LDOAN,LUPAN,1) GO TO 20 C---------- Foreign material -------------- 51 IF (JCCTYP.GE.MCCUSE) GO TO 71 CALL CCKRAK (IQ(LDOAN+1)) IXP = MCCPAR(JCCPP+1) IXD = MCCPAR(JCCPD+1) IF (IXP.EQ.0) GO TO 52 IF (IXP.EQ.IXPL .AND. IXD.EQ.IXDL) GO TO 56 IXPL = IXP IXDL = IXD GO TO 57 C-- implied target 52 IF (IXPL.LT.0) GO TO 57 IF (MCCPAR(JCCPD+2).LT.0) GO TO 56 IF (IXD.EQ.IXDL) GO TO 56 IXDL = IXD GO TO 57 C-- same action target as previous 56 IQ(LDOAN) = IOR (IQ(LDOAN), KM18) 57 MODEAN = 5 CALL DPLIST (MODEAN,LDOAN,LUPAN,1) 58 LDOAN = LQ(LDOAN-1) IF (LDOAN.EQ.0) GO TO 87 JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.GE.MCCSEL) GO TO 59 CALL DPLIST (MODEAN,LDOAN,LUPAN,0) GO TO 58 59 MODEAN = 0 GO TO 22 C---------- Control line --------------- 71 MODEAN = 6 CALL DPLIST (MODEAN,LDOAN,LUPAN,1) IF (JCCTYP.GE.MCCPAT) NQLPAT = NQUSED GO TO 20 C---- Done 87 CONTINUE RETURN END +SEQ, QCARDL. ===================================================== +PATCH, YSYNOPT. for program Nysynopt +DECK, NSYNOPT. PROGRAM NSYNOPT +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=4) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'PAM .car 9 2 0 !ff' +, 'opt 3 11 0 !ff' +, 'read .cra 1 1 2 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist +SELF, IF=QS_IBMVM. NAME(4)(9:16) = '.listing' +SELF. CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nysynopt Help,Eject,Start, Individual,Missing,' // + ' Xact,Ycde,Zseq,0->4 pg size') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXSYNOPT +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXSYNOPT. SUBROUTINE EXSYNOPT C- Run nysynopt C. started 18-july-95 +CDE, QBITA31, QBANKS, QPAGE, QUNIT. +CDE, LUNSLN, MUSEBC, Q, PY. C-------------- End CDE -------------------------------- PARAMETER (MASK= KMH + KME + KMS + KMI + KMM + KMX + KMY + KMZ) DIMENSION MMKEEP(4) DATA MMKEEP / 1, 4, 2, 4 / CALL INIAUX (LASTWK) NQUSED = 12 CALL KROPT (IXLUN(2),MASK) CALL PGSIZE (0, IXLUN(2)) IF (MOPTIO(8).NE.0) GO TO 81 IF (MOPTIO(19).NE.0) THEN MOPTIO(19) = 0 ELSE MOPTIO(3) = 1 MOPTIO(5) = 0 ENDIF MOPTIO(6) = 1 CALL PKBYT (MOPTIO(1),MOPTIO(33),1,32,0) NQCPGH = 120 CALL UCOPY (MMKEEP, MMBANK(2,JBKKEE), 4) C-- set MOPUPD such that all IF's are true in CCPROC MOPUPD = -1 C-- Get the cradle into memory INCRAD = 3 IF (IQREAD.NE.0) CALL ARRIVE (0) C-- Complete the initialization CALL PINIT2 MU_GLOB = MU_GLOB + KM5 CALL SBIT0 (MU_GLOB,6) C-- Do the cradle initially CALL SYCRAD IF (JANSW.NE.0) GO TO 89 C-- Do next PAM file 41 INCRAD = 0 CALL SYPAM C-- Do cradle continuation INCRAD = 2 CALL SYCRAD IF (JANSW.EQ.0) GO TO 41 GO TO 89 C---- Help 81 WRITE (IQPRNT,9081) 89 CALL PGSIZE (1, 0) RETURN 9081 FORMAT (' nysynopt pam.car options read.cra print'/ F/' reads the "pam" file printing on "print" a numbered' F/' listing of the whole file, much like Nylist, but normally' F/' with sequence-calls expanded and actions signalled.' F/' The operation can be controlled in some detail by giving' F/' a cradle; if this is not needed "EOF" should be' F/' given for "read".'/ F/' "options": H help - print this help information only' F/' S start - start each deck on a new page,' F/' unless T=JOIN present' F/' E eject - honour the pseudo sequence calls' F/' +SEQ, QEJECT, N=n.' F/' M missing sequences to be signalled' F/' I line numbers separate for individual PAM files' F/' X do not signal actions' F/' Y do not expand +CDE calls' F/' Z do not expand +SEQ calls' F/' 0 ... 4 - select page size by single digit option' F/' "n" - set page size to be n > 19') END +SEQ, QCARDL. ===================================================== +DECK, SYCRAD. SUBROUTINE SYCRAD C- Process the cradle C. started 18-july-95 +CDE, QBITS19, QBANKS, QPAGE, QUNIT. +CDE, CCTYPE, CCPARA, CHEXC, MUSEBC, TAGC. +CDE, MQCM, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- PARAMETER (IXCRA=2) CHARACTER MARK*4, LINE*8 EQUIVALENCE (LINE,TEXT) +SEQ, Q_OR, Q_JBYT. LARRV = LACRAD NDKSAV = NQDKNO NQDKNO = 0 NSLORG = 1 IXEXPAM = 0 NCHTAG = 0 NQWYLDO = 0 NVEXDK(2) = 1 NVEXDK(6) = 1 CALL DPBLAN (0) IF (INCRAD.NE.3) GO TO 21 IF (IQREAD.NE.0) GO TO 27 C---- Run in no-cradle mode MU_GLOB = IOR (MU_GLOB, KM2) LINE = '+PAM. ' MLIAD(2) = 7 JCCTYP = MCCPAM CALL CCKRAK (1) CALL DOAPAM GO TO 77 +SEQ, QEJECT. C------ Restart the cradle after having read a PAM file 21 IF (IQREAD.EQ.0) GO TO 79 CALL VZERO (IQ(LQHOLD+1),3) CALL ARRIVE (1) C-- lift PAT bank for P=CRA* CALL CREAPD (IXCRA,-1,1) LPCRA = LEXP LEXD = 0 IXEXPAT = IXCRA IXEXDEC = IXCRA IXEXID = IXCRA LDECO = 0 NQNEWH = 1 NQJOIN = 1 NSLORG = 1 INCRAD = 2 27 IF (JDKTYP.GE.6) GO TO 79 IF (JDKTYP.GE.4) GO TO 72 C-------- Do next deck 29 JDKTYP = 1 IF (JDKNEX.EQ.0) CALL ARRIVE (2) CALL DOMAPA (0) JSLORG = JSLZER - NSLORG NSLHAV = IQ(LQHOLD+3) LUPAN = 0 LDOAN = KQPREP + 1 KKM5AN = 0 C---- Next PREP bank 31 LDOAN = LQ(LDOAN-1) IF (LDOAN.EQ.0) GO TO 39 C-- MODEAN = 0 self material C- 1 CDE expansion C- 2 comment line C- 3 +SELF header line C- 4 +CDE call line C- 5 foreign material C- 6 control line JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.LT.MCCKEE) GO TO 33 IF (JCCTYP.EQ.MCCKEE) GO TO 34 IF (JCCTYP.EQ.MCCUSE) GO TO 34 IF (JCCTYP.EQ.MCCLIS) GO TO 34 IF (JCCTYP.LT.MCCFOR) GO TO 33 IF (JCCTYP.LE.MCCOP2) GO TO 34 C---- list no-action lines 33 JCCTYP = 0 CALL DPLIST (0,LDOAN,LUPAN,0) GO TO 31 C---- Nysynopt cradle actions 34 CALL CCKRAK (IQ(LDOAN+1)) C-- Do : +KEEP IF (JCCTYP.EQ.MCCKEE) THEN CALL SYKEEP GO TO 38 ENDIF C-- Do : +USE +LIST +FORCE +SUSPEND 36 IF (JCCTYP.LE.MCCSUS) THEN CALL X_USE GO TO 38 ENDIF C-- Do : +OPTION +PARAMETER +SHOW IF (JCCTYP.LE.MCCSHO) THEN CALL X_OPT GO TO 38 ENDIF +SELF, IF=QDEBUG. CALL P_CRASH ('SYCRAD should not reach this point') +SELF. 38 CALL DPLIST (6,LDOAN,LUPAN,1) GO TO 31 C---- step to the next deck 39 INCRAD = 1 CALL ARRNXD (1) IF (JDKTYP.GE.6) GO TO 79 NSLORG = NSLORG + NSLHAV IF (JDKTYP.LE.3) GO TO 29 +SEQ, QEJECT. C------ Handle +PAM or +QUIT 72 JSLCRA = IQ(LQHOLD+1) NSLCRA = IQ(LQHOLD+2) JTXCRA = MLIAD(JSLCRA) NTX = MLIAD(JSLCRA+1) - JTXCRA - NCHNEWL JCCTYP = JPTYPE (TEXT(JTXCRA)) MARK = ' + ' CALL CCKRAK (JSLCRA) IF (JCCBAD.NE.0) MARK = ' *! ' C-- print the c/line CALL DPLINE (NSLORG,MARK,NTX,TEXT(JTXCRA)) C-- exit if faulty c/line IF (JCCBAD.NE.0) GO TO 91 C------ Accepted control line +PAM or +QUIT IF (JCCTYP.EQ.MCCQUI) GO TO 79 NSLORG = 0 C-- Digest the +PAM parameters to bank at LPAM CALL DOAPAM IF (JCCBAD.NE.0) GO TO 91 C-- Save cradle material after +PAM, ... JSLCRA = JSLCRA + 1 NSLCRA = NSLCRA - 1 IF (NSLCRA.EQ.0) GO TO 77 CALL MQLIFT (LASAV, LACRAD,-2, JBKASA,1) IQ(LASAV+1) = JSLCRA IQ(LASAV+2) = NSLCRA 77 IQ(LQHOLD+2) = 0 IQ(LPAM+14) = IQ(LPAM+14) + 1 NQDKNO = NDKSAV JANSW = 0 RETURN C-- +QUIT or EOF reached 79 JANSW = 1 RETURN C---- Trouble 91 IF (JCCTYP.EQ.MCCQUI) GO TO 79 CALL P_FATAL ('faulty line +PAM,...') END +SEQ, QCARDL. ===================================================== +DECK, SYPAM. SUBROUTINE SYPAM C- Process the next multi-PAM file C. started 18-july-95 +CDE, SLATE, SLATLN. +CDE, QBITS19, QBANKS, QPAGE, QUNIT. +CDE, ARRCOM, CCTYPE, CCPARA, CHEXC, MUSEBC, TITLEC. +CDE, MQCM, KQADR, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. +SEQ, bkPAM, IF=DOC_INL. +SEQ, bkARRV, IF=DOC_INL. CALL DOPAMCO MOPUPD = -1 IFLMERG = 1 JDKSUB = 0 MXFOSV = MX_FORC MOPT = IQ(LPAM+6) IFLATT = IAND (MOPT,KM1) IFLHOL = IAND (MOPT,KM2) IFLLIS = IAND (MOPT,KM7) IFLSEP = IAND (MOPT,KM8) IF (IFLLIS.NE.0) MX_FORC = IOR (MX_FORC, KM16) NQWYLDO = 7 NHOLD = IQ(LARRV+9) IF (NHOLD.EQ.0) GO TO 31 C---- Resume input of the PAM file stopped by RETURN=pname IQ(LARRV+9) = 0 CALL ARRIVE (1) JSLTTL = IQ(LARRV+10) IXEXPAM = IQ(LARRV+11) IF (IQ(LPAM+4).GT.0) GO TO 42 NCENT = NQDKNO / 100 NNUM = MOD (NHOLD,100) NNEW = 100*NCENT + NNUM IF (NNEW.LT.NQDKNO) NNEW= NNEW + 100 NQDKNO = NNEW NQWYL = IQ(LARRV+5) JDKTYP = 2 GO TO 42 C------ Load the title deck to memory ------------ 31 IF (JDKNEX.EQ.0) CALL ARRIVE (2) IF (IFLATT+IFLSEP+MOPTIO(9).NE.0) NQWYL= 0 C---- Handle the PAM-file title CALL KRTITL JDKSUB = 0 IF (JCCTYP.EQ.MCCDEC) JDKSUB= 1 IF (JCCTYP.EQ.MCCPAT) JDKSUB= 2 JDKTYP = 3 JSLTTL = IQ(LARRV+10) IQ(LPAM+13) = IQ(LPAM+13) + 1 IF (IQ(LPAM+4).GT.0) GO TO 42 IF (NQDKNO.GE.2) THEN NQDKNO = ((NQDKNO-1)/100 + 1) *100 ELSE NQDKNO = 0 ENDIF C-- create RPAM bank 42 CALL QSHUNT (KQMAIN,KQPAST) CALL MQLIFT (LRPAM, LEXP,1, JBKRPA,3) IQ(LRPAM+1) = JSLTTL IQ(LRPAM+2) = -IXEXPAM IQ(LRPAM+3) = NQDKNO C-- PAM file to be read, not skipped IF (IQ(LPAM+4).GT.0) GO TO 71 IF (JDKTYP.EQ.3) THEN IF (NFILET.LT.NFIMAX) NFILET= NFILET + 1 JTIPAM(NFILET) = JSLTTL ENDIF +SEQ, QEJECT. C------ DO all patches IF (JDKSUB.NE.0) JDKTYP= JDKSUB JDKSUB = 0 CALL SYPAT IF (JDKTYP.EQ.6) GO TO 81 IF (JDKTYP.EQ.2) GO TO 61 C---- +TITLE seen, do next PAM file IQ(LPAM+5) = IQ(LPAM+5) - 1 IF (IQ(LPAM+5).LE.0) GO TO 62 GO TO 31 C---- Stop input from PAM C- for RETURN=name reached C- for number of PAM files to be done exhausted 61 IQ(LARRV+9)= NQDKNO 62 JSLSAV = IQ(LQHOLD+1) NSLSAV = IQ(LQHOLD+2) IF (IFLHOL.EQ.0) THEN LQLEND(2) = JSLSAV LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) GO TO 82 ENDIF IF (NSLSAV.EQ.0) GO TO 88 +SELF, IF=QCIO. IF (IQ(LARRV+7).GT.0) THEN IN_DOX = 1 IN_DO1 = JSLSAV CALL ARRIN GO TO 88 ENDIF +SELF. CALL MQLIFT (LASAV,LARRV,-2,JBKASA,1) IQ(LASAV+1) = JSLSAV IQ(LASAV+2) = NSLSAV GO TO 88 C------ Skip the PAM file 71 IQ(LPAM+4) = IQ(LPAM+4) - 1 IQ(LPAM+5) = 0 IQ(LRPAM+4) = -1 NQWYL = 0 CALL LN_GET (JSLTTL, SLLINE, 60) NTXT = NDSLAT CALL DPBLAN (0) WRITE (IQPRNT,9072) SLLINE(1:NTXT) NQUSED = NQUSED + 2 9072 FORMAT (' Skip Pam file: ',A/) JDKTYP = 3 CALL ARRSKP IF (JDKTYP.LT.6) GO TO 31 C------ End of multi-PAM reached 81 CONTINUE C-- Detach or Rewind 82 IF (IFLHOL.EQ.0) THEN IN_DOX = -1 ELSE IN_DOX = 0 ENDIF CALL ARRIN 88 IQ(LQHOLD+2) = 0 IQ(LPAM+12) = IQ(LPAM+12) + IQ(LARRV+12) IQ(LARRV+5) = NQWYL IQ(LARRV+12) = 0 MX_FORC = MXFOSV RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYPAT. SUBROUTINE SYPAT C- Process all patches of the current PAM file C. started 18-july-95 +CDE, QBITS19, QPAGE. +CDE, CCTYPE, CCPARA, CHEXC, MUSEBC, TAGC. +CDE, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_AND. IF (JDKTYP.EQ.3) GO TO 27 IF (JDKTYP.EQ.1) GO TO 26 C-- get the patch name 21 JSLF = IQ(LQHOLD+1) JCCTYP = MCCPAT CALL CCKRAK (JSLF) IXEXPAT = MCCPAR(JCCPP+1) IF (IXEXPAT.NE.0) GO TO 27 26 IXEXPAT= 1 C-- find/create the patch bank 27 CALL CREAPD (IXEXPAT,-1,7) IXEXID = IXEXPAT CALL SBYT (NQDKNO, IQ(LEXP+1),13,20) MU_PAT = IAND (IQ(LEXP),KM19-1) IXEXDEC = 0 C-- Check enough space 31 IFLGAR = 0 CALL SETGAP IF (JDKNEX.EQ.0) CALL ARRIVE (2) NQNEWH = 7 NCHTAG = 0 LDECO = 0 +SEQ, QEJECT. C------ Ready the deck parameters IF (JDKTYP.NE.1) GO TO 37 C---- Deck header is +DECK, name JSLF = IQ(LQHOLD+1) JCCTYP = MCCDEC CALL CCKRAK (JSLF) C-- get the name IXEXDEC = MCCPAR(JCCPD+1) IF (IXEXDEC.EQ.0) IXEXDEC= 1 IXEXID = IXEXDEC C-- find the deck bank, set operation mode 37 LEXD = KQFIND (IXEXDEC,1, LEXP-2,KEXD) IF (LEXD.NE.0) THEN MU_DECK = IAND (IQ(LEXD),KM19-1) ELSE MU_DECK = MU_PAT ENDIF NSLHAV = IQ(LQHOLD+3) IF (IAND(MU_DECK,KM5).EQ.0) GO TO 71 CALL MXOPER (0) C-- start of PAM IF (JDKTYP.NE.3) GO TO 44 NVEXDK(2) = 1 IF (NQJOIN.GT.0) NQJOIN = 0 IF (NQPAGE.LT.2) NQJOIN = 1 CALL DPHEAD NQJOIN = -1 GO TO 51 C-- start of patch or deck 44 IF (NVEXDK(2).EQ.0) GO TO 51 CALL CCJOIN C------ Process the deck 51 NSLORG = 0 NCHTAG = 0 LLORG = 0 LLACT = 0 LMODE = 0 C-- ready the foreign material into this deck CALL ACSORT C-- analyse the contents CALL DOMAPA (7) C-- process the contents CALL SYXQT C------ Processing complete C-- send the DECK bank to garbage collection IF (LEXD.NE.0) THEN L = KQFIND (IXEXDEC,1, LEXP-2, KEXD) IF (L.NE.0) THEN CALL TOGARB (KEXD,0) ENDIF ENDIF IF (NVEXDK(2).NE.0) GO TO 72 C---- Deck not listed, step the Wylbur line number 71 NQWYL = NQWYL + NSLHAV C-- step to the next deck 72 NQDKNO = NQDKNO + 1 CALL ARRNXD (1) IF (JDKTYP.EQ.1) GO TO 31 IF (IAND(IQ(LEXP+1),KM5).EQ.0) THEN IF (LQ(LEXP-2).NE.0) CALL TOGARB (LEXP-2,7) IF (LQ(LEXP-3).NE.0) CALL TOGARB (LEXP-3,7) ENDIF IF (JDKTYP.GE.3) RETURN C-- check stop for RETURN=pname IF (IXEXPAT.NE.IQ(LPAM+7)) GO TO 21 RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYXQT. SUBROUTINE SYXQT C- List the material of the current deck according to the map C. started 18-july-95 +CDE, QBITA19, QUNIT, CCTYPE, CCPARA, MUSEBC. +CDE, MQCM, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT, Q_AND, Q_OR. +SEQ, QEJECT. IXPL = -1 LEVIF = 0 LUPAN = 0 LDOAN = KQPREP + 1 C---- Next bank 20 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) 22 MODEAN = 0 IF (LDOAN.EQ.0) GO TO 87 IF (LQ(LDOAN-2).EQ.0) GO TO 24 C-- print action into here 23 IF (NVEXDK(2).NE.0) CALL SYFORG (-7,0) IF (MODEAN.EQ.5) GO TO 58 GO TO 20 C-- MODEAN = 0 self material C- 1 CDE expansion C- 2 comment line C- 3 +SELF header line C- 4 +CDE call line C- 5 foreign material C- 6 control line 24 JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.GE.MCCKEE) GO TO 51 C---------- Self material ---------------- IF (NVEXDK(2).EQ.0) GO TO 20 IF (JCCTYP.EQ.0) GO TO 39 IF (JCCTYP.EQ.MCCNIL) GO TO 38 IF (JCCTYP.LE.MCCINC) GO TO 71 IF (JCCTYP.LE.MCCXSQ) GO TO 35 IF (JCCTYP.LT.MCCSEL) GO TO 32 IXPL = -1 LEVIF = 0 C-- to here +SELF, +SKIP and fault MODEAN = 3 IF (JCCTYP.NE.MCCSES) GO TO 28 IF (MOPTIO(26).NE.0) GO TO 28 CALL CCKRAK (IQ(LDOAN+1)) IF (IQ(LDOAN+2).GE.2) L = M_SPLIT (LDOAN, IQ(LDOAN+1)+1) CALL DPLIST (MODEAN,LDOAN,LUPAN,1) GO TO 37 28 CALL DPLIST (MODEAN,LDOAN,LUPAN,1) GO TO 20 C-- to here +_IF etc 32 IF (JCCTYP.GE.MCCELS) GO TO 34 IF (LEVIF.EQ.0) IQ(LDOAN)= IOR (IQ(LDOAN), KM17) LEVIF = LEVIF + 1 GO TO 39 34 IF (JCCTYP.EQ.MCCELS) GO TO 39 IF (LEVIF.EQ.1) IQ(LDOAN)= IOR (IQ(LDOAN), KM17) LEVIF = MAX (LEVIF-1, 0) GO TO 39 C-- sequence call 35 MODEAN = 4 CALL DPLIST (MODEAN,LDOAN,LUPAN,0) IF (JCCTYP.EQ.MCCCDE) THEN IF (MOPTIO(25).EQ.0) GO TO 36 ELSE IF (MOPTIO(26).EQ.0) GO TO 36 ENDIF IF (MOPTIO(5).NE.0) CALL XEJECT GO TO 20 36 CALL CCKRAK (IQ(LDOAN+1)) IF (NCCPZ.EQ.0) GO TO 20 IF (IAND(MCCPAR(JCCPT+1),KMD).NE.0) GO TO 20 37 CALL SYSEQ GO TO 20 C-- comment line 38 MODEAN = 2 39 CALL DPLIST (MODEAN,LDOAN,LUPAN,1) GO TO 20 +SEQ, QEJECT. C---------- Foreign material -------------- 51 LEVIF = 0 IF (JCCTYP.GE.MCCUSE) GO TO 71 CALL CCKRAK (IQ(LDOAN+1)) IF (JCCTYP.EQ.MCCKEE) GO TO 56 IXP = MCCPAR(JCCPP+1) IXD = MCCPAR(JCCPD+1) IF (IXP.EQ.0) GO TO 52 IF (IXP.EQ.IXPL .AND. IXD.EQ.IXDL) GO TO 53 IXPL = IXP IXDL = IXD GO TO 54 C-- implied target 52 IF (IXPL.LT.0) GO TO 54 IF (MCCPAR(JCCPD+2).LT.0) GO TO 53 IF (IXD.EQ.IXDL) GO TO 53 IXDL = IXD GO TO 54 C-- same action target as previous 53 IQ(LDOAN) = IOR (IQ(LDOAN), KM18) 54 CALL SYFORG (IXPL,IXDL) GO TO 57 C-- sequence definition 56 IXPL = -1 CALL SYKEEP 57 MODEAN = 5 IF (NVEXDK(2).NE.0) CALL DPLIST (MODEAN,LDOAN,LUPAN,1) 58 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) IF (LDOAN.EQ.0) GO TO 87 IF (LQ(LDOAN-2).NE.0) GO TO 23 JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.GE.MCCSEL) GO TO 22 IF (NVEXDK(2).NE.0) CALL DPLIST (MODEAN,LDOAN,LUPAN,0) GO TO 58 C---------- Control line --------------- 71 MODEAN = 6 IF (NVEXDK(2).EQ.0) GO TO 20 CALL DPLIST (MODEAN,LDOAN,LUPAN,1) IF (JCCTYP.LT.MCCPAT) GO TO 20 NQLPAT = NQUSED GO TO 20 C---- Done 87 LQCEND(2) = LQCSTA(2) RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYFORG. SUBROUTINE SYFORG (IXP,IXD) C- Remember actions +ADD etc C. started 18-july-95 +CDE, QBANKS, QPAGE. +CDE, CCTYPE, CCPARA, MUSEBC. +CDE, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_OR, Q_SHIFTL. IF (IXP.EQ.-7) GO TO 41 C---- Create ACT bank for new action going out IF (MOPTIO(24).NE.0) RETURN IF (JCCBAD.NE.0) GO TO 91 IF (IXP.LE.0) GO TO 91 CALL CREAPD (IXP, IXD, 0) IF (LCRD.EQ.0) GO TO 91 IF (LDECO.EQ.0) CALL CRDECO JSLCL = IQ(LDOAN+1) JACTU = ISHFTL (JCCTYP-MCCDEL,8) C-- lift the ACT bank 24 CALL MQLIFT (LACT,LCRD,-2,JBKACT,1) IQ(LACT) = IOR (IQ(LACT), JACTU) LQ(LACT-3) = LDECO C! IQ(LACT+1) = JSLCL C! IQ(LACT+2) = 1 IQ(LACT+3) = JSLCL - JSLORG IQ(LACT+4) = MCCPAR(JCCPC+1) IQ(LACT+5) = MCCPAR(JCCPC+2) IF (JCCTYP.NE.MCCDEL) RETURN C-- iterate if multiple +DEL JCCPC = JCCPC + 3 NCCPC = NCCPC - 1 IF (NCCPC.NE.0) GO TO 24 RETURN C---- List action into here 41 IF (NVEXDK(2).EQ.0) RETURN LOWAN = LDOAN LUPAN = LQ(LDOAN-2) NQWYLDO = 0 CALL DPLACT NQWYLDO = 7 LUPAN = 0 RETURN C---- Faulty action header line 91 CONTINUE RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYKEEP. SUBROUTINE SYKEEP C- Remember sequence definition C. started 18-july-95 +CDE, QBITA19, QBANKS, CCTYPE, CCPARA. +CDE, MQCM, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- PARAMETER (NOFFLI=2, NOFFDA=4) +SEQ, Q_JBYT, Q_AND, Q_OR, Q_SHIFTL. IF (JCCBAD.NE.0) GO TO 91 MOPT = MCCPAR(JCCPT+1) IXS = MCCPAR(JCCPZ+1) IF (LDECO.EQ.0) CALL CRDECO IF (INCRAD.EQ.0) GO TO 41 C-------- +KEEP in the cradle -------------------------- C-- check sequence existing CALL SYLKEEP (LACT) IF (LACT.NE.0) GO TO 39 KACT = IQUEST(1) CALL MQLIFT (LACT,KACT,0,JBKKEE,1) IQ(LACT-3) = LDECO IQ(LACT) = IOR (IQ(LACT), KM18) IQ(LACT+4) = IXS IF (IAND(MOPT,KMS).EQ.0) THEN IQ(LACT) = IOR (IQ(LACT), KM12) ELSE IQ(LACT) = IOR (IQ(LACT), KM14) ENDIF C-- no associated material for a +KEEP in the cradle 39 NSL = IQ(LDOAN+2) IF (NSL.GE.2) L = M_SPLIT (LDOAN, IQ(LDOAN+1)+1) RETURN +SEQ, QEJECT. C-------- +KEEP on the PAM file -------------------------- 41 IF (IAND(MOPT,KMD).NE.0) RETURN C-- check sequence existing CALL SYLKEEP (LACT) KACT = IQUEST(1) IF (LACT.EQ.0) GO TO 47 C-- check sequence is special or blocked from the cradle MACT = IQ(LACT) IF (IAND(MACT,KM12+KM13).NE.0) RETURN IF (IAND(MACT,KM14).EQ.0) GO TO 44 C-- sequence had been registered with T=SINGLE IF (IAND(MACT,KM15).NE.0) RETURN CALL TOGARB (KACT,0) IFLSING = 7 GO TO 48 C-- a new definition of an existing sequence 44 KACT = LACT - 4 LACT = LQ(KACT) IF (LACT.NE.0) GO TO 44 C-- create the heading KEEP bank 47 IFLSING = 0 48 CALL MQLIFT (LACT,KACT,0,JBKKEE,1) CALL SYSPLIT (LDOAN) IQ(LACT-3) = LDECO IQ(LACT) = IOR (IQ(LACT), KM7) IQ(LACT+1) = IQ(LDOAN+1) + 1 IQ(LACT+2) = IQ(LDOAN+2) - 1 IQ(LACT+3) = IQ(LACT+1) - JSLORG IQ(LACT+4) = IXS IF (IAND(MOPT,KMN).NE.0) IQ(LACT) = IOR (IQ(LACT), KM16) IF (IFLSING.NE.0) IQ(LACT) = IOR (IQ(LACT), KM14+KM15) C------ create MAT continuation banks for KEEP IFLSGL = KM5+KM6+KM17 IFLMSK = KM5+KM6 LAST = LACT IF (NCCPP.NE.0) IFLSGL= 0 KJOIN = LACT - 2 LDOTK = LDOAN 51 LDOTK = LQ(LDOTK-1) IF (LDOTK.EQ.0) GO TO 69 IF (LQ(LDOTK-2).NE.0) GO TO 51 JCCTYP = JBYT (IQ(LDOTK),9,6) IF (JCCTYP.GE.MCCSEL) GO TO 69 JSLNEW = IQ(LDOTK+1) NSLNEW = IQ(LDOTK+2) NUMNEW = JSLNEW - JSLORG IF (NSLNEW.EQ.0) GO TO 51 IF (JCCTYP.LT.MCCCDE) GO TO 62 IF (JCCTYP.GE.MCCXSQ) GO TO 61 C-- handle +CDE or +SEQ CALL CCKRAK (JSLNEW) C-- check +SEQ,..., T=DUMMY IF (IAND(MCCPAR(JCCPT+1),KMD).NE.0) GO TO 51 C---- try immediate substitution for +SEQ, single name IF (NCCPZ.NE.1) GO TO 54 IF (NCCPIF.NE.0) GO TO 54 IXC = MCCPAR(JCCPZ+1) CALL SYLSEQ (LSQF, IXC, 0,0) IF (LSQF.EQ.0) GO TO 54 IF (IAND(IQ(LSQF),KM17).EQ.0) GO TO 54 C-- do the substitution JSLNEW = IQ(LSQF+1) IF (JSLNEW.LT.LQLSTA(4)) THEN JSLNEW = LN_COP4 (JSLNEW,1) IQ(LSQF+1) = JSLNEW ENDIF JCCTYP = 0 C-- does the KEEP bank have zero lines? IF (LAST.NE.LACT) GO TO 62 IF (IQ(LACT+3).NE.NUMNEW) GO TO 62 IQ(LACT+1) = JSLNEW IQ(LACT+2) = 1 GO TO 51 +SEQ, QEJECT. C---- lift XSQ bank for +CDE or +SEQ 54 NCCPZ = MIN (NCCPZ,61) MMBANK(3,JBKXSQ) = NCCPZ + NOFFLI MMBANK(5,JBKXSQ) = NCCPZ + NOFFDA CALL MQLIFT (LMAT,KJOIN,0,JBKXSQ,1) IQ(LMAT) = IOR (IQ(LMAT), ISHFTL(JCCTYP,8)) IQ(LMAT) = IOR (IQ(LMAT), IAND(MCCPAR(JCCPT+1),KMP)) IQ(LMAT+NOFFDA) = NCCPZ CALL UCOCOP (MCCPAR(JCCPZ+1),IQ(LMAT+NOFFDA+1),NCCPZ,1,3,1) IFLMSK = 0 GO TO 63 C---- lift new MAT bank 61 IFLMSK = 0 62 CALL MQLIFT (LMAT,KJOIN,0,JBKMAT,1) IQ(LMAT) = IOR (IQ(LMAT), ISHFTL(JCCTYP,8)) 63 LQ(LMAT-2) = LDECO IQ(LMAT+1) = JSLNEW IQ(LMAT+2) = NSLNEW IQ(LMAT+3) = NUMNEW LAST = LMAT KJOIN = LMAT - 1 GO TO 51 C---- End of material for KEEP, finalize 69 IF (LQ(LACT-2).NE.0) IFLSGL= 0 IF (IQ(LACT+2).NE.1) IFLSGL= 0 IFLMSK = IOR (IFLMSK, IFLSGL) IQ(LACT) = IOR (IQ(LACT), IFLMSK) JCCTYP = MCCKEE RETURN C---- Faulty control line 91 CONTINUE RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYSEQ. SUBROUTINE SYSEQ C- Send the sequences called from bank LDOAN at KDOAN to output. C. started 24-aug-95 +CDE, QBITA19, QBANKS, QPAGE, CCTYPE, CCPARA, TAGC. +CDE, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- PARAMETER (NOFFLI=2, NOFFDA=4) PARAMETER (MAXLEV=36) COMMON /MSAVEC/ MSAVE(6,MAXLEV) +SEQ, Q_JBYT, Q_AND, Q_OR, Q_SHIFTL. LEVK = 0 LNACT = 0 LLACT = 0 NCHTAG = 0 KPC = LEXP - 3 KDC = 0 IF (LEXD.NE.0) KDC= LEXD - 3 NCCPZ = MIN (NCCPZ,61) MMBANK(3,JBKXSQ) = NCCPZ + NOFFLI MMBANK(5,JBKXSQ) = NCCPZ + NOFFDA CALL MQLIFT (LMAT,KDOAN,0,JBKXSQ,2) LQ(LMAT-1) = LQ(LDOAN-1) IQ(LMAT) = IOR (IQ(LMAT), ISHFTL(JCCTYP,8)) IQ(LMAT) = IOR (IQ(LMAT), IAND(MCCPAR(JCCPT+1),KMP)) IQ(LMAT+1) = IQ(LDOAN+1) IQ(LMAT+2) = IQ(LDOAN+2) IQ(LMAT+NOFFDA) = NCCPZ CALL UCOCOP (MCCPAR(JCCPZ+1),IQ(LMAT+NOFFDA+1),NCCPZ,1,3,1) LDOAN = LMAT LCSQ = LMAT C---- New XSQ bank 21 JSEQ = 0 NSEQ = IQ(LCSQ+NOFFDA) IFLPAS = IAND (IQ(LCSQ),KM16) 22 JSEQ = JSEQ + 1 IF (JSEQ.GT.NSEQ) GO TO 67 ITER = 0 NDONE = 0 IXSEQ = IQ(LCSQ+JSEQ+NOFFDA) LKEEP = LQ(LCSQ-JSEQ-NOFFLI) IF (LKEEP.NE.0) GO TO 41 CALL SYLSEQ (LKEEP, IXSEQ, 0,0) IF (LKEEP.EQ.0) GO TO 51 LQ(LCSQ-JSEQ-NOFFLI) = LKEEP +SEQ, QEJECT. C---- Start output of this sequence 41 IF (IAND(IQ(LKEEP),KM12+KM16).NE.0) GO TO 22 IFALTN = NDONE C-- ready special sequence IFSPEC = IAND(IQ(LKEEP),KM13) IF (IFSPEC.NE.0) THEN CALL X_SEQSP (IQ(LCSQ+1), IXSEQ, IFSEND) IF (IFSEND.EQ.0) GO TO 22 ENDIF NDONE = NDONE + 1 LLORG = 0 LNORG = LQ(LKEEP-3) CALL SYKTAG (LEVK,IXSEQ) C-- output of the start of the sequence expansion IF (IQ(LKEEP+2).NE.0) GO TO 44 IF (LQ(LKEEP-2).NE.0) GO TO 43 CALL SYKTAG (-1,0) GO TO 48 43 IFLST = LEVK+1 GO TO 45 44 CALL DPLIST (1,LKEEP,0,LEVK+1) IFLST = 0 C-- output of continuation MAT banks 45 LDO = LKEEP - 1 46 LDO = LQ(LDO-1) IF (LDO.EQ.0) GO TO 48 JCCTYP = JBYT (IQ(LDO),9,6) LNORG = LQ(LDO-2) CALL DPLIST (1,LDO,0,IFLST) IFLST = 0 IF (JCCTYP.GE.MCCCDE) GO TO 61 GO TO 46 C-- next sequence in multiple definition 48 IF (IFSPEC.NE.0) GO TO 22 LKEEP = LQ(LKEEP-4) IF (LKEEP.NE.0) GO TO 41 C-- do also patch/deck directed sequences 51 ITER = ITER + 1 IF (ITER.GE.3) GO TO 57 KP = KPC IF (ITER.EQ.1) THEN IF (LQ(KP).EQ.0) GO TO 51 KD = 0 ELSE IF (KDC.EQ.0) GO TO 57 IF (LQ(KDC).EQ.0) GO TO 57 KD = KDC ENDIF CALL SYLSEQ (LKEEP, IXSEQ, KP,KD) IF (LKEEP.NE.0) GO TO 41 GO TO 51 C-- missing sequence ? 57 IF (NDONE.NE.0) GO TO 22 IF (IFLPAS.NE.0) GO TO 22 IF (MOPTIO(13).EQ.0) GO TO 22 CALL DPLMSQ (IXSEQ) GO TO 22 C---- new sequence call bank, step level up by one 61 LEVK = LEVK + 1 MSAVE(1,LEVK) = LCSQ MSAVE(2,LEVK) = LDO MSAVE(3,LEVK) = JSEQ MSAVE(4,LEVK) = NDONE MSAVE(5,LEVK) = LKEEP MSAVE(6,LEVK) = ITER LCSQ = LDO GO TO 21 C---- end of doing this sequence call bank, step level down 67 IF (LEVK.EQ.0) GO TO 69 LCSQ = MSAVE(1,LEVK) LDO = MSAVE(2,LEVK) JSEQ = MSAVE(3,LEVK) NDONE = MSAVE(4,LEVK) LKEEP = MSAVE(5,LEVK) ITER = MSAVE(6,LEVK) LEVK = LEVK - 1 IFALTN = NDONE - 1 NSEQ = IQ(LCSQ+NOFFDA) IXSEQ = IQ(LCSQ+JSEQ+NOFFDA) IFLPAS = IAND (IQ(LCSQ),KM16) IFSPEC = 0 IFLST = 0 CALL SYKTAG (LEVK,0) GO TO 46 69 NCHTAG = 0 NQWYLDO = 7 RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYKTAG. SUBROUTINE SYKTAG (LEVEL,IXKEEP) C- Construct the next tail for sequence IXKEEP at level LEVEL C- if LEVEL < 0: simply print the pending tag C. started 24-aug-95 +CDE, SLATE, QBITS19, QCHAR, QPAGE, QUNIT. +CDE, TAGC, Q, PY. C-------------- End CDE -------------------------------- CHARACTER MASK*4, MASKK(4)*4 DATA MASKK / ' z ', ' .z ', ' y ', ' .y ' / +SEQ, Q_AND. LEV = LEVEL IF (NCHTAG.LE.0) GO TO 31 IF (LMODE.LT.2) GO TO 30 C-- Print pending tag CALL DPHEAD NQUSED = NQUSED + 1 NQLLBL = 0 JP = MIN (LMODE,3) - 1 IF (LALTN.NE.0) JP= JP + 2 MASK = MASKK(JP) NBL = NQCMAX - NCHTAG - 26 NBL = MIN (NBL,75) WRITE (IQPRNT,9024) CHWYL,MASK,CQBLAN(1:NBL),CHTAG(1:NCHTAG) 9024 FORMAT (A,A,'-void-',A,A) 30 NCHTAG = 0 31 IF (LEV.LT.0) RETURN CHWYL = ' ' IF (IXKEEP.EQ.0) GO TO 41 CHTAG(1:10) = ' ' C-- construct prefix NUMORG = IAND (IQ(LNORG), KM19-1) CALL CSETDI (NUMORG, CHWYL,2,5) CALL CLEFT (CHWYL,2,5) JP = NESLAT CHWYL(JP:JP) = '=' JP = JP + 1 IXORG = IQ(LNORG+1) IF (IXORG.EQ.0) IXORG = IQ(LNORG+2) CALL NA_GET (IXORG,CHWYL,JP) C-- construct tag IF (LEV.NE.0) THEN CALL CSETDI (LEV+1,CHTAG,1,2) JP = 4 ELSE JP = 1 ENDIF CALL NA_GET (IXKEEP,CHTAG,JP) NCHTAG = NESLAT - 1 LLORG = LNORG LALTN = IFALTN LMODE = 2 + LEV NQWYLDO = -1 RETURN C-- construct tag to signal continuation 41 CHTAG(1:12) = ' continued' CALL CSETDI (LEV+1,CHTAG,1,2) NCHTAG = 12 LLORG = 0 LALTN = IFALTN LMODE = -2 NQWYLDO = -3 RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYLKEEP. SUBROUTINE SYLKEEP (LSEQ) C- Find the KEEP bank for the sequence decribed by C- the current +KEEP control line; C- create target PAT/DECK banks if local sequence. C- return LSEQ L-adr of the sequence found, or LSEQ=0 C- IQUEST(1) K-adr of the seq found, if found C- else: K-adr for attachment at end C- IQUEST(2) zero: sequence is global C- -ve: sequence is local C- IQUEST(11) zero if global sequence C. started 29-aug-92 +CDE, QBITS19, CCPARA. +CDE, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_AND. IXS = MCCPAR(JCCPZ+1) CALL SYLSEQ (L, IXS, 0,0) IQUEST(11) = 0 IF (L.NE.0) GO TO 22 IF (NCCPP.EQ.0) GO TO 29 GO TO 23 C-- global sequence exist, check expansion restricted 22 IF (IAND(IQ(L),KM12+KM13).NE.0) GO TO 29 IF (NCCPP.EQ.0) GO TO 29 IF (IAND(IQ(L),KM14).NE.0) THEN IF (IAND(IQ(L),KM15).NE.0) GO TO 29 ENDIF 23 IXP = MCCPAR(JCCPP+1) IXD = MCCPAR(JCCPD+2) KD = 0 CALL CREAPD (IXP, IXD, 0) KP = LCRP - 3 IF (LCRD.NE.0) KD = LCRD - 3 24 CALL SYLSEQ (L, IXS, KP,KD) IQUEST(11) = 7 29 LSEQ = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYLSEQ. SUBROUTINE SYLSEQ (LSEQ, IXSEQ, KP,KD) C- Find KEEP bank for the sequence with the name index IXSEQ C- KP gives the patch-directed, KD the deck-directed sequences C- C- return LSEQ L-adr of the sequence found, or LSEQ = 0 C- IQUEST(1) K-adr of the seq found, if found C- else: K-adr for attachment at end C- C- if the sequence has been found, C- it is re-linked to the start of its structure C. started 29-aug-92 +CDE, KQADR, Q, PY. C-------------- End CDE -------------------------------- EQUIVALENCE (KSEQ,IQUEST(1)) PARAMETER (LOCID=4) C-- Global set IF (KP.NE.0) GO TO 23 KU = KQKEEP GO TO 29 C-- Patch-directed set 23 IF (KD.NE.0) GO TO 24 KU = KP GO TO 29 C-- Deck-directed set 24 KU = KD 29 L = KQFIND (IXSEQ,LOCID,KU,KSEQ) IF (L.NE.0) THEN IF (KSEQ.NE.KU) THEN LQ(KSEQ) = LQ(L-1) LQ(L-1) = LQ(KU) LQ(KU) = L KSEQ = KU ENDIF ENDIF LSEQ = L RETURN END +SEQ, QCARDL. ===================================================== +DECK, SYSPLIT. SUBROUTINE SYSPLIT (LTHIS) C- split on +CDE or +SEQ contained in a sequence definition C. started 24-aug-95 +CDE, CCTYPE, CCPARA, Q, PY. C-------------- End CDE -------------------------------- +SEQ, Q_OR, Q_SHIFTL, Q_JBYT. LDO = LTHIS JSLA = IQ(LDO+1) JSLE = JSLA + IQ(LDO+2) JSLF = JSLA C---- Find next control line 20 JSLG = JSLF + 1 21 IF (JSLG.GE.JSLE) GO TO 41 CALL NEXTCC ('+',JSLG,JSLE,JSLF,JTYPE) IF (JTYPE.EQ.0) GO TO 41 IF (JTYPE.LT.MCCCDE) GO TO 20 IF (JTYPE.GT.MCCSEQ) GO TO 20 C-- split before +CDE IF (JSLF.GT.JSLA) LDO= M_SPLIT (LDO,JSLF) IQ(LDO) = IOR (IQ(LDO), ISHFTL(JTYPE,8)) JSLG = IQ(LDO+1) + 1 IF (JSLG.GE.JSLE) GO TO 41 C-- split after +CDE LDO = M_SPLIT (LDO,JSLG) JSLA = JSLG GO TO 21 C---- step to next bank 41 LDO = LQ(LDO-1) IF (LDO.EQ.0) RETURN IF (LQ(LDO-2).NE.0) GO TO 41 JTYPE = JBYT (IQ(LDO),9,6) IF (JTYPE.GE.MCCSEL) RETURN JSLA = IQ(LDO+1) JSLE = JSLA + IQ(LDO+2) JSLG = JSLA GO TO 21 END +SEQ, QCARDL. ===================================================== +PATCH, YCHECK. for program Nycheck +DECK, NCHECK. PROGRAM NCHECK +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=3) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'PAM .car 9 2 0 !ff' +, 'opt 3 11 0 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist +SELF, IF=QS_IBMVM. NAME(3)(9:16) = '.listing' +SELF. CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nycheck Help User_dt') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXCHECK +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXCHECK. SUBROUTINE EXCHECK C- Run nycheck C. started 12-jan-94 +CDE, SLATE, SLATLN, QBITA31, QPAGE, QSTATE, QUNIT. +CDE, CM_TYP, LUNSLN. +CDE, Q, PY. C-------------- End CDE -------------------------------- PARAMETER (MASK= KMH + KMU) CALL INIAUX (LASTWK) CALL KROPT (IXLUN(2),MASK) CALL PGSIZE (0, IXLUN(2)) IF (MOPTIO(8).NE.0) GO TO 81 NQCMAX = 90 NQCPGH = 80 NQJOIN = 1 C------ Load the title deck to memory ------------ CALL INIPAM (11, IXLUN(1), 1,0) 21 IF (JDKNEX.EQ.0) CALL ARRIVE (2) C---- Handle the PAM-file title line JDKTYP = 3 CALL KRTITL JSLTTL = IQ(LARRV+10) IF (NQDKNO.GE.2) THEN NQDKNO = ((NQDKNO-1)/100 + 1) *100 ELSE NQDKNO = 0 ENDIF CALL LN_GET (JSLTTL, SLLINE, 60) NTXT = NDSLAT IF (IQPRNT.NE.IQTYPE) WRITE (IQTYPE,9024) SLLINE(1:NTXT) 9024 FORMAT (' Read Pam file: ',A/) C------ Loop over all decks until next title CALL CHDECK IF (JDKTYP.EQ.3) GO TO 21 IF (MOPTIO(21).EQ.0) GO TO 47 IF (N_TYP.LE.JIN_TYP) GO TO 47 CALL DPBLAN (1) WRITE (IQPRNT,9025) DO 27 JASM=1,N_TYP LASMT = LQ(LHASM-JASM) NDK = IQ(LASMT+8) IF (NDK.EQ.0) GO TO 27 N = LNBLNK (CH_TYP(JASM)) WRITE (IQPRNT,9027) NDK, CH_TYP(JASM)(1:N) NQUSED = NQUSED + 1 27 CONTINUE 47 IF (NQERR .NE.0) CALL EXITRC (2) IF (NQWARN.NE.0) CALL EXITRC (1) CALL DPBLAN (0) WRITE (IQPRNT,9049) 9049 FORMAT (' All is well.'/) RETURN C---- Help 81 WRITE (IQPRNT,9081) RETURN 9025 FORMAT (' Table of Data types'/) 9027 FORMAT (4X,I6,' decks of type ',A) 9081 FORMAT (' nycheck pam.car options print'/ F/' reads the "pam" file to check all Patchy control-lines' F/' for syntax, reporting errors on "print".'/ F/' "options": H help - print this help information only' F/' U user data-types present to cause warning exit') END +SEQ, QCARDL. ===================================================== +DECK, CHDECK. SUBROUTINE CHDECK C- Check all decks until next +TITLE C. started 12-jan-94 +CDE, SLATLN, QBITS19, QPAGE. +CDE, CCTYPE, CCPARA, CHEXC, CM_TYP, DEPCOM, MUSEBC. +CDE, MQCM, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT. C-- Check file starts with +PATCH or +DECK IF (JCCTYP.EQ.MCCDEC) JDKTYP= 1 IF (JCCTYP.EQ.MCCPAT) JDKTYP= 2 C-- set limits of control division 2 LQCSTA(2) = LQCEND(1) + 100 LQCEND(2) = LQCSTA(2) C-- clear text division 3 LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) JD_DTP = 1 +SEQ, QEJECT. C------ Ready the deck parameters 21 NQNEWH = 7 IXEXDEC = 0 IF (JDKTYP.EQ.3) GO TO 47 JSLF = IQ(LQHOLD+1) IF (JDKTYP.EQ.1) GO TO 42 C-- deck header is +PATCH, name JCCTYP = MCCPAT CALL CCKRAK (JSLF) IXEXPAT = MCCPAR(JCCPP+1) IF (IXEXPAT.EQ.0) IXEXPAT= 1 IXEXID = IXEXPAT JD_DTN = 0 IF (JCCBAD.EQ.0) CALL CCDOPT (1, JD_DTN) IF (JD_DTN.EQ.0) JD_DTN= 1 JD_DTP = JD_DTN GO TO 44 C-- deck header is +DECK, name 42 JSLF = IQ(LQHOLD+1) JCCTYP = MCCDEC CALL CCKRAK (JSLF) IXEXDEC = MCCPAR(JCCPD+1) IF (IXEXDEC.EQ.0) IXEXDEC= 1 IXEXID = IXEXDEC 44 JD_DTN = 0 IF (JCCBAD.EQ.0) CALL CCDOPT (1, JD_DTN) IF (JD_DTN.EQ.0) JD_DTN= JD_DTP LASMT = LQ(LHASM-JD_DTN) NR = IQ(LASMT+8) IQ(LASMT+8) = NR + 1 IF (MOPTIO(21).EQ.0) GO TO 47 IF (JD_DTN.LE.JIN_TYP) GO TO 47 IF (NR.NE.0) GO TO 47 SLERRM = 'New user data-type ' // CH_TYP(JD_DTN) CALL FAILLN (0,0,0,JSLF,SLERRM(1:LENOCC(SLERRM))) C-- set operation mode 47 NVEXDK(1) = 0 NVEXDK(2) = 1 NVEXDK(5) = 1 NVEXDK(6) = 1 NQJOIN = 1 C------ Process the deck LEXD = 0 NSLORG = 0 IF (JDKNEX.EQ.0) CALL ARRIVE (2) C-- analyse the contents CALL DOMAPA (0) C-- process the contents LUPAN = 0 LDOAN = KQPREP + 1 54 LDOAN = LQ(LDOAN-1) IF (LDOAN.EQ.0) GO TO 88 JCCTYP = JBYT (IQ(LDOAN),9,6) IF (JCCTYP.EQ.0) GO TO 54 CALL CCKRAK (IQ(LDOAN+1)) IF (JCCBAD.NE.0) THEN CALL FAILCC (1,'syntax error') GO TO 54 ENDIF IF (JCCWAR.EQ.0) GO TO 54 IF (JCCWAR.EQ.1) CALL FAILCC (0,'hidden dot') IF (JCCWAR.EQ.2) CALL FAILCC (0,'trailing comma') GO TO 54 C-- step to the next deck 88 CALL ARRNXD (1) NQDKNO = NQDKNO + 1 IFLGAR = 0 IF (JDKTYP.LT.3) GO TO 21 RETURN END +SEQ, QCARDL. ===================================================== +PATCH, YTIDY. for program Nytidy +KEEP, ADDTI. +, IXBLADK, IXSQSP(7), NTRBLA,NMODIF, JSLTTL, LASTTI +DECK, DOC, T=JOIN, IF=DOCUMENT, DOC_INL. +KEEP, xADDTI. C IXBLADK = NA_LONG ('BLANKDEK') C IXSQSP(1) = NA_LONG ('DATEQQ') C IXSQSP(2) = NA_LONG ('TIMEQQ') C IXSQSP(3) = NA_LONG ('VERSQQ') C IXSQSP(4) = NA_LONG ('VIDQQ') +DECK, NTIDY, T=JOIN. PROGRAM NTIDY +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=4) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'PAM .car 9 2 0 !ff' +, 'NEW .car 9 6 0 !ff' +, 'opt 3 11 0 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist +SELF, IF=QS_IBMVM. NAME(4)(9:16) = '.listing' +SELF. CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nytidy Cmz, Help, Verbose') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXTIDY +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXTIDY. SUBROUTINE EXTIDY C- Run nytidy C. started 26-may-94 +CDE, SLATE, SLATLN, QBITA31, QUNIT. +CDE, LUNSLN, FLINKC, DEPCOM. +CDE, Q, PY, ADDTI. C-------------- End CDE -------------------------------- INTEGER RENAMEF PARAMETER (MASK= KMB + KMC + KMH + KMV) CALL INIAUX (LASTTI) CALL KROPT (IXLUN(3),MASK) IF (MOPTIO(8).NE.0) GO TO 81 MOPTIO(2) = 0 CALL INIPAM (11, IXLUN(1), 1,0) IXBLADK = NA_LONG ('BLANKDEK') IXSQSP(1) = NA_LONG ('DATEQQ') IXSQSP(2) = NA_LONG ('TIMEQQ') IXSQSP(3) = NA_LONG ('VERSQQ') IXSQSP(4) = NA_LONG ('VIDQQ') IFLOVW = 0 IF (IXLUN(2).EQ.0) GO TO 24 C-- check "new" is a pure directory CALL FLSPLIT (IXLUN(2),IXDIR,IXFN,IXEXT) IF (IXFN.NE.0) GO TO 27 CALL FLSPLIT (IXLUN(1),IXD,IXFN,IXEXT) IF (IXD.EQ.IXDIR) CALL P_KILL ('clashing file names') GO TO 26 C-- derive the name of "new" if not given 24 IFLOVW = 7 CALL FLSPLIT (IXLUN(1),IXDIR,IXFN,IXEXT) IXEXT = NA_LONG ('.tdy') 26 CALL FLJOIN (IXDIR,IXFN,IXEXT,IXLUN(2)) +SEQ, QEJECT. C-- open the output file 27 JD_LUN = 21 CALL FLINK (JD_LUN,6,IXLUN(2),0) +SELF, IF=QCIO. JD_LUN = LUNFD +SELF. WRITE (IQTYPE,9029) CHLIFI(1:NLIFI) 9029 FORMAT (' Writing file: "',A,'"'/) C------ Load the title deck to memory ------------ 41 IF (JDKNEX.EQ.0) THEN CALL ARRIVE (2) CALL TIDISTB NTRBLA = NTRBLA + IQUEST(1) ENDIF C---- Handle the PAM-file title line JDKTYP = 3 CALL KRTITL JSLTTL = IQ(LARRV+10) CALL USETT (JSLTTL) CALL LN_GET (JSLTTL, SLLINE, 72) NTXT = NDSLAT CALL DPBLAN (0) WRITE (IQPRNT,9044) SLLINE(1:NTXT) IF (IQPRNT.NE.IQTYPE) WRITE (IQTYPE,9044) SLLINE(1:NTXT) 9044 FORMAT (' Read Pam file: ',A/) C------ Loop over all decks until next title CALL TIDECK IF (JDKTYP.EQ.3) GO TO 41 C-- close output +SELF, IF=QCIO. CALL CICLOS (JD_LUN) +SELF, IF=QFIO. CLOSE (JD_LUN) +SELF. C-- close input CALL INIPAM (0,0, -1,0) CALL DPBLAN (0) WRITE (IQPRNT,9071) NMODIF,NTRBLA IF (IQPRNT.NE.IQTYPE) WRITE (IQTYPE,9071) NMODIF,NTRBLA 9071 FORMAT (I8,' changes done,',I7,' lines with trailing blanks.'/) IF (IFLOVW.EQ.0) RETURN +SELF, IF=-QMIBM. C-- delete the new file if overwriting and unchanged IF (NMODIF+NTRBLA.EQ.0) THEN CALL FLNAME (IXLUN(2),N) CALL UNLINKF (CHLIFI(1:NLIFI)) RETURN ENDIF C-- rename "new" to "pam" CALL FLNAME (IXLUN(1), N) NIN = NLIFI SLLINE(1:NIN) = CHLIFI(1:NIN) CALL FLNAME (IXLUN(2),N) WRITE (IQTYPE,9077) CHLIFI(1:NLIFI),SLLINE(1:NIN) 9077 FORMAT (' Renaming file: ',A F/ ' to: ',A/) ISTAT = RENAMEF (CHLIFI(1:NLIFI), SLLINE(1:NIN)) IF (ISTAT.EQ.0) RETURN CALL P_KILLM ('Rename new to old failed') +SELF, IF=QMIBM. C-- show the "new" name on IBM CALL FLNAME (IXLUN(2),N) WRITE (IQTYPE,9078) CHLIFI(2:NLIFI) 9078 FORMAT (' The name of the new file is: ',A/) +SELF. RETURN +SEQ, QEJECT. C---- Help 81 WRITE (IQPRNT,9081) RETURN 9081 FORMAT (' nytidy pam.car new.car options print'/ F/' copies "pam" to "new" with some tidying-up:' F/' - remove trailing blanks' F/' - remove lead/trailing comment lines in decks of type FORT' F/' - translate non-standard sequence calls'/ F/' options: C the input is a CMZ output file' F/' H help - print this help information only' F/' V verbose - print each modification'/ +SELF, IF=-QMIBM. F/' If "new" is not given the result will overwrite "pam".' F/' If "new" is given as a directory (with / at the end) it will' F/' inherit file-name and extension from "pam".') +SELF, IF=QMIBM. F/' If "new" is not given the result will go to pam.TDY') +SELF. END +SEQ, QCARDL. ===================================================== +DECK, TIDECK. SUBROUTINE TIDECK C- Tidy all decks until next +TITLE C. started 26-may-94 +CDE, CCTYPE, CCPARA, CHEXC, CM_TYP, DEPCOM. +CDE, QPAGE, MQCM, Q, PY, ADDTI. C-------------- End CDE -------------------------------- C-- Check file starts with +PATCH or +DECK IF (JCCTYP.EQ.MCCDEC) JDKTYP= 1 IF (JCCTYP.EQ.MCCPAT) JDKTYP= 2 NOFFBD = 0 C-- make sure the deck is in memory 21 IF (JDKNEX.EQ.0) THEN CALL ARRIVE (2) CALL TIDISTB NTRBLA = NTRBLA + IQUEST(1) ENDIF C-- set limits of control division 2 22 LQCSTA(2) = LQCEND(1) + 100 LQCEND(2) = LQCSTA(2) C-- clear text division 3 LQLSTA(3) = LQLEND(2) LQLEND(3) = LQLSTA(3) C-------- Ready the deck parameters NQNEWH = 7 IF (JDKTYP.EQ.1) GO TO 46 IXEXDEC = 0 IF (JDKTYP.EQ.2) GO TO 41 C---- deck header is +TITLE or start of PAM JD_DTP = 0 JD_DTD = 0 GO TO 49 +SEQ, QEJECT. C---- deck header is +PATCH, name 41 JSLF = IQ(LQHOLD+1) IF (JDKNEX.NE.1) GO TO 44 C-- check next deck is BLANKDEK JSLN = JSLF + IQ(LQHOLD+3) JCCTYP = MCCDEC CALL CCKRAK (JSLN) IX = MCCPAR(JCCPD+1) IF (IX.NE.IXBLADK) GO TO 44 NOFFBD = IQ(LQHOLD+3) JTXN = MLIAD(JSLN) TEXT(JTXN) = '*' CALL ARRNXD (0) IF (JDKNEX.EQ.0) GO TO 21 44 JCCTYP = MCCPAT CALL CCKRAK (JSLF) IXEXPAT = MCCPAR(JCCPP+1) IF (IXEXPAT.EQ.0) IXEXPAT= 1 IXEXID = IXEXPAT JD_DTD = 0 IF (JCCBAD.EQ.0) THEN CALL CCDOPT (1, JD_DTD) IF (JD_DTD.EQ.0) JD_DTD= 1 ENDIF JD_DTP = JD_DTD GO TO 49 C---- deck header is +DECK, name 46 JSLF = IQ(LQHOLD+1) JCCTYP = MCCDEC CALL CCKRAK (JSLF) IXEXDEC = MCCPAR(JCCPD+1) IF (IXEXDEC.EQ.0) IXEXDEC= 1 IXEXID = IXEXDEC JD_DTD = 0 IF (JCCBAD.EQ.0) THEN CALL CCDOPT (1, JD_DTD) IF (JD_DTD.EQ.0) JD_DTD= JD_DTP ENDIF C-- if type is INCLUDE: handle as CC 49 IF (JD_DTD.EQ.JIN_TYP) JD_DTD= JCC_TYP C-------- Process the deck LEXD = 0 NSLORG = 0 C-- restore the leading + for +DECK, BLANKDEK. IF (NOFFBD.NE.0) THEN JSLN = IQ(LQHOLD+1) + NOFFBD JTXN = MLIAD(JSLN) TEXT(JTXN) = '+' ENDIF C-- analyse the contents CALL DOMAPA (0) IF (JDKTYP.EQ.3) GO TO 67 IF (NOFFBD.NE.0) THEN L = LQFIND (JSLN,1, LQPREP) IF (L.NE.0) LQ(L-2) = -1 NOFFBD = 0 ENDIF C-- transform the contents IF (JD_DTD.EQ.1) CALL TICOMM CALL TISEQ CALL TILIST +SELF, IF=XDEBUG, IF=XDDSNAP. CALL DDPREP +SELF. C-- send the deck to output 67 CALL TISEND C-- step to the next deck CALL ARRNXD (1) IFLGAR = 0 IF (JDKTYP.LT.3) GO TO 21 RETURN END +SEQ, QCARDL. ===================================================== +DECK, TICOMM. SUBROUTINE TICOMM C- Delete leading and trailing comment or blank lines C- in Fortran decks only C. started 26-may-94 +CDE, CCTYPE, CCPARA. +CDE, Q, PY, ADDTI. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT. C---- delete leading comments LDO = LQPREP 21 LPR = LDO LDO = LQ(LDO-1) IF (LDO.EQ.0) RETURN IF (LQ(LDO-2).NE.0) GO TO 21 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.EQ.0) GO TO 24 IF (JCCTYP.LT.MCCTRU) GO TO 22 IF (JCCTYP.LT.MCCKEE) GO TO 31 C-- step over foreign and control material 22 CALL TIFORG (LPR,LDO) IF (LDO.EQ.0) RETURN IF (JCCTYP.NE.0) GO TO 31 C-- check all comment 24 JSLA = IQ(LDO+1) NSL = IQ(LDO+2) JSLE = JSLA + NSL JSL = JSLA - 1 25 JSL = JSL + 1 IF (JSL.GE.JSLE) GO TO 27 JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.EQ.0) GO TO 25 IF (TEXT(JTX).EQ.'C') GO TO 25 IF (TEXT(JTX).EQ.'c') GO TO 25 IF (TEXT(JTX).EQ.'*') GO TO 25 IF (JSL.EQ.JSLA) GO TO 31 LPR = LDO LDO = M_SPLIT (LPR,JSL) +SELF, IF=QDIAG. IF (LDO.EQ.0) CALL P_KILL ('M_SLIT failed') +SELF. LQ(LPR-2) = -1 GO TO 31 27 LQ(LDO-2) = -1 GO TO 21 +SEQ, QEJECT. C----- set the reverse link on remaining banks 31 CONTINUE 34 LPR = LDO 35 LDO = LQ(LDO-1) IF (LDO.EQ.0) GO TO 39 IF (LQ(LDO-2).NE.0) GO TO 35 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.EQ.MCCNIL) GO TO 36 IF (JCCTYP.EQ.MCCKIL) GO TO 36 IF (JCCTYP.LT.MCCKEE) GO TO 37 C-- step over foreign and control material 36 CALL TIFORG (LPR,LDO) IF (LDO.EQ.0) GO TO 39 37 LQ(LDO-3) = LPR GO TO 34 39 LLAST = LPR C---- look for trailing comment lines LDO = LLAST 42 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.NE.0) GO TO 89 JSLA = IQ(LDO+1) NSL = IQ(LDO+2) JSLE = JSLA + NSL JSL = JSLE 44 JSL = JSL - 1 IF (JSL.LT.JSLA) GO TO 47 JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.EQ.0) GO TO 44 IF (TEXT(JTX).EQ.'C') GO TO 44 IF (TEXT(JTX).EQ.'c') GO TO 44 IF (TEXT(JTX).EQ.'*') GO TO 44 JSL = JSL + 1 IF (JSL.EQ.JSLE) GO TO 89 LPR = LDO LDO = M_SPLIT (LPR,JSL) +SELF, IF=QDIAG. IF (LDO.EQ.0) CALL P_KILL ('M_SLIT failed') +SELF. LQ(LDO-2) = -1 GO TO 89 C-- all lines are comments 47 LQ(LDO-2) = -1 LDO = LQ(LDO-3) IF (LDO.NE.0) GO TO 42 C---- done 89 RETURN END +SEQ, QCARDL. ===================================================== +DECK, TIFORG. SUBROUTINE TIFORG (LPREV,LNEXT) C- Skip over foreign and control material C. started 9-may-95 +CDE, CCTYPE, CCPARA, Q. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT. LDO = LQ(LPREV-1) IF (JCCTYP.LT.MCCKEE) GO TO 24 IF (JCCTYP.GE.MCCUSE) GO TO 24 C-- scan foreign 21 LDO = LQ(LDO-1) IF (LDO.EQ.0) GO TO 27 IF (LQ(LDO-2).NE.0) GO TO 21 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.LT.MCCSEL) GO TO 21 IF (JCCTYP.GE.MCCUSE) GO TO 24 IF (JCCTYP.GE.MCCKEE) GO TO 21 GO TO 27 C-- scan control 24 LDO = LQ(LDO-1) IF (LDO.EQ.0) GO TO 27 IF (LQ(LDO-2).NE.0) GO TO 24 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.GE.MCCUSE) GO TO 24 IF (JCCTYP.GE.MCCKEE) GO TO 21 IF (JCCTYP.EQ.0) GO TO 27 IF (JCCTYP.LT.MCCTRU) GO TO 24 C-- end of scan 27 LNEXT = LDO RETURN END +SEQ, QCARDL. ===================================================== +DECK, TISEQ. SUBROUTINE TISEQ C- Transform special sequence calls C. started 26-may-94 +CDE, SLATE, SLATLN, QSTATE. +CDE, CCTYPE, CCPARA, CM_TYP, DEPCOM. +CDE, USETTC. +CDE, QBANKS, KQADR, Q, PY, ADDTI. C-------------- End CDE -------------------------------- EQUIVALENCE (IFLBACK,MOPTIO(2)), (IFLCMZ,MOPTIO(3)) CHARACTER LINE*128 EQUIVALENCE (LINE,SLLINE) +SEQ, Q_JBYT. C---- Next bank LDO = KQPREP + 1 11 LDO = LQ(LDO-1) IF (LDO.EQ.0) RETURN IF (LQ(LDO-2).NE.0) GO TO 11 JCCTYP = JBYT (IQ(LDO),9,6) IF (JCCTYP.LT.MCCCDE) GO TO 11 IF (JCCTYP.GT.MCCSEQ) GO TO 11 JSLOLD = IQ(LDO+1) CALL CCKRAK (JSLOLD) IF (NCCPZ.NE.1) GO TO 11 IXZ = MCCPAR(JCCPZ+1) IF (IXZ.EQ.0) GO TO 11 JSQ = IUCOMP (IXZ,IXSQSP,4) IF (JSQ.EQ.0) GO TO 11 NSL = 1 GO TO (21, 31, 41, 51), JSQ +SEQ, xADDTI, IF=DOC_INL. +SEQ, QEJECT. C---- doing +SEQ, DATEQQ 21 IF (IFLCMZ.NE.0) GO TO 24 22 IF (IFLBACK.NE.0) GO TO 11 JSLNEW = LN_TO3 ('+SEQ, QDATE . IDATQQ = ?') GO TO 88 24 IF (JD_DTD.NE.JCC_TYP) GO TO 22 IF (IFLBACK.NE.0) GO TO 26 JSLNEW = LN_TO3 ('+SEQ, QDATE .#define IDATQQ ?') GO TO 88 26 LINE = '#define IDATQQ ' C- _:.=+=.: 1_:.=+=.: 2_:.=+ CALL CSETDI (IQDATE, LINE,17,24) JSLNEW = LN_TO3 (LINE(1:24)) GO TO 88 C---- doing +SEQ, TIMEQQ 31 IF (IFLCMZ.NE.0) GO TO 34 32 IF (IFLBACK.NE.0) GO TO 11 JSLNEW = LN_TO3 ('+SEQ, QTIME . ITIMQQ = ?') GO TO 88 34 IF (JD_DTD.NE.JCC_TYP) GO TO 32 IF (IFLBACK.NE.0) GO TO 36 JSLNEW = LN_TO3 ('+SEQ, QTIME .#define ITIMQQ ?') GO TO 88 36 LINE = '#define ITIMQQ ' C- _:.=+=.: 1_:.=+=.: 2_:.=+ CALL CSETDI (IQTIME, LINE,17,22) JSLNEW = LN_TO3 (LINE(1:24)) GO TO 88 C---- doing +SEQ, VERSQQ 41 IF (IFLCMZ.EQ.0) GO TO 11 IF (JD_DTD.EQ.JCC_TYP) GO TO 44 IF (IFLBACK.NE.0) GO TO 42 JSLNEW = LN_TO3 ('+SEQ, QFVSNUM . IVERSQ = ?') GO TO 88 42 LINE = ' IVERSQ = ' // CHTTNA(3) JSLNEW = LN_TO3 (LINE(1:40)) GO TO 88 44 IF (IFLBACK.NE.0) GO TO 46 JSLNEW = LN_TO3 ('+SEQ, QFVERS .#define VERSQQ "?"') JSL = LN_TO3 ('+SEQ, QFVSNUM .#define IVERSQ ?') NSL = 2 GO TO 88 46 LINE = '#define VERSQQ "' // CHTTNA(2) N = LENOCC (LINE(1:48)) LINE(N+1:N+1) = '"' JSLNEW = LN_TO3 (LINE(1:48)) LINE = '#define IVERSQ ' // CHTTNA(3) JSL = LN_TO3 (LINE(1:48)) NSL = 2 GO TO 88 C---- doing +SEQ, VIDQQ 51 IF (IFLCMZ.EQ.0) GO TO 11 IF (JD_DTD.EQ.JCC_TYP) GO TO 54 NSL = 2 JSLNEW = LN_TO3 (' CHARACTER VIDQQ*(48)') IF (IFLBACK.NE.0) GO TO 52 JSL = LN_TO3 ('+SEQ, QFHEAD . DATA VIDQQ /''@(#)?>''/') GO TO 88 52 LINE = ' DATA VIDQQ /''@(#)' // + CHTTNA(1)(1:9) // CHTTNA(2) // CHTTDT N = LENOCC (LINE(1:68)) LINE(N+1:N+3) = '>''/' JSL = LN_TO3 (LINE(1:N+3)) GO TO 88 54 IF (IFLBACK.NE.0) GO TO 56 JSLNEW = + LN_TO3 ('+SEQ, QFHEAD .static char vidqq[] = "@(#)?>"') GO TO 88 56 LINE = 'static char vidqq[] = "@(#)' // + CHTTNA(1)(1:9) // CHTTNA(2) // CHTTDT N = LENOCC (LINE(1:80)) LINE(N+1:N+2) = '>"' JSLNEW = LN_TO3 (LINE(1:N+2)) C---- store the replacement 88 CALL MQLIFT (LNEW, LDO,-2, JBKPRE,2) IQ(LNEW+1) = JSLNEW IQ(LNEW+2) = NSL GO TO 11 END +SEQ, QCARDL. ===================================================== +DECK, TILIST. SUBROUTINE TILIST C- Count the modification done, list them if option Verbose C. started 27-may-94 +CDE, SLATE, SLATLN, QPAGE, QUNIT, CHEXC. +CDE, KQADR, Q, PY, ADDTI. C-------------- End CDE -------------------------------- CHARACTER LINE*512 EQUIVALENCE (LINE,SLLINE) LDO = KQPREP + 1 21 LDO = LQ(LDO-1) IF (LDO.EQ.0) RETURN IF (LQ(LDO-2).EQ.0) GO TO 21 NMODIF = NMODIF + 1 IF (MOPTIO(22).EQ.0) GO TO 21 IF (NQNEWH.EQ.0) GO TO 27 NQNEWH = 0 C-- list P/D identifier LINE(1:80) = ' --- p=' CALL NA_GET (IXEXPAT,LINE,8) JN = NESLAT LINE(JN+1:JN+2) = 'd=' CALL NA_GET (IXEXDEC,LINE,JN+3) N = NESLAT - 1 CALL DPBLAN (0) WRITE (IQPRNT,9024) LINE(1:N) 9024 FORMAT (A/) 27 LNEW = LQ(LDO-2) JSLOLD = IQ(LDO+1) NSLOLD = IQ(LDO+2) IF (LNEW.GT.0) GO TO 41 C------ NSLOLD lines deleted C-- check multiple deletes 31 LNX = LQ(LDO-1) IF (LNX.EQ.0) GO TO 32 IF (LQ(LNX-2).GE.0) GO TO 32 NSLOLD = NSLOLD + IQ(LNX+2) IQ(LDO+2) = NSLOLD LQ(LDO-1) = LQ(LNX-1) GO TO 31 32 CALL DPBLAN (1) WRITE (IQPRNT,9032) 9032 FORMAT (' delete:') JSL = JSLOLD LNO = JSL - JSLZER JSLE = JSLOLD + NSLOLD - 1 LNOE = LNO + NSLOLD - 1 NSLX = NSLOLD IF (NSLX.GT.7) NSLX = 3 DO 34 J=1,NSLX CALL LN_GET (JSL,LINE,512) WRITE (IQPRNT,9034) LNO,LINE(1:NDSLAT) LNO = LNO + 1 34 JSL = JSL + 1 IF (NSLX.EQ.NSLOLD) GO TO 21 CALL LN_GET (JSLE,LINE,512) WRITE (IQPRNT,9033) WRITE (IQPRNT,9034) LNOE,LINE(1:NDSLAT) GO TO 21 9033 FORMAT (8X,'...') 9034 FORMAT (I8,' - ',A) +SEQ, QEJECT. C------ NSLNEW lines replacing 41 JSLNEW = IQ(LNEW+1) NSLNEW = IQ(LNEW+2) CALL DPBLAN (1) WRITE (IQPRNT,9041) 9041 FORMAT (' replace:') JSL = JSLOLD LNO = JSL - JSLZER DO 44 J=1,NSLOLD CALL LN_GET (JSL,LINE,512) WRITE (IQPRNT,9034) LNO,LINE(1:NDSLAT) LNO = LNO + 1 44 JSL = JSL + 1 WRITE (IQPRNT,9042) 9042 FORMAT (' by:') JSL = JSLNEW DO 46 J=1,NSLNEW CALL LN_GET (JSL,LINE,512) WRITE (IQPRNT,9044) LINE(1:NDSLAT) 46 JSL = JSL + 1 GO TO 21 9044 FORMAT (8X,' < ',A) END +SEQ, QCARDL. ===================================================== +DECK, TISEND. SUBROUTINE TISEND C- Send the material of the current deck to output C. started 26-may-94 +CDE, DEPCOM. +CDE, KQADR, Q, PY. C-------------- End CDE -------------------------------- LDO = KQPREP + 1 21 LDO = LQ(LDO-1) IF (LDO.EQ.0) RETURN LNEW = LQ(LDO-2) IF (LNEW.LT.0) GO TO 21 IF (LNEW.EQ.0) THEN JSL = IQ(LDO+1) NSL = IQ(LDO+2) ELSE JSL = IQ(LNEW+1) NSL = IQ(LNEW+2) ENDIF IF (NSL.EQ.0) GO TO 21 +SELF, IF=QCIO. JTX = MLIAD(JSL) NTX = MLIAD(JSL+NSL) - JTX CALL CIPUT (JD_LUN,TEXT(JTX),NTX,ISTAT) IF (ISTAT.NE.0) CALL P_KILLM ('CIO write fails') +SELF, IF=QFIO. DO 24 JJ=1,NSL JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.NE.0) THEN CALL DPEXLN (TEXT(JTX), NTX) ELSE WRITE (JD_LUN, '(A)') ENDIF 24 JSL = JSL + 1 +SELF. GO TO 21 END +SEQ, QCARDL. ===================================================== +DECK, TIDISTB. SUBROUTINE TIDISTB C- Discard trailing blanks on the lines in memory C. started 26-may-94 +CDE, Q. C-------------- End CDE -------------------------------- EQUIVALENCE (NCOUNT,IQUEST(1)) +SEQ, Q_AND. NCOUNT = 0 IF (IAND(IQ(LQHOLD),1) .EQ.0) RETURN CALL SBIT0 (IQ(LQHOLD),1) JSLSTA = IQ(LQHOLD+1) JSLEND = IQ(LQHOLD+1) + IQ(LQHOLD+2) C---- scan to find next line with trailing blank JSL1 = JSLSTA JTXPUT = MLIAD(JSL1) 41 JTXTAK = MLIAD(JSL1) JSL2 = JSLEND - 1 DO 42 J=JSL1,JSL2 JTXF = MLIAD(J) JTXN = MLIAD(J+1) - NCHNEWL IF (JTXN.EQ.JTXF) GO TO 42 IF (TEXT(JTXN-1).EQ.' ') GO TO 44 42 CONTINUE IF (NCOUNT.EQ.0) RETURN NCHCOP = MLIAD(JSLEND) - JTXTAK GO TO 51 C-- step to last non-blank on the line 44 JSL2 = J 45 JTXN = JTXN - 1 IF (JTXN.GT.JTXF) THEN IF (TEXT(JTXN-1).EQ.' ') GO TO 45 ENDIF +SELF, IF=QNEWLINE. TEXT(JTXN) = CHAR(NEWLN) JTXN = JTXN + 1 +SELF. NCHCOP = JTXN - JTXTAK IF (NCOUNT.EQ.0) GO TO 57 C-- copy the text and update the line slots 51 CALL CCOPYL (TEXT(JTXTAK), TEXT(JTXPUT), NCHCOP) NSH = JTXPUT - JTXTAK DO 54 J=JSL1,JSL2 54 MLIAD(J) = MLIAD(J) + NSH 57 JTXPUT = JTXPUT + NCHCOP NCOUNT = NCOUNT + 1 JSL1 = JSL2 + 1 IF (JSL1.LT.JSLEND) GO TO 41 MLIAD(JSLEND) = JTXPUT RETURN END +SEQ, QCARDL. ===================================================== +PATCH, YMERGE. for program Nymerge +DECK, DOC, IF=DOCUMENT, DOC_INL. +KEEP, bkYMERGE. C- .YMERGE special usage of the DECK bank C- ---------------------------------- C- C- DECK bank linear structure supported by LQUSER(1) C- C- link 1: next C- status: C- word 1: JSL of the first line in memory C- 2: NSL number of lines in this deck C- 3: = 1/2 if deck/patch C- C- All the material from the "merge" file is held C- in text division 1, each deck being supported by C- one DECK bank in control division 1. +SELF. +DECK, NMERGE, T=JOIN. PROGRAM NMERGE +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=5) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'MERGE .car 9 2 0 !ff' +, 'OLD .car 9 2 0 !ff' +, 'NEW .car 9 6 0 !ff' +, 'opt 3 11 0 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nymerge Help First Main Update Ponly Quick') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXMERGE +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXMERGE. SUBROUTINE EXMERGE C- Run nymerge C. started 11-july-95 +CDE, SLATE. +CDE, QBITA31, QBANKS, QPAGE, QUNIT. +CDE, CCPARA, CCTYPE, CHEXC, DEPCOM, LUNSLN, FLINKC. +CDE, MQCM, KQUSER, Q, PY. C-------------- End CDE -------------------------------- EQUIVALENCE (LMERGE,LQUSER(1)) CHARACTER LINE*80, COL(80)*1 EQUIVALENCE (LINE,COL) PARAMETER (MASK= KMF + KMH + KMM + KMP + KMQ + KMU) DIMENSION MMDEC(4) DATA MMDEC / 1, 1, 1, 3 / CALL INIAUX (LASTWK) CALL KROPT (IXLUN(4),MASK) IF (MOPTIO(8).NE.0) GO TO 81 MOPTIO(21) = MOPTIO(21) + MOPTIO(6) + MOPTIO(13) CALL UCOPY (MMDEC, MMBANK(2,JBKDEC), 4) +SEQ, QEJECT. C---- load the "merge" file CALL MELOAD C---- open the "new" file JD_LUN = 21 IXFLUN = IXLUN(3) IF (IXFLUN.EQ.0) + CALL P_KILL ('output file name missing') CALL FLINK (JD_LUN, 6, -1, 0) +SELF, IF=QCIO. JD_LUN = LUNFD +SELF. C---- start the "old" file CALL MQLIFT (LQHOLD, 0,7, JBKHOL,1) CALL MQLIFT (LARRV,LQARRV,1,JBKARR,3) CALL INIPAM (11,IXLUN(2),1,0) IFSTEP = 0 NQDKNO = -1 C-------- ready the next "merge" deck --------------- 31 IF (LMERGE.EQ.0) THEN IXMGPAT = -1 GO TO 41 ENDIF JSLM = IQ(LMERGE+1) NSLM = IQ(LMERGE+2) JTYP = IQ(LMERGE+3) IF (JTYP.EQ.1) GO TO 32 IF (JTYP.NE.2) GO TO 68 JCCTYP = MCCPAT CALL CCKRAK (JSLM) IXMGPAT = MCCPAR(JCCPP+1) IXMGDEC = 0 IF (JCCBAD.NE.0) GO TO 91 GO TO 36 32 JCCTYP = MCCDEC CALL CCKRAK (JSLM) IF (JCCBAD.NE.0) GO TO 91 IXMGPAT = MCCPAR(JCCPP+1) IXMGDEC = MCCPAR(JCCPD+1) 36 LINE = 'd=' CALL NA_GET (IXMGDEC, LINE,3) N = NESLAT IF (IXMGPAT.GT.0) THEN LINE(N+1:N+2) = 'p=' CALL NA_GET (IXMGPAT, LINE,N+3) N = NESLAT ENDIF IF (MOPTIO(17).EQ.0) THEN CALL DPBLAN (0) WRITE (IQPRNT,9036) LINE(1:N-1) ENDIF 9036 FORMAT (43X,' merge ',A/) +SEQ, QEJECT. C---- read the next deck from "old" 41 CALL ARRNXD (IFSTEP) IF (JDKTYP.GE.4) GO TO 71 IFSTEP = 1 NQDKNO = NQDKNO + 1 IF (JDKNEX.EQ.0) CALL ARRIVE (2) JSLF = IQ(LQHOLD+1) NSLF = IQ(LQHOLD+3) LINE = ' ' IF (JDKTYP.EQ.1) GO TO 44 IF (JDKTYP.EQ.2) GO TO 43 C-- Deck header is +TITLE or start of PAM NQDKNO = (NQDKNO+99) / 100 NQDKNO = NQDKNO * 100 CALL METITL (JSLF,NSLF) IXEXPAT = 0 GO TO 41 C-- Deck header is +PATCH, name 43 JCCTYP = MCCPAT CALL CCKRAK (JSLF) IXEXPAT = MCCPAR(JCCPP+1) IXEXDEC = 0 IF (IXEXPAT.EQ.0) GO TO 92 CALL NA_GET (IXEXPAT, LINE,1) CALL CRIGHT (LINE,1,32) N = 39 IFPRNT = MOPTIO(17) GO TO 51 C-- Deck header is +DECK, name 44 JCCTYP = MCCDEC CALL CCKRAK (JSLF) IXEXDEC = MCCPAR(JCCPD+1) IF (IXEXDEC.EQ.0) GO TO 92 CALL NA_GET (IXEXDEC, LINE,41) N = NESLAT - 1 IFPRNT = MOPTIO(16) + MOPTIO(17) C---- choose next deck from "old" or "merge" 51 IF (IXMGPAT.LT.0) GO TO 56 IF (IXMGPAT.NE.0) THEN IF (IXMGPAT.NE.IXEXPAT) GO TO 56 ENDIF IF (IXMGDEC.EQ.IXEXDEC) GO TO 61 C---- send deck from "old" C- | pname | num | . | dname C- 1 33 38 41 56 IF (IFPRNT.EQ.0) THEN CALL CSETDI (NQDKNO, LINE,34,37) COL(39) = '.' WRITE (IQPRNT,9056) LINE(1:N) NQLLBL = 0 ENDIF 9056 FORMAT (1X,A) CALL MESEND (JSLF,NSLF) GO TO 41 C---- send deck from "merge" 61 IF (MOPTIO(17).NE.0) GO TO 67 IF (MOPTIO(16).EQ.0) THEN COL(39) = '-' WRITE (IQPRNT,9056) LINE(1:N) NQLLBL = 0 ENDIF LINE = ' ' IF (IXMGDEC.EQ.0) THEN CALL NA_GET (IXMGPAT, LINE,1) CALL CRIGHT (LINE,1,32) N = 39 ELSE CALL NA_GET (IXMGDEC, LINE,41) N = NESLAT - 1 ENDIF CALL CSETDI (NQDKNO, LINE,34,37) COL(39) = '+' WRITE (IQPRNT,9056) LINE(1:N) NQLLBL = 0 67 CALL MESEND (JSLM,NSLM) 68 CALL TOGARB (KQUSER,0) GO TO 31 +SEQ, QEJECT. C------ Done 71 CALL DPBLAN (0) IF (LQUSER(1).EQ.0) RETURN C-- "merge" file has not been exhausted LINE = 'd=' CALL NA_GET (IXMGDEC, LINE,3) N = NESLAT IF (IXMGPAT.GT.0) THEN LINE(N+1:N+5) = 'of p=' CALL NA_GET (IXMGPAT, LINE,N+6) N = NESLAT ENDIF WRITE (IQPRNT,9074) LINE(1:N-1) 9074 FORMAT (' ***!!! ',A,' has not been found.') CALL P_KILL ('the merge file has not been consumed') C---- faulty c/l 91 LINE = ' merge:' C- _:.=+=.:_1 JSL = JSLM GO TO 93 92 LINE = ' old:' JSL = JSLF 93 CALL DPBLAN (0) CALL LN_GET (JSL,LINE(9:),70) N = NDSLAT + 8 WRITE (IQPRNT,9093) LINE(1:N) 9093 FORMAT (' ***!!! faulty control line:'/3X,A) CALL P_KILL ('fatal') C---- Help 81 WRITE (IQPRNT,9081) RETURN 9081 FORMAT ( F ' nymerge merge.car old.car new.car options print'/ F/' Merge "merge" into "old" copying to "new" with matching' F/' decks from "merge" overruling their brothers on "old".' F/' This is a purely sequential process, the decks on "merge"' F/' have to be in the right order.'/ F/' options: U update the PAM file titles;' F/' F update only the first PAM title;' F/' M main release: update the primary version number;' F/' P ponly - log only the patch names;' F/' Q quick - no log printing;' F/' H print this help information only.') END +SEQ, QCARDL. ===================================================== +DECK, METITL. SUBROUTINE METITL (JSLF,NSLF) C- Run nymerge C. started 11-july-95 +CDE, SLATE, SLATLN, QSTATE, QPAGE, QUNIT. +CDE, CCPARA, CCTYPE, USETTC. +CDE, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*128, LTEXT*128 EQUIVALENCE (LTEXT,TEXT) JSL = JSLF NSL = NSLF CALL LN_GET (JSL,LINE,128) NL = NDSLAT C-- copy +TITLE. to output JCCTYP = JPTYPE (LINE) IF (JCCTYP.NE.MCCTIT) GO TO 31 N = MIN (NL,12) JC = ICFIND (':', LINE,1,N) IF (JC.NE.NL) THEN IF (JC.LE.N) GO TO 31 ENDIF IF (NSL.EQ.1) RETURN CALL MESEND (JSL,1) JSL = JSL + 1 NSL = NSL - 1 CALL LN_GET (JSL,LINE,128) NL = NDSLAT C-- analyse true title line 31 CALL USETT (JSL) JAOLD = JTTNAM JEOLD = NL IF (MOPTIO(21).NE.0) GO TO 34 IF (LINE(1:2).NE.'C ') GO TO 48 LTEXT = LINE(JTTNAM:NL) NCHTX = NL+1 - JTTNAM +SELF, IF=QNEWLINE. NCHTX = NCHTX + 1 TEXT(NCHTX) = CHAR (NEWLN) +SELF. MLIAD(2) = NCHTX + 1 CALL DPBLAN (0) WRITE (IQPRNT,9048) NQDKNO, ' . ', LINE(JAOLD:JEOLD) GO TO 46 +SEQ, QEJECT. C---- title line update 34 IF (MOPTIO(6).NE.0) MOPTIO(21) = 0 JTK = 1 IF (LINE(1:2).EQ.'C ') JTK=JTTNAM C-- secondary version update IF (MOPTIO(13).NE.0) GO TO 36 IF (JTTSLA.EQ.0) GO TO 36 LTEXT = LINE (JTK:JTTSLA) NCHTX = JTTSLA+1 - JTK N = ICDECI (LINE,JTTSLA+1,JTTSLA+6) + 1 CALL CSETDI (N, LTEXT,NCHTX+1,NCHTX+6) CALL CLEFT (LTEXT,NCHTX+1,NCHTX+6) NCHTX = NESLAT + 1 GO TO 39 C-- primary version update 36 IF (JTTVER.EQ.0) GO TO 38 JA = ICNEXT (LINE,JTTVER,NL) JE = NESLAT JD = ICFIND ('.', LINE,JA,JE) IF (NGSLAT.EQ.0) JD= JA-1 N = ICDECI (LINE,JD+1,JE) + 1 NDIG = NDSLAT LTEXT = LINE (JTK:JE) NCHTX = JE - JTK JD = JD+1 - JTK IF (NDIG.NE.0) CALL CSETDI (N, LTEXT,JD+1,NCHTX) NCHTX = NCHTX + 2 GO TO 39 C-- no version number present 38 LTEXT = LINE(JTK:NL) // ' /1' NCHTX = NL+8 - JTK C-- update date/time 39 LTEXT(NCHTX+1:NCHTX+16) = CQDATEM // ' ' // CQTIME NCHTX = NCHTX + 16 C-- add the free comment IF (JTTCOM.NE.0) THEN NCHTX = MAX (NCHTX+2,JTTCOM-1) N = NL+1 - JTTCOM LTEXT(NCHTX+1:NCHTX+N) = LINE(JTTCOM:JTTCOM+N-1) NCHTX = NCHTX + N ENDIF NCHPR = NCHTX +SELF, IF=QNEWLINE. NCHTX = NCHTX + 1 TEXT(NCHTX) = CHAR (NEWLN) +SELF. MLIAD(2) = NCHTX + 1 C---- new title line complete CALL USETT (1) CALL DPBLAN (0) WRITE (IQPRNT,9045) NQDKNO, ' + ', LTEXT(JTTNAM:NCHPR) WRITE (IQPRNT,9046) ' - ', LINE(JAOLD:JEOLD) 9045 FORMAT (4X,I6,A,A) 9046 FORMAT (10X,A,A/) 46 CALL MESEND (1,1) JSL = JSL + 1 NSL = NSL - 1 IF (NSL.EQ.0) RETURN GO TO 49 C-- title unchanged 48 CALL DPBLAN (0) WRITE (IQPRNT,9048) NQDKNO, ' . ', LINE(JAOLD:JEOLD) 9048 FORMAT (4X,I6,A,A/) 49 CALL MESEND (JSL,NSL) RETURN END +SEQ, QCARDL. ===================================================== +DECK, MESEND. SUBROUTINE MESEND (JSLX,NSLX) C- Send the NSLX lines at JSLX to output C. started 11-july-95 +CDE, DEPCOM, Q, PY. C-------------- End CDE -------------------------------- +SELF, IF=QCIO. 32 JTX = MLIAD(JSLX) NTX = MLIAD(JSLX+NSLX) - JTX CALL CIPUT (JD_LUN,TEXT(JTX),NTX,ISTAT) IF (ISTAT.NE.0) CALL P_KILLM ('CIO write fails') +SELF, IF=QFIO. 32 JSL = JSLX DO 34 JJ=1,NSLX JTX = MLIAD(JSL) NTX = MLIAD(JSL+1) - JTX - NCHNEWL IF (NTX.NE.0) THEN CALL DPEXLN (TEXT(JTX), NTX) ELSE WRITE (JD_LUN, '(A)') ENDIF 34 JSL = JSL + 1 +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, MELOAD. SUBROUTINE MELOAD C- Load the "merge" file C. started 11-july-95 +CDE, QBANKS, LUNSLN. +CDE, MQCM, KQUSER, Q, PY. C-------------- End CDE -------------------------------- IF (IXLUN(1).EQ.0) RETURN CALL INIPAM (11,IXLUN(1),1,0) CALL ARRIVE (1) IF (JDKTYP.GE.4) GO TO 49 LDECK = KQUSER + 1 NSLCUM = 0 21 IF (JDKNEX.EQ.0) CALL ARRIVE (2) JSLF = IQ(LQHOLD+1) NSLF = IQ(LQHOLD+3) IF (NSLCUM.EQ.0) JSLFIR= JSLF CALL MQLIFT (LDECK, LDECK,-1, JBKDEC,1) IQ(LDECK+1) = JSLF IQ(LDECK+2) = NSLF IQ(LDECK+3) = JDKTYP NSLCUM = NSLCUM + NSLF C-- step to the next deck CALL ARRNXD (1) IF (JDKTYP.LE.3) GO TO 21 IF (JSLFIR+NSLCUM.NE.LQLEND(2)) GO TO 91 C-- reset division 1 to cover the "merge" material LQLEND(1) = LQLEND(2) LQLSTA(2) = LQLEND(2) C-- close the input file 49 CALL INIPAM (0,0,-1,0) RETURN C----- trouble, file too big 91 CALL P_KILL ('MERGE file too big.') END +SEQ, QCARDL. ===================================================== +PATCH, YDIFF. for program Nydiff +USE, DIF_XQT. +KEEP, ADDDI. +, INMEM(2),NSLTOT(2),NSLMAX(2),NTXMAX(2),JSLTTF(2), IFSTRUC +, NOBJTT(3,2),NOBJMAT, MDELADD(2,2), LUNCRA,NLSENT, LASTDI +DECK, DOC, T=JOIN, IF=DOCUMENT, DOC_INL. +KEEP, xADDDI. C- INMEM(J) file J is complete in memory if non-zero C- NSLTOT(2) number of lines on file 1/2 C- NSLMAX(2) maximum number of lines per patch, file 1/2 C- NTXMAX(2) max. number of characters p/p, file 1/2 C- JSLTTF(2) the title of the first PAM on file 1/2 C- C- NOBJTT(JO,J) total number of objects read C- JO= 1 decks, 2 patches, 3 PAMs C- NOBJMAT number of matching decks C- C- MDELADD (1,1) number of deleted patches C- (2,1) deleted decks C- (1,2) number of new patches added C- (2,2) new decks added C- C- LUNCRA logical unit number for cradle output C- NLSENT number of active cradle lines written C- LASTDI end for MQWORK +DECK, NDIFF, T=JOIN. PROGRAM NDIFF +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=5) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'OLD .car 9 2 0 !ff' +, 'NEW .car 9 2 0 !ff' +, 'DIFF .ucra 9 5 0 !ff' +, 'opt 3 11 0 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nydiff Anyway Force Help') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXDIFF +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXDIFF. SUBROUTINE EXDIFF C- Run nydiff C. started 3-june-94 +CDE, QBITA31, QBANKS, QSTATE, QUNIT. +CDE, LUNSLN. +CDE, MQCM, Q, PY, ADDDI. C-------------- End CDE -------------------------------- PARAMETER (MASK= KMH + KMA + KMD + KMF) DIMENSION MMPAT(4) DATA MMPAT / 0, 4, 1, 10 / CALL INIAUX (LASTDI) LQCSTA(2) = LQCEND(1) + 100 LQCEND(2) = LQCSTA(2) LQLSTA(1) = LQLEND(1) + 10 MLIAD(LQLSTA(1)) = MLIAD(LQLEND(1)) + 2048 LQLEND(1) = LQLSTA(1) LQLSTA(2) = LQLEND(1) LQLEND(2) = LQLSTA(2) CALL KROPT (IXLUN(4),MASK) IF (MOPTIO(8).NE.0) GO TO 81 CALL UCOPY (MMPAT, MMBANK(2,JBKPAT), 4) MMPAT(2) = 3 CALL UCOPY (MMPAT, MMBANK(2,JBKDEC), 4) C---- load the "old" and the "new" file CALL DILOAD C---- match decks on the names only CALL DIPREM C---- match unmatched P/D on contents CALL DISAME C---- insert proxies for new patches CALL DINEWP C---- check that 3/4 of the decks have been matched IF (MOPTIO(6).EQ.0) THEN NDK = MIN (NOBJTT(1,1), NOBJTT(1,2)) IF (4*NOBJMAT.LT.3*NDK) + CALL P_KILL ('Less than 3/4 of the decks match') ENDIF C---- prepare for the re-ordering necessary CALL DIORD C---- find lost decks in foreign patches CALL DILOST C---- make Patchy cradle CALL DICRAD C---- make Wylbur re-ordering cradle CALL DIWYLB CALL DPBLAN (0) C---- done IF (NQERR.NE.0) THEN WRITE (IQPRNT,9067) CALL EXITRC (2) ENDIF IF (NQWARN.NE.0) THEN WRITE (IQPRNT,9068) CALL EXITRC (1) ENDIF RETURN 9067 FORMAT (' ***!!! There are errors !!!***'/) 9068 FORMAT (' **!! There are warnings !!**'/) C---- Help 81 WRITE (IQPRNT,9081) WRITE (IQPRNT,9082) RETURN 9081 FORMAT ( F ' nydiff old.car new.car diff.ucra options print'/ F/' compare "old" and "new" to derive the cradles which' F/' will give "new" when applied to "old":'/ F/' diff.ucra to update "old" to "temp" using nypatchy;' F/' diff.uexe to re-order "temp" to "new" using Wylbur.'/ F/' options: A anyway: operate even if there are too few' F/' matching patch names initially' F/' F force operation even if less than 3/4 of' F/' the decks have been matched' F/' H print this help information only.') 9082 FORMAT ( F/' A shell script to make "new" from "old" using the' F/' cradles obtained from nydiff would look like this:'/ F/' nypatchy - new.car .go <0 otherwise C- IQUEST(1) = number of matching banks C. started 3-june-94 +CDE, QBITS19, Q, PY, ADDDI. C-------------- End CDE -------------------------------- EQUIVALENCE (NLEN,IQUEST(1)) +SEQ, Q_OR. NMATCH = 0 ISTAT = 0 LOLDF = LQ(LOLDUP-4) LOLDF = LQ(LOLDF-1) LOLD = LOLDF LNEWF = LQ(LNEWUP-4) LNEWF = LQ(LNEWF-1) IF (LOLDF+LNEWF.EQ.0) GO TO 37 IF (LOLDF.NE.0) THEN IF (LNEWF.NE.0) GO TO 27 ENDIF ISTAT = 1 GO TO 39 C-- match each as-yet unmatched bank of the OLD structure 24 CALL DIMSTR (LOLD, LNEWF, LEVEL, IFLINK, IRC) NMATCH = NMATCH + NLEN ISTAT = MAX (ISTAT,IRC) IF (IRC.LT.2) GO TO 31 26 LOLD = LQ(LOLD-1) IF (LOLD.EQ.0) GO TO 31 27 IF (LQ(LOLD-2).EQ.0) GO TO 24 GO TO 26 C-- end of OLD reached 31 IF (ISTAT.NE.0) GO TO 39 C-- exact match of the whole structure 37 IF (IFLINK.EQ.0) GO TO 39 IQ(LOLDUP) = IOR (IQ(LOLDUP),KM1+KM2+KM3) IQ(LNEWUP) = IOR (IQ(LNEWUP),KM1+KM2+KM3) 39 IQUEST(1) = NMATCH IST = ISTAT RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIMSTR. SUBROUTINE DIMSTR (LOLDF,LNEWF,LEVEL,IFLINK,IST) C- Find first match of bank at LOLDF in lin/st at LNEWF C- LEVEL = 0,1,2 for bank type DECK, PATCH, PAM C- IFLINK = 0/1 do not/do link the matching banks C- return IST = 0 exact match C- 1 all remain OLD banks have matched C- 2 more OLD banks to be tried C- IQUEST(1) = number of consecutive matching banks C. started 3-june-94 +CDE, Q, PY, ADDDI. C-------------- End CDE -------------------------------- LOLD = LOLDF LNEW = LNEWF IXNM = IQ(LOLD+4) C-- find the start of match NLEN = 0 ISTAT = 0 IF (LQ(LNEW-2).EQ.0 .AND. IQ(LNEW+4).EQ.IXNM) GO TO 31 ISTAT = 2 24 LNEW = LQ(LNEW-1) IF (LNEW.EQ.0) GO TO 49 IF (IQ(LNEW+4).NE.IXNM) GO TO 24 IF (LQ(LNEW-2).NE.0) GO TO 24 C-- find the length of the match 31 LOLDM = LOLD LNEWM = LNEW NLEN = 1 32 LOLD = LQ(LOLD-1) LNEW = LQ(LNEW-1) IF (LOLD.EQ.0) GO TO 41 IF (LNEW.EQ.0) GO TO 42 IF (IQ(LNEW+4).NE.IQ(LOLD+4)) GO TO 42 IF (LQ(LNEW-2).NE.0) GO TO 42 NLEN = NLEN + 1 GO TO 32 C-- store the match 41 ISTAT = MIN(1,ISTAT) IF (LNEW.NE.0) ISTAT= 1 GO TO 43 42 ISTAT = 2 43 IF (IFLINK.EQ.0) GO TO 49 CALL DILINK (LOLDM,LNEWM,LEVEL,NLEN) 49 IQUEST(1) = NLEN IST = ISTAT RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIORD. SUBROUTINE DIORD C- Prepare for the re-ordering to operate on "old" updated by C- the cradle generated by DICRAD to give "new"; this must C- be done before "lost" decks from foreign patches are linked. C. started 18-june-94 +CDE, QUNIT, Q, PY. C-------------- End CDE -------------------------------- C-- ordering the patches of this PAM LFI = LQUSER(2) CALL DIORDX (LFI) LPNEW = LFI - 3 24 LPNEW = LQ(LPNEW-1) IF (LPNEW.EQ.0) GO TO 27 LPOLD = LQ(LPNEW-2) IF (LPOLD.EQ.0) GO TO 24 C-- ordering the decks of this patch CALL DIORDX (LPNEW) GO TO 24 27 CONTINUE +SELF, IF=XDEBUG, IF=XYDIFF. WRITE (IQTYPE,9029) 9029 FORMAT (/'.End of execution in DIORD.') CALL DISNAP (3,1) +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIORDX. SUBROUTINE DIORDX (LUP) C- Find and record the strings of contiguous matches C- (unmatched banks to not disturb the order) C. started 18-june-94 +CDE, QBITS19, Q. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. IF (IAND(IQ(LUP),KM3).NE.0) RETURN LNEW = LQ(LUP-4) NDIS = 0 C---- start of a new string 22 LOLD = LQ(LNEW-2) LX = LOLD LN = LNEW NLEN = 0 C-- step to next "new" 24 LN = LQ(LN-1) IF (LN.EQ.0) GO TO 27 IF (LQ(LN-2).EQ.0) THEN IQ(LN+6) = 1 NLEN = NLEN + 1 GO TO 24 ENDIF C-- step to next "old" 25 LX = LQ(LX-1) IF (LX.EQ.0) GO TO 27 IF (LQ(LX-2).EQ.0) GO TO 25 IF (LQ(LX-2).NE.LN) GO TO 27 C-- string continues NLEN = NLEN + 1 GO TO 24 C---- end of this string 27 IQ(LNEW+9) = NLEN IF (LN.EQ.0) GO TO 29 LNEW = LN NDIS = 7 GO TO 22 C---- finished 29 IF (NDIS.EQ.0) IQ(LUP)= IOR (IQ(LUP),KM3) RETURN END +SEQ, QCARDL. ===================================================== +DECK, DILOST. SUBROUTINE DILOST C- Try to find unmatched decks by name+content in foreign patches: C- for each "old" patch which has unmatched decks, and which is C- matched as a patch with a patch on "new" (ie. which will not C- be USE-inhibited), look at its unmatched decks and try to find C- them as as-yet unmatched decks in other patches on "new". C. started 21-june-94 +CDE, QBITS19, QUNIT, DIFFC. +CDE, Q, PY, ADDDI. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. +SELF, IF=XDEBUG, IF=XYDIFF. WRITE (IQTYPE,9001) 9001 FORMAT (/'.Start finding lost decks in foreign patches') +SELF. LFX = LQUSER(1) LFN = LQUSER(2) C------ position to the next patch on OLD LPX = LQ(LFX-4) 22 LPX = LQ(LPX-1) IF (LPX.EQ.0) GO TO 68 IF (IAND(IQ(LPX),KM2).NE.0) GO TO 22 LPNM = LQ(LPX-2) IF (LPNM.EQ.0) GO TO 22 C---- position to the next patch on NEW LPN = LQ(LFN-4) 24 LPN = LQ(LPN-1) IF (LPN.EQ.0) GO TO 22 IF (IAND(IQ(LPN),KM2).NE.0) GO TO 24 IF (LPN.EQ.LPNM) GO TO 24 C-- try all "old" decks against all "new" decks of same name LDX = LQ(LPX-4) 42 LDX = LQ(LDX-1) IF (LDX.EQ.0) GO TO 24 IF (LQ(LDX-2).NE.0) GO TO 42 LDN = LQ(LPN-4) 44 LDN = LQ(LDN-1) IF (LDN.EQ.0) GO TO 42 IF (LQ(LDN-2).NE.0) GO TO 44 IF (IQ(LDN+4).NE.IQ(LDX+4)) GO TO 44 C-- found a deck of the same name on "old" and "new", C-- verify that the contents match CALL DILOOK (LDX,LDN,0,LPX,LPN,8,60) IF (NFAID.LT.0) GO TO 42 IF (NFAID.EQ.0) IQ(LDX+6)=4 CALL DILINK (LDX, LDN, 0,1) IQ(LDN+6) = 4 + IQ(LPNM+4) IQ(LPN) = IOR (IQ(LPN),KM4) CALL DINOUN (LPX) CALL DINOUN (LPN) IF (IAND(IQ(LPX),KM2).NE.0) GO TO 22 IF (IAND(IQ(LPN),KM2).NE.0) GO TO 24 GO TO 42 C-- done 68 CONTINUE +SELF, IF=XDEBUG, IF=XYDIFF. WRITE (IQTYPE,9068) 9068 FORMAT ('.End of execution in DILOST.') CALL DISNAP (3,0) +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, DICRAD. SUBROUTINE DICRAD C- Write the Patchy update cradle C. started 6-june-94 +CDE, SLATE, SLATLN, QBITS19, QUNIT, QSTATE. +CDE, FLINKC, LUNSLN. +CDE, Q, PY, ADDDI. +CDE, DIFFC. C-------------- End CDE -------------------------------- CHARACTER LNDUP*80, LINE*128, COL(128)*1, MARK*4 EQUIVALENCE (LNDUP,SLLINE), (LINE,SLERRM), (COL,SLERRM) DIMENSION MFAID(NSIZEQ) EQUIVALENCE (MFAID,IQ) LOGICAL ALSO, PRINT CHARACTER ACTION(3)*4 DATA ACTION / '+DEL', '+REP', '+ADD' / +SEQ, Q_AND. ALSO = IQTYPE .NE. IQPRNT CALL DPBLAN (1) IF (IXLUN(3).EQ.0) THEN PRINT = .TRUE. ASSIGN 9008 TO IFMT LUNCRA = IQPRNT WRITE (IQPRNT,9002) GO TO 20 ENDIF PRINT = .FALSE. ASSIGN 9009 TO IFMT LUNCRA = 21 CALL FLINK (LUNCRA,5,IXLUN(3),0) WRITE (IQPRNT,9001) CHLIFI(1:NLIFI) IF (ALSO) WRITE (IQTYPE,9001) CHLIFI(1:NLIFI) 9001 FORMAT (' the Nypatchy update cradle goes to file ',A) 9002 FORMAT (' Here comes the Nypatchy update cradle:'/) 9004 FORMAT (A) 9005 FORMAT ('+nil. Attention: PAM structure changes !') 9008 FORMAT (3X,A,'.') 9009 FORMAT (A,'.') +SEQ, QEJECT. C---- Write the leading lines to the cradle LINE = 'update /1 ' // CQDATEM // ' ' // CQTIME + // ' from Nydiff' N = LENOCC (LINE) WRITE (LUNCRA,9004) LINE(1:N) C- _:.=+=.: 1_:.=+=.:_2 LINE = '+nil. "old" was:' CALL LN_GET (JSLTTF(1),LINE(20:),40) N = LENOCC (LINE) WRITE (LUNCRA,9004) LINE(1:N) LINE = '+nil. "new" was:' CALL LN_GET (JSLTTF(2),LINE(20:),40) N = LENOCC (LINE) WRITE (LUNCRA,9004) LINE(1:N) IF (IFSTRUC.NE.0) WRITE (LUNCRA,9005) LINE = '+PATCH, UPD.' N = 12 IF (IXLUN(3).GT.0) THEN CALL FLSPLIT (IXLUN(3),IXDIR,IXFN,IXEXT) IF (IXFN.GT.0) THEN CALL NA_GET (IXFN,LINE,9) N = NESLAT COL(N) = '.' ENDIF ENDIF WRITE (LUNCRA,9004) LINE(1:N) C-------- generate the +USE, T=INH lines for the "old" file ------ C- _:.=+=.: 1_:.=+=.:_2 20 LINE = '+use, t=inh, p=' JCOL = 16 LFI = LQUSER(1) LP = LFI - 3 C-- scan all patches 22 LP = LQ(LP-1) IF (LP.EQ.0) GO TO 27 IF (IAND(IQ(LP),KM2).NE.0) GO TO 22 CALL NA_GET (IQ(LP+4),LINE,JCOL) JCPE = NESLAT - 1 IF (LQ(LP-2).NE.0) GO TO 24 WRITE (LUNCRA,IFMT) LINE(1:JCPE) NLSENT = NLSENT + 1 MDELADD(1,1) = MDELADD(1,1) + 1 IF (IQ(LP+10).EQ.0) GO TO 22 NQERR = NQERR + 1 LNDUP = 'p=' CALL NA_GET (IQ(LP+4),LNDUP,3) N = NESLAT WRITE (IQPRNT,9023) LNDUP(1:N) GO TO 22 9023 FORMAT (' ***!!! Error: deleting duplicate ',A,' !!!***') C-- scan all decks of this patch 24 LINE(JCPE+1:JCPE+4) = ', D=' JCD = JCPE + 5 LD = LQ(LP-4) 25 LD = LQ(LD-1) IF (LD.EQ.0) GO TO 22 IF (LQ(LD-2).NE.0) GO TO 25 CALL NA_GET (IQ(LD+4),LINE,JCD) WRITE (LUNCRA,IFMT) LINE(1:NESLAT-1) NLSENT = NLSENT + 1 MDELADD(2,1) = MDELADD(2,1) + 1 IF (IQ(LD+10).EQ.0) GO TO 25 NQERR = NQERR + 1 LNDUP = 'p=' CALL NA_GET (IQ(LP+4),LNDUP,3) N = NESLAT LNDUP(N+1:N+2) = 'd=' CALL NA_GET (IQ(LD+4),LNDUP,N+3) N = NESLAT WRITE (IQPRNT,9023) LNDUP(1:N) GO TO 25 27 IF (PRINT .AND. NLSENT.NE.0) CALL DPBLAN (-1) C-------- generate corrections for existing decks ------------- LFI = LQUSER(2) C---- scan all patches LPN = LFI - 3 32 LPN = LQ(LPN-1) IF (LPN.EQ.0) GO TO 60 LPX = LQ(LPN-2) IF (LPX.EQ.0) GO TO 32 CALL DINEED (2,LPN) +SEQ, QEJECT. C---- scan all decks of this patch C-- first take only the decks of the matching patch IXPUSE = 0 LDNEXT = 0 LDN = LPN - 3 34 LDN = LQ(LDN-1) IF (LDN.EQ.0) GO TO 57 LDX = LQ(LDN-2) IF (LDX.EQ.0) GO TO 34 IF (IQ(LDX+2).LE.0) GO TO 34 C-- check the deck is of foreign origin IF (IQ(LDN+6).GE.4) THEN LDNEXT = LDN GO TO 34 ENDIF C-- skip if done IF (IQ(LDX+6).EQ.4) GO TO 34 C---- compare the "new" deck to the "old" 41 IQ(LDX+6) = 4 MARK = ' -> ' CALL DINEED (1,LPX) CALL DIF_XQT (IQ(LDX+1),IQ(LDX+2), IQ(LDN+1),IQ(LDN+2),0) IF (NFAID.EQ.0) GO TO 49 IF (IQ(LDX+10)+IQ(LDN+10) .NE.0) THEN CALL DIACERR (LDX,IFERR) IF (IFERR.NE.0) GO TO 49 ENDIF IXP = IQ(LPX+4) IXD = IQ(LDX+4) LINE = '+xxx, ' CALL NA_GET (IXP,LINE,7) JN = NESLAT COL(JN) = ',' IF (IXD.EQ.0) THEN JN = JN + 1 ELSE CALL NA_GET (IXD,LINE,JN+2) JN = NESLAT ENDIF COL(JN) = ',' JPUT = JN + 2 JFAID = JFAIDA 44 JCODE = MFAID(JFAID) JFGOX = MFAID(JFAID+1) - 1 JFGON = MFAID(JFAID+2) - 1 NLDEL = MFAID(JFAID+3) NLINS = MFAID(JFAID+4) IF (NLDEL+NLINS.EQ.0) GO TO 47 LINE(1:4) = ACTION(JCODE+2) LINE(JPUT:JPUT+12) = ' ' IF (JCODE.GT.0) THEN IF (JFGOX.EQ.0) THEN LINE(1:4) = '+ADB' ELSE JFGOX = JFGOX - 1 ENDIF ENDIF CALL CSETDI (JFGOX, LINE,JPUT,JPUT+5) IF (NLDEL.GE.2) THEN COL(JPUT+6) = '-' CALL CSETDI (JFGOX+NLDEL-1, LINE,JPUT+7,JPUT+12) ENDIF CALL CLEFT (LINE,JPUT,JPUT+12) N = NESLAT - 1 IF (PRINT) WRITE(IQPRNT,9004) MARK WRITE (LUNCRA,IFMT) LINE(1:N) NLSENT = NLSENT + 1 IF (NLINS.NE.0) CALL DISEND (IQ(LDN+1)+JFGON, NLINS) MARK = ' > ' 47 JFAID = JFAID + 5 IF (JFAID.LT.JFAIDE) GO TO 44 49 IF (IXPUSE.EQ.0) GO TO 34 C-- scanning foreign decks coming all from the same old patch 52 LDN = LQ(LDN-1) IF (LDN.EQ.0) GO TO 57 LDX = LQ(LDN-2) IF (LDX.EQ.0) GO TO 52 IF (IQ(LDX+6).EQ.4) GO TO 52 IF (IQ(LDX+2).LE.0) GO TO 52 IF (IQ(LDN+6).EQ.IXPUSE) GO TO 41 LDNEXT = LDN GO TO 52 C-- start scanning foreign decks coming from patch IXPUSE 57 IF (LDNEXT.EQ.0) GO TO 32 LDN = LDNEXT LDX = LQ(LDN-2) LPX = LQ(LDX-3) IXPUSE = IQ(LDN+6) LDNEXT = 0 LDN = LQ(LPN-4) GO TO 52 +SEQ, QEJECT. C-------- add new patches or decks -------------------------- 60 LFI = LQUSER(2) C---- scan all patches LPN = LFI - 3 62 LPN = LQ(LPN-1) IF (LPN.EQ.0) GO TO 87 LPX = LQ(LPN-2) IF (LPX.EQ.0) GO TO 71 C---- scan all decks of this patch LDN = LPN - 3 64 LDN = LQ(LDN-1) IF (LDN.EQ.0) GO TO 62 LDX = LQ(LDN-2) IF (LDX.EQ.0) GO TO 72 IF (IQ(LDX+9).LT.0) GO TO 72 C-- check the deck is of foreign origin IF (IQ(LDN+6).GE.4) GO TO 64 C-- remember this deck for adding to it LLD = LDX GO TO 64 C-- this patch is new, generate a +ADD for it 71 LUSE = LPN J = 1 GO TO 74 C-- this deck is new, generate a +ADD for it 72 LUSE = LDN J = 2 IF (IQ(LDN+4).EQ.0) J= 1 C-- send the lines held by the bank at LUSE to the cradle 74 MDELADD(J,2) = MDELADD(J,2) + 1 CALL DINEED (2,LPN) LLP = LQ(LLD-3) IXP = IQ(LLP+4) IXD = IQ(LLD+4) LINO = IQ(LLD+2) LINE = '+ADD, ' CALL NA_GET (IXP,LINE,7) JN = NESLAT COL(JN) = ',' IF (IXD.EQ.0) THEN JN = JN + 1 ELSE CALL NA_GET (IXD,LINE,JN+2) JN = NESLAT ENDIF COL(JN) = ',' JN = JN + 2 CALL CSETDI (LINO, LINE,JN,JN+5) CALL CLEFT (LINE,JN,JN+5) N = NESLAT - 1 MARK = ' -> ' IF (PRINT) WRITE(IQPRNT,9004) MARK WRITE (LUNCRA,IFMT) LINE(1:N) NLSENT = NLSENT + 1 CALL DISEND (IQ(LUSE+1),IQ(LUSE+2)) IF (LPX.EQ.0) GO TO 62 GO TO 64 C---- Done 87 IF (PRINT .AND. NLSENT.NE.0) CALL DPBLAN (-1) WRITE (IQPRNT,9087) NLSENT IF (ALSO) WRITE (IQTYPE,9087) NLSENT WRITE (IQPRNT,9088) MDELADD IF (ALSO) WRITE (IQTYPE,9088) MDELADD 9087 FORMAT (' the Nypatchy update cradle has',I6,' active lines,') 9088 FORMAT (I6,' old patches,',I5,' old decks deleted,' F/ I6,' new patches,',I5,' new decks added.') NQLLBL = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DISEND. SUBROUTINE DISEND (JSLGO,NSL) C- Send the NSL lines at JSLGO to the cradle file C. started 6-june-94 +CDE, SLATE, SLATLN, QUNIT, CCTYPE. +CDE, Q, PY, ADDDI. C-------------- End CDE -------------------------------- CHARACTER LINE*512, COL(512)*1 EQUIVALENCE (LINE,SLLINE), (COL,SLLINE) IF (LUNCRA.EQ.IQPRNT) THEN ASSIGN 9008 TO IFMT ELSE ASSIGN 9009 TO IFMT ENDIF 9008 FORMAT (3X,A) 9009 FORMAT (A) JSL = JSLGO DO 24 J=1,NSL CALL LN_GET (JSL,LINE,512) IF (NDSLAT.EQ.0) THEN WRITE (LUNCRA,9009) GO TO 24 ENDIF IF (COL(1).NE.'+') GO TO 23 JCCTYP = JPTYPE (LINE) IF (JCCTYP.LT.MCCSEL) GO TO 23 COL(1) = '-' 23 WRITE (LUNCRA,IFMT) LINE(1:NDSLAT) 24 JSL = JSL + 1 NLSENT = NLSENT + NSL RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIACERR. SUBROUTINE DIACERR (LOLD,IFERR) C- Action on duplicate deck C. started 3-june-94 +CDE, SLATE, SLATLN, QUNIT, QSTATE. +CDE, Q. C-------------- End CDE -------------------------------- CHARACTER LINE*128, COL(128)*1 EQUIVALENCE (LINE,SLERRM), (COL,SLERRM) LDX = LOLD LDN = LQ(LDX-2) LPX = LQ(LDX-3) LPN = LQ(LDN-3) LINE = 'p=' CALL NA_GET (IQ(LPX+4),LINE,3) N = NESLAT LINE(N+1:N+2) = 'd=' N = N + 3 CALL NA_GET (IQ(LDX+4),LINE,N) N = NESLAT NDX = IQ(LDX+10) NDN = IQ(LDN+10) IF (NDN.NE.NDX) GO TO 31 IF (NDN.NE.1) GO TO 31 IF (IQ(LPX+4).NE.IQ(LPN+4)) GO TO 31 NQWARN = NQWARN WRITE (IQPRNT,9024) LINE(1:N) IFERR = 0 RETURN 31 NQERR = NQERR WRITE (IQPRNT,9034) LINE(1:N) IFERR = 1 RETURN 9024 FORMAT (' **!! Warn: Action on the first member of duplicate ' F/16X,A,' !!**') 9034 FORMAT (' ***!!! Error: Action on a bad member of duplicate ' F/16X,A,' !!!***') END +SEQ, QCARDL. ===================================================== +DECK, DIWYLB. SUBROUTINE DIWYLB C- Make the Wylbur cradle C. started 6-june-94 +CDE, SLATE, SLATLN, QBITS19, QUNIT, QSTATE. +CDE, FLINKC, LUNSLN. +CDE, Q, PY, ADDDI. C-------------- End CDE -------------------------------- CHARACTER LINE*128, COL(128)*1 EQUIVALENCE (LINE,SLERRM), (COL,SLERRM) LOGICAL ALSO, PRINT +SEQ, Q_AND. ALSO = IQTYPE .NE. IQPRNT CALL DPBLAN (1) NLSENT = 0 IF (IXLUN(3).EQ.0) THEN PRINT = .TRUE. ASSIGN 9008 TO IFMT LUNCRA = IQPRNT WRITE (IQPRNT,9002) GO TO 20 ENDIF CALL NA_GET (IXLUN(3),LINE,1) N = NDSLAT J = ICFILA ('.', LINE,1,N) LINE(J:J+4) = '.uexe' N = J + 4 IXFLUN = NA_LONG (LINE(1:N)) PRINT = .FALSE. ASSIGN 9009 TO IFMT LUNCRA = 21 CALL FLINK (LUNCRA,5,-1,0) WRITE (IQPRNT,9001) CHLIFI(1:NLIFI) IF (ALSO) WRITE (IQTYPE,9001) CHLIFI(1:NLIFI) LINE = '# update Wylbur Exec ' // CQDATEM // ' ' // CQTIME N = LENOCC (LINE) WRITE (LUNCRA,9004) LINE(1:N) C- _:.=+=.: 1_:.=+=.:_2 LINE = '# "old" was:' CALL LN_GET (JSLTTF(1),LINE(15:),40) N = LENOCC (LINE) WRITE (LUNCRA,9004) LINE(1:N) LINE = '# "new" was:' CALL LN_GET (JSLTTF(2),LINE(15:),40) N = LENOCC (LINE) WRITE (LUNCRA,9004) LINE(1:N) 9001 FORMAT (' the Wylbur update exec goes to file ',A) 9002 FORMAT (' Here comes the Wylbur update exec:') 9004 FORMAT (A) 9008 FORMAT (3X,A) 9009 FORMAT (A) +SEQ, QEJECT. C------ generate the re-ordering commands 20 LFI = LQUSER(2) C-- re-order the patches of this PAM IF (IAND(IQ(LFI),KM3).EQ.0) THEN CALL DIWYLR (LFI,1) ENDIF C-- scan all patches LP = LFI - 3 22 LP = LQ(LP-1) IF (LP.EQ.0) GO TO 27 IF (IAND(IQ(LP),KM4).EQ.0) GO TO 26 C-- foreign decks moved into this patch IXP = IQ(LP+4) LD = LQ(LP-4) 24 LL = LD LD = LQ(LL-1) IF (LD.EQ.0) GO TO 26 IXPGET = IQ(LD+6) - 4 IF (IXPGET.LT.0) GO TO 24 IF (PRINT) WRITE (IQPRNT,9004) WRITE (LUNCRA,IFMT) '# fetch a lost child' C- _:.=+=.:_1 LINE = 'range p=' CALL NA_GET (IXP,LINE,9) JC = NESLAT LINE(JC:JC+2) = ',d=' CALL NA_GET (IQ(LL+4),LINE,JC+3) WRITE (LUNCRA,IFMT) LINE(1:NESLAT-1) C- _:.=+=.:_1_:.=+=.:_2 LINE = 'move,n,f |p=' CALL NA_GET (IXPGET,LINE,16) JC = NESLAT LINE(JC:JC+2) = ',d=' CALL NA_GET (IQ(LD+4),LINE,JC+3) WRITE (LUNCRA,IFMT) LINE(1:NESLAT-1) C! WRITE (LUNCRA,IFMT) 'num -nol' NLSENT = NLSENT + 3 GO TO 24 26 IF (IAND(IQ(LP),KM3).NE.0) GO TO 22 CALL DIWYLR (LP,0) GO TO 22 27 IF (PRINT .AND. NLSENT.NE.0) CALL DPBLAN (-1) WRITE (IQPRNT,9070) NLSENT IF (ALSO) WRITE (IQTYPE,9070) NLSENT 9070 FORMAT (' the Wylbur update exec has',I4,' active lines.') NQLLBL = 0 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIWYLR. SUBROUTINE DIWYLR (LUP,LEVEL) C- generate the Wylbur command to re-order C- LEVEL = 0: the decks of the patch at LUP C- 1: the patches of the PAM at LUP C. started 18-june-94 +CDE, SLATE, SLATLN, QUNIT. +CDE, Q, PY, ADDDI. C-------------- End CDE -------------------------------- CHARACTER LINE*512, COL(512)*1 CHARACTER LONG*8192, LONC(8192)*1 EQUIVALENCE (LINE,SLLINE), (COL,SLLINE) EQUIVALENCE (LONG,TEXT), (LONC,TEXT) CHARACTER EQU*3 LOGICAL PRINT C- this is the maximum number of line-range elements on C- a command line which Wylbur can handle: PARAMETER (NSIZELI=20) EQU = ' d=' IF (LEVEL.NE.0) EQU= ' p=' 9001 FORMAT (A) 9002 FORMAT (3X,A) PRINT = LUNCRA.EQ.IQPRNT ASSIGN 9001 TO IFMT IF (PRINT) ASSIGN 9002 TO IFMT C---- look for the next re-ordering group LGO = LQ(LUP-4) 21 LGO = LQSTEP (LGO, IQ(LGO+9)+1) IF (LGO.EQ.0) RETURN LMIN = LGO LMAX = LGO JORD = IQ(LGO+5) MINCUR = JORD MAXCUR = JORD C-- scan starting from the string at LGO 23 MINORD = MINCUR MAXORD = MAXCUR LBK = LGO C-- find the last string with ordinal number < MAXORD 24 LBK = LQSTEP (LBK, IQ(LBK+9)+1) IF (LBK.EQ.0) GO TO 26 JORD = IQ(LBK+5) IF (JORD.GE.MAXCUR) GO TO 24 LLAST = LBK IF (JORD.GE.MINCUR) GO TO 24 MINCUR = JORD LMIN = LBK GO TO 24 C-- no re-ordering of string at LGO if no such string found 26 IF (LMIN.EQ.LGO) GO TO 21 IF (MINCUR.EQ.MINORD) GO TO 41 C-- find the string with the highest ordinal number in (LGO | LLAST) LBK = LGO 27 LBK = LQSTEP (LBK, IQ(LBK+9)+1) IF (LBK.EQ.LLAST) GO TO 29 JORD = IQ(LBK+5) IF (JORD.LE.MAXCUR) GO TO 27 MAXCUR = JORD LMAX = LBK GO TO 27 C-- if the maximum has increased: scan again 29 IF (MAXCUR.NE.MAXORD) GO TO 23 +SEQ, QEJECT. C---- found the re-ordering group from LGO to LLAST C-- construct: range p=pname,d=dfirst-dlast C-- or: range p=pfirst-plast 41 IXFI = IQ(LMIN+4) LBK = LQSTEP (LMAX,IQ(LMAX+9)) IXLA = IQ(LBK+4) NLRE = 0 IF (PRINT) WRITE (IQPRNT,9001) WRITE (LUNCRA,IFMT) '# change the order' C- _:.=+=.:_1 LINE = 'range p=' JPUT = 9 IF (LEVEL.EQ.0) THEN CALL NA_GET (IQ(LUP+4),LINE,JPUT) JPUT = NESLAT LINE(JPUT:JPUT+2) = ',d=' JPUT = JPUT + 3 ENDIF CALL NA_GET (IXFI,LINE,JPUT) COL(NESLAT) = '-' JPUT = NESLAT + 1 CALL NA_GET (IXLA,LINE,JPUT) NRANGE = NESLAT - 1 C-- construct: move,o,n d=d1-d2 d=d3-d4 ... to f C- _:.=+=.:_1 LONG(1:10) = 'move,o,n ' JPUT = 10 LBK = LGO 44 NLEN = IQ(LBK+9) IXFI = IQ(LBK+4) NLRE = NLRE + 1 LONG(JPUT:JPUT+2) = EQU CALL NA_GET (IXFI,LONG,JPUT+3) JPUT = NESLAT LE = LBK IF (NLEN.NE.0) THEN LONC(JPUT) = '-' LE = LQSTEP (LE,NLEN) CALL NA_GET (IQ(LE+4),LONG,JPUT+1) JPUT = NESLAT ENDIF IF (LBK.EQ.LLAST) GO TO 47 LBK = LQ(LE-1) GO TO 44 C! 47 IF (JPUT.GT.25) GO TO 61 47 IF (JPUT.GT.250) GO TO 61 IF (NLRE.GE.NSIZELI) GO TO 61 LONG(JPUT:JPUT+4) = ' to f' NPUT = JPUT + 4 WRITE (LUNCRA,IFMT) LINE(1:NRANGE) WRITE (LUNCRA,IFMT) LONG(1:NPUT) NLSENT = NLSENT + 2 LGO = LLAST GO TO 21 C-- resulting command line too long, operate in pieces 61 JEND = JPUT - 1 WRITE (LUNCRA,IFMT) 'range' WRITE (LUNCRA,IFMT) 'end end-marker' WRITE (LUNCRA,IFMT) 'set val w11 *' WRITE (LUNCRA,IFMT) LINE(1:NRANGE) NLSENT = NLSENT + 4 JTAK = 10 62 LINE = 'copy,n' JPUT = 8 NLRE = 0 63 JTAK = ICNEXT (LONG,JTAK,JEND) N = NDSLAT IF (JPUT+N.GE.250) GO TO 64 IF (NLRE+1.EQ.NSIZELI) GO TO 64 NLRE = NLRE + 1 LINE(JPUT:JPUT+N-1) = LONG(JTAK:JTAK+N-1) JTAK = JTAK + N + 1 JPUT = JPUT + N + 1 IF (JTAK.LT.JEND) GO TO 63 64 LINE(JPUT:JPUT+4) = 'to *+' NPUT = JPUT + 4 WRITE (LUNCRA,IFMT) LINE(1:NPUT) NLSENT = NLSENT + 1 IF (JTAK.LT.JEND) GO TO 62 WRITE (LUNCRA,IFMT) 'set val w12 *' WRITE (LUNCRA,IFMT) 'copy,o,n :w11+/:w12 to f' WRITE (LUNCRA,IFMT) 'del -nol :w11/:w12' NLSENT = NLSENT + 3 LGO = LLAST GO TO 21 END +SEQ, QCARDL. ===================================================== +DECK, DINEED. SUBROUTINE DINEED (JFILE,LPAT) C- The patch pointed to by LPAT from file JFILE is needed in memory C. started 15-june-94 +CDE, MQCM, Q, PY, ADDDI. C-------------- End CDE -------------------------------- IF (IQ(LPAT+1).NE.0) RETURN JFI = JFILE JDIV = 3 - JFI JDVN = JDIV + 1 JSLLIM = LQLSTA(JDVN) JTXLIM = MLIAD(JSLLIM) NSLTAK = IQ(LPAT+2) NTXTAK = IQ(LPAT+3) IFLOOP = 0 IF (NSLTAK.LE.0) THEN IQ(LPAT+1) = 1 RETURN ENDIF 22 JSLGO = LQLEND(JDIV) JTXGO = MLIAD(JSLGO) IF (JSLGO+NSLTAK+2 .LT.JSLLIM) THEN IF (JTXGO+NTXTAK+2 .LT.JTXLIM) GO TO 24 ENDIF IF (IFLOOP.NE.0) GO TO 91 23 IFLOOP = 7 CALL DICLFI (LQUSER(JFI)) LQLEND(JDIV) = LQLSTA(JDIV) GO TO 22 C-- read the patch into memory 24 LARRV = LQARRV IF (JFI.EQ.2) LARRV= LQ(LARRV-1) CALL DINEIN (JSLGO,LPAT) C-- set the starting slot number of each deck IQ(LPAT+1) = JSLGO JSL = JSLGO LDK = LQ(LPAT-4) 27 IQ(LDK+1) = JSL JSL = JSL + IQ(LDK+2) LDK = LQ(LDK-1) IF (LDK.NE.0) GO TO 27 LQLEND(JDIV) = JSL +SELF, IF=QDEBUG. JSLE = JSLGO + NSLTAK JTXE = JTXGO + NTXTAK IF (JSL.NE.JSLE) CALL P_CRASH ('Trouble in DINEED') IF (MLIAD(JSL).NE.JTXE) CALL P_CRASH ('Trouble in DINEED') +SELF. RETURN C-- trouble 91 CALL P_KILL ('Crash DINEED - large patch too big') RETURN END +SEQ, QCARDL. ===================================================== +DECK, DINEINC, IF=QCIO. +SEQ, QCARD1, R=DINEIN SUBROUTINE DINEIN (JSLGO,LPAT) C- Read the patch pointed to by LPAT into memory starting at JSLGO C. started 21-june-94 +CDE, ARRCOM, Q, PY. C-------------- End CDE -------------------------------- +SELF, IF=XDEBUG, IF=XDINEED. +CDE, SLATE. CHARACTER LINE*32 +SELF. IN_FD = IQ(LARRV+2) C-- position the file NSLSKI = IQ(LPAT+7) NTXSKI = IQ(LPAT+8) CALL CISEEK (IN_FD,NTXSKI,ISTAT) IF (ISTAT.NE.0) CALL P_KILLM ('CIO seek fails') C-- read the patch JSLA = JSLGO NSLN = IQ(LPAT+2) NTXN = IQ(LPAT+3) JTXA = MLIAD(JSLA) CALL CIGET (IN_FD,TEXT(JTXA),NTXN,NTXR,IN_EOF) IF (IN_EOF.NE.0) GO TO 93 JTXE = JTXA + NTXR IF (ICHAR(TEXT(JTXE-1)) .NE. NEWLN) THEN TEXT(JTXE) = CHAR(NEWLN) JTXE = JTXE + 1 NTXR = NTXR + 1 ENDIF IF (NTXR.NE.NTXN) GO TO 92 C-- construct the line directory JSLE = JSLA DO 26 JTXU=JTXA,JTXE-1 IF (ICHAR(TEXT(JTXU)) .EQ. NEWLN) THEN JSLE = JSLE + 1 MLIAD(JSLE) = JTXU + 1 ENDIF 26 CONTINUE IF (JSLE.NE.JSLA+NSLN) GO TO 91 +SELF, IF=XDEBUG, IF=XDINEED. CALL NA_GET (IQ(LPAT+4),LINE,1) PRINT 9826, LINE(1:NDSLAT),JSLA,JSLE,MLIAD(JSLA),MLIAD(JSLE) 9826 FORMAT (' -- load p=',A,' JSLA/JSLE=',2I6,' JTXA/JTXE=',2I8) +SELF. RETURN 91 CALL P_KILL ('Crash DINEIN: wrong number of lines') 92 CALL P_KILL ('Crash DINEIN: wrong number of characters') 93 CALL P_KILLM ('CIO read fails in DINEIN') END +SEQ, QCARDL. ===================================================== +DECK, DINEINF, IF=QFIO. +SEQ, QCARD1, R=DINEIN SUBROUTINE DINEIN (JSLGO,LPAT) C- Read the patch pointed to by LPAT into memory starting at JSLGO C. started 21-june-94 +CDE, ARRCOM, Q, PY. C-------------- End CDE -------------------------------- IN_LUN = IQ(LARRV+1) C-- position the file NSLSKI = IQ(LPAT+7) - IQ(LARRV+9) IF (NSLSKI.LT.0) THEN REWIND IN_LUN IQ(LARRV+9) = 0 NSLSKI = IQ(LPAT+7) ENDIF IF (NSLSKI.EQ.0) GO TO 24 DO 23 J=1,NSLSKI READ (IN_LUN,'(A)',END=93) 23 CONTINUE IQ(LARRV+9) = IQ(LARRV+9) + NSLSKI C-- read the patch 24 NSLN = IQ(LPAT+2) NTXN = IQ(LPAT+3) JSL = JSLGO JSLE = JSLGO + NSLN JTX = MLIAD(JSL) DO 26 JSL=JSLGO,JSLE-1 CALL ARRLN (IN_LUN,TEXT(JTX),NTX) IF (NTX.LT.0) GO TO 93 JTX = JTX + NTX 26 MLIAD(JSL+1) = JTX IF (JTX-MLIAD(JSLGO).NE.NTXN) GO TO 92 IQ(LARRV+9) = IQ(LARRV+9) + NSLN RETURN 92 CALL P_KILL ('Crash DINEIN: wrong number of characters') 93 CALL P_KILL ('Unexpected EoF in DINEIN') END +SEQ, QCARDL. ===================================================== +DECK, DICLFI. SUBROUTINE DICLFI (LFI) C- Reset all banks of all PAMs as out-of-memory C. started 3-june-94 +CDE, Q. C-------------- End CDE -------------------------------- +SELF, IF=XDEBUG, IF=XYDIFF. PRINT *, ' !!!! DICLFI entered for ',LFI +SELF. LF = LFI LP = LQ(LF-4) 22 IF (LP.EQ.0) RETURN IF (IQ(LP+1).EQ.0) GO TO 26 IQ(LP+1) = 0 LD = LQ(LP-4) 24 IF (LD.EQ.0) GO TO 26 IQ(LD+1) = 0 LD = LQ(LD-1) GO TO 24 26 LP = LQ(LP-1) GO TO 22 END +SEQ, QCARDL. ===================================================== C! +SEQ, bkYDIFF, IF=DOC_INL. +DECK, DILINK. SUBROUTINE DILINK (LOLD,LNEW,LEVEL,NLEN) C- Link NLEN banks, at least one, starting with LOLD/LNEW C- LEVEL = 0,1,2 for bank type DECK, PATCH, PAM C- if NLEN < 0: do not count the match (for proxy) C. started 16-june-94 +CDE, Q, PY, ADDDI. C-------------- End CDE -------------------------------- LX = LOLD LN = LNEW LEV = LEVEL NDO = NLEN +SELF, IF=QDEBUG. IF ((LEV.GT.2) .OR. (LEV.LT.0)) + CALL P_KILL ('LEVEL is faulty in DILINK') +SELF. 21 LQ(LX-2) = LN LQ(LN-2) = LX IQ(LN+5) = IQ(LX+5) IF (NDO.GT.0) NOBJMAT= NOBJMAT + 1 NDO = NDO - 1 IF (LEV.NE.0) GO TO 26 24 IF (NDO.LE.0) RETURN LX = LQ(LX-1) LN = LQ(LN-1) GO TO 21 C-- if a PAT bank has been linked, link also it blank deck C-- (similarly for PAM bank) 26 LXX = LX LNN = LN LVX = LEV 27 LXX = LQ(LXX-4) LNN = LQ(LNN-4) LQ(LXX-2) = LNN LQ(LNN-2) = LXX LVX = LVX - 1 IF (LVX.NE.0) GO TO 27 GO TO 24 END +SEQ, QCARDL. ===================================================== +DECK, DILOOK. SUBROUTINE DILOOK (LDX,LDN,NBIAS,LPX,LPN,LOW,NPCENT) C- Check that the 2 objects at LDX and LDN are the same to NPCENT C. started 6-june-94 +CDE, DIFFC. +CDE, Q, PY, ADDDI. C-------------- End CDE -------------------------------- NSLX = IQ(LDX+2) - NBIAS NSLN = IQ(LDN+2) - NBIAS NSL1 = MIN (NSLX,NSLN) NSL2 = MAX (NSLX,NSLN) IF (2*NSL1.LT.NSL2) GO TO 29 NSLM = NPCENT*NSL1 /100 IF (NSLM.LT.2) GO TO 29 IF (NSL1.NE.NSL2) THEN IF (NSLM.LT.LOW) GO TO 29 ENDIF IF (IQ(LPX+1).EQ.0) CALL DINEED (1,LPX) IF (IQ(LPN+1).EQ.0) CALL DINEED (2,LPN) JSLX = IQ(LDX+1) + NBIAS JSLN = IQ(LDN+1) + NBIAS CALL DIF_XQT (JSLX,NSLX, JSLN,NSLN, NSLM) IF (NSLM.EQ.0) GO TO 29 IF (NFAID.EQ.0) RETURN IF (NSLM.GE.LOW) RETURN 29 NFAID = -1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DINOUN. SUBROUTINE DINOUN (LUP) C- Check there are no unmatched banks depending on LUP left C. started 17-june-94 +CDE, QBITS19, Q. C-------------- End CDE -------------------------------- +SEQ, Q_AND, Q_OR. IF (IAND(IQ(LUP),KM2).NE.0) RETURN L = LQ(LUP-4) 24 L = LQ(L-1) IF (L.NE.0) THEN IF (LQ(L-2).EQ.0) RETURN GO TO 24 ENDIF IQ(LUP) = IOR (IQ(LUP),KM2) RETURN END +SEQ, QCARDL. ===================================================== +PATCH, DIF_XQT. Differencing subroutines +KEEP, DIFXC. PARAMETER (LGLIV=4, LGLIV2=8) COMMON /DIFXC/ JX_ORG, JY_ORG, NX_NLI, NY_NLI +, JX_FEND, JY_FEND, NLI_MAT +, JX_NTH, JX_JSL, JX_JTX, JX_NCH +, JY_NTH, JY_JSL, JY_JTX, JY_NCH +, LXV_FAI(LGLIV), LYV_FAI(LGLIV) +, LXV_SCA(LGLIV), LYV_SCA(LGLIV) +, LXV_MAT(LGLIV), LYV_MAT(LGLIV) +DECK, DOC, T=JOIN, IF=DOCUMENT, DOC_INL. +KEEP, xDIFXC. Difference processing, DIF_XQT and subsidiaries C- Parameters of the range for the "old" lines : C- JX_ORG slot number -1 of the first line of "old" C- NX_NLI total number of lines in range C- Parameters of the range for the "new" lines : C- JY_ORG slot number -1 of the first line of "new" C- NY_NLI total number of lines in range C- LGLIV=4 length of one line-vector JX_NTH, ... C- LGLIV2=8 length of the 2 contigous line-vetors JX_NTH / JY_NTH C- Parameters for the local matching process C- JX_FEND ordinal numbers of last lines of the C- JY_FEND current failure gap to be searched C- NLI_MAT length of the match found C- Line-vector of the current "old" line : C- JX_NTH ordinal number, = 1,2,...,NX_NLI C- JX_JSL JSL of current line C- JX_JTX JTX of current line C- JX_NCH number of characters in current line C- Line-vector of the current "new" line : C- JY_NTH, JY_JSL, JY_JTX, JY_NCH same C- Line-vectors of particular instances : C- LXV_FAI(LGLIV), LYV_FAI(LGLIV) start of current failure C- LXV_SCA(LGLIV), LYV_SCA(LGLIV) start of current scan C- LXV_MAT(LGLIV), LYV_MAT(LGLIV) start of match found +DECK, DIF_XQT. SUBROUTINE DIF_XQT (JSLX,NSLX, JSLY,NSLY, NQUICKP) C- Excute differencing, C- On entry: C- JSLX slot number in MLIAD of the first line on "old" C- NSLX number of lines on "old" C- JSLY, NSLY same for "new" C- C- NQUICK if not zero: C- quick test only to see if at least NQUICK lines do match, C- if not so: reset NQUICK to zero C- if so: leave NQUICK unchanged, C- return NFAID = 0: perfect match (identity) C- 1: good but not perfect C- On exit if NQUICK =zero on entry: C- Failure table in MFAID, from JFAIDA to JFAIDE-1, C- at the start of control division 2, NFAID entries; C- one entry of 5 words describes one failure : C- C- MFAID(JFAID + 0 : code -1 pure delete C- 0 delete / insert C- +1 pure insert C- + 1 : n of failure-start line for "old" C- + 2 : n of failure-start line for "new" C- + 3 : no. of lines deleted C- + 4 : no. of lines inserted C- Internal: C- Table of matching regions, one entry describes C- one set of matching lines: C- C- MGOOD(JGOOD + 0 : NM number of matching lines C- + 1 : JX ordinal number of first line on "old" C- + 2 : JY ... on "new" C- C- The first entry is at JGOOD = JGOODA C- the last entry is at JGOOD = JGOODE - 3 +CDE, QUNIT, MQCM, Q, PY, DIFFC, DIFXC. C-------------- End CDE ------------------- COMMON /SLATE/ NDSLAT,NESLAT,DUMMY(38) DIMENSION MGOOD(NSIZEQ), MHAVE(NSIZEQ), MFAID(NSIZEQ) EQUIVALENCE (MGOOD,IQ), (MHAVE,IQ), (MFAID,IQ) NQUICK = NQUICKP JX_ORG = JSLX - 1 JY_ORG = JSLY - 1 +SELF, IF=QDEBUG. IF (JX_ORG.LT.0 .OR. JY_ORG.LT.0) + CALL P_CRASH ('Faulty slot number in DIF_XQT') +SELF. NX_NLI = NSLX NY_NLI = NSLY LOWQ = LQCSTA(2) LIMQ = LQCSTA(3) JGOODA = LOWQ JHAVEE = LIMQ - 6 JFAIDA = LOWQ JFAIDE = JFAIDA NFAID = 0 +SELF, IF=XDEBUG, IF=XYDIFF. C WRITE (IQPRNT,9801) LIMQ-LOWQ, LOWQ, LIMQ 9801 FORMAT (/' Entry to DIF_XQT, table space of',I6,' words from', FI6,' to',I6) +SELF. +SEQ, QEJECT. C-------- Start, set up a first GOOD table ------- CALL DIF_LX (1) CALL DIF_LY (1) C-- Walk along to find the first failure CALL DIF_HEAD IF (NDSLAT.EQ.2) RETURN NFAID = 1 JGOOD = JGOODA NGOOD = JX_NTH - 1 MGOOD(JGOOD) = NGOOD MGOOD(JGOOD+1) = 1 MGOOD(JGOOD+2) = 1 JGOOD = JGOOD + 3 MGOOD(JGOOD) = 0 MGOOD(JGOOD+1) = NX_NLI + 1 MGOOD(JGOOD+2) = NY_NLI + 1 JGOODE = JGOOD + 3 IF (NDSLAT.NE.0) THEN NGOOD = NGOOD + 1 MGOOD(JGOODA) = NGOOD JHAVEA = JHAVEE - 6 CALL UCOPY (MGOOD(JGOODA),MHAVE(JHAVEA),6) GO TO 61 ENDIF MAXGAP = MIN (NX_NLI-JX_NTH, NY_NLI-JY_NTH) + 1 MIMAT = MIN (MAXGAP/2,128) MILILE = 14 IFTAIL = 0 C-------- Match, construct a new GOOD table -------------- 21 IF (NQUICK.NE.0) THEN IF (NGOOD.GE.NQUICK) RETURN ENDIF MIMAT = MIN (MIMAT,MAXGAP) IF (MIMAT.GE.8) THEN MIMAT = MIMAT/2 ELSE MIMAT = MIN(MIMAT,5) - 1 ENDIF +SELF, IF=XDEBUG, IF=XYDIFFTB. WRITE (IQPRNT,9827) WRITE (IQPRNT,9828) ((J-JGOODA)/3,MGOOD(J+1),MGOOD(J+2),MGOOD(J), + MGOOD(J+1)+MGOOD(J) , + MGOOD(J+2)+MGOOD(J) , + MGOOD(J+4)-(MGOOD(J+1)+MGOOD(J)), + MGOOD(J+5)-(MGOOD(J+2)+MGOOD(J)), + J=JGOODA,JGOODE-4,3) J = JGOODE-3 WRITE (IQPRNT,9828) (J-JGOODA)/3,MGOOD(J+1),MGOOD(J+2),MGOOD(J) IF (MIMAT.GE.0) WRITE (IQPRNT,9829) MAXGAP,MIMAT 9827 FORMAT (/ F' GOOD table: jgX jgY Ng jfX jfY del ins') 9828 FORMAT (2X,3I8,I6,2I8,2I6) 9829 FORMAT (' Start iteration',19X,'Maxgap=',I6,' MIMAT=',I4) +SELF. NWD = JGOODE - JGOODA JHAVEA = JHAVEE - NWD IF (JHAVEA.GT.JGOODE) THEN CALL UCOPY (MGOOD(JGOODA),MHAVE(JHAVEA),NWD) ELSE CALL UCOPY2 (MGOOD(JGOODA),MHAVE(JHAVEA),NWD) ENDIF IF (MIMAT.LT.0) GO TO 61 MAXGAP = 0 NGOOD = 0 JGOOD = JGOODA JHAVE = JHAVEA LMATX = 1 LMATY = 1 NMAT = MHAVE(JHAVE) JX_FEND = 0 JY_FEND = 0 GO TO 34 +SEQ, QEJECT. C------ Scan all failure regions C-- No new match, use the next pre-established match 31 LMATX = JX_FEND+1 LMATY = JY_FEND+1 NMAT = MATAFT C-- Is this match an extension of the previous? 32 N = MGOOD(JGOOD-3) NFX = LMATX - (MGOOD(JGOOD-2)+N) NFY = LMATY - (MGOOD(JGOOD-1)+N) IF (NFX.NE.0) GO TO 33 IF (NFY.NE.0) GO TO 33 MGOOD(JGOOD-3) = N + NMAT NGOOD = NGOOD + NMAT GO TO 36 C-- Record this match 33 MAXGAP = MAX (MAXGAP, MIN(NFX,NFY)) IF (JGOOD+4.GE.JHAVEA) GO TO 60 34 MGOOD(JGOOD) = NMAT MGOOD(JGOOD+1) = LMATX MGOOD(JGOOD+2) = LMATY JGOOD = JGOOD + 3 NGOOD = NGOOD + NMAT 36 LFAIX = LMATX + NMAT LFAIY = LMATY + NMAT C-- Moving into the next HAVE region? N = 0 IF (LFAIX.GT.JX_FEND) N= 1 IF (LFAIY.GT.JY_FEND) N= N+1 IF (N.EQ.0) GO TO 37 IF (N.EQ.1) GO TO 31 JHAVE = JHAVE + 3 IF (JHAVE.GE.JHAVEE) GO TO 49 MATAFT = MHAVE(JHAVE) JX_FEND = MHAVE(JHAVE+1) - 1 JY_FEND = MHAVE(JHAVE+2) - 1 C-- Is the failure gap too small to contain a possible match, C-- or is it too big for small MIMAT ? 37 NFAIX = JX_FEND+1 - LFAIX NFAIY = JY_FEND+1 - LFAIY NGAP = MIN (NFAIX, NFAIY) IF (NGAP.LE.MIMAT) GO TO 31 IF (MIMAT.LT.3) THEN NDIS = MAX (NFAIX, NFAIY) - NGAP N = 2*NDIS + NGAP IF (N.GE.24*(MIMAT+1)) GO TO 31 ENDIF C-- Find match, if any, in this failure gap CALL DIF_LX (LFAIX) CALL DIF_LY (LFAIY) CALL DIF_FMAT (MILILE,MIMAT) IF (NLI_MAT.EQ.0) GO TO 31 LMATX = LXV_MAT(1) LMATY = LYV_MAT(1) NMAT = NLI_MAT C-- Forward extension of imprecise match IF (MATAFT.LT.2) GO TO 32 LNNX = LMATX + NMAT LNNY = LMATY + NMAT IF (LNNX.NE.JX_FEND+1) THEN IF (LNNY.NE.JY_FEND+1) GO TO 32 ENDIF CALL DIF_SAME (LNNX,LNNY,IFSAME) IF (IFSAME.EQ.0) GO TO 32 NLEXT = 0 42 NLEXT = NLEXT + 1 IF (NLEXT.LT.MATAFT-1) THEN CALL DIF_NX CALL DIF_NY CALL DIF_SAME (JX_NTH, JY_NTH, IFSAME) IF (IFSAME.NE.0) GO TO 42 ENDIF NMAT = NMAT + NLEXT JX_FEND = JX_FEND + NLEXT JY_FEND = JY_FEND + NLEXT MATAFT = MATAFT - NLEXT GO TO 32 C-- End of this iteration 49 JGOODE = JGOOD IF (MIMAT.GT.9) GO TO 21 IF (IFTAIL.NE.0) GO TO 21 CALL DIF_TAIL (MGOOD(JGOODE-6)) IFTAIL = 7 GO TO 21 +SEQ, QEJECT. C-------- Convert MHAVE table to MFAID table -------------- 60 CONTINUE +SELF, IF=XDEBUG. WRITE (IQPRNT,9860) LIMQ-LOWQ 9860 FORMAT (/' Capacity exceeded in DIF_XQT, table space',I6,' words') +SELF. 61 IF (NQUICK.NE.0) THEN IF (NGOOD.LT.NQUICK) NQUICKP= 0 RETURN ENDIF JHAVEE = JHAVEE - 3 JHAVE = JHAVEA JFAID = JFAIDA 64 JCODE = 0 NMAT = MHAVE(JHAVE) JFGOX = MHAVE(JHAVE+1) + NMAT JFGOY = MHAVE(JHAVE+2) + NMAT NLDEL = MHAVE(JHAVE+4) - JFGOX NLINS = MHAVE(JHAVE+5) - JFGOY IF (NLINS.EQ.0) THEN JCODE = -1 ELSE IF (NLDEL.EQ.0) JCODE= 1 ENDIF MFAID(JFAID) = JCODE MFAID(JFAID+1) = JFGOX MFAID(JFAID+2) = JFGOY MFAID(JFAID+3) = NLDEL MFAID(JFAID+4) = NLINS JFAID = JFAID + 5 JHAVE = JHAVE + 3 IF (JHAVE.LT.JHAVEE) GO TO 64 JFAIDE = JFAID NFAID = (JFAIDE-JFAIDA) /5 +SELF, IF=XDEBUG, IF=XYDIFFTB. WRITE (IQPRNT,9878) WRITE (IQPRNT,9879) ((J-JFAIDA)/5,MFAID(J),MFAID(J+1),MFAID(J+2), + MFAID(J+3),MFAID(J+4),J=JFAIDA,JFAIDE-1,5) 9878 FORMAT (/' Failure table:'/ F' code jfX jfY del ins') 9879 FORMAT (I8,I5,2I8,2I6) +SELF. IF (JFAIDE.GT.LIMQ) CALL P_KILL ('Capacity exceeded') RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_HEAD. SUBROUTINE DIF_HEAD C- Find first failure between the two sets C- return NDSLAT = 0 failure found, the line vectors are positioned C- to the start of the failure C- 1 end of one of the sets found, the line vectors C- are positioned to the last matching line C- 2 the two sets are identical +CDE, Q, DIFXC. C-------------- End CDE ------------------- COMMON /SLATE/ NDSLAT,NESLAT,DUMMY(38) LOGICAL LN_EQU NDSLAT = 0 21 IF (JX_NCH.NE.JY_NCH) GO TO 29 IF (JX_NCH.EQ.0) GO TO 22 IF (.NOT.LN_EQU(TEXT(JX_JTX), TEXT(JY_JTX), JX_NCH)) GO TO 29 22 IF (JX_NTH.EQ.NX_NLI) GO TO 27 IF (JY_NTH.EQ.NY_NLI) GO TO 28 CALL DIF_NX CALL DIF_NY GO TO 21 27 NDSLAT = 1 IF (JY_NTH.NE.NY_NLI) GO TO 29 28 NDSLAT = NDSLAT + 1 29 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_TAIL, T=JOIN. SUBROUTINE DIF_TAIL (MGOOD) C- Check whether the very last lines of the 2 ranges match, C- on entry: MGOOD with the last 2 entries of the GOOD table C- on exit: MGOOD updated +CDE, DIFXC. C-------------- End CDE ------------------- DIMENSION MGOOD(6) IF (MGOOD(4).NE.0) RETURN NMAT = MGOOD(1) NLDEL = MGOOD(5) - (MGOOD(2) + NMAT) NLINS = MGOOD(6) - (MGOOD(3) + NMAT) NPOSS = MIN (NLDEL,NLINS) IF (NPOSS.EQ.0) RETURN CALL DIF_LX (NX_NLI) CALL DIF_LY (NY_NLI) CALL DIF_BACK (NPOSS,NMAT) IF (NMAT.EQ.0) RETURN MGOOD(4) = NMAT MGOOD(5) = JX_NTH MGOOD(6) = JY_NTH RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_FMAT. SUBROUTINE DIF_FMAT (MILILE, MIMATP) C- Find next matching lines, at leat MIMAT+1 lines C- with a length of MILILE or more columns C- On input: old/new JX_/JY_NTH positioned to the start of failure C- JX_FEND/Y last possible failing line C- On output: LXV_FAI/_YFAI param. of the start lines of failure C- LXV_MAT/_YMAT param. of the start lines of match C- NLI_MAT the length of this match, C- =0 : no match found +CDE, Q, DIFXC. C-------------- End CDE ------------------- LOGICAL LN_EQU CALL UCOPY (JX_NTH, LXV_FAI, LGLIV2) MILENGO = MILILE MIMAT = MIMATP MILENCO = MIN (MILENGO,9) NLI_MAT = 0 GO TO 16 C-- Step to first possible start lines 15 IF (JX_NTH.GE.JX_FEND) GO TO 81 CALL DIF_NX 16 IF (JX_NCH.LT.MILENGO) GO TO 15 GO TO 18 17 IF (JY_NTH.GE.JY_FEND) GO TO 81 CALL DIF_NY 18 IF (JY_NCH.LT.MILENGO) GO TO 17 CALL UCOPY (JX_NTH, LXV_SCA, LGLIV2) JHALTX = JX_FEND - MIMAT JHALTY = JY_FEND - MIMAT IF (JX_NTH.GT.JHALTX) GO TO 81 IF (JY_NTH.GT.JHALTY) GO TO 81 JENDY = JY_NTH GO TO 22 +SEQ, QEJECT. C---- Next X line, compare against Y lines so far 21 IF (JENDX.EQ.JHALTX) GO TO 31 CALL DIF_NX 22 JENDX = JX_NTH NCH = JX_NCH IF (NCH.LT.MILENGO) GO TO 31 CALL UCOPY (LYV_SCA, JY_NTH, LGLIV) GO TO 25 24 IF (JY_NTH.EQ.JENDY) GO TO 31 CALL DIF_NY 25 IF (JY_NCH.NE.NCH) GO TO 24 IF (.NOT.LN_EQU(TEXT(JY_JTX),TEXT(JX_JTX),NCH)) GO TO 24 GO TO 41 C---- Next Y line, compare against X lines so far 31 IF (JENDY.EQ.JHALTY) THEN IF (JENDX.NE.JHALTX) GO TO 21 GO TO 81 ENDIF CALL DIF_NY JENDY = JY_NTH NCH = JY_NCH IF (NCH.LT.MILENGO) GO TO 21 CALL UCOPY (LXV_SCA, JX_NTH, LGLIV) GO TO 35 34 IF (JX_NTH.EQ.JENDX) GO TO 21 CALL DIF_NX 35 IF (JX_NCH.NE.NCH) GO TO 34 IF (.NOT.LN_EQU(TEXT(JX_JTX),TEXT(JY_JTX),NCH)) GO TO 34 C-- Found first line of possible match 41 CALL UCOPY (JX_NTH, LXV_MAT, LGLIV2) NEXMAT = 0 NSAME = 0 42 NSAME = NSAME + 1 IF (JX_NTH.EQ.JX_FEND) GO TO 46 IF (JY_NTH.EQ.JY_FEND) GO TO 46 CALL DIF_NX CALL DIF_NY N = JX_NCH IF (JY_NCH.NE.N) GO TO 46 IF (N.EQ.0) GO TO 42 IF (.NOT.LN_EQU(TEXT(JX_JTX),TEXT(JY_JTX),N)) GO TO 46 IF (N.LT.MILENCO) GO TO 42 NEXMAT = NEXMAT + 1 GO TO 42 C-- Is the match is long enough ? 46 IF (NEXMAT.GE.MIMAT) GO TO 51 CALL DIF_LX (LXV_MAT(1) + NSAME -1) CALL DIF_LY (LYV_MAT(1) + NSAME -1) JENDX = MIN (MAX(JENDX,JX_NTH), JHALTX) JENDY = MIN (MAX(JENDY,JY_NTH), JHALTY) IF (JY_NTH.LT.JENDY) GO TO 24 IF (JX_NTH.LT.JENDX) GO TO 34 GO TO 21 C---- Match found 51 NLI_MAT = NSAME C-- Find identical short lines in front NPOSS = MIN (LXV_MAT(1)-LXV_FAI(1) +, LYV_MAT(1)-LYV_FAI(1)) IF (NPOSS.LE.0) GO TO 87 CALL UCOPY (LXV_MAT, JX_NTH, LGLIV2) CALL DIF_LX (JX_NTH-1) CALL DIF_LY (JY_NTH-1) CALL DIF_BACK (NPOSS,NPRE) IF (NPRE.NE.0) CALL UCOPY (JX_NTH, LXV_MAT, LGLIV2) NLI_MAT = NLI_MAT + NPRE C---- No match in the region 81 CONTINUE 87 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_BACK. SUBROUTINE DIF_BACK (NPOSSP,NMATP) C- Compare backwards the NPOSS > 0 lines from the current C- On entry: line vectors positioned to the first line to be checked C- On return: NMAT > 0 the number of matching lines found, C- line vectors positioned to the first C- line of the match C- NMAT = 0 no match, line vectors unchanged +CDE, DIFXC. C-------------- End CDE ------------------- NPOSS = NPOSSP NMAT = 0 CALL DIF_SAME (JX_NTH, JY_NTH, IFSAME) IF (IFSAME.EQ.0) GO TO 28 C-- Current lines match 24 NMAT = NMAT + 1 NPOSS = NPOSS - 1 IF (NPOSS.EQ.0) GO TO 28 C-- How about the previous? CALL DIF_SAME (JX_NTH-1, JY_NTH-1, IFSAME) IF (IFSAME.NE.0) GO TO 24 C-- Not equal, position to start of match CALL DIF_NX CALL DIF_NY 28 NMATP = NMAT RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_SAME, T=JOIN. SUBROUTINE DIF_SAME (NTHX,NTHY,NMAT) C- Compare the 2 lines NTHX and NTHY, C- return: NMAT = 0/1 for no/yes +CDE, Q, DIFXC. C-------------- End CDE ------------------- LOGICAL LN_EQU IF (JX_NTH.NE.NTHX) CALL DIF_LX (NTHX) IF (JY_NTH.NE.NTHY) CALL DIF_LY (NTHY) N = JX_NCH IF (JY_NCH.EQ.N) THEN IF (N.EQ.0) GO TO 24 IF (LN_EQU(TEXT(JX_JTX),TEXT(JY_JTX),N)) GO TO 24 ENDIF NMAT = 0 RETURN 24 NMAT = 1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_LX. SUBROUTINE DIF_LX (LNO) C- Set the current to be ordinal line number LNO, C- but not beyond the last line NX_NLI +CDE, Q, DIFXC. C-------------- End CDE ------------------- JX_NTH = MIN (LNO, NX_NLI) JX_JSL = JX_NTH + JX_ORG JX_JTX = MLIAD(JX_JSL) JX_NCH = MLIAD(JX_JSL+1) - JX_JTX - NCHNEWL RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_LY, T=JOIN. SUBROUTINE DIF_LY (LNO) C- Set the current to be ordinal line number LNO, C- but not beyond the last line NY_NLI +CDE, Q, DIFXC. C-------------- End CDE ------------------- JY_NTH = MIN (LNO, NY_NLI) JY_JSL = JY_NTH + JY_ORG JY_JTX = MLIAD(JY_JSL) JY_NCH = MLIAD(JY_JSL+1) - JY_JTX - NCHNEWL RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_NX. SUBROUTINE DIF_NX C- Step the current line on "old" by +1 +CDE, Q, DIFXC. C-------------- End CDE ------------------- JX_NTH = JX_NTH + 1 JX_JSL = JX_NTH + JX_ORG JX_JTX = MLIAD(JX_JSL) JX_NCH = MLIAD(JX_JSL+1) - JX_JTX - NCHNEWL RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIF_NY, T=JOIN. SUBROUTINE DIF_NY C- Step the current line on "new" by +1 +CDE, Q, DIFXC. C-------------- End CDE ------------------- JY_NTH = JY_NTH + 1 JY_JSL = JY_NTH + JY_ORG JY_JTX = MLIAD(JY_JSL) JY_NCH = MLIAD(JY_JSL+1) - JY_JTX - NCHNEWL RETURN END +SEQ, QCARDL. ===================================================== +PATCH, YSHELL. for program Nyshell +USE, AUXSM. +SELF. +DIVERT, AUXSM, D=SMRXQT. !!!! to test Nyshell +SELF. +DIVERT, AUXSM, D=SMCODE. +KEEP, SHMKC. PARAMETER (NTYSZ=4, NACSZ=4, NLNSZ=4, NRTSZ=10000) CHARACTER CHNLOG*80, CODEX*8, CHTYP*8 COMMON /SHMKC/ NNLOG,CHNLOG, CODEX, CHTYP(17) +KEEP, ADDSH. +, NLINST(4,NACSZ,NTYSZ), IXINST(NLNSZ,4,NACSZ,NTYSZ) +, NCOUNTR(4,NTYSZ), NCSUMR(NTYSZ) +, NCOUNTH(4,NTYSZ), NCSUMH(NTYSZ), IXOPTN(4,3), IXOPTP(4,3) +, NRXQT, NROUT, NNAME(NRTSZ), NRALLC, NRDEL +, LUNSH, IXOBJ, IXSDIR, JXTYP, JXACT, JXSTR, LASTSH +DECK, DOC, T=JOIN, IF=DOCUMENT, DOC_INL. +KEEP, xADDSH. C-- Parameters of NYSHELL C- NTYSZ=4 dimensions of IXINST C- NACSZ=4 C- NLNSZ=4 C- C- NRTSZ=10000 dimension of NNAME C- C- NNLOG number of significant characters in CHNLOG C- CHNLOG file-name part of the input file C- CODEX last code like "fort:3" analysed by SMCODE C- CHTYP(17) list of type-codes, see SMCODE C- C- NLINST(4,NACSZ,NTYSZ) number of lines in each item C- IXINST(NLNSZ,4,NACSZ,NTYSZ) set-up description C- C: IXINST(JLINE,JSTR,JACT,JTYP) IX of one compile-instruction line C- C- JTYP= 1 fortran, 2 C, 3 assembler, 4 start/end C- C- JACT= 1 for fo:i, co:i, ao:i, start:i specific options C- 2 for fopt, copt, aopt, start common options C- 3 for fc, cc, as, end: compiler name C- 4 for fort:i, cc:i, as:i, end command line C- C- JSTR= i of fo:i, co:i, ..., fort:i, cc:i, etc C- C- JLINE= 1, 2, ..., NLINST(JSTR,JACT,JTYP) C- C- IXOPTN(JSTR,JTYP) joined compiler options for this run C- IXOPTP(JSTR,JTYP) joined compiler options from .xqtlog C- C- NCOUNTR(4,NTYSZ) count number of routines to be compiled per stream C- NCSUMR(NTYSZ) count number of routines to be compiled per type C- C- NCOUNTH(4,NTYSZ) count number of routines seen per stream C- NCSUMH(NTYSZ) count number of routines seen per type C- C- NRXQT number of routines from .xqtlog in store C- NROUT number of routines in store C- J = 1,NRXQT routines from .xqtlog C- J = NRXQT+1,NROUT routines from .log C- NNAME(NRTSZ) routine descriptors: C- C: NNAME(JR) = ((IXNAME*8 + JTYP)*8 + JSTR)*4 + IFLNEW C- C- IXNAME index of the routine name C- JTYP routine type: Fortran, C, AS C- JSTR stream: 1 normal/normal C- 2 normal/divert C- 3 extra/normal C- 4 extra/divert C- IFLNEW has bit 2 set if current .o file valid C- bit 1 set if recompilation forced C- C- NRALLC number of routines to be compiled C- NRDEL number of .o files deleted by SHUPTO C- LUNSH logical unit number for writing xxx.shfca C- IXOBJ IX of the .o file extension, C- ".o" on UNIX, ".OBJ" on VAX C- IXSDIR IX of the source-files directory C- C- JXTYP type, action, stream of CODEX cracked by SMCODE C- JXACT C- JXSTR C- C- LASTSH last word for use with INIAUX/MQWORK +DECK, NSHELL. PROGRAM NSHELL +SELF, IF=QDIAG, IF=QS_UNIX. EXTERNAL SEGVIOL +SELF. +SEQ, NCNAME. PARAMETER (NFILES=4) CHARACTER NAME(NFILES)*(NCNAME) DATA NAME/ 'LOG .log 9 2 0 !ff' +, 'opt 3 11 0 !ff' +, 'read .cra 1 1 2 !ff' +, 'print .lis 2 4 0 !ff' / C- _:.=+=.:_1_:.=+=.:_2_:.=+=.:_3_: C- (1) (2) (3) C- (1) LUNUSE = 1 read, 2 print, C- 3 option, 4 cch subst, >4 file C- (2) LUNDES = 1 cradle input C- 2 PAM input C- 4 printed output C- 5 Fortran output C- 6 ASM output write-only (T=ATT) C- 7 ASM input-output (T=MODIF) C- 11 option parameter C- 12 control-character substitution parameter C- (3) LUNFLG = 0/>0 parameter value EOF not/yes allowed C- 2 the cradle file need not exist +SELF, IF=QS_IBMVM. NAME(4)(9:16) = '.listing' +SELF. CALL MQINIT CALL FLPARA (NFILES,NAME, + 'Nyshell All, By, Empty, Help, Quick, HSetup, Uptodate, Verbose') +SELF, IF=QDIAG, IF=QS_UNIX. CALL SIGNALF (11, SEGVIOL, -1) +SELF. CALL EXSHELL +SEQ, PGMSTOP, T=PASS. END +SEQ, QCARDL. ===================================================== +DECK, EXSHELL. SUBROUTINE EXSHELL C- Run nyshell C. started 20-jan-94 +CDE, SLATE, QBITA31, QUNIT. +CDE, LUNSLN, FLINKC. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER CHFSH*64, CHFIN*128, CHNAME*32, CHDO*2 PARAMETER (MASK= KMA + KMB + KME + KMH + KMQ + KMS + KMU + KMV) +SEQ, Q_AND, Q_SHIFTR. CALL INIAUX (LASTSH) CALL KROPT (IXLUN(2),MASK) MOPTIO(2) = MAX (MOPTIO(1), MOPTIO(2)) +SELF, IF=TRANSIT. MOPTIO(5) = 1 +SELF. IXFILE = IXLUN(1) IF (IXFILE.LE.0) IXFILE = NA_LONG (' f.e') CALL FLSPLIT (IXFILE, IXSDIR, IXSFN, IXSEXT) CHNLOG = ' ' CALL NA_GET (IXSFN,CHNLOG,1) NNLOG = NDSLAT CHFIN = ' ' CALL NA_GET (IXFILE,CHFIN,1) NCHFIN = NDSLAT IF (MOPTIO(8).NE.0) IXLUN(1) = -7 +SEQ, QEJECT. C---- Load the defaults CALL SMDEF +SELF, IF=QS_UNIX. CALL SMCIL (-1, 'start' , '# Script from nyshell for file ' + // CHFIN(1:NCHFIN)) CALL SMCIL (-1, 'end' , '# End of the shell script') +SELF, IF=QS_VMS. CALL SMCIL (-1, 'start', '$! shfca:') CALL SMCIL (0, ' ', + '$ proc_ver = f$environment("verify_procedure")') CALL SMCIL (0, ' ', + '$ imag_ver = f$environment("verify_image")') CALL SMCIL (0, ' ', '$ set verify=(procedure,noimage)') CALL SMCIL (-1, 'end', '$ temp=f$verify(proc_ver,imag_ver)') +SELF. C---- Load the compile-instructions from the cradle IF (IQREAD.NE.0) CALL SMCINST IF (IQREAD.LT.0) IXLUN(1)= -1 C---- Pre-delete the script yyy.shfca +SELF, IF=QS_IBMVM. CHFSH = CHNLOG(1:NNLOG) // '.exec' NCHFSH = NNLOG + 5 +SELF, IF=-QS_IBMVM. CHFSH = CHNLOG(1:NNLOG) // '.shfca' NCHFSH = NNLOG + 6 +SELF. LUNSH = 21 CHLIFI = CHFSH(1:NCHFSH) NLIFI = NCHFSH CALL FLINK (LUNSH, -1, 0, 0) C---- Print the Help information IF (IXLUN(1).LE.0) THEN IF (MOPTIO(19).EQ.0) THEN WRITE (IQPRNT,9002) WRITE (IQPRNT,9003) WRITE (IQPRNT,9004) WRITE (IQPRNT,9005) WRITE (IQPRNT,9006) WRITE (IQPRNT,9007) ENDIF MOPTIO(17) = 0 MOPTIO(22) = 1 ENDIF C---- Print the run information WRITE (IQPRNT,9026) CHFIN(1:NCHFIN), CHFSH(1:NCHFSH) +, CHNLOG(1:NNLOG) 9026 FORMAT (' Input file: ',A F/ ' Shell script: ',A F/ ' Log file: ',A,'.xqtlog') IF (MOPTIO(17).NE.0) GO TO 29 WRITE (IQPRNT,9027) 9027 FORMAT (/' Actual set-up used:') CALL SMDISP (4) DO 28 JTYP=1,3 CALL SMDISP (JTYP) 28 CONTINUE CALL SMDISP (5) CALL SMDISP (6) 29 IF (IXLUN(1).LE.0) GO TO 81 C---- Load the .xqtlog and .log files with the routine names CALL SMJOPT IF (MOPTIO(21).NE.0) THEN IF (MOPTIO(2).EQ.0) CALL SMRXQT ENDIF CALL SMRLOG +SELF, IF=QS_UNIX, QS_VMS. C---- Delete all .o files which are not part of the program IF (MOPTIO(21).NE.0) CALL SHUPTO +SELF, IF=QS_VMS. C-- Fix parameters on the command lines for the VAX CALL SHFIXP +SELF. +SEQ, QEJECT. C------ Write the shell script ------------------ C-- open the .shfca file CHLIFI = CHFSH(1:NCHFSH) NLIFI = NCHFSH CALL FLINK (LUNSH, 5, 0, 0) C-- write the script header CALL SHWSTA (1) IF (NRALLC.EQ.0) GO TO 49 C-- write the compile instructions for each file C- NNAME(JR) = ((IXNAME*8 + JXTYP)*8 + JXSTR)*4 + IFLNEW C- IFLNEW has bit 2 set if .o file exists C- bit 1 set if recompilation forced DO 47 JRT=NRXQT+1,NROUT JJ = NNAME(JRT) IF (IAND(JJ,3).EQ.2) GO TO 47 JJ = ISHFTR(JJ,2) JSTR = IAND (JJ,7) JJ = ISHFTR (JJ,3) JTYP = IAND (JJ,7) IXNA = ISHFTR (JJ,3) CALL NA_GET (IXNA, CHNAME, 1) NN = NDSLAT CALL SHWCOMP (JTYP,JSTR, CHNAME(1:NN)) 47 CONTINUE C-- write the apreslude CALL SHWSTA (2) 49 CLOSE (LUNSH) +SELF, IF=QS_UNIX. CALL SYSTEMF ('chmod 755 *.shfca') +SELF. C---- Print the summary WRITE (IQPRNT,9053) IF (NRALLC.EQ.0) GO TO 57 CHDO = 'Do' JA = 4 DO 54 JT=1,3 DO 53 JS=1,4 N = NCOUNTR(JS,JT) IF (N.EQ.0) GO TO 53 CHNAME(1:8) = ' ' CALL SMSID (JT,JS,CHNAME,1) WRITE (IQPRNT,9053) CHDO,N,CHNAME(1:6) 9053 FORMAT (6X,A,I5,' files for ',A) CHDO = ' ' 53 CONTINUE 54 CONTINUE C---- Write the new .xqtlog file 57 CALL SHWXQT IF (NRALLC+NRDEL.EQ.0) GO TO 94 C---- Done IF (MOPTIO(21).EQ.0) RETURN IF (MOPTIO(22).EQ.0) THEN IF (NRDEL.EQ.0) RETURN ENDIF CALL NA_GET (IXOBJ, CHNAME,1) NC = NDSLAT WRITE (IQPRNT,9057) NRDEL, CHNAME(1:NC) 9057 FORMAT (8X,I5,' orphan ',A,' files deleted') RETURN +SEQ, QEJECT. 9002 FORMAT (' nyshell x.log options read print'/ F/' translates the nypatchy output file x.log for SPLIT or MODIFY' F/' mode into the shell-script x.shfca to compile the wanted' F/' routines as specified by the options, and according to the' F/' compilation rules defined by the "set-up". Nyshell has a' F/' default set-up which can be modified by the user with control' F/' lines given on the "read" stream. Nyshell writes the script' F/' x.shfca and also the file x.xqtlog recording the state which' F/' should be achieved with this run, to be used in the next run.'/ F/' Nyshell and the resulting script x.shfca must be run in the' F/' directory where the resulting .o files are to be.'/ F/' "options": A all - compile or re-compile all files' F/' B bypass the use of the input .xqtlog file' F/' E empty - bypass the .xqtlog file if it is empty' F/' H help - print this help information only' F/' Q quick - do not display the set-up information' F/' U uptodate - check that all .o files in the' F/' current directory are ready to be' F/' put into the last-version library' F/' V verbose - display the complete set-up.') 9003 FORMAT ( F ' "read": name of the file with the user set-up commands,' F/' tty if standard input to be used,' F/' eof if default set-up to be used as is.' F/' "print" printed output file.'/ F/' The set of routines to be handled is defined by the log file.' F/' If the "A" option is given all routines are to be compiled.' F/' If the "U" option is not given only the routines which do not' F/' have the "same" flag on the log are to be compiled.' F/' If the "U" option is given nyshell will make sure that all' F/' the .o files are up-to-date: a routine does not need' F/' recompilation only if it meets all these criteria:' F/' 1) the "same" flag is present,' F/' 2) the compiler options are the same as last time,' F/' 3) a re-compilation ordered last time has been done,' F/' 4) the .o file is more recent than the .f file,' F/' 5) the .o file is more recent than any .h file called.' F/' Also: delete all .o files in the current directory whose' F/' names to not appear in the log file.') 9004 FORMAT ( F/' Set-up commands, given on "read", may be used to modify' F/' the default set-up. The "tag", starting before column 7,' F/' identifies the set-up parameter to be changed.' F/' An empty tag signals a continuation line. The text after' F/' gives the new content.' F/' The commands which would generate the set-up used will be' F/' printed at the end, unless the Quick option has been given.' F/' These are the possible set-up commands:'//' for Fortran:'/ F/' fo:1 options special to stream :1' F/' fo:2 to stream :2' F/' fo:3 to stream :3' F/' fo:4 to stream :4' F/' fopt compiler options common to all streams' F/' fc the name of the Fortran compiler' F/' fort:1 command to compile a file for stream :1' F/' fort:2 for stream :2' F/' fort:3 for stream :3' F/' fort:4 for stream :4') 9005 FORMAT (/' for the C language:'/ F/' co:1 options special to stream :1' F/' co:2 to stream :2' F/' co:3 etc.' F/' copt compiler options common to all streams' F/' cc the name of the C compiler' F/' cc:1 command to compile a file for stream :1' F/' cc:2 for stream :2' F/' cc:3 etc.'/ F/' for the assembler:'/ F/' ao:1 options special to stream 1' F/' ao:2 etc.' F/' aopt assembler options common to all streams' F/' as the name of the assembler' F/' as:1 command to assemble a file for stream :1' F/' as:2 etc.') 9006 FORMAT (/' start and end of the shell-script:'/ F/' start shell commands ahead' F/' end shell commands added at the end'/ F/' where-abouts of the source files:'/ F/' sdir name, default is directory part of the input file' F/' (normally this is empty, ie. the current w.dir.)') 9007 FORMAT ( F/' The special set-up parameter "by" for fort:i, cc:i, as:i' F/' requests not to compile the files of this stream.' F/' The special set-up parameter "=:1", for example, given' F/' for fort:i, cc:i, as:i requests the files of this stream' F/' to be processed as for stream :1.' F/' Given for fo:i, co:i, as:i it is a request to use for this' F/' stream the same options as for stream :1.'/ +SELF, IF=QS_UNIX. F/' Nyshell converts the set-up parameters into shell parameters' F/' and puts their definitions at the beginning of the script.'/ F/' Status returned by nyshell on Unix is =0 normally,' F/' =1 for zero routines to be recompiled, >1 for bad data.'/) +SELF, IF=QS_VMS. F/' Status returned by nyshell on VAX is =1 normally,' F/' =9 for zero routines to be recompiled, 4 for bad data.'/) +SELF, IF=QS_IBMVM. F/' Status returned by nyshell on IBM/VM is =0 normally,' F/' =1 for zero routines to be recompiled, 8 for bad data.'/) +SELF. C---- Trouble 81 IF (IXLUN(1).EQ.0) THEN WRITE (IQPRNT,9080) ELSEIF (IXLUN(1).EQ.-1) THEN WRITE (IQPRNT,9081) ENDIF CALL EXITRC (2) 9080 FORMAT (/' ***!!! No file-name given, no execution !!!***') 9081 FORMAT (/' ***!!! Errors on input, no execution !!!***') 9094 FORMAT (/' **!! Zero routines to be compiled !!**') 9095 FORMAT (/' **!! No routines to be compiled or deleted !!**') 94 IF (MOPTIO(21).EQ.0) THEN WRITE (IQPRNT,9094) ELSE WRITE (IQPRNT,9095) ENDIF CALL EXITRC (1) END +SEQ, QCARDL. ===================================================== +DECK, SHUPTO, IF=QS_UNIX, QS_VMS. SUBROUTINE SHUPTO C- For Uptodate mode: get the names of all .o files, C- check each to be in the .log list, if not delete it C. started 4-feb-94 +CDE, SLATE, SLATLN, FLINKC, QUNIT. +CDE, MQCM. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINE*64 EQUIVALENCE (LINE, SLLINE) INTEGER SYSTEMF +SEQ, Q_AND, Q_SHIFTR. CALL UNLINKF ('temp_dir.fca') IXTEMP = NA_LONG ('temp_dir.fca') +SELF, IF=QS_UNIX. LINE = 'ls *.o >' C- _:.=+=.: 1_: CALL NA_GET (IXTEMP, LINE,10) N = NESLAT - 1 ISTAT = SYSTEMF (LINE(1:N)) +SELF, IF=QS_VMS. CALL UNLINKF ('temp_com.fca') OPEN (LUNSH,FILE='temp_com.fca',STATUS='UNKNOWN') WRITE (LUNSH,9007) 9007 FORMAT ('$! ''f$verify(0)'' ' F/'$ purge/nolog/noconfirm *.obj' F/'$ dir*ectory :=' F/'$ directory/col=1/width=file=32/output=temp_dir.fca *.obj') CLOSE (LUNSH) ISTAT = SYSTEMF ('@temp_com.fca') CALL UNLINKF ('temp_com.fca') +SELF, IF=XDEBUG, IF=XYSHELL. IF (ISTAT.NE.0) WRITE (IQPRNT,9019) ISTAT 9019 FORMAT (' Dbg SHUPTO: SYSTEMF returns status ',Z8,' hex') +SELF. CALL INIPAM (11, IXTEMP, 0,2) IF (IXFLUN.LT.0) GO TO 59 20 LQLEND(2) = LQLSTA(2) IQ(LQHOLD+2) = 0 CALL ARRIVE (3) +SELF, IF=XDEBUG, IF=XYSHELL. WRITE (IQPRNT,9020) IQ(LQHOLD+2) 9020 FORMAT (' Dbg SHUPTO: ',I6,' lines to read from temporary') +SELF. +SEQ, QEJECT. C---- Do next line JSLIN = IQ(LQHOLD+1) - 1 NSLIN = IQ(LQHOLD+2) JSLEND = JSLIN + NSLIN 21 JSLIN = JSLIN + 1 IF (JSLIN.GT.JSLEND) GO TO 49 CALL LN_GET (JSLIN,LINE,512) NXX = NDSLAT IF (NXX.EQ.0) GO TO 21 +SELF, IF=XDEBUG, IF=XYSHELL, IF=XDETAILDB. PRINT *, ' line: ',LINE(1:NXX) +SELF. NXX = LNBLNK (LINE(1:NXX)) IF (NXX.EQ.0) GO TO 21 C-- get the routine name JNA = ICNEXT (LINE,1,NXX) JNE = NESLAT - 1 +SELF, IF=QS_UNIX. IF (LINE(JNE-1:JNE).NE.'.o') GO TO 21 JNN = JNE - 2 +SELF, IF=QS_VMS. CALL CUTOL (LINE(JNA:JNE)) JNE = ICFIND (';', LINE,JNA,JNE) - 1 IF (LINE(JNE-3:JNE).NE.'.obj') GO TO 21 JNN = JNE - 4 +SELF. IF (JNN.LT.JNA) GO TO 21 IXU = NA_LONG (LINE(JNA:JNN)) C-- find this name in the list of routines C- NNAME(JR) = ((IXNAME*8 + JXTYP)*8 + JXSTR)*4 + IFLNEW DO 24 JR=NRXQT+1,NROUT MM = NNAME(JR) IXN = ISHFTR (MM,8) IF (IXN.EQ.IXU) THEN IF (IAND(MM,3).EQ.2) GO TO 21 GO TO 27 ENDIF 24 CONTINUE NRDEL = NRDEL + 1 C-- delete .o file if not in the list, if to be re-compiled 27 CALL UNLINKF (LINE(JNA:JNE)) IF (MOPTIO(22).EQ.0) GO TO 21 WRITE (IQPRNT,9028) LINE(JNA:JNE) 9028 FORMAT (7X,'delete file ',A) GO TO 21 C---- Done 49 IF (JDKNEX.LT.4) GO TO 20 CALL INIPAM (0,0, -1,0) 59 CALL UNLINKF ('temp_dir.fca') RETURN END +SEQ, QCARDL. ===================================================== +DECK, SHFIXP, IF=QS_VMS. SUBROUTINE SHFIXP C- Parameter substitution in the command lines for VAX C. started 22-feb-94 +CDE, SLATE, SLATLN. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINE*512, SDIR*128 CHARACTER CONAME*128, COOPT*256, LINEWK*640 COMMON /CHSLAT/ CONAME, COOPT, LINEWK EQUIVALENCE (LINE,SLLINE), (SDIR,SLERRM) CHARACTER TKNAME*5, TKOPT*7 CHARACTER CHT(3)*1, CHC(3)*2, CHS(4)*1 DATA CHT / 'F', 'C', 'A' / DATA CHC / 'FC', 'CC', 'AS' / DATA CHS / '1', '2', '3', '4' / C-- ready the string to be substituted for ${s} CALL NA_GET (IXSDIR, SDIR,1) NSDIR = NDSLAT IF (IXSDIR.NE.0) CALL FTOVAX (SDIR,NSDIR) C-------- Do all types DO 49 JTYP=1,3 IF (NCSUMR(JTYP).EQ.0) GO TO 49 C-- ready compiler name for this type TKNAME = '${' // CHC(JTYP) // '}' IXU = IXINST(1,1,3,JTYP) CALL NA_GET (IXU,CONAME,1) NNM = NDSLAT C-- ready compiler option mask for this type TKOPT = '${' // CHT(JTYP) // 'O_x}' C- _: . =+=. +SEQ, QEJECT. C------ Do all streams of this type 31 DO 48 JSTR=1,4 IF (NCOUNTR(JSTR,JTYP).EQ.0) GO TO 48 NLINES = NLINST(JSTR,4,JTYP) IF (NLINES.EQ.0) GO TO 48 TKOPT(6:6) = CHS(JSTR) CALL NA_GET (IXOPTN(JSTR,JTYP),COOPT,1) NOPT = NESLAT - 1 C-- all lines of this stream DO 47 JLINE=1,NLINES JTX = NA_JTX (IXINST(JLINE,JSTR,4,JTYP)) NTX = NDSLAT C-- replace source directory CALL CCOSUB (TEXT(JTX),NTX, LINE,1,512, + '${s}', SDIR(1:NSDIR)) NTX = NDSLAT C-- replace compiler name CALL CCOSUB (LINE,NTX, LINEWK,1,512, + TKNAME, CONAME(1:NNM)) IF (NGSLAT.NE.0) THEN NTX = NDSLAT LINE(1:NTX) = LINEWK(1:NTX) ENDIF C-- replace compiler options CALL CCOSUB (LINE,NTX, LINEWK,1,512, + TKOPT, COOPT(1:NOPT)) IF (NGSLAT.NE.0) THEN NTX = NDSLAT LINE(1:NTX) = LINEWK(1:NTX) ENDIF IXINST(JLINE,JSTR,4,JTYP) = NA_LONG (LINE(1:NTX)) 47 CONTINUE 48 CONTINUE 49 CONTINUE C------ Replace the source-directory in the start/end text JTYP = 4 DO 59 JACT=1,4 DO 58 JSTR=1,4 NLINES = NLINST(JSTR,JACT,JTYP) IF (NLINES.EQ.0) GO TO 58 DO 57 JLINE=1,NLINES JTX = NA_JTX (IXINST(JLINE,JSTR,JACT,JTYP)) NTX = NDSLAT CALL CCOSUB (TEXT(JTX),NTX, LINE,1,512, + '${s}', SDIR(1:NSDIR)) IF (NGSLAT.NE.0) THEN NTX = NDSLAT IXINST(JLINE,JSTR,JACT,JTYP) = NA_LONG (LINE(1:NTX)) ENDIF 57 CONTINUE 58 CONTINUE 59 CONTINUE RETURN END +SEQ, QCARDL. ===================================================== +DECK, SHWSTA. SUBROUTINE SHWSTA (JDO) C- Output of shell-commands for "start" and "end" C- JDO = 1 start of the script C- 2 end of the script C. started 20-jan-94 +CDE, SLATE, SLATLN. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINEWK*524 EQUIVALENCE (LINEWK,SLLINE) C---- Write part 1 of the end text JTYP = 4 JACT = 3 IF (JDO.NE.1) GO TO 21 C---- Write part 1 of the start text +SELF, IF=QS_UNIX. WRITE (LUNSH,9020) 9020 FORMAT ('#!/bin/csh -f') +SELF. JACT = 1 C---- Send the CIL lines to the shell script 21 DO 38 JSTR=1,4 NLINES = NLINST(JSTR,JACT,JTYP) IF (NLINES.EQ.0) GO TO 38 DO 37 JLINE=1,NLINES CALL NA_GET (IXINST(JLINE,JSTR,JACT,JTYP), LINEWK,1) JE = NESLAT - 1 WRITE (LUNSH,9036) LINEWK(1:JE) 9036 FORMAT (A) 37 CONTINUE 38 CONTINUE IF (JACT.EQ.2) RETURN IF (JACT.EQ.4) RETURN C---- Write part 2 of the start or end text JACT = JACT + 1 +SELF, IF=QS_UNIX. IF (JACT.EQ.2) CALL SHWPAR +SELF. GO TO 21 END +SEQ, QCARDL. ===================================================== +DECK, SHWPAR, IF=QS_UNIX. SUBROUTINE SHWPAR C- Output of the parameter-defining statements for Unix C. started 22-feb-94 +CDE, SLATE, SLATLN. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINEWK*256, COLWK(256)*1 EQUIVALENCE (LINEWK,SLLINE), (COLWK,SLLINE) CHARACTER CHT(3)*1, CHS(4)*1, CHC(3)*2 DATA CHT / 'F', 'C', 'A' / DATA CHC / 'FC', 'CC', 'AS' / DATA CHS / '1', '2', '3', '4' / 21 LINEWK = 'set FILE = ' // CHNLOG(1:NNLOG) C- _:.=+=.: 1_:.=+= N = NNLOG + 12 WRITE (LUNSH,9000) LINEWK(1:N) LINEWK = 'set s = "' C- _:.=+=.: 1_:.=+= CALL NA_GET (IXSDIR, LINEWK, 13) N = NESLAT COLWK(N) = '"' WRITE (LUNSH,9000) LINEWK(1:N) 9000 FORMAT (A) C------ All data-types, all active streams DO 49 JTYP=1,3 IF (NCSUMR(JTYP).EQ.0) GO TO 49 DO 48 JSTR=1,4 IF (NCOUNTR(JSTR,JTYP).EQ.0) GO TO 48 C-- define the compiler options LINEWK = 'set xO_y = " ' C- _:.=+=.: 1_:.=+= COLWK(5) = CHT(JTYP) COLWK(8) = CHS(JSTR) IX = IXOPTN(JSTR,JTYP) CALL NA_GET (IX,LINEWK,13) N = NESLAT COLWK(N) = '"' WRITE (LUNSH,9000) LINEWK(1:N) 48 CONTINUE C-- define the compiler name JACT = 3 LINEWK = 'set xx = "' C- _:.=+=.: 1_:.=+= LINEWK(5:6) = CHC(JTYP) IX = IXINST(1,1,JACT,JTYP) CALL NA_GET (IX,LINEWK,13) N = NESLAT COLWK(N) = '"' WRITE (LUNSH,9000) LINEWK(1:N) 49 CONTINUE RETURN END +SEQ, QCARDL. ===================================================== +DECK, SHWCOMP. SUBROUTINE SHWCOMP (JTYP,JSTR,XNAME) C- Output of the shell-command for routine name XNAME C. started 20-jan-94 +CDE, SLATE, SLATLN. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER XNAME*(*) CHARACTER LINEWK*512, COLWK(512)*1 EQUIVALENCE (LINEWK,SLLINE), (COLWK,LINEWK) JACT = 4 NLINE = NLINST(JSTR,JACT,JTYP) IF (NLINE.EQ.0) RETURN DO 29 JLINE=1,NLINE JTX = NA_JTX (IXINST(JLINE,JSTR,JACT,JTYP)) NTX = NDSLAT CALL CCOSUB (TEXT(JTX),NTX, LINEWK,1,512, '$*', XNAME) JE = NESLAT - 1 C-- Write the line ready WRITE (LUNSH,9027) LINEWK(1:JE) 9027 FORMAT (A) 29 CONTINUE RETURN END +SEQ, QCARDL. ===================================================== +DECK, SHWXQT. SUBROUTINE SHWXQT C- Write the .xqtlog file C. started 5-may-94 +CDE, SLATE, SLATLN. +CDE, FLINKC. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINE*64, LINEWK*256 EQUIVALENCE (LINE,SLLINE), (LINEWK,SLLINE) +SEQ, Q_AND, Q_SHIFTR. C-- open the .xqtlog file for output CHLIFI = CHNLOG(1:NNLOG) // '.xqtlog' NLIFI = NNLOG + 7 CALL FLINK (LUNSH, 5, 0, 0) C-- record the compiler options used WRITE (LUNSH,9001) 9001 FORMAT ('>.xqtlog') 9000 FORMAT (A) DO 27 JTYP=1,3 IF (NCSUMH(JTYP).EQ.0) GO TO 27 DO 26 JSTR=1,4 IF (NCOUNTH(JSTR,JTYP).EQ.0) GO TO 26 LINEWK = '>' CALL SMSID (JTYP,JSTR,LINEWK,2) CALL NA_GET (IXOPTN(JSTR,JTYP), LINEWK,10) N = NESLAT - 1 WRITE (LUNSH,9000) LINEWK(1:N) 26 CONTINUE 27 CONTINUE C-- write the properties of each routine C- NNAME(JR) = ((IXNAME*8 + JXTYP)*8 + JXSTR)*4 + IFLNEW C- IFLNEW = 2 if "same" DO 47 JRT=NRXQT+1,NROUT JJ = NNAME(JRT) JJ = ISHFTR(JJ,2) JSTR = IAND (JJ,7) JJ = ISHFTR (JJ,3) JTYP = IAND (JJ,7) IXNA = ISHFTR (JJ,3) LINE = ' ' CALL SMSID (JTYP,JSTR,LINE,2) CALL NA_GET (IXNA, LINE, 10) N = NESLAT WRITE (LUNSH,9000) LINE(1:N-1) 47 CONTINUE CLOSE (LUNSH) RETURN END +SEQ, QCARDL. ===================================================== +PATCH, AUXSM. Service routines for NYSHELL +DECK, SMCIL. SUBROUTINE SMCIL (MODE, CODE, XTEXT) C- Store a compiler instructions line C- MODE = -1 start at line 1, =0 add one line C- CODE encoded: JXTYP type number, JXACT action, JXSTR stream C- XTEXT text to be stored C. started 20-jan-94 +CDE, QUNIT. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER CODE*(*), XTEXT*(*), LINE*512 EQUIVALENCE (LINE, TEXT) CALL SMCODE (CODE) IF (JXTYP.EQ.0) GO TO 94 NTXT = LENOCC (XTEXT) IF (JXTYP.GE.5) GO TO 31 IF (MODE.LT.0) THEN NLINST(JXSTR,JXACT,JXTYP) = 0 IXINST(1,JXSTR,JXACT,JXTYP) = 0 ENDIF IF (NTXT.EQ.0) RETURN JLINE = NLINST(JXSTR,JXACT,JXTYP) 25 JLINE = JLINE + 1 IF (JLINE.GT.NLNSZ) GO TO 91 IXU = NA_LONG (XTEXT(1:NTXT)) IXINST(JLINE,JXSTR,JXACT,JXTYP) = IXU NLINST(JXSTR,JXACT,JXTYP) = JLINE RETURN C-- sdir name 31 IXSDIR = 0 IF (NTXT.GT.0) IXSDIR= NA_LONG (XTEXT(1:NTXT)) RETURN C---- trouble 91 NMAX = NLNSZ IF (JXTYP.NE.4) GO TO 93 IF (JXSTR.EQ.4) GO TO 92 JXSTR = JXSTR + 1 JLINE = 0 GO TO 25 92 IF (INDEX (CODEX,':').EQ.0) NMAX = 8*NMAX IF (JXACT.EQ.2) GO TO 93 IF (JXACT.EQ.4) GO TO 93 JXACT = JXACT + 1 JXSTR = 1 JLINE = 0 GO TO 25 93 WRITE (IQPRNT,9091) NMAX,CODEX 9091 FORMAT (/' ***!!! Capacity of',I3,' lines exceeded for ',A) GO TO 97 94 WRITE (IQPRNT,9091) CODE,XTEXT 9094 FORMAT (' ***!!! Faulty init with ',A,' for ',A,' !!!***') 97 CALL P_KILL ('Abend') END +SEQ, QCARDL. ===================================================== +DECK, SMCINST. SUBROUTINE SMCINST C- Read the user-defined compiler instructions C. started 20-jan-94 +CDE, SLATE, SLATLN, QUNIT. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINE*512 EQUIVALENCE (LINE, SLLINE) INCRAD = 3 CALL ARRIVE (0) INCRAD = 0 JSLIN = IQ(LQHOLD+1) - 1 JSLEND = JSLIN + IQ(LQHOLD+2) NIGN = 0 JXTYP = 0 NLINE = 0 C---- Read next line 21 JSLIN = JSLIN + 1 IF (JSLIN.GT.JSLEND) GO TO 49 CALL LN_GET (JSLIN,LINE,512) NXX = NDSLAT IF (NXX.EQ.0) GO TO 21 NXX = LNBLNK (LINE(1:NXX)) IF (NXX.EQ.0) GO TO 21 IF (MOPTIO(17).EQ.0) THEN NLINE = NLINE + 1 WRITE (IQPRNT,9023) NLINE,LINE(1:NXX) ENDIF 9023 FORMAT (1X,I6,' - ',A) IF (LINE(1:1).EQ.'#') GO TO 21 C-- get the logical stream type:n IFL = 0 JNA = 0 24 JNA = ICNEXT (LINE,JNA+1,NXX) IF (JNA.GE.7) GO TO 41 IF (LINE(JNA:JNA).EQ.'+') THEN IFL = 7 GO TO 24 ENDIF IF (NDSLAT.LT.2) GO TO 71 JTE = NESLAT CALL SMCODE (LINE(JNA:JTE-1)) IF (JXTYP.EQ.0) GO TO 71 IF (IFL.EQ.0) CALL SMCIL (-1, ' ', ' ') JNA = ICFNBL (LINE,JTE,NXX) IF (JNA.GT.NXX) GO TO 21 C-- register the new compiler instruction line 41 IF (JXTYP.EQ.0) GO TO 71 CALL SMCIL (0, ' ', LINE(JNA:NXX)) GO TO 21 C---- Done 49 IF (NIGN.NE.0) GO TO 97 IF (NLINE.NE.0) WRITE (IQPRNT,9023) RETURN C---- Fault 71 NIGN = NIGN + 1 WRITE (IQPRNT,9071) LINE(1:NXX) 9071 FORMAT (/' Bad: ',A F/' ***!!! Faulty compiler-instruction !!!***') IF (NIGN.LT.8) GO TO 21 97 IQREAD = -1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, SMCODE. SUBROUTINE SMCODE (CODE) C- Crack CODE into JXTYP, JXACT, JXSTR C. started 26-jan-94 +CDE, SLATE. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER CODE*(*) PARAMETER (NTYPES = 17) C- code fo: fopt fc fort: co: copt cc cc: ao: aopt as as: C- CHTYP( 1 2 3 4 5 6 7 8 9 10 11 12 C- JXTYP= 1 2 3 C- JXACT= 1 2 3 4 1 2 3 4 1 2 3 4 C- code start: start end: end sdir C- CHTYP( 13 14 15 16 17 C- JXTYP= 4 4 4 4 5 C- JXACT= 1 2 3 4 C-- if all blank: leave the parameters unchanged NA = LNBLNK (CODE) IF (NA.EQ.0) RETURN CODEX = CODE C-- find the length of the string and compare NC = ICFIND (':', CODEX,1,NA) IF (NC.EQ.1) GO TO 49 JTYP = ICNTHL (CODEX(1:NC),CHTYP,NTYPES) - 1 IF (JTYP.LT.0) GO TO 49 JXTYP = JTYP/4 + 1 JXACT = MOD (JTYP,4) + 1 JXSTR = 1 IF (CODEX(NC:NC).EQ.':') GO TO 24 IF (JXTYP.LE.3) RETURN C-- take start:1 for start and end:1 for end JXACT = JXACT - 1 RETURN C-- get number from :n 24 JXSTR = ICDECI (CODEX, NC+1, 8) IF (JXSTR.LE.0) GO TO 49 IF (JXSTR.LE.4) RETURN IF (JXTYP.NE.4) GO TO 49 JXACT = JXACT + 1 JXSTR = JXSTR - 4 IF (JXSTR.LE.4) RETURN C-- CODEX not for one of the compilers 49 JXTYP = 0 END +SEQ, QCARDL. ===================================================== +DECK, SMDEF. SUBROUTINE SMDEF C- Load the default compiler instructions for nyshell and nymake C. started 20-jan-94 +CDE, SLATLN. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINEWK*128 EQUIVALENCE (LINEWK, SLERRM) CHTYP(1) = 'fo: ' CHTYP(2) = 'fopt ' CHTYP(3) = 'fc ' CHTYP(4) = 'fort: ' CHTYP(5) = 'co: ' CHTYP(6) = 'copt ' CHTYP(7) = 'cc ' CHTYP(8) = 'cc: ' CHTYP(9) = 'ao: ' CHTYP(10) = 'aopt ' CHTYP(11) = 'as ' CHTYP(12) = 'as: ' CHTYP(13) = 'start: ' CHTYP(14) = 'start ' CHTYP(15) = 'end: ' CHTYP(16) = 'end ' CHTYP(17) = 'sdir ' CALL SMCIL (-1, 'fo:3' , '=:1') CALL SMCIL (-1, 'fo:4' , '=:2') CALL SMCIL (-1, 'co:3' , '=:1') CALL SMCIL (-1, 'co:4' , '=:2') CALL SMCIL (-1, 'ao:2' , '=:1') CALL SMCIL (-1, 'ao:3' , '=:1') CALL SMCIL (-1, 'ao:4' , '=:2') CALL SMCIL (-1, 'fort:3', '=:1') CALL SMCIL (-1, 'fort:4', '=:2') CALL SMCIL (-1, 'cc:3' , '=:1') CALL SMCIL (-1, 'cc:4' , '=:2') CALL SMCIL (-1, 'as:2' , '=:1') CALL SMCIL (-1, 'as:3' , '=:1') CALL SMCIL (-1, 'as:4' , '=:2') +SEQ, QEJECT. +SELF, IF=QS_UNIX. IXOBJ = NA_LONG ('.o') CALL SMCIL (-1, 'fo:1' , '-O') CALL SMCIL (-1, 'fopt' , '-c') CALL SMCIL (-1, 'co:1' , '-O') CALL SMCIL (-1, 'copt' , '-c') CALL SMCIL (-1, 'fort:1', '${FC} ${FO_1} ${s}$*.f') CALL SMCIL (-1, 'fort:2', '${FC} ${FO_2} ${s}$*.f') CALL SMCIL (-1, 'cc:1' , '${CC} ${CO_1} ${s}$*.c') CALL SMCIL (-1, 'cc:2' , '${CC} ${CO_2} ${s}$*.c') CALL SMCIL (-1, 'as:1' , '${AS} ${AO_1} ${s}$*.s') CALL SMCIL (-1, 'fc' , 'f77') CALL SMCIL (-1, 'cc' , 'cc') CALL SMCIL (-1, 'as' , 'as') +SELF, IF=QS_VMS. IXOBJ = NA_LONG ('.obj') CALL SMCIL (-1, 'fo:1' , '/opt') CALL SMCIL (-1, 'fopt' , + '/nolist/check=noover') C! + '/nolist/check=noover/warn=(nounuse,nouncall)') CALL SMCIL (-1, 'copt' , '/warn=noinfo') CALL SMCIL (-1, 'aopt' , '/nolist') CALL SMCIL (-1, 'fort:1', '$ ${FC} ${FO_1} ${s}$*.for') CALL SMCIL (-1, 'fort:2', '$ ${FC} ${FO_2} ${s}$*.for') CALL SMCIL (-1, 'cc:1' , '$ ${CC} ${CO_1} ${s}$*.c') CALL SMCIL (-1, 'cc:2' , '$ ${CC} ${CO_2} ${s}$*.c') CALL SMCIL (-1, 'as:1' , '$ ${AS} ${AO_1} ${s}$*.mar') CALL SMCIL (-1, 'fc' , 'fortran') CALL SMCIL (-1, 'cc' , 'cc') CALL SMCIL (-1, 'as' , 'macro') +SELF. +SELF, IF=QF_APO, IF=-QMAPO10. CALL SMCIL (-1, 'fo:1' , '-opt 3') CALL SMCIL (-1, 'fo:2' , '-opt 0') CALL SMCIL (-1, 'fopt' , + '-bounds_violation -info 1 -indexl -cpu mathlib_sr10') +SELF, IF=QF_APO, IF=QMAPO10. CALL SMCIL (-1, 'fo:1' , '-opt 2') CALL SMCIL (-1, 'fo:2' , '-opt 0') CALL SMCIL (-1, 'fopt' , + '-bounds_violation -info 1 -indexl -cpu a88k') +SELF, IF=QF_APO. CALL SMCIL (-1, 'fort:1', + '${FC} ${s}$*.ftn ${FO_1}; mv $*.bin $*.o') CALL SMCIL (-1, 'fort:2', + '${FC} ${s}$*.ftn ${FO_2}; mv $*.bin $*.o') CALL SMCIL (-1, 'fc' , '/com/ftn') +SELF, IF=QF_APO77, IF=-QMAPO10. CALL SMCIL (-1, 'fo:1' , '-O3') CALL SMCIL (-1, 'fo:2' , '-O0') LINEWK = '-c -A cpu,mathlib_sr10 -W0,-bounds_violation' // + ' -W0,-info,1 -W0,-indexl' CALL SMCIL (-1, 'fopt' , LINEWK) +SELF, IF=QF_APO77, IF=QMAPO10. CALL SMCIL (-1, 'fo:1' , '-O3') CALL SMCIL (-1, 'fo:2' , '-O0') LINEWK = '-c -A cpu,a88k -W0,-bounds_violation' // + ' -W0,-info,1 -W0,-indexl' CALL SMCIL (-1, 'fopt' , LINEWK) +SELF, IF=QMALT. +SELF, IF=QMAMX. CALL SMCIL (-1, 'fopt' , '-c -q') CALL SMCIL (-1, 'fc' , 'ftn') CALL SMCIL (-1, 'co:1' , ' ') +SELF, IF=QMCRY. CALL SMCIL (-1, 'fo:1' , ' ') CALL SMCIL (-1, 'fopt' , ' ') CALL SMCIL (-1, 'co:1' , ' ') CALL SMCIL (-1, 'fc' , 'cft77') CALL SMCIL (-1, 'cc' , 'scc') +SELF, IF=QMCVX. CALL SMCIL (-1, 'fopt' , '-c -72') CALL SMCIL (-1, 'fc' , 'fc') +SELF, IF=QMDOS. CALL SMCIL (-1, 'fo:1' , ' ') CALL SMCIL (-1, 'fopt' , '-c -vm') CALL SMCIL (-1, 'co:1' , ' ') CALL SMCIL (-1, 'copt' , '-n2 -n3 -OLM') CALL SMCIL (-1, 'aopt' , '-c') CALL SMCIL (-1, 'fc' , 'mf486') CALL SMCIL (-1, 'as' , '386ASM') +SELF, IF=QMHPX. CALL SMCIL (-1, 'fo:1' , ' ') CALL SMCIL (-1, 'fopt' , '-c -w +ppu') +SELF, IF=QMIBX. +SELF, IF=QMIRT. CALL SMCIL (-1, 'fopt' , '-c -qextname -qcharlen=8192') CALL SMCIL (-1, 'fc' , 'xlf') +SELF, IF=QMLNX. CALL SMCIL (-1, 'fo:1' , '-O2') CALL SMCIL (-1, 'fo:2' , '-O0') CALL SMCIL (-1, 'fopt' , '-c -Nx800 -Nc200') CALL SMCIL (-1, 'co:1' , '-O2') CALL SMCIL (-1, 'co:2' , '-O0') CALL SMCIL (-1, 'copt' , '-c -posix') +SELF, IF=QMNXT. +SELF, IF=QMSGI. +SELF, IF=QMSUN. CALL SMCIL (-1, 'fopt' , '-c -w66') CALL SMCIL (-1, 'as:1' , '${AS} -o $*.o ${s}$*.s') +SELF, IF=QMTMO. CALL SMCIL (-1, 'fo:1' , ' ') CALL SMCIL (-1, 'co:1' , ' ') +SELF, IF=QMVMI. CALL SMCIL (-1, 'fopt' , '-c -w1') CALL SMCIL (-1, 'cc' , 'f77') CALL SMCIL (-1, 'as:1' , '${AS} -o $*.o ${s}$*.s') +SELF, IF=QMVAO. CALL SMCIL (-1, 'fo:2' , '-O0') CALL SMCIL (-1, 'fopt' , '-c -w1 -warn nouncalled') CALL SMCIL (-1, 'co:1' , '-O2') CALL SMCIL (-1, 'co:2' , '-O0') CALL SMCIL (-1, 'as:1' , '${AS} -o $*.o ${s}$*.s') +SELF, IF=QMUUX. +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, SMDISP. SUBROUTINE SMDISP (JTARG) C- Display the compiler instructions for data type JTYP C. started 20-jan-94 +CDE, SLATE, SLATLN, QUNIT. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINEWK*100, CHWK*4 EQUIVALENCE (LINEWK,SLLINE), (CHWK,LINEWK) JTYP = JTARG NLEAD = 9 IF (JTYP.GE.4) GO TO 41 WRITE (IQPRNT,9001) C-- check if stream 3 and 4 need to be displayed NSTRDO = 4 IF (MOPTIO(22).NE.0) GO TO 24 NSTRDO = 2 DO 22 JSTR=3,4 IXU = IXINST(1,JSTR,4,JTYP) IF (IXU.EQ.0) GO TO 22 CALL NA_GET (IXU, CHWK, 1) IF (CHWK(1:2).NE.'=:') NSTRDO= JSTR 22 CONTINUE C---- Do all actions of type JTYP 24 DO 29 JACT=1,4 JTAC = 4*(JTYP-1) + JACT IFSTR = 0 NSTR = 1 IF (JACT.EQ.2) GO TO 26 IF (JACT.EQ.3) GO TO 26 IFSTR = 1 NSTR = NSTRDO 26 JSTR = 0 27 IF (JSTR.EQ.NSTR) GO TO 29 JSTR = JSTR + 1 NLINE = NLINST(JSTR,JACT,JTYP) JLINE = 1 LINEWK = CHTYP(JTAC) IF (IFSTR.EQ.0) GO TO 28 CALL CSETDI (JSTR,LINEWK,7,NLEAD) CALL CLEFT (LINEWK,4,NLEAD) 28 CALL NA_GET (IXINST(JLINE,JSTR,JACT,JTYP), LINEWK, NLEAD+1) JE = NESLAT - 1 WRITE (IQPRNT,9002) LINEWK(1:JE) IF (JLINE.GE.NLINE) GO TO 27 JLINE = JLINE + 1 IF (JLINE.NE.2) GO TO 28 LINEWK(1:NLEAD) = ' ' GO TO 28 29 CONTINUE RETURN +SEQ, QEJECT. C---- Display start or end 41 IF (JTYP.GE.6) GO TO 51 JACDO = 1 IF (JTYP.NE.4) JACDO= 3 JTYP = 4 JTAC = 12 + JACDO LINEWK = CHTYP(JTAC) IFANY = 0 DO 49 JACT=JACDO,JACDO+1 DO 49 JSTR=1,4 JLINE = 0 NLINE = NLINST(JSTR,JACT,JTYP) 44 IF (JLINE.GE.NLINE) GO TO 49 JLINE = JLINE + 1 CALL NA_GET (IXINST(JLINE,JSTR,JACT,JTYP), LINEWK, NLEAD+1) JE = NESLAT - 1 IF (IFANY.EQ.0) WRITE (IQPRNT,9001) WRITE (IQPRNT,9002) LINEWK(1:JE) IF (IFANY.NE.0) GO TO 44 LINEWK(1:NLEAD) = ' ' IFANY = 7 GO TO 44 49 CONTINUE RETURN C---- Display source directory 51 IF (MOPTIO(22).EQ.0) THEN IF (IXSDIR.EQ.0) RETURN ENDIF LINEWK = CHTYP(17) CALL NA_GET (IXSDIR, LINEWK, NLEAD+1) JE = NESLAT - 1 WRITE (IQPRNT,9001) WRITE (IQPRNT,9002) LINEWK(1:JE) RETURN 9001 FORMAT (A) 9002 FORMAT (1X,A) END +SEQ, QCARDL. ===================================================== +DECK, SMJOPT. SUBROUTINE SMJOPT C- Join the stream-specific and general options for all types C. started 5-may-94 +CDE, SLATE, SLATLN, QUNIT. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINEWK*256, COLWK(256)*1, CHWK*4 EQUIVALENCE (LINEWK,SLLINE), (COLWK,SLLINE) DO 49 JTYP=1,3 DO 49 JSTR=1,4 LINEWK = ' ' JPUT = 1 C-- set the common options first JACT = 2 NL = NLINST(1,JACT,JTYP) JL = 0 24 JL = JL + 1 IF (JL.GT.NL) GO TO 31 IX = IXINST(JL,1,JACT,JTYP) IF (IX.EQ.0) GO TO 31 CALL NA_GET (IX,LINEWK,JPUT) JPUT = NESLAT + 1 GO TO 24 C-- add the stream-specific options 31 JACT = 1 JSUS = JSTR NLOOP = 0 32 NL = NLINST(JSUS,JACT,JTYP) IF (NL.EQ.0) GO TO 46 IX = IXINST(1,JSUS,JACT,JTYP) IF (IX.EQ.0) GO TO 46 CALL NA_GET (IX,CHWK,1) IF (CHWK(1:2).NE.'=:') GO TO 35 JSUS = ICDECI (CHWK,3,4) IF (JSUS.LE.0) GO TO 91 IF (JSUS.GT.4) GO TO 91 NLOOP = NLOOP + 1 IF (NLOOP.GT.7) GO TO 92 GO TO 32 35 JL = 1 36 CALL NA_GET (IX,LINEWK,JPUT) JPUT = NESLAT + 1 JL = JL + 1 IF (JL.GT.NL) GO TO 46 IX = IXINST(JL,JSUS,JACT,JTYP) IF (IX.NE.0) GO TO 36 C-- done, store this line 46 N = LNBLNK(LINEWK(1:JPUT)) IF (N.EQ.0) GO TO 48 +SELF, IF=QS_UNIX. CALL CSQMBL (LINEWK,1,N) N = NDSLAT +SELF, IF=QS_VMS. CALL CLEFT (LINEWK,1,N) N = NDSLAT +SELF. N = NA_LONG (LINEWK(1:N)) 48 IXOPTN(JSTR,JTYP) = N 49 CONTINUE RETURN C---- Faulty compiler instructions 91 WRITE (IQPRNT,9091) CHWK 9091 FORMAT (/' Trying to do: ',A) CALL P_KILL ('Faulty compile-stream re-direction') 92 CALL P_KILL ('Compile-stream re-direction loop') END +SEQ, QCARDL. ===================================================== +DECK, SMRLOG. SUBROUTINE SMRLOG C- Read the Patchy log file and crack each entry C. started 20-jan-94 +CDE, SLATE, SLATLN, QUNIT, LUNSLN. +CDE, MQCM. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINE*256 EQUIVALENCE (LINE, SLLINE) CHARACTER SCDIR*80, FILEN*128, CHWK*4 INTEGER STATF +SEQ, Q_AND, Q_SHIFTR. IF (NRXQT.EQ.0) THEN MOPTIO(2) = MOPTIO(2) + MOPTIO(5) IF (MOPTIO(2).EQ.0) MOPTIO(1)= 1 ENDIF C-- set the source directory IF (IXSDIR.NE.0) THEN CALL NA_GET (IXSDIR,SCDIR,1) NDIR = NDSLAT +SELF, IF=QS_VMS. CALL FTOVAX (SCDIR,NDIR) +SELF. ELSE NDIR = 0 ENDIF C-- get the .log file into memory NROUT = NRXQT NIGN = 0 IFDOTH = 0 CALL INIPAM (11, IXLUN(1), 0,0) 20 LQLEND(2) = LQLSTA(2) IQ(LQHOLD+2) = 0 CALL ARRIVE (3) +SEQ, QEJECT. C---- Do next line JSLIN = IQ(LQHOLD+1) - 1 NSLIN = IQ(LQHOLD+2) JSLEND = JSLIN + NSLIN 21 JSLIN = JSLIN + 1 IF (JSLIN.GT.JSLEND) GO TO 39 CALL LN_GET (JSLIN,LINE,512) NXX = NDSLAT IF (NXX.EQ.0) GO TO 21 NXX = LNBLNK (LINE(1:NXX)) IF (NXX.EQ.0) GO TO 21 IF (IFDOTH.EQ.7) GO TO 65 C-- get and analyse the logical stream type:n JTA = ICNEXT (LINE,1,NXX) JTE = NESLAT NTA = NDSLAT IF (JTA.GE.11) GO TO 21 IF (JTA.GE.4) GO TO 81 IF (NTA.LT.3) GO TO 81 CALL SMCODE (LINE(JTA:JTA+NTA-1)) IF (JXTYP.EQ.0) GO TO 21 IF (JXTYP.GT.3) GO TO 21 IF (JXACT.NE.4) GO TO 81 C-- check if type:n is bypassed or re-directed NLOOP = 0 26 IXU = IXINST(1,JXSTR,JXACT,JXTYP) IF (IXU.EQ.0) GO TO 21 CHWK = ' ' CALL NA_GET (IXU,CHWK,1) IF (CHWK .EQ.'by ') GO TO 21 IF (CHWK(1:2).NE.'=:') GO TO 31 JXSTR = ICDECI (CHWK,3,4) IF (JXSTR.LT.1) GO TO 92 IF (JXSTR.GT.4) GO TO 92 NLOOP = NLOOP + 1 IF (NLOOP.GT.7) GO TO 91 GO TO 26 C---- Compilable routine, get the routine name 31 JNA = ICNEXT (LINE,JTE,NXX) JNF = NESLAT - 1 NNA = NDSLAT IF (NNA.EQ.0) GO TO 81 JNE = ICFIND ('.', LINE,JNA,JNF) - 1 IXNAME = NA_LONG (LINE(JNA:JNE)) IFLNEW = 1 IRCCO = 0 IF (MOPTIO(1) .NE.0) GO TO 38 C-- check the "same" flag is present IF (JNF.EQ.NXX) GO TO 38 JINC = ICNEXT (LINE,JNF+1,NXX) IF (NDSLAT.NE.4) GO TO 38 IF (LINE(JINC:JINC+3).NE.'same') GO TO 38 JINCE = NESLAT IF (MOPTIO(21).NE.0) GO TO 41 C---- register the new routine name 37 IFLNEW = 2 38 NROUT = NROUT + 1 IF (NROUT.GT.NRTSZ) GO TO 93 NNAME(NROUT) = ((IXNAME*8 + JXTYP)*8 + JXSTR)*4 + IFLNEW NCOUNTH(JXSTR,JXTYP) = NCOUNTH(JXSTR,JXTYP) + 1 NCSUMH(JXTYP) = NCSUMH(JXTYP) + 1 IF (IFLNEW.EQ.2) GO TO 21 NCOUNTR(JXSTR,JXTYP) = NCOUNTR(JXSTR,JXTYP) + 1 NCSUMR(JXTYP) = NCSUMR(JXTYP) + 1 NRALLC = NRALLC + 1 +SELF, IF=XDEBUG, IF=XYSHELL. IF (IRCCO.EQ.0) GO TO 21 CALL NA_GET (IXNAME,LINE,1) WRITE (IQPRNT,9038) LINE(1:NDSLAT),IRCCO 9038 FORMAT (' routine ',A,' ircco=',I2) +SELF. GO TO 21 C---- Done 39 IF (JDKNEX.LT.4) GO TO 20 IF (NROUT.EQ.NRXQT) GO TO 94 CALL INIPAM (0,0, -1,0) RETURN +SEQ, QEJECT. C---- check dependencies for "same" routine in UPTODATE mode 41 IF (MOPTIO(2).NE.0) GO TO 46 C-- find this routine in the .xqtlog file DO 42 JX=1,NRXQT JJ = NNAME(JX) IXNA = ISHFTR (JJ,8) IF (IXNA.EQ.IXNAME) GO TO 44 42 CONTINUE IRCCO = 1 GO TO 38 C-- check compiler options unchanged 44 JJ = ISHFTR(JJ,2) JSTR = IAND (JJ,7) JJ = ISHFTR (JJ,3) JTYP = IAND (JJ,7) IRCCO = 2 IF (JTYP.NE.JXTYP) GO TO 38 IF (IXOPTP(JSTR,JTYP).NE.IXOPTN(JXSTR,JXTYP)) GO TO 38 C-- get the date and length of the .o file 46 CALL NA_GET (IXNAME,FILEN,1) NFI = NESLAT CALL NA_GET (IXOBJ, FILEN,NFI) NFI = NESLAT - 1 ISTAO = STATF (FILEN(1:NFI), IQUEST) ILENO = IQUEST(7) ITIMO = IQUEST(9) +SELF, IF=XDEBUG, IF=XYSHELL, IF=XDETAILDB. WRITE (IQPRNT,9836) FILEN(1:NFI), ITIMO, ISTAO 9836 FORMAT (20X,'file ',A/' time=',Z10,' status=',I4) +SELF. IRCCO = 4 IF (ISTAO.NE.0) GO TO 38 IRCCO = 5 IF (ILENO.EQ.0) GO TO 38 ITIMOL = ISHFTR (ITIMO,3) ITIMOR = IAND (ITIMO,7) C-- get the date of the .f | .c | .a file IF (NDIR.GT.0) FILEN(1:NDIR)= SCDIR(1:NDIR) IRCCO = 6 61 FILEN(NDIR+1:NDIR+NNA)= LINE(JNA:JNA+NNA-1) NFI = NDIR + NNA C-- read the date and compare to that of the .o file ISTAF = STATF (FILEN(1:NFI), IQUEST) ITIMF = IQUEST(9) +SELF, IF=XDEBUG, IF=XYSHELL, IF=XDETAILDB. WRITE (IQPRNT,9836) FILEN(1:NFI), ITIMF, ISTAF +SELF. IF (ISTAF.NE.0) GO TO 38 ITIMFL = ISHFTR (ITIMF,3) IF (ITIMFL.LT.ITIMOL) GO TO 64 IF (ITIMFL.GT.ITIMOL) GO TO 38 ITIMFR = IAND (ITIMF,7) IF (ITIMFR.GE.ITIMOR) GO TO 38 C-- get the name for the next include file, if any 64 IF (JINCE.GT.NXX) GO TO 37 IRCCO = 7 65 IFDOTH = 0 JNA = ICNEXT (LINE,JINCE,NXX) JINCE = NESLAT NNA = NDSLAT IF (NNA.GT.1) GO TO 61 IF (LINE(JNA:JNA).NE.'+') GO TO 61 IFDOTH = 7 JINCE = 1 GO TO 21 +SEQ, QEJECT. C---- Ignore meaningless input line 81 NIGN = NIGN + 1 WRITE (IQPRNT,9081) LINE(1:NXX) 9081 FORMAT (' Ignored: ',A) IF (NIGN.LT.8) GO TO 21 IF (NIGN.LT.(NROUT-NRXQT)/2) GO TO 21 CALL P_KILL ('Faulty Patchy log file') C---- Faulty compiler instructions 91 CALL P_KILL ('Compile-stream re-direction loop') 92 WRITE (IQPRNT,9092) CHWK 9092 FORMAT (/' Trying to do: ',A) CALL P_KILL ('Faulty compile-stream re-direction') 93 WRITE (IQPRNT,9093) NRTSZ 9093 FORMAT (/' ***!!! More than',I7,' routines !!!***' F/' complain to zoll@cern.ch') CALL P_KILL ('Too many routines') 94 CALL P_KILL ('No compilable routines') END +SEQ, QCARDL. ===================================================== +DECK, SMRXQT. SUBROUTINE SMRXQT C- Read the Nyshell .xqtlog file and crack each entry C. started 5-may-94 +CDE, SLATE, SLATLN, QUNIT. +CDE, MQCM. +CDE, FLINKC. +CDE, SHMKC, Q, PY, ADDSH. C-------------- End CDE -------------------------------- CHARACTER LINE*256 EQUIVALENCE (LINE, SLLINE) C-- construct the name of the .xqtlog file CHLIFI = CHNLOG(1:NNLOG) // '.xqtlog' NLIFI = NNLOG + 7 C-- get the .xqtlog file into memory IXTEMP = NA_LONG (CHLIFI(1:NLIFI)) CALL INIPAM (11, IXTEMP, 0,2) IF (IXFLUN.LT.0) RETURN MODE = 0 20 LQLEND(2) = LQLSTA(2) IQ(LQHOLD+2) = 0 CALL ARRIVE (3) +SELF, IF=XDEBUG, IF=XYSHELL. WRITE (IQPRNT,9020) IQ(LQHOLD+2),CHLIFI(1:NLIFI) 9020 FORMAT (' Dbg: reading',I6,' lines from file ',A) +SELF. +SEQ, QEJECT. C---- Do next line JSLIN = IQ(LQHOLD+1) - 1 NSLIN = IQ(LQHOLD+2) JSLEND = JSLIN + NSLIN 21 JSLIN = JSLIN + 1 IF (JSLIN.GT.JSLEND) GO TO 69 CALL LN_GET (JSLIN,LINE,512) NXX = NDSLAT IF (NXX.EQ.0) GO TO 21 NXX = LNBLNK (LINE(1:NXX)) IF (NXX.EQ.0) GO TO 21 IF (MODE.NE.0) GO TO 22 IF (LINE(1:8).NE.'>.xqtlog') GO TO 91 MODE = 1 GO TO 21 C-- get the logical stream type:n 22 JTA = ICNEXT (LINE,2,NXX) JTE = NESLAT NTA = NDSLAT IF (JTA.GE.7) GO TO 91 IF (NTA.LT.3) GO TO 91 CALL SMCODE (LINE(JTA:JTA+NTA-1)) IF (JXTYP.EQ.0) GO TO 91 IF (JXTYP.GT.3) GO TO 91 IF (JXACT.NE.4) GO TO 91 IF (MODE.GE.2) GO TO 24 C-- get the compiler options in the prelude IF (LINE(1:1).NE.'>') GO TO 23 IF (JTE.GT.NXX) GO TO 21 JNA = ICFNBL (LINE,JTE,NXX) IXOPTP(JXSTR,JXTYP) = NA_LONG (LINE(JNA:NXX)) GO TO 21 C-- get the routine name 23 MODE = 2 24 JNA = ICNEXT (LINE,JTE,NXX) JNE = NESLAT NNA = NDSLAT IF (NNA.EQ.0) GO TO 91 C---- register the new routine name IXNAME = NA_LONG (LINE(JNA:JNA+NNA-1)) NROUT = NROUT + 1 IF (NROUT.GT.NRTSZ) GO TO 93 NNAME(NROUT) = ((IXNAME*8 + JXTYP)*8 + JXSTR)*4 GO TO 21 C---- Done 69 IF (JDKNEX.LT.4) GO TO 20 CALL INIPAM (0,0, -1,0) NRXQT = NROUT +SELF, IF=XDEBUG, IF=XYSHELL. WRITE (IQPRNT,9071) NRXQT 9071 FORMAT (' Dbg: SMRXQT has read',I5,' routines for options:') DO 74 JTYP=1,3 DO 73 JSTR=1,4 IX = IXOPTP(JSTR,JTYP) IF (IX.EQ.0) GO TO 73 LINE = ' ' CALL SMSID (JTYP,JSTR,LINE,4) CALL NA_GET (IX,LINE,12) WRITE (IQPRNT,'(A)') LINE(1:NESLAT-1) 73 CONTINUE 74 CONTINUE +SELF. RETURN C---- Fault 91 CALL INIPAM (0,0, -1,0) CALL P_KILL ('Not a valid .xqtlog file') 93 WRITE (IQPRNT,9093) NRTSZ 9093 FORMAT (/' ***!!! More than',I7,' routines !!!***' F/' complain to zoll@cern.ch') CALL P_KILL ('Too many routines') END +SEQ, QCARDL. ===================================================== +DECK, SMSID. SUBROUTINE SMSID (JTYP,JSTR,LINE,JCOL) C- Set the stream ID like fort:3 C. started 5-may-94 CHARACTER LINE*(*) J = JCOL IF (JTYP.EQ.1) THEN LINE(J:J+3) = 'fort' J = J + 4 ELSEIF (JTYP.EQ.2) THEN LINE(J:J+1) = 'cc' J = J + 2 ELSE LINE(J:J+1) = 'as' J = J + 2 ENDIF LINE(J:J) = ':' CALL CSETDI (JSTR, LINE,J+1,J+1) RETURN END +SEQ, QCARDL. ===================================================== +PATCH, AUXIL. Service routines for the Auxiliaries +DECK, INIAUX. SUBROUTINE INIAUX (LASTWSP) C- Initialize for the Auxiliaries C. started 12-jan-94 +CDE, QBITS19, QBANKS. +CDE, CM_TYP, TAGC, TITLEC, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- DIMENSION LASTWSP(9) CALL MQWORK (LACRAD,INCRAD,LASTWSP) NFILET = 0 NVGAP(1) = 4000 NVGAP(2) = 200 NVGAP(3) = 5000 NVGAP(4) = 40 NCHTAG = 0 CALL VZERO (LOWAN,12) C-- Pre-lift the banks for I/O handling CALL MQLIFT (LACRAD, 0,7, JBKARR,3) CALL MQLIFT (LPAM, 0,7, JBKPAM,3) CALL MQLIFT (LQARRV, 0,7, JBKARR,3) CALL MQLIFT (LQHOLD, 0,7, JBKHOL,1) LARRV = LQARRV C---- Lift the ASM banks N_TYP = 0 NAL_TYP = 2 JAL = MAX_TYP - NAL_TYP CH_TYP(JAL+1) = 'R*EPEAT' CH_TYP(JAL+2) = 'J*OIN' JU_TYP(JAL+1) = -1 JU_TYP(JAL+2) = -2 C-- lift the support bank ASMH CALL MQLIFT (LHASM, 0,7, JBKSMH,3) C-- lift the ASMT banks CALL ASMCREA ('FORT', JASM, 0) CALL ASMCREA ('CC', JASM, 0) CALL ASMCREA ('AS', JASM, 0) CALL ASMCREA ('DATA', JASM, 0) CALL ASMCREA ('SHELL', JASM, 0) CALL ASMCREA ('CRAD', JASM, 0) CALL ASMCREA ('INCL', JASM, 0) C---- Create standard aliases +SELF, IF=BACKCOMP. JAL = JAL - 4 CH_TYP(JAL+1) = 'CO*MPILE' CH_TYP(JAL+2) = 'X*CC' CH_TYP(JAL+3) = 'A*S*' CH_TYP(JAL+4) = 'D*ATA' JU_TYP(JAL+1) = JFO_TYP JU_TYP(JAL+2) = JCC_TYP JU_TYP(JAL+3) = JAS_TYP JU_TYP(JAL+4) = JDA_TYP NAL_TYP = MAX_TYP - JAL +SELF. RETURN END +SEQ, QCARDL. ===================================================== +DECK, INIPAM. SUBROUTINE INIPAM (LUNU, IXFILE, IFLAG,IFLEX) C- Connect PAM file for auxiliaries C- IFLAG => 0 start PAM file, with log print if >0 C- < 0 close the PAM file C- C- IFLEX = 2 the file does not need to exist C- 0 fatal exit for OPEN failure C. started 12-jan-94 +CDE, SLATE, SLATLN, QUNIT. +CDE, ARRCOM, Q, PY. +CDE, FLINKC. C-------------- End CDE -------------------------------- +SEQ, bkARRV, IF=DOC_INL. +SEQ, QEJECT. C---- Connect the PAM file IF (IFLAG.LT.0) GO TO 41 IN_LUN = LUNU IXFLUN = IXFILE IF (IXFLUN.EQ.0) GO TO 91 CALL FLINK (IN_LUN, 2, -1, IFLEX) IF (IXFLUN.LT.0) RETURN IQ(LARRV+1) = IN_LUN IQ(LARRV+2) = LUNFD IQ(LARRV+4) = IXFLUN IQ(LARRV+6) = LUNSIZ IQ(LARRV+7) = -2 +SELF, IF=QCIO. IF (LUNSIZ.GT.0) IQ(LARRV+7)= 0 +SELF. JDKTYP = 3 JDKNEX = 0 +SELF, IF=-XDEBUG. IF (IFLAG.EQ.0) RETURN +SELF. C-- Print log of file reading SLLINE(1:25) = ' ---> start reading file ' CALL NA_GET (IXFLUN,SLLINE,26) NTXT = NESLAT - 1 CALL DPBLAN (0) WRITE (IQPRNT,9027) SLLINE(1:NTXT) IF (IQTYPE.NE.IQPRNT) WRITE (IQTYPE,9027) SLLINE(1:NTXT) 9027 FORMAT (A/) RETURN C---- Disconnect the PAM file 41 IN_DOX = -1 CALL ARRIN RETURN C---- Trouble 91 CALL P_KILL ('No PAM file name given') END +SEQ, QCARDL. ===================================================== +DECK, CCJOIN. SUBROUTINE CCJOIN C- Check T=JOIN is present on current control line +CDE, CCPARA, QPAGE. C-------------- End CDE -------------------------------- IF (NQJOIN.LT.0) RETURN NQJOIN = 0 IF (NCCPT.EQ.0) RETURN LOC = JCCPT NTH = NCCPT 24 LOC = LOC + 3 JXX = MCCPAR(LOC+1) NXX = MCCPAR(LOC+2) J = ICNTH (CCKARD(JXX:JXX+NXX-1),'J*OIN ',1) IF (J.NE.0) GO TO 27 NTH = NTH - 1 IF (NTH.GT.0) GO TO 24 RETURN 27 NQJOIN = 1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DOMAPA. SUBROUTINE DOMAPA (IFLACT) C- Content analysis of the next deck for the Auxiliaries, C- map the description of this deck's material C- into the control-banks of the linear PREP structure. C- Merge actions if IFLACT not zero C. started 12-jan-94 +CDE, QBANKS, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, Q_JBYT. JSLZER = IQ(LQHOLD+1) JSLORG = JSLZER C-- create the PREP seedling CALL MQLIFT (LQPREP, 0,7, JBKPRE,2) IQ(LQPREP+1) = JSLZER IQ(LQPREP+2) = IQ(LQHOLD+3) C---- stage 1 : delimit control lines, create PREP structure CALL M_ANA1 IF (IFLACT.EQ.0) RETURN IF (LEXD.EQ.0) RETURN IF (LQ(LEXD-2).EQ.0) RETURN C---- stage 2 : split PREP banks on action limits LDO = LQPREP LACT = LEXD - 1 C-- Next action 21 LACT = LQ(LACT-1) IF (LACT.EQ.0) RETURN C- JACT = 0 DEL, 1 REP, 2 ADB, 3 ADD JACT = JBYT (IQ(LACT),9,3) JSLX = IQ(LACT+4) + JSLZER C- break at the insertion point LDO = M_SPLIT (LDO,JSLX) IF (LDO.EQ.0) GO TO 61 C- zero-line PREP bank with reference to ACT LX = LDO LDO = M_SPLIT (LDO,0) LQ(LX-2) = LACT GO TO 21 C-- Add trailing actions 61 LNEW = KQLAST (LQPREP-1) + 1 62 CALL MQLIFT (LNEW,LNEW,-1,JBKPRE,2) LQ(LNEW-2) = LACT LACT = LQ(LACT-1) IF (LACT.NE.0) GO TO 62 RETURN END +SEQ, QCARDL. ===================================================== +DECK, KROPT. SUBROUTINE KROPT (IXOPT,MASK) C- Krack the option parameter into MOPTIO(34) C. started 13-jan-94 +CDE, SLATE, SLATLN, QCHAR. +CDE, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*80, COL(80)*1 EQUIVALENCE (LINE,SLLINE), (COL,SLLINE) +SEQ, Q_AND. MOPTIO(34) = 0 IF (IXOPT.EQ.0) GO TO 37 CALL NA_GET (IXOPT,LINE,1) NN = NDSLAT +SELF, IF=XDEBUG. PRINT *, ' Dbg KROPT: opt string= ',LINE(1:NN) +SELF. DO 24 JL=1,NN J = INDEX (CQCETA(1:32),COL(JL)) IF (J.NE.0) CALL SBIT1 (MOPTIO(34),J) 24 CONTINUE 37 MOPTIO(33) = IAND (MOPTIO(34),MASK) CALL UPKBYT (MOPTIO(33),1,MOPTIO(1),32,0) RETURN END +SEQ, QCARDL. ===================================================== +DECK, PGSIZE. SUBROUTINE PGSIZE (MODE,IXOPT) C- Set (MODE=0) or print (=1) page size C. started 17-jan-94 +CDE, SLATE, SLATLN. +CDE, QPAGE, QUNIT. +CDE, Q, PY. C-------------- End CDE -------------------------------- CHARACTER LINE*80 EQUIVALENCE (LINE,SLLINE) DIMENSION LILENG(5) DATA LILENG / 56, 62, 74, 84, 98 / +SEQ, Q_JBIT. IF (MODE.NE.0) GO TO 41 DO 24 J=1,5 IF (JBIT(MOPTIO(34),J+26).NE.0) NQLMAX= LILENG(J) 24 CONTINUE CALL NA_GET (IXOPT,LINE,1) NN = NDSLAT J = 0 26 J = J + 1 IF (J.GE.NN) GO TO 29 NL = ICDECI (LINE,J,NN) IF (NDSLAT.LT.2) GO TO 26 IF (NL.LT.20) GO TO 26 NQLMAX = NL 29 CALL MQPAGE RETURN 41 CALL DPBLAN (1) WRITE (IQPRNT,9041) NQLMAX, LILENG RETURN 9041 FORMAT (' Page size used:',I5,' lines per page' F/' Available with option O:',I3, F' 1:',I3,' 2:',I3,' 3:',I3,' 4:',I3) END +SEQ, QCARDL. ===================================================== +DECK, XEJECT. SUBROUTINE XEJECT C- Check and act on +SEQ, QEJECT, N=n C. started 12-jan-94 +CDE, CCPARA, QPAGE, QUNIT, Q. +CDE, M_ANAC. C-------------- End CDE -------------------------------- +SEQ, xJSPSEQ, IF=DOC_INL. +SEQ, JSPSEQ. PARAMETER (IXEJ = JSPSEQ1 + 1) CALL CCKRAK (IQ(LDOAN+1)) IF (JCCBAD.NE.0) RETURN IF (NCCPZ.NE.1) RETURN IF (MCCPAR(JCCPZ+1).NE.IXEJ) RETURN NN = MCCPAR(JCCPN+1) IF (NN.LT.0) NN = NQLMAX IF (NN.EQ.0) NN = NQLMAX - 6 IF (NQUSED+NN.LE.NQLMAX) RETURN NQUSED = NQLMAX CALL DPPAGE RETURN END +SEQ, QCARDL. ===================================================== +PATCH, DQ. Debug routines +DECK, DQCLOBB. SUBROUTINE DQCLOBB (LNAME,LSTAT) C- Bank chaining clobbered has been detected at LNAME or LSTAT C- scan all divisions and print the last 4 good banks +CDE, QUNIT, MQCM, MQCN, QSH. C-------------- End CDE -------------------------------- DIMENSION LLAST(4) WRITE (IQPRNT,9000) IF (LNAME.NE.0) THEN WRITE (IQPRNT,9001) 'name',LNAME ELSE WRITE (IQPRNT,9001) 'status',LSTAT ENDIF 9000 FORMAT (/' ****!!!!! Patchy is crashing !!!!!****' F/' please call for help: zoll@cern.ch') 9001 FORMAT (/' Bank chaining clobbered at ',A,' adr',I7) C---- Next division JDIV = 0 21 JDIV = JDIV + 1 IF (JDIV.GT.3) GO TO 99 LNA = LQCSTA(JDIV) LEND = LQCEND(JDIV) WRITE (IQPRNT,9022) JDIV,LNA,LEND 9022 FORMAT (/' Division',I2,' boundaries:',2I7) C---- Scan to the trouble splot CALL VZERO (LLAST,4) 31 IF (LNA.GE.LEND) GO TO 21 CALL QBLOWX (LNA) IF (IQFOUL.NE.0) GO TO 41 CALL UCOPY (LLAST(2),LLAST(1),3) LLAST(4) = LNA LNA = IQLNX GO TO 31 C---- Trouble spot found, dump the last 4 banks 41 LNATR = LNA WRITE (IQPRNT,9041) 9041 FORMAT (/' After:') JBK = 0 42 JBK = JBK + 1 IF (JBK.GT.4) GO TO 44 LNA = LLAST(JBK) IF (LNA.EQ.0) GO TO 42 CALL QBLOWX (LNA) CALL DQBANK GO TO 42 C---- Find the first good bank after 44 LOK = 0 LNA = LNATR 45 LNA = LNA + 1 IF (LNA.GE.LEND-4) GO TO 46 CALL QBLOWX (LNA) IF (IQFOUL.NE.0) GO TO 45 LOK = LNA 46 LNAE = MIN (LNA, LNATR+39) WRITE (IQPRNT,9046) 9046 FORMAT (/' the memory is destroyed, dump the next few words:'/) 9047 FORMAT (1X,I8,' :',Z10,I20) DO 47 L=LNATR,LNAE WRITE (IQPRNT,9047) L,LQ(L),LQ(L) 47 CONTINUE IF (LOK.EQ.0) GO TO 21 WRITE (IQPRNT,9049) LOK 9049 FORMAT (/' The first good bank after, starting at adr',I8,' is:') CALL DQBANK GO TO 21 C---- Exit 99 CALL P_KILL ('fatal') END +SEQ, QCARDL. ===================================================== +DECK, DQBANK. SUBROUTINE DQBANK C- Dump the bank whose parameters are in /MQCN/ +CDE, SLATLN. +CDE, QBITS19, QBANKS, QUNIT, MQCM, QSYSBITS, Q. +CDE, MQCN. C-------------- End CDE -------------------------------- INTEGER INTID CHARACTER CHID*4, WK*2, CHK*1 EQUIVALENCE (CHID,INTID) CHARACTER LINE*48, LINEZ*30, COLZ(30)*1, LINEWH*34 EQUIVALENCE (LINE,SLLINE), (LINEZ,SLLINE(81:)), (COLZ,LINEZ) +, (LINEWH,SLLINE(161:)) +SEQ, Q_JBYT, Q_AND. LNA = IQLNA LBK = IQLST INTID = MMBANK(1,IQTY) IF (IAND(IQ(LNA),KMDROP).NE.0) THEN CHK = '_' ELSE CHK = ' ' ENDIF IF (IQNL.GT.0) THEN NLP = MIN (IQNL,6) CALL UCOPIV (LQ(LBK-NLP), IQUEST, NLP) WRITE (IQPRNT,9022) LBK,CHK,CHID,IQLI,IQNL,IQNS,IQND, + (IQUEST(J),J=1,NLP) ELSE WRITE (IQPRNT,9022) LBK,CHK,CHID,IQLI,IQNL,IQNS,IQND ENDIF 9022 FORMAT (/1X,I6,A,A,' LI/NL/NS/ND= ',I1,2I3,I5,:, F', links:',6I7) C-- Print the object identifier SLLINE = ' ' IF (IQTY.EQ.JBKPAT) THEN WK = 'P=' IX = IQ(LBK+2) ELSEIF (IQTY.EQ.JBKDEC) THEN WK = 'D=' IX = IQ(LBK+1) ELSEIF (IQTY.EQ.JBKKEE) THEN WK = 'Z=' IX = IQ(LBK+4) ELSE GO TO 30 ENDIF LINEWH(1:2) = WK CALL NA_GET (IX, LINEWH, 3) N = LENOCC (LINEWH) WRITE (IQPRNT,9029) LINEWH(1:N) 9029 FORMAT (13X,A) C---- Dump status word 30 IF (IQTY.EQ.JBKPRE) GO TO 31 IF (IQTY.EQ.JBKXSQ) GO TO 31 IF (IQTY.EQ.JBKMAT) GO TO 31 IF (IQTY.EQ.JBKKEE) GO TO 31 IF (IQTY.NE.JBKACT) GO TO 61 31 MSTAT = IQ(LBK) CALL UPKBYT (MSTAT,1,IQUEST,30,0) DO 32 J=1,30 IF (IQUEST(31-J).EQ.0) THEN LINEZ(J:J) = '.' ELSE LINEZ(J:J) = '1' ENDIF 32 CONTINUE IF (COLZ(27).NE.'.') COLZ(27) = 'X' IF (COLZ(28).NE.'.') COLZ(28) = 'D' IF (COLZ(29).NE.'.') COLZ(29) = 'L' IF (COLZ(30).NE.'.') COLZ(30) = 'E' IF (IQTY.EQ.JBKKEE) GO TO 33 IF (COLZ(25).NE.'.') COLZ(25) = 'K' IF (COLZ(26).NE.'.') COLZ(26) = 'D' IF (IQTY.EQ.JBKACT) GO TO 34 C-- PREP & XSQ & MAT LINE(3:8) = LINEZ(11:16) JC = JBYT(MSTAT,9,6) CALL CSETDI (JC,LINE,9,11) GO TO 36 C-- KEEP & ACT 33 IF (COLZ(25).NE.'.') COLZ(25) = 'A' IF (COLZ(26).NE.'.') COLZ(26) = 'U' 34 LINE(1:9) = LINEZ(11:19) JC = JBYT(MSTAT,9,3) CALL CSETDI (JC,LINE,10,11) 36 LINE(13:14) = LINEZ(23:24) LINE(16:17) = LINEZ(25:26) LINE(19:22) = LINEZ(27:30) 37 WRITE (IQPRNT,9037) LINE(1:22) 9037 FORMAT (13X,'st: ',A) C---- Print line content 61 IF (IQLI.EQ.0) GO TO 77 JSLA = IQ(LBK+1) NSL = IQ(LBK+2) WRITE (IQPRNT,9062) NSL,JSLA 9062 FORMAT (13X,'with',I6,' lines at JSLA',I7) IF (JSLA.EQ.0) GO TO 77 IF (JSLA.EQ.1) GO TO 77 IF (NSL.EQ.0) GO TO 77 IF (JSLA.LT.0) GO TO 93 IF (JSLA.GE.LQLSTA(5)) GO TO 93 C-- print first line in lot JSLU = JSLA JTXA = MLIAD(JSLU) JTXE = MLIAD(JSLU+1) NTX = JTXE - JTXA - NCHNEWL IF (NTX.LT.0) GO TO 94 IF (NTX.GE.513) GO TO 94 N = MIN (NTX,60) CALL LN_GET (JSLU,SLLINE,N) WRITE (IQPRNT,9063) SLLINE(1:N) 9063 FORMAT (17X,'first: ',A) 9064 FORMAT (17X,' last: ',A) C-- print last line in lot IF (NSL.LE.1) GO TO 77 JSLU = JSLA + NSL - 1 JTXA = MLIAD(JSLU) JTXE = MLIAD(JSLU+1) NTX = JTXE - JTXA - NCHNEWL IF (NTX.LT.0) GO TO 94 IF (NTX.GE.513) GO TO 94 N = MIN (NTX,60) CALL LN_GET (JSLU,SLLINE,N) WRITE (IQPRNT,9064) SLLINE(1:N) 77 RETURN C---- trouble 93 WRITE (IQPRNT,9093) 9093 FORMAT (/' ***!!! JSL invalid !!!***') GO TO 97 94 WRITE (IQPRNT,9094) JSLU,JTXA,JTXE 9094 FORMAT (/' ***!!! trouble with line at slot',I6 F/5X,'JTXA =',Z10/5X,'JTXE =',Z10) 97 IQFOUL = -1 RETURN END +SEQ, QCARDL. ===================================================== +PATCH, KERN. Pending routines for Kernlib +DECK, TMINIT, IF=QS_IBMVM. SUBROUTINE TMINIT (IFLAG) C C CERN PROGLIB# Z313 TMINIT .VERSION KERNFOR 4.37 930715 C ORIG. 16/02/94, JZ C C Initialize TMPRO / TMREAD C IFLAG = 7 RETURN END +USE, CCGEN, D=TMINIT, T=INH. +DECK, TMPRO, T=JOIN, IF=QS_IBMVM. SUBROUTINE TMPRO (TEXT) C C CERN PROGLIB# Z313 TMPRO .VERSION KERNFOR 4.37 930715 C ORIG. 16/02/94, JZ C C Print a prompt string to stdout C CHARACTER TEXT*(*) WRITE (6,9001) TEXT +SELF, IF=QS_IBMVM. 9001 FORMAT (1X,A) +SELF, IF=QS_VMS. 9001 FORMAT (1X,A,$) +SELF. RETURN END +USE, CCGEN, D=TMPRO, T=INH. +DECK, TMREAD, T=JOIN, IF=QS_IBMVM. SUBROUTINE TMREAD (MAXCH, LINE, NCH, ISTAT) C C CERN PROGLIB# Z313 TMREAD .VERSION KERNFOR 4.37 930715 C ORIG. 16/02/94, JZ C C Read the next line from stdin C CHARACTER LINE*512 READ (5,NUM=NCH,ERR=91,END=49) LINE(1:MAXCH) NCH = MIN(NCH,MAXCH) ISTAT = 0 RETURN 49 ISTAT = -1 RETURN 91 ISTAT = 7 RETURN END +USE, CCGEN, D=TMREAD, T=INH. +DECK, FTOIBM, IF=QS_IBMVM. SUBROUTINE FTOIBM (CHFI, NFI) C- Convert "name.ext.disk" or "disk/name.ext" C- to "/name ext disk" for IBM COMMON /SLATE/ NDSLAT,NESLAT,NFSLAT,NGSLAT, DUMMY(36) CHARACTER CHFI*(*) CHARACTER CHNAME*27, CHEXT*8, CHDIR*8 EQUIVALENCE (CHEXT, CHNAME(11:18)), (CHDIR, CHNAME(20:27)) CHNAME = '/' JSLASH = ICFIND ('/', CHFI,1,NFI) IF (NGSLAT.NE.0) THEN CHDIR = CHFI(1:JSLASH-1) JNAM = JSLASH + 1 ELSE CHDIR = 'A' JNAM = 1 ENDIF JDOT = ICFIND ('.', CHFI,JNAM,NFI) JDT2 = ICFIND ('.', CHFI,JDOT+1,NFI) N = MIN (8,JDOT-JNAM) IF (N.GT.0) CHNAME(2:N+1)= CHFI(JNAM:JNAM+N-1) IF (JDOT.LT.NFI) THEN CHEXT = CHFI(JDOT+1:JDT2-1) ENDIF IF (JDT2.LT.NFI) THEN CHDIR = CHFI(JDT2+1:NFI) ENDIF CALL CLTOU (CHNAME) CHFI = CHNAME NFI = LNBLNK(CHNAME) RETURN END +PATCH, TESTR. Routines used for testing +DECK, DIVLIM. SUBROUTINE DIVLIM C- Print the division limits C. started 15-june-94 +CDE, QUNIT, MQCM, Q. C-------------- End CDE -------------------------------- WRITE (IQPRNT,9011) (LQCSTA(J),LQCEND(J),J=1,3) 9011 FORMAT (/' Control divisions 1 to 3:',6I6) WRITE (IQPRNT,9012) (LQLSTA(J),LQLEND(J),J=1,4) 9012 FORMAT (/' Text divisions 1 to 4:'/' slot adr ',8I8) WRITE (IQPRNT,9013) (MLIAD(LQLSTA(J)),MLIAD(LQLEND(J)),J=1,4) 9013 FORMAT (' text adr ',8I8/) NQLLBL = 1 RETURN END +SEQ, QCARDL. ===================================================== +DECK, TNAPUT, T=JOIN. SUBROUTINE TNAPUT (IFLAG,NAME) C- Test the name handler +CDE, QUNIT, SLATE. C-------------- End CDE -------------------------------- CHARACTER NAME*(*) CHARACTER LINE*64 CALL CFILL ('xxxx',LINE,1,64) NLG = MIN (LEN(NAME), 40) LINE(11:10+NLG) = NAME(1:NLG) IF (IFLAG.NE.0) GO TO 41 C-- Find the name only JNA = NA_CHK (LINE,11,11+NLG) WRITE (IQPRNT,9024) JNA,NDSLAT,NAME RETURN C-- Put the name 41 JNA = NA_NEW (LINE,11,11+NLG) WRITE (IQPRNT,9044) JNA,NDSLAT,NAME RETURN 9024 FORMAT (4X,'Find:',I6,I4,2X,A) 9044 FORMAT (4X,'Put: ',I6,I4,2X,A) END +DECK, KMPRINT. SUBROUTINE KMPRINT C- Print the KM parameters +CDE, QUNIT, QBITA31. C-------------- End CDE -------------------------------- MUST = 1 JHAV = KM1 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMA IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM2 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMB IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM3 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMC IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM4 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMD IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM5 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KME IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM6 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMF IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM7 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMG IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM8 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMH IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM9 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMI IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM10 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMJ IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM11 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMK IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM12 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KML IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM13 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMM IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM14 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMN IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM15 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMO IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM16 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMP IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM17 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMQ IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM18 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMR IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM19 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMS IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM20 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMT IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM21 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMU IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM22 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMV IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM23 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMW IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM24 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMX IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM25 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMY IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM26 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV JHAV = KMZ IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM27 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM28 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM29 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM30 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV MUST = 2*MUST JHAV = KM31 IF (JHAV.NE.MUST) WRITE (IQPRNT,9011) MUST,JHAV RETURN 9011 FORMAT (' !!! KM for bit',I3,' is ',Z8,' !!!') END +DECK, DUMPSL. SUBROUTINE DUMPSL (JSLAX,NSLX,MSG) C- Dump the text content of the NSL slots starting at JSLA +CDE, QUNIT, Q. +CDE, SLATLN. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) JSLA = JSLAX NSL = NSLX JSLE = JSLA + NSL WRITE (IQPRNT,9000) NSL,JSLA,MSG 9000 FORMAT (/' DUMPSL: dump',I5,' lines at slot',I7,', ',A/) JSLE = MIN (JSLE, JSLA+4000) JSLU = JSLA - 1 21 JSLU = JSLU + 1 IF (JSLU.GE.JSLE) RETURN JTXA = MLIAD(JSLU) JTXE = MLIAD(JSLU+1) NTX = JTXE - JTXA - NCHNEWL IF (NTX.LT.0) GO TO 91 IF (NTX.GE.200) GO TO 91 N = MIN (NTX,68) CALL LN_GET (JSLU,SLLINE,N) WRITE (IQPRNT,9024) JSLU,SLLINE(1:N) GO TO 21 9024 FORMAT (1X,I6,1X,A) C---- trouble 91 WRITE (IQPRNT,9091) JSLU,JTXA,JTXE RETURN 9091 FORMAT (/' ***!!! trouble with line at slot',I6 F/5X,'JTXA =',Z10/5X,'JTXE =',Z10) END +SEQ, QCARDL. ===================================================== +DECK, PRHOLD. SUBROUTINE PRHOLD C- Print the status of the HOLD bank +CDE, QUNIT, MQCM, Q, PY. +CDE, SLATLN. C-------------- End CDE -------------------------------- JSLA = IQ(LQHOLD+1) NSLA = IQ(LQHOLD+2) NSLD = IQ(LQHOLD+3) JTTH = JDKTYP JTNX = JDKNEX WRITE (IQPRNT,9000) LQHOLD,JSLA,NSLD,NSLA,LQLEND(2),JTTH,JTNX 9000 FORMAT (' Xdebug: HOLD at',I5,' has JSL, NSLD, NSLALL=',I7,2I5 F/25X,'LQLEND(2) =',I7 F/25X,'type this/next=',2I4) C-- print first line in deck JSLU = JSLA JSER = JSLU - JSLA JTXA = MLIAD(JSLU) JTXE = MLIAD(JSLU+1) NTX = JTXE - JTXA - NCHNEWL IF (NTX.LT.0) GO TO 91 IF (NTX.GE.200) GO TO 91 N = MIN (NTX,40) CALL LN_GET (JSLU,SLLINE,N) WRITE (IQPRNT,9021) JSER,SLLINE(1:N) C-- print last line in deck IF (NSLD.LE.1) GO TO 23 JSLU = JSLA + NSLD - 1 JSER = JSLU - JSLA JTXA = MLIAD(JSLU) JTXE = MLIAD(JSLU+1) NTX = JTXE - JTXA - NCHNEWL IF (NTX.LT.0) GO TO 91 IF (NTX.GE.200) GO TO 91 N = MIN (NTX,40) CALL LN_GET (JSLU,SLLINE,N) WRITE (IQPRNT,9022) JSER,SLLINE(1:N) C-- print first line just after deck 23 IF (NSLA.LE.NSLD) RETURN JSLU = JSLA + NSLD JSER = JSLU - JSLA JTXA = MLIAD(JSLU) JTXE = MLIAD(JSLU+1) NTX = JTXE - JTXA - NCHNEWL IF (NTX.LT.0) GO TO 91 IF (NTX.GE.200) GO TO 91 N = MIN (NTX,40) CALL LN_GET (JSLU,SLLINE,N) WRITE (IQPRNT,9023) JSER,SLLINE(1:N) RETURN 9021 FORMAT (9X,'first in deck:',I5,1X,A) 9022 FORMAT (9X,' last in deck:',I5,1X,A) 9023 FORMAT (9X,' just after:',I5,1X,A) C---- trouble 91 WRITE (IQPRNT,9091) JSER,JTXA,JTXE RETURN 9091 FORMAT (/' ***!!! trouble with line',I5,' at slot',I6 F/5X,'JTXA =',Z10/5X,'JTXE =',Z10) END +SEQ, QCARDL. ===================================================== +DECK, DDSNAP. SUBROUTINE DDSNAP (MSG,MODE,JDIVX) C- Dump banks of division JDIVX C- if MODE =0 dump the whole division JDIV C- <0 dump what is new in division JDIV since last call +CDE, SLATLN. +CDE, QBITS19, QUNIT, MQCM, Q. +CDE, MQCN. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) CHARACTER CHK*1 SAVE LIMLA INTEGER LIMLA(3) DATA LIMLA / 0, 0, 0 / LBK = MODE JDIV = JDIVX LIMLO = 0 LIMHI = LQCEND(3) IF (LBK.GT.0) RETURN IF (LBK.NE.0) THEN CHK = ' ' ELSE CHK = '1' ENDIF WRITE (IQPRNT,9000) CHK,MSG,LBK,JDIV 9000 FORMAT (/A,'------'/' DDSNAP for ',A, F ' with MODE=',I7,' and division',I3) C-- dump division JDIV = MAX (JDIV,1) JDIV = MIN (JDIV,3) LNA = LQCSTA(JDIV) LEND = LQCEND(JDIV) IF (LBK.LT.0) THEN IF (JDIV.EQ.1) THEN IF (LIMLA(1).GT.LQCEND(1)) LIMLA(1)= 0 LIMLO = LIMLA(1) ELSEIF (JDIV.EQ.3) THEN IF (LIMLA(3).LT.LQCSTA(3)) LIMLA(3)= LEND LIMHI = LIMLA(3) ENDIF ENDIF WRITE (IQPRNT,9016) LNA,LEND 9016 FORMAT (' division boundaries:',2I7) IF (JDIV.LT.3) THEN WRITE (IQPRNT,9017) LQCSTA,LQCEND, LQLSTA, LQLEND ELSE WRITE (IQPRNT,9018) (LQ(J),J=1,23) ENDIF 9017 FORMAT (/' LQCSTA(1-3) =',3I8/' LQCEND(1-3) =',3I8/ F /' LQLSTA(1-5) =',5I8/' LQLEND(1-5) =',5I8) 9018 FORMAT (/' Wsp control links:' F/5X,'LQGARB LQHOLD LQARRV LQKEEP' /3X,4I8/ F/5X,'LQPREP LEXP LLPAST LQPAST' /3X,4I8/ F/5X,'LQUSER (2) (3) (4)' /3X,4I8/ F/5X,'LHASM LRPAM LPAM LACRAD' /3X,4I8/ F/5X,'LARRV LPCRA LDCRAB LEXD ' /3X,4I8/ F/5X,'LDECO LCRP LCRD' /3X,4I8) IF (LNA.GE.LEND) RETURN C------ next bank ---------------------- 21 CALL QBLOWX (LNA) IF (IQFOUL.NE.0) GO TO 92 LBK = IQLST IF (LBK.LT.LIMLO) GO TO 77 IF (LNA.GE.LIMHI) GO TO 79 CALL DDBANK (MSG,0) 77 LNA = IQLNX IF (LNA.LT.LEND) GO TO 21 79 IF (JDIV.EQ.1) THEN LIMLA(1) = LQCEND(1) ELSEIF (JDIV.EQ.3) THEN LIMLA(3) = LQCSTA(3) ENDIF RETURN C---- trouble 92 WRITE (IQPRNT,9092) LNA 9092 FORMAT (/' ***!!! QBLOWX does not like LNA=',I12,' !!!***') CALL P_KILL ('fatal') END +SEQ, QCARDL. ===================================================== +DECK, DDLINS. SUBROUTINE DDLINS (MSG,LBANK) C- Dump the banks of the linear structure starting at LBANK +CDE, SLATLN, QUNIT, Q. +CDE, MQCN. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) LDO = LBANK WRITE (IQPRNT,9000) MSG,LDO 9000 FORMAT (/' ------'/' DDLINS for ',A,' with LBANK=',I7) IF (LDO.LE.0) RETURN C------ next bank ---------------------- 21 CALL QNAMEX (LDO) IF (IQFOUL.NE.0) GO TO 91 CALL DDBANK (MSG,0) 77 LDO = LQ(LDO-1) IF (LDO.NE.0) GO TO 21 RETURN C---- trouble 91 WRITE (IQPRNT,9091) LDO 9091 FORMAT (/' ***!!! QNAMEX does not like LBK=',I12,' !!!***') CALL P_KILL ('fatal') END +SEQ, QCARDL. ===================================================== +DECK, DDBANK. SUBROUTINE DDBANK (MSG,LBANK) C- Dump the bank at LBANK, C- or if LBANK = 0: the last bank accessed with QNAME or QBLOW +CDE, SLATLN. +CDE, QBITS19, QBANKS, QUNIT, MQCM, QSYSBITS, Q. +CDE, MQCN. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) INTEGER INTID CHARACTER CHID*4 EQUIVALENCE (CHID,INTID) CHARACTER LINE*48, LINEZ*30, LINEWH*34 EQUIVALENCE (LINE,SLLINE), (LINEZ,SLLINE(81:)) +, (LINEWH,SLLINE(161:)) LDO = LBANK IF (LDO.LE.0) GO TO 21 WRITE (IQPRNT,9000) MSG,LDO 9000 FORMAT (/' DDBANK for ',A,' with LBANK=',I7) CALL QNAMEX (LDO) IF (IQFOUL.NE.0) GO TO 91 C---- Dump the bank 21 CALL DQBANK IF (IQFOUL.NE.0) GO TO 97 RETURN C---- trouble 91 WRITE (IQPRNT,9091) LDO 9091 FORMAT (/' ***!!! QNAMEX does not like LBK=',I12,' !!!***') 97 CALL P_KILL ('fatal') END +SEQ, QCARDL. ===================================================== +DECK, DDPREP. SUBROUTINE DDPREP C- Dump the structure of PREP banks C. started 27-apr-95 +CDE, MQCN, QUNIT. +CDE, KQADR, Q, PY. +CDE, M_ANAC. C-------------- End CDE -------------------------------- WRITE (IQPRNT,9000) 9000 FORMAT (/' Dump the PREP structure') LDOAN = KQPREP + 1 LUPAN = 0 C------ Next PREP bank 22 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) IF (LDOAN.EQ.0) RETURN CALL QNAMEX (LDOAN) IF (IQFOUL.NE.0) GO TO 91 CALL DQBANK IF (IQFOUL.NE.0) GO TO 97 L = LQ(LDOAN-2) IF (L.EQ.0) GO TO 22 IF (L.EQ.-1) GO TO 22 CALL QNAMEX (L) IF (IQFOUL.NE.0) GO TO 92 CALL DQBANK IF (IQFOUL.NE.0) GO TO 97 C---- Follow reference to foreign material 31 LOWAN = LDOAN LUPAN = L LDOAN = LUPAN - 1 34 KDOAN = LDOAN - 1 LDOAN = LQ(KDOAN) IF (LDOAN.EQ.0) THEN C-- end of chain of MAT banks LDOAN = LOWAN LUPAN = 0 GO TO 22 ENDIF CALL QNAMEX (LDOAN) IF (IQFOUL.NE.0) GO TO 91 CALL DQBANK IF (IQFOUL.NE.0) GO TO 97 GO TO 34 C---- trouble 91 L = LDOAN 92 WRITE (IQPRNT,9091) L 9091 FORMAT (/' ***!!! QNAMEX does not like LBK=',I12,' !!!***') 97 CALL P_KILL ('fatal') END +SEQ, QCARDL. ===================================================== +DECK, DUMPTB. SUBROUTINE DUMPTB (MSG) C- Dump the garbage collection table C. started 8-oct-91 +CDE, QUNIT, MQCT, QSH. C-------------- End CDE -------------------------------- CHARACTER MSG*(*) WRITE (IQPRNT,9001) MSG, LQTA,LQTB,LQTE 9001 FORMAT (/' Garbage collection table ',A//' LQTA/B/E =',3I7/) DO 44 JTB=LQTA,LQTE,3 WRITE (IQPRNT,9044) JTB,LQ(JTB),LQ(JTB+1),LQ(JTB+2) 44 CONTINUE RETURN 9044 FORMAT (1X,I7,I6,2I5) END +SEQ, QCARDL. ===================================================== +DECK, DISNAP, IF=YDIFF. SUBROUTINE DISNAP (MSKFIL,LEVEL) C- Display the structure at LQUSER(1|2) for nydiff C- MSKFIL = 1,2,3 to display file 1 or 2 or both C- LEVEL = 0 display unmatched decks only C- > 0 display all decks C. started 3-june-94 +CDE, SLATE, SLATLN, QUNIT, QBITS19, Q, PY, ADDDI. C-------------- End CDE -------------------------------- CHARACTER LINE*128, COL(128)*1 EQUIVALENCE (LINE,SLLINE),(COL,SLLINE) +SEQ, Q_AND. CALL DIVLIM JFILE = IAND (MSKFIL,1) IF (JFILE.EQ.0) GO TO 41 12 LFILE = LQUSER(JFILE) IF (LFILE.EQ.0) THEN WRITE (IQPRNT,9021) JFILE GO TO 41 ENDIF WRITE (IQPRNT,9022) JFILE, LEVEL WRITE (IQPRNT,9023) NSLMAX(JFILE),NTXMAX(JFILE) NQLLBL = 0 9021 FORMAT (/' **!! LQUSER is zero for file',I2,' **!!') 9022 FORMAT (/' Display F/P/D structure for file',I2,' LEVEL=',I3/) 9023 FORMAT (' Longest patch has',I6,' lines with',I8,' characters'/) 9024 FORMAT (' ***!!! No patches !!!***'/) 9027 FORMAT (1X,A) 21 LINE = ' f=' CALL NA_GET (IQ(LFILE+4),LINE,5) JP = MAX (NESLAT-1,13) + 1 IF (JFILE.EQ.2) THEN IF (IAND(IQ(LFILE),KM3) .EQ.0) COL(JP+1) = 'o' ENDIF IF (IAND(IQ(LFILE),KM2) .EQ.0) COL(JP+2) = 'u' IF (IAND(IQ(LFILE),KM1) .NE.0) COL(JP+3) = 'e' IF (LQ(LFILE-2) .EQ.0) COL(JP+5) = '*' JP = JP + 6 WRITE (IQPRNT,9027) LINE(1:JP) LPAT = LQ(LFILE-4) IF (LPAT.EQ.0) THEN WRITE (IQPRNT,9024) GO TO 39 ENDIF C---- each patch 24 LINE = 'p=' CALL NA_GET (IQ(LPAT+4),LINE,3) JP = MAX (NESLAT-1,12) + 1 IF (JFILE.EQ.2) THEN IF (IAND(IQ(LPAT),KM4) .NE.0) COL(JP+1) = '<' IF (IAND(IQ(LPAT),KM3) .EQ.0) COL(JP+2) = 'o' ENDIF IF (IAND(IQ(LPAT),KM2) .EQ.0) COL(JP+3) = 'u' IF (IAND(IQ(LPAT),KM1) .NE.0) COL(JP+4) = 'e' IF (IQ(LPAT+1) .NE.0) COL(JP+5) = '.' IF (LQ(LPAT-2) .EQ.0) COL(JP+6) = '*' JP = JP + 7 CALL CSETDI (IQ(LPAT+5),LINE,JP+1,JP+4) CALL CLEFT (LINE,JP+1,JP+4) JP = NESLAT LDKN = LQ(LPAT-4) NDK = 0 MISS = 0 +SEQ, QEJECT. C-- each deck 31 LDECK = LDKN IF (LDECK.EQ.0) THEN LINE(JP+2:) = '!! no decks !!' JP = LENOCC (LINE) GO TO 37 ENDIF LDKN = LQ(LDECK-1) IF (LEVEL.LE.0) THEN IF (LQ(LDECK-2).NE.0) GO TO 37 ENDIF NDK = NDK + 1 IF (NDK.GE.4) THEN IF (LDKN.EQ.0) GO TO 34 IF (MISS.NE.0) GO TO 37 LINE(JP+2:JP+4) = '...' JP = JP + 4 MISS = 7 GO TO 37 ENDIF 34 JP = JP + 2 CALL CSETDI (IQ(LDECK+5),LINE,JP,JP+2) CALL CLEFT (LINE,JP,JP+2) JP = NESLAT IF (LQ(LDECK-2).EQ.0) THEN COL(JP) = '*' JP = JP + 1 ENDIF CALL NA_GET (IQ(LDECK+4),LINE,JP+1) JP = NESLAT - 1 37 IF (LDKN.NE.0) GO TO 31 WRITE (IQPRNT,9027) LINE(1:JP) LPAT = LQ(LPAT-1) IF (LPAT.NE.0) GO TO 24 39 LFILE = LQ(LFILE-1) IF (LFILE.NE.0) GO TO 21 41 IF (JFILE.EQ.2) RETURN JFILE = IAND (MSKFIL,2) IF (JFILE.NE.0) GO TO 12 RETURN END +SEQ, QCARDL. ===================================================== +DECK, DIDUMPM, IF=YDIFF. SUBROUTINE DIDUMPM (LPAT) C- Dump a patch in memory for nydiff C. started 24-june-94 +CDE, SLATE, QUNIT, Q. C-------------- End CDE -------------------------------- CHARACTER LINE*256 LP = LPAT CALL NA_GET (IQ(LP+4),LINE,1) N = NDSLAT WRITE (IQPRNT,9001) LINE(1:N),LP, (IQ(LP+J),J=1,3) 9001 FORMAT (/' .Dump patch ',A,' in memory, LP =',I6/ F/' JSL/NSL/NTX =',2I6,I7) LD = LQ(LPAT-4) 24 IF (LD.EQ.0) RETURN CALL NA_GET (IQ(LD+4),LINE,1) N = NDSLAT WRITE (IQPRNT,9002) LINE(1:N),LD, (IQ(LD+J),J=1,3) 9002 FORMAT (/' --- Deck ',A,' at LD =',I6,' JSL/NSL/NTX =',2I6,I7/) JSL = IQ(LD+1) NSL = IQ(LD+2) JNO = 0 DO 27 J=1,NSL CALL LN_GET (JSL,LINE,99) WRITE (IQPRNT,9024) JNO,LINE(1:NDSLAT) 9024 FORMAT (I6,' - ',A) JNO = JNO + 1 27 JSL = JSL + 1 LD = LQ(LD-1) GO TO 24 END +SEQ, QCARDL. ===================================================== +DECK, CATCH, T=JOIN. SUBROUTINE CATCH (NUM) C- To allow breakpoint setting PRINT *, 'arrived in CATCH, NUM= ',NUM RETURN END +SEQ, QCARDL. ===================================================== +PATCH, PAMEND, T=JOIN. last line of PATCHY Pam