Télécharger prgpsk.eso

Retour à la liste

Numérotation des lignes :

  1. C PRGPSK SOURCE CHAT 05/01/13 02:26:27 5004
  2. SUBROUTINE PRGPSK(ADJAC,OPTPRO,
  3. $ NEWNUM,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : PRGPSK
  9. C DESCRIPTION : Renumérotation d'un graphe symétrique par la méthode de
  10. C Gibbs-King ou de Gibbs-Poole-Stockmeyer.
  11. C Prépare la renumérotation par la méthode de
  12. C 1) Gibbs-King si OPTPRO = .TRUE. (réduction du profile)
  13. C 1) Gibbs-Poole-Stockmeyer
  14. C si OPTPRO = .FALSE. (bandwidth reduction)
  15. C
  16. C LANGAGE : ESOPE
  17. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  18. C mél : gounand@semt2.smts.cea.fr
  19. C BIBLIO : @Article{,
  20. C author = {S. W. Sloan},
  21. C title = {A Fortran Program for Profile and Wavefront Reduction},
  22. C journal = {International Journal for Numerical Methods in Engineering},
  23. C year = {1989},
  24. C volume = {28},
  25. C pages = {2651-2679}
  26. C}
  27. C
  28. C***********************************************************************
  29. C APPELES : GPSKCA, PROFI1
  30. C APPELE PAR : RENUME
  31. C***********************************************************************
  32. C ENTREES : ADJAC, OPTPRO
  33. C SORTIES : NEWNUM
  34. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  35. C***********************************************************************
  36. C VERSION : v1, 10/11/99, version initiale
  37. C HISTORIQUE : v1, 10/11/99, création
  38. C HISTORIQUE :
  39. C HISTORIQUE :
  40. C***********************************************************************
  41. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  42. C en cas de modification de ce sous-programme afin de faciliter
  43. C la maintenance !
  44. C***********************************************************************
  45. -INC CCOPTIO
  46. -INC SMLENTI
  47. INTEGER JG
  48. POINTEUR IWORK.MLENTI
  49. POINTEUR NEWNUM.MLENTI
  50. POINTEUR DEGREE.MLENTI
  51. *
  52. * Segment LSTIND (liste séquentielle indexée)
  53. *
  54. SEGMENT LSTIND
  55. INTEGER IDX(NBM+1)
  56. INTEGER IVAL(NBTVAL)
  57. ENDSEGMENT
  58. *
  59. * LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  60. *
  61. * NBM : NOMBRE DE MULTIPLETS
  62. * NBTVAL : NOMBRE TOTAL DE VALEURS
  63. * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME
  64. * MULTIPLET DANS LE TABLEAU IVAL
  65. * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  66. *
  67. *-INC SLSTIND
  68. POINTEUR ADJAC.LSTIND
  69. INTEGER IMPR,IRET
  70. *
  71. INTEGER ITOTPO
  72. INTEGER NTOTPO
  73. LOGICAL OPTPRO
  74. INTEGER WRKLEN,BANDWD,PROFI,ERROR,SPACE
  75. *
  76. * Executable statements
  77. *
  78. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans prgpsk'
  79. SEGACT ADJAC
  80. NTOTPO=ADJAC.IDX(/1)-1
  81. JG=NTOTPO
  82. SEGINI DEGREE
  83. DO 1 ITOTPO=1,NTOTPO
  84. DEGREE.LECT(ITOTPO)=ADJAC.IDX(ITOTPO+1)
  85. $ -ADJAC.IDX(ITOTPO)
  86. 1 CONTINUE
  87. JG=NTOTPO
  88. SEGINI NEWNUM
  89. DO 3 ITOTPO=1,NTOTPO
  90. NEWNUM.LECT(ITOTPO)=ITOTPO
  91. 3 CONTINUE
  92. WRKLEN=(6*NTOTPO)+3
  93. JG=WRKLEN
  94. SEGINI IWORK
  95. CALL GPSKCA(NTOTPO,DEGREE.LECT,ADJAC.IDX,ADJAC.IVAL,OPTPRO,WRKLEN,
  96. $ NEWNUM.LECT,
  97. $ IWORK.LECT,
  98. $ BANDWD,PROFI,
  99. $ ERROR,SPACE)
  100. IF (ERROR.NE.0) THEN
  101. WRITE(IOIMP,*) 'ERROR=',ERROR, 'in GPSKCA'
  102. GOTO 9999
  103. ENDIF
  104. SEGSUP IWORK
  105. SEGSUP DEGREE
  106. SEGDES NEWNUM
  107. SEGDES ADJAC
  108. IF (IMPR.GT.3) THEN
  109. WRITE(IOIMP,*) 'BANDWD = ',BANDWD
  110. WRITE(IOIMP,*) 'PROFI = ',PROFI
  111. ENDIF
  112. *
  113. * Normal termination
  114. *
  115. IRET=0
  116. RETURN
  117. *
  118. * Format handling
  119. *
  120. *
  121. * Error handling
  122. *
  123. 9999 CONTINUE
  124. IRET=1
  125. WRITE(IOIMP,*) 'An error was detected in subroutine prgpsk'
  126. RETURN
  127. *
  128. * End of subroutine PRGPSK
  129. *
  130. END
  131.  
  132.  
  133.  
  134.  
  135.  

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