C KEULE1    SOURCE    PV090527  26/04/30    21:15:44     12529          
               SUBROUTINE KEULE1 (IPMODL,IPCHE1,IPROTA,IPRIG,IFLAM,IRET)
*
*_______________________________________________________________________
*
*             appelé par KEULER ( opérateur KEULER )
*
*  Creation d'une matrice de raideur d'Euler dans le repère tournant
* (éléments BARR, POUTR, TIMO, TUYAU, Massif, COQ3, DST,DKT,COQ6,COQ8)
*
*  entrees :
*  ========
*
*            ipmodl pointeur sur un mmodel
*            ipche1 pointeur sur un mchaml de caracteristique
*            iprota   pointeur sur un point (vecteur vitesse de rotation)
*
*  sorties :
*  =========
*
*            iprig pointeur sur la matrice d'amortissement construite
*            iret   1 si ok, 0 sinon
*
*                         Didier COMBESCURE mars 2003
*
*_______________________________________________________________________
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC CCGEOME
-INC CCREEL

-INC SMRIGID
-INC SMCHAML
-INC SMELEME
-INC SMCOORD
-INC SMINTE
-INC SMMODEL

-INC TMPTVAL

      SEGMENT NOTYPE
      CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT

      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
      PARAMETER (NINF=3)
      INTEGER INFOS(NINF)
      DIMENSION VROT(3)
      LOGICAL lsupfo,lsupdp
C
            lsupfo=.false.
            lsupdp=.false.
      IRET = 0
      NHRM=NIFOUR

C     Activation XCOOR
      SEGACT MCOORD
C____________________________________________________________________
C
C    LECTURE DU VECTEUR ROTATION
C____________________________________________________________________

C
C     Cas 3D (idim=3)
      IF (IFOUR.EQ.2) THEN
        IF (IPROTA.EQ.0) THEN
          VROT(1) = 0.D0
          VROT(2) = 0.D0
          VROT(3) = 1.D0
        ELSE
          VROT(1) = XCOOR((4*IPROTA) - 3)
          VROT(2) = XCOOR((4*IPROTA) - 2)
          VROT(3) = XCOOR((4*IPROTA) - 1)
        ENDIF
C     Cas Axi et 2D Fourier (idim=2)
      ELSE IF ((IFOUR.EQ.0) .OR. (IFOUR.EQ.1)) THEN
        IF (IPROTA.EQ.0) THEN
          VROT(1) = 0.D0
          VROT(2) = 1.D0
          VROT(3) = 0.D0
        ELSE
          VROT(1) = 0.D0
          VROT(2) = XCOOR((3*IPROTA) - 1)
          VROT(3) = 0.D0
        ENDIF
C     Pas d'autres cas ...
C     --> ERREUR "Fonction indisponible pour ce mode de calcul"
      ELSE
        IPRIG=0
        CALL ERREUR(710)
        RETURN
      ENDIF
*
*    verification du lieu support du mchaml de caracteristiques
*
*  am 5/1/95   on remplace par un appel a quesuq plus
*  loin pour ne tester que sur les composantes ad hoc
*
*     call quesup(ipmodl,ipche1,4,0,isup)
*      if(isup.gt.1) return
C____________________________________________________________________
C
C     ACTIVATION DU MODELE
C____________________________________________________________________
C
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS=KMODEL(/1)
C
C____________________________________________________________________
c
C     CREATION DE L'OBJET MATRICE D AMORTISSEMENT
C____________________________________________________________________
C
      NRIGEL=NSOUS
      SEGINI MRIGID
      IF (IFLAM.NE.0) THEN
       MTYMAT='MASSE'
      ELSE
       MTYMAT='RIGIDITE'
      ENDIF
      IFORIG=IFOUR
      ICHOLE=0
      IMGEO1=0
      IMGEO2=0
      ISUPEQ=0
      DO 499 ISOUS=1,NSOUS
          IRIGEL(4,ISOUS)=0
          COERIG(ISOUS)=1.D0
  499 CONTINUE
C
C_______________________________________________________________________
C
C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES
C_______________________________________________________________________
C
      DO 500 ISOUS=1,NSOUS
C
C     ON RECUPERE LINFORMATION GENERALES
C
          IMODEL=KMODEL(ISOUS)
          SEGACT IMODEL
          IIPDPG = imodel.IPDPGE
          IIPDPG = IPTPOI(IIPDPG)
          IPMAIL = imodel.IMAMOD
          CONM   = imodel.CONMOD
C
C     TRAITEMENT DU MODELE
C
          MELEME=IMAMOD
          MELE=NEFMOD
          NFOR=FORMOD(/2)
          NMAT=MATMOD(/2)
          npint = MAX(infmod(1),1)
C
C     NATURE DU MATERIAU
C
          CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
          IF (CMATE.EQ.' ') THEN
              CALL ERREUR(251)
              SEGDES MMODEL
              GOTO 9997
          ENDIF
C Quelques initialisations :
          MOMATR=0
          IVAMAT=0
          MOCARA=0
          IVACAR=0
C_______________________________________________________________________
C
C     INFORMATION SUR L ELEMENT FINI
C_______________________________________________________________________
          iplaz=4
          if (npint.eq.12345) iplaz=1
          MFR   =INFELE(13)
          IF (IFOUR.NE.1) THEN
            NDDL  =INFELE(15)
            LRE   =INFELE(9)
          ELSE
            LRE   =2*INFELE(9)
            NDDL  =2*INFELE(15)
          ENDIF
          LW    =INFELE(7)
          LHOOK =INFELE(10)
          IELE=INFELE(14)
          MINTE=INFMOD(2+iplaz)
          MINTE1=INFMOD(3)
          IPMINT=MINTE
          IPMIN1=MINTE1
C
C     INITIALISATION DE MINTE
C
          SEGACT MINTE
          NBPGAU=POIGAU(/1)
C
C     CREATION DU TABLEAU INFOS
C
          CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD)
          IF (IRTD.EQ.0) GOTO 9990
C
C     ON RECUPERE LES MELVAL ET LES MELEME
C
          MELEME=IPMAIL
          SEGACT MELEME
*
*    modification du meleme pour le remplissage du segment descripteur
*    en deformations planes generalisees
*
          NBNN  =NUM(/1)
          NBELEM=NUM(/2)
          IPPORE=0
          IF(MFR.EQ.33) IPPORE=NBNN
C
C ---------------------------------------------------------*
C INITIALISATION DU SEGMENT DESCR, SEGMENT DESCRIPTEUR DES *
C DES INCONNUES RELATIVES A LA MATRICE DE RIGIDITE         *
C ---------------------------------------------------------*
          NLIGRP = LRE
          NLIGRD = LRE
          SEGINI DESCR
          IPDSCR=DESCR
          if(lnomid(1).ne.0) then
            nomid=lnomid(1)
            segact nomid
            modepl=nomid
            ndepl=lesobl(/2)
            ndum=lesfac(/2)
            lsupdp=.false.
          else
            lsupdp=.true.
            CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
          endif
          if(lnomid(2).ne.0) then
           nomid=lnomid(2)
           segact nomid
           moforc=nomid
           nforc=lesobl(/2)
           lsupfo=.false.
         else
          lsupfo=.true.
          CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
        endif
C
          IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
              CALL ERREUR(5)
              SEGSUP DESCR
              GOTO 9990
          ENDIF
C
C        REMPLISSAGE DU SEGMENT DESCRIPTEUR
C
          IDDL=1
          NCOMP=NDEPL
          NBNNS=NBNN
          IF (MFR.EQ.33) NCOMP=NDEPL-1
C          IF (IFOUR.EQ.-3) THEN
C              NCOMP=NDEPL-3
C              NBNNS=NBNN-1
C          ENDIF
          IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
          NOMID=MODEPL
          SEGACT NOMID
          NOMID=MOFORC
          SEGACT NOMID
          DO 1004 INOEUD=1,NBNNS
              DO 1005 ICOMP=1,NCOMP
               IF (IFOUR.NE.1) THEN
                  NOMID=MODEPL
                  LISINC(IDDL)=LESOBL(ICOMP)
                  NOMID=MOFORC
                  LISDUA(IDDL)=LESOBL(ICOMP)
                  NOELEP(IDDL)=INOEUD
                  NOELED(IDDL)=INOEUD
               ELSE
                  NOMID=MODEPL
                  LISINC(2*IDDL-1)=LESOBL(ICOMP)
                  IF (LESOBL(ICOMP).EQ.'UR  ') THEN
                      LISINC(2*IDDL)='IUR '
                  ELSEIF (LESOBL(ICOMP).EQ.'UZ  ') THEN
                      LISINC(2*IDDL)='IUZ '
                  ELSEIF (LESOBL(ICOMP).EQ.'UT  ') THEN
                      LISINC(2*IDDL)='IUT '
                  ELSEIF (LESOBL(ICOMP).EQ.'RT  ') THEN
                      LISINC(2*IDDL)='IRT '
                  ENDIF
                  NOMID=MOFORC
                  LISDUA(2*IDDL-1)=LESOBL(ICOMP)
                  IF (LESOBL(ICOMP).EQ.'FR  ') THEN
                      LISDUA(2*IDDL)='IFR '
                  ELSEIF (LESOBL(ICOMP).EQ.'FZ  ') THEN
                      LISDUA(2*IDDL)='IFZ '
                  ELSEIF (LESOBL(ICOMP).EQ.'FT  ') THEN
                      LISDUA(2*IDDL)='IFT '
                  ELSEIF (LESOBL(ICOMP).EQ.'MT  ') THEN
                      LISDUA(2*IDDL)='IMT '
                  ENDIF
                  NOELEP(2*IDDL-1)=INOEUD
                  NOELED(2*IDDL-1)=INOEUD
                  NOELEP(2*IDDL)=INOEUD
                  NOELED(2*IDDL)=INOEUD
               ENDIF
                  IDDL=IDDL+1
1005          CONTINUE
1004      CONTINUE
*
          NOMID=MODEPL
          SEGDES NOMID
          NOMID=MOFORC
          SEGDES NOMID
          SEGDES DESCR
C
C ------------------------------------------------------------*
C INITIALISATION DU SEGMENT xMATRI                            *
C CONTENANT LES MATRICES DE RIGIDITE ELEMENTAIRES             *
C ------------------------------------------------------------*
C NBELEM: NB D'ELEMENTS DANS LA SOUS ZONE
          NLIGRP=LRE
          NLIGRD=LRE
C         LVAL=(LRE*(LRE+1))/2
C
          NELRIG=NBELEM
          RIGREL=0
          SEGINI xMATRI
          IPMATR=xMATRI
C
C------------------------------------------------------*
C
C  TRAITEMENT DU CHAPEAU DES RIGIDITES, SEGMENT MRIGID *
C------------------------------------------------------*
C
          IRIGEL(1,ISOUS)=IPMAIL
          IRIGEL(2,ISOUS)=0
          IRIGEL(3,ISOUS)=IPDSCR
          IRIGEL(4,ISOUS)=xMATRI
          IRIGEL(5,ISOUS)=NHRM
C
C MATRICE ANTI-SYMETRIQUE
C
          IRIGEL(7,ISOUS)=1
          xmatri.symre=1
C_______________________________________________________________________
C
C     TRAITEMENT DES CHAMP MATERIAUX
C_______________________________________________________________________
C
          NOMID=0
          NOTYPE=0
          NBROBL=0
          NBRFAC=0
          LHOTRA=0
*
* rho dans les cas poutre,tuyau, massif, coque
*
          IF (MFR.EQ.1.OR.MFR.EQ.27.OR.MFR.EQ.7.OR.MFR.EQ.13.OR.
     .        MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
*
          IF(CMATE.NE.'SECTION') THEN
              NBROBL=1
C              NBRFAC=0
              SEGINI NOMID
              LESOBL(1)='RHO '
              NBTYPE=1
              SEGINI NOTYPE
              TYPE(1)='REAL*8'
          ELSE
              LHOTRA=LHOOK
              NBROBL=2
C              NBRFAC=0
              SEGINI NOMID
              LESOBL(1)='MODS'
              LESOBL(2)='MATS'
              NBTYPE=2
              SEGINI NOTYPE
              TYPE(1)='POINTEURMMODEL'
              TYPE(2)='POINTEURMCHAML'
          ENDIF
          MOMATR=NOMID
          MOTYPE=NOTYPE
       ENDIF
C
      NMATR=NBROBL
      NMATF=NBRFAC
      NMATT=NMATR+NMATF
C
      IF (MOMATR.NE.0) THEN
*
*    verification du support des composantes recherchees
*
          CALL QUESUQ(IMODEL,IPCHE1,4,0,MOMATR,IPLAZ,ISUP,IRET1)
          IF(ISUP.GT.1)THEN
            SEGSUP NOTYPE
              GO TO 9990
          ENDIF
*
          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
          SEGSUP NOTYPE
          IF (IERR.NE.0) GOTO 9996
          IF(ISUP.EQ.1)THEN
              CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
              IF(IERR.NE.0)THEN
                  ISUP=0
                  GOTO 9990
              ENDIF
          ENDIF
      ENDIF
C
C____________________________________________________________________
C
C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
C____________________________________________________________________
C
      NBROBL=0
      NBRFAC=0
      NOMID=0
      NOTYPE=0
      IVECT=0
*
* caracteristiques pour les poutres
*
      IF (MFR.EQ.7 ) THEN
          IF (CMATE.EQ.'SECTION') THEN
              NBROBL=0
              NBRFAC=4
              SEGINI NOMID
              LESFAC(1)='OMEG'
              LESFAC(2)='VX'
              LESFAC(3)='VY'
              LESFAC(4)='VZ'
              IVECT=1
*
              NBTYPE=4
              SEGINI NOTYPE
              MOTYPE=NOTYPE
              TYPE(1)='REAL*8'
              TYPE(2)='REAL*8'
              TYPE(3)='REAL*8'
              TYPE(4)='REAL*8'
*
           ELSE
              NBROBL=4
              NBRFAC=6
              SEGINI NOMID
              LESOBL(1)='TORS'
              LESOBL(2)='INRY'
              LESOBL(3)='INRZ'
              LESOBL(4)='SECT'
              LESFAC(1)='SECY'
              LESFAC(2)='SECZ'
              LESFAC(3)='OMEG'
              LESFAC(4)='VX'
              LESFAC(5)='VY'
              LESFAC(6)='VZ'
              IVECT=1
*
              NBTYPE=10
              SEGINI NOTYPE
              MOTYPE=NOTYPE
              TYPE(1)='REAL*8'
              TYPE(2)='REAL*8'
              TYPE(3)='REAL*8'
              TYPE(4)='REAL*8'
              TYPE(5)='REAL*8'
              TYPE(6)='REAL*8'
              TYPE(7)='REAL*8'
              TYPE(8)='REAL*8'
              TYPE(9)='REAL*8'
              TYPE(10)='REAL*8'
          ENDIF
*
* caracteristiques pour les tuyaux
*
      ELSE IF (MFR.EQ.13) THEN
          NBROBL=2
          NBRFAC=5
          SEGINI NOMID
          LESOBL(1)='EPAI'
          LESOBL(2)='RAYO'
          LESFAC(1)='RACO'
          LESFAC(2)='OMEG'
          LESFAC(3)='VX'
          LESFAC(4)='VY'
          LESFAC(5)='VZ'
          IVECT=1
*
          NBTYPE=7
          SEGINI NOTYPE
          MOTYPE=NOTYPE
          TYPE(1)='REAL*8'
          TYPE(2)='REAL*8'
          TYPE(3)='REAL*8'
          TYPE(4)='REAL*8'
          TYPE(5)='REAL*8'
          TYPE(6)='REAL*8'
          TYPE(7)='REAL*8'
*
* caracteristiques pour les barres
*
      ELSE IF (MFR.EQ.27) THEN
          NBRFAC=0
          NBROBL=1
          SEGINI NOMID
          LESOBL(1)='SECT'
*
          NBTYPE=1
          SEGINI NOTYPE
          MOTYPE=NOTYPE
          TYPE(1)='REAL*8'
*
* epaisseur et excentrement dans le cas des coques
*
      ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
          NBROBL=1
          NBRFAC=1
          SEGINI NOMID
          LESOBL(1)='EPAI'
          LESFAC(1)='EXCE'
*
          NBTYPE=1
          SEGINI NOTYPE
          MOTYPE=NOTYPE
          TYPE(1)='REAL*8'
*
      ENDIF
*
      NCARA=NBROBL
      NCARF=NBRFAC
      NCARR=NCARA+NCARF
      MOCARA=NOMID
*
      IF (MOCARA.NE.0)  THEN
*
*    verification du support des composantes recherchees
*
          CALL QUESUQ(IMODEL,IPCHE1,4,0,MOCARA,IPLAZ,ISUP,IRET2)
          IF(ISUP.GT.1)THEN
              SEGSUP NOTYPE
              GO TO 9990
          ENDIF
*
          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
          SEGSUP NOTYPE
          IF (IERR.NE.0) GOTO 9990
          IF(ISUP.EQ.1)THEN
              CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
              IF(IERR.NE.0)THEN
                  ISUP=0
                  GOTO 9990
              ENDIF
          ENDIF
      ENDIF

C
C_______________________________________________________________________
C
C     NUMERO DES ETIQUETTES      :
C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
C     LES ELEMENTS SONT GROUPES COMME SUIT :
C      - MASSIF,LIQUIDE 'SURFACE LIBRE' ----------------------> CORIO3
C      - COQ3/POUTRE,DKT,COQ4,COQ8,COQ2,DST ------------------> CORIO2
C        ET POUTRE DE TIMOSCHENKO
C_______________________________________________________________________
*                 CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
            GOTO (  99,  99,  99,  11,  99,  11,  99,  11,  99,  11,  99
*                 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
     &           ,  99,  99,  11,  11,  11,  11,  99,  99,  99,  99,  99
*                 TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
     &           ,  11,  11,  11,  11,  21,  21,  21,  99,  99,  99,  99
*                 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
     &           ,  99,  99,  99,  99,  99,  99,  99,  21,  21,  99,  21
*                 POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
     &           ,  99,  21,  99,  99,  21,  99,  99,  99,  99,  99,  99
*                 COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
     &           ,  21,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
     &           ,  99,  99,  99,  99,  99,  99,  21,  99,  99,  99,  99
*                 JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
     &           ,  99,  99,  99,  99,  21,  99,  99,  99,  99,  99,  99
*                 HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
     &           ,  99,  21,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 TE56 PY91 TRH6
     &           ,  99,  99,  99),MELE
C
   99 CONTINUE
      SEGSUP xMATRI
      IRIGEL(4,ISOUS)=0
      MOTERR(1:4)=NOMTP(MELE)
      MOTERR(5:12)='KEULE1'
      CALL ERREUR(86)
      GOTO 9990
C_______________________________________________________________________
C
C     MASSIF
C_______________________________________________________________________
C
  11  CONTINUE
      CALL CORIO3 (IPMAIL,NDDL,LRE,NBPGAU,IPMINT,MELE,MFR,IVAMAT,
     &IVACAR,NMATT,IPMATR,VROT,0,IIPDPG)
      GOTO 510
C_______________________________________________________________________
C
C     POUTRE, POUTRE DE TIMOSCHENKO, COQUE, BARRE
C_______________________________________________________________________
C
  21  CONTINUE
      CALL CORIO2(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,NCARR,
     &IVECT,ISOUS,NBPGAU,IPMINT,IPMIN1,NDDL,MATE,
     &CMATE,LHOTRA,IPMATR,VROT,0,IIPDPG)
      GOTO 510
C_______________________________________________________________________
C
C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
C_______________________________________________________________________
C
  510 CONTINUE
      SEGDES MINTE
      SEGDES MELEME
      SEGDES IMODEL
C
      IF (ISUP.EQ.1) THEN
        CALL DTMVAL(IVAMAT,3)
        CALL DTMVAL(IVACAR,3)
      ELSE
        CALL DTMVAL(IVAMAT,1)
        CALL DTMVAL(IVACAR,1)
      ENDIF
C
      NOMID=MOCARA
      IF (MOCARA.NE.0) SEGSUP NOMID
      NOMID=MOMATR
      IF (MOMATR.NE.0) SEGSUP NOMID
      NOMID=MOFORC
      if(lsupfo)SEGSUP NOMID
      NOMID=MODEPL
      if(lsupdp)SEGSUP NOMID
C
C     ERREUR  DANS LES S-P MASSE2 ,MASSE3 ,MASSE4
C
      IF (IERR.NE.0) GOTO 9997
C
 500  CONTINUE
C
C FIN NORMALE
      IRET = 1
      SEGDES MRIGID
C     WRITE(*,*) 'Je desactive MRIGID'
      IPRIG = MRIGID
      GOTO 666
C
C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
C
 9990 CONTINUE
      IRET=0
C
      IF (ISUP.EQ.1) THEN
        CALL DTMVAL(IVAMAT,3)
        CALL DTMVAL(IVACAR,3)
      ELSE
        CALL DTMVAL(IVAMAT,1)
        CALL DTMVAL(IVACAR,1)
      ENDIF

      NOMID=MOMATR
      IF (MOMATR.NE.0) SEGSUP NOMID
      NOMID=MOCARA
      IF (MOCARA.NE.0) SEGSUP NOMID
      NOMID=MOFORC
      if(lsupfo)SEGSUP NOMID
      NOMID=MODEPL
      if(lsupdp)SEGSUP NOMID
C
 9996 CONTINUE
      SEGDES MELEME
      SEGDES MINTE
      SEGDES IMODEL
C
 9997 CONTINUE
      SEGSUP MRIGID
      IPRIG = 0
C
C Fin commune
  666 CONTINUE
      SEGDES MMODEL
C     Desactivation XCOOR
      SEGDES MCOORD

      RETURN
      END