C PRINPO    SOURCE    MB234859  25/09/08    21:15:59     12358          
      SUBROUTINE PRINPO(IPCHE1,MMM,IPCHE2,IPMODL,IPSTRS,IRET)
C=======================================================================
C
C  entr{es :
C  ========
C
C   IPCHE1 =pointeur sur un MCHAML de CONTRAINTES ou de DEFORMATIONS
C     MMM  =motcle pour les COQUES ( sortie sur la peau SUP INF OU MOYE)
C   IPCHE2 =pointeur sur un MCHAML de CARACTERISTIQUES
C   IPMODL =pointeur sur un MODELE
C
C  sorties :
C  =======
C
C   IPSTRS =pointeur sur un MCHAML de CONTRAINTES PRINCIPALES
C     IRET =1  OU  0   SUIVANT SUCCES OU PAS (MESSAGE D'ERREUR
C                                             imprim{ dans ce cas)
C
C   Passage aux nouveaux Chamelem par S.RAMAHANDRY le 21/09/90
C
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      INTEGER ISUP2

-INC PPARAM
-INC CCOPTIO
-INC CCHAMP

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

-INC TMPTVAL

      SEGMENT MWRK1
         REAL*8  XEL(3,NBNN)
      ENDSEGMENT
C
      SEGMENT MWRK2
         REAL*8 TXR(3,3,NBNN) ,TH(NBNN)
      ENDSEGMENT
C
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
C
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
C
      CHARACTER*4 MOTCLE(6),MMM
      CHARACTER*(NCONCH) CONM
      LOGICAL lsuppr,lsupno
      DIMENSION A(3,3),D(3),S(3,3),BPSS(3,3),SIG(9),V1(4)
C
      DATA MOTCLE/'SUP ','MOYE','INF ','SUPE','INFE','TRID'/
      DATA XZER,UN,DEUX/0.D0,1.D0,2.D0/
C
      LSUPNO=.FALSE.
      LSUPpR=.FALSE.
      ISUP2=0
      IDIMM=IDIM
      XFLOT =XZER
      IF(MMM.EQ.MOTCLE(1)) XFLOT= UN
      IF(MMM.EQ.MOTCLE(4)) XFLOT= UN
      IF(MMM.EQ.MOTCLE(2)) XFLOT= XZER
      IF(MMM.EQ.MOTCLE(3)) XFLOT=-UN
      IF(MMM.EQ.MOTCLE(5)) XFLOT=-UN
C
      LETRID=0
      IF(MMM.EQ.MOTCLE(6)) LETRID=1

      NHRM=NIFOUR
C
      IRET = 0
C
      ICONT=0
      IDEFO=0
      MCHELM=IPCHE1
      SEGACT MCHELM
      IF (TITCHE .EQ.'CONTRAINTES' ) ICONT = 1
      IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1
C CLB
C CLB  DANS LE CAS DES DEFORMATIONS IL FAUT MULTIPLIER LES GAMMA PAR 0.5
C CLB

      XMULIJ=ICONT + IDEFO/DEUX
C
C ERREUR  IL FAUT UN CHAMELEM DE SOUS TYPE CONTRAINTES OU DEFORMATIONS
C
      IF (ICONT.NE.1 .AND. IDEFO.NE.1) THEN
      MOTERR(1:24)='CONTRAINTES'
      MOTERR(25:48)='DEFORMATIONS'
      CALL ERREUR(109)
      RETURN
      ENDIF
C
C     Verification du lieu support du MCHAML de contraintes
C

C Contraintes / Deformations : REDU et Verification du lieu support
      CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
      IF (ISUP1.GT.1) RETURN

C Caracteristiques : REDU et Verification du lieu support
****  IPCHE2 = 0
      IF (IPCHE2.NE.0) THEN
        CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2)
        IF (ISUP2.GT.1) RETURN
      ENDIF
C
C     ACTIVATION DU MODELE
C
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS=KMODEL(/1)
C
C     CREATION DU MCHELM
C
      N1=NSOUS
      L1=23
      N3=6
      SEGINI MCHELM
      TITCHE='CONTRAINTES PRINCIPALES'
C CLB
C CLB MODIFICATION DU TITRE DANS LE CAS DES DEFORMATIONS
C CLB
      IF (IDEFO .EQ. 1) THEN
         TITCHE='DEFORMATIONS PRINCIPALES'
      ENDIF
      IFOCHE=IFOUR
      IPSTRS=MCHELM
C____________________________________________________________________
C
C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
C____________________________________________________________________
C
      DO 500 ISOUS=1,NSOUS
C
      IVECT =0
      IVACAR=0
      IVACOM=0
      NCARF =0
      NCARA =0
      NPRIN =0
      MOCARA=0
      MOCOMP=0
      MOSPRI=0
C
C        ON RECUPERE L'INFORMATION GENERALE
C
         IMODEL=KMODEL(ISOUS)
         SEGACT IMODEL
         IPMAIL=IMAMOD
         CONM  =CONMOD
C
C   COQUE INTEGREE OU PAS ?
C
         NPINT=INFMOD(1)
C
         IMACHE(ISOUS)=IPMAIL
         CONCHE(ISOUS)=CONMOD
C
C        TRAITEMENT DU MODELE
C
         MELE=NEFMOD
         MELEME=IMAMOD
C____________________________________________________________________
C
C     INFORMATION SUR L'ELEMENT FINI
C____________________________________________________________________
C
         MFR  =INFELE(13)
         NBGS =INFELE(4)
         NSTRS=INFELE(16)
         MINTE=INFMOD(7)
         IPMINT=MINTE
         MINTE1=INFMOD(3)
C
C        CREATION DU TABLEAU INFOS
C
         CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
         IF (IRTD.EQ.0) RETURN
C
         INFCHE(ISOUS,1)=0
         INFCHE(ISOUS,2)=0
         INFCHE(ISOUS,3)=NHRM
         INFCHE(ISOUS,4)=MINTE
         INFCHE(ISOUS,5)=0
         INFCHE(ISOUS,6)=5
C
C        INITIALISATION DE MINTE
C
         SEGACT MINTE
         NBPGAU=POIGAU(/1)
C
C        ACTIVATION DU MELEME
C
         SEGACT MELEME
         NBNN  =NUM(/1)
         NBELEM=NUM(/2)
         IPPORE=0
         IF(MFR.EQ.33) IPPORE=NBNN

C____________________________________________________________________
C
C        RECHERCHE DES NOMS DE COMPOSANTES
C____________________________________________________________________
C
         lsupno=.false.
         IF(ICONT.EQ.1) THEN
          if(lnomid(4).ne.0) then
             nomid=lnomid(4)
             segact nomid
             mocomp=nomid
             ncomp=lesobl(/2)
             nfac=lesfac(/2)
           else
            lsupno=.true.
            CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
           endif
         ELSE IF(IDEFO.EQ.1) THEN
           if(lnomid(5).ne.0) then
             nomid=lnomid(5)
             segact nomid
             ncomp=lesobl(/2)
             mocomp=nomid
            else
             lsupno=.true.
             CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
            endif
         ENDIF
C
        if(lnomid(9).ne.0) then
          nomid=lnomid(9)
          segact nomid
          mospri=nomid
          nprin=lesobl(/2)
          nfac=lesfac(/2)
          lsuppr=.false.
        else
          lsuppr=.true.
         CALL IDPRIN(IMODEL,IFOUR,MOSPRI,NPRIN,NFAC)
        endif
C
C____________________________________________________________________
C
C        VERIFICATION DE LEUR PRESENCE
C____________________________________________________________________
C
         NBTYPE=1
         SEGINI NOTYPE
         MOTYPE=NOTYPE
         TYPE(1)='REAL*8'
         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
     1                          MOTYPE,1,INFOS,3,IVACOM)
         SEGSUP NOTYPE
         IF (IERR.NE.0) RETURN
         IF (ISUP1.EQ.1) THEN
           CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE,MOCOMP,MELE)
         ENDIF
C
C        RECHERCHE DE LA TAILLE DES MELVAL DES CONTRAINTES
C
         N1PTEL=0
         N1EL=0
         MPTVAL=IVACOM
         DO 111 IO=1,NCOMP
           MELVAL=IVAL(IO)
           N1PTEL=MAX(N1PTEL,VELCHE(/1))
 111     CONTINUE
         NBGCOM=N1PTEL
C
         N1EL=NBELEM
C
C        CREATION DU MCHAML DE LA SOUS ZONE
C
         N2=NPRIN
         SEGINI MCHAML
         ICHAML(ISOUS)=MCHAML
         NSR=1
         NCOSOR=NPRIN
         SEGINI MPTVAL
         IVAPRI=MPTVAL
         NOMID=MOSPRI
         SEGACT NOMID
         DO 100 ICOMP=1,NPRIN
            NOMCHE(ICOMP)=LESOBL(ICOMP)
            TYPCHE(ICOMP)='REAL*8'
            N2PTEL=0
            N2EL=0
            SEGINI MELVAL
            IELVAL(ICOMP)=MELVAL
            IVAL(ICOMP)=MELVAL
 100     CONTINUE
C____________________________________________________________________
C
C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
C____________________________________________________________________
C
         NBROBL=0
         NBRFAC=0
         MOCARA=0
C
C EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
C
         IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
            NBROBL=1
            NBRFAC=1
            SEGINI NOMID
            MOCARA=NOMID
            LESOBL(1)='EPAI'
            LESFAC(1)='EXCE'
C
C CARACTERISTIQUES POUR LES LINESPRING
C
         ELSE IF (MFR.EQ.15) THEN
            NBROBL=1
            SEGINI NOMID
            MOCARA=NOMID
            LESOBL(1)='EPAI'
         ENDIF
C
      IF (MOCARA.NE.0) THEN
         IF (IPCHE2.NE.0) THEN
            NBTYPE=1
            SEGINI NOTYPE
            MOTYPE=NOTYPE
            TYPE(1)='REAL*8'
            CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
     1                          MOTYPE,1,INFOS,3,IVACAR)
            SEGSUP NOTYPE
            IF (IERR.NE.0) RETURN
               IF (IVECT.EQ.1) THEN
                  MPTVAL=IVACAR
                  IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
C
C                    MOT CLE VECT EN CAS DE CONVERSION
C
                     IVECT=2
                     NOMID=MOCARA
                     SEGACT NOMID
                     NBRFAC=NBRFAC+2
                     SEGADJ NOMID
                     MOCARA=NOMID
                     LESFAC(NBRFAC-2)='VX  '
                     LESFAC(NBRFAC-1)='VY  '
                     LESFAC(NBRFAC)  ='VZ  '
C
                     NBTYPE=1
                     SEGINI NOTYPE
                     MOTYPE=NOTYPE
                     TYPE(1)='REAL*8'
                     CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
     1                                 MOTYPE,1,INFOS,3,IVACAR)
                     SEGSUP NOTYPE
                     IF (IERR.NE.0) RETURN
                  ENDIF
               ENDIF
         ELSE
            MOTERR(1:8)='CARACTER'
            MOTERR(9:12)=NOMTP(NEFMOD)
            MOTERR(13:20)='PRIN    '
            CALL ERREUR(145)
            RETURN
         ENDIF
      ENDIF
C
      NCARA=NBROBL
      NCARF=NBRFAC
      NCARR=NCARA+NCARF
      IF(ISUP2.EQ.1.AND.MOCARA.NE.0)THEN
        CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
        IF(IERR.NE.0)THEN
              ISUP2=0
              RETURN
        ENDIF
      ENDIF
C
C=================================================================
C              MASSI COQUE COQEP POUT  CIST  THER  TUYAU LISP
         GOTO (10,66,30,66,50,66,66,66,30,66,66,66,66,66,90),MFR
C Cas particulier des elements InCompressibles (MFR=31)
         IF (MFR.EQ.31) GOTO 10
c        cas Xfem: identique au cas massif
         IF(MFR.EQ.63) goto 10
c
C=================================================================
   66 CONTINUE
      MOTERR(1:8)=NOMFR(MFR)
      CALL ERREUR (194)
      RETURN
C____________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
C____________________________________________________________________
C
   10 CONTINUE
C
C     REMPLISSAGE DU SEGMENT CONTENANT LES MATRICES(JACOBIEN)
C
        IF (IDIM.EQ.1) THEN
          DO IB=1,NBELEM
            DO IGAU=1,NBPGAU
              MPTVAL=IVACOM
              MELVAL=IVAL(1)
              IGMN=MIN(IGAU,VELCHE(/1))
              IBMN=MIN(IB  ,VELCHE(/2))
              SIG(1)=VELCHE(IGMN,IBMN)
              MELVAL=IVAL(2)
              IGMN=MIN(IGAU,VELCHE(/1))
              IBMN=MIN(IB  ,VELCHE(/2))
              SIG(2)=VELCHE(IGMN,IBMN)
              MELVAL=IVAL(3)
              IGMN=MIN(IGAU,VELCHE(/1))
              IBMN=MIN(IB  ,VELCHE(/2))
              SIG(3)=VELCHE(IGMN,IBMN)
              CALL ORDO01(SIG(1),3,.FALSE.)
              MPTVAL=IVAPRI
              MELVAL=IVAL(1)
              IGMN=MIN(IGAU,VELCHE(/1))
              IBMN=MIN(IB  ,VELCHE(/2))
              VELCHE(IGMN,IBMN)=SIG(1)
              MELVAL=IVAL(2)
              IGMN=MIN(IGAU,VELCHE(/1))
              IBMN=MIN(IB  ,VELCHE(/2))
              VELCHE(IGMN,IBMN)=SIG(2)
              MELVAL=IVAL(3)
              IGMN=MIN(IGAU,VELCHE(/1))
              IBMN=MIN(IB  ,VELCHE(/2))
              VELCHE(IGMN,IBMN)=SIG(3)
            ENDDO
          ENDDO
          GOTO 110
        ENDIF

C     BOUCLE SUR LES ELEMENTS
      DO IB=1,NBELEM
C
C        BOUCLE SUR LES POINTS DE GAUSS
C
         DO IGAU=1,NBPGAU
C
            MPTVAL=IVACOM

            MELVAL=IVAL(1)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            A(1,1) =  VELCHE(IGMN,IBMN)
C
            MELVAL=IVAL(2)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            A(2,2) = VELCHE(IGMN,IBMN)
C
            MELVAL=IVAL(3)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            A(3,3) = VELCHE(IGMN,IBMN)
C
            MELVAL=IVAL(4)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            A(1,2) = XMULIJ*VELCHE(IGMN,IBMN)
            A(2,1) = A(1,2)
C
            IF(IFOUR.LT.1.AND.IFOUR.GE.-3) THEN
               IF(LETRID.EQ.1) THEN
                  IDIMM = 3
                  A(1,3)=0.
                  A(2,3)=0.
               ENDIF
               GO TO 6610
            ENDIF
C
            IF(IFOUR.EQ.1) IDIMM=3
            MELVAL=IVAL(5)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            A(3,1) = XMULIJ*VELCHE(IGMN,IBMN)
C
            MELVAL=IVAL(6)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            A(3,2) = XMULIJ*VELCHE(IGMN,IBMN)
            A(1,3) = A(3,1)
            A(2,3) = A(3,2)
C
 6610       CONTINUE
C
C       REMPLISSAGE DU SEGMENT CONTENANT LES VALEURS ET VECTEURS PROPRES
C
            CALL JACOB3(A,IDIMM,D,S)
C
            MPTVAL=IVAPRI
C
            DO 2010 ID = 1,3
               MELVAL=IVAL(ID)
               IGMN=MIN(IGAU,VELCHE(/1))
               IBMN=MIN(IB  ,VELCHE(/2))
               VELCHE(IGMN,IBMN) = D(ID)
C
               MELVAL=IVAL(ID+3)
               IGMN=MIN(IGAU,VELCHE(/1))
               IBMN=MIN(IB  ,VELCHE(/2))
               VELCHE(IGMN,IBMN) = S(ID,1)
C
               MELVAL=IVAL(ID+6)
               IGMN=MIN(IGAU,VELCHE(/1))
               IBMN=MIN(IB  ,VELCHE(/2))
               VELCHE(IGMN,IBMN) = S(ID,2)
C
               MELVAL=IVAL(ID+9)
               IGMN=MIN(IGAU,VELCHE(/1))
               IBMN=MIN(IB  ,VELCHE(/2))
               VELCHE(IGMN,IBMN) = S(ID,3)
C
 2010       CONTINUE
C
        END DO
C
      END DO
C
      GOTO 110
   30 CONTINUE
C____________________________________________________________________
C
C                FORMULATION COQUE
C____________________________________________________________________
C
      SEGINI MWRK1
C
C     BOUCLE SUR LES ELEMENTS
      DO IB=1,NBELEM
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU
C
          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
          IF(IDIM.EQ.3) THEN
            CALL VPAST(XEL,BPSS)
          ELSE IF(IDIM.EQ.2) THEN
            CALL VPAST2(XEL,BPSS)
          ENDIF
          CALL TRPOSE(BPSS)
C
C       REMPLISSAGE DU SEGMENT CONTENANT LES CARACTERISTIQUES  ET
C                     CALCUL DES CONTRAINTES
C
            MPTVAL=IVACOM
C
          DO ID = 1,NSTRS
            MELVAL=IVAL(ID)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            SIG(ID) =  VELCHE(IGMN,IBMN)
          END DO
C
          MPTVAL=IVACAR
C
          MELVAL=IVAL(1)
          EPAIST =  VELCHE(1,1)
C
          MELVAL=IVAL(2)
          IF (IVAL(2).NE.0) THEN
            EXCEN = VELCHE(1,1)
          ELSE
            EXCEN =REAL(0.D0)
          ENDIF
C
c+mdj
          IF(NPINT.NE.0) THEN
            SIG(4)= SIG(4)*XMULIJ
            CALL PRINC(SIG,V1,NSTRS)
            MPTVAL=IVAPRI
            DO ID = 1,4
              MELVAL=IVAL(ID)
              IGMN=MIN(IGAU,VELCHE(/1))
              IBMN=MIN(IB  ,VELCHE(/2))
              VELCHE(IGMN,IBMN) = V1(ID)
            END DO
            GOTO 1130
          ENDIF
c+mdj
C
          CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
C
          IF(IFOUR.GT.0) THEN
C
            A(1,1) = SIG(1) + XFLOT*SIG(4)
            A(2,2) = SIG(2) + XFLOT*SIG(5)
            A(1,2) = XMULIJ*(SIG(3) + XFLOT*SIG(6))
            A(2,1) = A(1,2)
          ELSE   IF(IFOUR.LE.0) THEN
            A(1,1) = SIG(1) + XFLOT*SIG(3)
            A(2,2) = SIG(2) + XFLOT*SIG(4)
            A(1,2) =REAL(0.D0)
            A(2,1) =REAL(0.D0)
          ENDIF
C
          CALL JACOB3(A,2,D,S)
          CALL MULMAT(A,BPSS,S,3,3,3)
C
          MPTVAL=IVAPRI
C
          DO ID = 1,2
            MELVAL=IVAL(ID)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            VELCHE(IGMN,IBMN) = D(ID)
          END DO
C
          DO ID = 1,3
            MELVAL=IVAL(ID+2)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            VELCHE(IGMN,IBMN)= A(ID,1)
C
            MELVAL=IVAL(ID+5)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            VELCHE(IGMN,IBMN)= A(ID,2)
          END DO

 1130 CONTINUE

C
        END DO
C
      END DO
C
      GOTO 110
  50  CONTINUE
C
C    FORMULATION COQUE  EPAISSE  PLUS COMPLIQUE CAR IL FAUT
C                  RECUPERER LES EPAISSEURS ET LES FCTNS DE FORME
C
C     PETITE HORREUR LOCALE ON SUPPOSE EPAISSEUR CONSTANTE
C
      SEGACT MINTE1
      SEGINI MWRK1,MWRK2
      N1PTEL=NBGS
C
      DO 1052 IB = 1,NBNN
            TH(IB)=UN
 1052 CONTINUE

C     BOUCLE SUR LES ELEMENTS
      DO IB=1,NBELEM
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU

C
          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
          CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
C
          DO IC=1,NBGS
                E=DZEGAU(IC)
C
          CALL CQ8LC1(IC,NBNN,E,XEL,TH,SHPTOT,TXR,BPSS,IRR)
C
                MPTVAL=IVACOM
C
                MELVAL=IVAL(1)
                IGMN=MIN(IGAU,VELCHE(/1))
                IBMN=MIN(IB  ,VELCHE(/2))
                A(1,1) =  VELCHE(IGMN,IBMN)
C
                MELVAL=IVAL(2)
                IGMN=MIN(IGAU,VELCHE(/1))
                IBMN=MIN(IB  ,VELCHE(/2))
                A(2,2) =  VELCHE(IGMN,IBMN)
C
                MELVAL=IVAL(3)
                IGMN=MIN(IGAU,VELCHE(/1))
                IBMN=MIN(IB  ,VELCHE(/2))
                A(1,2) =  XMULIJ*VELCHE(IGMN,IBMN)
                A(2,1) = A(1,2)
C
          CALL JACOB3(A,2,D,S)
          CALL MULMAT(A,BPSS,S,3,3,3)
C
                MPTVAL=IVAPRI
C
                MELVAL=IVAL(1)
                IGMN=MIN(IGAU,VELCHE(/1))
                IBMN=MIN(IB  ,VELCHE(/2))
                VELCHE(IGMN,IBMN) = D(1)
C
                MELVAL=IVAL(2)
                IGMN=MIN(IGAU,VELCHE(/1))
                IBMN=MIN(IB  ,VELCHE(/2))
                VELCHE(IGMN,IBMN)= D(2)
C
              DO ID = 1,3
                MELVAL=IVAL(ID+2)
                IGMN=MIN(IGAU,VELCHE(/1))
                IBMN=MIN(IB  ,VELCHE(/2))
                VELCHE(IGMN,IBMN)= A(ID,1)
C
                MELVAL=IVAL(ID+5)
                IGMN=MIN(IGAU,VELCHE(/1))
                IBMN=MIN(IB  ,VELCHE(/2))
                VELCHE(IGMN,IBMN)= A(ID,2)
              END DO
C
           END DO
C
         END DO
C
       END DO
C
      SEGSUP MWRK1,MWRK2
C
      GOTO 110
  90  CONTINUE
C
C     CAS LINESPRING
C
C     BOUCLE SUR LES ELEMENTS
      DO IB=1,NBELEM
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU

          MPTVAL=IVACAR
C
          MELVAL=IVAL(1)
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB  ,VELCHE(/2))
          EP  =  VELCHE(IGMN,IBMN)
          EP2 = EP*EP/REAL(6.D0)
C
          MPTVAL=IVACOM
C
          MELVAL=IVAL(1)
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB  ,VELCHE(/2))
          AUX1 =  VELCHE(IGMN,IBMN)
C
          MELVAL=IVAL(4)
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB  ,VELCHE(/2))
          AUX2 =  VELCHE(IGMN,IBMN)
C
          MPTVAL=IVAPRI
C
          MELVAL=IVAL(1)
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB  ,VELCHE(/2))
          VELCHE(IGMN,IBMN)=AUX1/EP  +  XFLOT * AUX2/EP2
C
        END DO
C
      END DO
C
         GOTO 110
C
C____________________________________________________________________
C
C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
C____________________________________________________________________
C
  110 CONTINUE
C
      IF(ISUP1.EQ.1)THEN
           CALL DTMVAL(IVACOM,3)
      ELSE
          CALL DTMVAL(IVACOM,1)
      ENDIF
C
      IF(ISUP2.EQ.1)THEN
           CALL DTMVAL(IVACAR,3)
      ELSE
          CALL DTMVAL(IVACAR,1)
      ENDIF
C
       CALL DTMVAL(IVAPRI,1)
C
      NOMID=MOCARA
      IF (MOCARA.NE.0) SEGSUP NOMID
      NOMID=MOCOMP
      if(lsupno)SEGSUP NOMID
      NOMID=MOSPRI
      if(lsuppr)SEGSUP NOMID
C
  500 CONTINUE
C
      IRET = 1
      RETURN
      END