Numérotation des lignes :

1. C ADCHEL SOURCE CB215821 20/11/04 21:15:05 10766
3. C_______________________________________________________________________
4. C
5. C ADDITION / SOUSTRACTION DE 2 CHPS PAR ELEMENTS
6. C
7. C ( ADDITION :IEPS=1 ; SOUSTRACTION IEPS=-1 )
8. C
9. C ENTREE :
10. C --------
11. C
12. C IPCHE1 POINTEUR SUR LE PREMIER CHAMPS (TYPE MCHAML)
13. C IPCHE2 POINTEUR SUR LE DEUXIEME CHAMPS (TYPE MCHALM)
14. C IEPS = 1 ADDITION
15. C =-1 SOUSTRACTION
16. C
17. C SORTIE :
18. C ________
19. C
20. C IPCHAD POINTEUR SUR LE CHAMPS SOMME (TYPE MCHAML)
21. C = 0 SI L OPERATION EST IMPOSSIBLE
22. C
23. C MESSAGE D ERREUR DECHENCHE SI IPCHAD=0
24. C
25. C LES 2 CHAM PAR ELEMENT PEUVENT AVOIR DES SUPPORTS GEOMETRIQUES
26. C DIFFERENTS POUR PEU QUE LES OBJETS AFFECTES ELEMENTAIRES QUI LES
27. C SOUS TENDENT FORMENT UNE PARTITION DE LA GEOMETRIE
28. C
29. C CODE EBERSOLT JUILLET 84 PASSAGE 4331 FEVRIER 85
30. C
31. C ON PEUT ADDITIONNER A UN CHAMELEM QUELCONQUE UN CHAMELEM A UNE
32. C COMPOSANTE
33. C
34. C MODIFIE SEPTEMBRE 86
35. C
36. C PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 29 10 90
37. C +PP EXTENSION ADDITION P.PEGON 24/11/92
38. C
39. C CB215821 : Gestion de la soustraction avec des SOUS-ZONES disjointes
40. C_______________________________________________________________________
41. C
42. IMPLICIT INTEGER(I-N)
43. IMPLICIT REAL*8(A-H,O-Z)
44. CHARACTER*16 TYPCH2
45. -INC SMCHAML
46. -INC SMLREEL
47. -INC SMCOORD
48.
49. -INC PPARAM
50. -INC CCOPTIO
51. C
52. SEGMENT MZONG
53. INTEGER NZONG(0)
54. ENDSEGMENT
55. C
56. SEGMENT MZON1
57. INTEGER NZON1(0)
58. ENDSEGMENT
59. C
60. SEGMENT MZON2
61. INTEGER NZON2(0)
62. ENDSEGMENT
63. C
64. SEGMENT ITAFF
65. INTEGER JTAFF(0)
66. ENDSEGMENT
67. C
68. SEGMENT MPTVAL
69. INTEGER IPOS(NS) ,NSOF(NS)
70. INTEGER IVAL(NCOSOU)
71. CHARACTER*16 TYVAL(NCOSOU)
72. ENDSEGMENT
73. C
74. PARAMETER ( NINF=3 )
75. INTEGER INFOS(NINF)
76. CHARACTER*72 MOT
77. CHARACTER*16 CONCH1,CONCH2
78. LOGICAL BOOLSO
79. C
80.
81. BOOLSO=.FALSE.
82.
83. IF(IEPS.EQ. 1) XX= 1.D0
84. IF(IEPS.EQ.-1) XX=-1.D0
85. C if (ieps.eq.-1) then
86. C write (6,*) ' adchel soustraction de chamelem '
87. C endif
88.
89.
90.
91. IF(IPCHE1.NE.IPCHE2) GOTO 1000
92. C
93. C SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL
94. C
95. MCHEL1=IPCHE1
96. MCHEL2=IPCHE2
97. SEGINI,MCHELM=MCHEL1
99. NSOUS = IMACHE(/1)
100. IF (IEPS.EQ. 1) XX=2
101. IF (IEPS.EQ.-1) XX=0
102. C
103. DO 110 IA=1,NSOUS
104. MCHAM1=ICHAML(IA)
105. SEGINI,MCHAML=MCHAM1
106. ICHAML(IA)=MCHAML
107. DO 111 ICOMP=1,IELVAL(/1)
108. MELVA1 = IELVAL(ICOMP)
109. SEGINI,MELVAL=MELVA1
110. N1PTEL=VELCHE(/1)
111. IF (N1PTEL.EQ.0) THEN
112. N2PTEL=IELCHE(/1)
113. N2EL =IELCHE(/2)
114. IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
115. DO 121 IGAU=1,N2PTEL
116. DO 122 IB=1,N2EL
117. MLREE1=IELCHE(IGAU,IB)
118. IF(MLREE1.EQ.0)THEN
119. MLREEL=MLREE1
120. ELSE
121. SEGACT MLREE1
122. JG=MLREE1.PROG(/1)
123. SEGINI MLREEL
124. DO 123 IPROG=1,JG
125. PROG(IPROG)=XX*MLREE1.PROG(IPROG)
126. 123 CONTINUE
127. ENDIF
128. IELCHE(IGAU,IB)=MLREEL
129. 122 CONTINUE
130. 121 CONTINUE
131. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
132. DO 125 IGAU=1,N2PTEL
133. DO 126 IB=1,N2EL
134. MEVOL1=IELCHE(IGAU,IB)
136. IELCHE(IGAU,IB)=MEVOL2
137. 126 CONTINUE
138. 125 CONTINUE
139. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN
140. SEGACT,MCOORD*mod
141. NBNO=NBPTS
142. NBNOI=NBNO
143. NBPTS=NBNO+(N2PTEL*N2EL)
145. DO 131 IGAU=1,N2PTEL
146. DO 132 IB=1,N2EL
147. IP=IELCHE(IGAU,IB)
148. IF(IP.EQ.0)THEN
149. NBPTS=IP
150. ELSE
151. IREF=(IP-1)*(IDIM+1)
152. C
153. DO 133 IC=1,IDIM
154. XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX
155. 133 CONTINUE
156. XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
157. ENDIF
158. IELCHE(IGAU,IB)=NBNOI+1
159. NBNOI=NBNOI+1
160. 132 CONTINUE
161. 131 CONTINUE
162. ELSE
163. C
164. C NOM DE COMPOSANTE NON RECONNU
165. C
166. MOTERR(1:4)=NOMCHE(ICOMP)
167. CALL ERREUR(197)
169. SEGSUP MELVAL,MCHAML,MCHELM
170. RETURN
171. ENDIF
172. ELSE
173. N1EL=VELCHE(/2)
174. DO 151 IGAU=1,N1PTEL
175. DO 152 IB=1,N1EL
176. VELCHE(IGAU,IB)=XX*VELCHE(IGAU,IB)
177. 152 CONTINUE
178. 151 CONTINUE
179. ENDIF
180. IELVAL(ICOMP) = MELVAL
181. 111 CONTINUE
182. 110 CONTINUE
183. GOTO 777
184. C
185. C CAS GENERAL
186. C
187. 1000 CONTINUE
188. MCHEL1=IPCHE1
189. MCHEL2=IPCHE2
190. SEGACT MCHEL1
191. SEGACT MCHEL2
192. IF(MCHEL1.IFOCHE.EQ.MCHEL2.IFOCHE) GOTO 3000
193. C
194. C ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
195. C DE SS TYPE DIFFERENTS
196. C
197. MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
198. CALL ERREUR(99)
200. GOTO 666
201. C_______________________________________________________________________
202. C
203. C CAS GENERAL
204. C_______________________________________________________________________
205. C
206. 3000 CONTINUE
207. MOT=MCHEL1.TITCHE
208. L1=MCHEL1.TITCHE(/1)
209. IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE' .OR.MOT.EQ.'RIGIDITE'.OR.
210. & MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'.OR.MOT.EQ.'SCALAIRE') THEN
211. MOT= MCHEL2.TITCHE
212. L1 = MCHEL2.TITCHE(/1)
213. ENDIF
214. N3=MCHEL1.INFCHE(/2)
215. NSOUS1=MCHEL1.ICHAML(/1)
216. NSOUS2=MCHEL2.ICHAML(/1)
217. C
218. C QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE
219. C
220. IF(NSOUS1.NE.NSOUS2) GOTO 4000
221. C
222. SEGINI ITAFF
223. DO 17 ISOUS1=1,NSOUS1
224. IPMAI1 = MCHEL1.IMACHE(ISOUS1)
225. CONCH1 = MCHEL1.CONCHE(ISOUS1)
226. DO 18 ISOUS2=1,NSOUS2
227. ISOUS=ISOUS2
228. IPMAI2= MCHEL2.IMACHE(ISOUS)
229. CONCH2= MCHEL2.CONCHE(ISOUS)
230. IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
231. C
232. C VERIFICATION POUR LES INFCHE
233. C
234. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
235. IF (IRTD.EQ.0) GOTO 18
236. IMINT1=0
237. IMINT2=0
238. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
239. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
240. IF (IMINT1.EQ.IMINT2) GOTO 171
241. IMINT1=1
242. IMINT2=1
243. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
244. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
245. IF (IMINT1.EQ.0) IMINT1=1
246. IF (IMINT2.EQ.0) IMINT2=1
247. IF (IMINT1.EQ.IMINT2) GOTO 171
248. C
249. C ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
250. C DE SS TYPE DIFFERENTS
251. C
252. MOTERR(1:8)=MCHEL1.TITCHE
253. MOTERR(9:16)=MCHEL2.TITCHE
254. CALL ERREUR(329)
255. SEGSUP ITAFF
257. RETURN
258. ENDIF
259. 18 CONTINUE
260. SEGSUP ITAFF
261. GOTO 4000
262.
263. 171 CONTINUE
264. C Ici, on a trouve que la zone ISOUS1 et ISOUS2 ont meme maillage,
265. c meme constituant, meme segment d'integration
266. JTAFF(**)=MCHEL2.ICHAML(ISOUS)
267.
268. 17 CONTINUE
269. C
270. C ON A TROUVE UNE BIJECTION ET ON VECTORISE
271. C
272. N1=NSOUS1
273. SEGINI MCHELM
274. TITCHE=MOT
275. IFOCHE=IFOUR
277. DO 400 ISOUS=1,NSOUS1
278. IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
279. CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
280. DO 401 N33=1,N3
281. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
282. 401 CONTINUE
283. C
284. MCHAM1=MCHEL1.ICHAML(ISOUS)
285. C
286. SEGINI,MCHAML=MCHAM1
287. ICHAML(ISOUS)=MCHAML
288. IPCHA=MCHAML
289. C
290. MCHAM2=JTAFF(ISOUS)
291. SEGACT MCHAM2
292. IPCHA2=MCHAM2
293. C
295. IF (IPCHA.EQ.0) THEN
296. SEGSUP ITAFF
297. GOTO 9990
298. ENDIF
299. C
300. 400 CONTINUE
301. SEGSUP ITAFF
302. GOTO 666
303. C_______________________________________________________________________
304. C
305. C ON A PAS TROUVE DE BIJECTION
306. C_______________________________________________________________________
307. C
308. 4000 CONTINUE
309. SEGINI MZONG,MZON1,MZON2
310. DO 500 ISOUS1=1,NSOUS1
311. NZONG(**)=MCHEL1.IMACHE(ISOUS1)
312. NZON1(**)=ISOUS1
313. NZON2(**)=0
314. 500 CONTINUE
315. IWRN=0
316. DO 510 ISOUS2=1,NSOUS2
317. IPMAI2 = MCHEL2.IMACHE(ISOUS2)
318. CONCH2 = MCHEL2.CONCHE(ISOUS2)
319. DO 520 ISOUS1=1,NSOUS1
320. IPMAI1= MCHEL1.IMACHE(ISOUS1)
321. CONCH1= MCHEL1.CONCHE(ISOUS1)
322. IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN
323. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
324. IF (IRTD.EQ.0) GOTO 520
325. C
326. C VERIFICATION POUR LES MINTES
327. C
328. IF ( MCHEL1.INFCHE(ISOUS1,6).EQ.
329. & MCHEL2.INFCHE(ISOUS2,6) ) GOTO 530
330. C
331. C ERREUR SUR LES SUPPORTS DES MCHAML
332. C
333. MOTERR(1:8) =MCHEL1.TITCHE
334. MOTERR(9:16)=MCHEL2.TITCHE
335. CALL ERREUR(329)
337. SEGSUP MZONG,MZON1,MZON2
338. RETURN
339. ENDIF
340. 520 CONTINUE
341. IWRN=1
342. NZONG(**)=IPMAI2
343. NZON1(**)=0
344. NZON2(**)=ISOUS2
345. GOTO 510
346. C
347. 530 CONTINUE
348. if (nzon2(isous1).ne.0) call erreur(329)
349. NZON2(ISOUS1)=ISOUS2
350. 510 CONTINUE
351. C
352. C WARNING LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
353. C
354. C IF(IWRN.EQ.1) CALL ERREUR(103)
355. NSOUS=NZONG(/1)
356. N1=NSOUS
357. SEGINI MCHELM
358. TITCHE=MOT
359. IFOCHE=IFOUR
361. C
362. DO 540 ISOUS=1,NSOUS
363. BOOLSO=.FALSE.
364. IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
365. C
366. IF(NZON1(ISOUS).NE.0) THEN
367. MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
368. SEGINI,MCHAML=MCHAM1
369. IMACHE(ISOUS)=NZONG(ISOUS)
370. CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
371. DO 402 N33=1,N3
372. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
373. 402 CONTINUE
374. C
375. ENDIF
376. IF(NZON2(ISOUS).NE.0) THEN
377. IF(IEPS .EQ. -1) BOOLSO=.TRUE.
378. MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
379. SEGINI,MCHAML=MCHAM2
380. IMACHE(ISOUS)=NZONG(ISOUS)
381. CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) )
382. DO 403 N33=1,N3
383. INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33)
384. 403 CONTINUE
385. C
386. ENDIF
387. ICHAML(ISOUS)=MCHAML
388. C
389. DO 175 ICOMP=1,IELVAL(/1)
390. MELVA1=IELVAL(ICOMP)
391. SEGINI,MELVAL=MELVA1
392. IELVAL(ICOMP)=MELVAL
393. C CB215821 Si c'est la soustraction qu'on demande il faut faire * XX...
394. C sur les SOUS-ZONES issues du 2ème MCHAML (BOOLSO = .TRUE.)
395. IF (BOOLSO) THEN
396. c N1PTEL=MELVAL.VELCHE(/1)
397. c IF(N1PTEL .NE. 0) THEN
398. c C Cas REAL*8
399. c N1EL =MELVAL.VELCHE(/2)
400. c DO IGAU=1,N1PTEL
401. c DO IB=1,N1EL
402. c MELVAL.VELCHE(IGAU,IB)=MELVAL.VELCHE(IGAU,IB) * XX
403. c ENDDO
404. c ENDDO
405. c
406. c ELSE
407. c C Cas POINTEUR
408. c N2PTEL=IELCHE(/1)
409. c N2EL =IELCHE(/2)
410. c IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
411. c DO IGAU=1,N2PTEL
412. c DO IB=1,N2EL
413. c ILREE1=IELCHE(IGAU,IB)
414. c CALL MUFLIR(ILREE1,XX,ILREEL,1)
415. c IELCHE(IGAU,IB)=ILREEL
416. c ENDDO
417. c ENDDO
418. c
419. c ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN
420. c SEGACT,MCOORD
421. c NBNO=nbpts
422. c NBNOI=NBNO
423. c NBPTS=NBNO+(N2PTEL*N2EL)
425. c DO IGAU=1,N2PTEL
426. c DO IB=1,N2EL
427. c IP =IELCHE(IGAU,IB)
428. c IREF=(IP-1)*(IDIM+1)
429. c C
430. c DO IC=1,IDIM
431. c XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX
432. c ENDDO
433. c XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
434. c IELCHE(IGAU,IB)=NBNOI+1
435. c NBNOI=NBNOI+1
436. c ENDDO
437. c ENDDO
438. c
439. c ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
440. c DO IGAU=1,N2PTEL
441. c DO IB=1,N2EL
442. c IEVOL1=IELCHE(IGAU,IB)
443. c CALL MUFLEV(IEVOL1,XX,IEVOL2,IEPS)
444. c IELCHE(IGAU,IB)=IEVOL2
445. c ENDDO
446. c ENDDO
447. c
448. c ELSE
449. c MOTERR(1:4)=NOMCHE(ICOMP)
450. c CALL ERREUR(197)
451. c RETURN
452. c ENDIF
453. c ENDIF
454. cbp, 2020 : lignes ci-dessus deportees et mutualisees dans :
455. TYPCH2=TYPCHE(ICOMP)
456. CALL MULMEL(MELVAL,XX,TYPCH2)
457. ENDIF
458. 175 CONTINUE
459. C
460. GOTO 540
461. C
462. 550 CONTINUE
463. MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
464. SEGINI,MCHAML=MCHAM1
465. IMACHE(ISOUS)=NZONG(ISOUS)
466. CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
467. DO 404 N33=1,N3
468. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
469. 404 CONTINUE
470. ICHAML(ISOUS)=MCHAML
471. IPCHA=MCHAML
472. MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
473. SEGACT MCHAM2
474. IPCHA2=MCHAM2
475. C
477. IF (IPCHA.EQ.0) THEN
478. SEGSUP MZONG,MZON1,MZON2
479. GOTO 9990
480. ENDIF
481. C
482. 540 CONTINUE
483. C
484. SEGSUP MZONG,MZON1,MZON2
485. GOTO 666
486. C
487. 9990 CONTINUE
488. C
489. C ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
490. C
491. SEGSUP MCHAML,MCHELM,ITAFF
493. RETURN
494. C
495. 666 CONTINUE
496. 777 CONTINUE
497.
498. END
499.
500.
501.
502.
503.
504.
505.

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