Télécharger funobj.eso

Retour à la liste

Numérotation des lignes :

  1. C FUNOBJ SOURCE CB215821 17/12/16 21:15:00 9669
  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. 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. DO III = 1,NBFUS
  552. MCHPOI = SID.IPOINT(III)
  553. DO JJJ = 1,MCHPOI.IPCHP(/1)
  554. MSOUPO=MCHPOI.IPCHP(JJJ)
  555. IPT1 =MSOUPO.IGEOC
  556. MPOVAL=MSOUPO.IPOVAL
  557. SEGDES,IPT1,MPOVAL,MSOUPO
  558. ENDDO
  559. SEGDES,MCHPOI
  560. ENDDO
  561. SEGSUP,ITRAV,ICPR,MTRAV
  562.  
  563. MCHPOI=ID1
  564.  
  565. C Dans crechp "NAT" vaut 1, on AJUSTE le SEGMENT si besoin
  566. SEGACT,MCHPOI*MOD
  567. IF (NAT .GT. MCHPOI.JATTRI(/1)) SEGADJ,MCHPOI
  568.  
  569. C Le chapeau du CHPOINT est complete d'apres le premier de la liste
  570. MCHPO4 = SID.IPOINT(1)
  571. SEGACT,MCHPO4
  572.  
  573. MCHPOI.MTYPOI=CHA8b
  574. MCHPOI.MOCHDE='CHPOINT CREE PAR FUNOBJ'
  575. DO IATT=1,NAT
  576. MCHPOI.JATTRI(IATT)=MCHPO4.JATTRI(IATT)
  577. ENDDO
  578.  
  579. SEGDES,MCHPOI,MCHPO4
  580. RETURN
  581.  
  582.  
  583.  
  584. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  585. C FUSION DE RIGIDITE ESCLAVES : En une seule fois (Pas de RIGIDITE temporaires)
  586. C Seulement les CHAPEAUX sont fusionnes
  587. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  588. 555 CONTINUE
  589. C OUVERTURE de tous les MRIGID
  590. NRIGEL=0
  591. DO III=1,NBFUS
  592. MRIGID=SID.IPOINT(III)
  593. SEGACT,MRIGID
  594. NRIGEL=NRIGEL + IRIGEL(/2)
  595. CHA8 =MRIGID.MTYMAT
  596.  
  597. IF(III .EQ. 1) THEN
  598. CHA8a=CHA8
  599. CHA8b=CHA8
  600. ELSE
  601. IF (CHA8 .NE. CHA8a) THEN
  602. IF(CHA8 .EQ. 'RIGIDITE')THEN
  603. CHA8b='RIGIDITE'
  604. ELSE
  605. CHA8b='INDETERM'
  606. ENDIF
  607. ENDIF
  608. ENDIF
  609. ENDDO
  610.  
  611. SEGINI,MRIGID
  612. ID1 = MRIGID
  613. MRIGID.ICHOLE = 0
  614. MRIGID.IMGEO1 = 0
  615. MRIGID.MTYMAT = CHA8b
  616.  
  617. C FUSION des CHAPEAUX
  618. IC=0
  619. DO III=1,NBFUS
  620. RI1=SID.IPOINT(III)
  621. JA =RI1.IRIGEL(/2)
  622. JB =RI1.IRIGEL(/1)
  623. DO KKK=1,JA
  624. MELEME=RI1.IRIGEL(1,KKK)
  625. SEGACT,MELEME
  626. IF (NUM(/2) .NE. 0) THEN
  627. IC=IC+1
  628. COERIG(IC)=RI1.COERIG(KKK)
  629. DO LLL=1,JB
  630. IRIGEL(LLL,IC)=RI1.IRIGEL(LLL,KKK)
  631. ENDDO
  632. ENDIF
  633. SEGDES,MELEME
  634. ENDDO
  635. SEGDES,RI1
  636. ENDDO
  637.  
  638. C Ajustement du SEGMENT le cas echeant
  639. IF (NRIGEL .NE. IC) THEN
  640. NRIGEL=IC
  641. SEGADJ,MRIGID
  642. ENDIF
  643.  
  644. SEGDES,MRIGID
  645. RETURN
  646.  
  647.  
  648. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  649. C FUSION DE RIGIDITE ESCLAVES : En une seule fois (Pas de RIGIDITE temporaires)
  650. C Seulement les CHAPEAUX sont fusionnes
  651. C
  652. C CB215821 : Impossible de faire COHABITER SMRIGID et SMMATRIK
  653. C - Les SEGMENTS portent les memes nom...
  654. C
  655. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  656. C 666 CONTINUE
  657. CC OUVERTURE de tous les MATRIK
  658. C NMATRI=0
  659. C DO III=1,NBFUS
  660. C MATRIK=SID.IPOINT(III)
  661. C SEGACT,MATRIK
  662. C NMATRI=NMATRI + IRIGEL(/2)
  663. C ENDDO
  664. C
  665. C NRIGE= 7
  666. C NKID = 9
  667. C NKMT = 7
  668. C SEGINI,MATRIK
  669. C ID1 = MATRIK
  670. C
  671. C IC = 1
  672. C DO III=1,NBFUS
  673. C IP1 = SID.IPOINT(III)
  674. C N1 = IP1.IRIGEL(/2)
  675. C
  676. CC Copie des IRIGEL dans le resultat
  677. C DO JJJ=1,N1
  678. C DO KKK=1,NRIGE
  679. C IRIGEL(KKK,IC + JJJ)=IP1.IRIGEL(KKK,JJJ)
  680. C ENDDO
  681. C
  682. CC On effectue une copie des segments IMATRI car ils pointent sur
  683. CC d'autres objets élémentaires (les valeurs des matrices élémentaires)
  684. C IMATR1=IP1.IRIGEL(4,JJJ)
  685. C SEGINI,IMATR2=IMATR1
  686. C SEGDES,IMATR2
  687. C IRIGEL(4,IC + JJJ)=IMATR2
  688. C ENDDO
  689. C IC = IC + N1
  690. C SEGDES,IP1
  691. C ENDDO
  692. C
  693. C SEGDES,MATRIK
  694. C RETURN
  695.  
  696.  
  697.  
  698. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  699. C FUSION DE MELEME ESCLAVES :
  700. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  701. 777 CONTINUE
  702. NBTY = 100
  703. NBMAIL= 100
  704. IDMAIL= 0
  705. SEGINI,INDEXM
  706.  
  707. SEGINI,LISTYP
  708. C Ouverture de tous les MELEME
  709. NMATRI= 0
  710. NBTYP = 0
  711. DO 7771 III=1,NBFUS
  712. IPT1=SID.IPOINT(III)
  713. SEGACT,IPT1
  714. NBSOUS=IPT1.LISOUS(/1)
  715. IF (NBSOUS .GT. 0) THEN
  716. C Cas des MELEME COMPLEXES
  717. DO 7772 JJJ=1,NBSOUS
  718. IDMAIL=IDMAIL + 1
  719.  
  720. IF(IDMAIL .GT. NBMAIL)THEN
  721. NBMAIL = NBMAIL * 2
  722. SEGADJ,INDEXM
  723. ENDIF
  724.  
  725. IPT2=IPT1.LISOUS(JJJ)
  726. SEGACT,IPT2
  727. NBELEM = IPT2.NUM(/2)
  728.  
  729. IF (NBELEM .GT. 0) THEN
  730. ITYPE = IPT2.ITYPEL
  731. NBNN = IPT2.NUM(/1)
  732. C Recherche d'un TYPE DEJA RENCONTRE
  733. IF (NBTYP .EQ. 0) THEN
  734. NBTYP = 1
  735. INDEXM(1) = 1
  736. LISTYP(1,1)=ITYPE
  737. LISTYP(1,2)=LISTYP(1,2) + NBELEM
  738. LISTYP(1,3)=NBNN
  739.  
  740. ELSE
  741. DO KKK=1,NBTYP
  742. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  743. & NBNN .EQ. LISTYP(KKK,3)) THEN
  744. INDEXM(IDMAIL)=KKK
  745. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  746. GOTO 7772
  747. ENDIF
  748. ENDDO
  749. NBTYP = NBTYP + 1
  750. IF(NBTYP .GT. NBTY)THEN
  751. NBTY = NBTY * 2
  752. SEGADJ,LISTYP
  753. ENDIF
  754. INDEXM(IDMAIL) = NBTYP
  755. LISTYP(NBTYP,1)= ITYPE
  756. LISTYP(NBTYP,2)= LISTYP(NBTYP,2) + NBELEM
  757. LISTYP(NBTYP,3)= NBNN
  758. ENDIF
  759. ENDIF
  760. 7772 CONTINUE
  761.  
  762. ELSE
  763. C Cas des MELEME SIMPLES
  764. IDMAIL=IDMAIL + 1
  765. IF(IDMAIL .GT. NBMAIL)THEN
  766. NBMAIL = NBMAIL * 2
  767. SEGADJ,INDEXM
  768. ENDIF
  769.  
  770. NBELEM = IPT1.NUM(/2)
  771. IF (NBELEM .GT. 0) THEN
  772. ITYPE = IPT1.ITYPEL
  773. NBNN = IPT1.NUM(/1)
  774. C Recherche d'un TYPE DEJA RENCONTRE
  775. IF (NBTYP .EQ. 0) THEN
  776. NBTYP = 1
  777. INDEXM(1) = 1
  778. LISTYP(1,1)= ITYPE
  779. LISTYP(1,2)= LISTYP(1,2) + NBELEM
  780. LISTYP(1,3)= NBNN
  781.  
  782. ELSE
  783. DO KKK=1,NBTYP
  784. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  785. & NBNN .EQ. LISTYP(KKK,3)) THEN
  786. INDEXM(IDMAIL)=KKK
  787. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  788. GOTO 7771
  789. ENDIF
  790. ENDDO
  791. NBTYP = NBTYP + 1
  792. IF(NBTYP .GT. NBTY)THEN
  793. NBTY = NBTY * 2
  794. SEGADJ,LISTYP
  795. ENDIF
  796. INDEXM(IDMAIL) =NBTYP
  797. LISTYP(NBTYP,1)=ITYPE
  798. LISTYP(NBTYP,2)=LISTYP(NBTYP,2) + NBELEM
  799. LISTYP(NBTYP,3)=NBNN
  800. ENDIF
  801. ENDIF
  802. ENDIF
  803. 7771 CONTINUE
  804.  
  805.  
  806. C CREATION DU RESULTAT ET REMPLISSAGE
  807. IDMAIL = 0
  808. NBTY = NBTYP
  809. SEGINI,IDELEM
  810. IF(NBTYP .EQ. 0)THEN
  811. C Cas du MELEME resultat SIMPLE VIDE
  812. ITEL = ILCOUR
  813. NBELEM = 0
  814. NBNN = 0
  815. NBSOUS = 0
  816. NBREF = 0
  817. SEGINI,MELEME
  818. MELEME.ITYPEL=ITEL
  819. SEGDES,MELEME
  820.  
  821. ELSEIF(NBTYP .EQ. 1)THEN
  822. C Cas du MELEME resultat SIMPLE NON VIDE
  823. NBELEM = LISTYP(1,2)
  824. NBNN = LISTYP(1,3)
  825. NBSOUS = 0
  826. NBREF = 0
  827. SEGINI,MELEME
  828. MELEME.ITYPEL=LISTYP(1,1)
  829. DO III=1,NBFUS
  830. IPT1=SID.IPOINT(III)
  831. NBELEM=IPT1.NUM(/2)
  832. IF (NBELEM .GT. 0)THEN
  833. JJ1=IDELEM(1)
  834. DO JJJ=1,NBELEM
  835. JJ1=JJ1 + 1
  836. MELEME.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  837. DO KKK=1,NBNN
  838. MELEME.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  839. ENDDO
  840. ENDDO
  841. IDELEM(1) = IDELEM(1) + NBELEM
  842. ENDIF
  843. ENDDO
  844. SEGDES,MELEME
  845.  
  846. ELSE
  847. C Cas du MELEME resultat COMPLEXE
  848. NBNN = 0
  849. NBELEM = 0
  850. NBSOUS = NBTYP
  851. NBREF = 0
  852. SEGINI,MELEME
  853.  
  854. DO III=1,NBTYP
  855. NBELEM=LISTYP(III,2)
  856. NBNN =LISTYP(III,3)
  857. NBSOUS=0
  858. NBREF =0
  859. SEGINI,IPT3
  860. IPT3.ITYPEL=LISTYP(III,1)
  861. MELEME.LISOUS(III)=IPT3
  862. ENDDO
  863.  
  864. DO III=1,NBFUS
  865. IPT1=SID.IPOINT(III)
  866. NBSOUS=IPT1.LISOUS(/1)
  867. IF (NBSOUS .GT. 0) THEN
  868. C Cas des MELEME COMPLEXES
  869. DO JJJ=1,NBSOUS
  870. IDMAIL=IDMAIL+1
  871. IPT2=IPT1.LISOUS(JJJ)
  872. NBELEM = IPT2.NUM(/2)
  873. IF (NBELEM .GT. 0)THEN
  874. NBTYP = INDEXM(IDMAIL)
  875. NBNN = IPT2.NUM(/1)
  876. IPT3 = MELEME.LISOUS(NBTYP)
  877. JJ1 = IDELEM(NBTYP)
  878. DO LLL=1,NBELEM
  879. JJ1=JJ1 + 1
  880. IPT3.ICOLOR(JJ1)=IPT2.ICOLOR(LLL)
  881. DO KKK=1,NBNN
  882. IPT3.NUM(KKK,JJ1)=IPT2.NUM(KKK,LLL)
  883. ENDDO
  884. ENDDO
  885. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  886. ENDIF
  887. ENDDO
  888.  
  889. ELSE
  890. C Cas des MELEME SIMPLES
  891. IDMAIL=IDMAIL+1
  892. NBELEM = IPT1.NUM(/2)
  893. IF (NBELEM .GT. 0)THEN
  894. NBTYP = INDEXM(IDMAIL)
  895. NBNN = IPT1.NUM(/1)
  896. IPT3 = MELEME.LISOUS(NBTYP)
  897. JJ1 = IDELEM(NBTYP)
  898. DO JJJ=1,NBELEM
  899. JJ1=JJ1 + 1
  900. IPT3.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  901. DO KKK=1,NBNN
  902. IPT3.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  903. ENDDO
  904. ENDDO
  905. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  906. ENDIF
  907. ENDIF
  908. ENDDO
  909.  
  910. C Fermeture des MELEME du resultat
  911. IF (NBTY .GT. 1)THEN
  912. DO III=1,NBTY
  913. IPT3=MELEME.LISOUS(III)
  914. SEGDES,IPT3
  915. ENDDO
  916. ENDIF
  917. SEGDES,MELEME
  918.  
  919. ENDIF
  920. ID1=MELEME
  921.  
  922. C Fermeture de tous les MELEME des entrees
  923. DO III=1,NBFUS
  924. IPT1=SID.IPOINT(III)
  925. NBSOUS=IPT1.LISOUS(/1)
  926. IF (NBSOUS .GT. 0) THEN
  927. C Cas des MELEME COMPLEXES
  928. DO JJJ=1,NBSOUS
  929. IPT2=IPT1.LISOUS(JJJ)
  930. SEGDES,IPT2
  931. ENDDO
  932. ENDIF
  933. SEGDES,IPT1
  934. ENDDO
  935.  
  936. C Suppression des SEGMENTS de travail
  937. SEGSUP,LISTYP,IDELEM,INDEXM
  938.  
  939. RETURN
  940. END
  941.  
  942.  
  943.  
  944.  

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