C
C File_Sort
C
C	This subroutine is used to sort ASCII format files according to
C	fields defined in the common block SORT.  
C	By default record fault is used and if the sort is
C	successful, the old file is deleted and the new file kept.
C	If the sort fails the new file is deleted and the old kept.
C
C		CALL File_Sort(Cfile,Iterminal,Istatus)
c
C 	where
C		Cfile		C*(*)		File name to sort
C		Iterminal	I*2		Terminal type (>= 96=>VT100)
C		Istatus		I*2		Sort exit status
C						=  1  Success
C						= -1  Failure
C
C	Required Common Blocks:
C
C	CHARACTER*1	    Cesc,Cbell,Cnull	! Provides information for
C	CHARACTER*4	    Cbold, Cnorm	! terminal video attributes
C	INTEGER*2	    Key_Info		! Controls sort
C	COMMON	/SORT/	    Key_Info(41)	!  Room for 10 sort keys
C	COMMON	/Constants/ Cesc,Cbell,Cnull,	!
C			    Cbold,Cnorm		!
C
C	If it is not desired to sort, an immediate return is done
C	if Key_Info(1) = 0.  If files are to be sorted, the 
C	screen is erased, and a message displayed that sorting
C	is taking place.  
C
C	The format of a sort control array should be a list of up to 
C	41 numbers.  The first number is a number from 0-10.  0 means no 
C	sorting to be done.  1-10 represent the number of keys to sort on. 
C	For each key to sort on, a block of 4 numbers in Info_Key
C	must exist.
C
C	#_of_keys,Data_type,Ascend/Descend,Start_Pos,Length,......
C
C		   <-- the required 4 words of info/key -->
C
C	The data is returned in an I*2 array of dimension 41 which is passed
C	in the common block SORT.  Information on how to set up the blocks of
C	numbers may be obtained in the VAX SORT manual, Section 3.2.2.
C
C	The **BUG** fix relates is documented in the VAX March 1983 System
C	dispatch and allows TAG sorts to be used.
C	
C-
	SUBROUTINE File_Sort(Cfile,Iterminal,Istatus)

	IMPLICIT	INTEGER*4 (A - Z)		!
	CHARACTER*1	Cesc,Cbell,Cnull		!
	CHARACTER*4	Cbold,Cnorm			! Video attributes
	CHARACTER*(*)	Cfile				! Data file to use
	CHARACTER*30	In_File, Out_File		! In/out file names
	CHARACTER*132	Ctmp				! Temporary string
	BYTE		SORT_TYPE   /2/			! Tag sort
	BYTE		Work_FIles  /2/			! Number of work files
	BYTE		SOR$GB_SOR_TYP			! ** bug fix **

	LOGICAL*1	Lkill_New_File	       /.FALSE./! Do not delete output
	INTEGER*2	Key_Info			! Sort keys
	INTEGER*4	Isize	/10/			! Initial file size
	INTEGER*4	Ists				!
	INTEGER*4	Ioptions			!
	INTEGER*4	SOR$V_Stable			!

	EXTERNAL	SOR$V_STABLE			!
	EXTERNAL 	SOR$GB_SOR_TYP			! ** bug fix **

	COMMON	/Constants/	Cesc,Cbell,Cnull,Cbold,Cnorm
	COMMON	/SORT/	Key_Info(41)			! Sort Key_Info
C
C .. Define Sort Parameters
C
	Key_Info(1)=1					! Just 1 sort key	
	Key_Info(2)=1					! Character data
	Key_Info(3)=0					! in assending order
	Key_Info(4)=1					! Starting position
	Key_Info(5)=9					! Last position


	ILEN=LEN(CFILE)					! Length of file name

	CALL String_Length(Cfile,Ilen)			!
	Ctmp='Sorting file '//Cbold//Cfile(1:Ilen)//Cnorm!
	CALL String_Length(Ctmp,I)			!
	Ipos=(80-I)/2					!
	CALL PAGE	
	CALL SCREEN(Ctmp(1:I),Iterminal,10,Ipos,0)	!


C ..
C ..	Open input and create output files
C ..
	Lkill_New_File=.FALSE.				! Do not del out file
	SOR$BG_SOR_TYP=SORT_TYPE			! Set TAG sort
	Status = SOR$PASS_FILES (Cfile, Cfile,,,,,,50)	! Set the file names
	IF (.NOT. Status) 		THEN		! If Sort init fails
	  WRITE(*,10) Cbold,Cfile(1:Ilen),Cnorm, Status	!
10	  FORMAT(' DTC_Sort_File -- File ',A,A,A,
     -		 ' could not be opened,',/,
     -           '                  Status = ',Z10)
	  GOTO 9900
	END IF

C	Describe key and initialize work area	!
c	Ioptions=%LOC(SOR$V_STABLE)		! Stable sort
	Ioptions=1				! **** bug fix ****
	Status = SOR$INIT_SORT (KEY_INFO,,Isize,WORK_FILES,
     -			SORT_TYPE,,,Ioptions)	!
	IF (.NOT. Status) 		THEN	! If Sort init fails
	  WRITE(*,20) Status			!
20	  FORMAT(' DTC_Sort_File -- Work area initialization failed',/,
     -           '                  Please check current disk quota.',/,
     -		 '                  Sort Error Status = ',Z10)
	  GOTO 9900
	END IF

C	Sort records				!
	Status = SOR$SORT_MERGE ()		!
	IF (.NOT. Status) 		THEN	! If Sort init fails
	  WRITE(*,30) Status			!
30	  FORMAT(' DTC_Sort_File -- Files could not be sorted.',/,
     -     '                  Please check your disk quota allocation',/,
     -	   '                  Sort Error Status = ',Z10)
	  GOTO 9900
	END IF					!

C	Close files and clean up work area	!
	Status = SOR$END_SORT ()		!
	IF (.NOT. Status) 		THEN	! If Sort init fails
	  WRITE(*,40) Status			!
40	  FORMAT(' DTC_Sort_File -- Sorted files can not be closed',/,
     -		 '                  Sort Error Status= ',Z10)
	  GOTO 9900
	END IF					!

C ..
C ..	Keep the new file, delete the old one
C ..
	OPEN(	UNIT	= 1,			! Open new file
     -		NAME	= Cfile,		!
     -		TYPE	= 'OLD',		!
     -		DISPOSE = 'KEEP',		!
     -		ERR	= 8000)			! Never delete it

	OPEN(	UNIT	= 2,			! Open previous version
     -		NAME	= Cfile//';-1',		!
     -		TYPE	= 'OLD',		!
     -		DISPOSE = 'DELETE',		! Delete the blighter
     -		ERR	= 8010)			! If can't open file
	CLOSE(UNIT = 1,ERR=8020)		!
	CLOSE(UNIT = 2,ERR=8030)		! By, By old file
	Istatus=1				!
	GOTO 9996				!

8000	Ctmp='DTC_Sort_File -- New data file '//Cbold//
     -	     Cfile//Cnorm//' can not be opened.'
	GOTO 8150				!
8010	Ctmp='DTC_Sort_File -- Old data file '//Cbold//
     -	     Cfile//Cnorm//' can not be opened for delete.'
	GOTO 8150				!
8020	Ctmp='DTC_Sort_File -- New data file '//Cbold//
     -	     Cfile//Cnorm//' can not be closed.'
	GOTO 8150				!
8030	Ctmp='DTC_Sort_File -- Old data file '//Cbold//
     -	     Cfile//Cnorm//' can not be closed for delete.'
	GOTO 8150				!

8040	Ctmp='DTC_Sort_File -- New data file '//Cbold//
     -	     Cfile//Cnorm//' can not be opened for delete.'
	Lkill_New_File=.TRUE.			! Try another way
	GOTO 8170				!
8050	Ctmp='DTC_Sort_File -- Old data file '//Cbold//
     -	     Cfile//Cnorm//' can not be opened.'
	GOTO 8170				!
8060	Ctmp='DTC_Sort_File -- New data file '//Cbold//
     -	     Cfile//Cnorm//' can not be closed for delete.'
	Lkill_New_File=.TRUE.			! Try another way
	GOTO 8170				!
8070	Ctmp='DTC_Sort_File -- Old data file '//Cbold//
     -	     Cfile//Cnorm//' can not be closed.'
	GOTO 8170				!

8150	CALL STRING_LENGTH(Ctmp,Ilength)	!
	WRITE(*,8160) Ctmp(1:Ilength)		!
8160	FORMAT(' ',A)				!
	GOTO 9990				!	

8170	CALL STRING_LENGTH(Ctmp,Ilength)	!
	WRITE(*,8180) Ctmp(1:Ilength)		!
8180	FORMAT(' ',A)				!
	GOTO 9990				!	

C ..
C ..	Delete the new file, keep the old one
C ..
9900	Status = SOR$END_SORT ()		! Close files
	OPEN(	UNIT	= 1,			! Open new file
     -		NAME	= Cfile,		!
     -		TYPE	= 'OLD',		!
     -		DISPOSE = 'DELETE',		!
     -		ERR	= 8040)			! the new one must go

	OPEN(	UNIT	= 2,			! Open previous version
     -		NAME	= Cfile//';-1',		!
     -		TYPE	= 'OLD',		!
     -		DISPOSE = 'KEEP',		! Keep it
     -		ERR	= 8050)			! If can't open file
	CLOSE(UNIT = 2,ERR=8070)		!
	CLOSE(UNIT = 1,ERR=8060)		! By, By new file

9990	Istatus=-1				!
	IF(Lkill_New_File)		THEN	! If new file must go
	   Ctmp='DTC_Sort_File -- Using VMS DELETE command to delete file '
     -	         //Cbold//Cfile//Cnorm//'.'	! Tell what we are doing
	   CALL STRING_LENGTH(Ctmp,Ilength)	!
	   WRITE(*,8180) Ctmp(1:Ilength)	!
	   Ists=LIB$SPAWN('$DELETE '//Cfile//';0')! Kill the bugger
	END IF
	
	TYPE *, ' '				!
	TYPE *, 'Press '//Cbold//'RETURN'//Cnorm//' to continue'
	READ(*,9995,END=9999)Ctmp		!
9995	FORMAT(A)				!
	GOTO 9999				!
9996	CALL DTC_PURGE_RECORDS(Cfile)		! Strip out unneeded records

9999	RETURN					!	

	END



C+
C	DTC_PURGE_RECORDS
C
C	This subroutine will take the DTC data file, which has been sorted
C	into assending order, and read the file in a record at a time.
C	Each record will be compared with the previous record and if the
C	key fields match, the first record will be disgarded.  If the
C	key fields do not match, the first record will be writen out to 
C	the new file, and the second record will take its place.
C	In this way we will waddle through the file, throwing out
C	duplicate records.  
C
c	The presumption here is that if two records exist, both with the 
C	same key field, the latter one is the most recent and should be 
C	kept.  This, of course depends on the action of the SORT routine
C	(which is supposed to be a stable sort....).
C
C	Note that if any record is null, it is also thrown out.
C
C-
	subroutine DTC_PURGE_RECORDS(Cfile)

	CHARACTER*(*)	Cfile			! The name of the file to attack
	CHARACTER*1	Cesc,Cbell,Cnull	!
	CHARACTER*4	Cbold,Cnorm		! Video attributes
	CHARACTER*60	Cblank			!
	CHARACTER*69	Crecord1		! Record buffers
	CHARACTER*69    Crecord2		!
	CHARACTER*132	Ctmp			!
	COMMON	/Constants/	Cesc,Cbell,Cnull,Cbold,Cnorm

	Cblank=' '				! Fill with spaces

	Open (UNIT	=1,
     -	      FILE	=Cfile,
     -	      STATUS	='OLD',
     -	      FORM	='FORMATTED',
     -        ERR	=8000)

	Open (UNIT	=2,
     -	      FILE	=Cfile,
     -	      STATUS	='NEW',
     -	      FORM	='FORMATTED',
     -	      DISPOSE	='DELETE',
     -        ERR	=8010)

10	READ(1, 20, END=8200) N,Crecord1	! Get a first valid record
20	FORMAT(Q,A)				!
	IF(N.EQ.0)			GOTO 10	! Sanity check
	IF (Crecord1(10:) .EQ. Cblank) 	GOTO 10	! Get real 1st record

30	READ(1,20,END=500)N,Crecord2		! Remember to write 1 rec on EOF
	IF(Crecord1(1:9).EQ.Crecord2(1:9)) THEN	!
	  Crecord1=Crecord2			! If same date/time throw away
						!  1st record, replace with 2nd
	  GOTO 30				!  and read again
	ELSE					! If first record unique
	  IF(Crecord1(10:).NE.Cblank)  	THEN	!  Then if not a blank record
	    WRITE(2,50)Crecord1			!    write it out
50	    FORMAT(A)				!
	  END IF				!
	  Crecord1=Crecord2			!  Make new rec the current rec
	  GOTO 30				!  and read again
	END IF


500	IF(Crecord1(10:).NE.Cblank)  	THEN	!  Then if not a blank record
	  WRITE(2,50)Crecord1			!    write it out
	END IF					!
	CLOSE(UNIT=2,DISPOSE='KEEP',ERR=8020)	! Close and keep new file
	CLOSE(UNIT=1,DISPOSE='DELETE',ERR=8030) ! Delete old data file
	GOTO 9999				! Return

	
8000	Ctmp='DTC_Purge_Rec -- data file '//Cbold//
     -	     Cfile//Cnorm//' can not be opened.'
	GOTO 8150				!
8010	Ctmp='DTC_Purge_Rec -- Output data file '//Cbold//
     -	     Cfile//Cnorm//' can not be opened for delete.'
	GOTO 8150				!
8020	Ctmp='DTC_Purge_Rec -- New data file '//Cbold//
     -	     Cfile//Cnorm//' can not be closed.'
	CLOSE(UNIT=1,DISPOSE='KEEP')		! If we can't close this one
						! we are in big trouble
	GOTO 8150				!
8030	Ctmp='DTC_Purge_Rec -- Old data file '//Cbold//
     -	     Cfile//Cnorm//' can not be closed for delete.'
	GOTO 8150				!

8070	Ctmp='DTC_Purge_Rec -- Old data file '//Cbold//
     -	     Cfile//Cnorm//' can not be closed.'
	GOTO 8150				!

8150	CALL STRING_LENGTH(Ctmp,Ilength)	!
	WRITE(*,8160) Ctmp(1:Ilength)		!
8160	FORMAT(' ',A)				!
	GOTO 9990				!	


8200	Ctmp='DTC_Purge_Rec -- DTC data file '//Cbold//
     -	     Cfile//Cnorm//' is empty'
	CLOSE(UNIT=2)				! Delete new (this better work)
	CLOSE(UNIT=1,ERR=8070)			! Keep original

	GOTO 9990


C ..
C ..	Delete the new file, keep the old one
C ..

9990	Istatus=-1				!
	
	TYPE *, ' '				!
	TYPE *, 'Press '//Cbold//'RETURN'//Cnorm//' to continue'
	READ(*,9995,END=9999)Ctmp		!
9995	FORMAT(A)				!

9999	RETURN					!	
	END
