OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
triplt.f
Go to the documentation of this file.
1  SUBROUTINE triplt
2  i (tangtl, tminco, numclm, lblclm, gciclm, nobclm,
3  i mrkclm, numstr, klmstr,
4  o mrkstr, skyclm, nrfclm, mapclm,
5  o idfclm, numtrp)
6 C-----------------------------------------------------------------------
7 C MODULE NAME: STTRIPLT
8 C
9 C
10 C PURPOSE: TO IDENTIFY STAR CLUMPS USING TRIPLET STAR MATCHING.
11 C
12 C
13 C ARGUMENT LIST:
14 C ARGUMENT I/O TYPE DIMENS DESCRIPTION
15 C -------- --- ---- ------ -----------
16 C TANGTL I R*8 MAX ANGULAR SEPARATION FOR TRIPLET MATCH
17 C TMINCO I R*8 MINIMUM COLINEARITY ANGLE FOR VALID TRIPLET
18 C NUMCLM I I*4 NUMBER OF CLUMPS
19 C LBLCLM I I*4 CLUMP LABELS
20 C GCICLM I R*4 3,* AVERAGE POSITION VEC (GCI) FOR EACH CLUMP
21 C NOBCLM I I*4 * NUMBER OF OBSERVATIONS PER CLUMP
22 C MRKCLM I O I*4 * STATUS FLAG FOR EACH CLUMP
23 C NUMSTR I I*4 NUMBER OF OBSERVATIONS
24 C KLMSTR I I*4 * CLUMP NUMBER FOR EACH OBSERVATION
25 C MRKSTR I O I*4 * STATUS FLAG FOR EACH OBSERVATION
26 C SKYCLM I O R*4 10,3,* LIST OF CORRECTED REFERENCE STAR POSITIONS
27 C NRFCLM I O I*4 * NUMBER OF REFERENCE STARS MATCHED TO CLUMP
28 C MAPCLM I O I*4 10,* LIST OF REFERENCE STAR #'S MATCHED TO CLUMP
29 C IDFCLM O I*4 * IDENTIFICATION FLAG FOR EACH CLUMP
30 C NUMTRP O I*4 NUMBER OF VALID CLUMP TRIPLETS CHECKED
31 C
32 C
33 C COMMON BLOCK VARIABLES USED:
34 C COMMON VAR I/O VAR I/O VAR I/O VAR I/O
35 C ------ --- --- --- --- --- --- --- ---
36 C CMDEBG LEVDBG I LUDBUG I
37 C CMCONV DTR I
38 C
39 C ++INCLUDE STCMDEBG
40 C ++INCLUDE AECMCONV
41  INTEGER*4 LEVDBG(8),LUDBUG
42  COMMON /cmdebg/levdbg,ludbug
43  real*8 pi,radeg,re,rem,f,omf2,omegae
44  COMMON /gconst/pi,radeg,re,rem,f,omf2,omegae
45 C
46 C EXTERNAL FILES REFERENCED:
47 C FILENAME OPERATION FORTRAN UNIT ID
48 C -------- --------- ---------------
49 C NONE
50 C
51 C EXTERNAL REFERENCES:
52 C --------------------------------------------------------------------
53 C STCOLINE - TEST COLINEAR ACCEPTABILITY OF CLUMP TRIPLET
54 C UTDANGLE - FUNCTION TO COMPUTE ANGULAR SEPARATION BETWEEN 2 VECTORS
55 C
56 C SUBROUTINE CALLED FROM:
57 C --------------------------------------------------------------------
58 C STIDENTY - STAR MATCHING DRIVER
59 C
60 C
61 C CONSTRAINTS, RESTRICTIONS, MESSAGES, NOTES:
62 C --------------------------------------------------------------------
63 C NONE
64 C
65 C REQUIREMENTS REFERENCES:
66 C --------------------------------------------------------------------
67 C UARS FDSS SPECS 3.1.1.5 (FUNCTION 3)
68 C
69 C
70 C DEVELOPMENT HISTORY:
71 C DATE AUTHOR DESCRIPTION
72 C -------- ------ -----------
73 C 8/ 3/88 R.J. BURLEY DESIGN
74 C 5/18/89 R.J. BURLEY CODED
75 C 10/17/89 R.J. BURLEY ADD FLAGGING OF UNIDENTIFIED CLUMPS AND
76 C CORRECT FLAGGING OF OBSERVATIONS.
77 C 10/19/89 R.J. BURLEY PUT CATALOG STAR INDEX NUMBER IN MAPCLM
78 C ARRAY INSTEAD OF BEST MATCH NUMBER.
79 C 10/24/89 R.J. BURLEY CONVERT MINIMUM COLINEARITY ANGLE TO
80 C TO RADIANS.
81 C 11/ 2/89 R.J. BURLEY MODIFY DEBUG
82 C 11/ 6/89 R.J. BURLEY ADD LBLCLM GESS ARRAY
83 C-----------------------------------------------------------------------
84 C METHOD:
85 C CONVERT TRIPLET ANGULAR SEPARATION TOLERANCE TO RADIANS
86 C CONVERT MINIMUM COLINEARITY ANGLE TO RADIANS
87 C SET NUMTRP TO ZERO
88 C RESET ALL CLUMP ID FLAGS AS UNIDENTIFIED IN IDFCLM ARRAY
89 C
90 C DO FOR ICLMPA = 1 TO (NUMCLM-2)
91 C DO FOR ICLMPB = (ICLMPA+1) TO (NUMCLM-1)
92 C DO FOR ICLMPC = (ICLMPB+1) TO NUMCLM
93 C
94 C! * TEST VALIDITY OF CLUMP TRIPLET
95 C CALL COLINE TO TEST COLINEAR ACCEPTABILITY OF CLUMP TRIPLET
96 C IF (ALL HAVE >=1 REF STAR).AND.(ALL HAVE MRKCLM FLAG = 0).AND.
97 C (1 OR MORE IS UNIDENTIFIED).AND.(COLINEARITY > TIMINCO) THEN
98 C INCREMENT NUMBER OF VALID TRIPLETS COUNT
99 C COMPUTE SUM OF ANGULAR SEPARATIONS OF CLUMP TRIPLET
100 C SET NUMBER OF TRIPLET MATCHES TO ZERO
101 C CURRENT SMALLEST DIFFERENCE = SOME MAXIMUM VALUE
102 C
103 C! * TEST ALL REFERENCE STAR COMBINATIONS
104 C DO FOR ALL REFERENCE STARS MATCHED TO CLUMPA
105 C DO FOR ALL REFERENCE STARS MATCHED TO CLUMPB
106 C DO FOR ALL REFERENCE STARS MATCHED TO CLUMPC
107 C COMPUTE SUM OF ANG SEPS OF REF STAR TRIPLET
108 C COMPUTE DIFFERENCE BETWEEN SUM OF CLUMP TRIPLET
109 C ANGLES AND STAR TRIPLET ANGLES
110 C IF ((DIFFERENCE <= CURRENT SMALLEST DIFFERENCE).AND.
111 C (DIFFERENCE < TOLERANCE)) THEN
112 C IF (DIFFERENCE = CURRENT SMALLEST DIFFERENCE) THEN
113 C INCREMENT NUMBER OF MATCHES
114 C ELSE
115 C NUMBER OF MATCHES = 1
116 C ENDIF
117 C SET CURRENT SMALLEST DIFFERENCE = DIFFERENCE
118 C SAVE THE REF STAR #'S WHICH MADE THIS TRIPLET
119 C ENDIF
120 C ENDDO FOR
121 C ENDDO FOR
122 C ENDDO FOR
123 C
124 C IF (NUMBER OF MATCHES = 0) THEN
125 C MARK CLUMPS AS UNIDENTIFIED IF NOT YET IDENTIFIED
126 C ELSE IF (NUMBER OF MATCHES > 1) THEN
127 C MARK CLUMPS AS QUESTIONABLE IF NOT YET IDENTIFIED
128 C ELSE
129 C MARK CLUMPS AS IDENTIFIED, SAVE REFERENCE STAR NUMBERS
130 C WIPE OUT ANY OTHER REFERENCE STARS MATCHED TO CLUMP
131 C ENDIF
132 C ENDIF
133 C ENDIF
134 C
135 C ENDDO FOR
136 C ENDDO FOR
137 C ENDDO FOR
138 C
139 C DO FOR ALL CLUMPS
140 C IF (CLUMP HAS NOT BEEN IDENTIFIED BY TRIPLT ALGORITHM) THEN
141 C SET ITS MRKCLM FLAG TO 15.
142 C ENDDO FOR
143 C DO FOR ALL OBSERVATIONS
144 C SET MRKSTR FLAG TO 17 IF IT IS IN A CLUMP MARKED AS UNIDENTIFIED
145 C ENDDO FOR
146 C RETURN
147 C-----------------------------------------------------------------------
148 C
149 C * DEFINE PARAMETER VARIABLES
150  real*8 tangtl , tminco
151 C
152  real*4 gciclm(3,*) , skyclm(10,3,*)
153 C
154  INTEGER*4 NUMCLM , LBLCLM(*) , NOBCLM(*)
155  INTEGER*4 MRKCLM(*) , IDFCLM(*) , NUMSTR , KLMSTR(*)
156  INTEGER*4 MRKSTR(*) , NRFCLM(*) , MAPCLM(10,*) , NUMTRP
157 C
158 C
159 C * DECLARE LOCAL VARIABLES
160  real*8 rangtl , angdif , toler , besta , rmax , coangl
161  real*8 cangab , cangac , cangbc , cangle, dangle, rminco
162  real*8 rang12 , rang13 , rang23 , rangle
163  real*8 e2clma(3), e2clmb(3), e2clmc(3)
164  real*8 e2ref1(3), e2ref2(3), e2ref3(3)
165  INTEGER*4 ICLMA , ICLMB , ICLMC , IREF1 , IREF2 , IREF3
166  INTEGER*4 IMATCH , IBEST1 , IBEST2 , IBEST3 , ISTR
167  LOGICAL*4 L_GOOD , L_MTCH , L_NOID
168  DATA toler /0.99d0/
169  DATA rmax /999999.0d0/
170 C
171 C
172 C INITIALIZE ROUTINE
173  IF (levdbg(7) .NE. 0) WRITE (ludbug,1000)
174  IF (levdbg(7) .GE. 1) WRITE (ludbug,3999) tangtl,tminco
175 C
176 C INITIALIZE ALGORITHM
177  numtrp = 0
178 C RANGTL = TANGTL * DTR
179 C RMINCO = TMINCO * DTR
180  rangtl = tangtl / radeg
181  rminco = tminco / radeg
182  IF (levdbg(7) .GE. 1) WRITE (ludbug,3999) rangtl,rminco
183  DO 100 iclma = 1,numclm
184  idfclm(iclma) = 0
185 100 CONTINUE
186 C
187  istr = 1
188  dowhile(nrfclm(istr).LT.1)
189  istr = istr + 1
190  END DO
191 C PERFORM TRIPLET CLUMP MATCHING
192  DO 700 iclma = istr,(numclm-2)
193  DO 600 iclmb = (iclma+1),(numclm-1)
194  DO 500 iclmc = (iclmb+1),numclm
195 C
196 C TEST IF CLUMPS MAKE VALID TRIPLET
197  IF ((mrkclm(iclma) .EQ. 0).AND.(mrkclm(iclmb) .EQ. 0).AND.
198  1 (mrkclm(iclmc) .EQ. 0)) THEN
199  l_good = .true.
200  ELSE
201  l_good = .false.
202  ENDIF
203  IF ((nrfclm(iclma) .GE. 1).AND.(nrfclm(iclmb) .GE. 1).AND.
204  1 (nrfclm(iclmc) .GE. 1)) THEN
205  l_mtch = .true.
206  ELSE
207  l_mtch = .false.
208  ENDIF
209  IF ((idfclm(iclma) .EQ. 0).OR.(idfclm(iclmb) .EQ. 0).OR.
210  1 (idfclm(iclmc) .EQ. 0)) THEN
211  l_noid = .true.
212  ELSE
213  l_noid = .false.
214  ENDIF
215  IF (l_good .AND. l_mtch .AND. l_noid) THEN
216  CALL coline (iclma, iclmb, iclmc, lblclm, gciclm, coangl)
217  IF (coangl .GT. rminco) THEN
218 C
219 C VALID CLUMP TRIPLET
220  numtrp = numtrp + 1
221 C
222 C FIND SUM OF ANGULAR SEPARATIONS
223  e2clma(1) = dble(gciclm(1,iclma))
224  e2clma(2) = dble(gciclm(2,iclma))
225  e2clma(3) = dble(gciclm(3,iclma))
226  e2clmb(1) = dble(gciclm(1,iclmb))
227  e2clmb(2) = dble(gciclm(2,iclmb))
228  e2clmb(3) = dble(gciclm(3,iclmb))
229  e2clmc(1) = dble(gciclm(1,iclmc))
230  e2clmc(2) = dble(gciclm(2,iclmc))
231  e2clmc(3) = dble(gciclm(3,iclmc))
232  cangab = dangle(e2clma, e2clmb, toler, angdif)
233  cangbc = dangle(e2clmb, e2clmc, toler, angdif)
234  cangac = dangle(e2clma, e2clmc, toler, angdif)
235  cangle = cangab + cangbc + cangac
236 C
237 C PERFORM TRIPLET STAR MATCHING
238  imatch = 0
239  besta = rmax
240  DO 400 iref1 = 1,nrfclm(iclma)
241  DO 300 iref2 = 1,nrfclm(iclmb)
242  DO 200 iref3 = 1,nrfclm(iclmc)
243 C
244 C COMPUTE SUM OF ANGLES BETWEEN
245 C REFERENCE STARS
246  e2ref1(1) = dble(skyclm(iref1,1,iclma))
247  e2ref1(2) = dble(skyclm(iref1,2,iclma))
248  e2ref1(3) = dble(skyclm(iref1,3,iclma))
249  e2ref2(1) = dble(skyclm(iref2,1,iclmb))
250  e2ref2(2) = dble(skyclm(iref2,2,iclmb))
251  e2ref2(3) = dble(skyclm(iref2,3,iclmb))
252  e2ref3(1) = dble(skyclm(iref3,1,iclmc))
253  e2ref3(2) = dble(skyclm(iref3,2,iclmc))
254  e2ref3(3) = dble(skyclm(iref3,3,iclmc))
255  rang12 = dangle(e2ref1, e2ref2, toler, angdif)
256  rang13 = dangle(e2ref1, e2ref3, toler, angdif)
257  rang23 = dangle(e2ref2, e2ref3, toler, angdif)
258  rangle = rang12 + rang13 + rang23
259 C
260 C COMPUTE DIFFERENCE BETWEEN SUMS
261 C ANGDIF = DABS(CANGLE - RANGLE)
262  angdif = dabs(cangab - rang12)
263  * + dabs(cangac - rang13)
264  * + dabs(cangbc - rang23)
265 C
266 C SAVE BEST FIT WITHIN RANGTL LIMIT
267  IF ((angdif.LE.besta).AND.(angdif.LT.rangtl)) THEN
268  IF (angdif .EQ. besta) THEN
269  imatch = imatch + 1
270  ELSE
271  imatch = 1
272  ENDIF
273  besta = angdif
274  ibest1 = iref1
275  ibest2 = iref2
276  ibest3 = iref3
277  ENDIF
278 C
279 C INTERMEDIATE DEBUG
280  IF (levdbg(7) .GE. 4) THEN
281  WRITE (ludbug,4000) lblclm(iclma),
282  1 lblclm(iclmb), lblclm(iclmc), cangle
283  WRITE (ludbug,4010) iref1, iref2, iref3,
284  1 mapclm(iref1,iclma), mapclm(iref2,iclmb),
285  2 mapclm(iref3,iclmc), rangle
286  WRITE (ludbug,4020) angdif, besta, imatch
287  ENDIF
288 C
289 C
290 200 CONTINUE
291 300 CONTINUE
292 400 CONTINUE
293 C
294 C
295  IF (imatch .EQ. 0) THEN
296 C MARK CLUMPS AS UNIDENTIFIED
297  IF (idfclm(iclma) .NE. 2) idfclm(iclma) = 0
298  IF (idfclm(iclmb) .NE. 2) idfclm(iclmb) = 0
299  IF (idfclm(iclmc) .NE. 2) idfclm(iclmc) = 0
300  ELSE IF (imatch .GT. 1) THEN
301 C MARK CLUMPS AS QUESTIONABLE
302  IF (idfclm(iclma) .NE. 2) idfclm(iclma) = 1
303  IF (idfclm(iclmb) .NE. 2) idfclm(iclmb) = 1
304  IF (idfclm(iclmc) .NE. 2) idfclm(iclmb) = 1
305  ELSE
306 C
307 C MARK CLUMPS AS IDENTIFIED
308  idfclm(iclma) = 2
309  idfclm(iclmb) = 2
310  idfclm(iclmc) = 2
311 C
312 C CLUMPS NOW HAVE ONLY 1 MATCH
313  nrfclm(iclma) = 1
314  nrfclm(iclmb) = 1
315  nrfclm(iclmc) = 1
316 C
317 C SAVE BEST MATCH AT FRONT OF LIST
318  mapclm(1,iclma) = mapclm(ibest1,iclma)
319  mapclm(1,iclmb) = mapclm(ibest2,iclmb)
320  mapclm(1,iclmc) = mapclm(ibest3,iclmc)
321 C
322 C SAVE BEST MATCH STAR POSITIONS
323  skyclm(1,1,iclma) = skyclm(ibest1,1,iclma)
324  skyclm(1,2,iclma) = skyclm(ibest1,2,iclma)
325  skyclm(1,3,iclma) = skyclm(ibest1,3,iclma)
326  skyclm(1,1,iclmb) = skyclm(ibest2,1,iclmb)
327  skyclm(1,2,iclmb) = skyclm(ibest2,2,iclmb)
328  skyclm(1,3,iclmb) = skyclm(ibest2,3,iclmb)
329  skyclm(1,1,iclmc) = skyclm(ibest3,1,iclmc)
330  skyclm(1,2,iclmc) = skyclm(ibest3,2,iclmc)
331  skyclm(1,3,iclmc) = skyclm(ibest3,3,iclmc)
332  ENDIF
333  ENDIF
334  ENDIF
335 C
336 C
337 500 CONTINUE
338 600 CONTINUE
339 700 CONTINUE
340 C
341 C FLAG UNIDENTIFIED CLUMPS
342  DO 800 iclma=1,numclm
343  IF ((mrkclm(iclma) .EQ. 0).AND.
344  1 (idfclm(iclma) .EQ. 0)) mrkclm(iclma) = 15
345 800 CONTINUE
346 C
347 C FLAG UNIDENTIFIED OBSERVATIONS
348  DO 900 istr = 1,numstr
349  IF (mrkclm(klmstr(istr)) .EQ. 15) mrkstr(istr) = 17
350 900 CONTINUE
351 C
352 C
353 C OUTGOING DEBUG
354  IF (levdbg(7) .GE. 3) THEN
355  WRITE (ludbug,5000)
356  DO 950 iclma=1,numclm
357  WRITE (ludbug,5010) lblclm(iclma),mrkclm(iclma),idfclm(iclma)
358  DO 930 imatch=1,nrfclm(iclma)
359  WRITE (ludbug,5020) imatch, mapclm(imatch,iclma),
360  1 (skyclm(imatch,i,iclma),i=1,3)
361 930 CONTINUE
362 950 CONTINUE
363  ENDIF
364 C
365 C NORMAL TERMINATION
366  IF (levdbg(7) .NE. 0) WRITE (ludbug,2000)
367  RETURN
368 C
369 C FORMAT SECTION
370 1000 FORMAT(' *** ENTER TRIPLT ***')
371 2000 FORMAT(' *** EXIT TRIPLT ***')
372 3999 FORMAT(' TRIPLET PARAMETERS: TANGTL=',d12.6,' TMINCO=',d12.6)
373 4000 FORMAT(' INTERMEDIATE DEBUG: '/,
374  1 4x,'CLUMP TRIPLT=',i8,2x,i8,2x,i8,' SEPARATION=',d12.6)
375 4010 FORMAT(4x,'STAR TRIPLT =',i8,2x,i8,2x,i8,' CATALOG #S=',
376  1 i8,2x,i8,2x,i8,' SEPARATION=',d12.6)
377 4020 FORMAT(4x,'ANGDIF=',d12.6,' BEST YET=',d12.6,' MATCH #=',i8)
378 5000 FORMAT(' STAR CLUMP TABLE AFTER TRIPLT ALGORITHM')
379 5010 FORMAT(' CLUMP=',i6,' STATUS=',i6,' IDFLAG=',i6)
380 5020 FORMAT(10x,'MATCH#',i4,' CATINDEX=',i8,' POSITION=',3(f13.6,1x))
381  END
real
#define real
Definition: DbAlgOcean.cpp:26
re
#define re
Definition: l1_czcs_hdf.c:701
pi
#define pi
Definition: vincenty.c:23
omf2
#define omf2
Definition: l1_czcs_hdf.c:703
coline
subroutine coline(ICLMA, ICLMB, ICLMC, LBLCLM, GCICLM, COANGL)
Definition: coline.f:4
triplt
subroutine triplt(TANGTL, TMINCO, NUMCLM, LBLCLM, GCICLM, NOBCLM, MRKCLM, NUMSTR, KLMSTR, MRKSTR, SKYCLM, NRFCLM, MAPCLM, IDFCLM, NUMTRP)
Definition: triplt.f:6
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