Télécharger diamtr.eso

Retour à la liste

Numérotation des lignes :

  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. DO 10 I=1,N
  83. IF (MASK(I).EQ.0) THEN
  84. DEGREE=XADJ(I+1)-XADJ(I)
  85. CAvant 21/02/00 IF (DEGREE.LT.MINDEG) THEN
  86. IF (DEGREE.LE.MINDEG) THEN
  87. SNODE=I
  88. MINDEG=DEGREE
  89. ENDIF
  90. ENDIF
  91. 10 CONTINUE
  92. *
  93. * Generate level structure for node with min degree
  94. *
  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
  125. CALL ISHELI(HSIZE,HLEVEL,N,XLS,
  126. $ IMPR,IRET)
  127. IF (IRET.NE.0) GOTO 9999
  128. ENDIF
  129. *
  130. * Remove nodes with duplicate degrees
  131. *
  132. ISTOP=HSIZE
  133. HSIZE=1
  134. DEGREE=XLS(HLEVEL(1))
  135. DO 25 I=2,ISTOP
  136. NODE=HLEVEL(I)
  137. IF (XLS(NODE).NE.DEGREE) THEN
  138. DEGREE=XLS(NODE)
  139. HSIZE=HSIZE+1
  140. HLEVEL(HSIZE)=NODE
  141. ENDIF
  142. 25 CONTINUE
  143. *
  144. * Loop over nodes in shrunken level
  145. *
  146. EWIDTH=NC+1
  147. DO 30 I=1,HSIZE
  148. NODE=HLEVEL(I)
  149. *
  150. * Form rooted level structures for each node in shrunken level
  151. *
  152. CALL ROOTLS(N,NODE,EWIDTH,E2,ADJ,XADJ,MASK,
  153. $ LS,XLS,DEPTH,WIDTH,
  154. $ IMPR,IRET)
  155. IF (IRET.NE.0) GOTO 9999
  156. IF (WIDTH.LT.EWIDTH) THEN
  157. *
  158. * Level structure was not aborted during assembly
  159. *
  160. IF (DEPTH.GT.SDEPTH) THEN
  161. *
  162. * Level structure of greater depth found
  163. * Store new starting node, new max depth, and begin
  164. * a new iteration
  165. *
  166. SNODE=NODE
  167. SDEPTH=DEPTH
  168. GOTO 15
  169. ENDIF
  170. *
  171. * Level structure width for this end node is smallest so far
  172. * store end node and new min width
  173. *
  174. ENODE=NODE
  175. EWIDTH=WIDTH
  176. ENDIF
  177. 30 CONTINUE
  178. *
  179. * Generate level structure rooted at end node if necessary
  180. *
  181. IF (NODE.NE.ENODE) THEN
  182. CALL ROOTLS(N,ENODE,NC+1,E2,ADJ,XADJ,MASK,
  183. $ LS,XLS,DEPTH,WIDTH,
  184. $ IMPR,IRET)
  185. IF (IRET.NE.0) GOTO 9999
  186. ENDIF
  187. *
  188. * Store distances of each node from end node
  189. *
  190. DO 50 I=1,DEPTH
  191. JSTRT=XLS(I)
  192. JSTOP=XLS(I+1)-1
  193. DO 40 J=JSTRT,JSTOP
  194. MASK(LS(J))=I-1
  195. 40 CONTINUE
  196. 50 CONTINUE
  197. *
  198. * Normal termination
  199. *
  200. IRET=0
  201. RETURN
  202. *
  203. * Format handling
  204. *
  205. *
  206. * Error handling
  207. *
  208. 9999 CONTINUE
  209. IRET=1
  210. WRITE(IOIMP,*) 'An error was detected in subroutine diamtr'
  211. RETURN
  212. *
  213. * End of subroutine DIAMTR
  214. *
  215. END
  216.  
  217.  
  218.  
  219.  
  220.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales