Télécharger funobj.eso

Retour à la liste

Numérotation des lignes :

funobj
  1. C FUNOBJ SOURCE FANDEUR 22/01/19 21:15:07 11256
  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. iforie = -99
  643. DO III=1,NBFUS
  644. MRIGID=SID.IPOINT(III)
  645. SEGACT,MRIGID
  646. NRIGEL=NRIGEL + IRIGEL(/2)
  647. CHA8 =MRIGID.MTYMAT
  648.  
  649. IF(III .EQ. 1) THEN
  650. CHA8a=CHA8
  651. CHA8b=CHA8
  652. iforie = mrigid.IFORIG
  653. ELSE
  654. IF (CHA8 .NE. CHA8a) THEN
  655. IF(CHA8 .EQ. 'RIGIDITE')THEN
  656. CHA8b='RIGIDITE'
  657. ELSE
  658. CHA8b='INDETERM'
  659. ENDIF
  660. ENDIF
  661. IF (iforie .NE. mrigid.IFORIG) THEN
  662. interr(1)=iforie
  663. interr(2)=mrigid.IFORIG
  664. interr(3)=IFOUR
  665. c-dbg write(ioimp,*) '1132 FUNOBJ',iii,mrigid
  666. call erreur(1132)
  667. iforie = IFOUR
  668. END IF
  669. ENDIF
  670. ENDDO
  671.  
  672. SEGINI,MRIGID
  673. ID1 = MRIGID
  674. MRIGID.ICHOLE = 0
  675. MRIGID.IMGEO1 = 0
  676. MRIGID.MTYMAT = CHA8b
  677. MRIGID.IFORIG = iforie
  678.  
  679. C FUSION des CHAPEAUX
  680. IC=0
  681. DO III=1,NBFUS
  682. RI1=SID.IPOINT(III)
  683. JA =RI1.IRIGEL(/2)
  684. JB =RI1.IRIGEL(/1)
  685. DO KKK=1,JA
  686. MELEME=RI1.IRIGEL(1,KKK)
  687. SEGACT,MELEME
  688. IF (NUM(/2) .NE. 0) THEN
  689. IC=IC+1
  690. COERIG(IC)=RI1.COERIG(KKK)
  691. DO LLL=1,JB
  692. IRIGEL(LLL,IC)=RI1.IRIGEL(LLL,KKK)
  693. ENDDO
  694. ENDIF
  695. ENDDO
  696. ENDDO
  697.  
  698. C Ajustement du SEGMENT le cas echeant
  699. IF (NRIGEL .NE. IC) THEN
  700. NRIGEL=IC
  701. SEGADJ,MRIGID
  702. ENDIF
  703.  
  704. SEGACT,MRIGID*NOMOD
  705. RETURN
  706.  
  707.  
  708. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  709. C FUSION DE RIGIDITE ESCLAVES : En une seule fois (Pas de RIGIDITE temporaires)
  710. C Seulement les CHAPEAUX sont fusionnes
  711. C
  712. C CB215821 : Impossible de faire COHABITER SMRIGID et SMMATRIK
  713. C - Les SEGMENTS portent les memes nom...
  714. C
  715. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  716. C 666 CONTINUE
  717. CC OUVERTURE de tous les MATRIK
  718. C NMATRI=0
  719. C DO III=1,NBFUS
  720. C MATRIK=SID.IPOINT(III)
  721. C SEGACT,MATRIK
  722. C NMATRI=NMATRI + IRIGEL(/2)
  723. C ENDDO
  724. C
  725. C NRIGE= 7
  726. C NKID = 9
  727. C NKMT = 7
  728. C SEGINI,MATRIK
  729. C ID1 = MATRIK
  730. C
  731. C IC = 1
  732. C DO III=1,NBFUS
  733. C IP1 = SID.IPOINT(III)
  734. C N1 = IP1.IRIGEL(/2)
  735. C
  736. CC Copie des IRIGEL dans le resultat
  737. C DO JJJ=1,N1
  738. C DO KKK=1,NRIGE
  739. C IRIGEL(KKK,IC + JJJ)=IP1.IRIGEL(KKK,JJJ)
  740. C ENDDO
  741. C
  742. CC On effectue une copie des segments IMATRI car ils pointent sur
  743. CC d'autres objets élémentaires (les valeurs des matrices élémentaires)
  744. C IMATR1=IP1.IRIGEL(4,JJJ)
  745. C SEGINI,IMATR2=IMATR1
  746. C SEGDES,IMATR2
  747. C IRIGEL(4,IC + JJJ)=IMATR2
  748. C ENDDO
  749. C IC = IC + N1
  750. C SEGDES,IP1
  751. C ENDDO
  752. C
  753. C SEGDES,MATRIK
  754. C RETURN
  755.  
  756.  
  757.  
  758. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  759. C FUSION DE MELEME ESCLAVES :
  760. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  761. 777 CONTINUE
  762. NBTY = 100
  763. NBMAIL= 100
  764. IDMAIL= 0
  765. SEGINI,INDEXM
  766.  
  767. SEGINI,LISTYP
  768. C Ouverture de tous les MELEME
  769. NMATRI= 0
  770. NBTYP = 0
  771. DO 7771 III=1,NBFUS
  772. IPT1=SID.IPOINT(III)
  773. NBSOUS=IPT1.LISOUS(/1)
  774. IF (NBSOUS .GT. 0) THEN
  775. C Cas des MELEME COMPLEXES
  776. DO 7772 JJJ=1,NBSOUS
  777. IDMAIL=IDMAIL + 1
  778.  
  779. IF(IDMAIL .GT. NBMAIL)THEN
  780. NBMAIL = NBMAIL * 2
  781. SEGADJ,INDEXM
  782. ENDIF
  783.  
  784. IPT2=IPT1.LISOUS(JJJ)
  785. NBELEM = IPT2.NUM(/2)
  786.  
  787. IF (NBELEM .GT. 0) THEN
  788. ITYPE = IPT2.ITYPEL
  789. NBNN = IPT2.NUM(/1)
  790. C Recherche d'un TYPE DEJA RENCONTRE
  791. IF (NBTYP .EQ. 0) THEN
  792. NBTYP = 1
  793. INDEXM(1) = 1
  794. LISTYP(1,1)=ITYPE
  795. LISTYP(1,2)=LISTYP(1,2) + NBELEM
  796. LISTYP(1,3)=NBNN
  797.  
  798. ELSE
  799. DO KKK=1,NBTYP
  800. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  801. & NBNN .EQ. LISTYP(KKK,3)) THEN
  802. INDEXM(IDMAIL)=KKK
  803. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  804. GOTO 7772
  805. ENDIF
  806. ENDDO
  807. NBTYP = NBTYP + 1
  808. IF(NBTYP .GT. NBTY)THEN
  809. NBTY = NBTY * 2
  810. SEGADJ,LISTYP
  811. ENDIF
  812. INDEXM(IDMAIL) = NBTYP
  813. LISTYP(NBTYP,1)= ITYPE
  814. LISTYP(NBTYP,2)= LISTYP(NBTYP,2) + NBELEM
  815. LISTYP(NBTYP,3)= NBNN
  816. ENDIF
  817. ENDIF
  818. 7772 CONTINUE
  819.  
  820. ELSE
  821. C Cas des MELEME SIMPLES
  822. IDMAIL=IDMAIL + 1
  823. IF(IDMAIL .GT. NBMAIL)THEN
  824. NBMAIL = NBMAIL * 2
  825. SEGADJ,INDEXM
  826. ENDIF
  827.  
  828. NBELEM = IPT1.NUM(/2)
  829. IF (NBELEM .GT. 0) THEN
  830. ITYPE = IPT1.ITYPEL
  831. NBNN = IPT1.NUM(/1)
  832. C Recherche d'un TYPE DEJA RENCONTRE
  833. IF (NBTYP .EQ. 0) THEN
  834. NBTYP = 1
  835. INDEXM(1) = 1
  836. LISTYP(1,1)= ITYPE
  837. LISTYP(1,2)= LISTYP(1,2) + NBELEM
  838. LISTYP(1,3)= NBNN
  839.  
  840. ELSE
  841. DO KKK=1,NBTYP
  842. IF(ITYPE .EQ. LISTYP(KKK,1) .AND.
  843. & NBNN .EQ. LISTYP(KKK,3)) THEN
  844. INDEXM(IDMAIL)=KKK
  845. LISTYP(KKK,2) =LISTYP(KKK,2) + NBELEM
  846. GOTO 7771
  847. ENDIF
  848. ENDDO
  849. NBTYP = NBTYP + 1
  850. IF(NBTYP .GT. NBTY)THEN
  851. NBTY = NBTY * 2
  852. SEGADJ,LISTYP
  853. ENDIF
  854. INDEXM(IDMAIL) =NBTYP
  855. LISTYP(NBTYP,1)=ITYPE
  856. LISTYP(NBTYP,2)=LISTYP(NBTYP,2) + NBELEM
  857. LISTYP(NBTYP,3)=NBNN
  858. ENDIF
  859. ENDIF
  860. ENDIF
  861. 7771 CONTINUE
  862.  
  863.  
  864. C CREATION DU RESULTAT ET REMPLISSAGE
  865. IDMAIL = 0
  866. NBTY = NBTYP
  867. SEGINI,IDELEM
  868. IF(NBTYP .EQ. 0)THEN
  869. C Cas du MELEME resultat SIMPLE VIDE
  870. ITEL = ILCOUR
  871. NBELEM = 0
  872. NBNN = 0
  873. NBSOUS = 0
  874. NBREF = 0
  875. SEGINI,MELEME
  876. MELEME.ITYPEL=ITEL
  877.  
  878. ELSEIF(NBTYP .EQ. 1)THEN
  879. C Cas du MELEME resultat SIMPLE NON VIDE
  880. NBELEM = LISTYP(1,2)
  881. NBNN = LISTYP(1,3)
  882. NBSOUS = 0
  883. NBREF = 0
  884. SEGINI,MELEME
  885. MELEME.ITYPEL=LISTYP(1,1)
  886. DO III=1,NBFUS
  887. IPT1=SID.IPOINT(III)
  888. NBELEM=IPT1.NUM(/2)
  889. IF (NBELEM .GT. 0)THEN
  890. JJ1=IDELEM(1)
  891. DO JJJ=1,NBELEM
  892. JJ1=JJ1 + 1
  893. MELEME.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  894. DO KKK=1,NBNN
  895. MELEME.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  896. ENDDO
  897. ENDDO
  898. IDELEM(1) = IDELEM(1) + NBELEM
  899. ENDIF
  900. ENDDO
  901.  
  902. ELSE
  903. C Cas du MELEME resultat COMPLEXE
  904. NBNN = 0
  905. NBELEM = 0
  906. NBSOUS = NBTYP
  907. NBREF = 0
  908. SEGINI,MELEME
  909.  
  910. DO III=1,NBTYP
  911. NBELEM=LISTYP(III,2)
  912. NBNN =LISTYP(III,3)
  913. NBSOUS=0
  914. NBREF =0
  915. SEGINI,IPT3
  916. IPT3.ITYPEL=LISTYP(III,1)
  917. MELEME.LISOUS(III)=IPT3
  918. ENDDO
  919.  
  920. DO III=1,NBFUS
  921. IPT1=SID.IPOINT(III)
  922. NBSOUS=IPT1.LISOUS(/1)
  923. IF (NBSOUS .GT. 0) THEN
  924. C Cas des MELEME COMPLEXES
  925. DO JJJ=1,NBSOUS
  926. IDMAIL=IDMAIL+1
  927. IPT2=IPT1.LISOUS(JJJ)
  928. NBELEM = IPT2.NUM(/2)
  929. IF (NBELEM .GT. 0)THEN
  930. NBTYP = INDEXM(IDMAIL)
  931. NBNN = IPT2.NUM(/1)
  932. IPT3 = MELEME.LISOUS(NBTYP)
  933. JJ1 = IDELEM(NBTYP)
  934. DO LLL=1,NBELEM
  935. JJ1=JJ1 + 1
  936. IPT3.ICOLOR(JJ1)=IPT2.ICOLOR(LLL)
  937. DO KKK=1,NBNN
  938. IPT3.NUM(KKK,JJ1)=IPT2.NUM(KKK,LLL)
  939. ENDDO
  940. ENDDO
  941. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  942. ENDIF
  943. ENDDO
  944.  
  945. ELSE
  946. C Cas des MELEME SIMPLES
  947. IDMAIL=IDMAIL+1
  948. NBELEM = IPT1.NUM(/2)
  949. IF (NBELEM .GT. 0)THEN
  950. NBTYP = INDEXM(IDMAIL)
  951. NBNN = IPT1.NUM(/1)
  952. IPT3 = MELEME.LISOUS(NBTYP)
  953. JJ1 = IDELEM(NBTYP)
  954. DO JJJ=1,NBELEM
  955. JJ1=JJ1 + 1
  956. IPT3.ICOLOR(JJ1)=IPT1.ICOLOR(JJJ)
  957. DO KKK=1,NBNN
  958. IPT3.NUM(KKK,JJ1)=IPT1.NUM(KKK,JJJ)
  959. ENDDO
  960. ENDDO
  961. IDELEM(NBTYP) = IDELEM(NBTYP) + NBELEM
  962. ENDIF
  963. ENDIF
  964. ENDDO
  965. ENDIF
  966. ID1=MELEME
  967.  
  968. C Suppression des SEGMENTS de travail
  969. SEGSUP,LISTYP,IDELEM,INDEXM
  970. RETURN
  971.  
  972. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  973. C FUSION D'EVOLUTIONS ESCLAVES :
  974. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  975. 999 CONTINUE
  976.  
  977. C Decompte pour dimensionnement
  978. N =0
  979. CHA8=' '
  980. DO 9991 III=1,NBFUS
  981. MEVOL1=SID.IPOINT(III)
  982. IF(III .EQ. 1) THEN
  983. CHA8a=MEVOL1.ITYEVO
  984. CHA8 =CHA8a
  985.  
  986. ELSE
  987. CHA8b=MEVOL1.ITYEVO
  988. IF(CHA8b .NE. CHA8a)THEN
  989. CHA8=' '
  990. ENDIF
  991. ENDIF
  992.  
  993. N=N + MEVOL1.IEVOLL(/1)
  994. 9991 CONTINUE
  995. SEGINI,MEVOLL
  996.  
  997. C Recuperation du titre dans CCOPTIO
  998. MEVOLL.IEVTEX=TITREE
  999. MEVOLL.ITYEVO=CHA8
  1000.  
  1001. C Remplissage
  1002. N=0
  1003. DO 9992 III=1,NBFUS
  1004. MEVOL1=SID.IPOINT(III)
  1005. N1 =MEVOL1.IEVOLL(/1)
  1006. DO 9993 IEV=1,N1
  1007. N = N + 1
  1008. MEVOLL.IEVOLL(N)=MEVOL1.IEVOLL(IEV)
  1009. 9993 CONTINUE
  1010. 9992 CONTINUE
  1011.  
  1012. ID1=MEVOLL
  1013. RETURN
  1014.  
  1015. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1016. C FUSION DE CHARGEMENTS ESCLAVES :
  1017. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1018. 1200 CONTINUE
  1019.  
  1020. C Decompte pour dimensionnement
  1021. N = 0
  1022. DO 1201 III=1,NBFUS
  1023. MCHAR1 = SID.IPOINT(III)
  1024. N = N + MCHAR1.KCHARG(/1)
  1025. 1201 CONTINUE
  1026. SEGINI,MCHARG
  1027.  
  1028. C Remplissage
  1029. N=0
  1030. DO 1202 III=1,NBFUS
  1031. MCHAR1 = SID.IPOINT(III)
  1032. N1 = MCHAR1.KCHARG(/1)
  1033.  
  1034. DO 1203 JJJ=1,N1
  1035. N = N + 1
  1036. MCHARG.KCHARG(N)=MCHAR1.KCHARG(JJJ)
  1037. MCHARG.CHANAT(N)=MCHAR1.CHANAT(JJJ)
  1038. MCHARG.CHANOM(N)=MCHAR1.CHANOM(JJJ)
  1039. MCHARG.CHAMOB(N)=MCHAR1.CHAMOB(JJJ)
  1040. MCHARG.CHALIE(N)=MCHAR1.CHALIE(JJJ)
  1041. MCHARG.KCHARG(N)=MCHAR1.KCHARG(JJJ)
  1042. 1203 CONTINUE
  1043. 1202 CONTINUE
  1044.  
  1045. ID1=MCHARG
  1046.  
  1047. END
  1048.  
  1049.  
  1050.  

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