TITLE ' TAPE UTILITY SUBROUTINES CALLABLE FROM FORTRAN' 00010000 * CALL RTAPE(K,BUF,N,&99,&999) READ TAPE 00020000 * K = 1 OR 2 (WHICH TAPE) 00030000 * BUF = INPUT ARRAY 00040000 * N = NUMBER OF BYTES READ R15 = 0 GOOD READ 00050000 * &99 = EOF LABEL R15 = 4 EOF READ 00060000 * &999 = ERR EXIT LABEL R15 = 8 ERR ON READ 00070000 * ---------------------------------------------------------- 00080000 * CALL WTAPE(K,BUF,N,&9999) WRITE TAPE 00090000 * K = 1 OR 2 (WHICH TAPE) 00100000 * BUF = OUTPUT ARRAY 00110000 * N = NUMBER OF BYTES TO WRITE R15 = 0 GOOD WRITE 00120000 * &9999 = ERR EXIT LABEL R15 = 4 ERR ON WRITE 00130000 * ---------------------------------------------------------- 00140000 * CALL OPENT(K,L) OPEN TAPE 00150000 * K = 1 OR 2 (WHICH TAPE) 00160000 * L = 1 FOR INPUT 00170000 * L = 2 FOR OUTPUT 00180000 * ---------------------------------------------------------- 00190000 * CALL CLOSET(K,L) CLOSE TAPE 00200000 * K = 1 OR 2 (WHICH TAPE) 00210000 * L = 1 FOR INPUT 00220000 * L = 2 FOR OUTPUT 00230000 * ---------------------------------------------------------- 00240000 * CALL RWTAPE(K) REWIND TAPE 00250000 * K = 1 OR 2 (WHICH TAPE) 00260000 * ---------------------------------------------------------- 00270000 * CALL SFILE(K) SKIP FILE 00280000 * K = 1 OR 2 (WHICH TAPE) 00290000 * ---------------------------------------------------------- 00300000 * CALL FSREC(K,N) FORWARD-SPACE RECORD 00310000 * K = 1 OR 2 (WHICH TAPE) 00320000 * N = NUMBER OF REC (INPUT) (MUST BE A VARIABLE) 00330000 * = NUMBER OF REC (OUTPUT) NOT PROCESSED 00340000 * BECAUSE OF EOF 00350000 * ---------------------------------------------------------- 00360000 * CALL BSREC(K,N) BACKWARD-SPACE RECORD 00370000 * K = 1 OR 2 (WHICH TAPE) 00380000 * N = NUMBER OF REC (INPUT) (MUST BE A VARIABLE) 00390000 * = NUMBER OF REC (OUTPUT) NOT PROCESSED 00400000 * BECAUSE OF EOF 00410000 * ---------------------------------------------------------- 00420000 * CALL FSFILE(K) FORWARD-SPACE FILE 00430000 * K = 1 OR 2 (WHICH TAPE) 00440000 * ---------------------------------------------------------- 00450000 * CALL BSFILE(K) BACKWARD-SPACE FILE 00460000 * K = 1 OR 2 (WHICH TAPE) 00470000 * ---------------------------------------------------------- 00480000 * CALL WTMARK(K) WRITE TAPE MARK 00490000 * K = 1 OR 2 (WHICH TAPE) 00500000 * ---------------------------------------------------------- 00510000 * 00520000 * 00530000 * IF K = 1 THEN THE SUBROUTINES DOES ITS PROCESSING FROM 00540000 * DDNAME = "SYSUT1" EX. 00550000 * 00560000 *//GO.SYSUT1 DD VOL=SER=SYSUT1,UNIT=TAPE,DISP=OLD,LABEL=(1,NL) 00570000 * 00580000 * IF K = 2 THEN THE SUBROUTINES DOES ITS PROCESSING FROM 00590000 * DDNAME = "SYSUT2" EX. 00600000 * 00610000 *//GO.SYSUT2 DD VOL=SER=SYSUT2,UNIT=TAPE,DISP=OLD,LABEL=(1,NL) 00620000 * ------------------------------------------------------------------* 00621009 * CHANGES * 00621109 *KBASS 0519-11 CHECK SYSUT1 AND SYSUT2 TO SEE IF TAPE * 00621209 * ------------------------------------------------------------------* 00623009 EJECT 00630000 MACRO 00640000 &LABEL EEXCP &CMD 00650000 &LABEL ST 5,GCCW STORE IN DATA AREA ADDR. 00660000 MVI GCCW,&CMD MOVE IN COMMAND BYTE 00670000 STH 6,GCCW+6 MOVE IN NUMBER OF BYTES 00680000 TM 48(2),X'10' IS TAPE OPEN? 00690000 BO *+14 BIF YES 00700000 LA 1,TOPENP NO ... 00710000 LA 15,OPENT ADDR OF OPENT 00720000 BALR 14,15 GO OPEN IT 00730000 * EXCP WIOB 00740006 EXCP WIOB DO IT 00750006 XC ECB,ECB 00751007 * WAIT ECB=ECB 00760000 WAIT ECB=ECB WAIT FOR COMPLETION 00770000 LA 15,0 SET RETURN CODE 00780000 MEND 00790000 MACRO 00800000 &LABEL SAVEIT &ENTRY 00810000 &LABEL SAVE (14,12),T,&ENTRY 00820000 BALR 10,0 00830000 USING *,10 00840000 AIF ('&ENTRY' NE 'OPENT').NOPENT 00850000 ST 13,SAVEOT+4 00860000 LA 5,SAVEOT 00870000 AGO .GOPENT 00880000 .NOPENT ANOP 00890000 ST 13,SAVE+4 00900000 LA 5,SAVE 00910000 .GOPENT ANOP 00920000 ST 5,8(13) 00930000 LR 13,5 00940000 MEND 00950000 MACRO 00960000 &LABEL RESTORE 00970000 &LABEL L 13,SAVE+4 00980000 L 14,12(13) 00990000 LM 0,12,20(13) 01000000 MVI 12(13),X'FF' 01010000 MEND 01020000 MACRO 01030000 &LABEL TAPEDCB 01040000 &LABEL L 5,0(2) 01050000 ST 5,TT 01060000 LA 2,SYSUT1 01070000 C 5,F1 01080000 BE *+8 01090000 LA 2,SYSUT2 01100000 ST 2,DCBA 01110000 XC WIOB(WIOBLEN),WIOB SJBA 01111006 MVC WIOB+21(3),DCBA+1 IOBECBPB 01120006 MVI WIOB,X'42' IOBCFLG1 UN RELATED FLAG 01121006 MVC WIOB+5(3),ECBA IOBCECB+1 01122006 MVC WIOB+17(3),GCCWA ADDR OF CHANNEL PROGRAM 01123006 XC ECB(4),ECB 01130000 MEND 01140000 EJECT 01150000 RTAPE CSECT 01160000 * CALL RTAPE(K,BUF,N,&99,&999) READ TAPE 01170000 * K = 1 OR 2 (WHICH TAPE) 01180000 * BUF = INPUT ARRAY 01190000 * N = NUMBER OF BYTES READ R15 = 0 GOOD READ 01200000 * &99 = EOF LABEL R15 = 4 EOF READ 01210000 * &999 = ERR EXIT LABEL R15 = 8 ERR ON READ 01220000 * ---------------------------------------------------------- 01230000 ENTRY WTAPE,OPENT,CLOSET,RWTAPE,SFILE,FSREC 01240000 ENTRY BSREC,FSFILE,BSFILE,WTMARK 01250000 SAVEIT RTAPE 01260000 LM R2,R4,0(R1) 01270000 TAPEDCB 01280000 LR R5,R3 01290000 L R6,F64K 64K-1 LENGTH 01300000 MVI GCCW+4,X'20' TURN OFF CHAINING 01310000 EEXCP X'02' READ IT 01320000 MVI GCCW+4,X'60' TURN ON CHAINING 01330000 TM ECB,X'7F' ERR? X'7F' = GOOD SJB2 01331000 BO RDOK BIF YES SJB2 01332000 TM ECB,X'41' ERR? CHANNEL PROGRAM ERROR? SJB2 01333000 BNO RDERR NO, NOT TAPEMARK SJB2 01334000 TM WIOB+12,X'02' @@ ERROR 01335006 BO RDERR YES, ERROR 01336004 TM WIOB+12,X'0D' @@ EOF? 01360006 BO RDEOF YES, EOF 01370000 B RDERR NO, ERROR 01371000 RDOK DS 0H 01380000 LH R6,WIOB+14 RESIDUAL 01400006 SLL R6,16 CLEAR HIGH ORDER HALF WORD 01410000 SRL R6,16 ... 01420000 L R7,F64K ORIGINAL BYTE COUNT 01430000 SR R7,R6 ORIGINAL - RESIDUAL 01440000 ST R7,0(R4) AND SAVE IT 01450000 B RDRET 01460000 RDEOF LA R15,4 01470000 B *+8 01480000 RDERR LA R15,8 01490000 LA R7,0 01500000 ST R7,0(4) 01510000 RDRET RESTORE 01520000 BR 14 01530000 EJECT 01540000 WTAPE SAVEIT WTAPE 01550000 * CALL WTAPE(K,BUF,N,&9999) WRITE TAPE 01560000 * K = 1 OR 2 (WHICH TAPE) 01570000 * BUF = OUTPUT ARRAY 01580000 * N = NUMBER OF BYTES TO WRITE R15 = 0 GOOD WRITE 01590000 * &9999 = ERR EXIT LABEL R15 = 4 ERR ON WRITE 01600000 * ---------------------------------------------------------- 01610000 LM 2,4,0(1) 01620000 L 4,0(4) 01630000 TAPEDCB 01640000 C 5,F1 IS THIS SYSUT1 SJB 01650000 BNE WDUMMT2 YES SJB 01660000 TM FLAG,$NULL1 IS THIS A DD DUMMY SJB 01670000 BO WDUMM1 SJB 01680000 B WNOTDUM SJB 01690000 WDUMMT2 DS 0H SJB 01700000 TM FLAG,$NULL2 IS THIS A DD DUMMY SJB 01710000 BO WDUMM1 SJB 01720000 WNOTDUM DS 0H SJB 01730000 LA 5,2 SET FOR OUTPUT OPEN 01740000 ST 5,TT+4 01750000 LR 5,3 01760000 LR 6,4 NUMBER OF BYTES TO WRITE 01770000 EEXCP X'01' WRITE IT 01780000 TM ECB,X'7F' IS WRITE GOOD 01790000 BO *+8 YES 01800000 LA 15,4 01810000 WDUMM1 LA 5,1 RESET OPEN FLAG FOR INPUT 01820000 ST 5,TT+4 01830000 RESTORE 01840000 BR 14 01850000 EJECT 01860000 RWTAPE SAVEIT RWTAPE 01870000 * CALL RWTAPE(K) REWIND TAPE 01880000 * K = 1 OR 2 (WHICH TAPE) 01890000 * ---------------------------------------------------------- 01900000 L 2,0(1) 01910000 TAPEDCB 01920000 LA 5,DUM 01930000 LA 6,1 01940000 EEXCP X'07' REWIND TAPE 01950000 RESTORE 01960000 BR 14 01970000 EJECT 01980000 FSREC SAVEIT FSREC 01990000 * CALL FSREC(K,N) FORWARD-SPACE RECORD 02000000 * K = 1 OR 2 (WHICH TAPE) 02010000 * N = NUMBER OF REC (INPUT) (MUST BE A VARIABLE) 02020000 * = NUMBER OF REC (OUTPUT) NOT PROCESSED 02030000 * BECAUSE OF EOF 02040000 * ---------------------------------------------------------- 02050000 LM 2,3,0(1) 02060000 L 4,0(3) 02070000 TAPEDCB 02080000 C 4,F0 02090000 BNH FSRET 02100000 LA 5,DUM 02110000 LA 6,1 02120000 FSREE EEXCP X'37' FOWARD SPACE REC 02130000 TM WIOB+12,X'03' EOF? 02140006 BM *+8 02150000 BCT 4,FSREE DO N TIMES 02160000 ST 4,0(3) 02170000 FSRET RESTORE 02180000 BR 14 02190000 EJECT 02200000 BSREC SAVEIT BSREC 02210000 * CALL BSREC(K,N) BACKWARD-SPACE RECORD 02220000 * K = 1 OR 2 (WHICH TAPE) 02230000 * N = NUMBER OF REC (INPUT) (MUST BE A VARIABLE) 02240000 * = NUMBER OF REC (OUTPUT) NOT PROCESSED 02250000 * BECAUSE OF EOF 02260000 * ---------------------------------------------------------- 02270000 LM 2,3,0(1) 02280000 L 4,0(3) 02290000 TAPEDCB 02300000 C 4,F0 02310000 BNH BSRET 02320000 LA 5,DUM 02330000 LA 6,1 02340000 BSREE EEXCP X'27' BACKWARD SPACE REC 02350000 TM WIOB+12,X'03' EOF? 02360006 BM *+8 02370000 BCT 4,BSREE DO N TIMES 02380000 ST 4,0(3) 02390000 BSRET RESTORE 02400000 BR 14 02410000 EJECT 02420000 FSFILE SAVEIT FSFILE 02430000 * CALL FSFILE(K) FORWARD-SPACE FILE 02440000 * K = 1 OR 2 (WHICH TAPE) 02450000 * ---------------------------------------------------------- 02460000 SFILE EQU FSFILE 02470000 L 2,0(1) 02480000 TAPEDCB 02490000 LA 5,DUM 02500000 LA 6,1 02510000 EEXCP X'3F' FOWARD SPACE FILE 02520000 RESTORE 02530000 BR 14 02540000 EJECT 02550000 BSFILE SAVEIT BSFILE 02560000 * CALL BSFILE(K) BACKWARD-SPACE FILE 02570000 * K = 1 OR 2 (WHICH TAPE) 02580000 * ---------------------------------------------------------- 02590000 L 2,0(1) 02600000 TAPEDCB 02610000 LA 5,DUM 02620000 LA 6,1 02630000 EEXCP X'2F' BACKWARD SPACE FILE 02640000 RESTORE 02650000 BR 14 02660000 EJECT 02670000 WTMARK SAVEIT WTMARK 02680000 * CALL WTMARK(K) WRITE TAPE MARK 02690000 * K = 1 OR 2 (WHICH TAPE) 02700000 * ---------------------------------------------------------- 02710000 L 2,0(1) 02720000 TAPEDCB 02730000 C 5,F1 IS THIS SYSUT1 SJB 02740000 BNE WTDUMM2 YES SJB 02750000 TM FLAG,$NULL1 IS THIS A DD DUMMY SJB 02760000 BO WTEOF SJB 02770000 B WTNOTDUM SJB 02780000 WTDUMM2 DS 0H SJB 02790000 TM FLAG,$NULL2 IS THIS A DD DUMMY SJB 02800000 BO WTEOF SJB 02810000 WTNOTDUM DS 0H SJB 02820000 LA 5,DUM 02830000 LA 6,1 02840000 EEXCP X'1F' WRITE TAPE MARK 02850000 WTEOF RESTORE 02860000 BR 14 02870000 EJECT 02880000 OPENT SAVEIT OPENT 02890000 * CALL OPENT(K,L) OPEN TAPE 02900000 * K = 1 OR 2 (WHICH TAPE) 02910000 * L = 1 FOR INPUT 02920000 * L = 2 FOR OUTPUT 02930000 * ---------------------------------------------------------- 02940000 LM 2,3,0(1) 02950000 TAPEDCB 02960000 MVI WIOB,X'42' TURN ON UN RELATED FLAG 02970006 MVC WIOB+5(3),ECBA 02980006 MVC WIOB+17(3),GCCWA ADDR OF CHANNEL PROGRAM 02990006 LA 5,1 03000000 STH 5,WIOB+28 BLOCK INCREMENT 03010006 L 4,0(3) 03020000 C 4,F1 03030000 BNE OT2 03040000 DEVTYPE CSYSUT1,DEVD1 SJB 03050000 CLC DEVD1,=F'0' IS A DD DUMMY SJB 03060000 BNE XOPEN1 SJB 03070000 OI FLAG,$NULL1 SJB 03080000 B OTRET SJB 03090000 XOPEN1 DS 0H SJB 03100000 TM DEVD1+02,X'80' IS THIS TAPE 0519-11 03101009 BZ NOTTAPE1 NO 0519-11 03102009 OPEN ((2),INPUT) 03110000 B OTRET 03120000 OT2 DS 0H SJB 03130000 DEVTYPE CSYSUT2,DEVD2 SJB 03140000 CLC DEVD2,=F'0' IS A DD DUMMY SJB 03150000 BNE XOPEN2 SJB 03160000 OI FLAG,$NULL2 SJB 03170000 B OTRET SJB 03180000 XOPEN2 DS 0H SJB 03190000 TM DEVD2+02,X'80' IS THIS TAPE 0519-11 03191009 BZ NOTTAPE2 NO 0519-11 03192009 OPEN ((2),OUTPUT) 03200000 OTRET L 13,SAVEOT+4 03210000 RETURN (14,12),RC=0 03220000 NOTTAPE1 DS 0H 0519-11 03221009 WTO 'RTAPE SYSUT1 NOT TAPE',ROUTCDE=11 0519-11 03221109 ABEND 101 03222009 NOTTAPE2 DS 0H 0519-11 03223009 WTO 'RTAPE SYSUT2 NOT TAPE',ROUTCDE=11 0519-11 03224009 ABEND 102 03225009 EJECT 03230000 CLOSET SAVEIT CLOSET 03240000 * CALL CLOSET(K,L) CLOSE TAPE 03250000 * K = 1 OR 2 (WHICH TAPE) 03260000 * L = 1 FOR INPUT 03270000 * L = 2 FOR OUTPUT 03280000 * ---------------------------------------------------------- 03290000 L 2,0(1) 03300000 TAPEDCB 03310000 CLOSE ((2),REWIND) 03320000 RESTORE 03330000 LA 15,0 03340000 BR 14 03350000 EJECT 03360000 WIOB DC 4D'0' 03370006 WIOBLEN EQU *-WIOB SJBA 03371006 GCCW CCW X'03',DUM,X'60',1 03380000 CCW X'03',DUM,X'20',1 DUMMY 03390002 SAVE DS 18F 03400000 SAVEOT DS 18F 03410000 F0 DC F'0' 03420000 F1 DC F'1' 03430000 F32760 DC F'32760' 03440000 FFFF DC X'FFFF' 03450000 F64K DC A(X'0000FFFF') 03460000 TOPENP DC A(TT) 03470000 DC A(TT+4) 03480000 TT DC F'1' 03490000 DC F'1' 03500000 DCBA DC F'0' 03510000 ECB DC F'0' 03520000 ECBA DC AL3(ECB) 03530000 GCCWA DC AL3(GCCW) 03540000 DUM DS C 03550000 FLAG DC X'00' SJB 03560000 $NULL1 EQU X'80' SJB 03570000 $NULL2 EQU X'40' SJB 03580000 CSYSUT1 DC CL8'SYSUT1' SJB 03590000 CSYSUT2 DC CL8'SYSUT2' SJB 03600000 DEVD1 DC F'0' SYSUT1 DEVTYPE SJB 03610009 DEVD2 DC F'0' SYSUT2 DEVTYPE SJB 03620009 XJFCB1 DS 0F SJB 03630000 DC X'87' SJB 03640000 DC AL3(JFCB1) SJB 03650000 XJFCB2 DS 0F SJB 03660000 DC X'87' SJB 03670000 DC AL3(JFCB2) SJB 03680000 JFCB1 DC 0F'0',CL176' ' SJB 03690000 JFCB2 DC 0F'0',CL176' ' SJB 03700000 EJECT 03710000 SYSUT1 DCB DDNAME=SYSUT1,DSORG=PS,RECFM=U,BUFNO=2, X03720000 OPTCD=Z,EXLST=XJFCB1, X03730000 DEVD=TA,EODAD=RDEOF,MACRF=(E),BUFOFF=0 03740000 EJECT 03750000 SYSUT2 DCB DDNAME=SYSUT2,DSORG=PS,RECFM=U,BUFNO=2, X03760000 OPTCD=Z,EXLST=XJFCB2, X03770000 DEVD=TA,EODAD=RDEOF,MACRF=(E),BUFOFF=0 03780000 YREGS , SJB 03790008 IEZIOB , 03791006 END 03800000