Sources Esope | Cast3M

xconv
C XCONV     SOURCE    CB215821  18/07/03    21:15:05     9868           
C
      SUBROUTINE XCONV(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ,
     &     NES,IDIM,NP,NPG,IAXI,AG,AD,IDIV,CMD,IKOMP,LRV,
     & WT,WS,HK,PGSK,RPGK,AIRE,AJK,UIL,DUIL,COEFK,ANUK,
     &     COEF,IKR,UN,NPTU,IPADU,AMU,IKM,
     &     LE,NBEL,K0,XCOOR,
     &     AF1,AF2,AF3,AS1,AS2,AS3,NINC,IDCEN,DTM1,
     &     TN,NPT,IPADT)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C************************************************************************
C
C     CALCUL DE LA MATRICE ELEMENTAIRE DE CONVECTION
C
C
C************************************************************************
      DIMENSION FN(NP,NPG),GR(IDIM,NP,NPG),PG(NPG),XYZ(IDIM,NP)
      DIMENSION HR(IDIM,NP,NPG),PGSQ(NPG),RPG(NPG),AJ(IDIM,IDIM,NPG)
      DIMENSION LE(NP,NBEL),IPADU(*),IPADT(*)
      DIMENSION AF1(NBEL,NP,NP),AS1(NBEL,NP,NP)
      DIMENSION AF2(NBEL,NP,NP),AS2(NBEL,NP,NP)
      DIMENSION AF3(NBEL,NP,NP),AS3(NBEL,NP,NP)
      DIMENSION XCOOR(*)
      DIMENSION COEF(1),UN(NPTU,IDIM),AMU(1),TN(NPT,NINC)
 
C     PARAMETER (LRV1=64,NPX=9,NPGX=9)
      DIMENSION WT(LRV,NP,NPG,*),WS(LRV,NP,NPG,*)
      DIMENSION HK(LRV,IDIM,NP,NPG)
      DIMENSION UIL(LRV,IDIM,NPG),DUIL(LRV,IDIM,NPG)
      DIMENSION PGSK(LRV,NPG),RPGK(LRV,NPG),AIRE(LRV)
      DIMENSION COEFK(LRV),ANUK(LRV)
      DIMENSION AJK(LRV,IDIM,IDIM,NPG)
-INC CCREEL
C***
C     WRITE(6,*)' DEBUT XCONV ',npt,idim,iaxi
C
C
C     write(6,*)' IDIV=',IDIV
 
      DEUPI=1.D0
      IF(IAXI.NE.0)DEUPI=2.D0*XPI
 
C Calcul du nombre de paquets de LRV éléments
C
      NNN=MOD(NBEL,LRV)
      IF(NNN.EQ.0) THEN
         NPACK=NBEL/LRV
      ELSE
         NPACK=1+(NBEL-NNN)/LRV
      ENDIF
      KPACKD=1
      KPACKF=NPACK
C
C ******* BOUCLE SUR LES PAQUETS DE LRV ELEMENTS **********
C
      DO 7001 KPACK=KPACKD,KPACKF
C
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
         DO 7002 K=KDEB,KFIN
            KP=K-KDEB+1
            NK=K+K0
            NKR=(1-IKR)*(NK-1)+1
            NKM=(1-IKM)*(NK-1)+1
            COEFK(KP)=COEF(NKR)
            ANUK(KP)=AMU(NKM)/COEF(NKR)
 7002    CONTINUE
 
C     CB215821 : DT n'est pas utilise mais doit etre initialise sinon NAN
      DT=0.D0
 
      IF(IDCEN.EQ.2)THEN
        DO 7006 NC=1,NINC
          CALL SUPGEF(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ,
     &         NES,NP,NPG,IAXI,XCOOR,
     &         LE,KDEB,KFIN,LRV,IDCEN,CMD,IKOMP,
     &         TN(1,NC),IPADT,UN,IPADU,NPTU,ANUK,
     &         WT(1,1,1,NC),WS(1,1,1,NC),HK,PGSK,RPGK,AJK,AIRE,UIL,DUIL,
     &         DTM1,DT,DTT1,DTT2,DIAEL,NUEL)
7006    CONTINUE
 
      ELSE
        CALL SUPGEF(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ,
     &       NES,NP,NPG,IAXI,XCOOR,
     &       LE,KDEB,KFIN,LRV,IDCEN,CMD,IKOMP,
     &       TN,IPADU,UN,IPADU,NPTU,ANUK,
     &       WT(1,1,1,1),WS(1,1,1,1),HK,PGSK,RPGK,AJK,AIRE,UIL,DUIL,
     &       DTM1,DT,DTT1,DTT2,DIAEL,NUEL)
      ENDIF
 
      CDIV=0.5D0
      IF(IDIV.EQ.0.OR.IKOMP.EQ.1)CDIV=0.D0
 
         DO 7005 NC=1,NINC
           N1=1
           IF(IDCEN.EQ.2)N1=NC
 
            DO 7003 K=KDEB,KFIN
               KP=K-KDEB+1
 
               DO 4 I=1,NP
                  DO 41 J=1,NP
                     S1=0.D0
                     S2=0.D0
                     DO 5 L=1,NPG
                        DUL=0.D0
                        DO 51 N=1,IDIM
                        DUL=DUL+DUIL(KP,N,L)
 51                     CONTINUE
 
                        SN=0.D0
                        DO 52 N=1,IDIM
                           SN=SN+(UIL(KP,N,L)*HK(KP,N,J,L))
 52                     CONTINUE
                 SN=(SN+CDIV*FN(J,L)*DUL)*PGSK(KP,L)*DEUPI*RPGK(KP,L)
                 S1=S1+SN*WT(KP,I,L,N1)
                 S2=S2+SN*WS(KP,I,L,N1)
 
 5                   CONTINUE
                     IF(NC.EQ.1)THEN
                        AF1(K,J,I)=S1*COEFK(KP)*AG
                        AS1(K,J,I)=S2*COEFK(KP)*AD
                     ELSEIF(NC.EQ.2)THEN
                        AF2(K,J,I)=S1*COEFK(KP)*AG
                        AS2(K,J,I)=S2*COEFK(KP)*AD
                     ELSEIF(NC.EQ.3)THEN
                        AF3(K,J,I)=S1*COEFK(KP)*AG
                        AS3(K,J,I)=S2*COEFK(KP)*AD
                     ENDIF
 
 41               CONTINUE
 4             CONTINUE
 7003       CONTINUE
 
            IF(IKOMP.EQ.1)THEN
 
               DO 7004 K=KDEB,KFIN
                  KP=K-KDEB+1
 
                  DO 6 I=1,NP
                     DO 61 J=1,NP
                        S1=0.D0
                        S2=0.D0
                        DO 7 L=1,NPG
                           DUL=0.D0
                           DO 71 N=1,IDIM
                           DUL=DUL+DUIL(KP,N,L)
 71                        CONTINUE
 
                           S1=S1+WT(KP,I,L,N1)*FN(J,L)*DUL
     $                          *PGSK(KP,L)*DEUPI*RPGK(KP,L)
                           S2=S2+WS(KP,I,L,N1)*FN(J,L)*DUL
     $                          *PGSK(KP,L)*DEUPI*RPGK(KP,L)
       IF(IAXI.NE.0)THEN
       S1=S1+WT(KP,I,L,N1)*FN(J,L)*UIL(KP,1,L)*PGSK(KP,L)*DEUPI
       S2=S2+WS(KP,I,L,N1)*FN(J,L)*UIL(KP,1,L)*PGSK(KP,L)*DEUPI
       ENDIF
 
 
 
 7                      CONTINUE
                        IF(NC.EQ.1)THEN
                           AF1(K,J,I)=AF1(K,J,I)+S1*COEFK(KP)*AG
                           AS1(K,J,I)=AS1(K,J,I)+S2*COEFK(KP)*AD
                        ELSEIF(NC.EQ.2)THEN
                           AF2(K,J,I)=AF2(K,J,I)+S1*COEFK(KP)*AG
                           AS2(K,J,I)=AS2(K,J,I)+S2*COEFK(KP)*AD
                        ELSEIF(NC.EQ.3)THEN
                           AF3(K,J,I)=AF3(K,J,I)+S1*COEFK(KP)*AG
                           AS3(K,J,I)=AS3(K,J,I)+S2*COEFK(KP)*AD
                        ENDIF
 61                  CONTINUE
 6                CONTINUE
 7004          CONTINUE
 
            ENDIF
 7005    CONTINUE
C
C     WRITE(6,*)' FIN XCONV '
 7001 CONTINUE
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
      END