github.com/moshix.mvs
1
0
Fork 0
mirror of https://github.com/moshix/mvs.git synced 2026-01-11 23:43:00 +00:00
Code Issues Releases Wiki Activity
moshix.mvs/a1401.txt
moshix a24be27d53
in-line documentation
2017-10-29 09:55:45 +02:00

2982 lines
220 KiB
Plaintext
Raw Blame History

//HERC01A JOB (BAL),
// '1401 EMULATOR',
// CLASS=A,
// MSGCLASS=H,
// TIME=1440,REGION=6M,
// MSGLEVEL=(1,1),
// USER=HERC01,PASSWORD=CUL8TR
//** **************************************************************
//** THIS IS AN IBM 1401 EMULATOR
//** IT DOES NOT PRESENTLY ASSEMBLE PROPERLY, BUT WORKING ON IT
//* IT'S HERE ONLY FOR HISTORICAL VALUE, NOT FOR PRACTICAL VALUE
//** **************************************************************
//A1401 EXEC ASMFCG,PARM.ASM=(OBJ,NODECK),MAC1='SYS2.MACLIB',
// REGION.GO=1228K,PARM.GO='/2000'
//**DDX DD DSN=HERC01.SIM1401,
//** VOL=SER=PUB001,
//** SPACE=(TRK,1),
//** DISP=(MOD,DELETE)
//**STEP2 EXEC PGM=IEBUPDTE,PARM=NEW,REGION=40K
//SYSPRINT DD SYSOUT=*
//**SYSUT2 DD DSN=HERC01.A1401,
//** VOL=SER=PUB001,
//** SPACE=(7200,40,RLSE),
//** DCB=(RECFM=FBS,BLKSIZE=7200,LRECL=80),
//** DISP=(NEW,CATLG)
//ASM.SYSIN DD *
* 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=HERC01.SIM1401,DISP=OLD *//
/*
Reference in New Issue View Git Blame Copy Permalink