Sources Esope | Cast3M

ccgadv
C CCGADV    SOURCE    GOUNAND   21/06/02    21:15:08     11022          
      SUBROUTINE CCGADV(LCOF,NOMLOI,
     $     FC,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : CCGADV
C DESCRIPTION : Calcul de la loi de comportement aux points de Gauss :
C
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 PPARAM
-INC CCOPTIO
-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
      CHARACTER*8 NOMLOI
      INTEGER ICOF
*
-INC TMXMAT
      POINTEUR JAC.MXMAT
      POINTEUR JM1.MXMAT
      POINTEUR M1.MXMAT
      POINTEUR M2.MXMAT
      POINTEUR M3.MXMAT
*
      INTEGER IMPR,IRET
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgadv'
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
*
      ICOF=ICOF+1
      JMAJAC=LCOF.LISCHE(ICOF)
      NLJA=JMAJAC.WELCHE(/6)
      NPJA=JMAJAC.WELCHE(/5)
      ICOF=ICOF+1
      JMIJAC=LCOF.LISCHE(ICOF)
      NLJI=JMIJAC.WELCHE(/6)
      NPJI=JMIJAC.WELCHE(/5)
      ICOF=ICOF+1
      JDTJAC=LCOF.LISCHE(ICOF)
      NLJD=JDTJAC.WELCHE(/6)
      NPJD=JDTJAC.WELCHE(/5)
*g      LDIM1=JMAJAC.WELCHE(/3)
*g      LDIM2=JMAJAC.WELCHE(/4)
*g      IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN
*g         WRITE(IOIMP,*) 'Erreur grave 1'
*g         GOTO 9999
*g      ENDIF
*g      SEGINI,JAC
*g      LDIM1=JMIJAC.WELCHE(/3)
*g      LDIM2=JMIJAC.WELCHE(/4)
*g      IF (LDIM1.NE.IDIM.OR.LDIM2.NE.IDIM) THEN
*g         WRITE(IOIMP,*) 'Erreur grave 2'
*g         GOTO 9999
*g      ENDIF
*g      SEGINI,JM1
*
* Objet temporaire
*
*g      LDIM1=IDIM
*g      LDIM2=IDIM
*g      SEGINI,M1
*g      SEGINI,M2=M1
*g      SEGINI,M3=M1
      DO ILFC=1,NLFC
         IF (NLJA.EQ.1) THEN
            ILJA=1
         ELSE
            ILJA=ILFC
         ENDIF
         IF (NLJI.EQ.1) THEN
            ILJI=1
         ELSE
            ILJI=ILFC
         ENDIF
         IF (NLJD.EQ.1) THEN
            ILJD=1
         ELSE
            ILJD=ILFC
         ENDIF
         DO IPFC=1,NPFC
            IF (NPJA.EQ.1) THEN
               IPJA=1
            ELSE
               IPJA=IPFC
            ENDIF
            IF (NPJI.EQ.1) THEN
               IPJI=1
            ELSE
               IPJI=IPFC
            ENDIF
            IF (NPJD.EQ.1) THEN
               IPJD=1
            ELSE
               IPJD=IPFC
            ENDIF
C            CALL MAMA(JMAJAC.WELCHE(1,1,1,1,IPJA,ILJA),IDIM,IDIM
C     $           'COPIE   ',
C     $           JAC.XMAT,IDIM,IDIM,
C     $           IMPR,IRET)
C            IF (IRET.NE.0) GOTO 9999
*g            CALL MAMA(JMIJAC.WELCHE(1,1,1,1,IPJI,ILJI),IDIM,IDIM,
*g     $           'COPIE   ',
*g     $           JM1.XMAT,IDIM,IDIM,
*g     $           IMPR,IRET)
*g            IF (IRET.NE.0) GOTO 9999
            DET  =JDTJAC.WELCHE(1,1,1,1,IPJD,ILJD)
            SDET =SIGN(1.D0,DET)
            IF (NOMLOI.EQ.'VOLORI  ') THEN
               CONTRI=DET
C            ELSEIF (NOMLOI.EQ.'ADAF    ') THEN
C               CALL ERREUR(5)
CC               WRITE(IOIMP,*) 'J-1=',JM1.XMAT(1,1)
CC               WRITE(IOIMP,*) 'DET=',DET
CC               WRITE(IOIMP,*) 'SDET=',SDET
C               CALL MARE(JM1.XMAT,IDIM,IDIM,
C     $              'TRJJT   ',
C     $              TIJIJT,
C     $           IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CONTRI=0.5D0*TIJIJT*DET*SDET
C            ELSEIF (NOMLOI(1:4).EQ.'ADAR') THEN
C               CALL ERREUR(5)
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 MAMA(JM1.XMAT,IDIM,IDIM,
C     $              'JJT     ',
C     $              M1.XMAT,IDIM,IDIM,
C     $           IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               CALL MARE(JM1.XMAT,IDIM,IDIM,
C     $              'TRJJT   ',
C     $              TIJIJT,
C     $           IMPR,IRET)
C               TR1=0.D0
C               DO IIDIM=1,IDIM
C                  TR1=TR1+
C     $                 (JM1.XMAT(IIDIM,IDIM1)*M1.XMAT(IDIM2,IIDIM))
C               ENDDO
C               TR2=JM1.XMAT(IDIM2,IDIM1)
C               CONTRI=((0.5D0*TIJIJT*TR2)-TR1)*DET*SDET
C            ELSEIF (NOMLOI(1:4).EQ.'ADAK') THEN
C               CALL ERREUR(5)
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               CALL MAMA(JM1.XMAT,IDIM,IDIM,
C     $              'TRANSPOS',
C     $              M1.XMAT,IDIM,IDIM,
C     $           IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               WRITE(IOIMP,*) 'transpos'
C               SEGPRT,JM1
C               SEGPRT,M1
C               CALL MAMA(M1.XMAT,IDIM,IDIM,
C     $              'JJT     ',
C     $              M2.XMAT,IDIM,IDIM,
C     $           IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               WRITE(IOIMP,*) 'JJT'
C               SEGPRT,M1
C               SEGPRT,M2
C               CALL MARE(JM1.XMAT,IDIM,IDIM,
C     $              'TRJJT   ',
C     $              TIJIJT,
C     $           IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               WRITE(IOIMP,*) 'trace JJT'
C               SEGPRT,JM1
C               WRITE(IOIMP,*) 'TRJJT=',TIJIJT
C               XX=-0.5D0*TIJIJT
C               CALL REMA(XX,IDIM,IDIM,
C     $              'DIAGONAL',
C     $              M1.XMAT,
C     $           IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               WRITE(IOIMP,*) 'diagonal'
C               WRITE(IOIMP,*) 'XX=',XX
C               SEGPRT,M1
C               CALL MAMAMA(M1.XMAT,IDIM,IDIM,M2.XMAT,IDIM,IDIM,
C     $              'PLUS    ',
C     $              M3.XMAT,IDIM,IDIM,
C     $           IMPR,IRET)
C               IF (IRET.NE.0) GOTO 9999
C               STOP 16
C               TR1=0.D0
C               SEGPRT,M1
C               SEGPRT,M2
C               SEGPRT,M3
C               DO IIDIM=1,IDIM
C                  TR1=TR1+(M3.XMAT(IDIM1,IIDIM)*JM1.XMAT(IDIM4,IIDIM)
C     $                 *JM1.XMAT(IDIM2,IDIM3))
C               ENDDO
C               WRITE(IOIMP,*) 'TR1=',TR1
C               WRITE(IOIMP,*) 'DET=',DET
C               WRITE(IOIMP,*) 'SDET=',SDET
C               CONTRI=TR1*DET*SDET
            ELSE
               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
*g      SEGSUP,M3
*g      SEGSUP,M2
*g      SEGSUP,M1
*g      SEGSUP,JM1
*g      SEGSUP,JAC
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine ccgadv'
      RETURN
*
* End of subroutine CCGADV
*
      END