PROGRAM TTP
C
C PROGRAM : TAPE TRANSFER PROGRAM
C DATE    : 28 JAN 80
C
C FEATURES INCLUDED					DEFAULTS
C
C	1. VARIABLE INPUT DEVICE			MM0:
C		IF DISK FILE INPUT
C			A. MUST BE FORMATTED
C			B. OUTPUT NOT DISK
C	2. OPTIONAL REWIND OF INPUT TAPE		NO
C	3. VARIABLE OUTPUT DEVICE			SY:TAPE.DAT
C		IF OUTPUT DEVICE IS TAPE :
C			A. OPTIONAL REWIND AT START	NO
C			B. FEATURES 4-8, 11 AND 12 DO
C			   NOT APPLY
C			C. OPTIONAL REWIND AT END       NO
C			D. SINGLE OR VOLUMN
C			   (UP TO DOUBLE EOF)		SINGLE
C	4. VARIABLE PHYSICAL RECORD SIZE ON (TAPE)	512 BYTES
C	5. VARIABLE LOGICAL  RECORD SIZE "  "		80  BYTES
C	6. RECORD TRUNCATION BEFORE OUTPUT		NONE
C	7. RECORD START NUMBER				1
C       8. RECORD STOP  NUMBER				AT EOF
C       9. OPTIONAL FILE   SKIP	TAPE INPUT		0
C      10. OPTIONAL RECORD SKIP "    "			0
C      11. OPTIONAL EBCDIC TO ASCII CONVERSION		NO
C		TAPE INPUT
C      12. OPTIONAL ASCI   TO EBCDIC CONVERSION
C		DISK INPUT
C      13. OPTIONAL SPANNING OF BLOCKS BY RECORDS	NO
C
C NOTE: MAXIMUM RECORD SIZE TAPE TO TAPE IS 20000 BYTES
C
C COMPILATION AND TASK BUILD INSTRUCTIONS
C
C	F4P TTP,TTP/-SP=TTP
C	TKB TTP,TTP/-SP=TTP,EBASCI
C
C
C NOTE SYSTEM OR LANGUAGE (F4P VERSES FOR)  SPECIFIC STATEMENTS ARE
C ENCLOSED WITH 'CZZ'
C
	DIMENSION IPRM(6),IOS(2),IBUF(10000),IPRM2(6),IOS2(2)
	BYTE INB(20000),FNAME(32),YNZ,YN,YN1,YN2,IOSB(4),MTU(32)
	BYTE IOSB2(4)
	LOGICAL MT,MF,DX
	COMMON INB,IPRM,IPRM2,IOS,IOS2,FNAME,MTU
	EQUIVALENCE (INB,IBUF),(MTUI,MTU)
	EQUIVALENCE (IOS,IOSB)
	EQUIVALENCE (IOS2,IOSB2),(IM3,FNAME)
	DATA IM1,IM2/'MT','MM'/
	DATA MTU/'M','M','0',':',28*0/
	DATA FNAME/'S','Y',':','T','A','P','E','.','D','A','T',21*0/
	DX=.FALSE.
C
C---ANNOUNCE UP AND REQUEST RUNNING PARAMETERS
C
5	WRITE(5,10)
10	FORMAT(/////,' TAPE TRANSFER PROGRAM',//)
C
C--ASSIGN TAPE UNIT AND REWIND IT
C
	WRITE(5,200)
200	FORMAT('$UNIT FOR INPUT (EX. MT0: )      (DEF MM0:) : ')
	READ(5,210) ICNT,(MTU(I),I=1,ICNT)
210	FORMAT(Q,32A1)
	IF(ICNT.NE.0) GO TO 220
	MTU(1)='M'
	ICNT=4
C
220      CONTINUE
C
C-CHECK FOR MAG TAPE (MM OR MT WITH UNIT NUMBER AND ':')
C
	IF(MTUI.NE.IM1.AND.MTUI.NE.IM2) GO TO 228
	IF(MTU(ICNT).NE.':') GO TO 228
	IF(ICNT.EQ.4.AND.(MTU(3).LT."60.OR.MTU(3).GT."67)) GO TO 228
	GO TO 221
228	MTU(ICNT+1)=0
CZZ
	OPEN(UNIT=1,NAME=MTU,TYPE='OLD',ERR=222)
CZZ
	DX=.TRUE.
	GO TO 6
222	WRITE(5,223) (MTU(I),I=1,ICNT)
223	FORMAT(' INVALID INPUT FILE SPECIFICATION : ',80A1)
	STOP
CZZ
221	CALL ASSIGN(1,MTU,ICNT)
CZZ
	WRITE(5,230)
230	FORMAT('$REWIND INPUT <Y OR N>             (DEF NO) : ')
	READ(5,80) YN
	IF(YN.NE.'Y') GO TO 6
CZZ
	CALL WTQIO("2400,1,1,,IOS,)
	IF(IOSB(1).EQ.1) GO TO 6
CZZ
	WRITE(5,1) IOS
1	FORMAT(' ERROR ON REWIND   IOS = ',2O8)
	STOP
C
C-GET OUTPUT FILE NAME AND OPEN THE FILE
C
6	YN=0
	WRITE(5,20)
20	FORMAT('$OUTPUT FILE SPEC         (DEF SY:TAPE.DAT) : ')
	READ(5,30) ICNT,(FNAME(I),I=1,ICNT)
30	FORMAT(Q,32A1)
	IF(ICNT.NE.0) GO TO 38
	FNAME(1)='S'
	ICNT=11
	GO TO 39
C
C-CHECK FOR MAG TAPE OUTPUT
C
38	IF(IM3.NE.IM1.AND.IM3.NE.IM2) GO TO 39
	IF(FNAME(ICNT).NE.':') GO TO 39
	IF(ICNT.EQ.4.AND.(FNAME(3).LT."60.OR.FNAME(3).GT."67)) GO TO 39
C
C-IF MAG TAPE SET INDICATOR
C
	MT=.TRUE.
CZZ
	CALL GETADR(IPRM2,INB)
	IPBS=20000
CZZ
39	IF(.NOT.MT.AND.DX) GO TO 36
CZZ
	IF(MT) CALL ASSIGN(2,FNAME,ICNT)
	FNAME(ICNT+1)=0
	IF(.NOT.MT) OPEN(UNIT=2,NAME=FNAME,CARRIAGECONTROL='LIST')
CZZ
	IF(MT) GO TO 35
	GO TO 333
C
C-ERROR IF DISK INPUT AND DISK OUTPUT
C
36	WRITE(5,37)
37	FORMAT(' INVALID INPUT/OUPUT COMBINATION (BOTH DISK)')
	STOP
C
C-CHECK FOR REWIND OF INPUT
C
35	WRITE(5,31)
31	FORMAT('$REWIND OUTPUT TAPE <Y OR N>       (DEF NO) : ')
	READ(5,80) YN
	IF(YN.NE.'Y') GO TO 3331
CZZ
	CALL WTQIO("2400,2,2,,IOS2,)
	IF(IOSB2(1).EQ.1) GO TO 3331
CZZ
	WRITE(5,32) IOS2
32	FORMAT(' ERROR ON OUTPUT DEVICE REWIND IOS = ',2O8)
	STOP
C..
C..     SET DENSITY OF OUTPUT TAPE
C..
3331   WRITE(5,3332)
3332   FORMAT('$OUTPUT DENSITY (800 1600)        (DEF 800) : ')
       READ(5,50)IDENS
       IF(IDENS.NE.0.AND.IDENS.NE.800.AND.IDENS.NE.1600) GOTO 3331
       ID="0000
       IF(IDENS.EQ.1600) ID="4000
C.. SET DENSITY TO WHATEVER
	CALL WTQIO("2500,2,2,,IOS,ID,)
C
C-CHECK FOR MULTIFILE COPY
C
33	IF(DX) GO TO 41
333	WRITE(5,34) 
34	FORMAT('$VOLUMN COPY (UP TO DOUBLE EOF)    (DEF NO) : ')
	YN=0
	MF=.FALSE.
	READ(5,80) YN
	IF(YN.EQ.'Y') MF=.TRUE.
	IF(MT) GO TO 90
C
C-GET PHYSICAL RECORD SIZE
C
41	WRITE(5,40)
40	FORMAT('$PHYSICAL BLOCK SIZE              (DEF 512) : ')
	READ(5,50) IPBS
50	FORMAT(I10)
	IF(IPBS.EQ.0) IPBS=512
C
C-GET LOGICAL RECORD SIZE
C
	WRITE(5,60)
60	FORMAT('$LOGICAL BLOCK SIZE                (DEF 80) : ')
	READ(5,50) ILBS
	IF(ILBS.EQ.0) ILBS=80
	WRITE(5,61)
61	FORMAT('$SPAN BLOCK <Y OR N>                (DEF N) : ')
	READ(5,80) YN2
	IF(YN2.NE.'Y'.AND.YN2.NE.'N') YN2='N'
C
C-CHECK FOR ASCI TO EBCDIC  (DISK TO TAPE)
C
	IF(.NOT.DX) GO TO 69
	YN=0
	WRITE(5,62)
62	FORMAT('$ASCI TO EBCDIC CONVERSION <Y OR N> (DEF N) : ')
	READ(5,80) YN
	IF(YN.NE.'Y'.AND.YN.NE.'N') YN='N'
	GO TO 309
C
C-CHECK FOR EBCDIC TO ASCII CONVERSION
C
69	WRITE(5,70)
70	FORMAT('$EBCDIC TO ASCII <Y OR N>           (DEF N) : ')
	READ(5,80) YN
80	FORMAT(1A1)
	IF(YN.NE.'Y'.AND.YN.NE.'N') YN='N'
C
C-CHECK FOR SPECIAL OUTPUT RECORD PROCESSING
C
309	WRITE(5,310)
310	FORMAT('$TRUNCATED RECORD SIZE          (DEF INPUT) : ')
	READ(5,50) IRS
	IF(IRS.EQ.0) IRS=ILBS
	WRITE(5,320)
320	FORMAT('$STARTING RECORD NUMBER             (DEF 1) : ')
	READ(5,50) IST
	IF(IST.EQ.0) IST=1
90	WRITE(5,330) 
330	FORMAT('$# RECORDS TO COPY             (DEF AT EOF) : ')
	READ(5,50) ISP
	IF(ISP.EQ.0) ISP=-1
C
C-CHECK FOR FILES TO SKIP ON INPUT
C
	IF(DX) GO TO 1000
	WRITE(5,95)
95	FORMAT('$ENTER # FILES TO SKIP              (DEF 0) : ')
	READ(5,50) I
	IF(I.EQ.0) GO TO 400
	IPRM(1)=I
CZZ
	CALL WTQIO("2440,1,1,,IOS,IPRM)
	IF(IOSB(1).EQ.1) GO TO 400
CZZ
C
C-IF ERROR PRINT
C
	WRITE(5,96) IOS
96	FORMAT(' ERROR ON SKIP FILE : ',2O8)
	STOP
C
C---CHECK FOR PHYSICAL RECORDS TO SKIP
C
400	WRITE(5,410)
410	FORMAT('$ENTER # PHYSICAL RECORDS TO SKIP   (DEF 0) : ')
	READ(5,50) I
	IF(I.EQ.0) GO TO 101
	IPRM(1)=I
CZZ
	CALL WTQIO("2420,1,1,,IOS,IPRM)
	IF(IOSB(1).EQ.1) GO TO 100
CZZ
C
C-IF ERROR PRINT
C
	WRITE(5,420) IOS
420	FORMAT(' ERROR ON SKIP BLOCK : ',2O8)
	STOP
C..
C..	CHECK FOR 0 LENGTH RECORD = END FILE MARKER
C..
101	WRITE(5,102) 
102	FORMAT('$MARK ZERO LENGTH RECORD AS EOF    (DEF NO) : ')
	READ(5,80) YNZ
	IF(YNZ.NE.'Y') YNZ='N'
C
C---SET UP PARAMETERS AND LOOP ON READS
C
100	IPT=1
	IF(YN2.EQ.'Y') IPT=10001
	ICN=0
	ICNT=0
CZZ
	CALL GETADR(IPRM,INB(IPT))
	IPRM(2)=IPBS
CZZ
110	ICNT=ICNT+1
	IF(ISP.NE.-1.AND.ICNT.GT.ISP) GO TO 150
CZZ
	CALL WTQIO("1000,1,1,,IOS,IPRM)
C..CHECK FOR EOF MARKER (ZERO RECORD LENGTH)
	IF(YNZ.EQ.'Y'.AND.IOS(2).EQ.0) GO TO 150
	ISS=IPBS
	IF(IOS(2).LT.IPBS) ISS=IOS(2)
	ILBS1=ILBS
	IF(IOS(2).LT.ILBS) ILSB1=IOS(2)
	IF(IOSB(1).NE.1) GO TO 115
CZZ
	IFC=0
	IF(.NOT.MT) GO TO 130
C
C-WRITE OUT TO MAG TAPE
C
	IPRM2(2)=IOS(2)
CZZ
	CALL WTQIO("400,2,2,,IOS2,IPRM2)
CZZ
	ICN=ICN+1
	IF(IOSB2(1).EQ.1) GO TO 110
	WRITE(5,111) IOS2
111	FORMAT(' ERROR ON OUTPUT WRITE   IOS = ',2O8)
	STOP
C
C-IF GOOD JUMP IF NOT CHECK REASON FOR ERROR
C
115	IF(IOSB(1).EQ.-10) GO TO 150
	IF(IOSB(1).EQ.-62) GO TO 140
	WRITE(5,120) IOS,ICNT
120	FORMAT(' ERROR ON READ, STATUS = ',2O8,/,
	1' RECORD # = ',I10)
	STOP
C
C-IF DESIRED DO CONVERSION
C
130	IF(YN.EQ.'Y'.AND.YN2.EQ.'Y') CALL EBASCI(ISS,INB(10001))
	IF(YN.EQ.'Y'.AND.YN2.NE.'Y') CALL EBASCI(ISS,INB)
C
C-WRITE OUT TO OUTPUT FILE (NOT MAG TAPE)
C
600	IF(ICNT.LT.IST) GO TO 601
	WRITE(2,390) (INB(I1),I1=IPT,IPT+IRS-1)
	ICN=ICN+1
	IF(ICN.EQ.ISP)  GO TO 150
601	IPT=IPT+ILBS1
	IF(YN2.EQ.'N') GO TO 630
	IF(IPT.EQ.10001+ISS) GO TO 620
	IF(IPT+ILBS1.LE.10001+ISS) GO TO 600
	IC=10001+ISS-IPT
	DO 610 I=1,IC
610	INB(10000-IC+I)=INB(IPT+I-1)
	IPT=10001-IC
	GO TO 110
620	IPT=10001
	GO TO 110
630	IF(IPT+ILBS1-1.LE.ISS) GO TO 600
	IPT=1
	GO TO 110
390	FORMAT(40(250A1))
C
C-END OF TAPE ENCOUNTERED
C
140	WRITE(5,145)
145	FORMAT(' EOT ENCOUNTERED')
C
C-REWIND INPUT TAPE
C
150	IF(.NOT.MT.AND..NOT.MF) GO TO 151
	IFC=IFC+1
	IFC1=IFC1+1
C
C-WRITE EOF MARK FOR TAPE, CLOSE FILE FOR DISK
C
CZZ
	IF(MT) CALL WTQIO("3000,2,2,,IOS,)
	IF(.NOT.MT) CALL CLOSE(2)
	IF(.NOT.MT) OPEN(UNIT=2,NAME=FNAME,TYPE='NEW',
     1 CARRIAGECONTROL='LIST')
CZZ
C
C-GIVE TOTALS FOR THIS FILE AND SEE IF MULTIFILE (VOLUMN TRANSFER)
	IF(ICN.EQ.0) GO TO 154
	WRITE(5,152) IFC1,ICN
152	FORMAT(' FILE #',I4,'  # RECORDS = ',I9)
	ICN=0
154	IF(MF.AND.IFC.NE.2) GO TO 110
151	WRITE(5,230)
	YN=0
C
C-CHECK FOR REWIND OF INPUT
C
	READ(5,80) YN
	IF(YN.NE.'Y') GO TO 155
CZZ
	CALL WTQIO("2400,1,1,,IOS,)
CZZ
155	IF(.NOT.MT) GO TO 159
C
C-CLOSE OUTPUT FILE
C
153	WRITE(5,31)
	YN=0
C
C-CHECK FOR REWIND OF OUTPUT
C
	READ(5,80) YN
	IF(YN.NE.'Y') STOP
CZZ
	CALL WTQIO("2400,2,2,,IOS,)
CZZ
	STOP
C
C-DO DISK TO TAPE CONVERSION
C
1000	ICN=0
	ICN1=0
	ICNT=0
	IPT=1
	CALL GETADR(IPRM2,INB)
	IPRM2(2)=IPBS
C
C-CHECK FOR STOP RECORD
C
1005	CONTINUE
	IF(ICNT.LT.ISP.OR.ISP.EQ.-1) GO TO 1006
	GO TO 1090
C
C-READ DISK RECORD
C
1006	READ(1,1010,END=1090,ERR=1090) IC,(INB(I),I=IPT,IPT+IC-1)
1010	FORMAT(Q,40(250A1))
	IF(YNZ.EQ.'Y'.AND.IC.EQ.0) GO TO 1090
	ICN=ICN+1
C
C-CHECK FOR START RECORD
C
	IF(ICN.LT.IST) GO TO 1005
	ICNT=ICNT+1
	IF(IC.GE.IRS) GO TO 1030
C
C-IF INPUT LESS THAN LBS BLANK FILL
C
	DO 1020 I=1,IRS-IC
1020	INB(IPT+IC+I-1)=' '
1030	IPT=IPT+IRS
	IF(IPT.GE.IPBS) GO TO 1050
	IF(IPT+IRS-1.LE.IPBS) GO TO 1005
	IF(YN2.EQ.'Y') GO TO 1005
C
C-IF NOT SPAN BLOCK BLANK FILL
C
1035	DO 1040 I=IPT,IPBS
1040	INB(I)=' '
C
C-CHECK FOR ASCI TI EBCDIC CONVERSION
C
1050	IF(YN.EQ.'Y') CALL EBASCI(-IPBS,INB)
C
C-WRITE OUTPUT RECORD
C
CZZ
	CALL WTQIO("400,2,2,,IOS2,IPRM2)
CZZ
	IF(IOSB2(1).NE.1) GO TO 1080
	ICN1=ICN1+1
	IF(IPT.LE.IPBS) GO TO 1070
C
C-TRANSFER LEFT OVER TO BEGINNING OF BLOCK (SPAN BLOCK ONLY)
C
	DO 1060 I=1,IPT-IPBS-1
1060	INB(I)=INB(IPT+I-1)
	IPT=IPT-IPBS
	GO TO 1005
C
C-CHECK IF DONE
C
1070	IF(IEOF.EQ.1) GO TO 1100
	IPT=1
	GO TO 1005
C
C-IF ERROR PRINT MESSAGE
C
1080	WRITE(5,111) IOS2
	STOP
C
C-SET END OF FILE INDICATOR
C
1090	IF(IPT.EQ.1) GO TO 1100
	IEOF=1
	GO TO 1035
C
C-WRITE EOF
C
CZZ
1100	CALL WTQIO("3000,2,2,,IOS2,)
CZZ
C
C-GIVE TOTAL COUNTS FOR TRANSFER
C
	WRITE(5,1110) ICNT,ICN1
1110	FORMAT(' TRANSFER COMPLETE',/,
	1X,I10,' DISK RECORDS READ',/,
	1X,I10,' TAPE RECORDS WRITTEN')
CZZ
	CLOSE(UNIT=1)
CZZ
	GO TO 153
C
C-PRINT TERMINATION MESSAGE WITH SUMMARY TAPE INPUT NONTAPE OUTPUT
C
CZZ
159	CALL CLOSE(2)
CZZ
	WRITE(5,160) ICNT,ICN
160	FORMAT(//,' TRANSFER COMPLETE',10X,/,
	1X,I10,' PHYSICAL RECORDS READ',/,
	1X,I10,' LOGICAL  RECORDS WRITTEN')
	STOP
	END