C CADXFF    SOURCE    GOUNAND   05/12/21    21:15:03     5281           
      SUBROUTINE CADXFF(JAC,NPJA,NLJA,IREL,IREF,
     $     JSDETG,IG,IGH,IGHIG,
     $     NOMLOI,
     $     FC,NPFC,NLFC,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : CADXFF
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,NPJA,NLJA)
      REAL*8 JSDETG(NPJA,NLJA)
      REAL*8 IG(IREF,IREF,NPJA,NLJA)
      REAL*8 IGH(IREF,IREF,NPJA,NLJA)
      REAL*8 IGHIG(IREF,IREF,NPJA,NLJA)
      CHARACTER*8 NOMLOI
      REAL*8 FC(NPFC,NLFC)
*     
      INTEGER IMPR,IRET
*     
* Executable statements
*     
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans cadxff'
*     
      DO ILFC=1,NLFC
         IF (NLJA.EQ.1) THEN
            ILJA=1
         ELSE
            ILJA=ILFC
         ENDIF
         DO IPFC=1,NPFC
            IF (NPJA.EQ.1) THEN
               IPJA=1
            ELSE
               IPJA=IPFC
            ENDIF
            SDETG=JSDETG(IPJA,ILJA)
*     
            
            CALL MARE(IGH(1,1,IPJA,ILJA),IREF,IREF,'TRACE   ',
     $           TRIGH,IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
*     
* Calcul de la fonctionnelle
*     
            IF (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,IPJA,ILJA)*JAC(IDIM1,J,IPJA,ILJA)
     $                    *IGH(IDIM2,I,IPJA,ILJA))
                  ENDDO
               ENDDO
               TR2=0.D0
               DO I=1,IREF
                  DO L=1,IREF
                     TR2=TR2+
     $                    (IG(I,IDIM2,IPJA,ILJA)*JAC(IDIM1,L,IPJA,ILJA)
     $                    *IGH(L,I,IPJA,ILJA))
                  ENDDO
               ENDDO
               CONTR1=-0.5D0*(TR1+TR2)*SDETG
               TR3=0.D0
               DO J=1,IREF
                  TR3=TR3+
     $                 (IG(IDIM2,J,IPJA,ILJA)*JAC(IDIM1,J,IPJA,ILJA))
               ENDDO
               TR4=0.D0
               DO I=1,IREF
                  TR4=TR4+
     $                 (IG(I,IDIM2,IPJA,ILJA)*JAC(IDIM1,I,IPJA,ILJA))
               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,IPJA,ILJA)*IG(K,IDIM2,IPJA,ILJA))
               ENDDO
*     
               TR1=0.D0
               DO I=1,IREF
                  DO J=1,IREF
                     TR1=TR1+
     $                    (IG(I,J,IPJA,ILJA)*JAC(IDIM3,J,IPJA,ILJA)
     $                    *IGH(IDIM4,I,IPJA,ILJA))
                  ENDDO
               ENDDO
               TR2=0.D0
               DO I=1,IREF
                  DO M=1,IREF
                     TR2=TR2+
     $                    (IG(I,IDIM4,IPJA,ILJA)*JAC(IDIM3,M,IPJA,ILJA)
     $                    *IGH(M,I,IPJA,ILJA))
                  ENDDO
               ENDDO
*     
*     
               TR3=0.D0
               DO K=1,IREF
                  DO L=1,IREF
                     TR3=TR3+
     $                    (JAC(IDIM1,K,IPJA,ILJA)*IG(K,L,IPJA,ILJA)
     $                    *JAC(IDIM3,L,IPJA,ILJA)*IGHIG(IDIM4,IDIM2,IPJA
     $                    ,ILJA))
                  ENDDO
               ENDDO
               TR3=TR3*(-1.D0)
*     
               TR4=0.D0
               DO K=1,IREF
                  DO IO=1,IREF
                     TR4=TR4+
     $                    (JAC(IDIM1,K,IPJA,ILJA)*IGHIG(K,IDIM4,IPJA
     $                    ,ILJA)*JAC(IDIM3,IO,IPJA,ILJA)*IG(IO,IDIM2
     $                    ,IPJA,ILJA))
                  ENDDO
               ENDDO
               TR4=TR4*(-1.D0)
*     
               TR5=0.D0
               IF (IDIM1.EQ.IDIM3) THEN
                  TR5=TR5+
     $                 (IGHIG(IDIM4,IDIM2,IPJA,ILJA))
               ENDIF
*     
               TR6=0.D0
               DO K=1,IREF
                  DO M=1,IREF
                     TR6=TR6+
     $                    (JAC(IDIM1,K,IPJA,ILJA)*IGHIG(K,M,IPJA,ILJA)
     $                    *JAC(IDIM3,M,IPJA,ILJA)*IG(IDIM4,IDIM2,IPJA
     $                    ,ILJA))
                  ENDDO
               ENDDO
               TR6=TR6*(-1.D0)
*     
               TR7=0.D0
               DO K=1,IREF
                  DO N=1,IREF
                     TR7=TR7+
     $                    (JAC(IDIM1,K,IPJA,ILJA)*IG(K,IDIM4,IPJA,ILJA)
     $                    *JAC(IDIM3,N,IPJA,ILJA)*IGHIG(N,IDIM2,IPJA
     $                    ,ILJA))
                  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,IPJA,ILJA)*IGHIG(K,IDIM2,IPJA,ILJA))
               ENDDO
               TR10=TR10*(-2.D0)
*     
               TR0=0.D0
               DO K=1,IREF
                  TR0=TR0+
     $                 (JAC(IDIM1,K,IPJA,ILJA)*IG(K,IDIM2,IPJA,ILJA))
               ENDDO
*     
               TR11=0.D0
               DO J=1,IREF
                  TR11=TR11+
     $                 (IG(IDIM4,J,IPJA,ILJA)*JAC(IDIM3,J,IPJA,ILJA))
               ENDDO
               TR12=0.D0
               DO I=1,IREF
                  TR12=TR12+
     $                 (IG(I,IDIM4,IPJA,ILJA)*JAC(IDIM3,I,IPJA,ILJA))
               ENDDO

*     
*     
               TR13=0.D0
               DO K=1,IREF
                  DO L=1,IREF
                     TR13=TR13+
     $                    (JAC(IDIM1,K,IPJA,ILJA)*IG(K,L,IPJA,ILJA)
     $                    *JAC(IDIM3,L,IPJA,ILJA)*IG(IDIM4,IDIM2,IPJA
     $                    ,ILJA))
                  ENDDO
               ENDDO
               TR13=TR13*(-1.D0)
               TR14=0.D0
               DO K=1,IREF
                  DO N=1,IREF
                     TR14=TR14+
     $                    (JAC(IDIM1,K,IPJA,ILJA)*IG(K,IDIM4,IPJA,ILJA)
     $                    *JAC(IDIM3,N,IPJA,ILJA)*IG(N,IDIM2,IPJA,ILJA))
                  ENDDO
               ENDDO
               TR14=TR14*(-1.D0)
*     
               TR15=0.D0
               IF (IDIM1.EQ.IDIM3) THEN
                  TR15=TR15+IG(IDIM4,IDIM2,IPJA,ILJA)
               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
            FC(IPFC,ILFC)=
     $           FC(IPFC,ILFC)+
     $           CONTRI
         ENDDO
      ENDDO
*     
* Normal termination
*     
      IRET=0
      RETURN
*     
* Format handling
*     
*     
* Error handling
*     
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine cadxff'
      RETURN
*     
* End of subroutine CADXFF
*     
      END