c	Program EXAREAD		Read standard FITS files from Exabyte
c
c Modifications:
c	14-Jan-90	JRV	add reading using list file
c	16-Jan-90	JRV	add command line parameter for list file
c	07-Feb-90	JRV	bug fixes
c	14-Feb-90	JRV	more bug fixes
c	22-May-90	JRV	add output file directory selection
c	13-Jun-90	JRV	modify for SUNCUB
c	30-Oct-90	JRV	change tape drive reference to logical name
c	14-Jan-91	JRV	slight change to local file generation
c				bug fix
c	07-Feb-91	JRV	bug fix in file skipping between clusters
c	04-Mar-91	JRV	converted to use standard FITS disk format
c	13-Nov-91	JRV	make buffer larger
c	11-Jun-92	JRV	attempt to figure out filenames for
c				Eyecom images
c	08-Jul-92	JRV	bug fix in cluster change code and file
c				name generation
c	03-Feb-95	JRV	change output filenames when no name specified
c	14-Sep-95	JRV	change output filenames to 8 characters
c				under some conditions
c
	character*80 header(144),string,filename,file,junk,tfile
	character*80 lfil, uinput, odir, rstring
	character*80 ffnam
	data comment/'COMMENT '/
	character*1 space,brack,dot
	character*6 nfstr
	data space/' '/,brack/']'/,dot/'.'/
	character*22 diskfile
	character*17 diskfil2
	character*4 sub
	data diskfile/'ORIGIN FILE WAS NAMED '/,junk/'JUNK.FTS '/
	data diskfil2/'ORIGIN FILE NAME '/
	character*8 comment
	data comment/'COMMENT '/
	integer*4 buffer(900000)
c		buffer is somewhere over 3.6 megabytes
	equivalence (buffer,header)
	character*6 tape
	data tape /'EXDRV:'/
	integer*4 tapeid,result,rmode,nimage, interflg
	integer clustart,cluend,filstart,filend,ldblank,lfblank,istat
	integer imm, ind2
	logical ltype,leot,lname, lrfdisp
	data leot/.FALSE./
	data lrfdisp/.FALSE./
	integer*4 bitpix,nax,naxes(10)
	integer*4 cnew,fnew
c
c	needed for command line parameters
	character*80 argc(20)
	integer com_args, n_args
c
	type *, 'EXAREAD	14 September 1995 version'
	type *, '		Reads std. FITS files from Exabyte tape'
c
c		Process command line
	string = space
	odir = space
	n_args = com_args(argc)
	If (n_args .GE. 1) then
		interflg = 0
		rmode = 1
		lfil = argc(1)

		If (lfil .EQ. '?') then
		   type *,'Usage: EXAREAD [listfile [outputdir]]'
		   stop
		Endif
	Endif
	If (n_args .EQ. 2) odir = argc(2)
	If (n_args .GT. 2) then
		type *,'EXAREAD: Too many arguments.'
		stop
	Endif
	If (n_args .LT. 1) then
		interflg = 1
	Endif
c
c		Set read mode
	If (interflg .EQ. 1) then
	   Write(*,1500)
1500	   Format('$Read using list file (Y/N)? ')
	   Read(*,1510) string
1510	   Format(a80)
	   If (string(1:1) .EQ. 'Y' .OR. string(1:1) .EQ. 'y') then
		rmode = 1
	   Else
		rmode = 0
	   Endif
	   If (rmode .EQ. 1) then
		Write(*,1520)
1520		Format('$Enter list file name: ')
		Read(*,1510) string
		lfil = string
	   Endif
	Endif
c
c		Attempt to access Exabyte drive
c
	call mtopid(tape,tapeid,result)
	if (result .ne. 0) then
	   type *,'Tape open error',result
	   call mtmess(result,'MTOPID',string)
	   type *,string
	   stop
	endif
	type *,'Exabyte Drive successfully accessed.'
c
c		Requesting output filename
c
	If (interflg .EQ. 1) then
	   type *,'Enter filename for restored images or <Return>'
	   read (*,'(A)') filename
	   if (filename(1:1) .ne. space) then
	     	lname = .true.
	   else
	 	lname=.false.
	   endif
c		Get output directory
	   type *,'Enter output file directory'
	   Read (*,'(A)') uinput
	   If (uinput(1:1) .NE. space) then
		odir = uinput
	   Endif
	Else
	  lname = .false.
	Endif
c
c		Requesting starting and ending file numbers
c

	If (rmode .EQ. 0) then
10	  write (*,951)
951	  format (1x,'Enter starting cluster number and file number',
     1    /'$   within cluster :')
	  read *,clustart,filstart
	  if (clustart .le. 0 .or. filstart .le. 0) goto 10
20	  write (*,952)
952	  format (1x,'Enter ending cluster number and file number',
     1    /'$   within cluster :')
	  read *,cluend,filend
	  if (cluend .lt. clustart .or. (cluend .eq. clustart .and.
     1		filend .lt. filstart)) goto 20
	Else If (rmode .EQ. 1) then
	   Open(unit=3,file=lfil,status='OLD',readonly)
	   Do i = 1, 5
c		Skip header lines
	      Read(3,1601)
1601	      Format(a80)
	   Enddo
           Read(3,1600) clustart, filstart
1600	   Format(i3,i5)
c	   type *,'Next image--cluster:',clustart,' file:',filstart
	Endif
c
c		Positioning Exabyte tape at first file
c
c
	nimage = 0
	iclust = 1
	ifile = 0
	cnew = clustart
	fnew = filstart
	nfskip = fnew - 1
	nskip =  cnew - 1
c
c		Move to next file
190	Continue
	ifile=ifile+1
	if (nskip .gt. 0) then
	   type *,'Now skipping over file clusters . . .'
	   call mtskfi(tapeid,nskip,iskip,result)
		if (result .ne. 0) then
		   type *,'Tape skip error',result
		   call mtmess(result,'MTSKFI',string)
		   type *,string
		   stop
		endif
c	   type *,nskip,' file marks skipped over.'
	   iclust = iclust + nskip
	else
c	   type *,'No file marks skipped over.'
	endif
c		Positioning to file within cluster
c	type *,'iclust now = ',iclust
	n2read=8192
    	if (nfskip .gt. 0) then
	 type *,'Now skipping over files within the cluster . . .'
	 do i=1,nfskip
		call mtread(tapeid,n2read,buffer,nbytes,result)
		if (result .ne. 0 .or. nbytes .ne. n2read) then
		   type *,'Tape skip error',result
		   call mtmess(result,'MTREAD',string)
		   type *,string
		   stop
		endif
		call fhedr0(header,72,ltype,bitpix,nax,naxes,nend,0,

     1			ierr)
		if (ierr .eq. 1 .and. ltype .and. nax .eq. 2 .and.
     1			nend .gt. 0) then
		   ndbyte=naxes(1)*naxes(2)
		   if (bitpix .eq. 16) ndbyte =ndbyte*2
		   ndblke=(ndbyte+8191)/8192
		   call mtskre(tapeid,ndblke,iskip,result)
		   if (result .ne. 0 .or. iskip .ne. ndblke) then
			type *,'Tape skip error',result
			call mtmess(result,'MTSKRE',string)
			type *,string
			stop
		   endif
		endif
		ifile = ifile + 1
	 enddo
c	 type *,nfskip,' files skipped over within the cluster.'
	else
c	 type *,'No data files skipped over within the cluster.'
	endif
	lrfdisp = .TRUE.
c                                                                 
     
c		Setting up to start copying
c
c	type *,'ifile now = ',ifile
c
c		Now copy the data
c
200	continue
	If (lrfdisp) then
	    type *, 'Reading files...'
	    lrfdisp = .FALSE.
	Endif
	call mtread(tapeid,n2read,buffer,nbytes,result)
	if (result .eq. 3) then
	   iclust=iclust+1
	   ifile=1
	   nfskip = fnew - ifile - 1
	   if (nfskip .LT. 0) nfskip = 0
	   if (rmode .eq. 0 .and. iclust .ge. cluend
     1		.and. ifile .gt. filend) goto 500
	   goto 300
	endif
201	if (result .ne. 0 .or. nbytes .ne. n2read) then
	   type *,'Tape header read error',result
	   call mtmess(result,'MTREAD',string)
	   type *,string
	   stop
	endif
	call fhedr0(header,72,ltype,bitpix,nax,naxes,nend,0,
     1		ierr)
	if (ierr .eq. 1 .and. ltype .and. nax .eq. 2 .and.
     1		nend .gt. 0) then
	   if (lname) then
c		use filename given by user
	      lset=.true.
	      ind=index(filename,space)
	      if (ind .eq. 0) then
		type *,'Could not make suitable filename'
		stop
	      endif
	      ind = ind - 1
	      write(nfstr, 904) iclust, ifile
904	      format(i2.2,i4.4)
	      file = filename(1:ind) // nfstr // '.fts'

	   else
c		use filename in file
	      lset=.false.
	      do i=1,nend
c		Write(*,1622) i,header(i)
1622		Format(i3,':',a75)
		if (header(i)(1:8) .eq. comment) then
		   ind=index(header(i),diskfile)
		   if (ind .gt. 0) then
		     do j=ind+22,72
			nj=j
			if (header(i)(j:j) .ne. space) goto 290
		     enddo
		   endif
		   ind=index(header(i),diskfil2)
		   if (ind .GT. 0) then
			do j = ind + 17, 79
			   nj = j
			   if (header(i)(j:j) .NE. space) goto 290
			enddo
		   endif
		   nj=0
290		   if (nj .ne. 0) then
			filename=header(i)(nj:)
c			Write(*,1623) filename
1623			Format(' Full filename: ',a60)
		   	ind=index(filename,brack)
		     	if (ind .gt. 0) then
			   file=filename(ind+1:)
		     	else
			   file=filename
		     	endif
c			Write(*,1638) file
1638			Format(' dir stripped: ',a60)
c				check for old 9 character file names
c				(before 14 Sept 1995) and change
c				if needed.
			ind2 = index(file, dot)
			If (ind2 .EQ. 10) then
c				9 character file name
			     If ((file(2:2) .GE. '0') .AND.
     &				 (file(2:2) .LE. '1')) then
c					9 character file name with
c					2 character numerical month
				Read(file(2:3), 1624) imm
1624				Format(i2)
				tfile = file(1:1)
				Write(tfile(2:), 1625) imm
1625				Format(Z1.1)
				tfile = tfile(1:2) // file(4:)
				file = tfile
			    Endif
			Endif
		     	lset=.true.
		  endif
		endif
	      enddo
	      If (.NOT. lset) then
c		    filename was not in header, try to make one up
		Call GFnam(header, filename, istat)
		If (istat .EQ. 1) then
		    file = filename
		Else
		    file=junk
		Endif
		lset = .true.

	      Endif
	   endif
c	   Write(*,1627) file
1627	   Format(' Filename selected: ',a60)
	   lfblank = index(file, '.DAT')
	   If (lfblank .GT. 0) then
		file(lfblank:(lfblank+3)) = '.FTS'
	   Endif
c	   Write(*,1628) file
1628	   Format(' FITS filename: ',a60)
	   If (odir .NE. ' ') then
		ldblank = index(odir, ' ')
		ldblank = ldblank - 1
		lfblank = index(file, ' ')
		lfblank = lfblank - 1
c		Call STR$TRIM(rstring, odir, ldblank)
c		Call STR$TRIM(rstring, file, lfblank)
	        ffnam = odir(1:ldblank)//file(1:lfblank)
	   Else
	        ffnam = file
	   Endif
c	   Write(*,1620) ffnam
1620	   Format(' Output filename: ',a60)
c
	   nhblk=(nend*80+2879)/2880
	   ndbyte=naxes(1)*naxes(2)
	   if (bitpix .eq. 16) ndbyte =ndbyte*2
	   ndblk=(ndbyte+2879)/2880
	   ndblke=(ndbyte+8191)/8192
c	   type *,'nhblk = ', nhblk,' ndblke = ', ndblke
c	   type *,'Ready to read image records'
	   do i=1,ndblke
	     call mtread(tapeid,n2read,buffer(1+nhblk*720+(i-1)*2048),
     1		nbytes,result)
	     if (result .ne. 0 .or. nbytes .ne. n2read) then
		type *,'Tape read error for Exabyte block',i
		call mtmess(result,'MTREAD',string)
		type *,string
	     endif
	   enddo
	else
	   type *,'Error during interpretation of header',ierr
	   type *,' in cluster and file number',iclust,ifile
	   type *,'FITS type, bitpix, # axes'
	   type *,ltype,bitpix,nax
	   type *,'Naxis1, Naxis2, # header lines'
	   type *,naxes(1),naxes(2),nend
	   type *,'Program stops'
	   stop
	endif
c
	if (lset) then
 	   open (unit=2,name=ffnam,type='new',disp='save',
     1		access='direct',recordsize=720,
     2		initialsize=ifilsize,err=91000)
       	   do i=1,nhblk+ndblk
	      write (2'i) (buffer(k+(i-1)*720), k=1,720)
       	   enddo
 	   close (unit=2)
	   nimage = nimage + 1
	else
	   type *,'File name not setup - file not opened'
	endif
c
c		Get next file from list
	If (rmode .EQ. 0) then

c		type *,'now comparing file numbers'
c		type *,'iclust = ',iclust,' ifile = ',ifile
		if ((iclust .lt. cluend) .or. (ifile .lt. filend)) then
			nfskip = 0
			nskip = 0
			goto 190
		endif
		if ((iclust .eq. cluend .and. ifile .ge. filend) .or.
     1			(iclust .GT. cluend)) goto 500
	Else
		Read(3,1600,end=500) cnew,fnew
c		type *,'Next image--cluster:',cnew,' file:',fnew
		nskip = cnew - iclust
		if (cnew .NE. iclust) then
			nfskip = fnew - 1
			ifile = 0
		else
			nfskip = fnew - ifile - 1
		endif
		if (nfskip .LT. 0) nfskip = 0
c		type *,'nskip = ',nskip,' nfskip = ',nfskip
		goto 190
	Endif
c
c
300	Continue
c		Comes here if cluster changes
	If (rmode .EQ. 1 .AND. cnew .EQ. iclust
     1		.AND. fnew .EQ. ifile) then
c		OK, read file
		lrfdisp = .TRUE.
		goto 200
	Else If (rmode .EQ. 0) then
		lrfdisp = .TRUE.
		goto 200
	Else
		type *,'Unexpected cluster change--Stopping'
	Endif
c
c
500	type *, nimage,' images read from tape'
	type *, 'Done.'
	stop
91000	type *,'Error while attempting to open file on disk'
	type *,'Exabyte Cluster and file numbers',iclust,ifile
	type *,'Program exits.'
	stop
	end
c
c	Subroutine GFnam	try to guess filename for Eyecom files
c
	Subroutine GFnam(header, filename, istat)
	Character*80 header(144), filename
	Integer istat
	Integer bitpix, nax, naxes(2), nend, ierr, i, imon
	Character*8 tobs, obstype, dobs, obsdate
	Character*3 months(12)
	Data tobs /'TYPE-OBS'/
	Data dobs /'DATE-OBS'/
	Data months /'JAN','FEB','MAR','APR','MAY','JUN',
     1	             'JUL','AUG','SEP','OCT','NOV','DEC'/
c
	istat = 1
	obstype = ' '
	obsdate = ' '
	Call fhedr0(header,72,ltype,bitpix,nax,naxes,nend,0,

     1	    ierr)
	If (ierr .NE. 1 .OR. (.NOT. ltype) .OR. nax .NE. 2 .OR.
     1			nend .LE. 0) then
	    istat = 0
	    Return
	Endif
	Do i = 1, nend
	    If (header(i)(1:8) .EQ. tobs) obstype = header(i)(12:19)
	    If (header(i)(1:8) .EQ. dobs) obsdate = header(i)(12:19)
	Enddo
	If (obsdate .NE. ' ' .AND. obstype .NE. ' ') then
	    If (obsdate(1:1) .EQ. ' ') obsdate(1:1) = '0'
	    If (obsdate(4:4) .EQ. ' ') obsdate(4:4) = '0'
	    Read(obsdate, 1000) imon
1000	    Format(3x,i2)
	    filename = obstype(1:1)//months(imon)
	    filename = filename(1:4)//obsdate(1:2)
	    filename = filename(1:6)//'001.FTS'
	Else
	    istat = -1
	Endif
	Return
	End