C CGADXF    SOURCE    GOUNAND   05/12/21    21:17:04     5281           
      SUBROUTINE CGADXF(JAC,IREL,IREF,
     $     SDETG,IG,IGH,IGHIG,
     $     NOMLOI,
     $     CONTRI,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : CGADXF
C DESCRIPTION : Calcul de la loi de comportement aux points de Gauss :
C               Partie en Fortran 77
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, 04/08/04, version initiale
C HISTORIQUE : v1, 04/08/04, création
C HISTORIQUE :
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 CCOPTIO
      REAL*8 JAC(IREL,IREF)
      REAL*8 SDETG
      REAL*8 IG(IREF,IREF)
      REAL*8 IGH(IREF,IREF)
      REAL*8 IGHIG(IREF,IREF)
      CHARACTER*8 NOMLOI
      REAL*8 CONTRI
*     
      INTEGER IMPR,IRET
*     
* Executable statements
*     
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans cgadxf'
*     
      
      CALL MARE(IGH,IREF,IREF,'TRACE   ',
     $     TRIGH,IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*
* Calcul du déterminant
*
      IF (NOMLOI.EQ.'ADCD    ') THEN
         CONTRI=SDETG
*     
* Calcul de la fonctionnelle
*     
      ELSEIF (NOMLOI.EQ.'ADCF    ') THEN
         CONTRI=0.5D0*TRIGH*SDETG
*     
* Calcul du résidu
*     
      ELSEIF (NOMLOI(1:4).EQ.'ADCR') 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
         TR1=0.D0
         DO I=1,IREF
            DO J=1,IREF
               TR1=TR1+
     $              (IG(I,J)*JAC(IDIM1,J)*IGH(IDIM2,I))
            ENDDO
         ENDDO
         TR2=0.D0
         DO I=1,IREF
            DO L=1,IREF
               TR2=TR2+
     $              (IG(I,IDIM2)*JAC(IDIM1,L)*IGH(L,I))
            ENDDO
         ENDDO
         CONTR1=-0.5D0*(TR1+TR2)*SDETG
         TR3=0.D0
         DO J=1,IREF
            TR3=TR3+
     $           (IG(IDIM2,J)*JAC(IDIM1,J))
         ENDDO
         TR4=0.D0
         DO I=1,IREF
            TR4=TR4+
     $           (IG(I,IDIM2)*JAC(IDIM1,I))
         ENDDO
         CONTR2=0.25D0*(TR3+TR4)*TRIGH*SDETG
         CONTRI=CONTR1+CONTR2
*               CONTRI=CONTR1
C               WRITE(IOIMP,*) 'ADCR'
C               WRITE(IOIMP,*) 'TR1=',TR1
C               WRITE(IOIMP,*) 'TR2=',TR2
C               WRITE(IOIMP,*) 'TR3=',TR3
C               WRITE(IOIMP,*) 'TR4=',TR4
*     
* Calcul du jacobien
*     
      ELSEIF (NOMLOI(1:4).EQ.'ADCJ') 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
         CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
         IF (IRET.NE.0) GOTO 9999
         TR0=0.D0
         DO K=1,IREF
            TR0=TR0+
     $           (JAC(IDIM1,K)*IG(K,IDIM2))
         ENDDO
*     
         TR1=0.D0
         DO I=1,IREF
            DO J=1,IREF
               TR1=TR1+
     $              (IG(I,J)*JAC(IDIM3,J)*IGH(IDIM4,I))
            ENDDO
         ENDDO
         TR2=0.D0
         DO I=1,IREF
            DO M=1,IREF
               TR2=TR2+
     $              (IG(I,IDIM4)*JAC(IDIM3,M)*IGH(M,I))
            ENDDO
         ENDDO
*     
*     
         TR3=0.D0
         DO K=1,IREF
            DO L=1,IREF
               TR3=TR3+
     $              (JAC(IDIM1,K)*IG(K,L)*JAC(IDIM3,L)
     $              *IGHIG(IDIM4,IDIM2))
            ENDDO
         ENDDO
         TR3=TR3*(-1.D0)
*     
         TR4=0.D0
         DO K=1,IREF
            DO IO=1,IREF
               TR4=TR4+
     $              (JAC(IDIM1,K)*IGHIG(K,IDIM4)
     $              *JAC(IDIM3,IO)*IG(IO,IDIM2))
            ENDDO
         ENDDO
         TR4=TR4*(-1.D0)
*     
         TR5=0.D0
         IF (IDIM1.EQ.IDIM3) THEN
            TR5=TR5+
     $           (IGHIG(IDIM4,IDIM2))
         ENDIF
*     
         TR6=0.D0
         DO K=1,IREF
            DO M=1,IREF
               TR6=TR6+
     $              (JAC(IDIM1,K)*IGHIG(K,M)
     $              *JAC(IDIM3,M)*IG(IDIM4,IDIM2))
            ENDDO
         ENDDO
         TR6=TR6*(-1.D0)
*     
         TR7=0.D0
         DO K=1,IREF
            DO N=1,IREF
               TR7=TR7+
     $              (JAC(IDIM1,K)*IG(K,IDIM4)*JAC(IDIM3,N)
     $              *IGHIG(N,IDIM2))
            ENDDO
         ENDDO
         TR7=TR7*(-1.D0)
         CONTR1=(TR1+TR2)*TR0
         CONTR2=(TR3+TR4+TR5+TR6+TR7)*2.D0
         CONT11=(CONTR1+CONTR2)*SDETG
****  
****  
         TR10=0.D0
         DO K=1,IREF
            TR10=TR10+
     $           (JAC(IDIM1,K)*IGHIG(K,IDIM2))
         ENDDO
         TR10=TR10*(-2.D0)
*     
         TR0=0.D0
         DO K=1,IREF
            TR0=TR0+
     $           (JAC(IDIM1,K)*IG(K,IDIM2))
         ENDDO
*     
         TR11=0.D0
         DO J=1,IREF
            TR11=TR11+
     $           (IG(IDIM4,J)*JAC(IDIM3,J))
         ENDDO
         TR12=0.D0
         DO I=1,IREF
            TR12=TR12+
     $           (IG(I,IDIM4)*JAC(IDIM3,I))
         ENDDO

*     
*     
         TR13=0.D0
         DO K=1,IREF
            DO L=1,IREF
               TR13=TR13+
     $              (JAC(IDIM1,K)*IG(K,L)*JAC(IDIM3,L)
     $              *IG(IDIM4,IDIM2))
            ENDDO
         ENDDO
         TR13=TR13*(-1.D0)
         TR14=0.D0
         DO K=1,IREF
            DO N=1,IREF
               TR14=TR14+
     $              (JAC(IDIM1,K)*IG(K,IDIM4)
     $              *JAC(IDIM3,N)*IG(N,IDIM2))
            ENDDO
         ENDDO
         TR14=TR14*(-1.D0)
*     
         TR15=0.D0
         IF (IDIM1.EQ.IDIM3) THEN
            TR15=TR15+IG(IDIM4,IDIM2)
         ENDIF
*     
         CONTR3=(TR11+TR12)*(TR10+(TR0*TRIGH))*SDETG
         CONTR4=(TR13+TR14+TR15)*2.D0*TRIGH*SDETG
         CONT12=(CONTR3+CONTR4)
***** 
***** Finalement !
***** 
*               WRITE(IOIMP,*) 'CONT11=',CONT11
*               WRITE(IOIMP,*) 'CONT12=',CONT12
         CONTRI=(CONT11*(-0.5D0))
     $        +(CONT12*0.25D0)
*               CONTRI=(CONT11*(-0.5D0))
C*    
C* Calcul du résidu (test)
C*    
C            ELSEIF (NOMLOI(1:4).EQ.'ADCS') THEN
C               CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
CC               TR1=JAC(IDIM1,IDIM2)
C               TR1=0.D0
C               DO I=1,IREF
C                  DO J=1,IREF
C                     TR1=TR1+
C     $               (IG(I,J)*JAC(IDIM1,J)*IGH(IDIM2,I))
C*     $               (IG(I,J)*JAC(IDIM1,J)*IG(IDIM2,I))
C                  ENDDO
C               ENDDO
C               TR2=0.D0
C               DO I=1,IREF
C                  DO M=1,IREF
C                     TR2=TR2+
C     $               (IG(I,IDIM2)*JAC(IDIM1,M)*IGH(M,I))
C                  ENDDO
C               ENDDO
C               CONTRI=(TR1+TR2)*SDETG
C*               CONTRI=(TR1+TR2)
C*               CONTRI=TR1
C*    
C* Calcul du jacobien (test)
C*    
C            ELSEIF (NOMLOI(1:4).EQ.'ADCK') THEN
C               CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
CC               IF ((IDIM1.EQ.IDIM3).AND.(IDIM2.EQ.IDIM4)) THEN
CC                  CONTRI=1.D0
CC               ELSE
CC                  CONTRI=0.D0
CC               ENDIF
C               TR0=0.D0
C               DO K=1,IREF
C                  TR0=TR0+
C     $                 (JAC(IDIM1,K)*IG(K,IDIM2))
C               ENDDO
C*    
C               TR1=0.D0
C               DO I=1,IREF
C                  DO J=1,IREF
C                     TR1=TR1+
C     $               (IG(I,J)*JAC(IDIM3,J)*IGH(IDIM4,I))
C                  ENDDO
C               ENDDO
C               TR2=0.D0
C               DO I=1,IREF
C                  DO M=1,IREF
C                     TR2=TR2+
C     $               (IG(I,IDIM4)*JAC(IDIM3,M)*IGH(M,I))
C                  ENDDO
C               ENDDO
C*    
C*    
C               TR3=0.D0
C               DO K=1,IREF
C                  DO L=1,IREF
C                     DO IO=1,IREF
C                        TR3=TR3+
C     $         (JAC(IDIM1,K)*IG(K,L)*JAC(IDIM3,L)
C     $                       *IG(IDIM4,IO)*HIG(IO,IDIM2))
C*     $         (JAC(IDIM1,K)*IG(K,L)*JAC(IDIM3,L)
C*     $                       *IG(IDIM4,IO)*IG(IO,IDIM2))
C                     ENDDO
C                  ENDDO
C               ENDDO
C               TR3=TR3*(-1.D0)
C*    
C               TR4=0.D0
C               DO K=1,IREF
C                  DO L=1,IREF
C                     DO IO=1,IREF
C                        TR4=TR4+
C     $         (JAC(IDIM1,K)*IGH(K,L)*IG(L,IDIM4)
C     $                       *JAC(IDIM3,IO)*IG(IO,IDIM2))
C*     $         (JAC(IDIM1,K)*IG(K,L)*IG(L,IDIM4)
C*     $                       *JAC(IDIM3,IO)*IG(IO,IDIM2))
C                     ENDDO
C                  ENDDO
C               ENDDO
C               TR4=TR4*(-1.D0)
C*    
C               TR5=0.D0
C               IF (IDIM1.EQ.IDIM3) THEN
C                  DO L=1,IREF
C                     TR5=TR5+
C     $                 (IGH(IDIM4,L)*IG(L,IDIM2))
C*     $                 (IG(IDIM4,L)*IG(L,IDIM2))
C                  ENDDO
C               ENDIF
C*    
C               TR6=0.D0
C               DO K=1,IREF
C                  DO L=1,IREF
C                     DO M=1,IREF
C                        TR6=TR6+
C     $         (JAC(IDIM1,K)*IGH(K,L)*IG(L,M)
C     $                       *JAC(IDIM3,M)*IG(IDIM4,IDIM2))
C                     ENDDO
C                  ENDDO
C               ENDDO
C               TR6=TR6*(-1.D0)
C*    
C               TR7=0.D0
C               DO K=1,IREF
C                  DO N=1,IREF
C                     DO IO=1,IREF
C                        TR7=TR7+
C     $         (JAC(IDIM1,K)*IG(K,IDIM4)*JAC(IDIM3,N)
C     $                       *IG(N,IO)*HIG(IO,IDIM2))
C                     ENDDO
C                  ENDDO
C               ENDDO
C               TR7=TR7*(-1.D0)
C*    
C               CONTR1=(TR1+TR2)*TR0
C               CONTR2=(TR3+TR4+TR5+TR6+TR7)*2.D0
C               CONTRI=(CONTR1+CONTR2)*SDETG
C*               CONTRI=(TR3+TR4+TR5+TR6+TR7)+(TR3B+TR4B+TR5B+TR6B+TR7B)
C*               CONTRI=(TR3+TR4+TR5+TR6+TR7)
C*    
C*               WRITE(IOIMP,*) 'CONTRI=',CONTRI
C*    
C* Calcul du résidu (test)
C*    
C            ELSEIF (NOMLOI(1:4).EQ.'ADCS') THEN
C               CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               TR11=0.D0
C               DO J=1,IREF
C                  TR11=TR11+
C     $                 (IG(IDIM2,J)*JAC(IDIM1,J))
C               ENDDO
C               TR12=0.D0
C               DO I=1,IREF
C                  TR12=TR12+
C     $                 (IG(I,IDIM2)*JAC(IDIM1,I))
C               ENDDO
C               CONTRI=(TR11+TR12)*TRIGH*SDETG
C*    
C* Calcul du jacobien (test)
C*    
C            ELSEIF (NOMLOI(1:4).EQ.'ADCK') THEN
C               CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C*    
C               TR10=0.D0
C               DO K=1,IREF
C                  DO L=1,IREF
C                     TR10=TR10+
C     $               (JAC(IDIM1,K)*IG(K,L)*HIG(L,IDIM2))
C                  ENDDO
C               ENDDO
C               TR10=TR10*(-2.D0)
C*    
C               TR0=0.D0
C               DO K=1,IREF
C                  TR0=TR0+
C     $                 (JAC(IDIM1,K)*IG(K,IDIM2))
C               ENDDO
C*    
C               TR11=0.D0
C               DO J=1,IREF
C                  TR11=TR11+
C     $                 (IG(IDIM4,J)*JAC(IDIM3,J))
C               ENDDO
C               TR12=0.D0
C               DO I=1,IREF
C                  TR12=TR12+
C     $                 (IG(I,IDIM4)*JAC(IDIM3,I))
C               ENDDO
C     
C*    
C*    
C               TR13=0.D0
C               DO K=1,IREF
C                  DO L=1,IREF
C                     TR13=TR13+
C     $         (JAC(IDIM1,K)*IG(K,L)*JAC(IDIM3,L)
C     $                       *IG(IDIM4,IDIM2))
C                  ENDDO
C               ENDDO
C               TR13=TR13*(-1.D0)
C               TR14=0.D0
C               DO K=1,IREF
C                  DO N=1,IREF
C                     TR14=TR14+
C     $         (JAC(IDIM1,K)*IG(K,IDIM4)
C     $                       *JAC(IDIM3,N)*IG(N,IDIM2))
C                  ENDDO
C               ENDDO
C               TR14=TR14*(-1.D0)
C*    
C               TR15=0.D0
C               IF (IDIM1.EQ.IDIM3) THEN
C                  TR15=TR15+IG(IDIM4,IDIM2)
C               ENDIF
C*    
CC               CONTRI=(TR13+TR14+TR15)*2.D0
C               CONTR3=(TR11+TR12)*(TR10+(TR0*TRIGH))*SDETG
C               CONTR4=(TR13+TR14+TR15)*2.D0*TRIGH*SDETG
CC               CONTR1=(TR1+TR2)*TR0
CC               CONTR2=(TR3+TR4+TR5+TR6+TR7)*2.D0
CC               CONTRI=(CONTR1+CONTR2)*SDETG
C               CONTRI=(CONTR3+CONTR4)
C*    
C               WRITE(IOIMP,*) 'CONTRI=',CONTRI
      ELSE
         WRITE(IOIMP,*) 'Erreur grave'
         GOTO 9999
      ENDIF
*     
* Normal termination
*     
      IRET=0
      RETURN
*     
* Format handling
*     
*     
* Error handling
*     
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine cgadxf'
      RETURN
*     
* End of subroutine CGADXF
*     
      END