C+
c TO COMPILE (remember to recompile for different systems (VMS vs AXP) :    
c		FOR/EXT HAXIM, TAPEFUN, ECHOIN, FSEARCH, HXISLIB_SUB, -
C			IMAGX, SORTING, IPEELB, DECOMP, ISWAP
c
C
C MACRO NOTE: 	       DECOMP.FOR now holds the marco routines ISDBTW
c		       and DECEBS, converted to FORTRAN.
c		       ISWAP.FOR holds the marco routine ISWAP, converted
c		       to FORTRAN.  
c		       All three routine use to be located in HAXIMASS.MAR
C
c
c TO LINK :
c		LIN HAXIM, TAPEFUN, ECHOIN, FSEARCH, HXISLIB_SUB, -
C		    IMAGX, SORTING, IPEELB, DECOMP, ISWAP
c
c
c TO RUN  : 	RUN HAXIM
c
C		(NOTE: creates a HIMSEL file -  HIM*.*)
c		       One record, (7680 bytes = 3840 words = 1920 longwords),
c		       is one image.)
c
c
c TAPE NOTE : 	Since this code is only intended to make disk files,
c		to be used by the IDL widgets HXIS display software,
c		none of the tape routines have been tested on an
c		VAX AXP system.  These tape routines would have made
c		HIMSEL tapes.  I haven't seen a HIMSEL tape in 5 years
c		so I don't think this is any great loss.
c		The tape code is still in place, just commented out, so
c		it could be restored and tested.  I think that 
c		HXISLIB.HIM is now called HIMSEL.LIB.  
C
c
C NAME:
C	HAXIM
C PURPOSE:
C	Decompression of raw HXIS production data.
C	Produces data files in HIMSEL format, either on disk or tape
C CALLING SEQUENCE:
C	run HAXIM at DCL prompt or select from menu of command procedure
C	HXIS.COM
C SUBROUTINES/FUNCTIONS:
C	ASSN,CASK,DATE*,DECIMH,DECIM0,DECIM1,HXISLIB_LIST,HXISLIB_SORT,
C	HXISLIB_TIME,IASK,IMAGX,INDEXX,ITRIM,LASK,LIB$GET_SYMBOL*,
C	LIB$SET_SYMBOL*,LIB$WAIT*,REWIND,SELECT_IPD,SKIPF,TREAD,TWRITE,WEOF
C	(* = system routines)
C COMMON BLOCKS:
C	common /IMAGE/ IOUT,INB,INAD
C RESTRICTIONS: -> Logical HIMSELLIB and symbols LIB__MF_TAPEUNIT,HAXIM_SOURCE,
C			HAXIM_DESTIN
C	If the decompressed images are written to a tape, a tape unit should
C	be mounted and it's name stored in the global DCL symbol
C	LIB_MF_TAPEUNIT prior to running the program.
C	The DCL symbols HAXIM_SOURCE (source directory of IPD files) and
C	HAXIM_DESTIN (destination directory of output file in case of output to
C	disk) should exist.
C	The logical HIMSELLIB should be assigned to the HIMSEL library file 
c	HXISLIB.HIM.
C	(HXIS.COM takes care of all this).
C SIDE EFFECTS:
C	The DCL symbols HAXIM_SOURCE and HAXIM_DESTIN are updated.
C PROCEDURE:
C	The original production data should be present on disk (copied from
C	Exabyte tape). As input files HAXIM searches for files using a wild
C	card specification IPDDOY*.*. Files matching the wild card
C	specification are processed sequentially. To assure the proper
C	chronological order the files names should reflect the start time of
C	the data on the file, i.e. the full file names should be something like
C	IPDDOY_HHMM*.* (HH and MM are hours and minutes of the start time).
C
C	Output is to disk or tape. If output is to disk the output file will
C	be given the name HIMDOY_HHMM.DUR, where DOY_HHMM defines the start
C	time of the data. The file name extension reflects duration (in minutes)
C	or is set to '000' (if night time images are excluded). Output to tape
C	can be to a fresh tape or may be appended to an existing HIMSEL tape.
C	IMPORTANT:
C	appending to an existing tape works properly ONLY IF the contents of
C	the tape is listed in the HIMSELLIB library (this information is used
C	to skip to the supposed end of volume).
C   
C	In one run of HAXIM all data in the specified period are extracted. If
C	the option to exclude night time images is not used all data are dumped
C	in one output file. If night time images are excluded, each day time
C	part of successive orbits is dumped into a separate output file.
C
C	Explanation of the array IOUT as it is written to the output medium
C	(integer*2 unless indicated otherwise; spares are set to zero).
C	Subroutines where entries are set or changed are indicated.
C
C	IOUT(1)			FPSS bit (0 for s/c night; 1 for s/c day) (added DEC-90 by PH)		IMAGX
C	IOUT(2) = 0		ICAL #   ????
C	IOUT(3) = 0		IPOS #   ????
C	IOUT(4)			File number (only for tape output)					HAXIM
C	IOUT(5)			Spare
C	IOUT(6)			Image number (1 for first image on file, etc.)				HAXIM
C	IOUT(7:11)		Character*10; Date on which image was read from IPD tape		HAXIM
C	IOUT(12)		Image time: number of hours since 31-DEC-1979 00:00:00 UT		IMAGX
C	IOUT(13:14)		Real*4; Image time: number of seconds elapsed in hour IOUT(12)		IMAGX
C	IOUT(15)		Spare (used to indicate flagged images in data analysis programs)
C	IOUT(16)		Number of 40 byte minor frames containing the image			IMAGX
C	IOUT(17)		Spare
C	IOUT(18) = 10000	Data quality (in 0.01 %): cheating (value is not changed anywhere)	HAXIM
C	IOUT(19:20)		Real*4; image index from on board micro					DECIMH
C	IOUT(21)		Version of ROM/RAM program						DECIMH
C	IOUT(22)		Image duration (in 0.125 secs)						DECIMH
C	IOUT(23)		High voltage setting of detector 1					DECIMH
C	IOUT(24)		Idem for detector 2							DECIMH
C	IOUT(25)		Flare start word							DECIMH
C	IOUT(26)		Flare present word							DECIMH
C	IOUT(27)		Calibration mode							DECIMH
C	IOUT(28)		Internal belt warning word						DECIMH
C	IOUT(29)		HV internal ON/OFF during belt						DECIMH
C	IOUT(30)		Flare mode (0,1 or 2)							DECIMH
C	IOUT(31)		Total counts in band 1 (coarse+fine+slit)				DECIMH
C	IOUT(32:71)		Housekeeping								IMAGX
C	IOUT(72:77)		Energy band settings (the defaults may be changed by DECIMH)	HAXIM,DECIMH
C	IOUT(78:91)		Nominal energy band boundaries (in 0.01 keV)				HAXIM
C	IOUT(92)		Number of overflows						DECIM0,DECIM1
C	IOUT(93:156)		Overflow adresses (maximum 64)						DECIM1
C	IOUT(157:158)		real*4; pitch (in degrees)						IMAGX
C	IOUT(159:160)		real*4; yaw (in degrees)						IMAGX
C	IOUT(161:162)		real*4; roll (in degrees)						IMAGX
C	IOUT(163:192)		spare (some are used in data analysis programs)
C	IOUT(193:768)		counts in band 1 (3.5-5.5 keV) for all 576 pixels		DECIM0,DECIM1
C	IOUT(769:1344)		idem band 2 (5.5-8 keV)						DECIM0,DECIM1
C	IOUT(1345:1920)		idem band 3 (8-11.5 keV)					DECIM0,DECIM1
C	IOUT(1921:2496)		idem band 4 (11.5-16 keV)					DECIM0,DECIM1
C	IOUT(2497:3072)		idem band 5 (16-22 keV)						DECIM0,DECIM1
C	IOUT(3073:3648)		idem band 6 (22-30 keV)						DECIM0,DECIM1
C	IOUT(3649:3662)		real*4; ANE(7) rates						DECIM0,DECIM1
C	IOUT(3663:3678)		monitors ??							DECIM0,DECIM1
C	IOUT(3679:3806)		data transfer pulses ???					DECIM0,DECIM1
C	IOUT(3807:3840)		spare
C
C	The 576 pixels for each energy band are assigned as follows:
C	1-128		coarse field of view (CFOV)
C	129-432		fine field of view (FFOV)
C	433-472		Y-slits
C	473-512		Z-slits
C	513-528		high energy monitor (HEM)
C	529-544		drift field monitor (calibration source)
C	545-560		amplitude and alignment monitor
C	561-576		unused
C MODIFICATION HISTORY:
C	Adapted from the PDP-11 FORTRAN version (NOV/DEC-90 by PH)
c
c	MAR 94 - Elaine Einfalt (HSTX) - removed this HIMSEL tape references,
c		 and commented out the EQUIVALENCE (SECIA,IA) reference for 
c		 AXP alignment reasons.
C-
	program HAXIM
	implicit integer*2 (I-N)
	parameter	(NDIM=20,	! Dimension of IFILE. Not used, but don't remove
     &			NMAX=100,	! Maximum number of IPD files
     &			LIBLENG=5000)	! Max. number of records in HXISLIB.HIM
	integer*4	LUOUT,LSIZE,STATUS		! Has to be integer*4 for TAPEFUN routines
	real*4		TIMELIST(NMAX),	! Start times on IPD files
     &			TSORT(LIBLENG)	! Tape numbers in HXISLIB.HIM (used to assign number to new tape)
	integer*2	INB(2108),	! Compressed image data (read in IMAGX, decompressed in DECIM* routines) 
     &			IOUT(3840) /6*0,5*0,6*0,10000,3822*0/,		!Final image
     &			ITL(256) /256*8224/,		!For HIMSEL tape header file
     &			IDEBS(72:77) /259,1031,2056,2313,2570,2827/, ! Default nergy band setting (???)
     &			KEV(14) /280,350,430,500,550,595,640,700, 
     &				 800,1150,1600,2200,3000,32767/,
     &			INXS(LIBLENG),			! KEV: channel energy boundaries (in 0.01 kev)
     &			IFILE(NDIM),			! Not used, but don't remove
     &			NFM(0:2),			! Flare mode image counters
     &			LULIB/1/,			! Unit number HXISLIB.HIM
     &			IA(11)			! Stored in HXISLIB.HIM
	byte		DOD(10),			! Creation data (equivalenced to ITL(7:11))
     &			BOUT1(3840),BOUT2(3840),	! Equivalenced to 1st and 2nd half of IOUT
     &			BOUT3(3840)			! Scratch array
	equivalence 	(DOD,IOUT(7)),(KEV,IOUT(78)), (BOUT1,IOUT(1)), 
     &			(BOUT2,IOUT(1921)), (SEC,IOUT(13))

ceee	MAR 94 - Elaine Einfalt (HSTX) - removed this equivalence because it 
ceee				deals with HIMSEL tapes and caused an AXP 
ceee				alignment warning.
ceee	equivalence	(SECIA,IA(4))

	logical 	TAPE,LTEST,LFPSS/.TRUE./,KEEP_GOING
	character 	SOURCEDIR*40, DESTINDIR*40, 
     &			OUTFILE*15/'HIM138_2460.060'/,FILELIST(NMAX)*20,
     &			STIME*12/'000:00:00:00'/,ETIME*12/'000:00:00:00'/,
     &			CTAPE*5,CDUM*3
	common /IMAGE/ 	IOUT,INB,INAD

	call DATE(DOD)			! Creation date of output file (equivalenced to IOUT(7:11))

	write (*,*) ' '
	write (*,*) '---------------------------     HAXIM      -------------------------------------'
	write (*,*) 'The meaning of life, the universe and everything (in a restricted sense): '
	write (*,*) 'Source:                  directory where the input production files are located'
	write (*,*) 'Destination:             directory where the disk output file is to be placed'
	write (*,*) 'Append to existing HIMSEL tape: can be done, but be careful (see instructions)'
	write (*,*) 'Start day (DOY in 1980): day of the year (in 1980) of requested data set'
	write (*,*) 'Hour and minute:         time of day on the start day where copying should start'
	write (*,*) 'Duration (minutes):      the total duration of the data set (guess what units)'
	write (*,'(1X,A,/)') '--------------------------------------------------------------------------------'

	I = 0
	call LIB$GET_SYMBOL('HAXIM_SOURCE',SOURCEDIR,I)		! Get default for source directory
	if (I .eq. 0) SOURCEDIR = 'no default'			! HAXIM_SOURCE does not exist
	call CASK('Source',SOURCEDIR)

	I = 0
	call LIB$GET_SYMBOL('LIB__MF_TAPEUNIT',CTAPE,I)
	if (I .eq. 0) CTAPE = ' '				! LIB__MF_TAPEUNIT does not exist

	if (CTAPE .eq. ' ') then				! Output to hard disk

	    TAPE = .FALSE.
	    I = 0
	    call LIB$GET_SYMBOL('HAXIM_DESTIN',DESTINDIR,I)	! Get default for destination directory
	    if (I .eq. 0) DESTINDIR = SOURCEDIR			! HAXIM_DESTIN does not exist
	    call CASK('Destination',DESTINDIR)
								! Deposit selected destination directory
	else							! Output to tape

ceee	    HIMSEL tapes are gone
ceee
ceee	    TAPE = .TRUE.
ceee	    call ASSN(CTAPE,LUOUT,STATUS)			! Assign unit to tape drive
ceee	    write (CDUM,'(I3)') LUOUT
ceee	    call CWRITE('TAPE DRIVE '//CTAPE//' ASSIGNED TO UNIT '//CDUM)
ceee	    LTEST = .FALSE.
ceee	    call LASK('Append to existing HIMSEL tape',LTEST)
ceee	    if (LTEST) then					! Appending to existing HIMSEL tape
ceee
ceee		LSIZE = 512
ceee		call TREAD(LUOUT,ITL,LSIZE,STATUS)		! Read tape header
ceee		write (CDUM,'(I3)') ITL(3)			! Tape number
ceee		call CWRITE('APPENDING TO HIMSEL TAPE'//CDUM)
ceee		NFILE = NDIM					! Get listing from HXISLIB.HIM
ceee		call HXISLIB_LIST(.TRUE.,.FALSE.,ITL(3),0,0,0,0,0,NFILE,IFILE)
ceee
ceee		call CWRITE('SKIPPING TO END OF VOLUME')	! Use NFILE to move to end of volume
ceee		LSIZE = NFILE					! Skip to start of last tape file
ceee		call SKIPF(LUOUT,LSIZE,STATUS)
ceee		if (STATUS .ne. 1) then
ceee		    call CWRITE('>>> ERROR SKIPPING TO LAST TAPE FILE:  REWIND AND EXIT')
ceee		    call REWIND(LUOUT,STATUS)
ceee		    stop ' '
ceee		endif
ceee		do I=1,3840					! Save first half of IOUT in BOUT3
ceee		    BOUT3(I) = BOUT1(I)
ceee		end do
ceee		LSIZE = 3840
ceee		call TREAD(LUOUT,BOUT1,LSIZE,STATUS)		! Initialize tape file counter IOUT(4)
ceee		if (STATUS .ne. 1) then 			! Check status
ceee		    write (*,'(20X,A,I5,/,20X,A,I5)') 'Error status code            =',STATUS,
ceee     &			'Failed skipping to tape file =',NFILE
ceee		    call CWRITE('>>> TAPE POSITION LOST:  REWIND AND EXIT')
ceee		    call REWIND(LUOUT,STATUS)
ceee		    stop ' '
ceee		end if
ceee		if (IOUT(4) .ne. NFILE) then			! Check tape position
ceee		    write (*,'(20X,A,I5,2(/,20X,A,I5))')
ceee     &			'Failed skipping to tape file =',NFILE,'Now at tape file     	  =',IOUT(4)
ceee		    call CWRITE('>>> TAPE POSITION LOST:  REWIND AND EXIT')
ceee		    call REWIND(LUOUT,STATUS)
ceee		    stop ' '
ceee		end if
ceee		call SKIPF(LUOUT,1,STATUS)			! Skip last file to end of volume
ceee		if (STATUS .ne. 1) then
ceee		    call CWRITE('>>> ERROR SKIPPING TO END OF VOLUME:  REWIND AND EXIT')
ceee		    call REWIND(LUOUT,STATUS)
ceee		    stop ' '
ceee		end if
ceee		call CWRITE('END OF VOLUME REACHED')
ceee
ceee		J = IOUT(4)
ceee		do I=1,3840					! Restore first half of IOUT, but ...
ceee		    BOUT1(I) = BOUT3(I)
ceee		end do
ceee		IOUT(4) = J					! .. don't loose tape file counter
ceee
ceee		IA(1) = ITL(3)					! Tape number for HXISLIB.HIM
ceee
ceee		open (LULIB,file='HIMSELLIB',status='OLD',access='DIRECT')
ceee		LIBREC = 1
ceee		read (LULIB'LIBREC,iostat=I) J
ceee		do while (I .eq. 0)
ceee		    LIBREC = LIBREC+1
ceee		    read (LULIB'LIBREC,iostat=I) J
ceee		end do
ceee		LIBREC = LIBREC-1				! # of records in HXISLIB.HIM
ceee
ceee	    else
ceee
ceee		open (LULIB,file='HIMSELLIB',status='OLD',access='DIRECT')
ceee		LIBREC = 1
ceee		read (LULIB'LIBREC,iostat=I) J
ceee		do while (I .eq. 0)
ceee		    if (LIBREC .gt. LIBLENG) stop 'ARRAYS TSORT AND INXS DIMENSIONS TOO SMALL'
ceee		    TSORT(LIBREC) = J				! HIMSEL tape numbers
ceee		    LIBREC = LIBREC+1
ceee		    read (LULIB'LIBREC,iostat=I) J
ceee		end do
ceee		LIBREC = LIBREC-1				! # of records in HXISLIB.HIM
ceee
ceee		IUP = 0						! Empty library
ceee		if (LIBREC .gt. 0) then
ceee		    INXS(1) = 1
ceee		    if (LIBREC .gt. 1) call INDEXX(1,LIBREC,1,LIBREC,TSORT,INXS) ! Sort tape numbers
ceee		    ILOW = 0
ceee		    I = 1
ceee		    IUP = nint(TSORT(INXS(I)))
ceee		    do while (IUP-ILOW .le. 1 .and. I .lt. LIBREC)
ceee			ILOW = IUP
ceee		    	I = I+1
ceee			IUP = nint(TSORT(INXS(I)))
ceee		    end do
ceee		    if (IUP-ILOW .gt. 1) IUP = ILOW
ceee		end if
ceee		ITL(3) = IUP+1		! Assign lowest unused nr to new tape
ceee		write (CDUM,'(I3)') ITL(3)
ceee		call CWRITE('NEW HIMSEL TAPE IS ASSIGNED NUMBER '//CDUM)
ceee		do I=7,11					! Creation date HIMSEL tape
ceee		    ITL(I) = IOUT(I)
ceee	    	end do
ceee
ceee		LSIZE = 512					! Write tape header file
ceee		call TWRITE(LUOUT,ITL,LSIZE,STATUS)		! Header contains tape nr and creation date
ceee	    	if (.not. STATUS) then
ceee		    call CWRITE('>>> ERROR WRITING TAPE HEADER:  REWIND AND EXIT')
ceee		    call REWIND(LUOUT,STATUS)			! Rewind
ceee	            stop ' '
ceee		end if
ceee		call WEOF(LUOUT,STATUS)				! Close tape header file with EOF marker
ceee
ceee		IOUT(4) = 0					! Initialize tape file counter
ceee		IA(1) = ITL(3)					! Tape number for HXISLIB.HIM
ceee
ceee	    end if

	end if

	call LASK('Only day time images',LFPSS)			! Exclude data in s/c night
	JMAGX = -1						! Tells IMAGX to open a IPD file
	IDAY = 138
	RM = 0
	RDUR = 60
	KEEP_GOING = .FALSE.

35	if (.not. KEEP_GOING) then			! Define new data period

	    call IASK('Start day (DOY in 1980) [0=STOP]',IDAY)	! Select start day
	    if  (IDAY .lt. 1) then

ceee		HIMSEL tapes are gone
ceee
ceee		if (TAPE) then				! Write second EOF (EOT) and rewind tape unit
ceee		    close (LULIB)
ceee		    call HXISLIB_SORT			! Sort HXISLIB.HIM
ceee		    NFILE = NDIM			! Get listing from HXISLIB.HIM
ceee		    call HXISLIB_LIST(.TRUE.,.FALSE.,ITL(3),0,0,0,0,0,NFILE,IFILE)
ceee		    call CWRITE('MARK END OF VOLUME AND REWIND')
ceee		    call WEOF(LUOUT,STATUS)
ceee		    call REWIND(LUOUT,STATUS)
ceee		end if

		call CWRITE('*****  EXIT HAXIM  *****')	! This is the only proper exit
		stop ' '

	    end if


	    call SELECT_IPD(IDAY,SOURCEDIR,NMAX,NFILE,FILELIST,TIMELIST)

	    IH = nint(TIMELIST(1))			! Select start time on first IPD file
	    call IASK('Hour',IH)
	    call FASK('Minute',RM)
	    call FASK('Duration (minutes)',RDUR)

	    IH0 = IDAY*24+IH	! (IH0,ISEC0) is the origin (T=0) for TSTART,TSTOP,TIMG
	    ISEC0 = nint(RM*60)
	    TSTART = 0.
	    TSTOP = RDUR*60.				! Stop time (in secs since T=0)

	    DT = IH+RM/60.
	    do I=1,NFILE				! Adapt TIMELIST to new time origin
		TIMELIST(I) = TIMELIST(I)-DT
	    end do

 	    IFS = NFILE					! Select first IPD file
	    do while (IFS .gt. 1 .and. TSTART .lt. TIMELIST(IFS))
	        IFS = IFS-1
	    end do

	    KEEP_GOING = .TRUE.

	end if

	call IMAGX(JMAGX,SOURCEDIR,FILELIST(IFS))	! Get image

	if (JMAGX .lt. 0) then				! EOF or OPEN ERROR
	    IFS = IFS+1					! Try next file
	    if (IFS .gt. NFILE) then
		call CWRITE('NO MORE IPD FILES')
		KEEP_GOING = .FALSE.			! Cancel this run
	    end if
	    go to 35
	end if

	TIMG = (IOUT(12)-IH0)*3600.+SEC-ISEC0
	if (TIMG .gt. TSTOP) then			! Picked the wrong file
	    call CWRITE('>>> IMAGE TIME LATER THAN STOP TIME')
	    JMAGX = -3					! Tells IMAGX to close the open IPD file
	    KEEP_GOING = .FALSE.			! Cancel this run
	    go to 35
	end if

	if (LFPSS .and. IOUT(1) .ne. 1) then		! Search for start of s/c day
	    do while (IOUT(1) .ne. 1 .and. TIMG .le. TSTOP)
		call IMAGX(JMAGX,SOURCEDIR,FILELIST(IFS))
		if (JMAGX .eq. -1) then			! EOF encountered
		    IFS = IFS+1				! Try next file
		    if (IFS .gt. NFILE) then
			call CWRITE('NO MORE IPD FILES')
			KEEP_GOING = .FALSE.		! Cancel this run
		    end if
		    go to 35
		end if
		TIMG = (IOUT(12)-IH0)*3600.+SEC-ISEC0
	    end do
	    if (TIMG .gt. TSTOP) then
		call CWRITE('SKIPPED PAST STOP TIME DURING S/C NIGHT')
		JMAGX = -3				! Tell IMAGX to close the open IPD file
		KEEP_GOING = .FALSE.
		go to 35
	    end if
	end if

	do while (TIMG .lt. TSTART)			! Find first image after start time
	    call IMAGX(JMAGX,SOURCEDIR,FILELIST(IFS))	! Get next image from IPD file
	    if (JMAGX .eq. -1) then			! EOF encountered
		call CWRITE('>>> NO IMAGES BETWEEN START AND STOP TIME ON THIS IPD FILE')
		KEEP_GOING = .FALSE.
		go to 35				! Cancel this run
	    end if
	    TIMG = (IOUT(12)-IH0)*3600.+SEC-ISEC0
	end do

	if (JMAGX .lt. 0) then			! Safety belt: should not be possible
	    call CWRITE('>>> BAD NEWS: SOME STUPID FLAW IN THE LOGIC')
	    KEEP_GOING = .FALSE.
	    go to 35
	end if
						! First image found.
	do I=72,77				! Default settings may have been changed by DECIMH 
	    IOUT(I) = IDEBS(I)			! NOTE: the old HAXIM program did not do this !!!!!
	end do
	call DECIMH()				! Decompress header
c	if (IOUT(21) .eq. "17 .or. IOUT(30) .lt. 0 .or. IOUT(30) .gt. 2) go to 35  ! Reject image
	if (IOUT(21) .eq. '17'o .or. IOUT(30) .lt. 0 .or. IOUT(30) .gt. 2) go to 35  ! Reject image

	if (.not. TAPE) then			! Open output file on disk
	    if (LFPSS) then
		IM1 = SEC/60.
		IH1 = IM1/60.
		IM1 = IM1-IH1*60
		IH1 = IOUT(12)+IH1
		ID1 = IH1/24
		IH1 = IH1-ID1*24
		write (OUTFILE(4:6),'(I3.3)') ID1		! Output file name: DOY, ..
		write (OUTFILE(8:9),'(I2.2)') IH1		! .. and hours, ..
		write (OUTFILE(10:11),'(I2.2)') IM1		! .. and minutes, ..
		write (OUTFILE(13:15),'(I3.3)') 0
	    else
		write (OUTFILE(4:6),'(I3.3)') IDAY		! Output file name: DOY, ..
		write (OUTFILE(8:9),'(I2.2)') IH		! .. and hours, ..
		write (OUTFILE(10:11),'(I2.2)') IM		! .. and minutes, ..
		write (OUTFILE(13:15),'(I3.3)') min(999,nint(RDUR)) ! .. and duration (extension)
	    end if
	    LUOUT = 8						! 1920 longwords=3840 words
	    open (LUOUT,defaultfile=DESTINDIR,file=OUTFILE,status='NEW',access='DIRECT',recl=1920,iostat=I)
	    if (I .ne. 0) then
		call CWRITE('>>> ERROR OPENING DISK OUTPUT FILE '//DESTINDIR(1:ITRIM(DESTINDIR))//OUTFILE)
		call LIB$WAIT(2.)
		stop ' '
	    end if
	    call LIB$SET_SYMBOL('HAXIM_DESTIN',DESTINDIR(1:ITRIM(DESTINDIR)),2)
	    IOUT(4) = 1
	else					! If output is to tape, then ..
	    IOUT(4) = IOUT(4)+1			! .. increment output tape file counter
	end if
	IOUT(6) = 0				! Reset output image number counter

	NT = 0					! Initialize input file bookkeeping
	NFM(0) = 0
	NFM(1) = 0
	NFM(2) = 0

	do while (KEEP_GOING) 			! While stop time not yet reached and still data left
	    if (IOUT(30) .eq. 0) then
		call DECIM0()			! Flare-mode 0
	    else if (IOUT(30) .eq. 1) then
		call DECIM1()			! Flare-mode 1
	    else if (IOUT(30) .eq. 2) then
		call DECIM1()			! Flare-mode 2
	    end if

	    IOUT(6) = IOUT(6)+1				! Current image number
	    if (.not. TAPE) then
		write (LUOUT'IOUT(6)) IOUT		! Write to disk
	    else
		LSIZE = 3840
		call TWRITE(LUOUT,BOUT1,LSIZE,STATUS)	! Write first half of IOUT to tape
		LSIZE = 3840
		call TWRITE(LUOUT,BOUT2,LSIZE,STATUS)	! Write second half of IOUT to tape
	    end if

	    NT = NT+1					! # images read from input file
	    if (NT .eq. 1) call HXISLIB_TIME(IOUT(12),SEC,STIME)	! Start time string
	    NFM(IOUT(30)) = NFM(IOUT(30))+1		! # flare mode I images read from input
	    if (IOUT(6) .eq. 1) then			! If this is the first image to output
		IA(2) = IOUT(4)				! Tape number
		IA(3) = IOUT(12)			! Start time
		SECIA = SEC				! SECIA equivalenced to IA(4:5)
		call HXISLIB_TIME(IA(3),SECIA,STIME)	! Start time string
		call CWRITE('FIRST (DAYTIME) IMAGE FOUND AT '//STIME//' UT')
		write (*,'(7X,A)') 'IPD file       # HIM      Start UT        Stop UT    #Img(FMo0    1    2)'
		IA(7) = 0				! Count rate fine+coarse+slit
		if (IOUT(22) .gt. 0) IA(7) = nint(8.*IOUT(31)/IOUT(22))
		IA(8) = 0
		IA(9) = 0
		IA(10) = 0
		IA(11) = 0
	    end if
	    IHSTOP = IOUT(12)
	    SECSTOP = SEC			! Save for calculation of IA(6)
	    call HXISLIB_TIME(IHSTOP,SECSTOP,ETIME)	! Stop time string
	    if (IOUT(22) .gt. 0) IA(7) = max(IA(7),nint(min(32767.,8.*IOUT(31)/IOUT(22))))
	    IA(8) = IA(8)+1			! # images written to output file
	    I = 9+IOUT(30)
	    IA(I) = IA(I)+1			! # flare mode I images written to output

	    do while (KEEP_GOING)

		call IMAGX(JMAGX,SOURCEDIR,FILELIST(IFS)) ! Get next image from IPD file
		if (JMAGX .ge. 0) then
		    TIMGOLD = TIMG
		    TIMG = (IOUT(12)-IH0)*3600.+SEC-ISEC0 ! Image time (in secs since T=0)
		endif

		if (JMAGX .lt. 0 .and. IFS .ge. NFILE) then ! EOF or open error; all IPD files scanned

		    KEEP_GOING = .FALSE.	! Output file completed
c		    IOUT(21) = "17		! Needed to escape outer DO WHILE loop
		    IOUT(21) = '17'o		! Needed to escape outer DO WHILE loop

		else if (JMAGX .eq. -2) then	! Open error, more IPD files to go

		    IFS = IFS+1			! Next input file on FILELIST

		else if (JMAGX .eq. -1) then	! EOF encountered, more IPD files to go

		    if (NT .ne. 0) then
			write (*,'(1X,A,I6,2(3X,A),3X,4(I4,A))')
     &				FILELIST(IFS),IOUT(4),STIME,ETIME,NT,'(',NFM(0),'-',NFM(1),'-',NFM(2),')'
		    else
			write (*,'(1X,A,I6,3X,A)') FILELIST(IFS),IOUT(4),'no data'
		    end if
		    NT = 0			! Initialize input file bookkeeping variables
		    NFM(0) = 0
		    NFM(1) = 0
		    NFM(2) = 0
		    IFS = IFS+1			! Next input file on FILELIST

		else if (TIMG .gt. TSTOP .or. (LFPSS .and. IOUT(1) .eq. 0)) then ! Image not needed

		    KEEP_GOING = .FALSE.	! Output file completed
c		    IOUT(21) = "17		! Needed to escape outer DO WHILE loop
		    IOUT(21) = '17'o		! Needed to escape outer DO WHILE loop

		else				! Image might be OK

		    do I=72,77			! Default settings may have been changed by DECIMH 
			IOUT(I) = IDEBS(I)	! NOTE: the old HAXIM program did not do this !!!!!
		    end do
		    call DECIMH()		! Decompress header
c		    if (IOUT(21) .ne. "17 .and. 		! Check version # and ...
		    if (IOUT(21) .ne. '17'o .and. 		! Check version # and ...
     &			IOUT(30) .ge. 0 .and. IOUT(30) .le. 2)	! .. flare mode
     &			KEEP_GOING = .FALSE.	! And IOUT(21) .ne. "17: escape from inner DO WHILE loop ...

		end if				! .. but stay inside outer DO WHILE loop: Write image to output

	    end do

c	    if (IOUT(21) .ne. "17) KEEP_GOING = .TRUE.	! Write image to output
	    if (IOUT(21) .ne. '17'o) KEEP_GOING = .TRUE.	! Write image to output

	end do

	if (NT .ne. 0) then
	    write (*,'(1X,A,I6,2(3X,A),3X,4(I4,A))')
     &		FILELIST(IFS),IOUT(4),STIME,ETIME,NT,'(',NFM(0),'-',NFM(1),'-',NFM(2),')'
	else
	    write (*,'(1X,A,I6,3X,A)') FILELIST(IFS),IOUT(4),'no data'
	endif

	if (TIMG .gt. TSTOP) then
	    call CWRITE('MOVED PAST STOP TIME')
	    JMAGX = -3						! Tells IMAGX to close the current IPD file
	else if (LFPSS .and. IOUT(1) .eq. 0) then
	    call CWRITE('MOVED INTO S/C NIGHT AT '//ETIME//' UT')
	    KEEP_GOING = .TRUE.
	else
	    call CWRITE('NO MORE IPD FILES')
	end if

	if (TAPE) then
	    call WEOF(LUOUT,STATUS)				! Closing EOF of last tape file
	    IA(6) = (IHSTOP-IA(3))*3600.+SECSTOP-SECIA		! File duration
	    LIBREC = LIBREC+1
	    write (LULIB'LIBREC) IA				! Update HXISLIB.HIM
	else
	    close (LUOUT)
	    call CWRITE('OUTPUT FILE ---> '//DESTINDIR(1:ITRIM(DESTINDIR))//OUTFILE)
	end if

	go to 35
	end
C ****
	subroutine SELECT_IPD(IDAY,SOURCEDIR,NMAX,NFILE,FILELIST,TIMELIST)

C  Selects the list of IPD files to be searched for data.
C  Input:	IDAY		integer*2; start day of requested day (used in wildcard specification)
C		SOURCEDIR	character*(*); directory where data files are located
C		NMAX		maximum number of permitted IPD files
C  Output:	NFILE		integer*2; number of files matching wild card
C		FILELIST	character*(*) array; file names of matching IPD files
C		TIMELIST	real*4 array; start times of data on IPD files (in hours on IDAY)
C Procedure:	A wildcard is constructed using the start day IDAY. All files located by the search
C		routine FSEARCH and succesfully opened are stored in FILELIST. The day following
C		the input date IDAY is also searched, in case the requested data extend past midnight.
C Calls:	CWRITE,FSEARCH,ISWAP,ITRIM,UTIME
C ***
	implicit integer*2 (I-N)
	character	FILELIST(NMAX)*(*),SUBSEARCH*9,CSEARCH*80,SOURCEDIR*(*),INFILE*80
	real*4		TIMELIST(NMAX)
	integer*2	LUIN/17/,ITFR(2),IUT(4)		! Time as read from IPD file and output by UTIME, resp.
	byte		MA(12)				! Reads fraction of record from IPD file
	equivalence	(IDY,MA(5)),(ITFR,MA(9))

	SUBSEARCH = 'IPD138*.*'

	write (SUBSEARCH(4:6),'(I3.3)') IDAY
	CSEARCH = SOURCEDIR(1:ITRIM(SOURCEDIR))//SUBSEARCH	! Wild card for selection IPD files
	call FSEARCH(1,CSEARCH,INFILE)
	if (INFILE .eq. ' ') then
	    write (SUBSEARCH(4:6),'(I3.3)') IDAY+1
	    CSEARCH = SOURCEDIR(1:ITRIM(SOURCEDIR))//SUBSEARCH
	    call FSEARCH(1,CSEARCH,INFILE)
	endif

	if (INFILE .eq. ' ' .and. index(SOURCEDIR,']') .eq. 0) then
	    write (SUBSEARCH(4:6),'(I3.3)') IDAY
	    CSEARCH = SOURCEDIR(1:ITRIM(SOURCEDIR))//':'//SUBSEARCH ! Try logical
	    call FSEARCH(1,CSEARCH,INFILE)
	    if (INFILE .eq. ' ') then
		write (SUBSEARCH(4:6),'(I3.3)') IDAY+1
		CSEARCH = SOURCEDIR(1:ITRIM(SOURCEDIR))//':'//SUBSEARCH
		call FSEARCH(1,CSEARCH,INFILE)
	    endif
	endif

	write (SUBSEARCH(4:6),'(I3.3)') IDAY
	if (INFILE .eq. ' ') then
	    call CWRITE('>>> NO IPD FILES IN '//SOURCEDIR(1:ITRIM(SOURCEDIR))//'FOR DOY '//SUBSEARCH(4:6))
	    call LIB$WAIT(2.)
	    stop ' '
	end if

	SOURCEDIR = INFILE(1:index(INFILE,']'))
	call LIB$SET_SYMBOL('HAXIM_SOURCE',SOURCEDIR(1:ITRIM(SOURCEDIR)),2)
					! Store source directory in global symbol

	NEXT_DAY = 0
	CSEARCH = SOURCEDIR(1:ITRIM(SOURCEDIR))//SUBSEARCH	! Wild card for selection IPD files
	call FSEARCH(1,CSEARCH,INFILE)
	if (INFILE .eq. ' ') then
	    call CWRITE('>>> NO IPD FILES MATCHING WILDCARD '//CSEARCH)
	    NEXT_DAY = 1
	    write (SUBSEARCH(4:6),'(I3.3)') IDAY+1
	    CSEARCH = SOURCEDIR(1:ITRIM(SOURCEDIR))//SUBSEARCH
	    call FSEARCH(1,CSEARCH,INFILE)
	    if (INFILE .eq. ' ') then
		call CWRITE('>>> NO IPD FILES MATCHING WILDCARD '//CSEARCH)
		stop ' '
	    end if
	end if

	NFILE = 0
	do while (INFILE .ne. ' ')
	    open (LUIN,file=INFILE,status='OLD',readonly,recordtype='VARIABLE',form='UNFORMATTED',iostat=I)

	    if (I .eq. 0) read (LUIN,iostat=I) J
	    if (I .eq. 0) read (LUIN,iostat=I) MA

	    if (I .eq. 0) then
		IDY = ISWAP(IDY)-365

		ITFR(1) = ISWAP(ITFR(1))
		ITFR(2) = ISWAP(ITFR(2))

		call UTIME(ITFR,IUT)
		I = index(INFILE,']')+1
		J = ITRIM(INFILE)
		if (I .gt. J) I = 1
		NFILE = NFILE+1
		FILELIST(NFILE) = INFILE(I:J)
		TIMELIST(NFILE) = (IDY-IDAY)*24+IUT(1)+IUT(2)/60.
		write (*,'(1X,I3,A,I3,2X,I2.2,A,I2.2,A,I2.2)') NFILE,')  '//INFILE(I:J)//' - Start time: DOY ',
     &			IDY,IUT(1),':',IUT(2),':',nint(IUT(3)+IUT(4)/1000.)
		close (LUIN)

		if (NFILE .gt. NMAX) return

		call FSEARCH(0,CSEARCH,INFILE)
		if (INFILE .eq. ' ' .and. NEXT_DAY .eq. 0) then
		    NEXT_DAY = 1
		    write (SUBSEARCH(4:6),'(I3.3)') IDAY+1
		    CSEARCH = SOURCEDIR(1:ITRIM(SOURCEDIR))//SUBSEARCH
		    call FSEARCH(1,CSEARCH,INFILE)
		end if
	    else
		I = index(INFILE,']')+1
		J = ITRIM(INFILE)
		if (I .gt. J) I = 1
		write (*,'(1X,A)') '***)  '//INFILE(I:J)//' - I/O error, file excluded'
	    end if

	end do
	return
	end
