Télécharger ccon1.eso

Retour à la liste

Numérotation des lignes :

  1. C CCON1 SOURCE CHAT 05/01/12 21:50:20 5004
  2. SUBROUTINE CCON1(MELEME,IRETO)
  3. IMPLICIT INTEGER(I-N)
  4. -INC SMCOORD
  5. -INC SMELEME
  6. -INC CCOPTIO
  7. -INC SMLENTI
  8. REAL*8 XDE
  9. CHARACTER*1 CHE
  10. LOGICAL LOGE
  11. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  12. SEGMENT INUINV(XCOOR(/1)/(IDIM+1))
  13. SEGMENT JMEM(NODES)
  14. SEGMENT MEMJT(NKON)
  15. SEGMENT IPOME(NODES+1)
  16. SEGMENT ICONC(NODES)
  17. SEGMENT IDEJ(NODES)
  18. SEGMENT IPRI(NODES)
  19. *** SEGACT MELEME
  20. *
  21. * LOGIQUE : ON PREND UN POINT PUIS TOUS LES ELEMENTS TOUCHANT
  22. * POINT PUIS ON DIT LE S NOEUDS VOISINS ET ON BOUCLE SUR LES NOEUDS
  23. * CONCERNEES NON DEJA TRAITES
  24. *
  25. * ON REGARDE L'ENSEMBLE DES NOEUDS DES NOEUDS DE MELEME ET ON CONSTRUIT
  26. * LE TABLEAU DONNANT LES ELEMENTS TOUCHANT CHAQUE NOEUD
  27. *
  28. SEGINI ICPR,INUINV
  29. SEGACT MELEME*MOD
  30. IPT1=MELEME
  31. IRETO=0
  32. IKOU=0
  33. DO 202 IO=1,MAX(1,LISOUS(/1))
  34. IF (LISOUS(/1).NE.0) THEN
  35. IPT1=LISOUS(IO)
  36. SEGACT IPT1*MOD
  37. ENDIF
  38. DO 203 I=1,IPT1.NUM(/1)
  39. DO 203 J=1,IPT1.NUM(/2)
  40. IJ=IPT1.NUM(I,J)
  41. IF (ICPR(IJ).NE.0) GOTO 203
  42. IKOU=IKOU+1
  43. ICPR(IJ)=IKOU
  44. INUINV(IKOU)=IJ
  45. 203 CONTINUE
  46. 202 CONTINUE
  47. NODES=IKOU
  48. SEGINI JMEM ,IPOME
  49. IPT1=MELEME
  50. NGRAND=0
  51. NMAX=0
  52. DO 3 IO=1,MAX(1,LISOUS(/1))
  53. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  54. DO 4 I=1,IPT1.NUM(/1)
  55. DO 4 J=1,IPT1.NUM(/2)
  56. JMEM(ICPR(IPT1.NUM(I,J)))=JMEM(ICPR(IPT1.NUM(I,J)))+1
  57. 4 CONTINUE
  58. NGRAND=MAX(NGRAND,IPT1.NUM(/2))
  59. NMAX=NMAX+IPT1.NUM(/2)
  60. 3 CONTINUE
  61. NGRAND=NGRAND+1
  62. IPOME(1)=0
  63. DO 6 I=1,NODES
  64. IPOME(I+1)=IPOME (I) + JMEM(I)
  65. 6 CONTINUE
  66. DO 7 I=1,NODES
  67. JMEM(I)=0
  68. 7 CONTINUE
  69. NKON=IPOME(NODES+1)
  70. SEGINI MEMJT
  71. IPT1=MELEME
  72. DO 101 IO=1,MAX(1,LISOUS(/1))
  73. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  74. DO 100 I=1,IPT1.NUM(/2)
  75. DO 100 J=1,IPT1.NUM(/1)
  76. IND=ICPR(IPT1.NUM(J,I))
  77. JMEM(IND)=JMEM(IND)+1
  78. MEMJT(IPOME(IND)+JMEM(IND))=I+NGRAND*IO
  79. 100 CONTINUE
  80. 101 CONTINUE
  81. *
  82. * quelques initialisations
  83. *
  84. * WRITE(6,FMT='('' NODES '' ,I5)') NODES
  85. SEGINI IDEJ,ICONC,IPRI
  86. INDE=0
  87. *
  88. * debut de tourner en rond.
  89. *
  90. 50 CONTINUE
  91. DO 51 I=1,NODES
  92. ICONC(I)=0
  93. IPRI(I)=0
  94. 51 CONTINUE
  95. DO 52 I=1,NODES
  96. IF(IDEJ(I).EQ.0) GO TO 54
  97. 52 CONTINUE
  98. GO TO 59
  99. 54 CONTINUE
  100. IDEP=I
  101. * WRITE(6,FMT='('' POINT DE DEPART '',I5)') IDEP
  102. INC=1
  103. INA=1
  104. ICONC(INC)=IDEP
  105. IPRI(IDEP)=1
  106. 55 CONTINUE
  107. INO=INC
  108. DO 57 I=INA,INO
  109. INU=ICONC(I)
  110. IF(IDEJ(INU).NE.0) THEN
  111. CALL ERREUR (5)
  112. ELSE
  113. IDEJ(INU)=1
  114. ENDIF
  115. K4=JMEM(INU)
  116. JSUB=IPOME(INU)
  117. * WRITE(6,FMT='('' NOEUD NBVOIS DDEB'',3I5)')INUINV(INU),
  118. * $ K4,JSUB
  119. DO 40 JJ=1,K4
  120. IND=JSUB+JJ
  121. K6=MEMJT(IND)
  122. IAIA= K6/NGRAND
  123. IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  124. SEGACT IPT1*MOD
  125. K6=MOD(K6,NGRAND)
  126. IF(IPT1.NUM(1,K6).LE.0) GO TO 40
  127. IPT1.NUM(1,K6)=-IPT1.NUM(1,K6)
  128. * WRITE(6,FMT='('' ELEMENT NUMERO '',I5)') K6
  129. DO 85 L=1,IPT1.NUM(/1)
  130. K5=ICPR(ABS(IPT1.NUM(L,K6)))
  131. IF (IPRI(K5).GT.0) GO TO 85
  132. INC=INC+1
  133. ICONC(INC)=K5
  134. IPRI(K5)=1
  135. * WRITE(6,FMT= '('' NOEUD NUMERO '',I5)') INUINV(K5)
  136. 85 CONTINUE
  137. 40 CONTINUE
  138. 57 CONTINUE
  139. IF(INO.NE.INC) THEN
  140. * WRITE(6,FMT='('' ON BOUCLE INA INO INC'',3I5)') INA,INO,INC
  141. INA=INO+1
  142. GO TO 55
  143. ENDIF
  144. *
  145. * on vient de trouver une composante connexe
  146. *
  147. 59 CONTINUE
  148. * WRITE(6,FMT=' ('' UNE COMPOSANTE CONNEXES TROUVEE '')')
  149. *
  150. * on cree une table si pas deja fait puis remise de meleme en positif
  151. *
  152. IF(IRETO.EQ.0) THEN
  153. JG=1
  154. SEGINI MLENTI
  155. IRETO=MLENTI
  156. ELSE
  157. SEGACT MLENTI
  158. JG=JG+1
  159. SEGADJ MLENTI
  160. ENDIF
  161. DO 71 K=1,MAX(1,LISOUS(/1))
  162. IF(LISOUS(/1).NE.0) IPT1=LISOUS(K)
  163. DO 73 KI=1,IPT1.NUM(/2)
  164. IPT1.NUM(1,KI)=ABS(IPT1.NUM(1,KI))
  165. 73 CONTINUE
  166. 71 CONTINUE
  167. NBNN=1
  168. NBELEM=INO
  169. NBSOUS=0
  170. NBREF=0
  171. SEGINI IPT2
  172. DO 70 I=1,INO
  173. IPT2.NUM(1,I)=INUINV(ICONC(I))
  174. 70 CONTINUE
  175. IPT2.ITYPEL=1
  176. SEGDES IPT2
  177. CALL ECRCHA('APPUYER')
  178. CALL ECROBJ('MAILLAGE',IPT2)
  179. CALL ECROBJ('MAILLAGE',MELEME)
  180. CALL EXTREL (IRR,1,LIEL)
  181. SEGSUP IPT2
  182. CALL LIROBJ('MAILLAGE',IPT,1,IRETAY)
  183. IF(IERR.NE.0) THEN
  184. CALL ERREUR(5)
  185. RETURN
  186. ENDIF
  187. SEGACT MELEME*MOD
  188. DO 2020 IO=1,MAX(1,LISOUS(/1))
  189. IF (LISOUS(/1).NE.0) THEN
  190. IPT1=LISOUS(IO)
  191. SEGACT IPT1*MOD
  192. ENDIF
  193. 2020 CONTINUE
  194. LECT(JG)=IPT
  195. INDE=INDE+INO
  196. IF(INDE.NE.NODES) GO TO 50
  197. 1000 CONTINUE
  198. SEGDES MLENTI
  199. IF(LISOUS(/1).NE.0) THEN
  200. DO 74 K=1,LISOUS(/1)
  201. IPT1=LISOUS(K)
  202. SEGDES IPT1
  203. 74 CONTINUE
  204. ENDIF
  205. SEGDES MELEME
  206. SEGSUP ICPR,ICONC,IDEJ,IPRI,MEMJT,JMEM,INUINV,IPOME
  207. RETURN
  208. END
  209.  
  210.  
  211.  
  212.  

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