Télécharger la plaquette Cast3M


fr en

Télécharger funobj.eso

Retour à la liste

Numérotation des lignes : 

funobj

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

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