Télécharger funobj.eso

Retour à la liste

Numérotation des lignes :

  1. C FUNOBJ SOURCE CB215821 17/04/03 21:15:07 9387
  2. SUBROUTINE FUNOBJ(ID,ID1,XVAL1,BOOL1,BMAX)
  3. C FUNOBJ permet d'effectuer la fusion par Tournoi (plus rapide en temps d'execution)
  4. C de N objets d'un même type contenus dans un segment de travail noté SID
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  9. C
  10. C ENTREES
  11. C---------
  12. C ID : POINTEUR sur le SEGMENT SID
  13. C BMAX : VRAI si on calcule le MAXI, FAUX si on calcule le MINI
  14. C
  15. C SORTIES
  16. C---------
  17. C ID1 : POINTEUR ou ENTIER
  18. C XVAL1 : FLOTTANT
  19. C BOOL1 : LOGIQUE
  20. C
  21. C
  22. C CREATION
  23. C----------
  24. C
  25. C HISTORIQUE
  26. C-----------
  27. C 19/01/2016 : La comparaison aux 'MOTS' n'est plus faite dans la boucle
  28. C Possibilite d'effectuer la fusion par TOURNOI ou
  29. C SEQUENTIELLE pour tous les types supportes
  30. C
  31. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  32.  
  33. -INC CCASSIS
  34. -INC SMCOORD
  35. -INC CCOPTIO
  36. -INC CCREEL
  37. -INC CCGEOME
  38. -INC TMTRAV
  39. -INC SMCHPOI
  40. -INC SMELEME
  41. -INC SMCHAML
  42. -INC SMRIGID
  43. -INC SMMODEL
  44.  
  45. PARAMETER (NBMO1=8)
  46. CHARACTER*8 LESMO1(NBMO1)
  47. C LESMO1 = LISTE DES OBJETS GERES PAR FUNOBJ
  48. DATA LESMO1/'RIGIDITE','MATRIK ','MMODEL ','MAILLAGE',
  49. & 'CHPOINT ','MCHAML ','FLOTTANT','LOGIQUE '/
  50.  
  51. C BMAX : VRAI si on calcule le MAXI, FAUX si on calcule le MINI
  52. logical ltelq, BOOL1, B1, B2, BMAX
  53. REAL*8 XVAL1,X1
  54.  
  55. C Nombre d'objets restant a fusionner
  56. INTEGER NBREST,ITYP0
  57.  
  58. C SID : SEGMENT CONTENANT LES INFORMATIONS POUR LA FUSION DES OBJETS
  59. C SID1: COPIE DE SID POUR NE PAS FAIRE SEGSUP DES SEGMENTS D'ENTREE
  60. SEGMENT SID
  61. C NBFUS : NOMBRE D'OBJETS A FUSIONNER
  62. C IPOINT : POINTEURS SUR LES NBFUS OBJETS A FUSIONNER
  63. C BVAL : LOGIQUES A FUSIONNER
  64. C XVAL : VALEURS MAXI / MINI LOCALES A FUSIONNER
  65. C CHATYP : MOT DONNANT LE TYPE D'OBJET A FUSIONNER
  66. INTEGER IPOINT(NBFUS)
  67. LOGICAL BVAL (NBFUS)
  68. REAL*8 XVAL (NBFUS)
  69. CHARACTER*8 CHATYP
  70. ENDSEGMENT
  71. POINTEUR SID1.SID
  72.  
  73. C ITRAV : SEGMENT DE TRAVAIL POUR CRECHP
  74. SEGMENT ITRAV
  75. CHARACTER*4 INC (NN)
  76. INTEGER IHAR(NN)
  77. ENDSEGMENT
  78.  
  79. C ICPR : SEGMENT POUR INDEXER RAPIDEMENT LES NOEUDS
  80. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  81.  
  82. C LISTYP:SEGMENT POUR LISTER LES TYPES D'ELEMENTS PRESENTS ET LEUR NOMBRES
  83. SEGMENT LISTYP(NBTY,3)
  84. SEGMENT IDELEM(NBTY)
  85. SEGMENT INDEXM(NBMAIL)
  86.  
  87. C ISEG : SEGMENT QUELCONQUE POUR TRAITER DES SEGMENTS (SEGACT,SEGDES,etc.)
  88. SEGMENT ISEG(0)
  89.  
  90. CHARACTER*8 CHA8,CHA8a,CHA8b
  91. INTEGER ISTADE
  92.  
  93. C Initialisations
  94. ITYP0 = 0
  95. ISTADE= 0
  96. SID = ID
  97. CHA8 = SID.CHATYP
  98. NBFUS = SID.IPOINT(/1)
  99.  
  100. C PRECONDITIONNEMENT pour ne pas relire des MOTS a chaque fois
  101. CALL PLACE(LESMO1,NBMO1,ITYP0,CHA8)
  102. C PRINT *,'CHA8',CHA8,LESMO1(ITYP0)
  103. IF (ITYP0.EQ.0) THEN
  104. MOTERR(1:8 ) = CHA8
  105. CALL ERREUR(1046)
  106. ENDIF
  107.  
  108. C Gestion de la methode de fusion selon ITYP0
  109. GOTO(555,111,111,777,444,111,333,333),ITYP0
  110.  
  111. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  112. C GESTION DE LA FUSION PAR TOURNOIS (2 par 2)
  113. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  114. 111 CONTINUE
  115. SEGINI,SID1=SID
  116. ltelq = .TRUE.
  117. BOOL1 = SID.BVAL(1)
  118. XVAL1 = SID.XVAL(1)
  119.  
  120. NBREST = NBFUS
  121. C Debut de la fusion d'objets par tournoi
  122. 1 CONTINUE
  123.  
  124. C Stade de la competition
  125. ISTADE = ISTADE + 1
  126.  
  127. IF (NBREST .EQ. 1) THEN
  128. C Fin lorsqu'il ne reste plus qu'un seul objet a fusionner
  129. ID1 = SID.IPOINT(1)
  130. SEGSUP,SID1
  131. RETURN
  132.  
  133. ELSEIF (MOD(NBREST,2) .EQ. 0) THEN
  134. C Cas du Nombre pair d'objets restant a fusionner
  135. DO 100 III = 1,(NBREST/2)
  136. I1 = (III*2) - 1
  137. I2 = (III*2)
  138. id1 = SID.IPOINT(I1)
  139. id2 = SID.IPOINT(I2)
  140. B1 = SID.BVAL(I1)
  141. B2 = SID.BVAL(I2)
  142. X1 = SID.XVAL(I1)
  143. X2 = SID.XVAL(I2)
  144. GOTO(2,4,6,8,10,12,14,16),ITYP0
  145.  
  146. C 'RIGIDITE'
  147. 2 CONTINUE
  148. call fusrig(id1,id2,iretou )
  149. GOTO 120
  150.  
  151. C 'MATRIK'
  152. 4 CONTINUE
  153. call fusmtk(id1,id2,iretou )
  154. GOTO 120
  155.  
  156. C 'MMODEL'
  157. 6 CONTINUE
  158. call fusmod(id1,id2,iretou )
  159. GOTO 120
  160.  
  161. C 'MAILLAGE'
  162. 8 CONTINUE
  163. call fuse (id1,id2,iretou,ltelq)
  164. GOTO 120
  165.  
  166. C 'CHPOINT'
  167. 10 CONTINUE
  168. call fuchpo(id1,id2,iretou )
  169. GOTO 120
  170.  
  171. C 'MCHAML'
  172. 12 CONTINUE
  173. call fuschl(id1,id2,iretou )
  174. GOTO 120
  175.  
  176. C 'FLOTTANT'
  177. 14 CONTINUE
  178. IF (BMAX) THEN
  179. XVAL1= MAX(XVAL1,X1,X2)
  180. ELSE
  181. XVAL1= MIN(XVAL1,X1,X2)
  182. ENDIF
  183. GOTO 100
  184.  
  185. C 'LOGIQUE'
  186. 16 CONTINUE
  187. BOOL1 = BOOL1 .AND. B1 .AND. B2
  188.  
  189. C LE RESULTAT SERA .FALSE. AU PREMIER .FALSE. RENCONTRE ON SORT
  190. IF (.NOT. BOOL1) THEN
  191. SEGSUP,SID1
  192. RETURN
  193. ENDIF
  194. GOTO 100
  195.  
  196. 120 CONTINUE
  197. C Menage des objets temporaires inutiles
  198. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID1)
  199. IF (IPLAC.EQ.0) THEN
  200. ISEG=ID1
  201. SEGSUP,ISEG
  202. ENDIF
  203. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID2)
  204. IF (IPLAC.EQ.0) THEN
  205. ISEG=ID2
  206. SEGSUP,ISEG
  207. ENDIF
  208.  
  209. C On remplace dans SID.IPOINT pour l'iteration suivante
  210. SID.IPOINT(III) = iretou
  211.  
  212. 100 CONTINUE
  213.  
  214. NBREST = (NBREST/2)
  215.  
  216. ELSE
  217. C Cas du Nombre impair d'objets restant a fusionner
  218. DO 200 III = 1,((NBREST-1)/2)
  219. I1 = (III*2) - 1
  220. I2 = (III*2)
  221. id1 = SID.IPOINT(I1)
  222. id2 = SID.IPOINT(I2)
  223. B1 = SID.BVAL(I1)
  224. B2 = SID.BVAL(I2)
  225. X1 = SID.XVAL(I1)
  226. X2 = SID.XVAL(I2)
  227. GOTO(3,5,7,9,11,13,15,17),ITYP0
  228.  
  229. C 'RIGIDITE'
  230. 3 CONTINUE
  231. call fusrig(id1,id2,iretou )
  232. GOTO 220
  233.  
  234. C 'MATRIK'
  235. 5 CONTINUE
  236. call fusmtk(id1,id2,iretou )
  237. GOTO 210
  238.  
  239. C 'MMODEL'
  240. 7 CONTINUE
  241. call fusmod(id1,id2,iretou )
  242. GOTO 220
  243.  
  244. C 'MAILLAGE'
  245. 9 CONTINUE
  246. call fuse (id1,id2,iretou,ltelq)
  247. GOTO 220
  248.  
  249. C 'CHPOINT'
  250. 11 CONTINUE
  251. call fuchpo(id1,id2,iretou )
  252. GOTO 210
  253.  
  254. C 'MCHAML'
  255. 13 CONTINUE
  256. call fuschl(id1,id2,iretou )
  257. GOTO 220
  258.  
  259. C 'FLOTTANT'
  260. 15 CONTINUE
  261. IF (BMAX) THEN
  262. XVAL1= MAX(XVAL1,X1,X2)
  263. ELSE
  264. XVAL1= MIN(XVAL1,X1,X2)
  265. ENDIF
  266. GOTO 200
  267.  
  268. C 'LOGIQUE'
  269. 17 CONTINUE
  270. BOOL1 = BOOL1 .AND. B1 .AND. B2
  271.  
  272. C LE RESULTAT SERA .FALSE. AU PREMIER .FALSE. RENCONTRE ON SORT
  273. IF (.NOT. BOOL1) THEN
  274. SEGSUP,SID1
  275. RETURN
  276. ENDIF
  277. GOTO 200
  278.  
  279. 220 CONTINUE
  280. C Menage des objets temporaires inutiles
  281. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID1)
  282. IF (IPLAC .EQ. 0) THEN
  283. ISEG=ID1
  284. SEGSUP, ISEG
  285. ENDIF
  286. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID2)
  287. IF (IPLAC .EQ. 0) THEN
  288. ISEG=ID2
  289. SEGSUP, ISEG
  290. ENDIF
  291.  
  292. 210 CONTINUE
  293. C On remplace dans SID.IPOINT pour l'iteration suivante
  294. SID.IPOINT(III+1) = iretou
  295.  
  296. 200 CONTINUE
  297.  
  298. C Le dernier OBJET n'est pas traité, il est repris au debut pour l'iteration suivante
  299. SID.IPOINT(1) = SID.IPOINT(NBREST)
  300. SID.BVAL(1) = SID.BVAL(NBREST)
  301. SID.XVAL(1) = SID.XVAL(NBREST)
  302.  
  303. NBREST = ((NBREST-1)/2) + 1
  304.  
  305. ENDIF
  306. GOTO 1
  307.  
  308.  
  309.  
  310. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  311. C GESTION SEQUENTIELLE DE LA FUSION : COMME AVANT
  312. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  313. 333 CONTINUE
  314. SEGINI,SID1=SID
  315. ID1 = SID.IPOINT(1)
  316. BOOL1 = SID.BVAL(1)
  317. XVAL1 = SID.XVAL(1)
  318.  
  319. C Stade de la competition
  320. ISTADE = ISTADE + 1
  321.  
  322. DO 300 III = 2,NBFUS
  323. ID2 = SID.IPOINT(III)
  324. B2 = SID.BVAL(III)
  325. X2 = SID.XVAL(III)
  326. GOTO(31,32,33,34,35,36,37,38),ITYP0
  327.  
  328. C 'RIGIDITE'
  329. 31 CONTINUE
  330. call fusrig(id1,id2,iretou )
  331. GOTO 320
  332.  
  333. C 'MATRIK'
  334. 32 CONTINUE
  335. call fusmtk(id1,id2,iretou )
  336. GOTO 320
  337.  
  338. C 'MMODEL'
  339. 33 CONTINUE
  340. call fusmod(id1,id2,iretou )
  341. GOTO 320
  342.  
  343. C 'MAILLAGE'
  344. 34 CONTINUE
  345. call fuse (id1,id2,iretou,ltelq)
  346. GOTO 320
  347.  
  348. C 'CHPOINT'
  349. 35 CONTINUE
  350. call fuchpo(id1,id2,iretou )
  351. GOTO 310
  352.  
  353. C 'MCHAML'
  354. 36 CONTINUE
  355. call fuschl(id1,id2,iretou )
  356. GOTO 320
  357.  
  358. C 'FLOTTANT'
  359. 37 CONTINUE
  360. IF (BMAX) THEN
  361. XVAL1= MAX(XVAL1,X2)
  362. ELSE
  363. XVAL1= MIN(XVAL1,X2)
  364. ENDIF
  365. GOTO 300
  366.  
  367. C 'LOGIQUE'
  368. 38 CONTINUE
  369. BOOL1 = BOOL1 .AND. B2
  370. C LE RESULTAT SERA .FALSE. AU PREMIER .FALSE. RENCONTRE ON SORT
  371. IF (.NOT. BOOL1) THEN
  372. SEGSUP,SID1
  373. RETURN
  374. ENDIF
  375. GOTO 300
  376. C
  377. 320 CONTINUE
  378.  
  379. C Menage des objets temporaires inutiles
  380. IF (ISTADE.GT.1) THEN
  381. ISEG=ID1
  382. SEGSUP,ISEG
  383. ENDIF
  384.  
  385. 310 CONTINUE
  386. C On remplace ID1 par IRETOU
  387. ID1 = iretou
  388.  
  389. 300 CONTINUE
  390. SEGSUP,SID1
  391. RETURN
  392.  
  393.  
  394.  
  395. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  396. C FUSION DE CHPOINT ESCLAVES : En une seule fois (Pas de CHPOINT temporaires)
  397. C Je fais la methode GENERALE directement (sortie de BSIGMA visee)
  398. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  399. 444 CONTINUE
  400. NN = 0
  401. NNIN = 0
  402. NNNOE = 0
  403.  
  404. NAT = 1
  405. NATi = -1
  406. NATf = -1
  407. CHA8 = ' '
  408. CHA8a = ' '
  409. CHA8b = ' '
  410. DO 400 III = 1,NBFUS
  411. C Ouverture de tous les MCHPOI
  412. MCHPOI = SID.IPOINT(III)
  413. SEGACT,MCHPOI
  414. NSOUPO = MCHPOI.IPCHP(/1)
  415. NAT = MAX(NAT,MCHPOI.JATTRI(/1))
  416. NATi = MCHPOI.JATTRI(1)
  417. CHA8 = MCHPOI.MTYPOI
  418.  
  419. IF (NATi .EQ. 0) THEN
  420. C On ne peut pas assembler des CHPOINTS qui ont des NATURES indeterminee
  421. CALL ERREUR(650)
  422. RETURN
  423. ENDIF
  424.  
  425. IF(III .EQ. 1) THEN
  426. NATf = NATi
  427. CHA8a=CHA8
  428. CHA8b=CHA8
  429. ELSE
  430. IF (NATi .NE. NATf) THEN
  431. C On ne peut pas assembler des CHPOINTS qui ont des NATURES differentes
  432. CALL ERREUR(649)
  433. RETURN
  434. ENDIF
  435. IF (CHA8 .NE. CHA8a) THEN
  436. CHA8b='INDETERM'
  437. ENDIF
  438. ENDIF
  439. DO 410 JJJ = 1,NSOUPO
  440. C Ouverture de tous les MSOUPO
  441. MSOUPO = MCHPOI.IPCHP(JJJ)
  442. SEGACT,MSOUPO
  443. NN = NN + MSOUPO.NOHARM(/1)
  444. 410 CONTINUE
  445. 400 CONTINUE
  446. SEGACT,MCOORD
  447. SEGINI,ITRAV,ICPR
  448.  
  449. C Decompte et stokage des composantes differentes
  450. DO 420 III = 1,NBFUS
  451. MCHPOI = SID.IPOINT(III)
  452. DO 430 JJJ = 1,MCHPOI.IPCHP(/1)
  453. MSOUPO = MCHPOI.IPCHP(JJJ)
  454. DO 431 KKK = 1,MSOUPO.NOHARM(/1)
  455. DO 432 LLL = 1,NNIN
  456. IF(MSOUPO.NOCOMP(KKK) .NE. ITRAV.INC (LLL)) GOTO 432
  457. IF(MSOUPO.NOHARM(KKK) .EQ. ITRAV.IHAR(LLL)) GOTO 431
  458. 432 CONTINUE
  459. NNIN = NNIN + 1
  460. ITRAV.INC (NNIN)=MSOUPO.NOCOMP(KKK)
  461. ITRAV.IHAR(NNIN)=MSOUPO.NOHARM(KKK)
  462. 431 CONTINUE
  463.  
  464. IPT1 =MSOUPO.IGEOC
  465. MPOVAL=MSOUPO.IPOVAL
  466. SEGACT,IPT1,MPOVAL
  467. DO 433 MMM=1,IPT1.NUM(/2)
  468. INOEUD=IPT1.NUM(1,MMM)
  469. IF(ICPR(INOEUD) .EQ. 0) THEN
  470. NNNOE = NNNOE + 1
  471. ICPR(INOEUD)= NNNOE
  472. ENDIF
  473. 433 CONTINUE
  474. 430 CONTINUE
  475. 420 CONTINUE
  476.  
  477. C Creation de MTRAV et remplissage
  478. SEGINI,MTRAV
  479.  
  480. DO 450 III = 1,NBFUS
  481. MCHPOI = SID.IPOINT(III)
  482. DO 460 JJJ = 1,MCHPOI.IPCHP(/1)
  483. MSOUPO=MCHPOI.IPCHP(JJJ)
  484. IPT1 =MSOUPO.IGEOC
  485. MPOVAL=MSOUPO.IPOVAL
  486.  
  487. C Recherche de la composante correspondante
  488. DO 461 KKK=1,MSOUPO.NOCOMP(/2)
  489. DO 462 LLL=1,NNIN
  490. IF(MSOUPO.NOCOMP(KKK) .NE. ITRAV.INC (LLL)) GOTO 462
  491. IF(MSOUPO.NOHARM(KKK) .EQ. ITRAV.IHAR(LLL)) GOTO 463
  492. 462 CONTINUE
  493. CALL ERREUR(5)
  494. 463 CONTINUE
  495.  
  496. C Selon l'ATTRIBUT de NATURE on ne fait pas la même operation
  497. IF (NATi .EQ. 1) THEN
  498. C NATURE DIFFUS on doit avoir la meme valeur en 1 pt d'une meme composante
  499. DO 464 MMM=1,IPT1.NUM(/2)
  500. INOEUD =ICPR(IPT1.NUM(1,MMM))
  501. IGEO(INOEUD)= IPT1.NUM(1,MMM)
  502. XX1 = MPOVAL.VPOCHA(MMM,KKK)
  503. XX2 = BB (LLL,INOEUD)
  504. I1 = IBIN(LLL,INOEUD)
  505.  
  506. IF (I1 .EQ. 0)THEN
  507. C Premiere valeur qu'on place la
  508. IBIN(LLL,INOEUD)= 1
  509. BB (LLL,INOEUD)= XX1
  510.  
  511. ELSEIF(I1 .EQ. 1) THEN
  512. C Autres valeurs qu'on trouve a la meme place
  513. XX3 = MAX(ABS(XX1) ,ABS(XX2))
  514. XXPREC= MAX(XZPREC*XX3,XPETIT )
  515. IF (ABS(XX1 - XX2) .GT. XXPREC) THEN
  516. C On ne peut pas assembler des CHPOINTS de nature DIFFUS
  517. C ayant des valeurs differentes en un point de la meme composante
  518. CALL ERREUR(651)
  519. RETURN
  520. ENDIF
  521. ENDIF
  522. 464 CONTINUE
  523.  
  524. ELSEIF (NATi .EQ. 2) THEN
  525. C NATURE DISCRET on procede a l'addition des valeurs en 1 pt d'une meme composante
  526. DO 465 MMM=1,IPT1.NUM(/2)
  527. INOEUD =ICPR(IPT1.NUM(1,MMM))
  528. IGEO(INOEUD)= IPT1.NUM(1,MMM)
  529. IBIN(LLL,INOEUD)= 1
  530. BB (LLL,INOEUD)= MPOVAL.VPOCHA(MMM,KKK)+BB(LLL,INOEUD)
  531. 465 CONTINUE
  532.  
  533. ELSE
  534. C On ne peut pas assembler des CHPOINTS qui ont des NATURES differentes
  535. CALL ERREUR(649)
  536. RETURN
  537. ENDIF
  538. 461 CONTINUE
  539.  
  540. SEGDES,IPT1,MPOVAL,MSOUPO
  541. 460 CONTINUE
  542. SEGDES,MCHPOI
  543.  
  544. C Remplissage des NOMS de composante et NUMEROS d'harmoniques
  545. DO 451 JJJ = 1,NNIN
  546. INCO(JJJ)=ITRAV.INC (JJJ)
  547. NHAR(JJJ)=ITRAV.IHAR(JJJ)
  548. 451 CONTINUE
  549. 450 CONTINUE
  550.  
  551. SEGSUP,ITRAV,ICPR
  552.  
  553. CALL CRECHP (MTRAV,ID1)
  554. SEGSUP,MTRAV
  555. MCHPOI=ID1
  556.  
  557. C Dans crechp "NAT" vaut 1, on AJUSTE le SEGMENT si besoin
  558. SEGACT,MCHPOI*MOD
  559. IF (NAT .GT. MCHPOI.JATTRI(/1))SEGADJ,MCHPOI
  560.  
  561. C Le chapeau du CHPOINT est complete d'apres le premier de la liste
  562. MCHPO4 = SID.IPOINT(1)
  563. SEGACT,MCHPO4
  564.  
  565. MCHPOI.MTYPOI=CHA8b
  566. MCHPOI.MOCHDE='CHPOINT CREE PAR FUNOBJ'
  567. DO IATT=1,NAT
  568. MCHPOI.JATTRI(IATT)=MCHPO4.JATTRI(IATT)
  569. ENDDO
  570.  
  571. SEGDES,MCHPOI,MCHPO4
  572. RETURN
  573.  
  574.  
  575.  
  576. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  577. C FUSION DE RIGIDITE ESCLAVES : En une seule fois (Pas de RIGIDITE temporaires)
  578. C Seulement les CHAPEAUX sont fusionnes
  579. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  580. 555 CONTINUE
  581. C OUVERTURE de tous les MRIGID
  582. NRIGEL=0
  583. DO III=1,NBFUS
  584. MRIGID=SID.IPOINT(III)
  585. SEGACT,MRIGID
  586. NRIGEL=NRIGEL + IRIGEL(/2)
  587. CHA8 =MRIGID.MTYMAT
  588.  
  589. IF(III .EQ. 1) THEN
  590. CHA8a=CHA8
  591. CHA8b=CHA8
  592. ELSE
  593. IF (CHA8 .NE. CHA8a) THEN
  594. IF(CHA8 .EQ. 'RIGIDITE')THEN
  595. CHA8b='RIGIDITE'
  596. ELSE
  597. CHA8b='INDETERM'
  598. ENDIF
  599. ENDIF
  600. ENDIF
  601. ENDDO
  602.  
  603. SEGINI,MRIGID
  604. ID1 = MRIGID
  605. MRIGID.ICHOLE = 0
  606. MRIGID.IMGEO1 = 0
  607. MRIGID.MTYMAT = CHA8b
  608.  
  609. C FUSION des CHAPEAUX
  610. IC=0
  611. DO III=1,NBFUS
  612. RI1=SID.IPOINT(III)
  613. JA =RI1.IRIGEL(/2)
  614. JB =RI1.IRIGEL(/1)
  615. DO KKK=1,JA
  616. MELEME=RI1.IRIGEL(1,KKK)
  617. SEGACT,MELEME
  618. IF (NUM(/2) .NE. 0) THEN
  619. IC=IC+1
  620. COERIG(IC)=RI1.COERIG(KKK)
  621. DO LLL=1,JB
  622. IRIGEL(LLL,IC)=RI1.IRIGEL(LLL,KKK)
  623. ENDDO
  624. ENDIF
  625. SEGDES,MELEME
  626. ENDDO
  627. SEGDES,RI1
  628. ENDDO
  629.  
  630. C Ajustement du SEGMENT le cas echeant
  631. IF (NRIGEL .NE. IC) THEN
  632. NRIGEL=IC
  633. SEGADJ,MRIGID
  634. ENDIF
  635.  
  636. SEGDES,MRIGID
  637. RETURN
  638.  
  639.  
  640. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  641. C FUSION DE RIGIDITE ESCLAVES : En une seule fois (Pas de RIGIDITE temporaires)
  642. C Seulement les CHAPEAUX sont fusionnes
  643. C
  644. C CB215821 : Impossible de faire COHABITER SMRIGID et SMMATRIK
  645. C - Les SEGMENTS portent les memes nom...
  646. C
  647. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  648. C 666 CONTINUE
  649. CC OUVERTURE de tous les MATRIK
  650. C NMATRI=0
  651. C DO III=1,NBFUS
  652. C MATRIK=SID.IPOINT(III)
  653. C SEGACT,MATRIK
  654. C NMATRI=NMATRI + IRIGEL(/2)
  655. C ENDDO
  656. C
  657. C NRIGE= 7
  658. C NKID = 9
  659. C NKMT = 7
  660. C SEGINI,MATRIK
  661. C ID1 = MATRIK
  662. C
  663. C IC = 1
  664. C DO III=1,NBFUS
  665. C IP1 = SID.IPOINT(III)
  666. C N1 = IP1.IRIGEL(/2)
  667. C
  668. CC Copie des IRIGEL dans le resultat
  669. C DO JJJ=1,N1
  670. C DO KKK=1,NRIGE
  671. C IRIGEL(KKK,IC + JJJ)=IP1.IRIGEL(KKK,JJJ)
  672. C ENDDO
  673. C
  674. CC On effectue une copie des segments IMATRI car ils pointent sur
  675. CC d'autres objets élémentaires (les valeurs des matrices élémentaires)
  676. C IMATR1=IP1.IRIGEL(4,JJJ)
  677. C SEGINI,IMATR2=IMATR1
  678. C SEGDES,IMATR2
  679. C IRIGEL(4,IC + JJJ)=IMATR2
  680. C ENDDO
  681. C IC = IC + N1
  682. C SEGDES,IP1
  683. C ENDDO
  684. C
  685. C SEGDES,MATRIK
  686. C RETURN
  687.  
  688.  
  689.  
  690. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  691. C FUSION DE MELEME ESCLAVES :
  692. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  693. 777 CONTINUE
  694. NBTY = 100
  695. NBMAIL= 100
  696. IDMAIL= 0
  697. SEGINI,INDEXM
  698.  
  699. SEGINI,LISTYP
  700. C Ouverture de tous les MELEME
  701. NMATRI= 0
  702. NBTYP = 0
  703. DO 7771 III=1,NBFUS
  704. IPT1=SID.IPOINT(III)
  705. SEGACT,IPT1
  706. NBSOUS=IPT1.LISOUS(/1)
  707. IF (NBSOUS .GT. 0) THEN
  708. C Cas des MELEME COMPLEXES
  709. DO 7772 JJJ=1,NBSOUS
  710. IDMAIL=IDMAIL + 1
  711.  
  712. IF(IDMAIL .GT. NBMAIL)THEN
  713. NBMAIL = NBMAIL * 2
  714. SEGADJ,INDEXM
  715. ENDIF
  716.  
  717. IPT2=IPT1.LISOUS(JJJ)
  718. SEGACT,IPT2
  719. NBELEM = IPT2.NUM(/2)
  720.  
  721. IF (NBELEM .GT. 0) THEN
  722. ITYPE = IPT2.ITYPEL
  723. NBNN = IPT2.NUM(/1)
  724. C Recherche d'un TYPE DEJA RENCONTRE
  725. IF (NBTYP .EQ. 0) THEN
  726. NBTYP = 1
  727. INDEXM(1) = 1
  728. LISTYP(1,1)=ITYPE
  729. LISTYP(1,2)=LISTYP(1,2) + NBELEM
  730. LISTYP(1,3)=NBNN
  731.  
  732. ELSE
  733. DO KKK=1,NBTYP
  734. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  735. & NBNN .EQ. LISTYP(KKK,3)) THEN
  736. INDEXM(IDMAIL)=KKK
  737. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  738. GOTO 7772
  739. ENDIF
  740. ENDDO
  741. NBTYP = NBTYP + 1
  742. IF(NBTYP .GT. NBTY)THEN
  743. NBTY = NBTY * 2
  744. SEGADJ,LISTYP
  745. ENDIF
  746. INDEXM(IDMAIL) = NBTYP
  747. LISTYP(NBTYP,1)= ITYPE
  748. LISTYP(NBTYP,2)= LISTYP(NBTYP,2) + NBELEM
  749. LISTYP(NBTYP,3)= NBNN
  750. ENDIF
  751. ENDIF
  752. 7772 CONTINUE
  753.  
  754. ELSE
  755. C Cas des MELEME SIMPLES
  756. IDMAIL=IDMAIL + 1
  757. IF(IDMAIL .GT. NBMAIL)THEN
  758. NBMAIL = NBMAIL * 2
  759. SEGADJ,INDEXM
  760. ENDIF
  761.  
  762. NBELEM = IPT1.NUM(/2)
  763. IF (NBELEM .GT. 0) THEN
  764. ITYPE = IPT1.ITYPEL
  765. NBNN = IPT1.NUM(/1)
  766. C Recherche d'un TYPE DEJA RENCONTRE
  767. IF (NBTYP .EQ. 0) THEN
  768. NBTYP = 1
  769. INDEXM(1) = 1
  770. LISTYP(1,1)= ITYPE
  771. LISTYP(1,2)= LISTYP(1,2) + NBELEM
  772. LISTYP(1,3)= NBNN
  773.  
  774. ELSE
  775. DO KKK=1,NBTYP
  776. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  777. & NBNN .EQ. LISTYP(KKK,3)) THEN
  778. INDEXM(IDMAIL)=KKK
  779. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  780. GOTO 7771
  781. ENDIF
  782. ENDDO
  783. NBTYP = NBTYP + 1
  784. IF(NBTYP .GT. NBTY)THEN
  785. NBTY = NBTY * 2
  786. SEGADJ,LISTYP
  787. ENDIF
  788. INDEXM(IDMAIL) =NBTYP
  789. LISTYP(NBTYP,1)=ITYPE
  790. LISTYP(NBTYP,2)=LISTYP(NBTYP,2) + NBELEM
  791. LISTYP(NBTYP,3)=NBNN
  792. ENDIF
  793. ENDIF
  794. ENDIF
  795. 7771 CONTINUE
  796.  
  797.  
  798. C CREATION DU RESULTAT ET REMPLISSAGE
  799. IDMAIL = 0
  800. NBTY = NBTYP
  801. SEGINI,IDELEM
  802. IF(NBTYP .EQ. 0)THEN
  803. C Cas du MELEME resultat SIMPLE VIDE
  804. ITEL = ILCOUR
  805. NBELEM = 0
  806. NBNN = 0
  807. NBSOUS = 0
  808. NBREF = 0
  809. SEGINI,MELEME
  810. MELEME.ITYPEL=ITEL
  811. SEGDES,MELEME
  812.  
  813. ELSEIF(NBTYP .EQ. 1)THEN
  814. C Cas du MELEME resultat SIMPLE NON VIDE
  815. NBELEM = LISTYP(1,2)
  816. NBNN = LISTYP(1,3)
  817. NBSOUS = 0
  818. NBREF = 0
  819. SEGINI,MELEME
  820. MELEME.ITYPEL=LISTYP(1,1)
  821. DO III=1,NBFUS
  822. IPT1=SID.IPOINT(III)
  823. NBELEM=IPT1.NUM(/2)
  824. IF (NBELEM .GT. 0)THEN
  825. JJ1=IDELEM(1)
  826. DO JJJ=1,NBELEM
  827. JJ1=JJ1 + 1
  828. MELEME.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  829. DO KKK=1,NBNN
  830. MELEME.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  831. ENDDO
  832. ENDDO
  833. IDELEM(1) = IDELEM(1) + NBELEM
  834. ENDIF
  835. ENDDO
  836. SEGDES,MELEME
  837.  
  838. ELSE
  839. C Cas du MELEME resultat COMPLEXE
  840. NBNN = 0
  841. NBELEM = 0
  842. NBSOUS = NBTYP
  843. NBREF = 0
  844. SEGINI,MELEME
  845.  
  846. DO III=1,NBTYP
  847. NBELEM=LISTYP(III,2)
  848. NBNN =LISTYP(III,3)
  849. NBSOUS=0
  850. NBREF =0
  851. SEGINI,IPT3
  852. IPT3.ITYPEL=LISTYP(III,1)
  853. MELEME.LISOUS(III)=IPT3
  854. ENDDO
  855.  
  856. DO III=1,NBFUS
  857. IPT1=SID.IPOINT(III)
  858. NBSOUS=IPT1.LISOUS(/1)
  859. IF (NBSOUS .GT. 0) THEN
  860. C Cas des MELEME COMPLEXES
  861. DO JJJ=1,NBSOUS
  862. IDMAIL=IDMAIL+1
  863. IPT2=IPT1.LISOUS(JJJ)
  864. NBELEM = IPT2.NUM(/2)
  865. IF (NBELEM .GT. 0)THEN
  866. NBTYP = INDEXM(IDMAIL)
  867. NBNN = IPT2.NUM(/1)
  868. IPT3 = MELEME.LISOUS(NBTYP)
  869. JJ1 = IDELEM(NBTYP)
  870. DO LLL=1,NBELEM
  871. JJ1=JJ1 + 1
  872. IPT3.ICOLOR(JJ1)=IPT2.ICOLOR(LLL)
  873. DO KKK=1,NBNN
  874. IPT3.NUM(KKK,JJ1)=IPT2.NUM(KKK,LLL)
  875. ENDDO
  876. ENDDO
  877. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  878. ENDIF
  879. ENDDO
  880.  
  881. ELSE
  882. C Cas des MELEME SIMPLES
  883. IDMAIL=IDMAIL+1
  884. NBELEM = IPT1.NUM(/2)
  885. IF (NBELEM .GT. 0)THEN
  886. NBTYP = INDEXM(IDMAIL)
  887. NBNN = IPT1.NUM(/1)
  888. IPT3 = MELEME.LISOUS(NBTYP)
  889. JJ1 = IDELEM(NBTYP)
  890. DO JJJ=1,NBELEM
  891. JJ1=JJ1 + 1
  892. IPT3.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  893. DO KKK=1,NBNN
  894. IPT3.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  895. ENDDO
  896. ENDDO
  897. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  898. ENDIF
  899. ENDIF
  900. ENDDO
  901.  
  902. C Fermeture des MELEME du resultat
  903. IF (NBTY .GT. 1)THEN
  904. DO III=1,NBTY
  905. IPT3=MELEME.LISOUS(III)
  906. SEGDES,IPT3
  907. ENDDO
  908. ENDIF
  909. SEGDES,MELEME
  910.  
  911. ENDIF
  912. ID1=MELEME
  913.  
  914. C Fermeture de tous les MELEME des entrees
  915. DO III=1,NBFUS
  916. IPT1=SID.IPOINT(III)
  917. NBSOUS=IPT1.LISOUS(/1)
  918. IF (NBSOUS .GT. 0) THEN
  919. C Cas des MELEME COMPLEXES
  920. DO JJJ=1,NBSOUS
  921. IPT2=IPT1.LISOUS(JJJ)
  922. SEGDES,IPT2
  923. ENDDO
  924. ENDIF
  925. SEGDES,IPT1
  926. ENDDO
  927.  
  928. C Suppression des SEGMENTS de travail
  929. SEGSUP,LISTYP,IDELEM,INDEXM
  930.  
  931. RETURN
  932. END
  933.  
  934.  
  935.  

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