Sources Esope | Cast3M

linli1
C LINLI1    SOURCE    GOUNAND   05/12/21    21:33:49     5281
      SUBROUTINE LINLI1(NDDLPR,NDDLDU,NBPOGO,
     $     N2FVPR,N2FVDU,
     $     NPFVPR,NPFVDU,NPFCPR,NPFCDU,NPDTJ,
     $     NLFVPR,NLFVDU,NLFCPR,NLFCDU,NLDTJ,NLMLIN,
     $     KDFRPR,KDFRDU,
     $     XPOPG,
     $     FVPR,FVDU,FCPR,FCDU,
     $     JDTJAC,LERF,JMTLIN,
     $     IMPR,IRET)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : LINLI1
C DESCRIPTION : Calcul de la matrice.
C
C ! Commentaires non à jour !
C
C LANGAGE     : Fortran 77 (sauf E/S)
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : -
C APPELE PAR       : LINLIN
C***********************************************************************
C ENTREES            : * MYPG (type POGAU)  : méthode d'intégration pour
C                        le maillage élémentaire courant.
C                      * FFGPR (type MCHEVA) : valeurs des fonctions
C                        d'interpolation aux points de gauss sur
C                        l'élément de référence pour la variable
C                        primale.
C                        Structure (cf.include SMCHAEL) :
C                        (1, nb. ddl. pri., 1, 1, nb. poi. gauss, 1)
C                      * DFFGPR (type MCHEVA) : valeurs des dérivées
C                        premières des fonctions d'interpolation
C                        primales aux points de gauss sur l'élément
C                        réel.
C                        Structure (cf.include SMCHAEL) :
C                        (1, nb. ddl pri., 1, dim.esp.réel,
C                         nb. poi. gauss, nb. élém.)
C                      * FFGDU (type MCHEVA) : valeurs des fonctions
C                        d'interpolation aux points de gauss sur
C                        l'élément de référence pour la variable
C                        duale.
C                        Structure (cf.include SMCHAEL) :
C                        (1, nb. ddl. dua., 1, 1, nb. poi. gauss, 1)
C                      * DFFGDU (type MCHEVA) : valeurs des dérivées
C                        premières des fonctions d'interpolation
C                        duales aux points de gauss sur l'élément
C                        réel.
C                        Structure (cf.include SMCHAEL) :
C                        (1, nb. ddl dua., 1, dim.esp.réel,
C                         nb. poi. gauss, nb. élém.)
C                      * CFGPR (type MCHEVA) : valeurs du coefficient
C                        aux points de Gauss sur le maillage
C                        élémentaire pour la variable primale.
C                        Structure (cf.include SMCHAEL) :
C                        (1, 1, 1, 1,
C                         nb. poi. gauss, nb. éléments)
C                      * CFGDU (type MCHEVA) : valeurs du coefficient
C                        aux points de Gauss sur le maillage
C                        élémentaire pour la variable duale.
C                        Structure (cf.include SMCHAEL) :
C                        (1, 1, 1, 1,
C                         nb. poi. gauss, nb. éléments)
C                      * KDERPR (type ENTIER) : dérivation sur la
C                        variable primale.
C                      * KDERDU(type ENTIER) : dérivation sur la
C                        variable duale.
C                      * JDTJAC (type MCHEVA) : valeurs du déterminant
C                        de la matrice jacobienne aux points de Gauss
C                        sur le maillage élémentaire.
C                        Structure (cf.include SMCHAEL) :
C                        (1, 1, 1, 1, nb. poi. gauss, nb. éléments)
C                      * NBELEM (type entier) : nombre d'éléments du
C                        maillage élémentaire courant.
C ENTREES/SORTIES    : * JMTLIN (type MCHEVA) : valeurs de la matrice
C                        moindres carrés sur le maillage élémentaire.
C                        Structure (cf.include SMCHAEL) :
C                        (nb. ddl dual, nb. ddl primal,
C                         1, 1,
C                         1, nb. éléments)
C SORTIES            : -
C TRAVAIL            : * NDDLDU (type entier) : nb. de ddl de la
C                        variable duale par élément.
C                      * NDDLPR (type entier) : nb. de ddl de la
C                        variable primale par élément.
C                      * IESREL (type entier) : dimension de l'espace
C                        réel (i.e. géométrique).
C                      * NBPOGO (type entier) : nombre de points
C                        d'intégration.
C                      * NLDFPR (type entier) : nombre d'éléments de
C                        DFFGPR.
C                      * NLDFDU (type entier) : nombre d'éléments de
C                        DFFGDU.
C                      * NLCPR (type entier) : nombre d'éléments de
C                        CFGPR.
C                      * NLCDU (type entier) : nombre d'éléments de
C                        CFGDU.
C                      * NLDTJ  (type entier) : nombre d'éléments de
C                        JDTJAC.
C       Les nombres d'éléments ci-dessus valent :
C       - soit NBELEM ;
C       - soit 1 si le champ par élément est constant sur le maillage
C         élémentaire courant.
C                      * NLMLIN (type entier) : nombre d'éléments de
C                        JMTLIN.
C***********************************************************************
C VERSION    : v3.1, 30/07/04, possiblité de travailler
C                              dans l'espace de référence
C VERSION    : v1, 11/05/04, version initiale
C HISTORIQUE : v1, 11/05/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
      INTEGER NDDLDU,NDDLPR,NBPOGO
      INTEGER N2FVPR,N2FVDU
      INTEGER NPFVPR,NPFVDU,NPFCPR,NPFCDU,NPDTJ
      INTEGER NLFVPR,NLFVDU,NLFCPR,NLFCDU,NLDTJ,NLMLIN
      INTEGER KDFRPR,KDFRDU
      REAL*8 XPOPG (NBPOGO)
      REAL*8 FVPR(NDDLPR,N2FVPR,NPFVPR,NLFVPR)
      REAL*8 FVDU(NDDLDU,N2FVDU,NPFVDU,NLFVDU)
      REAL*8 FCPR(NPFCPR,NLFCPR)
      REAL*8 FCDU(NPFCDU,NLFCDU)
      REAL*8 JDTJAC(NPDTJ,NLDTJ)
      REAL*8 JMTLIN(NDDLDU,NDDLPR,NLMLIN)
*
      REAL*8 CONTRI,SPOGO,ISPOGO
      INTEGER LERF
      INTEGER IMPR,IRET
      INTEGER IDDLPR,IDDLDU,IPOGO,ILMLIN
      INTEGER IPFVPR,IPFVDU,IPFCPR,IPFCDU,IPDTJ
      INTEGER ILFVPR,ILFVDU,ILFCPR,ILFCDU,ILDTJ
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans linli1'
*      Write(ioimp,*) 'linli1'
*      Write(ioimp,*) 'LERF=',LERF
      DO 1 ILMLIN=1,NLMLIN
*
* On suppose que le compilo pourra optimiser les IF
* en les sortant de la boucle 1. (Très chiant a faire
* a la main : 2^5 cas
*
* C'est pourquoi, on évite l'écriture
* ILFVPR=MIN(ILMLIN,NLFVPR) plus courte mais sans
* doute non optimisable
*
         IF (NLFVPR.EQ.1) THEN
            ILFVPR=1
         ELSE
            ILFVPR=ILMLIN
         ENDIF
         IF (NLFVDU.EQ.1) THEN
            ILFVDU=1
         ELSE
            ILFVDU=ILMLIN
         ENDIF
*
         IF (NLFCPR.EQ.1) THEN
            ILFCPR=1
         ELSE
            ILFCPR=ILMLIN
         ENDIF
         IF (NLFCDU.EQ.1) THEN
            ILFCDU=1
         ELSE
            ILFCDU=ILMLIN
         ENDIF
*
         IF (NLDTJ.EQ.1) THEN
            ILDTJ=1
         ELSE
            ILDTJ=ILMLIN
         ENDIF
         IF (LERF.EQ.2) THEN
            SPOGO=0.D0
            DO IPOGO=1,NBPOGO
               SPOGO=SPOGO+XPOPG(IPOGO)
            ENDDO
            ISPOGO=1.D0/SPOGO
*            WRITE(IOIMP,*) 'ISPOGO=',ISPOGO
         ENDIF
         DO 12 IPOGO=1,NBPOGO
            IF (NPFVPR.EQ.1) THEN
               IPFVPR=1
            ELSE
               IPFVPR=IPOGO
            ENDIF
            IF (NPFVDU.EQ.1) THEN
               IPFVDU=1
            ELSE
               IPFVDU=IPOGO
            ENDIF
*
            IF (NPFCPR.EQ.1) THEN
               IPFCPR=1
            ELSE
               IPFCPR=IPOGO
            ENDIF
            IF (NPFCDU.EQ.1) THEN
               IPFCDU=1
            ELSE
               IPFCDU=IPOGO
            ENDIF
*
            IF (NPDTJ.EQ.1) THEN
               IPDTJ=1
            ELSE
               IPDTJ=IPOGO
            ENDIF
            DO 12222 IDDLPR=1,NDDLPR
               DO 12224 IDDLDU=1,NDDLDU
                  CONTRI=
C     $                 XPOPG(IPOGO)*
     $                 FVDU(IDDLDU,KDFRDU,IPFVDU,ILFVDU)
     $                 *FCDU(IPFCDU,ILFCDU)
     $                 *FCPR(IPFCPR,ILFCPR)
     $                 *FVPR(IDDLPR,KDFRPR,IPFVPR,ILFVPR)
                  IF (LERF.EQ.0) THEN
                     CONTRI=CONTRI*ABS(JDTJAC(IPDTJ,ILDTJ))*XPOPG(IPOGO)
                  ELSEIF (LERF.EQ.1) THEN
                     CONTRI=CONTRI*XPOPG(IPOGO)
                  ELSEIF (LERF.EQ.2) THEN
                     CONTRI=CONTRI*XPOPG(IPOGO)*ISPOGO
                  ENDIF
                  JMTLIN(IDDLDU,IDDLPR,ILMLIN)=
     $                 JMTLIN(IDDLDU,IDDLPR,ILMLIN)+
     $                 CONTRI
12224          CONTINUE
12222       CONTINUE
 12      CONTINUE
 1    CONTINUE
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine linli1'
      RETURN
*
* End of subroutine LINLI1
*
      END