Télécharger adchel.eso

Retour à la liste

Numérotation des lignes :

  1. C ADCHEL SOURCE PV 17/01/25 21:15:04 9291
  2. SUBROUTINE ADCHEL(IPCHE1,IPCHE2,IPCHAD,IEPS)
  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. -INC SMCHAML
  45. -INC SMLREEL
  46. -INC SMCOORD
  47. -INC CCOPTIO
  48. C
  49. SEGMENT MZONG
  50. INTEGER NZONG(0)
  51. ENDSEGMENT
  52. C
  53. SEGMENT MZON1
  54. INTEGER NZON1(0)
  55. ENDSEGMENT
  56. C
  57. SEGMENT MZON2
  58. INTEGER NZON2(0)
  59. ENDSEGMENT
  60. C
  61. SEGMENT ITAFF
  62. INTEGER JTAFF(0)
  63. ENDSEGMENT
  64. C
  65. SEGMENT MPTVAL
  66. INTEGER IPOS(NS) ,NSOF(NS)
  67. INTEGER IVAL(NCOSOU)
  68. CHARACTER*16 TYVAL(NCOSOU)
  69. ENDSEGMENT
  70. C
  71. PARAMETER ( NINF=3 )
  72. INTEGER INFOS(NINF)
  73. CHARACTER*72 MOT
  74. CHARACTER*16 CONCH1,CONCH2
  75. LOGICAL BOOLSO
  76. C
  77.  
  78. BOOLSO=.FALSE.
  79.  
  80. IF(IEPS.EQ. 1) XX= 1.D0
  81. IF(IEPS.EQ.-1) XX=-1.D0
  82. C if (ieps.eq.-1) then
  83. C write (6,*) ' adchel soustraction de chamelem '
  84. C endif
  85.  
  86.  
  87.  
  88. IF(IPCHE1.NE.IPCHE2) GOTO 1000
  89. C
  90. C SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL
  91. C
  92. MCHEL1=IPCHE1
  93. MCHEL2=IPCHE2
  94. SEGINI,MCHELM=MCHEL1
  95. IPCHAD = MCHELM
  96. NSOUS = IMACHE(/1)
  97. IF (IEPS.EQ. 1) XX=2
  98. IF (IEPS.EQ.-1) XX=0
  99. C
  100. DO 110 IA=1,NSOUS
  101. MCHAM1=ICHAML(IA)
  102. SEGINI,MCHAML=MCHAM1
  103. ICHAML(IA)=MCHAML
  104. DO 111 ICOMP=1,IELVAL(/1)
  105. MELVA1 = IELVAL(ICOMP)
  106. SEGINI,MELVAL=MELVA1
  107. N1PTEL=VELCHE(/1)
  108. IF (N1PTEL.EQ.0) THEN
  109. N2PTEL=IELCHE(/1)
  110. N2EL =IELCHE(/2)
  111. IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  112. DO 1 IGAU=1,N2PTEL
  113. DO 1 IB=1,N2EL
  114. MLREE1=IELCHE(IGAU,IB)
  115. IF(MLREE1.EQ.0)THEN
  116. MLREEL=MLREE1
  117. ELSE
  118. SEGACT MLREE1
  119. JG=MLREE1.PROG(/1)
  120. SEGINI MLREEL
  121. DO 2 IPROG=1,JG
  122. PROG(IPROG)=XX*MLREE1.PROG(IPROG)
  123. 2 CONTINUE
  124. SEGDES MLREE1,MLREEL
  125. ENDIF
  126. IELCHE(IGAU,IB)=MLREEL
  127. 1 CONTINUE
  128. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  129. DO 11 IGAU=1,N2PTEL
  130. DO 11 IB=1,N2EL
  131. MEVOL1=IELCHE(IGAU,IB)
  132. CALL ADEVOL(MEVOL1,MEVOL1,MEVOL2,IEPS)
  133. IELCHE(IGAU,IB)=MEVOL2
  134. 11 CONTINUE
  135. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN
  136. SEGACT,MCOORD
  137. NBNO=XCOOR(/1)/(IDIM+1)
  138. NBNOI=NBNO
  139. NBPTS=NBNO+(N2PTEL*N2EL)
  140. SEGADJ,MCOORD
  141. DO 3 IGAU=1,N2PTEL
  142. DO 3 IB=1,N2EL
  143. IP=IELCHE(IGAU,IB)
  144. IF(IP.EQ.0)THEN
  145. NBPTS=IP
  146. ELSE
  147. IREF=(IP-1)*(IDIM+1)
  148. C
  149. DO 4 IC=1,IDIM
  150. XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX
  151. 4 CONTINUE
  152. XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
  153. ENDIF
  154. IELCHE(IGAU,IB)=NBNOI+1
  155. NBNOI=NBNOI+1
  156. 3 CONTINUE
  157. ELSE
  158. C
  159. C NOM DE COMPOSANTE NON RECONNU
  160. C
  161. MOTERR(1:4)=NOMCHE(ICOMP)
  162. CALL ERREUR(197)
  163. IPCHAD=0
  164. SEGDES MCHEL1,MCHEL2
  165. SEGSUP MELVAL,MCHAML,MCHELM
  166. RETURN
  167. ENDIF
  168. ELSE
  169. N1EL=VELCHE(/2)
  170. DO 5 IGAU=1,N1PTEL
  171. DO 5 IB=1,N1EL
  172. VELCHE(IGAU,IB)=XX*VELCHE(IGAU,IB)
  173. 5 CONTINUE
  174. ENDIF
  175. IELVAL(ICOMP) = MELVAL
  176. SEGDES MELVAL,melva1
  177. 111 CONTINUE
  178. SEGDES MCHAML
  179. 110 CONTINUE
  180. SEGDES MCHELM
  181. GOTO 777
  182. C
  183. C CAS GENERAL
  184. C
  185. 1000 CONTINUE
  186. MCHEL1=IPCHE1
  187. MCHEL2=IPCHE2
  188. SEGACT MCHEL1
  189. SEGACT MCHEL2
  190. IF(MCHEL1.IFOCHE.EQ.MCHEL2.IFOCHE) GOTO 3000
  191. C
  192. C ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  193. C DE SS TYPE DIFFERENTS
  194. C
  195. MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
  196. CALL ERREUR(99)
  197. IPCHAD=0
  198. GOTO 666
  199. C_______________________________________________________________________
  200. C
  201. C CAS GENERAL
  202. C_______________________________________________________________________
  203. C
  204. 3000 CONTINUE
  205. MOT=MCHEL1.TITCHE
  206. L1=MCHEL1.TITCHE(/1)
  207. IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE' .OR.MOT.EQ.'RIGIDITE'.OR.
  208. & MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'.OR.MOT.EQ.'SCALAIRE') THEN
  209. MOT= MCHEL2.TITCHE
  210. L1 = MCHEL2.TITCHE(/1)
  211. ENDIF
  212. N3=MCHEL1.INFCHE(/2)
  213. NSOUS1=MCHEL1.ICHAML(/1)
  214. NSOUS2=MCHEL2.ICHAML(/1)
  215. C
  216. C QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE
  217. C
  218. IF(NSOUS1.NE.NSOUS2) GOTO 4000
  219. C
  220. SEGINI ITAFF
  221. DO 17 ISOUS1=1,NSOUS1
  222. IPMAI1 = MCHEL1.IMACHE(ISOUS1)
  223. CONCH1 = MCHEL1.CONCHE(ISOUS1)
  224. DO 18 ISOUS2=1,NSOUS2
  225. ISOUS=ISOUS2
  226. IPMAI2= MCHEL2.IMACHE(ISOUS)
  227. CONCH2= MCHEL2.CONCHE(ISOUS)
  228. IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
  229. C
  230. C VERIFICATION POUR LES INFCHE
  231. C
  232. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  233. IF (IRTD.EQ.0) GOTO 18
  234. IMINT1=0
  235. IMINT2=0
  236. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  237. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  238. IF (IMINT1.EQ.IMINT2) GOTO 171
  239. IMINT1=1
  240. IMINT2=1
  241. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  242. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  243. IF (IMINT1.EQ.0) IMINT1=1
  244. IF (IMINT2.EQ.0) IMINT2=1
  245. IF (IMINT1.EQ.IMINT2) GOTO 171
  246. C
  247. C ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
  248. C DE SS TYPE DIFFERENTS
  249. C
  250. MOTERR(1:8)=MCHEL1.TITCHE
  251. MOTERR(9:16)=MCHEL2.TITCHE
  252. CALL ERREUR(329)
  253. SEGDES MCHEL1,MCHEL2
  254. SEGSUP ITAFF
  255. IPCHAD=0
  256. RETURN
  257. ENDIF
  258. 18 CONTINUE
  259. SEGSUP ITAFF
  260. GOTO 4000
  261. C
  262. 171 CONTINUE
  263. JTAFF(**)=MCHEL2.ICHAML(ISOUS)
  264. 17 CONTINUE
  265. C
  266. C ON A TROUVE UNE BIJECTION ET ON VECTORISE
  267. C
  268. N1=NSOUS1
  269. SEGINI MCHELM
  270. TITCHE=MOT
  271. IFOCHE=IFOUR
  272. IPCHAD=MCHELM
  273. DO 400 ISOUS=1,NSOUS1
  274. IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  275. CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  276. DO 401 N33=1,N3
  277. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  278. 401 CONTINUE
  279. C
  280. MCHAM1=MCHEL1.ICHAML(ISOUS)
  281. C
  282. SEGINI,MCHAML=MCHAM1
  283. ICHAML(ISOUS)=MCHAML
  284. IPCHA=MCHAML
  285. C
  286. MCHAM2=JTAFF(ISOUS)
  287. SEGACT MCHAM2
  288. IPCHA2=MCHAM2
  289. C
  290. CALL ADCHAM (IPCHA2,IPCHA,XX)
  291. IF (IPCHA.EQ.0) THEN
  292. SEGSUP ITAFF
  293. GOTO 9990
  294. ENDIF
  295. C
  296. Cpv SEGDES MCHAML,MCHAM2,MCHAM1
  297. SEGDES MCHAML
  298. 400 CONTINUE
  299. Cpv SEGDES MCHEL1,MCHEL2
  300. SEGSUP ITAFF
  301. SEGDES MCHELM
  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)
  336. IPCHAD=0
  337. SEGDES MCHEL1,MCHEL2
  338. SEGSUP MZONG,MZON1,MZON2
  339. RETURN
  340. ENDIF
  341. 520 CONTINUE
  342. IWRN=1
  343. NZONG(**)=IPMAI2
  344. NZON1(**)=0
  345. NZON2(**)=ISOUS2
  346. GOTO 510
  347. C
  348. 530 CONTINUE
  349. if (nzon2(isous1).ne.0) call erreur(329)
  350. NZON2(ISOUS1)=ISOUS2
  351. 510 CONTINUE
  352. C
  353. C WARNING LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
  354. C
  355. C IF(IWRN.EQ.1) CALL ERREUR(103)
  356. NSOUS=NZONG(/1)
  357. N1=NSOUS
  358. SEGINI MCHELM
  359. TITCHE=MOT
  360. IFOCHE=IFOUR
  361. IPCHAD=MCHELM
  362. C
  363. DO 540 ISOUS=1,NSOUS
  364. BOOLSO=.FALSE.
  365. IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
  366. C
  367. IF(NZON1(ISOUS).NE.0) THEN
  368. MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  369. SEGINI,MCHAML=MCHAM1
  370. IMACHE(ISOUS)=NZONG(ISOUS)
  371. CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  372. DO 402 N33=1,N3
  373. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  374. 402 CONTINUE
  375. C
  376. ENDIF
  377. IF(NZON2(ISOUS).NE.0) THEN
  378. IF(IEPS .EQ. -1) BOOLSO=.TRUE.
  379. MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  380. SEGINI,MCHAML=MCHAM2
  381. IMACHE(ISOUS)=NZONG(ISOUS)
  382. CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) )
  383. DO 403 N33=1,N3
  384. INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33)
  385. 403 CONTINUE
  386. C
  387. ENDIF
  388. ICHAML(ISOUS)=MCHAML
  389. C
  390. DO 175 ICOMP=1,IELVAL(/1)
  391. MELVA1=IELVAL(ICOMP)
  392. SEGINI,MELVAL=MELVA1
  393. IELVAL(ICOMP)=MELVAL
  394. C CB215821 Si c'est la soustraction qu'on demande il faut faire * XX...
  395. C sur les SOUS-ZONES issues du 2ème MCHAML (BOOLSO = .TRUE.)
  396. IF (BOOLSO) THEN
  397. N1PTEL=MELVAL.VELCHE(/1)
  398. IF(N1PTEL .NE. 0) THEN
  399. C Cas REAL*8
  400. N1EL =MELVAL.VELCHE(/2)
  401. DO IGAU=1,N1PTEL
  402. DO IB=1,N1EL
  403. MELVAL.VELCHE(IGAU,IB)=MELVAL.VELCHE(IGAU,IB) * XX
  404. ENDDO
  405. ENDDO
  406.  
  407. ELSE
  408. C Cas POINTEUR
  409. N2PTEL=IELCHE(/1)
  410. N2EL =IELCHE(/2)
  411. IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  412. DO IGAU=1,N2PTEL
  413. DO IB=1,N2EL
  414. ILREE1=IELCHE(IGAU,IB)
  415. CALL MUFLIR(ILREE1,XX,ILREEL,1)
  416. IELCHE(IGAU,IB)=ILREEL
  417. ENDDO
  418. ENDDO
  419.  
  420. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN
  421. SEGACT,MCOORD
  422. NBNO=XCOOR(/1)/(IDIM+1)
  423. NBNOI=NBNO
  424. NBPTS=NBNO+(N2PTEL*N2EL)
  425. SEGADJ,MCOORD
  426. DO IGAU=1,N2PTEL
  427. DO IB=1,N2EL
  428. IP =IELCHE(IGAU,IB)
  429. IREF=(IP-1)*(IDIM+1)
  430. C
  431. DO IC=1,IDIM
  432. XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX
  433. ENDDO
  434. XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
  435. IELCHE(IGAU,IB)=NBNOI+1
  436. NBNOI=NBNOI+1
  437. ENDDO
  438. ENDDO
  439.  
  440. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  441. DO IGAU=1,N2PTEL
  442. DO IB=1,N2EL
  443. IEVOL1=IELCHE(IGAU,IB)
  444. CALL MUFLEV(IEVOL1,XX,IEVOL2,IEPS)
  445. IELCHE(IGAU,IB)=IEVOL2
  446. ENDDO
  447. ENDDO
  448.  
  449. ELSE
  450. MOTERR(1:4)=NOMCHE(ICOMP)
  451. CALL ERREUR(197)
  452. RETURN
  453. ENDIF
  454. ENDIF
  455. ENDIF
  456. Cpv SEGDES MELVAL,melva1
  457. SEGDES MELVAL
  458. 175 CONTINUE
  459. SEGDES MCHAML
  460. C
  461. GOTO 540
  462. C
  463. 550 CONTINUE
  464. MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
  465. SEGINI,MCHAML=MCHAM1
  466. IMACHE(ISOUS)=NZONG(ISOUS)
  467. CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
  468. DO 404 N33=1,N3
  469. INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
  470. 404 CONTINUE
  471. ICHAML(ISOUS)=MCHAML
  472. IPCHA=MCHAML
  473. MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
  474. SEGACT MCHAM2
  475. IPCHA2=MCHAM2
  476. C
  477. CALL ADCHAM (IPCHA2,IPCHA,XX)
  478. IF (IPCHA.EQ.0) THEN
  479. SEGSUP MZONG,MZON1,MZON2
  480. GOTO 9990
  481. ENDIF
  482. C
  483. Cpv SEGDES MCHAML,MCHAM2
  484. SEGDES MCHAML
  485. 540 CONTINUE
  486. SEGDES MCHELM
  487. C
  488. SEGSUP MZONG,MZON1,MZON2
  489. GOTO 666
  490. C
  491. 9990 CONTINUE
  492. C
  493. C ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  494. C
  495. SEGDES MCHEL1,MCHEL2,MCHAM2
  496. SEGSUP MCHAML,MCHELM,ITAFF
  497. IPCHAD=0
  498. RETURN
  499. C
  500. 666 CONTINUE
  501. Cpv SEGDES MCHEL1,MCHEL2
  502. 777 CONTINUE
  503. RETURN
  504. END
  505.  
  506.  
  507.  
  508.  

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