C----------------------------------------------------------------------- C----------------------------------------------------------------------- PROGRAM DUPREP PARAMETER (MXTS=6,MXTB=2000000) COMMON /QUIET/ IPRT CHARACTER*255 FILI,FILO CHARACTER*80 TSTR,RSTR CHARACTER*8 CTAB(MXTS,MXTB),SUBSET REAL(8) ADATE,BDATE REAL(8) TAB_8(MXTS,MXTB),RAB_8(MXTS,MXTB) DIMENSION JDUP(MXTB) DIMENSION NDUP(0:4),IWORK(MXTB),IORD(MXTB) EQUIVALENCE (TAB_8(1,1),CTAB(1,1)) LOGICAL DUPES DATA TSTR /'YOB XOB DHR ELV TYP '/ DATA ADATE /00000000.00/ DATA BDATE /99999999.00/ DATA BMISS /10E10/ DATA LUBFI /20/ DATA LUBFJ /50/ DATA DEXY /0/ DATA DOUR /0/ DATA DELV /0/ DATA ISUB /0/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C READ I/O FILENAMES AND ANY OVERRIDE VALUES FOR THINNING PARAMETERS C ------------------------------------------------------------------ C DEFAULT PARAMETERS: C DEXY = 0.0 TOLERANCE FOR LAT/LON CHECKS C DOUR = 0.0 TOLERANCE FOR HOUR CHECK C DELV = 0.0 TOLERANCE FOR ELEVATION CHECK C ------------------------------------------------------------------ READ(5,'(A)',END=900,ERR=900) FILI READ(5,'(A)',END=900,ERR=900) FILO READ(5,*,END=1) DEXY,DOUR,DELV 1 CONTINUE PRINT *,'REQUESTED EARLIEST DATE IS ... ',ADATE PRINT *,'REQUESTED LATEST DATE IS ... ',BDATE PRINT * PRINT *,'UNCHECKED AND UNCORRECTED INPUT FILE IS' PRINT *,' ',TRIM(FILI) PRINT *,'DUPLICATE CHECKED AND CORRECTED OUTPUT FILE IS' PRINT *,' ',TRIM(FILO) PRINT * PRINT *,'DUPCOR PARAMETERS:' PRINT *,'TOLERANCE FOR LAT/LON CHECKS (IN DEGREES) .. ',DEXY PRINT *,'TOLERANCE FOR HOUR CHECK (IN HOURS) ........ ',DOUR PRINT *,'TOLERANCE FOR ELEVATION (IN METERS) ....... ',DELV PRINT * C MAKE A TABLE OUT OF THE LATS, LONS, AND TIME COORDINATES C -------------------------------------------------------- OPEN(LUBFI,FILE=FILI,FORM='UNFORMATTED') CALL UFBMEM(LUBFI,0,IRET,IUNIT) C READ THE INFORMATION FOR DUP CHECKING AND THINNING C -------------------------------------------------- CALL UFBTAM(TAB_8,MXTS,MXTB,NTAB,TSTR) if(ntab>=mxtb) call bort('duprep ufbtam mxtb overflow') C INITIAL VALUES FOR MARKERS AND COUNTERS AND CORRECTION INDICATORS C ----------------------------------------------------------------- JDUP = 0 NDUP = 0 C GET A SORTED INDEX OF THE REPORTS BY RECEIPT, OB TIME, AND LON/LAT C ------------------------------------------------------------------ CALL ORDERS( 2,IWORK,TAB_8(5,1),IORD,NTAB,MXTS,8,2) CALL ORDERS(12,IWORK,TAB_8(4,1),IORD,NTAB,MXTS,8,2) CALL ORDERS(12,IWORK,TAB_8(3,1),IORD,NTAB,MXTS,8,2) CALL ORDERS(12,IWORK,TAB_8(2,1),IORD,NTAB,MXTS,8,2) CALL ORDERS(12,IWORK,TAB_8(1,1),IORD,NTAB,MXTS,8,2) C GO THROUGH THE REPORTS IN ORDER, MARKING DUPLICATES AND CORRECTIONS C ------------------------------------------------------------------- DO 2 K=1,NTAB-1 I = IORD(K) DO KK=K+1,MIN(K+200,NTAB) J = IORD(KK) IF(NINT(ABS(TAB_8(1,I)-TAB_8(1,J))*100.).LT.NINT(DEXY*100.)) THEN DUPES = NINT(ABS(TAB_8(1,I)-TAB_8(1,J))*100.).LE.NINT(DEXY*100.) . .AND. NINT(ABS(TAB_8(2,I)-TAB_8(2,J))*100.).LE.NINT(DEXY*100.) . .AND. NINT(ABS(TAB_8(3,I)-TAB_8(3,J))*100.).LE.NINT(DOUR*100.) . .AND. NINT(ABS(TAB_8(4,I)-TAB_8(4,J))*100.).LE.NINT(DELV*100.) . .AND. NINT(ABS(TAB_8(5,I)-TAB_8(5,J))*100.).LE.0000 !IF(DUPES) print'(5f10.2)',(tab_8(l,i),l=1,5) !IF(DUPES) print'(5f10.2)',(tab_8(l,j),l=1,5) !IF(DUPES) print* IF(DUPES) JDUP(I) = 2 IF(DUPES) GOTO 2 ENDIF ENDDO 2 ENDDO C WRITE A DUP-CHECKED FILE C ------------------------ CALL CLOSBF(LUBFJ) OPEN(LUBFJ,FILE=FILO,FORM='UNFORMATTED') CALL OPENBF(LUBFJ,'OUT',LUBFI) IREC = 1 DO WHILE(IREADMM(IREC,SUBSET,IDATE).EQ.0) NSUBS = NMSUB(LUBFI) DUPES = .FALSE. DO N=1,NSUBS IDUP = JDUP(ISUB+N) IF(IDUP.GT.1) DUPES = .TRUE. ENDDO IF(.NOT.DUPES) THEN DO N=1,NSUBS IDUP = JDUP(ISUB+N) NDUP(IDUP) = NDUP(IDUP)+1 ENDDO ENDIF IF(DUPES) THEN CALL OPENMB(LUBFJ,SUBSET,IDATE) DO WHILE(IFBGET(LUBFI).EQ.0) ISUB = ISUB+1 IDUP = JDUP(ISUB) IF(IDUP.LE.1) THEN CALL COPYSB(LUBFI,LUBFJ,IRET) NDUP(IDUP) = NDUP(IDUP)+1 ELSE !print'(5f10.2)',(tab_8(i,isub),i=1,5) CALL COPYSB(LUBFI,00000,IRET) NDUP(IDUP) = NDUP(IDUP)+1 ENDIF ENDDO ELSE CALL CLOSMG(LUBFJ) CALL COPYMG(LUBFI,LUBFJ) ISUB = ISUB+NSUBS ENDIF ENDDO CALL CLOSBF(LUBFI) CALL CLOSBF(LUBFJ) C GENERATE REPORT C --------------- 100 CONTINUE PRINT *,'UNIQUE REPORTS= ',NDUP(0) PRINT *,'CORRECTED REPORTS= ',NDUP(1) PRINT *,'DUPLICATE REMOVED= ',NDUP(2) PRINT *,'DUPLICATE NOT RMV= ',NDUP(3) PRINT *,'UNWINDOWD REPORTS= ',NDUP(4) PRINT * PRINT *,'DUPCOR PROCESSED ',NTAB,' REPORTS ' PRINT * STOP C ERROR EXITS C ----------- 900 CONTINUE CALL BORT('DUPUPA - EOF ON NAMELIST ') END