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