Télécharger adchpo.eso

Retour à la liste

Numérotation des lignes :

  1. C ADCHPO SOURCE PV 15/03/30 21:15:00 8452
  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. SEGDES MPOVA1,MSOUP1,MCHPO1
  117. SEGSUP MSOUPO,MCHPOI
  118. CALL ERREUR(114)
  119. GOTO 666
  120. 30 CONTINUE
  121. SEGINI MPOVAL
  122. IPOVAL=MPOVAL
  123. DO 40 IC=1,NC
  124. DO 41 IB=1,N
  125. VPOCHA(IB,IC)=XX*MPOVA1.VPOCHA(IB,IC)
  126. 41 CONTINUE
  127. 40 CONTINUE
  128. SEGDES MPOVAL,MPOVA1,MSOUPO,MSOUP1
  129. 50 CONTINUE
  130. SEGDES MCHPOI,MCHPO1
  131. GOTO 666
  132. C
  133. C-----------------------------------------------------------------------
  134. C *** CAS OU LES POINTEURS IPO1 ET IPO2 SONT DIFFERENTS
  135. C-----------------------------------------------------------------------
  136. C
  137. 60 CONTINUE
  138. MCHPO1=IPO1
  139. MCHPO2=IPO2
  140. IPO(1)=IPO1
  141. IPO(2)=IPO2
  142. SEGACT MCHPO1,MCHPO2
  143. MOT=MCHPO1.MTYPOI
  144. IF(MOT.NE.MCHPO2.MTYPOI) THEN
  145. MOT='adchpo'
  146. ENDIF
  147. C
  148. C ON REGARDE SI UN CHAMP EST INCLUS DANS L'AUTRE
  149. C
  150. segact mcoord
  151. MCHPO1=IPO1
  152. MCHPO2=IPO2
  153. SEGACT MCHPO1,MCHPO2
  154. NSOUP1=MCHPO1.IPCHP(/1)
  155. NSOUP2=MCHPO2.IPCHP(/1)
  156. NAT1 = MCHPO1.JATTRI(/1)
  157. NAT2 = MCHPO2.JATTRI(/1)
  158. C
  159. C ON REGARDE SI on peut se passer de repartionner la geometrie
  160. C
  161. SEGINI MTR5
  162. SEGINI MTR3
  163. ncmax2=0
  164. nposr=0
  165. DO 100 IB=1,NSOUP2
  166. MSOUP2=MCHPO2.IPCHP(IB)
  167. SEGACT MSOUP2
  168. ncmax2=max(ncmax2,msoup2.nocomp(/2))
  169. ipt2=MSOUP2.IGEOC
  170. segact ipt2
  171. do 101 iel=1,ipt2.num(/2)
  172. izon(ipt2.num(1,iel))=ib
  173. 101 continue
  174. 100 continue
  175. ncmax1=0
  176. do 105 ia=1,nsoup1
  177. msoup1=mchpo1.ipchp(ia)
  178. segact msoup1
  179. ncmax1=max(ncmax1,msoup1.nocomp(/2))
  180. ipt1=msoup1.igeoc
  181. segact ipt1
  182. ib=0
  183. if (ipt1.num(/2).gt.0) ib=izon(ipt1.num(1,1))
  184. if (ib.eq.0) then
  185. do 106 iel=1,ipt1.num(/2)
  186. if (izon(ipt1.num(1,iel)).ne.0) then
  187. if (iimpi.eq.1954)
  188. > write (ioimp,*)
  189. $ ' adchpo zone 1ch coupe zone 2ch ',ia
  190. $ ,izon(ipt1.num(1,iel))
  191. goto 109
  192. endif
  193. 106 continue
  194. goto 105
  195. endif
  196. MSOUP2=MCHPO2.IPCHP(IB)
  197. * si meme nombre d'elements on compare les meleme
  198. ipt2=msoup2.igeoc
  199. IF(ipt1.eq.ipt2) GO TO 90
  200. if (ipt1.num(/2).ne.ipt2.num(/2))then
  201. if (iimpi.eq.1954)
  202. > write (ioimp,*) ' adchpo nbel diff ',ipt1.num(/2)
  203. $ ,ipt2.num(/2)
  204. goto 109
  205. endif
  206. do 84 iel=1,ipt1.num(/2)
  207. if (izon(ipt1.num(1,iel)).ne.ib) then
  208. if (iimpi.eq.1954)
  209. > write (ioimp,*) ' adchpo zone mismatch '
  210. goto 109
  211. endif
  212. 84 continue
  213. 90 CONTINUE
  214. nposr=nposr+1
  215. ipos1(ia)=1
  216. ipos2(ib)=1
  217. INDEX(ia)=IB
  218. 105 CONTINUE
  219. npaq1=0
  220. do 82 ipaq=1,nsoup1
  221. npaq1=npaq1+ipos1(ipaq)
  222. 82 continue
  223. npaq2=0
  224. do 83 ipaq=1,nsoup2
  225. npaq2=npaq2+ipos2(ipaq)
  226. 83 continue
  227. if (iimpi.eq.1954) write (ioimp,*) ' adchpo rapide '
  228. goto 108
  229. 109 continue
  230. C
  231. C tous les meleme de l'un ne sont pas inclus dans l'autre
  232. C
  233. SEGDES MSOUP1,MCHPO1,MCHPO2
  234. SEGSUP MTR3,MTR5
  235. GO TO 300
  236. 108 continue
  237. C
  238. C *** CAS OU LES SUPPORTS GEOMETRIQUES DE L'UN SONT INCLUS DANS L'AUTRE
  239. C
  240. NSOUPO=NSOUP1+NSOUP2-nposr
  241. NAT=MAX(NAT1,NAT2,1)
  242. SEGINI MCHPOI
  243. IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  244. IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  245. JATTRI(1)= MCHPO1.JATTRI(1)
  246. ELSE
  247. JATTRI(1)=0
  248. ENDIF
  249. ELSE
  250. JATTRI(1)=0
  251. ENDIF
  252. IRET=MCHPOI
  253. MTYPOI=MOT
  254. MOCHDE=MCHPO1.MOCHDE
  255. IFOPOI=IFOMOD
  256. ncmax=ncmax1+ncmax2
  257. *goo SEGINI mtr6
  258. nposr=0
  259. DO 250 IA=1,NSOUP1
  260. SEGINI mtr6
  261. if (ipos1(ia).eq.0) goto 250
  262. MSOUP1=MCHPO1.IPCHP(IA)
  263. MSOUP2=MCHPO2.IPCHP(INDEX(IA))
  264. SEGACT MSOUP1,MSOUP2
  265. C
  266. C COMPARAISON DES NOMS DES COMPOSANTES
  267. C
  268. NC1=MSOUP1.NOCOMP(/2)
  269. NC2=MSOUP2.NOCOMP(/2)
  270. DO 130 IB=1,NC1
  271. mpcom(ib)=MSOUP1.NOCOMP(IB)
  272. mphar(ib)=MSOUP1.NOHARM(IB)
  273. 130 CONTINUE
  274. mc=nc1
  275. DO 160 IB=1,NC2
  276. DO 140 IC=1,NC1
  277. IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140
  278. IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150
  279. 140 CONTINUE
  280. mc=mc+1
  281. mpcom(mc)=MSOUP2.NOCOMP(IB)
  282. mphar(mc)=MSOUP2.NOHARM(IB)
  283. micom(ib)=mc
  284. GO TO 160
  285. 150 CONTINUE
  286. micom(ib)=ic
  287. nicom(ic)=1
  288. 160 CONTINUE
  289. C
  290. MPOVA1=MSOUP1.IPOVAL
  291. MPOVA2=MSOUP2.IPOVAL
  292. SEGACT MPOVA1,MPOVA2
  293. N1=MPOVA1.VPOCHA(/1)
  294. N2=MPOVA2.VPOCHA(/1)
  295. NCX1=MPOVA1.VPOCHA(/2)
  296. NCX2=MPOVA2.VPOCHA(/2)
  297. IF(NCX1.NE.NC1) GOTO 170
  298. IF(NCX2.NE.NC2) GOTO 170
  299. IF(N1.NE.N2) GOTO 170
  300. GOTO 180
  301. 170 CONTINUE
  302. SEGDES MSOUP1,MSOUP2,MPOVA1,MPOVA2,MCHPO1,MCHPO2
  303. SEGSUP MTR6,MCHPOI,MTR3,MTR5
  304. C
  305. C PB AVEC LES DIMENSIONS DES CHPOINTS
  306. C
  307. CALL ERREUR(114)
  308. IRET=0
  309. GOTO 666
  310. *
  311. 180 CONTINUE
  312. *
  313. N=N1
  314. NC=mc
  315. SEGINI MPOVAL
  316. C
  317. C recopier le premier chpo
  318. C
  319. DO 210 IC=1,NC1
  320. if (nicom(ic).eq.0) then
  321. DO 200 IB=1,N
  322. VPOCHA(IB,IC)=XXT(1)*MPOVA1.VPOCHA(IB,IC)
  323. 200 CONTINUE
  324. endif
  325. 210 CONTINUE
  326. C
  327. C rajouter le second
  328. C
  329. ipt1=msoup1.igeoc
  330. ipt2=msoup2.igeoc
  331. * si les numerotations sont differentes il faut reordonner
  332. if (ipt1.ne.ipt2) then
  333. do 229 iel=1,ipt2.num(/2)
  334. izon(ipt2.num(1,iel))=iel
  335. 229 continue
  336. DO 230 IC=1,NC2
  337. IIC=micom(ic)
  338. if (iic.gt.nc1) then
  339. DO 221 IB=1,N
  340. VPOCHA(IB,IIC)=XXT(2)*
  341. $ MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)
  342. 221 CONTINUE
  343. else
  344. DO 220 IB=1,N
  345. VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC)
  346. $ +XXT(2)*MPOVA2.VPOCHA(izon(ipt1.num(1,ib))
  347. $ ,IC)
  348. 220 CONTINUE
  349. endif
  350. 230 CONTINUE
  351. else
  352. * meme pointeur geometrique on se passe de izon
  353. DO 235 IC=1,NC2
  354. IIC=micom(ic)
  355. if (iic.gt.nc1) then
  356. DO 236 IB=1,N
  357. VPOCHA(IB,IIC)=XXT(2)*MPOVA2.VPOCHA(IB,IC)
  358. 236 CONTINUE
  359. else
  360. DO 237 IB=1,N
  361. VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC)+
  362. > XXT(2)*MPOVA2.VPOCHA(IB,IC)
  363. 237 CONTINUE
  364. endif
  365. 235 CONTINUE
  366. endif
  367. SEGDES MPOVA2
  368. SEGDES MPOVA1
  369. C
  370. SEGINI MSOUPO
  371. DO 240 IB=1,NC
  372. NOCOMP(IB)=mpcom(ib)
  373. NOHARM(IB)=mphar(ib)
  374. 240 CONTINUE
  375. IPOVAL=MPOVAL
  376. SEGDES MPOVAL
  377. IPT3=IPT1
  378. IGEOC=IPT3
  379. SEGDES IPT1,ipt2,ipt3
  380. nposr=nposr+1
  381. IPCHP(nposr)=MSOUPO
  382. SEGDES MSOUP1,MSOUP2
  383. SEGSUP MTR6
  384. 250 CONTINUE
  385. *goo SEGSUP MTR6
  386. * il faut maintenant adjoindre les paquets de 1 pas dans 2 ou inversement
  387. DO 251 IA=1,NSOUP1
  388. if (ipos1(ia).ne.0) goto 251
  389. nposr=nposr+1
  390. msoupo=mchpo1.ipchp(ia)
  391. segini,msoup1=msoupo
  392. ipchp(nposr)=msoup1
  393. ipt1=msoup1.igeoc
  394. * segini,ipt2=ipt1
  395. ipt2=ipt1
  396. msoup1.igeoc=ipt2
  397. mpoval=msoup1.ipoval
  398. segact mpoval
  399. n=vpocha(/1)
  400. nc=vpocha(/2)
  401. segini,mpova1
  402. do 254 jb=1,nc
  403. do 2541 ja=1,n
  404. mpova1.vpocha(ja,jb)=xxt(1)*vpocha(ja,jb)
  405. 2541 continue
  406. 254 continue
  407. msoup1.ipoval=mpova1
  408. segdes ipt1,msoupo,ipt2,mpoval,mpova1
  409. 251 continue
  410. DO 252 IB=1,NSOUP2
  411. if (ipos2(ib).ne.0) goto 252
  412. nposr=nposr+1
  413. msoupo=mchpo2.ipchp(ib)
  414. segini,msoup1=msoupo
  415. ipchp(nposr)=msoup1
  416. ipt1=msoup1.igeoc
  417. * segini,ipt2=ipt1
  418. ipt2=ipt1
  419. msoup1.igeoc=ipt2
  420. mpoval=msoup1.ipoval
  421. segact mpoval
  422. n=vpocha(/1)
  423. nc=vpocha(/2)
  424. segini,mpova1
  425. do 253 jb=1,nc
  426. do 2531 ja=1,n
  427. mpova1.vpocha(ja,jb)=xxt(2)*vpocha(ja,jb)
  428. 2531 continue
  429. 253 continue
  430. msoup1.ipoval=mpova1
  431. segdes ipt1,msoupo,ipt2,mpoval,mpova1
  432. 252 continue
  433. * verification que les composantes sont bien differentes entre paquets
  434. do 255 isoupo=1,ipchp(/1)
  435. msoup1=ipchp(isoupo)
  436. SEGACT MSOUP1
  437. nc1=msoup1.nocomp(/2)
  438. do 256 jsoupo=isoupo+1,ipchp(/1)
  439. msoup2=ipchp(jsoupo)
  440. SEGACT MSOUP2
  441. nc2=msoup2.nocomp(/2)
  442. if (nc1.ne.nc2) goto 256
  443. do 257 ic1=1,nc1
  444. do 258 ic2=1,nc2
  445. if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2))
  446. $ goto 258
  447. if (msoup1.nocomp(ic1).eq.msoup2.nocomp(ic2))
  448. $ goto 257
  449. 258 continue
  450. goto 256
  451. 257 continue
  452. * pas de chance composantes en double
  453. if (iimpi.eq.1954) write (ioimp,*)
  454. $ ' pacquets en double => lent '
  455. segsup mtr3,mtr5
  456. goto 300
  457. 256 continue
  458. segdes msoup1
  459. 255 continue
  460. SEGSUP MTR3,MTR5
  461. SEGDES MCHPOI,MCHPO1,MCHPO2
  462. GOTO 666
  463. C
  464. C *** CAS OU LES SUPPORTS GEOMETRIQUES NE SONT PAS IDENTIQUES
  465. C *** A UNE PERMUTATION PRES
  466. C
  467. 300 CONTINUE
  468. C
  469. SEGINI MTRA,MTR1,MTR4
  470. C
  471. MCHPOI=IPO1
  472. SEGACT MCHPOI
  473. MSOUPO=IPCHP(1)
  474. SEGACT MSOUPO
  475. IPCOM(**)=NOCOMP(1)
  476. IPHAR(**)=NOHARM(1)
  477. SEGDES MSOUPO,MCHPOI
  478. NC=1
  479. IK=0
  480. C
  481. C CREATION DE NOPOIN ET DE IPCOM
  482. C
  483. DO 360 ICH=1,2
  484. MCHPOI=IPO(ICH)
  485. SEGACT MCHPOI
  486. NSOUPO=IPCHP(/1)
  487. C
  488. C BOUCLE SUR LES SOUS REFERENCES D 1 CHPOINT
  489. C
  490. DO 350 IA=1,NSOUPO
  491. MSOUPO=IPCHP(IA)
  492. SEGACT MSOUPO
  493. MELEME=IGEOC
  494. SEGACT MELEME
  495. NBNN =NUM(/1)
  496. NBELEM=NUM(/2)
  497. C IF(NBNN.NE.1) GOTO 777
  498. DO 310 IB=1,NBELEM
  499. K=NUM(1,IB)
  500. IF(NOPOIN(K).NE.0) GO TO 310
  501. IK=IK+1
  502. NOPOIN(K)=IK
  503. 310 CONTINUE
  504. SEGDES MELEME
  505. NCBBB=NOCOMP(/2)
  506. DO 330 IB=1,NCBBB
  507. NC=IPCOM(/2)
  508. DO 320 IC=1,NC
  509. IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
  510. IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 330
  511. 320 CONTINUE
  512. IPCOM(**)=NOCOMP(IB)
  513. IPHAR(**)=NOHARM(IB)
  514. NC=NC+1
  515. 330 CONTINUE
  516. SEGDES MSOUPO
  517. 350 CONTINUE
  518. SEGDES MCHPOI
  519. 360 CONTINUE
  520. C
  521. NNIN=NC
  522. NNNOE=IK
  523. SEGINI MTRAV
  524. C
  525. C CREATION DE INCO
  526. C
  527. DO 380 IA=1,NNIN
  528. INCO(IA)=IPCOM(IA)
  529. NHAR(IA)=IPHAR(IA)
  530. 380 CONTINUE
  531. C
  532. C CREATION DE BB,IBIN,IGEO
  533. C
  534. MCHPOI=IPO(1)
  535. SEGACT MCHPOI
  536. NSOUPO=IPCHP(/1)
  537. DO 1430 IA=1,NSOUPO
  538. MSOUPO=IPCHP(IA)
  539. SEGACT MSOUPO
  540. MELEME=IGEOC
  541. SEGACT MELEME
  542. MPOVAL=IPOVAL
  543. SEGACT MPOVAL
  544. NBELEM=NUM(/2)
  545. if (nbelem.ne.vpocha(/1)) then
  546. call erreur(114)
  547. iret=0
  548. goto 666
  549. endif
  550. N=VPOCHA(/1)
  551. NC=VPOCHA(/2)
  552. NC1=NOCOMP(/2)
  553. C
  554. DO 1420 IB=1,NC1
  555. DO 1390 IC=1,NNIN
  556. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 1390
  557. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 1400
  558. 1390 CONTINUE
  559. 1400 CONTINUE
  560. DO 1410 ID=1,NBELEM
  561. KI=NOPOIN(NUM(1,ID))
  562. IGEO(KI)=NUM(1,ID)
  563. IBIN(IC,KI)=1
  564. BB(IC,KI)=XXT(1)*VPOCHA(ID,IB)
  565. 1410 CONTINUE
  566. 1420 CONTINUE
  567. SEGDES MELEME,MSOUPO,MPOVAL
  568. 1430 CONTINUE
  569. SEGDES MCHPOI
  570. MCHPOI=IPO(2)
  571. XSIGN=XXT(2)
  572. SEGACT MCHPOI
  573. NSOUPO=IPCHP(/1)
  574. DO 430 IA=1,NSOUPO
  575. MSOUPO=IPCHP(IA)
  576. SEGACT MSOUPO
  577. MELEME=IGEOC
  578. SEGACT MELEME
  579. MPOVAL=IPOVAL
  580. SEGACT MPOVAL
  581. NBELEM=NUM(/2)
  582. N=VPOCHA(/1)
  583. NC=VPOCHA(/2)
  584. NC1=NOCOMP(/2)
  585. C
  586. DO 420 IB=1,NC1
  587. DO 390 IC=1,NNIN
  588. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
  589. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
  590. 390 CONTINUE
  591. 400 CONTINUE
  592. DO 410 ID=1,NBELEM
  593. KI=NOPOIN(NUM(1,ID))
  594. IGEO(KI)=NUM(1,ID)
  595. IBIN(IC,KI)=1
  596. BB(IC,KI)=BB(IC,KI)+XXT(2)*VPOCHA(ID,IB)
  597. 410 CONTINUE
  598. 420 CONTINUE
  599. SEGDES MELEME,MSOUPO,MPOVAL
  600. 430 CONTINUE
  601. SEGDES MCHPOI
  602. ITRAV=MTRAV
  603. SEGDES MTRAV
  604. C
  605. C RECONSTUCTION DE LA PARTITION
  606. C
  607. CALL CRECHP(ITRAV,ICHPOI)
  608. C
  609. SEGSUP MTRAV,MTRA,MTR1,MTR4
  610. IRET=ICHPOI
  611. MCHPOI=ICHPOI
  612. MCHPO1 = IPO1
  613. MCHPO2 = IPO2
  614. SEGACT MCHPOI,MCHPO1,MCHPO2
  615. NAT1 = MCHPO1.JATTRI(/1)
  616. NAT2 = MCHPO2.JATTRI(/1)
  617. NAT=MAX(NAT1,NAT2,1)
  618. NSOUPO = IPCHP(/1)
  619. SEGADJ MCHPOI
  620. IRET=MCHPOI
  621. MTYPOI=MOT
  622. IF ( MIN(NAT1,NAT2) .GE. 1) THEN
  623. IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
  624. JATTRI(1)= MCHPO1.JATTRI(1)
  625. ELSE
  626. JATTRI(1)=0
  627. ENDIF
  628. ELSE
  629. JATTRI(1)=0
  630. ENDIF
  631. SEGDES MCHPOI,MCHPO1,MCHPO2
  632. C
  633. 666 CONTINUE
  634. RETURN
  635. END
  636.  
  637.  
  638.  
  639.  
  640.  
  641.  
  642.  
  643.  
  644.  
  645.  
  646.  

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