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

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