C RIGI2     SOURCE    AM        14/02/06    21:15:02     7945           
      SUBROUTINE RIGI2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
     &  IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT,
     &  IPORE,NDDL,IPMATR,IIPDPG,NCAR1)
*---------------------------------------------------------------------*
*        __________________________                                   *
*        |                        |                                   *
*        |  CALCUL DE LA RIGIDITE |                                   *
*        |________________________|                                   *
*                                                                     *
*        massif, liquide, 'surface libre', poreux et joints poreux,   *
*        incompressible                                               *
*                                                                     *
*---------------------------------------------------------------------*
*                                                                     *
*   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 de caractéristiques  *
*        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 composante de materiau (IMAT=1)           *
*        LHOOK    Dimension de la matrice de Hooke                    *
*        IPORE    Nombre de fonctions de forme                        *
*        NDDL     Nombre de degre de liberte                          *
*                                                                     *
*   SORTIES :                                                         *
*   ________                                                          *
*                                                                     *
*        IPMATR   pointeur sur la rigidite de la sous-zone            *
*                                                                     *
*---------------------------------------------------------------------*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
-INC CCOPTIO
-INC CCHAMP
-INC CCREEL
-INC SMCHAML
-INC SMINTE
-INC SMELEME
-INC SMRIGID
-INC SMCOORD
-INC SMLREEL
*
      SEGMENT WRK1
       REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK)
       REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB)
      ENDSEGMENT
*
      SEGMENT WRK2
       REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
      ENDSEGMENT
*
      SEGMENT WRK3
       REAL*8 BPSS(3,3),XEL(3,NBBB)
       REAL*8 XNTH(LRN,LRN),XNTB(LRN,LRN),XNTT(LRN)
      ENDSEGMENT
*
      SEGMENT WRK5
       REAL*8 XGENE(NSTN,LRN)
      ENDSEGMENT
*
      SEGMENT WRK55
       REAL*8 YGENE(NCOT,NBNN),COBMA(LHOOK)
      ENDSEGMENT
*
      SEGMENT WRK555
       REAL*8 XREL(LRN,LRN),COBB(NSTN),CPBB(NSTN),KKBB(NSTN,NSTN)
      ENDSEGMENT
*
      SEGMENT WRK8
       REAL*8 XLOC(IDIM,IDIM),XGLOB(IDIM,IDIM),TXR(IDIM,IDIM)
       REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK)
       ENDSEGMENT
*
*      SEGMENT MWRKIC
*        REAL*8 A(4,60),BB(3,60)
* ?      REAL*8 A(4,3*NBNO),BB(3,3*NBNO)
*      ENDSEGMENT
*
      SEGMENT,MVELCH
         REAL*8 VALMAT(NV1)
      ENDSEGMENT
*
      segment mwrk67
         real*8 valcar(nca1), xatef1(3,3)
      endsegment
*
      SEGMENT MPTVAL
        INTEGER IPOS(NS)    ,NSOF(NS)
        INTEGER      IVAL(NCOSOU)
        CHARACTER*16 TYVAL(NCOSOU)
      ENDSEGMENT
*
      DIMENSION A(4,60),BB(3,60)
      CHARACTER*8 CMATE,CELEM
      logical drend,BDPGE
*
*       WRITE (*,*) 'Entrée dans RIGI2.'
*       SEGACT MCOORD
      MELEME=IPMAIL
      NBNN=NUM(/1)
      NBELEM=NUM(/2)
*
      NV1=NMATT
      SEGINI,MVELCH
*
      XMATRI=IPMATR
      NLIGRD=LRE
      NLIGRP=LRE

*     INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
*     DE LA SECTION EN DEFO PLANE GENERALISEE
*     En 1D : pas de rotation
      IF (IFOUR.EQ.-3) THEN
        BDPGE=.TRUE.
        IREF=(IIPDPG-1)*(IDIM+1)
        XDPGE=XCOOR(IREF+1)
        YDPGE=XCOOR(IREF+2)
      ELSE IF ((IFOUR.GE.7.AND.IFOUR.LE.11).OR.IFOUR.EQ.14) THEN
        BDPGE=.TRUE.
        XDPGE=XZero
        YDPGE=XZero
      ELSE
        BDPGE=.FALSE.
        XDPGE=0.D0
        YDPGE=0.D0
      ENDIF
*
      NHRM=NIFOUR
*
      MINTE=IPMINT
      IRTD=1
      IDECAP=0
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
      GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
     1      99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,35,35,35,35,35,35,
     2      99,99,99,99,99,99,99,48,99,99,99,99,48,48,99,99,99,99,99,99,
     3      99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99, 4,99,99,79,79,
     4      79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
     5      99,99,99,99,99,99,99,80,80,80, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
     6       4, 4),MELE
*
      IF(MELE.GE.173.AND.MELE.LE.182) GO TO 173
      IF (MELE.EQ.183.OR.MELE.EQ.184.OR.
     .    MELE.EQ.193.OR.MELE.EQ.194) GOTO 4

      GOTO 99
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET INCOMPRESSIBLES
C_______________________________________________________________________
C
   4  CONTINUE
      DIM3=1.D0
*
*  CAS  ORTHOTROPE ( 2)  ANISOTROPE ( 3) UNIDIRICTIONNEL (4)
*
*  RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE
*  L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
      IPMIN2 = 0
      IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
        NLG=NUMGEO(MELE)
        CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
        MINTE2=IPMIN2
        SEGACT MINTE2
        SEGINI WRK8
      ENDIF

      NBNO=NBNN
      NBBB=NBNN
      SEGINI WRK1,WRK2

*     MWRKIC = 0
*     IF (MFR.EQ.31) SEGINI,MWRKIC
* Initialisation en cas de matrice d'efficacite
      MWRK67 = 0
      IF (IVACAR.GT.0) THEN
        MPTVAL=IVACAR
        SEGACT,MPTVAL
        IF (IVAL(NCAR1).GT.0 .OR. IVAL(NCAR1+1).GT.0) THEN
          nca1 = IVAL(/1) 
          SEGINI,MWRK67
          celem = 'MASSIF  '
          nstep = 2
          if (ifour.eq.2) nstep = 3
          drend = .false.
          irend = 0
          if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then
            drend = .true.
            irend = 1
          endif
          if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then
            drend = .false.
            irend = 2
          endif
        ENDIF
      ENDIF

      DO 3004  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     CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE ,
C     ANISOTROPE  ET UNIDIRECTIONNEL
C
C*    IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1)THEN
      IF (IPMIN2.NE.0) THEN
        NBSH=MINTE2.SHPTOT(/2)
        CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
        if (nbsh.eq.-1) then
         call erreur(525)
         goto 9904
        endif
      ENDIF
C
      CALL ZERO (RINT,LRE,LRE)
C
C= EF InCompressibles : CALCUL DES COEFF UTILES A LA MATRICE B-BARRE
      IF (MFR.EQ.31) THEN
        CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,POIGAU,
     1              QSIGAU,ETAGAU,DZEGAU,NSTRS,
     2              LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE)
      ENDIF
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4004  IGAU=1,NBPGAU
C
C   RECUPERATION DE L'EPAISSEUR
C
      IF (IFOUR.EQ.-2)THEN
        MPTVAL=IVACAR
        IF (IVACAR.NE.0) THEN
         MELVAL=IVAL(1)
         IF (MELVAL.NE.0) THEN
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB,VELCHE(/2))
          DIM3=VELCHE(IGMN,IBMN)
         ELSE
          DIM3=1.D0
         ENDIF
        ENDIF
      ENDIF
*
      CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
     1            MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE,
     2            SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)

      IF (DJAC.EQ.0.D0) THEN
        INTERR(1)=IB
        CALL ERREUR(259)
        GOTO 9904
      ENDIF
      IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
      DJAC=ABS(DJAC)*POIGAU(IGAU)

C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
      IF (MFR.EQ.31) THEN
        CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
     &            MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
      ENDIF
C
      MPTVAL=IVAMAT
      IF(IMAT.EQ.2) THEN
       IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
        MELVAL=IVAL(1)
        IBMN=MIN(IB  ,IELCHE(/2))
        IGMN=MIN(IGAU,IELCHE(/1))
        MLREEL=IELCHE(IGMN,IBMN)
        SEGACT MLREEL
        CALL DOHOOO(PROG,LHOOK,DDHOOK)
        SEGDES MLREEL
       ENDIF
      ELSE IF (IMAT.EQ.1) THEN
        DO 9004 IM=1,NMATT
          IF (IVAL(IM).NE.0) THEN
            MELVAL=IVAL(IM)
            IBMN=MIN(IB  ,VELCHE(/2))
            IGMN=MIN(IGAU,VELCHE(/1))
            if (ibmn.gt.0.and.igmn.gt.0) then
              VALMAT(IM)=VELCHE(IGMN,IBMN)
            else
              VALMAT(IM)=0.D0
            endif
          ELSE
            VALMAT(IM)=0.D0
          ENDIF
 9004   CONTINUE
        IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN
         IF(IGAU.LE.NBGMAT)
     1     CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
     2                 ROTH,DDHOOK,LHOOK,1,IRTD)
        ELSE
         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     1     CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
        ENDIF
      ENDIF
C
C    CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL
C                  /MASSIF ------------ PRODUIT PAR BLOC
C
* initialise
      CALL ZERO (REL,LRE,LRE)
* calcul rigidite elementaire
C**   IF (IFOUR.EQ.-3) THEN
      IF (BDPGE) THEN
       CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
      ELSE
       CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE,
     1    IGAU,IMAT,0.D0)
      ENDIF

* matrice d'efficacite
        IF (MWRK67.NE.0) THEN
          MPTVAL=IVACAR
          DO 9008 IM= 1,IVAL(/1)
            IF (IVAL(IM).GT.0) THEN
              MELVAL=IVAL(IM)
              IF (TYVAL(IM).EQ.'REAL*8') THEN 
                IBMN=MIN(IB  ,VELCHE(/2))
                IGMN=MIN(IGAU,VELCHE(/1))
                VALCAR(IM)=VELCHE(IGMN,IBMN)
              ELSE
                IBMN=MIN(IB  ,IELCHE(/2))
                IGMN=MIN(IGAU,IELCHE(/1))
                VALCAR(IM)=IELCHE(IGMN,IBMN)
              ENDIF
            ELSE
              VALCAR(IM)=0.D0
            ENDIF
 9008     CONTINUE
          do i = 1,nstep
            do j = 1, nstep
              xatef1(i,j) = 0.d0
            enddo
          enddo
          if (irend.eq.1) then
            xatef1(1,1) = valcar(ncar1)
            xatef1(2,2) = valcar(ncar1)
            if (nstep.eq.3) xatef1(3,3) = valcar(ncar1)
          else if (irend.eq.2) then
            xatef1(1,1) = valcar(ncar1+7)
            xatef1(2,2) = valcar(ncar1+8)
            if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
          endif
          call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1,
     &               nstep,drend,celem)
        ENDIF
*  stocke 
       do jj = 1,LRE
         do ii = 1,LRE
           rint(ii,jj) = rint(ii,jj) + rel(ii,jj) 
         enddo
       enddo
*
 4004 CONTINUE
*
      IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
        INTERR(1)=IB
        CALL ERREUR(195)
        GOTO 9904
      ENDIF
C
C     REMPLISSAGE DE XMATRI
C
c      CALL REMPMT(RINT,LRE,RE)
       DO 4100 IBK=1,LRE      
        DO 4100 IAK=1,LRE 
         RE(IAK,IBK,IB)=RINT(IAK,IBK)
 4100  CONTINUE                                                        
*      do i = 1,8
*      write(6,*) re(13,3*i-2),re(13,3*i-1),re(13,3*i) 
*      enddo
*
 3004 CONTINUE
c
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
 9904 CONTINUE
C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND.IMAT.EQ.1) THEN
      IF (IPMIN2.NE.0) THEN
       SEGDES MINTE2
       SEGSUP WRK8
      ENDIF
      SEGSUP WRK1,WRK2
*     IF (MWRKIC.NE.0) SEGSUP,MWRKIC
      IF (MWRK67.NE.0) SEGSUP,MWRK67
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LES ELEMENTS LIQUIDES
C_______________________________________________________________________
C
  35  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      NSTRS=NDDL
      SEGINI WRK1,WRK2
c
      DO 3035  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)
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4035  IGAU=1,NBPGAU

        MPTVAL=IVAMAT
        DO 9035 IM=1,5
             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
 9035   CONTINUE
C
C     CALCUL DES COEFFICIENTS DE NORMALISATION
C
      RHO   =VALMAT(1)
      C     =VALMAT(2)
      RHOREF=VALMAT(3)
      CREF  =VALMAT(4)
      RLCAR =VALMAT(5)
C
      COEFPR=(RHOREF*CREF*CREF)/RLCAR
      VKL   =(COEFPR*COEFPR)/(RHO*C*C)

      CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
     1                  SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
      IF(DJAC.LT.0.D0) ISDJC=ISDJC+1

      DJAC=ABS(DJAC)*POIGAU(IGAU)
      CALL NKLNST(BGENE,DJAC,VKL,LRE,NSTRS,REL)
 4035 CONTINUE
*
      IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
        INTERR(1)=IB
        CALL ERREUR(195)
        GOTO 9935
      ENDIF
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,IB))
 3035 CONTINUE
*
 9935 CONTINUE
      SEGSUP WRK1,WRK2
      GOTO 510
C_______________________________________________________________________
C
C     SECTEUR DE CALCUL POUR LES ELEMENTS DE SURFACE LIBRE
C_______________________________________________________________________
C
  48  CONTINUE
      NBNO=NBNN
      NBBB=NBNN
      NSTRS=NDDL
      SEGINI WRK1,WRK2
c
      DO 3048  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)
C
      MPTVAL=IVAMAT
      DO 9048 IM=1,6
        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
 9048 CONTINUE
C
      RHO   =VALMAT(1)
      G     =VALMAT(6)
      VKS   =RHO*G
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4048  IGAU=1,NBPGAU
      CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
     1                  SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
      IF(DJAC.LT.0.0) ISDJC=ISDJC+1

      DJAC=ABS(DJAC)*POIGAU(IGAU)
      CALL NKSNST(BGENE,DJAC,VKS,LRE,NSTRS,REL)
 4048 CONTINUE
      IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
        INTERR(1)=IB
        CALL ERREUR(195)
        GOTO 9948
      ENDIF
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,ib))
 3048 CONTINUE
C
 9948 CONTINUE
      SEGSUP WRK1,WRK2
      GOTO 510
C_______________________________________________________________________
C
C     MILIEUX POREUX
C_______________________________________________________________________
C
  79  CONTINUE
C
C* Cas non pevus actuellement
      IF (IMAT.EQ.1) THEN
        IF (MATE.LT.1.OR.MATE.GT.4) GOTO 99
      ELSE
        GOTO 99
      ENDIF
C
C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
C                       NBNO = NOMBRE DE FONCTIONS DE FORME
C    ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
C
      DIM3=1.D0
      NCOT=0
      NBNO=IPORE
      NBBB=NBNN
      NSTN=1
****************  AM 08/01/01
***** NSTMU=2
***** IF(IFOUR.GE.0) NSTMU=3
      NSTMU=3
      LRN = NBNO-NBBB
      LRB=LRE-NBNN

      IELE=NUMGEO(MELE)
      IF(IELE.EQ.6 ) NCOT=3
      IF(IELE.EQ.10) NCOT=4
      IF(IELE.EQ.15) NCOT=12
      IF(IELE.EQ.17) NCOT=9
      IF(IELE.EQ.24) NCOT=6
      IF(NCOT.EQ.0) THEN
        CALL ERREUR(5)
        GOTO  510
      ENDIF
*
*     CAS NON ISOTROPES
*     RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES
*     AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
*
      IPMIN2 = 0
      IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1 ) THEN
        CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
        MINTE2=IPMIN2
        SEGACT MINTE2
        SEGINI WRK8
        NSTMU=LHOOK
      ENDIF
*
      SEGINI WRK1,WRK2,WRK5,WRK55
*
      DO 3079  IB=1,NBELEM
*
*     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
*
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
*
*     CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES
*
C*    IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
C*   .                         .AND.IMAT.EQ.1)THEN
      IF (IPMIN2.NE.0) THEN
        NBSH=MINTE2.SHPTOT(/2)
        CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
        if (nbsh.eq.-1) then
         call erreur(525)
         goto 9979
        endif
      ENDIF
*
      CALL ZERO (REL,LRE,LRE)
*
*     TRAITEMENT POUR NOEUDS MILIEUX   PRESSION
*
      FREF = 1.D6
      CALL BNPOR2(YGENE,NCOT,IELE)
      IF(IERR.NE.0) GOTO 9979
*
*      DO 27895 IOI=1,NCOT
*      WRITE(6,28927) IOI
*28927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
*      WRITE(6,28928) (YGENE(IOI,J),J=1,NBNN)
*28928 FORMAT(8(1X,1PE10.3))
*27895 CONTINUE
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4079  IGAU=1,NBPGAU
C
C   RECUPERATION DE L'EPAISSEUR
C
      IF (IFOUR.EQ.-2)THEN
        MPTVAL=IVACAR
        IF (IVACAR.NE.0) THEN
         MELVAL=IVAL(1)
         IF (MELVAL.NE.0) THEN
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB,VELCHE(/2))
          DIM3=VELCHE(IGMN,IBMN)
         ELSE
          DIM3=1.D0
         ENDIF
        ENDIF
      ENDIF
C
      CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
     .            DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
      IF (DJAC.EQ.0.D0) THEN
        INTERR(1)=IB
        CALL ERREUR(259)
        GOTO 9979
      ENDIF
      IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
      DJAC=ABS(DJAC)*POIGAU(IGAU)
C
*      IF(IGAU.EQ.1) THEN
*      DO 27892 IOI=1,LHOOK
*      WRITE(6,28920) IOI
*28920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
*      WRITE(6,28921) (BGENE(IOI,J),J=1,LRE)
*28921 FORMAT(8(1X,1PE10.3))
*27892 CONTINUE
*       DO 27893 IOI=1,NSTN
*       WRITE(6,28922) IOI
*28922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
*       WRITE(6,28923) (XGENE(IOI,J),J=1,LRN)
*28923 FORMAT(8(1X,1PE10.3))
*27893 CONTINUE
*      ENDIF

      MPTVAL=IVAMAT
C*D   IF(IMAT.EQ.2) THEN
C*D     GO TO 99
C*D   ELSE IF (IMAT.EQ.1) THEN
*
        DO 9079 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
 9079   CONTINUE
*
        IF(MATE.EQ.1) THEN
         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     .   CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
         DO 4879 I=1,NSTMU
           COBMA(I) =VALMAT(3)
 4879    CONTINUE
         XMOB       =VALMAT(4)
*
        ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
        IF(IGAU.LE.NBGMAT)
     .   CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
     .               ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD)
C*D     ELSE
C*D       GO TO 99
        ENDIF
*
C*D   ENDIF
*
      CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
     .           IGAU,IMAT,0.D0)
      EREF  =1.D0
      DJACER=DJAC*EREF
      DO 4179 I=1,LRB
      DO 4179 J=1,LRN
      JJ=J+LRB
        r_z = DJACER*XGENE(1,J)
      DO 4179 K=1,NSTMU
      REL(JJ,I)=REL(JJ,I)-COBMA(K)*r_z*BGENE(K,I)
 4179 CONTINUE
*
      IF(XMOB.EQ.0.D0) THEN
        UNSURM=0.D0
      ELSE
        UNSURM=1.D0 / XMOB
      ENDIF
      COMJAC=UNSURM*DJAC*EREF*EREF
      DO 4279 I=1,LRN
      II=I+LRB
        r_z = COMJAC*XGENE(1,I)
      DO 4279 J=1,I
      JJ=J+LRB
      REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)
 4279 CONTINUE
C
      COMJAC=UNSURM*DJAC*FREF
      DO 4379 I=1,NBNN
      II=I+LRB
      DO 4379 J=1,I
      JJ=J+LRB
      DO 4379 K=1,NCOT
      REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
 4379 CONTINUE
*
 4079 CONTINUE
      IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
        INTERR(1)=IB
        CALL ERREUR(195)
        GOTO 9979
      ENDIF
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMT(REL,LRE,RE(1,1,ib))
*
 3079 CONTINUE
c
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
 9979 CONTINUE
      SEGSUP WRK1,WRK2,WRK5,WRK55
C*    IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1) THEN
      IF (IPMIN2.NE.0) THEN
       SEGDES MINTE2
       SEGSUP WRK8
      ENDIF
      GOTO 510
C_______________________________________________________________________
C
C     MILIEUX POREUX - SUITE
C_______________________________________________________________________
C
 173  CONTINUE
C
C     CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
      IF (IMAT.EQ.1) THEN
        IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
          CALL ERREUR(251)
          GO TO 510
        ENDIF
      ELSE
C*    ELSE IF (IMAT.EQ.2) THEN
        GO TO 99
      ENDIF
C
C    POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
C                       NBNO = NOMBRE DE FONCTIONS DE FORME
C    ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
C
      IF(MFR.EQ.57) IDECAP=2
      IF(MFR.EQ.59) IDECAP=3
*
      DIM3=1.D0
      NCOT=0
      NBNO=IPORE
      NBBB=NBNN
      NSTN=IDECAP
*
****************  AM 08/01/01
***** NSTMU=2
***** IF(IFOUR.GE.0) NSTMU=3
*
      NSTMU=3
      LPP=NBNO-NBBB
      LRN = IDECAP*LPP
****  LRB=LRE-LRN
      LRB=LRE-(IDECAP*NBBB)
      IELE=NUMGEO(MELE)
*
      IF(IELE.EQ.6 ) NCOT=3
      IF(IELE.EQ.10) NCOT=4
      IF(IELE.EQ.15) NCOT=12
      IF(IELE.EQ.17) NCOT=9
      IF(IELE.EQ.24) NCOT=6
      IF(NCOT.EQ.0) THEN
        CALL ERREUR(5)
        GO TO  510
      ENDIF
*
      SEGINI WRK1,WRK2,WRK5,WRK55,WRK555

      DO 3173  IB=1,NBELEM
*
*     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
*
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
*
      CALL ZERO (REL,LRE,LRE)
*
*     TRAITEMENT POUR NOEUDS MILIEUX   PRESSION
*
      FREF = 1.D6
      CALL BNPOR2(YGENE,NCOT,IELE)
      IF(IERR.NE.0) GO TO 9973

*      DO 17895 IOI=1,NCOT
*      WRITE(6,78927) IOI
*78927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
*      WRITE(6,78928) (YGENE(IOI,J),J=1,NBNN)
*78928 FORMAT(8(1X,1PE10.3))
*17895 CONTINUE
C
C     BOUCLE SUR LES POINTS DE GAUSS
C
      ISDJC=0
      DO 4173  IGAU=1,NBPGAU
C
C   RECUPERATION DE L'EPAISSEUR
C
      IF (IFOUR.EQ.-2)THEN
        MPTVAL=IVACAR
        IF (IVACAR.NE.0) THEN
         MELVAL=IVAL(1)
         IF (MELVAL.NE.0) THEN
          IGMN=MIN(IGAU,VELCHE(/1))
          IBMN=MIN(IB,VELCHE(/2))
          DIM3=VELCHE(IGMN,IBMN)
         ELSE
          DIM3=1.D0
         ENDIF
        ENDIF
      ENDIF
C
      CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
     .     DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,1)
      IF(DJAC.EQ.0.D0) THEN
        INTERR(1)=IB
        CALL ERREUR(259)
        GOTO 9973
      ENDIF
      IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
      DJAC=ABS(DJAC)*POIGAU(IGAU)
C
*      IF(IGAU.EQ.1) THEN
*      DO 17892 IOI=1,LHOOK
*      WRITE(6,78920) IOI
*78920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
*      WRITE(6,78921) (BGENE(IOI,J),J=1,LRE)
*78921 FORMAT(8(1X,1PE10.3))
*17892 CONTINUE
*      DO 17893 IOI=1,NSTN
*      WRITE(6,78922) IOI
*78922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
*       WRITE(6,78923) (XGENE(IOI,J),J=1,LRN)
*78923 FORMAT(8(1X,1PE10.3))
*17893 CONTINUE
*       ENDIF

      MPTVAL=IVAMAT
C*D   IF(IMAT.EQ.2) THEN
C*D     GO TO 99
C*D   ELSE IF (IMAT.EQ.1) THEN
*
        DO 9173 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
 9173   CONTINUE
*
C*D     IF(MATE.EQ.1) THEN
         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     .   CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
*
C*D     ELSE
C*D       GO TO 99
C*D     ENDIF
C*D   ENDIF
*
      CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
      EREF  =1.D0
*
      IF(MFR.EQ.57) THEN
            COBB(1)  = VALMAT(3)
            COBB(2)  = VALMAT(4)
            CPBB(1)  = VALMAT(5)
            CPBB(2)  = VALMAT(6)
            KKBB(1,1)= VALMAT(7)
            KKBB(1,2)= VALMAT(8)
            KKBB(2,1)= VALMAT(9)
            KKBB(2,2)= VALMAT(10)
*
      ELSE IF(MFR.EQ.59) THEN
            COBB(1)  = VALMAT(3)
            COBB(2)  = VALMAT(4)
            COBB(3)  = VALMAT(5)
            CPBB(1)  = VALMAT(6)
            CPBB(2)  = VALMAT(7)
            CPBB(3)  = VALMAT(8)
            KKBB(1,1)= VALMAT(9)
            KKBB(1,2)= VALMAT(10)
            KKBB(1,3)= VALMAT(11)
            KKBB(2,1)= VALMAT(12)
            KKBB(2,2)= VALMAT(13)
            KKBB(2,3)= VALMAT(14)
            KKBB(3,1)= VALMAT(15)
            KKBB(3,2)= VALMAT(16)
            KKBB(3,3)= VALMAT(17)
       ENDIF
*
        DJACER=DJAC*EREF

        DO 6673 IPR=1,IDECAP
          LRBDEC=LRB + (IPR-1)*NBBB
          LPPDEC= (IPR-1)*LPP
          COMJAC=COBB(IPR)*DJACER
          DO 4973 I=1,LRB
          DO 4973 J=1,LPP
          JJ=J+LRBDEC
          JX=J+LPPDEC
          r_z = COMJAC*XGENE(IPR,JX)
          DO 4973 K=1,NSTMU
          REL(I,JJ)=REL(I,JJ)-r_z*BGENE(K,I)
 4973     CONTINUE
 6673   CONTINUE
*
        DO 6674 IPR=1,IDECAP
          LRBDEC=LRB + (IPR-1)*NBBB
          LPPDEC= (IPR-1)*LPP
          COMJAC=CPBB(IPR)*DJACER
          DO 4974 I=1,LRB
          DO 4974 J=1,LPP
          JJ=J+LRBDEC
          JX=J+LPPDEC
          r_z = COMJAC*XGENE(IPR,JX)
          DO 4974 K=1,NSTMU
*             ici - pour bsig
          REL(JJ,I)=REL(JJ,I)-r_z*BGENE(K,I)
 4974     CONTINUE
 6674   CONTINUE
*
        COMJAC=DJAC*EREF*EREF
        CALL ZERO(XREL,LRN,LRN)
        CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)

        DO 6873 IPR=1,IDECAP
          IRBDEC=LRB + (IPR-1)*NBBB
          IPPDEC= (IPR-1)*LPP
        DO 6873 JPR=1,IDECAP
          JRBDEC=LRB + (JPR-1)*NBBB
          JPPDEC= (JPR-1)*LPP
          DO 4273 I=1,LPP
          II=I+IRBDEC
          IX=I+IPPDEC
          DO 4273 J=1,LPP
          JJ=J+JRBDEC
          JX=J+JPPDEC

*          IF(IGAU.EQ.1) THEN
*          PRINT *,'I =',I,' IX=',IX,' II=',II
*          PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
*          ENDIF

          REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
 4273     CONTINUE
 6873   CONTINUE
C
        DO 6973 IPR=1,IDECAP
          COMJAC=KKBB(IPR,IPR)*DJAC*FREF
          LRBDEC=LRB + (IPR-1)*NBBB
          DO 4373 I=1,NBNN
          II=I+LRBDEC
          DO 4373 J=1,NBNN 
          JJ=J+LRBDEC
          DO 4374 K=1,NCOT
          REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
 4374   CONTINUE
 4373   CONTINUE
 6973  CONTINUE
*
 4173 CONTINUE
      IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
        INTERR(1)=IB
        CALL ERREUR(195)
        GOTO 9973
       ENDIF
C
C     REMPLISSAGE DE XMATRI
C
      CALL REMPMS(REL,LRE,RE(1,1,ib))
 3173 CONTINUE
c
      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
 9973 CONTINUE
      SEGSUP WRK1,WRK2,WRK5,WRK55,WRK555
      GOTO 510
C_______________________________________________________________________
C
C     JOINTS EN FORMULATION MILIEUX POREUX
C_______________________________________________________________________
C
  80  CONTINUE
C
* CAS NON PREVUS
      IF (IMAT.EQ.1) THEN
        IF (MATE.NE.1) GOTO 99
      ELSE IF (IMAT.EQ.2) THEN
        GOTO 99
      ENDIF
C
C   POUR CES ELEMENTS  NBBB = NOMBRE DE NOEUDS
C                      NBNO = NOMBRE DE FONCTIONS DE FORME
C   ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
C
      NCOT=0
      NBNO=IPORE
      NBBB=NBNN
      NSTN=1
      NSTMU=2
      IF(IFOUR.EQ.2) NSTMU=3
      LRN=(NBNO-NBBB)*3/2
      LRB=LRE-NBNN
      IELE=NUMGEO(MELE)
      IF(IELE.EQ.29) NCOT=2
      IF(IELE.EQ.30) NCOT=6
      IF(IELE.EQ.31) NCOT=8
      IF(NCOT.EQ.0) THEN
        CALL ERREUR(5)
        GO TO  510
      ENDIF
*
      SEGINI WRK1,WRK2,WRK3,WRK5,WRK55
*
      DO 3080  IB=1,NBELEM
*
*   ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
*
      CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
*
*   CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
*
      CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
*
      CALL ZERO (REL,LRE,LRE)
*
      CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE)
*
*   TRAITEMENT POUR NOEUDS MILIEUX   PRESSION
*
      FREF = 1.D6
      CALL BNPOR2(YGENE,NCOT,IELE)
      IF (IERR.NE.0) GOTO 9980
*
*   BOUCLE SUR LES POINTS DE GAUSS
*
      ISDJC=0
      DO 4080  IGAU=1,NBPGAU
*
      CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
     .            SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
      IF (DJAC.EQ.0.D0) THEN
        INTERR(1)=IB
        CALL ERREUR(259)
        GOTO 9980
      ENDIF
      IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
      DJAC=ABS(DJAC)*POIGAU(IGAU)
*
      MPTVAL=IVAMAT
C*D   IF(IMAT.EQ.2) THEN
C*D     GO TO 99
C*D   ELSE IF (IMAT.EQ.1) THEN
*
        DO 9080 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
 9080   CONTINUE
*
C*D     IF(MATE.EQ.1) THEN
         IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
     .   CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
C*D     ELSE
C*D       GO TO 99
C*D     ENDIF
C*D   ENDIF
*
      CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
     .           IGAU,IMAT,0.D0)
      EREF  =1.D0
*
          COBMA(NSTMU)=VALMAT(3)
          XMOB=VALMAT(4)
*
      IF(XMOB.EQ.0.D0) THEN
        UNSURM=0.D0
      ELSE
        UNSURM=1.D0 / XMOB
      ENDIF
*
      DJACER=DJAC*EREF
      DO 4180 I=1,LRB
      DO 4180 J=1,LRN
      JJ=J+LRB
        r_z = DJACER*XGENE(1,J)*XNTT(J)
      DO 4180 K=1,NSTMU
      REL(JJ,I)=REL(JJ,I)-r_z*COBMA(K)*BGENE(K,I)
 4180 CONTINUE
*
      COMJAC=UNSURM*DJAC*EREF*EREF
      DO 4280 I=1,LRN
      II=I+LRB
        r_z = COMJAC*XGENE(1,I)*XNTT(I)
      DO 4280 J=1,I
      JJ=J+LRB
      REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)*XNTT(J)
 4280 CONTINUE
*
      COMJAC=UNSURM*DJAC*FREF
      DO 4380 I=1,NBNN
      II=I+LRB
      DO 4380 J=1,I
      JJ=J+LRB
      DO 4380 K=1,NCOT
      REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
 4380 CONTINUE
*
 4080 CONTINUE
      IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
        INTERR(1)=IB
        CALL ERREUR(195)
        GOTO 9980
      ENDIF
*
*   REMPLISSAGE DE XMATRI
*
      CALL REMPMT(REL,LRE,RE(1,1,IB))
 3080 CONTINUE

      IF(IRTD.EQ.0) THEN
        MOTERR(1:8)=CMATE
        MOTERR(9:16)=NOMFR(MFR/2+1)
       INTERR(1)=IFOUR
       CALL ERREUR(81)
      ENDIF
 9980 CONTINUE
      SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55
      GOTO 510
*
* ERREUR : CAS NON PREVU
*
   99 CONTINUE
      MOTERR(1:4)=NOMTP(MELE)
      MOTERR(5:12)='RIGI2   '
      CALL ERREUR(86)
*
 510  CONTINUE
*      WRITE (*,*) 'Sortie de RIGI2.'
*     SEGDES,XMATRI
      SEGSUP,MVELCH

      RETURN
      END