Télécharger corinc.eso

Retour à la liste

Numérotation des lignes :

  1. C CORINC SOURCE PV 05/12/01 21:15:02 5252
  2. SUBROUTINE CORINC(KRINCD,KRINCP,
  3. $ KRIDUN,LIPUN,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : CORINC
  9. C PROJET : Assemblage matrice élémentaire -> matrice Morse
  10. C DESCRIPTION : Construction d'une liste indexée de correspondance :
  11. C (nom d'inconnue duale)->(noms d'inconnues primales
  12. C associées)
  13. C
  14. C LANGAGE : ESOPE
  15. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  16. C mél : gounand@semt2.smts.cea.fr
  17. C***********************************************************************
  18. C APPELES : IUNIQ, IREPER
  19. C APPELE PAR : MKPMOR
  20. C***********************************************************************
  21. C ENTREES : KRINCD, KRINCP
  22. C SORTIES : KRIDUN, LIPUN
  23. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  24. C***********************************************************************
  25. C VERSION : v1, 18/11/99, version initiale
  26. C HISTORIQUE : v1, 18/11/99, création
  27. C HISTORIQUE :
  28. C HISTORIQUE :
  29. C***********************************************************************
  30. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  31. C en cas de modification de ce sous-programme afin de faciliter
  32. C la maintenance !
  33. C***********************************************************************
  34. -INC CCOPTIO
  35. -INC SMLENTI
  36. INTEGER JG
  37. POINTEUR KRINCD.MLENTI
  38. POINTEUR KRINCP.MLENTI
  39. POINTEUR KRIDUN.MLENTI
  40. POINTEUR KRCDUN.MLENTI
  41. *
  42. * Includes perso
  43. *
  44. *
  45. * Segment LSTIND (liste séquentielle indexée)
  46. *
  47. SEGMENT LSTIND
  48. INTEGER IDX(NBM+1)
  49. INTEGER IVAL(NBTVAL)
  50. ENDSEGMENT
  51. *
  52. * LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  53. *
  54. * NBM : NOMBRE DE MULTIPLETS
  55. * NBTVAL : NOMBRE TOTAL DE VALEURS
  56. * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME
  57. * MULTIPLET DANS LE TABLEAU IVAL
  58. * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  59. *-INC SLSTIND
  60. INTEGER NBM,NBTVAL
  61. POINTEUR LIPUN.LSTIND
  62. *
  63. INTEGER IMPR,IRET
  64. *
  65. INTEGER IDXCOU,INOZER
  66. INTEGER ICOMPD,IDUNIQ
  67. INTEGER NCOMPD,NDUNIQ,NCOMPP,NINCP
  68. LOGICAL LFOUND
  69. *
  70. * Executable statements
  71. *
  72. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans corinc'
  73. C On détermine le nombre de composantes primales distinctes
  74. SEGACT KRINCD
  75. NCOMPD=KRINCD.LECT(/1)
  76. JG=NCOMPD
  77. SEGINI KRIDUN
  78. CALL IUNIQ(KRINCD.LECT,NCOMPD,
  79. $ KRIDUN.LECT,NDUNIQ,
  80. $ IMPR,IRET)
  81. IF (IRET.NE.0) GOTO 9999
  82. JG=NDUNIQ
  83. SEGADJ,KRIDUN
  84. * On construit la liste de repérage de KRINCD dans KRIDUN
  85. JG=NCOMPD
  86. SEGINI KRCDUN
  87. CALL IREPER(NCOMPD,NDUNIQ,
  88. $ KRINCD.LECT,KRIDUN.LECT,
  89. $ KRCDUN.LECT,
  90. $ IMPR,IRET)
  91. C Pour chaque composante primale distincte, il faut déterminer
  92. C avec quels composantes duales distinctes il est relié :
  93. C Par exemple, si on a :
  94. C KRINCD = 1 1 1 2
  95. C KRINCP = 2 2 3 4
  96. C On a : KRIDUN = 1 2
  97. C On veut : LIPUN = (2 3) (4) (c'est une liste indexée)
  98. SEGACT KRINCP
  99. NCOMPP=KRINCP.LECT(/1)
  100. NBM=NDUNIQ
  101. * Au maximum, chaque élément KRINCD est relié à tous les
  102. * autres de KRINCP
  103. NBTVAL=NDUNIQ*NCOMPP
  104. SEGINI LIPUN
  105. * On remplit la liste des index
  106. LIPUN.IDX(1)=1
  107. DO 1 IDUNIQ=1,NDUNIQ
  108. LIPUN.IDX(IDUNIQ+1)=LIPUN.IDX(IDUNIQ)+NCOMPP
  109. 1 CONTINUE
  110. * On construit la liste de correspondance contenant éventuellement
  111. * des zéros que l'on supprimme après
  112. DO 3 ICOMPD=1,NCOMPD
  113. IDUNIQ=KRCDUN.LECT(ICOMPD)
  114. IDXCOU=LIPUN.IDX(IDUNIQ)
  115. NINCP=KRINCP.LECT(ICOMPD)
  116. 5 CONTINUE
  117. LFOUND=(LIPUN.IVAL(IDXCOU).EQ.NINCP)
  118. IF (LIPUN.IVAL(IDXCOU).NE.0.AND.(.NOT.LFOUND)) THEN
  119. IDXCOU=IDXCOU+1
  120. GOTO 5
  121. ENDIF
  122. IF (.NOT.LFOUND) THEN
  123. LIPUN.IVAL(IDXCOU)=NINCP
  124. ENDIF
  125. 3 CONTINUE
  126. * On supprimme les zéros
  127. INOZER=1
  128. IDXCOU=1
  129. DO 7 IDUNIQ=1,NDUNIQ
  130. 9 CONTINUE
  131. IF (IDXCOU.LE.LIPUN.IVAL(/1)) THEN
  132. IF (LIPUN.IVAL(IDXCOU).NE.0) THEN
  133. LIPUN.IVAL(INOZER)=LIPUN.IVAL(IDXCOU)
  134. INOZER=INOZER+1
  135. IDXCOU=IDXCOU+1
  136. GOTO 9
  137. ENDIF
  138. ENDIF
  139. IDXCOU=LIPUN.IDX(IDUNIQ+1)
  140. LIPUN.IDX(IDUNIQ+1)=INOZER
  141. 7 CONTINUE
  142. NBTVAL=LIPUN.IDX(NDUNIQ+1)-1
  143. SEGADJ,LIPUN
  144. SEGDES LIPUN
  145. SEGDES KRINCP
  146. SEGSUP KRCDUN
  147. SEGDES KRIDUN
  148. SEGDES KRINCD
  149. *
  150. * Normal termination
  151. *
  152. IRET=0
  153. RETURN
  154. *
  155. * Format handling
  156. *
  157. *
  158. * Error handling
  159. *
  160. 9999 CONTINUE
  161. IRET=1
  162. WRITE(IOIMP,*) 'An error was detected in subroutine corinc'
  163. RETURN
  164. *
  165. * End of subroutine CORINC
  166. *
  167. END
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  

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