Télécharger adchpo.eso

Retour à la liste

Numérotation des lignes :

  1. C ADCHPO SOURCE CB215821 19/07/30 21:15:08 10273
  2. SUBROUTINE ADCHPO(IPO1,IPO2,IRET,XCO1,XCO2)
  3. C=======================================================================
  4. C
  5. C COMBINAISON LINEAIRE DE 2 CHPS PAR POINTS
  6. C ENTREE
  7. C IPO1=POINTEUR SUR LE 1 CHAMPS PAR POINT
  8. C IPO2=POINTEUR SUR LE 2 CHAMPS PAR POINT
  9. C XCO1 ET XCO2 COEFFICIENTS APPLIQUES SUR LES CHAMPS
  10. C SORTIE
  11. C IRET= POINTEUR SUR LE CHAMP SOMME
  12. C = 0 SI SOMME IMPOSSIBLE
  13. C
  14. C MESSAGE D ERREUR DECLENCHE SI IRET=0
  15. C
  16. C CODE EBERSOLT JUILLET 84 MODIF HAMY NOVEMBRE 84
  17. C
  18. C POUR L INSTANT ON AUTORISE L ADDITION DE CHPOINTS DE SOUS
  19. C TYPE DIFFERENTS ( STOCKES DANS MTYPOI )
  20. C
  21. C CETTE ROUTINE FAIT APPEL A LA ROUTINE CRECHP
  22. C
  23. C=======================================================================
  24. IMPLICIT INTEGER(I-N)
  25. IMPLICIT REAL*8(A-H,O-Z)
  26. -INC SMCHPOI
  27. -INC CCOPTIO
  28. -INC SMELEME
  29. -INC SMCOORD
  30. -INC TMTRAV
  31. SEGMENT/MTRA/(NOPOIN(XCOOR(/1)/(IDIM+1)))
  32. SEGMENT MTR1
  33. CHARACTER*4 IPCOM(0)
  34. ENDSEGMENT
  35. SEGMENT/MTR2/(IICOM(0))
  36. SEGMENT/MTR3/(INDEX(max(nsoup1,nsoup2)))
  37. SEGMENT/MTR4/(IPHAR(0))
  38. SEGMENT/MTR5/(IPOS1(NSOUP1),IPOS2(NSOUP2),
  39. > IZON(XCOOR(/1)/(IDIM+1)))
  40. segment mtr6
  41. character*4 mpcom(ncmax)
  42. integer micom(ncmax),nicom(ncmax)
  43. integer mphar(ncmax)
  44. endsegment
  45. C
  46. C-----------------------------------------------------------------------
  47. C --- DESCRIPTION DES SEGMENTS DE TRAVAIL ---
  48. C * MTRAV : - BB(I,J) EST LA VALEUR DE LA IEME INCONNUE DE CHAMP POUR
  49. C LE JIEME NOEUD DU TABLEAU IGEO .
  50. C - INCO(NNIN) CONTIENT LE NOM DES NNIN INCONNUES DIFFERENTES
  51. C - IBIN(I,J)=1 OU 0 INDIQUE QUE LA IEME INCONNUE DU CHAMP
  52. C EXISTE POUR LE JIEME NOEUD DU TABLEAU IGEO .
  53. C - IGEO(I) EST LE NUMERO A METTRE DANS UN OBJET MELEME POUR
  54. C REFERENCER LE IEME NOEUD .
  55. C
  56. C * MTRA : - NOPOIN(I) ADRESSE DE COLONNE DANS BB ET IBIN DES VALEURS
  57. C CORRESPONDANT AU NOEUD I .
  58. C
  59. C * MTR1 : - IPCOM LISTE DES NOMS DES INCONNUES PERMET DE CREER INCO .
  60. C
  61. C * MTR2 : - IICOM ADRESSE DANS IPCOM DES INCONNUES CORRESPONDANT AU
  62. C 2IEME CH POINT .
  63. C
  64. C * MTR3 : - INDEX TABLEAU DE CORRESPONDANCE ENTRE LES SUPPORTS GEOME-
  65. C TRIQUES DU 1ER CHPOINT ET DU 2IEME CHPOINT .
  66. C-----------------------------------------------------------------------
  67. DIMENSION IPO(2),XXT(2)
  68. CHARACTER*8 MOT
  69. C-----------------------------------------------------------------------
  70. C
  71. C MODIFIER ICI SI ON VEUT FAIRE FLO1*CHP1 + FLO2*CHP2
  72. C
  73. C-----------------------------------------------------------------------
  74. XXT(1)=XCO1
  75. XXT(2)=XCO2
  76. XX=XXT(1)+XXT(2)
  77. C
  78. IF(IPO1.NE.IPO2) GOTO 60
  79. C
  80. C-----------------------------------------------------------------------
  81. C *** CAS OU LES 2 POINTEURS IPO1 ET IPO2 SONT EGAUX
  82. C-----------------------------------------------------------------------
  83. C
  84. MCHPO1=IPO1
  85. SEGACT MCHPO1
  86. NSOUPO=MCHPO1.IPCHP(/1)
  87. NAT=MCHPO1.JATTRI(/1)
  88. SEGINI MCHPOI
  89. DO 10 I=1,NAT
  90. JATTRI(I)=MCHPO1.JATTRI(I)
  91. 10 CONTINUE
  92. IRET=MCHPOI
  93. MOCHDE=MCHPO1.MOCHDE
  94. MTYPOI=MCHPO1.MTYPOI
  95. IFOPOI=IFOMOD
  96. DO 50 IA=1,NSOUPO
  97. MSOUP1=MCHPO1.IPCHP(IA)
  98. SEGACT MSOUP1
  99. NC=MSOUP1.NOCOMP(/2)
  100. SEGINI MSOUPO
  101. IPCHP(IA)=MSOUPO
  102. DO 20 IB=1,NC
  103. NOCOMP(IB)=MSOUP1.NOCOMP(IB)
  104. NOHARM(IB)=MSOUP1.NOHARM(IB)
  105. 20 CONTINUE
  106. IGEOC=MSOUP1.IGEOC
  107. MPOVA1=MSOUP1.IPOVAL
  108. SEGACT MPOVA1
  109. N =MPOVA1.VPOCHA(/1)
  110. NC1=MPOVA1.VPOCHA(/2)
  111. IF(NC1.EQ.NC) GOTO 30
  112. C
  113. C ERREUR PB DIMENSION TABLEAU VOIR ROUTINE ADCHPO
  114. C
  115. IRET=0
  116. SEGSUP MSOUPO,MCHPOI
  117. CALL ERREUR(114)
  118. RETURN
  119. 30 CONTINUE
  120. SEGINI MPOVAL
  121. IPOVAL=MPOVAL
  122. DO 40 IC=1,NC
  123. DO 41 IB=1,N
  124. VPOCHA(IB,IC)=XX*MPOVA1.VPOCHA(IB,IC)
  125. 41 CONTINUE
  126. 40 CONTINUE
  127. SEGACT,MPOVAL*NOMOD,MSOUPO*NOMOD
  128. 50 CONTINUE
  129. C SEGACT,MCHPOI*NOMOD
  130. RETURN
  131. C
  132. C-----------------------------------------------------------------------
  133. C *** CAS OU LES POINTEURS IPO1 ET IPO2 SONT DIFFERENTS
  134. C-----------------------------------------------------------------------
  135. C
  136. 60 CONTINUE
  137. MCHPO1=IPO1
  138. MCHPO2=IPO2
  139. IPO(1)=IPO1
  140. IPO(2)=IPO2
  141. SEGACT MCHPO1,MCHPO2
  142. MOT=MCHPO1.MTYPOI
  143. IF(MOT.NE.MCHPO2.MTYPOI) THEN
  144. MOT='adchpo'
  145. ENDIF
  146. C
  147. C ON REGARDE SI UN CHAMP EST INCLUS DANS L'AUTRE
  148. C
  149. segact mcoord
  150. MCHPO1=IPO1
  151. MCHPO2=IPO2
  152. SEGACT MCHPO1,MCHPO2
  153. NSOUP1=MCHPO1.IPCHP(/1)
  154. NSOUP2=MCHPO2.IPCHP(/1)
  155. NAT1 = MCHPO1.JATTRI(/1)
  156. NAT2 = MCHPO2.JATTRI(/1)
  157. C
  158. C ON REGARDE SI on peut se passer de repartionner la geometrie
  159. C
  160. SEGINI MTR5
  161. SEGINI MTR3
  162. ncmax2=0
  163. nposr=0
  164. DO 100 IB=1,NSOUP2
  165. MSOUP2=MCHPO2.IPCHP(IB)
  166. SEGACT MSOUP2
  167. ncmax2=max(ncmax2,msoup2.nocomp(/2))
  168. ipt2=MSOUP2.IGEOC
  169. segact ipt2
  170. do 101 iel=1,ipt2.num(/2)
  171. izon(ipt2.num(1,iel))=ib
  172. 101 continue
  173. 100 continue
  174. ncmax1=0
  175. do 105 ia=1,nsoup1
  176. msoup1=mchpo1.ipchp(ia)
  177. segact msoup1
  178. ncmax1=max(ncmax1,msoup1.nocomp(/2))
  179. ipt1=msoup1.igeoc
  180. segact ipt1
  181. ib=0
  182. if (ipt1.num(/2).gt.0) ib=izon(ipt1.num(1,1))
  183. if (ib.eq.0) then
  184. do 106 iel=1,ipt1.num(/2)
  185. if (izon(ipt1.num(1,iel)).ne.0) then
  186. if (iimpi.eq.1954)
  187. > write (ioimp,*)
  188. $ ' adchpo zone 1ch coupe zone 2ch ',ia
  189. $ ,izon(ipt1.num(1,iel))
  190. goto 109
  191. endif
  192. 106 continue
  193. goto 105
  194. endif
  195. MSOUP2=MCHPO2.IPCHP(IB)
  196. * si meme nombre d'elements on compare les meleme
  197. ipt2=msoup2.igeoc
  198. IF(ipt1.eq.ipt2) GO TO 90
  199. if (ipt1.num(/2).ne.ipt2.num(/2))then
  200. if (iimpi.eq.1954)
  201. > write (ioimp,*) ' adchpo nbel diff ',ipt1.num(/2)
  202. $ ,ipt2.num(/2)
  203. goto 109
  204. endif
  205. do 84 iel=1,ipt1.num(/2)
  206. if (izon(ipt1.num(1,iel)).ne.ib) then
  207. if (iimpi.eq.1954)
  208. > write (ioimp,*) ' adchpo zone mismatch '
  209. goto 109
  210. endif
  211. 84 continue
  212. 90 CONTINUE
  213. nposr=nposr+1
  214. ipos1(ia)=1
  215. ipos2(ib)=1
  216. INDEX(ia)=IB
  217. 105 CONTINUE
  218. npaq1=0
  219. do 82 ipaq=1,nsoup1
  220. npaq1=npaq1+ipos1(ipaq)
  221. 82 continue
  222. npaq2=0
  223. do 83 ipaq=1,nsoup2
  224. npaq2=npaq2+ipos2(ipaq)
  225. 83 continue
  226. if (iimpi.eq.1954) write (ioimp,*) ' adchpo rapide '
  227. goto 108
  228. 109 continue
  229. C
  230. C tous les meleme de l'un ne sont pas inclus dans l'autre
  231. C
  232. SEGSUP MTR3,MTR5
  233. GO TO 300
  234. 108 continue
  235. C
  236. C *** CAS OU LES SUPPORTS GEOMETRIQUES DE L'UN SONT INCLUS DANS L'AUTRE
  237. C
  238. NSOUPO=NSOUP1+NSOUP2-nposr
  239. NAT=MAX(NAT1,NAT2,1)
  240. SEGINI MCHPOI
  241. IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  242. IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  243. JATTRI(1)= MCHPO1.JATTRI(1)
  244. ELSE
  245. JATTRI(1)=0
  246. ENDIF
  247. ELSE
  248. JATTRI(1)=0
  249. ENDIF
  250. IRET=MCHPOI
  251. MTYPOI=MOT
  252. MOCHDE=MCHPO1.MOCHDE
  253. IFOPOI=IFOMOD
  254. ncmax=ncmax1+ncmax2
  255. *goo SEGINI mtr6
  256. nposr=0
  257. DO 250 IA=1,NSOUP1
  258. SEGINI mtr6
  259. if (ipos1(ia).eq.0) goto 250
  260. MSOUP1=MCHPO1.IPCHP(IA)
  261. MSOUP2=MCHPO2.IPCHP(INDEX(IA))
  262. SEGACT MSOUP1,MSOUP2
  263. C
  264. C COMPARAISON DES NOMS DES COMPOSANTES
  265. C
  266. NC1=MSOUP1.NOCOMP(/2)
  267. NC2=MSOUP2.NOCOMP(/2)
  268. DO 130 IB=1,NC1
  269. mpcom(ib)=MSOUP1.NOCOMP(IB)
  270. mphar(ib)=MSOUP1.NOHARM(IB)
  271. 130 CONTINUE
  272. mc=nc1
  273. DO 160 IB=1,NC2
  274. DO 140 IC=1,NC1
  275. IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140
  276. IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150
  277. 140 CONTINUE
  278. mc=mc+1
  279. mpcom(mc)=MSOUP2.NOCOMP(IB)
  280. mphar(mc)=MSOUP2.NOHARM(IB)
  281. micom(ib)=mc
  282. GO TO 160
  283. 150 CONTINUE
  284. micom(ib)=ic
  285. nicom(ic)=1
  286. 160 CONTINUE
  287. C
  288. MPOVA1=MSOUP1.IPOVAL
  289. MPOVA2=MSOUP2.IPOVAL
  290. SEGACT MPOVA1,MPOVA2
  291. N1=MPOVA1.VPOCHA(/1)
  292. N2=MPOVA2.VPOCHA(/1)
  293. NCX1=MPOVA1.VPOCHA(/2)
  294. NCX2=MPOVA2.VPOCHA(/2)
  295. IF(NCX1.NE.NC1) GOTO 170
  296. IF(NCX2.NE.NC2) GOTO 170
  297. IF(N1.NE.N2) GOTO 170
  298. GOTO 180
  299. 170 CONTINUE
  300. SEGSUP MTR6,MCHPOI,MTR3,MTR5
  301. C
  302. C PB AVEC LES DIMENSIONS DES CHPOINTS
  303. C
  304. CALL ERREUR(114)
  305. IRET=0
  306. RETURN
  307. *
  308. 180 CONTINUE
  309. *
  310. N=N1
  311. NC=mc
  312. SEGINI MPOVAL
  313. C
  314. C recopier le premier chpo
  315. C
  316. DO 210 IC=1,NC1
  317. if (nicom(ic).eq.0) then
  318. DO 200 IB=1,N
  319. VPOCHA(IB,IC)=XXT(1)*MPOVA1.VPOCHA(IB,IC)
  320. 200 CONTINUE
  321. endif
  322. 210 CONTINUE
  323. C
  324. C rajouter le second
  325. C
  326. ipt1=msoup1.igeoc
  327. ipt2=msoup2.igeoc
  328. * si les numerotations sont differentes il faut reordonner
  329. if (ipt1.ne.ipt2) then
  330. do 229 iel=1,ipt2.num(/2)
  331. izon(ipt2.num(1,iel))=iel
  332. 229 continue
  333. DO 230 IC=1,NC2
  334. IIC=micom(ic)
  335. if (iic.gt.nc1) then
  336. DO 221 IB=1,N
  337. VPOCHA(IB,IIC)=XXT(2)*
  338. $ MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)
  339. 221 CONTINUE
  340. else
  341. DO 220 IB=1,N
  342. VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC)
  343. $ +XXT(2)*MPOVA2.VPOCHA(izon(ipt1.num(1,ib))
  344. $ ,IC)
  345. 220 CONTINUE
  346. endif
  347. 230 CONTINUE
  348. else
  349. * meme pointeur geometrique on se passe de izon
  350. DO 235 IC=1,NC2
  351. IIC=micom(ic)
  352. if (iic.gt.nc1) then
  353. DO 236 IB=1,N
  354. VPOCHA(IB,IIC)=XXT(2)*MPOVA2.VPOCHA(IB,IC)
  355. 236 CONTINUE
  356. else
  357. DO 237 IB=1,N
  358. VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC)+
  359. > XXT(2)*MPOVA2.VPOCHA(IB,IC)
  360. 237 CONTINUE
  361. endif
  362. 235 CONTINUE
  363. endif
  364. C
  365. SEGINI MSOUPO
  366. DO 240 IB=1,NC
  367. NOCOMP(IB)=mpcom(ib)
  368. NOHARM(IB)=mphar(ib)
  369. 240 CONTINUE
  370. IPOVAL=MPOVAL
  371. SEGACT,MPOVAL*NOMOD
  372. IPT3=IPT1
  373. IGEOC=IPT3
  374. C SEGDES IPT1,ipt2,ipt3
  375. nposr=nposr+1
  376. IPCHP(nposr)=MSOUPO
  377. SEGSUP MTR6
  378. 250 CONTINUE
  379. *goo SEGSUP MTR6
  380. * il faut maintenant adjoindre les paquets de 1 pas dans 2 ou inversement
  381. DO 251 IA=1,NSOUP1
  382. if (ipos1(ia).ne.0) goto 251
  383. nposr=nposr+1
  384. msoupo=mchpo1.ipchp(ia)
  385. segini,msoup1=msoupo
  386. ipchp(nposr)=msoup1
  387. mpoval=msoup1.ipoval
  388. segact mpoval
  389. n=vpocha(/1)
  390. nc=vpocha(/2)
  391. segini,mpova1
  392. do 254 jb=1,nc
  393. do 2541 ja=1,n
  394. mpova1.vpocha(ja,jb)=xxt(1)*vpocha(ja,jb)
  395. 2541 continue
  396. 254 continue
  397. msoup1.ipoval=mpova1
  398. C SEGACT,msoup1*NOMOD,mpova1*NOMOD
  399. 251 continue
  400. DO 252 IB=1,NSOUP2
  401. if (ipos2(ib).ne.0) goto 252
  402. nposr=nposr+1
  403. msoupo=mchpo2.ipchp(ib)
  404. segini,msoup1=msoupo
  405. ipchp(nposr)=msoup1
  406. mpoval=msoup1.ipoval
  407. segact mpoval
  408. n=vpocha(/1)
  409. nc=vpocha(/2)
  410. segini,mpova1
  411. do 253 jb=1,nc
  412. do 2531 ja=1,n
  413. mpova1.vpocha(ja,jb)=xxt(2)*vpocha(ja,jb)
  414. 2531 continue
  415. 253 continue
  416. msoup1.ipoval=mpova1
  417. C SEGACT,msoup1*NOMOD,mpova1*NOMOD
  418. 252 continue
  419. * verification que les composantes sont bien differentes entre paquets
  420. do 255 isoupo=1,ipchp(/1)
  421. msoup1=ipchp(isoupo)
  422. SEGACT MSOUP1
  423. nc1=msoup1.nocomp(/2)
  424. do 256 jsoupo=isoupo+1,ipchp(/1)
  425. msoup2=ipchp(jsoupo)
  426. SEGACT MSOUP2
  427. nc2=msoup2.nocomp(/2)
  428. if (nc1.ne.nc2) goto 256
  429. do 257 ic1=1,nc1
  430. do 258 ic2=1,nc2
  431. if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2))
  432. $ goto 258
  433. if (msoup1.nocomp(ic1).eq.msoup2.nocomp(ic2))
  434. $ goto 257
  435. 258 continue
  436. goto 256
  437. 257 continue
  438. * pas de chance composantes en double
  439. if (iimpi.eq.1954) write (ioimp,*)
  440. $ ' pacquets en double => lent '
  441. segsup mtr3,mtr5
  442. goto 300
  443. 256 continue
  444. 255 continue
  445. SEGSUP MTR3,MTR5
  446. C SEGACT,MCHPOI*NOMOD
  447. RETURN
  448. C
  449. C *** CAS OU LES SUPPORTS GEOMETRIQUES NE SONT PAS IDENTIQUES
  450. C *** A UNE PERMUTATION PRES
  451. C
  452. 300 CONTINUE
  453. C
  454. SEGINI MTRA,MTR1,MTR4
  455. C
  456. MCHPOI=IPO1
  457. SEGACT MCHPOI
  458. MSOUPO=IPCHP(1)
  459. SEGACT MSOUPO
  460. IPCOM(**)=NOCOMP(1)
  461. IPHAR(**)=NOHARM(1)
  462. NC=1
  463. IK=0
  464. C
  465. C CREATION DE NOPOIN ET DE IPCOM
  466. C
  467. DO 360 ICH=1,2
  468. MCHPOI=IPO(ICH)
  469. SEGACT MCHPOI
  470. NSOUPO=IPCHP(/1)
  471. C
  472. C BOUCLE SUR LES SOUS REFERENCES D 1 CHPOINT
  473. C
  474. DO 350 IA=1,NSOUPO
  475. MSOUPO=IPCHP(IA)
  476. SEGACT MSOUPO
  477. MELEME=IGEOC
  478. SEGACT MELEME
  479. NBNN =NUM(/1)
  480. NBELEM=NUM(/2)
  481. C IF(NBNN.NE.1) GOTO 777
  482. DO 310 IB=1,NBELEM
  483. K=NUM(1,IB)
  484. IF(NOPOIN(K).NE.0) GO TO 310
  485. IK=IK+1
  486. NOPOIN(K)=IK
  487. 310 CONTINUE
  488. NCBBB=NOCOMP(/2)
  489. DO 330 IB=1,NCBBB
  490. NC=IPCOM(/2)
  491. DO 320 IC=1,NC
  492. IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
  493. IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 330
  494. 320 CONTINUE
  495. IPCOM(**)=NOCOMP(IB)
  496. IPHAR(**)=NOHARM(IB)
  497. NC=NC+1
  498. 330 CONTINUE
  499. 350 CONTINUE
  500. 360 CONTINUE
  501. C
  502. NNIN=NC
  503. NNNOE=IK
  504. SEGINI MTRAV
  505. C
  506. C CREATION DE INCO
  507. C
  508. DO 380 IA=1,NNIN
  509. INCO(IA)=IPCOM(IA)
  510. NHAR(IA)=IPHAR(IA)
  511. 380 CONTINUE
  512. C
  513. C CREATION DE BB,IBIN,IGEO
  514. C
  515. MCHPOI=IPO(1)
  516. SEGACT MCHPOI
  517. NSOUPO=IPCHP(/1)
  518. DO 1430 IA=1,NSOUPO
  519. MSOUPO=IPCHP(IA)
  520. SEGACT MSOUPO
  521. MELEME=IGEOC
  522. SEGACT MELEME
  523. MPOVAL=IPOVAL
  524. SEGACT MPOVAL
  525. NBELEM=NUM(/2)
  526. if (nbelem.ne.vpocha(/1)) then
  527. call erreur(114)
  528. iret=0
  529. RETURN
  530. endif
  531. N=VPOCHA(/1)
  532. NC=VPOCHA(/2)
  533. NC1=NOCOMP(/2)
  534. C
  535. DO 1420 IB=1,NC1
  536. DO 1390 IC=1,NNIN
  537. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 1390
  538. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 1400
  539. 1390 CONTINUE
  540. 1400 CONTINUE
  541. DO 1410 ID=1,NBELEM
  542. KI=NOPOIN(NUM(1,ID))
  543. IGEO(KI)=NUM(1,ID)
  544. IBIN(IC,KI)=1
  545. BB(IC,KI)=XXT(1)*VPOCHA(ID,IB)
  546. 1410 CONTINUE
  547. 1420 CONTINUE
  548. 1430 CONTINUE
  549.  
  550. MCHPOI=IPO(2)
  551. XSIGN=XXT(2)
  552. SEGACT MCHPOI
  553. NSOUPO=IPCHP(/1)
  554. DO 430 IA=1,NSOUPO
  555. MSOUPO=IPCHP(IA)
  556. SEGACT MSOUPO
  557. MELEME=IGEOC
  558. SEGACT MELEME
  559. MPOVAL=IPOVAL
  560. SEGACT MPOVAL
  561. NBELEM=NUM(/2)
  562. N=VPOCHA(/1)
  563. NC=VPOCHA(/2)
  564. NC1=NOCOMP(/2)
  565. C
  566. DO 420 IB=1,NC1
  567. DO 390 IC=1,NNIN
  568. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
  569. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
  570. 390 CONTINUE
  571. 400 CONTINUE
  572. DO 410 ID=1,NBELEM
  573. KI=NOPOIN(NUM(1,ID))
  574. IGEO(KI)=NUM(1,ID)
  575. IBIN(IC,KI)=1
  576. BB(IC,KI)=BB(IC,KI)+XXT(2)*VPOCHA(ID,IB)
  577. 410 CONTINUE
  578. 420 CONTINUE
  579. 430 CONTINUE
  580. ITRAV=MTRAV
  581. C
  582. C RECONSTUCTION DE LA PARTITION
  583. C
  584. CALL CRECHP(ITRAV,ICHPOI)
  585. C
  586. SEGSUP MTRAV,MTRA,MTR1,MTR4
  587. IRET = ICHPOI
  588. MCHPOI = ICHPOI
  589. MCHPO1 = IPO1
  590. MCHPO2 = IPO2
  591. SEGACT MCHPO1,MCHPO2
  592. NAT1 = MCHPO1.JATTRI(/1)
  593. NAT2 = MCHPO2.JATTRI(/1)
  594. NAT=MAX(NAT1,NAT2,1)
  595. NSOUPO = IPCHP(/1)
  596. SEGADJ,MCHPOI
  597. IRET =MCHPOI
  598. MTYPOI=MOT
  599. IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  600. IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  601. JATTRI(1)= MCHPO1.JATTRI(1)
  602. ELSE
  603. JATTRI(1)=0
  604. ENDIF
  605. ELSE
  606. JATTRI(1)=0
  607. ENDIF
  608. C SEGACT MCHPOI*NOMOD
  609. C SEGDES,MCHPO1,MCHPO2
  610.  
  611. END
  612.  
  613.  
  614.  

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