1 : C DIAMTR SOURCE CHAT 05/01/12 22:49:57 5004
2 : SUBROUTINE DIAMTR(N,E2,ADJ,XADJ,
3 : $ MASK,
4 : $ LS,XLS,HLEVEL,
5 : $ SNODE,NC,
6 : $ IMPR,IRET)
7 : IMPLICIT INTEGER(I-N)
8 : IMPLICIT REAL*8 (A-H,O-Z)
9 : C***********************************************************************
10 : C NOM : DIAMTR
11 : C DESCRIPTION : Find nodes which define a pseudo-diameter of a graph
12 : C and store distances from end node
13 : C
14 : C LANGAGE : FORTRAN 77 (sauf E/S)
15 : C
16 : C AUTEUR : Scott Sloan
17 : C
18 : C BIBLIO : @Article{,
19 : C author = {S. W. Sloan},
20 : C title = {A Fortran Program for Profile and Wavefront Reduction},
21 : C journal = {International Journal for Numerical Methods in Engineering},
22 : C year = {1989},
23 : C volume = {28},
24 : C pages = {2651-2679}
25 : C}
26 : C
27 : C***********************************************************************
28 : C APPELES : ROOTLS, ISHELII
29 : C APPELE PAR : LABEL
30 : C***********************************************************************
31 : C ENTREES :
32 : C N - The total number of nodes in the graph
33 : C E2 - Twice the number of edges in the graph = XADJ(N+1)-1
34 : C ADJ - Adjacency list for all nodes in graph
35 : C - List of length 2E where E is the number of edges in
36 : C the graph and 2E = XADJ(N+1)-1
37 : C XADJ - Index vector for ADJ
38 : C - Nodes adjacent to node I are found in ADJ(J), where
39 : C J = XADJ(I),...,XADJ(I+1)-1
40 : C - Degree of node I given by XADJ(I+1)-XADJ(I)
41 : C ENTREES/SORTIES : -
42 : C MASK(E)- Masking vector for graph
43 : C - Visible nodes have MASK = 0, node invisible otherwise
44 : C MASK(S)- List of distances of nodes from the end node
45 : C SORTIES :
46 : C LS - List of nodes in the component
47 : C SNODE - Starting node for numbering
48 : C NC - The number of nodes in this component of the graph
49 : C TABLEAUX DE TRAVAIL :
50 : C XLS - Not used
51 : C HLEVEL - Not used
52 : C
53 : C NOTES :
54 : C
55 : C SNODE and ENODE define a pseudo-diameter
56 : C
57 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
58 : C***********************************************************************
59 : C VERSION : v1, 05/11/99, version initiale
60 : C HISTORIQUE : v1, 10/03/89, création
61 : C HISTORIQUE : 21/02/00, correction d'un bug apparaissant pour un
62 : C graphe plein.
63 : C HISTORIQUE :
64 : C***********************************************************************
65 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
66 : C en cas de modification de ce sous-programme afin de faciliter
67 : C la maintenance !
68 : C***********************************************************************
69 : -INC CCOPTIO
70 : INTEGER NC,J,SNODE,DEGREE,MINDEG,ISTRT,ISTOP,HSIZE,NODE
71 : INTEGER JSTRT,JSTOP,EWIDTH,I,WIDTH,DEPTH,ENODE,N,SDEPTH,E2
72 : INTEGER XADJ(N+1),ADJ(E2),XLS(N+1),LS(N),MASK(N),HLEVEL(N)
73 : INTEGER IMPR,IRET
74 : *
75 : * Executable statements
76 : *
77 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans diamtr'
78 : *
79 : * Choose first guess for starting node by min degree
80 : * Ignore nodes that are invisible (MASK ne 0)
81 : *
82 : MINDEG=N
83 : DO 10 I=1,N
84 : IF (MASK(I).EQ.0) THEN
85 : DEGREE=XADJ(I+1)-XADJ(I)
86 : CAvant 21/02/00 IF (DEGREE.LT.MINDEG) THEN
87 : IF (DEGREE.LE.MINDEG) THEN
88 : SNODE=I
89 : MINDEG=DEGREE
90 : ENDIF
91 : ENDIF
92 : 10 CONTINUE
93 : *
94 : * Generate level structure for node with min degree
95 : *
95 : CALL ROOTLS(N,SNODE,N+1,E2,ADJ,XADJ,MASK,
96 : $ LS,XLS,SDEPTH,WIDTH,
97 : $ IMPR,IRET)
98 : IF (IRET.NE.0) GOTO 9999
99 : *
100 : * Store number of nodes in this component
101 : *
102 : NC=XLS(SDEPTH+1)-1
103 : *
104 : * Iterate to find start and end nodes
105 : *
106 : 15 CONTINUE
107 : *
108 : * Store list of nodes that are at max distance from starting node
109 : * Store their degrees in XLS
110 : *
111 : HSIZE=0
112 : ISTRT=XLS(SDEPTH)
113 : ISTOP=XLS(SDEPTH+1)-1
114 : DO 20 I=ISTRT,ISTOP
115 : NODE=LS(I)
116 : HSIZE=HSIZE+1
117 : HLEVEL(HSIZE)=NODE
118 : XLS(NODE)=XADJ(NODE+1)-XADJ(NODE)
119 : 20 CONTINUE
120 : *
121 : * Sort list of nodes in ascending sequence of their degree
122 : * Use (insertion sort algorithm) Shell's method
123 : *
124 : IF (HSIZE.GT.1) THEN
124 : CALL ISHELI(HSIZE,HLEVEL,N,XLS,
125 : $ IMPR,IRET)
126 : IF (IRET.NE.0) GOTO 9999
127 : ENDIF
128 : *
129 : * Remove nodes with duplicate degrees
130 : *
131 : ISTOP=HSIZE
132 : HSIZE=1
133 : DEGREE=XLS(HLEVEL(1))
134 : DO 25 I=2,ISTOP
135 : NODE=HLEVEL(I)
136 : IF (XLS(NODE).NE.DEGREE) THEN
137 : DEGREE=XLS(NODE)
138 : HSIZE=HSIZE+1
139 : HLEVEL(HSIZE)=NODE
140 : ENDIF
141 : 25 CONTINUE
142 : *
143 : * Loop over nodes in shrunken level
144 : *
145 : EWIDTH=NC+1
146 : DO 30 I=1,HSIZE
147 : NODE=HLEVEL(I)
148 : *
149 : * Form rooted level structures for each node in shrunken level
150 : *
150 : CALL ROOTLS(N,NODE,EWIDTH,E2,ADJ,XADJ,MASK,
151 : $ LS,XLS,DEPTH,WIDTH,
152 : $ IMPR,IRET)
153 : IF (IRET.NE.0) GOTO 9999
154 : IF (WIDTH.LT.EWIDTH) THEN
155 : *
156 : * Level structure was not aborted during assembly
157 : *
158 : IF (DEPTH.GT.SDEPTH) THEN
159 : *
160 : * Level structure of greater depth found
161 : * Store new starting node, new max depth, and begin
162 : * a new iteration
163 : *
164 : SNODE=NODE
165 : SDEPTH=DEPTH
166 : GOTO 15
167 : ENDIF
168 : *
169 : * Level structure width for this end node is smallest so far
170 : * store end node and new min width
171 : *
172 : ENODE=NODE
173 : EWIDTH=WIDTH
174 : ENDIF
175 : 30 CONTINUE
176 : *
177 : * Generate level structure rooted at end node if necessary
178 : *
179 : IF (NODE.NE.ENODE) THEN
179 : CALL ROOTLS(N,ENODE,NC+1,E2,ADJ,XADJ,MASK,
180 : $ LS,XLS,DEPTH,WIDTH,
181 : $ IMPR,IRET)
182 : IF (IRET.NE.0) GOTO 9999
183 : ENDIF
184 : *
185 : * Store distances of each node from end node
186 : *
187 : DO 50 I=1,DEPTH
188 : JSTRT=XLS(I)
189 : JSTOP=XLS(I+1)-1
190 : DO 40 J=JSTRT,JSTOP
191 : MASK(LS(J))=I-1
192 : 40 CONTINUE
193 : 50 CONTINUE
194 : *
195 : * Normal termination
196 : *
197 : IRET=0
198 : RETURN
199 : *
200 : * Format handling
201 : *
202 : *
203 : * Error handling
204 : *
205 : 9999 CONTINUE
206 : IRET=1
207 : WRITE(IOIMP,*) 'An error was detected in subroutine diamtr'
208 : RETURN
209 : *
210 : * End of subroutine DIAMTR
211 : *
212 : END
213 :
214 :
215 :
216 :
© Cast3M 2003 - All rights reserved.
Disclaimer