Télécharger funobj.eso

Retour à la liste

Numérotation des lignes :

  1. C FUNOBJ SOURCE CB215821 19/07/30 21:16:38 10273
  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 PLAMO8(LESMO1,NBMO1,ITYP0,CHA8)
  102. IF (ITYP0.EQ.0) THEN
  103. MOTERR(1:8 ) = CHA8
  104. CALL ERREUR(1046)
  105. ENDIF
  106.  
  107. C Activations des SEGMENTS en entree
  108. DO IFUS=1,NBFUS
  109. id1 = SID.IPOINT(IFUS)
  110. CALL ACTOBJ(CHA8,id1,1)
  111. ENDDO
  112.  
  113. C Gestion de la methode de fusion selon ITYP0
  114. GOTO(555,111,111,777,444,111,333,333),ITYP0
  115.  
  116. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  117. C GESTION DE LA FUSION PAR TOURNOIS (2 par 2)
  118. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  119. 111 CONTINUE
  120. SEGINI,SID1=SID
  121. ltelq = .TRUE.
  122. BOOL1 = SID.BVAL(1)
  123. XVAL1 = SID.XVAL(1)
  124.  
  125. NBREST = NBFUS
  126. C Debut de la fusion d'objets par tournoi
  127. 1 CONTINUE
  128.  
  129. C Stade de la competition
  130. ISTADE = ISTADE + 1
  131.  
  132. IF (NBREST .EQ. 1) THEN
  133. C Fin lorsqu'il ne reste plus qu'un seul objet a fusionner
  134. ID1 = SID.IPOINT(1)
  135. SEGSUP,SID1
  136. RETURN
  137.  
  138. ELSEIF (MOD(NBREST,2) .EQ. 0) THEN
  139. C Cas du Nombre pair d'objets restant a fusionner
  140. DO 100 III = 1,(NBREST/2)
  141. I1 = (III*2) - 1
  142. I2 = (III*2)
  143. id1 = SID.IPOINT(I1)
  144. id2 = SID.IPOINT(I2)
  145. B1 = SID.BVAL(I1)
  146. B2 = SID.BVAL(I2)
  147. X1 = SID.XVAL(I1)
  148. X2 = SID.XVAL(I2)
  149. GOTO(2,4,6,8,10,12,14,16),ITYP0
  150.  
  151. C 'RIGIDITE'
  152. 2 CONTINUE
  153. call fusrig(id1,id2,iretou )
  154. GOTO 120
  155.  
  156. C 'MATRIK'
  157. 4 CONTINUE
  158. call fusmtk(id1,id2,iretou )
  159. GOTO 120
  160.  
  161. C 'MMODEL'
  162. 6 CONTINUE
  163. call fusmod(id1,id2,iretou )
  164. GOTO 120
  165.  
  166. C 'MAILLAGE'
  167. 8 CONTINUE
  168. call fuse (id1,id2,iretou,ltelq)
  169. GOTO 120
  170.  
  171. C 'CHPOINT'
  172. 10 CONTINUE
  173. call fuchpo(id1,id2,iretou )
  174. GOTO 120
  175.  
  176. C 'MCHAML'
  177. 12 CONTINUE
  178. call etmchl(id1,id2,iretou )
  179. GOTO 120
  180.  
  181. C 'FLOTTANT'
  182. 14 CONTINUE
  183. IF (BMAX) THEN
  184. XVAL1= MAX(XVAL1,X1,X2)
  185. ELSE
  186. XVAL1= MIN(XVAL1,X1,X2)
  187. ENDIF
  188. GOTO 100
  189.  
  190. C 'LOGIQUE'
  191. 16 CONTINUE
  192. IF (BMAX) THEN
  193. BOOL1 = BOOL1 .AND. B1 .AND. B2
  194. ELSE
  195. BOOL1 = BOOL1 .OR. B1 .OR. B2
  196. ENDIF
  197. GOTO 100
  198.  
  199. 120 CONTINUE
  200. C Menage des objets temporaires inutiles
  201. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID1)
  202. IF (IPLAC.EQ.0) THEN
  203. ISEG=ID1
  204. SEGSUP,ISEG
  205. ENDIF
  206. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID2)
  207. IF (IPLAC.EQ.0) THEN
  208. ISEG=ID2
  209. SEGSUP,ISEG
  210. ENDIF
  211.  
  212. C On remplace dans SID.IPOINT pour l'iteration suivante
  213. SID.IPOINT(III) = iretou
  214.  
  215. 100 CONTINUE
  216.  
  217. NBREST = (NBREST/2)
  218.  
  219. ELSE
  220. C Cas du Nombre impair d'objets restant a fusionner
  221. DO 200 III = 1,((NBREST-1)/2)
  222. I1 = (III*2) - 1
  223. I2 = (III*2)
  224. id1 = SID.IPOINT(I1)
  225. id2 = SID.IPOINT(I2)
  226. B1 = SID.BVAL(I1)
  227. B2 = SID.BVAL(I2)
  228. X1 = SID.XVAL(I1)
  229. X2 = SID.XVAL(I2)
  230. GOTO(3,5,7,9,11,13,15,17),ITYP0
  231.  
  232. C 'RIGIDITE'
  233. 3 CONTINUE
  234. call fusrig(id1,id2,iretou )
  235. GOTO 220
  236.  
  237. C 'MATRIK'
  238. 5 CONTINUE
  239. call fusmtk(id1,id2,iretou )
  240. GOTO 210
  241.  
  242. C 'MMODEL'
  243. 7 CONTINUE
  244. call fusmod(id1,id2,iretou )
  245. GOTO 220
  246.  
  247. C 'MAILLAGE'
  248. 9 CONTINUE
  249. call fuse (id1,id2,iretou,ltelq)
  250. GOTO 220
  251.  
  252. C 'CHPOINT'
  253. 11 CONTINUE
  254. call fuchpo(id1,id2,iretou )
  255. GOTO 210
  256.  
  257. C 'MCHAML'
  258. 13 CONTINUE
  259. call etmchl(id1,id2,iretou )
  260. GOTO 220
  261.  
  262. C 'FLOTTANT'
  263. 15 CONTINUE
  264. IF (BMAX) THEN
  265. XVAL1= MAX(XVAL1,X1,X2)
  266. ELSE
  267. XVAL1= MIN(XVAL1,X1,X2)
  268. ENDIF
  269. GOTO 200
  270.  
  271. C 'LOGIQUE'
  272. 17 CONTINUE
  273. IF (BMAX) THEN
  274. BOOL1 = BOOL1 .AND. B1 .AND. B2
  275. ELSE
  276. BOOL1 = BOOL1 .OR. B1 .OR. B2
  277. ENDIF
  278. GOTO 200
  279.  
  280. 220 CONTINUE
  281. C Menage des objets temporaires inutiles
  282. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID1)
  283. IF (IPLAC .EQ. 0) THEN
  284. ISEG=ID1
  285. SEGSUP, ISEG
  286. ENDIF
  287. CALL PLACE2(SID1.IPOINT,NBFUS,IPLAC,ID2)
  288. IF (IPLAC .EQ. 0) THEN
  289. ISEG=ID2
  290. SEGSUP, ISEG
  291. ENDIF
  292.  
  293. 210 CONTINUE
  294. C On remplace dans SID.IPOINT pour l'iteration suivante
  295. SID.IPOINT(III+1) = iretou
  296.  
  297. 200 CONTINUE
  298.  
  299. C Le dernier OBJET n'est pas traité, il est repris au debut pour l'iteration suivante
  300. SID.IPOINT(1) = SID.IPOINT(NBREST)
  301. SID.BVAL(1) = SID.BVAL(NBREST)
  302. SID.XVAL(1) = SID.XVAL(NBREST)
  303.  
  304. NBREST = ((NBREST-1)/2) + 1
  305.  
  306. ENDIF
  307. GOTO 1
  308.  
  309.  
  310.  
  311. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  312. C GESTION SEQUENTIELLE DE LA FUSION : COMME AVANT
  313. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  314. 333 CONTINUE
  315. SEGINI,SID1=SID
  316. ID1 = SID.IPOINT(1)
  317. BOOL1 = SID.BVAL(1)
  318. XVAL1 = SID.XVAL(1)
  319.  
  320. C Stade de la competition
  321. ISTADE = ISTADE + 1
  322.  
  323. DO 300 III = 2,NBFUS
  324. ID2 = SID.IPOINT(III)
  325. B2 = SID.BVAL(III)
  326. X2 = SID.XVAL(III)
  327. GOTO(31,32,33,34,35,36,37,38),ITYP0
  328.  
  329. C 'RIGIDITE'
  330. 31 CONTINUE
  331. call fusrig(id1,id2,iretou )
  332. GOTO 320
  333.  
  334. C 'MATRIK'
  335. 32 CONTINUE
  336. call fusmtk(id1,id2,iretou )
  337. GOTO 320
  338.  
  339. C 'MMODEL'
  340. 33 CONTINUE
  341. call fusmod(id1,id2,iretou )
  342. GOTO 320
  343.  
  344. C 'MAILLAGE'
  345. 34 CONTINUE
  346. call fuse (id1,id2,iretou,ltelq)
  347. GOTO 320
  348.  
  349. C 'CHPOINT'
  350. 35 CONTINUE
  351. call fuchpo(id1,id2,iretou )
  352. GOTO 310
  353.  
  354. C 'MCHAML'
  355. 36 CONTINUE
  356. call etmchl(id1,id2,iretou )
  357. GOTO 320
  358.  
  359. C 'FLOTTANT'
  360. 37 CONTINUE
  361. IF (BMAX) THEN
  362. XVAL1= MAX(XVAL1,X2)
  363. ELSE
  364. XVAL1= MIN(XVAL1,X2)
  365. ENDIF
  366. GOTO 300
  367.  
  368. C 'LOGIQUE'
  369. 38 CONTINUE
  370. IF (BMAX) THEN
  371. BOOL1 = BOOL1 .AND. B2
  372. ELSE
  373. BOOL1 = BOOL1 .OR. B2
  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. NSOUPO = MCHPOI.IPCHP(/1)
  414. NAT = MAX(NAT,MCHPOI.JATTRI(/1))
  415. NATi = MCHPOI.JATTRI(1)
  416. CHA8 = MCHPOI.MTYPOI
  417.  
  418. IF (NATi .EQ. 0) THEN
  419. C On ne peut pas assembler des CHPOINTS qui ont des NATURES indeterminee
  420. CALL ERREUR(650)
  421. RETURN
  422. ENDIF
  423.  
  424. IF(III .EQ. 1) THEN
  425. NATf = NATi
  426. CHA8a=CHA8
  427. CHA8b=CHA8
  428. ELSE
  429. IF (NATi .NE. NATf) THEN
  430. C On ne peut pas assembler des CHPOINTS qui ont des NATURES differentes
  431. CALL ERREUR(649)
  432. RETURN
  433. ENDIF
  434. IF (CHA8 .NE. CHA8a) THEN
  435. CHA8b='INDETERM'
  436. ENDIF
  437. ENDIF
  438. DO 410 JJJ = 1,NSOUPO
  439. C Ouverture de tous les MSOUPO
  440. MSOUPO= MCHPOI.IPCHP(JJJ)
  441. IPT1 =MSOUPO.IGEOC
  442. MPOVAL=MSOUPO.IPOVAL
  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. DO 433 MMM=1,IPT1.NUM(/2)
  467. INOEUD=IPT1.NUM(1,MMM)
  468. IF(ICPR(INOEUD) .EQ. 0) THEN
  469. NNNOE = NNNOE + 1
  470. ICPR(INOEUD)= NNNOE
  471. ENDIF
  472. 433 CONTINUE
  473. 430 CONTINUE
  474. 420 CONTINUE
  475.  
  476. C Creation de MTRAV et remplissage
  477. SEGINI,MTRAV
  478.  
  479. DO 450 III = 1,NBFUS
  480. MCHPOI = SID.IPOINT(III)
  481. DO 460 JJJ = 1,MCHPOI.IPCHP(/1)
  482. MSOUPO=MCHPOI.IPCHP(JJJ)
  483. IPT1 =MSOUPO.IGEOC
  484. MPOVAL=MSOUPO.IPOVAL
  485.  
  486. C Recherche de la composante correspondante
  487. DO 461 KKK=1,MSOUPO.NOCOMP(/2)
  488. DO 462 LLL=1,NNIN
  489. IF(MSOUPO.NOCOMP(KKK) .NE. ITRAV.INC (LLL)) GOTO 462
  490. IF(MSOUPO.NOHARM(KKK) .EQ. ITRAV.IHAR(LLL)) GOTO 463
  491. 462 CONTINUE
  492. CALL ERREUR(5)
  493. 463 CONTINUE
  494.  
  495. C Selon l'ATTRIBUT de NATURE on ne fait pas la même operation
  496. IF (NATi .EQ. 1) THEN
  497. C NATURE DIFFUS on doit avoir la meme valeur en 1 pt d'une meme composante
  498. DO 464 MMM=1,IPT1.NUM(/2)
  499. INOEUD =ICPR(IPT1.NUM(1,MMM))
  500. IGEO(INOEUD)= IPT1.NUM(1,MMM)
  501. XX1 = MPOVAL.VPOCHA(MMM,KKK)
  502. XX2 = BB (LLL,INOEUD)
  503. I1 = IBIN(LLL,INOEUD)
  504.  
  505. IF (I1 .EQ. 0)THEN
  506. C Premiere valeur qu'on place la
  507. IBIN(LLL,INOEUD)= 1
  508. BB (LLL,INOEUD)= XX1
  509.  
  510. ELSEIF(I1 .EQ. 1) THEN
  511. C Autres valeurs qu'on trouve a la meme place
  512. XX3 = MAX(ABS(XX1) ,ABS(XX2))
  513. XXPREC= MAX(XZPREC*XX3,XPETIT )
  514. IF (ABS(XX1 - XX2) .GT. XXPREC) THEN
  515. C On ne peut pas assembler des CHPOINTS de nature DIFFUS
  516. C ayant des valeurs differentes en un point de la meme composante
  517. CALL ERREUR(651)
  518. RETURN
  519. ENDIF
  520. ENDIF
  521. 464 CONTINUE
  522.  
  523. ELSEIF (NATi .EQ. 2) THEN
  524. C NATURE DISCRET on procede a l'addition des valeurs en 1 pt d'une meme composante
  525. DO 465 MMM=1,IPT1.NUM(/2)
  526. INOEUD =ICPR(IPT1.NUM(1,MMM))
  527. IGEO(INOEUD)= IPT1.NUM(1,MMM)
  528. IBIN(LLL,INOEUD)= 1
  529. BB (LLL,INOEUD)= MPOVAL.VPOCHA(MMM,KKK)+BB(LLL,INOEUD)
  530. 465 CONTINUE
  531.  
  532. ELSE
  533. C On ne peut pas assembler des CHPOINTS qui ont des NATURES differentes
  534. CALL ERREUR(649)
  535. RETURN
  536. ENDIF
  537. 461 CONTINUE
  538. 460 CONTINUE
  539.  
  540. C Remplissage des NOMS de composante et NUMEROS d'harmoniques
  541. DO 451 JJJ = 1,NNIN
  542. INCO(JJJ)=ITRAV.INC (JJJ)
  543. NHAR(JJJ)=ITRAV.IHAR(JJJ)
  544. 451 CONTINUE
  545. 450 CONTINUE
  546.  
  547. CALL CRECHP (MTRAV,ID1)
  548.  
  549. C FERMETURE ET SUPPRESSION DES SEGMENTS
  550. SEGSUP,ITRAV,ICPR,MTRAV
  551.  
  552. MCHPOI=ID1
  553.  
  554. C Dans crechp "NAT" vaut 1, on AJUSTE le SEGMENT si besoin
  555. IF (NAT .GT. MCHPOI.JATTRI(/1)) SEGADJ,MCHPOI
  556.  
  557. C Le chapeau du CHPOINT est complete d'apres le premier de la liste
  558. MCHPO4 = SID.IPOINT(1)
  559. MCHPOI.MTYPOI=CHA8b
  560. MCHPOI.MOCHDE='CHPOINT CREE PAR FUNOBJ'
  561. DO IATT=1,NAT
  562. MCHPOI.JATTRI(IATT)=MCHPO4.JATTRI(IATT)
  563. ENDDO
  564.  
  565. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  566. RETURN
  567.  
  568.  
  569.  
  570. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  571. C FUSION DE RIGIDITE ESCLAVES : En une seule fois (Pas de RIGIDITE temporaires)
  572. C Seulement les CHAPEAUX sont fusionnes
  573. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  574. 555 CONTINUE
  575. C OUVERTURE de tous les MRIGID
  576. NRIGEL=0
  577. DO III=1,NBFUS
  578. MRIGID=SID.IPOINT(III)
  579. SEGACT,MRIGID
  580. NRIGEL=NRIGEL + IRIGEL(/2)
  581. CHA8 =MRIGID.MTYMAT
  582.  
  583. IF(III .EQ. 1) THEN
  584. CHA8a=CHA8
  585. CHA8b=CHA8
  586. ELSE
  587. IF (CHA8 .NE. CHA8a) THEN
  588. IF(CHA8 .EQ. 'RIGIDITE')THEN
  589. CHA8b='RIGIDITE'
  590. ELSE
  591. CHA8b='INDETERM'
  592. ENDIF
  593. ENDIF
  594. ENDIF
  595. ENDDO
  596.  
  597. SEGINI,MRIGID
  598. ID1 = MRIGID
  599. MRIGID.ICHOLE = 0
  600. MRIGID.IMGEO1 = 0
  601. MRIGID.MTYMAT = CHA8b
  602.  
  603. C FUSION des CHAPEAUX
  604. IC=0
  605. DO III=1,NBFUS
  606. RI1=SID.IPOINT(III)
  607. JA =RI1.IRIGEL(/2)
  608. JB =RI1.IRIGEL(/1)
  609. DO KKK=1,JA
  610. MELEME=RI1.IRIGEL(1,KKK)
  611. SEGACT,MELEME
  612. IF (NUM(/2) .NE. 0) THEN
  613. IC=IC+1
  614. COERIG(IC)=RI1.COERIG(KKK)
  615. DO LLL=1,JB
  616. IRIGEL(LLL,IC)=RI1.IRIGEL(LLL,KKK)
  617. ENDDO
  618. ENDIF
  619. ENDDO
  620. ENDDO
  621.  
  622. C Ajustement du SEGMENT le cas echeant
  623. IF (NRIGEL .NE. IC) THEN
  624. NRIGEL=IC
  625. SEGADJ,MRIGID
  626. ENDIF
  627.  
  628. SEGACT,MRIGID*NOMOD
  629. RETURN
  630.  
  631.  
  632. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  633. C FUSION DE RIGIDITE ESCLAVES : En une seule fois (Pas de RIGIDITE temporaires)
  634. C Seulement les CHAPEAUX sont fusionnes
  635. C
  636. C CB215821 : Impossible de faire COHABITER SMRIGID et SMMATRIK
  637. C - Les SEGMENTS portent les memes nom...
  638. C
  639. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  640. C 666 CONTINUE
  641. CC OUVERTURE de tous les MATRIK
  642. C NMATRI=0
  643. C DO III=1,NBFUS
  644. C MATRIK=SID.IPOINT(III)
  645. C SEGACT,MATRIK
  646. C NMATRI=NMATRI + IRIGEL(/2)
  647. C ENDDO
  648. C
  649. C NRIGE= 7
  650. C NKID = 9
  651. C NKMT = 7
  652. C SEGINI,MATRIK
  653. C ID1 = MATRIK
  654. C
  655. C IC = 1
  656. C DO III=1,NBFUS
  657. C IP1 = SID.IPOINT(III)
  658. C N1 = IP1.IRIGEL(/2)
  659. C
  660. CC Copie des IRIGEL dans le resultat
  661. C DO JJJ=1,N1
  662. C DO KKK=1,NRIGE
  663. C IRIGEL(KKK,IC + JJJ)=IP1.IRIGEL(KKK,JJJ)
  664. C ENDDO
  665. C
  666. CC On effectue une copie des segments IMATRI car ils pointent sur
  667. CC d'autres objets élémentaires (les valeurs des matrices élémentaires)
  668. C IMATR1=IP1.IRIGEL(4,JJJ)
  669. C SEGINI,IMATR2=IMATR1
  670. C SEGDES,IMATR2
  671. C IRIGEL(4,IC + JJJ)=IMATR2
  672. C ENDDO
  673. C IC = IC + N1
  674. C SEGDES,IP1
  675. C ENDDO
  676. C
  677. C SEGDES,MATRIK
  678. C RETURN
  679.  
  680.  
  681.  
  682. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  683. C FUSION DE MELEME ESCLAVES :
  684. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  685. 777 CONTINUE
  686. NBTY = 100
  687. NBMAIL= 100
  688. IDMAIL= 0
  689. SEGINI,INDEXM
  690.  
  691. SEGINI,LISTYP
  692. C Ouverture de tous les MELEME
  693. NMATRI= 0
  694. NBTYP = 0
  695. DO 7771 III=1,NBFUS
  696. IPT1=SID.IPOINT(III)
  697. NBSOUS=IPT1.LISOUS(/1)
  698. IF (NBSOUS .GT. 0) THEN
  699. C Cas des MELEME COMPLEXES
  700. DO 7772 JJJ=1,NBSOUS
  701. IDMAIL=IDMAIL + 1
  702.  
  703. IF(IDMAIL .GT. NBMAIL)THEN
  704. NBMAIL = NBMAIL * 2
  705. SEGADJ,INDEXM
  706. ENDIF
  707.  
  708. IPT2=IPT1.LISOUS(JJJ)
  709. NBELEM = IPT2.NUM(/2)
  710.  
  711. IF (NBELEM .GT. 0) THEN
  712. ITYPE = IPT2.ITYPEL
  713. NBNN = IPT2.NUM(/1)
  714. C Recherche d'un TYPE DEJA RENCONTRE
  715. IF (NBTYP .EQ. 0) THEN
  716. NBTYP = 1
  717. INDEXM(1) = 1
  718. LISTYP(1,1)=ITYPE
  719. LISTYP(1,2)=LISTYP(1,2) + NBELEM
  720. LISTYP(1,3)=NBNN
  721.  
  722. ELSE
  723. DO KKK=1,NBTYP
  724. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  725. & NBNN .EQ. LISTYP(KKK,3)) THEN
  726. INDEXM(IDMAIL)=KKK
  727. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  728. GOTO 7772
  729. ENDIF
  730. ENDDO
  731. NBTYP = NBTYP + 1
  732. IF(NBTYP .GT. NBTY)THEN
  733. NBTY = NBTY * 2
  734. SEGADJ,LISTYP
  735. ENDIF
  736. INDEXM(IDMAIL) = NBTYP
  737. LISTYP(NBTYP,1)= ITYPE
  738. LISTYP(NBTYP,2)= LISTYP(NBTYP,2) + NBELEM
  739. LISTYP(NBTYP,3)= NBNN
  740. ENDIF
  741. ENDIF
  742. 7772 CONTINUE
  743.  
  744. ELSE
  745. C Cas des MELEME SIMPLES
  746. IDMAIL=IDMAIL + 1
  747. IF(IDMAIL .GT. NBMAIL)THEN
  748. NBMAIL = NBMAIL * 2
  749. SEGADJ,INDEXM
  750. ENDIF
  751.  
  752. NBELEM = IPT1.NUM(/2)
  753. IF (NBELEM .GT. 0) THEN
  754. ITYPE = IPT1.ITYPEL
  755. NBNN = IPT1.NUM(/1)
  756. C Recherche d'un TYPE DEJA RENCONTRE
  757. IF (NBTYP .EQ. 0) THEN
  758. NBTYP = 1
  759. INDEXM(1) = 1
  760. LISTYP(1,1)= ITYPE
  761. LISTYP(1,2)= LISTYP(1,2) + NBELEM
  762. LISTYP(1,3)= NBNN
  763.  
  764. ELSE
  765. DO KKK=1,NBTYP
  766. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  767. & NBNN .EQ. LISTYP(KKK,3)) THEN
  768. INDEXM(IDMAIL)=KKK
  769. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  770. GOTO 7771
  771. ENDIF
  772. ENDDO
  773. NBTYP = NBTYP + 1
  774. IF(NBTYP .GT. NBTY)THEN
  775. NBTY = NBTY * 2
  776. SEGADJ,LISTYP
  777. ENDIF
  778. INDEXM(IDMAIL) =NBTYP
  779. LISTYP(NBTYP,1)=ITYPE
  780. LISTYP(NBTYP,2)=LISTYP(NBTYP,2) + NBELEM
  781. LISTYP(NBTYP,3)=NBNN
  782. ENDIF
  783. ENDIF
  784. ENDIF
  785. 7771 CONTINUE
  786.  
  787.  
  788. C CREATION DU RESULTAT ET REMPLISSAGE
  789. IDMAIL = 0
  790. NBTY = NBTYP
  791. SEGINI,IDELEM
  792. IF(NBTYP .EQ. 0)THEN
  793. C Cas du MELEME resultat SIMPLE VIDE
  794. ITEL = ILCOUR
  795. NBELEM = 0
  796. NBNN = 0
  797. NBSOUS = 0
  798. NBREF = 0
  799. SEGINI,MELEME
  800. MELEME.ITYPEL=ITEL
  801.  
  802. ELSEIF(NBTYP .EQ. 1)THEN
  803. C Cas du MELEME resultat SIMPLE NON VIDE
  804. NBELEM = LISTYP(1,2)
  805. NBNN = LISTYP(1,3)
  806. NBSOUS = 0
  807. NBREF = 0
  808. SEGINI,MELEME
  809. MELEME.ITYPEL=LISTYP(1,1)
  810. DO III=1,NBFUS
  811. IPT1=SID.IPOINT(III)
  812. NBELEM=IPT1.NUM(/2)
  813. IF (NBELEM .GT. 0)THEN
  814. JJ1=IDELEM(1)
  815. DO JJJ=1,NBELEM
  816. JJ1=JJ1 + 1
  817. MELEME.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  818. DO KKK=1,NBNN
  819. MELEME.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  820. ENDDO
  821. ENDDO
  822. IDELEM(1) = IDELEM(1) + NBELEM
  823. ENDIF
  824. ENDDO
  825.  
  826. ELSE
  827. C Cas du MELEME resultat COMPLEXE
  828. NBNN = 0
  829. NBELEM = 0
  830. NBSOUS = NBTYP
  831. NBREF = 0
  832. SEGINI,MELEME
  833.  
  834. DO III=1,NBTYP
  835. NBELEM=LISTYP(III,2)
  836. NBNN =LISTYP(III,3)
  837. NBSOUS=0
  838. NBREF =0
  839. SEGINI,IPT3
  840. IPT3.ITYPEL=LISTYP(III,1)
  841. MELEME.LISOUS(III)=IPT3
  842. ENDDO
  843.  
  844. DO III=1,NBFUS
  845. IPT1=SID.IPOINT(III)
  846. NBSOUS=IPT1.LISOUS(/1)
  847. IF (NBSOUS .GT. 0) THEN
  848. C Cas des MELEME COMPLEXES
  849. DO JJJ=1,NBSOUS
  850. IDMAIL=IDMAIL+1
  851. IPT2=IPT1.LISOUS(JJJ)
  852. NBELEM = IPT2.NUM(/2)
  853. IF (NBELEM .GT. 0)THEN
  854. NBTYP = INDEXM(IDMAIL)
  855. NBNN = IPT2.NUM(/1)
  856. IPT3 = MELEME.LISOUS(NBTYP)
  857. JJ1 = IDELEM(NBTYP)
  858. DO LLL=1,NBELEM
  859. JJ1=JJ1 + 1
  860. IPT3.ICOLOR(JJ1)=IPT2.ICOLOR(LLL)
  861. DO KKK=1,NBNN
  862. IPT3.NUM(KKK,JJ1)=IPT2.NUM(KKK,LLL)
  863. ENDDO
  864. ENDDO
  865. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  866. ENDIF
  867. ENDDO
  868.  
  869. ELSE
  870. C Cas des MELEME SIMPLES
  871. IDMAIL=IDMAIL+1
  872. NBELEM = IPT1.NUM(/2)
  873. IF (NBELEM .GT. 0)THEN
  874. NBTYP = INDEXM(IDMAIL)
  875. NBNN = IPT1.NUM(/1)
  876. IPT3 = MELEME.LISOUS(NBTYP)
  877. JJ1 = IDELEM(NBTYP)
  878. DO JJJ=1,NBELEM
  879. JJ1=JJ1 + 1
  880. IPT3.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  881. DO KKK=1,NBNN
  882. IPT3.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  883. ENDDO
  884. ENDDO
  885. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  886. ENDIF
  887. ENDIF
  888. ENDDO
  889. ENDIF
  890. CALL ACTOBJ('MAILLAGE',MELEME,1)
  891. ID1=MELEME
  892.  
  893. C Suppression des SEGMENTS de travail
  894. SEGSUP,LISTYP,IDELEM,INDEXM
  895.  
  896. END
  897.  
  898.  
  899.  

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