Due to the lapse in federal government funding, NASA is not updating this website. We sincerely regret this inconvenience.
A sphere with three ocean waves in differing shades of blue. Next to the sphere, there is the bolded text "Ocean Color". Under that, there are two acronyms, separated by a vertical pipe: OB.DAAC (Ocean Biology Distributed Active Archive Center) and OBPG (Ocean Biology Processing Group). Lorem ipsum dolor sit amet
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
f
#define f
Definition: l1_czcs.c:696
real
#define real
Definition: DbAlgOcean.cpp:26
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
re
#define re
Definition: l1_czcs.c:695
omf2
#define omf2
Definition: l1_czcs.c:697
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

How to Use Earthdata Search

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

Freedom of Information Act

USA.gov

Responsible NASA Official: Sean Bailey
Curator: OceanColor Webmaster