C PROTEIN DATA BANK SOURCE CODE TORSRU C AUTHOR. G.REEKE C ENTRY DATE. 9/79 UNSUPPORTED C LAST REVISION. 9/79 C PURPOSE. COMPLETE TORSION ANGLES C LANGUAGE. FORTRAN IV, ASSEMBLER(IBM 360/ C LANGUAGE. 370) C C C C TORSION ANGLE DISTRIBUTION PROGRAM 00000100 C C C INSTRUCTIONS FOR TORSION C C C AUTHOR. GEORGE N. REEKE C ROCKEFELLER UNIVERSITY C 1230 YORK AVENUE C NEW YORK, NEW YORK 10021 C 212-360-1339 C C C INTRODUCTION C C THIS PROGRAM READS ONE OR MORE COORDINATE FILES FROM MAGNETIC C TAPE IN BROOKHAVEN DATABANK FORMAT OR IN THE FORMAT OF THE ROCKS C CRYSTALLOGRAPHIC PROGRAM SYSTEM. ALL STANDARD DIHEDRAL ANGLES ARE C CALCULATED, THE ANGLES CAN BE PRINTED INDIVIDUALLY AND/OR C SUMMARIZED IN A SERIES OF BAR GRAPHS. AN EXTRA SET OF BAR GRAPHS C IS ALWAYS PRINTED AT THE END GIVING THE DISTRIBUTIONS OF ANGLES C FOR ALL PROTEINS EXAMINED IN THE RUN. CONTROL CARDS DETERMINE THE C FILES TO BE READ AND THE OUTPUT OPTIONS. C C THE PROGRAM RUNS IN 72K BYTES OF STORAGE AND REQUIRES LESS C THAN 2 SECONDS PER PROTEIN ON AN IBM 3033 COMPUTER. C C C INPUT C C COORDINATES ARE READ FROM ONE OR MORE FILES ON UNIT 8. INPUT C SHOULD CONSIST OF 80-COLUMN RECORDS BLOCKED AS DESIRED IN FIXED OR C FIXED-BLOCKED RECORD FORMAT. RECORDS ON UNIT 8 MAY BE AS DEFINED C FOR THE BROOKHAVEN DATA BANK OR MAY CONSIST SOLELY OF ROCKS C COORD CARDS AS DEFINED IN THE ROCKS STRUCTURE FACTOR PROGRAM. C COORD CARDS ARE READ IN FIXED FORMAT, NOT SCANNED. NO SPECIAL C INDICATION MUST BE GIVEN OF WHICH TYPE OF INPUT IS USED. C C ON IBM SYSTEMS, THE DD CARD FOR UNIT 8 SHOULD BE CALLED C FT08F000 FOR ACCESS TO MULTIPLE FILES WITH ONE DD CARD. IF THE C SPECIAL VERSION OF ICHFIOCS SUPPLIED IS NOT USED, THE USER SHOULD C SUPPLY CARDS FT08FNNN FOR EACH FILE TO BE READ, NNN = 001, 002, C ..., AND SHOULD PUNCH THE ONEFILE OPTION ON THE CONTROL CARDS (SEE C BELOW). C C OPTIONS OF THE PROGRAM ARE CONTROLLED BY CARDS (OR CARD- C EQUIVALENTS) READ FROM UNIT 5. THERE ARE THREE TYPES OF CONTROL C CARDS AND THESE MAY BE ENTERED IN ANY ORDER AS NEEDED. C C 1. TITLE CARD C C THIS CARD HAS THE WORD TITLE IN COLS. 1-5 AND ANY DESIRED C INFORMATION IN THE REST OF THE CARD. THE CONTENTS OF COLS. 6-66 C ARE PRINTED AS A TITLE AT THE TOP OF EACH PAGE OF OUTPUT UNTIL C ANOTHER TITLE CARD IS READ, AS LONG AS INPUT IS IN ROCKS FORMAT. C WITH DATABANK FORMAT, THE NAME OF EACH PROTEIN STORED IN THE C DATABANK FILE REPLACES THE TITLE EVERY TIME A NEW FILE IS C OPENED. C C 2. CELL CARD C C THIS CARD HAS THE WORD CELL IN COLS. 1-4 AND THE UNIT CELL C DIMENSIONS A,B,C, ALPHA, BETA, GAMMA IN COLS. 7-78 IN FORMAT C 6F12.5. WITH ROCKS FORMAT, A CELL CARD MUST BE ENTERED TO C PERMIT ORTHOGONALIZATION OF FRACTIONAL COORDINATES. WITH DATA- C BANK INPUT, THE COORDINATES ARE ALREADY ORTHOGONALIZED, SO NO C CELL CARDS ARE REQUIRED. THE CELL DIMENSIONS ENTERED ARE USED C UNTIL ANOTHER CELL CARD IS READ OR UNTIL A DATABANK FILE IS C READ. C C 3. FILE AND OPTION CONTROL CARD C C ANY CARD NOT BEGINNING WITH TITLE OR CELL IS ASSUMED TO BE A C TYPE 3 CARD. THE CARD MAY BE IN FREE FORMAT, WITH ANY OF THE C FOLLOWING OPTIONS APPEARING IN ANY ORDER. EACH OPTION APPLIES C UNTIL CHANGED. OPTIONS MAY BE PUNCHED IN COLS. 1-71 AND PRE- C CEDED OR FOLLOWED BY ONE OR MORE BLANKS. CARDS MAY BE CONTINUED C BY ENDING WITH A COMMA AND BEGINNING THE FOLLOWING CARD IN COLS. C 5-16. OPTIONS... C C N. N REPRESENTS AN INTEGER. WHEN AN INTEGER N IS READ, THE C INPUT TAPE IS POSITIONED TO FILE N AND THE DATA IN THAT FILE C ARE PROCESSED USING THE OPTIONS CURRENTLY IN EFFECT. C SCANNING OF THE CONTROL CARD THEN RESUMES AT THE NEXT C OPTION. C C ONEFILE. WHEN THIS OPTION IS ENCOUNTERED, THE NEXT INPUT FILE C IS PROCESSED. ON IBM SYSTEMS, THE SPECIAL TAPE POSITIONING C FACILITY IS NOT USED SO A SEPARATE FT08FNNN DD CARD MUST BE C PROVIDED FOR EACH FILE PROCESSED. THE N AND ONEFILE OPTIONS C ARE MUTUALLY EXCLUSIVE WITHIN ONE JOB -- USE ONE STYLE OF C INPUT ONLY. C C LIST. TURNS ON THE LISTING OF INDIVIDUAL TORSION ANGLES. C C NOLIST. TURNS OFF THE LISTING OF INDIVIDUAL TORSION ANGLES. C C GRAPH. TURNS ON THE PLOTTING OF ANGLE DISTRIBUTION GRAPHS FOR C INDIVIDUAL PROTEINS. C C NOGRAPH. TURNS OFF THE PLOTTING OF ANGLE DISTRIBUTION GRAPHS C FOR INDIVIDUAL PROTEINS. C C INITIAL (DEFAULT) OPTIONS ARE NOLIST, NOGRAPH. THE ONLY DE- C FAULT OUTPUT IS THE FINAL DISTRIBUTION GRAPHS. GRAPH IS REDUNDANT C IF ONLY ONE FILE IS PROCESSED BECAUSE OF THE FINAL GRAPHS. C C C OUTPUT C C THE ONLY OUTPUT IS THE PRINTED LISTING OF ANGLES AND BAR C GRAPHS. A 132-COLUMN PRINTER IS ASSUMED. THIS OUTPUT IS PRODUCED C ON UNIT 6, WHICH ON IBM SYSTEMS REQUIRES A FT06F001 DD CARD. C C TORSION ANGLE LISTINGS ARE PRINTED ONE LINE PER RESIDUE, WITH C THE NAMES OF THE ANGLES LISTED ACROSS THE TOP OF EACH PAGE UNDER C THE PAGE TITLE. C C FOR CYSTEINES, CHI2, 3, AND 4 ARE PRINTED ONLY FOR THE SECOND C RESIDUE OF EACH LINKED PAIR DESCRIBED IN AN SSBOND RECORD. CHI3 C IS THE -S-S- DIHEDRAL ANGLE AND CHI4 IS CHI2 OF THE OTHER CYS. C C AT THE END OF THE LISTING FOR EACH PROTEIN, A MESSAGE IS C PRINTED OF THE FORM - I RESIDUES, J UNIDENTIFIED, K BAD ATOMS, L C MULTIPLE SITES, M SS BONDS, N MISSING ATOMS, WHERE I IS THE NUMBER C OF RESIDUES FOUND, J IS THE NUMBER OF RESIDUES WITH NAMES NOT C KNOWN TO THE PROGRAM (THESE ARE NOT PROCESSED), K IS THE NUMBER OF C ATOMS WITH NAMES NOT KNOWN TO THE PROGRAM (NOT PROCESSED, BUT THE C REST OF THE RESIDUE IS), L IS THE NUMBER OF ATOMS WITH COL. 17 OF C THE ATOM RECORD NON-BLANK (NOT PROCESSED), M IS THE NUMBER OF C SSBOND RECORDS PROCESSED (UP TO 20 PER PROTEIN), AND N IS THE C NUMBER OF DIHEDRAL ANGLES THAT COULD NOT BE CALCULATED BECAUSE OF C ONE OR MORE MISSING ATOMS. ALL ANGLES ARE CALCULATED FOR WHICH C THE FOUR DEFINING ATOMS ARE PRESENT IN THE INPUT. C C BAR GRAPHS ARE PRINTED FOR EACH INDIVIDUAL KIND OF TORSION C ANGLE. THEY ARE LABELLED AT THE LEFT WITH THE NAME OF THE AMINO C ACID. FOR EACH AMINO ACID, ANGLES ARE GRAPHED IN THE ORDER PHI, C PSI, CHI1, CHI2, CHI3, CHI4. NAMES OF THESE ANGLES ARE NOT C PRINTED. EACH BAR REPRESENTS A RANGE OF 15 DEG IN TORSION ANGLE C AND THE FIRST BIN STARTS AT -172.5 DEG. GRAPHS ARE NORMALIZED SO C THAT THE BIN WITH LARGEST OCCUPANCY IS A BAR OF FULL HEIGHT. C UNDER EACH BIN, THE NUMBER OF ANGLES FALLING IN THAT BIN IS PRINT- C ED, WITH THE DIGITS OF EACH NUMBER ARRANGED VERTICALLY, READING C DOWN THE PAGE. C C C ORTHOGONALIZATION C C ROCKS FORMAT COORDINATES ARE ORTHOGONALIZED ACCORDING TO C X = A X + B Y COS(GAMMA) + C Z COS(BETA) C Y = B Y SIN(GAMMA) - (V B* / A) Z COS(ALPHA*) C Z = (1 / C*) Z C THESE TRANSFORMATIONS ARE GENERAL AND APPLY TO ALL COORDINATE C SYSTEMS, INCLUDING TRICLINIC. C C C 00000200 C INPUT: 00000300 C 1) CONTROL CARDS ON UNIT 5 CONSISTING OF: 00000400 C A) OPTIONAL ROCKS 'TITLE' CARD 00000410 C B) ROCKS 'CELL' CARD IF COORDS MUST BE ORTHOGONALIZED 00000420 C C) LIST OF COORD FILES TO BE READ IN FREE FORM 00000430 C INTERMINGLED WITH FOLLOWING OPTIONS AS NEEDED: 00000440 C LIST NOLIST TO CONTROL LISTING OF ANGLES (DEFAULT: OFF) 00000450 C GRAPH NOGRAPH TO CONTROL DISTRIBUTION PLOTS (DEFAULT: OFF)00000460 C ONEFILE TO OMIT CALLING SETFIL, PROCESS ONE FILE 00000470 C 00000480 C 2) COORDINATES ON UNIT 8 (FT08F000 IF MULTIFILE, DSN = FILENNNN) 00000500 C IN DATABANK OR ROCKS (FIXED, NOT SCANNED) FORMAT 00000510 C 00000600 C OUTPUT: 00000700 C 1) LISTS OF REQUESTED TORSION ANGLES ON UNIT 6 00000790 C 2) BAR GRAPHS OF DISTRIBUTIONS ON UNIT 6 00000800 C 00000900 C SUBROUTINES NEEDED FROM ROCKS LIBRARY: SETFIL, TALK, JABR 00001000 C 00001100 C PRINCIPAL ARRAYS: 00001200 C MDIST,NDIST LOCAL,GLOBAL DISTRIBUTIONS 00001300 C KIND POINTERS TO BOND CODES FOR VARIOUS ANGLE TYPES 00001400 C ANAMES NAMES OF RECOGNIZABLE ATOMS 00001500 C ATYPES ATOM TYPE ASSOCIATED WITH EACH NAME 00001600 C AXYZ COORDS FILED BY ATOM TYPE 00001700 C AIN INDICATORS BY ATOM TYPE (TRUE IF ATOM FOUND) 00001800 C SNAMES NAMES OF RESIDUES IN SS BRIDGES 00001900 C SXYZ COORDS OF FIRST S OF SS BRIDGE 00002000 C SSIN,SSIN2... INICATORS FOR SS BRIDGES (TRUE IF 1ST S FOUND) 00002100 C RNAMES NAMES OF RECOGNIZED RESIDUES 00002200 C RPTRS POINTERS TO FIRST DIST BY RESIDUES 00002300 C RNUMS NUMBERS OF DISTRIBUTIONS BY RESIDUES 00002400 C KODES 4 ATOMS AND A RESTRICTION CODE FOR EACH BOND TYPE 00002500 C MCNT,NCNT LOCAL, GLOBAL ERROR COUNTS 00002600 C 00002700 LOGICAL*1 LINE,CNAME,LNBUF 00002800 COMMON DUMMY(8),CARD(20),IEXIT,IT1,IT2, 00002900 1 CELL(6),COSA(3),DUM2(6),SHH(6),LINE(136) 00002910 INTEGER ATYPES,RPTRS,RNUMS,BLSCAN,QPTRS,QNUMS 00003000 LOGICAL AIN,LIST,GRAPH,SSIN,SSIN2,SSIN3,SCYS,CELLRD,ONEFIL 00003100 DIMENSION MDIST(24,88),NDIST(24,88),KIND(88) 00003200 DIMENSION ANAMES(41),ATYPES(41) 00003300 DIMENSION AXYZ(3,10),AIN(10) 00003400 DIMENSION SNAMES(3,20),SXYZ(3,20),SSIN(20) 00003500 DIMENSION SXYZ2(3,20),SSIN2(20),SXYZ3(3,20),SSIN3(20) 00003600 DIMENSION RNAMES(24),RPTRS(24),RNUMS(24) 00003700 DIMENSION KODES(5,8),R(3,3) 00003800 DIMENSION MCNT(6),NCNT(6) 00003900 DIMENSION FIELD(4),DSN(2),INBUF(20),LNBUF(80),CNAME(10) 00004000 COMMON /RES/ QNAMES(24),QPTRS(24),QNUMS(24) 00004100 EQUIVALENCE (INBUF(1),LNBUF(1)) 00004200 EXTERNAL CRYIN,CDSCAN,BLSCAN,SETFIL,SETTIT,MOVE,CRYOUT, 00004300 1 BLANK,DIHED,BCDOUT,IBCDWT,BCDIN,CDPRNT,PDIST 00004400 C 00004500 C THE FOLLOWING TABLES ENCODE THE CONNECTIVITY OF PROTEINS 00004600 C (RESIDUES IN ALPHABETICAL ORDER BY ONE-LETTER CODES) 00004700 C 00004800 DATA KIND /1,2, 1,2,3,5, 1,2,3,4,6, 1,2,3,5, 1,2,3,4,7, 00004900 1 1,2,3,5, 1,2, 1,2,3,5, 1,2,3,4, 1,2,3,4,6,8, 1,2,3,4, 00005000 2 1,2,3,4,6, 1,2,3,5, 1,2, 1,2,3,4,7, 1,2,3,4,6,8, 1,2,3, 00005100 3 1,2,3, 1,2,3, 1,2,3,4, 1,2,3,5, 1,2,3,4,7 / 00005200 DATA ANAMES/'N ','CA ','C ','CB ','CG ','CG1 ', 00005300 1 'OG ','OG1 ','SG ','CD ','CD1 ','ND1 ','OD1 ','AD1 ', 00005400 2 'SD ','CE ','CE1 ','NE ','OE1 ','AE1 ','CZ ','NZ ', 00005500 3 'O ','CG2 ','CD2 ','ND2 ','OD2 ','AD2 ','CE2 ','CE3 ', 00005600 4 'NE1 ','NE2 ','OE2 ','AE2 ','CZ2 ','CZ3 ','CH2 ','NH1 ', 00005700 5 'NH2 ','OH ','OXT ' / 00005800 DATA ATYPES/2,3,4,5,5*6,6*7,5*8,2*9,19*0/ 00005900 DATA RNAMES/'ALA','ASX','CYS','ASP','GLU','PHE','GLY', 00006000 1 'HIS','ILE','LYS','LEU','MET','ASN','PRO','GLN','ARG', 00006100 2 'SER','THR','VAL','TRP','TYR','GLX','CYH','PR0'/ 00006200 DATA RPTRS/1,3,7,12,16,21,25,27,31,35,41,45,50, 00006300 1 54,56,61,67,70,73,76,80,84,7,54/ 00006400 DATA RNUMS/2,4,5,4,5,4,2,4,4,6,4,5,4,2,5,6,3,3,3, 00006500 1 4,4,5,4,2/ 00006600 DATA KODES/1,2,3,4,0, 2,3,4,10,0, 2,3,5,6,0, 00006700 1 3,5,6,7,0, 3,5,6,7,1, 5,6,7,8,0, 5,6,7,8,1, 6,7,8,9,0/ 00006800 DATA DSN/'FILE',' '/,F8P3/Z00030707/ 00006900 1 FORMAT(20A4) 00007000 C 00007100 C START PROGRAM. CLEAR GRAND COUNTERS 00007200 C 00007300 DO 5 I = 1,88 00007400 DO 5 J = 1,24 00007500 5 NDIST(J,I) = 0 00007600 DO 10 I = 1,6 00007700 10 NCNT(I) = 0 00007800 DO 15 J=1,24 00007900 QNAMES(J) = RNAMES(J) 00008000 QPTRS(J) = RPTRS(J) 00008100 15 QNUMS(J) = RNUMS(J) 00008200 IEXIT = 0 00008300 LIST = .FALSE. 00008400 GRAPH = .FALSE. 00008500 CELLRD = .FALSE. 00008510 ONEFIL = .FALSE. 00008520 IT1 = 8 00008600 C 00008700 C SCAN INPUT CARDS FOR FILE NUMBERS OF PROTEINS TO USE 00008800 C 00008900 45 CALL CRYIN(CARD) 00009000 CALL CMPARE(CARD,0,4,'END ',&900) 00009100 CALL CMPARE(CARD,0,4,'CELL',&80) 00009110 CALL CMPARE(CARD,0,4,'TITL',&95) 00009120 CALL CDSCAN(CARD,0) 00009200 50 IEND = BLSCAN(FIELD) 00009300 IF (IEND .GE. 32) GO TO 45 00009400 CALL CMPARE(FIELD,0,4,'LIST',&52) 00009500 CALL CMPARE(FIELD,0,4,'NOLI',&54) 00009600 CALL CMPARE(FIELD,0,4,'GRAP',&56) 00009700 CALL CMPARE(FIELD,0,4,'NOGR',&58) 00009800 CALL CMPARE(FIELD,0,4,'ONEF',&62) 00009810 GO TO 60 00009900 52 LIST = .TRUE. 00010000 GO TO 50 00010100 54 LIST = .FALSE. 00010200 GO TO 50 00010300 56 GRAPH = .TRUE. 00010400 GO TO 50 00010500 58 GRAPH = .FALSE. 00010600 GO TO 50 00010700 60 IFILE = IBCDIN(3591,FIELD) 00010800 C 00010900 C GOT ONE. OPEN FILE, READ NAME, ZERO DISTRIBUTIONS 00011000 C 00011100 IF(IFILE .LE. -2) IFILE = -1 00011200 DSN(2) = FIELD(1) 00011300 CALL SETFIL(IT1,IFILE,0,DSN) 00011400 62 READ(IT1,1) INBUF 00011500 CALL CMPARE(INBUF,0,4,'COOR',&63) 00011550 READ(IT1,1)INBUF 00011600 CALL SETTIT(INBUF) 00011700 63 CONTINUE 00011750 DO 65 I = 1,88 00011800 DO 65 J = 1,24 00011900 65 MDIST(J,I) = 0 00012000 DO 70 I = 1,6 00012100 70 MCNT(I) = 0 00012200 AIN(1) = .FALSE. 00012300 NSS = 0 00012400 IF(LIST)CALL CRYOUT('0 RESIDUE PHI PSI CHI1 CHI2 00012500 1 CHI3 CHI4',10811) 00012600 GO TO 102 00012604 C 00012610 C PROCESS 'CELL' CARD. PREPARE ORTHOGONALIZATION MATRIX 00012612 C 00012614 80 CALL CDPRNT 00012616 M = 6 00012618 DO 82 I=1,6 00012620 CALL MOVE(FIELD,0,12,CARD,M) 00012622 CELL(I) = BCDIN(329483,FIELD) 00012624 82 M = M + 12 00012626 IF (CELL(2) .EQ. 0.0) CELL(2) = CELL(1) 00012630 IF (CELL(3) .EQ. 0.0) CELL(3) = CELL(2) 00012632 DO 90 I=1,3 00012640 IF (CELL(I+3)) 87,84,87 00012642 84 CELL(I+3) = 90.0 00012644 COSA(I) = 0.0 00012646 GO TO 90 00012648 87 COSA(I) = COS(CELL(I+3)*1.7453292E-2) 00012650 90 CONTINUE 00012652 DETA = SQRT(1.0 - COSA(1)**2 - COSA(2)**2 - COSA(3)**2 00012660 & + 2.0*COSA(1)*COSA(2)*COSA(3)) 00012662 SING = SQRT(1.0 - COSA(3)**2) 00012664 R(1,1) = CELL(1) 00012666 R(2,1) = CELL(2)*COSA(3) 00012668 R(3,1) = CELL(3)*COSA(2) 00012670 R(1,2) = 0.0 00012672 R(2,2) = CELL(2)*SING 00012674 R(3,2) = (CELL(3)/SING)*(COSA(1)-COSA(2)*COSA(3)) 00012676 R(1,3) = 0.0 00012678 R(2,3) = 0.0 00012680 R(3,3) = (CELL(3)/SING)*DETA 00012682 CELLRD = .TRUE. 00012684 CALL LINES(5) 00012686 WRITE (6,92) R 00012688 92 FORMAT('0 ORTHOGONALIZATION MATRIX'/3(1X,3F9.4/)) 00012690 GO TO 45 00012692 95 CALL CDPRNT 00012694 CALL SETTIT 00012696 GO TO 45 00012698 C 00012700 C SEARCH FOR SSBOND CARDS AND RECORD THEM 00012800 C 00012900 100 READ(IT1,1,END=50)INBUF 00013000 102 CALL CMPARE(INBUF,0,4,'COOR',&150) 00013010 CALL CMPARE(INBUF,0,4,'ATOM',&150) 00013100 CALL CMPARE(INBUF,0,4,'SSBO',&110) 00013200 GO TO 100 00013300 110 NSS = NSS + 1 00013400 MCNT(5) = MCNT(5) + 1 00013500 IF(NSS .LE. 20) GO TO 115 00013600 GO TO 100 00013700 115 SSIN(NSS) = .FALSE. 00013800 SSIN2(NSS) = .FALSE. 00013900 SSIN3(NSS) = .FALSE. 00014000 CALL MOVE(SNAMES(1,NSS),0,1,INBUF,15) 00014100 CALL MOVE(SNAMES(1,NSS),1,5,INBUF,17) 00014200 CALL MOVE(SNAMES(1,NSS),6,1,INBUF,29) 00014300 CALL MOVE(SNAMES(1,NSS),7,5,INBUF,31) 00014400 GO TO 100 00014500 C 00014600 C PREPARE FOR NEW RESIDUE 00014700 C 00014800 150 DO 155 I = 2,10 00014900 155 AIN(I) = .FALSE. 00015000 CALL CMPARE(INBUF,0,4,'ATOM',&199) 00015005 C 00015010 C PROCESS A ROCKS 'COORD' CARD 00015012 C USE FIXED FORMAT BECAUSE BLSCAN ALREADY IN USE 00015014 C 00015016 CALL MOVE(CNAME,0,3,INBUF,6) 00015020 CALL BLANK(CNAME,3,7) 00015022 CALL MOVE(CNAME,6,3,INBUF,10) 00015024 IRES = IBCDIN(3586,LNBUF(11)) 00015026 MCNT(1) = MCNT(1) + 1 00015028 160 DO 165 IA=1,41 00015030 CALL CMPARE(INBUF,14,3,ANAMES(IA),&170) 00015035 165 CONTINUE 00015040 MCNT(3) = MCNT(3) + 1 00015042 GO TO 250 00015044 170 IT = ATYPES(IA) 00015050 IF (IT .LE. 0) GO TO 250 00015052 AIN(IT) = .TRUE. 00015054 DO 180 J=1,3 00015060 180 AXYZ(J,IT) = BCDIN(F8P3,LNBUF(9*J+17)) 00015062 IF (.NOT. CELLRD) GO TO 250 00015064 C ORTHOGONALIZE THE COORDS 00015070 AXYZ(1,IT) = R(1,1)*AXYZ(1,IT)+R(2,1)*AXYZ(2,IT)+R(3,1)*AXYZ(3,IT)00015072 AXYZ(2,IT) = R(2,2)*AXYZ(2,IT)+R(3,2)*AXYZ(3,IT) 00015074 AXYZ(3,IT) = R(3,3)*AXYZ(3,IT) 00015076 GO TO 250 00015080 199 CONTINUE 00015098 CALL MOVE(CNAME,0,10,INBUF,17) 00015100 IRES = IBCDIN(3587,LNBUF(23)) 00015200 MCNT(1) = MCNT(1) + 1 00015300 C 00015400 C PROCESS AN ATOM CARD. STORE COORDS UNDER PROPER TYPE 00015500 C 00015600 200 DO 210 IA = 1,41 00015700 CALL CMPARE(INBUF,13,3,ANAMES(IA),&220) 00015800 210 CONTINUE 00015900 MCNT(3) = MCNT(3) + 1 00016000 GO TO 250 00016100 220 CALL CMPARE(INBUF,16,1,' ',&225) 00016200 MCNT(4) = MCNT(4) + 1 00016300 GO TO 250 00016400 225 IT = ATYPES(IA) 00016500 IF (IT .LE. 0) GO TO 250 00016600 AIN(IT) = .TRUE. 00016700 DO 240 J = 1,3 00016800 240 AXYZ(J,IT) = BCDIN(F8P3,LNBUF(8*J+23)) 00016900 C 00017000 C READ A CARD. CHECK FOR ATOM RESIDUE ID 00017100 C 00017200 250 READ (IT1,1,END=800) INBUF 00017300 CALL CMPARE(INBUF,0,4,'COOR',&260) 00017310 CALL CMPARE(INBUF,0,4,'ATOM',&290) 00017400 GO TO 340 00017500 260 CALL CMPARE(CNAME,6,3,INBUF,10,&160) 00017502 C 00017510 C ROCKS FORMAT END OF RESIDUE. GET N FROM NEXT RESIDUE 00017512 C 00017514 CALL CMPARE(INBUF,14,3,ANAMES(1),&265) 00017520 GO TO 340 00017522 265 JRES = IBCDIN(3586,LNBUF(11)) 00017524 IF (JRES .NE. IRES+1) GO TO 340 00017526 DO 270 J=1,3 00017530 270 AXYZ(J,10) = BCDIN(F8P3,LNBUF(9*J+17)) 00017532 AIN(10) = .TRUE. 00017534 SCYS = .FALSE. 00017536 IF (.NOT. CELLRD) GO TO 340 00017538 C ORTHOGONALIZE THE COORDS 00017540 AXYZ(1,10) = R(1,1)*AXYZ(1,10)+R(2,1)*AXYZ(2,10)+R(3,1)*AXYZ(3,10)00017542 AXYZ(2,10) = R(2,2)*AXYZ(2,10)+R(3,2)*AXYZ(3,10) 00017544 AXYZ(3,10) = R(3,3)*AXYZ(3,10) 00017548 GO TO 340 00017550 290 CALL CMPARE(CNAME,0,10,INBUF,17,&200) 00017600 C 00017700 C END OF RESIDUE. GET N FROM NEXT RESIDUE 00017800 C 00017900 300 CALL CMPARE(INBUF,13,3,ANAMES(1),&305) 00018000 GO TO 340 00018100 305 JRES = IBCDIN(3587,LNBUF(23)) 00018200 CALL CMPARE(INBUF,26,1,' ',&310) 00018300 JRES = JRES + 1 00018400 310 IF (JRES .NE. IRES+1) GO TO 340 00018500 DO 320 J = 1,3 00018600 320 AXYZ(J,10) = BCDIN(F8P3,LNBUF(8*J+23)) 00018700 AIN(10) = .TRUE. 00018800 SCYS = .FALSE. 00018900 C 00019000 C CHECK FOR CYS. SAVE OR FETCH S ATOM TO COMPLETE S-S BOND 00019100 C 00019200 340 IF (NSS .LE. 0) GO TO 400 00019300 CALL CMPARE(CNAME,0,3,RNAMES(3),&350) 00019400 GO TO 400 00019500 350 IF (.NOT. AIN(6)) GO TO 400 00019600 DO 360 I = 1,NSS 00019700 CALL CMPARE(SNAMES(1,I),0,6,CNAME(5),&370) 00019800 CALL CMPARE(SNAMES(1,I),6,6,CNAME(5),&380) 00019900 360 CONTINUE 00020000 GO TO 400 00020100 370 DO 375 J = 1,3 00020200 SXYZ2(J,I) = AXYZ(J,5) 00020300 SXYZ3(J,I) = AXYZ(J,3) 00020400 375 SXYZ(J,I) = AXYZ(J,6) 00020500 SSIN2(I) = AIN(5) 00020600 SSIN3(I) = AIN(3) 00020700 SSIN(I) = .TRUE. 00020800 GO TO 400 00020900 380 DO 385 J = 1,3 00021000 AXYZ(J,8) = SXYZ2(J,I) 00021100 AXYZ(J,9) = SXYZ3(J,I) 00021200 385 AXYZ(J,7) = SXYZ(J,I) 00021300 AIN(7) = SSIN(I) 00021400 AIN(8) = SSIN2(I) 00021500 AIN(9) = SSIN3(I) 00021600 SCYS = AIN(9) 00021700 IF (.NOT.(AIN(7).AND.AIN(8).AND.AIN(9))) MCNT(6) = MCNT(6) + 1 00021800 C 00021900 C IDENTIFY CURRENT RESIDUE 00022000 C 00022100 400 DO 410 IR = 1,24 00022200 CALL CMPARE(CNAME,0,3,RNAMES(IR),&420) 00022300 410 CONTINUE 00022400 MCNT(2) = MCNT(2) + 1 00022500 GO TO 790 00022600 420 IP = RPTRS(IR) 00022700 NB = RNUMS(IR) 00022800 IF (SCYS) NB = NB + 1 00022900 IF (.NOT. LIST) GO TO 450 00023000 CALL MOVE(LINE,0,10,CNAME) 00023100 CALL BLANK(LINE,10,48) 00023200 C 00023300 C LOOP OVER DIHEDRAL ANGLES. CALCULATE AND ANALYZE 00023400 C 00023500 450 DO 600 IB = 1,NB 00023600 IK = KIND(IP) 00023700 IF ((.NOT.SCYS).OR.(IP.NE.12)) GO TO 460 00023800 IP =10 00023900 IK = 8 00024000 460 CONTINUE 00024100 I1 = KODES(1,IK) 00024200 I2 = KODES(2,IK) 00024300 I3 = KODES(3,IK) 00024400 I4 = KODES(4,IK) 00024500 IF (.NOT.(AIN(I1).AND.AIN(I2).AND.AIN(I3).AND.AIN(I4))) GO TO 580 00024600 ANGLE = DIHED(AXYZ(1,I1),AXYZ(1,I2),AXYZ(1,I3),AXYZ(1,I4),IER) 00024700 IF (IER .NE. 0) GO TO 590 00024800 IF (LIST) CALL BCDOUT(1799,LINE(8*IB+3),ANGLE) 00024900 IF (KODES(5,IK).GT.0.AND.ANGLE.LT.0.0) ANGLE = ANGLE + 180.0 00025000 IH = (ANGLE+187.5)/15.0 00025100 IF (IH.LE.0) IH = IH + 24 00025200 IF (IH.GT.24) STOP 1 00025300 MDIST(IH,IP) = MDIST(IH,IP) + 1 00025400 GO TO 600 00025500 580 IF (IB .LE. 2 .OR. IP .EQ. 10) GO TO 600 00025600 590 MCNT(6) = MCNT(6) + 1 00025700 600 IP = IP + 1 00025800 C 00025900 C PRINT ANGLES IF REQUESTED 00026000 C 00026100 IF (LIST) CALL CRYOUT(' ',2305,LINE,58) 00026200 C 00026300 C RESIDUE FINISHED. SAVE C-PRIME FOR NEXT ONE 00026400 C 00026500 IF (.NOT. AIN(4)) GO TO 620 00026600 DO 610 J = 1,3 00026700 610 AXYZ(J,1) = AXYZ(J,4) 00026800 620 AIN(1) = AIN(4) 00026900 GO TO 790 00027000 780 READ (IT1,1,END=800) INBUF 00027100 790 CALL CMPARE(INBUF,0,4,'ATOM',&150) 00027200 CALL CMPARE(INBUF,0,4,'COOR',&150) 00027210 GO TO 780 00027300 C 00027400 C PROTEIN COMPLETE. PRINT AND ACCUMULATE DISTRIBUTIONS 00027500 C 00027600 800 IF (GRAPH) CALL CRYOUT('0 ',10756) 00027700 DO 810 I = 1,6 00027800 CALL IBCDWT(3589,LINE(6*I-5),MCNT(I)) 00027900 810 CONTINUE 00028000 CALL CRYOUT(' ',2305,LINE(1),6,' RESIDUES,',10,LINE(7),6, 00028100 1 ' UNIDENTIFIED,',14,LINE(13),6,' BAD ATOMS,',11,LINE(19),6, 00028200 2 ' MULTIPLE SITES,',16,LINE(25),6,' SS BONDS,',10,LINE(31),6, 00028300 3 ' MISSING ATOMS',14,' ',2049) 00028400 IF (GRAPH) CALL PDIST(MDIST) 00028500 DO 820 I = 1,6 00028600 820 NCNT(I) = NCNT(I) + MCNT(I) 00028700 DO 825 I = 1,88 00028800 DO 825 J = 1,24 00028900 825 NDIST(J,I) = NDIST(J,I) + MDIST(J,I) 00029000 GO TO 50 00029100 C 00029200 C INPUT COMPLETE. PRINT CUMULATIVE DISTRIBUTIONS 00029300 C 00029400 900 CALL CRYOUT('0 ',10756) 00029500 DO 910 I = 1,6 00029600 CALL IBCDWT(3589,LINE(6*I-5),NCNT(I)) 00029700 910 CONTINUE 00029800 CALL CRYOUT('0CUMULATIVE TOTALS AND DISTRIBUTIONS',2596, 00029900 1 ' ',2305) 00030000 CALL CRYOUT(' ',2305,LINE(1),6,' RESIDUES,',10,LINE(7),6, 00030100 1 ' UNIDENTIFIED,',14,LINE(13),6,' BAD ATOMS,',11,LINE(19),6, 00030200 2 ' MULTIPLE SITES,',16,LINE(25),6,' SS BONDS,',10,LINE(31),6, 00030300 3 ' MISSING ATOMS',14) 00030400 CALL SETTIT(' DISTRIBUTION OF PROTEIN TORSION ANGLES 00030500 1 ') 00030600 C *** REMOVE FOLLOWING C FOR PRODUCTION *** 00030700 C DO 950 I = 1,3 00030800 CALL CRYOUT('0 ',10756) 00030900 CALL PDIST(NDIST) 00031000 950 CONTINUE 00031100 STOP 00031200 END 00031300 FUNCTION DIHED(XYZ1,XYZ2,XYZ3,XYZ4,IER) 00031400 C 00031500 C CALCULATE DIHEDRAL ANGLE FROM COORDS OF FOUR ATOMS 00031600 C 00031700 DIMENSION XYZ1(3),XYZ2(3),XYZ3(3),XYZ4(3) 00031800 DIMENSION V1(3),V2(3),V3(3),A(3),B(3) 00031900 IER = 0 00032000 DO 10 I = 1,3 00032100 V1(I) = XYZ2(I) - XYZ1(I) 00032200 V2(I) = XYZ3(I) - XYZ2(I) 00032300 10 V3(I) = XYZ4(I) - XYZ3(I) 00032400 A(1) = V1(2)*V2(3) - V1(3)*V2(2) 00032500 A(2) = V1(3)*V2(1) - V1(1)*V2(3) 00032600 A(3) = V1(1)*V2(2) - V1(2)*V2(1) 00032700 AA = A(1)*A(1) + A(2)*A(2) + A(3)*A(3) 00032800 B(1) = V2(2)*V3(3) - V2(3)*V3(2) 00032900 B(2) = V2(3)*V3(1) - V2(1)*V3(3) 00033000 B(3) = V2(1)*V3(2) - V2(2)*V3(1) 00033100 BB = B(1)*B(1) + B(2)*B(2) + B(3)*B(3) 00033200 AABB = AA*BB 00033300 IF (AABB .LT. 1E-6) GO TO 90 00033400 AB = A(1)*B(1) + A(2)*B(2) + A(3)*B(3) 00033500 SS = V1(1)*B(1) + V1(2)*B(2) + V1(3)*B(3) 00033600 DIHED = SIGN(ARCOS(AB/SQRT(AABB)),SS)*57.29578E0 00033700 RETURN 00033800 90 IER = 1 00033900 DIHED = 0. 00034000 RETURN 00034100 END 00034200 SUBROUTINE PDIST(DIST) 00034300 C 00034400 C OUTPUT ROUTINE TO PRINT BAR GRAPHS OF ANGLE DISTRIBUTIONS 00034500 C 00034600 INTEGER DIST(24,88) 00034700 LOGICAL*1 LINE(132,5),X/'X'/,VALUE(4) 00034800 REAL RNAMES(24) 00034900 INTEGER RPTRS(24),RNUMS(24) 00035000 COMMON /RES/ RNAMES,RPTRS,RNUMS 00035100 IF = 1 00035200 DO 200 IR = 1,22 00035300 NA = RNUMS(IR) 00035400 20 IL = MIN0(NA,5) + IF - 1 00035500 DO 30 I = 1,5 00035600 30 CALL BLANK(LINE(1,I),0,132) 00035700 CALL MOVE(LINE(1,5),0,3,RNAMES(IR)) 00035800 IP = 5 00035900 C 00036000 C LOOP OVER ANGLES OF A ROW. FIND MAXIMUM OF EACH DISTRIBUTION 00036100 C 00036200 DO 100 IA = IF,IL 00036300 LARGE = 1 00036400 DO 40 I = 1,24 00036500 IF (DIST(I,IA).GT.LARGE) LARGE = DIST(I,IA) 00036600 40 CONTINUE 00036700 C 00036800 C PLACE X'S IN OUTPUT ACCORDING TO FREQUENCIES 00036900 C 00037000 DO 80 I = 1,24 00037100 NX = 5*DIST(I,IA)/LARGE 00037200 IF (NX.LE.0) GO TO 80 00037300 DO 60 J = 1,NX 00037400 60 LINE(IP,6-J) = X 00037500 80 IP = IP + 1 00037600 100 IP = IP + 2 00037700 C 00037800 C PRINT ONE ROW OF BAR GRAPHS AND UNDERLINE THEM 00037900 C 00038000 CALL CRYOUT(' ',3329,LINE(1,1),132,' ',2049,LINE(1,2),132, 00038100 1 ' ',2049,LINE(1,3),132,' ',2049,LINE(1,4),132,' ',2049,LINE(1,5),00038200 2 132) 00038300 CALL CRYOUT('+ ________________________ ______________________00038400 1__ ________________________ ________________________ __________00038500 2______________',2046+IP) 00038600 C 00038700 C PREPARE FREQUENCIES FOR PRINTING 00038800 C 00038900 DO 120 I = 1,4 00039000 120 CALL BLANK(LINE(1,I),0,132) 00039100 IP = 5 00039200 DO 150 IA = IF,IL 00039300 DO 140 I = 1,24 00039400 CALL IBCDWT(19971,VALUE,DIST(I,IA)) 00039500 DO 130 J = 1,4 00039600 130 LINE(IP,J) = VALUE(J) 00039700 140 IP = IP + 1 00039800 150 IP = IP + 2 00039900 CALL CRYOUT(' ',3073,LINE(1,1),132,' ',2049,LINE(1,2),132, 00040000 1 ' ',2049,LINE(1,3),132,' ',2049,LINE(1,4),132) 00040100 C 00040200 C NEXT ROW, NEXT RESIDUE 00040300 C 00040400 IF = IL + 1 00040500 NA = NA - 5 00040600 IF (NA.GT.0) GO TO 20 00040700 200 CONTINUE 00040800 RETURN 00040900 END 00041000 TALK TITLE 'CRYSTALLOGRAPHIC SYSTEM INPUT/OUTPUT PACKAGE' 00000100 * TALK INPUT/OUTPUT AND NUMERICAL CONVERSION PACKAGE 00000200 * FOR 'CRYM' CRYSTALLOGRAPHIC COMPUTING SYSTEM 00000300 * 00000400 * THIS DECK CONTAINS ROUTINES FOR BINARY TO DECIMAL AND 00000500 * DECIMAL TO BINARY CONVERSION, PRINTING, PUNCHING, CARD 00000600 * READING, AND CONTROL CARD DETECTION AND SCANNING. 00000700 * PROGRAMMED BY G. N. REEKE 00000800 * REVISED 7/74 G.N.R. - ADDITION OF #CNTRL, #CDUNIT, 00000900 * RETURN LENGTHS, IMPROVED CONTROL CARD SCAN 00001000 * REVISED 5/75 G.N.R. - ADD 'EXECUTE' CARD FEATURE 00001100 * REVISED 11/76 G.N.R. - ADD SETTIT AND NOREWIND EXEC OPTION 00001102 * REVISED 11/78 G.N.R. - SETTIT ARGS, DATA PUNCT IN #CNTRL, OMIT 00001104 * CNTINU PRINT IF NO CDPRNT, CALL PRNSCR FROM CRYIN, 00001106 * NO RECYCLE IN SCAN WITH 2 ARGS OPTION 00001108 * REVISED 11/78 G.N.R. - ALLOW SUBTITLE LINES TO OVERFLOW 00001110 * MAKE SPOUT INCREMENTAL, SPOUT '$' MSG, ADD CDPRT1 00001112 * 00001200 * NOTE: THESE ROUTINES DO NOT ALWAYS OBEY STANDARD IBM LINKAGES 00001300 * 00001400 SPACE 5 00001500 MACRO 00001600 &NAME NWSV &NEW,&R 00001700 &NAME ST 13,&NEW+4 PERFORM SAVE AREA LINKAGE 00001800 LR &R,13 00001900 LA 13,&NEW 00002000 ST 13,8(&R) 00002100 MEND 00002200 SPACE 3 00002300 * 00002400 * ENTRY POINT DEFINITIONS 00002500 * 00002600 TALK START 0 00002700 ENTRY COMM,BCDOUT,IBCDWT,BCDIN,IBCDIN 00002800 ENTRY CDSCAN,BLSCAN,SCAN,ERMARK 00002900 ENTRY CRYOUT,PUNCH,LINES,SPOUT 00003000 ENTRY CRYIN,CDPRNT,CDPRT1,RDAGN,CNTRL,CDUNIT,SETTIT 00003100 SPACE 3 00003200 * 00003300 * ASSEMBLY CONTROL PARAMETERS 00003400 * 00003500 NCDU EQU 4 NUMBER OF CARD UNITS IN STACK 00003600 PGLNS EQU 58 MAXIMUM LINES/PAGE AFTER TITLE 00003700 SBHDCH EQU 280 MAXIMUM CHARACTERS IN SUBTITLE 00003800 * INCLUDING RECORD CONTROL WORDS 00003900 * 00004000 * I/O UNITS ARE CONTROLLED BY DEFAULT ENTRIES 00004100 * FOR READ, PRINT, PUNCH, ERROR PRINT IN IHCUATBL 00004200 EJECT 00004300 * 00004400 * HANDLE FORTRAN CALLING SEQUENCES FOR NUMBER CONVERSION 00004500 * 00004600 USING BCDOUT,15 00004700 BCDOUT STM 14,7,12(13) SAVE REGISTERS 00004800 L 4,8(1) LOCATE ARGUMENT 00004900 L 2,0(0,1) LOCATE CODES 00005000 MVC HIGH,0(4) MOVE ARG TO DOUBLE WORD 00005100 LD 0,HIGH ARG TO FPR0 00005200 LA 15,COMM SET STANDARD BASE 00005300 USING COMM,15 00005400 B FORTOUT 00005500 USING IBCDWT,15 00005600 IBCDWT STM 14,7,12(13) FIXED POINT OUTPUT ENTRY 00005700 L 4,8(1) LOCATE ARGUMENT 00005800 L 1,0(1) LOCATE CODES 00005900 L 0,0(4) ARGUMENT TO GPR0 00006000 LA 15,COMM SET STANDARD BASE 00006100 USING COMM,15 00006200 B FIXOUT 00006300 USING BCDIN,15 00006400 BCDIN DS 0H FORTRAN FLOATING POINT ENTRY (INPUT) 00006500 IBCDIN STM 14,7,12(13) FORTRAN FIXED POINT ENTRY (INPUT) 00006600 L 3,0(1) LOCATE CODES 00006700 LA 15,COMM SET STANDARD BASE REGISTER 00006800 USING COMM,15 00006900 B SETUP 00007000 * 00007100 * FORTRAN CALLS FOR CONTROL CARD SCAN 00007200 * 00007300 USING SCAN,15 00007400 SCAN OI F,SBL CONTROL CARD SCAN - SET TYPE II 00007500 BALR 15,0 FIX BASE FOR NORMAL ENTRY TO SCAN 00009500 USING BLSCAN,15 00009600 BLSCAN LA 15,COMM CONTROL CARD SCAN WITH BLANK DELIMITERS 00009700 USING COMM,15 00009800 STM 14,12,12(13) SAVE USER REGISTERS 00009900 L 4,0(0,1) LOCATE RESULT FIELD 00010000 LA 4,0(0,4) GET RID OF VL BIT 00010100 B BSCAN MERGE WITH ASSEMBLER ENTRY 00010200 USING CDSCAN,15 00010300 CDSCAN L 0,0(1) LOC OF ARRAY TO R0 00010400 L 1,4(1) LOC OF COLUMN TO R1 00010500 L 1,0(1) COL-1 TO R1 00010600 AR 1,0 R1 = STARTING LOCATION 00010700 AH 0,H70 R0 = ENDING LOCATION 00010800 CR 0,1 00010900 BL ABEND20 ERROR - NO COLS TO SCAN 00011000 STM 0,1,SCEND STORE INFORMATION 00011100 MVI F,FTN SET FORTRAN FLAG, CLEAR OTHERS 00011200 MVI RF,0 SET FLAGS AS IF PREVIOUS COMMA FOUND 00011300 BR 14 RETURN 00011400 EJECT 00011450 * 00011500 * FORTRAN ENTRY TO MARK CARD ERRORS 00011600 * NOTE: NO SAVE, USES ONLY R14 - R1 00011700 * 00011800 USING ERMARK,15 00011900 ERMARK LA 15,COMM FORTRAN ERROR MARKER 00012000 USING COMM,15 00012100 L 1,0(1) LOCATE CODE 00012200 OC #ERSCAN+1(1),3(1) SET CODE 00012300 B AMARK 00012400 * 00013200 * FORTRAN ENTRY TO SET FLAG TO REREAD PREVIOUS CARD 00013300 * 00013400 USING RDAGN,15 00013500 RDAGN OI ACCPT,X'0F' FORTRAN REREAD ENTRY POINT 00013600 BR 14 RETURN 00013700 * 00013740 * FORTRAN ENTRY TO SET TITLE FROM CARD PREVIOUSLY READ 00013742 * 00013744 USING SETTIT,15 00013746 SETTIT LR 0,2 SAVE R2 IN R0 00013750 L 2,LAST LOCATE LAST CARD READ 00013752 LTR 1,1 IS THERE AN ARGUMENT? 00013754 BZ *+8 NO 00013756 L 2,0(0,1) YES, USE IT INSTEAD 00013758 L 1,#HEAD LOCATE TITLE 00013760 MVC 36(60,1),6(2) MOVE IT 00013762 LR 2,0 RESTORE R2 00013764 BR 14 RETURN 00013766 EJECT 00013800 * 00013900 * ASSEMBLER ENTRY POINTS 00014000 * AND GENERAL COMMUNICATIONS REGION 00014100 * 00014200 * NOTE: 'COMM' IS ENTRY POINT FOR ALL ASSEMBLER LANGUAGE 00014300 * REFERENCES TO THIS PROGRAM. REFERENCE SPECIFIC ROUTINES BY 00014400 * 'COMM' + DISPLACEMENT. EXAMPLE - TO CALL #SCAN 00014500 * L 15,=V(COMM) 00014600 * BAL 14,32(15) 00014700 * NOTE: ALL THESE PROGRAMS PRESERVE CONTENT OF R15, SO R15 00014800 * NEED BE LOADED ONLY ONCE FOR A SERIES OF CALLS. 00014900 * 00015000 USING COMM,15 00015100 COMM DS 0F 00015200 #BCDOUT B BEGOUT-COMM(15) FLOATING POINT OUTPUT (PREVENT TRACE) 00015300 #IBCDWT B FIXOUT-4 FIXED POINT OUTPUT 00015400 #BCDIN B BEGIN FIXED AND FLOATING POINT INPUT 00015500 #CRYOUT B PRNCOM ASSEMBLER PRINT ENTRY POINT 00015600 #PUNCH B PUNCOM ASSEMBLER PUNCH ENTRY POINT 00015700 #LINES B ALNS ASSEMBLER LINES ENTRY POINT 00015800 #ERMARK B AMARK CONTROL CARD ERROR MARKER 00015900 #CDSCAN B ACDSCN CARD SCAN INITIALIZATION 00016000 #SCAN B ASCAN CARD SCAN 00016100 #BLSCAN B ABLSCN CARD SCAN WITH BLANK SEPARATORS 00016200 #CRYIN B INCOME READ A CONTROL CARD 00016300 #CDPRNT B INPRNT PRINT PREVIOUS CONTROL CARD 00016400 #HEAD DC A(DTWD) LOCATION OF PAGE TITLE 00016500 #SPOUT B ASPOUT TURN ON AUXILIARY PRINT OUT 00016600 LAST DC A(0) LOCATION OF LAST CONTROL CARD READ 00016700 ACCPT EQU LAST REREAD CONTROL CARD FLAG 00016800 CP EQU X'01' VALUE OF ACCPT WHEN CARD PRINTED 00016810 #ERSCAN DC H'0' ERROR CODES 00016900 #FLSCAN DC H'0' CONTROL CARD SCAN RETURN CODES 00017000 RF EQU #FLSCAN+1 00017100 #FIELD DC 16C' ' CONTROL CARD FIELD RETURN 00017200 #CNTRL DC A(CVT) TRT TABLE FOR FINDING CONTROL CARDS 00017300 #LENGTH EQU #CNTRL LENGTH RETURN (MUST = #FIELD+16) 00017400 #CDUNIT B INUNIT CHANGE CRYIN UNIT 00017500 #PGLNS DC A(LPP) LOCATION OF LINES PER PAGE 00017600 TITLE 'BINARY TO DECIMAL CONVERSION' 00017700 * INPUT AND OUTPUT NUMERICAL CONVERSION ROUTINES 00017800 * BCDOUT, IBCDWT, BCDIN, IBCDIN 00017900 * 00018000 *********************************************************************** 00018100 * FORTRAN CALLING SEQUENCE (RE-USABLE) IS: 00018200 *********************************************************************** 00018300 * 1) SINGLE OR DOUBLE PRECISION FLOATING POINT TO DECIMAL 00018400 * CALL BCDOUT(CODE,FIELD,ARG) 00018500 * 2) INTEGER (OR GENERAL FIXED POINT) TO DECIMAL 00018600 * CALL IBCDWT(CODE,FIELD,IARG) 00018700 * 'CODE' IS 'SSDDCCWW' DESCRIBED BELOW 00018800 * 'FIELD' IS AN ARRAY OF ANY TYPE INTO WHICH THE RESULT IS 00018900 * PLACED FOR PRINTING IN 'A' FORMAT 00019000 * 'ARG' IS AN R*8 OR R*4 NUMBER TO BE CONVERTED, AND 'IARG' 00019100 * IS AN I*4 INTEGER TO BE CONVERTED 00019200 * 3) DECIMAL TO FLOATING POINT (R*4 OR R*8) 00019300 * X = BCDIN(CODE,FIELD) 00019400 * 4) DECIMAL TO INTEGER (OR GENERAL FIXED POINT) 00019500 * I = IBCDIN(CODE,FIELD) 00019600 * 'CODE' IS 'SSDDCCWW' DESCRIBED BELOW 00019700 * 'FIELD' IS AN ARRAY FROM WHICH THE DECIMAL NUMBER IS TO BE 00019800 * READ, PERHAPS OUTPUT OF CRYIN OR OF BLSCAN OR SCAN. 00019900 * BCDIN SHOULD BE DECLARED DOUBLE PRECISION IF ANY DOUBLE 00020000 * PRECISION NUMBERS ARE TO BE READ 00020100 * SINCE HEXADECIMAL LITERALS ARE NOT ALLOWED IN FORTRAN CALLS, 00020200 * THE CODE (SEE BELOW) SHOULD BE MADE UP BY DATA STATEMENTS. 00020300 * OR BY CALCULATING THE DECIMAL EQUIVALENT OF THE CODE 00020400 * 00020500 *********************************************************************** 00020600 * ASSEMBLER CALLING SEQUENCE: 00020700 *********************************************************************** 00020800 * LOAD REGISTERS AS FOLLOWS: 00020900 * FPR0 FLOATING POINT ARGUMENT (OUTPUT) 00021000 * R0 FIXED POINT ARGUMENT (OUTPUT) 00021100 * R1 LOCATION OF PARAMETER LIST 00021200 * FIRST WORD OF PARAM LIST IS CODE, SECOND IS FIELD 00021300 * R13 LOCATION OF SAVE AREA 00021400 * R14 RETURN ADDRESS 00021500 * R15 ADDRESS OF 'COMM' 00021600 * AND BRANCH TO 'COMM' FOR BCDOUT, 'COMM+4' FOR IBCDWT, 00021700 * 'COMM+8' FOR BCDIN OR IBCDIN. 00021800 * RESULT REGISTERS: 00021900 * FPR0 FLOATING POINT AND HEXADECIMAL INPUT 00022000 * GPR0 FIXED POINT AND HEX (LOW ORDER) INPUT 00022100 * LENGTH OF OUTPUT FLD - 1 IS RETURNED IN #LENGTH 00022200 * THERE IS NO E FORMAT INPUT 00022300 *********************************************************************** 00022400 * WHEN ENTERING VIA 'COMM', 00022500 * 'SSDDCCWW' IS IN CALLING SEQUENCE, INSTEAD OF ITS ADDRESS. 00022600 * (NOTE: 'SSDDCCWW' IS THE 'CODE' MENTIONED ABOVE FOR FORTRAN.) 00022700 * 'FIELD' IS ADDRESS OF EBCDIC OUTPUT OR INPUT FIELD. 00022800 * IT MAY BE 'A' TYPE OR 'S' TYPE 00022900 * IF 'A' TYPE, THEN WORD 2 OF PARAMETER LIST IS FIELD LOC. 00023000 * AND PARAMETER LIST MUST BE ALIGNED TO WORD BOUNDARY 00023100 * IF 'S' TYPE, THEN WORD 2 IS A 'LA' INSTRUCTION TO LOAD 00023200 * ADDRESS OF FIELD IN R1 - ALIGNED TO HALFWORD 00023300 * THE 'LA' MAY USE R5-R15 ON OUTPUT, R4-R15 ON INPUT. 00023400 *********************************************************************** 00023500 * -->THE HEXADECIMAL CODE 'SSDDCCWW' IS AS FOLLOWS: 00023600 * 'SS' IS NUMBER OF FRACTION BITS IN GENERAL FIXED POINT NUMBER 00023700 * IT IS ALWAYS '00' FOR INTEGERS AND FLOATING POINT NUMBERS 00023800 * 'DD' IS LOCATION OF DECIMAL POINT FROM RIGHT OF FIELD - 15 MAX 00023900 * MAX VALUE OF 'DD' IS 10 FOR FIXED POINT OUTPUT, 9 FOR INPUT 00024000 * ON OUTPUT, 'DD' = '00' IS NO DECIMAL POINT; OTHER VALUES ARE 00024100 * ONE GREATER THAN 'N' IN FORTRAN FORMAT 'FW.N'. 00024200 * ON INPUT, 'DD' IS NUMBER OF DIGITS TO RIGHT OF ASSUMED DECIMAL 00024300 * WHEN NONE IS FOUND IN FIELD 00024400 * 'CC' IS SERVICE CODE, MADE UP OF ANY OF THE FOLLOWING BITS: 00024500 * X000 1000 X=0 FOR INTEGERS, X=1 FOR GENERAL 00024600 * FIXED POINT (BIT '08' MUST BE ON) 00024700 * NOTE: ON FIXED POINT OUTPUT, THE INTEGER 00024800 * BIT, WHEN OFF, SUPPRESSES SCALING BEFORE 00024900 * INSERTION OF DECIMAL POINT, SO INTEGERS 00025000 * CAN BE DIVIDED BY POWERS OF TEN 00025100 * 0X00 0000 X=1 TO LEFT ADJUST THE OUTPUT 00025200 * IGNORED ON INPUT 00025300 * 00X0 0000 X=1 FOR AUTOMATIC E FORMAT ON OUTPUT 00025400 * WHEN FIELD UNDERFLOWS (NO SIGNIF DIGITS) 00025500 * (PROGRAM ALWAYS GIVES E FORMAT ON 00025600 * FIELD OVERFLOW) BIT IGNORED ON INPUT 00025700 * 000X 0000 X=1 AUTOMATIC DECIMAL FEATURE (OUTPUT) 00025800 * I.E. DECIMAL IS ADJUSTED TO GIVE 00025900 * GREATEST NUMBER OF SIGNIF FIGURES 00026000 * IGNORED ON INPUT 00026100 * 0000 X000 X=0 FLOATING, X=1 FIXED POINT 00026200 * 0000 0XX0 XX=00 E FORMAT, XX=11 F OR I FORMAT 00026300 * (I FORMAT = F FORMAT WITH 'DD' = '00' 00026400 * DEC PTS CAN BE INSERTED IN INTEGERS.) 00026500 * XX=01 HEXADECIMAL CONVERSION 00026600 * 0000 000X X=0 DOUBLE, X=1 SINGLE PRECISION 00026700 * 00026800 * 'WW' IS ONE LESS THAN WIDTH OF EBCDIC FIELD IN CHARS - MAX 15 00026900 * 00027000 * ALL GPR ARE PRESERVED EXCEPT GPR0 ON IBCDIN. FPR0 AND FPR2 00027100 * ARE ALWAYS DESTROYED; FPR4 IS DESTROYED ON E FORMAT OUTPUT . 00027200 * 00027300 * ERROR PROCEDURES: ON OUTPUT, IF FIELD OVERFLOWS AND WIDTH 00027400 * IS >4, THEN E FORMAT IS USED. IF WIDTH <5, OUTPUT IS '****'. 00027500 * ON INPUT, ALL CHARACTERS EXCEPT '-', '.', AND DIGITS ARE 00027600 * IGNORED. ONLY POSSIBLE ERROR IS OVERFLOW ON FIXED POINT, 00027700 * WHICH LEADS TO A MESSAGE. PARAMETERS ARE TREATED MODULO THEIR 00027800 * MAX VALUE IF THEY ARE TOO LARGE. 00027900 * 00028000 * RESTRICTIONS: EBCDIC CODE IS ASSUMED. MACHINE MUST HAVE 00028100 * FLOATING AND DECIMAL INSTRUCTIONS (ONLY DECIMAL INSTR. IS ONE 00028200 * EDMK). FIXED POINT OVERFLOW INTERRUPT MUST BE MASKED OFF IF 00028300 * FIXED POINT ITEMS OF MORE THAN EIGHT DIGITS ARE PROCESSED. 00028400 * 00028500 * ALL RESULTS ARE ACCURATE TO ONE IN THE LOW-ORDER BIT 00028600 * 00028700 EJECT 00028800 * 00028900 * INITIAL PREPARATIONS FOR FLOATING POINT OUTPUT 00029000 * 00029100 BEGOUT STM 14,7,12(13) SAVE REGISTERS 00029200 LR 2,1 R2 = LOC OF CODES 00029300 FORTOUT IC 0,3(2) R0 = WIDTH 00029400 SR 4,4 R4 IS ZERO OR E FORMAT EXPONENT+100 00029500 N 0,MSK3 MAX WIDTH 15 00029600 TM 2(2),1 IF ARG IS SINGLE PRECISION, REMOVE 00029700 BZ DOUBLE LOW ORDER 00029800 SDR 2,2 00029900 LER 2,0 00030000 LDR 0,2 00030100 DOUBLE STD 0,LOW SAVE ARG 00030200 LR 5,4 R5 = F'0' 00030300 TM 2(2),6 TEST AND BRANCH FOR HEX FORMAT 00030400 BM XFORM 00030500 IC 3,1(2) R3 = DECIMAL PARAMETER 00030600 N 3,MSK3 00030700 LPDR 2,0 ABS(ARG) TO FPR2 00030800 BZ NULL BRANCH TO PRINT '0' FOR ZERO ARG. 00030900 TM 2(2),6 TEST AND BRANCH FOR E FORMAT 00031000 BZ FORCE 00031100 TM 2(2),X'10' TEST AND BRANCH FOR EXPLICIT DECIMAL 00031200 BZ XPLCIT 00031300 * 00031400 * AUTOMATIC DECIMAL, DETERMINE SIZE OF ARGUMENT 00031500 * 00031600 CD 2,TOP IF ARG .GE. 1.0E16 00031700 BNL FORCE GO TO E FORMAT 00031800 L 6,MONE R6 = DECIMAL EXPONENT 00031900 CE 2,TENS IF ARG .LT. 1.0 00032000 BL SRCH2 GO USE MAX DECIMAL 00032100 IC 7,LOW IN BETWEEN, 00032200 N 7,MSK3 PICK UP HEX EXP 00032300 SLL 7,3 00032400 M 6,LOGTWO DEC EXP = HEX EXP * LOG(16) 00032500 SRCH1 LR 3,6 BUT ARG MAY BE SMALLER 00032600 SLL 3,3 00032700 CD 2,TENS+8(3) 00032800 BNL SRCH2 NO, IT'S OK NOW 00032900 BCT 6,SRCH1 YES, REDUCE EXP AND TEST AGAIN 00033000 SRCH2 LR 3,0 R3 = WIDTH - 1 00033100 LTER 0,0 REDUCE BY ONE MORE IF ARG IS NEGATIVE 00033200 BNM *+6 00033300 BCTR 3,0 00033400 SR 3,6 DEC PARM = WIDTH - EXPONENT 00033500 BM FORCE FIELD TOO NARROW, USE E FORMAT 00033600 * 00033700 * SCALING, BINARY TO DECIMAL CONVERSION, AND EDITING 00033800 * 00033900 XPLCIT DS 0H ENTER WITH EXPLICIT DECIMAL IN R3 00034000 SCALE LR 7,3 SCALE ARGUMENT TO INTEGER 00034100 SLA 7,3 DECIMAL * 8 TO ACT AS INDEX 00034200 SCL1 MD 2,TENS(7) 00034300 AD 2,HALF ROUND BY ADDING HALF 00034400 BXLE 4,5,SCL2 IF E CONVERSION, 00034500 CD 2,TENS+8(7) SEE IF ROUNDING 00034600 BL SCL3 MADE RESULT GE 10.0 00034700 DD 4,TENS+16 IF SO, RESCALE ARG 00034800 LA 4,1(0,4) INCREASE EXPONENT 00034900 LDR 2,4 00035000 B SCL1 AND REPEAT OUTPUT WITH NEW SCALE 00035100 SCL2 CD 2,TOP TEST FOR OVERFLOW (>16 DIGITS) 00035200 BNL FARCE OVERFLOW, GO TO E FORMAT 00035300 SCL3 AW 2,CHAR UNNORMALIZE SO POINT IS AT RIGHT OF R2 00035400 STD 2,LOW MOVE ARG TO GPR 00035500 LM 6,7,LOW 00035600 LA 6,0(0,6) REMOVE CHARACTERISTIC 00035700 CONVT BXLE 6,5,SINGLE IF HIGH ORDER ZERO, DO ONLY ONE CONVERT 00035800 D 6,SPLIT TWO CONVERTS, EIGHT DIGIT PIECES 00035900 CVD 7,HIGH CONVERT TO DECIMAL 00036000 CVD 6,LOW 00036100 MVZ LOW+3(1),HIGH+7 COMBINE RESULTS 00036200 MVC HIGH+7(4),HIGH+3 00036300 B EDIT 00036400 SINGLE LTR 7,7 ENTER HERE FOR SINGLE CONVERSION. IF 00036500 BM CONVT+4 SIGN BIT ON, GO BACK; IF 00036600 BNZ LOWORD IT IS ALSO ZERO, SIGNIFICANCE IS LOST 00036700 TM 2(2),X'20' TEST IF USER REQUESTED E FORMAT 00036800 BNZ UNDRFL FOR UNDERFLOW. BRANCH IF YES 00036900 LOWORD CVD 7,LOW CONVERT LOW ORDER ALONE 00037000 MVI GUARD,0 ADD ONE ZERO TO LEFT 00037100 EDIT MVC PATTERN,SELECT MOVE EDIT PATTERN TO WORK AREA 00037200 LA 1,PATTERN+17 LOCATE SIGNIF. STARTER 00037300 BXLE 3,5,ABUT3 IF DEC PT = 0, GO OMIT POINT IN RESULT 00037400 SR 1,3 ADDRESS OF SIG START = END PATT - DEC 00037500 CR 0,3 IF DEC PT ABUTS LEFT OF FIELD 00037600 BH ABUT 00037700 LA 1,1(1) OMIT LEADING ZERO 00037800 MVC 0(2,1),SSPT 00037900 B ABUT2 00038000 ABUT3 MVI PATTERN+1,C' ' NO DEC PT IN RESULT - DOCTOR PATTERN 00038100 MVI 0(1),X'21' SIG START IN PENULTIMATE DIGIT 00038200 B ABUT2 00038300 ABUT MVC 0(3,1),SSDSPT OTHERWISE, PUT ONE ZERO BEFORE DEC 00038400 ABUT2 LA 1,1(1) R1 POINTS TO FIRST SIGNIF DIGIT 00038500 OI LOW+7,1 MAKE ARG NEG SO PT IS NOT BLANKED 00038600 EDMK PATTERN,GUARD LEADING ZEROS AND BLANKS INTO RESULT 00038700 EXP BXLE 4,5,MINUS IF NOT E CONVERSION, GO INSERT SIGN 00038800 * 00038900 * INSERT EXPONENT FOR E FORMAT OUTPUT 00039000 * 00039100 S 4,DECADE+12 EXPONENT OUTPUT = R4 - 100 00039200 MVI GUARD,C'+' 00039300 BNM *+8 USE POSITIVE EXPONENT IF PLUS 00039400 MVI GUARD,C'-' OTHERWISE, NEGATIVE EXPONENT 00039500 CVD 4,LOW EXPONENT TO DECIMAL 00039600 UNPK LOW(2),LOW+6(2) EXPONENT TO PATTERN 00039700 OI LOW+1,X'F0' AND CONVERT SIGN TO ZONE 00039800 LA 4,3 SET TO EXPAND FIELD TO RIGHT 00039900 * 00040000 * INSERT MINUS SIGN, MOVE RESULTS TO CALLER'S FIELD 00040100 * 00040200 MINUS LA 4,PATTERN+18(4) R4 LOCATES RIGHT OF DATA 00040300 LTER 0,0 TEST SIGN OF ORIGINAL ARGUMENT 00040400 BNM ADJUST POSITIVE - BRANCH 00040500 BCTR 1,0 NEGATIVE - LOCATE SIGN ONE DIGIT LEFT 00040600 MVI 0(1),C'-' OF FIRST SIG DIGIT 00040700 ADJUST LR 3,4 R3 = RIGHTMOST CHARACTER 00040800 SR 3,1 R3 = LENGTH OF SIGNIFICANT DATA 00040900 CR 3,0 TEST FOR OVERFLOW OF FIELD - FIRST SIG 00041000 BH OVFLOW DIGIT IS LEFT OF FIELD BEGINNING 00041100 ADJ2 STC 3,#LENGTH RETURN FIELD LENGTH 00041200 PUT LM 5,7,40(13) RESTORE R5,7 FOR POSSIBLE USE IN ADDRESS 00041300 L 1,24(13) R1 = LOC OF PARAMETER LIST 00041400 CLI 4(1),X'41' TEST FOR 'S' TYPE CONSTANT 00041500 BE PUT2 YES 00041600 L 1,4(1) IS 'A' TYPE CONSTANT 00041700 B FINAL 00041800 PUT2 EX 0,4(1) IS 'S' TYPE CONSTANT - EXECUTE USER'S LA 00041900 FINAL TM 2(2),X'40' TEST JUSTIFICATION 00042000 BZ NORM NORMAL RIGHT JUSTIFY - BRANCH 00042100 * NOTE: SLIGHT SIMPLIFICATION POSSIBLE 00042200 * IF BLANK FIELD TO RIGHT OF PATTERN 00042300 SR 4,3 LEFT ADJUST - R4 = BEGIN OF SIG DATA 00042400 EX 3,PLACE MOVE SIGNIF DATA TO RESULT 00042500 LA 1,1(3,1) R1 = LOC OF BYTE AFTER DATA IN RESULT 00042600 BCTR 0,0 R0 = ORIGINAL WIDTH MINUS ONE 00042700 SR 3,0 R3 = - WIDTH REMAINING 00042800 LCR 3,3 R3 = + WIDTH REMAINING 00042900 BM MOVE+4 NONE 00043000 LA 4,BLANKS PREPARE TO FILL EXCESS WITH BLANKS 00043100 B MOVE 00043200 NORM SR 4,0 NORMAL RIGHT JUSTIFIED OUTPUT 00043300 LR 3,0 R3 = FIELD WIDTH 00043400 MOVE EX 3,PLACE MOVE RESULT TO USER'S FIELD 00043500 LM 0,4,20(13) RESTORE REMAINING REGISTERS 00043600 BR 14 RETURN TO CALLER 00043700 * 00043800 * INSTRUCTION EXECUTED TO MOVE DATA TO CALLER'S FIELD 00043900 * 00044000 PLACE MVC 0(0,1),0(4) 00044100 * 00044200 * GENERATE STRAIGHT '0' WHEN ARG IS EXACT ZERO 00044300 * 00044400 NULL SR 3,3 SET LENGTH = 0 00044500 LA 4,BLANKS+16 00044600 B ADJ2 MAKE A SINGLE ZERO 00044700 EJECT 00044800 * 00044900 * ENTER HERE ON FIELD OVERFLOW - PREPARE FOR E CONVERSION 00045000 * 00045100 OVFLOW DS 0H HERE FROM 'ADJUST' 00045200 UNDRFL TM 2(2),X'08' IF ARGUMENT WAS FLOATING, 00045300 BZ FARCE GO AT ONCE TO E FORMAT 00045400 L 7,ARG IF ARG WAS FIXED, FIRST FLOAT IT 00045500 FLOAT LPR 6,7 ENTER HERE WHEN E FORMAT REQUESTED 00045600 SR 7,7 INITIALLY FOR FIXED ARGUMENT 00045700 IC 1,0(2) R1 = BINARY SCALE 00045800 LR 3,1 00045900 SLL 1,22 FOR EVERY 16, ONE EXPONENT 00046000 N 1,MSK7 00046100 N 3,THREE R3 = SHIFT, MOD 4 00046200 SRDL 6,8(3) VACATE BYTE FOR CHARA 00046300 O 6,MSK8 PUT IN CHARA 00046400 SR 6,1 CORRECT CHARA FOR SCALE 00046500 STM 6,7,LOW BACK TO FPR2 00046600 LD 2,LOW 00046700 AD 2,ZERO NORMALIZE 00046800 B FORCE 00046900 * 00047000 * SCALING FOR E FORMAT CONVERSION 00047100 * 00047200 * ENTER HERE FROM SCALE, OVFLOW, UNDRFL 00047300 FARCE LPDR 2,0 ORIGINAL ARG TO FR2 00047400 FORCE LR 3,0 R3 = WIDTH - 1 00047500 S 3,FOUR TEST WIDTH, REDUCE FOR DECIMAL 00047600 BNM FLAG 00047700 LA 4,STARS+3 WIDTH INADEQUATE, RESULT IS '****' 00047800 LR 3,0 R3 = WIDTH 00047900 B PUT GO LOCATE OUTPUT FIELD 00048000 FLAG LA 4,100 R4 = EXPONENT + 100 00048100 LD 4,TOP FPR4 = 1.0E16 00048200 DOWN CDR 2,4 IF ARG IS .GE. 1.0E16 00048300 BL UP 00048400 DDR 2,4 SCALE DOWN BY 1.0D16 00048500 SIXTEEN LA 4,16(4) ADJUST EXPONENT 00048600 B DOWN AND CHECK AGAIN 00048700 UP CE 2,TENS IF ARG IS .LT. 1.0 00048800 BNL LOGSCL 00048900 MDR 2,4 SCALE UP BY 1.0D16 00049000 SH 4,SIXTEEN+2 ADJUST EXPONENT 00049100 B UP AND CHECK AGAIN 00049200 LOGSCL STE 2,LOW HERE 1.0 LE ARG LT 10**16, FIND SCALE 00049300 IC 7,LOW R7 = HEX CHARA 00049400 N 7,MSK3 RANGE 0 TO E 00049500 SLL 7,3 00049600 M 6,LOGTWO R6 = HEX CHAR * LOG 16 = DEC CHAR 00049700 AR 4,6 ADD CHAR TO R4 00049800 SLL 6,3 MAKE R6 INTO AN INDEX 00049900 DD 2,TENS+8(6) NOW ARG IS < 10.0 00050000 MORE CE 2,TENS MAKE IT .GE. 1.0 00050100 BNL SETPT 00050200 MD 2,TENS+16 SCALE UP BY 10.0 00050300 BCT 4,MORE DECREASE EXP (ALWAYS BRANCH) 00050400 SETPT LDR 4,2 SAVE ARG 00050500 TM 2(2),X'16' IF E FORMAT WITH AUTO DEC REQSTD, 00050600 BNZ SCALE SET DEC = WIDTH - 4 00050700 IC 6,1(2) OTHERWISE, USE CALLER'S DECIMAL 00050800 N 6,MSK3 00050900 CR 6,3 UNLESS IT IS TOO LARGE 00051000 BNL SCALE 00051100 LR 3,6 00051200 B SCALE THUS AVOIDING INFINITE LOOPS 00051300 * 00051400 * HEXADECIMAL CONVERSION 00051500 * 00051600 XFORM UNPK PATTERN+3(15),LOW 00051700 UNPK PATTERN+18(1),PATTERN+17(1) FIX 'SIGN' 00051800 XFORM2 MVZ PATTERN+3(16),ZERO REMOVE ZONES 00051900 TR PATTERN+3(16),TABLE CONVERT TO EBCDIC 00052000 LA 4,PATTERN+18 00052100 LR 3,0 R3 = WIDTH 00052200 B PUT 00052300 EJECT 00052400 * 00052500 * FIXED POINT OUTPUT CONVERSION - ARG IN R0 00052600 * 00052700 STM 14,7,12(13) 00052800 FIXOUT LR 2,1 R2 = LOC OF CODES 00052900 ST 0,ARG SAVE ARG 00053000 LR 7,0 R7 = ARGUMENT 00053100 IC 0,3(2) R0 = WIDTH 00053200 N 0,MSK3 MAX WIDTH 15 00053300 TM 2(2),6 00053400 BM IHEX BRANCH FOR HEXADECIMAL 00053500 LE 0,ARG ARG TO FPR0 FOR LATER SIGN TEST 00053600 SR 4,4 SET NO E FORMAT 00053700 IC 3,1(2) 00053800 LR 5,4 R5 = F'0' 00053900 N 3,MSK3 R3 = DECIMAL PARAMETER 00054000 LPR 7,7 R7 = ABS(ARGUMENT) 00054100 BZ NULL VALUE ZERO 00054200 TM 2(2),6 00054300 BZ FLOAT BRANCH FOR E FORMAT 00054400 TM 2(2),X'80' 00054500 BZ LOWORD BRANCH FOR INTEGER 00054600 C 3,DECADE+8 00054700 BL *+8 IF DEC PT > 9, 00054800 LA 3,9 REPLACE IT WITH 9 00054900 SLA 3,2 FIX R3 TO USE AS INDEX 00055000 IC 1,0(0,2) R1 = SCALE = NUMBER OF FRACTION BITS 00055100 M 6,DECADE(3) SCALE 00055200 N 1,MSK2 00055300 SRA 3,2 RESTORE DEC 00055400 SRDA 6,X'FF'(1) REMOVE ALL BUT ONE BIT OF FRACTION 00055500 AL 7,DECADE ROUND 00055600 BC 12,*+8 NO OVERFLOW 00055700 A 6,DECADE OVERFLOW, CARRY INTO HIGH ORDER 00055800 SRDA 6,1 SHIFT AWAY LAST FRACTION BIT 00055900 B CONVT GO CONVERT 00056000 * 00056100 * INTEGER TO HEXADECIMAL 00056200 * 00056300 IHEX UNPK PATTERN+11(9),ARG(5) EXTRA BYTE AVOIDS 'SIGN' 00056400 MVC PATTERN+3(8),ZERO ZERO HIGH ORDER PART 00056500 B XFORM2 00056600 TITLE 'DECIMAL TO BINARY CONVERSION' 00056700 * 00056800 * ASSEMBLER ENTRY POINT FOR INPUT CONVERSION 00056900 * 00057000 BEGIN STM 14,7,12(13) SAVE REGISTERS 00057100 LA 3,0(0,1) R3 = LOCATION OF CODES 00057200 CLI 4(1),X'41' TEST FOR 'S' TYPE FIELD LOCATOR 00057300 BNE SETUP 'A' TYPE 00057400 EX 0,4(1) 'S' TYPE - CALCULATE FIELD ADDRESS 00057500 B SETUP+4 00057600 SETUP L 1,4(0,1) IS 'A' TYPE IF OPCODE NOT 'LA' 00057700 IC 7,3(0,3) FETCH WIDTH 00057800 N 7,MSK3 00057900 TM 2(3),6 TEST FOR HEXADECIMAL INPUT 00058000 BM HEXIN 00058100 LA 0,0(1,7) R0 = END OF SOURCE FIELD 00058200 LA 6,HIGH R6 = TARGET DIGIT LOCATOR 00058300 SR 2,2 R2 WILL RECEIVE FUNCTION BYTES 00058400 LR 4,6 R4 = R6; FLAG THAT DECIMAL NOT FOUND 00058500 XAMIN EX 7,XSCAN TRANSLATE AND TEST 00058600 BZ FINI END OF FIELD, NOTHING FOUND 00058700 B *(2) BRANCH ACCORDING TO THING FOUND 00058800 B NEGAT CODE 4 = NEGATIVE SIGN 00058900 B DECIM CODE 8 = DECIMAL POINT 00059000 MVC 0(1,6),0(1) CODE 12 = DIGIT. STORE IT 00059100 LA 6,1(6) INCREMENT DIGIT COUNT 00059200 NUSCAN LA 1,1(1) LOCATE NEXT SOURCE BYTE 00059300 LR 7,0 R7 = END OF SOURCE FIELD 00059400 SR 7,1 R7 = NEW SOURCE COUNT 00059500 BNM XAMIN RESCAN IF SOURCE BYTES REMAIN 00059600 * 00059700 * END SCAN OF SOURCE FIELD FOR MEANINGFUL CHARACTERS 00059800 * 00059900 FINI LA 7,HIGH+1 00060000 BXLE 4,6,FOUND IF DECIMAL FOUND, COMPUTE DIGITS IN R4 00060100 IC 4,1(3) NO. USE DEFAULT FROM CALL 00060200 N 4,MSK3 00060300 FOUND SR 6,7 COUNT NUMERALS FOUND IN R6 00060400 BNM PACK IF NO DIGITS FOUND, RESULT IS ZERO 00060500 SR 0,0 SET RESULT ZERO AND QUIT 00060600 SDR 0,0 00060700 LM 1,7,24(13) RESTORE 00060800 BR 14 RETURN 00060900 PACK EX 6,STUFF PACK DECIMAL DIGITS 00061000 S 6,EIGHT TEST FOR MORE THAN EIGHT CHARACTERS 00061100 BM LESS LESS 00061200 * 00061300 * MORE THAN EIGHT NUMERALS FOUND - DO TWO CONVERSIONS 00061400 * 00061500 EX 6,STUFF2 PACK HIGH ORDER DIGITS 00061600 CVB 7,HIGH CONVERT TO BINARY 00061700 M 6,SPLIT TIMES 10 TO EIGHTH 00061800 MVO LOW(4),ZERO(4) REMOVE EXTRA LOW ORDER DIGITS 00061900 CVB 0,LOW CONVERT LOW ORDER PART 00062000 ALR 7,0 ADD LOW ORDER TO HIGH ORDER 00062100 BC 12,TYPE NO CARRY. DOUBLE REGISTER IS DONE 00062200 A 6,DECADE CARRY. INCREASE R6 BY ONE 00062300 B TYPE 00062400 LESS CVB 7,LOW EIGHT OR FEWER DIGITS - ONE CONVERT 00062500 SR 6,6 NO HIGH ORDER 00062600 * 00062700 * CONVERSION COMPLETE - INTEGER IN R6,7. NOW FLOAT IF NEEDED 00062800 * 00062900 TYPE TM 2(3),X'88' 00063000 BNZ FIXED GO TO FIXED POINT INPUT 00063100 O 6,CHAR PUT IN CHARACTERISTIC 00063200 STM 6,7,LOW 00063300 LD 0,LOW MOVE TO FPR0 00063400 AD 0,ZERO NORMALIZE 00063500 SLA 4,3 R4 = DECIMAL SCALE. MAKE IT AN INDEX 00063600 DD 0,TENS+8(4) SCALE RESULT 00063700 TM 2(3),1 IS RESULT SINGLE PREC? 00063800 BZ FULL NO 00063900 STD 0,LOW YES, ROUND 00064000 XC LOW+1(3),LOW+1 GET RID OF HIGH ORDER BITS 00064100 AD 0,LOW 00064200 FULL LTR 3,3 WAS MINUS SIGN FOUND? 00064300 LM 0,7,20(13) RESTORE REGISTERS 00064400 BCR 11,14 BCR 11 = BNM 00064500 LNDR 0,0 YES, MAKE RESULT NEGATIVE 00064600 BR 14 RETURN 00064700 * 00064800 * COMPLETE FIXED-POINT INPUT 00064900 * 00065000 FIXED BM INTGER TEST AND BRANCH FOR INTEGER 00065100 C 4,DECADE+8 ERROR IF DECIMAL >9 00065200 BNL QUIT 00065300 IC 2,0(0,3) GET SCALE 00065400 SLA 4,2 MAKE DEC AN INDEX 00065500 N 2,MSK2 00065600 SLDA 6,1(2) APPLY SCALE + 1 00065700 BC 1,QUIT OVERFLOW 00065800 * 00065900 * NOTE: AS LONG AS DEC > 9 IS NOT ALLOWED, THIS OVERFLOW IS 00066000 * FATAL BECAUSE WILL GIVE DIVIDE CHECK ANYWAY 00066100 * IF D > 9 IS TO BE ALLOWED, ANOTHER METHOD OF SCALING 00066200 * IS NEEDED, REQUIRES DOUBLEWORD DIVISOR OR SCALED DIVISORS 00066300 * 00066400 L 0,DECADE+4(4) GET DIVISOR 00066500 ALR 7,0 ROUND. R6,7 = 2*I + 10**P 00066600 BC 12,*+8 TEST CARRY 00066700 A 6,DECADE PERFORM CARRY 00066800 CLR 6,0 SEE IF TOO BIG FOR SCALING 00066900 BC 10,QUIT 00067000 SRDA 6,1 FIX BINARY SCALE AGAIN 00067100 DR 6,0 SCALE RESULT 00067200 LR 0,7 OUTPUT TO R0 00067300 B FININ 00067400 * 00067500 * INTEGER INPUT. CHECK FOR OVERFLOW AND EXIT 00067600 * 00067700 INTGER OR 4,6 A DECIMAL PT OR HIGH ORDER 00067800 BNZ QUIT IS AN ERROR 00067900 LTR 0,7 RESULT TO R0 00068000 BM QUIT SIGN ALREADY SET IS OVERFLOW 00068100 FININ LTR 3,3 NOW TEST FOR NEGATIVE ARGUMENT 00068200 LM 1,7,24(13) RESTORE 00068300 L 14,12(13) LOCATE RETURN 00068400 BCR 11,14 (BCR 11 = BNMR) 00068500 LNR 0,0 SET RESULT NEGATIVE 00068600 BR 14 RETURN 00068700 * 00068800 * ACCOMPLISH HEXADECIMAL INPUT 00068900 * 00069000 HEXIN EX 7,STUFF4 MOVE FIELD TO WORK AREA 00069100 EX 7,STUFF5 TRANSLATE BYTES 00069200 EX 7,STUFF3 PACK INTO 'HIGH' 00069300 MVO HIGH(9),HIGH-1(9) GET RID OF 'SIGN' 00069400 LD 0,HIGH RESULT TO FPR0 00069500 L 0,HIGH+4 AND TO GPR0 00069600 LM 1,7,24(13) 00069700 BR 14 00069800 * 00069900 * OVERFLOW ON FIXED POINT CONVERSION 00070000 * 00070100 QUIT OI #ERSCAN+1,64 INDICATE 'TOO BIG' MESSAGE 00070200 BAL 14,MARK2 MARK THE OFFENDING INPUT 00070300 L 0,OMEGA SET LARGEST POSSIBLE ANSWER 00070400 B FININ 00070500 * 00070600 * OUT-OF-LINE EXCURSIONS FOR INPUT CONVERSION 00070700 * 00070800 XSCAN TRT 0(0,1),FUNC LOOK FOR '-', '.', AND DIGITS 00070900 NEGAT O 3,MAX SET R3 SIGN BIT TO SHOW NEGATIVE 00071000 B NUSCAN 00071100 DECIM LNR 4,6 R4 = -R6 = - LOC OF NEXT NUMERAL 00071200 B NUSCAN 00071300 STUFF PACK LOW,HIGH(0) COUNT SUPPLIED BY EX 00071400 STUFF2 PACK HIGH,HIGH(0) HIGH ORDER PACKING 00071500 STUFF3 PACK HIGH-1(9),PATTERN(0) REMOVE ZONES FROM HEX INPUT 00071600 STUFF4 MVC PATTERN(0),0(1) HEXADECIMAL INPUT TO WORK AREA 00071700 STUFF5 TR PATTERN(0),FUNC2 TRANSLATE HEXADECIMAL 00071800 TITLE 'CRYM CONTROL CARD SCAN' 00071900 * 00072000 * CONTROL CARD SCAN ROUTINES 00072100 * 00072200 * THESE ROUTINES ARE USED TO EXTRACT EBCDIC FIELDS FROM CONTROL 00072300 * CARDS READ (USUALLY) BY CRYIN. EITHER SCAN OR BLSCAN MUST BE 00072400 * CALLED ONCE FOR EACH FIELD. FIELDS ARE READ LEFT-TO-RIGHT 00072500 * SEQUENTIALLY AND ARE MOVED TO A PLACE SPECIFIED BY THE USER 00072600 * (FORTRAN) OR TO #FIELD (ASM). FROM THERE THEY CAN BE 00072700 * ANALYZED AND CONVERTED USING BCDIN IF DECIMAL. 00072800 * 00072900 * FORTRAN CALLS: 00073000 * 1) TO INITIALIZE (CALL ONCE AT START OF EACH NEW CARD) 00073100 * CALL CDSCAN(ARRAY,COL-1) 00073200 * 'ARRAY' IS LOC OF CARD TO BE SCANNED, BEGINNING IN COL. 'COL' 00073300 * 2) TO GET A FIELD - IGNORING ALL SINGLE BLANKS 00073400 * IC=SCAN(FIELD) 00073500 * 3) TO GET A FIELD - TERMINATED BY FIRST BLANK 00073600 * IC=BLSCAN(FIELD) (TREATED AS 'SCAN' IF 'SCAN' HAS BEEN 00073700 * ALREADY CALLED ONCE) 00073800 * DATA ARE RETURNED IN ARRAY 'FIELD' OF LENGTH 16 BYTES 00073900 * 'FIELD' SHOULD BE A FORTRAN ARRAY OF DIM(4) 00074000 * 'IC' IS A RETURN CODE WHICH IS SUPPLIED AS A FUNCTION 00074100 * VALUE IN R0 AND IS ALSO PLACED IN SECOND BYTE OF '#FLSCAN' 00074200 * (NOTE: 'SCAN' AND 'BLSCAN' MUST BE DECLARED INTEGER FUNCTIONS) 00074300 * RETURN CODE IS: 0 COMMA, QUOTES, OR ( ENDED FIELD 00074400 * 2 ASTERISK 00074500 * 4 BLANKS 00074600 * 8 RIGHT PARENS FOUND 00074700 * 12 EQUAL SIGN ENDED FIELD 00074800 * TO THESE CODES, 16 IS ADDED IF FIELD IS WITHIN PARENS 00074900 * WHEN CARD IS EXHAUSTED, CODES ARE: 00075000 * 32 NO ERRORS - ENDED BY 2 BLANKS 00075100 * 40 BLSCAN CALL - FIELD NOT FOUND 00075200 * 00075300 * A SERIES OF NUMBERED ERROR MESSAGES CAN BE PRODUCED 00075400 * IN WHICH THE LOCATION OF THE ERROR IS MARKED BY A '$' PRINTED 00075500 * BELOW THE CONTROL CARD AT THE POINT OF ERROR 00075600 * FORTRAN CALL TO ERMARK IS: 00075700 * CALL ERMARK(MCODE) 00075800 * WHERE 'MCODE' IS THE CODE NUMBER OF THE ERROR (INTEGER*4) 00075900 * 00076000 * CODES FOR ERRORS ARE: 1 INCORRECT PUNCTUATION 00076100 * 2 ILLEGIBLE FIELD 00076200 * 4 FIELD TOO LONG (16 CHARS MAX) 00076300 * 8 UNBALANCED PARENS 00076400 * 16 BLSCAN CALL - FIELD NOT FOUND 00076500 * 32 CONTROL CARD NOT RECOGNIZED 00076600 * 64 NUMERICAL VALUE OUT OF ALLOWED RANGE 00076700 * NOTE TO FORTRAN USERS: TO ASSURE THAT ALL MESSAGES 00076800 * GET PRINTED PROPERLY, ALL CARDS MUST BE PRINTED WITH 'CDPRNT' 00076900 * MESSAGES 4 AND 8 ARE PRODUCED AUTOMATICALLY BY THE SCANNING 00077000 * ROUTINES. THESE MESSAGES CAN BE INVOKED BY 'ERMARK' WHEN 00077100 * THE ERROR IS DISCOVERED BY THE USER. 00077200 * IN ADDITION, MESSAGE 1 (INCORRECT PUNCTUATION) CAN BE 00077300 * INVOKED AUTOMATICALLY ON A SCAN CALL FOR WHICH THE FIELD 00077400 * FOUND WAS NOT PRECEDED BY A COMMA (USEFUL, E.G., ON 00077500 * THE MAIN OPTION SCAN ON A CONTROL CARD) 00077600 * TO MAKE THIS CHECK, USE THE FOLLOWING FORTRAN CALL: 00077700 * IC = SCAN(FIELD,IEXIT) 00077800 * 'IEXIT' IS A VARIABLE WHICH IS SET NON-ZERO WHEN AN ERROR IS 00077900 * FOUND ON ANY SCAN. IN ADDITION 00078000 * MESSAGE 16 (FIELD NOT FOUND) CAN BE SUPPLIED AUTOMATICALLY 00078200 * ON A BLSCAN CALL WHEN END OF CARD IS REACHED BY: 00078300 * IC = BLSCAN(FIELD,IEXIT) 00078400 * 00078500 * NOTE: CODES FOR ERRORS ARE STORED IN #ERSCAN+1 UNTIL MESSAGES 00078600 * ARE PRINTED, THEN #ERSCAN+1 IS ZEROED AND #ERSCAN IS SET TO 1 00078700 * TO INDICATE GENERAL ERROR. AFTER ALL CONTROL CARDS ARE IN, ONE 00078800 * CAN TEST #ERSCAN TO DECIDE WHETHER TO CONTINUE EXECUTION. 00078900 * 00079000 * ASSEMBLER INSTRUCTIONS: 00079100 * TO INITIALIZE, PUT LOCATION OF CARD RECORD IN R12, AND IN 00079200 * R1 PUT LOCATION OF A FULLWORD OF THE FORM 00079300 * AL1(COL-1),AL3(EXIT) 00079400 * THEN SET R15=V(COMM) AND BAL 14,#CDSCAN (#CDSCAN=COMM+28) 00079500 * ALL OTHER CALLS ARE ANALOGOUS TO FORTRAN EXCEPT AT END OF 00079600 * CARD RETURN IS TO 'EXIT' GIVEN ABOVE INSTEAD OF AFTER BAL 00079700 * AND 'FIELD' IS NOT AN ARGUMENT - LOCATION OF FIELD 00079800 * (NAMELY, CELL '#FIELD') IS RETURNED IN R1 00079900 * 00080000 * ASSEMBLER USERS CAN PRODUCE ERMARK MESSAGES BY 00080100 * 'OR'ING (OI INSTRUCTION) THE CODE INTO #ERSCAN+1 AND EXECUTING 00080200 * BAL 14,#ERMARK 00080300 * 00080400 * CARDS BEING SCANNED MAY BE CONTINUED ON AS MANY FURTHER 00080500 * CARDS AS NEEDED. TO CONTINUE, BREAK OFF AT A COMMA, (, OR 00080600 * = SIGN, OR PUT ANY CHARACTER IN COL. 72, AND LEAVE COLS. 00080700 * 1-4 OF FOLLOWING CARD BLANK. WHEN TEXT RUNS INTO COL. 71, 00080800 * AND COL. 72 IS NOT BLANK, FIELD CONTINUES IN FIRST NON-BLANK 00080900 * COL. OF FOLLOWING CARD. COMMENTS ARE ALLOWED 00081000 * ON ANY CARD, SEPARATED FROM TEXT BY AT LEAST TWO BLANKS. 00081100 * TWO BLANKS TERMINATE PROCESSING IF NO CONTINUATION. 00081200 * (NOTE: CONTINUATION CARDS ARE READ FROM CURRENT CRYIN UNIT) 00081300 * 00081400 * REGISTERS USED ARE AS FOLLOWS 00081500 * 00081600 * 0 SCRATCH 00081700 * 1 ARGUMENT ADDRESS OF TRT (USED TO LOCATE END FOR SCNFU) 00081800 * 2 FUNCTION BYTE 00081900 * 3 TRT COUNT; CNTINU OLD SAVE AREA 00082000 * 4 CURRENT LOCATION IN OUTPUT FIELD 00082100 * 5 BEGINNING OF CURRENT TRT 00082200 * 6 = F'1' 00082300 * 7 ADDRESS OF END OF CARD (COL. 71) 00082400 * 8 ADDRESS OF BEGINNING OF FIRST TRT OF THIS FIELD 00082500 * 9 REMAINING FIELD COUNT LESS 1 00082600 * 10 LOCATION OF VARIABLE SYMBOL 00082700 * 11 CNTINU AND UPDATE RETURN ADDRESS 00082800 * 12 NEW CARD LOCATION; FIELD MOVE COUNT 00082900 * 13 SAVE AREA 00083000 * 14 RETURN 00083100 * 15 BASE 00083200 * 00083300 * INTERNAL FLAGS IN LOCATION 'F' ARE: 00083400 PN EQU X'01' IN PARENS 00083500 QT EQU X'02' IN QUOTES 00083600 SBL EQU X'04' PERFORMING SCAN, NOT BLSCAN 00083700 TER EQU X'08' FORCE SCAN TERMINATION ON NEXT CALL 00083800 FTN EQU X'10' CALL WAS FROM FORTRAN 00083900 IN EQU X'20' INITIAL IN FIELD, DATA NOT FOUND YET 00084000 AMP EQU X'40' AMPERSAND FOUND - PROCESSING VAR SYM 00084100 CEPA EQU X'80' COMMA, EQUAL SIGN, LEFT PAREN ENDED FLD 00084200 EJECT 00084300 ACDSCN L 0,0(1) ASSEMBLER SCAN INITIALIZATION 00084400 ST 0,SEXIT STORE EXIT 00084500 SRL 0,24 COLUMN TO RIGHT OF R0 00084600 LA 1,0(0,12) GET RID OF ANY HIGH ORDER BITS 00084700 AR 1,0 R1 = STARTING LOCATION 00084800 H70 EQU *+2 00084900 LA 0,70(12) R0 = ENDING LOCATION 00085000 CR 0,1 ARE THERE ANY COLUMNS? 00085100 BL ABEND20 NO, QUIT 00085200 STM 0,1,SCEND STORE LOCATIONS 00085300 MVI F,0 SET FLAGS 00085400 BR 14 RETURN 00085500 ABEND20 ABEND 20 00085600 * 00085700 * SCAN ONE FIELD (ASCAN = ASMBLR, BSCAN = FTN) 00085800 * 00085900 ASCAN OI F,SBL FLAG BLANK SCAN 00086000 ABLSCN LA 1,#FIELD LOCATE OUTPUT FIELD 00086100 STM 14,12,12(13) SAVE CALLER'S REGISTERS 00086200 LR 4,1 LOCATE FIELD 00086210 BSCAN TM F,SBL+FTN IS IT FORTRAN CALL TO SCAN? 00086250 MVC 0(16,4),BLANKS BLANK OUTPUT FIELD 00086252 BNO BSC1 (FTN SCAN, ASM CDSCAN DOESN'T BRANCH) 00086255 TM 0(1),VL+C' ' IS PUNCTUATION TEST REQUESTED? 00086260 BNZ BSC1 NO 00086265 TM RF,ALL-4 WAS PREVIOUS PUNCT COMMA OR BLANK? 00086270 BZ BSC1 YES, OK 00086275 L 14,4(0,1) ERROR, LOCATE USER'S ERROR FLAG 00086280 OI 3(14),1 SET IT 00086285 OI #ERSCAN+1,1 SET PUNCT ERROR CODE 00086290 BAL 14,AMARK MARK IT 00086295 BSC1 OI F,IN FLAG INITIAL IN FIELD 00086300 LA 6,1 R6 = F'1' FOR THE DURATION 00086500 LM 7,8,SCEND LOAD SCAN LIMITS 00086600 TM F,TER TERMINATED ON PREVIOUS FIELD? 00086700 BO ACTV YES, GO END SCAN 00086800 LA 9,15 FIELD LENGTH REMAINING (LESS 1) 00087000 MVI RF,0 ZERO RETURN CODE 00087100 SSTART LR 5,8 LOCATE SOURCE DATA 00087200 SCNMORE SR 2,2 CLEAR R2 FOR FUNCTION BYTE 00087300 LA 1,1(0,7) SET R1 AS IF DELIMITER IN COL. 72 00087400 LR 3,7 MAX SCAN COUNT = 71 - CURR. COL. 00087500 SR 3,5 00087600 BM SCN0 ALREADY IN COL. 72 - DON'T SCAN 00087700 EX 3,SCTRT TEST FOR A DELIMITER 00087800 BZ SCN0 INTO COL. 71 - LOOK FOR CONTINUATION 00087900 BAL 11,UPDATE MOVE DATA TO USER FIELD 00088200 TM F,QT IN QUOTES? 00088300 BO QUOTED YES, GO IGNORE DELIMITER 00088400 * NOTE: CONDITION CODE MUST BE 0 HERE 00088500 DISPATCH BZ *(2) BRANCH ACCORDING TO DELIMITER 00088600 B SCN1 04 - BLANK 00088700 B SCN6 08 - RIGHT PARENS 00088800 B SCN5 12 - EQUALS SIGN 00088900 BZ SCN2 16 - QUOTE (BZ STOPS SKPBLNKS) 00089000 B SCN3 20 - COMMA 00089100 BZ SCN4 24 - LEFT PARENS 00089200 B SCN7 28 - ASTERISK 00089300 B ACTIV 32 - SEMICOLON 00089400 BZ SCN8 36 - AMPERSAND 00089500 * 00089600 * ACTION WHEN NO FUNCTION BYTE FOUND - DATA IN COL. 71 00089700 * 00089800 SCN0 BAL 11,UPDATE MOVE DATA, IF ANY, TO USER FIELD 00089900 COL72 BAL 11,CONTEST CHECK FOR CONTINUATION 00090000 B SSTART FOUND, CONTINUE SCANNING 00090100 B ACTIV NOT FOUND, END FIELD AND CARD 00090200 * 00090300 * ACTION WHEN BLANK FOUND 00090400 * 00090500 SCN1 TM F,SBL SCAN OR BLSCAN? 00090600 BZ SKB2 BLSCAN - GO SKIP GROUP OF BLANKS 00090700 BXH 8,6,COL72 SCAN - LOOK AT NXT COL UNLESS HIT 72 00090800 CLI 0(8),C' ' SECOND BLANK FOUND? 00090900 BNE SSTART NO, CONTINUE SCAN, IGNORE BLANK 00091000 B SKBCT YES, GO CHECK FOR FURTHER PUNCT 00091100 * 00091200 * ACTION WHEN QUOTE FOUND (NOT ALREADY IN QUOTES) 00091300 * 00091400 SCN2 TM F,IN INITIAL IN FIELD? 00091500 BZ IGNORE NO, TREAT AS DATA 00091600 OI F,QT YES, SET QUOTE FLAG ON 00091700 NI F,ALL-CEPA CONTINUATION EXPECTED FLAG OFF 00091800 B ACTIII CONTINUE SCAN AT NEXT CHARACTER 00091900 * 00092000 * ACTION WHEN IN QUOTES AND ANY DELIMITER IS FOUND 00092100 * 00092200 QUOTED CLI 0(1),C'''' WAS CHARACTER A QUOTE? 00092300 BNE IGNORE NO, TREAT AS DATA 00092400 CLI 1(1),C'''' YES, IS NEXT CHAR ALSO QUOTE? 00092500 BNE QTD1 NO, GO END QUOTED STRING 00092600 AR 1,6 YES, INCLUDE FIRST QUOTE IN FIELD 00092700 BAL 11,UPDATE 00092800 B ACTIII 00092900 QTD1 NI F,ALL-IN-QT-CEPA TERMINATE QUOTED STRING 00093000 B SKPBLNKS SEEK OTHER PUNCT 00093100 * 00093200 * ACTION WHEN COMMA OR EQUALS SIGN FOUND 00093300 * 00093400 SCN5 OI RF,12 EQUAL SIGN: RETURN CODE = 12 00093500 SCN3 OI F,CEPA COMMA: CONTINUATION EXPECTED 00093600 B ACTII 00093700 * 00093800 * ACTION WHEN LEFT PARENTHESIS FOUND 00093900 * 00094000 SCN4 TM F,PN ALREADY IN PARENS? 00094100 BZ SCN41 NO, OK 00094200 LA 14,ACTIII SET ERROR RETURN 00094300 SCNP OI #ERSCAN+1,8 YES, SET ERROR CODE 00094400 B ERMARKIN IGNORE CHARACTER, RETURN VIA R14 00094500 SCN41 OI F,CEPA FLAG CONTINUATION EXPECTED 00094600 TM F,IN INITIAL? 00094700 BZ ACTIIR NO END FIELD, REUSE LATER 00094800 OI F,PN YES, SET PARENS FLAG ON 00094900 B ACTIII AND CONTINUE SCAN 00095000 * 00095100 * ACTION WHEN RIGHT PARENTHESIS FOUND 00095200 * 00095300 SCN6 TM F,PN ALREADY IN PARENS? 00095400 LA 14,SKPBLNKS SET ERROR RETURN FOR SCNP 00095500 BZ SCNP NO, ERROR 00095600 NI F,ALL-IN-PN-CEPA TERMINATE PARENTHESIZED FIELD 00095700 OI RF,24 RETURN CODE = 24 00095800 BR 14 LOOK FOR FOLLOWING COMMA (SKPBLNKS) 00095900 * 00096000 * ACTION WHEN ASTERISK FOUND 00096100 * 00096200 SCN7 OI RF,2 RETURN CODE = 2 00096300 OI F,CEPA EXPECT CONTINUATION 00096400 B ACTII TERMINATE FIELD 00096500 * 00096600 * ACTION WHEN AMPERSAND FOUND 00096700 * 00096800 SCN8 OI F,AMP SET FLAG FOR SEARCH TABLE UPDATE 00096900 B ACTIII 00097000 EJECT 00097100 * 00097200 * ACTION I - CONTINUE SCAN, TREATING CHARACTER AS DATA 00097300 * 00097400 IGNORE LA 5,1(0,1) START SCAN AT NEXT CHARACTER 00097500 B SCNMORE 00097600 * 00097700 * ACTION II - END OF FIELD 00097800 * 00097900 ACTII AR 1,6 SKIP OVER PUNCT CHARACTER 00098000 ACTIIR ST 1,CBEG HERE TO REUSE PUNCT CHAR 00098100 ACT2A TM F,PN IN PARENS? 00098200 BZ *+8 NO 00098300 OI RF,16 YES, ADD 16 TO RET CODE 00098400 LA 0,14 CALCULATE LENGTH OF FIELD 00098500 SR 0,9 00098600 STC 0,#LENGTH 00098700 LM 14,12,12(13) RESTORE 00098800 LH 0,#FLSCAN SET RETURN CODE 00098900 BR 14 RETURN 00099000 * 00099100 * ACTION III - CONTINUE SCAN, OMITTING PRESENT CHARACTER 00099200 * 00099300 ACTIII LA 8,1(0,1) START SCAN AND MOVE AT FOLLOWING CHAR 00099400 B SSTART 00099500 * 00099600 * ACTION IV - END OF FIELD AND CARD 00099700 * 00099800 ACTIV OI F,TER TERMINATE NEXT TIME 00099900 OI RF,4 SIGNAL LAST FIELD 00100000 ST 1,CBEG UPDATE CBEG FOR LATER ERMARK 00100100 TM F,PN+QT IN PARENS OR QUOTES? 00100200 BZ ACT4A NO 00100300 OI #ERSCAN+1,8 YES, SET ERROR CODE - UNBALANCED 00100400 BAL 14,ERMARKIN 00100500 ACT4A BAL 11,CONCOMM IS CONTINUED COMMENT PRESENT? 00100600 B ACT4A YES, LOOK FOR ANOTHER 00100700 TM F,IN NO, ANY DATA IN THIS FIELD? 00100800 BZ ACT2A YES, DO END-OF-FIELD RETURN 00100900 TM F,SBL NO, IS IT BLSCAN? 00101000 BNZ ACTV 00101100 L 14,24(0,13) YES, LOCATE USER'S PARM LIST 00101200 TM 0(14),X'C0' IS THIS A REQUIRED FIELD (OR ASM CALL)? 00101300 BNZ ACTV NO, MAKE NORMAL EXIT 00101400 L 14,4(0,14) YES, SET USER'S ERROR FLAG 00101500 OI 3(14),1 00101600 OI #ERSCAN+1,16 ERROR CODE - MISSING FIELD 00101700 BAL 14,ERMARKIN 00101800 *FALL THROUGH TO ACT V 00101900 * 00102000 * ACTION V - END OF CARD WHILE INITIAL IN FIELD 00102100 * 00102200 ACTV MVI RF,32 NORMAL END EXIT CODE 00102300 TM F,SBL IS IT BLSCAN? 00102400 BNZ *+8 00102500 OI RF,8 YES, FIELD NOT FOUND CODE 00102600 TM F,FTN FORTRAN CALL? 00102700 LM 14,12,12(13) RESTORE USER REGISTERS 00102800 LH 0,#FLSCAN SET RETURN CODE 00102900 BCR 1,14 FORTRAN RETURN 00103000 L 14,SEXIT ASSEMBLER RETURN 00103100 BR 14 00103200 EJECT 00103300 * 00103400 * SUBROUTINE 'CONTEST' TO DETERMINE WHETHER A CONTINUATION 00103500 * CARD HAS BEEN REQUESTED; AND 'CNTINU' TO PROCESS SAME 00103600 * CALL BY: BAL 11,CONTEST 00103700 * OR BAL 11,CNTINU 00103800 * RETURNS 4(11) IF CONTINUATION NOT FOUND; 0(11) IF OK 00103900 CONTEST TM F,CEPA PREV FLD ENDED BY COMMA, ETC.? 00104000 BNZ CNTINU YES, EXPECT CONTINUATION 00104100 CONCOMM CLI 1(7),C' ' COL. 72 BLANKS? 00104200 BE 4(11) YES, NO CONTINUATION 00104300 CNTINU NWSV SAVER,3 00104400 OI CNTSW,VL END MESSAGE 00104500 IC 2,ACCPT FETCH OLD PRINT FLAG 00104550 BAL 14,INCOME READ NEXT CARD 00104600 NI CNTSW,ALL-VL RESET CONTINUATION SWITCH AND MESSAGE 00104700 CLC 0(4,12),BLANKS TEST FOR 4 BLANKS 00104800 BE CNTV OK, VALID CONTINUATION 00104900 OI ACCPT,X'0F' REJECT CARD 00105000 BAL 1,CNT1 PRINT ERROR MESSAGE 00105100 DC X'0A',AL1(L'MESS3),SL2(MESS3) 00105200 DC X'80',AL1(L'MESS4),SL2(MESS4) 00105300 CNT1 BAL 14,PRNCOM 00105400 CNTR LR 1,7 RESTORE CARD LOCATION 00105500 LR 13,3 RESTORE SAVE AREA 00105600 B 4(11) RETURN TO CALLER - ERROR EXIT 00105700 CNTV NR 2,6 VALID CONTINUATION, SHOULD I PRINT? 00106010 BZ CNT2 NO, BECAUSE CDPRNT WASN'T CALLED 00106020 BAL 14,INPRT1 YES, PRINT IT 00106060 CNT2 DS 0H 00106070 LA 7,70(0,12) LOCATE NEW END OF CARD 00106100 LA 8,4(12) 00106200 ST 7,SCEND SAVE END OF CARD 00106300 TM F,QT IF IN QUOTES, 00106400 BO CNT4 RETURN WITH COL. 5 NEXT, 00106500 CNT3 CLI 0(8),C' ' OTHERWISE, SKIP OVER LEADING BLANKS 00106600 BNE CNT4 00106700 BXLE 8,6,CNT3 LOOP TO COL. 72 00106800 OI F,TER EMPTY CARD 00106900 B CNTR 00107000 CNT4 LR 13,3 RESTORE SAVE AREA 00107100 BR 11 NORMAL EXIT 00107200 EJECT 00107300 * 00107400 * SUBROUTINE 'UPDATE' TO MOVE DATA TO RESULT FIELD 00107500 * CALL BY: BAL 11,UPDATE 00107600 * WITH LOC OF LAST CHAR + 1 IN R1 00107700 * DON'T TOUCH R1, 2, 6, 7, 13, 15 00107800 * 00107900 UPDATE LR 12,1 CALCULATE COUNT FOR MOVE 00108000 SR 12,8 00108100 SR 12,6 00108200 BCR 4,11 RETURN IF NO DATA 00108300 TM F,AMP TEST FOR VARIABLE SYMBOL 00108400 BZ UPD5 00108500 * 00108600 * LOOK UP VARIABLE SYMBOL AND REPLACE WITH ITS VALUE 00108700 * 00108800 MVC LOW(8),BLANKS 00108900 N 12,MSK6 NOT TOO MUCH 00109000 EX 12,VSMVC 00109100 L 10,VSTAB+4 00109200 B UPD3A 00109300 UPD3 CLC LOW(7),17(10) COMPARE SYMBOL WITH TABLE 00109400 BE UPD4 FOUND 00109500 LA 10,24(10) SCAN TABLE 00109600 UPD3A C 10,VSTOP 00109700 BNH UPD3 00109800 OI #ERSCAN+1,2 END OF TABLE - BAD SYMBOL 00109900 BAL 14,ERMARKIN BOMBS R3, R0 00110000 B UPD5 00110100 UPD4 LR 8,10 00110200 IC 12,16(0,10) 00110300 UPD5 CR 12,9 IS FIELD TOO LONG? 00110400 BNH UPD1 NO 00110500 OI #ERSCAN+1,4 YES, SET ERROR CODE 00110600 LA 3,70(9,8) LOCATE END OF MAX FIELD 00110700 BAL 14,REMARKIN MARK THE ERROR (BOMBS R3, R0) 00110800 LTR 12,9 SET MAX COUNT 00110900 BCR 4,11 EXIT IF NEGATIVE 00110910 UPD1 EX 12,SCMVC MOVE DATA 00111000 AR 12,6 UPDATE COUNTS: R12 = R12 + 1 00111100 AR 4,12 00111200 LR 8,1 00111300 SR 9,12 00111400 NI F,ALL-IN-CEPA-AMP CLEAR INITIAL, CONTINUE, SYMBOL 00111500 BR 11 RETURN 00111600 SCMVC MVC 0(0,4),0(8) MOVE DATA TO FIELD 00111700 VSMVC MVC LOW(0),0(8) VARIABLE SYMBOL MOVER 00111800 * 00111900 * ROUTINE 'SKPBLNKS' TO SKIP BLANKS, LOOKING FOR 00112000 * POSSIBLE MULTIPLE PUNCTUATION (E.G. ")," OR "',") 00112100 * 00112200 SKPBLNKS LA 0,2 MAX 2 COLS IF SCAN 00112300 TM F,SBL SCAN OR BLSCAN? 00112400 BNZ SKB3 SCAN 00112500 SKB2 LA 0,71 BLSCAN, MAX 71 COLS 00112600 SKB3 BXH 8,6,SKBCT ADVANCE COL., QUIT IF PAST COL. 71 00112700 CLI 0(8),C' ' IS NEXT CHAR BLANK? 00112800 BNE SKB4 NO, STOP SKIPPING 00112900 BCT 0,SKB3 YES, SKIP MORE UNTIL COUNT EXHAUSTED 00113000 SKBCT BAL 11,CONTEST NO MORE THIS CARD, IS IT CONTINUED? 00113100 B SKB4 YES 00113200 B ACTIV NO 00113300 SKB4 TM F,IN CONTINUED, IS IT INITIAL? 00113400 BNZ SSTART YES, LOOK FOR MORE DATA 00113500 SR 2,2 NO, CHECK FOR SPECIAL END DELIMITERS 00113600 LR 5,8 00113700 LR 1,8 00113800 SCTRT TRT 0(0,5),FUNC3 SEE WHAT THE CHAR IS 00113900 OR 6,6 MAKE COND CODE .NE. 0 00114000 EX 0,DISPATCH(2) TREAT AS SUCH UNLESS 0, 16, 24, OR 36 00114100 OI RF,4 SET CODE FIELD - ENDED BY BLANKS 00114200 B ACTIIR DISALLOWED EXTRA PUNCT, GO END FIELD 00114300 * 00114400 * SUBROUTINE 'ERMARK' TO PUT $ UNDER ERRORS (INTERNAL) 00114500 * WARNING: DO NOT BOMB R1 (INTERNAL) OR R2-R12 (ANY CALL) 00114600 * 00114700 ERMARKIN LA 3,70(1) COMPUTE DISPLACEMENT OF ERROR ON CARD 00114800 REMARKIN SR 3,7 00114900 LA 3,DMESS+4(3) PUT $ IN MESSAGE 00115000 MVI 0(3),C'$' 00115100 B MARK2 00115200 * 00115300 * EXTERNAL FORTRAN OR ASSEMBLER CALL - ERMARK 00115400 * 00115500 AMARK TM #ERSCAN+1,32 00115600 BNZ MARK2 PREVENT $ ON BAD CARD MSG 00115700 L 1,CBEG COMPUTE LOCATION OF ERROR 00115800 S 1,SCEND 00115900 LA 1,DMESS+73(1) 00116000 MVI 0(1),C'$' 00116100 MARK2 OI #ERSCAN,1 FLAG TO END XEQ 00116200 LR 0,1 SAVE R1 00116300 L 1,ACARD SET IEXIT .NE. 0 00116400 USING CARD,1 00116500 OI IEXIT+3,1 00116600 DROP 1 00116700 LR 1,0 RESTORE R1 00116800 MVC OVL1(4),SCB OVERLAY PRINT PROGRAM TO 00116900 MVC OVL2(4),SCB PRINT THE ERROR 00117000 BR 14 RETURN 00117100 TITLE 'CONSTANTS AND STORAGE FOR CONVERSIONS' 00117200 * 00117300 * CONSTANTS AND STORAGE FOR CONVERSION AND SCANNING ROUTINES 00117400 * 00117500 TENS DC D'1.0,1.0,10.0,1E2,1E3,1E4,1E5,1E6,1E7' 00117600 DC D'1E8,1E9,1E10,1E11,1E12,1E13,1E14,1E15' 00117700 TOP DC D'1E16' 00117800 HALF DC D'0.5' 00117900 CHAR DC XL8'4E00000000000000' 00118000 MONE DC F'-1' 00118100 MSK2 DC X'0000001F' 00118200 MSK3 DC X'0000000F' 00118300 MSK6 DC X'00000007' 00118500 MSK7 DC X'1F000000' 00118600 MSK8 DC X'48000000' 00118700 OMEGA DC X'7FFFFFFF' 00118800 MAX DC X'80000000' 00118900 DECADE DC F'1.0,1.0,10.0,1E2,1E3,1E4,1E5,1E6,1E7' 00119000 SPLIT DC F'1E8,1E9' 00119100 THREE DC F'3' 00119200 FOUR DC F'4' 00119300 EIGHT DC F'8' 00119400 LOGTWO DC FS31'0.30103' 00119500 ACARD DC A(CARD) 00119600 SELECT DC X'40',18X'20' EDIT PATTERN 00119700 SSPT DC X'214B' SIG START + DEC PT 00119800 SSDSPT DC X'21204B' SIG START + DIGIT SELECT + DEC PT 00119900 STARS DC 4C'*' OVERFLOW ERROR SIGNAL 00120000 TABLE DC C'0123456789ABCDEF' HEXADECIMAL TRANSLATION TABLE 00120100 VSTAB DC F'0',A(1,0) VARIABLE SYMBOL TABLE: LENGTH, START 00120200 VSTOP EQU VSTAB+8 AND STOP 00120300 * 00120400 * TRANSLATE AND TEST TABLE 00120500 * 00120600 FUNC3 DS 0D 00120700 ZERO DC 64X'00' 00120800 DC X'04',12X'00',X'18',14X'00',X'1C0820' 00120900 DC 12X'00',X'14',17X'00',X'100C00' 00121000 DC 64X'00' 00121100 FUNC DC 64X'00' 00121200 FUNC2 DC 11X'00',X'08',20X'00',X'04',31X'00' 00121300 DC 64X'00' 00121400 DC 48X'00',10X'0C',6X'00' 00121500 DC X'000A0B0C0D0E0F',41X'00',X'00010203040506070809',6X'00' 00121600 * 00121700 * ERROR MESSAGES 00121800 * 00121900 CMESS DC C'0' SINGLE 0 AS LINE SKIP CHARACTER 00122000 BLANKS DC 16C' ',C'0' 00122100 MESS3 DC C'0***EXPECTED CONTINUATION CARD NOT FOUND.' 00122200 MESS4 DC C' SCAN END FORCED.' 00122300 MESS5 DC C' ***BAD CONTINUATION.' 00122400 DMESS DC 76C' ' DOLLAR SIGN MESSAGE 00122500 EJECT 00122600 * 00122700 * DEFINITION OF WORKING STORAGE 00122800 * 00122900 DS 0D ALIGN 00123000 ARG DS F FIXED POINT ARGUMENT 00123100 PATTERN DS CL19 EDMK DESTINATION (START ON 4,8 BDRY) 00123200 GUARD DS CL1 00123300 LOW DS D LOW ORDER PACKED DECIMAL 00123400 HIGH EQU LOW-8 HIGH ORDER PACKED DECIMAL 00123500 SAVER DS 18F SAVE AREA FOR CNTINU, CDPRNT 00123600 SCEND DS D END OF SCAN (COL. 72 ADDRESS) 00123700 CBEG EQU SCEND+4 CURRENT LOCATION OF SCAN 00123800 SEXIT DS F RETURN POINT FOR END OF SCAN 00124000 F EQU SEXIT FLAGS IN LEFTMOST BYTE 00124100 CNTSW EQU MESS5 VL BIT ON IF CRYIN CALLED BY CNTINU 00124110 TITLE 'PRINTING, PUNCHING, CARD READING AND LISTING' 00124200 * 00124300 * FORTRAN CALLING SEQUENCE FOR PRINTING OR PUNCHING IS: 00124400 * CALL CRYOUT(FIELD,LENGTH+256*CODE,...) 00124500 * CALL PUNCH(FIELD,LENGTH+256*CODE,...) 00124600 * 'FIELD' IS EBCDIC ARRAY TO BE WRITTEN OR A LITERAL 00124700 * 'LENGTH' IS NUMBER OF CHARACTERS IN 'FIELD' 00124800 * 'CODE' IS MADE UP AS DESCRIBED BELOW (SEE 'CC') 00124900 * FIELD AND CODE ENTRIES MAY ALTERNATE, AS MANY AS DESIRED 00125000 * THE 'LENGTH+256*CODE' PART MUST BE AN INTEGER*4 VARIABLE 00125100 * ALL OPERATIONS ARE COMPLETELY COMPATIBLE WITH FORTRAN 00125200 * I/O AND CAN BE INTERMIXED FREELY 00125300 * (NOTE: EXCEPT THAT A SPECIAL VERSION OF FORTRAN LIBRARY 00125400 * ROUTINE FIOCS# MUST BE SUPPLIED) 00125500 * 00125600 * ASSEMBLER LANGUAGE CALL MAY BE SAME AS FORTRAN OR 00125700 * LOAD REGISTERS AS FOLLOWS: 00125800 * R1 LOCATION OF PARAMETER LIST 00125900 * R13 LOCATION OF SAVE AREA 00126000 * R14 RETURN ADDRESS 00126100 * R15 ADDRESS OF 'COMM' 00126200 * AND BRANCH TO 'COMM+12' FOR PRINT, 'COMM+16' FOR PUNCH, 00126300 * OR 'COMM+20' FOR LINE CONTROL 00126400 * THE PARAMETER LIST CONTAINS FOUR BYTE ITEMS ON HALFWORD 00126500 * 'CC' IS SERVICE CODE, MADE UP AS FOLLOWS: 00126600 * BOUNDARIES OF FORM 'CCWWRDDD' 00126700 * 0000 XXXX XXXX=0000 CONTINUE CURRENT LINE 00126800 * (IF FIRST LIST ITEM, STARTS A NEW LINE, 00126900 * GENERATES BLANK CARRIAGE CONTROL) 00127000 * XXXX=1LLL BEGIN NEXT LINE 00127100 * FIELD MUST BEGIN WITH CARRIAGE CONTROL 00127200 * SUCH THAT 'LLL' LINES ARE FILLED 00127300 * XXXX=1111 BEGIN NEW PAGE 00127400 * TITLES AND SUBTITLES ARE SUPPLIED 00127500 * ASSUMES ONE LINE WILL BE WRITTEN 00127600 * 000X 0000 X=1 TO OMIT AUTOMATIC PAGINATION 00127700 * 0XX0 0000 XX=00 NORMAL FIELD 00127800 * XX=01 FIELD IS A NEW SUBTITLE 00127900 * NEXT PRINT CALL WILL BEGIN NEW PAGE 00128000 * (SUBTITLE IS INITIALLY BLANKS) 00128100 * XX=11 FIELD IS A NEW SUBTITLE 00128200 * THE NEW SUBTITLE BEGINS AT THE CURRENT 00128300 * LINE, AND A NEW PAGE IS NOT FORCED 00128400 * X000 0000 X=1 END OF LIST (NOT USED FOR FORTRAN) 00128500 * 00128600 * 'WW' IS WIDTH OF FIELD - MAX 255 00128700 * 'RDDD' IS 'S' TYPE ADDRESS CONSTANT LOCATING DATA FIELD 00128800 * 'R' IS ANY REGISTER EXCEPT 13, 'DDD' IS DISPLACEMENT 00128900 * 00129000 * OBVIOUSLY, SUBTITLES MAY NOT BE USED FOR PUNCH 00129100 * IF A LINE OVERFLOWS, IT IS CONTINUED ON NEXT LINE 00129200 * TO LEAVE A BLANK LINE BELOW SUBTITLE, INCLUDE IT IN LIST 00129300 * E.G. DC X'8902',S(DUM) 00129400 * DUM DC C' ' 00129500 * 00129600 * ALL GPR ARE SAVED 00129700 * 00129800 * ERROR PROCEDURES: IF THE SUBTITLE IS TOO LONG (SEE 00129900 * PARAMETER &SBHDCH), ABEND 050 RESULTS. IF PAGINATION OCCURS 00130000 * DURING SUBHEAD OR PUNCH PROCESSING, ABEND 051 RESULTS. 00130100 * I/O ERRORS ARE HANDLED BY STANDARD IBCOM ERROR MESSAGES 00130200 * 00130300 * REMOTE TERMINAL FACILITY: 00130400 * WHEN 'CRYM' IS RUN FROM A TELETYPE TERMINAL, A SELECTED 00130500 * PORTION OF THE OUTPUT CAN BE SENT BACK TO THE TERMINAL 00130600 * VIA ERROR UNIT AS SPECIFIED IN IHCUATBL. THIS FEATURE 00130700 * IS CONTROLLED BY SUBROUTINE SPOUT (FORTRAN) OR 00130800 * #SPOUT (ASSEMBLER). CALL AS FOLLOWS: 00130900 * FORTRAN CALL SPOUT(N) 00131000 * ASSEMBLER L 1,=N 00131100 * BAL 14,#SPOUT (R15=A(COMM)) 00131200 * IF N<0, THE EXTRA PRINT IS INACTIVATED (NORMAL SITUATION) 00131300 * IF N=0, THE EXTRA PRINT IS ENABLED, SUCH THAT FUTURE CALLS 00131400 * WITH N>0 WILL BE RECOGNIZED. 00131500 * IF N>0, AND A PREVIOUS N=0 CALL WAS MADE, THEN THE PRINT 00131600 * FROM THE NEXT 'N' CRYOUT CALLS IS SENT TO THE TERMINAL 00131700 * (AS WELL AS TO SYSOUT). ALL CARRIAGE CONTROLS ARE 00131800 * CONVERTED TO BLANKS, AND SUBTITLES ARE SENT ONLY ONCE, 00131900 * WHEN FIRST ENTERED. 00132000 * NOTE: IF AN N=0 CALL HAS BEEN MADE, THEN ALL ERROR MESSAGES 00132100 * (WHOSE FIRST TEXT CHARACTER IS '*') ARE SENT TO THE 00132200 * TERMINAL AUTOMATICALLY. CONTROL CARDS MARKED BY 00132300 * #ERMARK ARE ALSO SENT. 00132400 * 00132500 * TO GUARANTEE THAT A GROUP OF N LINES END UP ON THE SAME PAGE, 00132600 * USE THE LINES CODE 'LLL' IF N<7. OTHERWISE, USE 'LINES' 00132700 * SUBROUTINE 00132800 * FORTRAN: CALL LINES(N) 00132900 * ASSEMBLER: LA 1,N 00133000 * BAL 14,COMM+20 (R15=A(COMM)) 00133100 * NOTE: 'LINES' MUST BE CALLED BEFORE EACH FORTRAN WRITE 00133200 * STATEMENT WHICH CAUSES PRINTING TO OCCUR 00133300 * FORTRAN 'LINES' IS ALSO A FUNCTION - 00133310 * RETURNS NUMBER OF LINES LEFT ON CURRENT PAGE 00133312 * 00133400 * ASSEMBLER CALL TO READ NEXT SYSTEM INPUT CARD: 00133500 * LOAD R13 WITH ADDRESS OF SAVE AREA AND R15 WITH ADDRESS OF 00133600 * 'COMM' AND 00133700 * BAL 14,#CRYIN (#CRYIN = COMM+40) 00133800 * RETURNS LOCATION OF NEXT INPUT CARD IN R12. IF A COMMENT 00133900 * CARD IS READ, IT IS PRINTED AND THE NEXT CARD IS GIVEN. 00134000 * ANY CARD WITH '*' IN COL. 1 IS A COMMENT CARD. 00134100 * IF A BAD CONTINUATION CARD IS READ, IT IS PRINTED AND SKIPPED 00134200 * 'EXECUTE' CARDS ARE PROCESSED AND VARIABLE SYMBOLS 00134300 * ARE TABULATED FOR LATER SUBSTITUTION DURING CARD SCANNING 00134400 * IF 'ACCPT' IS NON-ZERO ON ENTRY, IT IS SET TO ZERO AND 00134500 * THE PREVIOUS CARD IS RE-READ. AT END OF DATA SET, AN 00134600 * 'END X-RAY' CARD IS GENERATED ON ALL FURTHER CALLS. 00134700 * 00134800 * FORTRAN CALL TO READ NEXT CARD INTO AN ARRAY (20A4): 00134900 * CALL CRYIN(ARRAY) 00135000 * 00135100 * IF A CARD IS READ WHICH IS NOT RECOGNIZED AS A VALID CARD 00135200 * BY THE CALLING PROGRAM, AND IT IS AT END OF EXPECTED INPUT, 00135300 * IT SHOULD NOT BE PRINTED. INSTEAD, IT SHOULD BE SAVED FOR 00135400 * LATER REREADING BY THE MONITOR BY THE STATEMENT 00135500 * CALL RDAGN 00135600 * THE NEXT CARD READ BY CRYIN WILL THEN BE THE SAME AS THE 00135700 * CURRENT CARD - WARNING: RDAGN WILL NOT CAUSE REREADING OF 00135800 * CARDS READ BY FORTRAN READ STATEMENTS 00135900 * 00136000 * ASSEMBLER CALL TO PRINT LAST CARD READ: 00136100 * (RETURNS CARD LOC IN R12) 00136200 * BAL 14,#CDPRNT 00136300 * 00136400 * FORTRAN CALL TO PRINT THE LAST CARD READ: 00136500 * CALL CDPRNT 00136600 * 00136700 * ASSEMBLER CALL TO CHANGE INPUT UNIT: 00136800 * LA 1,NEWUNIT 00136900 * BAL 14,#CDUNIT 00137000 * UNITS ARE PUSHED ONTO A STACK WITH ROOM FOR 4 ENTRIES 00137100 * STACK IS POPPED UP IF R1=0 ON ENTRY 00137200 * 00137300 * FORTRAN CALL TO CHANGE INPUT UNIT: 00137400 * CALL CDUNIT(N) 00137500 * 00137600 * REGISTERS USED BY PROGRAM ARE DEFINED HERE: 00137700 GRX EQU 2 FIOCS BUFFER LOCATION 00137800 GRY EQU 3 FIOCS BUFFER LENGTH 00137900 RPR EQU 3 PRNSCR RETURN 00137950 ROS EQU 4 OLD SAVE AREA LOCATION 00138000 RSB EQU 5 SUBROUTINE BASE (>4 FOR IBCDWT) 00138100 RDT EQU 6 CURRENT FIELD LOCATION (EVEN REG) 00138200 RWD EQU RDT+1 WIDTH OF CURRENT FIELD 00138300 RCD EQU RDT+2 CODE AND WIDTH LOCATION 00138400 RPL EQU RDT+3 PARAMETER LIST LOCATION 00138500 RIO EQU RDT+4 LINE COUNT OF CURRENT REQUEST 00138600 RLR EQU RDT+5 LIST RETURN ADDRESS 00138700 RRC EQU 12 RECORD COUNT 00138800 RCB EQU 12 CARD READER BASE 00138900 * 13 NEW SAVE AREA 00139000 RRT EQU 14 RETURN ADDRESS FOR LOWER LEVELS 00139100 RSC EQU 15 GENERAL SCRATCH 00139200 * 00139300 * MASKS FOR TM INSTRUCTIONS 00139400 * 00139500 OVFLM EQU X'01' OVERFLOW MASK 00139600 PNCHM EQU X'02' PUNCH MODE 00139700 ITEMM EQU X'04' NOT FIRST ITEM 00139800 FORTM EQU X'08' SIGNIFY FORTRAN CALL 00139900 SBHDM EQU X'10' SUBHEAD PROCESSING 00140000 SBPTM EQU X'20' SUBHEAD TO BE LISTED NOW 00140100 SPM EQU X'40' SPOUT MODE ON 00140200 ALL EQU X'FF' ALL MASKS 00140300 VL EQU X'80' VARIABLE LENGTH CALL TEST 00140400 EJECT 00140500 * 00140600 * ASSEMBLER ENTRIES FOR PRINTING AND PUNCHING 00140700 * FIX BASE REGISTERS AND BRANCH 00140800 * 00140900 USING COMM,15 00141000 USING PRINT,RSB 00141100 PRNCOM STM 14,12,12(13) SAVE REGISTERS 00141200 L RSB,APBASE LOAD BASE REGISTER 00141300 OVL1 MVI PRUNIT+3,2 SET PRINT UNIT 00141400 * BAL RPR,PRNSCR ** ALTERED IF ERROR ON CONTROL CARD SCAN 00141500 MVI FLAGS,0 SET PRINT MODE 00141600 B APSV 00141700 PUNCOM STM 14,12,12(13) PUNCH - SAVE REGISTERS 00141800 L RSB,APBASE LOAD BASE REGISTER 00141900 MVI PRUNIT+3,3 SET PUNCH UNIT 00142000 MVI FLAGS,PNCHM 00142100 B APSV 00142200 DROP RSB 00142300 * 00142400 * ASSEMBLER ENTRY TO RESERVE LINES 00142500 * 00142600 ALNS LNR 0,1 R0 = MINUS REQUEST 00142700 L 1,APBASE MAKE LINECT ADDRESSIBLE 00142800 USING PRINT,1 00142900 AH 0,LINECT R0 = COUNT - REQUEST 00143000 BCR 11,14 NOT MINUS - LINES WILL FIT THIS PAGE 00143100 SR 0,0 MINUS - LINES WONT FIT 00143200 STH 0,LINECT FORCE NEW PAGE 00143300 BR 14 00143400 DROP 1 00143500 * 00143600 * ASSEMBLER ENTRY TO CONTROL REMOTE TERMINAL PRINT 00143700 * 00143800 ASPOUT L 15,ASP 00143900 USING SPOUT,15 00144000 B SPT1 SET FORTRAN BASE AND ENTER SPOUT 00144100 * 00144200 * ASSEMBLER ENTRY TO READ A CONTROL CARD 00144300 * 00144400 USING COMM,15 00144500 INCOME L RCB,APBASE LOAD BASE REGISTER 00144600 USING PRINT,RCB 00144700 B COMEIN READ CONTROL CARD 00144800 DROP RCB 00144900 * 00145000 * ROUTINE TO PRINT PREVIOUS CONTROL CARD (DOUBLE SPACED) 00145100 * 00145200 USING CDPRNT,15 00145210 CDPRNT L 15,ACOM FORTRAN ENTRY POINT 00145220 USING COMM,15 00145230 B *+8 00145240 INPRNT L 12,LAST LOCATE PREVIOUS CARD 00145300 L 0,LAST DITTO, FOR PARMLIST 00145330 OI ACCPT,CP SIGNAL IT WAS PRINTED 00145350 BAL 1,PRNCOM PRINT CARD 00145400 INP1 DC X'0A04',S(CMESS) 00145500 DC X'80',AL1(80),S(0(0)) 00145600 * 00145700 * RETURN IS DIRECT TO USER WITH R1 AND R12 ALTERED. 00145800 * 00145900 * 00145902 * ROUTINE TO PRINT PREVIOUS CONTROL CARD (SINGLE SPACED) 00145904 * 00145908 USING CDPRT1,15 00145910 CDPRT1 L 15,ACOM 00145920 USING COMM,15 00145930 INPRT1 L 0,LAST LOCATE LAST CARD READ 00145940 OI ACCPT,CP SIGNAL IT WAS PRINTED 00145950 BAL 1,PRNCOM PRINT CARD 00145960 DC X'0904',S(BLANKS) 00145970 DC X'80',AL1(80),S(0(0)) 00145980 * 00146000 * ASSEMBLER ENTRY TO CHANGE CONTROL CARD UNIT 00146100 * 00146200 USING COMM,15 00146300 INUNIT L 15,ACDU 00146400 USING CDUNIT,15 00146500 B CDU1 USE FORTRAN BASE 00146600 * 00146700 * ASSORTED BASE REGISTER CONSTANTS FOR 2ND HALF OF PROGRAM 00146800 * 00146900 APBASE DC A(PRINT) BASE CONSTANT 00147000 ASP DC A(SPOUT) BASE CONSTANT 00147100 ACDU DC A(CDUNIT) BASE CONSTANT FOR CDUNIT 00147200 EXSCAN DC AL1(0),AL3(EXEND) CARD SCAN EXIT FOR EXECUTE CARD 00147300 USING PRINT,RSB 00147400 SCB BAL RPR,PRNSCR DUMMY 00147500 DROP RSB 00147600 TITLE 'PRINT AND PUNCH - PROCESS LISTS' 00147700 * 00147800 * FORTRAN ENTRY POINT FOR PUNCHING 00147900 * 00148000 PUNCH STM 14,12,12(13) SAVE ALL REGISTERS 00148100 USING PUNCH,15 00148200 MVI PRUNIT+3,3 SET PUNCH UNIT 00148300 MVI FLAGS,FORTM+PNCHM 00148400 BAL RSB,FPSV SET BASE AND BRANCH 00148500 * 00148600 * FORTRAN ENTRY POINT FOR PRINTING 00148700 * 00148800 CRYOUT STM 14,12,12(13) SAVE REGISTERS 00148900 PRINT EQU CRYOUT 00149000 LR RSB,15 SET BASE 00149100 USING PRINT,RSB 00149200 DROP 15 00149300 OVL2 MVI PRUNIT+3,2 SET PRINT UNIT 00149400 * BAL RPR,PRNSCR ** ALTERED IF ERROR ON CONTROL CARD SCAN 00149500 MVI FLAGS,FORTM SET MODE 00149600 * 00149700 * CODE BEYOND THIS POINT NEED NOT BE ADDRESSIBLE FROM 'COMM' 00149800 * 00149900 FPSV BAL RLR,SETIO LOCATE FIRST BUFFER 00150000 * 00150100 * SCAN USER'S LIST 00150200 * 00150300 FPSCAN L RDT,0(RPL) LOCATE DATA ARRAY 00150400 L RCD,4(RPL) LOCATE CODE AND LENGTH 00150500 LA RCD,2(RCD) ALLOW FOR REGULAR FORTRAN INTEGER 00150600 BAL RLR,LISP PROCESS LIST ITEM 00150700 TM 4(RPL),VL TEST FOR END OF LIST 00150800 BO FPDONE DONE 00150900 LA RPL,8(RPL) ADVANCE TO NEXT LIST ITEM 00151000 B FPSCAN 00151100 * 00151200 * ASSEMBLER ENTRY POINT FOR PUNCHING AND PRINTING 00151300 * 00151400 SPMSV STM 14,12,12(13) SPECIAL ENTRY FOR CONSOLE OUTPUT ONLY 00151500 MVI PRUNIT+3,0 SET FOR CONSOLE UNIT 00151600 MVI FLAGS,SPM 00151700 APSV BAL RLR,SETIO INITIALIZE FIOCS AND GET FIRST BUFFER 00151800 APSCAN LH RDT,2(RPL) GET DATA LOCATION (S TYPE) 00151900 SRDL RDT,12 DISPLACEMENT OUT 00152000 SRL RDT+1,20 00152100 LA RDT,2(RDT) 00152200 N RDT,FIFTEEN 00152300 SLL RDT,2 POSITION FOR INDEXING 00152400 L RDT,12(RDT,ROS) GET ACTUAL ADDRESS 00152500 AR RDT,RDT+1 ADD DISPLACEMENT 00152600 LR RCD,RPL LOCATE CODE AND LENGTH 00152700 BAL RLR,LISP PROCESS LIST ITEM 00152800 TM 0(RPL),X'80' TEST FOR END OF LIST 00152900 BO FPDONE DONE 00153000 LA RPL,4(RPL) ADVANCE TO NEXT LIST ITEM 00153100 B APSCAN AND PROCESS IT 00153200 * 00153300 * END OF LIST - RESTORE AND RETURN 00153400 * 00153500 FPDONE TM FLAGS,SBHDM+SBPTM TEST FOR SUBHEAD CALL TYPE 00153600 BZ APREST 1) NOT SUBHEAD 00153700 LM GRX,GRY,28(13) RESTORE BUFFER REGISTERS 00153800 BM SBHDFX 2) NEW SUBHEAD JUST SET 00153900 LH 0,LINECT 3) NEW SUBHEAD TO BE LISTED NOW 00154000 SH 0,SHDLNS R0 = LINES REMAINING AFTER SUBHEAD 00154100 CH 0,FORE 00154200 BNH SBHDFX NOT ENOUGH, DON'T BOTHER 00154300 STH 0,LINECT STORE NEW LINE COUNT 00154400 NI FLAGS,ALL-SBHDM ALTER PRNMOV FLOW 00154500 SBD2 LH RPL,SHDREC SET TO OMIT TITLE, DO SUBTITLE 00154600 LA RCD,BFWD 00154700 BCT RPL,SBD1 REDUCE COUNT AND BRANCH TO PRINT 00154800 SBHDFX MVC LINECT(2),ZOT ZERO LINE COUNT TO FORCE TITLE NEXT 00154900 APREST BAL RRT,PRNLIN CLOSE LAST BUFFER 00155000 * 00155100 * TEST FOR SPOUT (TERMINAL PRINT OUT) AND RESCAN IF NEEDED 00155200 * 00155300 TM FLAGS,PNCHM+SPM IF NOT PRINTING OR ALREADY SPOUTING, 00155400 BNZ APRIL GO TO RETURN 00155500 L 0,SPEND TEST SPOUT COUNT 00155600 S 0,UNITY 00155700 BM APRIL IF ALREADY ZERO OR NEGATIVE, RETURN 00155800 ST 0,SPEND STORE UPDATED COUNT 00155900 MVI PRUNIT+3,0 SET FOR TERMINAL UNIT 00156000 BAL RLR,SETSPM 00156100 L RPL,24(0,ROS) RESTORE PARAMETER LIST LOCATION 00156200 OI FLAGS,SPM TURN ON SPOUT MODE 00156300 NI FLAGS,ALL-SBHDM 00156350 TM FLAGS,FORTM DETERMINE TYPE OF ORIGINAL CALL 00156400 BZ APSCAN 00156500 B FPSCAN 00156600 APRIL LR 13,ROS LOCATE OLD SAVE AREA 00156700 LM 14,12,12(13) RESTORE REGISTERS 00156800 BR 14 RETURN 00156900 EJECT 00157000 * 00157100 * LIST PROCESSOR SUBROUTINE, ENTERED ONCE FOR EACH ITEM 00157200 * 00157300 LISP SR RWD,RWD LOAD FIELD WIDTH 00157400 IC RWD,1(RCD) 00157500 TM 0(RCD),X'20' TEST FOR NEW SUBTITLE 00157600 BNZ LSTIT 00157700 LSP1 TM 0(RCD),X'0F' TEST LINE CONTROL BITS 00157800 BZ CONLIN 1) CONTINUE CURRENT LINE 00157900 BO NEWPAG 2) START NEW PAGE 00158000 IC RIO,0(0,RCD) FETCH LINE COUNT 00158100 N RIO,SEVEN 00158200 TM FLAGS,SBHDM 3) BEGIN NEW LINE, TEST MODE 00158300 BO TITREC SUBTITLE - NEW RECORD 00158500 TM FLAGS,SPM+PNCHM IF PRINTING AT TERMINAL OR PUNCHING, 00158600 BNZ LSP3 DON'T UPDATE LINE COUNT 00158700 CLI 1(RDT),C'*' TEST FOR ERROR MESSAGE 00158800 BNE LSP21 NOT ERROR MSG 00158900 L 0,SPEND IS ERROR MSG - INCREMENT TERMINAL COUNT 00159000 A 0,UNITY 00159100 BNP LSP21 NEVER MIND IF WAS NEGATIVE TO START WITH 00159200 ST 0,SPEND 00159300 LSP21 TM 0(RCD),X'10' REGULAR NEW LINE, TEST PAGINATION 00159400 LSP22 BNZ LSP3 DO NOT PAGINATE 00159500 LH 0,LINECT COMPUTE LINES REMAINING 00159600 SR 0,RIO 00159700 BM NWPG2 NOT ENOUGH, START NEW PAGE 00159800 LSP23 STH 0,LINECT 00159900 LSP3 BAL RRT,PRNLIN WRITE CURRENT BUFFER 00160000 B PRNCHR 00160100 * 00160200 * PRINT CHARACTERS OF CURRENT ITEM 00160300 * 00160400 CONLIN TM FLAGS,ITEMM CONTINUE LINE - TEST FIRST ITEM 00160500 BZ LSP7 FIRST, GENERATE CARRIAGE CONTROL 00160600 PRNCHR TM FLAGS,OVFLM TEST FOR OVERFLOW LINE 00160700 BO CON2 00160800 LSP4 SR GRY,RWD TEST FOR LINE OVERFLOW 00160900 BM OVRFLW 00161000 BAL RRT,PRNMOV EXECUTE MOVE 00161100 OI FLAGS,ITEMM SIGNAL ITEM PROCESSED 00161200 BR RLR RETURN TO LIST SCAN 00161300 OVRFLW TM FLAGS,SBHDM OVERFLOW ON TITLE 00161400 BZ LSP6 00161500 LSP5 ABEND 050 INDICATE TITLE OVERFLOW 00161600 LSP6 LR RSC,RWD SAVE WIDTH 00161700 AR RWD,GRY SET TO PRINT MAXIMUM THAT FITS 00161800 SR GRY,GRY UPDATE COUNT 00161900 BAL RRT,PRNMOV EXECUTE MOVE 00162000 AR RDT,RWD ADVANCE DATA POINTER 00162100 LNR RWD,RWD RESTORE COUNT 00162200 AR RWD,RSC 00162300 LSP7 L RIO,UNITY SET FOR SINGLE LINE COUNT 00162400 OI FLAGS,OVFLM SET OVERFLOW 00162500 TM FLAGS,SPM+PNCHM 00162550 B LSP22 00162600 CON2 TM FLAGS,PNCHM TEST FOR PUNCH MODE 00162700 BNZ CON3 YES - OMIT CARRIAGE CHARACTER 00162800 STM RDT,RWD,OVTMP SAVE DATA STATUS 00162900 LM RDT,RWD,CARIJ SET FOR A BLANK 00163000 BCTR GRY,0 DECREASE REMAINING BUFFER SPACE 00163100 BAL RRT,PRNMOV MOVE BLANK TO BUFFER 00163200 LM RDT,RWD,OVTMP 00163300 CON3 NI FLAGS,ALL-OVFLM SHUT OFF OVERFLOW 00163400 B LSP4 00163500 * 00163600 * INITIATE SUBHEAD PROCESSING 00163700 * 00163800 LSTIT TM FLAGS,PNCHM ABEND IF PUNCHING 00163900 BZ LST2 00164000 LST1 ABEND 051 00164100 LST2 TM FLAGS,SBHDM SEE IF 00164200 BO LSP1 ALREADY PROCESSING SUBTITLE 00164210 TM FLAGS,SPM IF PROCESSING TERMINAL PRINT, 00164300 BO SBD2 GO PRINT SUBTITLE ONCE 00164400 OI FLAGS,SBHDM NEW SUBTITLE - SET FLAGS 00164500 STM GRX,GRY,28(13) SAVE BUFFER LOC DURING SUBTITLE 00164600 TM 0(RCD),X'40' TEST FOR IMMEDIATE PRINT 00164700 BZ LST3 00164800 OI FLAGS,SBPTM SET FLAG 00164900 LST3 LA GRX,BFWD LOCATE SUBHEAD BUFFER 00165000 MVC SHDLNS(4),UNITY START COUNT AT ONE FOR TITLE 00165100 LA GRY,SBHDCH 00165200 TITREC ST GRX,CLOC START NEW SUBTITLE RECORD 00165300 IC 0,0(RCD) FETCH LINE COUNT 00165400 N 0,SEVEN 00165500 SLL 0,16 INSERT SINGLE RECORD COUNT 00165600 A 0,UNITY 00165700 A 0,SHDLNS 00165800 ST 0,SHDLNS ADD LINES AND RECORDS TOGETHER 00165900 MVC 0(2,GRX),ZOT ZERO RECORD COUNT 00166000 S GRY,TWO DECREASE REMAINING COUNT 00166100 LA GRX,2(GRX) AND RECORD POINTER 00166200 B PRNCHR 00166300 EJECT 00166400 * 00166500 * ENTRY TO FORCE BEGINNING OF NEW PAGE 00166600 * 00166700 NEWPAG TM FLAGS,SBHDM TEST FOR SUBHEAD SETTING 00166800 BO LST1 ILLEGAL DURING SUBHEAD 00167000 TM FLAGS,SPM+PNCHM IF PROCESSING PUNCH OR TERMINAL PRINT, 00167100 BNZ LSP3 OMIT SUBTITLE 00167200 L RIO,UNITY SET COUNT FOR SINGLE LINE 00167300 NWPG2 TIME TU GET THE DATE (IGNORE TIME) 00167400 * ** B DATZ AFTER FIRST EXECUTION 00167500 ST 1,DTCON+4 STORE DATE 00167600 LA 1,DTTB SET LOOP INDEX FOR MONTH TABLE 00167700 TM DTCON+5,X'12' TEST FOR LEAP YEAR 00167800 BM DAT0 00167900 TM DTCON+5,X'01' 00168000 BO DAT0 00168100 LA 1,2(1) LEAP YEAR - SET ALTERNATE MONTH TABLE 00168200 DAT0 UNPK DTCON+1(3),DTCON+5(2) YEAR TO EBCDIC 00168300 MVC DATE+9(2),DTCON+1 YEAR TO TITLE 00168400 MVC DTCON+1(5),DTCON ZAP YEAR 00168500 CVB 0,DTCON DATE TO BINARY 00168600 LA 14,8 LOAD TABLE INCREMENT 00168700 LA 15,DTTBND+2 END OF TABLE 00168800 DAT1 CH 0,12(1) TEST MONTH 00168900 BNH DAT2 FOUND MONTH 00169000 BXLE 1,14,DAT1 00169100 DAT2 SH 0,4(1) CORRECT DATE 00169200 N 1,DTM1 R1 TO WORD BOUNDARY 00169300 MVC DATE+4(4),0(1) MONTH TO TITLE 00169400 L 15,ACOM MAKE COMM ADDRESSABLE 00169500 USING COMM,15 00169600 BAL 1,DAT3 DATE TO EBCDIC 00169700 DC X'00000F03' 00169800 LA 1,DATE 00169900 DTM2 B DATZ DUMMY 00170000 DAT3 BAL 14,#IBCDWT 00170100 STIMER TASK,,TUINTVL=OMEGA 00170200 MVC NWPG2(4),DTM2 MASK OUT ABOVE SETUP 00170300 * 00170400 * UPDATE TIME ELAPSED AND PAGE NUMBER 00170500 * 00170600 DATZ TTIMER 00170700 L 15,ACOM 00170800 L 1,OMEGA 00170900 SR 1,0 R0 = ELAPSED TIME IN 26.04 USEC UNITS 00171000 M 0,DTM3 TU TO HUNDRETHS OF SECS 00171100 SRDA 0,36 KEEP INTEGER FOR DIVISION 00171200 D 0,DTM4 DIVIDE TO MINUTES 00171300 ST 1,DTCON+4 SAVE MINUTES 00171400 BAL 1,DAT4 CONVERT SECONDS 00171500 DC X'00030F05' 00171600 LA 1,DATE+16 00171700 DAT4 BAL 14,#IBCDWT 00171800 L 0,DTCON+4 GET MINUTES 00171900 BAL 1,DAT5 00172000 DC X'00010F04' 00172100 LA 1,DATE+12 00172200 DAT5 BAL 14,#IBCDWT 00172300 LH 0,PGNO INCREMENT PAGE NUMBER 00172400 A 0,UNITY 00172500 STH 0,PGNO 00172600 BAL 1,NWPG3 PREPARE TO CONVERT 00172700 DC X'00004F04' 00172800 LA 1,PGWD+5 ADCON FOR IBCDWT 00172900 NWPG3 BAL 14,#IBCDWT PAGE NUMBER TO EBCDIC 00173000 DROP 15 00173100 * 00173200 * FOLLOWING ROUTINE MOVES TITLE TO BUFFER 00173300 * IN RECORDS, SO NEW BLOCKS ARE WRITTEN ONLY AS NEEDED 00173400 * 00173500 PRNSBD STM RDT,RLR,SVTMP SAVE DATA LOCATION, ETC. 00173600 LH RPL,SHDREC NO OF RECORDS IN TITLE + SUBTITLE 00173700 LA RCD,SBHDCD LOCATE TITLE 00173800 SBD1 BAL RRT,PRNLIN TERMINATE OLD BUFFER 00173900 MVC SEGCW,0(RCD) GET RECORD COUNT TO H BOUNDARY 00174000 LH RWD,SEGCW 00174100 LA RDT,2(RCD) LOCATE DATA 00174400 LA RCD,2(RCD,RWD) UPDATE COUNTER ADDRESS 00174600 BAL RLR,LSP4 PROCESS ON LINE 00174650 BCT RPL,SBD1 LOOP OVER RECORDS 00174700 LM RDT,RLR,SVTMP RESTORE 00174800 TM FLAGS,SBPTM TEST RETURN 00174900 BO APREST 00175000 L 0,LPP RESET LINE COUNT 00175100 SH 0,SHDLNS 00175200 SR 0,RIO TAKE AWAY COUNT OF THIS REQUEST 00175300 B LSP23 00175500 EJECT 00175600 * 00175700 * SETIO - INITIALIZATION OF FORTRAN FIOCS ROUTINE 00175800 * PRUNIT PRESET TO UNIT, RLR = RETURN 00175900 * 00176000 SETIO NWSV SAVEAREA,ROS 00176100 LR RPL,1 PERM PARM LIST 00176200 SETSPM LA GRX,PRUNIT LINK TO FIOCS 00176300 L 1,IOCOM 00176400 BALR 0,1 00176500 DC X'00FF' FORMATTED OUTPUT FLAG 00176600 NOP 0 ERROR RETURN 00176700 SR RRC,RRC RECORD COUNT = ZERO 00176800 BR RLR 00176900 * 00177000 * PRNLIN - LINKS TO FIOCS TO WRITE A BUFFER 00177100 * 00177200 PRNLIN LTR RRC,RRC TEST FOR DATA WRITTEN 00177300 BCR 8,RRT NONE 00177400 TM FLAGS,SPM IF PROCESSING TERMINAL OUTPUT 00177500 BZ PRN4 00177600 SR GRX,RRC LOCATE FIRST CHARACTER OF LINE 00177700 MVI 0(GRX),C' ' AND CHANGE IT TO A BLANK 00177800 PRN4 LR GRX,RRC COUNT TO GRX FOR FIOCS 00177900 L 1,IOCOM 00178000 BALR 0,1 00178100 DC AL1(2,0) 00178200 NOP 0 ERROR RETURN 00178300 SR RRC,RRC ZERO WRITTEN COUNT 00178400 BR RRT RETURN 00178500 * 00178600 * PRNMOV - MOVE DATA TO BUFFER 00178700 * 00178800 PRNMOV LTR 1,RWD COMPUTE WIDTH FOR EXECUTE 00178900 BCR 8,RRT PROTECT AGAINST NULL FIELDS 00179000 BCTR 1,0 00179100 EX 1,PRNMV MOVE CHARACTERS 00179200 AR GRX,RWD INCREMENT BUFFER ORG 00179300 TM FLAGS,SBHDM 00179400 BO MV2 BRANCH IF SUBHEAD TO LEAVE RRC ALONE 00179500 AR RRC,RWD INCREMENT RECORD COUNT 00179600 BR RRT 00179700 MV2 L 1,CLOC INCREASE SUBHEAD RECORD COUNT 00179800 MVC SEGCW,0(1) DO BOUNDARY ALIGNMENT 00179900 LH 0,SEGCW 00180000 AR 0,RWD 00180100 STH 0,SEGCW 00180200 MVC 0(2,1),SEGCW 00180300 BR RRT 00180400 PRNMV MVC 0(0,GRX),0(RDT) 00180500 DROP RSB 00180600 EJECT 00180700 * 00180800 * FORTRAN LINE RESERVATION ROUTINE 00180900 * NOTE: ASSEMBLER LINE RESERVATION DOES NOT ACTUALLY PRINT 00181000 * TITLES, WHEREAS FORTRAN VERSION DOES 00181100 * 00181200 USING LINES,15 00181300 USING PRINT,RSB 00181400 LINES STM 14,12,12(13) 00181500 L RSB,PCOM SET BASE REGISTER 00181600 DROP 15 00181700 LH 0,LINECT GET CURRENT LINE COUNT 00181800 L 1,0(1) LOCATE REQUEST 00181900 L RIO,0(0,1) SUBTRACT REQUEST 00182000 SR 0,RIO COUNT HELD IN RIO FOR USE AT SBD1 00182100 STH 0,LINECT 00182200 BNM LIN1 OK, REQUEST FITS, RETURN 00182300 MVI PRUNIT+3,2 PREPARE TO PRINT TITLE 00182400 MVI FLAGS,0 00182500 BAL RLR,SETIO 00182600 SR RWD,RWD SET NO DATA AFTER TITLE 00182700 BAL RLR,NWPG2 PRINT TITLE AND SUBTITLE 00182800 LR 13,ROS RESTORE SAVE AREA 00182900 LIN1 LM 14,12,12(13) 00183000 USING LINES,15 00183010 LH 0,LINECT RETURN LINES IN R0 00183020 BR 14 00183100 DROP RSB,15 00183200 * 00183300 * FORTRAN REMOTE TERMINAL CONTROL ROUTINE 'SPOUT' 00183400 * 00183500 USING SPOUT,15 00183600 SPOUT L 1,0(0,1) LOCATE N 00183700 L 1,0(0,1) FETCH N 00183800 SPT1 LTR 1,1 TEST N (ASSEMBLER ENTRY HERE) 00183900 BNP SPT2 IF N=0 OR N<0, IS ABSOLUTE COMMAND 00184000 A 1,SPEND ACCUMULATE SPOUT COUNTS 00184100 TM SPEND,VL IF N>0, USE ONLY IF SPEND >=0 00184150 BO SPT3 IF N>0, SPEND<0, RETURN 00184200 SPT2 ST 1,SPEND 00184300 SPT3 L 15,ACOM RESTORE R15 FOR ASM VERSION 00184400 BR 14 00184500 DROP 15 00184600 EJECT 00184700 * 00184800 * ROUTINE 'PRNSCR' INTERCEPTS NORMAL PRINT AFTER CONTROL 00184900 * CARD ERROR TO PRINT MESSAGES AND MARKERS 00185000 * 00185100 USING PRINT,RSB 00185200 PRNSCR L 15,ACOM LOCATE COMMUNICATIONS AREA 00185300 USING COMM,15 00185400 MVC OVL1(4),RESTORE RESTORE NORMAL PRINT FLOW 00185500 MVC OVL2(4),RESTORE 00185600 NWSV SAVERR,ROS 00185700 L 12,LAST LOCATE PREVIOUS INPUT CARD 00185900 TM SPEND,VL IS TERMINAL PRINT ACTIVE? 00186000 LA 1,INP1 LOCATE CARD PRINT PARM LIST 00186100 BNZ *+8 NO TERMINAL 00186200 BAL 14,SPMSV YES, SO PRINT CARD THERE 00186300 TM ACCPT,CP HAS CARD BEEN PRINTED YET? 00186400 BNZ *+8 YES 00186500 BAL 14,PRNCOM NO, SO PRINT IT NOW 00186550 LA 1,1 SPOUT $ MSG 00186570 BAL 14,ASPOUT 00186580 IC GRX,#ERSCAN+1 PREPARE TO SCAN ERRORS 00186600 MVI #ERSCAN+1,0 00186700 LA RDT,4 INCREMENT 00186800 LA RWD,CCSEND COMPARAND - BASE 00186900 BAL 1,PRN2 LOCATE PRINT LIST LIST 00187000 CCSEMP DC X'89',AL1(76),SL2(DMESS) PRINT $ MARKER 00187100 DC X'89',AL1(L'SMES4),SL2(SMES4) 00187200 DC X'89',AL1(L'SMES3),SL2(SMES3) 00187300 DC X'89',AL1(L'SMES2),SL2(SMES2) 00187400 DC X'89',AL1(L'SMES1),SL2(SMES1) 00187500 DC X'89',AL1(L'SMES5),SL2(SMES5) 00187600 DC X'89',AL1(L'SMES6),SL2(SMES6) 00187700 DC X'89',AL1(L'SMES7),SL2(SMES7) 00187800 CCSEND EQU *-4 00187900 PRN1 LA 0,1 TEST REGISTER 00188000 NR 0,GRX 00188100 SRL GRX,1 SET TO TEST NEXT BIT LATER 00188200 BZ PRN3 00188300 PRN2 BAL 14,PRNCOM PRINT AN ITEM 00188400 LA 1,0(1) CLEAR FIRST EIGHT BITS OF 1 00188500 PRN3 BXLE 1,RDT,PRN1 LOOP 00188600 MVC DMESS+4(72),DMESS+3 CLEAR $ MESSAGE 00188700 LR 13,ROS RELOCATE USER'S SAVE AREA 00188800 DROP 15 00188900 L 1,24(13) RESTORE USER'S PARAMETER LIST 00189000 RESTORE MVI PRUNIT+3,2 EXECUTE OMITTED INSTRUCTION 00189100 BR RPR RETURN TO CRYOUT OR CRYIN 00189200 DROP RSB 00189300 TITLE 'CRYM - SYSIN CARD READER' 00189400 * 00189500 * CARD UNIT ASSIGNMENT (PUSH DOWN STACK) 00189600 * (NOTE: NO SAVE, USES ONLY R14 - R1) 00189700 * 00189800 USING CDUNIT,15 00189900 CDUNIT L 1,0(0,1) FORTRAN ENTRY 00190000 L 1,0(0,1) 00190100 CDU1 LTR 0,1 ASSEMBLER ENTRY 00190200 L 1,CDUPTR GET STACK POINTER 00190300 BZ POP ZERO UNIT => POP UP 00190400 AH 1,FORE PUSH DOWN 1 00190500 C 1,CDUTOP TOO MANY? 00190600 BNH CDU2 OK 00190700 ABEND 061 00190800 CDU2 ST 0,0(0,1) STORE NEW UNIT NO. 00190900 MVI 0(1),X'08' FIXUP FOR FIOCS 00191000 B CDU3 00191100 POP SH 1,FORE POP STACK 00191200 C 1,CDUBOT AT BOTTOM? 00191300 BNL CDU3 OK 00191400 MVI EIN1+1,X'F0' THAT'S ALL - MAKE EOF EXIT 00191500 B *+8 00191600 CDU3 ST 1,CDUPTR SAVE NEW STACK POINTER 00191700 L 15,ACOM RESTORE R15 FOR ASM CALL 00191800 BR 14 RETURN 00191900 DROP 15 00192000 * 00192100 * FORTRAN ENTRY POINT FOR CARD READING 00192200 * 00192300 USING CRYIN,15 00192400 CRYIN STM 12,14,FSAVE -->NOTE NONSTANDARD REGISTER SAVE<-- 00192500 L RCB,PCOM SET READER BASE 00192600 USING PRINT,RCB 00192700 BAL 14,COMEIN GET A CARD 00192800 DROP RCB 00192900 L 1,0(1) LOCATE USER'S ARRAY 00193000 MVC 0(80,1),0(12) MOVE CARD TO ARRAY 00193100 LM 12,14,FSAVE RESTORE 00193200 BR 14 00193300 DROP 15 00193400 * NOTE IMPLICIT ASSUMPTION - THAT 'COMEIN' PRESERVES R1, R15 00193500 EJECT 00193600 * 00193700 * ROUTINE TO READ SYSTEM CONTROL CARDS 00193800 * HANDLES COMMENTS, CONTINUATIONS, AND 'EXECUTE' CARDS 00193900 * 00194000 USING PRINT,RCB 00194100 COMEIN STM 14,7,12(13) SAVE USER'S REGISTERS 00194200 EIN1 BC 0,EIN20 ** B IF AT END OF INPUT 00194300 L 15,ACOM LOCATE 'COMM' BRANCH TABLE 00194400 USING COMM,15 00194500 TM ACCPT,ALL-CP TEST REREAD FLAG 00194600 BNZ EIN21 00194700 NWSV SAVER2,2 LINK TO NEW SAVE AREA 00194800 LR RSB,RCB PREPARE BASE FOR PRNSCR 00194870 EX 0,OVL1 CALL PRNSCR IF NEEDED 00194880 LR RCB,RSB RESTORE BASE 00194890 EIN3 L 1,IOCOM LOCATE FIOCS 00194900 L 2,CDUPTR GET UNIT POINTER 00195000 BALR 0,1 LINK TO FIOCS 00195100 DC X'00F0' FORMATTED READ 00195200 B EOF1 END-OF-DATA RETURN 00195300 * 00195400 * HANDLE SPANNED RECORDS, IF PRESENT 00195500 * 00195600 LA 5,80 00195700 LA GRX,0(0,GRX) CLEAR ACCPT FLAGS ULTIMATELY 00195750 CR GRY,5 RECORD DONE IN FIRST SEGMENT? 00195800 BNL EIN6 YES 00195900 L 4,ACARD NO, ASSEMBLE RECORD IN "CARD" 00196000 B EIN5 00196100 ABEND60 ABEND 060 RECORD TOO SHORT 00196200 EIN4 L 1,IOCOM READ ANOTHER SEGMENT 00196300 BALR 0,1 00196400 DC X'0100' 00196500 B ABEND60 EOF HERE IS VERY BAD 00196600 CR GRY,5 DOES THIS SEG FINISH IT? 00196700 BNH EIN5 NO, MOVE IT ALL 00196800 LR GRY,5 YES, JUST MOVE ENOUGH TO FILL "CARD" 00196900 EIN5 LTR 1,GRY MAKE COUNT FOR MVC 00197000 BNP *+14 00197100 BCTR 1,0 00197200 EX 1,SEGMVC MOVE DATA 00197300 AR 4,GRY UPDATE LOCATION 00197400 SR 5,GRY 00197500 SH GRX,FORE LOCATE SCW 00197600 TM 2(GRX),1 MORE SEGMENTS? 00197700 BNZ EIN4 YES, GO READ THEM 00197800 LTR 5,5 NO, WAS CARD DONE? 00197900 BP ABEND60 NO, RECORD TOO SHORT 00198000 L GRX,ACARD SET TO USE ASSEMBLED CARD 00198100 * 00198200 * HANDLE COMMENT CARDS 00198300 * 00198400 EIN6 ST GRX,LAST SAVE CARD LOCATION 00198500 CLC 0(6,GRX),LEND IS IT AN 'END' CARD? 00198600 BE EOF1 YES, GENERATE END-OF-FILE 00198700 CLI 0(GRX),C'*' COMMENT? 00198800 BNE EIN7 NO 00198900 BAL 1,EIN8A YES, PRINT IT 00199000 DC X'0A08',S(CMESS) 00199100 DC X'80',AL1(80),S(0(2)) 00199200 * 00199300 * IF NOT A CNTINU CALL, CHECK FOR CONTINUATION OR EXECUTE CARD 00199400 * 00199500 EIN7 TM CNTSW,VL CALLED BY CNTINU? 00199600 BNZ EIN10 YES, JUST RETURN 00199700 CLC 0(4,GRX),BLANKS NOT A CNTINU CALL, IS IT CONTINUATION? 00200300 BNE EIN9 NO 00200400 LA 1,1 YES, SPOUT IT 00200430 BAL 14,ASPOUT 00200440 BAL 14,INPRT1 AND PRINT IT 00200450 BAL 1,EIN8A AND APPEND ERROR MESSAGE 00200500 DC X'80',AL1(L'MESS5),S(MESS5) 00200550 EIN8A BAL 14,PRNCOM 00200600 B EIN3 GO READ ANOTHER CARD 00200700 EIN9 CLC 0(4,GRX),LEXEC NOT CONTINUATION, IS IT EXEC? 00200800 BE EX1 00200900 * 00201000 * RESTORE EVERYTHING AND RETURN TO CALLER 00201100 * 00201200 EIN10 LR 12,GRX R12 = LOCN OF CARD JUST READ 00201300 L 13,4(0,13) 00201400 LM 14,7,12(13) 00201500 BR 14 00201600 * 00201700 * HERE TO MAKE QUICK RETURN IF END-OF-FILE OR RDAGN SET 00201800 * 00201900 EIN20 LA 12,LEND GENERATE 'END' CARD 00202000 BR 14 00202100 EIN21 MVI ACCPT,0 READ SAME CARD AGAIN 00202200 L 12,LAST 00202300 L 15,16(0,13) 00202400 BR 14 00202500 * 00202600 * HERE ON END-OF-FILE. POP UP STACK, QUIT IF ON UNIT 1 NOW 00202700 * 00202800 EOF1 SR 1,1 00202900 EOF2 BAL 14,INUNIT GO POP STACK 00203000 L 13,4(0,13) GO BACK, READ MORE ON NEW UNIT 00203100 LM 14,7,12(13) 00203200 B EIN1 00203300 EJECT 00203400 * 00203500 * PROCESS CRYM 'EXECUTE' CARD 00203600 * 00203700 EX1 L 13,4(0,13) ANOTHER SAVE AREA - RECURSIVE CALL 00203800 NWSV SAVER3,2 00203900 LM 0,1,VSTAB RELEASE OLD SYMBOL TABLE IF PRESENT 00204000 LTR 0,0 00204100 BZ EX2 00204200 FREEMAIN R,LV=(0),A=(1) 00204300 L 15,ACOM 00204400 EX2 SR 4,4 DEFAULT UNIT IS CRYIN UNIT 00204500 SR 5,5 SIGNAL IN CASE NO SYMBLS ON CARD 00204600 ST 5,VSTAB SIGNAL NO CORE NOW ALLOCATED 00204700 NI EXRSW+1,X'0F' SET SWITCH TO REWIND 00204705 LA 3,10 DEFAULT MAXSYM IS 10 00204800 BAL 14,INPRNT PRINT IT 00204900 DROP RCB RCB = R12 IS BOPPED HERE 00205000 MVI FUNC3+C'&&',0 MAKE SCAN IGNORE AMPERSANDS 00205100 LA 1,EXSCAN 00205200 BAL 14,ACDSCN INITIALIZE SCAN 00205300 L RCB,APBASE RESTORE BASE REGISTER 00205400 USING PRINT,RCB 00205500 BAL 14,ABLSCN SKIP OVER THE WORD "EXEC" 00205600 * 00205700 * 'UNIT' AND 'MAXSYM' OPTIONS 00205800 * 00205900 EX3 BAL 14,ABLSCN GET FIELD (BLANK DELIMITERS) 00206000 CLC 0(4,1),LEXEC+12 IS IT 'NOREWIND'? 00206060 BNE EX9 NO 00206062 OI EXRSW+1,X'F0' YES, SET SWITCH TO OMIT REWIND 00206064 B EX3 00206066 EX9 CLI RF,12 MAKE SURE '=' FOUND 00206100 BNE EX8 00206200 CLC 0(4,1),LEXEC+4 IS IT 'UNIT' OPTION? 00206300 BNE EX4 NO 00206400 BAL 2,EXIN YES, GET UNIT NO. 00206500 LR 4,0 CHECK FOR EXCESSIVE UNIT NO. 00206600 SLA 0,4 IHCUATBL HAS MXUNITS*16 00206700 L 1,IUATBL LOCATE IHCUATBL 00206800 CH 0,2(1) CHECK UNIT 00206900 BNH EX3 00207000 OI #ERSCAN+1,64 TOO HIGH, BLEEP IT 00207100 BAL 14,AMARK 00207200 B EX3 00207300 EX4 CLC 0(4,1),LEXEC+8 IS IT 'MAXSYMBLS'? 00207400 BNE EX5 00207500 BAL 2,EXIN YES, GET NO. OF SYMBLS 00207600 LR 3,0 00207700 B EX3 SCAN MORE 00207800 * 00207900 * READ IN AN INTEGER VIA IBCDIN 00208000 * 00208100 EXIN BAL 14,ABLSCN 00208200 CLI RF,4 CHECK FOR COMMA 00208300 BH EX8 00208400 BAL 1,*+12 CONVERT INTEGER 00208500 DC X'00000E0B' 00208600 LA 1,#FIELD 00208700 BAL 14,BEGIN 00208800 BR 2 RETURN VALUE IN R0 00208900 * 00209000 * MAXSYM AND UNIT SET - NOW ALLOCATE SPACE FOR TABLE 00209100 * 00209200 EX5 MH 3,H24 24 BYTES PER ENTRY 00209300 LR 0,3 00209400 GETMAIN R,LV=(0) 00209500 L 15,ACOM RESTORE R15 00209600 STM 0,1,VSTAB 00209700 LR 5,1 R5 IS STORAGE POINTER 00209800 H24 EQU *+2 00209900 LA 2,24 R2 IS STORAGE INCREMENT 00210000 AR 3,1 R3 IS TOP FENCE 00210100 SR 3,2 00210200 LA 1,#FIELD RESTORE LOCATION OF FIRST FIELD 00210300 * 00210400 * PICKUP VARIABLE SYMBOLS AND STORE VALUES (SAVE R4) 00210500 * 00210600 EX6 CLI 0(1),C'&&' DOES SYMBOL BEGIN WITH '&'? 00210700 BE *+6 00210800 BCTR 1,0 IF SO, SKIP OVER IT 00210900 CLI RF,12 AND END WITH '='? 00211000 BNE EXER 00211100 MVC 16(8,5),0(1) STORE SYMBOL IN TABLE (ONLY 7 CHARS) 00211200 BAL 14,ASCAN GET VALUE OF SYMBOL 00211300 MVC 0(17,5),#FIELD STORE VALUE (16 CHARS) AND LENGTH (1) 00211400 CLI RF,4 ENDED BY COMMA? 00211500 BNH EX7 00211600 EXER OI #ERSCAN+1,1 PUNCTUATION ERROR - CARRY ON 00211700 BAL 14,AMARK 00211800 EX7 BAL 14,ASCAN SCAN NEXT FIELD 00211900 BXLE 5,2,EX6 INCREMENT POINTER AND SCAN MORE 00212000 EX8 BAL 1,*+8 MAXSYM EXCEEDED, KILL JOB 00212100 DC X'8A',AL1(L'SMES8),SL2(SMES8) 00212200 BAL 14,PRNCOM 00212300 LA 14,EIGHT+2 DO AN IBCOM STOP TO SAVE DATA TAPE 00212400 L 15,IBCOM 00212500 B 68(15) 00212600 * 00212700 * END OF SCAN. RETURN TO NORMAL CRYIN 00212800 * 00212900 EXEND ST 5,VSTOP STORE LOC OF LAST ENTRY 00213000 MVI FUNC3+C'&&',X'24' RESTORE SENSING OF AMPERSANDS 00213100 LTR 1,4 WAS A UNIT SPECIFIED? 00213200 BZ EOF2+4 NO, DON'T POP STACK 00213300 BAL 14,INUNIT YES, PUSH STACK 00213400 EXRSW BC 0,EOF2+4 ** B TO OMIT REWIND 00213450 LR 2,1 AND REWIND THE UNIT 00213500 L 1,IOCOM 00213600 BALR 0,1 00213700 DC AL1(3,1) 00213800 B EOF1 MAYBE UNIT NO GOOD 00213900 B EOF2+4 OK, NOW RESTORE R13-R8, CALL CRYIN AGAIN 00214000 DROP 15,RCB 00214100 EJECT 00214200 * 00214300 * STORAGE FOR WORKING WITH DATE AND TIME 00214400 * 00214500 DTCON DC D'0' WORK AREA 00214600 DTTB DC C' JAN',H'0,0' MONTH AND BEGINNING DATE FOR 00214700 DC C' FEB',H'31,31' REGULAR AND LEAP YEARS 00214800 DC C' MAR',H'59,60' 00214900 DC C' APR',H'90,91' 00215000 DC C' MAY',H'120,121' 00215100 DC C' JUN',H'151,152' 00215200 DC C' JUL',H'181,182' 00215300 DC C' AUG',H'212,213' 00215400 DC C' SEP',H'243,244' 00215500 DC C' OCT',H'273,274' 00215600 DC C' NOV',H'304,305' 00215700 DTTBND DC C' DEC',H'334,335' 00215800 DTM1 DC X'00FFFFFC' 00215900 DTM3 DC FS36E-4'26.04' TIMER UNITS TO HUNDRETH SECONDS 00216000 DTM4 DC F'6000' 00216100 LPP DC A(PGLNS) LINES PER PAGE (VARIABLE FROM CRYMRT) 00216200 * 00216300 * CONSTANTS AND STORAGE FOR PRINT/PUNCH PROGRAM 00216400 * 00216500 SAVEAREA DS 18F SAVE AREA FOR CRYOUT, PUNCH 00216600 SAVERR DS 18F SAVE AREA FOR ERROR MESSAGE TIME 00216700 SAVER2 DS 18F SAVE AREA FOR CARD READER 00216800 SAVER3 DS 18F SAVE AREA FOR EXEC CARDS 00216900 FSAVE DS 3F FORTRAN CARD READ SAVE AREA 00217000 SVTMP DS 6F SUBTITLE SAVE AREA 00217100 OVTMP DS 2F OVERFLOW SAVE AREA 00217110 SEGCW DS H ALIGN BUFFER COUNT 00217200 FORE DC H'4' 00217300 ZOT DC F'0' 00217400 TWO DC F'2' 00217500 SEVEN DC F'7' 00217600 FIFTEEN DC F'15' 00217700 ACOM DC A(COMM) 00217800 * 00217900 * CONSTANTS FOR CRYIN AND CDUNIT 00218000 * 00218100 IUATBL DC V(IHCUATBL) 00218200 IBCOM DC V(IBCOM#) 00218300 CDUPTR DC A(CDUTAB) ADDRESS OF UNIT TABLE 00218400 CDUTOP DC A(CDUTAB-4+4*NCDU) LIMIT FOR UNIT PUSH-DOWN 00218500 CDUBOT DC A(CDUTAB) 00218600 CDUTAB DC (NCDU)X'04000001' USE DEFAULT READ UNIT 00218700 SEGMVC MVC 0(0,4),0(2) 00218800 LEXEC DC C'EXECUNITMAXSNORE' 00218900 LEND DC CL10'END' END OF DECK SIGNAL 00219000 * 00219100 * PARAMETERS FOR FIOCS 00219200 * 00219300 IOCOM DC V(FIOCS#) 00219400 PCOM DC A(PRINT) 00219500 PRUNIT DC X'04',AL3(0) 00219600 CARIJ DC C' ',AL3(CARIJ),F'1' 00219700 UNITY EQU CARIJ+4 00219800 SPEND DC F'-1' SPOUT CONTROL INTEGER 00219900 FLAGS DC X'00' 0000 0001 OVERFLOW LINE 00220000 * 0000 0010 PRINT CALL 00220100 * 0000 0100 NOT FIRST ITEM 00220200 * 0000 1000 FORTRAN CALL 00220300 * 0001 0000 PROCESSING SUBHEAD 00220400 * 0011 0000 SUBHEAD TO BE PRINTED AT ONCE 00220500 * 0100 0000 SPOUT MODE ON 00220600 SPACE 4 00220700 * 00220800 * STORAGE FOR PAGE TITLE AND SUBTITLE 00220900 * 00221000 SBHDBK DS 0F SUBTITLE BLOCK 00221100 CLOC DC A(SBHDCD) LOCATION OF CURRENT RECORD CONTROL 00221200 SHDLNS DC H'2' NUMBER OF LINES IN SUBTITLE 00221300 SHDREC DC H'2' NUMBER OF RECORDS IN TITLES 00221400 LINECT DC H'0' LINES REMAINING ON PAGE 00221500 PGNO DC H'0' PAGE NUMBER 00221600 SBHDCD DC AL2(BFWD-DTWD) LENGTH OF TITLE 00221700 DTWD DC C'1',35C' ' 00221800 DC C' ROCKS - CRYSTALLOGRAPHIC COMPUTING SYSTEM',17C' ' 00221900 DATE DC 24C' ' 00222000 PGWD DC C'PAGE',6C' ' 00222100 BFWD DC AL2(4),C'0 ' 00222200 DS CL(SBHDCH-6) 00222300 * 00222400 * ERROR MESSAGES FOR CONTROL CARD SCAN 00222500 * 00222600 SMES1 DC C' ***UNBALANCED OR NESTED PARENS OR QUOTES AT "$".' 00222700 SMES2 DC C' ***FIELD AT "$" EXCEEDS 16 COLS.' 00222800 SMES3 DC C' ***UNRECOGNIZABLE CONTROL CARD FIELD AT "$".' 00222900 SMES4 DC C' ***INCORRECT PUNCTUATION AT "$".' 00223000 SMES5 DC C' ***REQUIRED FIELD NOT PRESENT.' 00223100 SMES6 DC C' ***ABOVE CARD NOT RECOGNIZED. CHECK COLS. 1-4.' 00223200 SMES7 DC C' ***INVALID NUMERIC VALUE OR DECIMAL ERROR.' 00223300 * (NOTE: "AT $" NOT MENTIONED BECAUSE MAY CALL OUTSIDE SCAN.) 00223400 SMES8 DC C' ***BAD UNIT OR MAXSYM ON EXECUTE CARD.' 00223500 TITLE 'CONTROL CARD DETECTING ROUTINE' 00223600 * 00223700 * 'CNTRL' - FORTRAN CONTROL CARD LOCATING ROUTINE 00223800 * 00223900 * TO DISTINGUISH CONTROL CARDS FROM DATA CARDS 00224000 * CALL CNTRL(CARD,&N) 00224100 * 'CARD' IS LOCATION OF CARD, FIRST 8 COLS. OF WHICH ARE 00224200 * TO BE TESTED FOR PRESENCE OF ALPHABETIC CHARACTERS. 00224300 * RETURNS TO NEXT STATEMENT IF DATA CARD (NO ALPHABETIC) 00224400 * RETURNS TO STATMENT 'N' (ERROR EXIT) IF CONTROL CARD FOUND 00224500 * RECOGNIZES PACKED FORMAT DATA CARDS AS DATA 00224600 * 00224700 * ASSEMBLER USAGE: 00224800 * L 14,#CNTRL 00224900 * TRT CARD,0(14) 00225000 * BNZ CONTROL 00225100 * (BUT NOTE: THIS DOESN'T CHECK FOR PACKED CARDS) 00225200 * 00225300 USING CNTRL,15 00225400 CNTRL STM 14,2,12(13) 00225500 L 1,0(1) LOCATE CARD 00225600 SR 2,2 SET RETURN CODE 0 FOR DATA CARD 00225700 CLI 0(1),X'58' TEST FOR PACKED FORMAT CARD 00225800 BE *+10 00225900 TRT 0(8,1),CVT TEST FOR ALPHABETIC CHARACTERS 00226000 LR 15,2 FUNCTION TO RETURN CODE REGISTER 00226100 LM 0,2,20(13) 00226200 BR 14 RETURN 00226300 DS 0D 00226400 CVT DC 64X'04' 00226500 DC X'00',10X'04',X'00',X'04',2X'00',13X'04',3X'00',X'04' 00226600 DC X'00',10X'04',X'00',18X'04',X'00',X'04' 00226650 DC 64X'04' 00226700 DC 48X'04',10X'00',6X'04' 00226800 * 00226900 * DEFINITION OF CRYM COMMON 00227000 * 00227100 COM 00227200 DS 8F 00227300 CARD DS CL80 STORAGE FOR INPUT CARDS 00227400 IEXIT DS F ERROR FLAG 00227500 END 00227600 JABR TITLE 'CRYM - FORTRAN INTERFACE TO TALK ROUTINES' 00000100 * 00000200 * THESE ROUTINES PROVIDE ADDITIONAL INTERFACE BETWEEN FORTRAN 00000300 * PROGRAMS AND THE 'TALK' PACKAGE OF THE 'CRYM' SYSTEM. 00000400 * (1) BLANK, MOVE, CMPARE 00000500 * TO MANIPULATE CHARACTER STRINGS INDEP OF WORD LENGTH 00000600 * (2) JFIND, XXSCAN, EQSCAN 00000900 * TO AID IN INTERPRETING CONTROL CARDS 00001000 * (3) JAND, JOR, JXOR, JSHFTL, JSHFTR 00001100 * LOGICAL 'AND' AND 'OR' FUNCTIONS 00001200 * 00001300 * REVISED 2/19/79, GNR DELETE MULTIN, MULTOU, PRNUMS 00001340 * ADD XXSCAN OPTIONS -3, -2, 2, 3, XXPSET ENTRY 00001342 SPACE 4 00001400 MACRO 00001500 CHRENT &ENTRY 00001600 USING &ENTRY,15 00001700 &ENTRY STM 14,4,12(13) 00001800 L 15,AJABR 00001900 USING JABR,15 00002000 BAL 2,DEST 00002100 MEND 00002200 SPACE 4 00002300 MACRO 00002400 SETUP &ENTRY 00002500 USING &ENTRY,15 00002600 &ENTRY STM 14,8,12(13) 00002700 LR 2,13 00002800 L 13,AJABR 00002900 USING JABR,13 00003000 DROP 15 00003100 MEND 00003200 * 00003300 * IMMEDIATE SYMBOLS 00003400 * 00003500 JABR START 0 00003600 ENTRY BLANK 00004000 ENTRY MOVE 00004100 ENTRY CMPARE 00004200 ENTRY JFIND 00004300 ENTRY XXSCAN 00004400 ENTRY XXPSET 00004410 ENTRY EQSCAN 00004500 ENTRY JAND,JOR,JXOR,JSHFTL,JSHFTR 00004600 ALL EQU X'FF' MASK FOR TM 00004800 VL EQU X'80' TEST BIT FOR VARIABLE-LENGTH ARG LIST 00004900 DS 18F SAVE AREA 00005000 EJECT 00005100 * CHARACTER STRING SUBROUTINES 00005200 * (1) TO BLANK OUT PART OF A FIELD 00005300 * CALL BLANK (FIELD,IDSPL,LENGTH) 00005400 * 'LENGTH' CHARACTERS BEGINNING 'IDSPL' CHARACTERS BEYOND START 00005500 * OF 'FIELD' WILL BE SET TO BLANKS. (MAX LENGTH = 256) 00005600 * 00005700 * (2) TO MOVE ONE FIELD TO ANOTHER 00005800 * CALL MOVE (FIELD1,IDSPL1,LENGTH,FIELD2,IDSPL2) 00005900 * 'LENGTH' CHARACTERS, BEGINNING 'IDSPL2' CHARACTERS BEYOND 00006000 * START OF 'FIELD2' WILL BE MOVED TO A PLACE 'IDSPL1' CHARACTERS 00006100 * BEYOND START OF 'FIELD1'. FIELD2 AND REST OF FIELD1 ARE 00006200 * UNCHANGED. (MAX LENGTH = 255) 00006300 * 00006400 * (3) TO COMPARE TWO CHARACTER FIELDS 00006500 * CALL CMPARE(FIELD1,IDSPL1,LENGTH,FIELD2,IDSPL2,&EQUAL) 00006600 * RETURNS TO STATEMENT 'EQUAL' IF FIELDS ARE IDENTICAL, 00006700 * OTHERWISE TO NEXT STATEMENT. OTHER SYMBOLS ARE SAME AS 00006800 * FOR 'MOVE'. 'IDSPL2' MAY BE OMITTED IF ZERO FROM 'MOVE' OR 00006900 * 'CMPARE' CALLS. NEGATIVE DISPLACEMENTS ARE ALLOWED. 00007000 * 00007100 * REGISTERS ARE USED AS FOLLOWS: 00007200 * R1 PARAMETER LIST LOCATION IN CALLING PROGRAM 00007300 * R2 INTERNAL CALL TO SET DESTINATION; SOURCE LOCATION 00007400 * R3 DESTINATION FIELD 00007500 * R4 CHARACTER COUNT, LESS ONE 00007600 * R15 BASE REGISTER AND RETURN CODE 00007700 * 00007800 CHRENT BLANK ENTRY POINT BLANK 00007900 MVI 0(3),C' ' BLANK FIRST CHARACTER 00008000 S 4,ONE 00008100 BM *+8 SINGLE CHARACTER, QUIT NOW 00008200 EX 4,MVC1 00008300 LM 2,4,28(13) RESTORE 00008400 BR 14 RETURN 00008500 * 00008600 CHRENT MOVE ENTRY POINT MOVE 00008700 L 2,12(0,1) LOCATE SOURCE 00008800 TM 12(1),VL TEST FOR END OF PARM LIST 00008900 BNZ MOV2 YES 00009000 L 1,16(0,1) NO, LOCATE DISPLACEMENT 00009100 A 2,0(0,1) ADD DISPLACEMENT TO BASE 00009200 MOV2 EX 4,MVC2 MOVE THE FIELD 00009300 LM 2,4,28(13) RESTORE 00009400 BR 14 RETURN 00009500 * 00009600 CHRENT CMPARE ENTRY POINT CMPARE 00009700 L 2,12(0,1) LOCATE SOURCE 00009800 TM 12(1),VL TEST FOR END OF PARAM LIST 00009900 BNZ MOV3 00010000 L 1,16(0,1) 00010100 A 2,0(0,1) 00010200 MOV3 EX 4,CLC3 COMPARE THE TWO FIELDS 00010300 LA 15,0 SET NORMAL RETURN CODE 00010400 DROP 15 00010500 LM 2,4,28(13) RESTORE 00010600 BCR 7,14 NOT EQUAL, RETURN 00010700 LA 15,4 EQUAL, SET CODE TO 4 00010800 BR 14 RETURN 00010900 * 00011000 USING JABR,15 00011100 DEST L 4,8(0,1) LOCATE LENGTH 00011200 L 4,0(0,4) LOAD LENGTH 00011300 S 4,ONE REDUCE FOR EX 00011400 BM CMRET NO COUNT, DON'T BOTHER 00011500 L 3,4(0,1) LOCATE DISPLACEMENT 00011600 L 3,0(0,3) FETCH DISPLACEMENT 00011700 A 3,0(0,1) ADD BASE ADDRESS 00011800 BR 2 RETURN 00011900 CMRET LA 15,4 RETURN WHEN NO COUNT; SET RETURN CODE 00012000 LM 2,4,28(13) 00012100 BR 14 00012200 * 00012300 MVC1 MVC 1(0,3),0(3) MVC FOR BLANKING 00012400 MVC2 MVC 0(0,3),0(2) MVC FOR MOVING 00012500 CLC3 CLC 0(0,3),0(2) CLC FOR COMPARING 00012600 EJECT 00012700 * 00020500 * CONTROL CARD TEST ROUTINES 00020600 * (1) TO FIND A CHARACTER STRING ON A CONTROL CARD 00020700 * J = JFIND(KEY,IDSPL,LENGTH) 00020800 * SCANNING BEGINS 'IDSPL' COLUMNS BEYOND START OF CARD IN 00020900 * COMMON ARRAY 'CARD', AND GOES TO END OF CARD. 00021000 * 'KEY' IS LITERAL STRING TO BE FOUND 00021100 * 'LENGTH' IS LENGTH OF KEY - ASSUMED 4 BYTES IF OMITTED. 00021200 * J IS RETURNED AS DISPLACEMENT OF DESIRED FIELD IF FOUND 00021300 * OR AS ZERO IF FIELD IS NOT FOUND 00021400 * MODIFIED 10/28/74 TO STOP SCAN AT SEMICOLON 00021500 * WARNING: THIS ROUTINE SEARCHES RIGHT THROUGH COMMENTS AND ALL 00021600 * 00021700 USING JFIND,15 00021800 JFIND STM 14,15,12(13) 00021900 LA 0,4 SET DEFAULT LENGTH 00022000 TM 4(1),VL TEST FOR OTHER LENGTH 00022100 BNZ *+12 NO 00022200 L 14,8(0,1) YES, LOCATE LENGTH 00022300 L 0,0(0,14) FETCH LENGTH 00022400 BCTR 0,0 LESS 1 FOR CLC 00022500 STC 0,JCLC+1 SET INSTRUCTION LENGTH FOR COMPARE 00022600 LA 0,72 TOTAL AVAILABLE CARD LENGTH 00022700 L 14,0(0,1) ADDRESS OF KEY TO BE FOUND 00022800 L 1,4(0,1) LOCATE DISPLACEMENT 00022900 L 1,0(0,1) FETCH DISPLACEMENT 00023000 SR 0,1 SET COUNTER 00023100 A 1,ADR FORM ABSOLUTE ADDRESS 00023200 JSMC CLI 0(1),C';' CHECK FOR SEMICOLON 00023300 BE FND-4 00023400 JCLC CLC 0(0,1),0(14) ** LENGTH IS INSERTED HERE 00023500 BE FND 00023600 LA 1,1(0,1) ADVANCE COUNTER 00023700 BCT 0,JSMC LOOP 00023800 L 1,ADR NOT FOUND, GENERATE J=0 00023900 FND S 1,ADR COMPUTE JFIND VALUE 00024000 LR 0,1 PUT IN RETURN REGISTER 00024100 L 14,12(13) RESTORE 00024200 BR 14 RETURN 00024300 EJECT 00024400 * 00024500 * CONTROL CARD SCAN SUBROUTINE 00024600 * (1) TO LOCATE OPTIONS ON A CONTROL CARD AND SET VALUES 00024700 * CALL XXSCAN (ICODE,IERR,KEYLEN,(KEYN,CODEN,ARGN),...) 00024800 * HAVING PREVIOUSLY CALLED 'CDSCAN' TO INITIALIZE SCANNING. 00024900 * CALL 'XXPSET(FIELD)' IF FIRST KEYWORD ALREADY SCANNED 00024910 * THE CARD IS SCANNED FOR THE KEYS 'KEYN' (AS MANY AS DESIRED) 00025000 * WHEN A KEY IS FOUND, THE ACTION DEPENDS ON 'CODEN' 00025100 * IF CODEN.LE.-4, IABS(CODEN) CHARS ARE MOVED TO 'ARGN' 00025140 * FROM VALUE GIVEN BY 'KEYN=VALUE' 00025142 * IF CODEN=-3, 'ARGN' IS SET TO -1 00025144 * IF CODEN=-2, 'ARGN' IS A DATA SET OR PHASE SET LOCATOR 00025146 * TO BE SET TO NAME (CL8) OR POSITION (F,F'0') 00025148 * IF CODEN=-1, 'ARGN' IS OF FORM '&EXIT' AND PROGRAM EXITS TO 00025200 * THE GIVEN FORTRAN STATEMENT, WHICH CAN DO ANYTHING, EXCEPT 00025300 * READ CARDS. AFTER PROCESSING, TO CONTINUE SCANNING, GO BACK 00025400 * TO THE ORIGINAL 'CALL XXSCAN' STATEMENT. 00025500 * IF CODEN=0 TO 3, 'ARGN' IS A FLAG WHICH IS SET = TO 'CODEN' 00025600 * IF CODEN>3, 'VALUE' IS CONVERTED TO INTEGER AND PUT IN 'ARGN' 00025700 * IF CODEN IS A FLOATING POINT NUMBER 'W.D', VALUE IS CONVERTED 00025800 * ACCORDING TO FLOATING POINT FORMAT 'FW.D' AND STORED IN 'ARGN' 00025900 * 00026000 * AT END OF CONTROL CARD, RETURN IS TO STATEMENT AFTER CALL. 00026100 * 'ICODE' IS CELL IN WHICH SCAN CODES ARE TO BE STORED ON EXITS. 00026200 * 'IERR' IS A CELL TO BE SET NONZERO ON PUNCTUATION OR FIELD 00026300 * IDENTIFICATION ERROR. 00026400 * 'KEYLEN' IS LENGTH OF KEYS IN CHARACTERS. 00026500 * 00026600 * REGISTERS: 00026700 * R2 LOCATION OF CODEN 00026710 * R3 LOCATION OF ARGN 00026720 * R4 VALUE OF CODEN 00026730 * R5 LOCATION OF VALUE FIELD 00026740 * R6 POINTER TO KEY LIST BEING SCANNED 00026800 * R7 COUNTS EXITS AS ENCOUNTERED 00026900 * R8 LOCATION OF PARAMETER LIST 00026910 * 00027000 USING XXPSET,15 00027020 XXPSET MVC PRESET(4),BPSET1 SET TO OMIT FIRST KEYWORD SCAN 00027025 MVC APSET(4),0(1) SAVE LOCATION OF FIRST FIELD 00027030 BR 14 RETURN 00027035 DROP 15 00027040 SETUP XXSCAN 00027100 ST 2,4(0,13) SAVE AREA LINKAGE 00027200 ST 13,8(0,2) 00027300 L 15,VCOMM LOCATE TALK ROUTINES 00027400 USING COMM,15 00027500 LA 8,0(0,1) SAVE USER PARM LIST IN R8; DELETE VL 00027600 L 2,8(0,8) LOCATE KEYLENGTH 00027700 L 0,0(0,2) 00027800 BCTR 0,0 00027900 STC 0,CLC+1 00028000 ITEM LR 6,8 STARTING LOCATION OF KEY SCAN 00028100 LA 7,4 COUNT EXITS PASSED 00028200 PRESET BAL 14,#SCAN ** MODIFIED BY XXPSET 00028300 CLI #FLSCAN+1,32 CHECK FOR END OF CARD 00028400 BNL END 00028500 KEY L 14,12(0,6) LOCATE KEY 00028600 L 2,16(0,6) LOCATE CODE 00028700 L 4,0(0,2) FETCH CODE 00028800 CLC CLC 0(0,14),0(1) COMPARE KEYS; ** LENGTH INSERTED HERE 00028900 BE MATCH 00029000 A 4,ONE NO MATCH, TEST FOR EXIT CODE 00029100 BNZ TEST 00029200 LA 7,4(0,7) ADVANCE EXIT COUNTER 00029300 S 6,FOUR DROP BACK PARM POINTER 00029400 TEST TM 20(6),VL END OF KEYWORD LIST? 00029500 LA 6,12(0,6) STEP TO NEXT KEY 00029600 BZ KEY NOT END, CONTINUE SCAN 00029700 OI #ERSCAN+1,2 IS END, NO MATCH, BAD FIELD ERROR 00029800 SCARE BAL 14,#ERMARK MARK THE ERROR 00029900 L 14,4(0,8) SET USER' FLAG 00030000 OI 3(14),1 00030100 COMMA CLI #FLSCAN+1,4 COMMA FOUND? 00030200 BNH ITEM 00030300 BAL 14,#SCAN NO COMMA, FIND ONE 00030400 CLI #FLSCAN+1,32 END OF CARD? 00030500 BL COMMA NO, KEEP LOOKING 00030600 END SR 7,7 END OF CARD FOUND; SET NORMAL EXIT 00030700 EXIT L 14,0(8) STORE SCAN CODE FOR USER 00030800 ST 0,0(0,14) 00030900 LR 15,7 EXIT CODE TO R15 00031000 RETURN L 13,4(0,13) RESTORE REGISTERS 00031100 L 14,12(0,13) 00031200 LM 1,8,24(13) 00031300 BR 14 RETURN 00031400 * 00031500 MATCH LPR 14,4 MATCH FOUND, TEST CODE TYPE 00031600 N 14,MFOUR 0 TO 3 GIVES ZERO HERE 00031700 BZ NOVAL HENCE, NO VALUE IS TO BE READ 00031800 CLI #FLSCAN+1,12 MAKE SURE '=' PRESENT 00031900 BNE MKPUN NO, GO MAKE PUNCTUATION ERROR 00032000 EQUAL BAL 14,#SCAN SCAN FOR VALUE 00032300 L 3,20(0,6) LOCATE ARGUMENT 00032800 BAL 6,CONV2 GO CONVERT ITEM 00032900 B PUNCT GO CHECK PUNCTUATION 00033000 NOVAL LTR 4,4 NO VALUE EXPECTED, TEST FOR SPECIAL CODE 00033100 BNM SETVAL CODE 0-3, GO SET ARG=CODE 00033200 A 4,TWO NEGATIVE CODE, TEST TYPE 00033250 BP EXIT -1, EXIT TO USER 00033300 BZ SETSET -2, SET DATA OR PHASE SET NAME 00033350 * -3, DROP TO SETVAL, SET ARG TO -1 00033400 SETVAL L 3,20(0,6) CODE WAS 0 TO 3, SET ARG TO CODE 00033500 ST 4,0(0,3) 00033600 B PUNCT GO CHECK PUNCTUATION 00033700 SETSET L 3,20(0,6) CODE -2, READ DATA SET LOCATOR 00033710 CLI #FLSCAN+1,12 TEST FOR EQUAL SIGN 00033712 BE SETNAME FOUND, GO GET NAME 00033714 ST 4,4(0,3) NOT FOUND, IS NUMBER, ZERO WD 2 OF ARG 00033716 LR 5,1 LOCATE #FIELD 00033718 LA 1,INLIST LOCATE INPUT CONVERSION CODES 00033720 MVI 3(1),15 SET LENGTH 00033722 BAL 6,8(1) GO READ AND STORE SET NUMBER 00033724 B PUNCT GO CHECK PUNCTUATION 00033726 SETNAME BAL 14,#SCAN SET NAME, PICK UP NAME FIELD 00033728 MVC 0(8,3),0(1) MOVE NAME TO ARG 00033730 * 00033740 PUNCT CLI #FLSCAN+1,4 BE SURE FIELD ENDED BY BLANK OR COMMA 00033742 BNH ITEM OK 00033744 MKPUN OI #ERSCAN+1,1 MARK PUNCTUATION ERROR 00033746 B SCARE 00033748 * 00033750 PSET1 MVC PRESET(4),EQUAL PRESCANNED FIRST KEY - RESTORE PGM FLOW 00033752 L 1,APSET LOCATE FIRST FIELD 00033754 BR 14 RETURN 00033756 BPSET1 BAL 14,PSET1 ALTERNAE INSTR. FOR LOCN. 'PRESET' 00033758 EJECT 00033800 * 00033900 * CONTROL CARD SCAN SUBROUTINE 00034000 * (2) TO SCAN AND CONVERT A SINGLE FIELD (ALREADY IDENTIFIED) 00034100 * CALL EQSCAN(ITEM,CODE,IERR,&EXIT) 00034200 * 'ITEM' IS VARIABLE TO BE SUPPLIED FROM CONTROL CARD, NORMALLY 00034300 * PRECEDED BY A KEYWORD AND AN EQUAL SIGN (ALREADY SCANNED) 00034400 * 'ITEM' MAY BE REAL, INTEGER, OR CHARACTER (F, I, A FORMAT) 00034500 * 'CODE' DETERMINES TYPE OF CONVERSION AS IN 'XXSCAN' 00034600 * 'IERR' IS OPTIONAL. IF ABSENT, PUNCTUATION IS NOT CHECKED. 00034700 * IF PRESENT, PREVIOUS SCAN MUST HAVE FOUND EQUAL SIGN. 00034800 * IF NOT, 'IERR' IS SET NON-ZERO AND RETURN IS TO '&EXIT'. 00034900 * IF '&EXIT' IS OMITTED, RETURN IS TO NEXT STATEMENT. 00035000 * EQSCAN ALSO RETURNS SCAN CODE AS A FUNCTION VALUE 00035100 * (DECLARE 'INTEGER EQSCAN' TO USE THIS FEATURE) 00035200 * REMEMBER '&EXIT' CANNOT BE USED IF EQSCAN IS USED AS FUNCTION 00035300 * 00035400 SETUP EQSCAN 00035500 ST 2,4(0,13) SAVE AREA LINKAGE 00035600 ST 13,8(0,2) 00035700 L 15,VCOMM LOCATE TALK ROUTINES 00035800 USING COMM,15 00035900 LR 8,1 SAVE USER PARM LOC 00036000 TM 4(1),VL SEE IF PUNCT TEST WANTED 00036100 BO EQS 'CODE' IS END OF LIST - NO 'IEXIT' 00036200 CLI #FLSCAN+1,12 TEST FOR PREVIOUS EQUAL SIGN 00036300 BE EQS OK 00036400 OI #ERSCAN+1,1 MARK ERROR 00036500 BAL 14,#ERMARK 00036600 L 1,8(0,8) FIND USER'S ERROR CELL 00036700 OI 3(1),1 SET IT NON-ZERO 00036800 LH 0,#FLSCAN SET FUNCTION VALUE 00036850 LA 15,4 SET RETURN CODE 00036900 B RETURN 00037000 EQS BAL 14,#SCAN OK, GET NEW FIELD 00037100 BAL 6,CONVERT CONVERT FIELD 00037400 LH 0,#FLSCAN SET FUNCTION VALUE 00037450 SR 15,15 SET NORMAL RETURN CODE 00037500 B RETURN 00037700 EJECT 00037800 * 00037900 * 'CONVERT' ROUTINE TO SET UP WIDTH AND DECIMAL CONTROLS 00038000 * AND PERFORM INPUT CONVERSION VIA 'TALK' 00038100 * 00038200 CONVERT L 2,4(0,8) LOCATE USER CODE (WIDTH/POINT) 00038400 L 3,0(0,8) LOCATE ARGUMENT 00038500 CONV2 L 4,0(0,2) GET THE CODE 00038600 TM 0(2),ALL TEST THE TYPE 00038700 LR 5,1 LOCATE #FIELD 00038710 LA 1,INLIST LOCATE INTEGER PARM LIST 00038720 BZ FIXT 00038800 BO CHAR 00038900 LA 1,FLT SET FOR FLOATING POINT 00039000 IC 4,1(0,2) GET WIDTH/POINT FROM MANTISSA OF W.D 00039100 N 4,FFTN GET POINT 00039200 IC 4,PTBL(4) HEX FRACTION TO DECIMAL INTEGER 00039300 STC 4,1(0,1) STORE DEC IN PARM LIST 00039400 IC 4,1(0,2) GET WIDTH 00039500 SRL 4,4 00039600 FIXT S 4,ONE MAKE WIDTH ONE LESS 00039700 BCR 4,6 IF WAS ZERO, SKIP CONVERSION 00039800 STC 4,3(0,1) STORE WIDTH IN LIST 00039900 B 8(1) GO TO LIST AND RETURN TO CALLER 00040000 CHAR LPR 4,4 CHARACTER STRING, FIX WIDTH 00040100 BCTR 4,0 00040200 EX 4,CHR MOVE STRING 00040300 BR 6 00040400 SPACE 3 00040500 * FORTRAN LOGICAL (BIT MANIPULATION) FUNCTIONS 00040600 * (1) TO FORM THE LOGICAL 'AND' OF TWO FULLWORD ARGUMENTS 00040700 * I = JAND(J,K) 00040800 * 00040900 JAND L 15,0(0,1) LOCATE FIRST ARG 00041000 L 0,0(0,15) PICK UP FIRST ARG 00041100 L 15,4(0,1) LOCATE SECOND ARG 00041200 N 0,0(0,15) 'AND' SECOND ARG INTO FIRST 00041300 BR 14 RETURN 00041400 SPACE 3 00041500 * (2) TO FORM THE LOGICAL 'OR' OF TWO FULLWORD ARGUMENTS 00041600 * I = JOR(J,K) 00041700 * 00041800 JOR L 15,0(0,1) LOCATE FIRST ARG 00041900 L 0,0(0,15) PICK UP FIRST ARG 00042000 L 15,4(0,1) LOCATE SECOND ARG 00042100 O 0,0(0,15) 'OR' SECOND ARG INTO FIRST 00042200 BR 14 RETURN 00042300 SPACE 3 00042400 * (3) TO FORM THE EXCLUSIVE 'OR' (BITFLIP) OF TWO FULLWORDS 00042500 * I = JXOR(J,K) 00042600 * 00042700 JXOR L 15,0(0,1) 00042800 L 0,0(0,15) 00042900 L 15,4(0,1) 00043000 X 0,0(0,15) 00043100 BR 14 00043200 SPACE 3 00043300 * (4) TO SHIFT ARGUMENT 1 RIGHT LOGICAL BY ARG 2 BITS 00043400 * I = JSHFTR(J,K) 00043500 * 00043600 JSHFTR L 15,0(0,1) 00043700 L 0,0(0,15) 00043800 L 15,4(0,1) 00043900 L 15,0(0,15) 00044000 SRL 0,0(15) 00044100 BR 14 00044200 SPACE 3 00044300 * (5) TO SHIFT ARGUMENT 1 LEFT LOGICAL BY ARG 2 BITS 00044400 * I = JSHFTL(J,K) 00044500 * 00044600 JSHFTL L 15,0(0,1) 00044700 L 0,0(0,15) 00044800 L 15,4(0,1) 00044900 L 15,0(0,15) 00045000 SLL 0,0(15) 00045100 BR 14 00045200 EJECT 00045300 * 00045400 * CONSTANTS AND STORAGE 00045500 * 00045600 * 00046800 INLIST DC X'00000E00' INTEGER INPUT CONVERSION 00046900 LA 1,0(0,5) 00047000 BAL 14,#BCDIN 00047100 ST 0,0(0,3) 00047200 BR 6 00047300 FLT DC X'00000700' FLOATING POINT INPUT CONVERSION 00047400 LA 1,0(0,5) 00047500 BAL 14,#BCDIN 00047600 STE 0,0(0,3) 00047700 BR 6 00047800 CHR MVC 0(0,3),0(5) 00047900 DROP 15 00048000 * 00048100 AJABR DC A(JABR) 00048400 VCOMM DC V(COMM) 00048500 ADR DC A(CARD) 00048600 FFTN DC F'15' 00048700 ONE DC F'1' 00048800 TWO DC F'2' 00048810 FOUR DC F'4' 00048900 MFOUR DC F'-4' 00049000 PTBL DC X'00010002030004000506000708000900' 00049100 APSET DS A LOCATION OF PRESCANNED FIELD 00049200 * 00049300 COM 00049400 DS 8F 00049500 CARD DS CL80 00049600 * 00049700 COMM DSECT 00049800 #BCDOUT DS F 00049900 #IBCDWT DS F 00050000 #BCDIN DS F 00050100 #CRYOUT DS F 00050200 #PUNCH DS F 00050300 #LINES DS F 00050400 #ERMARK DS F 00050500 #CDSCAN DS F 00050600 #SCAN DS F 00050700 #BLSCAN DS F 00050800 #CRYIN DS F 00050900 #CDPRNT DS F 00051000 #HEAD DS A 00051100 #AHEAD DS A 00051200 #ACCPT DS A 00051300 #ERSCAN DS H 00051400 #FLSCAN DS H 00051500 #FIELD DS CL16 00051600 #CNTRL DS A 00051700 #UNIT DS XL4 00051800 END 00051900 MACRO 00000100 IHCFIOSM 00000200 GBLA &ERR 00000300 AIF (&ERR EQ 0).FINO 00000400 IOCS TITLE 'IHCEFIOS - OPERATING SYSTEM/360 - FORTRAN INPUT/OUTPUT' 00000500 IHCEFIOS CSECT 00000600 AGO .FI001 00000700 .FINO ANOP 00000800 IOCS TITLE 'IHCFIOSH - OPERATING SYSTEM/360 - FORTRAN INPUT/OUTPUT' 00000900 IHCFIOSH CSECT 00001000 .FI001 ANOP 00001100 * 00001200 * 00001300 * 00001400 * STATUS -- CHANGE LEVEL 7 - 1 AUGUST 1974 RELEASE 21.8 00001500 * 00001600 * MODIFIED 4/27/77 G.N.R. TO INCORPORATE SETFIL 00001700 * SETFIL CORRECTED FOR DD DUMMY, 1/17/78 G.N.R. 00001800 * SETFIL CORRECTED FOR DSN IN TRAILER LABEL, 10/31/78 G.N.R. 00001900 * 00002000 *FUNCTION/OPERATION--ALL I/O READ AND WRITE AND MANIPULATIVE COMMANDS 00002100 * OF A FORTRAN SOURCE PROGRAM RESULT IN ONE OR MORE ENTRIES INTO THIS 00002200 * ROUTINE, AND IN TURN, FIOCS MAKES AN APPROPRIATE REQUEST OF THE 00002300 * CONTROL PROGRAM. 00002400 *ENTRY POINTS--ONE ENTRY POINT WITH PARAMETERS AS FOLLOWS- 00002500 * 00002600 * INITIALIZATION 00002700 * LA GRX,DSRN POINTER TO DATA SET REF NO 00002800 * L L,=V(FIOCS#) 00002900 * BALR R,L 00003000 * DC AL1(0) 00003100 * DC AL1(FQUALS) 00003200 * WHERE DSRN IS OF THE FORM XL1'FLAG',AL3(UNIT) 00003300 * AND FQUALS = X'F0' FOR FORMATTED INPUT 00003400 * X'FF' FOR FORMATTED OUTPUT 00003500 * X'00' FOR NON-FORMATTED INPUT 00003600 * X'0F' FOR NON-FORMATTED OUTPUT 00003700 * 00003800 * READ OPERATION 00003900 * L L,=V(FIOCS#) 00004000 * BALR R,L 00004100 * DC AL1(1) 00004200 * DC AL1(0) 00004300 * 00004400 * WRITE OPERATION 00004500 * L GRX,RECLEN 00004600 * L L,=V(FIOCS#) 00004700 * BALR R,L 00004800 * DC AL1(2) 00004900 * DC AL1(0) 00005000 * WHERE RECLEN = NUMBER OF BYTES OF OUTPUT 00005100 * 00005200 * 00005300 * CONTROL OPERATION 00005400 * LA GRX,DSRN 00005500 * L L,=V(FIOCS#) 00005600 * BALR R,L 00005700 * DC AL1(3) 00005800 * DC AL1(CQUALS) 00005900 * WHERE DSRN IS OF THE FORM XL1'FLAG',AL3(UNIT) 00006000 * AND CQUALS = X'00' FOR BACKSPACE BLOCK 00006100 * X'01' FOR REWIND 00006200 * X'02' FOR WRITE END OF FILE MARK 00006300 * 00006400 * CLOSE DATA SETS 00006500 * L L,=V(FIOCS#) 00006600 * BALR R,L 00006700 * DC AL1(4) 00006800 * DC AL1(0) 00006900 * 00007000 * SETFIL SETUP AND CLOSE CALL 00007100 * DC AL1(5,1) 00007200 * 00007300 *INPUT--ALL INPUT PARAMETERS ARE FROM THE MODULE IHCFCOMH, 00007400 * AND ARE CONTAINED IN THE REGISTERS 0, 2, OR 3. 00007500 * 00007600 *OUTPUT--POINTERS TO BUFFERS, AND BUFFER LENGTHS, ARE GIVEN TO EITHER 00007700 * FCOMH, THE CALLING ROUTINE, OR TO THE CONTROL PROGRAM. 00007800 * 00007900 *EXTERNAL ROUTINES-- 00008000 * IHCFCOMH--ERROR MESSAGES, FROM ERRORS DETERMINED BY FIOCS, 00008100 * ARE PASSED TO IHCFCOMH. 00008200 * 00008300 *EXITS-- 00008400 * NORMAL--TO IHCFCOMH VIA REG. 1, 6 BYTES BEYOND BAL 0,1 00008500 * ERROR--(VIA REGISTER 15 WITH OFFSET)- 00008600 * 1.* IF DUE TO SYNAD, TO IHCFCOMH'S SYNAD ENTRY POINT. 00008700 * 2.* IF AT END OF DATA SET, TO IHCFCOMH'S EODAD ENTRY POINT. 00008800 * 3.* IF DUE TO AN ERROR,TO IHCFCOMH'S IBFERR ENTRY. 00008900 * 4.* IF FOR LACK OF A DD CARD TO PRINT ERROR MESSAGE, TO 00009000 * IHCFCOMH'S IBEXIT ENTRY. 00009100 * 00009200 *TABLES/WORK AREAS-- 00009300 * IHCUATBL--(REFERENCED EXTERNALLY)- 00009400 * UNIT ASSIGNMENT TABLE, CONSISTING OF - 00009500 * WORD ONE- ABSOLUTE VALUE = (NO. OF DSRN'S X 4) + 4 00009600 * WORD TWO- FOUR 1 BYTE INDEXES TO ASSIGNED DSRN'S 00009700 * WORDS THREE AND FOLLOWING- 4 WORDS PER DSRN, TO CONTAIN 00009800 * A POINTER TO THE UNIT TABLE FOR THAT DSRN, THEN 2 WORDS 00009900 * PER DSRN CONTAINING DEFAULT VALUES. 00010000 * UNIT TABLE-- 00010100 * ONE UNIT TABLE IS CONSTRUCTED OR IS IN CORE PER DSRN REFERENCED. 00010200 * EACH SUCH TABLE CONSISTS OF FOUR SECTIONS, USED AS FOLLOWS- 00010300 * 1.* HOUSEKEEPING SECTION - 7 WORDS 00010400 * 2.* DECB AREA - 2*6 WORDS 00010500 * 3.* DCB AREA - 88 BYTES 00010600 * 4.* PTR TO JFCB AREA - 4 BYTES 00010700 * 00010800 *ATTRIBUTES--THIS MODULE IS NOT REENTRANT AND ALSO NOT SERIALLY 00010900 * REUSEABLE. 00011000 * 00011100 *NOTES--DEPENDENCIES 00011200 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL 00011300 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS 00011400 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. THE CODING HAS 00011500 * BEEN ARRANGED SO THAT REDEFINITION OF 'CHARACTER' CONSTANTS, 00011600 * BY REASSEMBLY, WILL RESULT IN A CORRECT MODULE FOR THE NEW 00011700 * DEFINITIONS. 00011800 * 00011900 * 00012000 EJECT 00012100 ***** 00012200 * REGISTER DEFINITIONS 00012300 R EQU 0 RETURN REG. USED IN CUR. IBCOM 00012400 L EQU 1 LINKAGE REG. USED IN CUR. IBCOM 00012500 GRX EQU 2 FIRST ARGUMENT 00012600 GRY EQU 3 SECOND ARGUMENT 00012700 RX EQU 4 UTILITY AND BRANCH 00012800 RD EQU 5 UTILITY 00012900 CSECT2R EQU 5 BASE REG FOR IHCFIOS2 00013000 UTR EQU 6 UNIT TABLE REGISTER 00013100 DCBR EQU UTR+1 00013200 DECBR EQU UTR+2 00013300 RI EQU 9 UTILITY REGISTER 00013400 RJ EQU 10 UTILITY AND BRANCH REGISTER 00013500 BASE2 EQU 11 UAT ADDRESSABILITY REGISTER 00013600 BASE EQU 12 FIOCS ADDRESSABILITY REGISTER 00013700 SAVER EQU 13 00013800 R15 EQU 15 INDIC BSP PAST LOAD PNT 1/15 50138/57009 00013900 * 00014000 * IBCOM OFFSETS 00014100 IBFEROFS EQU 60 00014200 DSRNOF EQU 60 OFFSET IN IBCOM TO DSRN FIELD 00014300 THRTNUSR EQU 184 OFFSET IN IBCOM(SAVE) TO REG 13 00014400 FRTNUSR EQU 124 OFFSET IN IBCOM(SAVE) TO REG 14 00014500 IBCSV EQU X'C4' OFFSET IN IBCOM TO ERR. SAVEAREA 00014600 BUFPTRS EQU X'114' ADDRESS IN IBCOM OF WHERE TO 00014700 * STORE CURRENT BUFFER AND ITS LNG 00014800 ENDFILE EQU X'10C' OFFSET IN IBCOM FOR END= PARAM 00014900 SPACE 3 00015000 ***** 00015100 RDECB EQU X'80' 00015200 WDECB EQU X'20' 00015300 MINLEN EQU 18 MINIMUM RECORD LENGTH 00015400 VARUNIT EQU X'01' VARIABLE UNIT FLAG 00015500 XIOCLASS EQU X'04' ERRMSG,READ,PRINT,PUNCH 00015600 VFORM EQU X'40' V FORMAT RECORDS 00015700 VSFORM EQU X'48' VARIABLE SPANNED FORMAT II232 00015800 VSBFORM EQU X'58' VSB FORMAT 00015900 JFCBFLG EQU X'07' DCB EXIT CODE FOR TYPE=J 00016000 FCNTL EQU X'03' RWD,BSP,EOF 00016100 PRIMOP EQU 0 00016200 SECOP EQU 1 00016300 * 00016400 ONES EQU 1 00016500 ON EQU 1 II232 00016600 EQUAL EQU 8 00016700 ZERO EQU 8 00016800 NOTPLUS EQU 12 MINUS OR ZERO 00016900 EJECT 00017000 ***** 00017100 * ABYTE BITS 00017200 FORMAT EQU X'F0' FORMAT QUALIFIER 00017300 OUTPUT EQU X'0F' OUTPUT QUALIFIER 00017400 SPACE 3 00017500 ***** 00017600 * BBYTE BITS 00017700 ETEST EQU X'80' 'ERR=' PARAM ON READ 00017800 EYES EQU X'40' SYNAD TAKEN ON CHK 00017900 BSW EQU X'20' BUF SW, IBCOM BUF IS 2 00018000 ERR EQU X'10' ERROR OCCURRED.BIT NOT 10595 00018100 * TURNED OFF TILL NXT CHECK10595 00018200 EOBSW EQU X'08' IBCOM BUF EXHAUSTED 00018300 BLSW EQU X'04' BLOCKED RECORDS 00018400 VSWITCH EQU X'02' VAR. RECS. USE BLK'G ROUTINES 00018500 * MASKS TO SET OR TEST ABOVE 00018600 VBLSW EQU X'06' 00018700 ETYES EQU X'C0' 00018800 EOFF EQU X'3F' 00018900 BINIT EQU X'08' 00019000 EOBSWOFF EQU X'F7' SET END OF BUFFER SWITCH A37386 00019100 SPACE 3 00019200 ***** 00019300 * CBYTE BITS 00019400 OPENSW EQU X'80' DCB IS OPEN,CLOSED IF PREV RWD 00019500 NTCLOSE EQU X'40' EOF DOES TCLOSE,CAN BSP OVER 00019600 PROPEN EQU X'20' PREV. OPEN 00019700 POOLSW EQU X'10' BUFFER POOL ASSIGNED 00019800 RWNDFLAG EQU X'08' NOT RWD PREV. 00019900 CONCAT EQU X'02' 00020000 DUMMY EQU X'01' BIT IN CBYTE INDICATING DUMMY DS 7434 00020100 * TEST OR SET ABOVE SWS. 00020200 CLOSRWND EQU X'37' 00020300 CLSET EQU X'BF' 00020400 INITSET EQU X'FC' 00020500 POOLOFF EQU X'EF' 00020600 SPACE 3 00020700 ***** 00020800 * DBYTE BITS 00020900 PBSP EQU X'80' PHYSICAL BACKSPACE HAS OCCURRED GNR 00021000 LBSP EQU X'40' LOGICAL BACKSPACE HAS OCCURRED GNR 00021100 RETBUF EQU X'10' END-OF-FILE SHOULD RETAIN BUFFS GNR 00021200 EOFBSP EQU X'02' END-OF-FILE FOLLOWED BY BACKSPACE GNR 00021300 DASD EQU X'01' TEST FOR DASD I/O ** 00021400 FF EQU X'FF' 10595 00021500 VL EQU X'80' VARIABLE LENGTH LIST TERMINATOR 00021600 EJECT 00021700 ***** 00021800 ENTRY FIOCS# 00021900 AIF (&ERR EQ 0).FI201 00022000 ENTRY FIOCSBEP 00022100 .FI201 ANOP 00022200 FIOCS# EQU * 00022300 FIOCSA BCR 1,0 'PIPELINE DRAIN' FOR MOD 91 **** 00022400 USING FIOCSA,L 00022500 AIF (&ERR EQ 0).FI202 00022600 B SAVRGSS GO TO BEGINNING 00022700 USING FIOCSB,L 00022800 FIOCSB EQU * 00022900 FIOCSBEP EQU FIOCSB 00023000 BCR 1,0 DRAIN THE PIPE LINE FOR MODEL 91 00023100 L 1,FIOSHCON SET UP ADDRESSABILITY AS FOR 00023200 USING FIOCSA,L NORMAL ENTRY TO FIOCS 00023300 STM 14,12,12(13) SAVE REGS IN USER'S AREA 00023400 LA BASE2,LSAVEA SER 'LSAVEA' AS NEXT SAVE AREA 00023500 ST BASE2,8(0,13) 00023600 LR BASE2,13 SET UP FOR USER'S 13 TO GO INTO 00023700 * 'LSAVEA' +4. 00023800 MVI SW1,1 SET SPECIAL ENTRY SWITCH 00023900 B GETRGS 00024000 SAVRGSS EQU * 00024100 .FI202 ANOP 00024200 ST 13,SAVE+4 00024300 STM 14,12,SAVE+12 00024400 AIF (&ERR EQ 0).FI210 00024500 LA BASE2,SAVE SET SAVE AS PREVIOUS SAVE AREA 00024600 GETRGS EQU * 00024700 ST BASE2,LSAVEA+4 PUT PREVIOUS SAVE AREA IN LSAVEA 00024800 .FI210 ANOP 00024900 LM BASE2,SAVER,UATCON 00025000 DROP L 00025100 USING FIOCSA,BASE 00025200 USING IHCUAT,BASE2 00025300 USING UB,UTR 00025400 USING IHADCB,DCBR 4595 00025500 USING DECB,DECBR 00025600 LR RX,R 00025700 SR RJ,RJ 00025800 IC RJ,PRIMOP(RX) PICKUP PRIMARY OPERATION 00025900 STC RJ,OPTION1 GNR 00026000 SLA RJ,2 00026100 B ENTRY(RJ) 00026200 ENTRY B FINIT 00026300 B FREAD SECONDARY ENTRY FOR READ 00026400 B FRITE 00026500 B FCTRL 00026600 B FCLOS 00026700 B FSPEC 00026800 EJECT 00026900 ***** 00027000 DS 0D 00027100 PKDD DC 2F'0' 00027200 WORK2 DC 2F'0' INIT SET IN CVTB 00027300 TEMP DS F TEMPORARY STORAGE AREA 10842 00027400 LENGTH DS H CHARS. WRITTEN BY IBCOM 00027500 TOOSMALL DC AL2(MINLEN) GNR 00027600 CON4 DC H'4' 00027700 MIL DC H'16' MAXIMUM ITEM LENGTH II232 00027800 CON256 DC F'256' CONSTANT FOR DIVIDE 4595 00027900 * SWITCHES 00028000 OPTION1 DC X'00' 00028100 FLAG DC X'00' 00028200 ECHECK DC X'00' 00028300 PARAMS DC XL1'00' 00028400 AIF (&ERR EQ 0).FI211 00028500 SW1 DC XL1'00' SWITCH USED TO INDICATE ENTRY 00028600 * FOR WRITING ON OBJ. ERROR UNIT 00028700 .FI211 ANOP 00028800 OBJADDR DC F'0' ADDRESS OF ERROR UNIT ENTRY IN UATBL 00028900 SAVE5 DC F'0' TEMP SAVE FOR REG5 1/3 63580 00029000 PASTLOAD DC F'0' BSP PAST LOAD PT SW 2/15 50138/57009 00029100 XLRECL DC X'8000' LRECL=X II232 00029200 SAVEOPT DC XL1'00' 00029300 ZEROS DC F'0' 00029400 * SAVE AREAS 00029500 DS 0F 00029600 UTREGSV EQU * PTRS SAVED BY UTINIT 00029700 UTPTR DC F'0' 00029800 DCBPTR DC F'0' 00029900 DECBPT DC F'0' POINTER TO LAST USED DECB II210 00030000 ERRUB DC F'1' 00030100 DS 2F AREA FOR USE BY OBJ. ERROR UNIT 00030200 * 00030300 SAVE DC 2F'0' USED UPON ENTRY FROM IBCOM 00030400 DC A(LSAVEA) 00030500 DC 15F'0' 00030600 * 00030700 MSAVEA DC 9F'0' 00030800 * 00030900 LSAVEA DC 1F'0' 00031000 DC A(SAVE) 00031100 DC 16F'0' 00031200 VIHCERRM DC V(IHCERRM) ADDRESS OF ERROR MONITOR 00031300 VFIOCS2 DC A(FIOCS2) ADDRESS OF SECOND SECTION GNR 00031400 AIF (&ERR EQ 0).FI1 00031500 VRETEMP DC F'0' HOLDS OPEN EXIT RTNE 32775 00031600 * ADDRESSABILITY DURING 214 32775 00031700 * 00031800 * 00031900 PRMS214 DC A(MSG214) ADDRESS OF THE MESSAGE 00032000 DC A(RETCD) ADDRESS OF THE RETURN CODE FIELD 00032100 DC A(E214) ADDRESS OF THE ERROR NUMBER 00032200 DC XL1'80' LAST PARAMETER INDICATOR 00032300 DC AL3(DSRNPTR) ADDRESS OF THE DATA SET 00032400 * REFERENCE NUMBER 00032500 PRMS217 DC A(MSG217) 00032600 DC A(RETCD) 00032700 DC A(E217) 00032800 DC XL1'80' 00032900 DC AL3(DSRNPTR) 00033000 PRMS218 DC A(0) 00033100 DC A(RETCD) 00033200 DC A(E218) 00033300 DC A(DSRNPTR) 00033400 DC XL1'80' 00033500 DC AL3(0) 00033600 PRMS219 DC A(MSG219) 00033700 DC A(RETCD) 00033800 DC A(E219) 00033900 DC XL1'80' 00034000 DC AL3(DSRNPTR) 00034100 PRMS220 DC A(MSG220) 00034200 DC A(RETCD) 00034300 DC A(E220) 00034400 DC XL1'80' 00034500 DC AL3(DSRNPTR) 00034600 PRMS231 DC A(MSG231) 00034700 DC A(RETCD) 00034800 DC A(E231) 00034900 DC XL1'80' 00035000 DC AL3(DSRNPTR) 00035100 E214 DC F'214' 00035200 E217 DC F'217' 00035300 E218 DC F'218' 00035400 E219 DC F'219' 00035500 E220 DC F'220' 00035600 E231 DC F'231' 00035700 RETCD DC F'0' 00035800 DSRNPTR DC F'0' 00035900 OBJPTR DC F'0' 00036000 WTP218 DC AL2(108) MSG LENGTH 25557 00036100 DC X'8000' MCSFLAGS FIELD 25557 00036200 WTPSW DC X'00' SW TO INDICATE ERR 218 OR 219 25557 00036300 DS 0H 00036400 * 00036500 * 00036600 .FI1 ANOP 00036700 ADERRNO DC A(0) 00036800 DC F'0' 00036900 DC XL1'80' 00037000 DC AL3(ERRORNO) 00037100 ERRORNO DC F'0' 00037200 AIF (&ERR EQ 1).FI7 GNR 00037300 MCSCODE1 DC H'108' LENGTH OF MSG 218 25557 00037400 DC X'8000' MCSFLAGS FIELD 25557 00037500 MCSCODE2 DC X'0200' DESCRIPTOR CODE 25557 00037600 DC X'0020' 25557 00037700 .FI7 ANOP 00037800 EJECT 00037900 ***** 00038000 FINIT EQU * 00038100 BAL RJ,UTINIT 00038200 B DAFINIT SEQUENTIAL RETURN FROM UTINIT 00038300 AIF (&ERR EQ 0).FI2 00038400 ERR231 LA 1,PRMS231 GET PARAMETER LIST ADDRESS GNR 00038500 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00038600 BAL RJ,OFFCMINT(0,CSECT2R) GO PUT OUT ERROR 00038700 ERRRET L 13,4(0,13) RESTORE ADDRESS OF SAVE AREA FRO 00038800 LM 14,12,12(13) WHICH TO RESTORE REGS. AND 00038900 DROP BASE RESTORE REGISTERS 00039000 USING FIOCSA,L 00039100 CLI SW1,1 IS THIS A SPECIAL ENTRY 00039200 BE *+8 YES, BRANCH 00039300 L 13,4(0,13) NO, RESTORE REG. 13 FOR USER 00039400 MVI SW1,0 RESET ENTRY SWITCH 00039500 SR GRY,GRY INDICATE ZERO LENGTH RECORD 00039600 DROP L 00039700 USING FIOCSA,BASE 00039800 LR 1,0 00039900 B 2(0,1) RETURN AT ERROR OFFSET 00040000 AGO .FI6 00040100 .FI2 ANOP 00040200 ERR231 LA 1,231 INDICATE ERROR 231 GNR 00040300 COMERRHN ST 1,ERRORNO SAVE ERROR NUMBER IN PARAM. LIST 00040400 LA 1,ADERRNO GET ADDRESS OF PARAMETERS 00040500 L 15,IBCOMCON GET IBCOM ADDRESS 00040600 L 13,THRTNUSR(0,15) GET USER'S REG 13 00040700 MVC 12(16,13),FRTNUSR(15) MOVE HIS REGS 14-1 TO HIS AREA 00040800 ST 13,IBCSV+4(0,15) LINK SAVE AREAS 00040900 LA 13,IBCSV(0,15) GET IBCOMS SAVE AREA 00041000 L 15,VIHCERRM GET ADDDRESS OF ERROR MONITOR 00041100 BR 15 GO TO GIVE MESSAGE 00041200 .FI6 ANOP 00041300 DAFINIT TM CBYTE,POOLSW RTN HERE IF NORMFLAG ON 00041400 BO SETOP 00041500 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00041600 BAL RJ,OFFGTPL(0,CSECT2R) GO GET BUFFER POOL 00041700 SETOP TM PARAMS,OUTPUT 00041800 BO TESTOUT 00041900 EJECT 00042000 ***** 00042100 FREAD LM UTR,DECBR,UTREGSV 00042200 TM ABYTE,OUTPUT * WAS PREVIOUS OPERATION A WRITE? MAINT 00042300 BNO TESTEOB * NO, BRANCH MAINT 00042400 BAL RJ,INVERT MAINT 00042500 BAL RJ,DOCHECK MAINT 00042600 NOP 0 MAINT 00042700 B SETABYTE MAINT 00042800 SPACE 3 00042900 ***** 00043000 TESTEOB TM BBYTE,EOBSW AT END OF BUFFER ? 00043100 BO CR1 YES. CHECK NEXT 00043200 * 00043300 * IF VAR/BLK'D, GETLEN COMES HERE 00043400 * 00043500 DEBLOCK BAL RI,ENDREC GET NEXT RECORD 00043600 * 00043700 LA GRX,0(RX,RD) 00043800 TM DCBRECFM,VFORM 00043900 BO DBVAR 00044000 * 00044100 LH GRY,DCBLRECL 00044200 AR RD,GRY 00044300 DBCOMMON ST RD,RECPTR RECPTR FOR NEXT READ 00044400 CH RD,LN IS NEXT RECPTR WITHIN BLK 00044500 BL DBRETURN 00044600 OI BBYTE,EOBSW SET END OF BUFFER 00044700 DBRETURN B FIORET 00044800 * 00044900 DBVAR MVC TEMP(2),0(GRX) MOVE AND 00045000 LH GRY,TEMP LOAD LITTLE LL 00045100 AR RD,GRY BUMP TO NEXT RECORD 00045200 SH GRY,CON4 SUBTR.J OFF CTL WD 00045300 AH GRX,CON4 BUMP PAST CTL WD 00045400 B DBCOMMON 00045500 EJECT 00045600 CR1 EQU * 31899 00045700 TM BBYTE,ERR IF ERROR OCCURRED BRANCH TO10595 00045800 BO CR ALLOW USER TO GET RECORD 10595 00045900 CR2 BAL RJ,DOREAD GO READ CURRENT RECORD 4595 00046000 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00046100 CR BAL RJ,DOCHECK CHECK FOR ANY I/O ERROR 00046200 B SETEOD EOD RETURN 00046300 L GRX,AREA ADDR OF BUFFER JUST CHECKED 4595 00046400 * 00046500 * FOLLOWING LENGTH DETERMINATION IS EFFECTIVE FOR ALL V, U, AND TRUE 00046600 * TRUNCATED OR NON-TRUNCATED FIXED LENGTH RECORDS. - IF NOT TRUE 00046700 * TRUNCATED FOR FIXED, THEN SYNAD IS TAKEN. 00046800 * 00046900 GETLEN TM BBYTE,VSWITCH TEST FOR VARIABLE FORMAT 10842 00047000 BO GETVLN 10842 00047100 LH GRY,DCBBLKSI 10842 00047200 L RD,STATLOC STATUS IN DECB 00047300 SH GRY,14(RD) SUBTR BYTES NOT READ 00047400 * NOW HAVE LGTH OF BLOCK 00047500 TESTRVBL TM BBYTE,VBLSW VAR OR BLK'D 00047600 BZ FIORET NO 00047700 STH GRY,LN SAVE LGTH OF BLOCK READ 00047800 B DEBLOCK YES 00047900 GETVLN LH GRY,0(0,GRX) GET LENGTH OF VAR BLOCK 10842 00048000 B TESTRVBL BRANCH TO RECORD TEST II210 00048100 EJECT 00048200 * 00048300 DOCHECK OI BBYTE,ETEST ENABLE I/O ERROR CHECKING 00048400 CKCOM NI BBYTE,FF-ERR TURN OFF ERROR LAST TIME BT10595 00048500 CLI LIVECT,0 ANY I/O PENDING 10595 00048600 BE 4(0,RJ) NO 4595 00048700 MVI LIVECT,0 4595 00048800 * CHECK (DECBR) CHECK LAST I/O OPERATION 00048900 CHECK (DECBR) CHECK LAST I/O OPERATION 00049000 TM CBYTE,CONCAT WAS RTN FROM CONCATENATION 00049100 BO SETUBYTE YES, RE-INITIALIZE AND RE-READ 00049200 MVC ECHECK(1),BBYTE MOVE OUT BBYTE FOR ERR CHECK 00049300 NI BBYTE,EOFF TURN OFF ERROR TESTING BITS 00049400 TM ECHECK,ETYES ERR TEST AND ERROR OCCURRED? 00049500 BO SETSYN YES, TAKE ERROR EXIT 00049600 B 4(RJ) NORMAL RETURN 00049700 * 00049800 INVERT CLI DCBBUFNO,1 IS DATA SET SINGLE BUFFERED II210 00049900 BCR EQUAL,RJ DO NOT INVERT BUFFERS IF YES II210 00050000 BAL RX,GETABUF GET CURRENT BUFFER AND DECB PTRS II210 00050100 ST DECBR,DECBPTR SAVE DECB POINTER IN UNIT BLOCK II210 00050200 AIF (&ERR EQ 1).FI657 00050300 ST DECBR,DECBPT 00050400 AGO .FI647 00050500 .FI657 ANOP 00050600 CLI SW1,1 23848 00050700 BNE PRESTR MAINT 00050800 CLC ERRUB(4),UTREGSV ERROR ON SAME UNIT AS OBJ ERR MAINT 00050900 BNE STR MAINT 00051000 PRESTR ST DECBR,DECBPT YES,CHANGE DECB SAVED MAINT 00051100 * BY REGULAR CALL MAINT 00051200 STR EQU * 23848 00051300 ST DECBR,ERRUB+8 II210 00051400 .FI647 ANOP 00051500 XI BBYTE,BSW INVERT BUF BIT 00051600 BR RJ 00051700 * 00051800 GETABUF L RD,BUF2 4595 00051900 LA DECBR,DECB2 II210 00052000 TM BBYTE,BSW 4595 00052100 BCR ON,RX BUF2, SWITCH SET 00052200 L RD,BUF1 BUF1,SWITCH NOT SET 4595 00052300 LA DECBR,DECB1 II210 00052400 BR RX 4595 00052500 EJECT 4595 00052600 * 4595 00052700 DOREAD MVI LIVECT,1 4595 00052800 MVI DECBIO,X'80' INPUT, READ 'BLKSIZE' 4595 00052900 * READ (DECBR),SF,(DCBR),MF=E 00053000 READ (DECBR),SF,(DCBR),MF=E 4595 00053100 BR RJ 4595 00053200 DOWRITE MVI LIVECT,1 4595 00053300 MVI DECBIO,X'00' OUTPUT, WRITE LENGTH 4595 00053400 * WRITE (DECBR),SF,(DCBR),MF=E 00053500 WRITE (DECBR),SF,(DCBR),MF=E 4595 00053600 BR RJ 4595 00053700 * 00053800 * 00053900 * 00054000 ENDREC TM BBYTE,EOBSW AT END OF BUFFER ? 00054100 BZ EOBOFF NO 00054200 L GRX,BUF1 FOR SINGLE BUFFERING 00054300 CLI DCBBUFNO,1 SINGLE BUFFERED? 00054400 BE GOTBUFPT YES, BRANCH 00054500 BAL RX,GETABUF YES, GET PTR TO BUFFER 00054600 X RD,BUFMASK FLIP BUFFERS II210 00054700 L DECBR,DECBPTR II210 00054800 LR GRX,RD 00054900 GOTBUFPT SR GRY,GRY CLEAR REG 00055000 TM DCBRECFM,VFORM VAR RECORD ? 00055100 BZ *+8 NO 00055200 LA GRY,4 YES, SKIP BLK LGTH 00055300 STM GRX,GRY,BLKPTR STORE BLKPTR & RECPTR 00055400 XI BBYTE,EOBSW FLIP EOBSW 00055500 * 00055600 EOBOFF LM RX,RD,BLKPTR LOAD BLKPTR & RECPTR 00055700 BR RI 00055800 EJECT 00055900 * 00056000 * HERE INITIALLY ON A WRITE CALL 00056100 * 00056200 ***** 00056300 TESTOUT TM ABYTE,OUTPUT WAS PREV. OP READ 00056400 BO CHECKBL NO, BRANCH 00056500 MVC ABYTE(1),PARAMS * INITIALIZE ABYTE 27374 00056600 OI DBYTE,RETBUF INDICATE NOT TO FREE BUFFERS 27374 00056700 TM BBYTE,EOBSW+BLSW END OF BUFFER AND BLOCKED? GNR 00056800 BNO BUFTST NO, PROCESS READ-AHEAD RECORD GNR 00056900 TM BBYTE,VSWITCH * ARE RECORDS VARIABLE 27374 00057000 BO INVT * YES - PROCESS READ AHEAD RECORD27343 00057100 CLC RECPTR+2(2),DCBBLKSI WILL ANOTHER FIXED BLK FIT 27343 00057200 BNL INVT * NO - PROCESS READ AHEAD RECORD 27374 00057300 NI BBYTE,FF-EOBSW SET SW OFF 27374 00057400 B BUFTST * FILL REST OF BUFFER 27374 00057500 INVT BAL RJ,INVERT * FLIP BUFFERS 27374 00057600 BAL RI,ENDREC * GET PTRS 27374 00057700 BAL RJ,DOCHECK * 27374 00057800 B BLNK * EOD RETURN 27374 00057900 CLI DCBBUFNO,1 SINGLE BUFFERED? MAINT 00058000 BE BLNK YES - DO NOT BKSP MAINT 00058100 B ONEBK * BACKSPACE ONE RECORD 27374 00058200 BUFTST CLI DCBBUFNO,1 * SINGLE BUFFERED 27374 00058300 BE BACK1 * 27374 00058400 * 2 BUFS READS AHEAD 00058500 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00058600 BAL RJ,CKCOM YES, CHECK LAST READ 00058700 B BACK1 EOD RETURN 27374 00058800 BAL RJ,BKSPONE 00058900 BACK1 TM BBYTE,BLSW ARE RECS BLKD? MAINT 00059000 BZ SETDBYTE NO - BRANCH MAINT 00059100 BAL RJ,INVERT MAINT 00059200 ONEBK BAL RJ,BKSPONE * 27374 00059300 BLNK EQU * 27374 00059400 BAL RX,BLANK BLANK REST OF BUFFER GNR 00059500 NI DBYTE,FF-RETBUF SET OFF SWITCH 27374 00059600 CHECKBL TM BBYTE,EOBSW ONLY COME HERE IF HAVE BEEN 00059700 BO FINDBUF WRITING. 00059800 * FRITE WILL HAVE SET UP PTRS 00059900 * FOR RECORD AND PASSED TO 00060000 * CALLER BUT CALLER DID NOT USE. 00060100 EJECT 00060200 * FINIT EXITS TO HERE ON V/B 00060300 BLOCINIT BAL RI,ENDREC OBTAIN NEXT RECORD 00060400 LH GRY,DCBLRECL LGTH 00060500 LA GRX,0(RX,RD) PTR TO RECORD 10842 00060600 TM DCBRECFM,DCBRECU RECFM=U? II232 00060700 BO FIORET YES,BRANCH. II232 00060800 TM DCBRECFM,VFORM IS RECFM VARIABLE 10842 00060900 BZ FIORET 10842 00061000 * 00061100 LH GRY,DCBBLKSI II232 00061200 SR GRY,RD II232 00061300 VOUT EQU * II232 00061400 SH GRY,CON4 II232 00061500 MVC 2(2,GRX),ZEROS ZERO LAST 2 BYTES OF SCW 10842 00061700 LA GRX,4(0,GRX) PTR TO RECORD 10842 00061800 B FIORET 00061900 * 00062000 * 'CKMIXED' SECTION (IBM II232) REMOVED HERE 00062100 * REMAINING SPACE IN FORMATTED VSB REC IS CHECKED AT BVAR GNR 00062200 * (SECTION TERMINATED BUFFER IF REMAINING SPACE < LRECL 00062300 * THIS WAS PROBABLY TO PREVENT ITEMS FROM BEING SPLIT) 00062400 * 00062500 SPACE 3 00062600 FINDBUF BAL RX,GETABUF GET NEXT BUFFER 00062700 X RD,BUFMASK FLIP BUFFERS II210 00062800 LR GRX,RD POINTER TO BUFFER 00062900 LH GRY,DCBBLKSI SIZE 00063000 B FIORET 00063100 EJECT 00063200 ***** 00063300 FRITE STH GRX,LENGTH IBCOM RTNS # BYTES WRITTEN 00063400 AIF (&ERR EQ 0).FI203 00063500 CLI SW1,1 IS THIS ENTRY FOR OBJ. ERR. UNIT 00063600 BE LOADOBJ YES BRANCH 00063700 .FI203 ANOP 00063800 LM UTR,DECBR,UTREGSV PTRS TO UB,DCB,DECB 00063900 TEST1 EQU * 00064000 TM BBYTE,VBLSW VAR OR BLK'D? GNR 00064100 BZ COMOUT NO 00064200 * 00064300 * 00064400 * 00064500 BLOCK LM RX,RD,BLKPTR LOAD BLKPTR & RECPTR 00064600 LH 0,DCBBLKSI II232 00064700 TM DCBRECFM,VFORM VAR ? 00064800 BO BVAR YES 00064900 * 00065000 LH GRY,DCBLRECL II232 00065100 AR RD,GRY NO. ADD LRECL TO CUR REC OFFSET 00065200 SR 0,RD II232 00065300 CR 0,GRY II232 00065400 BL BEOBSET II232 00065500 LA GRX,0(RX,RD) PTR TO NEXT RECORD(FIXED) 00065600 ST RD,RECPTR II232 00065700 B FIORET II232 00065800 EJECT 00065900 AIF (&ERR EQ 0).FI204 00066000 * 00066100 LOADOBJ LM UTR,DECBR,ERRUB LOAD REGS FROM SECONDARY SAVE 00066200 B TEST1 AREA THEN BRANCH BACK 00066300 .FI204 ANOP 00066400 * 00066500 BVAR LTR GRX,GRX CHECK LENGTH OF DATA PORTION.4993 00066600 LA GRX,4(GRX) ADD LENGTH OF SEGMENT CW. 4993 00066700 BNZ BVAR1 IS SEGMENT LENGTH GT 4? 4993 00066800 TM DCBRECFM,DCBRECCC NO. IS A PRINTER CONTROL 4993 00066900 BZ BVAR1 CHARACTER NEEDED? 4993 00067000 LA GRX,2(GRX) YES. MAKE SEGMENT LENGTH 6. 4993 00067100 BVAR1 LA RJ,0(RX,RD) POINT TO SEGMENT CTL WORD. 4993 00067200 * OF SEG JUST FILLED BY IBCOM. II232 00067300 STH GRX,TEMP 00067400 MVC 0(2,RJ),TEMP MOVE LITTLE LL TO CTL WD 00067500 AR RD,GRX NEXT RECORD 00067600 LA GRX,0(RX,RD) PTR TO SCW OF NEXT RECORD 10842 00067700 ST RD,RECPTR RECORD OFFSET 00067900 TM BBYTE,BLSW IS THIS VARIABLE UNBLOCKED 00068000 BZ BEND YES, TERMINATE BLOCK 00068100 SR 0,RD BLKSIZE-RD=# OF BYTES REMAINING IN THE II232 00068200 * BLOCK II232 00068300 LH RJ,MIL NEED AT LEAST MIL BYTES GNR 00068400 TM PARAMS,FORMAT IF UNFORMATTED, GNR 00068500 BZ *+8 GNR 00068600 LH RJ,DCBLRECL OR LRECL IF FORMATTED GNR 00068700 CR 0,RJ DO ENOUGH USABLE BYTES REMAIN? GNR 00068750 BL BEND NO, BRANCH II232 00068800 LR GRY,0 (GRY)=# OF USEABLE BYTES IN BUFFER II232 00068900 B VOUT GNR 00069000 * 00069100 BEND EQU * TERMINATE BLOCK GNR 00069400 L RD,RECPTR SET BLOCK LGTH IN BIG LL 00069500 SLL RD,16 INSURE LAST 2 BYTES OF BDW WILL BE 0 II210 00069600 ST RD,0(RX) STORE BIG LL II210 00069700 * 00069800 BEOBSET OI BBYTE,EOBSW CURR BUF DONE IN 00069900 EJECT 00070000 * 00070100 COMOUT CLC LENGTH(2),TOOSMALL II210 00070200 BNL MOVLEN OK 00070300 MVI LENGTH+1,MINLEN SET MINIMUM LENGTH 00070400 MOVLEN MVC LN(2),LENGTH FIELD USED IF U RECS 00070500 BAL RJ,DOWRITE 4595 00070600 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00070700 NI BBYTE,EOBSWOFF A38926 00070800 BAL RJ,DOCHECK CHECK PREVIOUS WRITE A38926 00070900 NOP 0 DUMMY END EXIT 00071000 OI BBYTE,EOBSW A38926 00071100 TESTWVBL BAL RX,SETBUF GO TO CLEAR BUFFER 10842 00071200 TM BBYTE,VBLSW 10842 00071300 BZ FIORET NO 00071400 B BLOCINIT INIT BLOCKING 00071500 * 00071600 * BLANK OUT A BUFFER (SETBUF) OR PART OF ONE (BLANK) 00071700 * 00071800 BLANK TM PARAMS,FORMAT IS IT FORMATTED? GNR 00071900 BCR ZERO,RX YES, FORGET IT GNR 00072000 L RI,AREA GET AREA ADDRESS GNR 00072100 A RI,RECPTR PLUS THE OFFSET GNR 00072200 LH GRY,DCBBLKSI GET BUFFER LENGTH GNR 00072300 S GRY,RECPTR LESS OFFSET GNR 00072400 B SUBT GNR 00072500 SETBUF TM PARAMS,FORMAT 10842 00072600 BCR ZERO,RX IF UNFORMATTED, FORGET IT 10842 00072700 L RI,AREA CURRENT BUFFER POINTER II210 00072800 LH GRY,DCBBLKSI LOAD BUFFER LGTH 4595 00072900 SUBT MVI 0(RI),C' ' FMT TO BLANKS GNR 00073000 BCTR GRY,0 LESS ONE FOR EXECUTE 24797 00073100 BCTR GRY,0 LESS ONE FOR DOMINOE EFFECT 4595 00073200 LR 0,GRY COPY THE LENGTH TO R0 GNR 00073300 SRA 0,8 DIVIDE BY 256 FOR NO OF MVCS GNR 00073400 BZ RITOUT NO 4595 00073500 ZEROBUF MVC 1(256,RI),0(RI) 4595 00073600 LA RI,256(RI) NEXT LGTH 4595 00073700 BCT 0,ZEROBUF ANOTHER PIECE GNR 00073800 RITOUT EX GRY,ZEROPART INIT REMAINDER GNR 00073900 L GRX,AREA CURRENT BUFFER POINTER II210 00074000 LH GRY,DCBBLKSI 4595 00074100 BR RX 4595 00074200 ZEROPART MVC 1(1,RI),0(RI) 4595 00074300 EJECT 00074400 ***** 00074500 UTINIT MVC PARAMS(1),SECOP(RX) 00074600 MVC FLAG(1),0(GRX) 00074700 TM FLAG,VARUNIT 00074800 BZ NOTVAR 00074900 L GRX,0(GRX) 00075000 NOTVAR L GRX,0(GRX) 00075100 TM FLAG,XIOCLASS 00075200 BZ LOGUTCL 00075300 IC GRX,ERRMSG(GRX) 00075400 LOGUTCL LA RD,0(GRX) 00075500 STH GRX,BYTES STORE DSRN IN UAT 00075600 AIF (&ERR EQ 0).FI5 00075700 CLI SW1,1 IS ENTRY FOR OBJ. ERR. UNIT 00075800 BE SAVEOBJ YES, BRANCH 00075900 ST RD,DSRNPTR NO, SAVE DSRN 00076000 L 15,IBCOMCON GET ADDRESS OF IBCOM 00076100 ST RD,DSRNOF(0,15) SAVE DSRN FOR IBCOM'S POSSIBLE 00076200 B CHKRNG USE(IF AN ERROR OCCURS) 00076300 SAVEOBJ ST RD,OBJPTR SAVE DSRN FOR LATER USE 00076400 CHKRNG EQU * 00076500 .FI5 ANOP 00076600 LTR GRX,RD IS DSRN ZERO 00076700 BC 13,DSRNERR BR IF DSRN ZERO OR NEGATIVE 00076800 BCTR GRX,0 SET UP FOR 0-ORIGIN INDEXING ** 00076900 SLA GRX,4 MULT. BY 16 FOR INDEX VALUE ** 00077000 CH GRX,ENDT 00077100 BL GOODUT 00077200 AIF (&ERR EQ 0).FI3 00077300 DSRNERR LA 1,PRMS220 GIVE MESSAGE 220 00077400 LA RJ,ERRRET SET RETURN POINT 00077500 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00077600 B OFFCMINT(0,CSECT2R) GO PUT OUT ERROR 00077700 AGO .FI8 00077800 .FI3 ANOP 00077900 DSRNERR LA 1,220 GIVE MESSAGE 220 00078000 B COMERRHN 00078100 .FI8 ANOP 00078200 GOODUT LA GRX,UTENTRY(GRX) COMPUTE UAT POINTER ADDRESS ** 00078300 TM 15(GRX),DASD IS THIS A DASD DSRN ** 00078400 BC 1,DACHK BR IF A SEQUENTIAL DSRN ** 00078500 BC 15,4(RJ) MAKE DASD RETURN ** 00078600 DACHK TM 3(GRX),X'01' IS UNIT BLOCK ALREADY LOADED ** 00078700 BZ LOADED BR IF ALREADY IN STORAGE 00078800 EJECT 00078900 LOADUT EQU * 00079000 * GETMAIN R,LV=LENUB GETMAIN FOR UB,DCB AND 2 DECBS 00079100 GETMAIN R,LV=LENUB GETMAIN FOR UB,DCB AND 2 DECBS 00079200 ST 1,0(GRX) ADDR OF UB 00079300 LR UTR,1 00079400 MVI UB,0 4595 00079500 MVC UB+1(LENUB-1),UB ZERO OUT UNIT BLOCK 00079600 MVC DOFFSET+16(72),DCBBL+16 00079700 LA DCBR,DOFFSET 00079800 ST DCBR,DCBOFFS 00079900 LA DECBR,RWOFS ADDRESS OF DECB1 II210 00080000 ST DECBR,DECBPTR II210 00080100 ***** 00080200 LOADED L UTR,0(GRX) UTR PTS TO UB 00080300 L DCBR,DCBOFFS PTS TO DCB 00080400 L DECBR,DECBPTR II210 00080500 AIF (&ERR EQ 0).FI205 00080600 CLI SW1,1 IS THIS OBJ. ERR. UNIT 00080700 BNE SAVRGS NO- BRANCH 00080800 STM UTR,DECBR,ERRUB SAVE FOR NEXT ENTRY IN SECONDARY 00080900 B *+8 AREA AND BRANCH. 00081000 SAVRGS EQU * 00081100 .FI205 ANOP 00081200 STM UTR,DECBR,UTREGSV SAVE FOR NEXT ENTRY 00081300 CLI OPTION1,FCNTL CONTROL OPERATION? GNR 00081400 BCR 2,RJ HIGH IS FSPEC CALL GNR 00081500 BE CTLTST GNR 00081600 TM PARAMS,OUTPUT IF OUTPUT 24797 00081700 BO NFLG LEAVE SWITCH ON 24797 00081800 B SETOFF 24797 00081900 EJECT 00082000 CTLTST EQU * 24797 00082100 CLI PARAMS,X'00' 2ND BKSP AFTER EOF? II210 00082400 BE NFLG YES II210 00082500 SETOFF NI DBYTE,FF-EOFBSP SET SWITCH OFF II210 00082600 NFLG TM CBYTE,OPENSW+NTCLOSE OPEN, NOT TCLOSED? II210 00082700 BNO OP NO II210 00082800 TM DBYTE,LBSP PREV OP BKSP? II210 00082900 BZ OPENED NO - BRANCH TO 214 TEST GNR 00083000 OP EQU * II210 00083100 TM CBYTE,RWNDFLAG TEST IF OPENED ( WILL NOT 00083200 * BE OPENED IF PREVIOUSLY REWOUND 00083300 * OR IF NEVER OPENED BEFORE) 00083400 BO NOTRWD CLOSED IF PREV RWD 00083500 TM OPTION1,FCNTL DCB CLOSED 00083600 BZ NOTRWD BRANCH IF NOT CNTL 00083700 TM PARAMS,X'02' EOF ? (CQUALS) 00083800 BZ NEOFOPEN BR IF NOT EOF AND OPENED 00083900 NOTRWD TM CBYTE,PROPEN PREV OPEN ? 00084000 BO PRIOROP 00084100 SPACE 3 00084200 ***** 00084300 FIXUT BAL RI,CVTB SET UNIT # IN DCB 00084400 MVC DCBDDNAM+2(2),WORK2+6 STORE IN FTXXF001 SKEL. 00084500 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00084600 B OFFOPEN(0,CSECT2R) OPENING FOR FIRST TIME 00084700 SPACE 3 00084800 ***** 00084900 OPENED EQU * 00085000 TM BBYTE,VSWITCH VARIABLE RECS? 14452 00085100 BCR ON,RJ IF YES RETURN 14552 00085200 TM PARAMS,FORMAT IS REQUEST FORMATTED? 14552 00085300 BCR ON,RJ IF YES RETURN 14552 00085400 TM OPTION1,FCNTL IS CURRENT OPERATION CONTROL? 14552 00085500 BCR ON,RJ IF YES RETURN 14552 00085600 AIF (&ERR EQ 1).FI372 00085700 LA 1,214 PICK UP ERROR NUMBER 14552 00085800 B COMERRHN ISSUE ERROR MESSAGE 14552 00085900 AGO .FI375 00086000 .FI372 ANOP 00086100 LA 1,PRMS214 ERROR MESSAGE INDICATOR 14552 00086200 LA RJ,ERRRET 14552 00086300 B COMINTFC GO TO PUT OUT THE ERROR 14552 00086400 .FI375 ANOP 00086500 EJECT 00086600 ***** 00086700 PRIOROP TM CBYTE,RWNDFLAG WAS THERE A PREVIOUS REWIND 00086800 BZ SETDDTO1 YES, SET DDNAME TO SEQ 1 00086900 TM DBYTE,LBSP PREVIOUS OP BKSP? II210 00087000 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT II210 00087100 BO OFFPRBKS(0,CSECT2R) BRANCH IF YES II210 00087200 * PREVIOUS EOF PROCEDURE 00087300 PREVEOF OI CBYTE,NTCLOSE TURN OFF TCLOSE SWITCH 00087400 CLI OPTION1,FCNTL 4595 00087500 BNE EOFSOP 4595 00087600 CLI PARAMS,X'01' 4595 00087700 BL GOBSP2 BACKSPACE=X'00' 4595 00087800 BCR ZERO,RJ ENDFILE = X'02' 14552 00087900 * 4595 00088000 EOFSOP EQU * 00088100 * CLOSE ((DCBR),LEAVE),MF=(E,CLOSLIST) GNR 00088200 CLOSE ((DCBR),LEAVE),MF=(E,CLOSLIST) GNR 00088300 NI CBYTE,CLOSRWND+RWNDFLAG INDICATE NOT OPENED 00088400 * 00088500 INCRDD PACK PKDD+6(2),DCBDDNAM+5(3) 00088600 CVB RD,PKDD 00088700 LA RD,1(RD) 00088800 BAL RI,CVTB 00088900 MVC DCBDDNAM+5(3),WORK2+5 00089000 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00089100 B OFFOPEN(0,CSECT2R) OPEN 00089200 * 00089300 SPACE 3 00089400 ***** 00089500 * JUST RWD, REINIT TO FTXXF001 00089600 SETDDTO1 MVC DCBDDNAM+5(3),DDMSK+5 00089700 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00089800 B OFFOPEN(0,CSECT2R) OPEN 00089900 EJECT 00090000 ***** 00090100 CVTB CVD RD,PKDD RD CONTAINS UNIT NO. 00090200 UNPK WORK2(8),PKDD+4(4) LAST HALF-WD CONTAINS NO. 00090300 OI WORK2+7,X'F0' GET RID OF SIGN 4595 00090400 BR RI 00090500 SPACE 3 00090600 * 00090700 SETUBYTE MVI CBYTE,INITSET INITIALIZE CBYTE 00090800 BAL RX,GETBUFFS SET ADDR OF BUF1 & BUF2 IN UB MAINT 00090900 SETDBYTE MVI DBYTE,X'00' INITIALIZE DBYTE MAINT 00091000 SETABYTE MVI BBYTE,BINIT II210 00091100 SETA MVC ABYTE(1),PARAMS II210 00091200 L CSECT2R,VFIOCS2 SECTION MOVED BECAUSE OF 00091300 B OFFSTBYT(0,CSECT2R) ADDRESSABILITY PROBLEM 00091400 * 00091500 GETBUFFS L RD,DCBBUFCB STORE ADDR OF BUF1 & BUF2 00091600 L RI,0(RD) IN UNIT BLOCK 00091700 ST RI,BUF1 00091800 ST RI,AREA1 SET ADDRESS OF BUFF1 IN AREA1 II210 00091900 CLI DCBBUFNO,1 SINGLE BUFFERED 00092000 BCR EQUAL,RX YES, RETURN 00092100 AH RI,6(RD) ADD BLKSIZE TO BEGINNING 00092200 ST RI,BUF2 PUT 2ND BUF. ADDR. IN UB 00092300 ST RI,AREA2 SET ADDRESS OF BUF2 IN DECB2 II210 00092400 MVC BUFMASK,BUF1 II210 00092500 XC BUFMASK,BUF2 CREATE MASK FOR FLIPPING BUFFERS II210 00092600 BR RX 00092700 EJECT 00092800 ***** 00092900 FCTRL BAL RJ,UTINIT 00093000 B CTLRTN SEQUENTIAL RETURN 00093100 NEOFOPEN LA GRX,FORMAT(0) TELL IHCFCOME NOT TO READ ** 00093200 * DASD CTRL RETURNS HERE ** 00093300 * COMES HERE ALSO FROM LOADED 00093400 * RTNE IF NOT EOF AND OPENED 00093500 B FIORET RETURN TO CALLER IF DASD 00093600 CTLRTN CLI PARAMS,X'01' 4595 00093700 BH EOFM 'ENDFILE' = X'02' 4595 00093800 BE RWND 'REWIND' = X'01' 4595 00093900 * 'BACKSPACE' = X'00' 4595 00094000 SPACE 3 00094100 ***** 00094200 BKSP EQU * II210 00094300 BLTEST TM BBYTE,BLSW ARE RECORDS BLOCKED ? II210 00094400 BO EOFBB YES - BRANCH II210 00094500 TM DBYTE,PBSP PREVIOUS OPERATION A BKSP? II210 00094600 BO BKSPBLK YES - BRANCH II210 00094700 OI DBYTE,RETBUF INDICATE NOT TO FREE BUFS II210 00094800 BAL RJ,INVERT INVERT BUFS II210 00094900 BAL RJ,CKCOM CHECK PENDING I/O II210 00095000 B BKSPBLK EOD RETURN II210 00095100 NI DBYTE,FF-RETBUF SET SW OFF II210 00095200 TM ABYTE,OUTPUT OUTPUT DATA SET? II210 00095300 BZ BTEST BRANCH ON INPUT II210 00095400 BAL RI,TCLOSE WRITE LAST RECORD AND EOF II210 00095500 B BKSPBLK GO BACKSPACE II210 00095600 BTEST EQU * II210 00095700 CLI DCBBUFNO,1 CHECK BUFFERING II210 00095800 BE BKSPBLK SINGLE BUFFERED II210 00095900 NBLOOP BAL RJ,BKSPONE BKSP TWICE IF BUFNO = 2 II210 00096000 * HERE IF UNBLOCKED AND PREV OP WAS BSP 00096100 BKSPBLK BAL RJ,BKSPONE II210 00096200 TM ABYTE,FORMAT FORMATTED I/O? II210 00096300 BO NBOUT YES - RETURN II210 00096400 BAL RI,BLOOP3 READ - CHECK II210 00096500 L GRX,AREA OBTAIN CURRENT BLOCK PTR II210 00096600 TM 6(GRX),X'02' ANY PRECEEDING SEGMENTS? II210 00096700 BO NBLOOP YES- BKSP AGAIN II210 00096800 BAL RJ,BKSPONE NO - DO FINAL BKSP II210 00096900 NBOUT OI DBYTE,PBSP+LBSP SET LOG AND PHY BKSP SWITCHES II210 00097000 B FIORET RETURN TO IBCOM II210 00097100 EJECT 00097200 * 00097300 * INITIAL ENTRY TO BACKSPACE BLOCKED RECORDS 00097400 * 00097500 EOFBB EQU * II210 00097600 TM DBYTE,EOFBSP SECOND BKSP AFTER EOF? II210 00097700 BZ VORF NO - BRANCH TO TEST REC TYPE II210 00097800 NI DBYTE,FF-EOFBSP SET SWITCHES OFF II210 00097900 TM CBYTE,POOLSW ARE BUFFS ATTACHED? II210 00098000 BO SPEC1 YES - BRANCH II210 00098100 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT II210 00098200 BAL RJ,OFFGTPL(0,CSECT2R) GO TO GET BUFFER POOL II210 00098300 SETBLK MVC BLKPTR(4),BUF1 SET CURRENT BUFF PTR II210 00098400 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT II210 00098500 B OFFOPBK(0,CSECT2R) GET ADDRESS OF DECB1 II210 00098600 SPACE 3 00098700 SPEC1 BAL RI,BLOOP2 BKSP - READ - CHECK II210 00098800 B EOFCHK LOAD PAST BKSP? 61512 00098900 SETSW OI DBYTE,PBSP+LBSP SET DBYTE SWITCHES II210 00099000 LH GRX,DCBBLKSI CALC LEN OF BLOCK II210 00099100 L RJ,STATLOC II210 00099200 SH GRX,14(RJ) II210 00099300 TM BBYTE,VSWITCH VARIABLE RECORDS? II210 00099400 BO VAR YES - BRANCH II210 00099500 B SUB1 GO SET RECPTR TO PRECEEDING RECII210 00099600 EJECT 00099700 VORF EQU * II210 00099800 TM BBYTE,VSWITCH VARIABLE RECORDS? II210 00099900 BO VAR1 YES - BRANCH II210 00100000 SR GRX,GRX II210 00100100 C GRX,RECPTR RECPTR=0? II210 00100200 BNE DSTEST BRANCH IF NOT 0 II210 00100300 TM ABYTE,OUTPUT OUTPUT DS? II210 00100400 BZ IN1 BRANCH IF INPUT II210 00100500 TM DBYTE,LBSP PREVIOUS OP A BKSP? II210 00100600 BO BACKSP YES - BRANCH II210 00100700 TCL BAL RI,TCLOSE WRITE LAST RECORD AND EOF II210 00100800 B SETBLK BRANCH TO SET BLKPTR II210 00100900 INVRT BAL RJ,INVERT INVERT BUFFS II210 00101000 BACKSP EQU * II210 00101100 BAL RI,BLOOP1 BKSP - BKSP - READ - CHECK II210 00101200 EOFCHK L R15,PASTLOAD 61512 00101300 LTR R15,R15 WAS THERE INDICATION 50138/57009 00101400 BZ SETSW NO,NORMAL OPERATION, CONT 50138/57009 00101500 SR R15,R15 CLEAR INDICATOR 50138/57009 00101600 ST R15,PASTLOAD RESET SWITCH 50138/57009 00101700 BAL RJ,BKSPONE BSP OVER REC JUST READ 50138/57009 00101800 BAL RJ,INVERT FLIP BUFFERS 50138/57009 00101900 * SET DBYTE TO INDICATE PHYSICAL BACKSPACE 00102000 OI DBYTE,PBSP+LBSP PREV OP, BACKSPACE 11/15 50138/57009 00102100 B TESTWVBL BLANK OUT AND GET NEW BUFFER GNR 00102200 IN1 EQU * II210 00102300 TM DBYTE,PBSP HAS A PHYSICAL BKSP OCCURRED? II210 00102400 BO BACKSP BRANCH IF YES II210 00102500 BUFTEST CLI DCBBUFNO,1 SINGLE BUFFERED? II210 00102600 BE BACKSP BACKSPACE TWICE II210 00102700 OI DBYTE,RETBUF INDICATE NOT TO FREE BUFFS II210 00102800 BAL RJ,INVERT DOUB BUF - INVERT AREA II210 00102900 BAL RJ,DOCHECK CHECK PENDING I/O II210 00103000 B INVRT EODAD RETURN II210 00103100 NI DBYTE,FF-RETBUF SET SW OFF II210 00103200 BAL RJ,INVERT INVERT BUFFERS II210 00103300 LA RI,SETSW II210 00103400 B BLOOP BACKSPACE THREE TIMES II210 00103500 DSTEST EQU * II210 00103600 TM DBYTE,LBSP PREVIOUS OP A BKSP? II210 00103700 BO SUB YES - BRANCH II210 00103800 TM ABYTE,OUTPUT OUTPUT DS? II210 00103900 BO TCL YES - WRITE LAST REC AND EOF II210 00104000 OI DBYTE,LBSP SET DBYTE II210 00104100 SPACE 00104200 SUB EQU * II210 00104300 L GRX,RECPTR II210 00104400 SUB1 SH GRX,DCBLRECL OBTAIN PTR TO PRECEEDING RECORDII210 00104500 ST GRX,RECPTR II210 00104600 B FIORET RETURN TO IBCOM II210 00104700 EJECT 00104800 * 00104900 * VARIABLE BLOCKED BACKSPACE 00105000 * 00105100 VAR1 LA GRX,4 II210 00105200 C GRX,RECPTR RECPTR AT FIRST RECORD IN BLK? II210 00105300 BNE VAR3 NO - BRANCH II210 00105400 TM ABYTE,OUTPUT OUTPUT DATA SET? II210 00105500 BZ PTR4 BRANCH ON INPUT II210 00105600 TM DBYTE,LBSP PREV OP A BKSP? II210 00105700 BO PTR4 YES - BKSP TWICE II210 00105800 B TCL TCLOSE IF FIRST BACKSPACE II210 00105900 VAR3 MVC RECSV(2),RECPTR+2 SAVE RECPTR II210 00106000 TM DBYTE,LBSP PREVIOUS OP A BKSP? II210 00106100 BO SEARCH NO - BRANCH II210 00106200 TM ABYTE,OUTPUT OUTPUT DS? II210 00106300 BO TCL TCLOSE IF FIRST BACKSPACE II210 00106400 OI DBYTE,LBSP SET DBYTE II210 00106500 SEARCH BAL RJ,LOOP1 BR TO LOCATE PRECEEDING REC II210 00106600 PTR4 EQU * II210 00106700 TM DBYTE,PBSP PHYSICAL BKSP OCCURRED PREVIOUSLY?II210 00106800 BO BACKSP YES - BRANCH II210 00106900 TM ABYTE,OUTPUT OUTPUT DS? II210 00107000 BZ BUFTEST BRANCH IF INPUT II210 00107100 B BACKSP BR TO BKSP TWICE II210 00107200 VAR L RX,BLKPTR OBTAIN PTR TO BUFF II210 00107300 MVC RECSV(2),0(RX) OBTAIN BIG LL II210 00107400 BAL RJ,LOOP1 LOCATE PRECEEDING RECORD II210 00107500 B BACKSP BR TO BKSP TWICE II210 00107600 SPACE 3 00107700 LOOP1 EQU * II210 00107800 SR GRX,GRX II210 00107900 STH GRX,PTSV II210 00108000 LA GRX,4 SET RECPTR TO FIRST REC IN BLK II210 00108100 ST GRX,RECPTR II210 00108200 LOOP EQU * II210 00108300 A GRX,BLKPTR OBTAIN PTR TO REC II210 00108400 TM 2(GRX),X'02' ANY PRECEEDING SEGMENTS? II210 00108500 BO CONT YES - BRANCH II210 00108600 MVC PTSV(2),RECPTR+2 NO - SAVE RECPTR II210 00108700 CONT EQU * II210 00108800 MVC WKBK2(2),0(GRX) OBTAIN LITTLE LL II210 00108900 L GRX,WKBK2 II210 00109000 SLL GRX,1 ZERO OUT HIGH ORDER BIT II210 00109100 SRL GRX,17 II210 00109200 A GRX,RECPTR INCREASE RECPTR BY LITTLI LL II210 00109300 ST GRX,RECPTR SET RECPTR II210 00109400 CH GRX,RECSV END OF SEARCH? II210 00109500 BNE LOOP NO - GO THRU LOOP AGAIN II210 00109600 SR GRX,GRX II210 00109700 CH GRX,PTSV FIRST SEGMENT FOUND? II210 00109800 BCR 8,RJ NO - RETURN TO BKSP AGAIN II210 00109900 MVC RECPTR+2(2),PTSV YES - SET RECPTR II210 00110000 B FIORET RETURN TO IBCOM II210 00110100 EJECT 00110200 BLOOP BAL RJ,BKSPONE II210 00110300 BLOOP1 BAL RJ,BKSPONE II210 00110400 BLOOP2 BAL RJ,BKSPONE II210 00110500 BLOOP3 BAL RJ,DOREAD READ CURRENT BLOCK II210 00110600 BAL RJ,DOCHECK CHECK PREVIOUS READ II210 00110700 B NBOUT BRANCH IF DUMMY DATA SET A43159 00110800 BR RI RETURN II210 00110900 SPACE 3 00111000 GOBSP2 EQU * II210 00111100 OI DBYTE,PBSP+LBSP+EOFBSP SET SWITCHES II210 00111200 B FIORET RETURN TO IBCOM II210 00111300 SPACE 3 00111400 RECSV DS H II210 00111500 PTSV DS H II210 00111600 * 00111700 BKSPONE EQU * 00111800 * BSP (DCBR) 00111900 BSP (DCBR) 00112000 ST R15,PASTLOAD SET INDICATION FROM BSP 15/15 50138/57009 00112100 * RETURN CODE OF 4 INDICATES EITHER ERROR ON BACKSPACE 00112200 * OR POINTING AT TAPE MARK OR BEGINNING OF EXTENT 00112300 BR RJ 00112400 EJECT 00112500 ***** 00112600 RWND DS 0H II210 00112700 BAL RJ,FINBLOCK 9351 00112800 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00112900 TM ABYTE,OUTPUT 20213 00113000 BZ NOERRCK FOR INPUT DATA SET DO NOT 20213 00113100 OI BBYTE,ETEST ENABLE ERROR CHECKING 20213 00113200 NOERRCK BAL RJ,CKCOM CHECK PREVIOUS I/O 20213 00113300 NOP 0 00113400 CLI OPTION1,5 SPECIAL FILSET CALL? GNR 00113500 BNE RWNDNML GNR 00113600 * CLOSE ((DCBR),LEAVE),MF=(E,CLOSLIST) GNR 00113700 CLOSE ((DCBR),LEAVE),MF=(E,CLOSLIST) GNR 00113800 B RWND2 GNR 00113900 RWNDNML EQU * GNR 00114000 * CLOSE ((DCBR),REREAD),MF=(E,CLOSLIST) GNR 00114100 CLOSE ((DCBR),REREAD),MF=(E,CLOSLIST) GNR 00114200 RWND2 NI CBYTE,CLOSRWND 00114300 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00114400 BAL RI,OFFFRPL(0,CSECT2R) GET RID OF YOUR BUFFERS 00114500 B FIORET RETURN TO IBCOM 00114600 EJECT 00114700 ***** 00114800 EOFM BAL RJ,FINBLOCK 00114900 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00115000 BAL RJ,DOCHECK CHECK PREVIOUS I/O OPERATION 00115100 B SETCL 00115200 TM ABYTE,OUTPUT WAS LAST OPERATION OUTPUT? 47947 00115300 BNZ TSTDA YES, GO TEST FOR D.A. DEV 47947 00115400 CLI DCBBUFNO,1 DATA SET SINGLE BUFFERED? 47947 00115500 BE TSTDA YES...GO TEST FOR D.A. DEV. 47947 00115600 BAL RJ,BKSPONE DO ONE PHYSICAL BACKSPACE 47947 00115700 TSTDA EQU * 47947 00115800 TM DCBDEVT,X'20' IS THIS A DIRECT ACCESS DATA SET A37386 00115900 BNO NOTDA NO,BRANCH A37386 00116000 TM ABYTE,OUTPUT IS THIS INPUT DATA SET 1/4 57815 00116100 BZ NOTDA YES-ONLY ISSUE SVC 25 FOR O/P DADS 2/4 57815 00116200 TM CBYTE,DUMMY IS THIS DUMMY DATA SET 3/4 57815 00116300 BO NOTDA YES-DO NOT ISSUE SVC 25 FOR DUMMY DS 4/4 57815 00116400 LA 1,0(DCBR) PUT DCB ADDRS INTO REG 1 A37386 00116500 * SVC 25 TRACK BALANCE SVC A37386 00116600 SVC 25 A37386 00116700 NOTDA OI DCBOFLGS,DCBOFLWR FORCE BSAM TO WRITE EOF A37386 00116800 BAL RI,TCLOSE 00116900 SETCL NI CBYTE,CLSET 00117000 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00117100 BAL RI,OFFFRPL(0,CSECT2R) GET RID OF YOUR BUFFERS 00117200 B FIORET 00117300 SPACE 3 00117400 ***** 00117500 TCLOSE EQU * 00117600 BAL RJ,FINBLOCK PUT OUT LAST BLOCK ** 00117700 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00117800 BAL RJ,DOCHECK CHECK PREV I/O 4595 00117900 NOP 0 4595 00118000 TCLS1 EQU * 00118100 * CLOSE ((DCBR),LEAVE),TYPE=T,MF=(E,CLOSLIST) GNR 00118200 CLOSE ((DCBR),LEAVE),TYPE=T,MF=(E,CLOSLIST) GNR 00118300 BR RI 00118400 EJECT 00118500 ***** 00118600 * 00118700 * THE FOLLOWING LINES, MARKED AS FIX FOR 56182 HAVE 00118800 * BEEN REMOVED, AND THIS FIX (61504) REPLACES THAT ERRONEOUS 00118900 * FIX. 722470 THRU 722890. 00119000 * THE LAST 3 INSTUCTIONS ARE IDENTICAL WITH THE ONES 00119100 * REMOVED, BUT HAVE BEEN FLAGGED FOR ''61504''. 00119200 * 00119300 FCLOS SR RX,RX GNR 00119400 IC RX,ERRMSG GET NO OF ERR MSG UNIT GNR 00119500 BCTR RX,0 REDUCE BY ONE 61504 00119600 SLL RX,4 MULTIPLY BY 16 61504 00119700 LA RX,UTENTRY(RX) GET ADDR OF OBJ ERR UNIT 61504 00119800 ST RX,OBJADDR STORE ADDRESS 61504 00119900 LA GRX,UTENTRY 00120000 LA RX,16 SET INCREMENT FOR BXLE 00120100 LH RD,ENDT 00120200 LA RD,UTENTRY-8(RD) 00120300 TESTOPEN TM 3(GRX),X'01' WAS DSRN EVER USED ** 00120400 BO NEXTCL BR IF NEVER USED ** 00120500 TM 15(GRX),X'01' IS THIS A DASD DSRN ** 00120600 BC 8,NEXTCL BR IF IT IS A DASD DSRN ** 00120700 C GRX,OBJADDR IS THIS OBJ ERR UNIT? 61504 00120800 BE NEXTCL DO NOT CLOSE AT THIS TIME GNR 00120900 SETBASE L UTR,0(GRX) SET DSECT ADDRESS REGISTER 8/13 56182 00121000 ST RD,TEMP SAVE CONTENTS OF REG II210 00121100 L DECBR,DECBPTR II210 00121200 L DCBR,DCBOFFS 00121300 TM DCBOFLGS,DCBOFOPN IS DATA SET OPEN 4595 00121400 BZ FREEJFCB BRANCH IF CLOSED 00121500 BAL RJ,FINBLOCK 00121600 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00121700 BAL RJ,CKCOM CHECK PREVIOUS I/O 00121800 NOP 0 00121900 * CLOSE ((DCBR),DISP),MF=(E,CLOSLIST) GNR 00122000 CLOSE ((DCBR),DISP),MF=(E,CLOSLIST) GNR 00122100 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 4595 00122200 BAL RI,OFFFRPL(0,CSECT2R) GET RID OF YOUR BUFFERS 4595 00122300 * 00122400 * FREE STORAGE ALLOCATED TO JFCB AND UB 00122500 * 00122600 FREEJFCB TM JFCBPTR,JFCBFLG IS JFCB THERE? GNR 00122700 BNO FREEUBLK NO GNR 00122800 L 1,JFCBPTR GNR 00122900 * FREEMAIN R,LV=JFCBLGTH,A=(1) GNR 00123000 FREEMAIN R,LV=JFCBLGTH,A=(1) GNR 00123100 FREEUBLK LR 1,UTR LOAD UNIT BLOCK ADDRESS FOR 4595 00123200 * FREEING STORAGE ** 00123300 * FREEMAIN R,LV=LENUB,A=(1) FREE UB STORAGE GNR 00123400 FREEMAIN R,LV=LENUB,A=(1) FREE UB STORAGE GNR 00123500 OI 3(GRX),1 RESET UNIT BLOCK PTR 4595 00123600 L RD,TEMP RELOAD REG MODIFIED IN GETABUF II210 00123700 LA RX,16 RESET INCR REG MODIFIED IN INVERT II210 00123800 C GRX,OBJADDR IS THIS OBJ ERR UNIT? GNR 00123900 BE FIORET YES, EXIT GNR 00124000 * NO-CONTINUE LOOP PROCESSING 00124100 NEXTCL BXLE GRX,RX,TESTOPEN 00124200 L GRX,OBJADDR SET LOOP INDEX FOR OBJ ERR UNIT 61504 00124300 B SETBASE CLOSE IT NOW 56182 00124400 SPACE 2 00124500 *CLOSLIST CLOSE (,),MF=L GNR 00124600 CLOSLIST CLOSE (,),MF=L GNR 00124700 SPACE 3 00124800 ***** 00124900 * FSPEC - SPECIAL ENTRY TO SET UP FOR SETFIL 00125000 * 00125100 FSPEC BAL RJ,UTINIT GET UB BLOCK 00125200 B *+8 SEQUENTIAL RETURN 00125300 B ERR231 DASD RETURN - GENERATE IHC231I 00125400 TM DCBOFLGS,DCBOFOPN IS DCB OPEN? 00125500 BZ FIORET NO - RETURN TO SETFIL 00125600 NI DBYTE,FF-PBSP-LBSP-EOFBSP DO OP AT SETOFF 00125700 B RWND YES - COMPLETE AS FOR REWIND 00125800 EJECT 00125900 ***** 00126000 FINBLOCK STM GRX,RJ,MSAVEA ONLY OUTPUT 00126100 TM ABYTE,OUTPUT OUTPUT? 00126200 BCR ZERO,RJ NO 00126300 TM BBYTE,BLSW BLK'G ? 00126400 BCR ZERO,RJ NO 00126500 TM BBYTE,EOBSW END OF BUF ? 00126600 BCR ONES,RJ YES 00126700 OI BBYTE,EOBSW SET BUF FINISHED 00126800 SR GRY,GRY 00126900 TM DCBRECFM,VFORM VAR ? 00127000 BZ FBFIX NO 00127100 SH GRY,CON4 YES 00127200 FBFIX A GRY,RECPTR 00127300 BC NOTPLUS,FBRETURN ANY REC USED? BR IF NO 00127400 * 00127500 LH RI,DCBBLKSI SAVE DCB INFORMATION II210 00127600 TM DCBRECFM,VFORM VAR ? 00127700 BO FBENDVAR YES 00127800 * NO 00127900 STH GRY,DCBBLKSI 00128000 B FBIO BRANCH TO WRITE LAST RECORD II210 00128100 FBENDVAR LM RX,RD,BLKPTR 00128200 SLL RD,16 INSURE LAST 2 BYTES OF BDW WILL BE 0 II210 00128300 ST RD,0(RX) STORE BIG LL II210 00128400 FBIO BAL RJ,DOWRITE WRITE LAST RECORD II210 00128500 STH RI,DCBBLKSI RESTORE DCB INFORMATION II210 00128600 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00128700 BAL RJ,DOCHECK II210 00128800 NOP 0 II210 00128900 * 00129000 FBRETURN LM GRX,RJ,MSAVEA 00129100 BR RJ 00129200 EJECT 00129300 ***** 00129400 SETSYN EQU * 00129500 AIF (&ERR EQ 1).FI18 00129600 LA 1,218 25557 00129700 CLC BYTES(2),ERRMSG 25557 00129800 * IS CURRENT UNIT THE OBJECT ERROR UNIT? 25557 00129900 BNE COMERRHN GNR 00130000 L 1,ADERRNO GET ADDR OF MESSAGE 25557 00130100 MVC 0(4,1),MCSCODE1 MOVE LENGTH,MCSFLAGS 25557 00130200 MVC 108(4,1),MCSCODE2 MOVE DESCRIPTOR,ROUTING CODES 25557 00130300 * WTO MF=(E,(1)) ISSUE WTP 00130400 WTO MF=(E,(1)) ISSUE WTP 25557 00130500 B COMERRHN 25557 00130600 AGO .FI19 00130700 .FI18 ANOP 00130800 CLC BYTES+1(1),ERRMSG IS CURRENT DSRN THE OBJERR UNIT 00130900 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 25557 00131000 BE OFFNOBJ(0,CSECT2R) YES,SET NO SUMMARY SWITCH 25557 00131100 * AND TERMINATE 25557 00131200 LA 1,PRMS218 GET ADDRESS OF PARAMETER LIST 25557 00131300 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 25557 00131400 BAL RJ,OFFPSCMT(0,CSECT2R) GIVE MESSAGE 218 25557 00131500 B ERRRET ON RETURN IGNORE I/O REQUEST 25557 00131600 .FI19 ANOP 00131700 SETEOD EQU * 00131800 L GRY,IBCOMCON 19727 00131900 CLI X'7C'(GRY),X'FF' CALLED FROM IBCOM? GNR 00132000 BNE SETEOD1 YES, PROCEED NORMALLY GNR 00132100 L 13,4(0,13) NO, MAKE SPECIAL ROCKS EXIT GNR 00132200 LM 14,12,12(13) RESTORE USER REGISTERS GNR 00132300 L 13,4(0,13) RESTORE USER R13 GNR 00132400 LR L,R GNR 00132500 B 2(0,L) SPECIAL RETURN GNR 00132600 SETEOD1 EQU * 00132700 L GRX,ENDFILE(0,GRY) 19727 00132800 LA GRX,0(0,GRX) IS THERE AN 19727 00132900 LTR GRX,GRX END= PARAMETER ? 19727 00133000 BZ NOEND NO - WRITE MSG AND TRACEBACK 19727 00133100 MVI X'7C'(GRY),X'FF' 19727 00133200 LR 14,GRX YES - DON'T WRITE MSG OR 19727 00133300 LM 0,13,132(GRY) TRACEBACK 19727 00133400 L 14,0(0,14) BRANCH TO 19727 00133500 BR 14 ADDRESS SPECIFIED 19727 00133600 NOEND EQU * 19727 00133700 AIF (&ERR EQ 1).FI20 00133800 LA 1,217 GIVE MESSAGE 217 00133900 B COMERRHN 00134000 AGO .FI21 00134100 .FI20 ANOP 00134200 MVC PARAMS(1),ABYTE SAVE ABYTE 00134300 LA 1,PRMS217 GIVE MESSAGE 217 00134400 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00134500 BAL RJ,OFFCMINT(0,CSECT2R) GIVE MESSAGE 217 00134600 L 14,RETCD TEST RETURN CODE FIELD 00134700 LTR 14,14 IF =0 UPDATE FORTRAN SEQUENCE 00134800 BNZ ERRRET NUMBER ON DD CARD 00134900 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00135000 BAL RI,OFFFRPL(0,CSECT2R) IF =1 IGNORE REST OF I/O REQUEST 00135100 B EOFSOP 00135200 .FI21 ANOP 00135300 SPACE 3 00135400 * 00135500 * ALL NORMAL RETURNS COME THROUGH HERE 00135600 * 00135700 FIORET EQU * 00135800 AIF (&ERR EQ 0).FI200 00135900 L 15,IBCOMCON SAVE BUFFER ADDRESS AND 00136000 LA GRX,0(0,GRX) ITS LENGTH 00136100 CLI SW1,1 IF FOR OBJ. ERR. UNIT BRANCH 00136200 BE SPEC 00136300 STM GRX,GRY,BUFPTRS(15) ELSE SAVE THEM 00136400 .FI200 ANOP 00136500 NORMAL EQU * 00136600 L 13,4(0,13) RESTORE SAVE ADDRESS WHERE REGS 00136700 LM 14,1,12(13) WERE SAVED AND RESTORE REGS 00136800 LM 4,12,36(13) 00136900 AIF (&ERR EQ 0).FI212 GNR 00137000 DROP BASE 00137100 USING FIOCSA,L 00137200 CLI SW1,1 IF OBJ. ERR. UNIT BRANCH 00137300 BE *+8 00137400 .FI212 ANOP 00137500 L 13,4(0,13) ELSE RESTORE REG. 13 ALSO 00137600 AIF (&ERR EQ 0).FI213 00137700 MVI SW1,0 RESET SPECIAL ENTRY SWITCH 00137800 DROP L 00137900 USING FIOCSA,BASE 00138000 .FI213 ANOP GNR 00138100 LR 1,0 00138200 B 6(0,L) NORMAL RETURN 00138300 AIF (&ERR EQ 0).FI300 00138400 SPEC C GRX,BUFPTRS(0,15) IF BUFFER ADDRESS IS SAME AS CUR 00138500 BNE NORMAL RENT ONE THEN ZERO OUT BUFFER 00138600 MVI BUFPTRS(15),X'00' ADDRESS, SINCE BUFFER CONTENTS 00138700 MVC BUFPTRS+1(7,15),BUFPTRS(15) ARE DESTROYED. ELSE RETURN 00138800 B NORMAL WITHOUT CHANGING ADDRESS 00138900 .FI300 ANOP 00139000 EJECT 00139100 *DCBBL DCB DSORG=PS,MACRF=(R,W),DDNAME=FTXXF001, 00139200 * SYNAD=SYNAD,EODAD=EODAD,EXLST=EXLST 00139300 DCBBL DCB DSORG=PS,MACRF=(R,W),DDNAME=FTXXF001, X00139400 SYNAD=SYNAD,EODAD=EODAD,EXLST=EXLIST 00139500 EJECT 00139600 ***** 00139700 * 00139800 HERE EQU * 00139900 ORG DCBBL 00140000 UATCON DC V(IHCUATBL) 00140100 * ADDRESS CONSTANTS 00140200 * USING FIRST PART OF DCB(ABOVE) 00140300 FIOSHCON DC A(FIOCSA) 00140400 SAVECON DC A(LSAVEA) 00140500 IBCOMCON DC V(IBCOM#) 00140600 ORG DCBBL+40 00140700 DDMSK EQU * 00140800 ORG HERE 00140900 DDNM000 DC C'0000' GNR 00141000 SPACE 3 00141100 AIF (&ERR EQ 0).FI13 00141200 * MESSAGES 00141300 MSG214 DC F'83' 25557 00141400 DC C'IHC214I FIOCS - UNFORMATTED I/O, RECORD FORMAT SPECIFIX00141500 ED AS F, U OR V ON UNIT ' 25557 00141600 DC XL4'40404040' 25557 00141700 MSG217 DC F'44' 25557 00141800 DC C'IHC217I FIOCS - END OF DATA SET ON UNIT ' 25557 00141900 DC XL4'40404040' 25557 00142000 MSG219 DC F'44' 25557 00142100 DC C'IHC219I FIOCS - MISSING DD CARD FOR ' 25557 00142200 DSNUM DC XL8'4040404040404040' 25557 00142300 CODES DC X'0200' DESCRIPTOR CODE 25557 00142400 DC X'0020' ROUTING CODE 25557 00142500 WTPCODE DC AL2(48) MESSAGE LENGTH 25557 00142600 DC X'8000' MCSFLAGS FIELD 25557 00142700 MSG220 DC F'53' 25557 00142800 DC C'IHC220I FIOCS - UNIT NUMBER OUT OF RANGE. UNIT = ' 00142900 DC XL4'40404040' 25557 00143000 MSG231 DC F'80' 25557 00143100 DC C'IHC231I FIOCS - SEQUENTIAL I/O STATEMENTS USED FOR DIRX00143200 ECT ACCESS DATA SET ' 25557 00143300 DC XL4'40404040' 25557 00143400 .FI13 ANOP 25557 00143500 ***** 00143600 * EXIT LIST FOR OPEN 00143700 DS 0F 00143800 EXLIST DC X'85' '05' IS DCB EXIT INDICATION 00143900 DC AL3(IHCDCBXE) 00144000 EXJFCB DC X'87' '07' IS JFCB ADDR INDICATION GNR 00144100 DC AL3(0) GNR 00144200 SPACE 3 00144300 ***** 00144400 FIOCS2 EQU * 00144500 USING *,CSECT2R 00144600 USING FIOCSA,BASE 00144700 USING IHCUAT,BASE2 00144800 USING UB,UTR 00144900 USING IHADCB,DCBR 00145000 USING DECB,DECBR 00145100 EJECT 00145200 ***** 00145300 OPEN EQU * 7897 00145400 MVI SAVEOPT,X'00' ZERO OUT FIELD 00145500 LA 1,OPENLIST 00145600 TM JFCBPTR,JFCBFLG GNR 00145700 BO STXXF000 GNR 00145800 TM OPTION1,FCNTL IS CURRENT OPERATION CONTROL? 00145900 BO STOUTIN YES, BR TO OPEN FOR OUTIN 00146000 TM PARAMS,OUTPUT IS THIS AN OUTPUT REQUEST 00146100 BO STOUTIN BR IF OUTPUT 00146200 * OPEN ((DCBR),INOUT),MF=(E,(1)) OPEN FOR INOUT GNR 00146300 OPEN ((DCBR),INOUT),MF=(E,(1)) OPEN FOR INOUT GNR 00146400 B CHKOPEN CHECK THE OPEN 00146500 STOUTIN EQU * 00146600 * OPEN ((DCBR),OUTIN),MF=(E,(1)) OPEN FOR OUTIN GNR 00146700 OPEN ((DCBR),OUTIN),MF=(E,(1)) OPEN FOR OUTIN GNR 00146800 B CHKOPEN 00146900 * GNR 00147000 * HERE TO HANDLE OPEN FOR SPECIFIED FILE GNR 00147100 * GNR 00147200 STXXF000 MVC DCBDDNAM+5(3),DDNM000 MAKE DDNAME FTXXF000 GNR 00147300 MVC EXJFCB+1(3),JFCBPTR+1 LOCN OF JFCB TO EXIT LIST GNR 00147400 NI EXLIST,FF-VL ACTIVATE JFCB EXIT GNR 00147500 CLI OPTION1,FCNTL CONTROL? GNR 00147600 BE SPOUTIN YES, GO OPEN OUTIN GNR 00147700 TM PARAMS,OUTPUT OUTPUT? GNR 00147800 BO SPOUTIN YES GNR 00147900 * OPEN ((DCBR),INOUT),MF=(E,(1)),TYPE=J GNR 00148000 OPEN ((DCBR),INOUT),MF=(E,(1)),TYPE=J GNR 00148100 B SPCHK GNR 00148200 SPOUTIN EQU * GNR 00148300 * OPEN ((DCBR),OUTIN),MF=(E,(1)),TYPE=J GNR 00148400 OPEN ((DCBR),OUTIN),MF=(E,(1)),TYPE=J GNR 00148500 SPCHK OI EXLIST,VL DEACTIVATE JFCB EXIT GNR 00148600 CHKOPEN EQU * 00148700 AIF (&ERR EQ 0).FI9325 00148800 LA RI,PRMS214+12 GET END OF LIST IND A42666 00148900 TM 0(RI),X'40' IS THIS SPECIAL 214 CASE A42666 00149000 BO SPEC214 YES, 214 IS TERMINAL ERROR A42666 00149100 .FI9325 CLI SAVEOPT,FF DID OPEN EXIT FIND ERROR A42666 00149200 AIF (&ERR EQ 0).FI9 00149300 BE ERRRET YES, BRANCH 00149400 AGO .FI10 00149500 .FI9 BNE TSTOPEN NO, BRANCH 00149600 LA 1,214 YES, GIVE MESSAGE 214 00149700 B COMERRHN ISSUE ERROR MESSAGE 00149800 .FI10 ANOP 00149900 TSTOPEN EQU * 00150000 TM DCBOFLGS,DCBOFOPN IS DATA SET OPEN 4595 00150100 BO SETUBYTE BR IF OPEN 4595 00150200 SPACE 3 00150300 AIF (&ERR EQ 1).FI206 25557 00150400 CHKNODD EQU * 25557 00150500 * 25557 00150600 * IF NO DD CARD FOR ERROR MSG UNIT 25557 00150700 * THEN GO TO JOB TERMINATION 25557 00150800 * 25557 00150900 CLC BYTES+1(1),ERRMSG IS THIS OBJ ERR UNIT? 25557 00151000 BNE NODD NO... 25557 00151100 * ABEND 001 YES, JUST GET OUT OF HERE GNR 00151200 ABEND 001 YES, JUST GET OUT OF HERE GNR 00151300 AGO .FI4 25557 00151400 .FI206 ANOP 25557 00151500 CHKNODD EQU * 25557 00151600 * 25557 00151700 * IF NO DD CARD FOR ERROR MSG UNIT 25557 00151800 * THEN GO TO JOB TERMINATION 25557 00151900 * 25557 00152000 CLC BYTES+1(1),ERRMSG IS THIS THE OBJ ERROR UNIT? 25556 00152100 BNE NODD NO, BRANCH 25557 00152200 MVI WTPSW,X'FF' INDICATE 219 ERROR 25557 00152300 NOOBJERR MVI SW1,0 TURN OFF OBJERR ENTRY SWITCH 25557 00152400 L 1,VIHCERRM GET ADDR IF ERROR MONITOR 25557 00152500 MVI 19(1),X'FF' SET NOP AT IHCERRM ENTRY+16 TO 25557 00152600 * INDICATE NO ERROR SUMMARY. THIS IS 25557 00152700 * DONE WHEN I/O ERROR OR NO DD ERROR 25557 00152800 * OCCURRED ON THE OBJECT ERROR UNIT 25557 00152900 * TERMINATE JOB 25557 00153000 CLI WTPSW,X'00' DID ERROR 218 OCCUR? 25557 00153100 BE ERR218 BRANCH IF YES 25557 00153200 MVC DSNUM(8),DCBDDNAM 25557 00153300 MVC MSG219(4),WTPCODE 25557 00153400 * WTO MF=(E,MSG219) 25557 00153500 WTO MF=(E,MSG219) 25557 00153600 B TERM 25557 00153700 ERR218 L 1,PRMS218 GET ADDR OF GETMAINED AREA 25557 00153800 MVC 0(4,1),WTP218 MOVE LENGTH,MCSFLAGS 25557 00153900 MVC 108(4,1),CODES MOVE DESC, ROUTE CODES 25557 00154000 * WTO MF=(E,(1)) ISSUE WTP 25557 00154100 WTO MF=(E,(1)) ISSUE WTP 25557 00154200 TERM EQU * 25557 00154300 L 15,IBCOMCON GET ADDR OF IBCOM 25557 00154400 BAL 14,68(0,15) GO TERMINATE JOB 25557 00154500 DC AL2(16) 25557 00154600 NODD LA 1,PRMS219 GIVE ERROR MESSAGE 219 00154700 L RJ,0(0,1) 00154800 MVC 40(8,RJ),DCBDDNAM MOVE DD NAME TO MESSAGE 00154900 LA RJ,ERRRET SET RETURN POINT 00155000 B PSCMNTFC PUT OUT MESSAGE 00155100 SPEC214 EQU * A42666 00155200 NI 12(RI),X'80' RESET END OF LIST IND A42666 00155300 L 15,IBCOMCON GET ADDR OF IBCOM A42666 00155400 BAL 14,68(0,15) GO TO TERMINATE JOB A42666 00155500 DC AL2(16) RETCODE A42666 00155600 AGO .FI12 00155700 .FI4 ANOP 00155800 NODD LA 1,219 GIVE MESSAGE 219 00155900 B COMERRHN PUT OUT MESSAGE 00156000 .FI12 ANOP 00156100 SPACE 2 00156200 *OPENLIST OPEN (,),MF=L GENERATE LIST FOR OPEN GNR 00156300 OPENLIST OPEN (,),MF=L GENERATE LIST FOR OPEN GNR 00156400 EJECT 00156500 AIF (&ERR EQ 0).FI14 00156600 COMINTFC EQU * 00156700 LR 14,1 GET PARAM. LIST ADDRESS 00156800 L 3,0(0,1) GET ADDRESS OF MESSAGE 00156900 L 15,0(0,3) GET LENGTH OF MESSAGE 00157000 LA 3,0(15,3) SET TO CONVERT DSRN INTO 00157100 L 15,IBCOMCON MESSAGE VIA THE CONVERSION RT 00157200 LA 2,DSRNPTR 00157300 CLI SW1,1 IF ENTRY FOR OBJ. ERR.UNIT GET 00157400 BNE *+8 DSRN FROM DIFFERENT AREA 00157500 LA 2,OBJPTR 00157600 EX 0,82(0,15) 00157700 BALR 0,1 00157800 DC XL2'0404' 00157900 LR 1,14 RESET PARAMETER LIST ADDRESS 00158000 PSCMNTFC EQU * 00158100 L 15,IBCOMCON GET ADDRESS OF IBCOM 00158200 * 00158300 * THIS CODE DOES NOT SET UP THE HIGH (I.E. NEXT) SAVE AREA 00158400 * POINTER IN THE USER'S SAVE AREA BECAUSE THIS IS NOT NECESSARY 00158500 * CURRENTLY IN TRACEBACK 00158600 * 00158700 L 13,THRTNUSR(0,15) GET USER'S REG 13 00158800 MVC 12(16,13),FRTNUSR(15) MOVE REGS 14-1 TO HIS AREA 00158900 ST 13,IBCSV+4(0,15) LINK SAVE AREAS 00159000 LA 13,IBCSV(0,15) GET IBCOMS SAVE AREA 00159100 L 3,LSAVEA+4 SAVE CONTENTS OF LSAVEA+4 AND OF 00159200 IC 0,PARAMS PARAMS SINCE ERROR MONITOR WILL 00159300 * USE FIOCS DURING ITS OPERATION 00159400 * 00159500 * THIS ROUTINE DOES NOT ZERO THE RETURN CODE BECAUSE THE ERROR 00159600 * WILL DO SO BEFORE GOING TO THE USER'S EXIT 00159700 * 00159800 L 15,VIHCERRM GET ADDR OF ERROR MONITOR 00159900 BALR 14,15 GO TO ERROR MONITOR 00160000 STC 0,PARAMS RESTORE PARAMS 00160100 LA 13,LSAVEA RESTORE REG. 13 00160200 ST 3,LSAVEA+4 RESTORE LSAVEA+4 00160300 BR RJ RETURN 00160400 EJECT 00160500 .FI14 ANOP 00160600 * 00160700 FREEPOOL TM CBYTE,POOLSW 00160800 BCR ZERO,RI RETURN TO CALLER 00160900 * FREEPOOL (DCBR) 00161000 FREEPOOL (DCBR) 00161100 NI CBYTE,POOLOFF 00161200 BR RI RETURN TO CALLER 00161300 * 00161400 * COME HERE FROM *FINIT* 00161500 * OR *PRBKSP* 00161600 GETAPOOL EQU * 00161700 SR 0,0 00161800 IC 0,DCBBUFNO 00161900 SLL 0,16 00162000 AH 0,DCBBLKSI REG0.. BUFNO,LGTH (2 BYTES EACH) 00162100 * GETPOOL (DCBR),(0) 00162200 GETPOOL (DCBR),(0) 00162300 BAL RX,GETBUFFS SET ADDR OF BUFS IN UB 00162400 OI CBYTE,POOLSW INDICATE POOL ATTACHED 00162500 BR RJ RETURN TO CALLER 00162600 EJECT 00162700 ***** 00162800 PRBKSP EQU * II210 00162900 CLI OPTION1,FCNTL CURRENT OP CTRL? II210 00163000 BNE NOBK NO - BRANCH II210 00163100 CLI PARAMS,X'00' CURRENT OP BKSP? II210 00163200 BNE NOBK NO - BRANCH 00163300 TM BBYTE,BLSW BLOCKED RECORDS? II210 00163400 BCR 1,RJ YES - RETURN II210 00163500 B POOLTST BR TO TEST FOR BUFFERS II210 00163600 NOBK NI DBYTE,FF-LBSP SET OFF LOG BKSP SW II210 00163700 TM BBYTE,BLSW ARE RECORDS BLOCKED? II210 00163800 BZ CTLTEST NO - BRANCH II210 00163900 CLI OPTION1,X'00' CURRENT OPERATION OUTPUT? II210 00164000 BNE CTLTEST NO - BR TO SET PHY BKSP SW OFF II210 00164100 TM PARAMS,OUTPUT IF OUTPUT DATA SET, BRANCH II210 00164200 BO RBW2 TO TEST FOR NO. OF BKSP'S II210 00164300 TM DBYTE,PBSP HAS A PHYSICAL BKSP OCCURRED ? II210 00164400 BO SETBBYTE YES - BRANCH II210 00164500 NI BBYTE,EOBSWOFF SET OFF EOB SW II210 00164600 B DEBLOCK AND GO GET NEXT RECORD II210 00164700 RBW2 TM DBYTE,EOFBSP ENDFILE - BKSP - WRITE 27374 00164800 BZ RBW3 NO - BR TO CLEAR REST OF BUFF 24797 00164900 NI DBYTE,X'7D' SET SWS OFF 24797 00165000 B POOLTST GO TEST FOR BUFFS 24797 00165100 RBW3 BAL RX,BLANK * BLANK REST OF BUFFER 27374 00165200 TM DBYTE,PBSP HAS PHY BKSP OCCURRED 24797 00165300 BO BK1 YES - BRANCH II210 00165400 CLI DCBBUFNO,1 SINGLE BUFFERED ? II210 00165500 BE BK1 YES - BRANCH II210 00165600 OI DBYTE,RETBUF INDICATE NOT TO FREE BUFFS II210 00165700 BAL RJ,INVERT INVERT BUFFS II210 00165800 BAL RJ,DOCHECK CHECK PREVIOUS READ II210 00165900 B INV2 EODAD RETURN II210 00166000 NI DBYTE,X'EF' SET SW OFF II210 00166100 BAL RJ,BKSPONE GO BACKSPACE II210 00166200 INV2 BAL RJ,INVERT INVERT BUFFERS II210 00166300 BK1 BAL RJ,BKSPONE BACKSPACE ONE BLOCK II210 00166400 EJECT II210 00166500 SETBBYTE EQU * II210 00166600 NI DBYTE,FF-PBSP SET PHYS BKSP SW OFF II210 00166700 NI BBYTE,BSW INITIALIZE BBYTE II210 00166800 TM OPTION1,FCNTL IS CURRENT OP CNTL? 26130 00166900 BCR ON,RJ RETURN IF YES 26130 00167000 B SETA BR TO INITIALIZE UB II210 00167100 CTLTEST NI DBYTE,FF-PBSP SET OFF PHY BK SW II210 00167200 TM BBYTE,BLSW ARE RECORDS BLOCKED? II210 00167300 BO SETBBYTE YES - BRANCH II210 00167400 POOLTST TM CBYTE,POOLSW ARE BUFFS ATTACHED? II210 00167500 BZ STOR NO - BRANCH II210 00167600 TM OPTION1,FCNTL CONTROL OP? II210 00167700 BCR ON,RJ YES - RETURN II210 00167800 B SETABYTE BRANCH TO INITIALIZE UB II210 00167900 STOR EQU * II210 00168000 ST RJ,TEMP SAVE REG 10 II210 00168100 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT II210 00168200 BAL RJ,OFFGTPL(0,CSECT2R) GO GET BUFFER POOL II210 00168300 L RJ,TEMP RESTORE REG 10 II210 00168400 TM OPTION1,FCNTL CURRENT OP CONTROL? II210 00168500 BCR ON,RJ YES - RETURN II210 00168600 B SETUBYTE BRANCH TO INITIALIZE UB II210 00168700 SPACE 3 II210 00168800 EJECT 00168900 SETBYTE EQU * 00169000 L L,DCBDEBAD GET ADDR OF DEB 60622 00169100 L L,32(L) OFFSET INTO DEB FOR UCB ADDR 60622 00169200 C L,ZEROS IF NO UCB EXISTS, IS DUMMY D.S. 60622 00169300 BNE *+12 NOT DUMMY D.S. - CONTINUE 60622 00169400 OI CBYTE,DUMMY INDICATE DUMMY FILE GNR 00169500 MVI DCBBUFNO,1 FORCE SINGLE BUFFER 60622 00169600 TM DCBRECFM,DCBRECU U FORMAT? 4595 00169700 BO OPENRW YES 4595 00169800 TM DCBRECFM,VFORM V FORMAT? 00169900 BZ *+8 NO 00170000 OI BBYTE,VSWITCH YES II210 00170100 TM DCBRECFM,DCBRECBR IS D.S. BLOCKED? 00170200 BZ OPENRW NO 00170300 OI BBYTE,BLSW YES 00170400 TM BBYTE,EOBSW AT END OF BUFFER? II210 00170500 BO OPENRW YES - BRANCH II210 00170600 TM ABYTE,OUTPUT OUTPUT DATA SET? II210 00170700 BO BLOCINIT YES - INITIALIZE BLOCKING II210 00170800 B INV1 BRANCH TO CHECK BUFNO II210 00170900 * 00171000 OPENRW TM OPTION1,FCNTL CONTROL OPERATION?. 00171100 BO CTLRTN IF YES, DO NOTHING 00171200 OPBK EQU * ENTRY FOR BACKSPACE II210 00171300 LA DECBR,RWOFS ADDRESS OF DECB1 II210 00171400 ST DECBR,DECBPTR II210 00171500 AIF (&ERR EQ 1).FI757 00171600 ST DECBR,DECBPT 00171700 AGO .FI747 00171800 .FI757 ANOP 00171900 CLI SW1,1 23848 00172000 BE STR1 23848 00172100 ST DECBR,DECBPT 00172200 STR1 EQU * 23848 00172300 .FI747 ANOP 00172400 MVI LIVECT1,X'00' 26620 00172500 MVI LIVECT2,X'00' 26620 00172600 CLI DCBBUFNO,1 SINGLE BUFFERED? 00172700 BE *+8 YES, BRANCH 00172800 OI BBYTE,BSW 00172900 TM OPTION1,FCNTL CONTROL OPERATION? II210 00173000 BO SPEC1 YES - RETURN II210 00173100 TM PARAMS,OUTPUT IS IT OUTPUT? 00173200 BO TESTWVBL IF YES BR TO CLEAR BUFFERS GNR 00173300 BAL RJ,DOREAD READ RECORD II210 00173400 INV1 CLI DCBBUFNO,1 IS DATA SET SINGLE BUFFERED II210 00173500 BE CR IF YES DO NOT INVERT AND READ AHEAD II210 00173600 BAL RJ,INVERT FLIP BUFFERS AND DECBS II210 00173700 B CR2 BRANCH TO READ AHEAD II210 00173800 EJECT 00173900 DS 0H II232 00174000 SYNAD EQU * II232 00174100 BALR RD,0 FREE SYNAD FROM FIOCS BASE II232 00174200 USING *,RD II232 00174300 OI BBYTE,EYES+ERR INDICATE ERROR OCCURRED II232 00174400 TM BBYTE,ETEST IF ERROR TEST BIT IS OFF, 4659 00174500 BCR 14,14 THEN RETURN 00174600 LR RX,14 SAVE RETURN REG. SINCE SVC TO BE 00174700 AIF (&ERR EQ 0).FI15 ISSUED 00174800 ST 0,PRMS218+16 PUT DECB ADDRESS IN PARAMETER 00174900 MVI PRMS218+16,X'80' LIST AND RESET LAST PARM. IND. 00175000 .FI15 ANOP 00175100 * SYNADAF ACSMETH=BSAM 00175200 SYNADAF ACSMETH=BSAM 4659 00175300 LR RJ,1 SAVE ADDR OF SYNADAF MSAGE 4659 00175400 * GETMAIN R,LV=112 00175500 GETMAIN R,LV=112 00175600 AIF (&ERR EQ 0).FI31 00175700 ST 1,PRMS218 SAVE ADDRESS OF MESSAGE IN PRM. 00175800 AGO .FI30 LIST. 00175900 .FI31 ST 1,ADERRNO SAVE MESSAGE ADDRESS 00176000 .FI30 ANOP 00176100 MVC 4(27,1),MSG218 MOVE HEADING PART OF MESSAGE 00176200 MVC 31(77,1),50(RJ) MOVE SYNADAF TEXT 00176300 LA RJ,104 SET LENGTH OF MESSAGE 00176400 ST RJ,0(0,1) 00176500 * SYNADRLS 00176600 SYNADRLS 4659 00176700 BR RX RETURN 00176800 MSG218 DC C'IHC218I FIOCS - I/O ERROR ' II232 00176900 DROP RD II232 00177000 EJECT 00177100 DS 0H 00177200 EODAD EQU * 00177300 L CSECT2R,VFIOCS2 SET UP REG PROPERLY 00177400 USING FIOCS2,CSECT2R 00177500 ST RJ,SAVE SAVE PRIMARY LINK REGISTER ** 00177600 BAL RI,TCLS1 BRANCH TO TCLOSE DATA SET II210 00177700 MVI LIVECT1,X'00' 26620 00177800 MVI LIVECT2,X'00' 26620 00177900 TM DBYTE,RETBUF WANT TO FREE BUFS? II210 00178000 BNZ BKRET NO, SKIP IT GNR 00178100 NI CBYTE,CLSET RECORD THIS IN THOSE BITS 00178200 BAL RI,FREEPOOL FREE THE BUFFERS 00178300 BKRET NI DBYTE,FF-RETBUF SET BUF SW OFF GNR 00178400 L RJ,SAVE RESTORE RETURN REGISTER II210 00178500 BR RJ AND RETURN 00178600 DROP CSECT2R 00178700 EJECT 00178800 ***** 00178900 IHCDCBXE DS 0H II210 00179000 BALR 3,0 00179100 USING *,3 00179200 USING DEFAULTS,GRX 4595 00179300 LA RD,FMTST4 II232 00179400 FMTST2 TM PARAMS,FORMAT IS THIS A FORMATTED REQUEST? SIR1 00179500 BCR ON,RD YES, BRANCH. II232 00179600 TM OPTION1,FCNTL 11798 00179700 BCR ON,RD YES,BRANCH II232 00179800 CLI DCBRECFM,0 IS FIELD=0 II232 00179900 BNE TUMMY NO, BRANCH II232 00180000 OI DCBRECFM,VSBFORM RECFM=VSB IS THE DEFAULT GNR 00180100 BR RD BRANCH II232 00180200 TUMMY EQU * II232 00180300 TM DCBRECFM,DCBRECU RECFM=U? II232 00180400 AIF (&ERR EQ 0).FI23205 II232 00180500 BO BADRFM1 YES,BRANCH. II232 00180600 AGO .FI23206 II232 00180700 .FI23205 ANOP II232 00180800 BO ERRSET YES,BRANCH II232 00180900 .FI23206 ANOP II232 00181000 TM DCBRECFM,VFORM RECFM=V(SB)? GNR 00181100 BO FMTST5 YES,MAKE SPANNED GNR 00181200 AIF (&ERR EQ 0).FI11 II232 00181300 BADRFM1 EQU * II232 00181400 BAL RI,CALLM214 GIVE ERR MSG 214 II232 00181500 LTR 1,1 STANDARD RECFM FIXUP DESIRED? II232 00181600 BNZ ERRSET NO,BRANCH II232 00181700 TM DCBRECFM,DCBRECU RECFM=U? II232 00181800 BO MAKEVS YES,BRANCH. II232 00181900 TM DCBRECFM,VFORM RECFM=V? II232 00182000 BO FMTST5 YES, BRANCH II232 00182100 MAKEVS EQU * II232 00182200 MVI DCBRECFM,VSFORM DEFAULT VALUE FOR UNFORMATTED II232 00182300 BR RD II232 00182400 SPACE 3 II232 00182500 CALLM214 EQU * II232 00182600 LA 1,PRMS214 GIVE ERROR MESSAGE 214 00182700 LR RX,GRX SAVE REG. 00182800 ST 14,SAVE SAVE REG. 00182900 ST 3,VRETEMP SAVE REG 3 32775 00183000 ST RD,SAVE5 TEMP SAVE 63580 00183100 L CSECT2R,VFIOCS2 GET ADDR OF 2ND. CSECT 00183200 BAL RJ,OFFCMINT(0,CSECT2R) GO PUT OUT ERROR 00183300 L RD,SAVE5 63580 00183400 L 3,VRETEMP RESTORE REG 3 32775 00183500 L 14,SAVE RESTORE REG. 00183600 LR GRX,RX RESTORE REG. 00183700 L 1,RETCD YES TEST RETURN CODE FIELD 00183800 BR RI II232 00183900 SPACE 3 II232 00184000 .FI11 ANOP 00184100 ERRSET EQU * 00184200 MVI SAVEOPT,X'FF' INDICATE ERROR FOUND, SKIP I/O 00184300 BR RD II232 00184400 FMTST5 OI DCBRECFM,DCBRECSB INDICATE SPANNED II232 00184500 FMTST4 LA GRX,4(0,GRX) 4595 00184600 SR RI,RI 4595 00184700 CH RI,DCBBLKSI IS BLKSIZE = 0 4595 00184800 BNE TRECFM NO 4595 00184900 MVC DCBBLKSI,BLKSIZE YES,MOVE IN DEFAULT 4595 00185000 TRECFM CLI DCBRECFM,0 IS FIELD = 0 4595 00185100 BNE TBUFNO NO 4595 00185200 MVC DCBRECFM,RECFM YES,MOVE IN DEFAULT 4595 00185300 TBUFNO CLI DCBBUFNO,1 SINGLE BUFFERED? II210 00185400 BE TLRECL YES - BRANCH TO NEXT TEST II210 00185500 MVC DCBBUFNO,BUFNO SET DEFAULT BUFNO 00185600 MVC DCBNCP,BUFNO AND DEFAULT NO. OF CHAN PGMS 00185700 TLRECL CH RI,DCBLRECL IS FIELD = 0 4595 00185800 BNE DEFOUT NO 4595 00185900 MVC DCBLRECL,LRECL YES,MOVE IN DEFAULT 4595 00186000 DEFOUT LH RJ,DCBBLKSI LOAD BLOCK SIZE 9922 00186100 TM DCBRECFM,DCBRECF IS RECORD FORMAT F OR U? 9922 00186200 BO DEFOUT1A YES 9922 00186300 SH RJ,CON4 REDUCE MAXIMUM LRECL VALUE 9922 00186400 DEFOUT1A CH RI,DCBLRECL IS DCB LRECL ZERO? 9922 00186500 BE DEFOUT1B YES 9922 00186600 TM PARAMS,FORMAT FORMATTED READ/WRITE? II232 00186700 BZ DEFOUT2 NO, MUST BE VSB, ANY LRECL OK GNR 00186800 DEEF EQU * II232 00187100 CLC DCBLRECL,XLRECL IS DEFAULT LRECL=X? II232 00187200 BE DEFOUT1B YES, BRANCH. II232 00187300 TM DCBRECFM,DCBRECU U TYPE RECORDS? 23855 00187400 BO DEFOUT1B YES - BRANCH 23855 00187500 CH RJ,DCBLRECL IS DCB LRECL GT MAXIMUM? 9922 00187600 BL DEFOUT1B YES, GO ADJUST GNR 00187700 LR 1,RJ NO, NOW BE SURE BLKSIZE GNR 00187710 SR 0,0 IS A MULTIPLE OF LRECL GNR 00187720 LH RJ,DCBLRECL (FALLS THROUGH TO DEFOUT1B) GNR 00187730 DR 0,RJ GNR 00187740 MR 0,RJ GNR 00187750 STH 1,DCBBLKSI GNR 00187760 DEFOUT1B STH RJ,DCBLRECL ADJUST LRECL SIZE 9922 00187800 DEFOUT2 TM CBYTE,OPENSW IS DATA SET OPENED 4595 00187900 BCR ZERO,14 NO,BIT OFF 4595 00188000 OI CBYTE,CONCAT YES,MUST BE CONCATENATION 4595 00188100 BR 14 4595 00188200 DROP 3,GRX 00188300 DROP BASE,BASE2,UTR,DCBR,DECBR 00188400 EJECT 00188500 * 00188600 * SETFIL ROUTINE 00188700 * 00188800 * PROVIDES FORTRAN PROGRAM WITH CONTROL OVER 00188900 * FILE SEQ NUM AND DSNAME FOR MULTIFILE TAPE VOLUMES 00189000 * 00189100 * SETFIL IS TO BE DECLARED AN EXTERNAL INTEGER FUNCTION 00189200 * CALL BY: N=SETFIL(DSRN,NFILE,BLKSI,DSNAME, DSNLEN[) 00189300 * N VALUE RETURNED IS NEXT FILE TO BE USED 00189400 * DSRN FORTRAN UNIT NUMBER 00189500 * NFILE >0 SET NEXT FILE USED TO NFILE 00189600 * =0 USE CURRENT FILE (INITIALLY FROM DD) 00189700 * =-1 INCREMENT FILE BY 1 00189800 * <-1 NOP - DOES NOT AFFECT FILE SETTING 00189900 * BLKSI =0 DO NOT SET BLOCKSIZE 00190000 * >0 SET FILE BLOCKSIZE TO BLKSI 00190100 * DSNAME DATA SET NAME TO BE ASSIGNED TO FILE 00190200 * DSNLEN LENGTH OF DSNAME IN CHARS (<45) 00190300 * (DEFAULT 8, TOO LARGE ->44, <1 BLANKS DSN) 00190400 * 00190500 * WHEN SETFIL IS FIRST CALLED FOR A DSRN, ANY ACTIVE 00190600 * I/O ON THAT DSRN IS COMPLETED, THE FILE IS CLOSED, AND THEN 00190700 * THE DDNAME IS CHANGED TO FTXXF000 AND REMAINS SO UNTIL THE 00190800 * STEP TERMINATES. SETFIL MUST BE CALLED ONCE FOR EACH 00190900 * SUBSEQUENT FILE, OR ELSE THE SAME FILE WILL BE REPROCESSED. 00191000 * 00191100 * REVISED 1/17/78 GNR SO WILL NOT GEN DSN OR FILE SEQ 00191200 * FOR DUMMY FILES 00191300 * 00191400 * ERRORS: 1) IHC400I, NO FTXXF000 DD CARD 00191500 * 2) IHC401I, DSORG NOT PS OR DEVD NOT MAGTAPE 00191600 * 00191700 SETFIL CSECT 00191800 USING SETFIL,15 00191900 B *+14 00192000 DC XL1'6',CL9'SETFIL' DEFINE NAME FOR TRACE, STAY ALIGNED 00192100 STM 14,12,12(13) SAVE REGISTERS 00192200 LR 2,13 LINK SAVE AREAS 00192300 CNOP 0,4 00192400 BAL 13,SETSTRT 00192500 SETSAVE DS 18F SAVE AREA 00192600 SETSTRT ST 2,4(0,13) 00192700 ST 13,8(0,2) 00192800 USING SETSAVE,13 00192900 DROP 15 00193000 LR RP,1 SAVE PARMLIST 00193100 L RFSEQ,4(0,RP) 00193200 L RFSEQ,0(0,RFSEQ) GET FILE SEQUENCE NUMBER 00193300 C RFSEQ,MTWO CHECK FOR NOP EXIT 00193400 BNH SETFRTN 00193500 L GRX,0(0,RP) LOCATE UNIT 00193600 L L,VFIOCS# CALL FIOCS TO INITIALIZE 00193700 BALR R,L 00193800 DC AL1(5,1) SPECIAL CALL 00193900 NOP 0 IGNORE EOF RETURN 00194000 * 00194100 * ON RETURN FROM SPECIAL FIOCS CALL, WE ARE ASSURED THAT 00194200 * UB IS PRESENT AND FILE IS CLOSED. NOW GET JFCB. 00194300 * 00194400 L BASE,VFIOCS# 00194500 USING FIOCSA,BASE 00194600 L UTR,UTREGSV LOCATE UNIT BLOCK 00194700 USING UB,UTR 00194800 L DCBR,DCBOFFS MAKE DCB ADDRESSIBLE 00194900 USING IHADCB,DCBR 00195000 TM JFCBPTR,JFCBFLG JFCB LOADED? 00195100 BO THERENOW YES 00195200 L BASE2,UATCON GET UNIT FROM UAT 00195300 USING IHCUAT,BASE2 00195400 LH RD,BYTES 00195500 BAL RI,CVTB CONVERT TO ZONED FORMAT 00195600 MVC STFDDNAM+2(2),WORK2+6 00195700 MVC DCBDDNAM(8),STFDDNAM 00195800 * GETMAIN R,LV=JFCBLGTH ALLOCATE FOR JFCB 00195900 GETMAIN R,LV=JFCBLGTH 00196000 LR JFCBR,1 MAKE JFCB ADDRESSIBLE 00196100 USING JFCB,JFCBR 00196200 ST JFCBR,EXJFCB ACTIVATE DCB JFCB EXIT 00196300 MVI EXJFCB,VL+JFCBFLG 00196400 NI EXLIST,FF-VL 00196500 * RDJFCB ((DCBR)),MF=(E,CLOSLIST) FETCH JFCB FROM SYSTEM 00196600 RDJFCB ((DCBR)),MF=(E,CLOSLIST) 00196700 OI EXLIST,VL DEACTIVATE JFCB EXIT 00196800 LTR 15,15 TEST RETURN CODE 00196900 BNZ BADDD 00197000 OI JFCBMASK+4,X'80' REQUEST WRITING BACK 00197100 * THIS ADDS OVERHEAD, BUT GETS THE TRAILER RIGHT IF SL TAPE 00197200 * 00197300 * BE SURE WE HAVE A MAGTAPE DEVICE ONLY 00197400 * DEVTYPE DCBDDNAM,WORK2 00197500 DEVTYPE DCBDDNAM,WORK2 00197600 LTR 15,15 TEST RETURN CODE 00197700 BNZ BADDEVD 00197800 TM WORK2+2,X'7F' TAPE OR DUMMY? 00197900 BNZ BADDEVD 00198000 ST JFCBR,JFCBPTR OK, NOW PUT ADDRESS IN UB 00198100 MVI JFCBPTR,JFCBFLG 00198200 OC JFCBPTR(1),WORK2+2 SAVE DUMMY FLAG 00198300 DROP BASE2 00198400 * 00198500 * ENTER HERE IF JFCB ALREADY IN CORE 00198600 * 00198700 THERENOW L JFCBR,JFCBPTR 00198800 LTR RFSEQ,RFSEQ DECIDE ACTION 00198900 BP SETFLSQ 00199000 LH RFSEQ,JFCBFLSQ 00199100 BNZ SETINCR 00199200 LPR RFSEQ,RFSEQ ZERO, USE FROM DD 00199220 BNZ SETBLKSI BUT BE SURE IT'S GT 0 00199240 SETINCR AH RFSEQ,H1 NEG, INCR BY 1 00199300 SETFLSQ STH RFSEQ,JFCBFLSQ SAVE NEW FLSEQ 00199400 SETBLKSI L GRX,8(0,RP) LOCATE BLOCKSIZE PARAMETER 00199500 L GRX,0(0,GRX) 00199600 LTR GRX,GRX 00199700 BNP SETDSNAM 00199800 STH GRX,JFCBLKSI SET USER'S BLOCKSIZE IN JFCB 00199900 STH GRX,DCBBLKSI AND IN DCB 00200000 SETDSNAM TM JFCBPTR,X'80' DUMMY? 00200100 BZ SETDSN3 YES, OMIT DSN 00200200 MVI JFCBDSNM,C' ' BLANK OUT OLD DSNAME 00200300 MVC JFCBDSNM+1(43),JFCBDSNM 00200400 LA GRY,8 SET DEFAULT LENGTH 00200500 TM 12(RP),VL IS LENGTH GIVEN? 00200600 BNZ SETDSN2 00200700 L GRY,16(0,RP) YES, GET IT 00200800 L GRY,0(0,GRY) 00200900 CH GRY,H44 00201000 BNH SETDSN2 00201100 LH GRY,H44 00201200 SETDSN2 SH GRY,H1 ADJUST FOR EXECUTE 00201300 BM SETDSN3 00201400 L GRX,12(0,RP) FIND IT 00201500 EX GRY,DSNMVC MOVE IT 00201600 SETDSN3 EQU * 00201700 SETFRTN L 13,4(0,13) RESTORE USER'S REGISTERS 00201800 LM 14,15,12(13) 00201900 LR 0,RFSEQ 00202000 LM 1,12,24(13) 00202100 BR 14 00202200 * 00202300 * ERROR EXITS - PERFORM TRACEBACK AND EXIT 00202400 * 00202500 BADDD LA 1,400 00202600 LA 15,SETFMSG1 00202700 B SETFERRM 00202800 BADDEVD LA 1,401 00202900 LA 15,SETFMSG2 00203000 SETFERRM ST 1,ERRORNO 00203100 ST 15,ADERRNO 00203200 LA 1,ADERRNO 00203300 L 15,VIHCERRM 00203400 BR 15 00203500 DROP 13,BASE,UTR,DCBR 00203600 EJECT 00203700 * 00203800 * CONSTANTS AND STORAGE FOR SETFIL 00203900 * 00204000 MTWO DC F'-2' 00204100 H1 DC H'1' 00204200 H44 DC H'44' 00204300 VFIOCS# DC A(FIOCS#) 00204400 SETFMSG1 DC A(L'MSG1TXT+8) 00204500 MSG1TXT DC C' SETFIL - BAD DD FOR ' 00204600 STFDDNAM DC C'FTXXF000' 00204700 SETFMSG2 DC A(L'MSG2TXT) 00204800 MSG2TXT DC C' SETFIL - DEVICE NOT TAPE' 00204900 DSNMVC MVC JFCBDSNM(0),0(GRX) 00205000 * REGISTERS FOR SETFIL 00205100 RP EQU 8 PARAMETER LIST 00205200 JFCBR EQU 9 JFCB PTR 00205300 RFSEQ EQU 10 HOLDS FILE SEQ NO. 00205400 EJECT 00205500 **** 00205600 * EQUATES FOR BRANCHES INTO THE 2ND. CSECT 00205700 OFFGTPL EQU GETAPOOL-FIOCS2 00205800 OFFFRPL EQU FREEPOOL-FIOCS2 00205900 OFFOPEN EQU OPEN-FIOCS2 00206000 OFFSTBYT EQU SETBYTE-FIOCS2 00206100 OFFOPBK EQU OPBK-FIOCS2 00206200 OFFPRBKS EQU PRBKSP-FIOCS2 00206300 AIF (&ERR EQ 0).FIKKK 00206400 OFFNOBJ EQU NOOBJERR-FIOCS2 00206500 OFFCMINT EQU COMINTFC-FIOCS2 00206600 OFFPSCMT EQU PSCMNTFC-FIOCS2 00206700 .FIKKK ANOP 00206800 ***** 00206900 IHCUAT DSECT 00207000 BYTES DS H'0' 00207100 ENDT DS AL2(0) 00207200 ERRMSG DS X'00' 00207300 READ DS X'00' 00207400 PRINT DS X'00' 00207500 PUNCH DS X'00' 00207600 * 00207700 UTENTRY DS 4A GNR 00207800 DEFAULTS DSECT 4595 00207900 DEFBITS DS X'00' 4595 00208000 DS X'00' 4595 00208100 BLKSIZE DS XL2'00' 4595 00208200 RECFM DS X'00' 4595 00208300 BUFNO DS X'00' 4595 00208400 LRECL DS XL2'00' 4595 00208500 SPACE 3 00208600 ***** 00208700 UB DSECT 00208800 ABYTE DS X'00' 00208900 BBYTE DS X'00' 00209000 CBYTE DS X'00' 00209100 DBYTE DS X'00' II210 00209200 BUF1 DS F 00209300 BUF2 DS F 00209400 BLKPTR DS F 00209500 RECPTR DS F 00209600 * 00209700 DECBPTR DS F POINTER TO LAST USED DECB II210 00209800 BUFMASK DS F MASK FOR FLIPPING BUFS VIA EXC OR II210 00209900 RWOFS DS 0F BEGINNING OF DECB AREA II210 00210000 DECB1 DS 0F II210 00210100 DS 2F II210 00210200 DCBOFFS DS F DCB ADDRESS II210 00210300 AREA1 DS F ADDRESS OF BUFFER1 II210 00210400 DS F II210 00210500 WKBK1 DS XL3'00' WORK AREA FOR BACKSPACE ROUTINE II210 00210600 LIVECT1 DS X'00' SWITCH INDICATING IF DECB IS ACTIVE II210 00210700 DECB2 DS 0F II210 00210800 DS 3F II210 00210900 AREA2 DS F ADDRESS OF BUFFER2 II210 00211000 DS F II210 00211100 WKBK2 DS XL3'00' WORK AREA FOR BACKSPACE ROUTINE II210 00211200 LIVECT2 DS X'00' SWITCH INDICATING IF DECB IS ACTIVE II210 00211300 DOFFSET DS 22F DCB AREA 00211400 JFCBPTR DS A POINTER TO JFCB AREA 00211500 LENUB EQU *-UB LENGTH OF UB 00211600 EJECT 00211700 ***** 00211800 DCBD DSORG=BS,DEVD=(DA,TA) 00211900 EJECT 00212000 ***** 00212100 DECB DSECT 00212200 ECB DS F 00212300 DECBIO DS X'00' 00212400 IOTYPE DS X'00' 00212500 LN DS H 00212600 DCBAD DS F 00212700 AREA DS F 00212800 STATLOC DS F 00212900 DS XL3'00' II210 00213000 LIVECT DS X'00' II210 00213100 SPACE 3 00213200 ***** 00213300 JFCB DSECT DEFINE NEEDED FIELDS OF JFCB ONLY 00213400 JFCBDSNM DS CL44 DATA SET NAME 00213500 DS CL8 00213600 JFCBTSDM DS XL1 JOB MANAGEMENT INTERFACE 00213700 DS CL13 00213800 JFCBLTYP DS XL1 LABEL TYPE 00213900 DS XL1 00214000 JFCBFLSQ DS H FILE SEQUENCE NUMBER 00214100 DS H 00214200 JFCBMASK DS XL8 DATA MANAGEMENT MASK 00214300 DS XL18 00214400 JFCDSORG DS 2XL1 DATA SET ORGANIZATION 00214500 JFCRECFM DS XL1 RECORD FORMAT 00214600 JFCOPTCD DS XL1 OPTION CODES 00214700 JFCBLKSI DS H BLOCKSIZE 00214800 JFCLRECL DS H LOGICAL RECORD LENGTH 00214900 DS CL70 00215000 JFCBLGTH EQU *-JFCB LENGTH OF JFCB 00215100 MEND 00215200