********************************************************************** * 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