Sources Esope | Cast3M

zconv
C ZCONV     SOURCE    CHAT      05/01/13    04:21:31     5004
C Attention ! IDIM, IKT, IKU ne servent jamais
C
      SUBROUTINE ZCONV(FN,GR,PG,XYZ,HR,PGSQ,RPG,
     &     NES,IDIM,NP,NPG,IAXI,AIMPL,IKOMP,
     &     COEF,IKR,UN,IKU,NPTU,IPADU,AMU,IKM,
     &     LE,NBEL,K0,XCOOR,
     &     AF1,AF2,AF3,AS1,AS2,AS3,NINC,IDCEN,DTM1,
     &     TN,IKT,NPT,IPADT,COTE,NELZ)
      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)
      DIMENSION LE(NP,NBEL),IPADU(*),IPADT(*)
      DIMENSION COTE(NELZ,*)
      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)
 
      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)
C***
C     WRITE(IOIMP,*)' DEBUT XCONV ',npt,nelz,idim,iaxi
C
C
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)
            AL(KP)=COTE(NK,1)
            AH(KP)=COTE(NK,2)
 7002    CONTINUE
 
         IF(IDIM.EQ.3)THEN
            DO 8002 K=KDEB,KFIN
               KP=K-KDEB+1
               NK=K+K0
               AP(KP)=COTE(NK,3)
 8002       CONTINUE
         ENDIF
 
         DO 7005 NC=1,NINC
 
            CALL KSUPG(FN,GR,PG,XYZ,HR,PGSQ,RPG,
     &           NES,NP,NPG,IAXI,XCOOR,
     &           WT,WS,HK,PGSK,RPGK,AIRE,
     &           UMJ,DUMJ,KDEB,KFIN,LRV,NPX,NPGX,
     &           TN(1,NC),IPADT,UN,IPADU,NPTU,NELZ,ANUK,
     &           IDCEN,LE,
     &           AL,AH,AP,
     &           DTM1,DT,DTT1,DTT2,DIAEL,NUEL)
 
            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
                        DO 51 N=1,IDIM
                           S1=S1+WT(KP,I,L)*UMJ(KP,N,L)*HK(KP,N,J,L)
     $                          *PGSK(KP,L)
                           S2=S2+WS(KP,I,L)*UMJ(KP,N,L)*HK(KP,N,J,L)
     $                          *PGSK(KP,L)
 51                     CONTINUE
 5                   CONTINUE
                     IF(NC.EQ.1)THEN
                        AF1(K,J,I)=S1*COEFK(KP)*AIMPL
                        AS1(K,J,I)=S2*COEFK(KP)*(AIMPL-1.D0)
                     ELSEIF(NC.EQ.2)THEN
                        AF2(K,J,I)=S1*COEFK(KP)*AIMPL
                        AS2(K,J,I)=S2*COEFK(KP)*(AIMPL-1.D0)
                     ELSEIF(NC.EQ.3)THEN
                        AF3(K,J,I)=S1*COEFK(KP)*AIMPL
                        AS3(K,J,I)=S2*COEFK(KP)*(AIMPL-1.D0)
                     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
                           DO 71 N=1,IDIM
                              S1=S1+WT(KP,I,L)*FN(J,L)*DUMJ(KP,N,L)
     $                             *PGSK(KP,L)
                              S2=S2+WS(KP,I,L)*FN(J,L)*DUMJ(KP,N,L)
     $                             *PGSK(KP,L)
 71                        CONTINUE
 7                      CONTINUE
                        IF(NC.EQ.1)THEN
                           AF1(K,J,I)=AF1(K,J,I)+S1*COEFK(KP)*AIMPL
                           AS1(K,J,I)=AS1(K,J,I)+S2*COEFK(KP)*(AIMPL-1
     $                          .D0)
                        ELSEIF(NC.EQ.2)THEN
                           AF2(K,J,I)=AF2(K,J,I)+S1*COEFK(KP)*AIMPL
                           AS2(K,J,I)=AS2(K,J,I)+S2*COEFK(KP)*(AIMPL-1
     $                          .D0)
                        ELSEIF(NC.EQ.3)THEN
                           AF3(K,J,I)=AF3(K,J,I)+S1*COEFK(KP)*AIMPL
                           AS3(K,J,I)=AS3(K,J,I)+S2*COEFK(KP)*(AIMPL-1
     $                          .D0)
                        ENDIF
 61                  CONTINUE
 6                CONTINUE
 7004          CONTINUE
 
            ENDIF
 7005    CONTINUE
C
C     WRITE(IOIMP,*)' FIN XCONV '
 7001 CONTINUE
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
      END