// JOB CSP00010 // ASM CSP00020 * NAME ADD CSP00030 ** ADD/SUB SUBROUTINES FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP00040 * LIST CSP00050 ENT ADD ADD SUBROUTINE ENTRY POINT CSP00060 * CALL ADD(JCARD,J,JLAST,KCARD,K,KLAST,NER) CSP00070 * THE FIELD JCARD(J) THROUGH CSP00080 * JCARD(JLAST) IS ADDED TO THE CSP00090 * FIELD KCARD(K) THROUGH CSP00100 * KCARD(KLAST). CSP00110 ENT SUB SUBTRACT SUBROUTINE ENTRY POINT CSP00120 * CALL SUB(JCARD,J,JLAST,KCARD,K,KLAST,NER) CSP00130 * THE FIELD JCARD(J) THROUGH CSP00140 * JCARD(JLAST) IS SUBTRACTED FROM CSP00150 * THE FIELD KCARD(K) THROUGH CSP00160 * KCARD(KLAST). CSP00170 SUB DC *-* ARGUMENT ADDRESS COMES IN HERE. CSP00180 LD SUB PICK UP ARGUMENT ADDRESS. CSP00190 STO ADD STORE IT AT ADD. CSP00200 LD IHFS LOAD THE INSTRUCTION TO CHANGE CSP00210 STO SWIT SIGN OF JCARD FOR SUBTRACT. CSP00220 MDX ADD+3 START COMPUTING. CSP00230 IHFS EOR X HFFFF-SWIT-1 CHANGE SIGN OF SUBTRHND CSP00240 MDX MDX *+2 SKIP OVER NEXT INSTRUCTION. CSP00250 ADD DC *-* ARGUMENT ADDRESS COMES IN HERE. CSP00260 LD MDX LOAD SKIP OVER INSTRUCTION. CSP00270 STO SWIT STORE IT AT SWIT. CSP00280 STX 1 SAVE1+1 SAVE IR1. CSP00290 LDX I1 ADD PUT ARGUMENT ADDRESS IN IR1 CSP00300 LD 1 0 GET JCARD ADDRESS CSP00310 S I1 2 SUBTRACT JLAST VALUE CSP00320 STO DO+1 PLACE ADDRESS FOR ADD OR SUBTR CSP00330 A ONE+1 ADD CONSTANT OF ONE CSP00340 STO JPLUS+1 CREATE JCARD(JLAST) ADDRESS CSP00350 LD I1 2 GET JLAST VALUE CSP00360 ONE S I1 1 SUBTRACT J VALUE CSP00370 A ONE+1 ADD CONSTANT OF ONE CSP00380 BSC + SKIP IF POSITIVE CSP00390 LD ONE+1 NEGATIVE OR ZERO-MAKE COUNT 1 CSP00400 STO COUNT+1 STORE JCARD LENGTH CSP00410 LD 1 3 GET KCARD ADDRESS CSP00420 STO KCRD1 PLACE IN CALLING SEQUENCE OF CSP00430 STO KCRD2 CARRY AND FILL SUBROUTINES CSP00440 S I1 5 SUBTRACT KLAST VALUE CSP00450 STO KCRD3+1 PLACE LOAD ADDR FOR ADD/SUB CSP00460 STO KCRD4+1 PLACE STORE ADDR FOR RESULT CSP00470 STO KCRD5+1 PLACE SUBTRACT ADDRESS AND CSP00480 STO KCRD6+1 STORE ADDR FOR NEG CARRY CSP00490 A ONE+1 ADD CONSTANT OF ONE CSP00500 STO KCRD7+1 PLACE ADDR FOR SIGN CHANGE CSP00510 STO KPLUS+1 PLACE ADDR OF SIGN OF KCARD CSP00520 LD 1 6 GET NER ADDRESS CSP00530 STO ERA+1 SAVE NER ADDRESS CSP00540 * CLEAR AND SAVE SIGNS ON JCARD CSP00550 * AND KCARD FIELDS. CSP00560 JPLUS LD L *-* GET SIGN OF JCARD CSP00570 STO JSIGN SAVE SIGN OF JCARD CSP00580 SWIT MDX *+2 SKIP ON ADD-CHANGE SIGN ON SUBT CSP00590 STO I JPLUS+1 STORE CHANGED SIGN OF JCARD CSP00600 BSC L KPLUS,- DETERMINE SIGN OF JCARD CSP00610 EOR HFFFF NEGATIVE - MAKE POSITIVE CSP00620 STO I JPLUS+1 STORE IT POSITIVE CSP00630 MDX L OP,1 CHANGE OPERATION - SEE OP & OPR CSP00640 KPLUS LD L *-* GET SIGN OF KCARD CSP00650 STO KSIGN SAVE SIGN OF KCARD CSP00660 BSC L OP,- DETERMINE SIGN OF KCARD CSP00670 EOR HFFFF NEGATIVE - MAKE POSITIVE CSP00680 STO I KPLUS+1 STORE IT POSITIVE CSP00690 MDX L OP,1 CHANGE OPERATION - SEE OP & OPR CSP00700 * CALCULATE THE OPERATION. CSP00710 * INITIALLY THIS IS FOR ADD. IT CSP00720 * CAN BE CHANGED UP TO TWO TIMES, CSP00730 * FIRST TO SUBTRACT AND THEN BACK CSP00740 * AGAIN TO ADD. SEE OPR. CSP00750 OP LD OPR PICK UP OPERATION CSP00760 STO DO STORE IT AT DO CSP00770 LD OPO RESET THE PICK UP INSTRCTN TO + CSP00780 STO OP WITH INSTRUCTION AT OPO CSP00790 LD 1 4 GET ADDRESS OF K CSP00800 STO K1 STORE IT AT K1 FOR CARRY SUBRTN CSP00810 STO K2 AND AT K2 FOR FILL SUBROUTINE CSP00820 * DETERMINE IF JCARD IS LONGER CSP00830 * THAN KCARD. KLAST-JLAST+J=KNOW CSP00840 * IS COMPARED TO K. IF KNOW IS CSP00850 * GREATER THAN OR EQUAL TO K GO CSP00860 * TO KLAS3 FOR ERROR. CSP00870 LD I1 5 GET KLAST VALUE CSP00880 STO KLAS3+1 SAVE IT TO INDICATE ERROR CSP00890 S I1 4 SUBTRACT K VALUE CSP00900 STO COMP+1 SAVE FOR CMPLMNT ON NEG CARRY CSP00910 S I1 2 SUBTRACT JLAST VALUE CSP00920 A I1 1 ADD J VALUE CSP00930 BSC L RETAD,+Z IS JCARD LONGER THAN KCARD CSP00940 MDX 1 7 NO-OK-MOVE OVER SEVEN ARGUMENTS CSP00950 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP00960 * SETUP JNOW CSP00970 COUNT LDX L1 *-* LOAD JCARD LENGTH TO IR1 CSP00980 * KCARD(KNOW)=KCARD(KNOW) + OR - CSP00990 * JCARD(JNOW) CSP01000 KCRD3 LD L1 *-* LOAD KCARD(KNOW) CSP01010 DO A L1 *-* ADD OR SUBTRACT JCARD(JNOW) CSP01020 KCRD4 STO L1 *-* STORE RESULT IN KCARD(KNOW) CSP01030 * KNOW=KNOW+1 AND SEE IF JNOW IS CSP01040 * GREATER THAN JLAST. IF NOT, CSP01050 * JNOW=JNOW+1 AND GO BACK FOR CSP01060 * MORE. CSP01070 MDX 1 -1 DECREMENT IR1 CSP01080 MDX KCRD3 GO BACK FOR MORE CSP01090 * RESOLVE CARRIES GENERATED CSP01100 * DURING OPERATION. CSP01110 AGAIN CALL CARRY GO TO CARRY SUBROUTINE CSP01120 KCRD1 DC *-* KCARD ADDRESS CSP01130 K1 DC *-* K ADDRESS CSP01140 KLAS1 DC KLAS3+1 KLAST ADDRESS CSP01150 DC ADD ADDRESS TO HOLD ANY CARRY CSP01160 * LET KNOW BE ANY RESULTING CARRY CSP01170 * IF NEGATIVE, COMPLIMENT AND CSP01180 * CHANGE THE SIGN OF KCARD. IF CSP01190 * ZERO, ALL DONE. IF POSITIVE, CSP01200 * OVERFLOW ERROR. CSP01210 BSC L FIN,+- CHECK FOR ZERO-YES GO TO FIN CSP01220 BSC L ERR9,- NO-CHECK FOR OVERFLOW-YES ERR9 CSP01230 KCRD7 A L *-* COMPLIMENT-ADD CARRY TO LOW CSP01240 STO I KCRD7+1 ORDER AND STORE IT BACK CSP01250 * COMPLIMENT - SUBTRACT EACH CSP01260 * DIGIT FROM 9 AND CHANGE THE CSP01270 * SIGN OF KCARD. CSP01280 COMP LDX L1 *-* LOAD IR1 WITH LENGTH OF KCARD CSP01290 MDX 1 1 ADD 1 TO GET THE TRUE LENGTH CSP01300 LD NINE LOAD A NINE. CSP01310 KCRD5 S L1 *-* SUBTRACT KCARD(KNOW) CSP01320 KCRD6 STO L1 *-* PUT BACK IN KCARD(KNOW) CSP01330 * SEE IF KNOW IS GREATER THAN CSP01340 * KLAST. IF NOT, KNOW=KNOW+1 CSP01350 MDX 1 -1 DECREMENT IR1 CSP01360 MDX COMP+3 GO BACK FOR MORE CSP01370 LD KSIGN CSP01380 EOR KCRD6 CSP01390 STO KSIGN SET SIGN OF KCARD CSP01400 MDX AGAIN CHECK AGAIN FOR CARRIES CSP01410 SAVE1 LDX L1 *-* RESTORE IR1 CSP01420 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP01430 * ERROR - ERROR - OVERFLOW- - - - CSP01440 ERR9 CALL FILL FILL KCARD WITH NINES. CSP01450 KCRD2 DC *-* ADDRESS OF KCARD CSP01460 K2 DC *-* ADDRESS OF K CSP01470 KLAS2 DC KLAS3+1 ADDRESS KLAST CSP01480 DC NINE FILL CHARACTER CSP01490 KLAS3 LDX L1 *-* PICK UP KLAST VALUE CSP01500 ERA STX L1 *-* STORE VALUE AT NER CSP01510 * RESTORE SIGNS ON JCARD AND CSP01520 * KCARD FIELDS CSP01530 FIN LD JSIGN PICK UP SIGN OF JCARD CSP01540 STO I JPLUS+1 AND RESTORE IT CSP01550 LD KSIGN PICK UP SIGN OF KCARD CSP01560 BSC L NEG,+Z CHECK FOR PLUS OR MINUS CSP01570 LD I KPLUS+1 PLUS-GET NEW SIGN AND CSP01580 BSC L REV,+Z REVERSE IT IF NEGATIVE CSP01590 MDX SAVE1 POSITIVE-ALL DONE-GO TO EXIT.. CSP01600 NEG LD I KPLUS+1 MINUS-GET NEW SIGN AND CSP01610 BSC L SAVE1,+Z GO TO EXIT IF NOT NEGATIVE CSP01620 REV EOR HFFFF REVERSE THE SIGN CSP01630 STO I KPLUS+1 STORE IT BACK CSP01640 MDX SAVE1 ALL DONE-GO TO EXIT........... CSP01650 HFFFF DC /FFFF CONSTANT OF ALL BINARY ONES CSP01660 JSIGN DC *-* SIGN OF JCARD CSP01670 KSIGN DC *-* SIGN OF KCARD CSP01680 NINE DC 9 CONSTANT OF NINE CSP01690 RETAD MDX 1 7 MOVE OVER SEVEN ARGUMENTS CSP01700 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP01710 BSC L KLAS3 GO TO KLAS3 CSP01720 OPR A L1 *-* ADD FOR ADD OR SUBTRACT OPERATN CSP01730 ORG OPR+1 RESET THE ADDRESS COUNTER CSP01740 S L1 *-* SUBTR FOR ADD OR SUBTR OPRATN CSP01750 ORG OPR+2 RESET THE ADDRESS COUNTER CSP01760 A L1 *-* ADD FOR ADD OR SUBTRACT OPERATN CSP01770 ORG OPR+3 RESET THE ADDRESS COUNTER CSP01780 OPO LD X OPR-OP-1 FOR RESETING THE INSTRCTN CSP01790 * AT OP TO ITS INITIAL STATE.. CSP01800 END CSP01810 // DUP CSP01820 *STORE WS UA ADD CSP01830 // ASM CSP01840 ** A1A3/A3A1 SUBROUTINES FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP01850 * NAME A1A3 CSP01860 * LIST CSP01870 ENT A1A3 A1A3 SUBROUTINE ENTRY POINT CSP01880 * CALL A1A3(JCARD,J,JLAST,KCARD,K,ICHAR) CSP01890 * THE WORDS JCARD(J) THROUGH CSP01900 * JCARD(JLAST) IN A1 FORMAT ARE CSP01910 * CRAMMED INTO KCARD IN A3 FORMAT. CSP01920 ENT A3A1 A3A1 SUBROUTINE ENTRY POINT CSP01930 * CALL A3A1(JCARD,J,JLAST,KCARD,K,ICHAR) CSP01940 * THE WORDS JCARD(J) THROUGH CSP01950 * JCARD(JLAST) IN A3 FORMAT ARE CSP01960 * UNCRAMMED INTO KCARD IN A1 FORMAT. CSP01970 A1A3 DC *-* ARGUMENT ADDRESS COMES IN HERE CSP01980 LD SW1 LOAD BRANCH TO ELSE CSP01990 STO SWTCH STORE BRANCH AT SWITCH CSP02000 MDX START START COMPUTING CSP02010 SW1 MDX X ELSE-SWTCH-1 BRANCH TO ELSE CSP02020 SW2 MDX X 0 NOP INSTRUCTION CSP02030 A3A1 DC *-* ARGUMENT ADDRESS COMES IN HERE CSP02040 LD A3A1 PICK UP ARGUMENT ADDRESS AND CSP02050 STO A1A3 STORE IT IN A1A3 CSP02060 LD SW2 LOAD NOP INSTRUCTION CSP02070 STO SWTCH STORE NOP AT SWITCH CSP02080 START STX 1 SAVE1+1 SAVE IR1 CSP02090 STX 2 SAVE2+1 SAVE IR2 CSP02100 STX 3 SAVE3+1 SAVE IR3 CSP02110 LDX I1 A1A3 PUT ARGUMENT ADDRESS IN IR1 CSP02120 LD 1 0 GET JCARD ADDRESS CSP02130 S I1 2 SUBTRACT JLAST VALUE CSP02140 STO JCARD+1 CREATE JCARD(J) ADDRESS CSP02150 STO OVR1+1 STORE JCARD(J) ADDRESS CSP02160 STO OVR2+1 STORE JCARD(J) ADDRESS CSP02170 LD 1 3 GET KCARD ADDRESS CSP02180 A ONE+1 ADD CONSTANT OF 1 CSP02190 S I1 4 SUBTRACT K VALUE CSP02200 STO KCARD+1 CREATE KCARD(K) ADDRESS CSP02210 LD I1 2 GET JLAST VALUE CSP02220 ONE S I1 1 SUBTRACT J VALUE CSP02230 A ONE+1 ADD CONSTANT OF 1 CSP02240 STO CNT+1 CREATE FIELD WIDTH CSP02250 LD 1 5 GET ICHAR ADDRESS CSP02260 S D40 SUBTRACT CONSTANT OF 40 CSP02270 STO TABLE+1 CREATE TABLE END ADDRESS CSP02280 STO TCODE+1 STORE TABLE END ADDRESS CSP02290 MDX 1 6 ADJUST OVER 6 ARGUMENTS CSP02300 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP02310 KCARD LDX L1 *-* PUT KCARD ADDRESS IN IR1 CSP02320 CNT LDX L2 *-* PUT FIELD WIDTH IN IR2 CSP02330 JCARD LD L2 *-* PICK UP JCARD(J) CSP02340 SWTCH MDX X 0 SWITCH BETWEEN CRAM AND UNCM CSP02350 BSC L MINUS,+Z TEST SIGN OF INTEGER CSP02360 SRT 16 SHIFT INTEGER TO EXTENSION CSP02370 D D1600 DIVIDE BY 1600 CSP02380 A D20 ADJUST FIRST VALUE CSP02390 HOLD STO A3A1 SAVE FIRST CHARACTER VALUE CSP02400 SRA 16 ZERO ACCUMULATOR CSP02410 D D40 DIVIDE BY 40 CSP02420 STO A1A3 SAVE SECOND CHARACTER VALUE CSP02430 SLT 16 SHIFT THIRD CHAR VALUE TO ACCUM CSP02440 BSI L DECOD DECODE THIRD CHARACTER CSP02450 STO 1 -2 STORE THIRD CHARACTER CSP02460 LD A1A3 GET SECOND CHARACTER CSP02470 BSI L DECOD DECODE SECOND CHARACTER CSP02480 STO 1 -1 STORE SECOND CHARACTER CSP02490 LD A3A1 GET FIRST CHARACTER CSP02500 BSI L DECOD DECODE FIRST CHARACTER CSP02510 STO 1 0 STORE FIRST CHARACTER CSP02520 MDX 1 -3 DECREMENT A1 OUT ARRAY CSP02530 MDX 2 -1 DECREMENT FIELD WIDTH CSP02540 MDX JCARD FIELD WIDTH IS NOT ZERO CSP02550 MDX SAVE1 GO TO RESTORE AND RETURN CSP02560 MINUS A D32K ADJUST FOR NEGATIVE INTEGER CSP02570 SRT 16 SHIFT INTEGER TO EXTENSION CSP02580 D D1600 DIVIDE BY 1600 CSP02590 MDX HOLD GO TO GET THE REMAINING INTEGERS CSP02600 D40 DC 40 CONSTANT OF 40 CSP02610 D32K DC 32000 CONSTANT OF 32000 CSP02620 D1600 DC 1600 CONSTANT OF 1600 CSP02630 D20 DC 20 CONSTANT OF 20 CSP02640 ELSE STO A3A1 STORE FIRST A1 CHARACTER CSP02650 MDX 2 -1 DECREMENT FIELD WIDTH CSP02660 MDX OVR1 GO TO GET NEXT CHARACTER CSP02670 MDX FILL1 LAST CHARACTER-FILL WITH BLANK CSP02680 OVR1 LD L2 *-* GET SECOND CHARACTER CSP02690 STO A1A3 STORE SECOND CHARACTER CSP02700 MDX 2 -1 DECREMENT FIELD WIDTH CSP02710 MDX OVR2 GO TO GET NEXT CHARACTER CSP02720 MDX FILL2 LAST CHARACTER-FILL BLANK CSP02730 OVR2 LD L2 *-* GET THIRD CHARACTER CSP02740 RET BSI L CODE CODE CHARACTER TO NUMBER CSP02750 STO KCARD&1 SAVE NUMBR OF THIRD CHARACTER CSP02760 LD A1A3 GET SECOND CHARACTER CSP02770 BSI L CODE CODE SECOND CHARACTER CSP02780 M D40 MULTIPLY BY 40 AND CSP02790 SLT 16 SHIFT TO ACCUMULATOR CSP02800 A KCARD+1 ADD NUMBER(THIRD) AND CSP02810 STO KCARD+1 SAVE RESULTING INTEGER CSP02820 LD A3A1 GET FIRST CHARACTER CSP02830 BSI L CODE CODE FIRST CHARACTER CSP02840 S D20 SUBTRACT 20 CSP02850 M D1600 MULTIPLY BY 1600 CSP02860 SLT 16 SHIFT TO ACCUMULATOR CSP02870 A KCARD+1 ADD IN PREVIOUS RESULT CSP02880 STO 1 0 STORE IN A3 ARRAY CSP02890 MDX 1 -1 NEXT WORD IN A3 ARRAY CSP02900 MDX 2 -1 DECREMENT FIELD WIDTH CSP02910 MDX JCARD GET MORE A1 CHARACTERS CSP02920 SAVE1 LDX L1 *-* RESTORE IR1 CSP02930 SAVE2 LDX L2 *-* RESTORE IR2 CSP02940 SAVE3 LDX L3 *-* RESTORE IR3 CSP02950 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP02960 FILL1 LD H4040 FILL WITH TWO BLANKS CSP02970 STO A1A3 STORE SECOND CHARACTER BLANK CSP02980 FILL2 LD H4040 FILL WITH ONE BLANK CSP02990 MDX 2 1 SET IR1 TO 1 CSP03000 MDX RET GO TO CODE ROUTINE CSP03010 H4040 DC /4040 CONSTANT OF A1 BLANK CSP03020 DECOD DC *-* DECODE RETURN ADDRESS GOES HERE CSP03030 A ONE+1 ADD ONE TO NUMBER GIVING CSP03040 STO PLACE+1 SUBSCRIPT OF TABLE AND SAVE CSP03050 PLACE LDX L3 *-* LOAD IR3 WITH SUBSCRIPT OF TABLE CSP03060 TABLE LD L3 *-* GET A1 CHARACTER CSP03070 BSC I DECOD RETURN CSP03080 CODE DC *-* CODE RETURN ADDRESS GOES HERE CSP03090 STO DECOD SAVE THE CHARACTER TO BE CODED CSP03100 LDX 3 40 LOAD IR3 WITH THE TABLE LENGTH-40 CSP03110 TCODE LD L3 *-* LOAD CHARACTER FROM ICHAR ARRAY CSP03120 EOR DECOD ZERO ACCUMULATOR IF MATCH CSP03130 BSC L OUT,Z GO TO PUT IF NOT ZERO CSP03140 AWAY STX 3 DECOD SAVE SUBSCRIPT OF MATCH CSP03150 LD DECOD LOAD SUBSCRIPT CSP03160 S ONE+1 SUBTRACT ONE GIVING NUMBER CSP03170 BSC I CODE RETURN CSP03180 OUT MDX 3 -1 DECREMENT THROUGH THE TABLE-ICHAR CSP03190 MDX TCODE GO TRY AGAIN CSP03200 LD H4040 NOT IN THE TABLE - LOAD A BLANK CSP03210 MDX CODE+1 GO BACK TO CODE THE BLANK.... CSP03220 END CSP03230 // DUP CSP03240 *STORE WS UA A1A3 CSP03250 // ASM CSP03260 ** A1DEC SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP03270 * NAME A1DEC CSP03280 * LIST CSP03290 ENT A1DEC A1DEC SUBROUTINE ENTRY POINT CSP03300 * CALL A1DEC(JCARD,J,JLAST,NER) CSP03310 * THE WORDS JCARD(J) THROUGH CSP03320 * JCARD(JLAST) ARE CONVERTED FROM CSP03330 * A1 FORMAT TO D1 FORMAT AND THE CSP03340 * ORIGINAL DATA IS REPLACED BY THE CSP03350 * CONVERTED DATA. CSP03360 FOUR DC 4 CONSTANT OF FOUR CSP03370 A1DEC DC *-* ARGUMENT ADDRESS COMES IN HERE CSP03380 STX 1 SAVE1+1 SAVE IR1 CSP03390 LDX I1 A1DEC PUT ARGUMENT ADDRESS IN IR1 CSP03400 LD 1 0 GET JCARD ADDRESS CSP03410 STO JCRD1 SETUP JCARD ADDRESS FOR NZONE CSP03420 TWO S I1 2 SUBTRACT JLAST VALUE CSP03430 STO PICK+1 PLACE LOAD ADDRESS FOR CONVRS CSP03440 STO PUT+1 PLACE STORE ADDRESS FOR CONVRS CSP03450 A ONE+1 ADD CONSTANT OF ONE CSP03460 STO LAST+1 PLACE ADDRESS OF SIGN POSITON CSP03470 LD 1 2 GET JLAST ADDRESS CSP03480 STO JLAS1 SETUP JLAST ADDRESS FOR NZONE CSP03490 LD I JLAS1 GET JLAST VALUE AND CSP03500 STO A1DEC SAVE IT AT A1DEC CSP03510 ONE S I1 1 SUBTRACT J VALUE CSP03520 A ONE+1 ADD CONSTANT OF ONE CSP03530 BSC + CHECK FIELD WIDTH CSP03540 LD ONE+1 ZERO OR NEGATIVE-MAKE IT ONE CSP03550 STO COUNT+1 OK-SAVE WIDTH IN COUNT CSP03560 LD 1 3 GET NER ADDRESS CSP03570 STO ERA+1 SAVE IT CSP03580 MDX 1 4 MOVE OVER FOUR ARGUMENTS CSP03590 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP03600 * REMOVE AND SAVE THE SIGN CSP03610 CALL NZONE REMOVE THE ZONE OVER LOW ORDER CSP03620 JCRD1 DC *-* ADDRESS OF JCARD CSP03630 JLAS1 DC *-* ADDRESS OF JLAST CSP03640 DC FOUR ADDRESS OF CONSTANT OF FOUR CSP03650 DC JCRD1 ADDRESS OF OLD ZONE CSP03660 * JNOW=J CSP03670 COUNT LDX L1 *-* LOAD IR1 WITH FIELD WIDTH CSP03680 * JTEST=JCARD(JNOW) CSP03690 PICK LD L1 *-* PICK UP JCARD(JNOW) AND CSP03700 BSC L POS,- CHECK IT AGAINST ZERO CSP03710 S ZERO NEGATIVE-IS IT LESS THAN CSP03720 BSC L OK,- AN EBCDIC ZERO CSP03730 * NER=JNOW CSP03740 ERR STX 1 COUNT+1 YES - ERROR CSP03750 LD A1DEC COMPUTE THE SUBSCRIPT CSP03760 S COUNT+1 OF THIS CHARACTER IN CSP03770 A ONE+1 THE ARRAY AND CSP03780 ERA STO L *-* STORE THE SUBSCRIPT AT NER CSP03790 MDX MORE GO GET THE NEXT CHARACTER CSP03800 POS S BLANK NOT NEGATIVE - IS IT AN CSP03810 BSC L ERR,Z EBCDIC BLANK CSP03820 * JTEST + 4032 IS NOW IN ACCUM CSP03830 * SHIFT 8 IS SAME AS DIVIDE BY 256 CSP03840 OK SRA 8 EITHER BLANK OR DIGIT - PUT CSP03850 PUT STO L1 *-* THE FOUR BITS OF DECIMAL BACK CSP03860 * SEE IF JNOW IS LESS THAN JLAST. CSP03870 * IF YES, JNOW=JNOW+1 AND GO BACK CSP03880 * FOR MORE. IF NO, SET UP THE CSP03890 * SIGN. CSP03900 MORE MDX 1 -1 DECREMENT THE FIELD WIDTH CSP03910 MDX PICK GO BACK FOR MORE CSP03920 * WAS THE ORIGINAL SIGN INDICATION CSP03930 * TWO. IF NOT, ALL DONE. IF YES CSP03940 * MAKE THE SIGN NEGATIVE. CSP03950 * JCARD(JLAST)=-JCARD(JLAST) - 1 CSP03960 LD JCRD1 PICK UP THE OLD ZONE AND CSP03970 S TWO+1 CHECK IT AGAINST TWO CSP03980 BSC L SAVE1,Z IF NO MATCH GO TO EXIT CSP03990 S ONE+1 IF MATCH, MAKE THE CSP04000 LAST EOR L *-* SIGN NEGATIVE(LOW ORDER) AND CSP04010 STO I LAST+1 STORE IT BACK CSP04020 * EXIT........................... CSP04030 SAVE1 LDX L1 *-* RESTORE IR1 CSP04040 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP04050 ZERO DC /F040 CONSTANT OF EBCDIC ZERO CSP04060 BLANK DC /4040 CONSTANT OF EBCDIC BLANK CSP04070 END CSP04080 // DUP CSP04090 *STORE WS UA A1DEC CSP04100 // ASM CSP04110 ** CARRY SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP04120 * NAME CARRY CSP04130 * LIST CSP04140 ENT CARRY CARRY SUBROUTINE ENTRY POINT CSP04150 * CALL CARRY(JCARD,J,JLAST,KARRY) CSP04160 * THE WORDS JCARD(J) THROUGH CSP04170 * JCARD(JLAST) ARE CHECKED TO SEE CSP04180 * THAT THEY ARE BETWEEN ZERO AND CSP04190 * NINE. IF THEY ARE NOT, THE CSP04200 * UNITS DIGIT REMAINS AND THE TENS CSP04210 * DIGIT IS TREATED AS A CARRY TO CSP04220 * THE NEXT WORD. CSP04230 CARRY DC *-* ARGUMENT ADDRESS COMES IN HERE CSP04240 STX 1 SAVE1+1 SAVE IR1 CSP04250 LDX I1 CARRY PUT ARGUMENT ADDRESS IN IR1 CSP04260 LD 1 0 GET JCARD ADDRESS CSP04270 S I1 2 SUBTRACT JLAST VALUE CSP04280 A ONE+1 ADD CONSTANT OF ONE CSP04290 STO SRCE+1 CREATE JCARD(JLAST) ADDRESS CSP04300 LD I1 2 GET JLAST VALUE CSP04310 ONE S I1 1 SUBTRACT J VALUE CSP04320 A ONE+1 ADD CONSTANT OF ONE CSP04330 BSC + CHECK FIELD WIDTH CSP04340 LD ONE+1 ZERO OR NEGATIVE-MAKE IT ONE CSP04350 STO COUNT+1 OK-SAVE WIDTH IN COUNT CSP04360 LD 1 3 GET KARRY ADDRESS CSP04370 STO OVF+1 AND SAVE IT CSP04380 MDX 1 4 MOVE OVER FOUR ARGUMENTS CSP04390 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP04400 SLT 32 CLEAR THE ACCUMULATOR AND EXTEN CSP04410 * LET CARRY BE THE SAME AS NCARY CSP04420 STO CARRY SET NCARY TO ZERO CSP04430 COUNT LDX L1 *-* LOAD IR1 WITH THE FIELD WIDTH CSP04440 * THE NEXT INSTRUCTION STARTS OUT CSP04450 * BY PICKING UP JCARD(JLAST). CSP04460 * THE SUBSCRIPT IS DECREMENTED BY CSP04470 * THE INSTRUCTION AFTER POSZ. CSP04480 * THE CALCULATIONS ARE.. CSP04490 * JTEST=JCARD(JNOW)+NCARY CSP04500 * NCARY=JTEST/10 CSP04510 * JTEST=JTEST-10*NCARY CSP04520 SRCE LD L *-* PICK UP JCARD(JNOW) CSP04530 A CARRY ADD THE PREVIOUS CARRY TO IT CSP04540 SRT 16 SHIFT THE ACCUM TO THE EXTENTON CSP04550 D TEN DIVIDE BY TEN AND CSP04560 STO CARRY STORE THE QUOTIENT AT NCARY CSP04570 * THE QUOTIENT IS THE GENERATED CSP04580 * CARRY. CSP04590 SLT 16 PUT REMAINDER IN ACCUMULATOR AN CSP04600 BSC L POSZ,- CHECK TO SEE IF NEGATIVE-NO- CSP04610 * GO TO POSZ........... CSP04620 A TEN YES - COMPLIMENT BY ADDING TEN CSP04630 SRT 16 STORE TEMPORARILY IN EXTENTION CSP04640 LD CARRY LOAD NCARY CSP04650 S ONE+1 AND SUBTRACT CSP04660 STO CARRY ONE FROM IT CSP04670 * JCARD(JNOW)=JTEST CSP04680 SLT 16 SHIFT COMPLIMENTED REMAINDER CSP04690 * BACK TO ACCUMULATOR CSP04700 POSZ STO I SRCE+1 AND STORE IN RESULT CSP04710 * JNOW=JNOW-1 CSP04720 MDX L SRCE+1,1 GO TO NEXT DIGIT OF JCARD CSP04730 * IF JNOW IS LESS THAN J, ALL CSP04740 * DONE. OTHERWISE, GET THE NEXT CSP04750 * DIGIT. CSP04760 MDX 1 -1 DECREMENT THE FIELD WIDTH CSP04770 MDX SRCE GO BACK FOR NEXT DIGIT CSP04780 * KARRY=NCARY CSP04790 LD CARRY ALL DONE - PICK UP ANY CSP04800 OVF STO L *-* GENERATED CARRY AND STORE IT CSP04810 * AR KARRY. EXIT................ CSP04820 SAVE1 LDX L1 *-* RESTORE IR1 CSP04830 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP04840 TEN DC 10 CONSTANT OF TEN CSP04850 END CSP04860 // DUP CSP04870 *STORE WS UA CARRY CSP04880 // ASM CSP04890 ** DECA1 SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP04900 * NAME DECA1 CSP04910 * LIST CSP04920 ENT DECA1 DECA1 SUBROUTINE ENTRY POINT CSP04930 * CALL DECA1(JCARD,J,JLAST,NER) CSP04940 * THE WORDS JCARD(J) THROUGH CSP04950 * JCARD(JLAST) ARE CONVERTED FROM CSP04960 * D1 FORMAT TO A1 FORMAT AND THE CSP04970 * ORIGINAL DATA IS REPLACED BY THE CSP04980 * CONVERTED DATA. CSP04990 DECA1 DC *-* ARGUMENT ADDRESS COMES IN HERE CSP05000 STX 1 SAVE1+1 SAVE IR1 CSP05010 LDX I1 DECA1 PUT ARGUMENT ADDRESS IN IR1 CSP05020 LD 1 0 GET JCARD ADDRESS CSP05030 STO JCRD1 SETUP JCARD ADDRESS FOR NZONE CSP05040 TWO S I1 2 SUBTRACT JLAST VALUE CSP05050 STO PICK+1 PLACE LOAD ADDRESS FOR CONVRSN CSP05060 STO PUT+1 PLACE STORE ADDRESS FOR CONVRSN CSP05070 A ONE+1 ADD CONSTANT OF ONE CSP05080 STO TEST+1 CREATE JCARD(JLAST) ADDRESS CSP05090 LD 1 2 GET JLAST ADDRESS CSP05100 STO JLAS1 SETUP JLAST ADDRESS FOR NZONE CSP05110 LD I JLAS1 GET JLAST VALUE AND CSP05120 STO DECA1 SAVE IT AT DECA1 CSP05130 ONE S I1 1 SUBTRACT J VALUE CSP05140 A ONE+1 ADD CONSTANT OF ONE CSP05150 BSC + CHECK FIELD WIDTH CSP05160 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP05170 STO COUNT+1 OK-SAVE WIDTH IN COUNT CSP05180 LD 1 3 GET NER ADDRESS CSP05190 STO ERA+1 SAVE IT CSP05200 MDX 1 4 MOVE OVER FOUR ARGUMENTS CSP05210 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP05220 * CHECK THE SIGN OF JCARD. IF CSP05230 * NEGATIVE, SET JSIGN=2, AND MAKE CSP05240 * IT POSITIVE. OTHERWISE, SET CSP05250 * JSIGN=4 CSP05260 TEST LD L *-* GET JCARD(JLAST) CSP05270 BSC L NEG,+Z CHECK FOR NEGATIVE CSP05280 LD FOUR NO - LOAD FOUR CSP05290 MDX GO SKIP OVER NEGATIVE PROCESSING CSP05300 NEG EOR HFFFF YES - CHANGE SIGN TO POSITIVE CSP05310 STO I TEST+1 RESTORE SIGN AS POSITIVE CSP05320 LD TWO+1 LOAD TWO CSP05330 GO STO TEST+1 STORE ACCUMULATOR TO SAVE SIGN CSP05340 * JNOW=J CSP05350 COUNT LDX L1 *-* LOAD IR1 WITH FIELD WIDTH CSP05360 * JTEST=JCARD(JNOW) CSP05370 PICK LD L1 *-* PICK UP JCARD(JNOW) CSP05380 BSC L OK,- AND CHECK IT AGAINST ZERO CSP05390 * NER=JNOW CSP05400 ERR STX 1 COUNT+1 LESS THAN - ERROR CSP05410 LD DECA1 CALCULATE THE SUBSCRIPT CSP05420 S COUNT+1 OF THIS DIGIT CSP05430 A ONE+1 AND STORE CSP05440 ERA STO L *-* IT AT NER CSP05450 MDX MORE GET NEXT DIGIT CSP05460 OK S TEN NOT LESS - COMPARE IT TO CSP05470 BSC L ERR,- CONSTANT OF TEN-NOT LESS GO TO CSP05480 * ERR CSP05490 A TEN LESS - ADD TEN BACK CSP05500 SLA 8 SHIFT THE FOUR BITS OF DECIMAL CSP05510 OR ZERO IN PLACE AND CREATE A1 CSP05520 PUT STO L1 *-* CHARACTER-STORE IN JCARD(JNOW) CSP05530 * SEE IF JNOW IS LESS THAN JLAST. CSP05540 * IF YES, JNOW=JNOW+1 AND GO BACK CSP05550 * FOR MORE. IF NO, SETUP THE SIGN CSP05560 MORE MDX 1 -1 DECREMENT THE FIELD WIDTH CSP05570 MDX PICK GO BACK FOR MORE CSP05580 CALL NZONE NZONE ROUTINE TO PLACE SIGN CSP05590 JCRD1 DC *-* ADDRESS OF JCARD CSP05600 JLAS1 DC *-* ADDRESS OF JLAST CSP05610 DC TEST+1 ADDRESS OF SIGN INDICATOR TO CSP05620 * USE CSP05630 DC JCRD1 ADDRESS OF SIGN INDICATOR FOR CSP05640 * OLD SIGN CSP05650 * EXIT CSP05660 SAVE1 LDX L1 *-* RESTORE IR1 CSP05670 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP05680 FOUR DC 4 CONSTANT OF FOUR CSP05690 HFFFF DC /FFFF CONSTANT OF ALL BINARY ONES CSP05700 TEN DC 10 CONSTANT OF TEN CSP05710 ZERO DC /F040 CONSTANT OF EBCDIC ZERO CSP05720 END CSP05730 // DUP CSP05740 *STORE WS UA DECA1 CSP05750 // ASM CSP05760 ** DIV SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP05770 * NAME DIV CSP05780 * LIST CSP05790 ENT DIV DIVIDE SUBROUTINE ENTRY POINT CSP05800 * CALL DIV(JCARD,J,JLAST,KCARD,K,KLAST,NER) CSP05810 * THE WORDS JCARD(J) THROUGH CSP05820 * JCARD(JLAST) ARE DIVIDED INTO CSP05830 * THE WORDS KCARD(K) THROUGH CSP05840 * KCARD(KLAST). THE KCARD FIELD CSP05850 * IS EXTENDED TO THE LEFT AND CSP05860 * CONTAINS THE QUOTIENT AND CSP05870 * REMAINDER. CSP05880 DIV DC *-* ARGUMENT ADDRESS COMES IN HERE CSP05890 STX 1 SAVE1+1 SAVE IR1 CSP05900 STX 2 SAVE2+1 SAVE IR2 CSP05910 STX 3 SAVE3+1 SAVE IR3 CSP05920 LDX I1 DIV PUT ARGUMENT ADDRESS IN IR1 CSP05930 LD 1 0 GET JCARD ADDRESS CSP05940 S I1 2 SUBTRACT JLAST VALUE CSP05950 STO SRCH+1 STORE END OF JCARD ADDRESS CSP05960 STO L MULT1+1 FOR SEARCH AND MULTIPLICATION CSP05970 A ONE+1 ADD CONSTANT OF ONE CSP05980 STO SGNJ+1 CREATE JCARD(JLAST) ADDRESS CSP05990 * JSPAN=JLAST-J+1 CSP06000 TWO LD I1 2 GET JLAST VALUE CSP06010 ONE S I1 1 SUBTRACT J VALUE CSP06020 A ONE+1 ADD CONSTANT OF ONE CSP06030 BSC + CHECK FIELD WIDTH CSP06040 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP06050 STO SRCHT+1 STORE COUNT FOR SEARCH CSP06060 LD 1 3 GET KCARD ADDRESS CSP06070 STO KCRD1 SAVE FOR FILL CSP06080 S I1 5 SUBTRACT KLAST VALUE CSP06090 A ONE&1 ADD CONSTANT OF ONE CSP06100 STO SGNK+1 CREATE KCARD(KLAST) ADDRESS CSP06110 MDX 1 7 MOVE OVER SEVEN ARGUMENTS CSP06120 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP06130 * CLEAR AND SAVE THE SIGNS ON THE CSP06140 * JCARD AND THE KCARD FIELDS CSP06150 SGNJ LD L *-* PICKUP THE SIGN OF JCARD CSP06160 STO DIV SAVE IT IN DIV CSP06170 BSC L JPLUS,- IF NOT NEGATIVE-GO TO JPLUS CSP06180 EOR HFFFF+1 NEGATIVE-MAKE IT POSITIVE CSP06190 STO I SGNJ+1 PUT BACK IN JCARD(JLAST) CSP06200 LD HFFFF+1 LOAD A MINUS ONE CSP06210 JPLUS SRT 16 SAVE IN EXTENSION CSP06220 SGNK LD L *-* PICKUP THE SIGN OF KCARD CSP06230 STO KSIGN SAVE IT IN KSIGN CSP06240 BSC L KPLUS,- IF NOT NEGATIVE-GO TO KPLUS CSP06250 EOR HFFFF+1 NEGATIVE-MAKE IT POSITIVE CSP06260 STO I SGNK+1 PUT BACK IN KCARD(KLAST) CSP06270 SLT 16 GET SIGN OF JCARD CSP06280 EOR HFFFF+1 CHANGE IT CSP06290 MDX OVRK SKIP NEXT INSTRUCTION CSP06300 KPLUS SLT 16 GET SIGN OF JCARD CSP06310 OVRK STO QSIGN STORE FOR SIGN OF QUOTIENT CSP06320 * KSTRT=K-1 CSP06330 LD I1 -3 GET VALUE OF K CSP06340 A HFFFF&1 SUBTRACT CONSTANT OF ONE CSP06350 STO KSTRT SAVE IN KSTRT CSP06360 * KLOW=K-JSPAN CSP06370 A ONE+1 GET VALUE OF K CSP06380 S SRCHT+1 SUBTRACT JSPAN CSP06390 STO KLOW SAVE IN KLOW CSP06400 MTWO LD I1 -2 GET KLAST VALUE CSP06410 STO TMP SAVE IT CSP06420 * CALCULATE THE ADDRESS OF THE CSP06430 * SIGN OF THE QUOTIENT CSP06440 LD KCRD1 GET KCARD ADDRESS CSP06450 S TMP SUBTRACT KLAST VALUE CSP06460 A SRCHT+1 ADD JSPAN CSP06470 A ONE+1 ADD CONSTANT OF ONE CSP06480 STO L QUOT+1 STORE ADDR OF SIGN OF QUOTIENT CSP06490 * IS KLAST-KSTRT-JSPAN NEGATIVE CSP06500 LD TMP LOAD KLAST VALUE CSP06510 S KSTRT SUBTRACT KSTRT CSP06520 S SRCHT+1 SUBTRACT JSPAN CSP06530 BSC L ERR,+Z IF NEGATIVE-GO TO ERROR CSP06540 * IS KLOW POSITIVE CSP06550 LD KLOW OK-GET KLOW VALUE CSP06560 BSC L ERR,+ IF NOT POSITIVE-GO TO ERROR CSP06570 * FILL THE EXTENSION OF KCARD WITH CSP06580 * ZEROES CSP06590 CALL FILL OK-FILL EXTENSION WITH ZEROES CSP06600 KCRD1 DC *-* ADDRESS OF KCARD CSP06610 DC KLOW ADDRESS OF LEFT END OF EXTENSION CSP06620 DC KSTRT ADDRESS OF RGHT END OF EXTENSON CSP06630 DC ZIP ADDRESS OF CONSTANT OF ZERO CSP06640 * JFRST=J CSP06650 SRCHT LDX L2 *-* LOAD IR2 WITH JCARD COUNT CSP06660 SRCH LD L2 *-* PICKUP JCARD(JFRST) CSP06670 * IS JCARD(JFRST) POSITIVE CSP06680 BSC L HIT,-Z IF POSITIVE-GO TO HIT CSP06690 * SEE IF JFRST IS LESS THAN JLAST. CSP06700 * IF YES, JFRST=JFRST+1 AND GO CSP06710 * BACK FOR MORE. IF NO, ERROR. CSP06720 MDX 2 -1 DECREMENT IR2 CSP06730 MDX SRCH GO BACK FOR MORE CSP06740 * ERROR - NER=KLAST CSP06750 ERR LD TMP PICKUP KLAST VALUE CSP06760 HFFFF STO I1 -1 AND STORE IN NER CSP06770 * REPLACE JCARD SIGN CSP06780 FINER LD DIV PICKUP JCARD SIGN AND CSP06790 STO I SGNJ+1 PUT IT BACK CSP06800 * REPLACE KCARD SIGN CSP06810 LD KSIGN PICKUP KCARD SIGN CSP06820 BSC L KNEG,+Z IF NEGATIVE-GO TO KNEG CSP06830 LD I SGNK+1 NOT NEGATIVE-PICKUP NEW SIGN CSP06840 BSC L SAVE1,- IF NOT NEGATIVE-GO TO EXIT CSP06850 BCK1 EOR HFFFF+1 NEGATIVE-CHANGE SIGN AND CSP06860 STO I SGNK+1 PUT INTO KCARD(KLAST) CSP06870 MDX SAVE1 GO TO EXIT CSP06880 KNEG LD I SGNK+1 NEGATIVE-PICKUP NEW SIGN CSP06890 BSC L SAVE1,+Z IF NEGATIVE-GO TO EXIT CSP06900 MDX BCK1 NOT NEGATIVE-GO TO BCK1 CSP06910 * EXIT............................ CSP06920 SAVE1 LDX L1 *-* RESTORE IR1 CSP06930 SAVE2 LDX L2 *-* RESTORE IR2 CSP06940 SAVE3 LDX L3 *-* RESTORE IR3 CSP06950 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP06960 KSTRT DC *-* ONE LESS THAN K CSP06970 KSIGN DC *-* SIGN OF KCARD CSP06980 QSIGN DC *-* SIGN OF QUOTIENT CSP06990 ZIP DC 0 CONSTANT OF ZERO CSP07000 KLOW DC *-* SUBSCRIPT OF LEFTMOST POSITION CSP07010 * OF EXTENSION OF KCARD CSP07020 TEN DC 10 CONSTANT OF TEN CSP07030 TMP DC *-* TEMPORARY STORAGE CSP07040 * JHIGH=JCARD(JFRST) CSP07050 HIT STO SRCHT+1 SAVE FIRST SIGNIFICANT DIGIT CSP07060 * KPUT=KLOW+JLAST-JFRST CSP07070 STX 2 JLOOP+1 GET THE VALUE OF JLAST-JFRST CSP07080 LD KCRD1 GET KCARD ADDRESS CSP07090 STO KCRD2 SAVE FOR CARRY CSP07100 S KLOW SUBTRACT KLOW VALUE CSP07110 S JLOOP+1 SUBTRACT JLAST-JFRST VALUE CSP07120 S MTWO+1 ADD CONSTANT OF TWO CSP07130 STO PUT2+1 SAVE ADDRESS FOR STORING CSP07140 * KSTOP=KLAST+JFRST-JLAST-1 CSP07150 LD TMP GET KLAST VALUE CSP07160 S JLOOP+1 SUBTRACT JLAST-JFRST VALUE CSP07170 S HFFFF+1 ADD CONSTANT OF ONE CSP07180 STO SRCH&1 SAVE VALUE FOR COMPLIMENTING CSP07190 S KSTRT SUBTRACT KSTRT VALUE CSP07200 STO LOOPM+1 SAVE COUNT AT LOOPM+1 CSP07210 LD KCRD2 GET KCARD ADDRESS CSP07220 S TMP SUBTRACT KLAST VALUE CSP07230 A JLOOP&1 ADD JLAST-JFRST VALUE CSP07240 STO DIV1&1 SAVE FOR MULT. BY TEN CSP07250 STO DIV5&1 SAVE FOR ADD OF 10*KNOW CSP07260 STO DIV6&1 SAVE FOR STORE OF 10*KNOW CSP07270 A HFFFF+1 SUBTRACT CONSTANT OF ONE CSP07280 STO DIV2&1 SAVE FOR ADD INTO MULT CSP07290 STO DIV3&1 SAVE FOR SUBTRACTION FROM CSP07300 STO DIV4&1 SAVE FOR STORE SUBTRACTED FROM CSP07310 * KM=KSTRT CSP07320 LOOPM LDX L1 *-* LOAD IR1 WITH COUNT CSP07330 * MULT=(10*KCARD(KM)+KCARD(KM+1)) CSP07340 * DIVIDED BY JHIGH CSP07350 DIV1 LD L1 *-* PICKUP KCARD(KM) CSP07360 M TEN MULTIPLY BY TEN CSP07370 SLT 16 REPOSITION PRODUCT CSP07380 DIV2 A L1 *-* ADD IN KCARD(KM+1) CSP07390 SRT 16 REPOSITION FOR DIVISION CSP07400 D SRCHT+1 DIVIDE BY JHIGH CSP07410 STO KLOW SAVE IN KLOW(MULT) CSP07420 * NQUO=MULT CSP07430 STO KSTRT SAVE IN KSTRT(NQUO) CSP07440 * IS MULT GREATER THAN ZERO CSP07450 BSC L PUT,+ IF MULT NOT POSITIVE-GO TO PUT CSP07460 * KNOW=KM+1 CSP07470 ADBCK STX 1 KNOW+1 POSITIVE-GET KM+1 AND CSP07480 KNOW LDX L3 *-* PUT IT IN IR3 CSP07490 * JNOW=JFRST CSP07500 JLOOP LDX L2 *-* RELOAD IR2 WITH REMAINING JCARD CSP07510 SRA 16 CLEAR ACCUMULATOR CSP07520 * KCARD(KNOW)=KCARD(KNOW) - CSP07530 * MULT*JCARD(JNOW) CSP07540 MULT1 S L2 *-* LOAD NEGATIVE JCARD(JNOW) CSP07550 M KLOW MULTIPLY BY MULT CSP07560 SLT 16 REPOSITION PRODUCT CSP07570 DIV3 A L3 *-* ADD IN KCARD(KNOW) CSP07580 DIV4 STO L3 *-* STORE AT KCARD(KNOW) CSP07590 * KNOW=KNOW+1 CSP07600 MDX 3 -1 DECREMENT IR3 CSP07610 MDX * NOP CSP07620 * IS JNOW LESS THAN JLAST. IF YES CSP07630 * JNOW=JNOW+1 AND GO BACK FOR MORE CSP07640 * IF NO, RESOLVE CARRIES. CSP07650 MDX 2 -1 DECREMENT IR2 CSP07660 MDX JLOOP+2 NOT DONE-GO BACK FOR MORE CSP07670 STX 1 KNOW+1 DONE-CALCULATE CSP07680 LD SRCH&1 THE VALUE OF CSP07690 S KNOW+1 KNOW-1 CSP07700 STO KNOW+1 BY COMPLIMENTING COUNT CSP07710 STX 3 LOOPM+1 CALCULATE THE CSP07720 LD SRCH&1 VALUE OF KM CSP07730 S LOOPM+1 BY COMPLIMENTING THE CSP07740 STO LOOPM+1 OTHER COUNT CSP07750 * RESOLVE CARRIES IN THIS RESULT CSP07760 CALL CARRY RESOLVE CARRIES CSP07770 KCRD2 DC *-* ADDRESS OF KCARD CSP07780 DC KNOW+1 ADDRESS OF KM CSP07790 DC LOOPM+1 ADDRESS OF KNOW-1 CSP07800 DC KNOW+1 ADDRESS OF GENERATED CARRY CSP07810 * IS KNOW LESS THAN ZERO CSP07820 BSC L PUT,- IF NOT NEGATIVE-GO TO PUT CSP07830 * KCARD(KM)=KCARD(KM)+10*KNOW CSP07840 M TEN NEGATIVE-MULTIPLY CARRY BY TEN CSP07850 SLT 16 REPOSITION PRODUCT CSP07860 DIV5 A L1 *-* ADD IN KCARD(KNOW) CSP07870 DIV6 STO L1 *-* STORE AT KCARD(KNOW) CSP07880 * MULT=-1 CSP07890 LD HFFFF+1 LOAD A MINUS ONE CSP07900 STO KLOW STORE IN MULT CSP07910 * NQUO=NQUO-1 CSP07920 LD KSTRT LOAD THE VALUE OF NQUO CSP07930 A HFFFF+1 SUBTRACT CONSTANT OF ONE CSP07940 STO KSTRT STORE IN NQUO CSP07950 MDX ADBCK GO TO ADD OVERDRAW BACK CSP07960 * KCARD(KPUT)=NQUO CSP07970 PUT LD KSTRT LOAD NQUO CSP07980 PUT2 STO L *-* STORE AT KCARD(KPUT) CSP07990 * KPUT=KPUT+1 CSP08000 MDX L PUT2+1,-1 MODIFY KCARD(KPUT) ADDRESS CSP08010 * SEE IF KM IS LESS THAN KSTOP. CSP08020 * IF YES, KM=KM+1 AND GO BACK FOR CSP08030 * MORE. IF NO, PLACE ALL SIGNS. CSP08040 MDX 1 -1 DECREMENT IR1 CSP08050 MDX DIV1 NOT DONE-GO BACK FOR MORE CSP08060 * PUT SIGN ON QUOTIENT CSP08070 LD QSIGN DONE-PICKUP SIGN OF QUOTIENT CSP08080 BSC L NEG,+Z IF NEGATIVE-GO TO NEG CSP08090 QUOT LD L *-* NOT NEGATIVE-PICKUP ACTUAL SIGN CSP08100 BSC L FINER,- IF NOT NEGATIVE-GO TO OTHERS CSP08110 BCK2 EOR L HFFFF+1 NEGATIVE-CHANGE SIGN CSP08120 STO I QUOT+1 PUT SIGN ON QUOTIENT CSP08130 BSC L FINER, GO TO REPLACE OTHER SIGNS CSP08140 NEG LD I QUOT+1 NEGATIVE-PICKUP ACTUAL SIGN CSP08150 BSC L FINER,+Z IF NEGATIVE-GO TO OTHER SIGN CSP08160 MDX BCK2 GO TO CHANGE SIGN CSP08170 END CSP08180 // DUP CSP08190 *STORE WS UA DIV CSP08200 // ASM CSP08210 ** DPACK/DUNPK SUBROUTINES FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP08220 * NAME DUNPK CSP08230 * LIST CSP08240 ENT DUNPK DUNPK SUBROUTINE ENTRY POINT CSP08250 * CALL DUNPK(JCARD,J,JLAST,KCARD,K) CSP08260 * THE WORDS JCARD(J) THROUGH CSP08270 * JCARD(JLAST) IN D4 FORMAT ARE CSP08280 * UNPACKED INTO KCARD IN D1 FORMAT. CSP08290 ENT DPACK DPACK SUBROUTINE ENTRY POINT CSP08300 * CALL DPACK(JCARD,J,JLAST,KCARD,K) CSP08310 * THE WORDS JCARD(J) THROUGH CSP08320 * JCARD(JLAST) IN D1 FORMAT ARE PACKED CSP08330 * INTO KCARD IN D4 FORMAT. CSP08340 DUNPK DC *-* ARGUMENT ADDRESS COMES IN HERE CSP08350 LD SW2 LOAD NOP INSTRUCTION CSP08360 STO SWTCH STORE NOP AT SWITCH CSP08370 MDX START COMPUTING CSP08380 SW1 MDX X ELSE-SWTCH-1 BRANCH TO ELSE CSP08390 SW2 MDX X 0 NOP INSTRUCTION CSP08400 DPACK DC *-* ARGUMENT ADDRESS COMES IN HERE CSP08410 LD DPACK PICK UP ARGUMENT ADDRESS CSP08420 STO DUNPK AND STORE IT IN DUNPK CSP08430 LD SW1 LOAD BRANCH TO ELSE CSP08440 STO SWTCH STORE BRANCH AT SWITCH CSP08450 START STX 1 SAVE1+1 SAVE IR1 CSP08460 STX 2 SAVE2+1 SAVE IR2 CSP08470 LDX I1 DUNPK PUT ARGUMENT ADDRESS IN IR1 CSP08480 LD 1 0 GET JCARD ADDRESS CSP08490 A ONE+1 ADD CONSTANT OF 1 CSP08500 ONE S I1 1 SUBTRACT J VALUE CSP08510 STO JCARD+1 CREATE JCARD(J) ADDRESS CSP08520 LD 1 3 GET KCARD ADDRESS CSP08530 A ONE+1 ADD CONSTANT OF 1 CSP08540 FOUR S I1 4 SUBTRACT K VALUE CSP08550 STO KCARD+1 CREATE KCARD(K) ADDRESS CSP08560 LD 1 0 GET JCARD ADDRESS CSP08570 A ONE+1 ADD CONSTANT OF 1 CSP08580 S I1 2 SUBTRACT JLAST VALUE CSP08590 STO DPACK CREATE JCARD(JLAST) ADDRESS CSP08600 KCARD LDX L1 *-* PUT KCARD ADDRESS IN IR1 CSP08610 JCARD LD L *-* PICK UP JCARD(J) CSP08620 LDX 2 4 LOAD IR2 WITH 4, DIGITS/WORD CSP08630 SWTCH MDX X 0 SWITCH BETWEEN DPACK AND DUNPK CSP08640 SRT 16 TEMPORARILY SAVE ACCUM IN EXTNTN CSP08650 * CHECK FOR JCARD(JLAST) CSP08660 LD JCARD+1 PICK UP CURRENT JCARD ADDR CSP08670 S DPACK SUBTRACT JCARD(JLAST) CSP08680 BSC L ALLDO,+ IF ZERO, ALL DONE - ALLDO CSP08690 AGAIN SRA 16 NOT DONE - CLEAR ACCUMULATOR CSP08700 SLT 4 GET FIRST DIGIT OF WORD CSP08710 EOR H000F IS IT FILLER CSP08720 BSC L NEXT,+- YES - GO TO NEXT CSP08730 EOR H000F NO - RESTORE TO ORIGINAL CSP08740 STO 1 0 STORE IN KCARD CSP08750 MDX 1 -1 GO TO NEXT WORD OF KCARD CSP08760 NEXT MDX 2 -1 DECREMENT DIGITS/WORD CSP08770 MDX AGAIN MORE IN THIS WORD - GO BACK CSP08780 MDX L JCARD+1,-1 THIS WORD DONE CSP08790 * GET NEXT WORD IN JCARD CSP08800 MDX JCARD GO BACK CSP08810 H000F DC /000F CONSTANT OF 15 TO DETECT FILLER CSP08820 EN MDX L JCARD+1,1 BACK UP JCARD FOR SIGN CSP08830 STX 2 KCARD+1 IF DIGITS/WORD IS FOUR, CSP08840 LD KCARD+1 ALL DONE EXCEPT FOR SIGN CSP08850 S FOUR+1 SUBTRACT FOUR FROM DIGITS/WORD CSP08860 BSC L LAST,+- IF ZERO - ALL DONE - GO LAST CSP08870 SRT 4 NOT DONE - TAKE OUT SIGN CSP08880 BACK LD HF000 PUT IN FILLER CSP08890 RTE 28 SET FILLER IN LOW ORDER OF EXTN CSP08900 MDX 2 -1 DECREMENT DIGITS/WORD CSP08910 MDX BACK MORE - GO BACK CSP08920 SLT 16 DONE - PUT EXTENSION IN ACCUM CSP08930 STO 1 0 STORE IN KCARD CSP08940 MDX 1 -1 GET NEXT WORD OF KCARD FOR SIGN CSP08950 LAST LD I JCARD+1 PICK UP SIGN OF JCARD CSP08960 MDX ALLDO+1 GO TO INSTRUCTION AFTER ALLDO CSP08970 OVR LD I JCARD+1 PICK UP NEXT JCARD DIGIT CSP08980 ELSE SLA 12 PUT DIGIT IN HIGH ORDER OF ACC CSP08990 RTE 28 SET DIGIT IN LOW ORDER OF EXTN CSP09000 MDX L JCARD+1,-1 GET NEXT JCARD WORD CSP09010 * CHECK FOR JCARD(JLAST) CSP09020 LD JCARD+1 PICK UP CURRENT JCARD ADDR CSP09030 S DPACK SUBTRACT JCARD(JLAST) CSP09040 BSC L EN,+Z IF ZERO,ALL DONE - GO TO EN CSP09050 MDX 2 -1 NOT DONE-DECREMENT DIGITS/WORD CSP09060 MDX OVR GO BACK FOR NEXT DIGIT CSP09070 SLT 16 WORD FULL-PUT EXTN IN ACCUM CSP09080 STO 1 0 STORE IN KCARD CSP09090 MDX 1 -1 GET NEXT KCARD WORD CSP09100 MDX JCARD GO BACK CSP09110 ALLDO SLT 16 DONE-PUT EXTENSION IN ACCUMULTR CSP09120 STO 1 0 STORE SIGN IN KCARD CSP09130 MDX L DUNPK,5 CREATE RETURN ADDRESS CSP09140 SAVE1 LDX L1 *-* RESTORE IR1 CSP09150 SAVE2 LDX L2 *-* RESTORE IR2 CSP09160 BSC I DUNPK RETURN TO CALLING PROGRAM CSP09170 HF000 DC /F000 CONSTANT OF 15 FOR FILLER CSP09180 END CSP09190 // DUP CSP09200 *STORE WS UA DUNPK CSP09210 // ASM CSP09220 ** EDIT SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP09230 * NAME EDIT CSP09240 * LIST CSP09250 ENT EDIT EDIT SUBROUTINE ENTRY POINT CSP09260 * CALL EDIT(JCARD,J,JLAST,KCARD,K,KLAST) CSP09270 * THE WORDS JCARD(J) THROUGH CSP09280 * JCARD(JLAST) ARE EDITED UNDER CSP09290 * CONTROL OF THE MASK AT WORDS CSP09300 * KCARD(K) THROUGH KCARD(KLAST) CSP09310 * AND THE RESULT IS AT KCARD(K) CSP09320 * THROUGH KCARD(KLAST). CSP09330 EDIT DC *-* ARGUMENT ADDRESS COMES IN HERE CSP09340 STX 1 SAVE1+1 SAVE IR1 CSP09350 STX 2 SAVE2+1 SAVE IR2 CSP09360 LDX I1 EDIT PUT ARGUMENT ADDRESS IN IR1 CSP09370 LD 1 0 GET JCARD ADDRESS CSP09380 STO JCRD1 SAVE JCARD ADDRESS FOR NZONE CSP09390 STO JCRD2 SAVE JCARD ADDRESS FOR NZONE CSP09400 S I1 2 SUBTRACT JLAST VALUE CSP09410 A ONE+1 ADD CONSTANT OF ONE CSP09420 STO JCARD+1 CREATE JCARD(JLAST) ADDRESS CSP09430 TWO LD 1 2 GET JLAST ADDRESS CSP09440 STO JLAS1 SAVE JLAST ADDRESS FOR NZONE CSP09450 STO JLAS2 SAVE JLAST ADDRESS FOR NZONE CSP09460 LD I1 2 GET JLAST VALUE CSP09470 ONE S I1 1 SUBTRACT J VALUE CSP09480 A ONE+1 ADD CONSTANT OF ONE CSP09490 BSC + CHECK FIELD WIDTH CSP09500 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP09510 STO LDXJ+1 SAVE FIELD WIDTH CSP09520 LD 1 4 GET K ADDRESS CSP09530 STO K1 SAVE K ADDRESS FOR FILL CSP09540 STO L K2 SAVE K ADDRESS FOR FILL CSP09550 LD 1 5 GET KLAST ADDRESS CSP09560 STO KLAS1 SAVE KLAST ADDRESS FOR FILL CSP09570 LD 1 3 GET KCARD ADDRESS CSP09580 STO KCRD1 SAVE KCARD ADDRESS FOR FILL CSP09590 STO L KCRD2 SAVE KCARD ADDRESS FOR FILL CSP09600 S I1 5 SUBTRACT KLAST VALUE CSP09610 A ONE+1 ADD CONSTANT OF ONE CSP09620 STO KCARD+1 CREATE KCARD(KLAST) ADDRESS CSP09630 STO KCRD3+1 CREATE KCARD(KLAST) ADDRESS CSP09640 LD I1 5 GET JLAST VALUE CSP09650 FOUR S I1 4 SUBTRACT J VALUE CSP09660 A ONE+1 ADD CONSTANT OF ONE CSP09670 BSC + CHECK FIELD WIDTH CSP09680 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP09690 STO LDXK+1 SAVE FIELD WIDTH CSP09700 MDX 1 6 MOVE OVER SIX ARGUMENTS CSP09710 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP09720 * REMOVE AND SAVE THE JCARD ZONE CSP09730 CALL NZONE NZONE TO REMOVE SIGN CSP09740 JCRD1 DC *-* ADDRESS OF JCARD CSP09750 JLAS1 DC *-* ADDRESS OF JLAST CSP09760 DC FOUR+1 ADDRESS OF A FOUR CSP09770 DC NSIGN ADDRESS OF OLD SIGN INDICATOR CSP09780 * NDUMP=16448 CSP09790 * MONEY=16448 CSP09800 LDD BLANK LOAD TWO BLANKS CSP09810 STD MONEY STORE IN MONEY AND NDUMP CSP09820 * NZRSP=0 CSP09830 SRA 16 CLEAR THE ACCUMULATOR CSP09840 STO NZRSP SET NZRSP EQUAL TO ZERO CSP09850 * KNOW=KLAST CSP09860 LDXK LDX L1 *-* LOAD IR1 WITH KCARD COUNT CSP09870 * JNOW=JLAST CSP09880 LDXJ LDX L2 *-* LOAD IR2 WITH JCARD COUNT CSP09890 * KTEST=KCARD(KNOW) CSP09900 KCARD LD L *-* PICKUP KCARD(KNOW) CSP09910 STO LDXK+1 AND SAVE IT TEMPORARILY CSP09920 * IS KTEST NEGATIVE CSP09930 BSC L POSZ,- IS IT NEGATIVE-NO-GO TO POSZ CSP09940 * IS KTEST EQUAL TO AN EBCDIC ZERO CSP09950 S ZERO YES-CHECK AGAINST EBCDIC ZERO CSP09960 BSC L NEXT,Z IF NOT EQUAL-GO TO NEXT CSP09970 MDX ZRSP IF EQUAL-GO TO ZRSP CSP09980 * IS KTEST EQUAL TO 16448 CSP09990 POSZ S BLANK NOT NEGATIVE-CHECK AGAINST EBCD CSP10000 BSC L SRCE,+- BLANK-EQUAL-GO TO SRCE CSP10010 LD LDXK+1 NOT EQUAL-PICKUP KTEST CSP10020 * IS KTEST EQUAL TO 23616 CSP10030 S DLRSG IS IT A DOLLAR SIGN CSP10040 BSC L MNY,+- YES-GO TO MNY CSP10050 LD LDXK+1 NO-PICKUP KTEST CSP10060 * IS KTEST EQUAL TO 23360 CSP10070 S AST IS IT AN ASTERISK CSP10080 BSC Z YES-SKIP NEXT INSTRUCTION CSP10090 MDX NEXT NO-GO TO NEXT CSP10100 * NDUMP=KTEST CSP10110 LD LDXK+1 PICKUP KTEST AND CSP10120 STO NDUMP STORE IT IN NDUMP CSP10130 * MONEY=KTEST CSP10140 MNY LD LDXK+1 PICKUP KTEST AND CSP10150 STO MONEY STORE IT IN MONEY CSP10160 * NZRSP=KNOW CSP10170 ZRSP STX 1 NZRSP SAVE KNOW IN NZRSP CSP10180 * SEE IF JNOW IS LESS THAN J. IF CSP10190 * YES, GO TO NEXT. IF NO, GO TO CSP10200 * JCARD. CSP10210 SRCE STX 2 EDIT GET IR1 AND CSP10220 LD EDIT LOAD ITS VALUE CSP10230 BSC L NEXT,+ IF NOT POSITIVE-GO TO NEXT CSP10240 * KTEST=JCARD(JNOW) CSP10250 * KCARD(KNOW)=KTEST CSP10260 JCARD LD L *-* POSITIVE-PICKUP JCARD(JNOW) AND CSP10270 STO I KCARD+1 STORE IT IN KCARD(KNOW) CSP10280 STO LDXJ+1 STORE IN KTEST CSP10290 * JNOW=JNOW-1 CSP10300 MDX 2 -1 DECREMENT IR2 CSP10310 MDX * NOP CSP10320 MDX L JCARD+1,1 MODIFY JCARD ADDRESS TO CSP10330 * JNOW-1 CSP10340 * IS NZRSP POSITIVE CSP10350 LD NZRSP PICKUP NZRSP AND CSP10360 BSC L NEXT,+ IF NOT POSITIVE-GO TO NEXT CSP10370 * IS KTEST NEGATIVE CSP10380 LD LDXJ+1 POSITIVE-PICKUP KTEST CSP10390 BSC L OVER,- IF NOT NEGATIVE-GO TO OVER CSP10400 S ZERO NEGATIVE-CHECK AGAINST ZERO CSP10410 BSC L NEXT,+- EQUAL-GO TO NEXT CSP10420 MDX SETAG NOT EQUAL-GO TO SETAG CSP10430 * EXIT............................ CSP10440 SAVE1 LDX L1 *-* RESTORE IR1 CSP10450 SAVE2 LDX L2 *-* RESTORE IR2 CSP10460 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP10470 * IS KTEST EQUAL TO BLANK CSP10480 OVER S BLANK CHECK KTEST AGAINST BLANK CSP10490 BSC L NEXT,+- IF EQUAL-GO TO NEXT CSP10500 * IS KTEST EQUAL TO COMMA CSP10510 LD LDXJ+1 NOT EQUAL-CHECK KTEST CSP10520 S COMMA AGAINST A COMMA CSP10530 BSC L NEXT,+- EQUAL-GO TO NEXT CSP10540 * NZRSP=KNOW-1 CSP10550 SETAG STX 1 NZRSP NOT EQUAL-SET NZRSP EQUAL TO CSP10560 MDX L NZRSP,-1 KCARD COUNT MINUS ONE CSP10570 MDX * NO-OP CSP10580 * SEE IF KNOW IS LESS THAN K. IF CSP10590 * YES, PUT JCARD ZONE BACK. IF NO CSP10600 * GO BACK FOR MORE. CSP10610 NEXT MDX L KCARD+1,1 MODIFY KCARD ADDRESS TO CSP10620 * KNOW-1 CSP10630 MDX 1 -1 DECREMENT IR1 CSP10640 MDX KCARD GO BACK FOR MORE CSP10650 * PUT JCARD ZONE BACK CSP10660 CALL NZONE RESTORE JCARD ZONE CSP10670 JCRD2 DC *-* ADDRESS OF JCARD CSP10680 JLAS2 DC *-* ADDRESS OF JLAST CSP10690 DC NSIGN ADDRESS OF NEW SIGN INDICATOR CSP10700 DC EDIT DUMMY CSP10710 * SEE IF JNOW IS LESS THAN J. IF CSP10720 * YES, GO TO OK. IF NO, FILL WITH CSP10730 * ASTERISKS AND EXIT CSP10740 STX 2 JCRD1 GET THE CONTENTS OF CSP10750 LD JCRD1 IR2 AND CHECK CSP10760 BSC L OK,+ IF NOT POSITIVE-GO TO OK CSP10770 CALL FILL POSITIVE-ERROR-JCARD TOO LONG CSP10780 * FILL KCARD WITH ASTERISKS CSP10790 KCRD1 DC *-* ADDRESS OF KCARD CSP10800 K1 DC *-* ADDRESS OF K CSP10810 KLAS1 DC *-* ADDRESS OF KLAST CSP10820 DC AST ADDRESS OF FILL CHARACTER CSP10830 MDX SAVE1 GO TO EXIT CSP10840 ZERO DC E /F040 CONSTANT OF EBCDIC ZERO CSP10850 BLANK DC /4040 CONSTANT OF EBCDIC BLANK CSP10860 MONEY DC *-* FILL FOR FLOATING $ CSP10870 NDUMP DC *-* FILL FOR ANY SUPPRESSION CSP10880 NZRSP DC *-* HOW FAR TO ZERO SUPPRESS CSP10890 AST DC /5C40 CONSTANT OF ASTERISK CSP10900 DLRSG DC /5B40 CONSTANT OF DOLLAR SIGN CSP10910 COMMA DC /6B40 CONSTANT OF COMMA CSP10920 MINUS DC /6040 CONSTANT OF MINUS SIGN CSP10930 R DC /D940 CONSTANT OF LETTER R CSP10940 ONE2 DC 1 CONSTANT OF ONE CSP10950 TWO2 DC 2 CONSTANT OF TWO CSP10960 * IS NSIGN EQUAL TO TWO CSP10970 OK LD NSIGN PICKUP THE ORIGINAL ZONE CSP10980 S TWO2 INDICATOR AND CHECK AGAINST TWO CSP10990 BSC L NEG,+- EQUAL-GO TO NEG CSP11000 * KTEST=KCARD(KLAST) CSP11010 KCRD3 LD L *-* NOT EQUAL-PICKUP KCARD(KLAST) CSP11020 S MINUS AND CHECK AGAINST MINUS SIGN CSP11030 BSC L LD2,+- IF EQUAL-GO TO LD2 CSP11040 A MINUS NOT EQUAL-GET KTEST AND CHECK CSP11050 S R AGAINST LETTER R CSP11060 BSC L NEG,Z IF NOT EQUAL-GO TO NEG CSP11070 MDX L KCRD3+1,1 EQUAL-GET ADDRESS OF CSP11080 * KCARD(KLAST-1) CSP11090 * KCARD(KLAST-1)=16448 CSP11100 LD BLANK PICKUP A BLANK CSP11110 STO I KCRD3+1 STORE AT KCARD(KLAST-1) CSP11120 MDX L KCRD3+1,-1 GET ADDR OF KCARD(KLAST) CSP11130 * KCARD(KLAST)=16448 CSP11140 LD2 LD BLANK PICKUP A BLANK CSP11150 STO I KCRD3+1 STORE AT KCARD(KLAST) CSP11160 * IS NZRSP GREATER THAN ZERO CSP11170 NEG LD NZRSP GET NZRSP AND CSP11180 BSC L SAVE1,+ IF NOT POSITIVE-EXIT CSP11190 A I K1 POSITIVE-CALCULATE SUBSCRIPT OF CSP11200 S ONE2 LAST POSITION TO BE ZERO CSP11210 STO KCRD3+1 SUPPRESSED-END OF FILL AREA CSP11220 * ZERO SUPPRESS CSP11230 CALL FILL FILL ROUTINE TO ZERO SUPPRESS CSP11240 KCRD2 DC *-* ADDRESS OF KCARD CSP11250 K2 DC *-* ADDRESS OF K CSP11260 DC KCRD3+1 ADDRESS OF END OF FILL AREA CSP11270 DC NDUMP ADDRESS OF FILL CHARACTER CSP11280 * KCARD(NZRSP)=MONEY CSP11290 LD KCRD2 GET KCARD ADDRESS CSP11300 S KCRD3+1 SUBTRACT LAST FILL VALUE CSP11310 A ONE2 ADD CONSTANT OF ONE CSP11320 STO STOK+1 CREATE KCARD(NZRSP) ADDRESS CSP11330 LD MONEY PICKUP MONEY VALUE CSP11340 STOK STO L *-* STORE FOR SUPPRESSION CSP11350 NSIGN EQU STOK+1 TO SAVE CORE STORAGE CSP11360 MDX SAVE1 GO TO EXIT CSP11370 END CSP11380 // DUP CSP11390 *STORE WS UA EDIT CSP11400 // ASM CSP11410 ** FILL SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP11420 * NAME FILL CSP11430 * LIST CSP11440 ENT FILL FILL SUBROUTINE ENTRY POINT CSP11450 * CALL FILL(JCARD,J,JLAST,NCH) CSP11460 * THE WORDS JCARD(J) THROUGH CSP11470 * JCARD(JLAST) ARE FILLED WITH THE CSP11480 * CHARACTER AT LOCATION NCH. CSP11490 FILL DC *-* ARGUMENT ADDRESS COMES IN HERE CSP11500 STX 1 SAVE1+1 SAVE IR1 CSP11510 LDX I1 FILL PUT ARGUMENT ADDRESS IN IR1 CSP11520 LD 1 0 GET JCARD ADDRESS CSP11530 S I1 2 SUBTRACT VALUE OF JLAST CSP11540 STO STO+1 CREATE ADDRESS OF JCARD(JLAST) CSP11550 LD I1 2 GET VALUE OF JLAST CSP11560 ONE S I1 1 SUBTRACT VALUE OF J CSP11570 A ONE+1 ADD CONSTANT OF ONE CSP11580 BSC + CHECK FIELD WIDTH CSP11590 LD ONE+1 NEGATIVE OR ZERO - MAKE IT ONE CSP11600 STO LDX+1 OK - STORE FIELD WIDTH IN LDX CSP11610 LD I1 3 GET FILL CHARACTER - NCH CSP11620 MDX 1 4 MOVE OVER FOUR ARGUMENTS CSP11630 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP11640 * JNOW=J CSP11650 LDX LDX L1 *-* LOAD IR1 WITH FIELD WIDTH CSP11660 * JCARD(JNOW)=NCH CSP11670 STO STO L1 *-* STORE FILL CHAR AT JCARD(JNOW) CSP11680 * SEE IF JNOW IS LESS THAN JLAST. CSP11690 * IF YES, JNOW=JNOW+1 AND GO BACK CSP11700 * FOR MORE. IF NO, EXIT. CSP11710 MDX 1 -1 DECREMENT FIELD WIDTH CSP11720 MDX STO NOT DONE - GO BACK FOR MORE CSP11730 * EXIT......... CSP11740 SAVE1 LDX L1 *-* DONE - RESTORE IR1 CSP11750 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP11760 END CSP11770 // DUP CSP11780 *STORE WS UA FILL CSP11790 // ASM CSP11800 ** GET SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP11810 * NAME GET CSP11820 * LIST CSP11830 ENT GET GET SUBROUTINE ENTRY POINT CSP11840 * GET(JCARD,J,JLAST,SHIFT) CSP11850 * THE WORDS JCARD(J) THROUGH CSP11860 * JCARD(JLAST) ARE CONVERTED TO A CSP11870 * REAL NUMBER AND MULTIPLIED BY CSP11880 * SHIFT TO PLACE THE DECIMAL POINT CSP11890 GET DC *-* ARGUMENT ADDRESS COMES IN HERE CSP11900 STX 1 FIN+1 SAVE IR1 CSP11910 LDX I1 GET PUT ARGUMENT ADDRESS IN IR1 CSP11920 LD 1 0 GET JCARD ADDRESS CSP11930 STO JCRD1 STORE FOR NZONE AT JCRD1 CSP11940 STO JCRD3 STORE FOR NZONE AT JCRD3 CSP11950 TWO S I1 2 SUBTRACT JLAST VALUE CSP11960 STO JCRD2+1 CREATE JCARD(JLAST) ADDRESS CSP11970 LD 1 3 GET SHIFT ADDRESS AND CSP11980 STO SHIFT STORE FOR MULTIPLY TO PLACE . CSP11990 LD I1 2 GET JLAST VALUE AND CSP12000 STO GET SAVE FOR NZONE CSP12010 ONE S I1 1 SUBTRACT J VALUE CSP12020 A ONE+1 ADD CONSTANT OF ONE CSP12030 BSC + CHECK FIELD WIDTH CSP12040 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP12050 STO CNT+1 OK-SAVE FIELD WIDTH AT COUNT CSP12060 MDX 1 4 MOVE OVER FOUR ARGUMENTS CSP12070 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP12080 * MAKE THE FIELD POSITIVE AND CSP12090 * SAVE THE ORIGINAL SIGN CSP12100 CALL NZONE NZONE TO CLEAR ORIGINAL SIGN CSP12110 JCRD1 DC *-* ADDRESS OF JCARD CSP12120 DC GET ADDRESS OF JLAST CSP12130 DC FOUR ADDRESS OF CONSTANT OF FOUR CSP12140 DC JCRD1 ADDRESS OF OLD SIGN INDICATOR CSP12150 SLT 32 CLEAR ACCUMULATOR AND EXTENSION CSP12160 STD 3 126 CLEAR MANTISSA OF FAC CSP12170 STO 3 125 CLEAR CHARACTERISTIC OF FAC CSP12180 * LET GET AND ANS BE EQUIVALENT CSP12190 LIBF ESTO STORE THE CONTENTS OF FAC CSP12200 DC ANS AT GET CSP12210 * JNOW=J CSP12220 CNT LDX L1 *-* LOAD IR1 WITH THE FIELD WIDTH CSP12230 * JTEST=JCARD(JNOW) CSP12240 JCRD2 LD L1 *-* PICKUP JCARD(JNOW) CSP12250 BSC L MAYBE,+Z IS JTEST NEGATIVE-YES-MAYBE CSP12260 S BLANK NO - IS JTEST EQUAL TO AN CSP12270 BSC L ERR,Z EBCDIC BLANK - NO - GO TO ERR CSP12280 LD ZERO YES - REPLACE BLANK WITH ZERO CSP12290 MAYBE S ZERO IS JTEST LESS THAN AN EBCDIC CSP12300 BSC L ERR,+Z ZERO - YES - GO TO ERR CSP12310 * JTEST+4032 IN ACCUMULATOR CSP12320 * GET=10*GET+(JTEST+4032)/256 CSP12330 * SHIFT 8 IS SAME AS DIVIDE BY 256 CSP12340 SRA 8 NO - SHIFT 4 BIT DIGIT TO LOW CSP12350 LIBF FLOAT ORDER OF ACC AND MAKE REAL CSP12360 LIBF ESTO STORE REAL DIGIT CSP12370 DC TEMP IN TEMPORARY STORAGE CSP12380 LIBF ELD LOAD FAC WITH CSP12390 DC ANS GET CSP12400 LIBF EMPY MULTIPLY GET CSP12410 DC ETEN BT TEN CSP12420 LIBF NORM NORMALIZE THE PRODUCT CSP12430 LIBF EADD ADD TEMPORARY STORAGE CSP12440 DC TEMP TO FAC CSP12450 LIBF ESTO STORE RESULT CSP12460 DC ANS IN GET CSP12470 * SEE IF JNOW IS LESS THAN JLAST. CSP12480 * IF YES, JNOW=JNOW+1 AND GO BACK CSP12490 * FOR MORE. IF NO, PLACE DECIMAL CSP12500 * POINT. CSP12510 MDX 1 -1 DECREMENT FIELD WIDTH CSP12520 MDX JCRD2 NOT DONE-GET NEXT DIGIT CSP12530 * GET=SHIFT*GET CSP12540 LIBF EMPY DONE-MULTIPLY BY SHIFT TO PLACE CSP12550 SHIFT DC *-* ADDRESS OF SHIFT---DECIMAL POINT CSP12560 LIBF NORM NORMALIZE THE RESULT CSP12570 * REPLACE SIGN OF JCARD CSP12580 CALL NZONE RESTORE ORIGINAL JCARD SIGN CSP12590 JCRD3 DC *-* ADDRESS OF JCARD CSP12600 DC GET ADDRESS OF JLAST CSP12610 DC JCRD1 ADDRESS OF ORIG. SIGN INDICATOR CSP12620 DC JCRD3 DUMMY CSP12630 * IF INDICATOR EQUALS 2, CSP12640 * GET=-GET. OTHERWISE, EXIT..... CSP12650 LD JCRD1 LOAD OLD SIGN AND SEE IF IT CSP12660 S TWO+1 WAS NEGATIVE CSP12670 BSC L FIN,Z IF YES,REVERSE SIGN-NO-EXIT CSP12680 * GET=-GET CSP12690 LIBF SNR REVERSE THE SIGN OF THE RESULT CSP12700 * EXIT........................... CSP12710 FIN LDX L1 *-* RESTORE IR1 CSP12720 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP12730 FOUR DC 4 CONSTANT OF FOUR CSP12740 BLANK DC /4040 CONSTANT OF EBCDIC BLANK CSP12750 ZERO DC /F040 CONSTANT OF EBCDIC ZERO CSP12760 ERR SLT 32 CLEAR ACCUMULATOR AND EXTENSION CSP12770 STD 3 126 CLEAR MANTISSA OF FAC CSP12780 STO 3 125 CLEAR CHARACTERISTIC OF FAC CSP12790 MDX FIN GO TO EXIT CSP12800 TEMP BSS 3 TEMPORARY STORAGE CSP12810 ANS BSS 3 TEMPORARY STORAGE CSP12820 ETEN XFLC 10.0 CONSTANT OF 10.0 (TEN) CSP12830 END CSP12840 // DUP CSP12850 *STORE WS UA GET CSP12860 // ASM CSP12870 ** ICOMP SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP12880 * NAME ICOMP CSP12890 * LIST CSP12900 ENT ICOMP ICOMP SUBROUTINE ENTRY POINT CSP12910 * ICOMP(JCARD,J,JLAST,KCARD,K,KLAST) CSP12920 * THE WORDS JCARD(J) THROUGH CSP12930 * JCARD(JLAST) ARE COMPARED TO THE CSP12940 * WORDS KCARD(K) THROUGH CSP12950 * KCARD(KLAST). CSP12960 ICOMP DC *-* ARGUMENT ADDRESS COMES IN HERE CSP12970 STX 1 SAVE1+1 SAVE IR1 CSP12980 LDX I1 ICOMP PUT ARGUMENT ADDRESS IN IR1 CSP12990 LD 1 0 GET JCARD ADDRESS CSP13000 S I1 2 SUBTRACT JLAST VALUE CSP13010 STO JPIC1+1 STORE JCARD(JLAST) FOR JHASH CSP13020 STO JPIC2+1 STORE JCARD(JLAST) FOR ICOMP CSP13030 A ONE+1 ADD CONSTANT OF ONE CSP13040 STO SGNJ+1 CREATE ADDRESS OF JCARD(JLAST) CSP13050 LD 1 3 GET KCARD ADDRESS CSP13060 S I1 5 SUBTRACT KLAST VALUE CSP13070 STO KPIC2+1 STORE KCARD(KLAST) FOR ICOMP CSP13080 A ONE+1 ADD CONSTANT OF ONE CSP13090 STO SGNK+1 CREATE ADDRESS OF KCARD(KLAST) CSP13100 TWO LD I1 2 GET VALUE OF JLAST CSP13110 ONE S I1 1 SUBTRACT VALUE OF J CSP13120 A ONE+1 ADD CONSTANT OF ONE CSP13130 BSC + CHECK FIELD WIDTH CSP13140 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP13150 STO CNTCO+1 SAVE FIELD WIDTH IN COMP CNT CSP13160 * CLEAR AND SAVE THE SIGNS ON THE CSP13170 * JCARD AND THE KCARD FIELDS CSP13180 SGNJ LD L *-* PICKUP THE SIGN OF JCARD CSP13190 STO JSIGN SAVE IT CSP13200 BSC L SGNK,- IS IT NEG-NO-LOOK AT KCARD CSP13210 EOR HFFFF+1 YES-MAKE IT POSITIVE AND CSP13220 STO I SGNJ+1 CHANGE JCARD FIELD SIGN CSP13230 SGNK LD L *-* PICKUP THE SIGN OF KCARD CSP13240 STO KSIGN SAVE IT CSP13250 BSC L CHCK,- IS IT NEG-NO-GO TO CHCK CSP13260 EOR HFFFF+1 YES-MAKE IT POSITIVE AND CSP13270 STO I SGNK+1 CHANGE THE KCARD FIELD SIGN CSP13280 CHCK MDX 1 6 MOVE OVER SIX ARGUMENTS CSP13290 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP13300 * K IS COMPARED TO CSP13310 * KSTRT=KLAST+J-JLAST-1 CSP13320 LD I1 -2 PICKUP THE VALUE OF K CSP13330 HFFFF S I1 -1 SUBTRACT THE VALUE OF KLAST CSP13340 S I1 -5 SUBTRACT THE VALUE OF J CSP13350 A I1 -4 ADD THE VALUE OF JLAST CSP13360 A ONE+1 ADD CONSTANT OF ONE CSP13370 BSC L JHASH,-Z IF POSITIVE GO TO JHASH CSP13380 EOR HFFFF+1 OTHERWISE COMPLIMENT AND ADD CSP13390 A TWO+1 ONE GIVING LEADING PART KCARD CSP13400 STO ZIPCT+1 STORE THIS COUNT AT ZIPCT CSP13410 A I1 -2 ADD VALUE OF K CSP13420 S ONE+1 SUBTRACT CONSTANT OF ONE CSP13430 STO ICOMP STORE TEMPORARILY CSP13440 LD 1 -3 GET KCARD ADDRESS CSP13450 S ICOMP SUBTRACT TEMPORARY VALUE GIVING CSP13460 STO KPIC1+1 ADDR FOR SEARCHING BEGINNING CSP13470 * OF KCARD CSP13480 * ICOMP=-KSIGN CSP13490 LD KSIGN LOAD SIGN OF KCARD CSP13500 EOR HFFFF+1 NEGATE IT CSP13510 STO ICOMP STORE IT IN ICOMP CSP13520 * KNOW=K CSP13530 ZIPCT LDX L1 *-* LOAD IR1 WITH BEGINNING KCARD CT CSP13540 KPIC1 LD L1 *-* PICKUP KCARD(KNOW) CSP13550 * IS KCARD(KNOW) POSITIVE CSP13560 BSC L FIN,-Z IF POSITIVE, GO TO FIN CSP13570 * SEE IF KNOW IS LESS THAN KSTRT. CSP13580 * IF YES, KNOW=KNOW+1 AND LOOK AT CSP13590 * NEXT KCARD WORD. IF NO, GO TO CSP13600 * JHASH. CSP13610 MDX 1 -1 OTHERWISE, DECREMENT FIELD WIDTH CSP13620 MDX KPIC1 NOT DONE-GO BACK FOR NEXT DIGIT CSP13630 * JHASH=0 CSP13640 JHASH SRA 16 DONE-CLEAR ACCUMULATOR CSP13650 STO ICOMP CLEAR ICOMP CSP13660 * KNOW=KSTRT+1 CSP13670 * KSTRT=J CSP13680 CNTCO LDX L1 *-* LOAD IR1 WITH FIELD WIDTH CSP13690 * JHASH=JHASH+JCARD(KSTRT) CSP13700 JPIC1 A L1 *-* ADD JCARD(KSTRT) TO JHASH CSP13710 SRT 16 STORE JHASH IN EXTENSION CSP13720 * ICOMP=JCARD(KSTRT)-KCARD(KNOW) CSP13730 JPIC2 LD L1 *-* LOAD JCARD(KSTRT) CSP13740 KPIC2 S L1 *-* SUBTRACT KCARD(KNOW) CSP13750 STO ICOMP STORE RESULT CSP13760 * IS ICOMP ZERO - NO - GO TO NEQ CSP13770 BSC L NEQ,Z IF NOT ZERO, GO TO NEQ. CSP13780 SLT 16 OTHERWISE, PUT JHASH IN ACCUM CSP13790 * KNOW=KNOW+1 CSP13800 * SEE IF KSTRT IS LESS THAN JLAST. CSP13810 * IF YES, KSTRT=KSTRT+1 AND TRY CSP13820 * NEXT PAIR OF DIGITS. IF NO, CSP13830 MDX 1 -1 DECREMENT FIELD WIDTH CSP13840 MDX JPIC1 NOT DONE - GO BACK CSP13850 * IF NO IS JSIGN*KSIGN*JHASH NEGATIVE. CSP13860 BSC L FIN,+- DONE-IF JHASH IS ZERO GO FIN CSP13870 LD JSIGN OTHERWISE - COMPUTE JSIGN CSP13880 EOR KSIGN TIMES KSIGN CSP13890 BSC L FIN,- IF NOT NEGATIVE, GO TO FIN CSP13900 MDX OVR1 OTHERWISE GO TO OVR1 CSP13910 * IS KSIGN*JSIGN NEGATIVE CSP13920 NEQ LD JSIGN COMPUTE JSIGN CSP13930 EOR KSIGN TIMES KSIGN CSP13940 BSC L OVR2,- IF NOT NEGATIVE, GO TO OVR2 CSP13950 * ICOMP=1 CSP13960 OVR1 LD CNTCO OTHERWISE, SET ICOMP CSP13970 STO ICOMP TO A POSITIVE NUMBER CSP13980 * ICOMP=JSIGN*ICOMP CSP13990 OVR2 LD JSIGN CSP14000 SLA 5 CSP14010 EOR ICOMP CSP14020 STO ICOMP CSP14030 * RESTORE SIGNS ON JCARD,KCARD FIELDS CSP14040 FIN LD JSIGN RESTORE THE ORIGINAL CSP14050 STO I SGNJ+1 SIGN OF JCARD CSP14060 LD KSIGN RESTORE THE ORIGINAL CSP14070 STO I SGNK+1 SIGN OF KCARD CSP14080 LD ICOMP PUT ICOMP IN THE ACCUMULATOR CSP14090 * EXIT CSP14100 SAVE1 LDX L1 *-* RESTORE IR1 CSP14110 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP14120 JSIGN DC *-* SIGN OF JCARD CSP14130 KSIGN DC *-* SIGN OF KCARD CSP14140 END CSP14150 // DUP CSP14160 *STORE WS UA ICOMP CSP14170 // ASM CSP14180 ** IOND SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP14190 * NAME IOND CSP14200 * LIST CSP14210 ENT IOND SUBROUTINE NAME CSP14220 *CALL IOND NO PARAMETERS CSP14230 *CALL IOND ALLOWS I/O OPERATIONS TO END BEFORE A CSP14240 * PAUSE OR STOP IS ENTERED CSP14250 IOND BSS 1 ARGUMENT ADDRESS CSP14260 IOPND MDX L 50,0 ANY INTERRUPTS PENDING CSP14270 MDX IOPND YES - KEEP CHECKING CSP14280 BACK BSC I IOND NO - RETURN TO CALLING PRG CSP14290 END CSP14300 // DUP CSP14310 *STORE WS UA IOND CSP14320 // ASM CSP14330 ** MOVE SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP14340 * NAME MOVE CSP14350 * LIST CSP14360 ENT MOVE MOVE SUBROUTINE ENTRY POINT CSP14370 * CALL MOVE(JCARD,J,JLAST,KCARD,K) CSP14380 * THE WORDS JCARD(J) THROUGH CSP14390 * JCARD(JLAST) ARE MOVED TO KCARD CSP14400 * STARTING AT KCARD(K). CSP14410 MOVE DC *-* ARGUMENT ADDRESS COMES IN HERE CSP14420 STX 1 SAVE1+1 SAVE IR1 CSP14430 LDX I1 MOVE PUT ARGUMENT ADDRESS IN IR1 CSP14440 LD 1 0 GET JCARD ADDRESS CSP14450 S I1 2 SUBTRACT JLAST VALUE CSP14460 STO LD1+1 PLACE ADDR OF JCARD(JLAST) IN CSP14470 * PICKUP OF MOVE CSP14480 LD I1 2 GET JLAST VALUE CSP14490 ONE S I1 1 SUBTRACT J VALUE CSP14500 BSC +Z CHECK FIELD WIDTH CSP14510 SRA 16 NEGATIVE - MAKE IT ZERO CSP14520 STO LDX+1 STORE FIELD WIDTH IN LDX CSP14530 LD 1 3 GET KCARD ADDRESS CSP14540 S I1 4 SUBTRACT K VALUE CSP14550 S LDX+1 SUBTRACT FIELD WIDTH CSP14560 STO STO+1 PLACE ADDR OF KCARD(KLAST) IN CSP14570 * STORE OF MOVE CSP14580 MDX L LDX+1,1 ADD ONE TO FIELD WIDTH CSP14590 * MAKING IT TRUE CSP14600 MDX 1 5 MOVE OVER FIVE ARGUMENTS CSP14610 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP14620 * JNOW=J CSP14630 * KNOW=K+JNOW-J CSP14640 LDX LDX L1 *-* LOAD IR1 WITH FIELD WIDTH CSP14650 * KCARD(KNOW)=JCARD(JNOW) CSP14660 LD1 LD L1 *-* PICKUP JCARD(JNOW) CSP14670 STO STO L1 *-* STORE IT IN KCARD(KNOW) CSP14680 * SEE IF JNOW IS LESS THAN JLAST. CSP14690 * IF YES, JNOW=JNOW+1 AND MOVE CSP14700 * NEXT CHARACTER. IF NO, EXIT.... CSP14710 MDX 1 -1 DECREMENT THE FIELD WIDTH CSP14720 MDX LD1 NOT DONE - GET NEXT WORD CSP14730 * EXIT............................ CSP14740 SAVE1 LDX L1 *-* DONE - RESTORE IR1 CSP14750 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP14760 END CSP14770 // DUP CSP14780 *STORE WS UA MOVE CSP14790 // ASM CSP14800 ** MPY SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP14810 * NAME MPY CSP14820 * LIST CSP14830 ENT MPY MPY SUBROUTINE ENTRY POINT CSP14840 * CALL MPY(JCARD,J,JLAST,KCARD,K,KLAST,NER) CSP14850 * THE WORDS JCARD(J) THROUGH CSP14860 * JCARD(JLAST) MULTIPLY THE WORDS CSP14870 * KCARD(K) THROUGH KCARD(KLAST). CSP14880 * THE RESULT IS IN THE KCARD FIELD CSP14890 * EXTENDED TO THE LEFT. CSP14900 MPY DC *-* ARGUMENT ADDRESS COMES IN HERE CSP14910 STX 2 SAVE2+1 SAVE IR2 CSP14920 STX 1 SAVE1+1 SAVE IR1 CSP14930 LDX I1 MPY PUT ARGUMENT ADDRESS IN IR1 CSP14940 LD 1 4 GET K ADDRESS CSP14950 STO K1 STORE FOR FILL OF ZEROES CSP14960 * CALCULATE K-1 CSP14970 LD I K1 GET VALUE OF K CSP14980 S ONE+1 SUBTRACT CONSTANT OF ONE CSP14990 STO MPY STORE IN MPY CSP15000 LD 1 0 GET JCARD ADDRESS CSP15010 S I1 2 SUBTRACT JLAST VALUE CSP15020 STO SRCH+1 SAVE FOR JFRST SEARCH CSP15030 STO MULT1+1 SAVE FOR MULTIPLICATION CSP15040 A ONE+1 ADD CONSTANT OF ONE CSP15050 STO OK+2 CREATE ADDRESS OF JCARD(JLAST) CSP15060 TWO LD I1 2 GET JLAST VALUE CSP15070 ONE S I1 1 SUBTRACT J VALUE CSP15080 A ONE+1 ADD CONSTANT OF ONE CSP15090 BSC + CHECK FIELD WIDTH CSP15100 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP15110 STO SCHCT+1 SAVE FIELD WIDTH FOR SEARCH CSP15120 LD 1 3 GET KCARD ADDRESS CSP15130 STO KCRD1 SAVE FOR FILL CSP15140 STO KCRD2 SAVE FOR FILL CSP15150 STO KCRD3 SAVE FOR CARRY CSP15160 S I1 5 SUBTRACT JLAST VALUE CSP15170 STO PICK+1 SAVE FOR MULTIPLICATION CSP15180 STO PUT1+1 SAVE FOR MULTIPLICATION CSP15190 A ONE+1 ADD CONSTANT OF ONE CSP15200 STO SGNK+1 CREATE ADDRESS OF KCARD(KLAST) CSP15210 LD 1 5 GET KLAST ADDRESS CSP15220 STO KLAS2 SAVE FOR CARRY CSP15230 STO KLAS1 SAVE FOR FILL CSP15240 LD I1 5 GET KLAST VALUE CSP15250 S I1 4 SUBTRACT K VALUE CSP15260 A ONE+1 ADD CONSTANT OF ONE CSP15270 BSC + CHECK FIELD WIDTH CSP15280 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP15290 STO MULTC+1 SAVE FOR MULTIPLICATION CSP15300 MDX 1 7 MOVE OVER SEVEN ARGUMENTS CSP15310 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP15320 * KSTRT=K-JLAST+J-1 CSP15330 LD MPY LOAD K-1 CSP15340 A I1 -6 ADD VALUE OF J CSP15350 S I1 -5 SUBTRACT VALUE OF JLAST CSP15360 BSC L SCHCT,-Z IF KSTRT POSITIV-GO TO SCHCT CSP15370 * NER=KLAST CSP15380 LD I1 -2 NOT POSITIVE-LOAD KLAST VALUE CSP15390 MONE STO I1 -1 AND STORE AT NER CSP15400 MDX SAVE1 GO TO EXIT CSP15410 * JFRST=J CSP15420 SCHCT LDX L1 *-* LOAD IR1 WITH JCARD FIELD WIDTH CSP15430 OK STO SCHCT+1 SAVE KSTRT IN SCHCT+1 CSP15440 * CLEAR AND SAVE THE SIGNS ON THE CSP15450 * JCARD AND THE KCARD FIELDS CSP15460 LD L *-* GET JCARD(JLAST) VALUE CSP15470 STO JSIGN SAVE SIGN IN JSIGN CSP15480 BSC L OVRJ,- IF NOT NEGATIVE-GO TO OVRJ CSP15490 EOR MONE+1 NEGATIVE-MAKE SIGN POSITIVE CSP15500 STO I OK+2 AND PUT BACK IN JCARD(JLAST) CSP15510 LD MONE+1 PICKUP A MINUS ONE CSP15520 OVRJ SRT 16 PUT JSIGN INDICATION IN EXTENTON CSP15530 SGNK LD L *-* PICKUP KCARD(KLAST) CSP15540 BSC L KPLUS,- IF NOT NEGATIVE-GO TO KPLUS CSP15550 EOR MONE+1 NEGATIVE-MAKE POSITIVE AND CSP15560 STO I SGNK+1 PUT BACK IN KCARD(KLAST) CSP15570 SLT 16 GET JSIGN INDICATION CSP15580 EOR MONE+1 CHANGE IT CSP15590 MDX OVRK SKIP THE NEXT INSTRUCTION CSP15600 KPLUS SLT 16 GET JSIGN INDICATION CSP15610 OVRK STO KSIGN SAVE SIGN FOR RESULT CSP15620 * FILL LEFT EXTENSION OF KCARD CSP15630 * WITH ZEROES CSP15640 CALL FILL FILL KCARD EXTENSION WITH ZEROES CSP15650 KCRD1 DC *-* ADDRESS OF KCARD CSP15660 DC SCHCT+1 ADDRESS OF KSTRT CSP15670 DC MPY ADDRESS OF K-1 CSP15680 DC ZIP ADDRESS OF ZERO CSP15690 * IS JCARD(JLAST) POSITIVE CSP15700 SRCH LD L1 *-* PICKUP JCARD(JFRST) CSP15710 BSC L MULTC,-Z IF POSITIVE-GO TO MULTC CSP15720 * SEE IF JFRST IS LESS THAN JLAST. CSP15730 * IF YES, JFRST=JFRST+1 AND GO CSP15740 * BACK FOR MORE. IF NO, CSP15750 * MULTIPLICATION IS BY ZERO. CSP15760 MDX 1 -1 NOT POSITIVE-DECREMENT IR1 CSP15770 MDX SRCH NOT DONE - GO BACK FOR MORE CSP15780 * FILL WITH ZERO SINCE MULTIPLIER CSP15790 * IS ZERO CSP15800 CALL FILL DONE-MAKE ENTIRE RESULT ZERO CSP15810 KCRD2 DC *-* ADDRESS OF KCARD CSP15820 K1 DC *-* ADDRESS OF K CSP15830 KLAS1 DC *-* ADDRESS OF KLAST CSP15840 DC ZIP ADDRESS OF ZERO CSP15850 * RESTORE THE SIGN OF JCARD CSP15860 * EXIT............................ CSP15870 FIN LD JSIGN PICKUP JCARD SIGN CSP15880 STO I OK+2 AND RESTORE IT CSP15890 SAVE2 LDX L2 *-* RESTORE IR2 CSP15900 SAVE1 LDX L1 *-* RESTORE IR1 CSP15910 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP15920 * KM=K CSP15930 MULTC LDX L2 *-* POSITIVE-LOAD IR2 WITH KCARD CNT CSP15940 STX 1 K1 SAVE JFRST AT K1 CSP15950 * MULT=KCARD(KM) CSP15960 PICK LD L2 *-* PICKUP KCARD(KM) CSP15970 BSC L MO,+ IS IT POSITIVE-NO-GO TO MO CSP15980 STO KLAS1 YES-SAVE KCARD(KM) CSP15990 SRA 16 CLEAR ACCUMULATOR CSP16000 * KCARD(KM)=0 CSP16010 PUT1 STO L2 *-* SET KCARD(KM)=0 CSP16020 * KNOW=KM+JFRST-JLAST CSP16030 STX 2 MULTC+1 GET THE VALUE CSP16040 LD MULTC+1 OF KM CSP16050 A K1 AND ADD JFRST CSP16060 A MONE+1 TO IT AND CALCULATE CSP16070 A PUT1+1 THE ADDRESS OF CSP16080 STO PUT2+1 KCARD(KNOW) CSP16090 * JNOW=JFRST CSP16100 LDX I1 K1 LOAD IR1 WITH JFRST CSP16110 * KCARD(KNOW)=MULT*JCARD(JNOW) CSP16120 * +KCARD(KNOW) CSP16130 MULT1 LD L1 *-* PICKUP JCARD(JNOW) CSP16140 M KLAS1 MULTIPLY BY MULT CSP16150 SLT 16 RE-ALIGN THE PRODUCT CSP16160 A I PUT2+1 CSP16170 PUT2 STO L *-* CSP16180 MDX L PUT2+1,-1 MODIFY ADDR OF KCARD(KNOW) CSP16190 * SEE IF JNOW IS LESS THAN JLAST. CSP16200 * IF YES, JNOW=JNOW+1 AND GO BACK CSP16210 * FOR MORE. IF NO, CHECK KM. CSP16220 MDX 1 -1 DECREMENT IR1 CSP16230 MDX MULT1 NOT DONE-GO BACK FOR MORE CSP16240 * SEE IF KM IS LESS THAN KLAST. CSP16250 * IF YES, KM=KM+1 AND GO BACK FOR CSP16260 * MORE. IF NO, RESOLVE CARRIES. CSP16270 MO MDX 2 -1 DONE-DECREMENT IR2 CSP16280 MDX PICK NOT DONE-GO BACK FOR MORE CSP16290 * RESOLVE CARRIES IN THE PRODUCT CSP16300 CALL CARRY DONE-RESOLVE CARRIES IN THE RES CSP16310 KCRD3 DC *-* ADDRESS OF KCARD CSP16320 DC SCHCT+1 ADDRESS OF KSTRT CSP16330 KLAS2 DC *-* ADDRESS OF KLAST CSP16340 DC KCRD3 DUMMY CSP16350 * GENERATE THE SIGN OF THE PRODUCT CSP16360 LD KSIGN PICKUP THE SIGN INDICATOR CSP16370 BSC L FIN,- IF NOT NEGATIVE-ALL DONE-EXIT CSP16380 LD I SGNK+1 NEGATIVE-PICKUP KCARD(KLAST) CSP16390 EOR MONE+1 CHANGE THE SIGN CSP16400 STO I SGNK+1 RESTORE KCARD(KLAST) CSP16410 MDX FIN GO TO EXIT CSP16420 JSIGN DC *-* SIGN OF JCARD CSP16430 KSIGN DC *-* SIGN OF PRODUCT CSP16440 ZIP DC 0 CONSTANT OF ZERO CSP16450 END CSP16460 // DUP CSP16470 *STORE WS UA MPY CSP16480 // ASM CSP16490 ** NCOMP SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP16500 * NAME NCOMP CSP16510 * LIST CSP16520 ENT NCOMP NCOMP SUBROUTINE ENTRY POINT CSP16530 * NCOMP(JCARD,J,JLAST,KCARD,K) CSP16540 * THE WORDS JCARD(J) THROUGH CSP16550 * JCARD(JLAST) STARTING WITH CSP16560 * JCARD(J) ARE COMPARED LOGICALLY CSP16570 * TO THE FIELD STARTING AT CSP16580 * KCARD(K). ALL DATA MUST BE IN CSP16590 * A1 FORMAT. CSP16600 NCOMP DC *-* ARGUMENT ADDRESS COMES IN HERE CSP16610 STX 1 SAVE1+1 SAVE IR1 CSP16620 LDX I1 NCOMP PUT ARGUMENT ADDRESS IN IR1 CSP16630 LD 1 0 GET JCARD ADDRESS CSP16640 S I1 2 SUBTRACT JLAST VALUE CSP16650 STO LD1+1 CREATE END OF JCARD ADDRESS CSP16660 LD I1 2 GET JLAST VALUE CSP16670 ONE S I1 1 SUBTRACT J VALUE CSP16680 BSC +Z CHECK FIELD WIDTH CSP16690 SRA 16 NEGATIVE - MAKE IT ZERO CSP16700 STO LDX+1 SAVE FIELD WIDTH CSP16710 LD 1 3 GET KCARD ADDRESS CSP16720 S I1 4 SUBTRACT K VALUE CSP16730 S LDX+1 SUBTRACT FIELD WIDTH CSP16740 STO LD2+1 CREATE END OF KCARD ADDRESS CSP16750 MDX L LDX+1,1 MAKE FIELD WIDTH TRUE CSP16760 MDX 1 5 MOVE OVER FIVE ARGUMENTS CSP16770 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP16780 * JNOW=J CSP16790 * KNOW=K+JNOW-J CSP16800 LDX LDX L1 *-* PUT FIELD WIDTH IN IR1 CSP16810 LD2 LD L1 *-* PICKUP JCARD(JNOW) CSP16820 SRT 4 DIVIDE BY SIXTEEN CSP16830 STO LDX+1 SAVE TEMPORARILY CSP16840 LD1 LD L1 *-* PICKUP KCARD(KNOW) CSP16850 SRT 4 DIVIDE BY SIXTEEN CSP16860 S LDX+1 CALCUL JCARD(JNOW)-KCARD(KNOW) CSP16870 BSC L SAVE1,Z IS NCOMP ZERO-NO-ALL DONE CSP16880 * SEE IF JNOW IS LESS THAN JLAST. CSP16890 * IF YES, JNOW=JNOW+1 AND GO BACK CSP16900 * FOR MORE. IF NO, EXIT. CSP16910 MDX 1 -1 YES-DECREMENT FIELD WIDTH CSP16920 MDX LD2 GO BACK FOR MORE CSP16930 * ALL DONE - - EXIT............... CSP16940 SAVE1 LDX L1 *-* RESTORE IR1 CSP16950 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP16960 END CSP16970 // DUP CSP16980 *STORE WS UA NCOMP CSP16990 // ASM CSP17000 ** NSIGN SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP17010 * NAME NSIGN CSP17020 * LIST CSP17030 ENT NSIGN NSIGN SUBROUTINE ENTRY POINT CSP17040 * CALL NSIGN(JCARD,J,NEWS,NOLDS) CSP17050 * THE SIGN OF THE DIGIT AT CSP17060 * JCARD(J) IS TESTED AND NOLDS IS CSP17070 * SET. THE SIGN IS MODIFIED AS CSP17080 * INDICATED BY NEWS. CSP17090 NSIGN DC *-* ARGUMENT ADDRESS COMES IN HERE CSP17100 STX 1 SAVE1+1 SAVE IR1 CSP17110 LDX I1 NSIGN PUT ARGUMENT ADDRESS IN IR1 CSP17120 LD 1 0 GET JCARD ADDRESS CSP17130 ONE S I1 1 SUBTRACT J VALUE CSP17140 A ONE+1 ADD CONSTANT OF ONE CSP17150 STO CHAR+1 CREATE JCARD(J) ADDRESS CSP17160 * JTEST=JCARD(J) CSP17170 CHAR LD L *-* PICKUP DIGIT CSP17180 BSC L PLUS,- IS JTEST NEGATIV-NO-GO TO PLUS CSP17190 SRT 16 YES-SAVE TEMPORARILY CSP17200 * NOLDS=-1 CSP17210 LD HFFFF PICKUP MINUS ONE CSP17220 STO I1 3 STORE IN NOLDS CSP17230 * NEWS*JTEST IS COMPARED TO ZERO CSP17240 * NEWS IS COMPARED TO ZERO CSP17250 LD I1 2 PICKUP NEWS CSP17260 BSC L FIN,+Z IF NEGATIVE ALL DONE CSP17270 * JTEST=-JTEST-1 CSP17280 REV SLT 16 RESTORE JTEST CSP17290 EOR HFFFF CHANGE THE SIGN CSP17300 * JCARD(J)=JTEST CSP17310 STO I CHAR+1 PUT NEW SIGN IN JCARD(J) CSP17320 FIN MDX 1 4 MOVE OVER FOUR ARGUMENTS CSP17330 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP17340 * EXIT............................ CSP17350 SAVE1 LDX L1 *-* RESTORE IR1 CSP17360 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP17370 PLUS SRT 16 SAVE TEMPORARILY CSP17380 * NOLDS=1 CSP17390 LD ONE+1 PICKUP CONSTANT OF ONE CSP17400 STO I1 3 STORE IT IN NOLDS CSP17410 * NEWS*JTEST IS COMPARED TO ZERO CSP17420 * NEWS IS COMPARED TO ZERO CSP17430 LD I1 2 PICKUP NEWS CSP17440 BSC L FIN,-Z IF POSITIVE - ALL DONE CSP17450 MDX REV REVERSE SIGN - GO TO REV CSP17460 HFFFF DC /FFFF CONSTANT OF MINUS ONE CSP17470 END CSP17480 // DUP CSP17490 *STORE WS UA NSIGN CSP17500 // ASM CSP17510 ** NZONE SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP17520 * NAME NZONE CSP17530 * LIST CSP17540 ENT NZONE NZONE SUBROUTINE ENTRY POINT CSP17550 * CALL NZONE(JCARD,J,NEWZ,NOLDZ) CSP17560 * THE ZONE OF THE CHARACTER AT CSP17570 * JCARD(J) IS TESTED AND NOLDZ IS CSP17580 * SET. THE ZONE IS MODIFIED AS CSP17590 * INDICATED BY NEWZ. CSP17600 NZONE DC *-* ARGUMENT ADDRESS COMES IN HERE CSP17610 STX 1 SAVE1+1 SAVE IR1 CSP17620 LDX I1 NZONE PUT ARGUMENT ADDRESS IN IR1 CSP17630 LD 1 0 GET JCARD ADDRESS CSP17640 ONE S I1 1 SUBTRACT J VALUE CSP17650 A ONE+1 ADD CONSTANT OF ONE CSP17660 STO STO+1 CREATE JCARD(J) ADDRESS CSP17670 STO LD1+1 CREATE JCARD(J) ADDRESS CSP17680 * JTEST=JCARD(J) CSP17690 LD1 LD L *-* PICKUP THE CHARACTER CSP17700 STO LD1+1 SAVE IT TEMPORARILY CSP17710 * IS JTEST NEGATIVE CSP17720 BSC L PLUS,- IF NOT NEGATIVE-GO TO PLUS CSP17730 S ZERO NEGATIVE-CHECK TO SEE IF IT IS CSP17740 BSC L TWO,+- AN EBCDIC ZERO-YES-GO TO TWO CSP17750 * NOLDZ=5+(JTEST-4096)/4096 CSP17760 * SHIFT 12 IS EQUIVALENT TO DIVIDE CSP17770 * BY 4096 CSP17780 * AND 3000 IS EQUIVALENT TO CSP17790 * SUBTRACT 4096 AND SHIFT CSP17800 LD LD1+1 NO-RELOAD JTEST CSP17810 AND H3000 REMOVE ALL BUT BITS 2 AND 3 CSP17820 SRA 12 PUT IN LOW ORDER OF ACCUMULATOR CSP17830 A ONE+1 ADD CONSTANT OF ONE CSP17840 STO I1 3 STORE IN NOLDZ CSP17850 * IS NEWZ LESS THAN FIVE CSP17860 LD I1 2 PICKUP VALUE OF NEWZ CSP17870 S FOUR AND CHECK FOR LESS THAN FIVE CSP17880 BSC L FINIS,-Z NO-GO TO EXIT CSP17890 A FOUR YES - RESTORE NEWZ CSP17900 * JCARD(J)=JTEST+4096*(NEWZ-NOLDZ) CSP17910 S I1 3 SUBTRACT NOLDZ CSP17920 SLA 12 PUT RESULT IN BITS 2 AND 3 CSP17930 A LD1+1 ADD ORIGINAL CHARACTER CSP17940 STO STO L *-* STORE BACK IN JCARD(J) CSP17950 * EXIT............................ CSP17960 FINIS MDX 1 4 MOVE OVER FOUR ARGUMENTS CSP17970 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP17980 SAVE1 LDX L1 *-* RESTORE IR1 CSP17990 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP18000 MINUS DC /6040 CONSTANT OF EBCDIC MINUS SIGN CSP18010 ZERO DC /F040 CONSTANT OF EBCDIC ZERO CSP18020 FOUR DC 4 CONSTANT OF FOUR CSP18030 H3000 DC /3000 CONSTANT FOR STRIPING BITS CSP18040 * IS NEWZ TWO CSP18050 TWO LD I1 2 PICKUP VALUE OF NEWZ CSP18060 S TWO+1 IS IT TWO CSP18070 BSC L NOT,Z NO - GO TO NOT CSP18080 * JCARD(J)=24640 CSP18090 LD MINUS YES - SET JCARD(J) CSP18100 STO I STO+1 EQUAL TO AN EBCDIC MINUS SIGN CSP18110 * NOLDZ=4 CSP18120 NOT LD FOUR SET NOLDZ CSP18130 STO I1 3 EQUAL TO FOUR CSP18140 MDX FINIS GO TO EXIT CSP18150 * IS JTEST AN EBCDIC MINUS SIGN CSP18160 PLUS S MINUS NOT NEGATIVE - CHECK FOR EBCDIC CSP18170 BSC L SPEC,Z MINUS SIGN-NO-GO TO SPEC CSP18180 * NOLDZ=2 CSP18190 LD TWO+1 YES-LOAD TWO AND STORE CSP18200 STO I1 3 IT IN NOLDZ CSP18210 * IS NEWZ FOUR CSP18220 LD I1 2 PICKUP VALUE OF NEWZ AND CSP18230 S FOUR CHECK FOR VALUE OF FOUR CSP18240 BSC L FINIS,Z NO-GO TO FINIS CSP18250 * JCARD(J)=-4032 CSP18260 LD ZERO YES-LOAD EBCDIC ZERO AND CSP18270 STO I STO+1 STORE IT AT JCARD(J) CSP18280 BIG MDX FINIS GO TO EXIT CSP18290 SPEC LD BIG SPECIAL CHARACTER-LOAD LARGE CSP18300 STO I1 3 NUMBER AND STORE AT NOLDZ CSP18310 MDX FINIS ALL DONE - GO TO EXIT CSP18320 END CSP18330 // DUP CSP18340 *STORE WS UA NZONE CSP18350 // ASM CSP18360 ** PRINT AND SKIP SUBROUTINES FOR 1130 CSP CSP18370 * NAME PRINT CSP18380 * LIST CSP18390 ENT PRINT SUBROUTINE ENTRY POINT CSP18400 * CALL PRINT (JCARD, J, JLAST, NERR3) CSP18410 * PRINT JCARD(J) THROUGH JCARD(JLAST) ON THE CSP18420 * 1132 PRINTER. PUT ERROR PARAMETER IN NERR3. CSP18430 ENT SKIP SUBROUTINE ENTRY POINT CSP18440 * CALL SKIP(N) CSP18450 * EXECUTE CONTROL FUNCTION SPECIFIED BY INTEGER N CSP18460 ONE DC 1 CONSTANT OF 1 CSP18470 SPACE DC /2000 PRINT FUNCTION WITH SPACE CSP18480 JCARD DC *-* JCARD%J< ADDRESS CSP18490 JLAST DC *-* JCARD%JLAST< ADDRESS CSP18500 AREA BSS 61 WORD COUNT & PRINT AREA CSP18510 PRINT DC *-* ADDRESS OF 1ST ARGUMENT CSP18520 TEST LIBF PRNT1 CALL BUSY TEST ROUTINE CSP18530 DC /0000 BUSY TEST PARAMETER CSP18540 MDX TEST REPEAT TEST IF BUSY CSP18550 STX 1 SAVE1&1 STORE IR1 CSP18560 LDX I1 PRINT LOAD 1ST ARGUMENT ADDRESS CSP18570 LIBF ARGS CALL ARGS ROUTINE CSP18580 DC JCARD JCARD%J< PICKED UP CSP18590 DC JLAST JCARD%JLAST< PICKED UP CSP18600 DC AREA CHARACTER COUNT PICKED UP CSP18610 DC 120 MAX CHARACTER COUNT CSP18620 LD AREA GET CHARACTER COUNT CSP18630 A ONE HALF ADJUST CSP18640 SRA 1 DIVIDE BY TWO CSP18650 STO AREA STORE WORD COUNT CSP18660 LD 1 3 GET ERROR WORD ADDRESS CSP18670 STO ERR&1 STORE IT IN ERROR ROUTINE CSP18680 LIBF RPACK CALL REVERSE PACK ROUTINE CSP18690 DC JCARD JCARD%J< ADDRESS CSP18700 DC JLAST JCARD%JLAST< ADDRESS CSP18710 DC AREA&1 PACK INTO I/O AREA CSP18720 LIBF PRNT1 CALL PRINT ROUTINE CSP18730 WRITE DC /2000 PRINT PARAMETER CSP18740 DC AREA I/O AREA BUFFER CSP18750 DC ERROR ERROR PARAMETER CSP18760 LD SPACE LOAD PRINT WITH SPACE CSP18770 STO WRITE STORE IN PRINT PARAMETER CSP18780 MDX 1 4 INCREMENT OVER 4 ARGUMENTS CSP18790 STX 1 DONE1&1 STORE IR1 CSP18800 SAVE1 LDX L1 *-* RELOAD OR RESTORE IR1 CSP18810 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP18820 ERROR DC *-* RETURN ADDRESS GOES HERE CSP18830 ERR STO L *-* STORE ACC IN ERROR PARAM CSP18840 SRA 16 CLEAR ACC CSP18850 BSC I ERROR RETURN TO PRNT1 PROGRAM CSP18860 SKIP DC *-* ADDRESS OF ARGUMENT ADDR CSP18870 LD I SKIP GET ARGUMENT ADDRESS CSP18880 STO ARG&1 DROP IT AND CSP18890 ARG LD L *-* GET ARGUMENT CSP18900 BSC L NOSUP,-Z GO TO NOSUPPRESSION IF & CSP18910 LD NOSPC SET UP SPACE SUPPRESSION CSP18920 STO WRITE CHANGE PRINT FUNCTION CSP18930 MDX DONE GO TO RETURN CSP18940 NOSUP STO CNTRL SET UP COMMAND CSP18950 LIBF PRNT1 CALL THE PRNT ROUTINE CSP18960 CNTRL DC /3000 CARRIAGE COMMAND WORD CSP18970 DONE MDX L SKIP,1 ADJUST RETURN ADDRESS CSP18980 BSC I SKIP RETURN TO CALLING PROGRAM CSP18990 NOSPC DC /2010 SUPPRESS SPACE COMMAND CSP19000 END END OF PRINT SUBPROGRAM CSP19010 // DUP CSP19020 *STORE WS UA PRINT CSP19030 // ASM CSP19040 ** PUT SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP19050 * NAME PUT CSP19060 * LIST CSP19070 ENT PUT PUT SUBROUTINE ENTRY POINT CSP19080 * CALL PUT(JCARD,J,JLAST,VAR,ADJST,N) CSP19090 * THE REAL NUMBER VAR IS HALF- CSP19100 * ADJUSTED WITH ADJST AND CSP19110 * TRUNCATED. THEN DIGITS ARE CSP19120 * CONVERTED FROM REAL TO EBCDIC CSP19130 * AND PLACED IN THE JCARD FIELD CSP19140 * FROM JCARD(JLAST) TO JCARD(J). CSP19150 PUT DC *-* ARGUMENT ADDRESS COMES IN HERE CSP19160 STX 1 FIN+1 SAVE IR1 CSP19170 LDX I1 PUT PUT ARGUMENT ADDRESS IN IR1 CSP19180 LD 1 0 GET JCARD ADDRESS CSP19190 STO JCRD1 SAVE FOR NZONE SUBROUTINE CSP19200 S I1 2 SUBTRACT JLAST VALUE CSP19210 A ONE+1 ADD CONSTANT OF ONE CSP19220 STO PUT1+1 CREATE JCARD(JLAST) ADDRESS CSP19230 LD 1 3 GET VAR ADDRESS CSP19240 STO VAR SAVE FOR PICKUP CSP19250 A ONE+1 ADD CONSTANT OF ONE CSP19260 STO SIGN+1 SAVE SIGN POSITION ADDRESS CSP19270 LD 1 4 GET ADJST ADDRESS CSP19280 STO ADJST AND SAVE CSP19290 LD I1 5 GET N VALUE AND CSP19300 STO ADRN2+1 SAVE FOR TRUNCATION CSP19310 TWO LD I1 2 GET JLAST VALUE AND CSP19320 STO JLAST SAVE IT AT JLAST CSP19330 ONE S I1 1 SUBTRACT J VALUE CSP19340 A ONE+1 ADD CONSTANT OF ONE CSP19350 BSC + CHECK FIELD WIDTH CSP19360 LD ONE+1 NEGATIVE OR ZERO-MAKE IT ONE CSP19370 STO PUTCT+1 OK-SAVE FIELD WIDTH CSP19380 MDX 1 6 MOVE OVER SIX ARGUMENTS CSP19390 STX 1 DONE1+1 CREATE RETURN ADDRESS CSP19400 * DIGS=WHOLE(ABS(VAR)+ADJST) CSP19410 CALL EABS TAKE THE ABSOLUTE VALUE CSP19420 VAR DC *-* OF VAR CSP19430 LIBF EADD ADD TO IT THE CSP19440 ADJST DC *-* HALF-ADJUSTMENT VALUE CSP19450 CALL WHOLE TRUNCATE ANY FRACTION CSP19460 ZERO DC /F040 CONSTANT OF EBCDIC ZERO CSP19470 * IS N GREATER THAN ZERO CSP19480 LD ADRN2+1 CHECK TO SEE IF N IS GREATER CSP19490 BSC L PUTCT,+ THAN ZERO-NO-GO TO PUTCT CSP19500 * JNOW=1 CSP19510 ADRN2 LDX L1 *-* YES-PUT VALUE OF N IN IR1 CSP19520 AGAIN LIBF EMPY MULTIPLY BY CSP19530 DC PNT1 ONE TENTH CSP19540 CALL WHOLE TRUNCATE THE FRACTION CSP19550 DC 0 DUMMY CSP19560 * SEE IF JNOW IS LESS THAN N. CSP19570 * IF YES, JNOW=JNOW+1 AND GO BACK CSP19580 * FOR MORE. IF NO, START CSP19590 * CONVERTING. CSP19600 MDX 1 -1 DECREMENT N BY ONE CSP19610 MDX AGAIN NOT DONE-GO BACK FOR MORE CSP19620 * JNOW=JLAST CSP19630 PUTCT LDX L1 *-* DONE-PUT FIELD WIDTH IN IR1 CSP19640 BACK LIBF ESTO STORE FAC CSP19650 DC DIGS IN DIGS CSP19660 * DIGT=WHOLE(DIGS/10.0) CSP19670 LIBF EMPY MULTIPLY BY CSP19680 DC PNT1 ONE TENTH AND CSP19690 CALL WHOLE TRUNCATE ANY FRACTION CSP19700 JLAST DC *-* JLAST VALUE CSP19710 LIBF ESTO STORE RESULT IN CSP19720 DC DIGS1 DIGS1-SAME AS DIGT CSP19730 * JCARD(JNOW)=256*IFIX(DIGS CSP19740 * - 10.0*DIGT)-4032 CSP19750 * MULTIPLY BY 256 IS SAME AS SHIFT CSP19760 * EIGHT CSP19770 * SUBTRACT 4032 IS SAME AS OR F040 CSP19780 LIBF EMPY MULTIPLY DIGT BY CSP19790 DC ETEN TEN AND CSP19800 LIBF NORM NORMALIZE THE RESULT CSP19810 LIBF SNR REVERSE THE SIGN CSP19820 LIBF EADD AND ADD IN THE CSP19830 DC DIGS VALUE OF DIGS CSP19840 LIBF IFIX FIX THE RESULT CSP19850 SLA 8 AND PLACE IN BITS 4-7 CSP19860 OR ZERO MAKE AN A1 CHARACTER CSP19870 PUT1 STO L *-* AND STORE IN JCARD(JNOW) CSP19880 LIBF ELD SET FAC EQUAL CSP19890 DC DIGS1 TO DIGS1 CSP19900 * SEE IF JNOW IS GREATER THAN J. CSP19910 * IF YES, JNOW=JNOW-1 AND GO BACK CSP19920 * FOR MORE. IF NO, SET ZONE. CSP19930 MDX L PUT1+1,1 CHANGE JCARD ADDRESS CSP19940 MDX 1 -1 DECREMENT COUNT CSP19950 MDX BACK NOT DONE-GO BACK FOR MORE CSP19960 * IS VAR LESS THAN ZERO CSP19970 SIGN LD L *-* DONE-PICKUP ORIGINAL SIGN CSP19980 BSC L FIN,- IF NOT NEG-ALL DONE-GO TO EXIT CSP19990 CALL NZONE CALL NZONE FOR ZONE SETTING CSP20000 JCRD1 DC *-* ADDRESS OF JCARD CSP20010 DC JLAST ADDRESS OF JLAST CSP20020 DC TWO+1 ADDRESS OF NEW ZONE INDICATOR CSP20030 DC JCRD1 DUMMY CSP20040 * EXIT............................ CSP20050 FIN LDX L1 *-* RESTORE IR1 CSP20060 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP20070 PNT1 XFLC 0.1 CONSTANT OF ONE TENTH CSP20080 ETEN XFLC 10.0 CONSTANT OF TEN POINT ZERO CSP20090 DIGS BSS 3 TEMPORARY AREA FOR GETTING A DGT CSP20100 DIGS1 BSS 3 TEMPORARY AREA FOR GETTING A DGT CSP20110 END CSP20120 // DUP CSP20130 *STORE WS UA PUT CSP20140 // ASM CSP20150 ** PRINT AND SKIP SUBROUTINES FOR 1130 CSP, 1403 CSP20160 * NAME P1403 CSP20170 * LIST CSP20180 ENT P1403 SUBROUTINE ENTRY POINT CSP20190 * CALL P1403 (JCARD, J, JLAST, NERR3) CSP20200 * PRINT JCARD(J) THROUGH JCARD(JLAST) ON THE CSP20210 * 1403 PRINTER. PUT ERROR PARAMETER IN NERR3. CSP20220 ENT S1403 SUBROUTINE ENTRY POINT CSP20230 * CALL S1403(N) CSP20240 * EXECUTE CONTROL FUNCTION SPECIFIED BY INTEGER N CSP20250 ONE DC 1 CONSTANT OF 1 CSP20260 SPACE DC /2000 PRINT FUNCTION WITH SPACE CSP20270 JCARD DC *-* JCARD%J< ADDRESS CSP20280 JLAST DC *-* JCARD%JLAST< ADDRESS CSP20290 AREA BSS 61 WORD COUNT & PRINT AREA CSP20300 P1403 DC *-* ADDRESS OF 1ST ARGUMENT CSP20310 STX 1 SAVE1&1 STORE IR1 CSP20320 LDX I1 P1403 LOAD 1ST ARGUMENT ADDRESS CSP20330 LIBF ARGS CALL ARGS ROUTINE CSP20340 DC JCARD JCARD%J< PICKED UP CSP20350 DC JLAST JCARD%JLAST< PICKED UP CSP20360 DC AREA CHARACTER COUNT PICKED UP CSP20370 DC 120 MAX CHARACTER COUNT CSP20380 LD AREA GET CHARACTER COUNT CSP20390 A ONE HALF ADJUST CSP20400 SRA 1 DIVIDE BY TWO CSP20410 STO AREA STORE WORD COUNT CSP20420 SLA 1 DOUBLE IT = CHARACTER CSP20430 STO CNT COUNT AND STORE COUNT CSP20440 LD 1 3 GET ERROR WORD ADDRESS CSP20450 STO ERR&1 STORE IT IN ERROR ROUTINE CSP20460 LIBF RPACK CALL REVERSE PACK ROUTINE CSP20470 DC JCARD JCARD%J< ADDRESS CSP20480 DC JLAST JCARD%JLAST< ADDRESS CSP20490 DC AREA&1 PACK INTO I/O AREA CSP20500 LIBF ZIPCO CALL CONVERSION ROUTINE CSP20510 DC /0000 FROM EBCDIC TO 1403 CODES CSP20520 DC AREA+1 FROM I/O AREA CSP20530 DC AREA+1 TO I/O AREA CSP20540 CNT DC *-* CHARACTER COUNT CSP20550 CALL EBPT3 CONVERSION TABLE FOR ZIPCO CSP20560 TEST LIBF PRNT3 CALL BUSY TEST ROUTINE CSP20570 DC /0000 BUSY TEST PARAMETER CSP20580 MDX TEST REPEAT TEST IF BUSY CSP20590 LIBF PRNT3 CALL PRINT ROUTINE CSP20600 WRITE DC /2000 PRINT PARAMETER CSP20610 DC AREA I/O AREA BUFFER CSP20620 DC ERROR ERROR PARAMETER CSP20630 LD SPACE LOAD PRINT WITH SPACE CSP20640 STO WRITE STORE IN PRINT PARAMETER CSP20650 MDX 1 4 INCREMENT OVER 4 ARGUMENTS CSP20660 STX 1 DONE1&1 STORE IR1 CSP20670 SAVE1 LDX L1 *-* RELOAD OR RESTORE IR1 CSP20680 DONE1 BSC L *-* RETURN TO CALLING PROGRAM CSP20690 ERROR DC *-* RETURN ADDRESS GOES HERE CSP20700 ERR STO L *-* STORE ACC IN ERROR PARAM CSP20710 SRA 16 CLEAR ACC CSP20720 BSC I ERROR RETURN TO PRNT3 PROGRAM CSP20730 S1403 DC *-* ADDRESS OF ARGUMENT ADDR CSP20740 LD I S1403 GET ARGUMENT ADDRESS CSP20750 STO ARG&1 DROP IT AND CSP20760 ARG LD L *-* GET ARGUMENT CSP20770 BSC L NOSUP,-Z GO TO NOSUPPRESSION IF & CSP20780 LD NOSPC SET UP SPACE SUPPRESSION CSP20790 STO WRITE CHANGE PRINT FUNCTION CSP20800 MDX DONE GO TO RETURN CSP20810 NOSUP STO CNTRL SET UP COMMAND CSP20820 LIBF PRNT3 CALL THE PRNT3 ROUTINE CSP20830 CNTRL DC /3000 CARRIAGE COMMAND WORD CSP20840 DONE MDX L S1403,1 ADJUST RETURN ADDRESS CSP20850 BSC I S1403 RETURN TO CALLING PROGRAM CSP20860 NOSPC DC /2010 SUPPRESS SPACE COMMAND CSP20870 END END OF P1403 SUBPROGRAM CSP20880 // DUP CSP20890 *STORE WS UA P1403 CSP20900 // ASM CSP20910 ** PUNCH SUBROUTINE FOR 1130 CSP, 1442-5 CSP20920 * NAME P1442 CSP20930 * LIST CSP20940 ENT P1442 SUBROUTINE ENTRY POINT CSP20950 * CALL P1442 (JCARD, J, JLAST, NERR2) CSP20960 * PUNCH JCARD(J) THROUGH JCARD(JLAST) INTO THE CSP20970 * BEGINNING OF A CARD. PUT ERROR PARAMETER INTO CSP20980 * NERR2. CSP20990 JCARD DC *-* JCARD%J< ADDRESS CSP21000 AREA BSS 81 I/O AREA BUFFER CSP21010 FLAG DC *-* ERROR INDICATOR CSP21020 P1442 DC *-* FIRST ARGUMENT ADDRESS CSP21030 STX 1 SAVE1&1 SAVE IR1 CSP21040 LDX I1 P1442 LOAD 1ST ARGUMENT ADDRESS CSP21050 LIBF ARGS CALL ARGS SUBPROGRAM CSP21060 DC JCARD GET JCARD(J) ADDRESS CSP21070 DC JLAS2 GET JCARD(JLAST) ADDRESS CSP21080 DC AREA GET CHARACTER COUNT CSP21090 DC 80 MAX CHARACTER COUNT CSP21100 LD AREA DISTRIBUTE COUNT CSP21110 STO CNT2 INTO CNT2 CSP21120 LD 1 3 GET ERROR WORD ADDRESS CSP21130 STO ERR+1 STORE INSIDE ERROR ROUTINE CSP21140 SRA 16 CLEAR ACC CSP21150 STO FLAG CLEAR ERROR INDICATOR CSP21160 LIBF SWING CALL REVERSE ARRAY CSP21170 DC JCARD FROM JCARD%J< CSP21180 DC JLAS2 TO JCARD%JLAST< CSP21190 LIBF SPEED CALL CONVERSION ROUTINE CSP21200 DC /0011 FROM EBCDIC TO CARD CODE CSP21210 JLAS2 DC *-* FROM JCARD%JLAST< CSP21220 DC AREA&1 TO THE I/O AREA BUFFER CSP21230 CNT2 DC *-* CHARACTER COUNT CSP21240 LIBF PNCH1 CALL PUNCH ROUTINE CSP21250 DC /2000 PUNCH CSP21260 DC AREA I/O AREA BUFFER CSP21270 DC ERROR ERROR PARAMETER CSP21280 LIBF SWING REVERSE THE ARRAY CSP21290 DC JCARD FROM JCARD(J) CSP21300 DC JLAS2 TOJCARD(JLAST) CSP21310 TEST LIBF PNCH1 CALL BUSY TEST ROUTINE CSP21320 DC /0000 BUSY TEST PARAMETER CSP21330 MDX TEST REPEAT IF BUSY CSP21340 MDX 1 4 INCREMENT 4 ARGUMENTS CSP21350 STX 1 DONE+1 STORE IR1 CSP21360 SAVE1 LDX L1 *-* RESTORE IR1 CSP21370 DONE BSC L *-* RETURN TO CALLING PROGRAM CSP21380 ERROR DC *-* START OF ERROR ROUTINE CSP21390 ERR STO L *-* STORE ACC IN ERROR WORD CSP21400 MDX L FLAG,1 SET THE FLAG INDICATOR CSP21410 BSC I ERROR RETURN TO INTERRUPT PROGRM CSP21420 END END OF P1442 SUBPROGRAM CSP21430 // DUP CSP21440 *STORE WS UA P1442 CSP21450 // ASM CSP21460 ** READ AND PUNCH SUBROUTINES FOR 1130 CSP CSP21470 * NAME READ CSP21480 * LIST CSP21490 ENT READ SUBROUTINE ENTRY POINT CSP21500 * CALL READ (JCARD, J, JLAST, NERR1) CSP21510 * READ COLUMNS FROM BEGINNING OF CARD INTO JCARD(J) CSP21520 * THROUGH JCARD(JLAST). PUT ERROR PARAMETER IN CSP21530 * NERR1. CSP21540 ENT PUNCH SUBROUTINE ENTRY POINT CSP21550 * CALL PUNCH (JCARD, J, JLAST, NERR2) CSP21560 * PUNCH JCARD(J) THROUGH JCARD(JLAST) INTO THE CSP21570 * BEGINNING OF A CARD. PUT ERROR PARAMETER INTO CSP21580 * NERR2. CSP21590 JCARD DC *-* JCARD%J< ADDRESS CSP21600 AREA BSS 81 I/O AREA BUFFER CSP21610 FLAG DC *-* ERROR INDICATOR CSP21620 READ DC *-* FIRST ARGUMENT ADDRESS CSP21630 STX 1 SAVE1&1 SAVE IR1 CSP21640 LDX I1 READ GET 1ST ARGUMENT ADDRESS CSP21650 BSI SETUP GO TO SETUP CSP21660 LIBF CARD1 CALL CARD READ ROUTINE CSP21670 DC /1000 READ CSP21680 DC AREA AREA PARAMETER CSP21690 DC ERROR ERROR PARAMETER CSP21700 CONVT LIBF SPEED CALL CONVERSION ROUTINE CSP21710 DC /0010 CARD CODE TO EBCDIC CSP21720 DC AREA&1 FROM AREA CSP21730 JLAS1 DC *-* TO JCARD%JLAST< CSP21740 CNT1 DC *-* CHARACTER COUNT CSP21750 LD FLAG ERROR INDICATOR CSP21760 BSC L FINAL,&- ALL DONE IF ZERO CSP21770 SRA 16 CLEAR ACC CSP21780 STO FLAG CLEAR THE INDICATOR CSP21790 MDX CONVT CONVERT AGAIN CSP21800 FINAL LIBF SWING REVERSE THE ARRAY CSP21810 DC JCARD FROM JCARD%J< CSP21820 DC JLAS1 TO JCARD%JLAST< CSP21830 TEST LIBF CARD1 CALL BUSY TEST ROUTINE CSP21840 DC /0000 BUSY TEST PARAMETER CSP21850 MDX TEST REPEAT IF BUSY CSP21860 MDX 1 4 INCREMENT 4 ARGUMENTS CSP21870 STX 1 DONE&1 STORE IR1 CSP21880 SAVE1 LDX L1 *-* RESTORE IR1 CSP21890 DONE BSC L *-* RETURN TO CALLING PROGRAM CSP21900 ERROR DC *-* START OF ERROR ROUTINE CSP21910 ERR STO L *-* STORE ACC IN ERROR WORD CSP21920 MDX L FLAG,1 SET THE FLAG INDICATOR CSP21930 BSC I ERROR RETURN TO INTERRUPT PROGRM CSP21940 SETUP DC *-* START OF SETUP ROUTINE CSP21950 LIBF ARGS CALL ARGS SUBPROGRAM CSP21960 DC JCARD GET JCARD%J< ADDRESS CSP21970 DC JLAS1 GET JCARD%JLAST< ADDRESS CSP21980 DC AREA GET CHARACTER COUNT CSP21990 DC 80 MAX CHARACTER COUNT CSP22000 LD JLAS1 DISTRIBUTE JCARD%JLAST< CSP22010 STO JLAS2 INTO JLAS2 CSP22020 LD L AREA DISTRIBUTE COUNT CSP22030 STO CNT1 INTO CNT1 CSP22040 STO CNT2 AND CNT2 CSP22050 LD 1 3 GET ERROR WORD ADDRESS CSP22060 STO ERR&1 STORE INSIDE ERROR ROUTINE CSP22070 SRA 16 CLEAR ACC CSP22080 STO FLAG CLEAR ERROR INDICATOR CSP22090 BSC I SETUP RETURN TO CALLING PROG CSP22100 PUNCH DC *-* PUNCH ROUTINE STARTS HERE CSP22110 STX 1 SAVE1&1 SAVE IR1 CSP22120 LDX I1 PUNCH LOAD 1ST ARGUMENT ADDRESS CSP22130 BSI SETUP GO TO SETUP ROUTINE CSP22140 LIBF SWING CALL REVERSE ARRAY CSP22150 DC JCARD FROM JCARD%J< CSP22160 DC JLAS1 TO JCARD%JLAST< CSP22170 LIBF SPEED CALL CONVERSION ROUTINE CSP22180 DC /0011 FROM EBCDIC TO CARD CODE CSP22190 JLAS2 DC *-* FROM JCARD%JLAST< CSP22200 DC AREA&1 TO THE I/O AREA BUFFER CSP22210 CNT2 DC *-* CHARACTER COUNT CSP22220 LIBF CARD1 CALL PUNCH ROUTINE CSP22230 DC /2000 PUNCH CSP22240 DC AREA I/O AREA BUFFER CSP22250 DC ERROR ERROR PARAMETER CSP22260 MDX FINAL ALL THROUGH, GO TO FINAL CSP22270 END END OF READ SUBPROGRAM CSP22280 // DUP CSP22290 *STORE WS UA READ CSP22300 // ASM CSP22310 ** READ SUBROUTINE FOR 1130 CSP, 2501 CSP22320 * NAME R2501 CSP22330 * LIST CSP22340 ENT R2501 SUBROUTINE ENTRY POINT CSP22350 * CALL R2501(JCARD, J, JLAST, NERR1) CSP22360 * READ COLUMNS FROM BEGINNING OF CARD INTO JCARD(J) CSP22370 * THROUGH JCARD(JLAST). PUT ERROR PARAMETER IN CSP22380 * NERR1. CSP22390 JCARD DC *-* JCARD%J< ADDRESS CSP22400 AREA BSS 81 I/O AREA BUFFER CSP22410 FLAG DC *-* ERROR INDICATOR CSP22420 R2501 DC *-* FIRST ARGUMENT ADDRESS CSP22430 STX 1 SAVE1&1 SAVE IR1 CSP22440 LDX I1 R2501 GET 1ST ARGUMENT ADDRESS CSP22450 LIBF ARGS CALL ARGS SUBPROGRAM CSP22460 DC JCARD GET JCARD%J< ADDRESS CSP22470 DC JLAS1 GET JCARD%JLAST< ADDRESS CSP22480 DC AREA GET CHARACTER COUNT CSP22490 DC 80 MAX CHARACTER COUNT CSP22500 LD AREA DISTRIBUTE COUNT CSP22510 STO CNT1 INTO CNT1 CSP22520 LD 1 3 GET ERROR WORD ADDRESS CSP22530 STO ERR&1 STORE INSIDE ERROR ROUTINE CSP22540 SRA 16 CLEAR ACC CSP22550 STO FLAG CLEAR ERROR INDICATOR CSP22560 MDX 1 4 INCREMENT 4 ARGUMENTS CSP22570 STX 1 DONE&1 STORE IR1 CSP22580 LD ONE SET AREA TO ALL ONES CSP22590 LDX L1 80 LOAD IR1 WITH AREA SIZE CSP22600 MO STO L1 AREA STORE A ONE IN AREA CSP22610 MDX 1 -1 GO TO NEXT WORD OF AREA CSP22620 MDX MO GO BACK UNTIL FINISHED CSP22630 LIBF READ1 CALL CARD READ ROUTINE CSP22640 DC /1000 READ CSP22650 DC AREA AREA PARAMETER CSP22660 DC ERROR ERROR PARAMETER CSP22670 CONVT LIBF SPEED CALL CONVERSION ROUTINE CSP22680 DC /0010 CARD CODE TO EBCDIC CSP22690 DC AREA&1 FROM AREA CSP22700 JLAS1 DC *-* TO JCARD%JLAST< CSP22710 CNT1 DC *-* CHARACTER COUNT CSP22720 LD FLAG ERROR INDICATOR CSP22730 BSC L FINAL,&- ALL DONE IF ZERO CSP22740 SRA 16 CLEAR ACC CSP22750 STO FLAG CLEAR THE INDICATOR CSP22760 MDX CONVT CONVERT AGAIN CSP22770 FINAL LIBF SWING REVERSE THE ARRAY CSP22780 DC JCARD FROM JCARD%J< CSP22790 DC JLAS1 TO JCARD%JLAST< CSP22800 TEST LIBF READ1 CALL BUSY TEST ROUTINE CSP22810 DC /0000 BUSY TEST PARAMETER CSP22820 MDX TEST REPEAT IF BUSY CSP22830 SAVE1 LDX L1 *-* RESTORE IR1 CSP22840 DONE BSC L *-* RETURN TO CALLING PROGRAM CSP22850 ERROR DC *-* START OF ERROR ROUTINE CSP22860 ERR STO L *-* STORE ACC IN ERROR WORD CSP22870 MDX L FLAG,1 SET THE FLAG INDICATOR CSP22880 BSC I ERROR RETURN TO INTERRUPT PROGRM CSP22890 ONE DC 1 CONSTANT OF ONE CSP22900 END END OF R2501 SUBPROGRAM CSP22910 // DUP CSP22920 *STORE WS UA R2501 CSP22930 // ASM CSP22940 ** STACKER SELECT SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP22950 * NAME STACK CSP22960 * LIST CSP22970 ENT STACK STACK SUBROUTINE POINT CSP22980 * CALL STACK CSP22990 * SELECTS THE NEXT CARD THROUGH CSP23000 * THE PUNCH STATION TO THE CSP23010 * ALTERNATE STACKER ON THE 1442-5, CSP23020 * 6,OR 7. CSP23030 IOCC DC 0 I/O COMMAND - FIRST WORD CSP23040 DC /1480 I/O COMMAND - SECOND WORD CSP23050 STACK DC *-* RETURN ADDRESS COMES IN HERE CSP23060 XIO IOCC SELECT STACKER CSP23070 BSC I STACK RETURN TO CALLING PROG CSP23080 END CSP23090 // DUP CSP23100 *STORE WS UA STACK CSP23110 // ASM CSP23120 ** TYPE AND KEYBD SUBROUTINES FOR 1130 CSP CSP23130 * NAME TYPER CSP23140 * LIST CSP23150 ENT TYPER SUBROUTINE ENTRY POINT CSP23160 * CALL TYPE (JCARD, J, JLAST) CSP23170 * TYPE JCARD(J) THROUGH JCARD(JLAST) CSP23180 ENT KEYBD SUBROUTINE ENTRY POINT CSP23190 * CALL KEYBD (JCARD, J, JLAST) CSP23200 * ENTER AT KEYBOARD JCARD(J) THROUGH JCARD(JLAST) CSP23210 ONE DC 1 CONSTANT OF 1 CSP23220 JCARD DC *-* JCARD%J< ADDRESS CSP23230 AREA BSS 61 I/O AREA BUFFER CSP23240 TYPER DC *-* FIRST ARGUMENT ADDR HERE CSP23250 STX 1 SAVE1&1 SAVE IR1 CSP23260 LDX 1 120 PUT 120 IN IR1 CSP23270 STX 1 MAXCH STORE IT AS MAX CHARS CSP23280 LDX I1 TYPER PUT FIRST ADDR IN IR1 CSP23290 BSI SETUP GO TO SETUP CSP23300 LD AREA GET CHARACTER COUNT CSP23310 A ONE HALF ADJUST IT AND CSP23320 SRA 1 DIVIDE IT BY TWO CSP23330 STO AREA AND REPLACE IT CSP23340 SLA 1 DOUBLE IT CSP23350 STO CNT1 AND PUT IT IN CNT1 CSP23360 LIBF RPACK CALL REVERSE PACK ROUTINE CSP23370 DC JCARD FROM JCARD%J< CSP23380 DC JLAST TO JCARD%JLAST< CSP23390 DC AREA&1 PACK INTO I/O AREA CSP23400 LIBF EBPRT CALL CONVERSION ROUTINE CSP23410 DC /0000 FROM EBCDIC CSP23420 DC AREA&1 TO PRINTER CODE, CSP23430 DC AREA&1 ALL IN THE I/O AREA CSP23440 CNT1 DC *-* HALF ADJSTD CHARACTER CNT CSP23450 LIBF TYPE0 CALL TYPE ROUTINE CSP23460 DC /2000 TYPE PARAMETER CSP23470 DC AREA I/O AREA BUFFER CSP23480 FINAL MDX 1 3 INCREMENT OVER 3 ARGUMENTS CSP23490 STX 1 DONE&1 STORE IR1 CSP23500 SAVE1 LDX L1 *-* RESTORE IR1 CSP23510 DONE BSC L *-* RETURN TO CALLING PROGRAM CSP23520 SETUP DC *-* START OF SETUP ROUTINE CSP23530 TEST LIBF TYPE0 CALL BUSY TEST ROUTINE CSP23540 DC /0000 BUSY TEST PARAMETER CSP23550 MDX TEST REPEAT TEST IF BUSY CSP23560 LIBF ARGS CALL ARGS ROUTINE CSP23570 DC JCARD 1ST ARGUMENT TO JCARD%J< CSP23580 DC JLAST TO JCARD%JLAST< CSP23590 DC AREA TO CHARACTER COUNT CSP23600 MAXCH DC *-* MAXIMUM NUMBER OF CHARS CSP23610 BSC I SETUP END OF SETUP, RETURN CSP23620 KEYBD DC *-* START OF KEYBOARD ROUTINE CSP23630 STX 1 SAVE1&1 SAVE IR1 CSP23640 LDX 1 60 PUT BUFFER LENGTH IN IR1 CSP23650 STX 1 MAXCH 60 IS MAX NO OF CHARS CSP23660 LDX I1 KEYBD 1ST ARGUMENT ADDR IN IR1 CSP23670 BSI SETUP GO TO SETUP CSP23680 LDX 1 60 PUT BUFFER LENGTH IN IR1 CSP23690 SRA 16 CLEAR THE ACC CSP23700 CLEAR STO L1 AREA CLEAR THE I/O BUFFER CSP23710 MDX 1 -1 DECREMENT IR1 CSP23720 MDX CLEAR AND CONTINUE CLEARING CSP23730 LDX I1 KEYBD 1ST ARGUMENT ADDR IN IR1 CSP23740 LD AREA PUT CHARACTER COUNT CSP23750 STO CNT2 IN CNT2 CSP23760 LIBF TYPE0 CALL KEYBOARD ROUTINE CSP23770 DC /1000 KEYBOARD PARAMETER CSP23780 DC AREA I/O AREA BUFFER CSP23790 TEST1 LIBF TYPE0 CALL BUSY TEST ROUTINE CSP23800 DC /0000 BUSY TEST PARAMETER CSP23810 MDX TEST1 REPEAT TEST IF BUSY CSP23820 LIBF SPEED CALL CONVERSION ROUTINE CSP23830 DC /0010 CARD CODE TO EBCDIC CSP23840 DC AREA&1 FROM THE I/O AREA BUFFER CSP23850 JLAST DC *-* TO JCARD%JLAST< CSP23860 CNT2 DC *-* CHARACTER COUNT CSP23870 LIBF SWING CALL REVERSE ARRAY CSP23880 DC JCARD REVERSE FROM JCARD%J< CSP23890 DC JLAST TO JCARD%JLAST< CSP23900 MDX FINAL ALL THROUGH, GO TO FINAL CSP23910 END END OF TYPE SUBPROGRAM CSP23920 // DUP CSP23930 *STORE WS UA TYPER CSP23940 // ASM CSP23950 ** PACK/UNPAC SUBROUTINES FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP23960 * LIST CSP23970 * NAME UNPAC CSP23980 ENT UNPAC UNPACK SUBROUTINE ENTRY POINT CSP23990 * CALL UNPAC(JCARD,J,JLAST,KCARD,K) CSP24000 * THE WORDS JCARD%J< THROUGH CSP24010 * JCARD%JLAST< IN A2 FORMAT ARE CSP24020 * UNPACKED INTO KCARD%K< IN A1 FORMAT. CSP24030 ENT PACK PACK SUBROUTINE ENTRY POINT CSP24040 * CALL PACK(JCARD,J,JLAST,KCARD,K) CSP24050 * THE WORDS JCARD%J< THROUGH CSP24060 * JCARD%JLAST< IN A1 FORMAT ARE PACKED CSP24070 * INTO KCARD%K< IN A2 FORMAT. CSP24080 UNPAC DC *-* ARGUMENT ADDRESS COMES IN HERE CSP24090 LD SW2 LOAD NOP INSTRUCTION CSP24100 STO SWTCH STORE NOP AT SWITCH CSP24110 MDX START COMPUTING CSP24120 SW1 MDX X ELSE-SWTCH-1 BRANCH TO ELSE CSP24130 SW2 MDX X 0 NOP INSTRUCTION CSP24140 PACK DC *-* ARGUMENT ADDRESS COMES IN HERE CSP24150 LD PACK PICK UP ARGUMENT ADDRESS CSP24160 STO UNPAC AND STORE IT IN UNPAC CSP24170 LD SW1 LOAD BRANCH TO ELSE CSP24180 STO SWTCH STORE BRANCH AT SWITCH CSP24190 START STX 1 SAVE1&1 SAVE IR1 CSP24200 LDX I1 UNPAC PUT ARGUMENT ADDRESS IN IR1 CSP24210 LD 1 0 GET JCARD ADDRESS CSP24220 A ONE+1 ADD CONSTANT OF 1 CSP24230 ONE S I1 1 SUBTRACT J VALUE CSP24240 STO JCARD+1 CREATE JCARD(J) ADDRESS CSP24250 LD 1 3 GET KCARD ADDRESS CSP24260 A ONE+1 ADD CONSTANT OF 1 CSP24270 S I1 4 SUBTRACT K VALUE CSP24280 STO KCARD+1 CREATE KCARD(K) ADDRESS CSP24290 LD 1 0 GET JCARD ADDRESS CSP24300 A ONE+1 ADD CONSTANT OF 1 CSP24310 S I1 2 SUBTRACT JLAST VALUE CSP24320 STO PACK CREATE JCARD%JLAST< ADDRESS CCSP24330 KCARD LDX L1 *-* PUT KCARD ADDRESS IN IR1 CSP24340 JCARD LD L *-* PICK UP JCARD(J) CSP24350 SWTCH MDX X 0 SWITCH BETWEEN PACK AND UNPACK CSP24360 SRT 8 SHIFT LOW ORDER BITS TO EXT CSP24370 SLA 8 REPOSITION HIGH ORDER BITS CSP24380 OR BMASK PUT BLANK IN LOW ORDER BITS CSP24390 STO 1 0 PUT IN KCARD%K< CSP24400 MDX 1 -1 DECREMENT KCARD ADDRESS CSP24410 SLT 8 MOVE THE EXTEN INTO THE ACCUM CSP24420 SLA 8 IN TWO STEPS CSP24430 OR BMASK PUT BLANK IN LOW ORDER BITS CSP24440 MDX FINIS BRANCH AROUND PACK ROUTINE CSP24450 ELSE SRT 24 SHIFT HIGH ORDER BITS INTO EXT CSP24460 MDX L JCARD+1,-1 DECREMENT JCARD ADDRESS CSP24470 LD I JCARD+1 PICK UP JCARD(J+1) CSP24480 RTE 8 SHIFT IN BITS FROM EXT CSP24490 FINIS STO 1 0 PUT IN KCARD%K< CSP24500 MDX L JCARD+1,-1 DECREMENT JCARD ADDRESS CSP24510 MDX 1 -1 DECREMENT KCARD ADDRESS CSP24520 LD JCARD+1 GET JCARD(J) ADDRESS CSP24530 S PACK SUBTRACT JCARD%JLAST< ADDRESS CCSP24540 BSC L JCARD,- CONTINUE IF DIFFERENCE & OR CSP24550 MDX L UNPAC,5 CREATE RETURN ADDRESS CSP24560 SAVE1 LDX L1 *-* RESTORE IR1 CSP24570 BSC I UNPAC RETURN TO CALLING PROGRAM CSP24580 BMASK DC /40 MASK 0000000001000000 CSP24590 END CSP24600 // DUP CSP24610 *STORE WS UA UNPAC CSP24620 // ASM CSP24630 ** WHOLE NUMBER SUBROUTINE FOR 1130 COMMERCIAL SUBROUTINE PACKAGE CSP24640 * NAME WHOLE CSP24650 * LIST CSP24660 ENT WHOLE SUBROUTINE ENTRY POINT CSP24670 * X=WHOLE(Y), WITH Y IN FAC TO START CSP24680 * X IN FAC BECOMES THE INTEGRAL PART OF Y. CSP24690 DBL1 DC 0 DBL CONSTANT OF 1 CSP24700 DC 1 REST OF DBL1 CONSTANT CSP24710 MANT EQU 31 MANTISSA LENGTH CSP24720 C159 DC 128+MANT EXPONENT OF FULL INTEGER CSP24730 C31 DC MANT MANTISSA LENGTH CSP24740 SRT SRT MANT SRT MANTISSA LENGTH CSP24750 H0800 DC /0800 DIFF BETWEEN SRT AND SLT CSP24760 WHOLE DC *-* ARGUMENT ADDRESS HERE CSP24770 LD C159 EXP OF FULL INTEGER CSP24780 S 3 125 SUBTRACT EXP OF Y CSP24790 BSC L DONE,+Z BRANCH IF ALL INTEGER CSP24800 S C31 SUBTRACT MANTISSA LENGTH CSP24810 BSC L FRACT,- BRANCH IF ALL FRACTIONAL CSP24820 A SRT CREATE RIGHT SHIFT CSP24830 STO RIGHT STORE RIGHT SHIFT CSP24840 S H0800 CREATE LEFT SHIFT CSP24850 STO LEFT STORE LEFT SHIFT CSP24860 LDD 3 126 PICK UP MANTISSA CSP24870 BSC +Z CHECK FOR NEGATIVE MANTISA CSP24880 SD DBL1 SUBTRACT 1 IF NEGATIVE CSP24890 RIGHT SRT *-* RIGHT SHIFT CSP24900 BSC +Z CHECK FOR NEGATIVE MANTISA CSP24910 AD DBL1 ADD 1 IF NEGATIVE CSP24920 LEFT SLT *-* LEFT SHIFT CSP24930 STORE STD 3 126 STORE MANTISSA CSP24940 DONE MDX L WHOLE,1 CREATE RETURN ADDRESS CSP24950 BSC I WHOLE RETURN TO CALLING PROGRAM CSP24960 FRACT SLC 32 ZERO ACC AND EXT CSP24970 STO 3 125 ZERO THE EXPONENT CSP24980 MDX STORE ZERO THE MANTISSA CSP24990 END END OF WHOLE SUBROUTINE CSP25000 // DUP CSP25010 *STORE WS UA WHOLE CSP25020 // ASM CSP25030 ** ARGS, RPACK AND SWING SUBROUTINES FOR 1130 CSP CSP25040 * LIST CSP25050 * NAME ARGS CSP25060 LIBR LIBF TYPE ROUTINES FOLLOW CSP25070 * THESE SUBROUTINES CANNOT BE CALLED FROM FORTRAN CSP25080 ENT ARGS SUBROUTINE ENTRY POINT CSP25090 * ARGS GETS THE ARGUMENT FOR THE I/O ROUTINES CSP25100 ENT RPACK SUBROUTINE ENTRY POINT CSP25110 * RPACK REVERSES AND PACKS EBCDIC STRINGS CSP25120 ENT SWING SUBROUTINE ENTRY POINT CSP25130 * SWING REVERSES AN EBCDIC STRING CSP25140 ONE DC 1 CONSTANT OF ONE CSP25150 JLAST DC *-* JCARD(JLAST) ADDRESS CSP25160 ARGS STX 2 SAVE2&1 ARGS ROUTINE STARTS HERE CSP25170 LDX I2 0 GET 1ST ARGUMENT ADDR CSP25180 LD 1 0 GET JCARD ADDR CSP25190 S I1 2 SUBTRACT JLAST VALUE CSP25200 A ONE ADD ONE CSP25210 STO I2 1 STORE IN 2ND ARG CSP25220 LD 1 0 GET JCARD ADDR CSP25230 S I1 1 SUBTRACT J VALUE CSP25240 A ONE ADD ONE CSP25250 STO I2 0 STORE IN 1ST ARG CSP25260 S I2 1 SUBTRACT JLAST ADDR CSP25270 A ONE ADD ONE CSP25280 BSC L EROR1,+ CHECK FOR NEG OR 0 CHARS CSP25290 S 2 3 OK. SUBTRACT MAX CHARS CSP25300 BSC L ERROR,-Z CHECK MORE THAN MAX CHARS CSP25310 A 2 3 ADD MAX CHARS BACK CSP25320 MDX OK ADDRESSES OK CSP25330 EROR1 LD I2 0 PICK UP JCARD(J) CSP25340 STO I2 1 AND STORE IN JCARD(JLAST) CSP25350 LD ONE SET UP CHAR COUNT OF 1 CSP25360 MDX OK GO TO STORE CHAR COUNT CSP25370 ERROR LD I2 0 PICK UP JCARD(J) CSP25380 S 2 3 AND CALCULATE JCARD(JLAST) CSP25390 A ONE TO BE JCARD(J+MAX-1) CSP25400 STO I2 1 STORE ADDR IN JCARD(JLAST) CSP25410 LD 2 3 LOAD CHARACTER COUNT CSP25420 OK STO I2 2 STORE CHARACTER COUNT CSP25430 MDX 2 4 CREATE RETURN ADDR CSP25440 LAST STX 2 DONE&1 STORE RETURN ADDRESS CSP25450 SAVE2 LDX L2 *-* RESTORE IR2 CSP25460 DONE BSC L *-* RETURN TO CALLING PROGRAM CSP25470 RPACK STX 2 SAVE2&1 RPACK ROUTINE STARTS HERE CSP25480 LDX I2 0 GET 1ST ARGUMENT ADDRESS CSP25490 LD I2 0 GET JCARD ADDR CSP25500 STO JCARD&1 INITIALIZE JCARD ADDRESS CSP25510 LD I2 1 GET SECOND ARGUMENT ADDR CSP25520 STO JLAST INITIALIZE JCARD%JLAST< CSP25530 LD 2 2 GET AREA ADDRESS CSP25540 STO KCARD&1 INITIALIZE PACK TO ADDRESS CSP25550 JCARD LD L *-* LOAD FIRST CHARACTER CSP25560 SRT 24 SHIFT INTO EXT CSP25570 MDX L JCARD&1,-1 DECREMENT ADDRESS CSP25580 LD I JCARD&1 GET SECOND CHARACTER CSP25590 RTE 8 SHIFT RIGHT, RETRIEVE EXT CSP25600 KCARD STO L *-* STORE IN AREA CSP25610 MDX L JCARD&1,-1 DECREMENT ADDRESS CSP25620 MDX L KCARD&1,&1 INCREMENT AREA ADDRESS CSP25630 LD JCARD&1 GET ENDING ADDRESS CSP25640 S JLAST SUBTRACT JCARD%JLAST< ADDR CSP25650 BSC L JCARD,- REPEAT IF NOT MINUS CSP25660 MDX 2 3 INCREMENT OVER 3 ARGS CSP25670 MDX LAST ALL THROUGH, GO TO LAST CSP25680 SWING STX 2 SAVE2&1 SWING ARRAY END FOR END CSP25690 LDX I2 0 GET 1ST ARGUMENT ADDRESS CSP25700 LD I2 0 GET FIRST ARGUMENT CSP25710 STO BACK&1 STORE AT BACK ADDRESS CSP25720 LD I2 1 GET 2ND ARGUMENT CSP25730 STO FRONT&1 STORE AT FRONT ADDRESS CSP25740 FRONT LD L *-* GET WORD FROM FRONT CSP25750 SRT 16 PUT IT IN THE EXT CSP25760 BACK LD L *-* GET A WORD FROM THE BACK CSP25770 OR HEX40 OR IN AN EBCDIC BLANK CSP25780 STO I FRONT&1 PUT IT IN THE FRONT CSP25790 SLT 16 RETRIEVE THE EXT CSP25800 OR HEX40 OR IN AN EBCDIC BLANK CSP25810 STO I BACK&1 PUT IT IN THE BACK CSP25820 MDX L FRONT&1,&1 INCREMENT THE FRONT ADDR CSP25830 MDX L BACK&1,-1 DECREMENT THE BACK ADDR CSP25840 LD FRONT&1 GET THE FRONT ADDRESS CSP25850 S BACK+1 SUBTRACT THE BACK ADDRESS CSP25860 BSC L FRONT,& REPEAT IF MINUS CSP25870 MDX 2 2 INCREMENT OVER 2 ARGS CSP25880 MDX LAST ALL THROUGH, GO TO LAST CSP25890 HEX40 DC /0040 EBCDIC BLANK CODE CSP25900 END END OF ARGS SUBPROGRAM CSP25910 // DUP CSP25920 *STORE WS UA ARGS CSP25930 // FOR CSP25940 ** SAMPLE PROBLEM 1 CSP25950 * NAME SMPL1 CSP25960 *IOCS%CARD,1132 PRINTER,TYPEWRITER< CSP25970 * ONE WORD INTEGERS CSP25980 * EXTENDED PRECISION CSP25990 * LIST ALL CSP26000 C-----GENERAL PURPOSE 1130 COMMERCIAL SUBROUTINE PACKAGE TEST PROGRAM. CSP26010 DIMENSION NCARD%80<, NAMES%5,13) CSP26020 1 FORMAT %80A1< CSP26030 2 FORMAT %I10, 4F10.0, F10.3< CSP26040 3 FORMAT %30H0NOW TESTING 1130 CSP ROUTINE ,5A1,16H WITH PARAMETERS,CSP26050 X4F10.5, F10.3< CSP26060 4 FORMAT %13H CARD BEFORE#,80A1< CSP26070 5 FORMAT %13H CARD AFTER #,80A1< CSP26080 6 FORMAT(1H ,5I3,2X,12HCARD AFTER =,1X,80A1) CSP26090 7 FORMAT(1H0,4X,10HINDICATORS,3X,12HCARD BEFORE=,1X,80A1) CSP26100 8 FORMAT %10H ANSWER IS, F20.3< CSP26110 C-----DEFINE UNIT NUMBERS OF I/O DEVICES. CSP26120 CALL DATSW(0,N) CSP26130 CALL DATSW%1,M< CSP26140 CALL DATSW%2,L< CSP26150 NREAD#6*%1/L<&2 CSP26160 NWRIT#2*%1/N<&2*%1/M<&1 CSP26170 READ %NREAD,1< NAMES CSP26180 10 READ %NREAD,2< N, V1, V2, V3, V4, VAR CSP26190 IF (N) 98,98,99 CSP26200 98 STOP 1111 CSP26210 99 WRITE %NWRIT,3< %NAMES%I,N<, I#1,5<, V1, V2, V3, V4, VAR CSP26220 N1#V1 CSP26230 N2#V2 CSP26240 N3#V3 CSP26250 N4#V4 CSP26260 NVAR#VAR CSP26270 NER1=0 CSP26280 NER2=0 CSP26290 NER3=0 CSP26300 NER4=0 CSP26310 NER5=0 CSP26320 READ %NREAD,1< NCARD CSP26330 IF(N-7) 21,21,22 CSP26340 21 WRITE(NWRIT,4) NCARD CSP26350 C-----GO TO 1130 CSP ROUTINE CSP26360 GO TO %11,12,13,14,15,16,17<, N CSP26370 C-----COMP ROUTINE CSP26380 11 ANS#NCOMP%NCARD,N1,N2,NCARD,N3< CSP26390 GO TO 19 CSP26400 C-----MOVE ROUTINE CSP26410 12 CALL MOVE%NCARD,N1,N2,NCARD,N3< CSP26420 GO TO 20 CSP26430 C-----NZONE ROUTINE CSP26440 13 CALL NZONE%NCARD,N1,N2,N3< CSP26450 ANS#N3 CSP26460 GO TO 19 CSP26470 C-----EDIT ROUTINE CSP26480 14 CALL EDIT%NCARD,N1,N2,NCARD,N3,N4< CSP26490 GO TO 20 CSP26500 C-----GET ROUTINE CSP26510 15 ANS#GET%NCARD,N1,N2,V3< CSP26520 GO TO 19 CSP26530 C-----PUT ROUTINE CSP26540 16 CALL PUT(NCARD,N1,N2,VAR,V3,N4) CSP26550 GO TO 20 CSP26560 C-----FILL ROUTINE CSP26570 17 CALL FILL%NCARD,N1,N2,NVAR< CSP26580 GO TO 20 CSP26590 19 WRITE %NWRIT,8< ANS CSP26600 20 WRITE %NWRIT,5< NCARD CSP26610 GO TO 10 CSP26620 22 WRITE(NWRIT,7) NCARD CSP26630 C-----A1DEC ROUTINE CSP26640 CALL A1DEC(NCARD,N1,N2,NER1) CSP26650 CALL A1DEC(NCARD,N3,N4,NER2) CSP26660 N=N-7 CSP26670 GO TO (23,24,25,26,27,28),N CSP26680 C-----ADD ROUTINE CSP26690 23 CALL ADD(NCARD,N1,N2,NCARD,N3,N4,NER3) CSP26700 GO TO 29 CSP26710 C-----SUB ROUTINE CSP26720 24 CALL SUB(NCARD,N1,N2,NCARD,N3,N4,NER3) CSP26730 GO TO 29 CSP26740 C-----MPY ROUTINE CSP26750 25 CALL MPY(NCARD,N1,N2,NCARD,N3,N4,NER3) CSP26760 GO TO 29 CSP26770 C-----DIV ROUTINE CSP26780 26 CALL DIV(NCARD,N1,N2,NCARD,N3,N4,NER3) CSP26790 GO TO 29 CSP26800 C-----ICOMP ROUTINE CSP26810 27 NER3=ICOMP(NCARD,N1,N2,NCARD,N3,N4) CSP26820 GO TO 29 CSP26830 C-----NSIGN ROUTINE CSP26840 28 CALL NSIGN(NCARD,N1,NVAR,NER3) CSP26850 C-----DECA1 ROUTINE CSP26860 29 CALL DECA1(NCARD,N1,N2,NER4) CSP26870 IF(N-3) 33,32,30 CSP26880 30 IF(N-4) 33,31,33 CSP26890 31 JSPAN=N2-N1 CSP26900 KSPAN=N4-N3 CSP26910 KSTRT=N3-JSPAN-1 CSP26920 N3=N4-JSPAN CSP26930 CALL DECA1(NCARD,KSTRT,N3-1,NER5) CSP26940 GO TO 33 CSP26950 32 N3=N3-N2+N1-1 CSP26960 33 CALL DECA1(NCARD,N3,N4,NER5) CSP26970 WRITE(NWRIT,6) NER1,NER2,NER3,NER4,NER5,NCARD CSP26980 GO TO 10 CSP26990 END CSP27000 // XEQ CSP27010 NCOMPMOVE NZONEEDIT GET PUT FILL ADD SUB MPY DIV ICOMPNSIGN CSP27020 1 1 10 11 1CSP27030 ABCDEFGHIJKLMNOPQRST 2CSP27040 1 1 10 11 3CSP27050 BC8D F BC8D F 4CSP27060 1 20 25 30 5CSP27070 JKLMN CBAFG 6CSP27080 2 1 5 20 7CSP27090 ABCDE 8CSP27100 2 40 49 1 9CSP27110 9876543210 10CSP27120 3 10 5 11CSP27130 A 12CSP27140 3 10 5 13CSP27150 I 14CSP27160 3 20 5 15CSP27170 0 16CSP27180 3 20 5 17CSP27190 9 18CSP27200 3 30 5 19CSP27210 J 20CSP27220 3 30 5 21CSP27230 R 22CSP27240 3 10 1 23CSP27250 A 24CSP27260 3 10 1 25CSP27270 1 26CSP27280 3 10 1 27CSP27290 J 28CSP27300 3 20 4 29CSP27310 I 30CSP27320 3 20 2 31CSP27330 9 32CSP27340 3 20 3 33CSP27350 R 34CSP27360 3 30 3 35CSP27370 D 36CSP27380 3 30 2 37CSP27390 4 38CSP27400 3 30 4 39CSP27410 M 40CSP27420 4 1 6 20 30 41CSP27430 123456 , $. CR 42CSP27440 4 1 6 20 30 43CSP27450 02343K , $. CR 44CSP27460 4 1 6 20 29 45CSP27470 00343- , $. - 46CSP27480 4 1 7 21 28 47CSP27490 1234567 , $. 48CSP27500 4 1 6 10 30 49CSP27510 00005M ,* . CR 50CSP27520 4 1 6 20 29 51CSP27530 5M ,0 . - 52CSP27540 5 1 5 .01 53CSP27550 12345 54CSP27560 5 1 5 .01 55CSP27570 1234N 56CSP27580 5 1 7 .001 57CSP27590 1 3 5 7 58CSP27600 5 1 5 1. 59CSP27610 12AB4 60CSP27620 5 1 5 1. 61CSP27630 1230- 62CSP27640 5 1 3 .00001 63CSP27650 123 64CSP27660 6 1 5 0.5 0 12345. 65CSP27670 66CSP27680 6 1 2 5.0 1 12890. 67CSP27690 68CSP27700 6 11 15 5.0 1 12345. 69CSP27710 70CSP27720 6 10 16 50.0 2 -34567. 71CSP27730 72CSP27740 6 10 17 5.0 1 -16. 73CSP27750 74CSP27760 7 1 10 16448. 75CSP27770 ABCDEFGHIJK 76CSP27780 7 20 25 23360. 77CSP27790 ABCDEFGH 78CSP27800 08 31 35 66 70 CSP27810 24 2048 CSP27820 09 31 35 66 70 CSP27830 24 2048 CSP27840 10 31 35 66 70 CSP27850 24 2048 CSP27860 11 31 35 66 70 CSP27870 24 2048 CSP27880 12 31 35 66 70 CSP27890 24 2048 CSP27900 13 1 1 2 2 1. CSP27910 65 CSP27920 08 31 35 66 70 CSP27930 99 2048 CSP27940 09 31 35 66 70 CSP27950 99 2048 CSP27960 10 31 35 66 70 CSP27970 99 2048 CSP27980 11 31 35 66 70 CSP27990 99 2048 CSP28000 12 31 35 66 70 CSP28010 99 2048 CSP28020 13 1 1 2 2 -1. CSP28030 54 CSP28040 08 01 20 41 70 CSP28050 12345678901234567890 123456789012345678901234567890 CSP28060 09 01 20 41 70 CSP28070 12345678901234567890 123456789012345678901234567890 CSP28080 10 01 20 41 70 CSP28090 12345678901234567890 123456789012345678901234567890 CSP28100 11 01 20 41 70 CSP28110 12345678901234567890 123456789012345678901234567890 CSP28120 12 01 20 41 70 CSP28130 12345678901234567890 123456789012345678901234567890 CSP28140 13 1 1 2 2 CSP28150 32 CSP28160 08 01 20 41 70 CSP28170 1234567890123456789- 123456789012345678901234567890 CSP28180 09 01 20 41 70 CSP28190 1234567890123456789- 123456789012345678901234567890 CSP28200 10 01 20 41 70 CSP28210 1234567890123456789- 123456789012345678901234567890 CSP28220 11 01 20 41 70 CSP28230 1234567890123456789- 123456789012345678901234567890 CSP28240 12 01 20 41 70 CSP28250 1234567890123456789- 123456789012345678901234567890 CSP28260 13 1 1 2 2 1. CSP28270 ON CSP28280 08 01 20 41 70 CSP28290 12345678901234567890 12345678901234567890123456789- CSP28300 09 01 20 41 70 CSP28310 12345678901234567890 12345678901234567890123456789- CSP28320 10 01 20 41 70 CSP28330 12345678901234567890 12345678901234567890123456789- CSP28340 11 01 20 41 70 CSP28350 12345678901234567890 12345678901234567890123456789- CSP28360 12 01 20 41 70 CSP28370 12345678901234567890 12345678901234567890123456789- CSP28380 13 1 1 2 2 -1. CSP28390 NM CSP28400 08 01 20 41 70 CSP28410 1234567890123456789- 12345678901234567890123456789- CSP28420 09 01 20 41 70 CSP28430 1234567890123456789- 12345678901234567890123456789- CSP28440 10 01 20 41 70 CSP28450 1234567890123456789- 12345678901234567890123456789- CSP28460 11 01 20 41 70 CSP28470 1234567890123456789- 12345678901234567890123456789- CSP28480 12 01 20 41 70 CSP28490 1234567890123456789- 12345678901234567890123456789- CSP28500 13 1 1 2 2 CSP28510 ML CSP28520 08 01 20 51 70 CSP28530 12345678901234567890 12345678901234567890 CSP28540 09 01 20 51 70 CSP28550 12345678901234567890 12345678901234567890 CSP28560 10 01 20 51 70 CSP28570 12345678901234567890 12345678901234567890 CSP28580 11 01 20 51 70 CSP28590 12345678901234567890 12345678901234567890 CSP28600 12 01 20 51 70 CSP28610 12345678901234567890 12345678901234567890 CSP28620 13 1 1 2 2 1. CSP28630 -0 CSP28640 08 01 20 51 70 CSP28650 1234567890123456789- 12345678901234567890 CSP28660 09 01 20 51 70 CSP28670 1234567890123456789- 12345678901234567890 CSP28680 10 01 20 51 70 CSP28690 1234567890123456789- 12345678901234567890 CSP28700 11 01 20 51 70 CSP28710 1234567890123456789- 12345678901234567890 CSP28720 12 01 20 51 70 CSP28730 1234567890123456789- 12345678901234567890 CSP28740 13 1 1 2 2 -1. CSP28750 -0 CSP28760 08 01 20 51 70 CSP28770 12345678901234567890 1234567890123456789- CSP28780 09 01 20 51 70 CSP28790 12345678901234567890 1234567890123456789- CSP28800 10 01 20 51 70 CSP28810 12345678901234567890 1234567890123456789- CSP28820 11 01 20 51 70 CSP28830 12345678901234567890 1234567890123456789- CSP28840 12 01 20 51 70 CSP28850 12345678901234567890 1234567890123456789- CSP28860 13 1 1 2 2 CSP28870 -0 CSP28880 08 01 20 51 70 CSP28890 1234567890123456789- 1234567890123456789- CSP28900 09 01 20 51 70 CSP28910 1234567890123456789- 1234567890123456789- CSP28920 10 01 20 51 70 CSP28930 1234567890123456789- 1234567890123456789- CSP28940 11 01 20 51 70 CSP28950 1234567890123456789- 1234567890123456789- CSP28960 12 01 20 51 70 CSP28970 1234567890123456789- 1234567890123456789- CSP28980 CSP28990 // FOR CSP29000 ** SAMPLE PROBLEM 2 CSP29010 * NAME SMPL2 CSP29020 * LIST ALL CSP29030 * ONE WORD INTEGERS CSP29040 * EXTENDED PRECISION CSP29050 C-----THE INPUT IS MADE UP OF A MASTER CARD FOLLOWED BY THE TRANSACTION CSP29060 C-----CARDS FOR EACH CUSTOMER. WE WANT TO PRINT AN INVOICE AND PRINT A CSP29070 C-----NEW MASTER CARD FOR EACH CUSTOMER. CSP29080 DIMENSION INCRD(82),IMASK(13),IPRNT(79),IOTCD(80),ISTOP(5), CSP29090 1IHEAD(80), IPRVB(16),ITOT(5),IWK(13),ISUM(8),IEROR(6),IEOJ(10) CSP29100 CALL DATSW %2,N2< CSP29110 CALL DATSW%1,N3< CSP29120 GO TO %28,27<,N2 CSP29130 27 CALL READ(IEOJ,1,10,J) CSP29140 CALL READ(IEROR,1,6,J) CSP29150 CALL READ(IMASK,1,13,J) CSP29160 CALL READ(IPRVB,1,16,J) CSP29170 CALL READ(IHEAD,1,72,J) CSP29180 CALL READ(IHEAD,73,80,J) CSP29190 CALL READ(ISTOP,1,5,J) CSP29200 CALL READ(ITOT,1,5,J) CSP29210 GO TO 58 CSP29220 28 CALL R2501(IEOJ,1,10,J) CSP29230 CALL R2501(IEROR,1,6,J) CSP29240 CALL R2501(IMASK,1,13,J) CSP29250 CALL R2501(IPRVB,1,16,J) CSP29260 CALL R2501(IHEAD,1,72,J) CSP29270 CALL R2501(IHEAD,73,80,J) CSP29280 CALL R2501(ISTOP,1,5,J) CSP29290 CALL R2501(ITOT,1,5,J) CSP29300 58 J=2 CSP29310 INCRD(81)=16448 CSP29320 INCRD(82)=5440 CSP29330 1 I=0 CSP29340 L=0 CSP29350 M=0 CSP29360 GO TO %30,29<,N2 CSP29370 29 CALL READ(INCRD,1,80,J) CSP29380 GO TO 59 CSP29390 30 CALL R2501(INCRD,1,80,J) CSP29400 59 IF(J-1) 22,2,2 CSP29410 2 IF(NCOMP(INCRD,1,5,ISTOP,1)) 3,22,3 CSP29420 3 CALL NZONE(INCRD,70,5,K) CSP29430 IF(K-1) 26,4,26 CSP29440 4 GO TO %34,33< ,N3 CSP29450 33 CALL SKIP(12544) CSP29460 GO TO 60 CSP29470 34 CALL S1403(12544) CSP29480 60 CALL FILL(IPRNT,1,79,16448) CSP29490 GO TO %36,35<,N3 CSP29500 35 CALL PRINT(INCRD,1,20,I) CSP29510 GO TO 61 CSP29520 36 CALL P1403(INCRD,1,20,I) CSP29530 61 CALL MOVE(IMASK,1,13,IWK,1) CSP29540 CALL EDIT(INCRD,61,68,IWK,1,13) CSP29550 GO TO %38,37<,N3 CSP29560 37 CALL PRINT(INCRD,21,40,I) CSP29570 GO TO 62 CSP29580 38 CALL P1403(INCRD,21,40,I) CSP29590 62 CALL MOVE(IPRVB,1,16,IPRNT,23) CSP29600 CALL MOVE(IWK,1,13,IPRNT,67) CSP29610 GO TO %41,39<,N3 CSP29620 39 CALL PRINT(INCRD,41,60,I) CSP29630 CALL SKIP(16128) CSP29640 CALL PRINT(IHEAD,1,80,I) CSP29650 CALL PRINT(IPRNT,1,79,I) CSP29660 GO TO 63 CSP29670 41 CALL P1403(INCRD,41,60,I) CSP29680 CALL S1403(16128) CSP29690 CALL P1403(IHEAD,1,80,I) CSP29700 CALL P1403(IPRNT,1,79,I) CSP29710 63 CALL FILL(IPRNT,1,79,16448) CSP29720 40 CALL A1DEC(INCRD,61,68,L) CSP29730 IF(L) 5,5,23 CSP29740 5 CALL MOVE(INCRD,61,68,ISUM,1) CSP29750 CALL MOVE(INCRD,1,80,IOTCD,1) CSP29760 6 GO TO %32,31<,N2 CSP29770 31 CALL READ(INCRD,1,80,J) CSP29780 GO TO 64 CSP29790 32 CALL R2501(INCRD,1,80,J) CSP29800 64 IF(J-1) 22,7,7 CSP29810 7 CALL NZONE(INCRD,70,5,K) CSP29820 IF(K-1) 18,19,8 CSP29830 8 IF(K-2) 18,9,18 CSP29840 9 IF(NCOMP(INCRD,1,20,IOTCD,1)) 18,10,18 CSP29850 10 CALL MOVE(INCRD,21,40,IPRNT,23) CSP29860 CALL MOVE(IMASK,1,13,IPRNT,67) CSP29870 CALL MOVE(IMASK,3,8,IPRNT,7) CSP29880 IPRNT(12)=-4032 CSP29890 CALL EDIT(INCRD,49,52,IPRNT,7,12) CSP29900 CALL EDIT(INCRD,41,48,IPRNT,67,79) CSP29910 GO TO%49,48<,N3 CSP29920 48 CALL PRINT(IPRNT,1,79,I) CSP29930 GO TO 65 CSP29940 49 CALL P1403(IPRNT,1,79,I) CSP29950 65 IF(I-3) 11,11,17 CSP29960 11 CALL A1DEC(INCRD,41,48,L) CSP29970 IF(L) 12,12,14 CSP29980 12 CALL ADD(INCRD,41,48,ISUM,1,8,M) CSP29990 IF(M) 13,6,13 CSP30000 13 CALL IOND CSP30010 STOP 777 CSP30020 14 CALL NZONE(INCRD,L,4,N1) CSP30030 N1=0 CSP30040 CALL A1DEC(INCRD,L,L,N1) CSP30050 IF(N1) 16,16,15 CSP30060 15 CALL IOND CSP30070 STOP 666 CSP30080 16 CALL DECA1(INCRD,41,48,L) CSP30090 L=0 CSP30100 GO TO 11 CSP30110 17 GO TO %51,50<,N3 CSP30120 50 CALL SKIP(12544) CSP30130 CALL PRINT(IHEAD,1,80,I) CSP30140 GO TO 66 CSP30150 51 CALL S1403(12544) CSP30160 CALL P1403(IHEAD,1,80,I) CSP30170 66 I=0 CSP30180 GO TO 11 CSP30190 18 CALL TYPER(IEROR,1,5) CSP30200 CALL TYPER(INCRD,1,82) CSP30210 GO TO 6 CSP30220 19 CALL DECA1(ISUM,1,8,L) CSP30230 IF(L) 20,21,20 CSP30240 20 CALL IOND CSP30250 STOP 555 CSP30260 21 CALL FILL(IPRNT,1,79,16448) CSP30270 CALL MOVE(IMASK,1,13,IPRNT,67) CSP30280 CALL EDIT(ISUM,1,8,IPRNT,67,79) CSP30290 CALL MOVE(ISUM,1,8,IOTCD,61) CSP30300 CALL TYPER(IOTCD,1,80) CSP30310 CALL MOVE(ITOT,1,5,IPRNT,23) CSP30320 GO TO %55,54<,N3 CSP30330 54 CALL SKIP(15872) CSP30340 CALL PRINT(IPRNT,1,79,I) CSP30350 GO TO 67 CSP30360 55 CALL S1403(15872) CSP30370 CALL P1403(IPRNT,1,79,I) CSP30380 67 CALL TYPER(INCRD,81,82) CSP30390 GO TO 1 CSP30400 22 CALL TYPER(IEOJ,1,10) CSP30410 CALL IOND CSP30420 STOP 111 CSP30430 23 CALL NZONE(INCRD,L,4,N1) CSP30440 N1=0 CSP30450 CALL A1DEC(INCRD,L,L,N1) CSP30460 IF(N1) 25,25,24 CSP30470 24 CALL IOND CSP30480 STOP 444 CSP30490 25 CALL DECA1(INCRD,61,68,L) CSP30500 L=0 CSP30510 GO TO 40 CSP30520 26 CALL TYPER(IEROR,1,5) CSP30530 CALL TYPER(INCRD,1,82) CSP30540 GO TO 1 CSP30550 END CSP30560 // XEQ CSP30570 END OF JOB CSP30580 ERROR CSP30590 , $. CR CSP30600 PREVIOUS BALANCE CSP30610 QTY NAME CSP30620 AMT CSP30630 ISTOP CSP30640 TOTAL CSP30650 THIS IS A DELIBERATE ERROR J CSP30660 DAVES MARKET 1997 WASHINGTON ST. NEWTOWN, MASS. 0215800011129 A CSP30670 DAVE MARKET THIS CARD IS A DELIBERATE MISTAKE J CSP30680 DAVES MARKET SUGAR - BAGS 000021020008 J CSP30690 DAVES MARKET CHICKEN SOUP - CASES000038760011 J CSP30700 DAVES MARKET TOMATO SOUP - CASES 000030110010 J CSP30710 DAVES MARKET SUGAR RETURNED 0000210K0008 J CSP30720 DAVES MARKET COOKIES - CASES 000045210006 J CSP30730 DAVES MARKET GINGER ALE - CASES 000052370017 J CSP30740 DAVES MARKET ROOT BEER - CASES 000052370017 J CSP30750 DAVES MARKET ORANGE ADE - CASES 000052370017 J CSP30760 DAVES MARKET CREME SODA - CASES 000052370017 J CSP30770 DAVES MARKET CHERRY SODA - CASES 000052370017 J CSP30780 DAVES MARKET SODA WATER - CASES 000052370017 J CSP30790 DAVES MARKET DOG FOOD - CASES 000101260025 J CSP30800 DAVES MARKET CAT FOOD - CASES 000101260025 J CSP30810 DAVES MARKET SOAP POWDER - CASES 000072890010 J CSP30820 DAVES MARKET DETERGENT - CASES 000072890010 J CSP30830 DAVES MARKET HAM - TINS 000036750012 J CSP30840 DAVES MARKET HAM - LOAF 000033750012 J CSP30850 DAVES MARKET SALAMI 000033750012 J CSP30860 DAVES MARKET BOLOGNA 000033750012 J CSP30870 DAVES MARKET CORNED BEEF 000033750012 J CSP30880 DAVES MARKET ROAST BEEF 000033750012 J CSP30890 DAVES MARKET BREAD - LOAF 000150001000 J CSP30900 DAVES MARKET ROLLS 000150004000 J CSP30910 DAVES MARKET MILK - QUARTS 000057420200 J CSP30920 DAVES MARKET MILK - HALF GALS 000057420100 J CSP30930 DAVES MARKET MILK - GALS 000057420050 J CSP30940 DAVES MARKET POTATOES - BAGS 000011230100 J CSP30950 DAVES MARKET TOMATOES - LOOSE 000011230100 J CSP30960 DAVES MARKET CARROTS - BUNCHES 000011230100 J CSP30970 DAVES MARKET DETERGENT - CASES 000072890010 J CSP30980 DAVES MARKET HAM - TINS 000036750012 J CSP30990 DAVES MARKET HAM - LOAF 000033750012 J CSP31000 DAVES MARKET SALAMI 000033750012 J CSP31010 DAVES MARKET BOLOGNA 000033750012 J CSP31020 DAVES MARKET CORNED BEEF 000033750012 J CSP31030 DAVES MARKET ROAST BEEF 000033750012 J CSP31040 DAVES MARKET BREAD - LOAF 000150001000 J CSP31050 DAVES MARKET ROLLS 000150004000 J CSP31060 DAVES MARKET MILK - QUARTS 000057420200 J CSP31070 DAVES MARKET MILK - GALS 000057420050 J CSP31080 DAVES MARKET MILK - HALF GALS 000057420100 J CSP31090 DAVES MARKET POTATOES - BAGS 000011230100 J CSP31100 DAVES MARKET TOMATOES - LOOSE 000011230100 J CSP31110 DAVES MARKET CARROTS - BUNCHES 000011230100 J CSP31120 DAVES MARKET DETERGENT - CASES 000072890010 J CSP31130 DAVES MARKET HAM - TINS 000036750012 J CSP31140 DAVES MARKET BREAD - LOAF 000150001000 J CSP31150 DAVES MARKET ROLLS 000150004000 J CSP31160 DAVES MARKET MILK - QUARTS 000057420200 J CSP31170 DAVES MARKET MILK - HALF GALS 000057420100 J CSP31180 DAVES MARKET MILK - GALS 000057420050 J CSP31190 DAVES MARKET POTATOES - BAGS 000011230100 J CSP31200 DAVES MARKET TOMATOES - LOOSE 000011230100 J CSP31210 DAVES MARKET CARROTS - BUNCHES 000011230100 J CSP31220 DAVES MARKET DETERGENT - CASES 000072890010 J CSP31230 DAVES MARKET HAM - TINS 000036750012 J CSP31240 DAVES MARKET HAM - LOAF 000033750012 J CSP31250 DAVES MARKET SALAMI 000033750012 J CSP31260 DAVES MARKET BOLOGNA 000033750012 J CSP31270 DAVES MARKET CORNED BEEF 000033750012 J CSP31280 DAVES MARKET ROAST BEEF 000033750012 J CSP31290 DAVES MARKET BREAD - LOAF 000150001000 J CSP31300 DAVES MARKET ROLLS 000150004000 J CSP31310 DAVES MARKET MILK - QUARTS 000057420200 J CSP31320 DAVES MARKET MILK - HALF GALS 000057420100 J CSP31330 DAVES MARKET MILK - HALF GALS 000057420100 J CSP31340 DAVES MARKET POTATOES - BAGS 000011230100 J CSP31350 DAVES MARKET TOMATOES - LOOSE 000011230100 J CSP31360 DAVES MARKET CARROTS - BUNCHES 000011230100 J CSP31370 DAVES MARKET DETERGENT - CASES 000072890010 J CSP31380 DAVES MARKET HAM - TINS 000036750012 J CSP31390 A CSP31400 STANDISH MOTORS 10 WATER STREET PLYMOUTH, MASS.0229600235636 A CSP31410 STANDISH MOTORS AIR CLEANERS - CASES000200030020 J CSP31420 STANDISH MOTORS GREASE - BARRELS 000165240006 J CSP31430 STANDISH MOTORS TIRES - 650 X 13 000260380020 J CSP31440 STANDISH MOTORS TIRES - 750 X 14 000900530050 J CSP31450 STANDISH MOTORS TIRES - 800 X 14 001012000050 J CSP31460 STANDISH MOTOR THIS CARD IS NOT CORRECT ABCDEFGHIJKLMNOPQRSTUVJ CSP31470 STANDISH MOTORS GASOLINE CAPS 000099680100 J CSP31480 A CSP31490 ISTOP CSP31500 // JOB CSP31510 // FOR CSP31520 * NAME SP3 CSP31530 *IOCS%CARD,1132 PRINTER,TYPEWRITER< CSP31540 * ONE WORD INTEGERS CSP31550 * EXTENDED PRECISION CSP31560 * LIST ALL CSP31570 DIMENSION MASK(12),IN(69),IDEP(2),IEMP(3),INM(20),ISS(9),IRT(4), CSP31580 1 IYTD(7),JEMP(3),NYTD(7),ICUR(6),KCURR(12),KOYTD(12),KNYTD(12) CSP31590 1 FORMAT (69A1,I1) CSP31600 2 FORMAT (12A1) CSP31610 20 FORMAT %1H ,2A1,1X,23A1,2X,20A1,21X,1H1,3X,7HCSP < CSP31620 30 FORMAT %1H ,2A1,2X,3A1,2X,20A1,5X,3%12A1,2X<< CSP31630 CALL DATSW(0,I) CSP31640 CALL DATSW%1,M< CSP31650 CALL DATSW%2,L< CSP31660 NREAD#6*%1/L<&2 CSP31670 NWRIT#2*%1/I<&2*%1/M<&1 CSP31680 READ (NREAD,2) MASK CSP31690 15 READ (NREAD,1) IN,ICD CSP31700 IF (ICD) 6,10,6 CSP31710 6 NZERO=0 CSP31720 GO TO (7,8), ICD CSP31730 C THIS IS THE YEAR TO DATE PROCESSING CSP31740 7 CALL MOVE (IN,1,2,IDEP,1) CSP31750 CALL MOVE (IN,4,6,IEMP,1) CSP31760 CALL MOVE (IN,7,26,INM,1) CSP31770 CALL MOVE (IN,29,37,ISS,1) CSP31780 CALL MOVE (IN,38,41,IRT,1) CSP31790 CALL MOVE (IN,42,48,IYTD,1) CSP31800 GO TO 15 CSP31810 C THIS IS CURRENT PERIOD PROCESSING CSP31820 8 CALL MOVE (IN,1,3,JEMP,1) CSP31830 HRS=GET (IN,28,30,100.0< CSP31840 GO TO 15 CSP31850 10 NZERO = NZERO + 1 CSP31860 IF (NZERO - 1) 100,100,101 CSP31870 101 STOP 3333 CSP31880 100 IF (NCOMP(IEMP,1,3,JEMP,1)) 99,11,99 CSP31890 11 CURR#%HRS*GET%IRT,1,4,10.0<&500.0