GEANT321/cgpack/cgshel.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:19:44  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/02 29/03/94  15.41.32  by  S.Giani
  11 *-- Author :
  12       SUBROUTINE CGSHEL(ATRINV,ERROR,NEDGE,EDGE)
  13 ************************************************************************
  14 *                                                                      *
  15 *     Name: CGSHEL                                                     *
  16 *     Author: E. Chernyaev                       Date:    13.04.89     *
  17 *                                                Revised:              *
  18 *                                                                      *
  19 *     Function: Shell sort of edges                                    *
  20 *                                                                      *
  21 *     References: none                                                 *
  22 *                                                                      *
  23 *     Input:  ATRINV - atribute decrement for inverse edges            *
  24 *             ERROR  - presision error                                 *
  25 *     Output: NEDGE - number of edges                                  *
  26 *             EDGE(*,*)  - edges                                       *
  27 *                                                                      *
  28 *     Output:                                                          *
  29 *                                                                      *
  30 *     Errors: none                                                     *
  31 *                                                                      *
  32 ************************************************************************
  33 #include "geant321/cggpar.inc"
  34       REAL      EDGE(LCGEDG,*),SAVE(LCGEDG)
  35 *-
  36       IF (NEDGE .LE. 1)                 GOTO 999
  37       KE     = 0
  38       DO 200 NE=1,NEDGE
  39         IF (EDGE(KCGX1,NE) .GT. EDGE(KCGX2,NE)+ERROR)   GOTO 120
  40         IF (EDGE(KCGX1,NE) .LT. EDGE(KCGX2,NE)-ERROR)   GOTO 110
  41         IF (EDGE(KCGY1,NE) .GT. EDGE(KCGY2,NE)+ERROR)   GOTO 120
  42         IF (EDGE(KCGY1,NE) .LT. EDGE(KCGY2,NE)-ERROR)   GOTO 110
  43         IF (EDGE(KCGZ1,NE) .GT. EDGE(KCGZ2,NE)+ERROR)   GOTO 120
  44         IF (EDGE(KCGZ1,NE) .LT. EDGE(KCGZ2,NE)-ERROR)   GOTO 110
  45         GOTO 200
  46   110   KE     = KE + 1
  47         IF (KE .EQ. NE)         GOTO 200
  48         EDGE(KCGAE,KE) = EDGE(KCGAE,NE)
  49         EDGE(KCGX1,KE) = EDGE(KCGX1,NE)
  50         EDGE(KCGY1,KE) = EDGE(KCGY1,NE)
  51         EDGE(KCGZ1,KE) = EDGE(KCGZ1,NE)
  52         EDGE(KCGX2,KE) = EDGE(KCGX2,NE)
  53         EDGE(KCGY2,KE) = EDGE(KCGY2,NE)
  54         EDGE(KCGZ2,KE) = EDGE(KCGZ2,NE)
  55         GOTO 200
  56   120   KE     = KE + 1
  57         EDGE(KCGAE,KE) = EDGE(KCGAE,NE)-ATRINV
  58         X      = EDGE(KCGX1,NE)
  59         Y      = EDGE(KCGY1,NE)
  60         Z      = EDGE(KCGZ1,NE)
  61         EDGE(KCGX1,KE) = EDGE(KCGX2,NE)
  62         EDGE(KCGY1,KE) = EDGE(KCGY2,NE)
  63         EDGE(KCGZ1,KE) = EDGE(KCGZ2,NE)
  64         EDGE(KCGX2,KE) = X
  65         EDGE(KCGY2,KE) = Y
  66         EDGE(KCGZ2,KE) = Z
  67   200   CONTINUE
  68       NEDGE = KE
  69 *
  70 **          S H E L L   S O R T   O F   E D G E S
  71 *
  72       IF (NEDGE .LE. 1)                 GOTO 999
  73       ISTEP  = 1
  74   210 ISTEP  = ISTEP*3 + 1
  75       IF (ISTEP*2 .LT. NEDGE)           GOTO 210
  76 *
  77   300 ISTEP  = ISTEP/3
  78       DO 500 I=1,NEDGE-ISTEP
  79         J1    = I
  80         J2    = I + ISTEP
  81 *           I F  (E D G E (J 1)  .L E.  E D G E (J 2))  G O T O  5 0 0
  82         IF (EDGE(KCGX1,J1) .LT. EDGE(KCGX1,J2)-ERROR)   GOTO 500
  83         IF (EDGE(KCGX1,J1) .GT. EDGE(KCGX1,J2)+ERROR)   GOTO 350
  84         IF (EDGE(KCGY1,J1) .LT. EDGE(KCGY1,J2)-ERROR)   GOTO 500
  85         IF (EDGE(KCGY1,J1) .GT. EDGE(KCGY1,J2)+ERROR)   GOTO 350
  86         IF (EDGE(KCGZ1,J1) .LT. EDGE(KCGZ1,J2)-ERROR)   GOTO 500
  87         IF (EDGE(KCGZ1,J1) .GT. EDGE(KCGZ1,J2)+ERROR)   GOTO 350
  88         IF (EDGE(KCGX2,J1) .LT. EDGE(KCGX2,J2)-ERROR)   GOTO 500
  89         IF (EDGE(KCGX2,J1) .GT. EDGE(KCGX2,J2)+ERROR)   GOTO 350
  90         IF (EDGE(KCGY2,J1) .LT. EDGE(KCGY2,J2)-ERROR)   GOTO 500
  91         IF (EDGE(KCGY2,J1) .GT. EDGE(KCGY2,J2)+ERROR)   GOTO 350
  92         IF (EDGE(KCGZ2,J1) .LT. EDGE(KCGZ2,J2)-ERROR)   GOTO 500
  93         IF (EDGE(KCGZ2,J1) .GT. EDGE(KCGZ2,J2)+ERROR)   GOTO 350
  94         GOTO 500
  95 *            S A V E = E D G E (J 2)
  96   350   SAVE(KCGAE) = EDGE(KCGAE,J2)
  97         SAVE(KCGX1) = EDGE(KCGX1,J2)
  98         SAVE(KCGY1) = EDGE(KCGY1,J2)
  99         SAVE(KCGZ1) = EDGE(KCGZ1,J2)
 100         SAVE(KCGX2) = EDGE(KCGX2,J2)
 101         SAVE(KCGY2) = EDGE(KCGY2,J2)
 102         SAVE(KCGZ2) = EDGE(KCGZ2,J2)
 103 *            E D G E (J 2) = E D G E (J 1)
 104   400   EDGE(KCGAE,J2) = EDGE(KCGAE,J1)
 105         EDGE(KCGX1,J2) = EDGE(KCGX1,J1)
 106         EDGE(KCGY1,J2) = EDGE(KCGY1,J1)
 107         EDGE(KCGZ1,J2) = EDGE(KCGZ1,J1)
 108         EDGE(KCGX2,J2) = EDGE(KCGX2,J1)
 109         EDGE(KCGY2,J2) = EDGE(KCGY2,J1)
 110         EDGE(KCGZ2,J2) = EDGE(KCGZ2,J1)
 111         J2     = J1
 112         J1     = J1 - ISTEP
 113         IF (J1 .LE. 0)     GOTO 450
 114 *           I F  (E D G E (J 1) .G T. S A V E)  G O T O  4 0 0
 115         IF (EDGE(KCGX1,J1) .LT. SAVE(KCGX1)-ERROR)      GOTO 450
 116         IF (EDGE(KCGX1,J1) .GT. SAVE(KCGX1)+ERROR)      GOTO 400
 117         IF (EDGE(KCGY1,J1) .LT. SAVE(KCGY1)-ERROR)      GOTO 450
 118         IF (EDGE(KCGY1,J1) .GT. SAVE(KCGY1)+ERROR)      GOTO 400
 119         IF (EDGE(KCGZ1,J1) .LT. SAVE(KCGZ1)-ERROR)      GOTO 450
 120         IF (EDGE(KCGZ1,J1) .GT. SAVE(KCGZ1)+ERROR)      GOTO 400
 121         IF (EDGE(KCGX2,J1) .LT. SAVE(KCGX2)-ERROR)      GOTO 450
 122         IF (EDGE(KCGX2,J1) .GT. SAVE(KCGX2)+ERROR)      GOTO 400
 123         IF (EDGE(KCGY2,J1) .LT. SAVE(KCGY2)-ERROR)      GOTO 450
 124         IF (EDGE(KCGY2,J1) .GT. SAVE(KCGY2)+ERROR)      GOTO 400
 125         IF (EDGE(KCGZ2,J1) .LT. SAVE(KCGZ2)-ERROR)      GOTO 450
 126         IF (EDGE(KCGZ2,J1) .GT. SAVE(KCGZ2)+ERROR)      GOTO 400
 127 *           E D G E (J 2) = S A V E
 128   450   EDGE(KCGAE,J2) = SAVE(KCGAE)
 129         EDGE(KCGX1,J2) = SAVE(KCGX1)
 130         EDGE(KCGY1,J2) = SAVE(KCGY1)
 131         EDGE(KCGZ1,J2) = SAVE(KCGZ1)
 132         EDGE(KCGX2,J2) = SAVE(KCGX2)
 133         EDGE(KCGY2,J2) = SAVE(KCGY2)
 134         EDGE(KCGZ2,J2) = SAVE(KCGZ2)
 135   500   CONTINUE
 136       IF (ISTEP .NE. 1)         GOTO 300
 137 *
 138   999 RETURN
 139       END