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

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