Sources Esope | Cast3M

xcnef0
C XCNEF0    SOURCE    PV        09/03/12    21:37:09     6325
      SUBROUTINE XCNEF0(NBEL,NP,MP,AF1,RO,VITESS,DCENTR
     &     ,NPT,IDIM,IDCEN,XYZ,NUTOEL,XCOOR,LTOG,
     &     IPADL,AF2,AF3,
     &     FN,GR,PG,HR,PGSQ,RPG,NES,NPG,IAXI,DRR,
     &     NBME,AMU,COTE,NELZ,IKR,IKU,IKM,TN,AIMPL,IPADL2,DT,
     &     MELEMC)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC SMCHAML
-INC SMELEME
      POINTEUR MELEMC.MELEME
 
      DIMENSION FN(MP,NPG),GR(IDIM,MP,NPG),PG(NPG)
      DIMENSION HR(IDIM,MP,NPG),PGSQ(NPG),RPG(NPG)
      DIMENSION AF1(NBEL,NP,MP),AF2(NBEL,NP,MP)
      DIMENSION AF3(NBEL,NP,MP),RO(1)
      DIMENSION VITESS(NPT,IDIM),TN(*)
      DIMENSION DCENTR(1),XYZ(IDIM,MP)
      DIMENSION XCOOR(*),DRR(MP,NBEL),IPADL2(*)
      DIMENSION LTOG(MP,NBEL),IPADL(*),AMU(1),COTE(NELZ,*)
 
C=============================================
C     Cette routine calcules les matrices    C
C     Elementaires associees a l'operateur  C
C     KONV en EFM0                           C
C=============================================
      PARAMETER (LRV=64,NPX=9,NPGX=9)
      DIMENSION WT(LRV,NPX,NPGX),WS(LRV,NPX,NPGX),HK(LRV,3,NPX,NPGX)
      DIMENSION PGSK(LRV,NPGX),RPGK(LRV,NPGX),AIRE(LRV)
      DIMENSION UMJ(LRV,3,NPGX),DUMJ(LRV,3,NPGX)
      DIMENSION COEFK(LRV),ANUK(LRV)
      DIMENSION AL(LRV),AH(LRV),AP(LRV)
      DIMENSION UAM(9,9)
-INC CCREEL
 
      INTEGER I,J,K,NUMAUX
      REAL*8 UMOY(3),RESW,CT
 
C ===================================
C Calcul du nombre de paquets de LRV éléments
C
      NNN=MOD(NBEL,LRV)
      IF(NNN.EQ.0) NPACK=NBEL/LRV
      IF(NNN.NE.0) NPACK=1+(NBEL-NNN)/LRV
      KPACKD=1
      KPACKF=NPACK
      CT=0.0D0
 
C====================================
 
C     Boucle sur les paquets de LRV elements
 
c      WRITE(6,*) 'IDCEN=' , IDCEN
      DO KPACK=KPACKD,KPACKF
 
C ======= A L'INTERIEUR DE CHAQUE PAQUET DE LRV ELEMENTS =======
C
C 1. Calcul des limites du paquet courant.
         KDEB=1+(KPACK-1)*LRV
         KFIN=MIN(NBEL,KDEB+LRV-1)
C
C     On rempli le tableau de COEFK sur chaque
C     element du paquet
         DO K=KDEB,KFIN
            KP=K-KDEB+1
            NK=K+NUTOEL
            NKR=(1-IKR)*(NK-1)+1
            NKM=(1-IKM)*(NK-1)+1
            COEFK(KP)=RO(NKR)
            ANUK(KP)=AMU(NKM)/RO(NKR)
            AL(KP)=COTE(NK,1)
            AH(KP)=COTE(NK,2)
         END DO
 
         CALL KSUPG(FN,GR,PG,XYZ,HR,PGSQ,RPG,
     &        NES,MP,NPG,IAXI,XCOOR,
     &        WT,WS,HK,PGSK,RPGK,AIRE,
     &        UMJ,DUMJ,KDEB,KFIN,LRV,NPX,NPGX,
     &        TN,IPADL,VITESS,IPADL,NPT,NELZ,ANUK,
     &        IDCEN,LTOG,
     &        AL,AH,AP,
     &        DTM1,DT,DTT1,DTT2,DIAEL,NUEL)
 
         DO K=KDEB,KFIN
            KP=K-KDEB+1
            CT=CT+TN(IPADL2(MELEMC.NUM(1,K)))*
     &           AIRE(KP)
            DO I=1,MP
 
               IF (NBME.GT.0) AF1(K,1,I)=0.0D0
               IF (NBME.GT.1) AF2(K,1,I)=0.0D0
               IF (NBME.GT.2) AF3(K,1,I)=0.0D0
 
               DO J=1,MP
                  UAM(I,J)=0.0D0
                  DO L=1,NPG
                     UAM(I,J)=UAM(I,J)+
     &                    FN(I,L)*WT(KP,J,L)*PGSK(KP,L)
                  END DO
               END DO
            END DO
 
 
            DO I=1,MP
               DO J=1,MP
                  IF (NBME.GT.0) THEN
                     AF1(K,1,I)=AF1(K,1,I)+UAM(I,J)*
     &                    VITESS(IPADL(LTOG(J,K)),1)
     &                    *COEFK(KP)
                  END IF
                  IF (NBME.GT.1) THEN
                     AF2(K,1,I)=AF2(K,1,I)+UAM(I,J)*
     &                    VITESS(IPADL(LTOG(J,K)),2)
     &                    *COEFK(KP)
                  END IF
                  IF (NBME.GT.2) THEN
                     AF3(K,1,I)=AF3(K,1,I)+UAM(I,J)*
     &                    VITESS(IPADL(LTOG(J,K)),3)
     &                    *COEFK(KP)
                  END IF
               END DO
            END DO
 
         END DO
      END DO
C     WRITE(6,*) 'Int Ct=',CT
      RETURN
 
      END