C PRFUSE    SOURCE    GOUNAND   25/05/06    21:15:04     12261          
      SUBROUTINE PRFUSE

*=============================================================
*
* Interface entre la directive "ET" et le sous-programme "FUSE"
*
*=============================================================
*
* Modifications :
*
*   PM 09/10/2007 : fusion de deux LISTCHPOs
*   PM 09/10/2007 : respect de l'ordre des opérandes
*   CB 23/01/2017 : ET entre un LISTMOT et un MOT
*
*=============================================================
*
* Remarques :
*
*=============================================================

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
-INC CCNOYAU
-INC CCASSIS
-INC SMELEME
-INC SMLMOTS
-INC CCGEOME
-INC SMLREEL
-INC SMLENTI
-INC SMANNOT
-INC SMLOBJE

      EXTERNAL        LONG

      LOGICAL         IR1,IR2,IR3,LTELQ
      CHARACTER*(8)   CTYP,CTYP1,CTYP2,ICHAT,TYPRET,TYPRE1
      CHARACTER*(LOCHAI) LEMOT,LEMOT1,LEMOT2
      REAL*8 XVAL
      CHARACTER*4     LISTMO(1)
      DATA            LISTMO / 'TELQ' /

      IP0 = 0
      IP1 = 0
      IP2 = 0
*     Recherche préalable du mot-clef 'TELQUEL' éventuel
      CALL LIRMOT(LISTMO,1,IRE2,0)
      IF (IERR.NE.0) RETURN
      LTELQ = (IRE2.EQ.1)

*     Lecture du premier objet
*     ------------------------
      CALL MESLIR(-225)
      CALL QUETYP(CTYP,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
*       Cet opérateur a encore besoin d'un opérande.
         CALL ERREUR (533)
         RETURN
      ENDIF

      IF(CTYP.EQ.'LOGIQUE ') THEN
         CALL MESLIR(-225)
         CALL LIRLOG(IR1,1,IRETOU)
         CALL MESLIR(-223)
         CALL LIRLOG(IR2,1,IRETOU)
         IF(IERR.NE.0) RETURN
         GOTO 213

      ELSE IF(CTYP.EQ.'MOT     ') THEN
         CALL LIRCHA(LEMOT1,1,IRET1)
         IF (IERR.NE.0) RETURN

         CALL QUETYP(CTYP2,0,IRETOU)
         IF(IRETOU.EQ.0) THEN
*          Cet opérateur a encore besoin d'un opérande.
            CALL ERREUR (533)
            RETURN
         ENDIF
         IF(CTYP2 .EQ. 'LISTMOTS') THEN
           CALL LIROBJ('LISTMOTS',IP2,1,IRETOU)
           IF(IERR.NE.0) RETURN
           GOTO 222

         ELSE
           CALL LIRCHA(LEMOT2,1,IRET2)
           IF( IERR.NE.0) RETURN
           IF (LTELQ) THEN
*            Concaténation avec respect des espaces avant et après
           ELSE
*            Suppressions des espaces en fin de mot
             IRET1=LONG(LEMOT1)
             IRET2=LONG(LEMOT2)
           ENDIF
           GOTO 225
         ENDIF

      ELSE IF(CTYP.EQ.'FLOTTANT') THEN
         CALL LIRREE(XVAL1,1,IRETOU)
         IF(IERR.NE.0) RETURN
         CTYP='LISTREEL'
         II=16
         GOTO 24

      ELSE IF(CTYP.EQ.'ENTIER  ') THEN
         CALL LIRENT(IP1,1,IRETOU)
         IF(IERR.NE.0) RETURN
*       suivant que l'objet suivant est un ENTIER/LISTENTI ou pas,
*       on considère cette entrée comme un FLOTTANT
         CALL QUETYP(CTYP,1,IRETOU)
         IF(IERR.NE.0) RETURN
         IF(CTYP.NE.'ENTIER  '.AND.CTYP.NE.'LISTENTI') THEN
            XVAL1=FLOAT(IP1)
            IP1=0
            CTYP='LISTREEL'
            II=16
         ELSE
            CALL CRELEC(IP1)
            CTYP='LISTENTI'
            II=17
         ENDIF
         GOTO 24

      ELSE
         MOTERR(1:8)=CTYP
         CALL MESLIR(-222)
         CALL LIROBJ(CTYP,IP1,1,IRETOU)
         IF(CTYP.EQ.'POINT   ') THEN
            II = 1
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'MAILLAGE') THEN
            II = 2
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'CHPOINT ') THEN
            CALL ACTOBJ(CTYP,IP1,1)
            II = 3
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'MCHAML  ') THEN
            CALL ACTOBJ(CTYP,IP1,1)
            II = 20
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'RIGIDITE') THEN
            II = 4
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'EVOLUTIO') THEN
            II = 18
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'CHARGEME') THEN
            II = 15
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'STRUCTUR') THEN
            II = 5
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'SOLUTION') THEN
            II = 6
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'ATTACHE ') THEN
            II = 7
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'ELEMSTRU') THEN
            II = 10
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'BLOQSTRU') THEN
            II = 11
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'BASEMODA') THEN
            II = 12
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'DEFORME ') THEN
            II = 13
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'VECTEUR ') THEN
            II = 14
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'LISTREEL') THEN
            II = 16
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'LISTENTI') THEN
            II = 17
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'MMODEL  ') THEN
            CALL ACTOBJ(CTYP,IP1,1)
            II = 19
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'LISTMOTS') THEN
            II = 21
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'NUAGE   ') THEN
            II = 22
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'MATRIK') THEN
            II = 23
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'LISTCHPO') THEN
            II = 24
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'ANNOTATI') THEN
            II = 25
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'LISTOBJE') THEN
            II = 26
            GOTO 24
         ENDIF

         IF(CTYP.EQ.'TABLE') THEN
            MTABLE = IP1
            CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
     >           'MOT',ID3,RR1,LEMOT,IR1,ID2)
            IF (LEMOT.EQ.'LIAISONS_STATIQUES'.OR.
     >           LEMOT.EQ.'BASE_MODALE') GOTO 2000
            GOTO 1000
         ENDIF

         GOTO 999

      ENDIF


*     ================
*     Première syntaxe
*     ================

*     Lecture deuxième objet, lui aussi avec pointeur
*     -----------------------------------------------
 24   CONTINUE

      ICODE=1
*     pour les fusions mixtes, on est encore indécis sur le type du
*     deuxième objet.
      IF(CTYP.EQ.'POINT   '.OR.CTYP.EQ.'MAILLAGE'.OR.
     &   CTYP.EQ.'LISTENTI'.OR.CTYP.EQ.'LISTREEL'.OR.
     &   CTYP.EQ.'LISTMOTS'.OR.
     &   CTYP.EQ.'CHPOINT '.OR.CTYP.EQ.'LISTCHPO'.OR.
     &   CTYP.EQ.'LISTOBJE') ICODE=0

*     on lit a priori un objet de même type que le premier
      CALL QUETYP(CTYP2 , ICODE , IRETOU )
*     cas où on a un LISTOBJE uniquement, on fait la 2eme syntaxe
      IF (CTYP.EQ.'LISTOBJE'.AND.IRETOU.EQ.0) GOTO 1010
      IF (CTYP.EQ.'LISTOBJE'.OR.CTYP2.EQ.'LISTOBJE') THEN
         CALL LIROBJ(CTYP2,IP2,1,IRETOU)
         IF(IERR.NE.0) RETURN
         II = 26
         IF (CTYP.NE.'LISTOBJE') THEN
            IPX = IP2
            IP2 = IP1
            IP1 = IPX
            CTYP1 = CTYP2
            CTYP2 = CTYP
            CTYP  = CTYP1
         ENDIF
      ELSE
         MOTERR(1:8)=CTYP
         CALL MESLIR(-221)
         CALL LIROBJ(CTYP,IP2,ICODE,IRETOU)
         IF(IRETOU .EQ. 1) CALL ACTOBJ(CTYP,IP2,1)
         IF(IERR.NE.0) RETURN
      ENDIF

      GOTO ( 1,2,3,4,205,206,207,999,999,210,211,212,214,215,216,
     $     217,218,219,220,221,222,223,224,226,227,228),II

*--   Création maillage
 1    CONTINUE
      CALL CRELEM(IP1)
 2    CONTINUE
      IF (CTYP.NE.'POINT   '.AND.CTYP.NE.'MAILLAGE') GOTO 999
      IF(IRETOU.EQ.1.AND.CTYP.EQ.'POINT   ') THEN
*       on a deux points
         CALL CRELEM(IP2)
      ENDIF
      IF(IRETOU.EQ.0) THEN
*       on a lu des objets de types différents mais compatibles
         CALL MESLIR(-220)
         IF(CTYP.EQ.'POINT   ') CALL LIROBJ('MAILLAGE',IP2,1,IRETAU)
         IF(CTYP.EQ.'MAILLAGE') THEN
            CALL LIROBJ('POINT   ',IP2,1,IRETAU)
            IF(IRETAU.EQ.1) CALL CRELEM(IP2)
         ENDIF
         IF(IERR.NE.0) RETURN
      ENDIF
      CTYP='MAILLAGE'
      CALL FUSE(IP1,IP2,IRETOU,LTELQ)
      GOTO 100

*--   Création CHPOINT
    3 CONTINUE
      IF(IRETOU.EQ.1) THEN
*       La concaténation de deux champ-points donne un champ-point
         IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
         CALL FUCHPO(IP1,IP2,IRETOU)
         IF (IRETOU.EQ.0) RETURN
         IF (IRETOU.NE.IP1.AND.IRETOU.NE.IP2)
     &       CALL ACTOBJ('CHPOINT ',IRETOU,1)
         GOTO 100
      ELSE
*PM     autrement, on peut obtenir une liste de chpoints
         CALL CRLCHP(IP1)
         GOTO 226
      ENDIF

*--   Création RIGIDITE
    4 CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSRIG(IP1,IP2,IRETOU)
      GOTO 100
*--   Création STRUCTURE
 205  CONTINUE
      CALL FUSTRU(IP1,IP2,IRETOU)
      GOTO 100
*--   Création SOLUTION
 206  CONTINUE
      CALL FUSOLU(IP1,IP2,IRETOU)
      GOTO 100
*--   Création ATTACHE
 207  CONTINUE
      CALL FUSATT(IP1,IP2,IRETOU)
      GOTO 100
*--   Création ELEMSTRU
 210  CONTINUE
      CALL FUSELS(IP1,IP2,IRETOU)
      GOTO 100
*--   Création BLOQSTRU
 211  CONTINUE
      CALL FUSCLS(IP1,IP2,IRETOU)
      GOTO 100
*--   Création BASE MODALE
 212  CONTINUE
      CALL FUSBAS(IP1,IP2,IRETOU)
      GOTO 100
*--   Opération LOGIQUE
 213  CONTINUE
      IR3=IR1.AND.IR2
*  lecture optionnelle d'autres logiques
      do i=1,1000
       call lirlog(ir2,0,iretou)
       if(iretou.eq.0) goto 2130
       ir3=ir3.and.ir2
      enddo
 2130 continue
      CALL ECRLOG(IR3)
      RETURN
*--   Création DEFORMEE
 214  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSDEF(IP1,IP2,IRETOU)
      GOTO 100
*--   Création VECTEUR
 215  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSVEC (IP1,IP2,IRETOU)
      GOTO 100
*--   Création CHARGEMENT
 216  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSCHA(IP1,IP2,IRETOU)
      GOTO 100

*--   Création LISTREEL
 217  CONTINUE
      IF(IP1 .NE. 0)THEN
C       On a lu un LISTREEL en 1er argument
        IF(IRETOU.EQ.0) THEN
C         On n'a pas lu un LISTREEL en 2eme argument
          CALL QUETYP(CTYP,1,IRETOU)
          IF(IERR.NE.0) RETURN
          IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
C         On a lu des objets de types différents mais compatibles
          IF (CTYP.EQ.'ENTIER  ') THEN
             CALL LIRENT(IVAL2,1,IRETOU)
             XVAL2=FLOAT(IVAL2)
          ELSE
             CALL LIRREE(XVAL2,1,IRETOU)
          ENDIF
          IF(IERR.NE.0) RETURN

          MLREE2=IP1
          SEGACT,MLREE2
          JG1=MLREE2.PROG(/1)
          JG =JG1 + 1
          SEGINI,MLREE1
          MLREE1.PROG(JG)=XVAL2
          IF(JG1 .GT. 0)THEN
C           Recopie en FORTRAN
            CALL OPTABJ(1,1,3,1,
     &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(1),
     &                  JG1           ,JG1           ,JG1,
     &                  1,0,0.D0,IRETOU)
          ENDIF
        ELSE
C         On a lu un LISTREEL en 2eme argument
          CALL FUSPRO(IP1,IP2,IRETOU)
          MLREE1=IRETOU
        ENDIF
      ELSE
C       On n'a pas lu un LISTREEL en 1er argument
        IF(IRETOU.EQ.0) THEN
C         On n'a pas lu un LISTREEL en 2eme argument
          CALL QUETYP(CTYP,1,IRETOU)
          IF(IERR.NE.0) RETURN
          IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
C         On a lu des objets de types différents mais compatibles
          IF (CTYP.EQ.'ENTIER  ') THEN
             CALL LIRENT(IVAL2,1,IRETOU)
             XVAL2=FLOAT(IVAL2)
          ELSE
             CALL LIRREE(XVAL2,1,IRETOU)
          ENDIF
          IF(IERR.NE.0) RETURN
          JG=2
          SEGINI,MLREE1
          MLREE1.PROG(1)=XVAL1
          MLREE1.PROG(2)=XVAL2
        ELSE
C         On a lu un LISTREEL en 2eme argument
          MLREE2=IP2
          SEGACT,MLREE2
          JG1=MLREE2.PROG(/1)
          JG =JG1 + 1
          SEGINI,MLREE1
          MLREE1.PROG(1)=XVAL1
          IF(JG1 .GT. 0) THEN
C           Recopie en FORTRAN
            CALL OPTABJ(1,1,3,1,
     &                  MLREE2.PROG(1),MLREE2.PROG(1),MLREE1.PROG(2),
     &                  JG1           ,JG1           ,JG1,
     &                  1,0,0.D0,IRETOU)
          ENDIF
        ENDIF
      ENDIF
      CTYP='LISTREEL'
      SEGACT,MLREE1*NOMOD
      IRETOU=MLREE1
      GOTO 100

*--   Création LISTENTI
 218  CONTINUE
      IF(IRETOU.EQ.0) THEN
*       on n'a pas lu un LISTENTI
         CALL QUETYP(CTYP,1,IRETOU)
         IF(IERR.NE.0) RETURN
         IF(CTYP.NE.'ENTIER  ') GOTO 999
         CALL LIRENT(IP2,1,IRETOU)
         IF(IERR.NE.0) RETURN
         CALL CRELEC(IP2)
      ENDIF
      CTYP='LISTENTI'
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSLEC(IP1,IP2,IRETOU)
      GOTO 100

*--   Création EVOLUTION
 219  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUEVOL(IP1,IP2,IRETOU)
      GOTO 100
*--   Création MODELE
 220  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSMOD(IP1,IP2,IRETOU)
      GOTO 100
*--   Création MCHAML
 221  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL ETMCHL(IP1,IP2,IRETOU)
      GOTO 100

*--   Création LISTMOTS
 222  CONTINUE
      IF    (IP1 .GT. 0 .AND. IP2 .GT. 0) THEN
C       LISTMOTS 'ET' LISTMOTS
        CALL FUSMOT(IP1,IP2,IRETOU)

      ELSEIF(IP1 .GT. 0 .AND. IP2 .EQ. 0) THEN
C       LISTMOTS 'ET' MOT
        CALL QUETYP(CTYP2,0,IRETOU)
        IF(CTYP2 .EQ. 'MOT') THEN
          CALL LIRCHA(LEMOT1,1,IRET1)
          IF (IERR.NE.0) RETURN
          MLMOT1=IP1
          SEGACT,MLMOT1
          JGN=MLMOT1.MOTS(/1)
          JGM=MLMOT1.MOTS(/2)+1
          SEGINI,MLMOT2
          IRETOU=MLMOT2
          DO III=1,JGM-1
            MLMOT2.MOTS(III)=MLMOT1.MOTS(III)
          ENDDO
          MLMOT2.MOTS(JGM)=LEMOT1
          SEGDES,MLMOT1,MLMOT2
        ELSE
          GOTO 999
        ENDIF

      ELSEIF(IP1 .EQ. 0 .AND. IP2 .GT. 0) THEN
C       MOT 'ET' LISTMOTS
        IF(CTYP .EQ. 'MOT') THEN
          CTYP = CTYP2
          MLMOT1=IP2
          SEGACT,MLMOT1
          JGN=MLMOT1.MOTS(/1)
          JGM=MLMOT1.MOTS(/2)+1
          SEGINI,MLMOT2
          IRETOU=MLMOT2
          MLMOT2.MOTS(1)=LEMOT1(1:JGN)
          DO III=2,JGM
            MLMOT2.MOTS(III)=MLMOT1.MOTS(III-1)
          ENDDO
          SEGDES,MLMOT1,MLMOT2
        ELSE
          GOTO 999
        ENDIF
      ENDIF
      GOTO 100
*--   Création NUAGE
 223  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSNUA(IP1,IP2,IRETOU)
      GOTO 100
*--   Création MATRIK
 224  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSMTK(IP1,IP2,IRETOU)
      GOTO 100
*--   Création LISTCHPO
 226  CONTINUE
      IF (CTYP.NE.'CHPOINT '.AND.CTYP.NE.'LISTCHPO') GOTO 999
      IF(IRETOU.EQ.0) THEN
*       on a lu des objets de types différents mais compatibles
*       (le cas de 2 champ-points est traité ailleurs)
         CALL MESLIR(-221)
         IF(CTYP.EQ.'CHPOINT ') THEN
            CALL LIROBJ('LISTCHPO',IP2,1,IRETAU)
            CALL ACTOBJ('LISTCHPO',IP2,1)
         ELSE
            CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
            CALL ACTOBJ('CHPOINT ',IP2,1)
            CALL CRLCHP(IP2)
         ENDIF
         IF(IERR.NE.0) RETURN
      ENDIF
      CTYP='LISTCHPO'
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      CALL FUSSUI(IP1,IP2,IRETOU)
      GOTO 100
*--   Création ANNOTATI
 227  CONTINUE
      IF(IP1.EQ.0 .OR. IP2.EQ.0) GOTO 999
      MANNO1=IP1
      MANNO2=IP2
      SEGACT,MANNO1,MANNO2
      NBANN1=MANNO1.ICLAS(/1)
      NBANN2=MANNO2.ICLAS(/1)
      NBANNO=NBANN1+NBANN2
      SEGINI,MANNO3
      DO K1=1,NBANN1
          MANNO3.ICLAS(K1) = MANNO1.ICLAS(K1)
          MANNO3.ISEGT(K1) = MANNO1.ISEGT(K1)
      ENDDO
      DO K2=1,NBANN2
          MANNO3.ICLAS(NBANN1+K2) = MANNO2.ICLAS(K2)
          MANNO3.ISEGT(NBANN1+K2) = MANNO2.ISEGT(K2)
      ENDDO
      IRETOU=MANNO3
      GOTO 100
*--   Creation LISTOBJE
 228  CONTINUE
C     On a forcément un LISTOBJE en premier argument
      IF (CTYP.NE.CTYP2) THEN
C     LISTOBJE ET "un autre objet"
         MLOBJ1 = IP1
         SEGACT,MLOBJ1
         CTYP1 = MLOBJ1.TYPOBJ
         NBOB1 = MLOBJ1.LISOBJ(/1)
         IF (CTYP1.NE.CTYP2.AND.NBOB1.NE.0) THEN
            CTYP = CTYP2
            GOTO 999
         ENDIF
         NOBJ = 1
         SEGINI,MLOBJE
         TYPOBJ    = CTYP2
         LISOBJ(1) = IP2
         IP2 = MLOBJE
      ENDIF
      CALL FUSLOB(IP1,IP2,IRETOU)
      IF (IERR.NE.0) RETURN
      GOTO 100

*     Sortie sans problème, écriture résultat
 100  CONTINUE
      CALL ACTOBJ(CTYP,IRETOU,1)
      CALL ECROBJ(CTYP,IRETOU)
      RETURN

*     Fusion de chaines, limitation à 512 caractères
 225  CONTINUE
      IRET=IRET1+IRET2
      IF(IRET.GT.512) THEN
         CALL ERREUR(1110)
         RETURN
      ENDIF
      LEMOT(1:IRET1) = LEMOT1(1:IRET1)
      LEMOT(IRET1+1:IRET) = LEMOT2(1:IRET2)
      CALL ECRCHA(LEMOT(1:IRET))
      RETURN


*     ================
*     Deuxième syntaxe
*     ================
*     Fusion de tous les indices d'une table

 1000 CONTINUE
 1010 CONTINUE
*      WRITE(IOIMP,*) 'Utilisez ETG please'
*      CALL ERREUR(5)
* Plus sympa
      CALL REFUS
      CALL ETG
      RETURN

*     =================
*     Troisième syntaxe
*     =================
*     FUSION TABLE DE MODES

 2000 CONTINUE

      CALL CRTABL(IPTAB2)
      IPOUT = IPTAB2
      IL = 0
      IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
     &        'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,IP1)
      ELSE
         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
     &        'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,IP1)
         CALL CRTABL(IPTAB3)
         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MODES',.TRUE.,IP0,
     &        'TABLE',0,0.0D0,' ',.TRUE.,IPTAB3)
         IPTAB2 = IPTAB3
         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,IP0,
     &        'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,IP1)
         CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
     &        'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP1)
cbp : plutot qu'ecrire le mot MAILLAGE(???), on fusionne les 2 maillages
         CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
     >        'TABLE',ID3,RR1,' ',.TRUE.,IP1)
         IF (IERR.NE.0) RETURN
         MTABLE = IP1
         CALL ACCTAB(IP1,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
     >        'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT1)
         IF (IERR.NE.0) RETURN
      ENDIF

c  ---copie de la IKO ieme table (IKO=1,2)
      IKO = 0
 2100 IKO = IKO + 1
      SEGACT MTABLE

c  ---boucle sur les modes ou les solutions statiques
      IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
         IMA = MLOTAB - 1
      ELSE
         IMA = MLOTAB - 2
      ENDIF
      IM = 0
 2160 IM = IM + 1
      CTYP=' '
      CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
c      >     'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
     >     CTYP,ID3,RR1,' ',.TRUE.,ITMOD)
      IF(CTYP.NE.'TABLE') GOTO 2161
      IF (ITMOD.GT.0)  THEN
         IL = IL + 1
         CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
     &        'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
      ENDIF
 2161 CONTINUE
      IF (IM.LT.IMA) GOTO 2160
c  ---fin de boucle sur les modes ou les solutions statiques

      SEGDES MTABLE
      IF (IKO.EQ.1) THEN
         IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
            CALL LIRTAB('LIAISONS_STATIQUES',IP1,0,IRETOU)
            IF (IRETOU.EQ.0) GOTO 2300
            MTABLE = IP1
         ELSE
            CALL LIRTAB('BASE_MODALE',IP1,0,IRETOU)
            IF (IRETOU.EQ.0) GOTO 2300
            CALL ACCTAB(IP1,'MOT',0,0.D0,'MODES',.TRUE.,0,
     >           'TABLE',ID3,RR1,' ',.TRUE.,MTABLE)
c           fusion des 2 maillages
            CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MAILLAGE',.TRUE.,0,
     >           'MAILLAGE',ID3,RR1,' ',.TRUE.,IPT2)
            CALL FUSE(IPT1,IPT2,IPT3,.FALSE.)
*  A qoi sert cet appel a uniq?
**            iordre=0
**            CALL UNIQMA(IPT3,NBDIF,iordre)
            CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,IP0,
     &        'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT3)
         ENDIF
         GOTO 2100
      ENDIF
c  ---fin de boucle sur les tables IKO=1,2

 2300 CALL ECROBJ('TABLE   ',ipout)
      RETURN


*     =========
*     ERREUR 39
*     =========
 999  CONTINUE
*     On ne veut pas d'objet de type %m1:8
      MOTERR(1:8)=CTYP
      CALL ERREUR(39)
      END