cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c	ReadCPM.for
c	This program reads cpm 8-inch diskette format files generated
c	by FCOPY, decodes the file contents, and stores them on the
c	vax in files-11 format.
c	Dale Miller - UALR
c	18-Apr-1985
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      implicit integer (a-z)
c
      include '($ssdef)'		! $ssdef definitins parameterized
      include 'sys$library:foriosdef.for'		! $iodef definitions parameterized
      include '($lbrdef)'		! $lbrdef definitions parameterized
c
c     do the definitions necessary to read the tape
c
c
      character sysmsg*80
c
c
      integer disk(32,26,76)
      integer clus(32,8,247)
      integer dire(8,64)
      integer trk(32,26)
c     s is the array representing the skewing on the disk
      integer s(26)/01,07,13,19,25,05,11,17,23,03,09,15,21,
     &              02,08,14,20,26,06,12,18,24,04,10,16,22/
      integer car(12)
      character trans*20
      character qfilnam*45/' '/
      character afilnam*12,hfilnam*12
      character bfilnam*8
      character kk*1,acar*1
      character qx*1,hc*1,cfn*1
      dimension qx(4),icfn(3),cfn(12)
      dimension kk(4),acar(12)
      equivalence (disk,clus,dire)
      equivalence (qx,qxx)
      equivalence (hc,hcc)
      equivalence (cfn,icfn)
c
c     setup for the tape
c
      at_begin = .true.
      at_end = .false.
      block = 1
      ttyout=6
c
c
 0083 continue
c
c     first and last disk # to process
c
      print*,'Starting disk #?'
      read*,begdk
      enddk=begdk
      dskno=begdk-1
c
c     begin the real work
c
 0001 continue
      badfil=0
      dskno=dskno+1
      if (dskno.gt.enddk) stop
c     get the disk number as a string
      k1=dskno/1000
      k2=(dskno-(k1*1000))/100
      k3=(dskno-(k1*1000)-(k2*100))/10
      k4=(dskno-(k1*1000)-(k2*100)-(k3*10))
      iret = ots$cvt_l_ti(k1,kk(1))
      iret = ots$cvt_l_ti(k2,kk(2))
      iret = ots$cvt_l_ti(k3,kk(3))
      iret = ots$cvt_l_ti(k4,kk(4))
      bfilnam = 'disk'//kk(1)//kk(2)//kk(3)//kk(4)
      print*,bfilnam
      istat=lib$spawn
     &    ('create/dir disk$user:[cpmug.'//bfilnam//']')
c**************************************************************
c
c     read in an entire disk
c
c     skip first two tracks (where cp/m should reside)
c
      do ii=1,2
          do j=1,26
              read(4,end=500,err=550)(trk(k,j),k=1,32)
              end do
          end do
c
c
c     now, read in 75 tracks of the diskette
c
      do 100 i=1,75
          do j=1,26
              read(4,end=500,err=550)
     &            (trk(k,j),k=1,32)
	      end do
c
c         put it where it should go (de-skewing in the process)
c
          do 90 j=1,26
              do 90 k=1,32
                  disk(k,j,i)=trk(k,s(j))
 0090             continue
 0100 continue
*
*
*     process directory entries
*
      do 150 d=1,64
c         eliminate erased entries (an erased entry has e5 as the first)
c
          qxx=dire(1,d)
          hc = qx(1)
          if (hcc.eq.229) go to 150
c
c         eliminate non-0 extent files
          qxx=dire(4,d)
          hc=qx(1)
          if (hcc.ne.0) go to 150
c         set up for extent 0
          de=d
          extno=0
c
c*************************************************************************
c         create and open the file
c
c         build a filename
          icfn(1)=dire(1,d)
          icfn(2)=dire(2,d)
          icfn(3)=dire(3,d)
          z1=1
          do 200 z=2,9
c              z2=field(mod(z-1,4)*9,9,dire((z-1)/4+1,d))
              if (cfn(z).eq.' ') go to 200
              car(z1)=ichar(cfn(z))
              acar(z1)=cfn(z)
              z1=z1+1
 0200         continue
c         add a period (but decimal, add an underscore)
          car(z1)=95
          acar(z1)='.'
          z1=z1+1
c         move in extension
          do 210 z=10,12
c              z2=field(mod(z-1,4)*9,9,dire((z-1)/4+1,d))
c              if (z2.eq.32) go to 210
              if (cfn(z).eq.' ') go to 210
              car(z1)=ichar(cfn(z))
              acar(z1)=cfn(z)
              z1=z1+1
 0210         continue
c         blank fill
          if (z1.eq.13) go to 230
          do 220 z=z1,12
          car(z)=32
          acar(z)=' '
 0220     continue
 0230     continue
c
c         add up the filename to get 1 string to pass in the call
c
          afilnam = acar(1)//acar(2)//acar(3)//acar(4)//acar(5)
     &        //acar(6)//acar(7)//acar(8)//acar(9)
     &        //acar(10)//acar(11)//acar(12)
c
c         check filename for valid
c
          badflg=0
          do 512 z=1,z1-1
              z4=car(z)
              if((z4.ge.48).and.(z4.le.57)) go to 512
              if((z4.ge.65).and.(z4.le.90)) go to 512
              if(z4.eq.95) go to 512
              car(z)=95
              acar(z)='_'
              badflg=1
 0512         continue
          if (badflg.eq.1) then
              hfilnam=afilnam
              afilnam = acar(1)//acar(2)//acar(3)//acar(4)//acar(5)
     &            //acar(6)//acar(7)//acar(8)//acar(9)
     &            //acar(10)//acar(11)//acar(12)
              write(11,2050)dskno,hfilnam,afilnam
              endif
 0231     continue
 2050 format(' ','disk=',i4,' file=',a12,'  is now ',a12)
c*******************************************************************
c     we now have a file name.  open it for output
c
 0240 continue
      qfilnam='disk$user:[cpmug.'//bfilnam//']'//afilnam
      open (unit=1,name=qfilnam,carriagecontrol='none',
     1    type='new',form='unformatted',err=8000)
c********************************************************************
 0105 continue
c         determine number of records in extent and process
c         clusters obtained thereby
c
c          nrecs=field(27,9,dire(4,de))
          qxx=dire(4,de)
          hc=qx(4)
          nrecs=hcc
          if (nrecs.eq.0) go to 156
          do 110 e=1,nrecs
*             determine extent number
              en=(e-1)/8+1
*             now find cluster number (+1 is to fudge subscripts)
ccc              cn=field(( mod(en-1,4))*9,9,dire((en-1)/4+5,de))+1
              qxx=dire((en-1)/4+5,de)
              hc = qx (mod(en-1,4)+1)
              cn = hcc+1
ccc              it was much eaiser with field
*             find record offset within cluster (+1)
              ro=mod(e,8)
              if(ro.eq.0) ro=8
*             write the record to disk
              write(1)(clus(j,ro,cn),j=1,32)
 0110         continue
          if (nrecs.lt.128) go to 140
*         non extent-0 search
          do 115 w=1,64
ccc              if (field(0,9,dire(1,d)).eq.229) go to 115
              qxx=dire(1,d)
              hc = qx(1)
              if (hcc.eq.229) go to 115
ccc
ccc              if (field(0,9,dire(4,w)).ne.(extno+1)) go to 115
              qxx=dire(4,w)
              hc = qx(1)
              if (hcc.ne.(extno+1)) go to 115
              if (dire(1,d).ne.dire(1,w)) go to 115
              if (dire(2,d).ne.dire(2,w)) go to 115
              if (dire(3,d).ne.dire(3,w)) go to 115
              de=w
              extno=extno+1
              go to 105
 0115         continue
 0140     continue
          go to 0157
*
*         0 records in extent.  print message
*
 0156     write(11,1112)dskno,afilnam
 1112     format(' no records in file>[.disk',i4,']',a12) 
 0157     continue
*         close the file
          close (unit=01)
 0150     continue
      go to 0001
c
c
c
 0500 print*,'end of file encountered'
      stop
 0550 print*,'error reading record',i
      stop
 8000 print*,'fatal error trying to open file'
c*************************************************************************
c
c     error messages grabbed from ETAPE
c
9000	write(ttyout,9901)
9901	format(' Can''t assign channel for tape')
	go to 9040
9010	write(ttyout,9902)
9902	format(' Can''t rewind tape')
	stop
9040	write(ttyout,9905)retcode
9905	format(' SYS$QIOW returned error code:',z8)
9045	call SYS$GETMSG(%val(retcode),msglen,sysmsg,,)
	write(ttyout,13)sysmsg(1:msglen)
	go to 9500
9050	write(ttyout,9906)status
9906	format(' SYS$QIOW illegal status:',z8)
	call SYS$GETMSG(%val(status),msglen,sysmsg,,)
	write(ttyout,13)sysmsg(1:msglen)
	go to 9500
c
c common fatal error handler. rewind tape; if successful, he can continue,
c otherwise we might as well stop
c
9500	retcode=SYS$QIOW(,%val(channel),%val(IO$_REWIND),iosb,,,,,,,,)
	if(retcode.ne.SS$_NORMAL)then
		write(ttyout,14)
		stop
            endif
 0013 format(1x,a)
 0014 format( 'Fatal error, must stop')
      end
