C PRFUSE    SOURCE    GOUNAND   14/01/31    21:15:11     7928           
      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
*
*=============================================================
*
* Remarques :
*
*=============================================================

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

-INC CCOPTIO
-INC SMTABLE
-INC CCNOYAU
-INC CCASSIS
-INC SMELEME
-INC CCGEOME

      EXTERNAL       LONG

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

*     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 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

      ELSE IF(CTYP.EQ.'FLOTTANT') THEN
         CALL LIRFLO(XVAL,1,IRETOU)
         IF(IERR.NE.0) RETURN
         CALL CREPRO(XVAL,IP1)
         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
            XVAL=FLOAT(IP1)
            CALL CREPRO(XVAL,IP1)
            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
            II = 3
            GOTO 24
         ENDIF
         IF(CTYP.EQ.'MCHAML  ') THEN
            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
            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.'TABLE') THEN
            II = 24
            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') ICODE=0
      IF(CTYP.EQ.'LISTENTI'.OR.CTYP.EQ.'LISTREEL') ICODE=0
      IF(CTYP.EQ.'CHPOINT '.OR.CTYP.EQ.'LISTCHPO') ICODE=0
*     on lit a priori un objet de même type que le premier
      MOTERR(1:8)=CTYP
      CALL MESLIR(-221)
      CALL LIROBJ(CTYP,IP2,ICODE,IRETOU)
      IF(IERR.NE.0) RETURN

      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),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
         CALL FUCHPO(IP1,IP2,IRETOU)
         GOTO 100
      ELSE
*PM     autrement, on peut obtenir une liste de chpoints
         CALL CRLCHP(IP1)
         GOTO 226
      ENDIF

*--   Création RIGIDITE
    4 CONTINUE
      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
      CALL ECRLOG(IR3)
      RETURN
*--   Création DEFORMEE
 214  CONTINUE
      CALL FUSDEF(IP1,IP2,IRETOU)
      GOTO 100
*--   Création VECTEUR
 215  CONTINUE
      CALL FUSVEC (IP1,IP2,IRETOU)
      GOTO 100
*--   Création CHARGEMENT
 216  CONTINUE
      CALL FUSCHA(IP1,IP2,IRETOU)
      GOTO 100
*--   Création LISTREEL
 217  CONTINUE
      IF(IRETOU.EQ.0) THEN
*       on n'a pas lu un LISTREEL
         CALL QUETYP(CTYP,1,IRETOU)
         IF(IERR.NE.0) RETURN
         IF((CTYP.NE.'ENTIER  ').AND.(CTYP.NE.'FLOTTANT')) GOTO 999
*       on a lu des objets de types différents mais compatibles
         IF (CTYP.EQ.'ENTIER  ') THEN
            CALL LIRENT(IVAL,1,IRETOU)
            XVAL=FLOAT(IVAL)
         ELSE
            CALL LIRFLO(XVAL,1,IRETOU)
         ENDIF
         IF(IERR.NE.0) RETURN
         CALL CREPRO(XVAL,IP2)
      ENDIF
      CTYP='LISTREEL'
      CALL FUSPRO(IP1,IP2,IRETOU)
      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'
      CALL FUSLEC(IP1,IP2,IRETOU)
      GOTO 100

*--   Création EVOLUTION
 219  CONTINUE
      CALL FUEVOL(IP1,IP2,IRETOU)
      GOTO 100
*--   Création MODELE
 220  CONTINUE
      CALL FUSMOD(IP1,IP2,IRETOU)
      GOTO 100
*--   Création MCHAML
 221  CONTINUE
      CALL FUSCHL(IP1,IP2,IRETOU)
      GOTO 100
*--   Création LISTMOTS
 222  CONTINUE
      CALL FUSMOT(IP1,IP2,IRETOU)
      GOTO 100
*--   Création NUAGE
 223  CONTINUE
      CALL FUSNUA(IP1,IP2,IRETOU)
      GOTO 100
*--   Création MATRIK
 224  CONTINUE
      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)
         ELSE
            CALL LIROBJ('CHPOINT ',IP2,1,IRETAU)
            CALL CRLCHP(IP2)
         ENDIF
         IF(IERR.NE.0) RETURN
      ENDIF
      CTYP='LISTCHPO'
      CALL FUSSUI(IP1,IP2,IRETOU)
      GOTO 100

*     Sortie sans problème, écriture résultat
 100  CONTINUE
      IF(IERR.NE.0) RETURN
      CALL ECROBJ(CTYP,IRETOU)
      RETURN

*     Fusion de chaines, limitation à 72 caractères, contrairement à
*     l'opérateur CHAINE
 225  CONTINUE
      IRET=IRET1+IRET2
      IF(IRET.GT.72) THEN
*       Un titre ou un texte ne peut avoir plus de 72 caractères
         CALL ERREUR(425)
         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
      MTABLE=IP1
      IF (IRETOU.EQ.1) THEN
*        ET DE TABLES ESCLAVE
*        WRITE(IOIMP,*) ' TABLE ESCLAVE DANS ET'
*        IF (LODESL) THEN
*           WRITE(IOIMP,*) ' LODESL REMIS À FAUX DANS PRFUSE '
*           LODESL=.FALSE.
*           CALL ABORT
*        ENDIF
         CALL ACCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
     >        'MOT',ID3,RR1,CTYP,IR1,ID2)
         IF (CTYP.NE.'ESCLAVE') THEN
*           Donnez une TABLE de sous-type %m1:8
            MOTERR(1:8)='ESCLAVE'
            CALL ERREUR(-173)
*           Le sous-type de la table est incorrect
            CALL ERREUR(648)
            RETURN
         ENDIF
         SEGACT MTABLE
         ML=MLOTAB
*        L'INDICE 1 EST LE SOUS TYPE
         IND=MTABII(2)
         CTYP=' '
         CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >        CTYP,ID3,RR1,TYPRET,IR1,ID1)
         IRETOU=ID1
         IF (CTYP.EQ.'POINT') THEN
            NBNN=1
            NBSOUS=0
            NBREF=0
            NBELEM=ML-1
            SEGINI MELEME
            ITYPEL=1
            NUM(1,1)=ID1
            ICOLOR(1)=IDCOUL
            DO I=3,ML
               SEGACT MTABLE
               IND=MTABII(I)
               CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >              CTYP,ID3,RR1,' ',IR1,ID2)
               IF (IERR.NE.0) RETURN
               NUM(1,I-1)=ID2
               ICOLOR(I-1)=IDCOUL
            ENDDO
            SEGDES MELEME
            IRETOU=MELEME
            CTYP='MAILLAGE'
         ELSEIF (CTYP.EQ.'MAILLAGE') THEN
            DO I=3,ML
               SEGACT MTABLE
               IND=MTABII(I)
               CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >              CTYP,ID3,RR1,' ',IR1,ID2)
               IF (IERR.NE.0) RETURN
               CALL FUSE(ID1,ID2,IRETOU,LTELQ)
               ID1=IRETOU
            ENDDO
         ELSEIF (CTYP.EQ.'MCHAML') THEN
            DO I=3,ML
               SEGACT MTABLE
               IND=MTABII(I)
               CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >              CTYP,ID3,RR1,' ',IR1,ID2)
               IF (IERR.NE.0) RETURN
               CALL FUSCHL(ID1,ID2,IRETOU)
               ID1=IRETOU
            ENDDO
         ELSEIF (CTYP.EQ.'CHPOINT ') THEN
            DO I=3,ML
               SEGACT MTABLE
               IND=MTABII(I)
               CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >              CTYP,ID3,RR1,' ',IR1,ID2)
               IF (IERR.NE.0) RETURN
               CALL FUCHPO(ID1,ID2,IRETOU)
               IF (IERR.NE.0) RETURN
               ID1=IRETOU
            ENDDO
         ELSEIF (CTYP.EQ.'RIGIDITE') THEN
            DO I=3,ML
               SEGACT MTABLE
               IND=MTABII(I)
               CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >              CTYP,ID3,RR1,' ',IR1,ID2)
               IF (IERR.NE.0) RETURN
               CALL FUSRIG(ID1,ID2,IRETOU)
               IF (IERR.NE.0) RETURN
               ID1=IRETOU
            ENDDO
         ELSEIF (CTYP.EQ.'MATRIK  ') THEN
            DO I=3,ML
               SEGACT MTABLE
               IND=MTABII(I)
               CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >              CTYP,ID3,RR1,' ',IR1,ID2)
               IF (IERR.NE.0) RETURN
               CALL FUSMTK(ID1,ID2,IRETOU)
               IF (IERR.NE.0) RETURN
               ID1=IRETOU
            ENDDO
         ELSEIF (CTYP.EQ.'MMODEL') THEN
            DO I=3,ML
               SEGACT MTABLE
               IND=MTABII(I)
               CALL ACCTAB(MTABLE,'ENTIER',IND,0.D0,' ',.TRUE.,0,
     >              CTYP,ID3,RR1,' ',IR1,ID2)
               IF (IERR.NE.0) RETURN
               CALL FUSMOD(ID1,ID2,IRETOU)
               IF (IERR.NE.0) RETURN
               ID1=IRETOU
            ENDDO
         ELSE
*    On ne veut pas d'objet de type %m1:8
            MOTERR(1:8)=CTYP
            CALL ERREUR(39)
            RETURN
         ENDIF
         SEGDES MTABLE
         GOTO 100
      ENDIF

 2000 CONTINUE
*     FUSION TABLE DE MODES
      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)
         CALL ACCTAB(MTABLE,'MOT',0,0.D0,'MODES',.TRUE.,0,
     >        'TABLE',ID3,RR1,' ',.TRUE.,IP1)
         MTABLE = IP1
      ENDIF
      IKO = 0
 2100 IKO = IKO + 1
      SEGACT MTABLE
      IF (LEMOT.EQ.'LIAISONS_STATIQUES') THEN
         IMA = MLOTAB - 1
      ELSE
         IMA = MLOTAB - 2
      ENDIF
      IM = 0
 2160 IM = IM + 1
      CALL ACCTAB(MTABLE,'ENTIER',IM,0.D0,' ',.TRUE.,0,
     >     'TABLE',ID3,RR1,' ',.TRUE.,ITMOD)
      IF (ITMOD.GT.0)  THEN
         IL = IL + 1
         CALL ECCTAB(IPTAB2,'ENTIER',IL,0.0D0,' ',.TRUE.,IP0,
     &        'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
      ENDIF
      IF (IM.LT.IMA) GOTO 2160

      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)
         ENDIF
         GOTO 2100
      ENDIF

 2300 CALL ECROBJ ('TABLE   ',ipout)
      RETURN

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

      END