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
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