C FRIGTH    SOURCE    OF166741  25/02/21    21:16:53     12166          
      SUBROUTINE FRIGTH(IPMODL,IPCAR,CRIGI,IELA,ICONT)
**********************************************************************
*
*     CALCUL DES COMPOSANTES DE LA RIGIDITE (HOOK) ELASTIQUE
*     CALCUL DES COMPOSANTES DE LA MATRICE (HOOK) DE MASSE
*     ... AU SIGNE PRES
*     CONTRIBUTION DE CHAQUE ELEMENT DE CHAQUE SS_ZONE DU MODELE
*     DE SECTION
*
**********************************************************************
*
*  ENTREES:
*
*  IPMODL = POINTEUR SUR UN OBJET MMODEL
*  IPCAR  = POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
*
* SORTIES:
*
*  CRIGI(12) ELEMENT DE REDUCTION DE LA RIGIDITE
*
************************************************************************
*      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

      DIMENSION CRIGI(12)
*
      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT
*
      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
      CHARACTER*16 MOMODL(10)
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      LOGICAL lsupma,lsupca

      lsupma=.false.
      lsupca=.false.
C
      NHRM=NIFOUR
C
C     VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
C
      CALL QUESUP(IPMODL,IPCAR,5,0,ISUP5,IRETMA)
      IF (ISUP5.GT.1) RETURN
C
C     ACTIVATION DU MODELE
C
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS=KMODEL(/1)
C
C     MISE A ZERO DES RIGIDITES
C
      DO IE1=1,12
        CRIGI(IE1)=0.D0
      ENDDO
C____________________________________________________________________
C
C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
C____________________________________________________________________
C
      DO 1000 ISOUS=1,NSOUS
*
*   INITIALISATION
*
         NMATF=0
         NMATR=0
         MOMATR=0
         IVAMAT=0
         NCARA=0
         NCARF=0
         MOCARA=0
         IVACAR=0
         IPMINT=0
C
C     ON RECUPERE L INFORMATION GENERALE
C
         IMODEL=KMODEL(ISOUS)
         SEGACT IMODEL
         IPMAIL=IMAMOD
         CONM  =CONMOD
*
         MELE=NEFMOD
         MELEME=IMAMOD
         SEGACT MELEME
         NBNN=NUM(/1)
         NBELEM=NUM(/2)
C
C     TRAITEMENT DU MODELE
C
         NFOR=FORMOD(/2)
         NMAT=MATMOD(/2)
C
C     NATURE DU MATERIAU
C
         CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INFIBR)
         IF (CMATE.EQ.' ')THEN
            CALL ERREUR(251)
            GOTO 9990
         ENDIF
         IF(MATE.NE.1)THEN
            CALL ERREUR(635)
            GOTO 9990
         ENDIF
         CALL TEMANF(INFIBR,NIFIBR)
         IF((NIFIBR.EQ.0).AND.(INFIBR.NE.0))THEN
            CALL ERREUR(636)
            GOTO 9990
         ENDIF
C____________________________________________________________________
C
C     INFORMATION SUR L'ELEMENT FINI
C____________________________________________________________________
C
*         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
*         IF (IERR.NE.0) GOTO 9990
*         INFO=IPINF
         MFR  =INFELE(13)
         IPPORE=0
         IF(MFR.EQ.33) IPPORE=NBNN

         IF (MFR.NE.47)THEN
            CALL ERREUR(637)
            GOTO 9990
         ENDIF
*
         NBG  =INFELE(6)
         NBGS =INFELE(4)
         LRE  =INFELE(9)
*         MINTE=INFELE(11)
         MINTE=INFMOD(7)
         IPMINT=MINTE
C
C     CREATION DU TABLEAU INFOS
C
         CALL IDENT(IPMAIL,CONM,IPCAR,IPCAR,INFOS,IRTD)
         IF (IRTD.EQ.0) GOTO 9990
*
*   TRAITEMENT DU CHAMP DE CARACTERISTIQUES MATERIELLES
*
        if(lnomid(6).ne.0) then
         nomid=lnomid(6)
         segact nomid
         momatr=nomid
         nmatr=lesobl(/2)
         nmatf=lesfac(/2)
         lsupma=.false.
        else
         lsupma=.true.
         CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF)
        endif
        IF (MOMATR.EQ.0) THEN
           MOTERR(1:4)='MATE'
           MOTERR(5:8)=NOMTP(MELE)
           CALL ERREUR (76)
           GOTO 9990
        ENDIF
*
           NBTYPE=1
           SEGINI NOTYPE
           MOTYPE=NOTYPE
           TYPE(1)='REAL*8'
*
        CALL KOMCHA(IPCAR,IPMAIL,CONM,MOMATR,MOTYPE,1,
     &                                  INFOS,3,IVAMAT)
        SEGSUP NOTYPE
        IF (IERR.NE.0) GOTO 9990
        NMATT=NMATR+NMATF
*
        IF (ISUP5.EQ.1) THEN
           CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
           IF(IERR.NE.0)THEN
              ISUP5=0
              GOTO 9990
           ENDIF
        ENDIF
*
*      TRAITEMENT DU CHAMP DE CARACTERISTIQUES GEOMETRIQUES
*
        if(lnomid(7).ne.0) then
         nomid=lnomid(7)
         segact nomid
         mocara=nomid
         ncara=lesobl(/2)
         ncarf=lesfac(/2)
         lsupca=.false.
        else
         lsupca=.true.
         CALL IDCARB(MELE,IFOUR,MOCARA,NCARA,NCARF)
        endif
*
        NBTYPE=1
        SEGINI NOTYPE
        MOTYPE=NOTYPE
        TYPE(1)='REAL*8'
*
        CALL KOMCHA(IPCAR,IPMAIL,CONM,MOCARA,MOTYPE,1,
     &                                     INFOS,3,IVACAR)
        SEGSUP NOTYPE
        IF (IERR.NE.0) GOTO 9990
        NCARR=NCARA+NCARF
*
        IF (ISUP5.EQ.1.AND.MOCARA.NE.0) THEN
           CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
           IF(IERR.NE.0)THEN
              ISUP5=0
              GOTO 9990
           ENDIF
        ENDIF
*
*     APPEL AU CALCUL PROPREMENT DIT
*
         CALL FRITH2(MELE,IPMAIL,IPMINT,NBGS,IVAMAT,IVACAR,
     &    NMATT,NCARR,CRIGI,IELA,ICONT)
*
 9990    CONTINUE
*
*     DESACTIVATION DES SEGMENTS
*
         SEGDES MELEME,IMODEL
         IF (IPMINT.NE.0) SEGDES,MINTE
*
         IF(ISUP5.EQ.1)THEN
            CALL DTMVAL (IVAMAT,3)
            CALL DTMVAL (IVACAR,3)
         ELSE
            CALL DTMVAL (IVAMAT,1)
            CALL DTMVAL (IVACAR,1)
         ENDIF
*
         IF (MOCARA.NE.0) THEN
            NOMID=MOCARA
            if(lsupca)SEGSUP NOMID
         END IF
*
         IF (MOMATR.NE.0) THEN
            NOMID=MOMATR
            if(lsupma)SEGSUP NOMID
         END IF
*
         IF (IERR.NE.0) GOTO 888
*
1000  CONTINUE
*
 888  CONTINUE
      SEGDES MMODEL

      RETURN
      END