@ TRANSYLVANIA TAPE PRINT\@ TRANS 01191 DCW @\@ TRANS 01200 DCW @ SWITCH- ACTION IF ON\@ TRANS 01210 DCW @ A - SELECT DRIVE 1\@ TRANS 01220 DCW @ B - 2\@ TRANS 01230 DCW @ C - 3\@ TRANS 01240 DCW @ D - 4\@ TRANS 01250 DCW @ E - 5\@ TRANS 01260 DCW @ F - SKIP FORWARD\@ TRANS 01270 DCW @ G - BACKSPACE\@ TRANS 01271 DCW @\@ TRANS 01280 DCW @NOTE -1. TO LABEL PRINTOUT, LOAD PROGRAM & CARD\@ 01290 DCW @TO BE LISTED 80-80, WITH G ON. SET SWITCHES AS \@ TRANS 01300 DCW @INDICATED ABOVE WHEN LABEL MESSAGE APPEARS.\@ TRANS 01310 DCW @ 2. PROGRAM STOPS IF A THRU E ARE OFF.\@ TRANS 01320 DCW @ 3. READER MUST BE EMPTY TO SELECT DRIVE 1.\@ TRANS FILE011: 360 SIMULATOR FOR 1401, 360 AL FILE012: 360 SIMULATOR FOR 1401, MISC JCL AND UPDATES FILE013: 80/80 CARD TO TAPE AND CALL SORT, 1401 SOURCE FILE014: GENERALIZED 1401 ERROR ROUTINE, 1401 SOURCE FILE015: GENERALIZED UPDATE, 1401 SOURCE FILE016: VARIOUS 1401 UTILITIES, 1401 OBJECT Thanks(!), — Robert > Begin forwarded message: > > From: Van Snyder > Subject: Re: Emulation! > Date: April 24, 2023 at 12:30:39 PM PDT > To: Robert Garner > > On Sun, 2023-04-23 at 22:01 -0700, Robert Garner wrote: >> >>> I have the BAL code for a 1401 emulator that ran on any 360, >> >> I also have a listing of it (from Dick Weaver). >> Is your BAL code listing scanned or on our web site already? :) > > Rob: > > I also got it from Dick. I don't have an assembler listing, only the source code at http://vandyke.mynetgear.com/1401/weaver/weaver-split/360-1401.s and http://vandyke.mynetgear.com/1401/weaver/weaver-split/360-1401.jcl > > It's probably the same as what you have. > > The http://vandyke.mynetgear.com/1401/weaver/weaver-split/ directory came from a tape he gave me, that Paul Pierce read for me. I split into the several files in that directory. > > Van p.s. All 5, 625 lines of the 360 simulator the 1401! ########## 360 SIMULATOR FOR 1401, 360 AL //SIM1401 JOB 'U=ARMK204,T=20,D=683,L=5' *// /*SETUP DEVICE=2314,ID=ACT562 *// // EXEC PGM=IEFBR14,REGION=2K //DDX DD DSN=CACTR683.SIM1401, // VOL=REF=CACTR683.ACTR, // SPACE=(TRK,1), // DISP=(MOD,DELETE) // EXEC PGM=IEBUPDTE,PARM=NEW,REGION=40K //SYSPRINT DD DUMMY //SYSUT2 DD DSN=CACTR683.SIM1401, // VOL=REF=CACTR683.ACTR, // SPACE=(7200,40,RLSE), // DCB=(RECFM=FBS,BLKSIZE=7200,LRECL=80), // DISP=(NEW,CATLG) //SYSIN DD * ./ ADD SEQFLD=765 ./ NUMBER NEW1=10,INCR=10 * MODIFIED VERSION OF 360D-11.1.019 * R.WEAVER, IBM-ARMONK NY, JUNE/JULY 1970 SPACE * L I M I T A T I O N S * 1401 * SUPPORTS EXPANDED PRINT EDIT ONLY * ONLY THE FIRST 50 CHAR OF CONSOLE MSG'S ARE PRINTED * JCL * TAPEN DD'S MUST BE ASSIGNED TO TAPE UNITS, DISK CANNOT BE USED SPACE * PARM FORMAT IS 'ABCDEFGLLLX' * WHERE * A-G SENSE SWITCHES, N/F * LLL LINES TO PRINT PER PAGE * X PGM LOAD CARD OR TAPE, C/T SPACE SPACE * THE FOLLOWING COMMENT BLOCK APPLIED TO THE ORIGINAL PROGRAM. *********************************************************************** 00000200 * * 00000300 * * 00000400 * 1 4 0 1 S I M U L A T O R F O R S Y S T E M / 3 6 0 * 00000500 * * 00000600 * * 00000700 * * 00000800 * THIS PROGRAM WILL SIMULATE A 1401 ON A SYSTEM/360. THE * 00000900 * SYSTEM/360 MUST HAVE AT LEAST 65K, STANDARD INSTURCTION SET, ONE * 00001000 * 1052, ONE 2540, AND ONE PRINTER. THE 1401 FEATURES SUPPORTED ARE * 00001100 * ADVACED PROGRAMMING, SENSE SWITCHES, TAPES, MULTIPLY, DIVIDE, * 00001200 * 16K CORE, AND ALL STANDARD INSTRUCTIONS EXCEPT SELECT STACKER. * 00001300 * OPERATOR CONTROL IS THROUGH THE 1052, USING THE FOLLOWING ENTRIES * 00001400 * * 00001500 * * 00001600 * SRS - START RESET * 00001700 * STT - START * 00001800 * LDC - LOAD FROM CARDS * 00001900 * LDT - LOAD FROM TAPE * 00002000 * SSS - SET SENSE SWITCHES * 00002100 * TAS - TAPE ASSIGNMENT * 00002200 * CLR - CLEAR ALL 1401 CORE * 00002300 * DIS - DISPLAY 1401 CORE ON THE PRINTER * 00002400 * ALT - ALTER 1401 CORE * 00002500 * WTM - WRITE TAPE MARK * 00002600 * RWD - REWIND TAPE * 00002700 * TRM - TERMINATE THE SIMULATOR * 00002800 * * 00002900 * * 00003000 * * 00003100 * 16K BYTES ARE SET ASIDE FOR SIMULATED CORE, WITH EACH BYTE HAVING * 00003200 * THE FOLOWING FORMAT. * 00003300 * 360 BIT 1401 BIT * 00003400 * 0 UNUSED * 00003500 * 1 WORD MARK * 00003600 * 2 B * 00003700 * 3 A * 00003800 * 4 8 * 00003900 * 5 4 * 00004000 * 6 2 * 00004100 * 7 1 * 00004200 * * 00004300 * * 00004400 *********************************************************************** 00004500 EJECT 00004600 MACRO &L MSG &M,&L2 LCLC &A &L BAL 4,WTO &A SETC 'L''' DC AL2(&A.&L2.-1) &L2 DC C&M MEND SPACE PRINT NOGEN 14010461 START 0 00000100 USING SETBS1,15 00004700 USING SETBS1+4096,14 00004800 USING SIMCOR,7 00004900 TITLE 'ADD' 00005000 USING A,13 00005100 A CH 9,=H'7' DETERMINE INSTRUCTION LENGTH 00005200 BE AL7 * 00005300 CH 9,=H'1' * 00005400 BE AL1 * 00005500 CH 9,=H'4' * 00005600 BNE ILEGLN * 00005700 LA 6,1(10) 4 CHARACTERS, SET A AND B EQUAL 00005800 BAL 8,CVAD43 * 00005900 LR 11,5 * 00006000 LR 12,11 * 00006100 B AL1 * 00006200 AL7 LA 6,1(10) CONVERT ADDRESSES 00006300 BAL 8,CVAD43 * 00006400 LR 11,5 * 00006500 LA 6,4(10) * 00006600 BAL 8,CVAD43 * 00006700 LR 12,5 * 00006800 AL1 MVI POS1,1 SET 1-POSITION INDICATOR 00006900 MVI AEND,0 CLEAR A-FIELD ENDED INDICATOR 00007000 LA 0,1 SET REGISTER FOR FAST SUBTRACTION 00007100 IC 4,0(10) GET OP CODE 00007200 SRDL 4,1 SAVE LOW ORDER BIT 00007300 IC 4,0(11) GET A-FIELD SIGN 00007400 SRL 4,4 * 00007500 SRDL 4,2 * 00007600 IC 4,0(12) GET B-FIELD SIGN 00007700 SRL 4,4 * 00007800 SLDL 4,3 TEST TABLE 00007900 N 4,=F'31' * 00008000 A 4,=A(TBTRCP) * 00008100 TM 0(4),X'1' * 00008200 BO AL1H COMPLEMENT ADD 00008300 * 00008400 * PERFORM TRUE ADD 00008500 * 00008600 MVI AL1C+1,X'70' SET TO KEEP SIGN 00008700 LA 1,0 CLEAR CARRY 00008800 AL1A IC 3,0(12) GET B-FIELD CHARACTER 00008900 LR 6,3 SAVE B-FIELD ZONE 00009000 N 3,=F'15' ISOLATE DIGIT 00009100 C 3,=F'11' Q/ IS DIGIT NUMERIC 00009200 BL *+8 YES 00009300 S 3,=F'8' NO, ELIMINATE 8 BIT 00009400 CH 3,=H'10' Q/ ZERO 00009500 BNE *+6 NO 00009600 SR 3,3 YES, CLEAR IT 00009700 CLI AEND,1 Q/ IS THERE STILL AN A-FIELD 00009800 BE AL1B NO 00009900 IC 4,0(11) YES, GET DIGIT 00010000 LR 5,4 * 00010100 N 4,=F'15' * 00010200 C 4,=F'11' Q/ IS DIGIT NUMERIC 00010300 BL *+8 YES 00010400 S 4,=F'8' NO, ELIMINATE 8 BIT 00010500 CH 4,=H'10' Q/ ZERO 00010600 BNE *+6 NO 00010700 SR 4,4 YES, CLEAR IT 00010800 AR 3,4 ADD A TO B 00010900 AL1B AR 3,1 ADD CARRY 00011000 LA 1,0 CLEAR CARRY 00011100 CH 3,=H'9' Q/ IS RESULT GREATER THAN 9 00011200 BNH AL1C NO, OK 00011300 SH 3,=H'10' YES, SUBTRACT 10 00011400 LA 1,1 SET CARRY 00011500 AL1C NI 0(12),X'00' STORE RESULT DIGIT 00011600 STC 3,AL1D+1 * 00011700 TM AL1D+1,X'0F' Q/ IS RESULT ZERO 00011800 BC 5,AL1D NO 00011900 OI AL1D+1,X'0A' YES, SET 8-2 BITS 00012000 AL1D OI 0(12),0 * 00012100 MVI AL1C+1,X'40' SET TO ELIMINATE ZONES 00012200 CLI AEND,1 Q/ HAS A-FIELD ALREADY ENDED 00012300 BE AL1E YES 00012400 SR 11,0 DECREMENT A-FIELD ADDRESS 00012500 TM 1(11),X'40' Q/ END OF A-FIELD 00012600 BZ AL1E NO 00012700 MVI AEND,1 YES, SET A-FIELD ENDED INDICATOR 00012800 AL1E SR 12,0 DECREMENT B-FIELD ADDRESS 00012900 TM 1(12),X'40' Q/ END OF B-FIELD 00013000 BO AL1F YES 00013100 MVI POS1,0 NO, TURN OFF 1-POSITION INDICATOR 00013200 CLI AEND,1 Q/ A-FIELD ENDED 00013300 BNE AL1A NO 00013400 SR 5,5 YES, CLEAR A-FIELD CHARACTER 00013500 B AL1A ADD NEXT POSITION 00013600 AL1F CLI POS1,1 Q/ WAS THIS A 1-POSITION FIELD 00013700 BE AL1G1 YES, DONE 00013800 N 5,=F'48' NO, ADD HIGH ORDER ZONES 00013900 N 6,=F'48' * 00014000 AR 5,6 * 00014100 SLL 1,4 ADD CARRY 00014200 AR 5,1 * 00014300 STC 5,AL1G+1 STORE NEW ZONE 00014400 NI AL1G+1,X'30' * 00014500 AL1G OI 1(12),0 * 00014600 AL1G1 LTR 1,1 Q/ WAS THERE A CARRY 00014700 BC 8,NXTOP NO 00014800 MVI OVRFLO,1 YES, SET OVERFLOW INDICATOR 00014900 B NXTOP 00015000 * 00015100 * PERFORM COMPLEMENT ADDITION 00015200 * 00015300 AL1H LA 1,1 SET CARRY 00015400 ST 12,SAVB SAVE B-FIELD UNITS ADDRESS 00015500 MVI AL1L+1,X'70' SET TO KEEP B-FIELD SIGN 00015600 IC 3,0(12) GET B-FIELD SIGN 00015700 N 3,=F'48' * 00015800 CH 3,=H'32' Q/ IS IT MINUS 00015900 BE AL1I YES 00016000 OI 0(12),X'30' NO, PUT PLUS SIGN IN STANDARD FORM 00016100 AL1I IC 2,0(12) GET B-FIELD DIGIT 00016200 N 2,=F'15' * 00016300 C 2,=F'11' Q/ IS DIGIT NUMERIC 00016400 BL *+8 YES 00016500 S 2,=F'8' NO, ELIMINATE 8 BIT 00016600 CH 2,=H'10' Q/ ZERO 00016700 BNE *+6 NO 00016800 SR 2,2 YES, CLEAR IT 00016900 LA 3,9 SET COMPLEMENT 00017000 CLI AEND,1 Q/ HAS A-FIELD PREVIOUSLY ENDED 00017100 BE AL1J YES 00017200 IC 4,0(11) NO, GET A-FIELD DIGIT 00017300 N 4,=F'15' * 00017400 C 4,=F'11' Q/ IS DIGIT NUMERIC 00017500 BL *+8 YES 00017600 S 4,=F'8' NO, ELIMINATE 8 BIT 00017700 CH 4,=H'10' Q/ ZERO 00017800 BNE *+6 NO 00017900 SR 4,4 YES, CLEAR IT 00018000 SR 3,4 COMPLEMENT A-FIELD DIGIT 00018100 AL1J AR 2,3 ADD COMPLEMENT TO B-FIELD DIGIT 00018200 AR 2,1 ADD CARRY 00018300 LA 1,0 CLEAR CARRY 00018400 CH 2,=H'9' Q/ RESULT GREATER THAN 9 00018500 BNH AL1K NO, OK 00018600 SH 2,=H'10' YES, SUBTRACT 10 00018700 LA 1,1 SET CARRY 00018800 AL1K STC 2,AL1M+1 STORE RESULT DIGIT 00018900 AL1L NI 0(12),0 * 00019000 TM AL1M+1,X'0F' Q/ IS RESULT ZERO 00019100 BC 5,AL1M NO 00019200 OI AL1M+1,X'0A' YES, SET 8-2 BITS 00019300 AL1M OI 0(12),0 * 00019400 MVI AL1L+1,X'40' SET TO ELIMINATE B-FIELD ZONES 00019500 CLI AEND,1 Q/ HAS A-FIELD ALREADY ENDED 00019600 BE AL1N YES 00019700 SR 11,0 NO, DECREMENT A-FIELD ADDRESS 00019800 TM 1(11),X'40' Q/ IS THIS THE END OF THE A-FIELD 00019900 BZ AL1N NO 00020000 MVI AEND,1 YES, SET A-FIELD ENDED INDICATOR 00020100 AL1N SR 12,0 DECREMENT B-FIELD ADDRESS 00020200 TM 1(12),X'40' Q/ IS THIS THE END OF THE B-FIELD 00020300 BO AL1O YES 00020400 MVI POS1,0 NO, CLEAR 1-POSITION INDICATOR 00020500 B AL1I 00020600 AL1O LTR 1,1 Q/ CARRY 00020700 BC 6,NXTOP YES, DONE 00020800 * 00020900 * PERFORM RECOMPLEMENT CYCLE 00021000 * 00021100 LA 1,1 SET CARRY 00021200 L 12,SAVB RESTORE B-FIELD UNITS ADDRESS 00021300 IC 2,0(12) GET B-FIELD SIGN 00021400 N 2,=F'48' * 00021500 NI 0(12),X'CF' SET SIGN TO MINUS 00021600 OI 0(12),X'20' * 00021700 CH 2,=H'32' Q/ WAS THE B-FIELD SIGN MINUS 00021800 BNE AL1P NO, LEAVE IT MINUS 00021900 OI 0(12),X'30' YES, SET IT PLUS 00022000 AL1P IC 3,0(12) GET B-FIELD DIGIT 00022100 N 3,=F'15' * 00022200 CH 3,=H'10' Q/ ZERO 00022300 BNE *+6 NO 00022400 SR 3,3 YES, CLEAR IT 00022500 LA 4,9 SET COMPLEMENT 00022600 SR 4,3 COMPLEMENT THE DIGIT 00022700 AR 4,1 ADD CARRY 00022800 LA 1,0 CLEAR CARRY 00022900 CH 4,=H'9' Q/ IS THE RESULT GREATER THAN 9 00023000 BNH AL1Q NO, OK 00023100 SH 4,=H'10' YES, SUBTRACT 10 00023200 LA 1,1 SET CARRY 00023300 AL1Q STC 4,AL1R+1 STORE RESULT 00023400 NI 0(12),X'70' * 00023500 TM AL1R+1,X'0F' Q/ IS RESULT ZERO 00023600 BC 5,AL1R NO 00023700 OI AL1R+1,X'0A' YES, SET 8-2 BITS 00023800 AL1R OI 0(12),0 * 00023900 SR 12,0 DECREMENT B-FIELD ADDRESS 00024000 TM 1(12),X'40' Q/ IS THIS THE END OF THE B-FIELD 00024100 BZ AL1P NO 00024200 B NXTOP YES 00024300 TBTRCP DC X'01000100000101000100010000010100' 00024400 DC X'00010001010000010100010000010100' 00024500 POS1 DC X'0' 00283500 SAVB DS F 00283700 TITLE 'ZERO AND ADD' 00024600 USING ZA,13 00024700 ZA CH 9,=H'1' 00024800 BE ZAL1 00024900 CH 9,=H'7' 00025000 BE ZAL7 00025100 CH 9,=H'4' 00025200 BNE ILEGLN 00025300 ZAL7 LA 6,1(10) 00025400 BAL 8,CVAD43 00025500 LR 11,5 00025600 LR 12,5 00025700 CH 9,=H'4' 00025800 BE ZAL1 00025900 LA 6,4(10) 00026000 BAL 8,CVAD43 00026100 LR 12,5 00026200 ZAL1 LR 6,12 00026300 LR 5,11 00026400 LA 0,1 00026500 IC 3,0(11) SAVE LOW CHARACTER OF A-FIELD 00026600 STC 3,TEMP1 * 00026700 ZAL1A MVN 0(1,6),0(5) MOVE NUMERIC 00026800 NI 0(6),X'4F' ELIMINATE ZONE 00026900 SR 5,0 00027000 SR 6,0 00027100 TM 1(5),X'40' Q/ END OF A-FIELD 00027200 BO ZAL1E YES 00027300 TM 1(6),X'40' NO, END OF B-FIELD 00027400 BZ ZAL1A NO, MOVE NEXT DIGIT 00027500 ZAL1C OI 0(12),X'20' SET B-FIELD SIGN MINUS 00027600 NI TEMP1,X'30' Q/ IS A-FIELD MINUS 00027700 CLI TEMP1,X'20' * 00027800 BE ZAL1D YES 00027900 OI 0(12),X'30' NO, SET B-FIELD SIGN PLUS 00028000 ZAL1D LR 11,5 SET A-ADDRESS 00028100 LR 12,6 SET B-ADDRESS 00028200 B NXTOP 00028300 ZAL1E TM 1(6),X'40' ZERO B-FIELD BEYOND RANGE OF A-FIELD 00028400 BO ZAL1C * 00028500 NI 0(6),X'40' * 00028600 OI 0(6),X'0A' 00028700 SR 6,0 00028800 B ZAL1E * 00028900 TITLE 'ZERO AND SUBTRACT' 00029000 USING ZS,13 00029100 ZS CH 9,=H'7' 00029200 BE ZS1 00029300 CH 9,=H'1' 00029400 BE ZSL4 00029500 CH 9,=H'4' 00029600 BNE ILEGLN 00029700 ZS1 LA 6,1(10) 00029800 BAL 8,CVAD43 00029900 LR 11,5 00030000 LR 12,11 00030100 CH 9,=H'4' 00030200 BE ZSL4 00030300 LA 6,4(10) 00030400 BAL 8,CVAD43 00030500 LR 12,5 00030600 ZSL4 LR 5,11 00030700 LR 6,12 00030800 LA 0,1 SET ONE IN REG 0 FOR SUBTRACTING 00030900 IC 3,0(11) SAVE LOW CHARACTER OF A-FIELD 00031000 STC 3,TEMP1 * 00031100 ZSL4A MVN 0(1,6),0(5) MOVE NUMERIC 00031200 NI 0(6),X'4F' ELIMINATE ZONE 00031300 SR 5,0 DECREMENT A-ADDRESS 00031400 TM 1(5),X'40' 00031500 BO ZSL4F 00031600 SR 6,0 DECREMENT B-ADDRESS 00031700 TM 1(6),X'40' 00031800 BZ ZSL4A 00031900 ZSL4C OI 0(12),X'20' SET B-FIELD SIGN MINUS 00032000 NI TEMP1,X'30' Q/ WAS A-FIELD MINUS 00032100 CLI TEMP1,X'20' * 00032200 BNE ZSL4D LEAVE IT MINUS IF IT WAS PLUS 00032300 OI 0(12),X'30' MAKE B-FIELD PLUS 00032400 ZSL4D LR 11,5 00032500 LR 12,6 00032600 B NXTOP 00032700 ZSL4E NI 0(6),X'40' 00032800 OI 0(6),X'0A' 00032900 ZSL4F SR 6,0 00033000 TM 1(6),X'40' 00033100 BO ZSL4C 00033200 B ZSL4E 00033300 TITLE 'BRANCH, CONDITIONAL BRANCH, AND BRANCH ON CHARACTER' 00033400 USING B,13 00033500 B CH 9,=H'4' 00033600 BE BL5BCH UNCONDITIONAL BRANCH 00033700 CH 9,=H'8' 00033800 BE BCE8 00033900 CH 9,=H'1' 00034000 BE BCE1A 00034100 CH 9,=H'5' 00034200 BH BL5BCH 00034300 BL ILEGLN 00034400 IC 3,4(10) GET D CHARACTER 00034500 N 3,=F'63' * 00034600 SLL 3,2 MULTIPLY BY 4 00034700 L 4,DCHARTBL(3) GET ADDRESS OF CONDITIONAL BRANCH RTN 00034800 BR 4 GO TO ROUTINE OF NXTOP 00034900 BL5A TM SENSEA,1 Q/ IS SENSE SWITCH A ON 00035000 BZ NXTOP NO, CANNOT BRANCH 00035100 TM CRDEOF,1 YES, IS READER EMPTY 00035200 BO BL5BCH YES, BRANCH 00035300 B NXTOP NO 00035400 BL5B CLI SENSEB,1 00035500 B BL5CKB 00035600 BL5C CLI SENSEC,1 00035700 B BL5CKB 00035800 BL5D CLI SENSED,1 00035900 B BL5CKB 00036000 BL5E CLI SENSEE,1 00036100 B BL5CKB 00036200 BL5F CLI SENSEF,1 00036300 B BL5CKB 00036400 BL5G CLI SENSEG,1 00036500 B BL5CKB 00036600 BL5K CLI TPEOF,1 00036700 MVI TPEOF,0 00036800 B BL5CKB 00036900 BL5L CLI TPERR,1 00037000 B BL5CKB 00037100 BL5S CLI CPR,0 00037200 B BL5CKB 00037300 BL5T CLI CPR,1 00037400 B BL5CKB 00037500 BL5U CLI CPR,2 00037600 B BL5CKB 00037700 BL51 CLI CPR,0 00037800 BE NXTOP 00037900 B BL5BCH 00038000 BL5Z CLI OVRFLO,1 00038100 MVI OVRFLO,0 00038200 B BL5CKB 00038300 BL52 CLI PRTP12,1 00038400 B BL5CKB 00038500 BL5RER CLI RDRERR,1 00038600 MVI RDRERR,0 00038700 B BL5CKB 00038800 BL5PER CLI PCHERR,1 00038900 MVI PCHERR,0 00039000 BL5P B NXTOP 00039100 BL53 CLI PRTERR,1 Q/ PRINT ERROR 00039200 MVI PRTERR,0 CLEAR ERROR INDICATOR 00039300 B BL5CKB CHECK CONDITION CODE 00039400 BL5CKB BNE NXTOP 00039500 BL5BCH LA 6,1(10) 00039600 B SETBCH SET CONDITIONS FOR BRANCH 00039700 BCE8 CLI 4(10),0 Q/ IS FIFTH CHARACTER A BLANK 00039800 BE BL5BCH YES, BRANCH 00039900 LA 6,4(10) NO, TREAT AS BCE 00040000 BAL 8,CVAD43 00040100 LR 12,5 00040200 LA 6,1(10) 00040300 BAL 8,CVAD43 00040400 LR 11,5 00040500 MVC DCHAR,7(10) 00040600 BCE1A MVC TEMP1(1),0(12) 00040700 NI TEMP1,X'BF' 00040800 CLC TEMP1,DCHAR COMPARE D CHARACTER TO CORE LOCATION 00040900 BNE BCE1B 00041000 LR 12,10 00041100 AR 12,9 00041200 ST 10,LSTBCH STORE LOCATION COUNTER BEFORE BRANCH 00041300 LR 10,11 00041400 LA 9,0 00041500 B NXTOP 00041600 BCE1B SH 12,=H'1' 00041700 B NXTOP 00041800 DCHARTBL DC A(BL5BCH),11A(NXTOP),A(BL52),4A(NXTOP),A(BL51,BL5S) 00041900 DC A(BL5T,BL5U),4A(NXTOP),A(BL5Z,BL53),7A(NXTOP) 00042000 DC A(BL5K,BL5L),3A(NXTOP),A(BL5P,NXTOP,BL5P,BL5PER) 00042100 DC 6A(NXTOP),A(BL5A,BL5B,BL5C,BL5D,BL5E,BL5F,BL5G) 00042200 DC 2A(NXTOP),A(BL5RER),5A(NXTOP) 00042300 TITLE 'BRANCH ON WORD MARK / ZONE' 00042400 USING BWZ,13 00042500 BWZ CH 9,=H'1' 00042600 BE BWZL1 00042700 CH 9,=H'8' 00042800 BNE ILEGLN 00042900 LA 6,1(10) 00043000 BAL 8,CVAD43 00043100 LR 11,5 00043200 LA 6,4(10) 00043300 BAL 8,CVAD43 00043400 LR 12,5 00043500 MVC DCHAR(1),7(10) 00043600 BWZL1 SH 12,=H'1' 00043700 CLI DCHAR,X'01' 00043800 BE BWZW 00043900 CLI DCHAR,X'02' 00044000 BE BWZ0 00044100 CLI DCHAR,X'32' 00044200 BE BWZBA 00044300 CLI DCHAR,X'22' 00044400 BE BWZB 00044500 CLI DCHAR,X'12' 00044600 BE BWZA 00044700 CLI DCHAR,X'03' 00044800 BE BWZW0 00044900 CLI DCHAR,X'33' 00045000 BE BWZWBA 00045100 CLI DCHAR,X'23' 00045200 BE BWZWB 00045300 CLI DCHAR,X'13' 00045400 BE BWZWA 00045500 B ILEGOP 00045600 BWZW TM 1(12),X'40' 00045700 BO BWZBCH 00045800 B NXTOP 00045900 BWZ0 TM 1(12),X'30' 00046000 BZ BWZBCH 00046100 B NXTOP 00046200 BWZBA TM 1(12),X'30' 00046300 BO BWZBCH 00046400 B NXTOP 00046500 BWZB TM 1(12),X'20' 00046600 BZ NXTOP 00046700 TM 1(12),X'10' 00046800 BO NXTOP 00046900 B BWZBCH 00047000 BWZA TM 1(12),X'20' 00047100 BO NXTOP 00047200 TM 1(12),X'10' 00047300 BO BWZBCH 00047400 B NXTOP 00047500 BWZW0 TM 1(12),X'40' 00047600 BO BWZBCH 00047700 B BWZ0 00047800 BWZWBA TM 1(12),X'40' 00047900 BO BWZBCH 00048000 B BWZBA 00048100 BWZWB TM 1(12),X'40' 00048200 BO BWZBCH 00048300 B BWZB 00048400 BWZWA TM 1(12),X'40' 00048500 BO BWZBCH 00048600 B BWZA 00048700 BWZBCH ST 10,LSTBCH STORE LOCATION COUNTER BEFORE BRANCH 00048800 LR 12,10 SET B-REG 00048900 AR 12,9 * 00049000 LR 10,11 SET LOCATION COUNTER FOR BRANCH 00049100 LA 9,0 * 00049200 B NXTOP 00049300 TITLE 'COMPARE' 00049400 USING C,13 00049500 C CH 9,=H'1' 00049600 BE CL1 00049700 CH 9,=H'4' 00049800 BE CL4 00049900 CH 9,=H'7' 00050000 BNE ILEGLN 00050100 LA 6,4(10) 00050200 BAL 8,CVAD43 00050300 LR 12,5 00050400 MVI TCPR,0 INITALIZE COMPARE RESULT TO EQUAL 14015045 * (1401 RESETS WHEN B-ADDR LOADED) 14015046 CL4 LA 6,1(10) CONVERT A-ADDR TO 360 FORMAT 00050500 BAL 8,CVAD43 * 00050600 LR 11,5 * 00050700 CH 9,=H'4' Q/ IS INSTRUCTION 4 CHARACTERS 00050800 BNE CL1 NO 00050900 LR 12,11 YES, FORS 00051000 LR 12,11 YES, FORCE B/ADDR = A/ADDR 00051100 CL1 LA 4,0 14015130 LA 0,1 00051400 C1 SR 11,0 00051500 SR 12,0 00051600 TM 1(12),X'40' 00051700 BO C2 00051800 TM 1(11),X'40' 00051900 BO C5 LONG B-FIELD 00052000 LA 4,1(4) 00052100 B C1 00052200 C2 LR 5,11 00052300 LR 6,12 00052400 LA 4,1(4) 00052500 C3 MVC TCR(1),1(6) 00052600 MVC TCR+1(1),1(5) 00052700 TR TCR(2),CPRTBL CONVERT DIGITS TO SORT SEQUENCE 00052800 CLC TCR(1),TCR+1 00052900 BH C5 00053000 BL C6 00053100 LA 5,1(5) 00053200 LA 6,1(6) 00053300 BCT 4,C3 00053400 C4 CH 9,=H'1' 00053500 BNE C4A 00053600 CLI TCPR,0 00053700 BE NXTOP 00053800 C4A MVC CPR,TCPR 00053900 B NXTOP 00054000 C5 MVI TCPR,2 SET HIGH 00054100 B C4 00054200 C6 MVI TCPR,1 SET LOW 00054300 B C4 00054400 TCPR DC X'00' 00054500 TCR DS CL2 00054600 CPRTBL DC HL1'0,55,56,57,58,59,60,61,62,63,54,20,21,22,23,24' 00054700 DC HL1'19,13,46,47,48,49,50,51,52,53,45,14,15,16,17,18' 00054800 DC HL1'12,36,37,38,39,40,41,42,43,44,35,7,8,9,10,11' 00054900 DC HL1'6,26,27,28,29,30,31,32,33,34,25,1,2,3,4,5' 00055000 DC HL1'0,55,56,57,58,59,60,61,62,63,54,20,21,22,23,24' 00055100 DC HL1'19,13,46,47,48,49,50,51,52,53,45,14,15,16,17,18' 00055200 DC HL1'12,36,37,38,39,40,41,42,43,44,35,7,8,9,10,11' 00055300 DC HL1'6,26,27,28,29,30,31,32,33,34,25,1,2,3,4,5' 00055400 TITLE 'HALT' 00055500 USING H,13 00055600 H CH 9,=H'1' 00055700 BE H1 00055800 CH 9,=H'4' 00055900 BE H1 00056000 CH 9,=H'7' 00056100 BNE ILEGLN 00056200 H1 LR 5,10 CONVERT I ADDRESS 00056300 BAL 8,H5 * 00056400 MVC I003+12(6),HLTADARA MOVE I ADDR TO OUTPUT 06140 MVC I003+21(6),=CL6' ' 06150 MVC I003+30(6),=CL6' ' 06155 CH 9,=H'7' Q/ IS THERE A B ADDRESS 00056700 BL H2 NO 00056800 LA 6,1(10) CONVERT 1401 ADDRESS 00056900 BAL 8,CVAD43 * 00057000 BAL 8,H5 * 00057100 MVC I003+21(6),HLTADARA MOVE A ADDR TO OUTPUT 06210 LA 6,4(10) CONVERT 1401 B ADDRESS 00057300 BAL 8,CVAD43 * 00057400 BAL 8,H5 * 00057500 MVC I003+30(6),HLTADARA MOVE B ARRR YO OUTPUT MSG 'I003 HALT I , A , B ',I003 AIF ('&CONSOLE' EQ 'Y').HWTO2 H2 B TERMINAT .HWTO2 ANOP CH 9,=H'4' 00057900 BNE H3 00058000 LA 6,1(10) 00058100 BAL 8,CVAD43 00058200 ST 5,ADR360 00058300 H3 MVC RETURN,=A(H4) SET TO CONTINUE AFTER RESTART 00058400 B WTORTN 00058500 H4 CH 9,=H'4' Q/ BRANCH 00058600 BNE NXTOP 00058700 LR 12,10 00058800 AR 12,9 00058900 L 10,ADR360 00059000 LA 9,0 00059100 B NXTOP 00059200 H5 SR 5,7 GET 1401 ADDRESS 00059300 CVD 5,PAKT CONVERT TO DECIMAL 00059400 UNPK HLTADARA(6),PAKT+5(3) UNPACK 1401 ADDRESS 00059500 OI HLTADARA+5,X'F0' MAKE SIGN NUMERIC 00059600 LA 1,HLTADARA BLANK LEADING ZEROS 00059700 H6 CLI 0(1),C'0' * 00059800 BCR 6,8 * 00059900 MVI 0(1),X'40' * 00060000 LA 1,1(1) * 00060100 B H6 * 00060200 HLTADARA DC CL6' ' 00060300 TITLE 'CLEAR STORAGE' 00060400 USING CS,13 00060500 CS CH 9,=H'1' 00060600 BE CSL1 00060700 CH 9,=H'4' 00060800 BE CSL4 00060900 CH 9,=H'7' 00061000 BL ILEGLN 00061100 MVC HLDBCH(3),1(10) 00061200 LA 6,4(10) 00061300 B CSCOM 00061400 CSL4 LA 6,1(10) 00061500 CSCOM BAL 8,CVAD43 00061600 LR 12,5 00061700 CSL1 LR 3,12 00061800 SR 3,7 SUBTRACT SIMULATED CORE BASE LOCATION 00061900 LA 2,0 00062000 D 2,=F'100' 00062100 SR 12,2 00062200 STC 2,CSL1A+1 00062300 CSL1A XC 0(0,12),0(12) CLEAR CORE BLOCK 00062400 CR 12,7 Q/ DID B-REG GO TO 0 00062500 BNE CS2 NO 00062600 L 12,=F'15999' 00062700 AR 12,7 00062800 B CS3 * 00062900 CS2 SH 12,=H'1' SUBTRACT 1 FROM B-REG 00063000 CS3 CH 9,=H'7' Q/ IS THERE A BRANCH 00063100 BL NXTOP 00063200 LA 6,HLDBCH 00063300 B SETBCH 00063400 HLDBCH DS CL3 00063500 TITLE 'SET WORD MARK' 00063600 USING SW,13 00063700 SW CH 9,=H'6' 00063800 BNL SWL7 00063900 CH 9,=H'4' 00064000 BE SWL4 00064100 CH 9,=H'1' 00064200 BE SWL1 00064300 B ILEGLN 00064400 SWL4 LA 6,1(10) 00064500 BAL 8,CVAD43 00064600 LR 11,5 00064700 OI 0(11),X'40' 00064800 SH 11,=H'1' 00064900 LR 12,11 00065000 B NXTOP 00065100 SWL7 LA 6,1(10) 00065200 BAL 8,CVAD43 00065300 LR 11,5 00065400 LA 6,4(10) 00065500 BAL 8,CVAD43 00065600 LR 12,5 00065700 SWL1 OI 0(11),X'40' 00065800 OI 0(12),X'40' 00065900 SH 11,=H'1' 00066000 SH 12,=H'1' 00066100 CH 9,=H'7' 00066200 BNH NXTOP 00066300 LA 9,7 00066400 B NXTOP 00066500 TITLE 'CLEAR WORD MARK' 00066600 USING CW,13 00066700 CW CH 9,=H'6' 00066800 BNL CWL7 00066900 CH 9,=H'4' 00067000 BE CWL4 00067100 CH 9,=H'1' 00067200 BE CWL1 00067300 B ILEGLN 00067400 CWL4 LA 6,1(10) 00067500 BAL 8,CVAD43 00067600 LR 11,5 00067700 NI 0(11),X'BF' 00067800 SH 11,=H'1' 00067900 LR 12,11 00068000 B NXTOP 00068100 CWL7 LA 6,1(10) 00068200 BAL 8,CVAD43 00068300 LR 11,5 00068400 LA 6,4(10) 00068500 BAL 8,CVAD43 00068600 LR 12,5 00068700 CWL1 NI 0(11),X'BF' 00068800 NI 0(12),X'BF' 00068900 SH 11,=H'1' 00069000 SH 12,=H'1' 00069100 B NXTOP 00069200 TITLE 'MOVE CHARACTERS TO A WORD MARK' 00069300 USING MCW,13 00069400 MCW CH 9,=H'7' 00069500 BE MCWL7 00069600 CH 9,=H'4' 00069700 BE MCWL4 00069800 CH 9,=H'1' 00069900 BE MCWL1 00070000 CH 9,=H'8' 00070100 BE MCW8 00070200 B ILEGLN 00070300 MCWL7 LA 6,4(10) 00070400 BAL 8,CVAD43 00070500 LR 12,5 00070600 MCWL4 LA 6,1(10) 00070700 BAL 8,CVAD43 00070800 LR 11,5 00070900 MCWL1 LA 0,1 00071000 MCWL1B MVC MCWL1A+1(1),0(11) 00071100 NI MCWL1A+1,X'3F' 00071200 NI 0(12),X'40' 00071300 MCWL1A OI 0(12),0 00071400 SR 11,0 00071500 SR 12,0 00071600 TM 1(11),X'40' 00071700 BO NXTOP 00071800 TM 1(12),X'40' 00071900 BZ MCWL1B 00072000 B NXTOP 00072100 MCW8 MVC DCHAR(1),7(10) 00072200 CLI DCHAR,X'29' 00072300 BE RT 00072400 CLI DCHAR,X'16' 00072500 BE CHKCON CLI DCHAR,X'31' 00072700 BE MBD 00072800 CLI DCHAR,X'32' 00072900 BE MBD 00073000 B ILEGOP 00073100 CHKCON CLI 2(10),X'13' CHECK FOR T IN BE CONSOLE M%T0XXXW INST B WT * 00073200 * READ TAPE WITHOUT WORD MARKS 00073300 * 00073400 AIF ('&TAPE' EQ 'N').NOTRD RT LA 6,4(10) CONVERT CORE LOCATION FOR TAPE READ 00073500 BAL 8,CVAD43 * 00073600 LR 12,5 * 00073700 BAL 8,FNDRIV GET DEVICE ADDRESS 00073800 MVI RTCCW,X'A3' SET PARITY IN MODE SET COMMAND 00073900 MVI BCDTAP,1 * 00074000 TM 2(10),X'14' * 00074100 BO RT1 * 00074200 MVI RTCCW,X'B3' * 00074300 MVI BCDTAP,0 SET BINARY 00074400 RT1 ST 3,TMDCB 00074500 MVC TPCCW,=A(RTCCW) 00074600 STM 13,15,MACREGSV SAVE MACRO REGS 00074700 LA 6,MACREGSV SAVE ADDRESS TO XR 00074800 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00074900 EXCP TMIOB 00075000 LM 14,15,4(6) RESTORE REG 14 AND 15 00075100 WAIT 1,ECB=TMECB WAIT FOR I/O 00075200 LM 13,15,0(6) RESTORE MACRO REGISTERS 00075300 BAL 8,TPTEST 00075400 BAL 8,FNDLNG FIND LENGTH OF B-FIELD 00075500 LR 3,6 * 00075600 L 1,TAPEAREA SET SENDING ADDRESS 00075700 LH 5,SAVCSW+6 FIND NUMBER OF BYTES READ 00075800 LH 4,=H'25000' * 00075900 SR 4,5 * 00076000 CR 3,4 USE SMALLER FIELD 00076100 BNH RT3 * 00076200 LR 3,4 * 00076300 RT3 CH 3,=H'256' Q/ MORE THAN 256 BYTES 00076400 BNH RT4 NO 00076500 NC 0(256,12),WM256 YES, MOVE 256 BYTES 00076600 CLI BCDTAP,1 * 00076700 BNE RT3A * 00076800 TR 0(256,1),TR4IBC * 00076900 RT3A OC 0(256,12),0(1) * 00077000 LA 1,256(1) * 00077100 LA 12,256(12) * 00077200 SH 3,=H'256' * 00077300 B RT3 * 00077400 RT4 SH 3,=H'1' MOVE REMAINING BYTES 00077500 STC 3,RT5+1 * 00077600 STC 3,RT6+1 * 00077700 STC 3,RT7+1 * 00077800 RT5 NC 0(0,12),WM256 * 00077900 CLI BCDTAP,1 * 00078000 BNE RT7 * 00078100 RT6 TR 0(0,1),TR4IBC * 00078200 RT7 OC 0(0,12),0(1) * 00078300 AR 12,3 SET GROUP MARK AFTER DATA 00078400 NI 1(12),X'40' * 00078500 OI 1(12),X'3F' * 00078600 LA 12,2(12) SET B-ADDRESS 00078700 B NXTOP END OF TAPE READ INSTRUCTION 00078800 * 00078900 * WRITE TAPE WITHOUT WORD MARKS 00079000 * 00079100 WT LA 6,4(10) 00079200 BAL 8,CVAD43 00079300 LR 12,5 00079400 BAL 8,FNDLNG 00079500 STH 6,WTCCW2+6 STORE LENGTH IN CCW 00079600 LR 4,12 00079700 AR 12,6 SET B-ADDRESS 00079800 LA 12,1(12) * 00079900 L 3,TAPEAREA 00080000 MVI WTCCW1,X'A3' SET BCD MODE 00080100 MVI BCDTAP,1 * 00080200 CLI 2(10),X'14' Q/ IS INSTRUCTION BCD 00080300 BE WT1 YES 00080400 MVI WTCCW1,X'B3' NO, SET BINARY MODE 00080500 MVI BCDTAP,0 * 00080600 WT1 CH 6,=H'256' 00080700 BNH WT2 00080800 MVC 0(256,3),0(4) 00080900 CLI BCDTAP,1 Q/ BCD 00081000 BNE WT1A NO 00081100 TR 0(256,3),TRI4BC YES, CHANGE X'00' TO X'10' FOR TAPE 00081200 WT1A LA 3,256(3) UP REG 3 BY 256 00081300 LA 4,256(4) 00081400 SH 6,=H'256' 00081500 B WT1 00081600 WT2 STC 6,WT3+1 00081700 STC 6,WT4+1 00081800 WT3 MVC 0(0,3),0(4) 00081900 CLI BCDTAP,1 Q/ BCD 00082000 BNE WT4A NO 00082100 WT4 TR 0(0,3),TRI4BC YES, CHANGE X'00' TO X'10' FOR TAPE 00082200 WT4A BAL 8,FNDRIV GET DEVICE ADDRESS 00082300 ST 3,TMDCB 00082400 MVC TPCCW,=A(WTCCW1) 00082500 STM 13,15,MACREGSV SAVE MACRO REGS 00082600 LA 6,MACREGSV SAVE ADDRESS TO XR 00082700 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00082800 EXCP TMIOB 00082900 LM 14,15,4(6) RESTORE REG 14 AND 15 00083000 WAIT 1,ECB=TMECB WAIT FOR I/O 00083100 LM 13,15,0(6) RESTORE MACRO REGISTERS 00083200 BAL 8,TPTEST 00083300 B NXTOP 00083400 .NOTRD ANOP AIF ('&TAPE' EQ 'Y').RTOK RT B ILEGOP WT B ILEGOP .RTOK ANOP SPACE AIF ('&MB' EQ 'N').NOMB MBD LA 6,1(10) 00083500 BAL 8,CVAD43 00083600 LR 11,5 00083700 LA 6,4(10) 00083800 BAL 8,CVAD43 00083900 LR 12,5 00084000 LA 0,1 00084100 LR 6,12 00084200 SH 6,=H'100' 00084300 CLI DCHAR,X'32' 00084400 BE MBC 00084500 LR 6,11 00084600 SH 6,=H'100' 00084700 MBD1 IC 3,0(11) 00084800 STC 3,MBD2+1 00084900 NI MBD2+1,X'BF' 00085000 NI 0(12),X'40' 00085100 MBD2 OI 0(12),0 00085200 SR 12,0 00085300 IC 3,0(6) 00085400 STC 3,MBD3+1 00085500 NI MBD3+1,X'BF' 00085600 NI 0(12),X'40' 00085700 MBD3 OI 0(12),0 00085800 SR 12,0 00085900 SR 11,0 00086000 SR 6,0 00086100 TM 1(6),X'40' 00086200 BC 8,MBD1 00086300 B NXTOP 00086400 MBC IC 3,0(11) 00086500 STC 3,MBC1+1 00086600 NI MBC1+1,X'BF' 00086700 NI 0(12),X'40' 00086800 MBC1 OI 0(12),0 00086900 SR 11,0 00087000 IC 3,0(11) 00087100 STC 3,MBC2+1 00087200 NI MBC2+1,X'BF' 00087300 NI 0(6),X'40' 00087400 MBC2 OI 0(6),0 00087500 SR 12,0 00087600 SR 11,0 00087700 SR 6,0 00087800 TM 1(6),X'40' 00087900 BO NXTOP 00088000 TM 1(12),X'40' 00088100 BZ MBC 00088200 B NXTOP 00088300 .NOMB AIF ('&MB' EQ 'Y').YESMB MBD B ILEGOP .YESMB ANOP SPACE CONSOLE CH 9,=H'8' BNE ILEGLN LA 6,4(10) BAL 8,CVAD43 CONVERT B ADDR LR 12,5 TRT 0(50,5),TRGPWM 09630 BC 6,CONSOLE1 L 1,=F'49' 09650 B CLRMSG CONSOLE1 SR 1,5 CLRMSG MVI CON,C' ' BLANK MSG AREA 09680 MVC CON+1(49),CON 09690 EX 1,MV 09600 EX 1,TRAN 09610 MSG ' ',CON 09740 B NXTOP TRAN TR CON(0),TRIE 09800 MV MVC CON(0),0(12) 09810 TITLE 'MOVE CHARACTERS AND SUPPRESS LEADING ZEROS' 00088400 USING MCS,13 00088500 MCS CH 9,=H'1' 00088600 BE MCSL1 00088700 CH 9,=H'7' 00088800 BE MCSL7 00088900 CH 9,=H'4' 00089000 BNE ILEGLN 00089100 LA 6,1(10) 00089200 BAL 8,CVAD43 00089300 LR 11,5 00089400 LR 12,5 00089500 B MCSL1 00089600 MCSL7 LA 6,1(10) 00089700 BAL 8,CVAD43 00089800 LR 11,5 00089900 LA 6,4(10) 00090000 BAL 8,CVAD43 00090100 LR 12,5 00090200 MCSL1 LA 0,1 00090300 MVI SUPRES,1 00090400 IC 3,0(11) MOVE ONLY DIGIT OF FIRST CHARACTER 00090500 STC 3,0(12) * 00090600 NI 0(12),X'0F' * 00090700 STC 3,TEMP1 SAVE A-CHARACTER 00090800 OI 0(12),X'40' SET WORD MARK TO STOP REVERSE SCAN 00090900 B MCSL1B 00091000 MCSL1A IC 3,0(11) MOVE CHARACTER 00091100 STC 3,0(12) * 00091200 STC 3,TEMP1 SAVE A-CHARACTER 00091300 NI 0(12),X'3F' * 00091400 MCSL1B SR 11,0 00091500 SR 12,0 00091600 TM TEMP1,X'40' Q/ END OF A-FIELD 00091700 BZ MCSL1A NO 00091800 LA 12,1(12) YES 00091900 MCSL1C MVC TEMP1(1),0(12) 00092000 NI TEMP1,X'3F' 00092100 CLI SUPRES,1 Q/ IS ZERO SUPPRESSION ON 00092200 BE MCSL1G YES 00092300 CLI TEMP1,X'0A' NO, IS IT SIGNIFICANT DIGIT,BLANK 0 00092400 BNH MCSL1E YES 00092500 CLI TEMP1,X'1B' Q/ COMMA 00092600 BE MCSL1E YES 00092700 CLI TEMP1,X'20' Q/ HYPHEN 00092800 BE MCSL1E YES 00092900 MVI SUPRES,1 TURN ON ZERO SUPRESSION 00093000 MCSL1E TM 0(12),X'40' Q/ LAST DIGIT 00093100 BO MCSL1F YES 00093200 LA 12,1(12) NO, PROCESS NEXT DIGIT 00093300 B MCSL1C * 00093400 MCSL1F NI 0(12),X'BF' CLEAR WORD MARK 00093500 LA 12,1(12) SET B-ADDRESS 00093600 B NXTOP GET NEXT INSTRUCTION 00093700 MCSL1G CLI 0(12),X'09' Q/ SIGNIFICANT DIGIT 00093800 BH MCSL1H * 00093900 CLI 0(12),X'00' * 00094000 BE MCSL1H * 00094100 MVI SUPRES,0 YES, TURN OFF ZERO SUPPRESSION 00094200 B MCSL1E * 00094300 MCSL1H CLI TEMP1,X'00' Q/ BLANK 00094400 BE MCSL1I BLANK 00094500 CLI TEMP1,X'0A' Q/ ZERO 00094600 BE MCSL1I ZERO 00094700 CLI TEMP1,X'1B' Q/ COMMA 00094800 BNE MCSL1E NO 00094900 MCSL1I NI 0(12),X'40' 00095000 B MCSL1E 00095100 TITLE 'MOVE NUMERIC' 00095200 USING MN,13 00095300 MN CH 9,=H'1' 00095400 BE MNL1 00095500 CH 9,=H'4' 00095600 BE MNL4 00095700 CH 9,=H'7' 00095800 BNE ILEGLN 00095900 LA 6,4(10) 00096000 BAL 8,CVAD43 00096100 LR 12,5 00096200 MNL4 LA 6,1(10) 00096300 BAL 8,CVAD43 00096400 LR 11,5 00096500 CH 9,=H'4' 00096600 BNE MNL1 00096700 LR 12,11 4 CHARACTERS, SET B ADR = A ADR 00096800 MNL1 MVN 0(1,12),0(11) MOVE NUMERIC 00096900 SH 11,=H'1' 00097000 SH 12,=H'1' 00097100 B NXTOP 00097200 TITLE 'MOVE ZONE' 00097300 USING MZ,13 00097400 MZ CH 9,=H'1' 00097500 BE MZL1 00097600 CH 9,=H'7' 00097700 BNE ILEGLN 00097800 LA 6,1(10) 00097900 BAL 8,CVAD43 00098000 LR 11,5 00098100 LA 6,4(10) 00098200 BAL 8,CVAD43 00098300 LR 12,5 00098400 MZL1 IC 3,0(11) 00098500 STC 3,MZL1A+1 00098600 NI 0(12),X'CF' 00098700 NI MZL1A+1,X'30' 00098800 MZL1A OI 0(12),0 00098900 SH 11,=H'1' 00099000 SH 12,=H'1' 00099100 B NXTOP 00099200 TITLE 'LOAD CHARACTERS TO AN A-FIELD WORD MARK' 00099300 USING LCA,13 00099400 LCA CH 9,=H'7' 00099500 BE LCAL7 00099600 CH 9,=H'4' 00099700 BE LCAL4 00099800 CH 9,=H'1' 00099900 BE LCAL1 00100000 CH 9,=H'8' 00100100 BE LCA8 00100200 B ILEGLN 00100300 LCAL7 LA 6,4(10) 00100400 BAL 8,CVAD43 00100500 LR 12,5 00100600 LCAL4 LA 6,1(10) 00100700 BAL 8,CVAD43 00100800 LR 11,5 00100900 LCAL1 LA 0,1 00101000 LCAL1A IC 3,0(11) 00101100 STC 3,0(12) 00101200 SR 11,0 00101300 SR 12,0 00101400 TM 1(11),X'40' 00101500 BZ LCAL1A 00101600 B NXTOP 00101700 LCA8 CLI 7(10),X'29' 00101800 BE RTW 00101900 CLI 7(10),X'16' 00102000 BE WTW 00102100 B ILEGOP 00102200 * 00102300 * READ TAPE WITH WORD MARKS 00102400 * 00102500 AIF ('&TAPE' EQ 'N').NOTWT RTW LA 6,4(10) 00102600 BAL 8,CVAD43 00102700 LR 12,5 00102800 BAL 8,FNDRIV 00102900 MVI RTCCW,X'A3' LOAD MODE SET COMMAND 00103000 ST 3,TMDCB 00103100 MVC TPCCW,=A(RTCCW) 00103200 STM 13,15,MACREGSV SAVE MACRO REGS 00103300 LA 6,MACREGSV SAVE ADDRESS TO XR 00103400 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00103500 EXCP TMIOB 00103600 LM 14,15,4(6) RESTORE REG 14 AND 15 00103700 WAIT 1,ECB=TMECB WAIT FOR I/O 00103800 LM 13,15,0(6) RESTORE MACRO REGISTERS 00103900 BAL 8,TPTEST 00104000 LH 3,SAVCSW+6 FIND NUMBER OF BYTES READ 00104100 LH 4,=H'25000' * 00104200 SR 4,3 00104300 L 1,TAPEAREA SET SENDING ADDRESS 00104400 RTW1 CLI 0(12),X'7F' Q/ GP MK - WD MK IN CORE 00104500 BE RTW3 YES 00104600 CLI 0(1),X'1D' Q/ WORD SEPARATOR 00104700 BNE RTW2 NO 00104800 LA 1,1(1) YES 00104900 IC 3,0(1) 00105000 STC 3,0(12) 00105100 TR 0(1,12),TR4IBC 00105200 OI 0(12),X'40' 00105300 SH 4,=H'1' 00105400 B RTW2A 00105500 RTW2 IC 3,0(1) 00105600 STC 3,0(12) 00105700 TR 0(1,12),TR4IBC 00105800 RTW2A LA 1,1(1) 00105900 LA 12,1(12) 00106000 BCT 4,RTW1 00106100 CLI 0(12),X'7F' RECORD MOVED, IS GROUP MARK NEXT CHAR 00106200 BE RTW3 YES, LEAVE IT ALONE 00106300 MVI 0(12),X'3F' NO, MOVE IN A GROUP MARK 00106400 RTW3 LA 12,1(12) SET B-ADDRESS 00106500 B NXTOP 00106600 * 00106700 * WRITE TAPE WITH WORD MARKS 00106800 * 00106900 WTW LA 6,4(10) 00107000 BAL 8,CVAD43 00107100 LR 12,5 00107200 L 1,TAPEAREA 00107300 LR 2,12 00107400 WTW1 TM 0(2),X'7F' Q/ GROUP MARK WORD MARK 00107500 BO WTW3 YES, FIELD DONE 00107600 TM 0(2),X'40' Q/ WORD MARK 00107700 BZ WTW2 NO 00107800 MVI 0(1),X'1D' YES, INSERT WORD SEPARATOR 00107900 LA 1,1(1) * 00108000 WTW2 MVC 0(1,1),0(2) 00108100 TR 0(1,1),TRI4BC 00108200 LA 1,1(1) 00108300 LA 2,1(2) 00108400 B WTW1 00108500 WTW3 S 1,TAPEAREA 00108600 STH 1,WTCCW2+6 00108700 MVI WTCCW1,X'A3' 00108800 BAL 8,FNDRIV 00108900 ST 3,TMDCB 00109000 MVC TPCCW,=A(WTCCW1) 00109100 STM 13,15,MACREGSV SAVE MACRO REGS 00109200 LA 6,MACREGSV SAVE ADDRESS TO XR 00109300 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00109400 EXCP TMIOB 00109500 LM 14,15,4(6) RESTORE REG 14 AND 15 00109600 WAIT 1,ECB=TMECB WAIT FOR I/O 00109700 LM 13,15,0(6) RESTORE MACRO REGISTERS 00109800 BAL 8,TPTEST 00109900 LA 12,1(2) 00110000 B NXTOP 00110100 .NOTWT ANOP AIF ('&TAPE' EQ 'Y').WTOK RTW B ILEGOP WTW B ILEGOP .WTOK ANOP TITLE 'MOVE CHARACTERS AND EDIT' 00110200 USING MCE,13 00110300 MCE CH 9,=H'7' Q/ IS LENGTH CORRECT 00110400 BNE ILEGLN NO 00110500 LA 6,1(10) YES, CONVERT ADDRESSES 00110600 BAL 8,CVAD43 * 00110700 LR 11,5 * 00110800 LA 6,4(10) * 00110900 BAL 8,CVAD43 * 00111000 LR 12,5 * 00111100 LA 0,1 00111200 MVI AEND,0 CLEAR A-FIELD END INDICATOR 00111300 MVI BODY,0 CLEAR BODY TRIGGER 00111400 MVI SUPRES,0 CLEAR ZERO SUPPRESSION INDICATOR 00111500 MVI FLOAT,0 CLEAR FLOATING DOLLAR SIGN INDICATOR 00111600 MVI SIGDIG,0 CLEAR SIGNIFICANT DIGIT IND 00111700 MVI ASTER,0 CLEAR ASTERISK PROTECTION IND 00111800 MVI AMINUS,0 CLEAR A-FIELD MINUS INDICATOR 00111900 MVI DECIMAL,0 DECIMAL POINT INDICATOR 00112000 MVI FIRSTDOL,0 CLEAR $ INFIRST CHAR INDICATOR 00112100 MVI SIGNDOL,0 CLEAR DOLLAR SIGN INDICATOR 00112200 IC 2,0(11) Q/ A-FIELD MINUS 00112300 N 2,=F'48' 00112400 CH 2,=H'32' 00112500 BNE MCE1 NO 00112600 MVI AMINUS,1 YES,SET A-FIELD MINUS INDICATOR 00112700 MCE1 IC 1,0(12) SAVE B-FIELD CHARACTER 00112800 STC 1,TEMP1 * 00112900 NI 0(12),X'3F' CLEAR WORD MARK 00113000 CLI 0(12),X'3B' Q/ DECIMAL POINT 00113100 BNE MCE1A NO 00113200 MVI DECIMAL,1 YES,SET DECIMAL INDICATOR 00113300 ST 12,DECADD STORE ADDRESS OF DECIMAL POINT 00113400 MCE1A CLI 0(12),X'00' Q/ BLANK 00113500 BE MCE6 YES 00113600 CLI 0(12),X'0A' Q/ ZERO 00113700 BE MCE6 YES 00113800 CLI 0(12),X'30' Q/ AMPERSAND 00113900 BE MCE3 YES 00114000 CLI BODY,1 Q/ BODY TRIGGER ON 00114100 BE MCE3A YES 00114200 CLI 0(12),X'1B' Q/ COMMA 00114300 BE MCE3 YES 00114400 CLI 0(12),X'33' Q/ C 00114500 BE MCE2 YES 00114600 CLI 0(12),X'29' Q/ R 00114700 BE MCE2 YES 00114800 CLI 0(12),X'20' Q/ - 00114900 BNE MCE3A NO 00115000 MCE2 CLI AMINUS,1 Q/ A-FIELD MINUS 00115100 BE MCE3A YES 00115200 MCE3 MVI 0(12),X'00' MOVE BLANK TO B-FIELD 00115300 SR 12,0 DECREMENT B-FIELD 00115400 B MCE5 00115500 MCE3A CLI 0(12),X'2C' Q/ * 00115600 BNE MCE3B NO 00115700 CLI BODY,1 Q/ BODY TRIGGER ON 00115800 BNE MCE3B NO 00115900 MVI ASTER,1 SET ASTERISK PRORECTION INDICATOR 00116000 B MCE6 00116100 MCE3B CLI 0(12),X'2B' Q/ DOLLAR SIGN 00116200 BNE MCE5C NO 14021910 MVI SIGNDOL,1 SET DOLLAR SIGN INDICATOR 14022020 ST 12,DOLSIGN STORE ADDRESS OF DOLLAR SIGN 00117500 TM 1(12),X'40' Q/ FLOATING DOLLAR SIGN 00117600 BZ MCE5A 00117700 MVI FLOAT,1 00117800 MVC 0(1,12),0(11) 00117900 B MCE4A 00118000 MCE6 CLI AEND,1 Q/ HAS A-FIELD ALREADY ENDED 00118100 BE MCE3 YES 00118200 MVC 0(1,12),0(11) MOVE CHARACTER 00118300 NI 0(12),X'3F' * 00118400 CLI 0(12),X'00' BLANK 00118500 BE MCE6A YES 00118600 CLI 0(12),X'09' DIGIT 00118700 BH MCE6A NO 00118800 MVI SIGDIG,1 YES SET SIG DIGIT INDICATOR 00118900 MCE6A CLI BODY,1 Q/ BODY TRIGGER ON 00119000 CLI BODY,1 Q/ IS BODY TRIGGER ON 00119100 BE MCE7 YES 00119200 MVI BODY,1 NO 00119300 ST 12,LASTDIG STORE ADDRESS OF LOW ORDER DIGIT 00119400 NI 0(12),X'0F' REMOVE ZONE 00119500 MCE7 TM TEMP1,X'0A' Q/ IS DIGIT ZERO 00119600 BC 12,MCE4A NO 00119700 TM TEMP1,X'35' 00119800 BC 5,MCE4A NO 00119900 OI 0(12),X'40' YES, SET ZERO SUPPRESSION WORD MARK 00120000 ST 12,ZEROSUP STORE ZERO SUPPRESSION ADDRESS 00120100 MVI SUPRES,1 SET ZERO SUPPRESSION INDICATOR 00120200 B MCE4A INDICATOR 00120300 SPACE MCE5C SR 12,0 DECREMENT B-FIELD B MCE5 MCE4A SR 11,0 MCE5A SR 12,0 TM 1(11),X'40' Q/ END OF A-FIELD BZ MCE5 NO MVI AEND,1 YES, SET A-FIELD ENDED INDICATOR MCE5 TM TEMP1,X'40' Q/ END OF B-FIELD BZ MCE1 NO * E N D O F 1 S T F O R W A R D S C A N SPACE CLI SUPRES,1 Q/ WAS THERE ZERO SUPPRESSION 14022320 BNE NXTOP NO, GET NEXT INSTRUCTION 00120500 MVI FIRST,1 SET FIRST CHARACTER OF SCAN INDICATOR 00120600 LA 12,1(12) 00120700 CLI 0(12),X'2B' DOLLAR SIGN 00120800 BNE MCE8A 00120900 MVI FIRSTDOL,1 YES 00121000 MCE8A MVC TEMP1(1),0(12) SAVE CHARACTER 00121100 NI 0(12),X'3F' CLEAR WORD MARK 00121200 CLI 0(12),X'00' Q/ BLANK 00121300 BE MCE9 YES 00121400 CLI 0(12),X'0A' Q/ ZERO 00121500 BE MCE11 YES 00121600 CLI 0(12),X'09' Q/ SIGNIFICANT DIGIT 00121700 BH MCE9 NO 00121800 MVI SUPRES,0 TURN OFF ZERO SUPPRESSION 00121900 MVI SIGDIG,1 SET SIGNIFICANT DIGIT INDICATOR 00122000 B MCE10 00122100 MCE9 CLI 0(12),X'1B' Q/ COMMA 00122200 BE MCE11 YES 00122300 CLI 0(12),X'20' Q/ - 00122400 BNE MCE10C NO 14022530 CLI FIRST,1 Q/ FIRST CHARACTER IN STRING 14022535 BNE MCE10 NO 14022540 CLI AMINUS,1 Q/ A-FIELD MINUS 14022550 BE MCE10 14022560 MVI 0(12),X'00' NO,BLANK MINUS SIGN 14022565 B MCE10 14022570 SPACE 14022575 MCE10C CLC 0(2,12),=X'3329' Q/ CR SYMBOL 14022580 BNE MCE10 NO 14022585 CLI SUPRES,1 Q/ ZERO SUPPRESSION ON 14022590 BNE MCE10 NO 14022595 CLI FIRST,1 Q/ 1ST CHARACTER IN STRING 14022600 BE MCE14 YES 14022605 MVC 0(2,12),=C' ' NO,BLANK CR 14022610 B MCE10 14022615 MCE14 CLI AMINUS,1 Q/ A-FIELD MINUS 14022620 BE MCE10A YES 14022625 MVC 0(2,12),=C' ' NO,BLANK CR 14022630 B MCE10 14022640 MCE10A LA 12,1(12) 14022644 B MCE10 14022645 SPACE 14022650 MCE11 CLI SUPRES,1 Q/ ZERO SUPPRESSION ON 00124100 BNE MCE10 NO 00124200 MVI 0(12),X'00' YES, BLANK CHARACTER 00124300 CLI FIRST,1 Q/ FIRST CHARACTER IN STRING 00124400 BE MCE12 YES 00124500 CLI ASTER,1 Q/ ASTERISK PROTECTION ON 00124600 BNE MCE10 NO 00124700 MVI 0(12),X'2C' YES, INSERT ASTERISK 00124800 B MCE10 00124900 MCE12 CLI AMINUS,1 Q/ A-FIELD MINUS 00125000 BE MCE10 YES 00125100 MVI 0(12),X'00' NO,BLANK CHARACTER 00125200 SPACE 14022810 MCE10 LA 12,1(12) 14022880 MVI FIRST,0 TURN OFF FIRST TIME INDICATOR 14022890 TM TEMP1,X'40' Q/ W/RD MARK 14022900 BNO MCE8A NO, PROCESS NEXT DIGIT 14022910 * E N D O F R E V E R S E S C A N 14022920 SPACE 14022930 FLDOL CLI FLOAT,1 Q/ FLOATING DOLLAR SIGN 00126600 BNE DECON NO, GO TO DECIMAL CONTR 00126700 DOLLAR CLI 0(12),X'00' Q/ BLANK 00126800 BNE MOVDOL NO,GO TO NEXT POSITION IN B-FIELD 00126900 MVI 0(12),X'2B' MOVE DOLLAR SIGN INTO B-FIELD 00127000 B DECON 00127100 MOVDOL SR 12,0 DECREMENT B-FIELD 00127200 B DOLLAR 00127300 DECON CLI DECIMAL,1 IS DECIMAL CONTROL NEEDED 00127400 BNE NXTOP NO 00127500 CLI SIGDIG,1 Q/ SIGNIFICANT DIGIT 00127600 BE NXTOP YES 14023050 L 5,LASTDIG 14023120 CLC DECADD,ZEROSUP 00128500 BH MCE16A 00128600 L 4,DECADD 00128700 B MCE16B 00128800 MCE16A L 4,ZEROSUP 00128900 MCE16B SR 5,4 00129000 AH 5,=H'1' 00129100 MCE16D MVC 0(1,4),=X'00' 00129200 AR 4,0 00129300 BCT 5,MCE16D 00129400 TM 1(12),X'40' Q/ FLOATING DOLLAR SIGN 00129500 CLI SIGNDOL,1 Q/ DOLLAR SIGN 00129600 BNE NXTOP NO 00129700 CLI FIRSTDOL,1 Q/ DOLLAR SIGN OK 00129800 BE NXTOP 00129900 L 3,DOLSIGN NO 00130000 MVI 0(3),X'00' BLANK DOLLAR SIGN 00130100 B NXTOP 00130200 ZEROSUP DS F ZERO SUPPRESSION ADDRESS 00130300 DECADD DS F DECIMAL POINT ADDRESS 00130400 DECIMAL DC X'00' DECIMAL INDICATOR 00130500 FLOAT DC X'00' FLOATING DOLLAR SIGN INDICATOR 00130600 FIRST DC X'00' FIRST CHARACTER OF SCAN INDICATOR 00130700 AMINUS DC X'00' A-FIELD MINUS INDICATOR 00130800 BODY DC X'00' BODY TRIGGER 00130900 ASTER DC X'00' ASTERISK PROTECTION INDICATOR 00131000 SIGDIG DC X'00' SIGNIFICANT DIGIT INDICATOR 00131100 FIRSTDOL DC X'00' 00131200 DOLSIGN DS F 00131300 LASTDIG DS F ADDRESS OF LOW ORDER DIGIT 00131400 SIGNDOL DC X'00' 00131500 TITLE 'READ A CARD' 00131600 USING R,13 00131700 R CH 9,=H'1' 00131800 BE RL1 00131900 CH 9,=H'4' 00132000 BE RL4 00132100 B ILEGLN 00132200 RL1 BAL 8,READ 00132300 B NXTOP 00132400 RL4 MVC ADR140(3),1(10) 00132500 BAL 8,READ 00132600 LA 6,ADR140 GET BRANCH ADDRESS 00132700 B SETBCH SET CONDITIONS FOR BRANCH 00132800 TITLE 'PUNCH A CARD' 00132900 USING P,13 00133000 P CH 9,=H'1' 00133100 BE PL1 00133200 CH 9,=H'4' 00133300 BNE ILEGLN 00133400 BAL 8,PUNCH 00133500 LA 6,1(10) REFERENCE BRANCH ADDRESS 00133600 B SETBCH SET CONDITIONS FOR BRANCH 00133700 PL1 BAL 8,PUNCH 00133800 B NXTOP 00133900 TITLE 'READ AND PUNCH' 00134000 USING RP,13 00134100 RP CH 9,=H'1' 00134200 BE RPL1 00134300 CH 9,=H'4' 00134400 BNE ILEGLN 00134500 MVC ADR140(3),1(10) SAVE BRANCH ADDRESS 00134600 BAL 8,READ 00134700 BAL 8,PUNCH 00134800 LA 6,ADR140 REFERENCE BRANCH ADDRESS 00134900 B SETBCH SET CONDITIONS FOR BRANCH 00135000 RPL1 BAL 8,READ 00135100 BAL 8,PUNCH 00135200 B NXTOP 00135300 TITLE 'PRINT A LINE' 00135400 USING W,13 00135500 W CH 9,=H'1' 00135600 BE WL1 00135700 CH 9,=H'2' 00135800 BE WM 00135900 CH 9,=H'5' 00136000 BE WM 00136100 CH 9,=H'4' 00136200 BNE ILEGLN 00136300 WL4 BAL 8,WRITE 00136400 LA 6,1(10) REFERENCE BRANCH ADDRESS 00136500 B SETBCH SET CONDITIONS FOR BRANCH 00136600 WL1 BAL 8,WRITE 00136700 B NXTOP 00136800 WM MVC DCHAR(1),1(10) 00136900 CH 9,=H'2' 00137000 BE WML2 00137100 MVC DCHAR(1),4(10) 00137200 WML2 CLI DCHAR,X'3C' Q. PRINT WM 00137500 BE WML20A 00137600 CLI DCHAR,X'12' Q. SPACE SUPPRESS 00137700 BNE ILEGOP 00137800 MVI PRNTBUFF,X'01' CH 9,=H'5' 00137900 BE WL4 00138000 B WL1 00138100 WML20A MVC PRNTBUFF+1(132),SIMCOR+201 MOVE WORD MARKS TO PRINT 00138200 TR PRNTBUFF+1(132),TRWDMK * 00138300 BAL 8,WRITEC 14770 CH 9,=H'2' 00139100 BE NXTOP 00139200 LA 6,1(10) 00139300 B SETBCH SET CONDITIONS FOR BRANCH 00139400 TITLE 'READ AND PRINT' 00139500 USING WR,13 00139600 WR CH 9,=H'1' 00139700 BE WRL1 00139800 CH 9,=H'4' 00139900 BNE ILEGLN 00140000 MVC ADR140(3),1(10) SAVE BRANCH ADDRESS 00140100 BAL 8,WRITE 00140200 BAL 8,READ 00140300 LA 6,ADR140 REFERENCE BRANCH ADDRESS 00140400 B SETBCH SET CONDITIONS FOR BRANCH 00140500 WRL1 BAL 8,WRITE 00140600 BAL 8,READ 00140700 B NXTOP 00140800 TITLE 'PRINT AND PUNCH' 00140900 USING WP,13 00141000 WP CH 9,=H'1' 00141100 BE WPL1 00141200 CH 9,=H'4' 00141300 BNE ILEGLN 00141400 BAL 8,WRITE 00141500 BAL 8,PUNCH 00141600 LA 6,1(10) REFERENCE BRANCH ADDRESS 00141700 B SETBCH SET CONDITIONS FOR BRANCH 00141800 WPL1 BAL 8,WRITE 00141900 BAL 8,PUNCH 00142000 B NXTOP 00142100 TITLE 'WRITE,READ, AND PUNCH' 00142200 USING WRP,13 00142300 WRP CH 9,=H'1' 00142400 BE WRPL1 00142500 CH 9,=H'4' 00142600 BNE ILEGLN 00142700 MVC ADR140(3),1(10) SAVE BRANCH ADDRESS 00142800 BAL 8,WRITE 00142900 BAL 8,READ 00143000 BAL 8,PUNCH 00143100 LA 6,ADR140 REFERENCE BRANCH ADDRESS 00143200 B SETBCH SET CONDITIONS FOR BRANCH 00143300 WRPL1 BAL 8,WRITE 00143400 BAL 8,READ 00143500 BAL 8,PUNCH 00143600 B NXTOP 00143700 TITLE 'SELECT STACKER' 00143800 USING SS,13 00143900 SS CH 9,=H'2' 00144000 BE NXTOP 00144100 CH 9,=H'5' 00144200 BNE ILEGLN 00144300 LA 6,1(10) 00144400 B SETBCH 00144500 TITLE 'CONTROL CARRIAGE' 00144600 USING CC,13 00144700 CC MVC DCHAR(1),1(10) 00144800 CH 9,=H'2' 00144900 BE CCL2 00145000 CH 9,=H'5' 00145100 BNE ILEGLN 00145200 MVC DCHAR(1),4(10) 00145300 CCL2 TM DCHAR,X'30' 00145400 BZ CCIMSK 00145500 BO CCAFSK 00145600 TM DCHAR,X'20' 00145700 BO CCIMSP 00145800 IC 3,DCHAR 00145900 N 3,=F'3' 00146000 SLL 3,3 00146100 O 3,=F'1' 00146200 STC 3,PRNTBUFF 00146300 B CCDONE 00146400 CCIMSP IC 3,DCHAR 00146500 N 3,=F'3' 00146600 SLL 3,3 00146700 STC 3,PRNTBUFF 00146800 OI PRNTBUFF,X'03' 00146900 B CCNOW 00147000 CCAFSK IC 3,DCHAR 00147100 N 3,=F'15' 00147200 TM DCHAR,X'0F' 00147300 BM CC1 00147400 LA 3,10 00147500 CC1 SLL 3,3 00147600 STC 3,PRNTBUFF 00147700 OI PRNTBUFF,X'81' 00147800 B CCDONE 00147900 CCIMSK IC 3,DCHAR 00148000 TM DCHAR,X'0F' 00148100 BM CC2 00148200 LA 3,10 00148300 CC2 N 3,=F'15' 00148400 SLL 3,3 00148500 O 3,=F'131' 00148600 STC 3,PRNTBUFF 00148700 CCNOW BAL 8,WRITEC 15810 CCDONE CH 9,=H'2' 00149500 BE NXTOP 00149600 LA 6,1(10) 00149700 B SETBCH 00149800 TITLE 'MULTIPLY' 00154500 USING M,13 00154600 M CH 9,=H'7' 00154700 BNE ILEGLN 00154800 LA 6,1(10) 00154900 BAL 8,CVAD43 00155000 LR 11,5 00155100 LA 6,4(10) 00155200 BAL 8,CVAD43 00155300 LR 12,5 00155400 ST 12,MPYSAV SAVE UNITS ADDRESS OF PRODUCT 00155500 LR 5,11 INTIALIZE PRODUCT AREA 00155600 LR 6,12 * 00155700 M1 MVI 0(6),X'0A' * 00155800 TM 0(5),X'40' * 00155900 BO M2 * 00156000 SH 5,=H'1' * 00156100 SH 6,=H'1' * 00156200 B M1 * 00156300 M2 SH 6,=H'2' * 00156400 MVI 1(6),X'0A' * 00156500 LA 1,0 COMPARE SIGNS 00156600 LA 2,0 * 00156700 TM 0(6),X'20' * 00156800 BZ M3 * 00156900 TM 0(6),X'10' * 00157000 BO M3 * 00157100 LA 1,1 * 00157200 M3 TM 0(11),X'20' * 00157300 BZ M4 * 00157400 TM 0(11),X'10' * 00157500 BO M4 * 00157600 LA 2,1 * 00157700 M4 MVI MINPRD,0 00157800 CR 1,2 00157900 BE M5 SIGNS EQUAL 00158000 MVI MINPRD,1 SIGNS UNEQUAL 00158100 M5 IC 1,0(6) 00158200 N 1,=F'15' 00158300 CH 1,=H'10' Q/ ZERO 00158400 BNE *+6 NO 00158500 SR 1,1 YES, CLEAR 00158600 M6 LA 0,0 00158700 LTR 1,1 Q/ IS MULTIPLICAND DIGIT ZERO 00158800 BZ M9 00158900 LR 5,12 SET REGISTERS FOR ADD 00159000 LR 4,11 00159100 LR 8,12 LOAD PRODUCT POINTER 00159200 M7 IC 2,0(4) 00159300 N 2,=F'15' 00159400 CH 2,=H'10' Q/ ZERO 00159500 BNE *+6 NO 00159600 SR 2,2 YES, CLEAR 00159700 IC 3,0(5) 00159800 N 3,=F'15' 00159900 CH 3,=H'10' Q/ ZERO 00160000 BNE *+6 NO 00160100 SR 3,3 YES, CLEAR IT 00160200 AR 3,2 00160300 AR 3,0 00160400 LA 0,0 00160500 CH 3,=H'9' 00160600 BNH M8 00160700 SH 3,=H'10' 00160800 LA 0,1 00160900 M8 STC 3,0(8) STORE RESULT 00161000 CLI 0(8),X'00' Q/ RESULT ZERO 00161100 BNE *+8 NO 00161200 MVI 0(8),X'0A' YES, SET 8-2 BITS 00161300 SH 4,=H'1' 00161400 SH 5,=H'1' 00161500 SH 8,=H'1' 00161600 TM 1(4),X'40' 00161700 BZ M7 00161800 IC 3,0(5) ADD CARRY TO NEXT PRODUCT DIGIT 00161900 CH 3,=H'10' Q/ ZERO 00162000 BNE *+6 NO 00162100 SR 3,3 YES, CLEAR 00162200 AR 3,0 00162300 STC 3,0(8) * 00162400 CLI 0(8),X'00' Q/ RESULT ZERO 00162500 BNE *+8 NO 00162600 MVI 0(8),X'0A' YES, SET 8-2 BITS 00162700 SH 1,=H'1' 00162800 BC 6,M6 COUNT NOT ZERO, ADD NEXT DIGIT 00162900 M9 SH 6,=H'1' 00163000 NI 1(6),X'40' CLEAR LAST USED MULTIPLICAND DIGIT 00163100 OI 1(6),X'0A' * 00163200 TM 1(6),X'40' 00163300 BO M10 00163400 SH 12,=H'1' 00163500 B M5 00163600 M10 LR 11,4 00163700 L 12,MPYSAV RELOAD UNITS ADDRESS OF PRODUCT 00163800 OI 0(12),X'20' 00163900 CLI MINPRD,1 00164000 BE M11 00164100 OI 0(12),X'30' 00164200 M11 LR 12,6 00164300 B NXTOP 00164400 MINPRD DS C 00164500 MPYSAV DS F 00164600 TITLE 'DIVIDE' 00164700 USING D,13 00164800 D CH 9,=H'7' Q/ IS LENGTH ( BYTES 00164900 BNE ILEGLN NO 00165000 LA 6,1(10) YES, CONVERT ADDRESSES 00165100 BAL 8,CVAD43 * 00165200 LR 11,5 * 00165300 LA 6,4(10) * 00165400 BAL 8,CVAD43 * 00165500 LR 12,5 * 00165600 LA 0,1 SET REG TO 1 FOR + OR - 1 00165700 LR 1,11 SCAN DIVISOR FOR LENGTH AND IS IT ZERO 00165800 MVI TEMP1,0 * 00165900 MVI TEMP2,0 * 00166000 D1 MVN TEMP2,0(1) * 00166100 CLI TEMP2,X'0A' * 00166200 BE D1A * 00166300 CLI TEMP2,X'00' * 00166400 BE D1A * 00166500 MVI TEMP1,1 * 00166600 D1A SR 1,0 * 00166700 TM 1(1),X'40' * 00166800 BZ D1 * 00166900 CLI TEMP1,0 Q/ IS DIVISOR ZERO 00167000 BNE D2 NO, OK 00167100 MVI OVRFLO,1 YES, SET OVERFLOW INDICATOR 00167200 B NXTOP 00167300 D2 LR 6,12 FIND HIGH ORDER QUOTIENT LOCATION 00167400 AR 6,1 * 00167500 SR 6,11 * 00167600 SR 6,0 * 00167700 D3 MVI TEMP1,0 PREPARE TO COMPARE DIVISOR + DVDND 00167800 LR 1,11 00167900 LR 2,12 00168000 D4 IC 3,0(1) GET DIGITS 00168100 IC 4,0(2) * 00168200 N 3,=F'15' * 00168300 N 4,=F'15' * 00168400 CH 3,=H'10' Q/ ZERO 00168500 BNE *+6 NO 00168600 SR 3,3 YES, CLEAR IT 00168700 CH 4,=H'10' Q/ ZERO 00168800 BNE *+6 NO 00168900 SR 4,4 YES, CLEAR 00169000 CR 3,4 COMPARE 00169100 BE D5 EQUAL, DO NOT CHANGE INDICATOR 00169200 BH D4A A-DIGIT GREATER 00169300 MVI TEMP1,0 A-DIGIT LESS 00169400 B D5 * 00169500 D4A MVI TEMP1,1 SET A GREATER THAN B 00169600 D5 SR 1,0 DECREMENT FIELD POINTERS 00169700 SR 2,0 * 00169800 TM 1(1),X'40' Q/ END OF A-FIELD 00169900 BZ D4 NO 00170000 TM 0(2),X'0A' TEST 1 MORE DIVIDEND DIGIT 00170100 BO D6 ZERO 00170200 TM 0(2),X'0F' Q/ BLANK 00170300 BZ D6 YES, TREAT SAME AS ZERO 00170400 MVI TEMP1,0 1, DIVIDEND GREATER THAN DIVISOR 00170500 D6 CLI TEMP1,1 Q/ IS DIVISOR TOO LARGE 00170600 BE D10 YES 00170700 LR 1,11 SET REGISTERS FOR COMPLEMENT ADD 00170800 LR 2,12 * 00170900 LA 8,1 SET CARRY 00171000 D7 IC 5,0(2) GET B-FIELD DIGIT 00171100 N 5,=F'15' * 00171200 CH 5,=H'10' Q/ ZERO 00171300 BNE *+6 NO 00171400 SR 5,5 YES, CLEAR 00171500 LA 4,9 GET COMPLEMENT OF A-FIELD DIGIT 00171600 IC 3,0(1) * 00171700 N 3,=F'15' * 00171800 CH 3,=H'10' Q/ ZERO 00171900 BNE *+6 NO 00172000 SR 3,3 YES, CLEAR IT 00172100 SR 4,3 * 00172200 AR 5,4 ADD TO B-FIELD DIGIT 00172300 AR 5,8 ADD CARRY 00172400 LA 8,0 CLEAR CARRY 00172500 CH 5,=H'9' Q/ RESULT GREATER THAN 9 00172600 BNH D8 NO 00172700 SH 5,=H'10' YES, SUBTRACT 10 FROM RESULT 00172800 LA 8,1 SET CARRY 00172900 D8 STC 5,D9+1 STORE RESULT 00173000 NI 0(2),X'F0' * 00173100 CLI D9+1,X'00' Q/ RESULT ZERO 00173200 BNE D9 NO 00173300 OI D9+1,X'0A' YES, SET 8-2 BITS 00173400 D9 OI 0(2),0 * 00173500 SR 2,0 DECREMENT A- AND B-ADDRESSES 00173600 SR 1,0 * 00173700 TM 1(1),X'40' Q/ END OF A-FIELD 00173800 BZ D7 NO, PROCESS NEXT DIGIT 00173900 IC 3,0(2) YES, ADD 1 MORE DIVIDEND DIGIT 00174000 N 3,=F'15' * 00174100 CH 3,=H'10' Q/ ZERO 00174200 BNE *+6 NO 00174300 SR 3,3 YES, CLEAR IT 00174400 LA 3,9(3) * 00174500 AR 3,8 * 00174600 CH 3,=H'9' Q/ RESULT GREATER THAN 9 00174700 BNH D9A NO 00174800 SH 3,=H'10' YES, SUBTRACT 10 00174900 D9A STC 3,0(2) STORE RESULT 00175000 CLI 0(2),X'00' Q/ RESULT ZERO 00175100 BNE *+8 NO 00175200 MVI 0(2),X'0A' YES, SET 8-2 BITS 00175300 IC 3,0(6) ADD 1 TO QUOTIENT DIGIT 00175400 N 3,=F'15' * 00175500 CH 3,=H'10' Q/ ZERO 00175600 BNE *+6 NO 00175700 SR 3,3 YES, CLEAR IT 00175800 AR 3,0 * 00175900 STC 3,TEMP1 STORE RESULT 00176000 MVN 0(1,6),TEMP1 * 00176100 B D3 00176200 D10 TM 0(12),X'30' Q/ ZONE BITS 00176300 BC 5,D11 YES, DIVIDE DONE 00176400 AR 6,0 NO, UP REFERENCE TO NEXT DIGIT 00176500 AR 12,0 * 00176600 B D3 00176700 D11 IC 2,0(11) COMPARE DIVISOR AND DIVIDEND SIGNS 00176800 IC 3,0(12) * 00176900 N 2,=F'48' * 00177000 N 3,=F'48' * 00177100 SRDL 2,4 * 00177200 LA 4,SINTBL * 00177300 IC 2,0(4,2) * 00177400 IC 3,0(4,3) * 00177500 OI 0(6),X'30' SET QUOTIENT PLUS 00177600 CR 2,3 Q/ ARE SIGNS EQUAL 00177700 BE D12 YES, LEAVE QUOTIENT PLUS 00177800 NI 0(6),X'EF' UNEQUAL, SET QUOTIENT MINUS 00177900 D12 LR 11,1 SET A- AND B-ADDRESSES 00178000 SR 11,0 * 00178100 LR 12,6 * 00178200 B NXTOP 00178300 SINTBL DC X'00000100' 00178400 TITLE 'MODIFY ADDRESS' 00178500 USING MA,13 00178600 MA CH 9,=H'7' 00178700 BE MA1 00178800 CH 9,=H'1' 00178900 BE MAL4 00179000 CH 9,=H'4' 00179100 BNE ILEGLN 00179200 MA1 LA 6,1(10) 00179300 BAL 8,CVAD43 00179400 LR 11,5 00179500 LR 12,11 00179600 CH 9,=H'4' 00179700 BE MAL4 00179800 LA 6,4(10) 00179900 BAL 8,CVAD43 00180000 LR 12,5 00180100 MAL4 SH 11,=H'3' 00180200 SH 12,=H'3' 00180300 LA 0,15 UNITS 00180400 LA 1,0 * 00180500 IC 2,3(11) * 00180600 IC 3,3(12) * 00180700 NR 2,0 * 00180800 NR 3,0 * 00180900 CH 2,=H'10' 00181000 BNE *+6 00181100 SR 2,2 00181200 CH 3,=H'10' 00181300 BNE *+6 00181400 SR 3,3 00181500 AR 3,2 * 00181600 CH 3,=H'9' * 00181700 BNH MAL4A * 00181800 SH 3,=H'10' * 00181900 LA 1,1 * 00182000 MAL4A STC 3,MAL4B+1 * 00182100 NI 3(12),X'70' * 00182200 TM MAL4B+1,X'0F' 00182300 BC 5,MAL4B 00182400 OI MAL4B+1,X'0A' 00182500 MAL4B OI 3(12),0 * 00182600 IC 2,2(11) TENS 00182700 IC 3,2(12) * 00182800 NR 2,0 * 00182900 NR 3,0 $ 00183000 CH 2,=H'10' 00183100 BNE *+6 00183200 SR 2,2 00183300 CH 3,=H'10' 00183400 BNE *+6 00183500 SR 3,3 00183600 AR 3,2 * 00183700 AR 3,1 * 00183800 LA 1,0 * 00183900 CH 3,=H'9' * 00184000 BNH MAL4C * 00184100 SH 3,=H'10' * 00184200 LA 1,1 * 00184300 MAL4C STC 3,MAL4D+1 * 00184400 NI 2(12),X'70' SAVE B FLD INDEX AND WORD MARK BITS 00184500 TM MAL4D+1,X'0F' 00184600 BC 5,MAL4D 00184700 OI MAL4D+1,X'0A' 00184800 MAL4D OI 2(12),0 * 00184900 IC 2,1(11) HUNDREDS 00185000 IC 3,1(12) * 00185100 NR 2,0 * 00185200 NR 3,0 * 00185300 CH 2,=H'10' 00185400 BNE *+6 00185500 SR 2,2 00185600 CH 3,=H'10' 00185700 BNE *+6 00185800 SR 3,3 00185900 AR 3,2 * 00186000 AR 3,1 * 00186100 LA 1,0 * 00186200 CH 3,=H'9' * 00186300 BNH MAL4E * 00186400 SH 3,=H'10' * 00186500 LA 1,16 * 00186600 MAL4E STC 3,MAL4F+1 * 00186700 NI 1(12),X'70' * 00186800 TM MAL4F+1,X'0F' 00186900 BC 5,MAL4F 00187000 OI MAL4F+1,X'0A' 00187100 MAL4F OI 1(12),0 * 00187200 LA 0,48 THOUSANDS 00187300 IC 2,1(11) * 00187400 IC 3,1(12) * 00187500 NR 2,0 * 00187600 NR 3,0 * 00187700 AR 3,2 * 00187800 AR 3,1 * 00187900 LA 1,0 * 00188000 CH 3,=H'48' * 00188100 BNH MAL4G * 00188200 SH 3,=H'64' * 00188300 LA 1,16 * 00188400 MAL4G STC 3,MAL4H+1 * 00188500 NI 1(12),X'4F' * 00188600 MAL4H OI 1(12),0 * 00188700 IC 2,3(11) FOUR THOUSANDS 00188800 IC 3,3(12) * 00188900 NR 2,0 * 00189000 NR 3,0 * 00189100 AR 3,2 * 00189200 AR 3,1 * 00189300 CH 3,=H'48' * 00189400 BNH MAL4I * 00189500 SH 3,=H'64' * 00189600 MAL4I STC 3,MAL4J+1 * 00189700 NI 3(12),X'4F' * 00189800 MAL4J OI 3(12),0 * 00189900 B NXTOP 00190000 TITLE 'STORE A-ADDRESS REGISTER' 00190100 USING SAR,13 00190200 SAR CH 9,=H'4' 00190300 BNE ILEGLN 00190400 LR 12,11 00190500 LA 6,1(10) 00190600 BAL 8,CVAD43 00190700 LR 11,5 00190800 ST 12,ADR360 00190900 BAL 8,CVAD34 00191000 SH 11,=H'3' 00191100 NC 1(3,11),=X'404040' 00191200 OC 1(3,11),ADR140 00191300 B NXTOP 00191400 TITLE 'STORE B-ADDRESS REGISTER' 00191500 USING SBR,13 00191600 SBR CH 9,=H'4' 00191700 BE SBRL4 00191800 CH 9,=H'1' 00191900 BE SBRL1 00192000 CH 9,=H'7' 00192100 BNE ILEGLN 00192200 LA 6,4(10) 00192300 BAL 8,CVAD43 00192400 LR 12,5 00192500 SBRL4 LA 6,1(10) 00192600 BAL 8,CVAD43 00192700 LR 11,5 00192800 ST 12,ADR360 00192900 BAL 8,CVAD34 00193000 SBRL1 SH 11,=H'3' 00193100 NC 1(3,11),=X'404040' 00193200 OC 1(3,11),ADR140 00193300 B NXTOP 00193400 TITLE 'MOVE CHARACTERS TO RCD MARK OR GROUP MARK - WORD MARK' 00193500 USING MCM,13 00193600 MCM CH 9,=H'1' 00193700 BE MCML1 00193800 CH 9,=H'7' 00193900 BNE ILEGLN 00194000 LA 6,1(10) 00194100 BAL 8,CVAD43 00194200 LR 11,5 00194300 LA 6,4(10) 00194400 BAL 8,CVAD43 00194500 LR 12,5 00194600 MCML1 NI MCMSW+1,X'0F' 00194700 LR 6,11 A-FIELD PTR 00194800 MCMSCAN TRT 0(256,6),TRTGMWRM SCAN FOR GMWM - RM - RMWM 00194900 BNZ MCMHIT 00195000 LA 6,256(6) 00195100 B MCMSCAN 00195200 MCMHIT SR 1,11 COMPUTE RECORD LENGTH 00195300 LA 1,1(1) BUMP FOR TERM CHAR 00195400 CH 1,=H'256' TOTAL LENGTH GT 256 00195500 BNH MCMDECR NO 00195600 OI MCMSW+1,X'F0' YES - SET SW FOR MULTIPLE MOVES 00195700 LR 3,1 00195800 MCM256 LA 1,256 00195900 MCMDECR BCTR 1,0 DECREMENT FOR EX INSTRUCTIONS 00196000 EX 1,MCMCHMOV MOVE RECORD TO WORK AREA 00196100 EX 1,MCMCHCLR CLEAR RECEIVING AREA EXCEPT WM 00196200 EX 1,MCMWMCLR ELIMINATE WORD MARKS IN WORK AREA 00196300 EX 1,MCMCHORC OR DATA BITS (BA8421) INTO REC AREA 00196400 LA 1,1(1) 00196500 AR 11,1 00196600 AR 12,1 00196700 MCMSW NOP MCMBUMP SW SET IF RECORD GT 256 BYTES 00196800 B NXTOP TO NEXT 1401 INSTRUCTION 00196900 MCMBUMP SR 3,1 COMPUTE BYTES REMAINING 00197000 CH 3,=H'256' Q / BYTES REMAINING GT 256 00197100 BH MCM256 YES 00197200 LR 1,3 00197300 NI MCMSW+1,X'0F' TURN OFF SWITCH 00197400 B MCMDECR MOVE REMAINING BYTES 00197500 * 00197600 MCMCHCLR NC 0(0,12),WM256 00197700 MCMCHMOV MVC WORK256(0),0(11) 00197800 MCMWMCLR NC WORK256(0),STRIPWM 00197900 MCMCHORC OC 0(0,12),WORK256 00198000 * 00198100 WORK256 DC CL256' ' 00198200 TRTGMWRM DC 26X'00' MCM SCAN TABLE 00198300 DC X'1A' RECORD MARK - A8 2 00198400 DC 63X'00' 00198500 DC X'5A' RECORD MARK WORD MARK - M A8 2 00198600 DC 36X'00' W 00198700 DC X'7F' GROUP MARK WORD MARK - MBA8421 00198800 DC 128X'00' 00198900 STRIPWM DC 256X'3F' 00199000 TITLE 'BRANCH IF BIT EQUAL' 00199100 USING BBE,13 00199200 BBE CH 9,=H'1' 00199300 BE BBEL1 00199400 CH 9,=H'8' 00199500 BNE ILEGLN 00199600 LA 6,1(10) 00199700 BAL 8,CVAD43 00199800 LR 11,5 00199900 LA 6,4(10) 00200000 BAL 8,CVAD43 00200100 LR 12,5 00200200 MVC DCHAR(1),7(10) 00200300 NI DCHAR,X'BF' 00200400 BBEL1 SH 12,=H'1' 00200500 MVC TEMP1,DCHAR 00200600 NC TEMP1(1),1(12) 00200700 BZ NXTOP 00200800 LR 10,11 00200900 LA 9,0 00201000 B NXTOP 00201100 PRINT ON TITLE 'I N I T A L I Z E' BEGIN SAVE (14,12) SAVE CONTROL PROGRAMS REGISTERS 00201300 BALR 15,0 LOAD BASE REGISTERS 00201400 SETBS1 L 14,BASE2 * 00201500 ST 13,SAVEAREA+4 SAVE CONTROL PROGRAMS REGISTER 13 00201600 LR 5,1 SAVE PARM ADDRESS STM 13,15,MACREGSV SAVE MACRO REGS LA 6,MACREGSV SAVE ADDRESS TO XR LA 13,SAVEAREA GIVE OS OUR SAVE AREA SPACE AIF ('&TAPE' EQ 'Y').YESTO OPEN (PRNTDCB,(OUTPUT),CARD,,PUNCHR,(OUTPUT), X SYSPDCB,(OUTPUT)) .YESTO ANOP AIF ('&TAPE' EQ 'N').NOTO OPEN (PRNTDCB,(OUTPUT),CARD,,PUNCHR,(OUTPUT), X TAPEDCB0,,TAPEDCB1,,TAPEDCB2,,TAPEDCB3,,TAPEDCB4,, X TAPEDCB5,, X SYSPDCB,(OUTPUT)) .NOTO ANOP LM 13,15,0(6) SPACE EXTRACT TIOTADDR,FIELDS=TIOT LM 13,15,0(6) L 3,TIOTADDR USING TIOT,3 MVC SYSPBUFF+1(8),TIOCNJOB MVC SYSPBUFF+10(8),TIOCSTP SPACE GETMAIN R,LV=16020 GET CORE FOR 1401 SIMULATED CORE LM 13,15,0(6) RESTORE MACRO REGISTERS LR 7,1 * A 1,=F'15999' STORE UPPER LIMIT OF 1401 CORE ST 1,SIMLIMIT * CLR LA 2,SIMCOR LA 3,64 CLR1 XC 0(250,2),0(2) LA 2,250(2) BCT 3,CLR1 L 1,=F'16010' AR 1,7 MVI 0(1),X'7F' AIF ('&TAPE' EQ 'N').NOTA LA 1,100 CLEAR L 2,TAPEAREA TAPE CLEAR XC 0(256,2),0(2) AREA LA 2,256(2) BCT 1,CLEAR .NOTA ANOP SPACE MVI PRNTBUFF,X'8B' RESTORE PRINT FORM IMMEDIATELY BAL 8,WRITEC * BAL 8,READF READ FIRST CD OR SET EOF CARD TITLE 'N O C O N S O L E C O M M A N D S U P P O R T' AIF ('&CONSOLE' EQ 'Y').YESCNSL AIF ('&TAPE' EQ 'N').QTL CLI PARM+10,C'T' BE TPLOAD .QTL ANOP B CDLOAD WTORTN B TERMINAT SPACE .YESCNSL ANOP TITLE 'C O N S O L E C O M M A N D S U P P O R T' AIF ('&CONSOLE' EQ 'N').NOCONSL SPACE WTORTN XC RQSTIN,RQSTIN 00203400 MVC OKWTOR+16(17),SYSPBUFF+1 STM 13,15,MACREGSV SAVE MACRO REGS 00203600 LA 6,MACREGSV SAVE ADDRESS TO XR 00203700 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00203800 OKWTOR WTOR ' SIM1401 A002 OK', RQSTIN,50,WTECB 00204000 LM 13,15,0(6) RESTORE MACRO REGISTERS 00204100 MVC SYSPBUFF+1(50),RQSTIN STM 13,15,MACREGSV LA 13,SAVEAREA LA 6,MACREGSV PUT SYSPDCB,SYSPBUFF LM 13,15,0(6) MVC SYSPBUFF+27(58),=CL58' ' SPACE TESTA STM 13,15,MACREGSV SAVE MACRO REG 00204200 LA 6,MACREGSV SAVE ADDRESS TO XR 00204300 LA 13,SAVEAREA 00204400 WAIT 1,ECB=WTECB WAIT FOR RESPONSE 00204500 LM 13,15,0(6) RESTORE MACRO REG 00204600 XC WTECB,WTECB CLEAR ECB 00204700 SPACE TR RQSTIN,TYPTBL 21610 CLC RQSTIN(3),=C'SSS' 00208600 BE SSIN 00208700 CLC RQSTIN(3),=C'LDC' 00209000 BE CDLOAD 00209100 CLC RQSTIN(3),=C'SRS' 00209400 BE STRST 00209500 CLC RQSTIN(3),=C'STT' 00209600 BE START 00209700 CLC RQSTIN(3),=C'CLR' 00209800 BE CLR 00209900 CLC RQSTIN(3),=C'DIS' 00210000 BE DIS 00210100 CLC RQSTIN(3),=C'ALT' 00210200 BE ALT 00210300 CLC RQSTIN(3),=C'TRM' 00210800 BE TERMINAT 00210900 AIF ('&TAPE' EQ 'N').NOTCMD CLC RQSTIN(3),=C'LDT' 00209200 BE TPLOAD 00209300 CLC RQSTIN(3),=C'WTM' 00210400 BE WTMCMD 00210500 CLC RQSTIN(3),=C'RWD' 00210600 BE RWDCMD 00210700 .NOTCMD ANOP SNDILG XC RQSTIN,RQSTIN ZERO OUT REPLY AREA 00211000 MSG 'A004 ILLEGAL ENTRY',A004 21790 B WTORTN SPACE * THIS SECTION WILL SIMULATE THE START PUSHBUTTON. IF THE 00213000 * OPERATOR COMMAND STT IS FOLLOWED BY AN ADDRESS, THE 1401 PROGRAM 00213100 * WILL RESUME FROM THAT ADDRESS. HOWEVER, IF STT IS NOT FOLLOWED 00213200 * BY ANYTHING, THE 1401 PROGRAM WILL RESUME FROM WHERE IT STOPPED. 00213300 * 00213400 START CLI OKSTT,1 00213500 BNE START4 00213600 LA 5,RQSTIN+3 Q/ IS THERE A START ADDRESS 00213700 CLI 0(5),0 * 00213800 BNE START1 YES, START FROM THERE 00213900 L 8,RETURN 00214000 BR 8 00214100 START1 CLI 0(5),0 Q/ END OF MESSAGE 00214200 BE START2 YES 00214300 CLI 0(5),C'0' NO, IS IT NUMERIC 00214400 BL SNDILG NO, ERROR 00214500 LA 5,1(5) YES, TRY NEXT BYTE 00214600 B START1 * 00214700 START2 S 5,=A(RQSTIN+4) GET LENGTH - 1 00214800 CH 5,=H'4' Q/ LENGTH GT 5 DIGITS 00214900 BH SNDILG YES, ERROR 00215000 STC 5,TEMP1 CONVERT TO BINARY 00215100 MVN START3+1(1),TEMP1 * 00215200 START3 PACK PAKT,RQSTIN+3(0) * 00215300 CVB 4,PAKT * 00215400 CH 4,=H'15999' Q/ ADDRESS GT 15999 00215500 BH SNDILG YES, ERROR 00215600 AR 4,7 NO, GO THERE 00215700 LR 10,4 * 00215800 LA 9,0 * 00215900 B NXTOP * 00216000 START4 XC RQSTIN,RQSTIN ZERO OUT REPLY AREA 00216100 MSG 'A006 CANNOT START, NO PGM LOADED',A006 22180 B WTORTN * 00217000 * THIS SECTION WILL SIMULATE THE START-RESET PUSHBUTTON. 00217100 * 00217200 STRST LR 6,10 00217300 AR 6,9 00217400 ST 6,ADR360 00217500 MVI TPERR,0 00217600 MVI TPEOF,0 00217700 MVI OVRFLO,0 00217800 MVI CPR,0 00217900 B WTORTN 00218000 * 00218100 * THIS SECTION SIMULATES THE SETTING OF SENSE SWITCHES BY SETTING 00222200 * INDICATORS IN CORE BASED UPON THE SSS INPUT COMMAND. THE 00222300 * ROUTINES THAT SIMULATE THE BSS INSTRUCTIONS WILL TEST THESE 00222400 * INDICATORS. 00222500 * 00222600 SSIN LA 6,RQSTIN+3 REFERENCE FIRST SENSE SWITCH 00222700 XC TSSA(7),TSSA CLEAR TEMPORARY SENSE SWITCHES 00222800 LA 5,8 SET TO SCAN 8 SETTINGS MAX 00222900 SSIN1 CLI 0(6),0 Q/ DONE 00223000 BE SSEND YES, MOVE THEM 00223100 CLI 0(6),C'A' Q/ IS THIS SENSE SWITCH LEGAL 00223200 BL SNDILG NO CLI 0(6),C'G' 00223400 BH SNDILG NO IC 4,0(6) YES 00223600 N 4,=F'7' SET TEMPORARY SENSE SWITCH 00223700 LA 2,TSSA-1 * 00223800 AR 2,4 * 00223900 MVI 0(2),1 * 00224000 LA 6,1(6) REFERENCE NEXT INPUT CHARACTER 00224100 BCT 5,SSIN1 Q/ ARE THERE TOO MANY INPUT CHARACTERS 00224200 B SNDILG YES SSEND MVC SENSEA(7),TSSA 00224400 B WTORTN TSSA DS 7C TEMPORARY SENSE SWITCHES 00224600 * 00237000 * THIS SECTION WILL DISPLAY ON THE PRINTER THE HUNDREDS GROUP 00237100 * OF 1401 CORE REFERENCED IN THE OPERATOR COMMAND DIS . 00237200 * 00237300 DIS LA 5,RQSTIN+3 00237400 DIS1 CLI 0(5),X'00' 00237500 BE DIS2 00237600 CLI 0(5),C'0' 00237700 BL SNDILG 00237800 LA 5,1(5) 00237900 B DIS1 00238000 DIS2 LR 2,5 00238100 SH 2,=H'2' 00238200 CLC 0(2,2),=C'00' 00238300 BNE SNDILG 00238400 S 5,=A(RQSTIN+4) 00238500 CH 5,=H'4' 00238600 BH SNDILG 00238700 STC 5,DIS3+1 00238800 MVC DSMRKR+1(20),WM256 00238900 DIS3 MVC DSMRKR+9(0),RQSTIN+3 MOVE ADDR FOR PRINTING 00239000 STC 5,TEMP1 00239100 MVN DIS4+1(1),TEMP1 00239200 DIS4 PACK PAKT,RQSTIN+3(0) 00239300 CVB 4,PAKT 00239400 CH 4,=H'15900' 00239500 BH SNDILG 00239600 MVC PRNTBUFF(133),DSMRKR BAL 8,WRITEC AR 4,7 ADD IN ADDRESS OF 1401 SIMCORE 00239700 MVC PRNTBUFF+1(20),WM256 00239900 MVC PRNTBUFF+21(100),0(4) 00240000 TR PRNTBUFF+21(100),TRIE CHANGE PRINT AREA TO EBCDIC 00240100 MVC PRNTBUFF+121(11),WM256 * 00240200 BAL 8,WRITEC 23040 MVC PRNTBUFF+21(100),0(4) CHANGE WORD MARKS TO EBCDIC IS 00241000 TR PRNTBUFF+21(100),TRWDMK * 00241100 BAL 8,WRITEC 23130 B WTORTN 00241400 DSMRKR DC X'09',20X'40' 00241500 DC C'0.......09........19........29........39........49.' 00241600 DC C'.......59........69........79........89........99' 00241700 DC C' ' 00241800 * 00241900 * THIS SECTION WILL MODIFY THE 1401 CORE LOCATION REFERENCED IN 00242000 * THE OPERATOR COMMAND ALT . 00242100 * 00242200 ALT LA 6,RQSTIN+3 00242300 ALT1 CLI 0(6),C',' 00242400 BE ALT2 00242500 CLI 0(6),C'0' 00242600 BL SNDILG 00242700 LA 6,1(6) 00242800 B ALT1 00242900 ALT2 LR 5,6 00243000 S 5,=A(RQSTIN+4) 00243100 CH 5,=H'4' 00243200 BH SNDILG 00243300 STC 5,TEMP1 00243400 MVN ALT3+1(1),TEMP1 00243500 ALT3 PACK PAKT,RQSTIN+3(0) 00243600 CVB 4,PAKT 00243700 CH 4,=H'15999' 00243800 BH SNDILG 00243900 AR 4,7 00244000 MVC 0(1,4),1(6) 00244100 TR 0(1,4),TREI 00244200 CLI 2(6),C'M' 00244300 BNE WTORTN 00244400 OI 0(4),X'40' 00244500 B WTORTN 00244600 SPACE RQSTIN DS CL50 00211800 WTECB DC F'0' 00204900 .NOCONSL ANOP TITLE 'C O M M O N C O M M A N D S U P P O R T' * THIS SECTION WILL SIMULATE THE 1402 CARD LOAD PUSHBUTTON. 00212000 * 00212100 CDLOAD XC SIMCOR+1(80),SIMCOR+1 00212200 BAL 8,READ 00212300 OI SIMCOR+1,X'40' 00212400 LA 10,SIMCOR+1 00212500 LA 9,0 00212600 MVI OKSTT,1 00212700 B NXTOP 00212800 SPACE * THIS ROUTINE OUTPUTS MESSAGES ON SYSPRINT AND CONSOLE, IF SUPPORTED * CALL SEQUENCE IS * BAL 4,WTO * DC AL2(L'MSG-1) *MSG DC 'MESSAGE' SPACE * THIS CAN BE GENERATED BY THE 'MSG' MACRO * MSG 'MESSAGE ',MSG SPACE WTO SR 5,5 IC 5,1(4) PICK UP LENGTH CH 5,=H'57' BNH WTOEX LH 5,=H'57' WTOEX EX 5,WTOMVC MOVE MESSAGE TO SYSPBUFF AIF ('&CONSOLE' EQ 'N').WTONO2 MVC WTOWTO+15(85),SYSPBUFF+1 MOVE TO WTO STM 13,15,MACREGSV LA 13,SAVEAREA LA 6,MACREGSV PRINT GEN WTOWTO WTO ' X ' PRINT NOGEN LM 13,15,0(6) .WTONO2 ANOP STM 13,15,MACREGSV LA 13,SAVEAREA LA 6,MACREGSV PUT SYSPDCB,SYSPBUFF LM 13,15,0(6) MVC SYSPBUFF+27(58),=CL58' ' LA 4,4(5,4) N 4,=X'FFFFFFFE' BR 4 WTOMVC MVC SYSPBUFF+27(0),2(6) SPACE * THIS ROUTINE WILL TERMINATE THE SIMULATOR UPON THE OPERATOR * ENTRY 'TRM'. SPACE TERMINAT LR 1,7 STM 14,15,MACREGSV 23515 LA 13,SAVEAREA LA 6,MACREGSV 23525 FREEMAIN R,LV=16020,A=(1) LM 14,15,0(6) 23535 CLOSE (PRNTDCB,,SYSPDCB,,PUNCHR,,CARD) L 13,4(13) RETURN (14,12) TITLE 'ROUTINE TO BRANCH TO NEXT OPCODE PROCESSING ROUTINE' 00273800 * BEFORE BRANCHING, SET THE B ADDRESS REGISTER TO THE ADDRESS OF 00250800 * THE INSTRUCTION AFTER THE BRANCH, THEN SET THE INSTRUCTION 00250900 * COUNTER TO THE BRANCH ADDRESS, AND BRANCH. 00251000 * 00251100 SETBCH BAL 8,CVAD43 CONVERT BRANCH ADDRESS 00251200 LR 12,10 LOAD B ADDRESS 00251300 AR 12,9 * 00251400 ST 10,LSTBCH SAVE LAST BRANCHED FROM LOCATION 00251500 LR 10,5 LOAD BRANCH ADDRESS 00251600 LA 9,0 * 00251700 SPACE * THIS SECTION EXAMINES THE NEXT OPERATION CODE AND, BASED UPON IT, 00274000 * BRANCHES TO THE PROPER ROUTINE TO PROCESS THE INSTRUCTION. 00274100 * 00274200 NXTOP AR 10,9 GET NEW OP CODE LOCATION 00274300 TM 0(10),X'40' Q/ IS THERE A WORD MARK 00274400 BZ ILEGOP NO 00274500 LA 1,250(10) 00274600 TRT 1(250,10),TRTB 00274700 LR 9,1 00274800 SR 9,10 00274900 IC 2,0(10) GET OP CODE 00275000 N 2,=F'63' ELIMINATE WORD MARK 00275100 SLL 2,2 MULTIPLY BY 4 00275200 L 13,BCHTBL(2) LOAD BASE OF PROCESSING ROUTINE 00275300 BR 13 BRANCH TO OPCODE PROCESSING ROUTINE 00275400 BCHTBL DC A(ILEGOP) 0 00275500 DC A(R) 1 1 00275600 DC A(W) 2 2 00275700 DC A(WR) 3 3 00275800 DC A(P) 4 4 00275900 DC A(RP) 5 5 00276000 DC A(WP) 6 6 00276100 DC A(WRP) 7 7 00276200 DC A(NXTOP) 10 8 00276300 DC A(NXTOP) 11 9 00276400 DC A(ILEGOP) 12 0 00276500 DC A(MA) 13 = 00276600 DC A(M) 14 @ 00276700 DC A(ILEGOP) 15 00276800 DC A(ILEGOP) 16 00276900 DC A(ILEGOP) 17 TP MK 00277000 DC A(ILEGOP) 20 A BIT 00277100 DC A(CS) 21 / 00277200 DC A(A) 22 S 00277300 DC A(ILEGOP) 23 T 00277400 AIF ('&TAPE' EQ 'Y').CUOK DC A(ILEGOP) 24 U .CUOK ANOP AIF ('&TAPE' EQ 'N').NOTCU DC A(CU) 24 U 00277500 .NOTCU ANOP DC A(BWZ) 25 V 00277600 DC A(BBE) 26 W 00277700 DC A(NXTOP) 27 X 00277800 DC A(MZ) 30 Y 00277900 DC A(MCS) 31 Z 00278000 DC A(ILEGOP) 32 \ 00278100 DC A(SW) 33 , 00278200 DC A(D) 34 % 00278300 DC A(ILEGOP) 35 WD SEP 00278400 DC A(ILEGOP) 36 00278500 DC A(ILEGOP) 37 00278600 DC A(ILEGOP) 40 - 00278700 DC A(ILEGOP) 41 J 00278800 DC A(SS) 42 K 00278900 DC A(LCA) 43 L 00279000 DC A(MCW) 44 M 00279100 DC A(NXTOP) 45 N 00279200 DC A(ILEGOP) 46 O 00279300 DC A(MCM) 47 P 00279400 DC A(SAR) 50 Q 00279500 DC A(ILEGOP) 51 R 00279600 DC A(ZS) 52 -0 00279700 DC A(ILEGOP) 53 $ 00279800 DC A(ILEGOP) 54 * 00279900 DC A(ILEGOP) 55 00280000 DC A(ILEGOP) 56 00280100 DC A(ILEGOP) 57 00280200 DC A(ILEGOP) 60 + 00280300 DC A(A) 61 A 00280400 DC A(B) 62 B 00280500 DC A(C) 63 C 00280600 DC A(MN) 64 D 00280700 DC A(MCE) 65 E 00280800 DC A(CC) 66 F 00280900 DC A(ILEGOP) 67 G 00281000 DC A(SBR) 70 H 00281100 DC A(ILEGOP) 71 I 00281200 DC A(ZA) 72 +0 00281300 DC A(H) 73 . 00281400 DC A(CW) 74 00281500 DC A(ILEGOP) 75 00281600 DC A(ILEGOP) 76 00281700 DC A(ILEGOP) 77 00281800 SPACE TRTB DC 64X'00',64X'F1',64X'00',64X'F1' 00291000 TITLE 'ADDRESS CONVERSION SUBROUTINES' 00256500 * SUBROUTINE TO CONVERT A 1401 ADDRESS TO A 360 ADDRESS 00256700 * 00256800 CVAD43 MVI IXTMP,0 00256900 LR 5,7 LOAD SIMULATED CORE BASE INTO 5 00257000 CVAD4A IC 3,0(6) 1000'S + 100'S 00257100 N 3,=F'63' * 00257200 SLL 3,1 * 00257300 AH 5,TBHNTH(3) * 00257400 IC 3,2(6) 4000'S + 1'S 00257500 N 3,=F'63' * 00257600 SLL 3,1 * 00257700 AH 5,TBT4UN(3) * 00257800 IC 3,1(6) 10'S 00257900 N 3,=F'15' * 00258000 SLL 3,1 * 00258100 AH 5,TBTENS(3) * 00258200 TM 1(6),X'30' Q/ INDEXING 00258300 BE CVAD4D NO, DONE 00258400 CLI IXTMP,1 Q/ SECOND TIME THROUGH 00258500 BE CVAD4D YES, DONE 00258600 MVI IXTMP,1 SET SECOND TIME INDICATOR 00258700 TM 1(6),X'30' Q/ IX3 00258800 BO CVAD4C IX3 00258900 TM 1(6),X'20' 00259000 BO CVAD4B IX2 00259100 LA 6,SIMCOR+87 IX1 00259200 B CVAD4A 00259300 CVAD4B LA 6,SIMCOR+92 00259400 B CVAD4A 00259500 CVAD4C LA 6,SIMCOR+97 00259600 B CVAD4A 00259700 CVAD4D C 5,SIMLIMIT Q/ IS ADDRESS GREATER THAN 15999 00259800 BCR 12,8 NO, DONE 00259900 SH 5,=H'16000' YES, SUBTRACT 16000 00260000 BR 8 00260100 IXTMP DS C 00260400 TBHNTH DC H'0,100,200,300,400,500,600,700,800,900' 00289200 DC 6H'0' 00289300 DC H'0,1100,1200,1300,1400,1500,1600,1700,1800,1900,1000' 00289400 DC 5H'0' 00289500 DC H'0,2100,2200,2300,2400,2500,2600,2700,2800,2900,2000' 00289600 DC 5H'0' 00289700 DC H'0,3100,3200,3300,3400,3500,3600,3700,3800,3900,3000' 00289800 DC 5H'0' 00289900 TBT4UN DC H'0,1,2,3,4,5,6,7,8,9' 00290000 DC 6H'0' 00290100 DC H'0,4001,4002,4003,4004,4005,4006,4007,4008,4009,4000' 00290200 DC 5H'0' 00290300 DC H'0,8001,8002,8003,8004,8005,8006,8007,8008,8009,8000' 00290400 DC 5H'0' 00290500 DC H'0,12001,12002,12003,12004,12005,12006,12007,12008' 00290600 DC H'12009,12000,0,0,0,0,0' 00290700 TBTENS DC H'0,10,20,30,40,50,60,70,80,90' 00290800 DC 6H'0' 00290900 * 00260700 * SUBROUTINE TO CONVERT A 360 ADDRESS TO A 1401 ADDRESS 00260800 * 00260900 CVAD34 L 5,ADR360 00261000 SR 5,7 SUBTRACT SIMULATED CORE BASE 00261100 LA 4,0 4000'S ZONE 00261200 D 4,=F'4000' * 00261300 SLL 5,4 * 00261400 LR 1,5 * 00261500 LR 5,4 1000'S ZONE 00261600 LA 4,0 * 00261700 D 4,=F'1000' * 00261800 SLL 5,4 * 00261900 LR 2,5 * 00262000 LR 5,4 100'S NUMERIC 00262100 LA 4,0 * 00262200 D 4,=F'100' * 00262300 OR 5,2 * 00262400 STC 5,ADR140 * 00262500 LR 5,4 10'S NUMERIC 00262600 LA 4,0 * 00262700 D 4,=F'10' * 00262800 STC 5,ADR140+1 * 00262900 OR 4,1 * 00263000 STC 4,ADR140+2 * 00263100 TM ADR140,X'0F' Q/ IS HUNDREDS ZERO 00263200 BC 5,CVAD3A NO 00263300 OI ADR140,X'0A' YES, ADD 8-2 BITS 00263400 CVAD3A TM ADR140+1,X'0F' Q/ IS TENS ZERO 00263500 BC 5,CVAD3B NO 00263600 OI ADR140+1,X'0A' YES, ADD 8-2 BITS 00263700 CVAD3B TM ADR140+2,X'0F' Q/ IS UNITS ZERO 00263800 BCR 5,8 NO, RETURN 00263900 OI ADR140+2,X'0A' YES, ADD 8-2 BITS 00264000 BR 8 RETURN 00264100 TITLE 'ROUTINES TO HELP UNIT RECORD OPERATIONS' 00264200 READ CLI CRDEOF,X'01' HAVE WE READ LAST CARD 00264900 BNE READ2 BRANCH IF NO 00265000 MSG 'I005 READ TRIED AFTER LAST CARD ',I005 25480 B WTORTN 25530 READ2 TR TMPARA(80),TREI CHANGE EBCDIC TO INTERNAL 1401 CODE 00265700 NC SIMCOR+1(80),WM256 REMOVE CARD AREA INFO, KEEP WD MKS 00265800 OC SIMCOR+1(80),TMPARA 00265900 LA 12,SIMCOR+81 00266000 READF STM 13,15,MACREGSV SAVE REGS 25640 LA 6,MACREGSV SAVE ADDRESS TO XR 00266200 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00266300 GET CARD,TMPARA READ CARD 00266400 LM 13,15,0(6) RESTORE MACRO REGISTERS 00266500 NI SIMCOR,X'40' SET BA BITS IN LOC 0 AFTER READ 00266600 OI SIMCOR,X'30' * 00266700 BR 8 00266800 SPACE 25715 EOC LM 13,15,0(6) RESTORE SIMULATOR REGISTERS 00266900 MVI CRDEOF,X'01' SET CARD EOF INDICATOR 00267000 BR 8 00267100 SPACE 25745 WRITE MVC PRNTBUFF+1(132),SIMCOR+201 00267200 TR PRNTBUFF+1(132),TRIE 00267300 WRITEC STM 13,15,MACREGSV SAVE MACRO REG 25770 LA 6,MACREGSV SAVE ADDRESS TO XR 00267500 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00267600 PUT PRNTDCB,PRNTBUFF 00267700 LM 13,15,0(6) RESTORE MACRO REGISTERS 00267800 TR PRNTBUFF(1),LINSKP CONVERT CONTROL CHAR TO LINE COUNT CLI PRNTBUFF,X'FF' Q. SKIP TO CHANNEL BE WRITEP YES, SET NEW PAGE AP LINCUR,PRNTBUFF(1) CP LINCUR,LINMAX BL WRITED MVI PRTP12,1 SET CH 12 INDICATOR B WRITED WRITEP SP LINCUR,LINCUR INIT NEW PAGE MVI PRTP12,0 WRITED MVI PRNTBUFF,X'09' SET SINGLE SPACE 25880 LA 12,SIMCOR+333 SET B ADDRESS REGISTER 00268000 BR 8 00268100 LINSKP DC X'FF',P'0',7X'FF',P'1',X'FF',P'1',4X'FF' 25920 DC X'FF',P'2',X'FF',P'2',5X'FF',P'3',X'FF',P'3',4X'FF' DC 224X'FF' SPACE 25845 PUNCH MVC PCHARA,SIMCOR+101 CONVERT 1401 PUNCH AREA FOR OUTPUT 00268200 TR PCHARA,TRIE * 00268300 STM 13,15,MACREGSV SAVE MACRO REGS 00268400 LA 6,MACREGSV SAVE ADDRESS TO XR 00268500 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00268600 PUT PUNCHR,PCHARA 00268700 LM 13,15,0(6) RESTORE MACRO REGISTERS 00268800 LA 12,SIMCOR+181 00268900 NI SIMCOR+100,X'40' SET 82 BITS IN LOC 100 AFTER PUNCH 00269000 OI SIMCOR+100,X'0A' * 00269100 BR 8 00269200 TITLE ' E R R O R S ' 25960 ILEGOP MSG 'I008 ILLEGAL OP CODE',I008 26080 B PANEL 00253000 SPACE 14036305 ILEGLN MSG 'I009 ILLEGAL LENGTH',I009 26150 SPACE 26085 PANEL LR 1,10 00253600 SR 1,7 00253700 CVD 1,PAKT 00253800 UNPK PNLWTOR+04(6),PAKT+5(3) MVZ PNLWTOR+09(1),=C'0' MVC PNLWTOR+19(1),0(10) NI PNLWTOR+19,X'BF' TR PNLWTOR+19(1),TRIE CVD 9,PAKT UNPK PNLWTOR+33(6),PAKT+5(3) MVZ PNLWTOR+38(1),=C'0' MVI PNLWTOR+40,X'80' MVC PNLWTOR+41(1),PNLWTOR+40 CH 9,=H'8' BH WTORPNL LTR 3,9 BZ WTORPNL SH 3,=H'1' STC 3,PANEL1+1 PANEL1 MVC PNLWTOR+40(0),0(10) TR PNLWTOR+40(8),TRIE WTORPNL MSG ' I OP LENGTH INST X ',PNLWTOR B WTORTN TITLE 'DATA CONVERSION TRANSLATE TABLES' 00289100 TREI DC 64X'00' 00291100 DC X'00000000000000000000003B3C3D3E3F' 00291200 DC X'30000000000000000000002B2C2D2E2F' 00291300 DC X'20110000000000000000001B1C1D1E1F' 00291400 DC X'201100000000000000000A0B0C0D0E0F' 00291500 DC 64X'00' 00291600 DC X'3A313233343536373839000000000000' 00291700 DC X'2A212223242526272829000000000000' 00291800 DC X'1A001213141516171819000000000000' 00291900 DC X'0A010203040506070809000000000000' 00292000 TRIE DC X'40F1F2F3F4F5F6F7F8F9F07B7C7D7E7F' 00292100 DC X'F061E2E3E4E5E6E7E8E9E06B6C6D6E6F' 00292200 DC X'60D1D2D3D4D5D6D7D8D9D05B5C5D5E5F' 00292300 DC X'50C1C2C3C4C5C6C7C8C9C04B4C4D4E4F' 00292400 DC X'40F1F2F3F4F5F6F7F8F9F07B7C7D7E7F' 00292500 DC X'F061E2E3E4E5E6E7E8E9E06B6C6D6E6F' 00292600 DC X'60D1D2D3D4D5D6D7D8D9D05B5C5D5E5F' 00292700 DC X'50C1C2C3C4C5C6C7C8C9C04B4C4D4E4F' 00292800 TR4IBC DC 16AL1(*-TR4IBC) 00292900 DC X'00' 00293000 DC 47AL1(*-TR4IBC) 00293100 TRI4BC DC X'10' 00293200 DC 63AL1(*-TRI4BC) 00293300 DC X'10' 00293400 DC 63AL1(*-64-TRI4BC) 00293500 TRWDMK DC 64X'40' 00293700 DC 64C'1' 00293800 TYPTBL DC 129AL1(*-TYPTBL) 00293900 DC C'ABCDEFGHI' 00294000 DC XL7'00' 00294100 DC C'JKLMNOPQR' 00294200 DC XL8'00' 00294300 DC C'STUVWXYZ' 00294400 DC 86AL1(*-TYPTBL) 00294500 TITLE 'C O N S T A N T S && L I T E R A L S' ADR360 DS F 00260200 ADR140 DS CL3 00260300 AEND DC X'0' 00283600 BCDTAP DS C INDICATOR FOR BCD TAPE MODE 00284200 CPR DC X'00' 00283100 CRDEOF DC X'00' CARD END-OF-FILE INDICATOR 00283400 DCHAR DS C 00283200 LINCUR DC PL2'1' LINMAX DC PL2'0' LSTBCH DS F TO HOLD ADDRESS OF LAST BRANCH 00283300 MACREGSV DS 18F 00285500 ONOFF DC 213X'00',X'01',42X'00' OKSTT DC X'00' OVRFLO DC X'0' RESET WHEN TESTED 00283000 PAKT DS D 00285000 DS 0F 00285100 PARM DS CL11 ABCDEFGLLLX PCHARA DS CL80 PUNCH OUTPUT AREA 00284700 PCHERR DC X'00' PUNCH ERROR INDICATOR 00284300 PRNTBUFF DC X'09' 00285200 DC CL132' ' 00285300 PRTP12 DC X'0' 00282700 PRTERR DC X'00' PRINTER ERROR INDICATOR 00284500 RDRERR DC X'00' CARD READ ERROR INDICATOR 00284400 RETURN DS F 00286600 SAVEAREA DS 18F 00285400 SAVCSW DS D 00285600 SENSEA DC X'0' 00282000 SENSEB DC X'0' 00282100 SENSEC DC X'0' 00282200 SENSED DC X'0' 00282300 SENSEE DC X'0' 00282400 SENSEF DC X'0' 00282500 SENSEG DC X'0' 00282600 SIMLIMIT DC F'0' UPPER LIMIT OF SIMULATED CORE 00283800 SUPRES DC X'00' ZERO SUPPRESSION INDICATOR 00284000 SYSPBUFF DC X'09' DC CL85' SIM1401' 27250 TEMP1 DS C 00260500 TEMP2 DS C 00260600 TIOTADDR DS A TMPARA DS CL80 00284600 TPEOF DC X'0' RESET WHEN TESTED 00282900 TPERR DC X'0' 00282800 TRGPWM DC 127X'00',X'7F',128X'00' WM256 DC 256X'40' 00284900 SPACE PRNTDCB DCB MACRF=PM,DSORG=PS,DDNAME=WRITE,LRECL=133 00288600 SYSPDCB DCB MACRF=PM,DSORG=PS,DDNAME=SYSPRINT,LRECL=133 PUNCHR DCB MACRF=PM,DSORG=PS,RECFM=F,BLKSIZE=80,LRECL=80, X00288700 DDNAME=CARDOUT 00288800 CARD DCB MACRF=GM,DSORG=PS,RECFM=F,BLKSIZE=80,LRECL=80, X00288900 DDNAME=CARDIN,EODAD=EOC 00289000 SPACE LTORG 00294700 SPACE SIMCOR DSECT 00294800 DS CL16020 00294900 CSECT TITLE 'T A P E I / O S U P P O R T' AIF ('&TAPE' EQ 'N').NOTAPE AIF ('&CONSOLE' EQ 'N').RWD * THIS SECTION SIMULATES THE LOAD TAPE PUSHBUTTON. 00218200 * 00218300 TPLOAD LA 10,=X'00000001' 00218400 BAL 8,FNDRIV 00218500 ST 3,TMDCB 00218600 MVC TPCCW,=A(LDTCCW) 00218700 MVI TMIOB,X'44' 00218800 STM 13,15,MACREGSV SAVE MACRO REGS 00218900 LA 6,MACREGSV SAVE ADDRESS TO XR 00219000 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00219100 EXCP TMIOB 00219200 LM 14,15,4(6) RESTORE REG 14 AND 15 00219300 WAIT 1,ECB=TMECB WAIT FOR I/O 00219400 LM 13,15,0(6) RESTORE MACRO REGISTERS 00219500 LH 1,TMIOB+14 LOAD BYTE COUNT FROM CSW 00219600 LH 2,=H'20000' 00219700 SR 2,1 00219800 LA 3,SIMCOR+1 00219900 L 1,TAPEAREA 00220000 TPLD1 CLI 0(1),X'1D' 00220100 BNE TPLD2 00220200 LA 1,1(1) 00220300 MVC 0(1,3),0(1) 00220400 TR 0(1,3),TR4IBC 00220500 OI 0(3),X'40' 00220600 SH 2,=H'1' 00220700 B TPLD3 00220800 TPLD2 MVC 0(1,3),0(1) 00220900 TR 0(1,3),TR4IBC 00221000 TPLD3 LA 1,1(1) 00221100 LA 3,1(3) 00221200 BCT 2,TPLD1 00221300 NI 0(3),X'40' 00221400 OI 0(3),X'3F' 00221500 LA 12,1(3) 00221600 LA 10,SIMCOR+1 00221700 LA 9,0 00221800 MVI OKSTT,1 00221900 B NXTOP 00222000 * 00222100 * THIS SECTION WILL WRITE A TAPE MARK ON THE TAPE DRIVE 00244800 * SELECTED BY THE WTM COMMAND. 00244900 * 00245000 WTMCMD NI RQSTIN+3,X'0F' GET DEVICE ADDRESS 00245100 LA 10,RQSTIN * 00245200 BAL 8,FNDRIV * 00245300 ST 3,TMDCB 00245400 MVC TPCCW,=A(WTMCCW) 00245500 STM 13,15,MACREGSV SAVE MACRO REGS 00245600 LA 6,MACREGSV SAVE ADDRESS TO XR 00245700 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00245800 EXCP TMIOB 00245900 LM 14,15,4(6) RESTORE REG 14 AND 15 00246000 WAIT 1,ECB=TMECB WAIT FOR I/O 00246100 LM 13,15,0(6) RESTORE MACRO REGISTERS 00246200 B WTORTN 00246300 * 00246400 * THIS SECTION WILL REWIND THE TAPE SELECTED BY THE RWD COMMAND 00249200 * 00249300 RWDCMD NI RQSTIN+3,X'0F' GET DEVICE ADDRESS 00249400 LA 10,RQSTIN * 00249500 BAL 8,FNDRIV * 00249600 ST 3,TMDCB 00249700 MVC TPCCW,=A(RWDCCW) 00249800 MVI TMIOB,X'04' 00249900 STM 13,15,MACREGSV SAVE MACRO REGS 00250000 LA 6,MACREGSV SAVE ADDRESS TO XR 00250100 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00250200 EXCP TMIOB 00250300 LM 14,15,4(6) RESTORE REG 14 AND 15 00250400 WAIT 1,ECB=TMECB WAIT FOR I/O 00250500 LM 13,15,0(6) RESTORE MACRO REGISTERS 00250600 B WTORTN 00250700 .RWD ANOP SPACE FNDRIV IC 3,3(10) 14038090 BCTR 3,0 SUBTRACT ONE 00271000 N 3,=F'7' 14038110 SLL 3,3 MULTIPLY LOGICAL DRIVE NUMBER BY 8 00271200 A 3,=A(TAPADR) ADD BASE OF TAPE ADDRESS TABLE 00271300 L 3,4(3) GET ACTUAL TAPE ADDRESS FROM TABLE 00271400 USING IHADCB,3 TM DCBOFLGS,X'10' BNZ FNDRIV2 SPACE 14036245 MSG 'I007 UNDEFINED TAPE',I007 B PANEL 00252400 SPACE FNDRIV2 MVI TMECB,0 CLEAR ECB BEFORE EXCP 00271500 NI 0(3),X'3F' CLEAR DCB EXCEPTION BITS 00271600 MVI TMIOB,X'42' SET IOB CMD CHAIN + UNRELATED BITS 00271700 BR 8 00271800 SPACE 14038185 FNDLNG LR 6,12 00269400 FNDLGA TRT 0(256,6),TRGPWM SCAN FOR GP MK - WD MK 00269500 BC 6,FNDLGB FOUND 00269600 LA 6,256(6) 00269700 B FNDLGA 00269800 FNDLGB LR 6,1 CALCULATE LENGTH 00269900 SR 6,12 * 00270000 BR 8 00270100 SPACE 14038015 TPTEST MVC SAVCSW+1(7),TPCSW SAVE CSW AFTER TAPE OPERATION 00271900 TM SAVCSW+4,1 Q/ EOF 00272000 BZ TPTIO1 00272100 LH 4,=H'24999' 00272200 STH 4,SAVCSW+6 00272300 L 4,TAPEAREA PUT TAPE MARK CHARACTER IN TAPE AREA 00272400 MVI 0(4),X'0F' * 00272500 MVI TPEOF,1 00272600 TPTIO1 MVI TPERR,0 00272700 TM SAVCSW+4,2 Q/ TAPE ERROR 00272800 BCR 8,8 00272900 MVI TPERR,1 00273000 BR 8 00273100 SPACE 14038315 CU CH 9,=H'5' 00150100 BNE ILEGLN 00150200 CLI 4(10),X'29' 00150300 BE RWD 00150400 CLI 4(10),X'24' 00150500 BE WTM 00150600 CLI 4(10),X'14' 00150700 BE RWU 00150800 CLI 4(10),X'32' 00150900 BE BSP 00151000 CLI 4(10),X'35' 00151100 BE SKP 00151200 B ILEGOP 00151300 RWD MVI CUCCW,X'07' 00151400 B CU1 00151500 WTM MVI CUCCW,X'1F' 00151600 B CU1 00151700 BSP MVI CUCCW,X'27' 00151800 B CU1 00151900 SKP MVI CUCCW,X'17' 00152000 CU1 BAL 8,FNDRIV 00152100 ST 3,CUDCB 00152200 MVI CUECB,0 00152300 MVI CUIOB,X'42' SET COMMAND CHAIN + UNRELATED BITS 00152400 STM 13,15,MACREGSV SAVE MACRO REGS 00152500 LA 6,MACREGSV SAVE ADDRESS TO XR 00152600 LA 13,SAVEAREA GIVE OS OUR SAVE AREA 00152700 EXCP CUIOB 00152800 LM 14,15,4(6) RESTORE REG 14 AND 15 00152900 WAIT 1,ECB=CUECB 00153000 LM 13,15,0(6) RESTORE MACRO REGISTERS 00153100 B NXTOP 00153200 RWU IC 2,3(10) GET 1401 DRIVE NUMBER 00153300 N 2,=F'7' * 00153400 BCTR 2,0 SUBTRACT 1 00153500 SLL 2,3 REFERENCE TAPADR TABLE ENTRY 14025670 L 4,TAPADR+4(2) GET DCB ADDRESS 00154000 STM 14,15,MACREGSV SAVE BASE REGISTERS LA 6,MACREGSV * 00273300 LA 13,SAVEAREA * 00273400 CLOSE ((4)) CLOSE THE DCB 00273500 LM 14,15,0(6) 00273600 B NXTOP 00273700 CUCCWMS CCW X'63',0,X'60',1 MODE SET 00154300 CUCCW CCW 0,0,X'20',1 00154400 TMIOB DS 0D 00247800 DC X'42' 00247900 DC 4X'00' 00248000 DC AL3(TMECB) 00248100 DC X'00' 00248200 TPCSW DC 7X'00' 00248300 TPCCW DC XL4'00' ADDRESS OF CCW FOR TAPE OPERATION 00248400 TMDCB DC XL4'00' DCB ADDRESS FOR TAPE DRIVE SELECTED 00248500 DC 4X'00' 00248600 DC 2X'00' 00248700 DC 2X'00' 00248800 TMECB DS 0F 00248900 DC 4X'00' 00249000 TAPEAREA DC A(SIMTAPE) ADDRESS OF TAPE I/O BUFFER SPACE WTCCW1 CCW X'63',1,X'60',1 00285800 WTCCW2 CCW 1,SIMTAPE,X'20',0 LDTCCW CCW X'63',0,X'60',1 00286000 RTCCW CCW 0,0,X'60',1 READ TAPE 00286200 RTCCW1 CCW 2,SIMTAPE,X'20',25000 WTMCCW CCW X'1F',0,X'20',1 WRITE TAPE MARK 00286400 RWDCCW CCW X'07',0,X'20',1 REWIND 00286500 CUIOB DS 0D 00286700 DC X'02' 00286800 DC 4X'00' 00286900 DC AL3(CUECB) 00287000 DC 8X'00' 00287100 DC AL4(CUCCWMS) 00287200 CUDCB DC F'0' 00287300 DC 8X'00' 00287400 CUECB DC F'0' 00287500 * 00287600 * THIS TABLE EQUATES A 360 TAPE DRIVE TO A 1401 TAPE DRIVE AS A 00287700 * RESULT OF A TAS ENTRY. 00287800 * 00287900 TAPADR DC A(0,TAPEDCB0) 00288000 DC A(0,TAPEDCB1) 00288100 DC A(0,TAPEDCB2) 00288200 DC A(0,TAPEDCB3) 00288300 DC A(0,TAPEDCB4) 00288400 DC A(0,TAPEDCB5) 00288500 LTORG TAPEDCB0 DCB MACRF=(E),DSORG=PS,DEVD=TA,DDNAME=TAPE1 14035720 TAPEDCB1 DCB MACRF=(E),DSORG=PS,DEVD=TA,DDNAME=TAPE2 14035730 TAPEDCB2 DCB MACRF=(E),DSORG=PS,DEVD=TA,DDNAME=TAPE3 14035740 TAPEDCB3 DCB MACRF=(E),DSORG=PS,DEVD=TA,DDNAME=TAPE4 14035750 TAPEDCB4 DCB MACRF=(E),DSORG=PS,DEVD=TA,DDNAME=TAPE5 14035760 TAPEDCB5 DCB MACRF=(E),DSORG=PS,DEVD=TA,DDNAME=TAPE6 14035770 SIMTAPE DS CL25600 .NOTAPE ANOP TITLE 'S Y S T E M C O N T R O L B L O C K S' TIOT DSECT TIOCNJOB DS CL8 JOB TIOCSTP DS CL8 PROC DS CL8 PROC STEP * F O R E A C H D D E N T R Y TIOELNGH DS FL.8 DS CL3 TIOEDDNM DS CL8 DD NAME DS CL4 * F O R E A C H D E V I C E TIOESTTB DS CL1 TIOEFSRT DS AL.24 UCB ADDRESS SPACE DCBD DSORG=PS,DEVD=TA SPACE UCB DSECT DS CL12 UCBWGT DS CL1 UCBNAME DS CL3 END BEGIN // EXEC ASF *// //C.SYSIN DD DSN=CACTR683.SIM1401,DISP=OLD *// /*