C FRITH2    SOURCE    OF166741  25/02/21    21:16:54     12166          

      SUBROUTINE FRITH2(MELE,IPMAIL,MINTE,NBPTEL,
     1     IVAMAT,IVACAR,NMATT,NCARR,CRIGI,IELA,ICONT)
***********************************************************************
*     CALCUL DES COMPOSANTES DE LA RIGIDITE (HOOK) ELASTIQUE
*     BOUCLE SUR LES SS-ZONES DU MODELE DE SECTION
**********************************************************************
* ENTREES :
*
* MELE    = NUMERO  ELEMENT FINI
* IPMAIL = POINTEUR DU MAILLAGE                              (ACTIF)
* MINTE  = POINTEUR CARACTERISTIQUES INTEGRATION             (ACTIF)
* NBPTEL =NOMBRE DE POINTS PAR ELEMENT
* IVAMAT =POINTEUR SUR UN SEGMENT MPTVAL DE MATERIAU
* IVACAR =POINTEUR SUR UN SEGMENT MPTVAL DE CARACT. GEOMETRIQUES
* NVARI  =NOMBRE DE COMPOSANTES DE VARIABLES INTERNES
* NMATT  =NOMBRE DE COMPOSNATES DE PROPRIETES DE MATERIAU
* NCARR  =NOMBRE DE COMPOSNATES DE CARACTERISTIQUES GEOMETRIQUES
*
* SORTIES :
* CRIGI(12) RIGIDITE SUR LA FIBRE MOYENNE ( SOMi (HOOKi * ALPHAi) )
*
************************************************************************
*      Pierre Pegon (ISPRA) Juillet/Aout 1993
***********************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC CCHAMP

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

-INC TMPTVAL

      SEGMENT WRK0
       REAL*8 XMAT(NCXMAT),XCAR(NCXCAR)
      ENDSEGMENT
*
      SEGMENT WRK2
        REAL*8 XE(3,NBBB),SHP(6,NBBB)
      ENDSEGMENT
*
      DIMENSION CRIGI(12)
*
      MFR =NUMMFR(MELE)
      MELEME=IPMAIL
      NBNN=NUM(/1)
      NBELEM=NUM(/2)
*
*    SEGMENT D'INTEGRATION
*
C**   SEGACT,MINTE           <- ACTIF EN E/S
*
*    INITIALISATION DES SEGMENTS DE TRAVAIL
*
      NCXMAT=NMATT
      NCXCAR=NCARR
      NBBB=NBNN
      SEGINI WRK0,WRK2
*
*       BOUCLE SUR LES ELEMENTS
*
      DO 1000 IB=1,NBELEM
*
*       ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
*
         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
*
*       BOUCLE SUR LES POINTS DE GAUSS
*
         DO 1100 IGAU=1,NBPTEL
*
*       ON CHERCHE LA POSITION DU POINT DE LA SECTION (X->Y) (Y->Z)
*
           YY=0.D0
           ZZ=0.D0
           DO IE1=1,NBNN
             CGAUSS=SHPTOT(1,IE1,IGAU)
             YY=YY+XE(1,IE1)*CGAUSS
             ZZ=ZZ+XE(2,IE1)*CGAUSS
           END DO
           YY2=YY*YY
           ZZ2=ZZ*ZZ
*
*       ON REMPLIT LES SHP ET ON CALCUL LE JACOBIEN
*
           DO IE2=1,NBNN
             DO IE1=1,6
               SHP(IE1,IE2)=SHPTOT(IE1,IE2,IGAU)
             END DO
           END DO
           CALL JACOBI(XE,SHP,2,NBNN,DJAC)
*
*     ON RECUPERE LES CONSTANTES DU MATERIAU
*
           MPTVAL=IVAMAT
           DO IC=1,NMATT
                 MELVAL=IVAL(IC)
                 IF(IC.LT.3)THEN
                   IIC=IC
                 ELSEIF(IC.LT.(NMATT-1))THEN
                   IIC=IC+2
                 ELSE
                   IIC=4+IC-NMATT
                 ENDIF
                 IF(MELVAL.NE.0)THEN
                    IF(TYVAL(IC)(1:8).NE.'POINTEUR')THEN
                       IBMN=MIN(IB,VELCHE(/2))
                       IGMN=MIN(IGAU,VELCHE(/1))
                       XMAT(IIC)=VELCHE(IGMN,IBMN)
                    ELSE
                      IBMN=MIN(IB,IELCHE(/2))
                      IGMN=MIN(IGAU,IELCHE(/1))
                      XMAT(IIC)=IELCHE(IGMN,IBMN)
                    ENDIF
                 ELSE
                    XMAT(IIC)=0.D0
                    IF(TYVAL(IC)(1:8).EQ.'POINTEUR') THEN
                       XMAT(IIC)=0
                    END IF
                 ENDIF
           END DO
*
*     ON RECUPERE LES CARACTERISTIQUES GEOMETRIQUES
*
           MPTVAL=IVACAR
           DO IC=1,NCARR
              MELVAL=IVAL(IC)
              IBMN=MIN(IB,VELCHE(/2))
              IGMN=MIN(IGAU,VELCHE(/1))
              XCAR(IC)=VELCHE(IGMN,IBMN)
           END DO
*
*     CONTRIBUTION A CRIGI
*
           PGAUSS=POIGAU(IGAU)*ABS(DJAC)
*
           IF(ICONT.EQ.0) THEN
             YOUNG=1.D0
             XNU  =1.D0
           ELSE
             YOUNG=XMAT(1)
             XNU  =XMAT(2)
           ENDIF
           ALPHA=XMAT(4)
           IF(IELA.EQ.1) ALPHA=1.D0
           GAMMA=YOUNG/(2.D0*(1.+XNU))
           ALPH1=XCAR(1)
           ALPH2=XCAR(2)
           CRIGI( 1)=CRIGI( 1)+YOUNG*PGAUSS*ALPHA
           CRIGI( 2)=CRIGI( 2)+YOUNG*YY*PGAUSS*ALPHA
           CRIGI( 3)=CRIGI( 3)+YOUNG*ZZ*PGAUSS*ALPHA
           CRIGI( 4)=CRIGI( 4)+YOUNG*YY2*PGAUSS*ALPHA
           CRIGI( 5)=CRIGI( 5)+YOUNG*YY*ZZ*PGAUSS*ALPHA
           CRIGI( 6)=CRIGI( 6)+YOUNG*ZZ2*PGAUSS*ALPHA
*
           CRIGI( 7)=CRIGI( 7)+ALPH2*GAMMA*PGAUSS*ALPHA
           CRIGI( 8)=CRIGI( 8)+ALPH1*GAMMA*PGAUSS*ALPHA
           CRIGI( 9)=CRIGI( 9)+ALPH2*GAMMA*YY*PGAUSS*ALPHA
           CRIGI(10)=CRIGI(10)+ALPH1*GAMMA*ZZ*PGAUSS*ALPHA
           CRIGI(11)=CRIGI(11)+ALPH2*GAMMA*YY2*PGAUSS*ALPHA
           CRIGI(12)=CRIGI(12)+ALPH1*GAMMA*ZZ2*PGAUSS*ALPHA
C
C    FIN DE LA BOUCLE SUR LES POINTS DE GAUSS
C
1100     CONTINUE
C
C     FIN DE LA BOUCLE SUR LES ELEMENTS
C
1000  CONTINUE
*
C**   SEGDES,MINTE           <- ACTIF EN E/S (NON MODIFIE)
      SEGSUP WRK0,WRK2
*
      RETURN
      END