LOGICAL*1 ZBUFF(8) LOGICAL*1 ZDMP(4000),ZDEV(2),ZOSB(4),ZCNV(64),ZICL(6000) INTEGER*2 IPRM(6),IOSB(2) INTEGER*4 IWRD EQUIVALENCE (ZDEV,IDEV),(ZOSB,IOSB) DATA ZCNV/'0','1','2','3','4','5','6','7', 1 '8','9',':',';','<','=','>','?', 1 ' ','!','"','#','#','%','&','''', 1 '(',')','*','+',',','-','.','/', 1 '@','A','B','C','D','E','F','G', 1 'H','I','J','K','L','M','N','O', 1 'P','Q','R','S','T','U','V','W', 1 'X','Y','Z','[','$',']','^','_'/ CALL GETADR(IPRM,ZDMP) TYPE 100 100 FORMAT ('$Where is the Magtape? ') ACCEPT 200,IDEV,IUNT 200 FORMAT (A2,O1) IF ((ZDEV(1).GE."141).AND.(ZDEV(1).LE."172)) ZDEV(1) = ZDEV(1) - "40 IF ((ZDEV(2).GE."141).AND.(ZDEV(2).LE."172)) ZDEV(2) = ZDEV(2) - "40 CALL ASNLUN(1,IDEV,IUNT) TYPE 101 101 FORMAT ('$Where do you want the output? ') ACCEPT 200,IDEV,IUNT IF ((ZDEV(1).GE."141).AND.(ZDEV(1).LE."172)) ZDEV(1) = ZDEV(1) - "40 IF ((ZDEV(2).GE."141).AND.(ZDEV(2).LE."172)) ZDEV(2) = ZDEV(2) - "40 CALL ASNLUN(2,IDEV,IUNT) IPRM(2) = 4000 CALL WTQIO("2400,1,1) CALL WTQIO("1000,1,1,,IOSB,IPRM) ILEN = IOSB(2) IF (ILEN.NE.60) TYPE 9000,(ILEN+2)/3 9000 FORMAT (' First record is ',I6,' ICL words - should be 20') IF (ILEN.NE.60) GOTO 900 CALL ICLCNV((ILEN+2)/3,ZDMP,ZICL) WRITE (2,300) (ZCNV(ZICL(I)+1),I=1,20) 300 FORMAT (' Tape Header :- ',20A1) CALL WTQIO("1000,1,1,,IOSB,IPRM) IF (ZOSB(1).NE.-10) TYPE 9010,ZOSB(1) 9010 FORMAT (' Tape Mark Not Found - Status = ',I6) IF (ZOSB(1).NE.-10) GOTO 900 CALL WTQIO("1000,1,1,,IOSB,IPRM) ILEN = IOSB(2) IF (ILEN.NE.60) TYPE 9020,(ILEN+2)/3 9020 FORMAT (' Second record is ',I6,' ICL words - should be 20') IF (ILEN.NE.60) GOTO 900 CALL ICLCNV((ILEN+2)/3,ZDMP,ZICL) CALL GETWRD(ZICL(5),IWRD) WRITE (2,400) IWRD 400 FORMAT (' Blocking Factor (?) of ',I10,' ICL words') 1 CALL WTQIO("1000,1,1,,IOSB,IPRM) IF (ZOSB(1).EQ.-10) GOTO 900 ILEN = IOSB(2) CALL ICLCNV((ILEN+2)/3,ZDMP,ZICL) ILEN = (((ILEN+2)/3)*4) WRITE (2,500) (ZCNV(ZICL(I)+1),I=1,ILEN) 500 FORMAT (100(' ',60A1/)) GOTO 1 900 CALL EXIT END C SUBROUTINE GETWRD(ZWRD,IWRD) LOGICAL*1 ZWRD(4) INTEGER*4 IWRD C IWRD = 0 DO 10,I=1,4 IWRD = IWRD*64 + ZWRD(I) 10 CONTINUE RETURN END C SUBROUTINE ICLCNV(ILEN,ZDMP,ZICL) INTEGER*4 IWRD,IDMP,ITMP INTEGER*2 IDMP1(2) LOGICAL*1 ZBUFF(12),ZICL(6000),ZDMP(4000),ZDMP1(4) EQUIVALENCE (ZDMP1,IDMP),(IDMP1,IDMP) C DO 100,I=1,ILEN IDMP1(2) = ZDMP(3*I - 2) ZDMP1(2) = ZDMP(3*I - 1) ZDMP1(1) = ZDMP(3*I) IERR = 2 CALL BINASC(IDMP,12,8,ZBUFF,IERR) C DO 10,J=1,4 CALL ASCBIN(2,ZBUFF(3 + J*2),8,ITMP,IERR) ZICL(I*4 - 4 + J) = ITMP 10 CONTINUE C 100 CONTINUE RETURN END