c	Program EXDIRWT		Write the directory for an Exabyte VMG image
c				tape to disk.
c
c	This program operates by reading the header from each image file
c	on the tape and writing a FORTRAN unformatted record for each one.
c	The file containing these records is then written to disk, and a
c	summary of the tape contents is also written to disk.
c
c	11-Jan-90	JRV	first release
c	15-Jan-90	JRV	added cluster summary
c	16-Jan-90	JRV	improved tape error handling, add command
c				line parameter for tape name
c	01-Feb-90	JRV	added kludge to handle some bad date and
c				time formats from "snapwl"--will be fixed.
c	25-Mar-90	JRV	added check for blank tape and header error
c				counter
c	13-Jun-90	JRV	modify for SUNCUB
c	30-Oct-90	JRV	modify for logical tape drive name
c	29-Nov-90	JRV	catch additional doppler obstype
c	14-May-91	JRV	additional information in cluster
c				summary
c	26-July-91	JRV	corrected error counter
c	12-June-92	JRV	increase max no. of obs. groups,
c				add more error checking
c	17-July-92	JRV	add special handling of the date
c				00/00/00 -- set to 1/1/68 (before
c				observatory existed)
c	23-Sep-92	JRV	improve observation type handling
c	09-Aug-93	JRV	more obs types
c	08-Nov-94	JRV	more obs types
c
c	The file containing the records is handled as a FORTRAN indexed
c	(ISAM) file.  The primary key is the cumulative image number.
c	The secondary key is the object name.
c
c	The cumulative image number is the number of the image on the tape,
c	starting at 1 (first cluster, first file).  Cluster and file numbers
c	also start at 1.
c
c	The software will handle up to 32767 files per tape (about 7.6 Gbytes)
c	which should be sufficient for the Exabyte tapes.
c
c	The record contains:
c	cumulative image number		integer*4	pos 1:4, key 0
c	cluster number			integer*4	pos 5:8
c	file number in cluster		integer*4	pos 9:12
c	bits per pixel			integer*4	pos 13:16
c	object name			character*8	pos 17:24, key 1
c	type of observation		character*1	pos 25
c	empty space			character*3	pos 26:28
c	number of frames		integer*4	pos 29:32
c	x offset (arcseconds)		integer*4	pos 33:36
c	y offset (arcseconds)		integer*4	pos 37:40
c	Julian date			real*8		pos 41:48
c	pointer to next observation	integer*4	pos 49:52
c	of same type and number of
c	frames	in this cluster
c	(NULL pointer means no more
c	files of this type.)
c
c	Declarations
	character*80 header(144),string,filnam,file,junk,temp
	character*80 fil2,tapenam
	integer*4 buffer(128000)
	equivalence (buffer,header)
	character*6 tape
	integer*4 tapeid,result
	integer clustart,cluend,filstart,filend
	integer*4 lstr, interflg
	integer*4 scc,sff,ecc,eff,smm,sdd,syy
	integer*4 emm,edd,eyy, maxclust, tlflag
	integer*4 errcnt, nttblk, nbleft, npleft
	Character*8 ststr,etstr
	Character*48 thiscomm
	Real*8 sldd,eldd
	logical ltype,leot,lname,datac
	integer*4 bitpix,nax,naxes(10)
	Integer*4 NULL, MAXGRP
	parameter (NULL = 0)
	parameter (MAXGRP = 1000)
c
c		needed for command line parameters
	character*80 argc(20)
	integer com_args, n_args
c
	data tape /'EXDRV:'/
	data leot/.false./
c
c	Structure for data records
	Structure /DATREC/
		Integer*4 cumnum
		Integer*4 clustnum
		Integer*4 filenum
		Integer*4 bitpix
		Character*8 objnam
		Character*1 typobs
		Character*3 empty
		Integer*4 nframes
		Integer*4 x
		Integer*4 y
		Real*8 jd
		Integer*4 nextobs
	End Structure
c
	Structure /TOBS/
		Character*8 objnam
		Integer*4 nframes
		Integer*4 refx
		Integer*4 refy
		Integer*4 firstobs
		Integer*4 lastobs
		Real*8 firstjd
		Real*8 lastjd
		Integer*4 nobs
		Character*48 comment
		Character*1 type
	End Structure
c
	Structure /CLUST/
		Integer*4 yy
		Integer*4 mm
		Integer*4 dd
		Integer*4 nfile
		Integer*4 nerror
		Character*2 inst
	End Structure
c
c	Declare instances of structures
	Record /DATREC/ thisimage
	Record /TOBS/ obsgroup(MAXGRP)
	Record /CLUST/ fcluster(50)
c
	Real*8 lcdd
	Integer*4 lastgroup, knownreg, refdist, i, j, ibptr
	Data refdist /10000/
c
	Record /DATREC/ clustimage(32000)
c
c
	type *, 'EXDIRWT 	09-November-94 version'
	type *, '		Writes Exabyte tape directory'
c
c		Process command line
	tapenam = ' '
	n_args = com_args(argc)
	If (n_args .EQ. 1) then
		interflg = 0
		tapenam = argc(1)
		lstr = index(tapenam,' ') - 1
	Else If (n_args .GT. 1) then
		type *,'Too many arguments'
		stop
	Else
		interflg = 1
	Endif
c		Get name of tape
	If (tapenam .EQ. ' ') then
	   Write(*,1350)
1350	   Format('$Enter name of tape: ')
	   Read(*,1351) tapenam
1351	   Format(a80)
	   lstr = index(tapenam,' ') - 1
	   If (lstr .EQ. 0) then
		type *,'Bad tape name'
		stop
	   Endif
	Endif
c
	Call ZUpper(tapenam)
	filnam = tapenam(1:lstr)//'.TDR'
	fil2 = tapenam(1:lstr)//'.TS'
	Write(*,1410) filnam
1410	Format(' Directory file name will be: ',a40)
c
c		Number of clusters on tape
	If (interflg .EQ. 1) then
	   Write(*,1411)
1411	   Format('$Read to EOT (Y/N)? ')
	   Read(*,1351) string
	   If (string(1:1) .EQ. 'N' .OR. string(1:1) .EQ. 'n') then
		Write(*,1412)
1412		Format('$Number of clusters to read: ')
		Accept *,maxclust
		If (maxclust .LT. 1 .OR. maxclust .GT. 100) then
			type *,'Cannot read that many'
			stop
		Endif
	   Else
		maxclust = 0
	   Endif
	Else
	   maxclust = 0
	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		Rewind tape
	type *,'Rewinding tape...'
	call mtrewi(tapeid,result)
	if (result .ne. 0) then
	    type *,'Error trying to rewind',result
	    stop
	endif
c
c		Set up to start reading
c
	errcnt = 0
	iclust = 1
	ifile = 0
	icfile = 0
	nttblk = 0
	n2read = 8192
	lastgroup = 0
	tlflag = 0
	type *, 'Reading files...'
c
c		Now read the file headers
c
c		Read the next header
c
200	continue
	call mtread(tapeid,n2read,buffer,nbytes,result)
c	Check for EOF
	if (result .eq. 3) goto 300
	If (nbytes .NE. n2read) then
	   type *,'Tape header read attempt record length mismatch'
	   errcnt = errcnt + 1
	   If (errcnt .GT. 10) then
		Type *,'Too many header read errors.  Stopping.'
		If (icfile .GT. 0) then
			tlflag = 1
			Goto 400
		Else
			Type *,'This tape appears to be blank!'
			Stop
		Endif
	   Endif
	   type *,'Will try to continue.'
	   goto 200
	Endif
210	if (result .ne. 0) then
	   type *,'Tape header read error',result
	   call mtmess(result,'MTREAD',string)
	   type *,string
	   stop
	endif
c	type *,'Reading cluster: ',iclust,' file: ',ifile
	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
c		header data are good
c		Read rest of file
	   ifile = ifile + 1
	   icfile = icfile + 1
	   ndbyte=naxes(1)*naxes(2)
	   if (bitpix .eq. 16) ndbyte =ndbyte*2
	   ndblke=(ndbyte+8191)/8192
	   Call MTSkRe(tapeid,ndblke,nrecr,result)
	   if (result .ne. 0 .or. nrecr .ne. ndblke) then
		type *,'Tape read error for image data record skip'
		call mtmess(result,'MTREAD',string)
		type *,string
	   endif
	   nttblk = nttblk + nrecr + 1
	else
c		Bad header data
	   type *,'Error during interpretation of FITS header',ierr
	   type *,' in cluster and file number',iclust,(ifile+1)
c	   type *,'FITS type, bitpix, # axes'
c	   type *,ltype,bitpix,nax
c	   type *,'Naxis1, Naxis2, # header lines'
c	   type *,naxes(1),naxes(2),nend
	   type *,'Will try to continue--this file skipped'
	   fcluster(iclust).nerror = fcluster(iclust).nerror + 1
	   goto 200
	endif
c
c
c		Get additional header info for directory
	thisimage.cumnum = icfile
	thisimage.clustnum = iclust
	thisimage.filenum = ifile
	thisimage.bitpix = bitpix
	thisimage.nextobs = NULL
	thisimage.empty = '   '
	Call XHInfo(header, thisimage, thiscomm, nend, datac)
c
c		Get cluster info
	If (ifile .EQ. 1) then
		Call Julian(1, fcluster(iclust).yy, fcluster(iclust).mm,
     1			lcdd, thisimage.jd)
		fcluster(iclust).dd = lcdd
		If (datac) then
		  fcluster(iclust).inst = 'DC'
		Else
		  fcluster(iclust).inst = 'QX'
		Endif
		fcluster(iclust).nerror = 0
	Endif
c
	fcluster(iclust).nfile = ifile
c
c		Handle pointer setups
c		Is this a region we know about?
c		A known region is a region with same position (within
c		tolerance), obs type and number of frames as a region in the
c		list.
	knownreg = 0
	do i = 1, lastgroup
		if   (thisimage.typobs  .EQ. obsgroup(i).type
     2		.AND. thisimage.nframes .EQ. obsgroup(i).nframes)
     3			then
		  relpos = ((thisimage.x - obsgroup(i).refx)*
     1		           (thisimage.x - obsgroup(i).refx)) +
     2			   ((thisimage.y - obsgroup(i).refy)*
     3			   (thisimage.y - obsgroup(i).refy))
		  if (relpos .LT. refdist) then
			knownreg = i
			goto 410
		  endif
		endif
	enddo
c		Known region
410	Continue
	if (knownreg .NE. 0) then
c		First observation for this date--reset position
	  if (thisimage.jd - obsgroup(knownreg).lastjd
     1		.GT. 0.75) then
		obsgroup(knownreg).refx = thisimage.x
		obsgroup(knownreg).refy = thisimage.y
	  endif
c		Reset object name if needed
	  if (obsgroup(knownreg).objnam .NE. thisimage.objnam) then
		obsgroup(knownreg).objnam = thisimage.objnam
		obsgroup(knownreg).comment = thiscomm
	  endif
c		Set pointer in the last observation record
	  clustimage(obsgroup(knownreg).lastobs).nextobs = icfile
	  obsgroup(knownreg).lastobs = icfile
	  obsgroup(knownreg).lastjd = thisimage.jd
	  obsgroup(knownreg).nobs = obsgroup(knownreg).nobs + 1
c
	else
c		New region--set position
	  lastgroup = lastgroup + 1
	  If (lastgroup .GT. MAXGRP) then
		Type *,'Too many observation groups.  Stopping.'
		lastgroup = lastgroup - 1
		tlflag = 1
		Goto 400
	  Endif
	  obsgroup(lastgroup).objnam  = thisimage.objnam
	  obsgroup(lastgroup).type    = thisimage.typobs
	  obsgroup(lastgroup).nframes = thisimage.nframes
	  obsgroup(lastgroup).refx    = thisimage.x
	  obsgroup(lastgroup).refy    = thisimage.y
	  obsgroup(lastgroup).comment = thiscomm
	  obsgroup(lastgroup).firstobs = icfile
	  obsgroup(lastgroup).lastobs = icfile
	  obsgroup(lastgroup).nobs    = 1
	  obsgroup(lastgroup).firstjd = thisimage.jd
	  obsgroup(lastgroup).lastjd  = thisimage.jd
	endif
c
	clustimage(icfile) = thisimage
c		Write record for testing
c	Write(*,1110) clustimage(icfile).cumnum,
c     1		clustimage(icfile).clustnum,
c     2		clustimage(icfile).filenum
c1110	Format(' Image: ',i6,' Cluster: ',i3,' File: ',i3)
c	Write(*,1120) clustimage(icfile).bitpix,
c     1		clustimage(icfile).objnam,
c     2		clustimage(icfile).typobs
c1120	Format(' Bits: ',i4,' Region: ',a8,' Type: ',a1)
c	Write(*,1130) clustimage(icfile).nframes,
c     1		clustimage(icfile).x,
c     2		clustimage(icfile).y
c1130	Format(' Frames: ',i5,' X: ',i4,' Y: ',i4)
c	Write(*,1140) clustimage(icfile).jd,
c     1		clustimage(icfile).nextobs
c1140	Format(' JD: ',f20.5,' Next: ',i6)
	Goto 200
c
c		Reached end of cluster
300	Continue
	type *,'EOF Read'
	If (fcluster(iclust).nerror .NE. 0) then
	    iaff = (fcluster(iclust).nerror + 29) / 30
	    type *,fcluster(iclust).nerror,' errors found'
	    type *,'affects approximately ',iaff,' images'
	Endif
c		Check for second EOF
	call mtread(tapeid,n2read,buffer,nbytes,result)
	if (result .eq. 3) then
		goto 400
c		If second EOF, finished with directory, write to tape
c		Else,
	else if (result .eq. 0) then
		If (maxclust .NE. 0 .AND.
     1			iclust .EQ. maxclust) goto 400
		iclust = iclust + 1
		ifile = 0
		GoTo 210
	Else
c		error
	Endif
c
c		Finished with directory
400	Continue
c	type *,'Found second EOF, skipping back one'
c	call mtskfi(tapeid,-1,iskip,result)
c	if (result .ne. 0) then
c		dt=secnds(t)
c		type *,'Error return from file skip back',result
c		type *,'This skip command number',isk
c		type *,'Time taken',dt,' seconds'
c		stop
c	endif
c
c		Write Directory to Disk as Indexed File
	type *,'Writing directory to disk'
	Open(unit=3,file=filnam,status='NEW',organization='INDEXED',
     1		access='KEYED',recordtype='VARIABLE',
     2		form='UNFORMATTED',recl=13,
     3		key=(1:4:integer,17:24:character),iostat=ios,err=251)
	goto 252
251	type *, 'Error opening indexed file.  Status = ',ios
	stop
c
252	continue
	do i = 1, icfile
		write(3,err=351,iostat=ios) clustimage(i)
	enddo
	goto 352
351	Continue
	type *,'Error writing disk file.  Status = ', ios
	close(3)
	stop
352	Continue
	close(3)
c
c	write(*,1341)
c1341	Format('$Continue? ')
c	read(*,1342) string
c1342	Format(a80)
c	If(string(1:1) .NE. 'Y' .AND. string(1:1) .NE. 'y')
c     1		stop
c
c
c		Write Directory to Tape
c	NOTE: This code may not work correctly and has been commented out
c	on 1/11/90 by John Varsik
c
c	type *,'Start writing data to tape'
c	type *,'Will write data for ',icfile,' images'
c	ntapblk = (icfile+169) / 170
c	type *,'Number of tape blocks to write: ',ntapblk
c	nrecrem = mod(icfile, 170)
c	do j=1, ntapblk
c	   if (j .EQ. ntapblk .AND. nrecrem .NE. 0) then
c		n2write = nrecrem * 48
c		type *,'Writing ',nrecrem,' data records'
c	   Else
c		n2write = 8160
c		type *,'Writing       170 data records'
c	   endif
c	   ibptr = 1 + (170 * (j-1))
c	   type *,'Starting to write ',n2write,' bytes from record: ',
c    1		ibptr
c	   do k = 1, (n2write/48)
c		l = ibptr + k - 1
c		write(*, 1501) clustimage(l).cumnum,
c    1			clustimage(l).clustnum,
c    2			clustimage(l).filenum, clustimage(l).bitpix,
c    3			clustimage(l).objnam,  clustimage(l).typobs,
c    4			clustimage(l).nframes, clustimage(l).x,
c    5			clustimage(l).y,       clustimage(l).jd,
c    6			clustimage(l).nextobs
c1501		format(1x,i6,i3,i5,i3,1x,a8,1x,a1,i5,i4,i4,f15.5,1x,i6)
c	   enddo
c	   call mtwrit(tapeid,n2write,clustimage(ibptr),nbtran,result)
c	   if (result .NE. 0 .OR. nbtran .NE. n2write) then
c		call mtmess(result, 'MTWRIT', string)
c		type *,'Write error return',result,string
c		type *,'Number of bytes to write: ',n2write,
c    1			'Number actually written: ',nbtran
c	   else
c		type *,'directory block written ', j
c	   endif
c	   if (result .eq. 4) leot=.true.
c	enddo
c	if (leot) then
c	   type *,'Logical EOT has been found writing directory'
c	endif
c
c	call mtweof(tapeid,result)
c	type *, 'Writing EOF'
c	   if(result .ne. 0) then
c		call mtmess(result,'MTWEOF',string)
c		type *,'Error writing EOF',string
c	   endif
c	call mtweof(tapeid,result)
c	type *, 'Writing second EOF'
c	   if(result .ne. 0) then
c		call mtmess(result,'MTWEOF',string)
c		type *,'Error writing EOF',string
c	   endif
c	type *,'Tape writing done in',secnds(dtime),' secs.'
c		Write tape summary file to disk
	type *,'Writing summary'
	If (tlflag .NE. 0) Type *,'Directory incomplete due to an error'
	Open(unit=3,file=fil2,status='NEW',
     1		access='SEQUENTIAL')
c		write header for file
	Write(3,1210) tapenam
1210	Format('     Exabyte Tape Name: ',a8)
	Write(3,1250)
c
	Write(3,1220) iclust
1220	Format(' Number of Clusters: ',i4)
	Write(3,1250)
c
	If (tlflag .NE. 0) Write(3,1211)
1211	Format(41(1H*)/' DIRECTORY INCOMPLETE DUE TO ERRORS'/41(1H*))
c		Cluster Summary
	Write(3,1271)
1271	Format('        Cluster Summary')
	Write(3,1272)
1272	Format(' Cluster    Date        Instrument  Images   Errors')
	Write(3,1250)
	Do i = 1, iclust
	  iyy = fcluster(i).yy - 1900
	  If (fcluster(i).nerror .EQ. 0) then
	    Write(3,1273) i,fcluster(i).mm,fcluster(i).dd,iyy,
     1		fcluster(i).inst,fcluster(i).nfile
1273	    Format(i6,4x,i2.2,'/',i2.2,'/',i2.2,11x,a2,5x,i5)
	  Else
	    iaff = (fcluster(i).nerror + 30) / 31
	    Write(3,1284) i,fcluster(i).mm,fcluster(i).dd,iyy,
     1		fcluster(i).inst,fcluster(i).nfile,
     2		fcluster(i).nerror,iaff
1284	    Format(i6,4x,i2.2,'/',i2.2,'/',i2.2,11x,a2,5x,i5,
     1		3x,i3,' errors affecting ',i3,' images')
	  Endif
	Enddo
c
	Write(*, 1282) iclust, icfile
1282	Format(' Total clusters: ',i3,' Total images: ',i5)
	Write(3, 1282) iclust, icfile
	If (maxclust .EQ. 0) then
	    nbleft = 250000 - (nttblk + (iclust * 61))
	    npleft = nbleft / 31
	    Write(*, 1283) npleft
1283	    Format(' This tape has room left for ',i6,' 8-bit images')
	    Write(3, 1283) npleft
	Endif
c
	Write(3,1250)
1221	Format(20x,'Region Types and Positions')
	Write(3,1230)
1230	Format('   Region  Obs   Itg   Num of    Position   '
     1		'           Comment')
	Write(3,1240)
1240	Format(23x,'Images',4x,'X',5x,'Y')
	Write(3,1250)
1250	Format(70('-'))
c
c		Write one line for each region observed
	Do i = 1, lastgroup
		Write(3,1260) obsgroup(i).objnam, obsgroup(i).type,
     1			obsgroup(i).nframes,obsgroup(i).nobs,
     2			obsgroup(i).refx,obsgroup(i).refy,
     3			obsgroup(i).comment
1260		Format(2x,a8,3x,a1,3x,i4,2x,i6,2x,i5,1x,i5,2x,a34)
	Enddo
	Write(3,1250)
	Write(3,1261)
1261	Format(20x,'Dates and File Numbers')
	Write(3,1262)
1262	Format('   Region  Obs   Itg ',3x,' Start  ',1x,'   End  ',
     1		14x,'Times')
	Write(3,1263)
1263	Format(24x,'Cls File Cls File',7x,'Start',16x,'End')
	Write(3,1250)
	Do i = 1, lastgroup
		scc = clustimage(obsgroup(i).firstobs).clustnum
		sff = clustimage(obsgroup(i).firstobs).filenum
		ecc = clustimage(obsgroup(i).lastobs).clustnum
		eff = clustimage(obsgroup(i).lastobs).filenum
		Call Julian(1,syy,smm,sldd,obsgroup(i).firstjd)
		Call Julian(1,eyy,emm,eldd,obsgroup(i).lastjd)
		Call Timestr(sldd,ststr)
		Call Timestr(eldd,etstr)
		sdd = sldd
		edd = eldd
		syy = syy - 1900
		eyy = eyy - 1900
		Write(3,1267) obsgroup(i).objnam, obsgroup(i).type,
     1			obsgroup(i).nframes,scc,sff,ecc,eff,
     2			smm,sdd,syy,ststr,emm,edd,eyy,etstr
1267		Format(2x,a8,3x,a1,3x,i4,3x,i3,i5,1x,i3,i5,2x,
     1			i2.2,'/',i2.2,'/',i2.2,1x,a8,2x,
     2			i2.2,'/',i2.2,'/',i2.2,1x,a8)
	Enddo
	Write(3,1250)
c		Close the file
	Close(3)
	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
	Subroutine XHInfo(header,dirrec,comment,nend,datac)
c	Structure for data records
	Structure /DATREC/
		Integer*4 cumnum
		Integer*4 clustnum
		Integer*4 filenum
		Integer*4 bitpix
		Character*8 objnam
		Character*1 typobs
		Character*3 empty
		Integer*4 nframes
		Integer*4 x
		Integer*4 y
		Real*8 jd
		Integer*4 nextobs
	End Structure
c
	Character*80 header(nend)
	Character*48 comment
	Integer nend
	Logical datac
	Record /DATREC/ dirrec
	Integer i, ih, imin, isec, iy, id, m
	Character*8 keywd, datestr, timestr, wavstr
	Character*8 typeobs
	Character*80 hedlin
	Real*8 d
c
	datac = .FALSE.
	dirrec.nframes = 1
	do i = 1, nend
	  hedlin = header(i)
	  keywd = hedlin(1:8)
	  If (keywd .EQ. 'CRVAL1  ')
     1     	Read(hedlin(11:30),1001) dirrec.x
1001	  Format(i20)
	  If (keywd .EQ. 'CRVAL2  ')
     1     	Read(hedlin(11:30),1001) dirrec.y
	  If (keywd .EQ. 'OBJECT  ') then
		Read(hedlin(12:19),1002) dirrec.objnam
1002	  	Format(a8)
		Read(hedlin(33:80),1003) comment
1003		Format(a48)
	  Endif
	  If (keywd .EQ. 'TYPE-OBS') then
		Read(hedlin(12:19),1002) typeobs
c		Write(*,1009) typeobs
1009		Format(' Obs-type: ',a8)
	  Endif
	  If (keywd .EQ. 'TIME-OBS')
     1		Read(hedlin(12:19),1002) timestr
	  If (keywd .EQ. 'DATE-OBS')
     1		Read(hedlin(12:19),1002) datestr
	  If (keywd .EQ. 'FRAMES  ')
     1		Read(hedlin(11:30), 1001) dirrec.nframes
	  If (keywd .EQ. 'BIAS    ') datac = .TRUE.
c		Used Datacube system
	  If (keywd .EQ. 'WAVELNTH')
     1		Read (hedlin(12:19), 1002) wavstr
	Enddo
c
	if (typeobs .EQ. 'VMG     ') then
		dirrec.typobs = 'V'
	else if (typeobs .EQ. 'VMG-Q   ') then
		dirrec.typobs = 'Q'
	else if (typeobs .EQ. 'VMG-U   ') then
		dirrec.typobs = 'U'
	else if (typeobs .EQ. 'DOPPL   '.OR.
     1		 typeobs .EQ. 'DOPPLER ') then
		dirrec.typobs = 'D'
	else if (typeobs .EQ. 'VMG W/L '.OR.
     1		 typeobs .EQ. 'VMG  W/L'.OR.
     2		 typeobs .EQ. 'VMG-I   ') then
		dirrec.typobs = 'I'
c		Bug in DISKMG from Quantex system
	else if (typeobs .EQ. 'DIRECT  ') then
		dirrec.typobs = 'J'
	else if (typeobs .EQ. 'LINE MAP') then
		dirrec.typobs = 'X'
	else if (typeobs .EQ. 'FULLDISK') then
		dirrec.typobs = 'H'
		if (wavstr .EQ. 'KLINE   ') dirrec.typobs = 'K'
		if (wavstr .EQ. 'W.L.    ') dirrec.typobs = 'W'
	else if (typeobs .EQ. 'REGION') then
		dirrec.typobs = 'F'
		if (wavstr .EQ. 'HALF    ') dirrec.typobs = 'C'
		if (wavstr .EQ. 'HACL    ') dirrec.typobs = 'C'
	else
		dirrec.typobs = typeobs(1:1)
	endif
c
	Read(datestr,'(i2,1x,i2,1x,i2)',err=500) id, m, iy
	If (id .EQ. 0 .AND. m .EQ. 0 .AND. iy .EQ. 0) then
	    id = 1
	    m = 1
	    iy = 68
	Endif
	d = dfloat(id)
	iy = iy + 1900
	Read(timestr,'(i2,1x,i2,1x,i2)',err=500) ih, imin, isec
	d = d + ((dfloat((ih * 60) + imin) + dfloat(isec)/60) /1440.0d0)
	Call Julian(0, iy, m, d, dirrec.jd)
	Goto 510
500	Continue
c		Kludge to get around bad format on some "G" images
c		from current version of snapwl
	dirrec.jd = 0
510	Continue	
	Return
	End
c
c		Convert to/from Julian dates (copied from 11/44 BBSO
c		Fortran library)
	Subroutine Julian(mode, iy, m, d, djul)
	Real*8 d, djul
	Integer mode, iy, m
	Real*8 n,z,sa,a,b,k,e,p,f,d0,sm,y,c
c
	If (mode .EQ. 0) then
c		Convert calendar date to Julian date
	  sm = m
	  y = iy
	  If (sm .LE. 2.5) then
		y = y - 1.0
		sm = sm + 12.0
	  Endif
	  a = dint(y/100.0)
	  b = 2.0 - a + dint(a/4.0)
	  If (y - 1582.0) 139, 130, 140
130	  If (m - 10) 139, 132, 140
132	  If (d .GE. 15.0) GoTo 140
139	  b = 0.0
140	  p = 365.25*y
	  If (y .LT. 0.0) p = p - 0.75
	  djul = dint(p) + dint(30.6001d0*(sm+1.0d0))+d+1720994.5d0+b
	  Return
	Endif
	If (mode .EQ. 1) then
c		Convert Julian date to calendar date
	  n = djul + 0.5
	  z = dint(n)
	  f = dmod(n,1.0d0)
	  a = z
	  If (z .GE. 2299161.0) then
		sa = dint((z - 1867216.25)/36524.25)
		a = z+1+sa-dint(sa/4.0)
	  Endif
	  b = a + 1524.0
	  c = dint((b - 122.1)/365.25)
	  k = dint(365.25 * c)
	  e = dint((b - k)/ 30.6001)
	  d0 = b - k - dint(30.6001 * e) + f
	  sm = e
	  If (e .GE. 13.5) sm = e - 12.0
	  sm = sm - 1.0
	  iy = jidint(c)
	  If (sm .GE. 2.5) iy = c - 1
	  iy = iy - 4715
	  m = sm
	  d = d0
	  Return
	Endif
	End
c
	Subroutine timestr(realday, tstring)
	Real*8 realday
	Character*8 tstring
c
	Integer ihh,imm,iss,idd
	Real*8	dtmp
c
	idd = realday
	dtmp = realday - idd	
	dtmp = 24.0 * dtmp
	ihh = dtmp
	dtmp = dtmp - ihh
	dtmp = 60.0 * dtmp
	imm = dtmp
	dtmp = dtmp - imm
	dtmp = 60.0 * dtmp
	iss = dtmp
	Write(tstring,1000) ihh,imm,iss
1000	Format(i2.2,':',i2.2,':',i2.2)
	Return
	End