**********************************************************************
* Modification History -See SCCS comments!
* 1999aug      edc 1.1  Original program by edc, sccs'd by billw.
* 1999aug18  billw 1.2  Where checking file for dups (about ln 290),
*                       added conditional test for 3 or 4 digit SSN's;
*                       for Soft_Req #694.
*                       Added IMPLICIT NONE.  Style to uppercase(stdfortran)
*                       Removed unused variable ITEST from sub SORTCH().
*                       Added test for type of input file.
* ----- end  billw 1.2  Added SCCS version and date report.
* 1999aug18  billw 1.3  LCARD1, LCARD2 from *3 to *4
* 1999aug25  billw 1.4  Removed branch to stmt 11 from outside block; style
*
**********************************************************************

       PROGRAM QQRECORD
**********************************************************************
*
*  PROGRAM TO APPEND UNIQUE QQRECORDS TO AN EXISTING AFILE
*  GIVEN EITHER A BLUE BOOK FILE OR G FILE, AND AN AFILE
* 
*  FILES = IN1    = INPUT BLUE BOOK OR GFILE
*          IOUT1  = OUTPUT AFILE
*
**********************************************************************
       IMPLICIT NONE

       CHARACTER*1   AC
       CHARACTER*2   ACC
       CHARACTER*1   ANS
       CHARACTER*10  CARDR
       CHARACTER*10  LCARD
       CHARACTER*4   LCARD1
       CHARACTER*4   LCARD2
       CHARACTER*80  RECORD
       CHARACTER*10  NUMKEY
       CHARACTER*10  NITEM
       CHARACTER*1   YORN
       CHARACTER*30  IDECK
       CHARACTER*30  ODECK
       CHARACTER*80  SCCSID
       CHARACTER*20  SCCSDATE
       CHARACTER*20  SCCSVERSION
       CHARACTER*1   TYPE

       INTEGER*2     W(5000)
       INTEGER*2     NPASS
       INTEGER*4     OUT1
       INTEGER*4     IN1
       INTEGER*4     II
       INTEGER*4     IFRM
       INTEGER*4     ITO

       DIMENSION NITEM(5000)

       SCCSID       = '@(#)qqrecord.f	1.4 - 99/08/25 12:29:23 NGS'
       SCCSDATE     = ' Date: 99/08/25  '
       SCCSVERSION  = ' Version: 1.4  '
       IN1= 21
       OUT1= 22


  7    WRITE(*,8)  SCCSVERSION, SCCSDATE
  8    FORMAT(T1,'   PROGRAM QQRECORD      ',A20,A20)

       PRINT *,'  '
       PRINT *,'  ARE YOU GOING TO USING A : '
       PRINT *,'  1 - BLUE BOOK DECK '
       PRINT *,'  2 - GFILE DECK     '
       PRINT *,'  AS YOUR INPUT FOR THE ACCURACIES '
       PRINT *,'  '
       PRINT *,'  TYPE THE NUMBER? '
       PRINT *,'  '

       READ(*,FMT='(A1)') ANS

       IF( (ANS.NE.'1').AND.(ANS.NE.'2') ) THEN
         PRINT *,' '
         PRINT *,'  SORRY, -',ANS,'-  NOT AN OPTION;  PLEASE TRY AGAIN'
         PRINT *,' '
         GO TO 7
       ENDIF


 10    print *,'  '
       print *,'  TYPE OF BLUE BOOK: '
       print *,'  3 - 3 DIGIT SSNs '
       print *,'  4 - 4 DIGIT SSNs '
       print *,'  TYPE NUMBER NOW '
       read(*,fmt='(a1)') TYPE

       IF( (TYPE.EQ.'3').OR.(TYPE.EQ.'4') ) THEN
         GO TO 20
       ELSE
         PRINT *,'  '
         PRINT *,'  SORRY, -',TYPE,'-  NOT AN OPTION;  PLEASE TRY AGAIN'
         GO TO 10
       ENDIF

 20    CONTINUE


       IF(ANS.EQ.'1') THEN
          PRINT *,'  '
          PRINT *,'   NAME OF THE BLUE BOOK DECK '
          PRINT *,'  '
          PRINT *,'   TYPE NAME - '

          READ(*,FMT='(A30)') IDECK

          OPEN(IN1,FILE=IDECK,STATUS='OLD',ERR=900)


 50       PRINT *,'  '
          PRINT *,'  ORDER OF THE PROJECT '
          PRINT *,'  '
          PRINT *,' 1 -  FIRST            1:100,000 '
          PRINT *,' 2 -  SECOND CLASS I   1: 50,000 '
          PRINT *,' 3 -  SECOND CLASS II  1: 20,000 '
          PRINT *,' 4 -  THIRD            1: 10,000 '
          PRINT *,'  TYPE ANSWER NOW  '
          READ(*,FMT='(A1)') AC

          IF(AC.EQ.'1') THEN
             ACC = '1 '
          ELSEIF(AC.EQ.'2') THEN
             ACC = '21'
          ELSEIF(AC.EQ.'3') THEN
             ACC = '22'
          ELSEIF(AC.EQ.'4') THEN
             ACC = '3  '
          ELSE
             PRINT *,'                         '
             PRINT *,'  SORRY, -',AC,'-  NOT AN OPTION;  TRY AGAIN'
             GO TO 50
          ENDIF
       ENDIF

 11    CONTINUE

       IF(ANS.EQ.'2') THEN

          PRINT *,'  '
          PRINT *,'   NAME OF THE GFILE DECK '
          PRINT *,'  '
          PRINT *,'   TYPE NAME - '

          READ(*,FMT='(A30)') IDECK

          OPEN(IN1,FILE=IDECK,STATUS='OLD',ERR=901)


 60       PRINT *,'  '
          PRINT *,' ORDER OF THE GPS PROJECT '
          PRINT *,'  '
          PRINT *,' 1 - AA - GPS SUPER   1:100,000,000 '
          PRINT *,' 2 - A  - GPS HIGH    1: 10,000,000 '
          PRINT *,' 3 - B  - GPS STD     1:  1,000,000 '
          PRINT *,' 4 - FIRST ORDER      1:    100,000 '
          PRINT *,' 5 - SECOND CLASS I   1:     50,000 '
          PRINT *,' 6 - SECOND CLASS II  1:     20,000 '
          PRINT *,' 7 - THIRD            1:     10,000 '
          PRINT *,'  TYPE ANSWER NOW '
          READ(*,FMT='(A1)') AC

          IF(AC.EQ.'1') THEN
             ACC = 'AA'
          ELSEIF(AC.EQ.'2') THEN
             ACC = 'A '
          ELSEIF(AC.EQ.'3') THEN
             ACC = 'B '
          ELSEIF(AC.EQ.'4') THEN
             ACC = '1 '
          ELSEIF(AC.EQ.'5') THEN
             ACC = '21'
          ELSEIF(AC.EQ.'6') THEN
             ACC = '22'
          ELSEIF(AC.EQ.'7') THEN
             ACC = '3 '
          ELSE
             PRINT *,'  '
             PRINT *,'  SORRY, -',AC,'-  NOT AN OPTION;  TRY AGAIN'
             GO TO 60
          ENDIF
       ENDIF


   12 PRINT *,'  '
      PRINT *,'   NAME OF THE AFILE DECK '
      PRINT *,'  '
      PRINT *,'   TYPE NAME - '

      READ(*,FMT='(A30)') ODECK

      OPEN(OUT1,FILE=ODECK,STATUS='OLD',ERR=902)

      NPASS = 0

************************************************************
*
*     READ THE INPUT FILE TO FIND THE TO AND FROM NUMBERS
*
      PRINT*,'                      '
      PRINT *,'  THE PROGRAM IS NOW READING THE BLUE BOOK '
      PRINT *,'  DECK OR GFILE NOW  '
      PRINT *,'                     '

      NUMKEY = '          '


  100 READ(IN1,FMT='(A80)',END=200) RECORD
       
      IF(TYPE.EQ.'3') THEN
         IF(RECORD(7:10).EQ.'*20*') THEN
            READ(RECORD,FMT='(T11,I3,T51,I3)') IFRM,ITO
         ELSEIF(RECORD(7:10).EQ.'*22*') THEN
            READ(RECORD,FMT='(T11,I3,T51,I3)') IFRM,ITO
         ELSEIF (RECORD(7:10).EQ.'*52*') THEN
            READ(RECORD,FMT='(T11,I3,T46,I3)') IFRM,ITO
         ELSEIF (RECORD(1:1).EQ.'C') THEN
            READ(RECORD,FMT='(T2,I3,T6,I3)') IFRM,ITO
         ELSEIF (RECORD(1:1).EQ.'F') THEN
            READ(RECORD,FMT='(T2,I3,T6,I3)') IFRM,ITO
         ELSE
            GO TO 100
         ENDIF
      ENDIF

       
      IF(TYPE.EQ.'4') THEN
         IF(RECORD(7:10).EQ.'*20*') THEN
            READ(RECORD,FMT='(T11,I4,T51,I4)') IFRM,ITO
         ELSEIF(RECORD(7:10).EQ.'*22*') THEN
            READ(RECORD,FMT='(T11,I4,T51,I4)') IFRM,ITO
         ELSEIF (RECORD(7:10).EQ.'*52*') THEN
            READ(RECORD,FMT='(T11,I4,T46,I4)') IFRM,ITO
         ELSEIF (RECORD(1:1).EQ.'C') THEN
            READ(RECORD,FMT='(T2,I4,T6,I4)') IFRM,ITO
         ELSEIF (RECORD(1:1).EQ.'F') THEN
            READ(RECORD,FMT='(T2,I4,T6,I4)') IFRM,ITO
         ELSE
            GO TO 100
         ENDIF
      ENDIF


      NPASS = NPASS + 1

      IF( NPASS .GT. 5000 ) THEN
         PRINT *,'  ERROR: ARRAY BOUNDS VIOLATION. PROGRAM STOPPED.'
         PRINT *,'         CONTACT PROGRAMMER.'
         STOP
      ENDIF

      IF(IFRM.GT.ITO) THEN
         WRITE(NUMKEY,FMT='(I5.5,I5.5)')  ITO,IFRM
         NITEM(NPASS) = NUMKEY
      ELSE
         WRITE(NUMKEY,FMT='(I5.5,I5.5)') IFRM,ITO
         NITEM(NPASS) = NUMKEY
      ENDIF

      GO TO 100

************************************************************
*
*     CALL THE SORT ROUTINE
*

  200 PRINT *,'   THE PROGRAM IS NOW SORTING THE SSN NUMBERS '
      PRINT *,'                         '

      CALL SORTCH(NITEM,NPASS,W)



************************************************************
*
*     NOW CHECK THE FILE FOR DUPLICATES 
*     SEEK TO END OF THE AFILE TO APPEND
*

  290 READ(OUT1,FMT='(A80)',END=300) RECORD
      GO TO 290

  300 BACKSPACE(OUT1)

      PRINT *,'  '
      PRINT *,'   THE PROGRAM IS NOW WRITING THE QQ RECORDS '
      PRINT *,'   TO THE AFILE  '
      PRINT *,'  '

      CARDR = 'XXXXXXXXXX'

      DO 350 II=1,NPASS
         READ(NITEM (W(II)),FMT='(T1,A10)') LCARD

      IF( CARDR.NE.LCARD ) THEN
C-1.2 start
         IF(TYPE.EQ.'3') THEN
            LCARD1 = LCARD(3:5)
            LCARD2 = LCARD(8:10)
         ENDIF

         IF(TYPE.EQ.'4') THEN
            LCARD1 = LCARD(2:5)
            LCARD2 = LCARD(7:10)
         ENDIF
C-1.2 stop

         IF(LCARD1.EQ.LCARD2) THEN
            GO TO 331
         ENDIF

         IF(TYPE.EQ.'3') THEN
            WRITE(OUT1,320) ACC,LCARD(3:5),LCARD(8:10)
  320       FORMAT(T1,'QQ',T3,A2,T11,A3,T51,A3)
         ENDIF

         IF(TYPE.EQ.'4') THEN
            WRITE(OUT1,321) ACC,LCARD(2:5),LCARD(7:10)
  321       FORMAT(T1,'QQ',T3,A2,T11,A4,T51,A4)
         ENDIF
      ENDIF

  331 CARDR = LCARD

  350 CONTINUE

  400 CLOSE(OUT1,STATUS='KEEP')
      CLOSE(IN1, STATUS='KEEP')

      GO TO 99

C**** PROGRAM LOGICAL END



C**** BEGIN FILE OPEN ERROR STATEMENTS

C**** BLUE BOOK OPENING ERROR
  900 PRINT *,'  FILE DOES NOT EXIST, DO YOU WANT TO '
      PRINT *,'  TRY AGAIN (Y/N) '
      PRINT *,'  TYPE ANSWER  '

      READ(*,FMT='(A1)') YORN
      IF((YORN.EQ.'Y').OR.(YORN.EQ.'y')) THEN
         GO TO 10
      ELSE
         GO TO 99
      ENDIF


C**** GFILE OPENING ERROR
  901 PRINT *,'  FILE DOES NOT EXIST, DO YOU WANT TO '
      PRINT *,'  TRY AGAIN (Y/N) '
      PRINT *,'  TYPE ANSWER  '

      READ(*,FMT='(A1)') YORN
      IF((YORN.EQ.'Y').OR.(YORN.EQ.'y')) THEN
         GO TO 11
      ELSE
         GO TO 99
      ENDIF


C**** AFILE OPENING ERROR
  902 PRINT *,'  FILE DOES NOT EXITS, DO YOU WANT TO '
      PRINT *,'  TRY AGAIN (Y/N) '
      PRINT *,'  TYPE ANSWER '

      READ(*,FMT='(A1)') YORN
      IF((YORN.EQ.'Y').OR.(YORN.EQ.'y')) THEN
         GO TO 12
      ELSE
         GO TO 99
      ENDIF


  910 PRINT *,' OUTPUT FROM SORT FILE DOES NOT EXIST '
      GO TO 99

   99 STOP
      END

C**** PROGRAM PHYSICAL END
**********************************************************************


      SUBROUTINE SORTCH (NITEM,NPASS,W)
**********************************************************************
* SUBROUTINE TO SORT 80 SERIES RECORDS BY DATA CODE AND SSN
* AND WRITE TO A SEQUENTIAL BLUE BOOK FILE
*   NITEM - 
*   NPASS - 
*   W     - 
*
**********************************************************************

      INTEGER*2    II
      INTEGER*2    JJ
      INTEGER*2    KK
      INTEGER*2    GAP
      INTEGER*2    NPASS
      INTEGER*2    TEMP1
      INTEGER*2    W(5000)

      CHARACTER*10 NITEM(5000)
      CHARACTER*10 RECORD
      CHARACTER*10 TEMP
      CHARACTER*10 V(5000)

      DO 1 II=1,5000
         V(II) = '          '
         W(II) = 0
   1  CONTINUE


      GAP=(NPASS - 1)/2
C
      DO 20 II=1,NPASS
         READ(NITEM(II),10) RECORD
   10    FORMAT(T1, A10)
         V(II)=RECORD(1:10)
         W(II)=II
   20 CONTINUE
C
   21 IF( GAP.GT.0 ) THEN
         DO 30 JJ=GAP,NPASS-1
            KK=JJ-GAP+1
   22       IF( KK.GT.0 ) THEN
               IF( V(KK).GT.V(KK+GAP) ) THEN
                  TEMP=V(KK)
                  TEMP1=W(KK)
                  V(KK)=V(KK+GAP)
                  W(KK)=W(KK+GAP)
                  V(KK+GAP)=TEMP
                  W(KK+GAP)=TEMP1
                  KK=KK-GAP
                  GO TO 22
               ENDIF
            ENDIF
   30    CONTINUE
         GAP=GAP/2
         GOTO 21
      ENDIF
C
C
      RETURN
      END
