Télécharger mklblc.eso

Retour à la liste

Numérotation des lignes :

  1. C MKLBLC SOURCE PV 06/04/16 21:16:53 5405
  2. SUBROUTINE MKLBLC(LMPRIB,KRMPRI,LIPNLC,NELC,
  3. $ LILBLC,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : MKLBLC
  9. C DESCRIPTION : Construction d'une liste indexée de correspondance :
  10. C matrice élémentaire B -> liste des matrices élémentaires
  11. C ayant un point de leurs maillages primaux en commun.
  12. C
  13. C
  14. C
  15. C LANGAGE : ESOPE
  16. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  17. C mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES : -
  20. C APPELE PAR : PROMAT
  21. C***********************************************************************
  22. C ENTREES : LMPRIB, KRMPRI, LIPNLC, NELC
  23. C SORTIES : LILBLC
  24. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  25. C***********************************************************************
  26. C VERSION : v1, 07/02/2000, version initiale
  27. C HISTORIQUE : v1, 07/02/2000, création
  28. C HISTORIQUE :
  29. C HISTORIQUE :
  30. C***********************************************************************
  31. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  32. C en cas de modification de ce sous-programme afin de faciliter
  33. C la maintenance !
  34. C***********************************************************************
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC SMLENTI
  39. POINTEUR KRMPRI.MLENTI
  40. INTEGER JG
  41. POINTEUR KRELC.MLENTI
  42. * Includes persos
  43. * Segment LSTIND (liste séquentielle indexée)
  44. INTEGER NBM,NBTVAL
  45. SEGMENT LSTIND
  46. INTEGER IDX(NBM+1)
  47. INTEGER IVAL(NBTVAL)
  48. ENDSEGMENT
  49. *-INC SLSTIND
  50. POINTEUR LMPRIB.LSTIND
  51. POINTEUR LIPNLC.LSTIND
  52. POINTEUR LILBLC.LSTIND
  53. *
  54. INTEGER NELC
  55. INTEGER IMPR,IRET
  56. *
  57. INTEGER LDG,NELB
  58. INTEGER IDG,IELB,IELC,ILPOPB
  59. INTEGER IVPRIB,IVSTRT,IVSTOP
  60. INTEGER JVPNLC,JVSTRT,JVSTOP
  61. INTEGER IVLBLC,LAST,PREC
  62. *
  63. * Executable statements
  64. *
  65. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans mklblc.eso'
  66. * Dimensionnement de LILBLC
  67. * Pour l'instant LILBLC.IDX(IELB+1)=nombre de matrices élémentaires de
  68. * IMATC reliées à la IELBème matrice élémentaire de IMATB
  69. SEGACT LMPRIB
  70. NELB=LMPRIB.IDX(/1)-1
  71. SEGACT KRMPRI
  72. SEGACT LIPNLC
  73. JG=NELC
  74. SEGINI KRELC
  75. NBM=NELB
  76. NBTVAL=0
  77. SEGINI LILBLC
  78. DO 1 IELB=1,NELB
  79. * Degré et fin de la liste chaînée
  80. LDG=0
  81. LAST=-1
  82. IVSTRT=LMPRIB.IDX(IELB)
  83. IVSTOP=LMPRIB.IDX(IELB+1)-1
  84. DO 12 IVPRIB=IVSTRT,IVSTOP
  85. ILPOPB=KRMPRI.LECT(LMPRIB.IVAL(IVPRIB))
  86. ** pv que faire si ilpopb=0 ?????
  87. if (ilpopb.eq.0) goto 12
  88. JVSTRT=LIPNLC.IDX(ILPOPB)
  89. JVSTOP=LIPNLC.IDX(ILPOPB+1)-1
  90. DO 122 JVPNLC=JVSTRT,JVSTOP
  91. IELC=LIPNLC.IVAL(JVPNLC)
  92. IF (KRELC.LECT(IELC).EQ.0) THEN
  93. LDG=LDG+1
  94. KRELC.LECT(IELC)=LAST
  95. LAST=IELC
  96. ENDIF
  97. 122 CONTINUE
  98. 12 CONTINUE
  99. LILBLC.IDX(IELB+1)=LDG
  100. * Remise à zéro de la liste chaînée
  101. DO 14 IDG=1,LDG
  102. PREC=KRELC.LECT(LAST)
  103. KRELC.LECT(LAST)=0
  104. LAST=PREC
  105. 14 CONTINUE
  106. 1 CONTINUE
  107. * LILBLC.IDX est transformé en la liste d'indexation sur
  108. * LILBLC.IVAL
  109. LILBLC.IDX(1)=1
  110. DO 3 IELB=1,NELB
  111. LILBLC.IDX(IELB+1)=LILBLC.IDX(IELB+1)+LILBLC.IDX(IELB)
  112. 3 CONTINUE
  113. NBM=NELB
  114. NBTVAL=LILBLC.IDX(NELB+1)-1
  115. SEGADJ,LILBLC
  116. * Remplissage de LILBLC
  117. IVLBLC=0
  118. DO 5 IELB=1,NELB
  119. * Degré et fin de la liste chaînée
  120. LDG=0
  121. LAST=-1
  122. IVSTRT=LMPRIB.IDX(IELB)
  123. IVSTOP=LMPRIB.IDX(IELB+1)-1
  124. DO 52 IVPRIB=IVSTRT,IVSTOP
  125. ILPOPB=KRMPRI.LECT(LMPRIB.IVAL(IVPRIB))
  126. ** pv que faire si ilpopb=0 ?????
  127. if (ilpopb.eq.0) goto 52
  128. JVSTRT=LIPNLC.IDX(ILPOPB)
  129. JVSTOP=LIPNLC.IDX(ILPOPB+1)-1
  130. DO 522 JVPNLC=JVSTRT,JVSTOP
  131. IELC=LIPNLC.IVAL(JVPNLC)
  132. IF (KRELC.LECT(IELC).EQ.0) THEN
  133. LDG=LDG+1
  134. KRELC.LECT(IELC)=LAST
  135. LAST=IELC
  136. ENDIF
  137. 522 CONTINUE
  138. 52 CONTINUE
  139. * Remise à zéro de la liste chaînée et vidage dans LILBLC
  140. DO 54 IDG=1,LDG
  141. PREC=KRELC.LECT(LAST)
  142. IVLBLC=IVLBLC+1
  143. LILBLC.IVAL(IVLBLC)=LAST
  144. KRELC.LECT(LAST)=0
  145. LAST=PREC
  146. 54 CONTINUE
  147. 5 CONTINUE
  148. SEGDES LILBLC
  149. SEGSUP KRELC
  150. SEGDES LIPNLC
  151. SEGDES KRMPRI
  152. SEGDES LMPRIB
  153. *
  154. * Normal termination
  155. *
  156. IRET=0
  157. RETURN
  158. *
  159. * Format handling
  160. *
  161. *
  162. * Error handling
  163. *
  164. 9999 CONTINUE
  165. IRET=1
  166. WRITE(IOIMP,*) 'An error was detected in subroutine mklblc'
  167. RETURN
  168. *
  169. * End of subroutine MKLBLC
  170. *
  171. END
  172.  
  173.  
  174.  
  175.  
  176.  

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