C PRINPO    SOURCE    PV        12/09/25    21:15:00     7514           
      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)
-INC CCOPTIO
-INC CCHAMP
-INC SMCHAML
-INC SMINTE
-INC SMMODEL
-INC SMCOORD
-INC SMELEME
C
      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
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      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/0.D0,1.D0/
C
      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
*
      IRET = 0
C
      ICONT=0
      IDEFO=0
      MCHELM=IPCHE1
      SEGACT MCHELM
      IF (TITCHE .EQ.'CONTRAINTES') ICONT = 1
      IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1
      SEGDES MCHELM
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:8)='CONTRAIN'
      MOTERR(9:16)='DEFORMAT'
      CALL ERREUR(109)
      RETURN
      ENDIF
*
*     Verification du lieu support du MCHAML de contraintes
*
      CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
      IF (ISUP1.GT.1) RETURN
*
*     Verification du lieu support du MCHAML de caracteristiques
*
      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'
      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
         IF(INFMOD(/1).NE.0)THEN
           NPINT=INFMOD(1)
         ELSE
           NPINT=0
         ENDIF
c+mdj
C         IF (NPINT.NE.0)THEN
C            CALL ERREUR(615)
C            SEGDES IMODEL,MMODEL
C            SEGSUP MCHELM
C            RETURN
C         ENDIF
c+mdj
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
*         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
*         IF (IERR.NE.0) THEN
*           SEGDES IMODEL,MMODEL
*           SEGSUP MCHELM
*           RETURN
*         ENDIF
*         INFO=IPINF
         MFR  =INFELE(13)
         NBGS =INFELE(4)
         NSTRS=INFELE(16)
*         MINTE=INFELE(11)
         MINTE=INFMOD(7)
         IPMINT=MINTE
         MINTE1=INFMOD(8)
*         SEGSUP,INFO
C
C        CREATION DU TABLEAU INFOS
C
         CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
         IF (IRTD.EQ.0) GOTO 9990
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(MFR,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) GOTO 9990
         IF (ISUP1.EQ.1) THEN
           CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE)
         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
         NS=1
         NCOSOU=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
         SEGDES NOMID
C____________________________________________________________________
C
* TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
C____________________________________________________________________
C
         NBROBL=0
         NBRFAC=0
         MOCARA=0
*
* EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
*
         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'
*
* CARACTERISTIQUES POUR LES LINESPRING
*
         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) GOTO 9990
               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) GOTO 9990
                  ENDIF
               ENDIF
         ELSE
            MOTERR(1:8)='CARACTER'
            CALL ERREUR(145)
            GOTO 9990
         ENDIF
      ENDIF
*
      NCARA=NBROBL
      NCARF=NBRFAC
      NCARR=NCARA+NCARF
      IF(ISUP2.EQ.1.AND.MOCARA.NE.0)THEN
        CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE)
        IF(IERR.NE.0)THEN
              ISUP2=0
              GOTO 9990
        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)
      GOTO 9990
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 1010  IB=1,NBELEM
C
C        BOUCLE SUR LES POINTS DE GAUSS
C
         DO 1010 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) = 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) = VELCHE(IGMN,IBMN)
C
            MELVAL=IVAL(6)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            A(3,2) = 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
 1010 CONTINUE
C
      GOTO 110
   30 CONTINUE
C____________________________________________________________________
C
C                FORMULATION COQUE
C____________________________________________________________________
C
      SEGINI MWRK1
C
C     BOUCLE SUR LES ELEMENTS
      DO 1030  IB=1,NBELEM
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
         DO 1030  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 130 ID = 1,NSTRS
           MELVAL=IVAL(ID)
           IGMN=MIN(IGAU,VELCHE(/1))
           IBMN=MIN(IB  ,VELCHE(/2))
           SIG(ID) =  VELCHE(IGMN,IBMN)
  130  CONTINUE
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 =0.D0
          ENDIF
C
c+mdj
          IF(NPINT.NE.0) THEN
            CALL PRINC(SIG,V1,NSTRS)
            MPTVAL=IVAPRI
            DO 161 ID = 1,4
               MELVAL=IVAL(ID)
               IGMN=MIN(IGAU,VELCHE(/1))
               IBMN=MIN(IB  ,VELCHE(/2))
               VELCHE(IGMN,IBMN) = V1(ID)
  161       CONTINUE
            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) = 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) = 0.D0
         A(2,1) = 0.D0
       ENDIF
C
      CALL JACOB3(A,2,D,S)
      CALL MULMAT(A,BPSS,S,3,3,3)
C
            MPTVAL=IVAPRI
C
       DO 61 ID = 1,2
             MELVAL=IVAL(ID)
             IGMN=MIN(IGAU,VELCHE(/1))
             IBMN=MIN(IB  ,VELCHE(/2))
             VELCHE(IGMN,IBMN) = D(ID)
  61   CONTINUE
C
       DO 2030 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)
C
 2030 CONTINUE
 1130 CONTINUE
 1030 CONTINUE
      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 1050  IB=1,NBELEM
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      DO 1050  IGAU=1,NBPGAU

C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
      CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
C
      DO 1050 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) =  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 2050 ID = 1,3
C
            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)
C
 2050 CONTINUE
 1050 CONTINUE
C
      SEGDES MINTE1
      SEGSUP MWRK1,MWRK2
C
      GOTO 110
  90  CONTINUE
C
C     CAS LINESPRING
C
C     BOUCLE SUR LES ELEMENTS
      DO 1090  IB=1,NBELEM
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
         DO 1090  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/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
 1090    CONTINUE
         GOTO 110
C
C____________________________________________________________________
C
C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
C____________________________________________________________________
C
  110 CONTINUE
      SEGDES MINTE
      SEGDES MELEME
      SEGDES IMODEL
      SEGDES MCHAML
*
      IF(ISUP1.EQ.1)THEN
           CALL DTMVAL(IVACOM,3)
      ELSE
          CALL DTMVAL(IVACOM,1)
      ENDIF
*
      IF(ISUP2.EQ.1)THEN
           CALL DTMVAL(IVACAR,3)
      ELSE
          CALL DTMVAL(IVACAR,1)
      ENDIF
*
       CALL DTMVAL(IVAPRI,1)
*
      NOMID=MOCARA
      IF (MOCARA.NE.0) SEGSUP NOMID
      NOMID=MOCOMP
      if(lsupno)SEGSUP NOMID
      NOMID=MOSPRI
      if(lsuppr)SEGSUP NOMID
*
  500 CONTINUE
*
      SEGDES MMODEL
      MCHELM=IPCHE1
**    write (6,*) ' mchelm desactive dans prinpo ',mchelm
      SEGDES MCHELM
      MCHELM=IPSTRS
**    write (6,*) ' ipstrs desactive dans prinpo ',ipstrs
      SEGDES MCHELM
      IRET = 1
      RETURN
*
*     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
*
 9990 CONTINUE
      IRET = 0
*
      IF(ISUP1.EQ.1)THEN
           CALL DTMVAL(IVACOM,3)
      ELSE
          CALL DTMVAL(IVACOM,1)
      ENDIF
*
      IF(ISUP2.EQ.1)THEN
           CALL DTMVAL(IVACAR,3)
      ELSE
          CALL DTMVAL(IVACAR,1)
      ENDIF
*
       CALL DTMVAL(IVAPRI,3)
*
      NOMID=MOCARA
      IF (MOCARA.NE.0) SEGSUP NOMID
      NOMID=MOCOMP
      if(lsupno)SEGSUP NOMID
      NOMID=MOSPRI
      if(lsuppr)SEGSUP NOMID
*
      SEGDES MINTE
      SEGDES MELEME
      SEGDES IMODEL
      SEGSUP MCHAML
*
      SEGDES MMODEL
      SEGSUP MCHELM

      RETURN
      END