OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
doublt.f
Go to the documentation of this file.
1  SUBROUTINE doublt
2  i (pangtl, numclm, numstr, klmstr, lblclm, gciclm,
3  o mrkclm, nrfclm, mapclm, skyclm, mrkstr, idfclm, numdub)
4 C-----------------------------------------------------------------------
5 C MODULE NAME: STDOUBLT
6 C
7 C
8 C PURPOSE: TO IDENTIFY STAR CLUMPS USING PAIRWISE STAR MATCHING.
9 C
10 C
11 C ARGUMENT LIST:
12 C ARGUMENT I/O TYPE DIMENS DESCRIPTION
13 C -------- --- ---- ------ -----------
14 C PANGTL I R*8 MAX ANGULAR SEPARATION FOR MATCH (DEG)
15 C NUMCLM I I*4 NUMBER OF CLUMPS
16 C NUMSTR I I*4 NUMBER OF OBSERVATIONS
17 C KLMSTR I I*4 * CLUMP NUMBER FOR EACH OBSERVATION
18 C LBLCLM I I*4 * CLUMP LABELS
19 C GCICLM I R*4 3,* AVG POSITION VECTOR (GCI) FOR EACH CLUMP
20 C MRKCLM I O I*4 * STATUS FLAG FOR EACH CLUMP
21 C NRFCLM I O I*4 * NUMBER OF REFERENCE STARS MATCHED TO CLUMP
22 C MAPCLM I O I*4 10,* LIST OF REFERENCE STAR #'S MATCHED TO CLUMP
23 C SKYCLM I O R*4 10,3,* LIST OF CORRECTED REFERENCE STAR POSITIONS
24 C MRKSTR I O I*4 * REJECTION FLAG FOR EVERY OBSERVATION
25 C IDFCLM O I*4 * IDENTIFICATION FLAG FOR EACH CLUMP
26 C NUMDUB O I*4 NUMBER OF DOUBLETS CHECKED
27 C
28 C
29 C COMMON BLOCK VARIABLES USED:
30 C COMMON VAR I/O VAR I/O VAR I/O VAR I/O
31 C ------ --- --- --- --- --- --- --- ---
32 C CMDEBG LEVDBG I LUDBUG I
33 C CMCONV DTR I
34 C
35 C ++INCLUDE STCMDEBG
36 C ++INCLUDE AECMCONV
37  INTEGER*4 LEVDBG(8),LUDBUG
38  COMMON /cmdebg/levdbg,ludbug
39  real*8 pi,radeg,re,rem,f,omf2,omegae
40  COMMON /gconst/pi,radeg,re,rem,f,omf2,omegae
41 C
42 C EXTERNAL FILES REFERENCED:
43 C FILENAME OPERATION FORTRAN UNIT ID
44 C -------- --------- ---------------
45 C NONE
46 C
47 C EXTERNAL REFERENCES:
48 C --------------------------------------------------------------------
49 C UTDANGLE - FUNCTION TO COMPUTE ANGULAR SEPARATION BETWEEN 2 VECTORS
50 C
51 C SUBROUTINE CALLED FROM:
52 C --------------------------------------------------------------------
53 C STIDENTY - STAR MATCHING DRIVER
54 C
55 C
56 C CONSTRAINTS, RESTRICTIONS, MESSAGES, NOTES:
57 C --------------------------------------------------------------------
58 C NONE
59 C
60 C REQUIREMENTS REFERENCES:
61 C --------------------------------------------------------------------
62 C UARS FDSS SPECS 3.1.1.5 FUNCTION F3
63 C
64 C
65 C DEVELOPMENT HISTORY:
66 C DATE AUTHOR DESCRIPTION
67 C -------- ------ -----------
68 C 8/ 2/88 R.J. BURLEY DESIGN
69 C 5/16/89 R.J. BURLEY CODED
70 C 10/17/89 R.J. BURLEY ADD FLAG UNIDENTIFIED CLUMPS, AND
71 C CORRECT FLAGGING OF OBSERVATIONS.
72 C 10/19/89 R.J. BURLEY CORRECT ALGORITHM INITIALIZATION TO
73 C RESET MRKCLM AND MRKSTR VALUES FLAGGED
74 C AS UNIDENTIFIED BY TRIPLT ALGORITHM,
75 C IN THE EVENT THAT DOUBLT IS BEING USED
76 C AS A DEFAULT BACKUP FOR TRIPLT.
77 C MAPCLM VALUES FOR MATCHED CLUMPS SHOULD
78 C BE SET TO STAR INDEX OF BEST MATCH.
79 C 11/ 6/89 R.J. BURLEY ADD LBLCLM GESS ARRAY
80 C-----------------------------------------------------------------------
81 C METHOD:
82 C CONVERT PAIRWISE ANGULAR SEPARATION TOLERANCE TO RADIANS
83 C RESET ALL CLUMP ID FLAGS TO 0 TO INDICATE UNIDENTIFIED AND
84 C RESET ALL CLUMP AND OBSERVATION STATUS FLAGS TO ZERO IF THE
85 C FLAG INDICATES IT WAS DROPPED DUE TO UNIDENTIFICATION BY TRIPLT.
86 C
87 C
88 C! TEST ALL COMBINATIONS OF CLUMP PAIRS
89 C DO FOR ICLMA = 1 TO (NUMCLM-1)
90 C DO FOR ICLMB = (ICLMA+1),NUMCLM
91 C
92 C IF ((BOTH CLUMPS HAVE 1 OR MORE REFERENCE STAR MATCHES).AND.
93 C (AT LEAST 1 OF THE CLUMPS IS NOT YET IDENTIFIED)) THEN
94 C INCREMENT COUNT OF VALID PAIRS
95 C USE DANGLE TO COMPUTE THE CLUMP SEPARATION ANGLE
96 C
97 C
98 C SET THE NUMBER OF MATCHES FOR THIS CLUMP PAIR TO ZERO
99 C CURRENT SMALLEST DIFFERENCE = SOME MAXIMUM HIGH VALUE
100 C
101 C! TEST ALL COMBINATIONS OF REFERENCE STAR PAIRS
102 C DO FOR ALL REF STARS MATCHED TO ICLMA BY DIRECT MATCH
103 C DO FOR ALL REF STARS MATCHED TO ICLMB BY DIRECT MATCH
104 C USE DANGLE TO COMPUTE THE STAR SEPARATION ANGLE
105 C ANGDIF = ABSOLUTE VALUE OF THE DIFFERENCE BETWEEN THE
106 C CLUMP SEPARATION ANGLE AND STAR SEPARATION ANGLE
107 C IF ((ANGDIF <= CURRENT SMALLEST DIFFERENCE).AND.
108 C (ANGDIF < PAIRWISE SEPARATION TOLERANCE )) THEN
109 C IF (ANGDIF = CURRENT SMALLEST DIFFERENCE) THEN
110 C INCREMENT NUMBER OF MATCHES
111 C ELSE
112 C SET NUMBER OF MATCHES TO 1
113 C ENDIF
114 C SAVE ANGDIF AS CURRENT SMALLEST AND SAVE REF STAR #'S
115 C ENDIF
116 C ENDDO FOR
117 C ENDDO FOR
118 C
119 C IF (MATCHES = 0) THEN
120 C MARK CLUMPS AS UN+IDENTIFIED IF NOT YET IDENTIFIED BY
121 C SETTING IDFCLM FLAG TO 0
122 C ELSE IF (MATCHES > 1) THEN
123 C MARK CLUMPS AS QUESTIONABLE IF NOT YET IDENTIFIED BY
124 C SETTING IDFCLM FLAG TO 1
125 C ELSE IF (MATCHES = 1) THEN
126 C MARK CLUMPS AS IDENTIFIED WITH REFERENCE STARS BY
127 C SETTING IDFCLM FLAG TO 2
128 C DELETE ANY OTHER REFERENCE STARS MATCHED TO CLUMPS
129 C ENDIF
130 C ENDIF
131 C ENDDO FOR
132 C ENDDO FOR
133 C
134 C DO FOR ALL CLUMPS
135 C IF (CLUMP HAS NOT BEEN IDENTIFIED BY THE DOUBLT ALGORITHM) THEN
136 C SET ITS MRKCLM FLAG TO 15 TO INDICATE SO.
137 C ENDDO FOR
138 C DO FOR ALL OBSERVATIONS
139 C IF (THE CLUMP THAT OBSERVATION IS IN IS UNIDENTIFIED) THEN
140 C SET ITS MRKSTR STATUS FLAG TO 17 TO INDICATE DROPPED DUE
141 C TO UNIDENTIFICATION IN DOUBLT MATCHING ALGORITHM.
142 C ENDIF
143 C ENDDO FOR
144 C
145 C RETURN
146 C-----------------------------------------------------------------------
147 C
148 C * DEFINE PARAMETER VARIABLES
149  real*8 pangtl
150 C
151  real*4 gciclm(3,*) , skyclm(10,3,*)
152 C
153  INTEGER*4 NUMCLM , NUMSTR , LBLCLM(*), KLMSTR(*)
154  INTEGER*4 MRKCLM(*) , IDFCLM(*) , NRFCLM(*)
155  INTEGER*4 MAPCLM(10,*), MRKSTR(*) , NUMDUB
156 C
157 C * DECLARE LOCAL VARIABLES
158  real*8 rangtl , sepang , refang , angdif , toler
159  real*8 e2clma(3), e2clmb(3), e2ref1(3), e2ref2(3)
160  real*8 besta , rmax , dangle
161  INTEGER*4 ICLMA , ICLMB , IMATCH , IREF1 , IREF2
162  INTEGER*4 IBEST1 , IBEST2 , ISTR , I
163  LOGICAL*4 L_MTCH , L_NOID
164  DATA toler /0.99d0/
165  DATA rmax /999999.0d0/
166 C
167 C
168 C INITIALIZE ROUTINE
169  IF (levdbg(7) .NE. 0) WRITE (ludbug,1000)
170 C
171 C INITIALIZE ALGORITHM
172  numdub = 0
173 C RANGTL = PANGTL * DTR
174  rangtl = pangtl / radeg
175  DO 110 iclma = 1,numclm
176  idfclm(iclma) = 0
177  IF (mrkclm(iclma) .EQ. 15) THEN
178  mrkclm(iclma) = 0
179  DO 100 istr = 1,numstr
180  IF ((klmstr(istr) .EQ. iclma).AND.
181  1 (mrkstr(istr) .EQ. 17)) mrkstr(istr) = 0
182 100 CONTINUE
183  ENDIF
184 110 CONTINUE
185 C
186 C PERFORM PAIRWISE CLUMP MATCHING
187  DO 500 iclma = 1,(numclm-1)
188  DO 400 iclmb = (iclma+1),numclm
189 C
190 C TEST IF CLUMPS MAKE VALID PAIR
191  IF ((nrfclm(iclma) .GE. 1).AND.(nrfclm(iclmb) .GE. 1)) THEN
192  l_mtch = .true.
193  ELSE
194  l_mtch = .false.
195  ENDIF
196  IF ((idfclm(iclma) .EQ. 0).OR.(idfclm(iclmb) .EQ. 0)) THEN
197  l_noid = .true.
198  ELSE
199  l_noid = .false.
200  ENDIF
201  IF (l_mtch .AND. l_noid) THEN
202 C
203 C VALID CLUMP PAIR
204  numdub = numdub + 1
205 C
206 C COMPUTE ANGLE BETWEEN CLUMPS
207  e2clma(1) = dble(gciclm(1,iclma))
208  e2clma(2) = dble(gciclm(2,iclma))
209  e2clma(3) = dble(gciclm(3,iclma))
210  e2clmb(1) = dble(gciclm(1,iclmb))
211  e2clmb(2) = dble(gciclm(2,iclmb))
212  e2clmb(3) = dble(gciclm(3,iclmb))
213  sepang = dangle(e2clma, e2clmb, toler, angdif)
214 C
215 C PERFORM PAIRWISE STAR MATCHING
216  imatch = 0
217  besta = rmax
218  DO 300 iref1 = 1,nrfclm(iclma)
219  DO 200 iref2 = 1,nrfclm(iclmb)
220 C
221 C COMPUTE ANGLE BETWEEN STARS
222  e2ref1(1) = dble(skyclm(iref1,1,iclma))
223  e2ref1(2) = dble(skyclm(iref1,2,iclma))
224  e2ref1(3) = dble(skyclm(iref1,3,iclma))
225  e2ref2(1) = dble(skyclm(iref2,1,iclmb))
226  e2ref2(2) = dble(skyclm(iref2,2,iclmb))
227  e2ref2(3) = dble(skyclm(iref2,3,iclmb))
228  refang = dangle(e2ref1, e2ref2, toler, angdif)
229 C
230 C COMPUTE DIFFERENCE BETWEEN SUMS
231  angdif = dabs(refang - sepang)
232 C
233 C SAVE BEST FIT WITHIN RANGTL LIMIT
234  IF ((angdif .LE. besta).AND.(angdif .LT. rangtl)) THEN
235  IF (angdif .EQ. besta) THEN
236  imatch = imatch + 1
237  ELSE
238  imatch = 1
239  ENDIF
240  besta = angdif
241  ibest1 = iref1
242  ibest2 = iref2
243  ENDIF
244 C
245 C INTERMEDIATE DEBUG
246  IF (levdbg(7) .GE. 4) THEN
247  WRITE (ludbug,4000) lblclm(iclma), lblclm(iclmb),
248  1 sepang
249  WRITE (ludbug,4010) iref1, iref2, mapclm(iref1,iclma),
250  1 mapclm(iref2,iclmb), refang
251  WRITE (ludbug,4020) angdif, besta, imatch
252  ENDIF
253 C
254 C
255 200 CONTINUE
256 300 CONTINUE
257 C
258 C
259  IF (imatch .EQ. 0) THEN
260 C MARK CLUMPS AS UNIDENTIFIED
261  IF (idfclm(iclma) .NE. 2) idfclm(iclma) = 0
262  IF (idfclm(iclmb) .NE. 2) idfclm(iclmb) = 0
263  ELSE IF (imatch .GT. 1) THEN
264 C MARK CLUMPS AS QUESTIONABLE
265  IF (idfclm(iclma) .NE. 2) idfclm(iclma) = 1
266  IF (idfclm(iclmb) .NE. 2) idfclm(iclmb) = 1
267  ELSE
268 C
269 C MARK CLUMPS AS IDENTIFIED
270  idfclm(iclma) = 2
271  idfclm(iclmb) = 2
272 C
273 C CLUMPS NOW HAVE ONLY 1 MATCH
274  nrfclm(iclma) = 1
275  nrfclm(iclmb) = 1
276 C
277 C SAVE BEST MATCH AT FRONT OF LIST
278  mapclm(1,iclma) = mapclm(ibest1,iclma)
279  mapclm(1,iclmb) = mapclm(ibest2,iclmb)
280 C
281 C SAVE BEST MATCH STAR POSITIONS
282  skyclm(1,1,iclma) = skyclm(ibest1,1,iclma)
283  skyclm(1,2,iclma) = skyclm(ibest1,2,iclma)
284  skyclm(1,3,iclma) = skyclm(ibest1,3,iclma)
285  skyclm(1,1,iclmb) = skyclm(ibest2,1,iclmb)
286  skyclm(1,2,iclmb) = skyclm(ibest2,2,iclmb)
287  skyclm(1,3,iclmb) = skyclm(ibest2,3,iclmb)
288  ENDIF
289  ENDIF
290 400 CONTINUE
291 500 CONTINUE
292 C
293 C FLAG UNIDENTIFIED CLUMPS
294  DO 600 iclma=1,numclm
295  IF ((mrkclm(iclma) .EQ. 0).AND.
296  1 (idfclm(iclma) .EQ. 0)) mrkclm(iclma) = 15
297 600 CONTINUE
298 C
299 C FLAG UNIDENTIFIED OBSERVATIONS
300  DO 700 istr = 1,numstr
301  IF (mrkclm(klmstr(istr)) .EQ. 15) mrkstr(istr) = 17
302 700 CONTINUE
303 C
304 C
305 C OUTGOING DEBUG
306  IF (levdbg(7) .GE. 3) THEN
307  WRITE (ludbug,5000)
308  DO 950 iclma=1,numclm
309  WRITE (ludbug,5010) lblclm(iclma),mrkclm(iclma),idfclm(iclma)
310  DO 900 imatch=1,nrfclm(iclma)
311  WRITE (ludbug,5020) imatch, mapclm(imatch,iclma),
312  1 (skyclm(imatch,i,iclma),i=1,3)
313 900 CONTINUE
314 950 CONTINUE
315  ENDIF
316 C
317 C NORMAL TERMINATION
318  IF (levdbg(7) .NE. 0) WRITE (ludbug,2000)
319  RETURN
320 C
321 C FORMAT SECTION
322 1000 FORMAT(' *** ENTER DOUBLT ***')
323 2000 FORMAT(' *** EXIT DOUBLT ***')
324 4000 FORMAT(' INTERMEDIATE DEBUG: '/,
325  1 4x,'CLUMP PAIR=',i8,2x,i8,' SEPARATION=',d14.8)
326 4010 FORMAT(4x,'STAR PAIR =',i8,2x,i8,' CATALOG INDEX=',i8,2x,i8,
327  1 ' SEPARATION=',d14.8)
328 4020 FORMAT(4x,'ANGDIF=',d14.8,' BEST YET=',d14.8,' MATCH #=',i8)
329 5000 FORMAT(' STAR CLUMP TABLE AFTER DOUBLT ALGORITHM')
330 5010 FORMAT(' CLUMP=',i6,' STATUS=',i6,' IDFLAG=',i6)
331 5020 FORMAT(10x,'MATCH#',i4,' CATINDEX=',i8,' POSITION=',3(f13.6,1x))
332  END
real
#define real
Definition: DbAlgOcean.cpp:26
re
#define re
Definition: l1_czcs_hdf.c:701
doublt
subroutine doublt(PANGTL, NUMCLM, NUMSTR, KLMSTR, LBLCLM, GCICLM, MRKCLM, NRFCLM, MAPCLM, SKYCLM, MRKSTR, IDFCLM, NUMDUB)
Definition: doublt.f:4
pi
#define pi
Definition: vincenty.c:23
omf2
#define omf2
Definition: l1_czcs_hdf.c:703
f
#define f
Definition: l1_czcs_hdf.c:702
dangle
real *8 function dangle(A, B, TOLER, ANG)
Definition: dangle.f:62


ABOUT

Our Team

Contact Us

DATA

Get Started

Find Data

Use Data

TOOLS

SeaBASS

SeaDAS

Giovanni Data Visualizer

Worldview Mapping Interface

Mission Quality Monitor

HELP

Level 1 & 2 Browser Help

Level 3 & 4 Browser Help

File Search Help

Search & Download Help

Earthdata Forum

Join Mailing List

How to Cite Data

CONNECT WITH US
COMPLIANCE

Web Privacy Policy

Data & Information Policy

Communications Policy

Accessibility Policy

Freedom of Information Act

USA.gov

Responsible NASA Official: Sean Bailey
Curator: OceanColor Webmaster