C EXTRAI    SOURCE    GOUNAND   14/01/29    21:15:04     7923           
      SUBROUTINE EXTRAI

C=======================================================================
C
C     ELEM = EXTRAIRE OBJET RANG ;
C
C
C     OBJET     TYPE1       OBJET DONT ON EXTRAIT UN ELEMENT.
C     RANG      TYPE2       INDICE DE POSITION DE L'ELEMENT A EXTRAIRE
C                           DE L'OBJET "OBJET".
C     ELEM      TYPE3       OBJET EXTRAIT DE "OBJET".
C
C
C AUTEUR, DATE DE CREATION:
C -------------------------
C
C     PASCAL MANIGOT     5 DECEMBRE 1984
C
C     MODIFIE SEPTEMBRE 94
C=======================================================================

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

-INC CCOPTIO
-INC CCGEOME
-INC CCHAMP

-INC SMSUPER
-INC SMRIGID
-INC SMELEME
-INC SMCHPOI
-INC SMBASEM
-INC SMTABLE
-INC SMDEFOR
-INC SMMODEL
-INC SMEVOLL
-INC SMLREEL
-INC SMLENTI
-INC SMLMOTS
-INC SMLCHPO
-INC SMNUAGE

      SEGMENT LIMODE(0)

      PARAMETER (NBFORM=100 , NBCHGT=8)
      CHARACTER*4 CAMPL(1), MOOPT(7), NOMU(3), LMOSU(5), MOTBAS(5),
     &     NUMO(5), MCHGT(NBCHGT), CMOC(20)
      CHARACTER*16 MOFORM(NBFORM)
      CHARACTER*4 MOT_4,CMOT,MOT1,MOT2
      CHARACTER*8 MOT_8,CTYP,CTYP1
      CHARACTER*512 CTEXTL
      CHARACTER*72 CTEXT
      logical ltelq, LAG,BORNINF,MINI
C
      DATA LMOSU /'RIGI','ELEM','RIGT','MASS','BLOQ'/
      DATA NOMU  /'NOMU','MULT','UNIL'/
      DATA MOOPT /'MAIL','RIGI','SYME','ANTI','CONT','COMP','DIAG'/
      DATA MOTBAS/'RIGI','MASS','MODE','STAT','PSMO'/
      DATA CAMPL /'AMPL'/
      DATA NUMO  /'INFE','SUPE','MINI','MAXI','ENTR'/
      DATA CMOC  /'MAIL','ZONE','FORM','CONS','ELEM','GEOM','CONT',
     $     'DEFO','DEPL','FORC','GRAD','GRAF','MATE','CONP',
     $     'TEMP','VARI','PARA','DEIN','COMP','OBJE'/
      DATA MCHGT /'CHAR','CHAM','TRAJ','EVOL','VITE','COMP',
     &     'LIE ','LIBR' /
C
      CALL QUETYP(CTYP,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
         CALL ERREUR(533)
         RETURN
      ENDIF
C
      IF(CTYP.EQ.'MOT     ') THEN
         call lircha(CTEXTL,1,LONMOT)
         if(ierr.ne.0) return

***** JCARDO 13/03/2012 : extraction d'une sous-chaîne
         CALL QUETYP(CTYP1,0,IRETOU)
         IF (IRETOU.NE.0) THEN
            IF (CTYP1.EQ.'ENTIER'.OR.CTYP1.EQ.'LISTENTI') THEN
               CALL SOUCHA(CTEXTL,LONMOT,CTYP1)
               RETURN
            ENDIF
         ENDIF
         MOT_8=CTEXTL(1:8)
*****

         call repert(MOT_8,ia)
         m=ia
         segini mtable
         mlotab=0
         do 7765 i=1,ia
            if(MOT_8.eq.'FLOTTANT' ) then
               call lirree(xval,1,iretou)
            elseif(MOT_8.eq.'LOGIQUE ') then
               call lirlog(lag,1,iretou)
            elseif (MOT_8.eq.'ENTIER  ') then
               call lirent(ival,1,iretou)
            elseif(MOT_8.eq.'MOT     ') then
               call lircha(CTEXT,1,iretou)
            else
               call lirobj(MOT_8,ival,1,iretou)
            endif
            call ecctab(mtable,'ENTIER  ',i,xval1,MOT_4,mini,ilo,
     $           MOT_8,ival,xval,CTEXT(1:iretou),lag,ival)
 7765    continue
         segdes mtable
         call ecrobj('TABLE   ',mtable)
         return
C
      ELSE IF (CTYP.EQ.'DEFORME ') THEN
         CALL LIROBJ('DEFORME ',MDEFOR,1,IRETOU)
         IF(IERR.NE.0) RETURN
         CALL LIRMOT(CAMPL,1,IRET,1)
         IF(IERR.NE.0) RETURN
         SEGACT MDEFOR
         IF (AMPL(/1).NE.1) THEN
            CALL ERREUR(475)
         ELSE
            AMP=AMPL(1)
            CALL ECRREE(AMP)
         ENDIF
         SEGDES MDEFOR
         RETURN
C
      ELSE IF (CTYP.EQ.'BASEMODA') THEN
         CALL LIROBJ('BASEMODA',IPBASE,1,IRETOU)
         IF(IERR.NE.0) RETURN
         CALL LIRMOT(MOTBAS,5,IRET,1)
         IF(IERR.NE.0) RETURN
         MOT_4=MOTBAS(IRET)
         CALL EXTRA7(IPBASE,MOT_4,IPTR)
         IF(IERR.NE.0) RETURN
         IF (IRET.LE.2) THEN
            CALL ECROBJ('RIGIDITE',IPTR)
         ELSE
            CALL ECROBJ('SOLUTION',IPTR)
         ENDIF
         RETURN
C
      ELSE IF (CTYP.EQ.'EVOLUTIO') THEN
         CALL LIROBJ('EVOLUTIO',IBOLL,1,IRETOU)
         IF(IERR.NE.0) RETURN
         CALL EXTRA6 (IBOLL)
         RETURN
C
      ENDIF
C
C  CAS D'UN OBJET SUPER ELEMENT
C
      CALL LIROBJ ('SUPERELE',MSUPER,0,IRETOU)
      IF (IERR.NE.0) RETURN
      IF (IRETOU.EQ.0) GO TO 113
      CALL LIRMOT(LMOSU,5,IRET,1)
      IF (IERR.NE.0) RETURN
      SEGACT MSUPER
      IF (IRET.EQ.1) THEN
         IPTR=MSURAI
         CALL ECROBJ('RIGIDITE',IPTR)
      ELSEIF (IRET.EQ.2) THEN
         IPTR=MSUPEL
         CALL ECROBJ('MAILLAGE',IPTR)
      ELSEIF (IRET.EQ.3) THEN
         IPTR=MRIGTO
         CALL ECROBJ('RIGIDITE',IPTR)
      ELSEIF (IRET.EQ.4) THEN
         IPTR=MSUMAS
         CALL ECROBJ('RIGIDITE',IPTR)
      ELSEIF (IRET.EQ.5) THEN
*
*  EXTRAI DE MSUPER LES BLOQUAGES DU SUPERELEMENT
*
         NRIGEL=MBLOQU
         RI1=MRIGTO
         SEGACT,RI1
         SEGINI,MRIGID
         MTYMAT=RI1.MTYMAT
         DO 1 IE1=1,NRIGEL
            COERIG(IE1)=RI1.COERIG(IE1)
            DO 11 IE2=1,8
               IRIGEL(IE2,IE1)=RI1.IRIGEL(IE2,IE1)
 11         CONTINUE
 1       CONTINUE
         SEGDES,RI1,MRIGID
         CALL ECROBJ('RIGIDITE',MRIGID)
      ENDIF
      SEGDES MSUPER
      RETURN
C
C  CAS D'UN OBJET MATRIK
C
 113  CONTINUE
      CALL LIROBJ ('MATRIK',IBOGID,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 1132
      CALL LIRMOT(MOOPT,7,IRET,0)
      IF (IRET.EQ.0) THEN
         CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETLM)
         IF (IRETLM.EQ.1) THEN
            CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
            IF (IERR.NE.0) RETURN
         ELSE
            CALL LIRCHA(MOT1,1,IRET)
            IF (IERR.NE.0) RETURN
            CALL LIRCHA(MOT2,1,IRET)
            IF (IERR.NE.0) RETURN
            JGN=4
            JGM=1
            SEGINI MLMOT1,MLMOT2
            MLMOT1.MOTS(1)=MOT1
            MLMOT2.MOTS(1)=MOT2
         ENDIF
         CALL EXINCK(IBOGID,MLMOT1,MLMOT2,IOUT,IMPR,IRET)
         IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2
         IF (IERR.NE.0) RETURN
         CALL ECROBJ('MATRIK',IOUT)
         RETURN
      ELSEIF (IRET.EQ.7) THEN
         CALL ECROBJ('MATRIK',IBOGID)
         CALL EXDIAG(1)
         RETURN
      ELSEIF(IRET.EQ.6) THEN
         CALL LIRCHA(CMOT,0,ICDUAL)
         IF (ICDUAL.NE.0) THEN
            IF (CMOT.NE.'DUAL') THEN
               MOTERR(1:4)=CMOT
               CALL ERREUR(7)
               RETURN
            ENDIF
         ENDIF
         CALL EXTR26(IBOGID,ICDUAL,IPLSTM)
         CALL ECROBJ('LISTMOTS',IPLSTM)
         RETURN
      ELSE
         MOTERR(1:4)=MOOPT(IRET)
         CALL ERREUR(7)
         RETURN
      ENDIF
C
C  CAS D'UN OBJET RIGIDITE
C
 1132 CONTINUE
      CALL LIROBJ ('RIGIDITE',IBOGID,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 114
      CALL LIRMOT(MOOPT,7,IRET,0)
      IF (IRET.EQ.0) THEN
         CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETLM)
         IF (IRETLM.EQ.1) THEN
            CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
            IF (IERR.NE.0) RETURN
         ELSE
            CALL LIRCHA(MOT1,1,IRET)
            IF (IERR.NE.0) RETURN
            CALL LIRCHA(MOT2,1,IRET)
            IF (IERR.NE.0) RETURN
            JGN=4
            JGM=1
            SEGINI MLMOT1,MLMOT2
            MLMOT1.MOTS(1)=MOT1
            MLMOT2.MOTS(1)=MOT2
         ENDIF
         CALL EXINCR(IBOGID,MLMOT1,MLMOT2,IOUT)
         IF (IRETLM.NE.1) SEGSUP MLMOT1,MLMOT2
         IF (IERR.NE.0) RETURN
         CALL ECROBJ('RIGIDITE',IOUT)
         RETURN
      ELSEIF (IRET.EQ.7) THEN
         CALL EXDIAR(IBOGID,ICHP)
         IF (IERR.NE.0) RETURN
         CALL ECROBJ('CHPOINT ',ICHP)
         RETURN
      ELSEIF(IRET.EQ.6) THEN
         CALL LIRCHA(CMOT,0,ICDUAL)
         IF (ICDUAL.NE.0) THEN
            IF (CMOT.NE.'DUAL') THEN
               MOTERR(1:4)=CMOT
               CALL ERREUR(7)
               RETURN
            ENDIF
         ENDIF
         CALL EXTR16(IBOGID,ICDUAL,IPLSTM)
         CALL ECROBJ('LISTMOTS',IPLSTM)
         RETURN
      ELSE IF(IRET.EQ.5) THEN
         MRIGID=IBOGID
         SEGACT MRIGID
         ISOPE= ISUPEQ
         IF(ISUPEQ.EQ.0)  CALL CRTABL(ISOPE)
         MTABLE=ISOPE
         SEGDES MTABLE
         CALL ECROBJ('TABLE   ',ISOPE)
         RETURN
      ELSE IF (IRET.EQ.3 .OR. IRET.EQ.4) THEN
         CALL EXTR13(IBOGID,IRET)
         RETURN
      ENDIF
      ICO=0
      IMO=3
      IF(IRET.EQ.2) THEN
         ICO=1
         IMO=2
      ENDIF
      CALL LIRMOT(NOMU,IMO,IMUL,ICO)
      IF(IERR.NE.0) RETURN
      IF(IRET.EQ.2) THEN
         CALL SEPA(IBOGID,IMUL)
         CALL ECROBJ('RIGIDITE',IBOGID)
         RETURN
      ENDIF
      IF(IMUL.NE.0) THEN
         CALL POIRIG(IBOGID,IMUL)
         RETURN
      ENDIF
      IF(IERR.NE.0)  RETURN
      MRIGID=IBOGID
      SEGACT MRIGID
      NBSOUS=IRIGEL(/2)
      IF(NBSOUS.EQ.0) THEN
         NBNN=0
         NBELEM=0
         NBREF=0
         SEGINI MELEME
         SEGDES MELEME,MRIGID
         CALL ECROBJ ('MAILLAGE',MELEME)
         RETURN
      ENDIF
      IPP1 = IRIGEL(1,1)
      IF(NBSOUS.GT.1) THEN
         nbref=0
         nbnn=0
         nbelem=0
         segini ipt4
         kt4 = 1
         ipt4.lisous(kt4) = ipp1
         DO 1130 I=1,NBSOUS
            do 1129 jj = 1,kt4
               if (irigel(1,i).eq.ipt4.lisous(jj)) goto 1130
 1129       continue
            kt4 = kt4 + 1
            IPT4.lisous(kt4)=IRIGEL(1,I)
 1130    CONTINUE
         nbsous = kt4
         segadj ipt4
         CALL FUSEBO (IPT4,IPP1)
      ENDIF
      SEGDES MRIGID
      CALL ECROBJ('MAILLAGE',IPP1)
      RETURN
C
C   CAS DU CHPOINT
C
 114  CONTINUE
      CALL LIROBJ ('CHPOINT ',IBOPOI,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 115
      CALL LIRCHA(CMOT,0,IRETOU)
      IF (IRETOU.NE.0) THEN
C
C        Extraction du TITRe du CHPOINT
         IF (CMOT.EQ.'TITR') THEN
            MCHPOI = IBOPOI
            SEGACT MCHPOI
            CTEXT = MOCHDE
            SEGDES MCHPOI
            ILON = LEN(CTEXT)
            DO 100 I = ILON,1,-1
               IF (CTEXT(I:I).NE.' ') THEN
                  NLON = I
                  GOTO 102
               ENDIF
 100        CONTINUE
            NLON = 1
 102        CONTINUE
            CALL ECRCHA(CTEXT(1:NLON))
            RETURN
C
C        Extraction de la NATUre du CHPOINT
         ELSE IF (CMOT.EQ.'NATU') THEN
            MCHPOI = IBOPOI
            SEGACT MCHPOI
            INAT = JATTRI(1)
            IF (INAT.EQ.0) CTEXT(1:11) = 'INDETERMINE'
            IF (INAT.EQ.1) CTEXT(1:11) = 'DIFFUS     '
            IF (INAT.EQ.2) CTEXT(1:11) = 'DISCRET    '
            SEGDES MCHPOI
            CALL ECRCHA(CTEXT(1:11))
            RETURN
C
C        Extraction du MAILlage POI1 du CHPOINT
         ELSE IF (CMOT .EQ.'MAIL') THEN
            IMUL=0
            CALL LIRMOT(NOMU,1,IMUL,0)
            MCHPOI=IBOPOI
            SEGACT MCHPOI
            NBSOUS=IPCHP(/1)
            IPP1=0
            DO 1140 I=1,NBSOUS
               MSOUPO=IPCHP(I)
               SEGACT MSOUPO
               IF(NOCOMP(1).EQ.'LX  '.AND.IMUL.EQ.1) GO TO  1140
               IF (IPP1.EQ.0) THEN
                  IPP1= IGEOC
               ELSE
                  IPP2=IGEOC
                  ltelq=.false.
                  CALL FUSE (IPP1,IPP2,IRET,ltelq)
                  IPP1=IRET
               ENDIF
               SEGDES MSOUPO
 1140       CONTINUE
            SEGDES MCHPOI
            IF(IPP1.EQ.0) THEN
* Création Maillage vide
               NBELEM=0
               NBNN=0
               NBREF=0
               NBSOUS=0
               SEGINI MELEME
               ITYPEL = 1
               IPP1 = MELEME
*               CALL ECRENT( 0)
*            ELSE
            ENDIF
            CALL ECROBJ('MAILLAGE',IPP1)
            RETURN
C
C        Extraction de la liste des COMPosantes du CHPOINT
         ELSE IF (CMOT .EQ.'COMP') THEN
            CALL EXTR11(IBOPOI,KLISTM)
            CALL ECROBJ('LISTMOTS',KLISTM)
            RETURN
C
C        Extraction du TYPE du CHPOINT
         ELSE IF (CMOT.EQ.'TYPE') THEN
            MCHPOI = IBOPOI
            SEGACT MCHPOI
            MOT_8 = MTYPOI
            SEGDES MCHPOI
            CALL ECRCHA(MOT_8(1:8))
            RETURN
C
C        Extraction des VALEurs du CHPOINT (a une seule composante)
         ELSE IF (CMOT.EQ.'VALE') THEN
            CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
            CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
            IF (IRETOU.EQ.0) THEN
               CALL LIRCHA(MOT_4,0,IRETOU)
               IF (IRETOU.GT.0) THEN
                  JGN=4
                  JGM=1
                  SEGINI,MLMOTS
                  MOTS(1)=MOT_4
                  SEGDES,MLMOTS
               ENDIF
            ENDIF
            IF (IERR.NE.0) RETURN
            CALL EXTR23(IBOPOI,MLMOTS,MELEME,MLREEL)
            IF (IERR.NE.0) RETURN
            CALL ECROBJ('LISTREEL',MLREEL)
            RETURN
         ELSE
C
C           Extraction de la valeur en un POINT d'une composante donnee du CHPOINT
            CALL LIROBJ('POINT   ',MPOINT,1,IRETOU)
            IF (IRETOU.EQ.0) THEN
               MOTERR(1:8)='POINT'
               CALL ERREUR(37)
               RETURN
            ENDIF
            CALL EXTRA9(IBOPOI,MPOINT,CMOT,KERRE,XFLOT)
            IF (KERRE.EQ.0) THEN
               CALL ECRREE(XFLOT)
               RETURN
            ENDIF
            MOTERR(1:4)=CMOT
            MOTERR(5:12)='CHPOINT'
            INTERR(1)=MPOINT
            CALL ERREUR(65)
            RETURN
         ENDIF
      ENDIF
*
*     Cas du MCHAML
*
 115  CONTINUE
      CALL LIROBJ('MCHAML',IPCHE1,0,IRET)
      IF(IRET.EQ.0) GOTO 116
*
      CALL LIRCHA(CMOT,1,IRET0)
      IF(IERR.NE.0) RETURN
*
      IF (CMOT.EQ.'DEVA'.OR.CMOT.EQ.'COVA') THEN
         CALL EXCHA1(IPCHE1,ILISR,CMOT)
         IF (ILISR.NE.0) CALL ECROBJ('LISTMOTS',ILISR)
         RETURN
      ELSE IF(CMOT.EQ.'NBZO') THEN
         CALL EXTR18(IPCHE1,NBZONE)
         if (ierr.ne.0) return
         CALL ECRENT(NBZONE)
         RETURN
      ELSE IF(CMOT.EQ.'COMP' ) THEN
         CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
         IF (IRETM.NE.0) THEN
*
*          RECHERCHE DES NOMS DES COMPOSANTES APPARTENANT
*                        A LA ZONE DU MODELE
*
            CALL EXTR15(IPMODL,IPCHE1,IPLSTM)
            IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
            RETURN
         ELSE
*
*          RECHERCHE DES NOMS DE TOUTES LES COMPOSANTES
*
            CALL EXTR17(IPCHE1,IPLSTM)
            CALL ECROBJ('LISTMOTS',IPLSTM)
            RETURN
         ENDIF
*
      ELSE IF(CMOT.EQ.'CONS' ) THEN
         CALL LIROBJ('MMODEL',IPMODL,0,IRETM)
         IF (IRETM.NE.0) THEN
*
*          RECHERCHE DES NOMS DES constituants APPARTENANT
*                        A LA ZONE DU MODELE
*
            CALL EXTR35(IPMODL,IPCHE1,IPLSTM)
            IF (IPLSTM.NE.0) CALL ECROBJ('LISTMOTS',IPLSTM)
            RETURN
         ELSE
*
*          RECHERCHE DES NOMS DE TOUs LES constituants
*
            CALL EXTR37(IPCHE1,IPLSTM)
            CALL ECROBJ('LISTMOTS',IPLSTM)
            RETURN
         ENDIF
*
      ELSE
         IF (CMOT.NE.'TITR'.AND.CMOT.NE.'TYPE'.AND.CMOT.NE.'MAIL')
     $        THEN
            CALL LIRENT(IENT1,1,IRET1)
            IF(IRET1.EQ.0) RETURN
            CALL LIRENT(IENT2,1,IRET2)
            IF(IRET2.EQ.0) RETURN
            CALL LIRENT(IENT3,1,IRET3)
            IF(IRET3.EQ.0) RETURN
         ENDIF
         CALL EXTR14(IPCHE1,IENT1,IENT2,IENT3,CMOT)
         RETURN
      ENDIF
C
C     CAS DU MMODEL
C
 116  CONTINUE
      CALL LIROBJ('MMODEL',IPMODL,0,IRET)
      IF(IRET.EQ.0) GOTO 117
      CALL LIRMOT(CMOC,20,IRET,1)
      IF(IERR.NE.0) RETURN
      CMOT=CMOC(IRET)
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS=KMODEL(/1)
*  en cas de modele melange derouler : creer un nouveau mmode
      segini limode
      do im = 1,NSOUS
         imodel = kmodel(im)
         segact imodel
         limode(**) = imodel
         if (formod(1).eq.'MELANGE') then
            if (ivamod(/1).ge.1) then
               do ivm1 = 1,ivamod(/1)
                  if (tymode(ivm1).eq.'IMODEL') then
                     limode(**) = ivamod(ivm1)
                  endif
               enddo
            endif
         endif
      enddo
      segdes mmodel
* test non redondance
      N1 = 1
      if (limode(/1).gt.1) then
         do 1161 it1 = limode(/1),2,-1
            imode1 = limode(it1)
            segact imode1
            do it2 = (it1 - 1) ,1,-1
               imode2 = limode(it2)
               segact imode2
               if (imode1.imamod.eq.imode2.imamod.and.
     &              imode1.conmod.eq.imode2.conmod) then
                  limode(it1) = 0
                  goto 1161
               endif
            enddo
            N1 = N1 + 1
 1161    continue
      endif
      is1 = 0
      if (limode(/1).gt.0) then
         segini,mmodel
         do is = 1,limode(/1)
            if (limode(is).gt.0) then
               is1 = is1 + 1
               kmodel(is1) = limode(is)
            endif
         enddo
      else
      endif
      NSOUS=KMODEL(/1)
      IPMODL = MMODEL

      IF (CMOT.EQ.'MAIL') THEN
         MMODEL=IPMODL
         SEGACT MMODEL
         NSOUS=KMODEL(/1)
         IMODEL=KMODEL(1)
         SEGACT IMODEL
         IPP1=IMAMOD
         SEGDES IMODEL
         IF(NSOUS.GT.1) THEN
            DO 1116 I=2,NSOUS
               IMODEL=KMODEL(I)
               SEGACT IMODEL
               IPP2 = IMAMOD
               SEGDES IMODEL
               ltelq=.false.
               CALL FUSE (IPP1,IPP2,IRET,ltelq)
               IPP1=IRET
 1116       CONTINUE
         ENDIF
         SEGDES MMODEL
         CALL ECROBJ('MAILLAGE',IPP1)
         RETURN
      ELSEIF (CMOT.eq.'COMP') THEN
         CALL LIRCHA(MOFORM(1),1,iretou)
         if(ierr.ne.0) return
         MMODEL=IPMODL
         SEGACT MMODEL
         NSOUS=KMODEL(/1)
         segini,MMODE1=MMODEL
         N1=0
         DO 5497 I=1,NSOUS
            IMODEL=KMODEL(I)
            SEGACT IMODEL
            DO IB=1,MATMOD(/2)
               IF( MATMOD(IB).EQ.MOFORM(1)) go to 5498
            ENDDO
            SEGDES IMODEL
            GO TO 5497
 5498       CONTINUE
            N1=N1+1
            MMODE1.KMODEL(N1)=KMODEL(I)
            SEGDES IMODEL
 5497    CONTINUE
         SEGDES MMODEL
         IF(N1.EQ.0)CALL ERREUR(610)
         IF(N1.GE.0.AND.N1.NE.NSOUS) SEGADJ MMODE1
         segdes MMODE1
         CALL ECROBJ('MMODEL',MMODE1)
         RETURN
      ELSEIF(CMOT.EQ.'OBJE') THEN
         mmodel=ipmodl
         segact mmodel
         if(kmodel(/1).ne.1) then
            WRITE(IOIMP,*) ' it is not an elementary model'
            call erreur(19)
            return
         endif
         imodel=kmodel(1)
         segact imodel
         iob=ivamod(/1)
         do io=iob,1,-1
            ctyp=tymode(io)
            if( ctyp.eq.'ENTIER') then
               call ecrent(ivamod(io))
            else
               call ecrobj(ctyp,ivamod(io))
            endif
         enddo
         segdes imodel,mmodel
         return
      ELSEIF (CMOT.EQ.'ZONE') THEN
         MMODEL=IPMODL
         SEGACT MMODEL
         NSOUS=KMODEL(/1)
         M=NSOUS*2
         N1 = 1
         SEGINI MTABLE
         IF(NSOUS.NE.0) THEN
            DO 128 IOK=1,NSOUS
               IMODEL=KMODEL(IOK)
               SEGACT IMODEL
               NFOR=FORMOD(/2)
C   CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
               CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
               CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
               CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
               IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
                  SEGINI,IMODE1= IMODEL
                  IMODE1.INFMOD(2)=0
                  SEGDES IMODEL
                  IMODEL=IMODE1
               ENDIF
               SEGINI MMODE1
               MMODE1.KMODEL(1) = IMODEL
               SEGDES MMODE1
               IPP1= MMODE1
               IPP2=IMAMOD
               IVALI1=IOK*2 -1
               IVALI2=IOK*2
               CALL  ECCTAB(MTABLE,'ENTIER  ',IVALI1,XFLOT,MOT_8,LAG,
     $              IOBIN,'MMODEL  ',IVALRE,XFLOT,MOT_8,LAG,IPP1)
               CALL  ECCTAB(MTABLE,'ENTIER  ',IVALI2,XFLOT,MOT_8,LAG,
     $              IOBIN,'MAILLAGE',IVALRE,XFLOT,MOT_8,LAG,IPP2)
               SEGDES IMODEL
 128        CONTINUE
         ENDIF
         CALL ECROBJ('TABLE   ',MTABLE)
         RETURN
      ELSE IF (CMOT.EQ.'FORM'.OR.CMOT.EQ.'CONS'.OR.CMOT.EQ.'ELEM'.OR.
     $        CMOT.EQ.'MATE') THEN
         INFOR=1
         IF (CMOT.EQ.'MATE') THEN
            IPASS=0
            ICOND=0
 1191       CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
            IF (IERR.NE.0) RETURN
            IPASS=IPASS+1
            IF (IRETO.EQ.0.AND.IPASS.EQ.1) THEN
               CALL NOVARD(IPMODL,CMOT)
               RETURN
            ENDIF
            IF (IRETO.NE.0) THEN
               INFOR=INFOR+1
               IF (INFOR.GT.NBFORM) THEN
                  CALL ERREUR(5)
                  RETURN
               ENDIF
               GO TO 1191
            ENDIF
         ELSE
            ICOND=1
 1192       CALL LIRCHA(MOFORM(INFOR),ICOND,IRETO)
            IF (IERR.NE.0) RETURN
            ICOND=0
            IF (IRETO.NE.0) THEN
               INFOR=INFOR+1
               IF (INFOR.GT.NBFORM) THEN
                  CALL ERREUR(5)
                  RETURN
               ENDIF
               GO TO 1192
            ENDIF
         ENDIF
         INFOR=INFOR-1
*
         MMODE1=IPMODL
         SEGACT MMODE1
         NSOUS=MMODE1.KMODEL(/1)
         N1=NSOUS
         SEGINI MMODEL
         IPP1=MMODEL
         NZON=0
*
         DO 1119 I=1,NSOUS
            IMODEL=MMODE1.KMODEL(I)
            SEGACT IMODEL
            IF(CMOT.EQ.'FORM') THEN
               NFOR=FORMOD(/2)

               IF(NFOR.NE.INFOR) GO TO 1119
               IF(NFOR.EQ.1) THEN
                  IF(MOFORM(1).NE.FORMOD(1)) GO TO 1119
               ELSE IF(NFOR.EQ.2) THEN
                  IF(((MOFORM(1).NE.FORMOD(1)).AND.(MOFORM(2).NE
     $                 .FORMOD(2))).AND.((MOFORM(1).NE.FORMOD(2)).AND
     $                 .(MOFORM(2).NE.FORMOD(1))))GO TO 1119
               ELSE
                  GO TO 1118
               ENDIF
            ELSE IF (CMOT.EQ.'CONS') THEN
               DO 425 IJ=1,INFOR
C    on enleve les espaces au debut et a la fin
                  idim0=LEN(MOFORM(IJ))
                  idim1=CONMOD(/1)
                  ideb0=0
                  ifin0=0
                  ideb1=0
                  ifin1=0
                  DO ii=1,idim0
                     IF(ideb0.EQ.0.AND.MOFORM(IJ)(ii:ii).NE.' ')
     $                    ideb0=ii
                     IF(ifin0.EQ.0.AND.
     &                    MOFORM(IJ)(idim0-ii+1:idim0-ii+1).NE.' ')
     &                    ifin0=idim0-ii+1
                  ENDDO
                  DO ii=1,idim1
                     IF(ideb1.EQ.0.AND.CONMOD(ii:ii).NE.' ') ideb1=ii
                     IF(ifin1.EQ.0.AND.
     &                    CONMOD(idim1-ii+1:idim1-ii+1).NE.' ')
     &                    ifin1=idim1-ii+1
                  ENDDO
C              print *,'Limites : ',ideb0,ifin0,' / ',ideb1,ifin1
                  IF(MOFORM(IJ)(ideb0:ifin0).EQ.CONMOD(ideb1:ifin1))
     &                 GOTO 429
 425           CONTINUE
               GO TO 1119
            ELSE IF (CMOT.EQ.'ELEM') THEN
               DO 426 IJ=1,INFOR
                  IF(MOFORM(IJ)(1:4).EQ.NOMTP(NEFMOD)) GO TO 429
 426           CONTINUE
               GO TO 1119
            ELSEIF(CMOT.EQ.'MATE') THEN
               NMAT=MATMOD(/2)
               DO 427 IJ=1,INFOR
                  DO 4275 JJ=1,NMAT
                     IF(MATMOD(JJ).EQ.MOFORM(IJ)) GO TO 429
 4275             CONTINUE
 427           CONTINUE
               GO TO 1119
            ENDIF
*  on vient ici pour prendre les sous modeles
 429        CONTINUE
            NZON=NZON+1
            NFOR=FORMOD(/2)
C   CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
            CALL PLACE (FORMOD,NFOR,IDARC,'DARCY')
            CALL PLACE (FORMOD,NFOR,IEULE,'EULER')
            CALL PLACE (FORMOD,NFOR,INAVI,'NAVIER_STOKES')
            IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))THEN
               SEGINI,IMODE1= IMODEL
               IMODE1.INFMOD(2)=0
               SEGDES IMODEL
               IMODEL=IMODE1
            ENDIF
            KMODEL(NZON)=IMODEL
            SEGDES IMODEL
 1119    CONTINUE
*
         IF(NZON.EQ.0) GO TO 1118
         N1=NZON
         SEGADJ MMODEL
         SEGDES MMODEL
         SEGDES MMODE1
         CALL ECROBJ('MMODEL',IPP1)
         RETURN
 1118    CONTINUE
         CALL ERREUR(610)
         SEGSUP MMODEL
         SEGDES IMODEL
         SEGDES MMODE1
         RETURN
      ELSE IF (IRET.GE.6.AND.IRET.LE.18.AND.IRET.NE.13) THEN
         CALL NOVARD(IPMODL,CMOT)
         RETURN
      ELSE
         MOTERR(1:4)=CMOT
         CALL ERREUR(7)
         RETURN
      ENDIF
C+LP
C
C   CAS DU CHARGEMENT
C =====================
 117  CONTINUE
      CALL LIROBJ('CHARGEME',ICHAR,0,IRET)
      IF (IERR.NE.0) RETURN
      IF (IRET.EQ.0) GOTO 121
C
      CMOT  = '    '
      ICHGT = 0
      LCHGT = 0
      IEC   = 1
      CALL LIROBJ('LISTMOTS',LCHGT,0,IRET)
      IF (IERR.NE.0) RETURN
      IF (IRET.EQ.0) THEN
         CALL LIRCHA(CMOT,1,IRETOU)
         IF (IERR.NE.0) RETURN
         CALL PLACE(MCHGT,NBCHGT,ICHGT,CMOT)
         IF (ICHGT.GE.1 .AND. ICHGT.LE.5) THEN
            CALL LIRENT(IEC,0,IRETOU)
            IF (IERR.NE.0) RETURN
            IF (IRETOU.EQ.0) IEC = 1
         ELSE IF (ICHGT.EQ.0) THEN
            CALL LIRCHA(MOT_4,0,IRETOU)
            IF (IRETOU.NE.0) THEN
               IF (MOT_4.EQ.'TABL') THEN
                  ICHGT=-1
               ELSE
                  CALL REFUS
               ENDIF
            ENDIF
         ENDIF
      ENDIF
C
      CALL EXTR20(ICHAR,CMOT,ICHGT,LCHGT,IEC,IOBJ1,CTYP1,IOBJ2,MOT_8)
C
      IF (IOBJ1.NE.0) CALL ECROBJ(CTYP1,IOBJ1)
      IF (IOBJ2.NE.0) CALL ECROBJ(MOT_8,IOBJ2)
      RETURN
C
C  CAS DE L'OBJET LISTCHPO
C
 121  CONTINUE
      CALL LIROBJ('LISTCHPO',ILCHP1,0,IRET)
      IF (IRET .EQ. 0 )GO TO 122
      MLCHP1 = ILCHP1
      SEGACT , MLCHP1
      LONCHP = MLCHP1.ICHPOI(/1)
      CALL LIROBJ('LISTENTI',ILENT,0,IRET)
C
C     SOUS CAS DE LISTCHPO/LISTENTI
C
      IF ( IRET .EQ. 1 ) THEN
         MLENTI = ILENT
         SEGACT , MLENTI
         JG = LECT(/1)
         N1=JG
         SEGINI , MLCHP2
         ILCHP2= MLCHP2
         DO 1211 I=1 , JG
            IF (( LECT(I) .GT. LONCHP ) .OR. ( LECT(I) .LT. 1 )) THEN
               INTERR(1) = LECT(I)
               CALL ERREUR(620)
            ENDIF
            MLCHP2.ICHPOI(I) = MLCHP1.ICHPOI(LECT(I))
 1211    CONTINUE
         SEGDES , MLENTI
         SEGDES , MLCHP1
         SEGDES , MLCHP2
         CALL ECROBJ ('LISTCHPO',ILCHP2)
         RETURN
C
C     SOUS CAS LISTCHPO/ENTIER
C
      ELSE
         CALL LIRENT (ILENT,1,IRETOU)
         IF (IERR .NE. 0) THEN
            SEGDES , MLCHP1
            RETURN
         ENDIF
         IF (ILENT.GT.LONCHP .OR. ILENT.LT.1 ) THEN
            INTERR(1)=ILENT
            CALL ERREUR(620)
         ENDIF
         ILCHPO = MLCHP1.ICHPOI(ILENT)
         SEGDES , MLCHP1
         CALL ECROBJ('CHPOINT ',ILCHPO)
         RETURN
      ENDIF
 122  CONTINUE
C
C
C CAS DE L'OBJET LIST DE MOT
C
      CALL LIROBJ('LISTMOTS',ILMOT1,0,IRET)
      IF (IRET .EQ. 0 )GO TO 123
      MLMOT1 = ILMOT1
      SEGACT , MLMOT1
      LONMOT = MLMOT1.MOTS(/2)
      JGN = MLMOT1.MOTS(/1)
      CALL LIROBJ('LISTENTI',ILENT,0,IRET)
C
C     SOUS CAS DE LISTMOTS/LISTENTI
C
      IF ( IRET .EQ. 1 ) THEN
         MLENTI = ILENT
         SEGACT , MLENTI
         JGM = LECT(/1)
         SEGINI , MLMOT2
         ILMOT2= MLMOT2
         DO 1221 I=1 , JGM
            IF (( LECT(I) .GT. LONMOT ) .OR. ( LECT(I) .LT. 1 )) THEN
               INTERR(1) = LECT(I)
               CALL ERREUR(620)
            ENDIF
            MLMOT2.MOTS(I) = MLMOT1.MOTS(LECT(I))
 1221    CONTINUE
         SEGDES , MLENTI
         SEGDES , MLMOT1
         SEGDES , MLMOT2
         CALL ECROBJ ('LISTMOTS',ILMOT2)
         RETURN
C
C     SOUS CAS LISTMOTS/ENTIER
C
      ELSE
         CALL LIRENT (ILENT,1,IRETOU)
         IF (IERR .NE. 0) THEN
            SEGDES , MLMOT1
            RETURN
         ENDIF
         IF (ILENT.GT.LONMOT .OR. ILENT.LT.1 ) THEN
            INTERR(1)=ILENT
            CALL ERREUR(620)
         ELSE
            CTEXT = MLMOT1.MOTS(ILENT)
         ENDIF
         SEGDES , MLMOT1
         CALL ECRCHA(CTEXT(1:JGN))
         RETURN
      ENDIF
 123  CONTINUE
C
C
C  CAS DE L'OBJET LISTREEL
C
      CALL LIROBJ('LISTREEL',ILREE1,0,IRET)
      IF (IRET .EQ. 0 )GO TO 124
      MLREE1 = ILREE1
      SEGACT , MLREE1
      LONREE = MLREE1.PROG(/1)
      CALL LIROBJ('LISTENTI',ILENT,0,IRET)
C
C    SOUS CAS LISTREEL/LISTENTIER
C
      IF ( IRET .EQ. 1 ) THEN
         MLENTI = ILENT
         SEGACT , MLENTI
         JG = LECT(/1)
         SEGINI , MLREE2
         ILREE2= MLREE2
         DO 1231 I=1 , JG
            IF (( LECT(I) .GT. LONREE ) .OR. ( LECT(I) .LT. 1 )) THEN
               INTERR(1) = LECT(I)
               CALL ERREUR(620)
            ENDIF
            MLREE2.PROG(I) = MLREE1.PROG(LECT(I))
 1231    CONTINUE
         SEGDES , MLENTI
         SEGDES , MLREE1
         SEGDES , MLREE2
         CALL ECROBJ ('LISTREEL',ILREE2)
         RETURN
C
C        SOUS CAS LISTREEL/ENTIER
C
      ELSE
         CALL LIRENT (ILENT,1,IRETOU)
         IF (IERR .NE. 0) THEN
            SEGDES , MLREE1
            RETURN
         ENDIF
         IF (ILENT.GT.LONREE .OR. ILENT.LT.1 ) THEN
            INTERR(1)=ILENT
            CALL ERREUR(620)
         ELSE
            REELDP = MLREE1.PROG(ILENT)
         ENDIF
         SEGDES , MLREE1
         CALL ECRREE(REELDP)
         RETURN
      ENDIF
 124  CONTINUE
C
C
C   CAS DE L'OBJET LISTENTIER
C
      CALL LIROBJ('LISTENTI',ILENT1,0,IRET)
      IF (IRET .EQ. 0 ) GO TO 125
      MLENT1 = ILENT1
      SEGACT , MLENT1
      LONENT = MLENT1.LECT(/1)
      CALL LIROBJ('LISTENTI',ILENT2,0,IRET)
C
C    SOUS CAS LISTENTIER/LISTENTIER
C
      IF ( IRET .EQ. 1 ) THEN
         MLENT2 = ILENT2
         SEGACT , MLENT2
         JG = MLENT2.LECT(/1)
         SEGINI , MLENT3
         ILENT3= MLENT3
         DO 1241 I=1 , JG
            IF (MLENT2.LECT(I).GT.LONENT.OR.MLENT2.LECT(I).LT.1) THEN
               INTERR(1) = MLENT2.LECT(I)
               CALL ERREUR(620)
            ENDIF
            MLENT3.LECT(I) = MLENT1.LECT(MLENT2.LECT(I))
 1241    CONTINUE
         SEGDES , MLENT1
         SEGDES , MLENT2
         SEGDES , MLENT3
         CALL ECROBJ ('LISTENTI',ILENT3)
         RETURN
C
C     SOUS CAS LISTENTIER/ENTIER
C
      ELSE
         CALL LIRENT (ILENT,1,IRETOU)
         IF (IERR .NE. 0) THEN
            SEGDES , MLENT1
            RETURN
         ENDIF
         IF (ILENT.GT.LONENT .OR. ILENT.LT.1 ) THEN
            INTERR(1)=ILENT
            CALL ERREUR(620)
         ELSE
            INTEGR = MLENT1.LECT(ILENT)
         ENDIF
         SEGDES , MLENT1
         CALL ECRENT(INTEGR)
         RETURN
      ENDIF
 125  CONTINUE
C
C   CAS DE L'OBJET NUAGE
C
      CALL LIROBJ('NUAGE   ',IPOINT,0,IRET)
      IF (IRET.EQ.0) GOTO 126

      MNUAGE=IPOINT
      SEGACT MNUAGE
      CALL LIRMOT(NUMO,5,INU1,0)
      IF (INU1.EQ.0) THEN
         CALL LIRCHA(CTYP1,1,IRETOU)
         IF (IERR.NE.0) THEN
            SEGDES MNUAGE
            GOTO 12599
         ENDIF
         CALL LIRMOT(NUMO,5,INU1,0)
         IF (INU1.EQ.0) THEN
            IF (CTYP1.EQ.'COMP    ') THEN
               IPROG = 1
            ELSE
               IPOSI = 0
               DO 1250 I=1,NUANOM(/2)
                  IF (NUANOM(I).EQ.CTYP1) IPOSI=I
 1250          CONTINUE
               IF (IPOSI.EQ.0) THEN
                  SEGDES MNUAGE
                  MOTERR(1:8) = CTYP1
*----CTYP1 n'est pas un nom de variable du NUAGE -----
                  CALL ERREUR(672)
                  RETURN
               ENDIF
               IPROG = 2
            ENDIF
         ELSE
            IPOSI = 0
            DO 1251 I=1,NUANOM(/2)
               IF (NUANOM(I).EQ.CTYP1) IPOSI=I
 1251       CONTINUE
            IF (IPOSI.EQ.0) THEN
               SEGDES MNUAGE
               MOTERR(1:8) = CTYP1
*----CTYP1 n'est pas un nom de variable du NUAGE -----
               CALL ERREUR(672)
               RETURN
            ENDIF
            IPROG = 3
         ENDIF
      ELSE
         CALL LIRCHA(CTYP1,1,IRETOU)
         IF (IERR.NE.0) THEN
            SEGDES MNUAGE
            GOTO 12599
         ENDIF
         IPOSI = 0
         DO 1252 I=1,NUANOM(/2)
            IF (NUANOM(I).EQ.CTYP1) IPOSI=I
 1252    CONTINUE
         IF (IPOSI.EQ.0) THEN
            SEGDES,MNUAGE
            MOTERR(1:8) = CTYP1
*----CTYP1 n'est pas un nom de variable du NUAGE -----
            CALL ERREUR(672)
            RETURN
         ELSE
            IPROG = 3
         ENDIF
      ENDIF

*----------- Lecture éventuelle des FLOTTANTS -------------

      IF ((IPROG.EQ.3).AND.(INU1.NE.3).AND.(INU1.NE.4)) THEN
         IF ((INU1.EQ.1).OR.(INU1.EQ.2)) THEN
            CALL LIRREE(XVAL1,0,IRETOU)
            IF (IRETOU.EQ.0) THEN
               SEGDES,MNUAGE
*---- Il manque la valeur de la composante reelle -----
               CALL ERREUR(668)
               RETURN
            ENDIF
         ELSE
            CALL LIRREE(XVAL1,0,IRETOU1)
            CALL LIRREE(XVAL2,0,IRETOU2)
            IF ((IRETOU1.EQ.0).OR.(IRETOU2.EQ.0)) THEN
               SEGDES,MNUAGE
*---- Il faut spécifier deux valeurs reelles  -----
               CALL ERREUR(673)
               RETURN
            ENDIF
         ENDIF
      ENDIF
      SEGDES MNUAGE

*------ Cas de l'extraction des noms des composantes du NUAGE -------

      IF (IPROG.EQ.1) THEN
         CALL EXTR19(IPOINT,IPLSTM)
         IF (IPLSTM.NE.0) THEN
            CALL ECROBJ('LISTMOTS',IPLSTM)
         ENDIF

*--- Cas de l'extraction de l'objet correspondant a une composante ---
*----------------- donnee d'un NUAGE "colonne" -----------------------

      ELSE IF (IPROG.EQ.2) THEN
         CALL EXTR51(IPOINT,IPOSI)

*---------------------------- Autres cas ------------------------------
      ELSE IF (IPROG.EQ.3) THEN
         IF (INU1.EQ.1) THEN
            BORNINF=.TRUE.
            CALL EXTR50(IPOINT,BORNINF,XVAL1,IPOSI)
         ELSE IF (INU1.EQ.2) THEN
            BORNINF=.FALSE.
            CALL EXTR50(IPOINT,BORNINF,XVAL1,IPOSI)
         ELSE IF (INU1.EQ.3) THEN
            MINI =.TRUE.
            CALL EXTR52(IPOINT,MINI,IPOSI)
         ELSE IF (INU1.EQ.4) THEN
            MINI =.FALSE.
            CALL EXTR52(IPOINT,MINI,IPOSI)
         ELSE IF (INU1.EQ.5) THEN
            CALL EXTR53(IPOINT,XVAL1,XVAL2,IPOSI)
         ELSE
            GOTO 126
         ENDIF

*---------------------------- Cas non prevus ---------------------------
      ELSE
         GOTO 126
      ENDIF
      GOTO 12599

 126  CONTINUE
*------ On ne trouve pas d'objet de type compatible avec EXTR ----
      CALL ERREUR(676)
12599 CONTINUE

      RETURN
      END