~)<RPG TAPE: A RPGGEN ABSRPGALIB RPG)~#<} NAMENAMEEXTRPG TAPE: #8 ISAM COMMUNICATIONS AREA (PAGE).- JMP G:PTFDSK ISAM OVERLAY RETURN VECTORS JMP G:ISAEXP JMP G:ERROR JMP G:EACONV XIF. IFS Z:ISAM.MPORARY..S8 LLC LMB RET VALUE STORED, RETURN..DATE+3LRNS<#b/L:XINERR HL L:ILLDAT DISPLAY MESSAGE, RETRY CALL P:DSPLY$.'L:XINRD HL L:XINMSG DISPLAY MESSAGE CALL P:DSPLY$. CALL G:GETMSG GET REPLY, EXIT TO MAINLINE. XIF. EBCDIC* G:GETMSG F:UMONTHZ:DATE Z:EXTIND Z:DFILES G:OPTDSK+3LRNS CALL P:DECHL LBMA LADT?S<%. (DUMMY INPUT FIELD PROCESSOR ALSO).+* SET RECORD IDENT INDICATOR EXIT SEQUENCE. AND REQUEST NEXT RECORD. IFS Z:MATCHL:MATCH PUSH MLA *MRPSW MSA MRSW POP XIF L:NOMAT LBH LAL MOVE BACK TO ORIGIN SU 1 OF FDB LCA POPT?S HL LLC LCA.'O:MVNLP LAM GET DIGIT PART OF SOURCE ND 0017 LBA CALL P:INCSWP LAM MOVE IN DIGIT ONLY ND 0360 ORB LMA CALL P:INCSWP LAC DONE? SU 1 RTZ YES, RETURNT ARGSS ZERO FILL 'TO' FIELD. XR 0377 NEGATE LDIFF AD 1 O:G6ARGSTS< LCA COUNT (LSB) LAB FILL CHAR LB 0 COUNT (MSB) LHD LLE' CALL P:BLKSET ZERO FILL 'TO' FIELD LDH LEL DE=HL+C JMP O:ZADMOV.O:ZADCLZ LCA COUNT (LSB)). DELETED LAB ; AND LB 0 ; FEB 12,1975  POPE LDIFF AD 1 O:G6ARGSTS<]& CALL P:BLKCHK CHECK LEADING ZEROS PUSH JFZ O:EROVFL.O:ZADMOV MLC *O:INDX POP AFROM&O:ZADGO* LB '0' ENTRY FROM G:CVSTI.7. BLOCK SET WITH ZERO UNTIL NON-ZERO DIGIT ENCOUNTERED.O:ZADL1 LAC LAST DIGIT? SU 1 JTZ O:ZADX1 YESS< LCA NO LAM ZERO? CP '0'! JFZ O:ZADN1 NO, TO MAIN LOOP! CALL P:INCSWP YES, STORE '0' LMB CALL P:INCSWP JMP O:ZADL1.,O:ZADX1 CALL O:GTSIGN PROCESS LAST DIGIT LBA GET SIGN! CALL O:GDIGIT GET DIGIT PARTJTZ O:ZADX1 YESS<6o ORA STILL ZERO?" JFZ O:ZADN2 NO, TO NORMAL END LA 0300 YES, STORE +0 LHD LLE LMA LA ZBIT AND SET ZERO COND MSA *SZFLAG- JMP O:TSTST RETURN WITH PROPER COND CODE.3. BLOCK TRANSFER ALL BUT LAST DIGIT. CHECK DIGITS..X1 YESS<HO:ZADL2 LAC DECR INDX SU 1 JTZ O:ZADX2 LCAO:ZADN1 CALL O:GBYTE LBM CALL P:INCSWP LMB CALL P:INCSWP JMP O:ZADL2.O:ZADX2 CALL O:GTSIGN LBA CALL O:GDIGITO:ZADN2 ORB OR SIGN BACK IN HL O:ZSIGNK DIGITS..X1 YESS OP2.!O:COMP2 LCA STORE LENGTH INDEX LHD LLE HL= REST OF OP2 CALL P:BLNCHK CMPR WITH ' ' JTZ O:COMPEZ (EQUAL) LB SBIT JMP O:COMPZZ OP1 < OP2.O:COMPEZ LB ZBIT SET TZSS<  JMP O:COMPZZO:COMPND LB 0 JFC O:COMPZZ SET FS,FZ LB SBIT ELSE SET TSO:COMPZZ MSB *SZFLAG# JMP O:TSTST RETURN WITH CND CD* O:COMPSTO:COMPZ:ASCIIO:LDIFFO:INDX P:INCSWPSZFLAG G:EACONVSBIT P:BLNCHKO:TSTST O:G6ARGSZBITZSS8 LLB INDICATOR LSBZSS<) LMC SET OR CLEAR RET.O:TIND* POP TEST INDICATOR LBM CALL P:INCHL PUSH LH INDTAB>8 LLB LAM ORA RETURN HARDWARE FLAGS RET*O:CINDO:TINDO:SINDP:INCHLINDTABhdh`hh! IDENT 0 RESULTING IND ROUTINE QUAL O.SS<!O:RIND* POP GET FIRST ARG IN D LDM CALL P:INCHL PUSH LC 8 SET OFF SPEC INDS.O:RINDL1 LAC SRC DONE? JTC O:RIND1 YES, TO IND SET LCA NDD IND SPEC? JTZ O:RINDL1 NO, LOOP PUSH YES, RESET IT LLM LH INDTAB>8 XRASS< LMA POP CALL P:INCHL JMP O:RINDL1.O:RIND1 LC 8 INDEX=4,2,1 LE 1 SET E=4 2 OR 1, MLA *SZFLAG FOR + - OR 0 ND ZBIT! JFZ O:RINDL2 JMP ZERO BIT ON LE 2 ZBIT OFF LAM ND SBIT! JFZ O:RINDL2 JMP SIGN BIT ON XRASS8 LA 0377SS8 LA 0377SS8 LA 0377SS< ) JFZ O:ADCKEX NO (NOTE +0 STOPS SCAN) CALL P:INCHL YES, CONTINUE LAD SU 1 DECR LEN OP2 LDA JFZ O:ADCKLZ$ CALL O:ERDIGT NOTE FORMAT ERROR.&O:ADCKEX PUSH FOUND FIRST SIG DIGIT MLA *O:LOP1 OVERFLOW? SUDDTAB>8 LA 0377SS< JTS O:EROVFL YES LAD RECOMP LDIFF, LOP2, INDX SUM! MSA O:LDIFF (NOTE LDIFF < 1) MSD O:LOP2 MSD O:INDX POP LDH RESTORE DE, ETC LEL. LA ZBIT MSA *O:ADZFLG MLA *O:LOP1 SU 1 LHB DERIVE ADDR. AT LLC END OF OP1S< CALL P:ADDHL CALL O:GTSIGN LBA PUSH SAVE ADDR LSD, OP1 MSA *O:ADSIGN SAVE SIGN MLA *O:LOP2 SU 1 LHD DERIVE ADDR AT LLE END OF OP2 CALL P:ADDHL CALL O:GTSIGN PUSH SAVE ADDR LSD, OP2 CPB COMPARE SIGNSEND OF OP1S<4 MLA *O:ADOPER JTZ O:ADD02 SAME => ADD SU 1 CHANGE OPERATION LMA!O:ADD02 DE O:UADD MODIFY CODE ORA IN MAIN LOOP JTZ O:ADD03 DE O:USUBO:ADD03 MSE *O:ADLOOP+1 MSD *O:ADLOOP+2 MSE *O:ADCY+1 MSD *O:ADCY+2END OF OP1S<8 POP ADDR LSD, OP2 CALL O:GDIGIT LCA& CALL P:DECSWP DE GETS LSD OP2 - 1 POP ADDR LSD, OP1& PUSH (THIS PUSH LASTS UNTIL ADSGN) CALL O:GDIGITO:ADLOOP CALL $-$ UADD/USUB LMA STORE BYTE PUSH ADR OP1 CP '0' ZERO?D OF OP1S<  JTZ O:ADLOP1 XRA SET OFF 'ZERO' FLAG MSA *O:ADZFLGO:ADLOP1 MLA *O:INDX SU 1 JTZ O:ADD90 LMA SAVE INDEX POP ADR OP1 CALL P:DECSWP GET OP2 DIGIT CALL O:GBYTE' ADC ADD CARRY (NOTE CLEVER BORROW!) LCA ZERO?D OF OP1S<? CALL P:DECSWP GET OP1 DIGIT CALL O:GBYTE JMP O:ADLOOP.+. CHECK FOR OVERFLOW AND DECIDE NEXT STEP..9. NOTE: THE STACK CONTAINS THE CURRENT OP2 ADDR AND THE-. OP2 LSB ADDR BEFORE THE SUBR RETURN OCCURSVER BORROW!) LCA ZERO?D OF OP1S8 AC 0 MSA *G:SQRT5+5 LAE INIT ROOT TO ZERO SU 1 HL G:SQROOT JTZ G:SQRTE LCA LA 0360 LB 0 CALL P:BLKSET1T2S< "G:SQRTE LA 0300 LMA HL G:SQROOT# PUSH SAVE ADDR FIRST ROOT DIGIT*'. INSTRUCTIONS SET UP - CALCULATE ROOT.G:SQRT1 LA '9' INIT DIGIT LMA#G:SQRT2 CALL O:ZADD TEMP _ ROOT%G:SQRT3 DC 0,*G:SQRTMP,0,*G:SQROOT0 CALL P:BLKSET1T2S<~# CALL O:MULT TEMP _ TEMP * ROOT%G:SQRT4 DC 0,*G:SQRTMP,0,*G:SQROOT$ CALL O:SUB TEMP _ TEMP - FACTOR G:SQRT5 DC 0,*G:SQRTMP,0,*$-$ POP JTZ G:SQRT8 0 - FOUND ROOT PUSH JTS G:SQRT6 <0 LAM >0 - DEC DIGIT SU 1 LMA CP '0'S<- JFZ G:SQRT2 TRY AGAIN*. FOUND LARGEST PARTIAL ROOT. ADVANCE TO NEXT DIGIT. G:SQRT6 POP CALL P:INCHL PUSH MLA *G:SQRCNT DEC COUNTER SU 1 LMA POP JTS G:SQRT8 NO MORE DIGITS PUSH JFZ G:SQRT1 DO NEXT DIGITA CP '0'S<)# LA 0311 LAST DIGIT - SET TO +9 LMA JMP G:SQRT2*'. ZERO FACTOR - SET SZFLAG ACCORDINGLY.G:SQRT7 LA ZBIT MSA *SZFLAG" JMP O:TSTST SET MACHINE STATE* . ALL ROOT POSITIONS CALCULATED.)G:SQRT8 CALL O:ZADD MOVE ROOT TO ACCA '0'S LAST DIGIT +1 LD 5 INCR +5O:HLFAJ1 LAM ND 017 STRIP SIGN ETC.'S<w ADD INCR DIGIT LEA LD 0 SU 10 CARRY? JTC $+6 NO LEA LD 1 LAM ND 0360 COMBINE ORE LMA AND REPLACE CALL P:DECHL LAC SU 1 DECREMENT COUNT LCA JFC O:HLFAJ1 CONTINUE LAD ORA CFZ O:EROVFL OVERFLOW!'S LEM GET ADDR(FIELD) CALL P:INCHL LDM CALL P:INCHL PUSH LHD LLE LAM GET THE BYTE ORB MERGE IN MASK BITS LMA RET*O:BITONP:INCHL IDENT 0 BITOF QUAL O.O:BITOF* POP LEM GET ADDR(FIELD)ITION?TDS<J CALL P:INCHL LDM CALL P:INCHL PUSH LHD LLE LAB GET MASK XR 0377 COMPLEMENT IT NDM MASK OUT BITS LMA RET*O:BITOFP:INCHL`i IDENT 0 TESTB QUAL O.O:TESTB* LAB LOOK AT MASK ORAR(FIELD)ITION?TDS<< JTZ O:TESTB2 ALL BITS OFF POP LEM GET ADDR(FIELD) CALL P:INCHL LDM CALL P:INCHL PUSH LHD LLE! LAM GET THE BYTE TO BE TESTED NDB LC 0$ JTZ O:TESTB1 ALL OFF - SET HIGH CPB LC ZBITAT MASK ORAR(FIELD)ITION?TDS<(Y$ JTZ O:TESTB1 ALL ON - SET EQUAL LC SBIT MIXED - SET LOWO:TESTB1 MSC *SZFLAG# JMP O:RIND SET RESULTING IND'S**. NO MASK BITS SET - CLEAR THE INDICATORS.O:TESTB2 POP LA 2 SKIP FIRST ARG CALL P:ADDHL LBM GET INDICATOR MASKS8 XRA LMA SET TO 0 LAD DEC COUNT SU 1 LDA RTZ JMP O:TESTB3*O:TESTBSZFLAGO:RINDP:INCHLSBITP:ADDHLZBITINDTAB' IDENT 0 EDIT QUAL O. O:EDFILL SK 1 FILL CHARACTER TM 2H LLCOR MASKS<%O:EDSOS SK 2 ADDRESS OF SOS (L,H).O:EDIT* POP GET FILL CHAR LBM CALL P:INCHL PUSH MSB *O:EDFILL DE $+7 JMP O:G6ARGS MLA *O:EDFILL FILL TO (A) LHB HL=ADR EDIT 'TO' FIELD LLC LC 0 INIT SOS FLAG CP '0' ZERO FILL?S<% JFZ O:EDITLP NO, START EDIT.! LCL YES, TURN ON SIGNIFICANCE PUSH MSC *O:EDSOS MSB O:EDSOS+1 POP LC 0377 INIT SOS FLAG.O:EDITLP LAM GET 'TO' CHAR CP 020 * DIGIT SELECT CHAR" JTZ O:EDGETD JMP DIGIT SELECT0' ZERO FILL?S HL SU 1 LLA LAD SB 0 LHA LAM GET FROM DIGIT POP RESTORE 'TO' ND 0360 MASK SIGN CP 0320 RTZ IF NEGATIVE RETURN PUSH ELSE BLANK MINUS OR CR MLA *O:LOP1 LENGTH POPG FLAG LCAS<5? ORA RETURN IF NO MORE CHARS RTZ LB 0 LCA( JMP P:BLNSET BLANK MINUS OR CR AREA*1O:FLDOL* MLA *O:EDSOS FLOATING DOLLAR ROUTINE MLH O:EDSOS+1 LLA LA '$' LMA RET*O:EDITO:FLDOLO:LOP2O:LOP1P:DECHL O:GTSIGNO:GBYTE LCAS< P:BLNSETP:INCHL O:G6ARGS O:GDIGIT5aj IDENT 0 TABLE FIRST ELEMENT QUAL O.O:FSTEL* POP GET ADDR(TDB) LEM CALL P:INCHL LDM CALL P:INCHL PUSH LHD LLE PUSH! LAL FUDGE CEN TO FORCE UPDATE AD DCENTD LLA LCAS< LB 0 LMB AD 1 LLA LMB POP LC 1 INDEX _ 1 JMP O:TABLE GET THE ELEMENT*O:FSTELP:INCHLDCENTDO:TABLE¿ IDENT 0 TABLE NEXT ELEMENT QUAL O.'. RETURNS TRUE ZERO IF NO NEXT ELEMENT. AD DCENTD LLA LCAS<8O:NXTEL* POP GET ADDR(TDB) LEM CALL P:INCHL LDM CALL P:INCHL PUSH LHD LLE PUSH LAL GET CURRENT INDEX AD DCENTD LLA LDM AD 1 LLA LEM POP GET MAX INDEX PUSH LAL AD DNELTD LLA LBM AD 1 LLA LCMASG:TALNDM DC 011,0,013,11,023,'NO DATA FOR TABLE OR ARRAY',3 EBCDICS IDENT 5 SYMBOLIC TO INTERNAL QUAL G.D. INTERFACE TO ZADD FOR CONVERTING LEADING BLANKS TO LEADING ZEROS..G:CVSTI* POP LCM C=LENGTH CALL P:INCHL LEM DE=DESTINATION CALL P:INCHL LDMHS<03 CALL P:INCHL LBM HL=SOURCE ADR CALL P:INCHL PUSH MSB *O:ZSIGN TEMP STORAGE POP LBM CALL P:INCHL PUSH SAVE RETURN MLL *O:ZSIGN LHB PUSH SAVE FROM ADR XRA! MSA *O:ZSIGN FAKE ZADD ENTRY LB '0' FILL CHAR POP.S<rG:CVSLP LAM GET FROM CHAR CP ' ' IF NOT BLANK, JFZ O:ZADGO JMP INTO ZADD CALL P:INCSWP LMB STORE '0' LAC SU 1 DECR INDEX JTZ G:CVSEND LCA CALL P:INCSWP JMP G:CVSLP.G:CVSEND LA 0300 STORE '+0' LMA LA ZBIT.S<*v MSA *SZFLAG JMP O:TSTST RET WITH CND CD*G:CVSTIO:ZADGOSZFLAG P:INCSWPP:INCHLO:ZSIGNZBITO:TSTSTlu IDENT 5 INTERNAL TO SYMBOLIC QUAL G.. ROUTINE TO REMOVE THE . PLUS ZONE. INVERSE OF CVSTI..G:CVITS* POPBIT.S<@ LCM LENGTH CALL P:INCHL LEM DESTINATION (LSB) CALL P:INCHL LDM CALL P:INCHL LBM SOURCE PUSH MSB *O:INDX POP CALL P:INCHL LBM CALL P:INCHL PUSH SAVE RETURN POINT MLL *O:INDX LHB. G:CVILP LAC SU 1BIT.S<]  JTZ G:CVIEND LCA CALL O:GBYTE CHECK DIGIT OR 0360 CONV TO EBCDIC LBA CALL P:INCSWP LMB CALL P:INCSWP JMP G:CVILP.-G:CVIEND CALL O:GTSIGN GET AND CHECK SIGN CP 0320 NEG? JTZ $+5 YES LA 0360 NO, STRIP '+'T.S8 LMB RET. EBCDIC*G:RDTSTERRORP:INCHLMEOFFD0S<INDTAB/T-/+/4 IDENT 5 RE-TRY PROCESSOR QUAL G ASCII.%. CALLED WITH CURSOR POSITION IN DE.1. RETURN IF 'Y' KEYED IN, JUMP TO :ERROR IF 'N'..3G:RTYERM DC 011,0,013,11,023,'RE-TRY DECLINED',3G:RTYERL DC 022,3.P:INCHLMEOFFD0S<.G:RETRY* LHD SAVE DE LLE PUSH HL KEYBUF LC 2 CALL P:KEYIN$ MLA *KEYBUF CP 'N' DE G:RTYERM JTZ ERROR POP LDH RESTORE DE LEL CP 'Y' RTZ SUCCESS RETURN EX BEEP HL G:RTYERL CALL P:DSPLY$P:INCHLMEOFFD0S