C CCGMTL    SOURCE    GOUNAND   26/06/09    21:15:03     12566          
      SUBROUTINE CCGMTL(LCOF,NOMLOI,
     $     FC,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : CCGMTL
C DESCRIPTION : Lois de comportement aux points de Gauss :
C      Métrique locale par rapport à un élément de référence
C      régulier ponderee par une metrique globale M
C
C               (Copie de CCGMET et CCGAHU)
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          :
C APPELE PAR       :
C***********************************************************************
C ENTREES            :
C ENTREES/SORTIES    :
C SORTIES            : -
C TRAVAIL            :
C***********************************************************************
C VERSION    : v1, 2026/04/14, version initiale
C HISTORIQUE : v1, 2026/04/14, création
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************

-INC PPARAM
-INC CCOPTIO
-INC CCREEL
-INC TNLIN
*-INC SMCHAEL
      INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
      POINTEUR FC.MCHEVA
      POINTEUR LCOF.LCHEVA
      POINTEUR JMAJAC.MCHEVA
      POINTEUR JMIJAC.MCHEVA
      POINTEUR JDTJAC.MCHEVA
      POINTEUR JMET.MCHEVA
      POINTEUR JMAREG.MCHEVA
      CHARACTER*8 NOMLOI
      INTEGER ICOF
*
-INC TMXMAT
* Objets temporaires
      POINTEUR JAC.MXMAT,J.MXMAT,MJ.MXMAT,JT.MXMAT
      POINTEUR JR.MXMAT,IJR.MXMAT,G.MXMAT,IG.MXMAT,GTMP.MXMAT
      POINTEUR M.MXMAT
*
      SEGMENT MCOF
      POINTEUR COEF(IDIM,IDIM).MCHEVA
      ENDSEGMENT
      POINTEUR MET.MCOF
*
      INTEGER IMPR,IRET
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgmtl'
C      IF (.NOT.(IDIM.EQ.1)) THEN
C         WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
C         GOTO 9999
C      ENDIF
      NLFC=FC.WELCHE(/6)
      NPFC=FC.WELCHE(/5)
      ICOF=0
*
*     Récupération des coefficients de la metrique
*
      SEGINI MET
      DO IIDIM=1,IDIM
         ICOF=ICOF+1
         JMET=LCOF.LISCHE(ICOF)
         IF (ICOF.EQ.1) THEN
            NLJM=JMET.WELCHE(/6)
            NPJM=JMET.WELCHE(/5)
         ELSE
            NLJM2=JMET.WELCHE(/6)
            NPJM2=JMET.WELCHE(/5)
            IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
               WRITE(IOIMP,*) 'Erreur grave dims JMET'
               GOTO 9999
            ENDIF
         ENDIF
         MET.COEF(IIDIM,IIDIM)=JMET
      ENDDO
      DO IIDIM=1,IDIM
         NJ=IDIM-IIDIM
         IF (NJ.GE.1) THEN
            DO JIDIM=IIDIM+1,IDIM
               ICOF=ICOF+1
               JMET=LCOF.LISCHE(ICOF)
               NLJM2=JMET.WELCHE(/6)
               NPJM2=JMET.WELCHE(/5)
               IF (NLJM2.NE.NLJM.OR.NPJM2.NE.NPJM) THEN
                  WRITE(IOIMP,*) 'Erreur grave dims JMET2'
                  GOTO 9999
               ENDIF
               MET.COEF(IIDIM,JIDIM)=JMET
            ENDDO
         ENDIF
      ENDDO
*
      ICOF=ICOF+1
      JMAJAC=LCOF.LISCHE(ICOF)
      NLJA=JMAJAC.WELCHE(/6)
      NPJA=JMAJAC.WELCHE(/5)
      IREF=JMAJAC.WELCHE(/4)
      IREL=JMAJAC.WELCHE(/3)
*
      IF (IREL.NE.IDIM) THEN
         WRITE(IOIMP,*) 'Erreur dims JMAJAC'
         GOTO 9999
      ENDIF
*
      ICOF=ICOF+1
      ICOF=ICOF+1
      ICOF=ICOF+1
      JMAREG=LCOF.LISCHE(ICOF)
      NLJR=JMAREG.WELCHE(/6)
      NPJR=JMAREG.WELCHE(/5)
      I1  =JMAREG.WELCHE(/4)
      I2  =JMAREG.WELCHE(/3)
      IF ((NLJR.NE.1).OR.(NPJR.NE.1).OR.(I1.NE.IREF).OR.(I2.NE.IREF))
     $     THEN
         WRITE(IOIMP,*) 'Erreur dims JMAREG'
         GOTO 9999
      ENDIF
*
* Objets temporaires et à préconditionner
*
      LDIM1=IREL
      LDIM2=IREF
      SEGINI,JAC
      SEGINI,J
      SEGINI,MJ
      LDIM1=IREF
      LDIM2=IREL
      SEGINI,JT
      LDIM1=IREF
      LDIM2=IREF
      SEGINI,JR
      SEGINI,IJR
      SEGINI,G
      SEGINI,IG
*      SEGINI,GTMP
      LDIM1=IREL
      LDIM2=IREL
      SEGINI,M
*
* Calcul de la métrique des éléments réguliers
*
      CALL MAMA(JMAREG.WELCHE,IREF,IREF,
     $     'COPIE   ',JR.XMAT,IREF,IREF,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*      SEGPRT,JR
* Calcul de l'inverse, du déterminant et trace de l'inverse de h
      CALL GEOLI2(IREF,1,1,JR.XMAT,IJR.XMAT,DETJR,
     $     IMPR,IRET)
      IF (IRET.NE.0) THEN
         WRITE(IOIMP,*)
     $        'Jacobien des elements reguliers non inversible'
         SEGPRT,JMAREG
         SEGPRT,IJR
         GOTO 9999
      ENDIF
*      SEGPRT,IJR
*
      DO ILFC=1,NLFC
         IF (NLJM.EQ.1) THEN
            ILJM=1
         ELSE
            ILJM=ILFC
         ENDIF
         IF (NLJA.EQ.1) THEN
            ILJA=1
         ELSE
            ILJA=ILFC
         ENDIF
         DO IPFC=1,NPFC
            IF (NPJM.EQ.1) THEN
               IPJM=1
            ELSE
               IPJM=IPFC
            ENDIF
            IF (NPJA.EQ.1) THEN
               IPJA=1
            ELSE
               IPJA=IPFC
            ENDIF
*
* Copie des coefficients de la métrique
*
            DO IIDIM=1,IDIM
               JMET=MET.COEF(IIDIM,IIDIM)
               M.XMAT(IIDIM,IIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
            ENDDO
            DO IIDIM=1,IIDIM
               NJ=IDIM-IIDIM
               IF (NJ.GE.1) THEN
                  DO JIDIM=IIDIM+1,IDIM
                     JMET=MET.COEF(IIDIM,JIDIM)
                     M.XMAT(IIDIM,JIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
                     M.XMAT(JIDIM,IIDIM)=JMET.WELCHE(1,1,1,1,IPJM,ILJM)
                  ENDDO
               ENDIF
            ENDDO
*            SEGPRT,M
*
* Copie du jacobien
*
            CALL MAMA(JMAJAC.WELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
     $           'COPIE   ',
     $           JAC.XMAT,IREL,IREF,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*            SEGPRT,JAC
*
* Jacobien complet
*
            CALL MAMAMA(JAC.XMAT,IREL,IREF,IJR.XMAT,IREF,IREF,
     $           'FOIS    ',J.XMAT,IREL,IREF,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*
* Calcul de la métrique G = Jt M J
*
*     Calcul de Jt
            CALL MAMA(J.XMAT,IREL,IREF,
     $           'TRANSPOS',JT.XMAT,IREF,IREL,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*            SEGPRT,JT
*     Calcul de MJ
            CALL MAMAMA(M.XMAT,IREL,IREL,J.XMAT,IREL,IREF,
     $           'FOIS    ',MJ.XMAT,IREL,IREF,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*     Calcul de G=JtMJ
            CALL MAMAMA(JT.XMAT,IREF,IREL,MJ.XMAT,IREL,IREF,
     $           'FOIS    ',G.XMAT,IREF,IREF,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*            SEGPRT,G
            CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,XM,IMPR,IRET)
            IF (IRET.GT.0) GOTO 9999
*            write(ioimp,*) 'In ccgmtl: JTMJ XM=',XM
            XM=SQRT(MAX(XM,XZERO))
            CALL MARE(G.XMAT,IREF,IREF,'TRACE   ',XL,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*            write(ioimp,*) 'In ccgmtl: JTMJ XL=',XL

            IF (IREF.EQ.IREL) THEN
c$$$               CALL GEOLI2(IREF,1,1,JAC.XMAT,GTMP.XMAT,XDET,
c$$$     $              IMPR,IRET)
c$$$               IF (IRET.GT.0) GOTO 9999
c$$$               CALL MARE(JAC.XMAT,IREF,IREF,'TRACE   ',
c$$$     $              XTRA,IMPR,IRET)
c$$$               IF (IRET.NE.0) GOTO 9999
c$$$               write(ioimp,*) 'In ccgmtl: JAC XDET,XTRA=',XDET,XTRA
c$$$               CALL GEOLI2(IREF,1,1,M.XMAT,GTMP.XMAT,XDET,
c$$$     $              IMPR,IRET)
c$$$               IF (IRET.GT.0) GOTO 9999
c$$$               CALL MARE(M.XMAT,IREF,IREF,'TRACE   ',
c$$$     $              XTRA,IMPR,IRET)
c$$$               IF (IRET.NE.0) GOTO 9999
c$$$               write(ioimp,*) 'In ccgmtl: MET XDET,XTRA=',XDET,XTRA
c$$$               CALL GEOLI2(IREF,1,1,G.XMAT,GTMP.XMAT,XM,
c$$$     $              IMPR,IRET)
c$$$               IF (IRET.GT.0) GOTO 9999
c$$$               CALL MARE(G.XMAT,IREF,IREF,'TRACE   ',
c$$$     $              XL,IMPR,IRET)
c$$$               IF (IRET.NE.0) GOTO 9999
c$$$               write(ioimp,*) 'In ccgmtl: JTMJ XM,XL=',XM,XL
            ENDIF
*
* Calcul des la métrique inverse de l'élément
*
            IF (NOMLOI(1:4).EQ.'METL') THEN
               CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
               IF (IRET.NE.0) GOTO 9999
               CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
               IF (IRET.NE.0) GOTO 9999
               CONTRI=G.XMAT(IDIM1,IDIM2)
*               WRITE(IOIMP,*) 'CONTRI=',CONTRI
            ELSE
               WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
               WRITE(IOIMP,*) 'Erreur grave'
               GOTO 9999
            ENDIF
            FC.WELCHE(1,1,1,1,IPFC,ILFC)=
     $           FC.WELCHE(1,1,1,1,IPFC,ILFC)+
     $           CONTRI
         ENDDO
      ENDDO
      SEGSUP,M
      SEGSUP,G
      SEGSUP,IJR
      SEGSUP,JR
      SEGSUP,JT
      SEGSUP,MJ
      SEGSUP,J
      SEGSUP,JAC
      SEGSUP,MET
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine ccgmtl'
      RETURN
*
* End of subroutine CCGMTL
*
      END