sortcl.f

Go to the documentation of this file.

      SUBROUTINE sortcl                                                         
     i          (numclm, numstr, ifxclm,                                        
     o           lblclm, timclm, briclm, gciclm, vrmclm, vrpclm, nobclm,        
     o           mrkclm, idfclm, nrfclm, mapclm, skyclm, klmstr, idfhst)        
C-----------------------------------------------------------------------        
C   MODULE NAME: STSORTCL                                                       
C                                                                               
C   PURPOSE:TO BUBBLE SORT THE CLUMP TABLE IN INCREASING ORDER BY NUMBER        
C           OF DIRECT MATCH REFERENCE STAR MATCHES, AND ALTER THE STAR          
C           OBSERVATION TABLE ACCORDINGLY.                                      
C                                                                               
C                                                                               
C   ARGUMENT LIST:                                                              
C   ARGUMENT I/O TYPE DIMENS DESCRIPTION                                        
C   -------- --- ---- ------ -----------                                        
C   NUMCLM   I   I*4         NUMBER OF CLUMPS                                   
C   NUMSTR   I   I*4         NUMBER OF OBSERVATIONS                             
C   IFXCLM   I   I*4         MAX NUMBER OF REF STAR MATCHES PER CLUMP           
C   LBLCLM   I O I*4    *    CLUMP LABLES                                       
C   TIMCLM   I O R*8    *    AVERAGE CLUMP TIMES                                
C   BRICLM   I O R*4    *    AVERAGE CLUMP MAGNITUDES                           
C   GCICLM   I O R*4   3,*   AVERAGE CLUMP POSITIONS (GCI)                      
C   VRMCLM   I O R*4    *    CLUMP MAGNITUDE VARIANCES                          
C   VRPCLM   I O R*4    *    CLUMP POSITION VARIANCES                           
C   NOBCLM   I O I*4    *    NUMBER OF OBSERVATIONS IN EACH CLUMP               
C   MRKCLM   I O I*4    *    STATUS FLAG FOR EACH CLUMP                         
C   IDFCLM   I O I*4    *    IDENTIFICATION FLAG FOR EACH CLUMP                 
C   NRFCLM   I O I*4    *    # OF REFERENCE STAR MATCHES FOR EACH CLUMP         
C   MAPCLM   I O I*4  10,*   SKYMAP ID NUMBERS OF REFERENCE STAR MATCHES        
C   SKYCLM   I O R*4 10,3,*  LIST OF CORRECTED REFERENCE STAR POSITIONS         
C                                (MATCH#,AXIS,CLUMP#)                           
C   KLMSTR   I O I*4    *    CLUMP NUMBER FOR EACH OBSERVATION                  
C   IDFHST   I O I*4    *    FHST NUMBER FOR EACH CLUMP                         
C                                                                               
C   COMMON BLOCK VARIABLES USED:                                                
C   COMMON   VAR    I/O   VAR    I/O   VAR    I/O   VAR    I/O                  
C   ------   ---    ---   ---    ---   ---    ---   ---    ---                  
C   CMDEBG   LEVDBG I     LUDBUG I                                              
C                                                                               
      IMPLICIT NONE                                                             
C       ++INCLUDE STCMDEBG
      INTEGER*4 LEVDBG(8),LUDBUG
      COMMON /cmdebg/levdbg,ludbug                                    
C                                                                               
C   EXTERNAL FILES REFERENCED:                                                  
C   FILENAME      OPERATION   FORTRAN UNIT ID                                   
C   --------      ---------   ---------------                                   
C   NONE                                                                        
C                                                                               
C   EXTERNAL REFERENCES:                                                        
C   --------------------------------------------------------------------        
C   STSWAPCL - SWAP ALL CLUMP ELEMENTS                                          
C                                                                               
C                                                                               
C   SUBROUTINE CALLED FROM:                                                     
C   --------------------------------------------------------------------        
C     STIDENTY - STAR MATCHING DRIVER                                           
C                                                                               
C                                                                               
C   CONSTRAINTS, RESTRICTIONS, MESSAGES, NOTES:                                 
C   --------------------------------------------------------------------        
C   NONE                                                                        
C                                                                               
C   REQUIREMENTS REFERENCES:                                                    
C   --------------------------------------------------------------------        
C   NONE                                                                        
C                                                                               
C   DEVELOPMENT HISTORY:                                                        
C   DATE     AUTHOR              DESCRIPTION                                    
C   -------- ------              -----------                                    
C   8/ 3/88  R.J. BURLEY         DESIGN                                         
C   5/16/89  R.J. BURLEY         CODED                                          
C  11/06/89  R.J. BURLEY         ADD LBLCLM GESS ARRAYS                         
C  02/04/92  C.C. YEH            ADD IDFHST (MTASS-11)                          
C-----------------------------------------------------------------------        
C   METHOD:                                                                     
C     SORTED = .FALSE.                                                          
C     DO WHILE NOT YET SORTED                                                   
C       SORTED = .TRUE.                                                         
C       DO FOR CLUMP# = 2, NUMCLM                                               
C         IF (#DIRECT MATCHES FOR CURRENT CLUMP IS LESS THAN                    
C             #DIRECT MATCHES FOR PREVIOUS CLUMP)                               
C           SORTED = .FALSE.                                                    
C           CALL SWAPCL TO SWAP ALL CLUMP ELEMENTS FROM PREVIOUS                
C            CLUMP TO CURRENT CLUMP                                             
C           DO FOR ALL OBSERVATIONS                                             
C             IF (OBSERVATION IS IN PREVIOUS CLUMP) THEN                        
C               MARK IT AS IN CLUMP                                             
C             ELSE IF (OBSERVATION IS IN CLUMP) THEN                            
C               MARK IT AS IN PREVIOUS CLUMP                                    
C             ENDIF                                                             
C           ENDDO FOR                                                           
C         ENDIF                                                                 
C       ENDDO FOR                                                               
C     ENDDO WHILE                                                               
C     RETURN                                                                    
C-----------------------------------------------------------------------        
C                                                                               
C     * DEFINE PARAMETER VARIABLES                                              
      real*8    timclm(*)                                                       
C                                                                               
      real*4    briclm(*), gciclm(3,*), vrmclm(*)   , vrpclm(*)                 
      real*4    skyclm(10,3,*)                                                  
C                                                                               
      INTEGER*4 NUMCLM      , NUMSTR   , IFXCLM     , LBLCLM(*)                 
      INTEGER*4 NOBCLM(*)   , MRKCLM(*), IDFCLM(*)  , NRFCLM(*)                 
      INTEGER*4 MAPCLM(10,*), KLMSTR(*), IDFHST(*)                              
C                                                                               
C     * DECLARE LOCAL VARIABLES                                                 
      INTEGER*4 ICLM  , IPREV, IOBS, ITEMP                                      
      LOGICAL*4 L_DONE                                                          
C                                                                               
C                                      INITIALIZE ROUTINE                       
      WRITE(*,*) 'ENTERING SORTCL'
      IF (levdbg(7) .NE. 0) WRITE (ludbug,1000)                                 
C                                                                               
C                                                                               
C                                      SORT CLUMPS BY # OF MATCHES              
      l_done = .false.                                                          
100   CONTINUE                                                                  
      IF (.NOT. l_done) THEN                                                    
        l_done = .true.                                                         
        DO 300 iclm = 2,numclm                                                  
          iprev = iclm - 1                                                      
          IF (nrfclm(iclm) .LE. nrfclm(iprev)) THEN                             
           IF ((nrfclm(iclm) .LT. nrfclm(iprev)).OR.
     *         (vrpclm(iclm) .LT. vrpclm(iprev))) THEN 
C                                                                               
C                                      NOT IN ORDER, SWAP CLUMPS                
            itemp = idfhst(iclm)                                                
            idfhst(iclm) = idfhst(iprev)                                        
            idfhst(iprev) = itemp                                               
            l_done = .false.                                                    
            CALL swapcl (iclm  , iprev , ifxclm,                                
     1                   lblclm, timclm, briclm, gciclm, vrmclm, vrpclm,        
     2                   nobclm, mrkclm, idfclm, nrfclm, mapclm, skyclm)        
C                                                                               
C                                      UPDATE OBSERVATION CLUMP #'S             
            DO 200 iobs = 1,numstr                                              
              IF (klmstr(iobs) .EQ. iprev) THEN                                 
                klmstr(iobs) = iclm                                             
              ELSE IF (klmstr(iobs) .EQ. iclm) THEN                             
                klmstr(iobs) = iprev                                            
              ENDIF                                                             
200         CONTINUE                                                            
           ENDIF
          ENDIF                                                                 
300     CONTINUE                                                                
        GO TO 100                                                               
      ENDIF                                                                     
C                                                                               
C                                      NORMAL TERMINATION                       
      IF (levdbg(7) .NE. 0) WRITE (ludbug,2000)                                 
      WRITE(*,*) 'EXIT SORTCL'
      RETURN                                                                    
C                                                                               
C                                      FORMAT SECTION                           
1000  FORMAT(' *** ENTER SORTCL *** ')                                          
2000  FORMAT(' *** EXIT  SORTCL *** ')                                          
      END