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.  
  70. -INC PPARAM
  71. -INC CCOPTIO
  72. INTEGER NC,J,SNODE,DEGREE,MINDEG,ISTRT,ISTOP,HSIZE,NODE
  73. INTEGER JSTRT,JSTOP,EWIDTH,I,WIDTH,DEPTH,ENODE,N,SDEPTH,E2
  74. INTEGER XADJ(N+1),ADJ(E2),XLS(N+1),LS(N),MASK(N),HLEVEL(N)
  75. INTEGER IMPR,IRET
  76. *
  77. * Executable statements
  78. *
  79. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans diamtr'
  80. *
  81. * Choose first guess for starting node by min degree
  82. * Ignore nodes that are invisible (MASK ne 0)
  83. *
  84. DO 10 I=1,N
  85. IF (MASK(I).EQ.0) THEN
  86. DEGREE=XADJ(I+1)-XADJ(I)
  87. CAvant 21/02/00 IF (DEGREE.LT.MINDEG) THEN
  88. IF (DEGREE.LE.MINDEG) THEN
  89. SNODE=I
  90. MINDEG=DEGREE
  91. ENDIF
  92. ENDIF
  93. 10 CONTINUE
  94. *
  95. * Generate level structure for node with min degree
  96. *
  97. CALL ROOTLS(N,SNODE,N+1,E2,ADJ,XADJ,MASK,
  98. $ LS,XLS,SDEPTH,WIDTH,
  99. $ IMPR,IRET)
  100. IF (IRET.NE.0) GOTO 9999
  101. *
  102. * Store number of nodes in this component
  103. *
  104. NC=XLS(SDEPTH+1)-1
  105. *
  106. * Iterate to find start and end nodes
  107. *
  108. 15 CONTINUE
  109. *
  110. * Store list of nodes that are at max distance from starting node
  111. * Store their degrees in XLS
  112. *
  113. HSIZE=0
  114. ISTRT=XLS(SDEPTH)
  115. ISTOP=XLS(SDEPTH+1)-1
  116. DO 20 I=ISTRT,ISTOP
  117. NODE=LS(I)
  118. HSIZE=HSIZE+1
  119. HLEVEL(HSIZE)=NODE
  120. XLS(NODE)=XADJ(NODE+1)-XADJ(NODE)
  121. 20 CONTINUE
  122. *
  123. * Sort list of nodes in ascending sequence of their degree
  124. * Use (insertion sort algorithm) Shell's method
  125. *
  126. IF (HSIZE.GT.1) THEN
  127. CALL ISHELI(HSIZE,HLEVEL,N,XLS,
  128. $ IMPR,IRET)
  129. IF (IRET.NE.0) GOTO 9999
  130. ENDIF
  131. *
  132. * Remove nodes with duplicate degrees
  133. *
  134. ISTOP=HSIZE
  135. HSIZE=1
  136. DEGREE=XLS(HLEVEL(1))
  137. DO 25 I=2,ISTOP
  138. NODE=HLEVEL(I)
  139. IF (XLS(NODE).NE.DEGREE) THEN
  140. DEGREE=XLS(NODE)
  141. HSIZE=HSIZE+1
  142. HLEVEL(HSIZE)=NODE
  143. ENDIF
  144. 25 CONTINUE
  145. *
  146. * Loop over nodes in shrunken level
  147. *
  148. EWIDTH=NC+1
  149. DO 30 I=1,HSIZE
  150. NODE=HLEVEL(I)
  151. *
  152. * Form rooted level structures for each node in shrunken level
  153. *
  154. CALL ROOTLS(N,NODE,EWIDTH,E2,ADJ,XADJ,MASK,
  155. $ LS,XLS,DEPTH,WIDTH,
  156. $ IMPR,IRET)
  157. IF (IRET.NE.0) GOTO 9999
  158. IF (WIDTH.LT.EWIDTH) THEN
  159. *
  160. * Level structure was not aborted during assembly
  161. *
  162. IF (DEPTH.GT.SDEPTH) THEN
  163. *
  164. * Level structure of greater depth found
  165. * Store new starting node, new max depth, and begin
  166. * a new iteration
  167. *
  168. SNODE=NODE
  169. SDEPTH=DEPTH
  170. GOTO 15
  171. ENDIF
  172. *
  173. * Level structure width for this end node is smallest so far
  174. * store end node and new min width
  175. *
  176. ENODE=NODE
  177. EWIDTH=WIDTH
  178. ENDIF
  179. 30 CONTINUE
  180. *
  181. * Generate level structure rooted at end node if necessary
  182. *
  183. IF (NODE.NE.ENODE) THEN
  184. CALL ROOTLS(N,ENODE,NC+1,E2,ADJ,XADJ,MASK,
  185. $ LS,XLS,DEPTH,WIDTH,
  186. $ IMPR,IRET)
  187. IF (IRET.NE.0) GOTO 9999
  188. ENDIF
  189. *
  190. * Store distances of each node from end node
  191. *
  192. DO 50 I=1,DEPTH
  193. JSTRT=XLS(I)
  194. JSTOP=XLS(I+1)-1
  195. DO 40 J=JSTRT,JSTOP
  196. MASK(LS(J))=I-1
  197. 40 CONTINUE
  198. 50 CONTINUE
  199. *
  200. * Normal termination
  201. *
  202. IRET=0
  203. RETURN
  204. *
  205. * Format handling
  206. *
  207. *
  208. * Error handling
  209. *
  210. 9999 CONTINUE
  211. IRET=1
  212. WRITE(IOIMP,*) 'An error was detected in subroutine diamtr'
  213. RETURN
  214. *
  215. * End of subroutine DIAMTR
  216. *
  217. END
  218.  
  219.  
  220.  
  221.  
  222.  

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