Télécharger renume.eso

Retour à la liste

Numérotation des lignes :

  1. C RENUME SOURCE PV 16/11/17 22:01:20 9180
  2. SUBROUTINE RENUME(PMTOT,
  3. $ IRENU,
  4. $ NEWNUM,
  5. $ IMPR,IRET)
  6. IMPLICIT INTEGER(I-N)
  7. IMPLICIT REAL*8 (A-H,O-Z)
  8. C***********************************************************************
  9. C NOM : RENUME
  10. C PROJET : Noyau linéaire NLIN
  11. C DESCRIPTION : On cherche une nouvelle numérotation des inconnues
  12. C pour minimiser le profil ou la largeur de bande d'un
  13. C profil d'une matrice Morse par les diverses méthodes
  14. C disponibles.
  15. C
  16. C IRENU=1 'RIEN' : pas de renumérotation
  17. C 2 'SLOA' : algorithme de chez Sloan
  18. C 3 'GIPR' : Gibbs-King (profile reduction)
  19. C 4 'GIBA' : Gibbs-Poole-Stockmeyer (bandwidth reduction)
  20. C
  21. C LANGAGE : ESOPE
  22. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  23. C mél : gounand@semt2.smts.cea.fr
  24. C***********************************************************************
  25. C APPELES : PRGRAP, PRSLOA, PRGPSK
  26. C APPELE PAR : PRASEM
  27. C***********************************************************************
  28. C ENTREES : PMTOT, IRENU
  29. C SORTIES : NEWNUM
  30. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  31. C***********************************************************************
  32. C VERSION : v1, 26/11/99, version initiale
  33. C HISTORIQUE : v1, 26/11/99, création
  34. C HISTORIQUE :
  35. C HISTORIQUE :
  36. C***********************************************************************
  37. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  38. C en cas de modification de ce sous-programme afin de faciliter
  39. C la maintenance !
  40. C***********************************************************************
  41. -INC CCOPTIO
  42. POINTEUR PMTOT.PMORS
  43. -INC SMLENTI
  44. INTEGER JG
  45. POINTEUR NEWNUM.MLENTI
  46. *-INC SLSTIND
  47. *
  48. * Segment LSTIND (liste séquentielle indexée)
  49. *
  50. SEGMENT LSTIND
  51. INTEGER IDX(NBM+1)
  52. INTEGER IVAL(NBTVAL)
  53. ENDSEGMENT
  54. *
  55. * LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  56. *
  57. * NBM : NOMBRE DE MULTIPLETS
  58. * NBTVAL : NOMBRE TOTAL DE VALEURS
  59. * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME
  60. * MULTIPLET DANS LE TABLEAU IVAL
  61. * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  62. POINTEUR ADJAC.LSTIND
  63. *
  64. INTEGER IRENU
  65. INTEGER IMPR,IRET
  66. *
  67. INTEGER ITOTPO,NTOTPO
  68. INTEGER E2,NEWPRO,OLDPRO,NEWPR2,OLDPR2
  69. LOGICAL OPTPRO,ISROK
  70. *
  71. * Executable statements
  72. *
  73. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans renume'
  74. *
  75. * Construction de la renumérotation...
  76. *
  77. IF (IRENU.GE.2.AND.IRENU.LE.4) THEN
  78. * construction du graphe symétrique (Sloan et Gibbs-King ont besoin
  79. * sue le graphe soit symétrique)
  80. *
  81. * In PRGRAP : SEGINI ADJAC
  82. CALL PRGRAP(PMTOT,
  83. $ ADJAC,
  84. $ IMPR,IRET)
  85. IF (IRET.NE.0) GOTO 9999
  86. *
  87. * ...par l'algorithme de l'article de Sloan
  88. IF (IRENU.EQ.2) THEN
  89. CALL PRSLOA(ADJAC,
  90. $ NEWNUM,
  91. $ IMPR,IRET)
  92. IF (IRET.NE.0) GOTO 9999
  93. * ...par l'algorithme TOMS 582
  94. ELSEIF (IRENU.EQ.3) THEN
  95. OPTPRO=.TRUE.
  96. CALL PRGPSK(ADJAC,OPTPRO,
  97. $ NEWNUM,
  98. $ IMPR,IRET)
  99. IF (IRET.NE.0) GOTO 9999
  100. ELSEIF (IRENU.EQ.4) THEN
  101. OPTPRO=.FALSE.
  102. CALL PRGPSK(ADJAC,OPTPRO,
  103. $ NEWNUM,
  104. $ IMPR,IRET)
  105. IF (IRET.NE.0) GOTO 9999
  106. ELSE
  107. WRITE(IOIMP,*) 'Erreur de programmation...'
  108. GOTO 9999
  109. ENDIF
  110. SEGACT NEWNUM
  111. IF (IMPR.GT.2) THEN
  112. SEGACT ADJAC
  113. *
  114. * Compute profiles of adjacency list
  115. * for old and new node numbers
  116. *
  117. NTOTPO=ADJAC.IDX(/1)-1
  118. E2=ADJAC.IDX(NTOTPO+1)-1
  119. CALL PROFI1(NTOTPO,NEWNUM.LECT,E2,ADJAC.IVAL,ADJAC.IDX,
  120. $ OLDPR2,NEWPR2,
  121. $ IMPR,IRET)
  122. IF (IRET.NE.0) GOTO 9999
  123. WRITE(IOIMP,*) 'Profil symétrique non ordonné = ',OLDPR2
  124. WRITE(IOIMP,*) 'Profil symétrique ordonné = ',NEWPR2
  125. SEGDES ADJAC
  126. ENDIF
  127. SEGSUP ADJAC
  128. SEGACT PMTOT
  129. NTOTPO=PMTOT.IA(/1)-1
  130. E2=PMTOT.IA(NTOTPO+1)-1
  131. CALL PROFI1(NTOTPO,NEWNUM.LECT,E2,PMTOT.JA,PMTOT.IA,
  132. $ OLDPRO,NEWPRO,
  133. $ IMPR,IRET)
  134. IF (IRET.NE.0) GOTO 9999
  135. SEGDES PMTOT
  136. IF (IMPR.GT.1) THEN
  137. WRITE(IOIMP,*) 'Profil Morse non ordonné = ',OLDPRO
  138. WRITE(IOIMP,*) 'Profil Morse ordonné = ',NEWPRO
  139. ENDIF
  140. SEGDES NEWNUM
  141. IF (OLDPRO.LT.NEWPRO) THEN
  142. ISROK=.FALSE.
  143. ELSE
  144. ISROK=.TRUE.
  145. ENDIF
  146. ENDIF
  147. *
  148. * ...non effectuée
  149. IF (IRENU.EQ.1.OR.(.NOT.ISROK)) THEN
  150. IF (IRENU.EQ.1) THEN
  151. SEGACT PMTOT
  152. NTOTPO=PMTOT.IA(/1)-1
  153. SEGDES PMTOT
  154. JG=NTOTPO
  155. SEGINI NEWNUM
  156. ELSEIF (.NOT.ISROK) THEN
  157. SEGACT NEWNUM*MOD
  158. NTOTPO=NEWNUM.LECT(/1)
  159. ENDIF
  160. DO 1 ITOTPO=1,NTOTPO
  161. NEWNUM.LECT(ITOTPO)=ITOTPO
  162. 1 CONTINUE
  163. * SEGDES NEWNUM
  164. SEGDES NEWNUM
  165. IF (IMPR.GT.2) THEN
  166. WRITE(IOIMP,*) 'Pas de renumérotation effectuée'
  167. ENDIF
  168. ENDIF
  169. *
  170. * Normal termination
  171. *
  172. IRET=0
  173. RETURN
  174. *
  175. * Format handling
  176. *
  177. *
  178. * Error handling
  179. *
  180. 9999 CONTINUE
  181. IRET=1
  182. WRITE(IOIMP,*) 'An error was detected in subroutine renume'
  183. RETURN
  184. *
  185. * End of subroutine RENUME
  186. *
  187. END
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  
  195.  

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