Télécharger funobj.eso

Retour à la liste

Numérotation des lignes :

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

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