Télécharger rigi4.eso

Retour à la liste

rigi4
C RIGI4     SOURCE    OF166741  25/02/21    21:18:19     12166          
 
*---------------------------------------------------------------------*
*         ________________________                                    *
*        |                        |                                   *
*        |  CALCUL DE LA RIGIDITE |                                   *
*        |________________________|                                   *
*                                                                     *
* poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,joint 3D,   *
* cerce, tuyo,joints 2D, litu,zone cohesives                          *
*                                                                     *
*---------------------------------------------------------------------*
*                                                                     *
*   ENTREES :                                                         *
*   ________                                                          *
*                                                                     *
*        MATE     Numero du materiau                                  *
*        MELE     Numero de l'element fini                            *
*        IPMAIL   Pointeur sur un segment  MELEME                     *
*        IPMINT   Pointeur sur un segment MINTE                       *
*        NBPGAU   Nombre de point d'integration pour la rigidite      *
*        LRE      Nombre de ddl dans la matrice de rigidite           *
*        NSTRS    Nombre de composante de contraintes/deformations    *
*        IVAMAT   Pointeur sur un segment MPTVAL pour le materiau ou  *
*                 pour une matrice de hooke                           *
*        IVACAR   Pointeur sur un segment MPTVAL pour les caracteri-  *
*                 stiques                                             *
*        IVECT    FLAG INDIQUANT SI ON A ENTRE UN VECTEUR LOCAL       *
*        CMATE    Nom du materiau                                     *
*        MFR      Numero de la formulation element fini               *
*        NBGMAT   Taille maxi des melval du materiau (pt de gauss)    *
*        NELMAT   Taille maxi des melval du materiau (No d'element)   *
*        IMAT     (2 il y a une matrice de HOOKE,1 non  )             *
*        NMATT    Nombre de composantes de materiau (IMAT=1)          *
*        NCARR    Nombre de caracteristiques geometriques             *
*        ISOUS    NUMERO DE LA SOUS-ZONE                              *
*        LW       Dimension du tableau de travail                     *
*        IPORE    nombre de fonctions de forme
*                                                                     *
*                                                                     *
*   SORTIES :                                                         *
*   ________                                                          *
*                                                                     *
*        IPMATR   pointeur sur la rigidite de la sous-zone            *
*                                                                     *
*---------------------------------------------------------------------*
 
      SUBROUTINE RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
     &     IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,
     &       NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC CCREEL
 
-INC SMCHAML
-INC SMINTE
-INC SMELEME
-INC SMRIGID
-INC SMMODEL
-INC SMCOORD
-INC SMLREEL
-INC SMLMOTS
 
-INC TMPTVAL
 
      SEGMENT WRK1
        REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS)
        REAL*8 REL(LRE,LRE) , XE(3,NBBB)
      ENDSEGMENT
 
      SEGMENT WRK2
        REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE)
      ENDSEGMENT
 
      SEGMENT WRK3
        REAL*8 WORK(LW)
      ENDSEGMENT
 
      SEGMENT WRK4
c cccccc
       REAL*8 BPSS(3,3),XEL(3,NBBB),rell(lre,lre),XPA(IDIM,IDIM)
       REAL*8 XPB(IDIM,IDIM)
c cccccc
      ENDSEGMENT
 
      SEGMENT WRK5
        REAL*8 XGENE(NSTN,LRN)
      ENDSEGMENT
 
      SEGMENT WRK6
        REAL*8 PSS(3,3)
      ENDSEGMENT
 
       SEGMENT WRK7
         REAL*8 PROPEL(14)
         REAL*8 OUT(5)
         REAL*8 WORK1(24*24)
       ENDSEGMENT
 
      SEGMENT,MVELCH
        REAL*8 VALMAT(NV1)
      ENDSEGMENT
 
      CHARACTER*4 lesinc(7),lesdua(7)
      DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
      DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
      DATA X577/.577350269189626D0/
      DIMENSION CRIGI(12),CMASS(12)
      CHARACTER*8 CMATE
 
      MELEME=IPMAIL
      NBNN=NUM(/1)
      NBELEM=NUM(/2)
 
      NV1=NMATT
      SEGINI,MVELCH
 
      XMATRI=IPMATR
*      NLIGRP=LRE
*      NLIGRD=LRE
 
C  Introduction du point autour duquel se fait le mouvement
C  de la section en defo plane generalisee
C  IIPDPG = numero du noeud/point support si defini pour le modele
C  IIPDPG > 0 si prise en compte du point support
C <- Ici test equivalent a IF (IFOUR.EQ.-3)THEN
      IF (IIPDPG.GT.0) THEN
        IREF=(IIPDPG-1)*(IDIM+1)
        XDPGE=XCOOR(IREF+1)
        YDPGE=XCOOR(IREF+2)
      ELSE
        XDPGE=0.D0
        YDPGE=0.D0
      ENDIF
*
      NHRM=NIFOUR
*
      MINTE=IPMINT
      IRTD=1
 
* cas cmate 'STATIQUE'
      IF (mfr.eq.28) THEN
      jgn = 4
       if (ifour.eq.2) then
      jgm = 6
      segini mlmots
      iinc = mlmots
      do igm = 1,jgm
       mots(igm) = lesinc(igm)
      enddo
      segini mlmots
      idua = mlmots
      do igm= 1,jgm
       mots(igm) = lesdua(igm)
      enddo
       else if (ifour.lt.0) then
      jgm = 4
      segini mlmots
      iinc = mlmots
       mots(1) = lesinc(1)
       mots(2) = lesinc(2)
       mots(3) = lesinc(4)
       mots(4) = lesinc(5)
      segini mlmots
      idua = mlmots
       mots(1) = lesdua(1)
       mots(2) = lesdua(2)
       mots(3) = lesdua(4)
       mots(4) = lesdua(5)
       else if (ifour.eq.0) then
      jgm = 3
      segini mlmots
      iinc = mlmots
       mots(1) = lesinc(7)
       mots(2) = lesinc(3)
       mots(3) = lesinc(6)
      segini mlmots
      idua = mlmots
       mots(1) = lesdua(7)
       mots(2) = lesdua(3)
       mots(3) = lesdua(6)
       else if (ifour.eq.1) then
* a faire
       endif
      ENDIF
 
C_______________________________________________________________________
C
C     NUMERO DES ETIQUETTES      :
C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
C     5  CONTINUE
C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
C     44 CONTINUE
C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
C_______________________________________________________________________
C
            IF (MELE.LE.100)
*                 CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
     &      GOTO (  99,  2,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99,  99
*                 TET4 TE10 PYR5 PY13 COQ3  DKT POUT LISP FAC3 FAC4 FAC6
     &           ,  99,  99,  99,  99,  99,  99,  29,  30,  99,  99,  99
*                 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
     &           ,  99,  99,  99,  99,  99,  99,  99,  99,  29,  43,  99
*                 POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
     &           ,  45,  46,  99,  99,  99,  30,  99,  99,  99,  99,  99
*                 COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
     &           ,  99,  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,  29,  85,  86,  87,  88
*                 JOI6 JOI8 LISC TRIH  DST LIC4 CERC TUYO LSE2 LITU HYT3
     &           ,  99,  99,  99,  92,  99,  99,  46,  96,  29,  29,  99
*                 HYQ4
     &           ,  99),MELE
            IF (MELE.LE.200)
*                 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
     &      GOTO (  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,  46, 124, 125, 126, 127,  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,  92,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51, 168, 169, 170, 171, 172,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ????
     &           ,  51,  51),MELE-100
            IF (MELE.LE.300)
*                 ???? ???? ???? ???? ???? ???? ???? ???? ????
     &      GOTO (  51,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51,  51
*                 ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
     &           ,  51,  51,  51,  51, 258,  51, 260,  51,  51,  51,  51
*                 JOI1 ZCO2 ZCO3 ZCO4
c cccccc
     &           , 129, 266, 266, 266,  51,51,271,272),MELE-200
c cccccc
 51   CONTINUE
           GOTO 99
 
  2   CONTINUE
      if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or.
     &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL')  then
        MPTVAL=IVAMAT
        MELVAL=IVAL(1)
        if (ival(/1).gt.1) then
          melva1 = ival(2)
        else
          melva1 = 0
        endif
        jddl = LRE/NBPGAU
        DO IB = 1,NBELEM
* kich 1 pgau inutile
          IGAU = 1
          JDIAG = 0
          IBMN=MIN(IB,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
            if (cmate.eq.'IMPCOMPL') then
             MLREEL=IELCHE(IGMN,IBMN)
             SEGACT MLREEL
             XRAID = prog(1)
            else
              XRAID = VELCHE(IGMN,IBMN)
              XTORS = XRAID
              if (melva1.gt.0) then
                XTORS = melva1.VELCHE(IGMN,IBMN)
              endif
            endif
           do j=1,jddl
            JDIAG = JDIAG + 1
            if (j.le.3) then
             RE(JDIAG,JDIAG,IB) = XRAID
             RE(JDIAG,JDIAG+jddl,IB) = XRAID*(-1.D0)
            else
             RE(JDIAG,JDIAG,IB) = XTORS
             RE(JDIAG,JDIAG+jddl,IB) = XTORS*(-1.D0)
            endif
           enddo
           do j=jddl+1,LRE
            JDIAG = JDIAG + 1
            if (j.le.jddl+3) then
             RE(JDIAG,JDIAG,IB) = XRAID
             RE(JDIAG,JDIAG-jddl,IB) = XRAID*(-1.D0)
            else
             RE(JDIAG,JDIAG,IB) = XTORS
             RE(JDIAG,JDIAG-jddl,IB) = XTORS*(-1.D0)
            endif
           enddo
        ENDDO
        SEGDES XMATRI
       goto 510
      endif
      if (mele.eq.2) goto 99
 
C_______________________________________________________________________
C
C     ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO
C_______________________________________________________________________
C
 
  29  CONTINUE
 
      NBBB=NBNN
      SEGINI WRK1,WRK3
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      KERRE=0
      DO  3029 IB=1,NBELEM
C
C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
C     CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE
C
      IF (MELE.EQ.98) THEN
         CALL ZERO(REL,LRE,LRE)
         GOTO 8029
      ENDIF
C
C     RANGEMENT DES CARACTERISTIQUES DANS WORK
C     SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
C
      NCARR1=NCARR
**    IF(IVECT.EQ.1) NCARR1=NCARR-3
      CALL ZERO(WORK,NCARR1,1)
      DO 4030 IGAU=1,NBNN
      MPTVAL=IVACAR
      DO 6029 IC=1,NCARR1
        IF (IVAL(IC).NE.0) THEN
          MELVAL=IVAL(IC)
          IBMN=MIN(IB,VELCHE(/2))
          IGMN=MIN(IGAU,VELCHE(/1))
          WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
        ELSE
          WORK(IC)=0.D0
        ENDIF
        IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
 6029 CONTINUE
 4030    CONTINUE
C
      MPTVAL=IVAMAT
C
C CAS DE L'ACOUSTIQUE PURE
C
      IF (MELE.EQ.97) THEN
         DO 7029 IM=1,NMATT
           IF (IVAL(IM).NE.0) THEN
             MELVAL=IVAL(IM)
             IBMN=MIN(IB,VELCHE(/2))
             WORK(IM+9)=VELCHE(1,IBMN)
           ELSE
             WORK(IM+9)=0.D0
           ENDIF
 7029    CONTINUE
      ELSE
C
C AUTRES CAS ......
C
        MELVAL=IVAL(1)
*
        IF(CMATE.NE.'SECTION') THEN
 
*   ON RECUPERE LE MODULE D'YOUNG SI IMAT = 1
 
          IF(IMAT.EQ.1) THEN
             IBMN=MIN(IB,VELCHE(/2))
             VALMAT(1)=VELCHE(1,IBMN)
             YOUNG=VALMAT(1)
C
C     ON CHERCHE LES COEFF DES MAT DE HOOKE  SI IMAT = 2
C
          ELSE IF(IMAT.EQ.2) THEN
            MELVAL=IVAL(1)
            IBMN=MIN(IB,IELCHE(/2))
            MLREEL=IELCHE(1,IBMN)
            SEGACT MLREEL
            IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     $       CALL DOHOOO(PROG,LHOOK,DDHOOK)
            SEGDES MLREEL
*
            IF(MELE.EQ.42) THEN
              EPAIS=WORK(1)
              REXT=WORK(2)
              RINT=REXT-EPAIS
              SD =XPI*(REXT**2-RINT**2)
              YOUNG = DDHOOK(1,1)/SD
            ENDIF
          ENDIF
C
C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
C                   EQUIVALENTE
          IF(MELE.EQ.42) THEN
            PRES=WORK(4)
            CISA=WORK(5)
**          write(6,*) 'tuykar ncarr',ncarr,
**   >            work(6),work(7),work(8),work(9),work(10)
            WORK(4)=WORK(6)
            WORK(5)=WORK(7)
            WORK(6)=WORK(8)
            WORK(7)=PRES
            WORK(8)=CISA
            CALL TUYKAR(WORK,KERRE,2,YOUNG)
          ENDIF
          IF (KERRE.EQ.77) THEN
            CALL ERREUR(77)
            GOTO 510
          ENDIF
 
C-------------
C  PROVISOIRE
C-------------
          IF(IMAT.EQ.2) THEN
           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
             WORK(4)=DDHOOK(1,1)/WORK(1)
             WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1)))
           ELSE
*
*ZZZZ  ATTENTION A LA DIVISION PAR 0.
*
            WORK(10)=DDHOOK(1,1)/WORK(4)
*
            IF(ABS(WORK(5)).LT.XPETIT/XZPREC) THEN
             IF(ABS(DDHOOK(2,2)).GE.XPETIT/XZPREC) then
               MOTERR(1:4)='SECY'
               CALL ERREUR(46)
               RETURN
             ELSE
               work(11)=0.d0
             ENDIF
            Else
             WORK(11)=DDHOOK(2,2)/WORK(5)
            ENDIF
           ENDIF
          ELSE IF (IMAT.EQ.1) THEN
*
            DO 9029 IM=1,NMATT
              IF (IVAL(IM).NE.0) THEN
                MELVAL=IVAL(IM)
                IBMN=MIN(IB,VELCHE(/2))
                VALMAT(IM)=VELCHE(1,IBMN)
              ELSE
                VALMAT(IM)=0.D0
              ENDIF
 9029       CONTINUE
            IF(MELE.EQ.84) THEN
             IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
              CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
             ELSE
C
              CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
             ENDIF
            ELSE
              IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
               CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
              ELSE
               CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
              ENDIF
            ENDIF
C-------------
C  PROVISOIRE
C-------------
            IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
              WORK(4)=VALMAT(1)
              AUX=VALMAT(2)
              WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
            ELSE
C
              WORK(10)=VALMAT(1)
              AUX=VALMAT(2)
              WORK(11)=WORK(10)*0.5D0/(1.D0+AUX)
            ENDIF
C-------------
          ENDIF
*
*  CAS DE LA FORMULATION SECTION
*
        ELSE
          IF(IMAT.EQ.2) THEN
            MELVAL=IVAL(1)
            IBMN=MIN(IB,IELCHE(/2))
            MLREEL=IELCHE(1,IBMN)
            SEGACT MLREEL
            IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     $        CALL DOHOOO(PROG,LHOOK,DDHOOK)
            SEGDES MLREEL
C
          ELSE IF (IMAT.EQ.1) THEN
*
*         ON REGARDE SI ON A LA COMPOSANTE MAHO
*         SI OUI, ON LA PREND
*
            IF(IVAL(3).NE.0) THEN
              MELVAL=IVAL(3)
              IBMN=MIN(IB,IELCHE(/2))
              MLREEL=IELCHE(1,IBMN)
              SEGACT MLREEL
              IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     $          CALL DOHOOO(PROG,LHOOK,DDHOOK)
              SEGDES MLREEL
*
            ELSE
              IBMN=MIN(IB,IELCHE(/2))
              IPMODL=IELCHE(1,IBMN)
              MELVAL=IVAL(2)
              IBMN=MIN(IB,IELCHE(/2))
              IPMAT=IELCHE(1,IBMN)
              CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
              IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     $         CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C
C FIN TRAITEMENT DES DONNEES MATERIAUX
C
      IF(MELE.EQ.97) THEN
         CALL ACORIG(REL,LRE,WORK,XE,KERRE)
      ELSE IF(MELE.EQ.84) THEN
         IF(CMATE.NE.'SECTION') THEN
 
           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
             CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE)
           ELSE
             CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE)
           ENDIF
*
         ELSE
           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
             CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,
     $                                      DDHOOK,KERRE)
           ELSE
             CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,
     $                                      DDHOOK,KERRE)
           ENDIF
         ENDIF
      ELSE
           IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
             CALL POURH2(REL,LRE,WORK,XE,WORK(12),IMAT,
     &       LHOOK, DDHOOK, KERRE)
           ELSE
             CALL POURHG(REL,LRE,WORK,XE,WORK(12),IMAT,
     &       LHOOK, DDHOOK, KERRE)
           ENDIF
      ENDIF
C
      IF(KERRE.NE.0) INTERR(1)=ISOUS
      IF(KERRE.NE.0) INTERR(2)=IB
C
 4029 CONTINUE
 8029 CONTINUE
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3029 CONTINUE
      IF(KERRE.EQ.1) CALL ERREUR(128)
      IF(KERRE.EQ.2) CALL ERREUR(138)
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
       return
      ENDIF
      SEGDES XMATRI
      SEGSUP WRK1,WRK3,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     ELEMENTS LINESPRING LISP ET LISM
C_______________________________________________________________________
C
  30  CONTINUE
      NBBB=NBNN
      NSTRS=2
      SEGINI WRK1,WRK3
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      DO 3030 IB=1,NBELEM
C
C     ON CHRCHE LES COORDONNEES DES NOEUDS
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
C     ON CHERCHE LES COEFFS DE LA MATRICE DE HOOKE
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
        MELVAL=IVAL(1)
        IBMN=MIN(IB  ,IELCHE(/2))
        MLREEL=IELCHE(1,IBMN)
        SEGACT MLREEL
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
*
        DO 9030 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
          ENDIF
 9030   CONTINUE
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
      ENDIF
C
C     ON CHERCHE LES CARACTERISTIQUES   ON OUBLIE LE 2 IEME POINT DEGAUS
C
      IE=0
      MPTVAL=IVACAR
      DO  IC=1,3,2
        DO  ID=1,NCARR
          IE=IE+1
          MELVAL=IVAL(ID)
          IGMN=MIN(IC,VELCHE(/1))
          IBMN=MIN(IB,VELCHE(/2))
          WORK(IE)=VELCHE(IGMN,IBMN)
        enddo
      enddo
C
C     CALCUL DE LA RIGIDITE
C
      CALL LISPRI(XE,WORK,DDHOOK,WORK(11),MELE,REL,I70,I343,I157,I158)
C     IF(I70.EQ.1)  INTERR(1)=IB
      IF(I158.EQ.1) INTERR(1)=IB
      IF(I343.EQ.1) INTERR(1)=IB
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3030 CONTINUE
C     IF(I70.EQ.1)  CALL ERREUR(70)
      IF(I158.EQ.1) CALL ERREUR(158)
      IF(I343.EQ.1) CALL ERREUR(343)
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
      SEGDES XMATRI
      SEGSUP WRK1,WRK3,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     ELEMENT TUYAU FISSURE
C_______________________________________________________________________
C
  43  CONTINUE
      NBBB=NBNN
      NSTRS=2
      SEGINI WRK1,WRK3
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      DO  3043 IB=1,NBELEM
C
C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
C
C     ON CHERCHE LES COEFF DES MAT DE HOOKE
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
        MELVAL=IVAL(1)
        IBMN=MIN(IB  ,IELCHE(/2))
        MLREEL=IELCHE(1,IBMN)
        SEGACT MLREEL
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
*
        DO 9043 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
          ENDIF
 9043   CONTINUE
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHFIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
      ENDIF
C
C     CHERCHER LES CARACTERISTIQUES
C
      MPTVAL=IVACAR
      DO 4043 IC=1,NCARR
        MELVAL=IVAL(IC)
        IBMN=MIN(IB,VELCHE(/2))
        WORK(IC)=VELCHE(1,IBMN)
4043  CONTINUE
C
C     ON CALCULE SA RAIDEUR
C
      CALL TUFIRI(REL,WORK(1),DDHOOK,I137)
      IF(I137.NE.0) INTERR(1)=ISOUS
      IF(I137.NE.0) INTERR(2)=IB
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
C
 3043 CONTINUE
      IF(I137.EQ.1) CALL ERREUR(137)
      IF(I137.EQ.2) CALL ERREUR(123)
      IF(I137.EQ.3) CALL ERREUR(266)
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
      SEGDES XMATRI
      SEGSUP WRK1,WRK3,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C      ELEMENT POI1
C_______________________________________________________________________
C
  45  CONTINUE
      if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or.
     &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL') then
 
        MPTVAL=IVAMAT
        MELVAL=IVAL(1)
        if (ival(/1).gt.1) then
          melva1 = ival(2)
        else
          melva1 = 0
        endif
        DO IB = 1,NBELEM
          JDIAG = 0
*          SEGINI XMATRI
*          IMATTT(IB)=XMATRI
          IBMN=MIN(IB,VELCHE(/2))
          do igau = 1,NBPGAU
              IGMN=MIN(IGAU,VELCHE(/1))
              XRAID = VELCHE(IGMN,IBMN)
              XTORS = XRAID
              if (melva1.gt.0) then
                XTORS = melva1.VELCHE(IGMN,IBMN)
              endif
           do j =1,LRE
            JDIAG = JDIAG + 1
            if (j.le.3) then
             RE(JDIAG,JDIAG,IB) = XRAID
            else
             RE(JDIAG,JDIAG,IB) = XTORS
            endif
           enddo
          enddo
*          SEGDES XMATRI
        ENDDO
        SEGDES XMATRI
       goto 510
      endif
 
      IF (CMATE.EQ.'MODAL') THEN
* MODAL
        DO IB = 1,NBELEM
          MPTVAL=IVAMAT
          MELVAL=IVAL(1)
          IBMN=MIN(IB,VELCHE(/2))
          XFREQ=VELCHE(1,IBMN)
          MELVAL=IVAL(2)
          IBMN=MIN(IB,VELCHE(/2))
          XMASS=VELCHE(1,IBMN)
          OMEG = 2. * XPI * XFREQ
          RE(1,1,IB) = XMASS * OMEG * OMEG
cbp-2017-10-02          if (xfreq.lt.0) RE(1,1,IB) = RE(1,1,IB) * (-1.)
          if (XFREQ.LT.0.D0) RE(1,1,IB) = 0.D0
        ENDDO
        GOTO 510
*
 
      ELSE IF (CMATE.EQ.'STATIQUE') THEN
* STATIQUE
        DO IB = 1,NBELEM
          MPTVAL=IVAMAT
          MELVAL=IVAL(1)
          IBMN=MIN(IB,IELCHE(/2))
          idepl=IELCHE(1,IBMN)
          MELVAL=IVAL(2)
          IBMN=MIN(IB,IELCHE(/2))
          itreac=IELCHE(1,IBMN)
          CALL XTY1(idepl,itreac,iinc,idua,X1)
          if (ierr.ne.0) return
          re(1,1,IB) = x1
        ENDDO
        SEGDES XMATRI
        GOTO 510
      ENDIF
*
      IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
        GOTO 99
      ENDIF
      NBBB=NBNN
      SEGINI WRK1,WRK3
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      KERRE=0
      DO 3045 IB=1,NBELEM
C
C  ON CHERCHE LES COORDONNEES DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
C
C  ON RECUPERE LA SECTION DE L'ELEMENT
C
      MPTVAL=IVACAR
      MELVAL=IVAL(1)
      IBMN=MIN(IB,VELCHE(/2))
      SECT=VELCHE(1,IBMN)
C
C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
        MELVAL=IVAL(1)
        IBMN=MIN(IB  ,IELCHE(/2))
        MLREEL=IELCHE(1,IBMN)
        SEGACT MLREEL
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
*
        DO 9045 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
          ENDIF
 9045   CONTINUE
        CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
      ENDIF
      CALL PO1RIG(REL,LRE,DDHOOK(1,1),XE,KERRE,XDPGE,YDPGE)
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3045 CONTINUE
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
      SEGDES XMATRI
      SEGSUP WRK1,WRK3,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     ELEMENTS BARRE ET CERCE
C_______________________________________________________________________
C
  46  CONTINUE
*
      IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
        GO TO 99
      ENDIF
      NBBB=NBNN
      SEGINI WRK1,WRK3
      IF(MELE.EQ.123) THEN
        NSTN=NBNN
        LRN =LRE
        SEGINI WRK5
      ENDIF
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      KERRE=0
      DO 3046 IB=1,NBELEM
C
C  ON CHERCHE LES COORDONNEES DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
C
C  ON RECUPERE LA SECTION DE L'ELEMENT
C
      MPTVAL=IVACAR
      MELVAL=IVAL(1)
      IBMN=MIN(IB,VELCHE(/2))
      SECT=VELCHE(1,IBMN)
C
C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
        MELVAL=IVAL(1)
        IBMN=MIN(IB  ,IELCHE(/2))
        MLREEL=IELCHE(1,IBMN)
        SEGACT MLREEL
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
*
        DO 9046 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
          ENDIF
 9046   CONTINUE
        CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
      ENDIF
      IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
      IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
      IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB)
      IF(KERRE.NE.0) INTERR(1)=ISOUS
      IF(KERRE.NE.0) INTERR(2)=IB
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3046 CONTINUE
      IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128)
      IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
      IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
      SEGDES XMATRI
      SEGSUP WRK1,WRK3,MVELCH
      IF(MELE.EQ.123) SEGSUP WRK5
      GOTO 510
C
C_______________________________________________________________________
C
C     ELEMENT BARRE 3D EXCENTRE (BAEX)
C_______________________________________________________________________
C
 124  CONTINUE
      NBBB=NBNN
      NBNO=NBNN
      NSTRS1=NSTRS
      NSTRS=NBNN
      SEGINI WRK1,WRK2,WRK3
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      KERRE=0
      DO 3108 IB=1,NBELEM
C
C  ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
C  ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
C  SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
C
      MPTVAL=IVACAR
      DO IC=1,NCARR
        IF(IVAL(IC).NE.0) THEN
          MELVAL=IVAL(IC)
          IBMN=MIN(IB,VELCHE(/2))
          WORK(IC)=VELCHE(1,IBMN)
        ELSE
          WORK(IC)=0.D0
        ENDIF
      END DO
      SECT=WORK(1)
C
C     ON CHERCHE LE COEFF DE LA MAT DE HOOKE
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
        MELVAL=IVAL(1)
        IBMN=MIN(IB  ,IELCHE(/2))
        MLREEL=IELCHE(1,IBMN)
        SEGACT MLREEL
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
        DO 9108 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
          ENDIF
 9108   CONTINUE
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
      ENDIF
C
C   BGENE  STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE)
      IF(KERRE.NE.0) INTERR(1)=ISOUS
      IF(KERRE.NE.0) INTERR(2)=IB
      IF(KERRE.EQ.1) CALL ERREUR(128)
      CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE)
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3108 CONTINUE
      NSTRS=NSTRS1
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK3,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     LIA2 : element de liaison a 2 noeuds (6 ddl par noeuds)
C_______________________________________________________________________
C
 125  CONTINUE
      NBBB=NBNN
      NBNO=NBNN
      SEGINI WRK1,WRK2,WRK3,WRK4
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      KERRE=0
      DO  3109 IB=1,NBELEM
C
      MPTVAL=IVACAR
      DO IC=1,NCARR
        IF(IVAL(IC).NE.0) THEN
          MELVAL=IVAL(IC)
          IBMN=MIN(IB,VELCHE(/2))
          WORK(IC)=VELCHE(1,IBMN)
        ELSE
          WORK(IC)=0.D0
        ENDIF
      END DO
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL MAPALI(XE,NBNN,WORK,BPSS,KERRE)
      IF(KERRE.NE.0) INTERR(1)=ISOUS
      IF(KERRE.NE.0) INTERR(2)=IB
      IF(KERRE.EQ.1) CALL ERREUR(128)
      CALL RIGLI2(REL,LRE,BPSS,WORK)
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3109 CONTINUE
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK3,MVELCH
      GOTO 510
*-------------------------------------------------------------
C_______________________________________________________________________
C
C     JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds)
C_______________________________________________________________________
C
 129  CONTINUE
      NBBB=NBNN
      NBNO=NBNN
      SEGINI WRK1,WRK2,WRK3,WRK4
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      KERRE=0
      DO  3110 IB=1,NBELEM
C
        MPTVAL=IVAMAT
 
        IF(IMAT.EQ.2) THEN
 
          MELVAL=IVAL(1)
          IBMN=MIN(IB  ,IELCHE(/2))
          MLREEL=IELCHE(1,IBMN)
          SEGACT MLREEL
          IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
          SEGDES MLREEL
 
          CALL RIGJOL(REL,LRE,DDHOOK,LHOOK,IDIM)
 
          IF(IDIM.EQ.2) THEN
            NCA=2
          ELSE
            NCA=6
          ENDIF
*
          MPTVAL=IVACAR
          DO IC=1,NCA
            IF(IVAL(IC).NE.0) THEN
              MELVAL=IVAL(IC)
              IBMN=MIN(IB,VELCHE(/2))
              WORK(IC)=VELCHE(1,IBMN)
            ELSE
              WORK(IC)=0.D0
            ENDIF
          END DO
          CALL MAPALU(NCA,WORK,BPSS,IDIM)
        ELSE
          DO IC=1,NMATT
            IF(IVAL(IC).NE.0) THEN
              MELVAL=IVAL(IC)
              IBMN=MIN(IB,VELCHE(/2))
              WORK(IC)=VELCHE(1,IBMN)
            ELSE
              WORK(IC)=0.D0
            ENDIF
          END DO
c
c         on calcule la matrice de rigidité locale
c
          CALL RIGJOI(NMATT,REL,LRE,WORK,IDIM,CMATE)
          CALL MAPALU(NMATT,WORK,BPSS,IDIM)
      ENDIF
c
c        on passe en repère global
c
       IAW1=101
       IAW2=IAW1+LRE*LRE
       IAW3=IAW2+LRE*LRE
       IAW4=IAW3+LRE*LRE
       CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2),
     &                 WORK(IAW3),WORK(IAW4),LRE,IDIM)
*
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*
*      SEGDES XMATRI
 3110 CONTINUE
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK3,MVELCH
      GOTO 510
*-------------------------------------------------------------
c
c    element coaxial COS2 (3D pour liaison acier-beton)
c
  271 continue
      NBBB=NBNN
      lw=5
      SEGINI WRK1,WRK4,wrk3
      do 3271 ib= 1,nbelem
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
 
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL ZERO (REL,LRE,LRE)
      CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
      MPTVAL=IVAmat
      if(imat.eq.1) then
      DO IC=1,2
        IF(IVAL(IC).NE.0) THEN
          MELVAL=IVAL(IC)
          IBMN=MIN(IB,VELCHE(/2))
          WORK(ic)=VELCHE(1,IBMN)
        ELSE
          WORK(IC)=0.D0
        ENDIF
      END DO
      ELSE
         MELVAL=IVAL(1)
         IBMN=MIN(IB,IELCHE(/2))
         MLREEL=IELCHE(1,IBMN)
         SEGACT MLREEL
       if(idim.eq.3) then
         work(1)= prog(1)
         work(2) = prog(9)
       else if (idim.eq.1.or.idim.eq.2) then
          CALL ERREUR(81)
       endif
       segdes mlreel
      endif
C
C
C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
         xv1= xe(1,2)-xe(1,1)
         yv1= xe(2,2)-xe(2,1)
         zv1=0.d0
         if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
         xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
C
C recuperation de la section et calcul du diamètre
C
      MPTVAL=IVACAR
      DO 2712 ICOMP=1,NCARR
          MELVAL=IVAL(ICOMP)
          IGMN = VELCHE(/1)
          IBMN=MIN(IB,VELCHE(/2))
          SECA =VELCHE(IGMN,IBMN)
2712  CONTINUE
      diam = sqrt(4.d0*SECA/xpi)
C
      xls1 = (3.d0*xpi*diam*xl)/8.d0
      xls2 = (1.d0*xpi*diam*xl)/8.d0
      xks1 = xls1*work(1)
      xks2 = xls2*work(1)
      xln1 = (3.d0*diam*xl)/8.d0
      xln2 = (1.d0*diam*xl)/8.d0
      xkn1 = xln1*work(2)
      xkn2 = xln2*work(2)
      xks = work(1)
      xkn = work(2)
       if (idim.eq.2) then
C cas de matrice elastique
          rel(1,1)= xks1
          rel(1,3)= xks2
          rel(1,5)= -xks2
          rel(1,7)=-xks1
          rel(7,7)= xks1
          rel(7,1)=-xks1
          rel(7,3)= -xks2
          rel(7,5)= xks2
          rel(3,3)=xks1
          rel(3,5)=-xks1
          rel(3,1)= xks2
          rel(3,7)= -xks2
          rel(5,5)=xks1
          rel(5,3)=-xks1
          rel(5,1)= -xks2
          rel(5,7)= xks2
c ---------------------------
          rel(2,2)= xkn1
          rel(2,4)= xkn2
          rel(2,6)= -xkn2
          rel(2,8)=-xkn1
          rel(8,8)= xkn1
          rel(8,2)=-xkn1
          rel(8,4)= -xkn2
          rel(8,6)= xkn2
          rel(4,4)=xkn1
          rel(4,6)=-xkn1
          rel(4,2)= xkn2
          rel(4,8)= -xkn2
          rel(6,6)=xkn1
          rel(6,4)=-xkn1
          rel(6,2)= -xkn2
          rel(6,8)= xkn2
       else if (idim.eq.3) then
C cas de matrice elastique
          rel(1,1)= xks1
          rel(1,4)= xks2
          rel(1,7)= -xks2
          rel(1,10)=-xks1
          rel(10,10)= xks1
          rel(10,1)=-xks1
          rel(10,4)= -xks2
          rel(10,7)= xks2
          rel(4,4)=xks1
          rel(4,7)=-xks1
          rel(4,1)= xks2
          rel(4,10)= -xks2
          rel(7,7)=xks1
          rel(7,4)=-xks1
          rel(7,1)= -xks2
          rel(7,10)= xks2
C ------- remplissage de KN ------------
          rel(2,2)= xkn1
          rel(2,5)= xkn2
          rel(2,8)= -xkn2
          rel(2,11)=-xkn1
          rel(11,11)= xkn1
          rel(11,2)=-xkn1
          rel(11,5)= -xkn2
          rel(11,8)= xkn2
          rel(5,5)=xkn1
          rel(5,8)=-xkn1
          rel(5,2)= xkn2
          rel(5,11)= -xkn2
          rel(8,8)=xkn1
          rel(8,5)=-xkn1
          rel(8,2)= -xkn2
          rel(8,11)= xkn2
c------------
          rel(3,3)= xkn1
          rel(3,6)= xkn2
          rel(3,9)= -xkn2
          rel(3,12)=-xkn1
          rel(12,12)= xkn1
          rel(12,3)=-xkn1
          rel(12,6)= -xkn2
          rel(12,9)= xkn2
          rel(6,6)=xkn1
          rel(6,9)=-xkn1
          rel(6,3)= xkn2
          rel(6,12)= -xkn2
          rel(9,9)=xkn1
          rel(9,6)=-xkn1
          rel(9,3)= -xkn2
          rel(9,12)= xkn2
       endif
       do  ia = 1, 4
       do  ic = 1,4
         do  io=1,idim
         do  iu=1,idim
           xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
         enddo
         enddo
         call prodt(xpb,xpa,bpss,idim,idim)
         do io=1,idim
         do iu=1,idim
            rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
         enddo
         enddo
       enddo
       enddo
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(RELL,LRE,RE(1,1,IB))
 3271 continue
      SEGDES XMATRI
      SEGSUP WRK1,WRK3,WRK4
      GOTO 510
c cccccc
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE COA2
C
C_______________________________________________________________________
C
  272 continue
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO 2721  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
      CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
      CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
      DO 2722  IGAU=1,NBPGAU
C
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
      CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
     .               BGENE,DJAC,IRRT,IDIM,NBNN,NSTRS,LRE)
      IF(IRRT.NE.0) THEN
             INTERR(1)=IB
             CALL ERREUR(764)
             GOTO 9985
      ENDIF
 
C
C
C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      xv1= xe(1,2)-xe(1,1)
      yv1= xe(2,2)-xe(2,1)
      zv1=0.d0
      if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
      xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
C
C recuperation de la section et calcul du diamètre
C
      MPTVAL=IVACAR
      DO 2729 ICOMP=1,NCARR
          MELVAL=IVAL(ICOMP)
          IGMN = VELCHE(/1)
          IBMN=MIN(IB,VELCHE(/2))
          SECA =VELCHE(IGMN,IBMN)
2729  CONTINUE
      diam = sqrt(4.d0*SECA/xpi)
C
      DJAC=DJAC*POIGAU(IGAU)
C
C     CALCUL DE LA MATRICE DE HOOK
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
          MELVAL=IVAL(1)
          IBMN=MIN(IB  ,IELCHE(/2))
          IGMN=MIN(IGAU,IELCHE(/1))
          MLREEL=IELCHE(IGMN,IBMN)
          SEGACT MLREEL
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOHOCO(PROG,LHOOK,DDHOOK,XL,DIAM)
          SEGDES MLREEL
        ELSE IF (IMAT.EQ.1) THEN
          DO 2723 IM=1,NMATT
            IF (IVAL(IM).NE.0) THEN
              MELVAL=IVAL(IM)
              IBMN=MIN(IB  ,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
              VALMAT(IM)=VELCHE(IGMN,IBMN)
            ELSE
              VALMAT(IM)=0.D0
            ENDIF
 2723     CONTINUE
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1     CALL DOUCO2(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD,XL,DIAM)
        END IF
C
C     CALCUL ET INTEGRATION DE BDB
C
      CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
 
 
 2722 CONTINUE
C
      do  ia = 1,4
      do  ic = 1,4
         do  io=1,idim
         do  iu=1,idim
           xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
         enddo
         enddo
         call prodt(xpb,xpa,bpss,idim,idim)
         do io=1,idim
         do iu=1,idim
            rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
         enddo
         enddo
      enddo
      enddo
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(RELL,LRE,RE(1,1,IB))
 2721 CONTINUE
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
c      SEGDES XMATRI
 9985 CONTINUE
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
*-----------------------------------------------------------------------
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JOI2
C
C_______________________________________________________________________
C
  85  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO 3085  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
      CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
      CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
C
CCC      IF (NOQUAL.EQ.1) THEN
CCCC                      NOEUDS TROP VOISINS
CCC         INTERR(1)=IB
CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
CCC         CALL ERREUR(323)
CCC      ELSE IF ( NOQUAL.EQ.2 ) THEN
CCCC                      JOINT NON PLAN
CCC         INTERR(1)=IB
CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
CCC         CALL ERREUR(323)
CCC         RETURN
CCC      ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      DO 4085  IGAU=1,NBPGAU
C
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
      CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
     +                                BGENE,DJAC,IRRT)
      DJAC=DJAC*POIGAU(IGAU)
 
*
      IF (IFOUR.EQ.0) THEN
C
C     EN AXISYMETRIE, ON MULTIPLIE PAR R
C     (R=RAYON DE COURBURE DU POINT DE GAUSS)
C
        RAYON=0.0D0
        NUMSUP=NBNO/2
*
        DO 5085 IRAY=1,NUMSUP
          RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
 5085   CONTINUE
* modif TC
*          dr =  XE(1,2)-xe(1,1)
*          ra= XE(1,1)
*          rb= XE(1,2)
*          rayona =  rb*rb*rb/6.d0 - 0.5d0*ra*ra*rb +ra*ra*ra /3.d0
*          rayona=rayona *2.d0 /dr / dr
*          rayonb= rb*rb*rb/3.d0 - 0.5d0*ra*rb*rb +ra*ra*ra /6.d0
*         rayonb=rayonb *2.d0 / dr / dr
 
*        rayon= rayona
*        if(igau.eq.2) rayon=rayonb
        DJAC=DJAC*RAYON
      ENDIF
C
C     IRRT=1 JACOBIEN <= 0
      IF(IRRT.NE.0) THEN
         INTERR(1)=IB
         CALL ERREUR(612)
      ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
          MELVAL=IVAL(1)
          IBMN=MIN(IB  ,IELCHE(/2))
          IGMN=MIN(IGAU,IELCHE(/1))
          MLREEL=IELCHE(IGMN,IBMN)
          SEGACT MLREEL
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
          SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
          DO 9085 IM=1,NMATT
            IF (IVAL(IM).NE.0) THEN
              MELVAL=IVAL(IM)
              IBMN=MIN(IB  ,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
              VALMAT(IM)=VELCHE(IGMN,IBMN)
            ELSE
              VALMAT(IM)=0.D0
            ENDIF
 9085     CONTINUE
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
      ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
      CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
 4085 CONTINUE
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3085 CONTINUE
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JGI2
C
C_______________________________________________________________________
C
  170 CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
        CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
        CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU
C
C        ON CHERCHE L EPAISSEUR DU JOINT
C
          EPAIST=0.D0
          MPTVAL=IVACAR
          MELVAL=IVAL(1)
          IF (MELVAL.NE.0) THEN
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB,VELCHE(/2))
            EPAIST=VELCHE(IGMN,IBMN)
          ENDIF
C
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
CcPPj     CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
CcPPj.                         EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
          CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
     .                         EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
          DJAC=DJAC*POIGAU(IGAU)
C
          IF (IFOUR.EQ.0) THEN
C
C     EN AXISYMETRIE, ON MULTIPLIE PAR R
C     (R=RAYON DE COURBURE DU POINT DE GAUSS)
C
            RAYON=0.0D0
            NUMSUP=NBNO/2
            DO IRAY=1,NUMSUP
               RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
            ENDDO
            DJAC=DJAC*RAYON
          ENDIF
C
C         IRRT=1 JACOBIEN <= 0
          IF(IRRT.NE.0) THEN
             INTERR(1)=IB
             CALL ERREUR(612)
          ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
          MPTVAL=IVAMAT
          IF(IMAT.EQ.2) THEN
              MELVAL=IVAL(1)
              IBMN=MIN(IB  ,IELCHE(/2))
              IGMN=MIN(IGAU,IELCHE(/1))
              MLREEL=IELCHE(IGMN,IBMN)
              SEGACT MLREEL
              IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1         CALL DOHOOO(PROG,LHOOK,DDHOOK)
              SEGDES MLREEL
          ELSE IF (IMAT.EQ.1) THEN
              DO IM=1,NMATT
                IF (IVAL(IM).NE.0) THEN
                  MELVAL=IVAL(IM)
                  IBMN=MIN(IB  ,VELCHE(/2))
                  IGMN=MIN(IGAU,VELCHE(/1))
                  VALMAT(IM)=VELCHE(IGMN,IBMN)
                ELSE
                  VALMAT(IM)=0.D0
                ENDIF
              ENDDO
              IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1         CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
          ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
          CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
        ENDDO
C
*        SEGINI XMATRI
*        IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
        CALL REMPMT(REL,LRE,RE(1,1,IB))
*        SEGDES XMATRI
      ENDDO
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JCT3 en 2D cisaillement
C
C_______________________________________________________________________
C
  168 CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
        CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
        CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
C
        IF (NOQUAL.EQ.1) THEN
           INTERR(1)=IB
           MOTERR(1:4) = 'JGT3'
           CALL ERREUR(765)
           RETURN
        ELSE IF ( NOQUAL.EQ.2) THEN
           INTERR(1)=IB
           MOTERR(1:4) = 'JGT3'
           CALL ERREUR(766)
           RETURN
        ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU
C               4
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
          CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
     +                               BGENE,DJAC,IRRT)
          DJAC=DJAC*POIGAU(IGAU)
C     IRRT=1 JACOBIEN <= 0
          IF(IRRT.NE.0) THEN
             CALL ERREUR(764)
          ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
          MPTVAL=IVAMAT
          IF(IMAT.EQ.2) THEN
            MELVAL=IVAL(1)
            IBMN=MIN(IB  ,IELCHE(/2))
            IGMN=MIN(IGAU,IELCHE(/1))
            MLREEL=IELCHE(IGMN,IBMN)
            SEGACT MLREEL
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
            SEGDES MLREEL
          ELSE IF (IMAT.EQ.1) THEN
            DO IM=1,NMATT
              IF (IVAL(IM).NE.0) THEN
                MELVAL=IVAL(IM)
                IBMN=MIN(IB  ,VELCHE(/2))
                IGMN=MIN(IGAU,VELCHE(/1))
                VALMAT(IM)=VELCHE(IGMN,IBMN)
              ELSE
                VALMAT(IM)=0.D0
              ENDIF
            ENDDO
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
          ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
          CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
        ENDDO
C
*        SEGINI XMATRI
*        IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
        CALL REMPMT(REL,LRE,RE(1,1,IB))
*        SEGDES XMATRI
      ENDDO
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JGT3 GENERALISE
C
C_______________________________________________________________________
C
  171 CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
        CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
        CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
C
        IF (NOQUAL.EQ.1) THEN
           INTERR(1)=IB
           MOTERR(1:4) = 'JGT3'
           CALL ERREUR(765)
           RETURN
        ELSE IF ( NOQUAL.EQ.2) THEN
           INTERR(1)=IB
           MOTERR(1:4) = 'JGT3'
           CALL ERREUR(766)
           RETURN
        ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU
C
C  ON CHERCHE L'EPAISSEUR DU JOINT
C
          EPAIST=0.D0
          MPTVAL=IVACAR
          MELVAL=IVAL(1)
          IF (MELVAL.NE.0) THEN
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB,VELCHE(/2))
            EPAIST=VELCHE(IGMN,IBMN)
          ENDIF
C               4
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
CcPPj     CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
          CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
     +                               EPAIST,BGENE,DJAC,IRRT)
          DJAC=DJAC*POIGAU(IGAU)
C     IRRT=1 JACOBIEN <= 0
          IF(IRRT.NE.0) THEN
             CALL ERREUR(764)
          ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
          MPTVAL=IVAMAT
          IF(IMAT.EQ.2) THEN
            MELVAL=IVAL(1)
            IBMN=MIN(IB  ,IELCHE(/2))
            IGMN=MIN(IGAU,IELCHE(/1))
            MLREEL=IELCHE(IGMN,IBMN)
            SEGACT MLREEL
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
            SEGDES MLREEL
          ELSE IF (IMAT.EQ.1) THEN
            DO IM=1,NMATT
              IF (IVAL(IM).NE.0) THEN
                MELVAL=IVAL(IM)
                IBMN=MIN(IB  ,VELCHE(/2))
                IGMN=MIN(IGAU,VELCHE(/1))
                VALMAT(IM)=VELCHE(IGMN,IBMN)
              ELSE
                VALMAT(IM)=0.D0
              ENDIF
            ENDDO
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
          ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
          CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
        ENDDO
C
*        SEGINI XMATRI
*        IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
        CALL REMPMT(REL,LRE,RE(1,1,IB))
*        SEGDES XMATRI
      ENDDO
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JCI4 en 2D cisaillement
C
C_______________________________________________________________________
C
  169 CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
        CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
        CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
 
        IF (NOQUAL.EQ.1) THEN
          INTERR(1)=IB
          MOTERR(1:4) = 'JCI4'
          CALL ERREUR(765)
          RETURN
        ELSE IF ( NOQUAL.EQ.2 ) THEN
          INTERR(1)=IB
          MOTERR(1:4) = 'JCI4'
          CALL ERREUR(766)
          RETURN
        ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU
C
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
          CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
          DJAC=DJAC*POIGAU(IGAU)
C     IRRT=1 JACOBIEN <= 0
          IF(IRRT.NE.0) THEN
            INTERR(1)=IB
            CALL ERREUR(611)
          ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
          MPTVAL=IVAMAT
          IF(IMAT.EQ.2) THEN
            MELVAL=IVAL(1)
            IBMN=MIN(IB  ,IELCHE(/2))
            IGMN=MIN(IGAU,IELCHE(/1))
            MLREEL=IELCHE(IGMN,IBMN)
            SEGACT MLREEL
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
            SEGDES MLREEL
          ELSE IF (IMAT.EQ.1) THEN
            DO IM=1,NMATT
              IF (IVAL(IM).NE.0) THEN
                MELVAL=IVAL(IM)
                IBMN=MIN(IB  ,VELCHE(/2))
                IGMN=MIN(IGAU,VELCHE(/1))
                VALMAT(IM)=VELCHE(IGMN,IBMN)
              ELSE
                VALMAT(IM)=0.D0
              ENDIF
            ENDDO
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
          ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
          CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
        ENDDO
C
*        SEGINI XMATRI
*        IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
        CALL REMPMT(REL,LRE,RE(1,1,IB))
*        SEGDES XMATRI
      ENDDO
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JGI4 GENERALISE
C
C_______________________________________________________________________
C
  172 CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
        CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
        CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
 
        IF (NOQUAL.EQ.1) THEN
          INTERR(1)=IB
          MOTERR(1:4) = 'JGI4'
          CALL ERREUR(765)
          RETURN
        ELSE IF ( NOQUAL.EQ.2 ) THEN
CbPPj     INTERR(1)=IB
CbPPj     MOTERR(1:4) = 'JGI4'
CbPPj     CALL ERREUR(766)
CbPPj     RETURN
          WRITE(IOIMP,*)'RIGI4(WARNING): JGI4 element number',IB,
     .                  ' not planar'
        ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
        DO IGAU=1,NBPGAU
C
C  ON CHERCHE L'EPAISSEUR DU JOINT
C
          EPAIST=0.D0
          MPTVAL=IVACAR
          MELVAL=IVAL(1)
          IF (MELVAL.NE.0) THEN
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB,VELCHE(/2))
            EPAIST=VELCHE(IGMN,IBMN)
          ENDIF
C
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
CcPPj     CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT)
          CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,
     .                                                           IRRT)
          DJAC=DJAC*POIGAU(IGAU)
C     IRRT=1 JACOBIEN <= 0
          IF(IRRT.NE.0) THEN
            INTERR(1)=IB
            CALL ERREUR(611)
          ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
          MPTVAL=IVAMAT
          IF(IMAT.EQ.2) THEN
            MELVAL=IVAL(1)
            IBMN=MIN(IB  ,IELCHE(/2))
            IGMN=MIN(IGAU,IELCHE(/1))
            MLREEL=IELCHE(IGMN,IBMN)
            SEGACT MLREEL
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOHOOO(PROG,LHOOK,DDHOOK)
            SEGDES MLREEL
          ELSE IF (IMAT.EQ.1) THEN
            DO IM=1,NMATT
              IF (IVAL(IM).NE.0) THEN
                MELVAL=IVAL(IM)
                IBMN=MIN(IB  ,VELCHE(/2))
                IGMN=MIN(IGAU,VELCHE(/1))
                VALMAT(IM)=VELCHE(IGMN,IBMN)
              ELSE
                VALMAT(IM)=0.D0
              ENDIF
            ENDDO
            IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1       CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
          ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
          CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
        ENDDO
C
*        SEGINI XMATRI
*        IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
        CALL REMPMT(REL,LRE,RE(1,1,IB))
*        SEGDES XMATRI
      ENDDO
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JOI3 SANS TEST DE PLANEITE
C                                    ET SANS REPERE LOCAL
C
C_______________________________________________________________________
C
  86  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO 3086  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
      CALL ZERO (REL,LRE,LRE)
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      DO 4086  IGAU=1,NBPGAU
C
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
 
      CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS)
      CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
     +                               BGENE,DJAC,IRRT)
      DJAC=DJAC*POIGAU(IGAU)
*
      IF (IFOUR.EQ.0) THEN
C
C     EN AXISYMETRIE, ON MULTIPLIE PAR R
C     (R=RAYON DE COURBURE DU POINT DE GAUSS)
C
        RAYON=0.0D0
        NUMSUP=NBNO/2
        DO 5086 IRAY=1,NUMSUP
           RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
 5086   CONTINUE
        DJAC=DJAC*RAYON
      ENDIF
C
C     IRRT=1 JACOBIEN <= 0
      IF(IRRT.NE.0) THEN
         INTERR(1)=IB
         CALL ERREUR(612)
      ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
          MELVAL=IVAL(1)
          IBMN=MIN(IB  ,IELCHE(/2))
          IGMN=MIN(IGAU,IELCHE(/1))
          MLREEL=IELCHE(IGMN,IBMN)
          SEGACT MLREEL
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
          SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
          DO 9086 IM=1,NMATT
            IF (IVAL(IM).NE.0) THEN
              MELVAL=IVAL(IM)
              IBMN=MIN(IB  ,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
              VALMAT(IM)=VELCHE(IGMN,IBMN)
            ELSE
              VALMAT(IM)=0.D0
            ENDIF
 9086     CONTINUE
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
      ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
      CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
 4086 CONTINUE
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3086 CONTINUE
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JOT3
C
C_______________________________________________________________________
C
  87  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO 3087  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
      CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
      CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
C
      IF (NOQUAL.EQ.1) THEN
         INTERR(1)=IB
         MOTERR(1:4) = 'JOT3'
         CALL ERREUR(765)
         RETURN
      ELSE IF ( NOQUAL.EQ.2) THEN
         INTERR(1)=IB
         MOTERR(1:4) = 'JOT3'
         CALL ERREUR(766)
         RETURN
      ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      DO 4087  IGAU=1,NBPGAU
C               4
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
      CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
     +                               BGENE,DJAC,IRRT)
      DJAC=DJAC*POIGAU(IGAU)
C     IRRT=1 JACOBIEN <= 0
      IF(IRRT.NE.0) THEN
         CALL ERREUR(764)
      ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
          MELVAL=IVAL(1)
          IBMN=MIN(IB  ,IELCHE(/2))
          IGMN=MIN(IGAU,IELCHE(/1))
          MLREEL=IELCHE(IGMN,IBMN)
          SEGACT MLREEL
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
          SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
          DO 9087 IM=1,NMATT
            IF (IVAL(IM).NE.0) THEN
              MELVAL=IVAL(IM)
              IBMN=MIN(IB  ,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
              VALMAT(IM)=VELCHE(IGMN,IBMN)
            ELSE
              VALMAT(IM)=0.D0
            ENDIF
 9087     CONTINUE
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
      ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
      CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
 4087 CONTINUE
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3087 CONTINUE
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LE JOI4
C
C_______________________________________________________________________
C
  88  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO 3088  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
      CALL ZERO (REL,LRE,LRE)
C
C     CALCUL DES AXES LOCAUX
C
      CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
 
      IF (NOQUAL.EQ.1) THEN
         INTERR(1)=IB
         MOTERR(1:4) = 'JOI4'
         CALL ERREUR(765)
         RETURN
      ELSE IF ( NOQUAL.EQ.2 ) THEN
         INTERR(1)=IB
         MOTERR(1:4) = 'JOI4'
         CALL ERREUR(766)
         RETURN
      ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      DO 4088  IGAU=1,NBPGAU
C
C     CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
C
      CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
      DJAC=DJAC*POIGAU(IGAU)
C     IRRT=1 JACOBIEN <= 0
      IF(IRRT.NE.0) THEN
         INTERR(1)=IB
         CALL ERREUR(611)
      ENDIF
C
C     CALCUL DE LA MATRICE DE HOOK
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
          MELVAL=IVAL(1)
          IBMN=MIN(IB  ,IELCHE(/2))
          IGMN=MIN(IGAU,IELCHE(/1))
          MLREEL=IELCHE(IGMN,IBMN)
          SEGACT MLREEL
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOHOOO(PROG,LHOOK,DDHOOK)
          SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
          DO 9088 IM=1,NMATT
            IF (IVAL(IM).NE.0) THEN
              MELVAL=IVAL(IM)
              IBMN=MIN(IB  ,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
              VALMAT(IM)=VELCHE(IGMN,IBMN)
            ELSE
              VALMAT(IM)=0.D0
            ENDIF
 9088     CONTINUE
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
      ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
      CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
 4088 CONTINUE
C
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3088 CONTINUE
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISE  TRIH
C_______________________________________________________________________
C
  92  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      LRN =NBNN
      NSTN=3
      SEGINI WRK1,WRK2 ,WRK5
      I195=0
      DO 3092  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL ZERO (REL,LRE,LRE)
*
        MPTVAL=IVAMAT
        DO 9092 IM=1,10
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
 
          ENDIF
 9092   CONTINUE
C
C     ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
C
      RHOF  =VALMAT(4)
      E     =VALMAT(6)
      C     =VALMAT(7)
      RHOREF=VALMAT(8)
      CREF  =VALMAT(9)
      RLCAR =VALMAT(10)
C
C     ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
C
      MPTVAL=IVACAR
      IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
        MELVAL=IVAL(1)
          IBMN=MIN(IB,VELCHE(/2))
          SCEL  =VELCHE(1,IBMN)
        MELVAL=IVAL(2)
          IBMN=MIN(IB,VELCHE(/2))
          SFLU  =VELCHE(1,IBMN)
        MELVAL=IVAL(3)
          IBMN=MIN(IB,VELCHE(/2))
          EPS   =VELCHE(1,IBMN)
        MELVAL=IVAL(4)
          IBMN=MIN(IB,VELCHE(/2))
          XINERT=VELCHE(1,IBMN)
        EI = E*XINERT/(EPS*EPS)
      ELSE
        MELVAL=IVAL(1)
          IBMN=MIN(IB,VELCHE(/2))
          SCEL  =VELCHE(1,IBMN)
        MELVAL=IVAL(2)
          IBMN=MIN(IB,VELCHE(/2))
          SFLU  =VELCHE(1,IBMN)
        MELVAL=IVAL(3)
          IBMN=MIN(IB,VELCHE(/2))
          EPS   =VELCHE(1,IBMN)
C       E REPRESENTE LA RIGIDITE MODALE DE LA POUTRE
        EI = E /(EPS*EPS)
      ENDIF
C
C     CALCUL DES COEFFICIENTS DE NORMALISATION
C
      COEFPR=(RHOREF*CREF*CREF)/RLCAR
      VKL1  =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
      VKL2  = EI/SCEL
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4092  IGAU=1,NBPGAU
      CALL TRIHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
     #                      SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
      IF(IRRT.NE.1) GOTO 5092
      DJAC=DJAC*POIGAU(IGAU)
      CALL TRIHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
 4092 CONTINUE
      IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3092 CONTINUE
C
C     IMPRESSION D  UN EVENTUEL MESSAGE D ERREUR
C
 5092 CONTINUE
      IF(IRRT.EQ.0) THEN
      MOTERR(1:4)=NOMTP(MELE)
      CALL ERREUR(420)
      ELSE
      IF(IRRT.EQ.2) THEN
      INTERR(1)=IB
      CALL ERREUR(405)
      ENDIF
      ENDIF
      IF(I195.NE.0) INTERR(1)=I195
      IF(I195.NE.0) CALL ERREUR(195)
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK5,MVELCH
      GOTO 510
*_______________________________________________________________________
*
*     ELEMENT  TUYO
*_______________________________________________________________________
*
  96  CONTINUE
      NBNO=IPORE
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK3,WRK6
C
C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
C
      DO  3096 IB=1,NBELEM
      KERRE=0
C
C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL ZERO (REL,LRE,LRE)
*
      XL=(XE(1,2)-XE(1,1))**2+(XE(2,2)-XE(2,1))**2+
     .   (XE(3,2)-XE(3,1))**2
      XL=SQRT(XL)
      IF(XL.EQ.0.D0) THEN
        KERRE=1
        GO TO 3096
      ENDIF
C
C     RANGEMENT DES CARACTERISTIQUES DANS WORK
C     ON SUPPOSE QU'ELLES SONT CONSTANTES POUR L'ELEMENT
C     VX VY VZ sont supposes etre a la fin
C
**    write(6,*) 'rigi4 en 2695'
      MPTVAL=IVACAR
      DO 6096 IC=1,NCARR
        IF (IVAL(IC).NE.0) THEN
          MELVAL=IVAL(IC)
          IBMN=MIN(IB,VELCHE(/2))
          WORK(IC)=VELCHE(1,IBMN)
        ELSE
          WORK(IC)=0.D0
        ENDIF
 6096 CONTINUE
C
C     TRAITEMENT DU VECTEUR
C
**      IF (IVAL(NCARR).NE.0) THEN
**        MELVAL=IVAL(NCARR)
**        IBMN=MIN(IB,IELCHE(/2))
**        IP=IELCHE(1,IBMN)
**        IREF=(IP-1)*(IDIM+1)
**        DO 6196 IC=1,IDIM
**          WORK(NCARR+IC-1)=XCOOR(IREF+IC)
*6196     CONTINUE
**      ELSE
**        DO 6296 IC=1,IDIM
**          WORK(NCARR+IC-1)=0.D0
*6296     CONTINUE
**      ENDIF
C
C     CALCUL DU REPERE LOCAL
C
      CALL TUYPAS(XE,XL,WORK,PSS,KERRE)
      IF(KERRE.NE.0) THEN
         INTERR(1)=IB
         CALL ERREUR(5 )
         RETURN
      ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      DO 4096  IGAU=1,NBPGAU
C
C     TRAITEMENT DU MATERIAU
C     IL PEUT VARIER D'UN POINT DE GAUSS A L'AUTRE
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
        MELVAL=IVAL(1)
        IGMN=MIN(IGAU,VELCHE(/1))
        IBMN=MIN(IB  ,IELCHE(/2))
        MLREEL=IELCHE(IGMN,IBMN)
        SEGACT MLREEL
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     .      CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
*
      ELSE IF (IMAT.EQ.1) THEN
*
        DO 9096 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IGMN=MIN(IGAU,VELCHE(/1))
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(IGMN,IBMN)
          ELSE
            VALMAT(IM)=0.D0
          ENDIF
 9096   CONTINUE
        CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
        EPAIST=WORK(1)
        CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
      ENDIF
*
*     CALCUL DE LA MATRICE B ET DU JACOBIEN
*
      CALL BTUYO(IGAU,MINTE,WRK1,WRK2,WRK3,XL,DJAC,KERRE)
      DJAC=DJAC*POIGAU(IGAU)
*
      IF(KERRE.NE.0) THEN
         INTERR(1)=IB
         CALL ERREUR(5)
      ENDIF
*
*     CALCUL ET INTEGRATION DE BTDB
*
      CALL BDBST(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL)
 4096 CONTINUE
*
*    CHANGEMENT DE BASE
*
      CALL TUYROT(REL,LRE,PSS,1)
*
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3096 CONTINUE
      IF(KERRE.EQ.1) CALL ERREUR(128)
      IF(KERRE.EQ.2) CALL ERREUR(138)
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
       return
      ENDIF
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK3,WRK6,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES  QUAH
C_______________________________________________________________________
C
 126  CONTINUE
C
      NBNO=NBNN
      NBBB=NBNN
      LRN =NBNN+NBNN
      NSTN=2
      SEGINI WRK1,WRK2 ,WRK5
      I195=0
      DO 3126  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL ZERO (REL,LRE,LRE)
*
        MPTVAL=IVAMAT
        DO 9126 IM=1,10
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
 
          ENDIF
 9126   CONTINUE
C
C     ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
C
      RHOF  =VALMAT(4)
 
      E     =VALMAT(6)
 
      C     =VALMAT(7)
 
      RHOREF=VALMAT(8)
 
      CREF  =VALMAT(9)
 
      RLCAR =VALMAT(10)
 
C
C     ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
C
      MPTVAL=IVACAR
        MELVAL=IVAL(1)
          IBMN=MIN(IB,VELCHE(/2))
          SCEL  =VELCHE(1,IBMN)
 
        MELVAL=IVAL(2)
          IBMN=MIN(IB,VELCHE(/2))
          SFLU  =VELCHE(1,IBMN)
 
        MELVAL=IVAL(3)
          IBMN=MIN(IB,VELCHE(/2))
          EPS   =VELCHE(1,IBMN)
 
        MELVAL=IVAL(5)
          IBMN=MIN(IB,VELCHE(/2))
          XINERT=VELCHE(1,IBMN)
          EI = E*XINERT/(EPS*EPS)
C
C     CALCUL DES COEFFICIENTS DE NORMALISATION
C
      COEFPR=(RHOREF*CREF*CREF)/RLCAR
      VKL1  =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
      VKL2  = EI/SCEL
C
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4126  IGAU=1,NBPGAU
      CALL QUAHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
     #                      SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
      IF(IRRT.NE.1) GOTO 5126
      DJAC=DJAC*POIGAU(IGAU)
      CALL QUAHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
 4126 CONTINUE
      IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3126 CONTINUE
C
C     IMPRESSION D  UN EVENTUEL MESSAGE D ERREUR
C
 5126 CONTINUE
      IF(IRRT.EQ.0) THEN
      MOTERR(1:4)=NOMTP(MELE)
      CALL ERREUR(420)
      ELSE
      IF(IRRT.EQ.2) THEN
      INTERR(1)=IB
      CALL ERREUR(405)
      ENDIF
      ENDIF
      IF(I195.NE.0) INTERR(1)=I195
      IF(I195.NE.0) CALL ERREUR(195)
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK5,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES  CUBH
C_______________________________________________________________________
C
 127  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      LRN =NBNN*2
      NSTN=2
C
      SEGINI WRK1,WRK2 ,WRK5
      I195=0
      DO 3127  IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
      CALL ZERO (REL,LRE,LRE)
*
        MPTVAL=IVAMAT
        DO 9127 IM=1,10
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=0.D0
 
          ENDIF
 9127   CONTINUE
C
C     ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
C
      RHOF  =VALMAT(4)
 
      E     =VALMAT(6)
 
      C     =VALMAT(7)
 
      RHOREF=VALMAT(8)
 
      CREF  =VALMAT(9)
 
      RLCAR =VALMAT(10)
C
C     ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
C
      MPTVAL=IVACAR
        MELVAL=IVAL(1)
          IBMN=MIN(IB,VELCHE(/2))
          SCEL  =VELCHE(1,IBMN)
 
        MELVAL=IVAL(2)
          IBMN=MIN(IB,VELCHE(/2))
          SFLU  =VELCHE(1,IBMN)
 
        MELVAL=IVAL(3)
          IBMN=MIN(IB,VELCHE(/2))
          EPS   =VELCHE(1,IBMN)
 
        MELVAL=IVAL(5)
          IBMN=MIN(IB,VELCHE(/2))
          XINERT=VELCHE(1,IBMN)
        EI = E*XINERT/(EPS*EPS)
C
C     CALCUL DES COEFFICIENTS DE NORMALISATION
C
      COEFPR=(RHOREF*CREF*CREF)/RLCAR
      VKL1  =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
      VKL2  = EI/SCEL
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4127  IGAU=1,NBPGAU
      CALL CUBHR1(IGAU,MELE,MFR,NBNO,NIFOUR,XE,SHPTOT,
     #                      SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
      IF(IRRT.NE.1) GOTO 5127
      DJAC=DJAC*POIGAU(IGAU)
C
C
      CALL CUBHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
 4127 CONTINUE
      IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
*      SEGINI XMATRI
*      IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
*      SEGDES XMATRI
 3127 CONTINUE
C
C     IMPRESSION D  UN EVENTUEL MESSAGE D ERREUR
C
 5127 CONTINUE
      IF(IRRT.EQ.0) THEN
      MOTERR(1:4)=NOMTP(MELE)
      CALL ERREUR(420)
      ELSE
      IF(IRRT.EQ.2) THEN
      INTERR(1)=IB
      CALL ERREUR(405)
      ENDIF
      ENDIF
      IF(I195.NE.0) INTERR(1)=I195
      IF(I195.NE.0) CALL ERREUR(195)
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK5,MVELCH
      GOTO 510
 
C_______________________________________________________________________
C
C     ELEMENTS  CIFL   MACRO ELEMENT CISAILLEMENT FLEXION
C
C_______________________________________________________________________
C
 258  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK3,WRK4
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
      DO IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
        CALL ZERO (REL,LRE,LRE)
C
C     PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX
C
         CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE)
C
C     CALCUL DE LA MATRICE DE HOOK
C
          MPTVAL=IVAMAT
          IF(IMAT.EQ.2) THEN
              MELVAL=IVAL(1)
              IGMN=MIN(1,IELCHE(/1))
              MLREEL=IELCHE(IGMN,IBMN)
              SEGACT MLREEL
              IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1         CALL DOHOOO(PROG,LHOOK,DDHOOK)
              SEGDES MLREEL
          ELSE IF (IMAT.EQ.1) THEN
              DO IM=1,NMATT
                IF (IVAL(IM).NE.0) THEN
                  MELVAL=IVAL(IM)
                  IBMN=MIN(IB  ,VELCHE(/2))
                  VALMAT(IM)=VELCHE(1,IBMN)
                ELSE
                  VALMAT(IM)=0.D0
                ENDIF
              ENDDO
C
              MPTVAL=IVACAR
              DO IC=1,NCARR
                IF (IVAL(IC).NE.0) THEN
                  MELVAL=IVAL(IC)
                  IBMN=MIN(IB,VELCHE(/2))
                  WORK(IC)=VELCHE(1,IBMN)
                ELSE
                  WORK(IC)=0.D0
                ENDIF
              ENDDO
C
              CALL DOHMUR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
          ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
          DDHOOK(1,1)=DDHOOK(1,1)/(XH/2)
          DDHOOK(2,2)=DDHOOK(2,2)/(XH/2)
          DDHOOK(3,3)=DDHOOK(3,3)/ XH
          DDHOOK(4,4)=DDHOOK(4,4)/(XH/2)
          DDHOOK(5,5)=DDHOOK(5,5)/(XH/2)
          CALL BDBST(BGENE,1.D0,DDHOOK,LRE,NSTRS,REL)
C
*        SEGINI XMATRI
*        IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
        CALL REMPMT(REL,LRE,RE(1,1,IB))
*        SEGDES XMATRI
      ENDDO
C
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK3,WRK4,MVELCH
      GOTO 510
C_______________________________________________________________________
C
C   ELEMENT DE COQUE VOLUMIQUE SHB8
C_______________________________________________________________________
C
  260 CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4,WRK7,MVELCH
C
C     BOUCLE POUR TOUS LES ELEMENTS
C
       DO IB=1,NBELEM
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
        CALL ZERO (REL,LRE,LRE)
 
         MPTVAL=IVAMAT
         DO 9070 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            VALMAT(IM)=VELCHE(1,IBMN)
          ELSE
            VALMAT(IM)=XZERO
          ENDIF
 9070   CONTINUE
 
         PROPEL(1)=VALMAT(1)
         PROPEL(2)=VALMAT(2)
         DO IM=3,12
          PROPEL(IM)=VALMAT(1)
         ENDDO
         PROPEL(13)=XZERO
         PROPEL(14)=VALMAT(1)
         WORK1(1)=IB
 
         DO IM=1,5
          REL(IM,1)=XZERO
         ENDDO
 
cbp      loi de comportement a utiliser =
c        1 : improved plane-stress constitutive law
c            [Abed-Meiram & Combescure, IJNME, 2009]
c        2 : plane-stress constitutive law
c        3 : tridimensional constitutive law
cbp          OUT(1)=3
         OUT(1)=1
C
C     CALCUL DE LA MATRICE DE RIGIDITE
C
         call SHB8 (2,XE,DDHOOK,PROPEL,WORK1,REL,OUT)
C
*        SEGINI XMATRI
*        IMATTT(IB)=XMATRI
C
C     REMPLISSAGE DE XMATRI
C
        CALL REMPMT(REL,LRE,RE(1,1,IB))
*        SEGDES XMATRI
      ENDDO
      SEGDES XMATRI
      SEGSUP WRK1,WRK2,WRK4,WRK7,MVELCH
      GOTO 510
*
C_______________________________________________________________________
C
C   ELEMENTS DE ZONE COHESIVE ZCO2, ZCO3, ZCO4
C_______________________________________________________________________
C
  266 CONTINUE
 
      NDIM = 2
      IF(IFOUR.GT.0) NDIM = 3
      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2,WRK4
C
      DO 3266 IB=1,NBELEM
C
C  ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
C
      CALL ZERO (REL,LRE,LRE)
C
C  BOUCLE SUR LES POINTS DE GAUSS
C
      DO 6266 IGAU=1,NBPGAU
C
       CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS)
C
       CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,
     .          NSTRS,NBNN,LRE,MELE,SHPWRK,BGENE,DJAC,IERT)
       IF (IERT.NE.0) THEN
         INTERR(1)=IB
         CALL ERREUR(612)
         GOTO 99266
       ENDIF
C
      DJAC=DJAC*POIGAU(IGAU)
C
C     CALCUL DE LA MATRICE DE HOOKE
C
 
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
        MELVAL=IVAL(1)
        IBMN=MIN(IB  ,IELCHE(/2))
        MLREEL=IELCHE(1,IBMN)
        SEGACT MLREEL
        IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
     1  CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
      ELSE IF (IMAT.EQ.1) THEN
          DO 9266 IM=1,NMATT
            IF (IVAL(IM).NE.0) THEN
              MELVAL=IVAL(IM)
              IBMN=MIN(IB  ,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
              VALMAT(IM)=VELCHE(IGMN,IBMN)
            ELSE
              VALMAT(IM)=0.D0
            ENDIF
 9266     CONTINUE
        IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1    CALL DOU266(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
      ENDIF
C
C     CALCUL ET INTEGRATION DE BDB
C
      CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
 6266 CONTINUE
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
 
 3266 CONTINUE
C
C     IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
C
      IF (IRTD.EQ.0) THEN
          MOTERR(1:8) = CMATE
          MOTERR(9:16) = NOMFR(MFR/2+1)
          INTERR(1) = IFOUR
          CALL ERREUR(81)
      ENDIF
C
99266 CONTINUE
      SEGSUP WRK1,WRK2,WRK4,MVELCH
      GOTO 510
*_______________________________________________________________________
*
   99 CONTINUE
      MOTERR(1:4)=NOMTP(MELE)
      MOTERR(9:12)='RIGI4'
      CALL ERREUR(86)
 
  510 CONTINUE
      SEGDES XMATRI
      IF (CMATE.eq.'STATIQUE') THEN
        mlmots = iinc
        if (iinc.gt.0) segsup mlmots
        mlmots = idua
        if (idua.gt.0) segsup mlmots
      ENDIF
 
c      RETURN
      END