Télécharger la plaquette Cast3M


fr en

Télécharger diamtr.eso

Retour à la liste

Numérotation des lignes : 

diamtr

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

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