C TSEG3C    SOURCE    PV090527  26/04/30    21:16:44     12529          
************************************************************************
*
*                             T S E G 3 C
*                             -----------
*
* FONCTION:
* ---------
*     CALCUL DE LA MATRICE DE CONDUCTIVITE D'UNE BARRE ( SEG2 )
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*     IPMAIL   (E)  NUMERO DU MAILLAGE ELEMENTAIRE CONSIDERE,DANS
*                  L'OBJET MODELE
*     IPCHEM  (E)  POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUES
*     IPRIGI (E/S) POINTEUR SUR L'OBJET RESULTAT,DE TYPE RIGIDITE
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*     DENIS ROBERT, LE 16 NOVEMBRE 1988.
*     REPRIS PAR P. DOWLATYARI SEP. 90
************************************************************************
      SUBROUTINE TSEG3C (NEF,IPMAIL,IPINTE,IMATE,IVAMAT,NVAMAT,
     &                   IPMATR,NLIGR)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

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

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

-INC TMPTVAL

      SEGMENT,MMAT1
         REAL*8 VALMAT(NMATR)
         REAL*8 CEL(NBNN,NBNN),XE(3,NBNN)
      ENDSEGMENT

      PARAMETER (X1s2 = 0.5D0)

c*      IF (NEF.NE.46) CALL ERREUR(5)
*      IF (IFOMOD.NE.-1.AND.IFOMOD.NE.2) THEN
*         CALL ERREUR(19)
*         RETURN
*      ENDIF
      IF (IMATE.NE.1) THEN
        CALL ERREUR (251)
        RETURN
      ENDIF
*
*---  CARACTERISTIQUES GEOMETRIQUES DU MAILLAGE ELEMENTAIRE
      MELEME = IPMAIL
c*      SEGACT,MELEME
      NBNN   = NUM(/1)
      NBELEM = NUM(/2)
*
*---  CARACTERISTIQUES D'INTEGRATION DU BARR-SEG2
      MINTE = IPINTE
c*      SEGACT,MINTE
      NBPGAU = POIGAU(/1)
*
      XMATRI = IPMATR
c*      SEGACT,XMATRI*MOD
*
      MPTVAL = IVAMAT
*
      NMATR = NVAMAT
      SEGINI,MMAT1
*
*---  BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IPMAIL
*
      DO 10 iel = 1, NBELEM

         CALL DOXE(XCOOR,IDIM,NBNN,NUM,iel,XE)
*
*- Calcul de la longueur de la BARRE
        IF (IDIM.EQ.2) THEN
         D = (XE(1,2)-XE(1,1))**2 + (XE(2,2)-XE(2,1))**2
        ELSE
         D =   (XE(1,2)-XE(1,1))**2 + (XE(2,2)-XE(2,1))**2
     &       + (XE(3,2)-XE(3,1))**2
        ENDIF
        IF (D.LE.XPETIT) THEN
          INTERR(1) = iel
          CALL ERREUR(255)
          GOTO 999
        ENDIF
*- Jacobien (constant) le long de la BARRE
        D = X1s2 / SQRT(D)

        CALL ZERO(CEL,NBNN,NBNN)
*
*---     BOUCLE SUR LES POINTS DE GAUSS
*
        DO 20 iGau = 1, NBPGAU
*
*     calcul du jacobien
*
       dz=0.d0
       dx= shptot(2,1,igau)*xe(1,1)+shptot(2,2,igau)*xe(1,2)
     $    + shptot(2,3,igau)*xe(1,3)
       dy= shptot(2,1,igau)*xe(2,1)+shptot(2,2,igau)*xe(2,2)
     $    + shptot(2,3,igau)*xe(2,3)
       dl2= dx*dx + dy * dy
       if(idim.eq.3) then
          dz= shptot(2,1,igau)*xe(3,1)+shptot(2,2,igau)*xe(3,2)
     $    + shptot(2,3,igau)*xe(3,3)
          dl2=dl2+ dz*dz
       endif
       dll= sqrt ( dl2)
       djac= 1./dll
       call tconv4(xe,shptot,idim,3,djj)
*
*- Recuperation des conductivite et section en un point de la barre
*- NB : ces composantes sont obligatoires donc IVAL(i) n'est pas nul !
          DO i = 1, NMATR
c*          IF (IVAL(i).NE.0) THEN
              MELVAL = IVAL(i)
              ibmn = MIN(iel ,VELCHE(/2))
              igmn = MIN(igau,VELCHE(/1))
              VALMAT(i) = VELCHE(igmn,ibmn)
c*          ELSE
c*            VALMAT(i) = 0.
c*          ENDIF
          ENDDO
*
          SE = VALMAT(2)
*- Section nulle ou trop faible dans une partie de l'element BARRE
          IF (SE.LE.XPETIT) THEN
            CALL ERREUR(517)
            GOTO 999
          ENDIF
*
* ON AJOUTE LE PRODUIT XK*SE*POIGAU*DETJ*B(TRANSPOSEE)*B
* POUR LE POINT DE GAUSS CONSIDERE A LA MATRICE CEL
        FAC = VALMAT(1) * SE * POIGAU(igau) * Djac
        do ia=1,3
         do ib=1,3
          cel(ia,ib)=cel(ia,ib)+shptot(2,ia,igau)*shptot(2,ib,igau)*fac
         enddo
       enddo

 20     CONTINUE

*
*
*- REMPLISSAGE DE XMATRI
        CALL REMPMT(CEL,NLIGR,RE(1,1,iel))
*
 10   CONTINUE
*
 999  CONTINUE
      SEGSUP,MMAT1
*
      RETURN
      END