Télécharger funobj.eso

Retour à la liste

Numérotation des lignes :

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

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