Sources Esope | Cast3M

ycvit
C YCVIT     SOURCE    CHAT      05/01/13    04:16:48     5004
      SUBROUTINE YCVIT
     &     (HR,RPG,DRR,LE,NEL,K0,NPTI,NPTS,NPTU,IES,NP,IAXI,
     &     IPADI,IPADS,IPADU,IKOMP,IKAS,
     &     RO,IKR,
     &     COEFF,IK1,RGE,IKG,NELG,TN,IKT,TREF,IKREF,
     &     AMUT,GN,UN,TK,TE,
     &     F,GK,GE,GE1,
     &     VOLU,COTE,NELZ,IDCEN,IMODEL,
     &     DT,DTT1,DTT2,NUEL,DIAEL,DIAM)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
C***********************************************************************
C  APPELE PAR NSKE
C  CE SP DISCRETISE LES EQUATIONS DE NAVIER STOKES COUPLEES
C  AUX DEUX EQUATIONS DU MODELE K - EPSILON
C    EN 2D SUR LES ELEMENTS QUA4 ET TRI3      PLAN OU AXI
C    EN 3D SUR LES ELEMENTS CUB8 ET PRI6
C  LES OPERATEURS SONT "SOUS-INTEGRES"
C
C***
C
C                    MODELE K - EPSILON
C
C
C    CONSTANTES :  CNU=0.09D0  C1=1.41D0  C2=1.92D0
C                   SGT=0.9D0  SGK=1.D0   SGE=1.3D0
C
C     P --> TABLEAU P
C
C    LE NU TURBULENT EST CALCULE PAR ELEMENT
C    IL N EST PAS TRANSMIS EN ARGUMENT
C
C
C***********************************************************************
 
      DIMENSION UN(NPTU,IES),GN(NPTI,IES),TK(NPTI),TE(NPTI)
      DIMENSION AMUT(*),RO(*)
      DIMENSION COTE(NELZ,IES),VOLU(NELZ)
 
C NOMBRE DE NOEUDS MAX PAR ELEMENT NPX
      PARAMETER (NPX=9)
 
C LONGUEUR DES REGISTRES VECTORIELS DE LA MACHINE CIBLE
 
      PARAMETER (LRV=64)
C
      DIMENSION IPADI(*),IPADS(*),IPADU(*),LE(NP,*)
      DIMENSION HR(NEL,NP,IES),RPG(*),DRR(NP,NEL)
      DIMENSION QGGT(8,8),Q1(8,8),Q2(8,8),Q3(8,8)
      SAVE QGGT,Q1,Q2,Q3
 
      DIMENSION F(NPTS,IES),GK(NPTS),GE(NPTS),GE1(NPTS)
 
-INC CCVQUA4
-INC CCREEL
*-
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
C* -TABLEAUX ADDITIONNELS POUR LA VECTORISATION   **********************
C
C ---- ILS CONDUISENT A UN SURCOUT DE LRV*(59+25NPX) MOTS. AVEC NPX=9
C      ET LRV=128 ON OBTIENT 37KMOTS (0.3 MEGAOCTETS) ET CECI QUELLE
C      SOIT LA NOMBRE TOTAL D'ELEMENTS DU MAILLAGE
C ------------------------------------------------------------------
      DIMENSION AIRE(LRV),COEF(LRV),AL(LRV),AH(LRV),AP(LRV)
      DIMENSION XMB(LRV),XMH (LRV)
      DIMENSION CFM(LRV)
C     DIMENSION CF1(LRV),CF2(LRV),CF3(LRV)
C
      DIMENSION DR(LRV,NPX)
      DIMENSION UIX(LRV,NPX),UIY(LRV,NPX),UIZ(LRV,NPX)
      DIMENSION GIX(LRV,NPX),GIY(LRV,NPX),GIZ(LRV,NPX)
      DIMENSION AK(LRV,NPX),AE(LRV,NPX)
C
      DIMENSION UM(LRV),UMI(LRV,3),AKM(LRV),AEM(LRV),ARO(LRV)
      DIMENSION P(LRV),PG(LRV),ANUT(LRV),
     ;     DUDX(LRV),DUDY(LRV),DUDZ(LRV),DVDX(LRV),DVDY(LRV),
     ;     DVDZ(LRV),DWDX(LRV),DWDY(LRV),DWDZ(LRV),
     ;     DTDX(LRV),DTDY(LRV),DTDZ(LRV)
C
      DIMENSION C1P(LRV),C1G(LRV),COEFT(LRV),COEFK(LRV),COEFE(LRV)
C
      DIMENSION BE1(LRV,NPX)
C
C
C ---- TABLEAUX POUR L'OPTION RAPIDE -------------------------------
C      DANS LA TRIPLE BOUCLE SUR K,I,J ON PEUT SORTIR UN MAXIMUM
C      D'OPERATIONS DE LA BOUCLES LA PLUS INTERNE. LES TABLEAUX CI-
C      DESSOUS PERMETTENT DE STOCKER LES VALEURS CALCULEES
C ------------------------------------------------------------------
C***
      DIMENSION COEFF(*),RGE(NELG,IES)
      DIMENSION TN(*),TREF(*)
 
      DIMENSION RGX(LRV),RGY(LRV),RGZ(LRV)
      DIMENSION SAF1(LRV,9),SAF2(LRV,9),SAF3(LRV,9)
      DIMENSION SAFK(LRV,9),SAFE(LRV,9)
      DIMENSION AL2(LRV),AH2(LRV),AP2(LRV)
      DIMENSION GRADGX(LRV,3),GRADGY(LRV,3),GRADGZ(LRV,3)
      DIMENSION GRADK (LRV,3),GRADE (LRV,3)
      DIMENSION UPGX(LRV),UPIGX(LRV,3),UPGY(LRV),UPIGY(LRV,3)
      DIMENSION UPGZ(LRV),UPIGZ(LRV,3)
      DIMENSION UPK (LRV),UPIK (LRV,3),UPE (LRV),UPIE (LRV,3)
      DIMENSION BM(LRV),BPGX(LRV),BPGY(LRV),BPGZ(LRV)
      DIMENSION         BPK (LRV),BPE (LRV)
      DIMENSION GXCXT(LRV),GXCYT(LRV),GXCZT(LRV)
      DIMENSION GXCXY(LRV),GXCXZ(LRV),GXCYZ(LRV)
      DIMENSION GYCXT(LRV),GYCYT(LRV),GYCZT(LRV)
      DIMENSION GYCXY(LRV),GYCXZ(LRV),GYCYZ(LRV)
      DIMENSION GZCXT(LRV),GZCYT(LRV),GZCZT(LRV)
      DIMENSION GZCXY(LRV),GZCXZ(LRV),GZCYZ(LRV)
      DIMENSION GKCXT(LRV),GKCYT(LRV),GKCZT(LRV)
      DIMENSION GKCXY(LRV),GKCXZ(LRV),GKCYZ(LRV)
      DIMENSION GECXT(LRV),GECYT(LRV),GECZT(LRV)
      DIMENSION GECXY(LRV),GECXZ(LRV),GECYZ(LRV)
 
      DIMENSION CONST(2,7)
 
      SAVE IPAS
      DATA IPAS/0/
 
C Constantes du modèle RNG
C      DATA CNU,C1,C2,C3/0.0845D0,1.42D0,1.68D0,0.8D0/
C      DATA SGT,SGK,SGE /0.9D0,0.7179D0,0.7179D0/
C
C Modèle standard
C     DATA CNU,C1,C2,C3,SGT,SGE/0.09D0,1.41D0,1.92D0,0.8D0,0.9D0,1.3D0/
C
C IMODEL=1 modele Standard   IMODEL=2 modele RNG
C
C
C*** Variation des constantes en fonction du modèle
      DATA (CONST(1,j),j=1,4) /0.09D0,1.41D0,1.92D0,0.8D0/
      DATA (CONST(1,j),j=5,7) /0.9D0,1.D0,1.3D0/
      DATA (CONST(2,j),j=1,4) /0.0845D0,1.42D0,1.68D0,0.8D0/
      DATA (CONST(2,j),j=5,7) /0.9D0,0.7179D0,0.7179D0/
C***
C
CDIR$ VECTOR
CDIR$ IVDEP
 
C      WRITE(IOIMP,*)' Debut YCVIT'
C      WRITE(IOIMP,*)' NELZ,ies=',nelz,ies
C      WRITE(IOIMP,1002)cote
C      WRITE(IOIMP,*)' Avt precaution ies=',ies
C
C           INITIALISATIONS DIVERSES
C
       zxzini = sqrt(xpetit)
      DTM1=0.D0
 
C     IF(IPAS.EQ.0)CALL CALHRG(QGGT,IES)
      IF(IPAS.EQ.0)CALL CALHRH(QGGT,Q1,Q2,Q3,IES)
      NK=K0
C                           ********
C                           *  2D  *
C                           ********
C
C      IMODEL=3
C Suite de la definition des constantes
C      IF(IMODEL.EQ.3) THEN
C       IMO=2
C      ELSE
C       IMO=1
C      ENDIF
C
C  (IMODEL=1 modèle Standard ; IMODEL=2 modèle RNG)
      CNU=CONST(IMODEL,1)
      C1=CONST(IMODEL,2)
      C2=CONST(IMODEL,3)
      C3=CONST(IMODEL,4)
      SGT=CONST(IMODEL,5)
      SGK=CONST(IMODEL,6)
      SGE=CONST(IMODEL,7)
C
      IF(IES.EQ.3)GO TO 10
C
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
C                           DIFFERENCES TRIANGLE / QUADRANGLE
      QUA4=0.D0
      IF(NP.EQ.4)QUA4=1.D0
 
C
C K  EST LE NUMERO DE L'ELEMENT
C KP PERMET DE SE SITUER A L'INTERIEUR DES TABLEAUX DE LRV ELEMENTS
C --- CALCUL DU NOMBRE DE PAQUETS DE LRV ELEMENTS ---
      NNN=MOD(NEL,LRV)
      IF(NNN.EQ.0) NPACK=NEL/LRV
      IF(NNN.NE.0) NPACK=1+(NEL-NNN)/LRV
      KPACKD=1
      KPACKF=NPACK
C
C*** BOUCLE SUR LES PAQUETS D'ELEMENTS ***
C
      DO 70001 KPACK=KPACKD,KPACKF
C
C --- POUR CHAQUE PAQUET DE LRV ELEMENTS
         KDEB=1+(KPACK-1)*LRV
         KFIN=MIN(NEL,KDEB+LRV-1)
C      WRITE(IOIMP,*)' KPACK=',KPACK
C
         DO 70002 K=KDEB,KFIN
            KP=K-KDEB+1
            NK=K+K0
            K1=1+(1-IK1)*(NK-1)
            AIRE(KP)=VOLU(NK)
            COEF(KP)=COEFF(K1)
            AL(KP)=COTE(NK,1)
            AH(KP)=COTE(NK,2)
            AL2(KP)=1.D0/AL(KP)/AL(KP)
            AH2(KP)=1.D0/AH(KP)/AH(KP)
            XMB (KP)=(AL(KP)+AH(KP))*0.5D0
70002    CONTINUE
C      WRITE(IOIMP,*)' Apr bcl 70002,,,,,,,,,,,,,,,,,,,,,,,, '
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Initialisation des UMI,UMIT avant accumulation
         DO 7005 K=KDEB,KFIN
            KP=K-KDEB+1
            UMI(KP,1)=zxzini
            UMI(KP,2)=zxzini
            GRADGX(KP,1)=zxzini
            GRADGX(KP,2)=zxzini
            GRADGY(KP,1)=zxzini
            GRADGY(KP,2)=zxzini
            AKM(KP)=zxzini
            AEM(KP)=zxzini
            UPIK(KP,1)=zxzini
            UPIK(KP,2)=zxzini
            UPIE(KP,1)=zxzini
            UPIE(KP,2)=zxzini
            GRADK(KP,1)=zxzini
            GRADK(KP,2)=zxzini
            GRADE(KP,1)=zxzini
            GRADE(KP,2)=zxzini
            DUDX(KP)=0.D0
            DUDY(KP)=0.D0
            DVDX(KP)=0.D0
            DVDY(KP)=0.D0
            DTDX(KP)=0.D0
            DTDY(KP)=0.D0
            C1P(KP)=C1
            C1G(KP)=0.D0
            PG(KP)=0.D0
 7005    CONTINUE
 
         DO 7006 I=1,NP
            DO 6006 K=KDEB,KFIN
               KP=K-KDEB+1
               NF=IPADI(LE(I,K))
               NFU=IPADU(LE(I,K))
               DR(KP,I)=DRR(I,K)
               UMI(KP,1)=UMI(KP,1)+UN(NFU,1)*DR(KP,I)
               UMI(KP,2)=UMI(KP,2)+UN(NFU,2)*DR(KP,I)
               UIX(KP,I)=UN(NFU,1)
               UIY(KP,I)=UN(NFU,2)
               GIX(KP,I)=GN(NF,1)
               GIY(KP,I)=GN(NF,2)
               AK(KP,I)=TK(NF)
               AE(KP,I)=TE(NF)
               GRADGX(KP,1)=GRADGX(KP,1)+HR(K,I,1)*GIX(KP,I)
               GRADGX(KP,2)=GRADGX(KP,2)+HR(K,I,2)*GIX(KP,I)
               GRADGY(KP,1)=GRADGY(KP,1)+HR(K,I,1)*GIY(KP,I)
               GRADGY(KP,2)=GRADGY(KP,2)+HR(K,I,2)*GIY(KP,I)
               AKM(KP)=AKM(KP)+TK(NF)*DR(KP,I)
               AEM(KP)=AEM(KP)+TE(NF)*DR(KP,I)
               GRADK(KP,1)=GRADK(KP,1)+HR(K,I,1)*AK(KP,I)
               GRADK(KP,2)=GRADK(KP,2)+HR(K,I,2)*AK(KP,I)
               GRADE(KP,1)=GRADE(KP,1)+HR(K,I,1)*AE(KP,I)
               GRADE(KP,2)=GRADE(KP,2)+HR(K,I,2)*AE(KP,I)
C *** CALCUL DU TERME DE PRODUCTION ****************************
               DUDX(KP) = DUDX(KP)+HR(K,I,1)*UN(NFU,1)
               DUDY(KP) = DUDY(KP)+HR(K,I,2)*UN(NFU,1)
               DVDX(KP) = DVDX(KP)+HR(K,I,1)*UN(NFU,2)
               DVDY(KP) = DVDY(KP)+HR(K,I,2)*UN(NFU,2)
 6006       CONTINUE
 7006    CONTINUE
 
C     WRITE(IOIMP,*)'Initialisation SAF1,SAF2,SBF '
C
C Initialisation des variables d'accumulation SAF1,SAF2,SBF
C
         IF(IKOMP.EQ.0)THEN
 
            DO 70060 K=KDEB,KFIN
               KP=K-KDEB+1
               ARO(KP)=1.D0
70060       CONTINUE
 
            IF(IKAS.EQ.2)THEN
               DO 70061 I=1,NP
                  DO 60061 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=0.D0
                     SAF2(KP,I)=0.D0
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
60061             CONTINUE
70061          CONTINUE
            ELSEIF(IKAS.EQ.3)THEN
               DO 70021 K=KDEB,KFIN
                  KP=K-KDEB+1
                  NK=K+K0
                  NKG=1+(1-IKG)*(NK-1)
                  RGX(KP)=RGE(NKG,1)
                  RGY(KP)=RGE(NKG,2)
70021          CONTINUE
               DO 70062 I=1,NP
                  DO 60062 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=(-RGX(KP))*DR(KP,I)
                     SAF2(KP,I)=(-RGY(KP))*DR(KP,I)
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
                     NKG=1+(1-IKG)*(NK-1)
                     DTDX(KP)=DTDX(KP)+HR(K,I,1)*RGE(NKG,1)
                     DTDY(KP)=DTDY(KP)+HR(K,I,2)*RGE(NKG,2)
60062             CONTINUE
70062          CONTINUE
            ELSEIF(IKAS.EQ.5)THEN
               DO 70022 K=KDEB,KFIN
                  KP=K-KDEB+1
                  NK=K+K0
                  NKG=1+(1-IKG)*(NK-1)
                  RGX(KP)=RGE(NKG,1)
                  RGY(KP)=RGE(NKG,2)
70022          CONTINUE
               DO 70063 I=1,NP
                  DO 60063 K=KDEB,KFIN
                     KP=K-KDEB+1
                     NF=1+(1-IKT)*(IPADS(LE(I,K))-1)
                     NFR=1+(1-IKREF)*(IPADS(LE(I,K))-1)
                     SAF1(KP,I)=(-RGX(KP)*(TREF(NFR)-TN(NF)))*DR(KP,I)
                     SAF2(KP,I)=(-RGY(KP)*(TREF(NFR)-TN(NF)))*DR(KP,I)
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
                     DTDX(KP)=DTDX(KP)+HR(K,I,1)*TN(NF)
                     DTDY(KP)=DTDY(KP)+HR(K,I,2)*TN(NF)
60063             CONTINUE
70063          CONTINUE
            ENDIF
 
         ELSEIF(IKOMP.EQ.1)THEN
 
            DO 70020 K=KDEB,KFIN
               KP=K-KDEB+1
               NK=K+K0
               NKR=1+(1-IKR)*(NK-1)
               ARO(KP)=RO(NKR)
70020       CONTINUE
 
            IF(IKAS.EQ.4)THEN
               DO 70064 I=1,NP
                  DO 60064 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=0.D0
                     SAF2(KP,I)=0.D0
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
60064             CONTINUE
70064          CONTINUE
            ELSEIF(IKAS.EQ.5)THEN
               DO 70024 K=KDEB,KFIN
                  KP=K-KDEB+1
                  NK=K+K0
                  NKG=1+(1-IKG)*(NK-1)
                  RGX(KP)=RGE(NKG,1)
                  RGY(KP)=RGE(NKG,2)
70024          CONTINUE
               DO 70065 I=1,NP
                  DO 60065 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=-RGX(KP)*DR(KP,I)
                     SAF2(KP,I)=-RGY(KP)*DR(KP,I)
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
60065             CONTINUE
70065          CONTINUE
            ENDIF
         ENDIF
 
         DO 7007 K=KDEB,KFIN
            KP=K-KDEB+1
            NK=K+K0
            AKM(KP)=ABS(AKM(KP))/AIRE(KP)+zxzini
            AEM(KP)=ABS(AEM(KP))/AIRE(KP)+zxzini
            UMI(KP,1)=UMI(KP,1)/AIRE(KP)
            UMI(KP,2)=UMI(KP,2)/AIRE(KP)
            UM(KP)=UMI(KP,1)*UMI(KP,1)+UMI(KP,2)*UMI(KP,2)
            UM(KP)=SQRT(UM(KP))
            AX=GRADGX(KP,1)*GRADGX(KP,1)+GRADGX(KP,2)*GRADGX(KP,2)
            AX=SQRT(AX)+zxzini
            GRADGX(KP,1)=GRADGX(KP,1)/AX
            GRADGX(KP,2)=GRADGX(KP,2)/AX
            AY=GRADGY(KP,1)*GRADGY(KP,1)+GRADGY(KP,2)*GRADGY(KP,2)
            AY=SQRT(AY)+zxzini
            GRADGY(KP,1)=GRADGY(KP,1)/AY
            GRADGY(KP,2)=GRADGY(KP,2)/AY
            UPGX(KP)=GRADGX(KP,1)*UMI(KP,1)+GRADGX(KP,2)*UMI(KP,2)
            UPIGX(KP,1)=UPGX(KP)*GRADGX(KP,1)
            UPIGX(KP,2)=UPGX(KP)*GRADGX(KP,2)
            UPGY(KP)=GRADGY(KP,1)*UMI(KP,1)+GRADGY(KP,2)*UMI(KP,2)
            UPIGY(KP,1)=UPGY(KP)*GRADGY(KP,1)
            UPIGY(KP,2)=UPGY(KP)*GRADGY(KP,2)
 
            AX=GRADK(KP,1)*GRADK(KP,1)+GRADK(KP,2)*GRADK(KP,2)
            AX=SQRT(AX)+zxzini
            GRADK(KP,1)=GRADK(KP,1)/AX
            GRADK(KP,2)=GRADK(KP,2)/AX
            UPK(KP)=GRADK(KP,1)*UMI(KP,1)+GRADK(KP,2)*UMI(KP,2)
            UPIK(KP,1)=UPK(KP)*GRADK(KP,1)
            UPIK(KP,2)=UPK(KP)*GRADK(KP,2)
 
            AX=GRADE(KP,1)*GRADE(KP,1)+GRADE(KP,2)*GRADE(KP,2)
            AX=SQRT(AX)+zxzini
            GRADE(KP,1)=GRADE(KP,1)/AX
            GRADE(KP,2)=GRADE(KP,2)/AX
            UPE(KP)=GRADE(KP,1)*UMI(KP,1)+GRADE(KP,2)*UMI(KP,2)
            UPIE(KP,1)=UPE(KP)*GRADE(KP,1)
            UPIE(KP,2)=UPE(KP)*GRADE(KP,2)
 
            ANUT(KP)=CNU*AKM(KP)*AKM(KP)/AEM(KP)
            AMUT(NK)=ARO(KP)*ANUT(KP)
            COEFT(KP)=COEF(KP)+AMUT(NK)
            COEFK(KP)=COEF(KP)+ANUT(KP)/SGK
            COEFE(KP)=COEF(KP)+ANUT(KP)/SGE
C --- 2. CALCUL DU TERME DE PRODUCTION PROPREMENT DIT ----------
            PTEMP=( (DUDY(KP)+DVDX(KP))**2
     $            + 2.D0*(DUDX(KP)**2+DVDY(KP)**2) )
            P(KP)=PTEMP
 7007    CONTINUE
C------------ANCIENNE VERSION--------------------
C      IF(IAXI.NE.0) THEN
C        DO 70012 K=KDEB,KFIN
C        KP=K+1-KDEB
C        P(KP)=P(KP)+2.D0*(UMI(KP,1)*UMI(KP,1))/(RPG(K)*RPG(K))
C70012   CONTINUE
C      END IF
C
C      IF(IKAS.EQ.5.AND.IKOMP.EQ.0)THEN
C        IF(IMODEL.EQ.1)THEN
C        DO 70113 K=KDEB,KFIN
C        KP=K+1-KDEB
C        PG(KP)=(RGX(KP)*DTDX(KP)+RGY(KP)*DTDY(KP))/SGT
C        IF(PG(KP).GT.0.D0)C1G(KP)=C1
C70113   CONTINUE
C        ELSEIF(IMODEL.EQ.2)THEN
C        DO 70213 K=KDEB,KFIN
C        KP=K+1-KDEB
C        PG(KP)=(RGX(KP)*DTDX(KP)+RGY(KP)*DTDY(KP))/SGT
C          RF    =-PG(KP)/(P(KP)+PG(KP)+zxzini)
C          IF(PG(KP).GT.0.D0)RF=0.D0
C          C1G(KP)=C1*(1.D0+C3*RF)
C          C1P(KP)=C1*(1.D0+C3*RF)
C70213   CONTINUE
C        ENDIF
C      ELSEIF(IKAS.EQ.2.AND.IKOMP.EQ.0)THEN
C        IF(IMODEL.EQ.1)THEN
C        DO 70114 K=KDEB,KFIN
C        KP=K+1-KDEB
C        PG(KP)=(DTDX(KP)+DTDY(KP))/SGT
C        IF(PG(KP).GT.0.D0)C1G(KP)=C1
C70114   CONTINUE
C        ELSEIF(IMODEL.EQ.2)THEN
C        DO 70214 K=KDEB,KFIN
C        KP=K+1-KDEB
C        PG(KP)=(DTDX(KP)+DTDY(KP))/SGT
C          RF    =-PG(KP)/(P(KP)+PG(KP)+zxzini)
C          IF(PG(KP).GT.0.D0)RF=0.D0
C          C1G(KP)=C1*(1.D0+C3*RF    )
C          C1P(KP)=C1*(1.D0+C3*RF    )
C70214   CONTINUE
C        END IF
C      END IF
C-------------VERSION POUR RNG---------------
         IF(IKAS.EQ.5.AND.IKOMP.EQ.0)THEN
            DO 70213 K=KDEB,KFIN
               KP=K+1-KDEB
               PG(KP)=(RGX(KP)*DTDX(KP)+RGY(KP)*DTDY(KP))/SGT
               RF    =-PG(KP)/(P(KP)+PG(KP)+zxzini)
               IF(PG(KP).GT.0.D0)RF=0.D0
               C1G(KP)=C1*(1.D0+C3*RF)
               C1P(KP)=C1*(1.D0+C3*RF)
70213       CONTINUE
         ELSEIF(IKAS.EQ.2.AND.IKOMP.EQ.0)THEN
            DO 70214 K=KDEB,KFIN
               KP=K+1-KDEB
               PG(KP)=(DTDX(KP)+DTDY(KP))/SGT
               RF    =-PG(KP)/(P(KP)+PG(KP)+zxzini)
               IF(PG(KP).GT.0.D0)RF=0.D0
               C1G(KP)=C1*(1.D0+C3*RF    )
               C1P(KP)=C1*(1.D0+C3*RF    )
70214       CONTINUE
         END IF
 
         IF(IMODEL.EQ.2) THEN
            ETA0=4.377D0
            BETA0=0.012D0
            ETA=(P(KP)**0.5D0)*AKM(KP)/AEM(KP)
            RETA= ETA*(1.D0-(ETA/ETA0))/(1.D0+BETA0*(ETA**3.D0))
            C1P(KP)=C1P(KP)-RETA
         END IF
C --------------------------------------------------------------
C *** FIN DU CALCUL DU TERME DE PRODUCTION *********************
 
         DO 70074 K=KDEB,KFIN
            KP=K-KDEB+1
            BMX=UMI(KP,1)/AL(KP)
            BMY=UMI(KP,2)/AH(KP)
            BM(KP)=BMX*BMX+BMY*BMY
            BM(KP)=SQRT(BM(KP))+zxzini
            BPGXX=UPIGX(KP,1)/AL(KP)
            BPGXY=UPIGX(KP,2)/AH(KP)
            BPGX(KP)=BPGXX*BPGXX+BPGXY*BPGXY
            BPGX(KP)=SQRT(BPGX(KP))+zxzini
            BPGYX=UPIGY(KP,1)/AL(KP)
            BPGYY=UPIGY(KP,2)/AH(KP)
            BPGY(KP)=BPGYX*BPGYX+BPGYY*BPGYY
            BPGY(KP)=SQRT(BPGY(KP))+zxzini
            BPKX=UPIK(KP,1)/AL(KP)
            BPKY=UPIK(KP,2)/AH(KP)
            BPK(KP)=BPKX*BPKX+BPKY*BPKY
            BPK(KP)=SQRT(BPK(KP))+zxzini
            BPEX=UPIE(KP,1)/AL(KP)
            BPEY=UPIE(KP,2)/AH(KP)
            BPE(KP)=BPEX*BPEX+BPEY*BPEY
            BPE(KP)=SQRT(BPE(KP))+zxzini
70074    CONTINUE
C
C     AVANT DECENTREMENT
C
C ALFA,AKSI,CCU utilisées seulement dans la boucle 7008
         IF(IDCEN.EQ.1)THEN
            DO 70081 K=KDEB,KFIN
               KP=K-KDEB+1
               GXCXT(KP)=0.D0
               GXCYT(KP)=0.D0
               GXCXY(KP)=0.D0
               GYCXT(KP)=0.D0
               GYCYT(KP)=0.D0
               GYCXY(KP)=0.D0
               GKCXT(KP)=0.D0
               GKCYT(KP)=0.D0
               GKCXY(KP)=0.D0
               GECXT(KP)=0.D0
               GECYT(KP)=0.D0
               GECXY(KP)=0.D0
70081       CONTINUE
 
         ELSEIF(IDCEN.EQ.2)THEN
            DO 7008 K=KDEB,KFIN
               KP=K-KDEB+1
               HMK=2.D0*UM(KP)/BM(KP)
               XMB(KP)=HMK
               ALFA=UM(KP)*HMK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCT=AKSI/BM(KP)
 
               HPK=2.D0*UPGX(KP)/BPGX(KP)
               ALFA=UPGX(KP)*HPK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPGX(KP)
               CPT=CCP-CCT
               CC2X=0.D0
               IF(CPT.GE.0.D0)CC2X=CPT
 
               HPK=2.D0*UPGY(KP)/BPGY(KP)
               ALFA=UPGY(KP)*HPK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPGY(KP)
               CPT=CCP-CCT
               CC2Y=0.D0
               IF(CPT.GE.0.D0)CC2Y=CPT
 
               HPK=2.D0*UPK(KP)/BPK(KP)
               ALFA=UPK(KP)*HPK/COEFK(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPK(KP)
               CPT=CCP-CCT
               CC2K=0.D0
               IF(CPT.GE.0.D0)CC2K=CPT
 
               HPK=2.D0*UPE(KP)/BPE(KP)
               ALFA=UPE(KP)*HPK/COEFE(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPE(KP)
               CPT=CCP-CCT
               CC2E=0.D0
               IF(CPT.GE.0.D0)CC2E=CPT
 
               GXCXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT
     $                   +UPIGX(KP,1)*UPIGX(KP,1)*CC2X)
               GXCYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT
     $                   +UPIGX(KP,2)*UPIGX(KP,2)*CC2X)
               GXCXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT
     $                   +UPIGX(KP,1)*UPIGX(KP,2)*CC2X)
 
               GYCXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT
     $                   +UPIGY(KP,1)*UPIGY(KP,1)*CC2Y)
               GYCYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT
     $                   +UPIGY(KP,2)*UPIGY(KP,2)*CC2Y)
               GYCXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT
     $                   +UPIGY(KP,1)*UPIGY(KP,2)*CC2Y)
 
               GKCXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT
     $                   +UPIK(KP,1)*UPIK(KP,1)*CC2K)
               GKCYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT
     $                   +UPIK(KP,2)*UPIK(KP,2)*CC2K)
               GKCXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT
     $                   +UPIK(KP,1)*UPIK(KP,2)*CC2K)
 
               GECXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT
     $                   +UPIE(KP,1)*UPIE(KP,1)*CC2E)
               GECYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT
     $                   +UPIE(KP,2)*UPIE(KP,2)*CC2E)
               GECXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT
     $                   +UPIE(KP,1)*UPIE(KP,2)*CC2E)
 
 7008       CONTINUE
 
         ELSEIF(IDCEN.EQ.3)THEN
            DO 7018 K=KDEB,KFIN
               KP=K-KDEB+1
               HMK=2.D0*UM(KP)/BM(KP)
               XMB(KP)=HMK
               ALFA=UM(KP)*HMK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCT=AKSI/BM(KP)
 
               GXCXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GXCYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GXCXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
 
               GYCXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GYCYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GYCXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
 
               GKCXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GKCYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GKCXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
 
               GECXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GECYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GECXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
 
 7018       CONTINUE
 
         ELSEIF(IDCEN.EQ.4)THEN
            DT19=DTM1*0.5D0
            DO 7009 K=KDEB,KFIN
               KP=K-KDEB+1
               XMB(KP)=(AL(KP)+AH(KP))/2.D0
               GXCXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GXCYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GXCXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GYCXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GYCYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GYCXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GKCXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GKCYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GKCXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GECXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GECYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GECXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
 7009       CONTINUE
 
         ENDIF
 
C     WRITE(IOIMP,*)' Avt Calcul DT'
C
C     AVANT CALCUL DT
C
         DO 7010 K=KDEB,KFIN
            KP=K-KDEB+1
            DT0=DT
            DT1X=2.D0/
     &           (UMI(KP,1)*UMI(KP,1)/(GXCXT(KP)+COEFT(KP))
     &           +UMI(KP,2)*UMI(KP,2)/(GXCYT(KP)+COEFT(KP)))
 
            DT1Y=2.D0/
     &           (UMI(KP,1)*UMI(KP,1)/(GYCXT(KP)+COEFT(KP))
     &           +UMI(KP,2)*UMI(KP,2)/(GYCYT(KP)+COEFT(KP)))
            DT2X=0.5D0/
     &           ((GXCXT(KP)+COEFT(KP))*AL2(KP)
     &           +(GXCYT(KP)+COEFT(KP))*AH2(KP))
            DT2Y=0.5D0/
     &           ((GYCXT(KP)+COEFT(KP))*AL2(KP)
     &           +(GYCYT(KP)+COEFT(KP))*AH2(KP))
            IF(DT1X.LT.DT)DT=DT1X
            IF(DT1Y.LT.DT)DT=DT1Y
            IF(DT2X.LT.DT)DT=DT2X
            IF(DT2Y.LT.DT)DT=DT2Y
C     IF(DT3.LT.DT)DT=DT3
            IF(DT.NE.DT0) THEN
               DTT1=MIN(DT1X,DT1Y)
               DTT2=MIN(DT2X,DT2Y)
C        DTT3=DT3
               DIAEL=XMB(KP)
               NUEL=K
            END IF
 7010    CONTINUE
 
C     WRITE(IOIMP,*)' le coeur du calcul '
C Le coeur du calcul ...
 
         IF(IKOMP.EQ.0)THEN
 
            DO 7014 I=1,NP
               DO 70141 J=1,NP
                  DO 70142 K=KDEB,KFIN
                     KP=K-KDEB+1
                     ZVGGX=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GXCXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GXCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GXCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GXCYT(KP)
     &               +    (GXCXT(KP)*AL2(KP)+GXCYT(KP)*AH2(KP))
     $                    /12.D0*VGGT(J,I)*QUA4  )
 
                     ZVGGY=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GYCXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GYCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GYCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GYCYT(KP)
     &               +    (GYCXT(KP)*AL2(KP)+GYCYT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGK =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GKCXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GKCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GKCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GKCYT(KP)
     &               +    (GKCXT(KP)*AL2(KP)+GKCYT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGE =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GECXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GECXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GECXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GECYT(KP)
     &               +    (GECXT(KP)*AL2(KP)+GECYT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGD=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFT(KP)
     &               +    (COEFT(KP)*AL2(KP)+COEFT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGDK=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFK(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFK(KP)
     &               +    (COEFK(KP)*AL2(KP)+COEFK(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGDE=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFE(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFE(KP)
     &               +    (COEFE(KP)*AL2(KP)+COEFE(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
Cnon  V2=(UIX(KP,I)*HR(K,J,1)+UIY(KP,I)*HR(K,J,2))*DR(KP,I)
 
                     V2=UMI(KP,1)*DR(KP,I)*HR(K,J,1)+UMI(KP,2)*DR(KP,I)
     $                    *HR(K,J,2)
 
                     SAF1(KP,I)=SAF1(KP,I)+(V2+ZVGGX)*GIX(KP,J)+ZVGD
     $                    *UIX(KP,J)
                     SAF2(KP,I)=SAF2(KP,I)+(V2+ZVGGY)*GIY(KP,J)+ZVGD
     $                    *UIY(KP,J)
 
                     SAFK(KP,I)=SAFK(KP,I)+(V2+ZVGK)*AK(KP,J)+ZVGDK
     $                    *AK(KP,J)
                     SAFE(KP,I)=SAFE(KP,I)+(V2+ZVGE)*AE(KP,J)+ZVGDE
     $                    *AE(KP,J)
 
70142             CONTINUE
70141          CONTINUE
 7014       CONTINUE
 
         ELSEIF(IKOMP.EQ.1)THEN
 
            DO 7015 I=1,NP
               DO 70151 J=1,NP
                  DO 70152 K=KDEB,KFIN
                     KP=K-KDEB+1
                     ZVGGX=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GXCXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GXCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GXCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GXCYT(KP)
     &               +    (GXCXT(KP)*AL2(KP)+GXCYT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGGY=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GYCXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GYCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GYCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GYCYT(KP)
     &               +    (GYCXT(KP)*AL2(KP)+GYCYT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGK =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GKCXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GKCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GKCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GKCYT(KP)
     &               +    (GKCXT(KP)*AL2(KP)+GKCYT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGE =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GECXT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GECXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GECXY(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GECYT(KP)
     &               +    (GECXT(KP)*AL2(KP)+GECYT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGD=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFT(KP)
     &               +    (COEFT(KP)*AL2(KP)+COEFT(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGDK=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFK(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFK(KP)
     &               +    (COEFK(KP)*AL2(KP)+COEFK(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     ZVGDE=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFE(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFE(KP)
     &               +    (COEFE(KP)*AL2(KP)+COEFE(KP)*AH2(KP))/12
     $                    .D0*VGGT(J,I)*QUA4  )
 
                     COEFT3=COEFT(KP)/3.D0
                     ZVGUU=AIRE(KP)*( HR(K,I,1)*HR(K,J,1)
     &                 +    AL2(KP)/12.D0*VGGT(J,I)*QUA4  )*COEFT3
     $                    *UIX(KP,J)
                     ZVGUV=AIRE(KP)*( HR(K,I,1)*HR(K,J,2))*COEFT3*UIY(KP
     $                    ,J)
                     ZVGVU=AIRE(KP)*( HR(K,I,2)*HR(K,J,1))*COEFT3*UIX(KP
     $                    ,J)
                     ZVGVV=AIRE(KP)*( HR(K,I,2)*HR(K,J,2)
     &                +    AH2(KP)/12.D0*VGGT(J,I)*QUA4  )*COEFT3
     $                    *UIY(KP,J)
 
                     V2=(UIX(KP,J)*HR(K,J,1)+UIY(KP,J)*HR(K,J,2))*DR(KP
     $                    ,I)
 
                     SAF1(KP,I)=SAF1(KP,I)+(V2+ZVGGX)*GIX(KP,J)+ZVGD
     $                    *UIX(KP,J)+ ZVGUU + ZVGUV
                     SAF2(KP,I)=SAF2(KP,I)+(V2+ZVGGY)*GIY(KP,J)+ZVGD
     $                    *UIY(KP,J)+ ZVGVU + ZVGVV
 
                     SAFK(KP,I)=SAFK(KP,I)+(V2+ZVGK)*AK(KP,J)+ZVGDK
     $                    *AK(KP,J)
                     SAFE(KP,I)=SAFE(KP,I)+(V2+ZVGE)*AE(KP,J)+ZVGDE
     $                    *AE(KP,J)
 
70152             CONTINUE
70151          CONTINUE
 7015       CONTINUE
 
         ENDIF
 
         IF(IAXI.NE.0) THEN
            DO 7016 I=1,NP
               DO 70161 J=1,NP
                  DO 70162 K=KDEB,KFIN
                     KP=K-KDEB+1
C     IP=LE(I,K)
C     XG=XCOOR((IP-1)*(IDIM+1)    +1)+zxzini
C        R2=1.D0/XG/XG*DR(KP,I)
 
                     R2=1.D0/RPG(K)/RPG(K)*DR(KP,I)
                     AX=(GXCXT(KP)+GXCYT(KP))*0.5D0
                     SAF1(KP,I)=SAF1(KP,I)+R2*(COEFT(KP)*UIX(KP,J)+AX
     $                    *GIX(KP,J))
 
70162             CONTINUE
70161          CONTINUE
 7016       CONTINUE
 
            IF(IKOMP.EQ.1)THEN
 
               DO 7118 I=1,NP
                  DO 71181 K=KDEB,KFIN
                     KP=K-KDEB+1
 
                     R1=1.D0/RPG(K)*DR(KP,I)
                     SAF1(KP,I)=SAF1(KP,I)+R1*UMI(KP,1)*GIX(KP,I)
                     SAF2(KP,I)=SAF2(KP,I)+R1*UMI(KP,1)*GIY(KP,I)
 
71181             CONTINUE
 7118          CONTINUE
 
            ENDIF
 
         ENDIF
C
C --------------------------------------------------------------
C
C
         DO 7017 I=1,NP
            DO 70171 K=KDEB,KFIN
               KP=K-KDEB+1
               TSK       =(ANUT(KP)*(P(KP)+PG(KP))-AEM(KP))*DR(KP,I)
               SAFK(KP,I)=SAFK(KP,I)-TSK
 
               TSE       =(CNU*(C1P(KP)*P(KP)+C1G(KP)*PG(KP))*AKM(KP))
     $              *DR(KP,I)
               SAFE(KP,I)=SAFE(KP,I)-TSE
 
               TSE1      =C2*AEM(KP)/AKM(KP)*DR(KP,I)
               BE1(KP,I) =TSE1
70171       CONTINUE
 7017    CONTINUE
 
C
C
C --- ECRITURE DANS LES TABLEAUX F(1,*),F(2,*),G,GK,GE,GE1 (SCALAIRE)
         DO 70019 I=1,NP
            DO 60019 K=KDEB,KFIN
               KP=K+1-KDEB
               NF=IPADS(LE(I,K))
               F(NF,1)=F(NF,1)-SAF1(KP,I)
               F(NF,2)=F(NF,2)-SAF2(KP,I)
               GK(NF) =GK(NF) -SAFK(KP,I)
               GE1(NF)=GE1(NF)+BE1(KP,I)
               GE(NF) =GE (NF)-SAFE(KP,I)
60019       CONTINUE
70019    CONTINUE
70001 CONTINUE
C
C *** FIN DE LA BOUCLE SUR LES PAQUETS D'ELEMENTS ***
C
C     WRITE(IOIMP,*)' FIN YCVIT GK='
C     WRITE(IOIMP,1002)(GK(i),i=1,nptd)
 
      IPAS=1
      RETURN
 
C                           ********
C                           *  3D  *
C                           ********
 
 10   CONTINUE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
C                           DIFFERENCES HEXAHEDRES / AUTRES ELEMENTS
      CUB8=0.D0
      IF(NP.EQ.8)CUB8=1.D0
 
C
C K  EST LE NUMERO DE L'ELEMENT
C KP PERMET DE SE SITUER A L'INTERIEUR DES TABLEAUX DE LRV ELEMENTS
C --- CALCUL DU NOMBRE DE PAQUETS DE LRV ELEMENTS ---
      NNN=MOD(NEL,LRV)
      IF(NNN.EQ.0) NPACK=NEL/LRV
      IF(NNN.NE.0) NPACK=1+(NEL-NNN)/LRV
      KPACKD=1
      KPACKF=NPACK
C
C*** BOUCLE SUR LES PAQUETS D'ELEMENTS ***
C
      DO 80001 KPACK=KPACKD,KPACKF
C
C --- POUR CHAQUE PAQUET DE LRV ELEMENTS
         KDEB=1+(KPACK-1)*LRV
         KFIN=MIN(NEL,KDEB+LRV-1)
C      WRITE(IOIMP,*)' KPACK=',KPACK
C
         DO 80002 K=KDEB,KFIN
            KP=K-KDEB+1
            NK=K+K0
            K1=1+(1-IK1)*(NK-1)
            AIRE(KP)=VOLU(NK)
            COEF(KP)=COEFF(K1)
            AL(KP)=COTE(NK,1)
            AH(KP)=COTE(NK,2)
            AP(KP)=COTE(NK,3)
            AL2(KP)=1.D0/AL(KP)/AL(KP)
            AH2(KP)=1.D0/AH(KP)/AH(KP)
            AP2(KP)=1.D0/AP(KP)/AP(KP)
            CFM(KP)=AL(KP)*AH(KP)/AP(KP)+AL(KP)*AP(KP)/AH(KP)+
     &              AP(KP)*AH(KP)/AL(KP)
C     CF1(KP)=AL(KP)*AH(KP)/AP(KP)
C     CF2(KP)=AL(KP)*AP(KP)/AH(KP)
C     CF3(KP)=AP(KP)*AH(KP)/AL(KP)
            XMH (KP)=(AL(KP)+AH(KP)+AP(KP))/3.D0
            XMB (KP)=XMH (KP)
80002    CONTINUE
C      WRITE(IOIMP,*)' Apr bcl 80002,,,,,,,,,,,,,,,,,,,,,,,, '
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Initialisation des UMI,UMIT avant accumulation
         DO 8005 K=KDEB,KFIN
            KP=K-KDEB+1
            UMI(KP,1)=zxzini
            UMI(KP,2)=zxzini
            UMI(KP,3)=zxzini
            GRADGX(KP,1)=zxzini
            GRADGX(KP,2)=zxzini
            GRADGX(KP,3)=zxzini
            GRADGY(KP,1)=zxzini
            GRADGY(KP,2)=zxzini
            GRADGY(KP,3)=zxzini
            GRADGZ(KP,1)=zxzini
            GRADGZ(KP,2)=zxzini
            GRADGZ(KP,3)=zxzini
            AKM(KP)=zxzini
            AEM(KP)=zxzini
            UPIK(KP,1)=zxzini
            UPIK(KP,2)=zxzini
            UPIK(KP,3)=zxzini
            UPIE(KP,1)=zxzini
            UPIE(KP,2)=zxzini
            UPIE(KP,3)=zxzini
            GRADK(KP,1)=zxzini
            GRADK(KP,2)=zxzini
            GRADK(KP,3)=zxzini
            GRADE(KP,1)=zxzini
            GRADE(KP,2)=zxzini
            GRADE(KP,3)=zxzini
            DUDX(KP)=0.D0
            DUDY(KP)=0.D0
            DUDZ(KP)=0.D0
            DVDX(KP)=0.D0
            DVDY(KP)=0.D0
            DVDZ(KP)=0.D0
            DWDX(KP)=0.D0
            DWDY(KP)=0.D0
            DWDZ(KP)=0.D0
            DTDX(KP)=0.D0
            DTDY(KP)=0.D0
            DTDZ(KP)=0.D0
            C1P(KP)=C1
            C1G(KP)=0.D0
            PG(KP)=0.D0
 8005    CONTINUE
 
         DO 8006 I=1,NP
            DO 5006 K=KDEB,KFIN
               KP=K-KDEB+1
               NF=IPADI(LE(I,K))
               NFU=IPADU(LE(I,K))
               DR(KP,I)=DRR(I,K)
               UMI(KP,1)=UMI(KP,1)+UN(NFU,1)*DR(KP,I)
               UMI(KP,2)=UMI(KP,2)+UN(NFU,2)*DR(KP,I)
               UMI(KP,3)=UMI(KP,3)+UN(NFU,3)*DR(KP,I)
               UIX(KP,I)=UN(NFU,1)
               UIY(KP,I)=UN(NFU,2)
               UIZ(KP,I)=UN(NFU,3)
               GIX(KP,I)=GN(NF,1)
               GIY(KP,I)=GN(NF,2)
               GIZ(KP,I)=GN(NF,3)
               AK(KP,I)=TK(NF)
               AE(KP,I)=TE(NF)
               GRADGX(KP,1)=GRADGX(KP,1)+HR(K,I,1)*GIX(KP,I)
               GRADGX(KP,2)=GRADGX(KP,2)+HR(K,I,2)*GIX(KP,I)
               GRADGX(KP,3)=GRADGX(KP,3)+HR(K,I,3)*GIX(KP,I)
               GRADGY(KP,1)=GRADGY(KP,1)+HR(K,I,1)*GIY(KP,I)
               GRADGY(KP,2)=GRADGY(KP,2)+HR(K,I,2)*GIY(KP,I)
               GRADGY(KP,3)=GRADGY(KP,3)+HR(K,I,3)*GIY(KP,I)
               GRADGZ(KP,1)=GRADGZ(KP,1)+HR(K,I,1)*GIZ(KP,I)
               GRADGZ(KP,2)=GRADGZ(KP,2)+HR(K,I,2)*GIZ(KP,I)
               GRADGZ(KP,3)=GRADGZ(KP,3)+HR(K,I,3)*GIZ(KP,I)
               AKM(KP)=AKM(KP)+TK(NF)*DR(KP,I)
               AEM(KP)=AEM(KP)+TE(NF)*DR(KP,I)
               GRADK(KP,1)=GRADK(KP,1)+HR(K,I,1)*AK(KP,I)
               GRADK(KP,2)=GRADK(KP,2)+HR(K,I,2)*AK(KP,I)
               GRADK(KP,3)=GRADK(KP,3)+HR(K,I,3)*AK(KP,I)
               GRADE(KP,1)=GRADE(KP,1)+HR(K,I,1)*AE(KP,I)
               GRADE(KP,2)=GRADE(KP,2)+HR(K,I,2)*AE(KP,I)
               GRADE(KP,3)=GRADE(KP,3)+HR(K,I,3)*AE(KP,I)
C *** CALCUL DU TERME DE PRODUCTION ****************************
               DUDX(KP) = DUDX(KP)+HR(K,I,1)*UN(NFU,1)
               DUDY(KP) = DUDY(KP)+HR(K,I,2)*UN(NFU,1)
               DUDZ(KP) = DUDZ(KP)+HR(K,I,3)*UN(NFU,1)
               DVDX(KP) = DVDX(KP)+HR(K,I,1)*UN(NFU,2)
               DVDY(KP) = DVDY(KP)+HR(K,I,2)*UN(NFU,2)
               DVDZ(KP) = DVDZ(KP)+HR(K,I,3)*UN(NFU,2)
               DWDX(KP) = DWDX(KP)+HR(K,I,1)*UN(NFU,3)
               DWDY(KP) = DWDY(KP)+HR(K,I,2)*UN(NFU,3)
               DWDZ(KP) = DWDZ(KP)+HR(K,I,3)*UN(NFU,3)
 5006       CONTINUE
 8006    CONTINUE
 
C     WRITE(IOIMP,*)'Initialisation SAF1,SAF2,SBF '
C
C Initialisation des variables d'accumulation SAF1,SAF2,SBF
C
         IF(IKOMP.EQ.0)THEN
 
            DO 80060 K=KDEB,KFIN
               KP=K-KDEB+1
               ARO(KP)=1.D0
80060       CONTINUE
 
            IF(IKAS.EQ.2)THEN
               DO 80061 I=1,NP
                  DO 50061 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=0.D0
                     SAF2(KP,I)=0.D0
                     SAF3(KP,I)=0.D0
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
50061             CONTINUE
80061          CONTINUE
            ELSEIF(IKAS.EQ.3)THEN
               DO 80021 K=KDEB,KFIN
                  KP=K-KDEB+1
                  NK=K+K0
                  NKG=1+(1-IKG)*(NK-1)
                  RGX(KP)=RGE(NKG,1)
                  RGY(KP)=RGE(NKG,2)
                  RGZ(KP)=RGE(NKG,3)
80021          CONTINUE
               DO 80062 I=1,NP
                  DO 50062 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=(-RGX(KP))*DR(KP,I)
                     SAF2(KP,I)=(-RGY(KP))*DR(KP,I)
                     SAF3(KP,I)=(-RGZ(KP))*DR(KP,I)
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
                     NKG=1+(1-IKG)*(NK-1)
                     DTDX(KP)=DTDX(KP)+HR(K,I,1)*RGE(NKG,1)
                     DTDY(KP)=DTDY(KP)+HR(K,I,2)*RGE(NKG,2)
                     DTDZ(KP)=DTDZ(KP)+HR(K,I,3)*RGE(NKG,3)
50062             CONTINUE
80062          CONTINUE
            ELSEIF(IKAS.EQ.5)THEN
               DO 80022 K=KDEB,KFIN
                  KP=K-KDEB+1
                  NK=K+K0
                  NKG=1+(1-IKG)*(NK-1)
                  RGX(KP)=RGE(NKG,1)
                  RGY(KP)=RGE(NKG,2)
                  RGZ(KP)=RGE(NKG,3)
80022          CONTINUE
               DO 80063 I=1,NP
                  DO 50063 K=KDEB,KFIN
                     KP=K-KDEB+1
                     NF=1+(1-IKT)*(IPADS(LE(I,K))-1)
                     NFR=1+(1-IKREF)*(IPADS(LE(I,K))-1)
                     SAF1(KP,I)=(-RGX(KP)*(TREF(NFR)-TN(NF)))*DR(KP,I)
                     SAF2(KP,I)=(-RGY(KP)*(TREF(NFR)-TN(NF)))*DR(KP,I)
                     SAF3(KP,I)=(-RGZ(KP)*(TREF(NFR)-TN(NF)))*DR(KP,I)
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
                     DTDX(KP)=DTDX(KP)+HR(K,I,1)*TN(NF)
                     DTDY(KP)=DTDY(KP)+HR(K,I,2)*TN(NF)
                     DTDZ(KP)=DTDZ(KP)+HR(K,I,3)*TN(NF)
50063             CONTINUE
80063          CONTINUE
            ENDIF
 
         ELSEIF(IKOMP.EQ.1)THEN
 
            DO 80020 K=KDEB,KFIN
               KP=K-KDEB+1
               NK=K+K0
               NKR=1+(1-IKR)*(NK-1)
               ARO(KP)=RO(NKR)
80020       CONTINUE
 
            IF(IKAS.EQ.4)THEN
               DO 80064 I=1,NP
                  DO 50064 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=0.D0
                     SAF2(KP,I)=0.D0
                     SAF3(KP,I)=0.D0
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
50064             CONTINUE
80064          CONTINUE
            ELSEIF(IKAS.EQ.5)THEN
               DO 80024 K=KDEB,KFIN
                  KP=K-KDEB+1
                  NK=K+K0
                  NKG=1+(1-IKG)*(NK-1)
                  RGX(KP)=RGE(NKG,1)
                  RGY(KP)=RGE(NKG,2)
                  RGZ(KP)=RGE(NKG,3)
80024          CONTINUE
               DO 80065 I=1,NP
                  DO 50065 K=KDEB,KFIN
                     KP=K-KDEB+1
                     SAF1(KP,I)=-RGX(KP)*DR(KP,I)
                     SAF2(KP,I)=-RGY(KP)*DR(KP,I)
                     SAF3(KP,I)=-RGZ(KP)*DR(KP,I)
                     SAFK(KP,I)=0.D0
                     SAFE(KP,I)=0.D0
50065             CONTINUE
80065          CONTINUE
            ENDIF
         ENDIF
 
         DO 8007 K=KDEB,KFIN
            KP=K-KDEB+1
            NK=K+K0
            AKM(KP)=ABS(AKM(KP))/AIRE(KP)+zxzini
            AEM(KP)=ABS(AEM(KP))/AIRE(KP)+zxzini
            UMI(KP,1)=UMI(KP,1)/AIRE(KP)
            UMI(KP,2)=UMI(KP,2)/AIRE(KP)
            UMI(KP,3)=UMI(KP,3)/AIRE(KP)
            UM(KP)=UMI(KP,1)*UMI(KP,1)+UMI(KP,2)*UMI(KP,2)
     &            +UMI(KP,3)*UMI(KP,3)
            UM(KP)=SQRT(UM(KP))
            AX=GRADGX(KP,1)*GRADGX(KP,1)+GRADGX(KP,2)*GRADGX(KP,2)
     &        +GRADGX(KP,3)*GRADGX(KP,3)
            AX=SQRT(AX)+zxzini
            GRADGX(KP,1)=GRADGX(KP,1)/AX
            GRADGX(KP,2)=GRADGX(KP,2)/AX
            GRADGX(KP,3)=GRADGX(KP,3)/AX
            AY=GRADGY(KP,1)*GRADGY(KP,1)+GRADGY(KP,2)*GRADGY(KP,2)
     &        +GRADGY(KP,3)*GRADGY(KP,3)
            AY=SQRT(AY)+zxzini
            GRADGY(KP,1)=GRADGY(KP,1)/AY
            GRADGY(KP,2)=GRADGY(KP,2)/AY
            GRADGY(KP,3)=GRADGY(KP,3)/AY
            AZ=GRADGZ(KP,1)*GRADGZ(KP,1)+GRADGZ(KP,2)*GRADGZ(KP,2)
     &        +GRADGZ(KP,3)*GRADGZ(KP,3)
            AZ=SQRT(AZ)+zxzini
            GRADGZ(KP,1)=GRADGZ(KP,1)/AZ
            GRADGZ(KP,2)=GRADGZ(KP,2)/AZ
            GRADGZ(KP,3)=GRADGZ(KP,3)/AZ
 
            UPGX(KP)=GRADGX(KP,1)*UMI(KP,1)+GRADGX(KP,2)*UMI(KP,2)
     &              +GRADGX(KP,3)*UMI(KP,3)
            UPIGX(KP,1)=UPGX(KP)*GRADGX(KP,1)
            UPIGX(KP,2)=UPGX(KP)*GRADGX(KP,2)
            UPIGX(KP,3)=UPGX(KP)*GRADGX(KP,3)
            UPGY(KP)=GRADGY(KP,1)*UMI(KP,1)+GRADGY(KP,2)*UMI(KP,2)
     &              +GRADGY(KP,3)*UMI(KP,3)
            UPIGY(KP,1)=UPGY(KP)*GRADGY(KP,1)
            UPIGY(KP,2)=UPGY(KP)*GRADGY(KP,2)
            UPIGY(KP,3)=UPGY(KP)*GRADGY(KP,3)
            UPGZ(KP)=GRADGZ(KP,1)*UMI(KP,1)+GRADGZ(KP,2)*UMI(KP,2)
     &              +GRADGZ(KP,3)*UMI(KP,3)
            UPIGZ(KP,1)=UPGZ(KP)*GRADGZ(KP,1)
            UPIGZ(KP,2)=UPGZ(KP)*GRADGZ(KP,2)
            UPIGZ(KP,3)=UPGZ(KP)*GRADGZ(KP,3)
 
            AX=GRADK(KP,1)*GRADK(KP,1)+GRADK(KP,2)*GRADK(KP,2)
     &        +GRADK(KP,3)*GRADK(KP,3)
            AX=SQRT(AX)+zxzini
            GRADK(KP,1)=GRADK(KP,1)/AX
            GRADK(KP,2)=GRADK(KP,2)/AX
            GRADK(KP,3)=GRADK(KP,3)/AX
            UPK(KP)=GRADK(KP,1)*UMI(KP,1)+GRADK(KP,2)*UMI(KP,2)
     &             +GRADK(KP,3)*UMI(KP,3)
            UPIK(KP,1)=UPK(KP)*GRADK(KP,1)
            UPIK(KP,2)=UPK(KP)*GRADK(KP,2)
            UPIK(KP,3)=UPK(KP)*GRADK(KP,3)
 
            AX=GRADE(KP,1)*GRADE(KP,1)+GRADE(KP,2)*GRADE(KP,2)
     &        +GRADE(KP,3)*GRADE(KP,3)
            AX=SQRT(AX)+zxzini
            GRADE(KP,1)=GRADE(KP,1)/AX
            GRADE(KP,2)=GRADE(KP,2)/AX
            GRADE(KP,3)=GRADE(KP,3)/AX
            UPE(KP)=GRADE(KP,1)*UMI(KP,1)+GRADE(KP,2)*UMI(KP,2)
     &             +GRADE(KP,3)*UMI(KP,3)
            UPIE(KP,1)=UPE(KP)*GRADE(KP,1)
            UPIE(KP,2)=UPE(KP)*GRADE(KP,2)
            UPIE(KP,3)=UPE(KP)*GRADE(KP,3)
 
            ANUT(KP)=CNU*AKM(KP)*AKM(KP)/AEM(KP)
            AMUT(NK)=ARO(KP)*ANUT(KP)
            COEFT(KP)=COEF(KP)+AMUT(NK)
            COEFK(KP)=COEF(KP)+ANUT(KP)
            COEFE(KP)=COEF(KP)+ANUT(KP)/SGE
C --- 2.D0 CALCUL DU TERME DE PRODUCTION PROPREMENT DIT ----------
            PTEMP=( (DUDY(KP)+DVDX(KP))**2 + (DUDZ(KP)+DWDX(KP))**2
     &            + (DVDZ(KP)+DWDY(KP))**2
     &            + 2.D0*(DUDX(KP)**2+DVDY(KP)**2+DWDZ(KP)**2) )
            P(KP)=PTEMP
 8007    CONTINUE
 
         IF(IKAS.EQ.5.AND.IKOMP.EQ.0)THEN
            IF(IMODEL.EQ.1)THEN
               DO 80113 K=KDEB,KFIN
                  KP=K+1-KDEB
                  PG(KP)=(RGX(KP)*DTDX(KP)+RGY(KP)*DTDY(KP)
     &                   +RGZ(KP)*DTDZ(KP) )/SGT
                  IF(PG(KP).GT.0.D0)C1G(KP)=C1
80113          CONTINUE
            ELSEIF(IMODEL.EQ.2)THEN
               DO 80213 K=KDEB,KFIN
                  KP=K+1-KDEB
                  PG(KP)=(RGX(KP)*DTDX(KP)+RGY(KP)*DTDY(KP)
     &                   +RGZ(KP)*DTDZ(KP) )/SGT
                  RF    =-PG(KP)/(P(KP)+PG(KP)+zxzini)
                  IF(PG(KP).GT.0.D0)RF=0.D0
                  C1G(KP)=C1*(1.D0+C3*RF)
                  C1P(KP)=C1*(1.D0+C3*RF)
80213          CONTINUE
            ENDIF
         ELSEIF(IKAS.EQ.2.AND.IKOMP.EQ.0)THEN
            IF(IMODEL.EQ.1)THEN
               DO 80114 K=KDEB,KFIN
                  KP=K+1-KDEB
                  PG(KP)=(DTDX(KP)+DTDY(KP)+DTDZ(KP))/SGT
                  IF(PG(KP).GT.0.D0)C1G(KP)=C1
80114          CONTINUE
            ELSEIF(IMODEL.EQ.2)THEN
               DO 80214 K=KDEB,KFIN
                  KP=K+1-KDEB
                  PG(KP)=(DTDX(KP)+DTDY(KP)+DTDZ(KP))/SGT
                  RF    =-PG(KP)/(P(KP)+PG(KP)+zxzini)
                  IF(PG(KP).GT.0.D0)RF=0.D0
                  C1G(KP)=C1*(1.D0+C3*RF    )
                  C1P(KP)=C1*(1.D0+C3*RF    )
80214          CONTINUE
            END IF
         END IF
 
C --------------------------------------------------------------
C *** FIN DU CALCUL DU TERME DE PRODUCTION *********************
 
         DO 80074 K=KDEB,KFIN
            KP=K-KDEB+1
            BMX=UMI(KP,1)/AL(KP)
            BMY=UMI(KP,2)/AH(KP)
            BMZ=UMI(KP,3)/AP(KP)
            BM(KP)=BMX*BMX+BMY*BMY+BMZ*BMZ
            BM(KP)=SQRT(BM(KP))+zxzini
 
            BPGXX=UPIGX(KP,1)/AL(KP)
            BPGXY=UPIGX(KP,2)/AH(KP)
            BPGXZ=UPIGX(KP,3)/AP(KP)
            BPGX(KP)=BPGXX*BPGXX+BPGXY*BPGXY+BPGXZ*BPGXZ
            BPGX(KP)=SQRT(BPGX(KP))+zxzini
            BPGYX=UPIGY(KP,1)/AL(KP)
            BPGYY=UPIGY(KP,2)/AH(KP)
            BPGYZ=UPIGY(KP,3)/AP(KP)
            BPGY(KP)=BPGYX*BPGYX+BPGYY*BPGYY+BPGYZ*BPGYZ
            BPGY(KP)=SQRT(BPGY(KP))+zxzini
            BPGZX=UPIGZ(KP,1)/AL(KP)
            BPGZY=UPIGZ(KP,2)/AH(KP)
            BPGZZ=UPIGZ(KP,3)/AP(KP)
            BPGZ(KP)=BPGZX*BPGZX+BPGZY*BPGZY+BPGZZ*BPGZZ
            BPGZ(KP)=SQRT(BPGZ(KP))+zxzini
 
            BPKX=UPIK(KP,1)/AL(KP)
            BPKY=UPIK(KP,2)/AH(KP)
            BPKZ=UPIK(KP,3)/AP(KP)
            BPK(KP)=BPKX*BPKX+BPKY*BPKY+BPKZ*BPKZ
            BPK(KP)=SQRT(BPK(KP))+zxzini
            BPEX=UPIE(KP,1)/AL(KP)
            BPEY=UPIE(KP,2)/AH(KP)
            BPEZ=UPIE(KP,3)/AP(KP)
            BPE(KP)=BPEX*BPEX+BPEY*BPEY+BPEZ*BPEZ
            BPE(KP)=SQRT(BPE(KP))+zxzini
80074    CONTINUE
C
C     AVANT DECENTREMENT
C
C ALFA,AKSI,CCU utilisées seulement dans la boucle 7008
         IF(IDCEN.EQ.1)THEN
            DO 80081 K=KDEB,KFIN
               KP=K-KDEB+1
               GXCXT(KP)=0.D0
               GXCYT(KP)=0.D0
               GXCZT(KP)=0.D0
               GXCXY(KP)=0.D0
               GXCXZ(KP)=0.D0
               GXCYZ(KP)=0.D0
               GYCXT(KP)=0.D0
               GYCYT(KP)=0.D0
               GYCZT(KP)=0.D0
               GYCXY(KP)=0.D0
               GYCXZ(KP)=0.D0
               GYCYZ(KP)=0.D0
               GZCXT(KP)=0.D0
               GZCYT(KP)=0.D0
               GZCZT(KP)=0.D0
               GZCXY(KP)=0.D0
               GZCXZ(KP)=0.D0
               GZCYZ(KP)=0.D0
               GKCXT(KP)=0.D0
               GKCYT(KP)=0.D0
               GKCZT(KP)=0.D0
               GKCXY(KP)=0.D0
               GKCXZ(KP)=0.D0
               GKCYZ(KP)=0.D0
               GECXT(KP)=0.D0
               GECYT(KP)=0.D0
               GECZT(KP)=0.D0
               GECXY(KP)=0.D0
               GECXZ(KP)=0.D0
               GECYZ(KP)=0.D0
80081       CONTINUE
 
         ELSEIF(IDCEN.EQ.2)THEN
            DO 8008 K=KDEB,KFIN
               KP=K-KDEB+1
               HMK=2.D0*UM(KP)/BM(KP)
               XMB(KP)=HMK
               ALFA=UM(KP)*HMK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCT=AKSI/BM(KP)
 
               HPK=2.D0*UPGX(KP)/BPGX(KP)
               ALFA=UPGX(KP)*HPK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPGX(KP)
               CPT=CCP-CCT
               CC2X=0.D0
               IF(CPT.GE.0.D0)CC2X=CPT
 
               HPK=2.D0*UPGY(KP)/BPGY(KP)
               ALFA=UPGY(KP)*HPK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPGY(KP)
               CPT=CCP-CCT
               CC2Y=0.D0
               IF(CPT.GE.0.D0)CC2Y=CPT
 
               HPK=2.D0*UPGZ(KP)/BPGZ(KP)
               ALFA=UPGZ(KP)*HPK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPGZ(KP)
               CPT=CCP-CCT
               CC2Z=0.D0
               IF(CPT.GE.0.D0)CC2Z=CPT
 
               HPK=2.D0*UPK(KP)/BPK(KP)
               ALFA=UPK(KP)*HPK/COEFK(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPK(KP)
               CPT=CCP-CCT
               CC2K=0.D0
               IF(CPT.GE.0.D0)CC2K=CPT
 
               HPK=2.D0*UPE(KP)/BPE(KP)
               ALFA=UPE(KP)*HPK/COEFE(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCP=AKSI/BPE(KP)
               CPT=CCP-CCT
               CC2E=0.D0
               IF(CPT.GE.0.D0)CC2E=CPT
 
               GXCXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT+UPIGX(KP,1)*UPIGX(KP,1
     $              )*CC2X)
               GXCYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT+UPIGX(KP,2)*UPIGX(KP,2
     $              )*CC2X)
               GXCZT(KP)=(UMI(KP,3)*UMI(KP,3)*CCT+UPIGX(KP,3)*UPIGX(KP,3
     $              )*CC2X)
               GXCXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT+UPIGX(KP,1)*UPIGX(KP,2
     $              )*CC2X)
               GXCXZ(KP)=(UMI(KP,1)*UMI(KP,3)*CCT+UPIGX(KP,1)*UPIGX(KP,3
     $              )*CC2X)
               GXCYZ(KP)=(UMI(KP,2)*UMI(KP,3)*CCT+UPIGX(KP,2)*UPIGX(KP,3
     $              )*CC2X)
 
               GYCXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT+UPIGY(KP,1)*UPIGY(KP,1
     $              )*CC2Y)
               GYCYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT+UPIGY(KP,2)*UPIGY(KP,2
     $              )*CC2Y)
               GYCZT(KP)=(UMI(KP,3)*UMI(KP,3)*CCT+UPIGY(KP,3)*UPIGY(KP,3
     $              )*CC2Y)
               GYCXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT+UPIGY(KP,1)*UPIGY(KP,2
     $              )*CC2Y)
               GYCXZ(KP)=(UMI(KP,1)*UMI(KP,3)*CCT+UPIGY(KP,1)*UPIGY(KP,3
     $              )*CC2Y)
               GYCYZ(KP)=(UMI(KP,2)*UMI(KP,3)*CCT+UPIGY(KP,2)*UPIGY(KP,3
     $              )*CC2Y)
 
               GZCXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT+UPIGZ(KP,1)*UPIGZ(KP,1
     $              )*CC2Z)
               GZCYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT+UPIGZ(KP,2)*UPIGZ(KP,2
     $              )*CC2Z)
               GZCZT(KP)=(UMI(KP,3)*UMI(KP,3)*CCT+UPIGZ(KP,3)*UPIGZ(KP,3
     $              )*CC2Z)
               GZCXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT+UPIGZ(KP,1)*UPIGZ(KP,2
     $              )*CC2Z)
               GZCXZ(KP)=(UMI(KP,1)*UMI(KP,3)*CCT+UPIGZ(KP,1)*UPIGZ(KP,3
     $              )*CC2Z)
               GZCYZ(KP)=(UMI(KP,2)*UMI(KP,3)*CCT+UPIGZ(KP,2)*UPIGZ(KP,3
     $              )*CC2Z)
 
               GKCXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT+UPIK(KP,1)*UPIK(KP,1)
     $              *CC2K)
               GKCYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT+UPIK(KP,2)*UPIK(KP,2)
     $              *CC2K)
               GKCZT(KP)=(UMI(KP,3)*UMI(KP,3)*CCT+UPIK(KP,3)*UPIK(KP,3)
     $              *CC2K)
               GKCXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT+UPIK(KP,1)*UPIK(KP,2)
     $              *CC2K)
               GKCXZ(KP)=(UMI(KP,1)*UMI(KP,3)*CCT+UPIK(KP,1)*UPIK(KP,3)
     $              *CC2K)
               GKCYZ(KP)=(UMI(KP,2)*UMI(KP,3)*CCT+UPIK(KP,2)*UPIK(KP,3)
     $              *CC2K)
 
               GECXT(KP)=(UMI(KP,1)*UMI(KP,1)*CCT+UPIE(KP,1)*UPIE(KP,1)
     $              *CC2E)
               GECYT(KP)=(UMI(KP,2)*UMI(KP,2)*CCT+UPIE(KP,2)*UPIE(KP,2)
     $              *CC2E)
               GECZT(KP)=(UMI(KP,3)*UMI(KP,3)*CCT+UPIE(KP,3)*UPIE(KP,3)
     $              *CC2E)
               GECXY(KP)=(UMI(KP,1)*UMI(KP,2)*CCT+UPIE(KP,1)*UPIE(KP,2)
     $              *CC2E)
               GECXZ(KP)=(UMI(KP,1)*UMI(KP,3)*CCT+UPIE(KP,1)*UPIE(KP,3)
     $              *CC2E)
               GECYZ(KP)=(UMI(KP,2)*UMI(KP,3)*CCT+UPIE(KP,2)*UPIE(KP,3)
     $              *CC2E)
 
 8008       CONTINUE
 
         ELSEIF(IDCEN.EQ.3)THEN
            DO 8018 K=KDEB,KFIN
               KP=K-KDEB+1
               HMK=2.D0*UM(KP)/BM(KP)
               XMB(KP)=HMK
               ALFA=UM(KP)*HMK/COEFT(KP)/2.D0
               AKSI=ALFA/3.D0
               IF(ALFA.GT.3.D0)AKSI=1.D0
               CCT=AKSI/BM(KP)
 
               GXCXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GXCYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GXCZT(KP)=UMI(KP,3)*UMI(KP,3)*CCT
               GXCXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
               GXCXZ(KP)=UMI(KP,1)*UMI(KP,3)*CCT
               GXCYZ(KP)=UMI(KP,2)*UMI(KP,3)*CCT
 
               GYCXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GYCYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GYCZT(KP)=UMI(KP,3)*UMI(KP,3)*CCT
               GYCXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
               GYCXZ(KP)=UMI(KP,1)*UMI(KP,3)*CCT
               GYCYZ(KP)=UMI(KP,2)*UMI(KP,3)*CCT
 
               GZCXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GZCYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GZCZT(KP)=UMI(KP,3)*UMI(KP,3)*CCT
               GZCXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
               GZCXZ(KP)=UMI(KP,1)*UMI(KP,3)*CCT
               GZCYZ(KP)=UMI(KP,2)*UMI(KP,3)*CCT
 
               GKCXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GKCYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GKCZT(KP)=UMI(KP,3)*UMI(KP,3)*CCT
               GKCXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
               GKCXZ(KP)=UMI(KP,1)*UMI(KP,3)*CCT
               GKCYZ(KP)=UMI(KP,2)*UMI(KP,3)*CCT
 
               GECXT(KP)=UMI(KP,1)*UMI(KP,1)*CCT
               GECYT(KP)=UMI(KP,2)*UMI(KP,2)*CCT
               GECZT(KP)=UMI(KP,3)*UMI(KP,3)*CCT
               GECXY(KP)=UMI(KP,1)*UMI(KP,2)*CCT
               GECXZ(KP)=UMI(KP,1)*UMI(KP,3)*CCT
               GECYZ(KP)=UMI(KP,2)*UMI(KP,3)*CCT
 
 8018       CONTINUE
 
         ELSEIF(IDCEN.EQ.4)THEN
            DT19=DTM1*0.5D0
            DO 8009 K=KDEB,KFIN
               KP=K-KDEB+1
               XMB(KP)=(AL(KP)+AH(KP))/2.D0
 
               GXCXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GXCYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GXCZT(KP)=UMI(KP,3)*UMI(KP,3)*DT19
               GXCXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GXCXZ(KP)=UMI(KP,1)*UMI(KP,3)*DT19
               GXCYZ(KP)=UMI(KP,2)*UMI(KP,3)*DT19
 
               GYCXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GYCYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GYCZT(KP)=UMI(KP,3)*UMI(KP,3)*DT19
               GYCXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GYCXZ(KP)=UMI(KP,1)*UMI(KP,3)*DT19
               GYCYZ(KP)=UMI(KP,2)*UMI(KP,3)*DT19
 
               GZCXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GZCYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GZCZT(KP)=UMI(KP,3)*UMI(KP,3)*DT19
               GZCXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GZCXZ(KP)=UMI(KP,1)*UMI(KP,3)*DT19
               GZCYZ(KP)=UMI(KP,2)*UMI(KP,3)*DT19
 
               GKCXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GKCYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GKCZT(KP)=UMI(KP,3)*UMI(KP,3)*DT19
               GKCXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GKCXZ(KP)=UMI(KP,1)*UMI(KP,3)*DT19
               GKCYZ(KP)=UMI(KP,2)*UMI(KP,3)*DT19
 
               GECXT(KP)=UMI(KP,1)*UMI(KP,1)*DT19
               GECYT(KP)=UMI(KP,2)*UMI(KP,2)*DT19
               GECZT(KP)=UMI(KP,3)*UMI(KP,3)*DT19
               GECXY(KP)=UMI(KP,1)*UMI(KP,2)*DT19
               GECXZ(KP)=UMI(KP,1)*UMI(KP,3)*DT19
               GECYZ(KP)=UMI(KP,2)*UMI(KP,3)*DT19
 
 8009       CONTINUE
 
         ENDIF
 
C     WRITE(IOIMP,*)' Avt Calcul DT'
C
C     AVANT CALCUL DT
C
         DO 8010 K=KDEB,KFIN
            KP=K-KDEB+1
            DT0=DT
            DT1X=2.D0/
     &           (UMI(KP,1)*UMI(KP,1)/(GXCXT(KP)+COEFT(KP))
     &           +UMI(KP,2)*UMI(KP,2)/(GXCYT(KP)+COEFT(KP))
     &           +UMI(KP,3)*UMI(KP,3)/(GXCZT(KP)+COEFT(KP)))
            DT1Y=2.D0/
     &           (UMI(KP,1)*UMI(KP,1)/(GYCXT(KP)+COEFT(KP))
     &           +UMI(KP,2)*UMI(KP,2)/(GYCYT(KP)+COEFT(KP))
     &           +UMI(KP,3)*UMI(KP,3)/(GYCZT(KP)+COEFT(KP)))
            DT1Z=2.D0/
     &           (UMI(KP,1)*UMI(KP,1)/(GZCXT(KP)+COEFT(KP))
     &           +UMI(KP,2)*UMI(KP,2)/(GZCYT(KP)+COEFT(KP))
     &           +UMI(KP,3)*UMI(KP,3)/(GZCZT(KP)+COEFT(KP)))
            DT2X=0.5D0/
     &           ((GXCXT(KP)+COEFT(KP))*AL2(KP)
     &           +(GXCYT(KP)+COEFT(KP))*AH2(KP)
     &           +(GXCZT(KP)+COEFT(KP))*AP2(KP))
            DT2Y=0.5D0/
     &           ((GYCXT(KP)+COEFT(KP))*AL2(KP)
     &           +(GYCYT(KP)+COEFT(KP))*AH2(KP)
     &           +(GYCZT(KP)+COEFT(KP))*AP2(KP))
            DT2Z=0.5D0/
     &           ((GZCXT(KP)+COEFT(KP))*AL2(KP)
     &           +(GZCYT(KP)+COEFT(KP))*AH2(KP)
     &           +(GZCZT(KP)+COEFT(KP))*AP2(KP))
            IF(DT1X.LT.DT)DT=DT1X
            IF(DT1Y.LT.DT)DT=DT1Y
            IF(DT1Z.LT.DT)DT=DT1Z
            IF(DT2X.LT.DT)DT=DT2X
            IF(DT2Y.LT.DT)DT=DT2Y
            IF(DT2Z.LT.DT)DT=DT2Z
C     IF(DT3.LT.DT)DT=DT3
            IF(DT.NE.DT0) THEN
               DTT1=MIN(DT1X,DT1Y,DT1Z)
               DTT2=MIN(DT2X,DT2Y,DT2Z)
C        DTT3=DT3
               DIAEL=XMB(KP)
               NUEL=K
            END IF
 8010    CONTINUE
 
C     WRITE(IOIMP,*)' le coeur du calcul '
C Le coeur du calcul ...
 
         IF(IKOMP.EQ.0)THEN
 
            DO 8014 I=1,NP
               DO 80141 J=1,NP
                  DO 80142 K=KDEB,KFIN
                     KP=K-KDEB+1
C     GEO1=(CF1(KP)*Q1(J,I)+CF2(KP)*Q2(J,I)+CF3(KP)*Q3(J,I))*CUB8
                     GEO1=CFM(KP)*QGGT(J,I)*CUB8
                     ZVGGX=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GXCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GXCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GXCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GXCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GXCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GXCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GXCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GXCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GXCYZ(KP) )
     &               +    (GXCXT(KP)+GXCYT(KP)+GXCZT(KP))/3.D0*GEO1
C    &+    (GXCXT(KP)+GXCYT(KP)+GXCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGGY=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GYCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GYCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GYCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GYCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GYCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GYCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GYCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GYCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GYCYZ(KP) )
     &               +    (GYCXT(KP)+GYCYT(KP)+GYCZT(KP))/3.D0*GEO1
C    &+    (GYCXT(KP)+GYCYT(KP)+GYCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGGZ=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GZCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GZCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GZCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GZCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GZCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GZCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GZCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GZCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GZCYZ(KP) )
     &               +    (GZCXT(KP)+GZCYT(KP)+GZCZT(KP))/3.D0*GEO1
C    &+    (GZCXT(KP)+GZCYT(KP)+GZCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGD=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*COEFT(KP) )
     &               +    COEFT(KP)*XMH(KP)*GEO1
C    &+    COEFT(KP)*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGK =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GKCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GKCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GKCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GKCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GKCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GKCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GKCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GKCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GKCYZ(KP) )
     &               +    (GKCXT(KP)+GKCYT(KP)+GKCZT(KP))/3.D0*GEO1
C    &+    (GKCXT(KP)+GKCYT(KP)+GKCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGE =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GECXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GECYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GECZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GECXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GECXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GECXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GECXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GECYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GECYZ(KP) )
     &               +    (GECXT(KP)+GECYT(KP)+GECZT(KP))/3.D0*GEO1
C    &+    (GECXT(KP)+GECYT(KP)+GECZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGDK=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFK(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFK(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*COEFK(KP) )
     &               +    COEFK(KP)*XMH(KP)*GEO1
C    &+    COEFK(KP)*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGDE=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFE(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFE(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*COEFE(KP) )
     &               +    COEFE(KP)*XMH(KP)*GEO1
C    &+    COEFE(KP)*XMH(KP)*QGGT(J,I)*CUB8
 
Cnon  V2=(UIX(KP,I)*HR(K,J,1)+UIY(KP,I)*HR(K,J,2)+UIZ(KP,I)*HR(K,J,3))
C    &   *DR(KP,I)
 
                     V2=UMI(KP,1)*DR(KP,I)*HR(K,J,1)+UMI(KP,2)*DR(KP,I)
     $                    *HR(K,J,2)+UMI(KP,3)*DR(KP,I)*HR(K,J,3)
 
                     SAF1(KP,I)=SAF1(KP,I)+(V2+ZVGGX)*GIX(KP,J)+ZVGD
     $                    *UIX(KP,J)
                     SAF2(KP,I)=SAF2(KP,I)+(V2+ZVGGY)*GIY(KP,J)+ZVGD
     $                    *UIY(KP,J)
                     SAF3(KP,I)=SAF3(KP,I)+(V2+ZVGGZ)*GIZ(KP,J)+ZVGD
     $                    *UIZ(KP,J)
 
                     SAFK(KP,I)=SAFK(KP,I)+(V2+ZVGK)*AK(KP,J)+ZVGDK
     $                    *AK(KP,J)
                     SAFE(KP,I)=SAFE(KP,I)+(V2+ZVGE)*AE(KP,J)+ZVGDE
     $                    *AE(KP,J)
 
80142             CONTINUE
80141          CONTINUE
 8014       CONTINUE
 
         ELSEIF(IKOMP.EQ.1)THEN
C->
 
            DO 8015 I=1,NP
               DO 80151 J=1,NP
                  DO 80152 K=KDEB,KFIN
                     KP=K-KDEB+1
C     GEO1=(CF1(KP)*Q1(J,I)+CF2(KP)*Q2(J,I)+CF3(KP)*Q3(J,I))*CUB8
                     GEO1=CFM(KP)*QGGT(J,I)*CUB8
                     ZVGGX=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GXCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GXCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GXCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GXCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GXCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GXCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GXCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GXCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GXCYZ(KP) )
     &               +    (GXCXT(KP)+GXCYT(KP)+GXCZT(KP))/3.D0*GEO1
C    &+    (GXCXT(KP)+GXCYT(KP)+GXCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGGY=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GYCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GYCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GYCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GYCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GYCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GYCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GYCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GYCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GYCYZ(KP) )
     &               +    (GYCXT(KP)+GYCYT(KP)+GYCZT(KP))/3.D0*GEO1
C    &+    (GYCXT(KP)+GYCYT(KP)+GYCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGGZ=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GZCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GZCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GZCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GZCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GZCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GZCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GZCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GZCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GZCYZ(KP) )
     &               +    (GZCXT(KP)+GZCYT(KP)+GZCZT(KP))/3.D0*GEO1
C    &+    (GZCXT(KP)+GZCYT(KP)+GZCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGD=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*COEFT(KP) )
     &               +    COEFT(KP)*GEO1
C    &+    COEFT(KP)*XMH(KP)*GEO1
C    &+    COEFT(KP)*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGK =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GKCXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GKCYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GKCZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GKCXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GKCXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GKCXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GKCXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GKCYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GKCYZ(KP) )
     &               +    (GKCXT(KP)+GKCYT(KP)+GKCZT(KP))/3.D0*GEO1
C    &+    (GKCXT(KP)+GKCYT(KP)+GKCZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGE =AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*GECXT(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*GECYT(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*GECZT(KP)
     &               +    HR(K,I,1)*HR(K,J,2)*GECXY(KP)
     &               +    HR(K,I,2)*HR(K,J,1)*GECXY(KP)
     &               +    HR(K,I,1)*HR(K,J,3)*GECXZ(KP)
     &               +    HR(K,I,3)*HR(K,J,1)*GECXZ(KP)
     &               +    HR(K,I,2)*HR(K,J,3)*GECYZ(KP)
     &               +    HR(K,I,3)*HR(K,J,2)*GECYZ(KP) )
     &               +    (GECXT(KP)+GECYT(KP)+GECZT(KP))/3.D0*GEO1
C    &+    (GECXT(KP)+GECYT(KP)+GECZT(KP))/3.D0*XMH(KP)*QGGT(J,I)*CUB8
 
                     ZVGDK=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFK(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFK(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*COEFK(KP) )
     &               +    COEFK(KP)*GEO1
 
                     ZVGDE=AIRE(KP)*(
     &                    HR(K,I,1)*HR(K,J,1)*COEFE(KP)
     &               +    HR(K,I,2)*HR(K,J,2)*COEFE(KP)
     &               +    HR(K,I,3)*HR(K,J,3)*COEFE(KP) )
     &               +    COEFE(KP)*GEO1
C    &+    COEFE(KP)*XMH(KP)*QGGT(J,I)*CUB8
 
                     COEFT3=COEFT(KP)/3.D0
                     ZVGUU=(AIRE(KP)*(HR(K,I,1)*HR(K,J,1))+GEO1)*COEFT3
     $                    *UIX(KP,J)
                     ZVGUV=AIRE(KP)*( HR(K,I,1)*HR(K,J,2))*COEFT3*UIY(KP
     $                    ,J)
                     ZVGUW=AIRE(KP)*( HR(K,I,1)*HR(K,J,3))*COEFT3*UIZ(KP
     $                    ,J)
                     ZVGVU=AIRE(KP)*( HR(K,I,2)*HR(K,J,1))*COEFT3*UIX(KP
     $                    ,J)
                     ZVGVV=(AIRE(KP)*(HR(K,I,2)*HR(K,J,2))+GEO1)*COEFT3
     $                    *UIY(KP,J)
                     ZVGVW=AIRE(KP)*( HR(K,I,2)*HR(K,J,3))*COEFT3*UIZ(KP
     $                    ,J)
                     ZVGWU=AIRE(KP)*( HR(K,I,3)*HR(K,J,1))*COEFT3*UIX(KP
     $                    ,J)
                     ZVGWV=AIRE(KP)*( HR(K,I,3)*HR(K,J,2))*COEFT3*UIY(KP
     $                    ,J)
                     ZVGWW=(AIRE(KP)*(HR(K,I,3)*HR(K,J,3))+GEO1)*COEFT3
     $                    *UIZ(KP,J)
 
                     V2=(UIX(KP,J)*HR(K,J,1)+UIY(KP,J)*HR(K,J,2)+UIZ(KP
     $                    ,J)*HR(K,J,3))*DR(KP,I)
 
C     V2=UMI(KP,1)*DR(KP,I)*HR(K,J,1)+UMI(KP,2)*DR(KP,I)*HR(K,J,2)
 
                     SAF1(KP,I)=SAF1(KP,I)+(V2+ZVGGX)*GIX(KP,J)+ZVGD
     $                    *UIX(KP,J)+ ZVGUU + ZVGUV + ZVGUW
                     SAF2(KP,I)=SAF2(KP,I)+(V2+ZVGGY)*GIY(KP,J)+ZVGD
     $                    *UIY(KP,J)+ ZVGVU + ZVGUV + ZVGVW
                     SAF3(KP,I)=SAF3(KP,I)+(V2+ZVGGZ)*GIZ(KP,J)+ZVGD
     $                    *UIZ(KP,J)+ ZVGWU + ZVGWV + ZVGWW
 
                     SAFK(KP,I)=SAFK(KP,I)+(V2+ZVGK)*AK(KP,J)+ZVGDK
     $                    *AK(KP,J)
                     SAFE(KP,I)=SAFE(KP,I)+(V2+ZVGE)*AE(KP,J)+ZVGDE
     $                    *AE(KP,J)
 
80152             CONTINUE
80151          CONTINUE
 8015       CONTINUE
 
         ENDIF
 
C
C --------------------------------------------------------------
C
C
         DO 8017 I=1,NP
            DO 80171 K=KDEB,KFIN
               KP=K-KDEB+1
               TSK       =(ANUT(KP)*(P(KP)+PG(KP))-AEM(KP))*DR(KP,I)
               SAFK(KP,I)=SAFK(KP,I)-TSK
 
               TSE       =(CNU*(C1P(KP)*P(KP)+C1G(KP)*PG(KP))*AKM(KP))
     $              *DR(KP,I)
               SAFE(KP,I)=SAFE(KP,I)-TSE
 
               TSE1      =C2*AEM(KP)/AKM(KP)*DR(KP,I)
               BE1(KP,I) =TSE1
80171       CONTINUE
 8017    CONTINUE
 
C
C
C --- ECRITURE DANS LES TABLEAUX F(1,*),F(2,*),G,GK,GE,GE1 (SCALAIRE)
         DO 80019 I=1,NP
            DO 50019 K=KDEB,KFIN
               KP=K+1-KDEB
               NF=IPADS(LE(I,K))
               F(NF,1)=F(NF,1)-SAF1(KP,I)
               F(NF,2)=F(NF,2)-SAF2(KP,I)
               F(NF,3)=F(NF,3)-SAF3(KP,I)
               GK(NF) =GK(NF) -SAFK(KP,I)
               GE1(NF)=GE1(NF)+BE1(KP,I)
               GE(NF) =GE (NF)-SAFE(KP,I)
50019       CONTINUE
80019    CONTINUE
80001 CONTINUE
C
C *** FIN DE LA BOUCLE SUR LES PAQUETS D'ELEMENTS ***
C
C     WRITE(IOIMP,*)' FIN YCVIT GK='
C     WRITE(IOIMP,1002)(GK(i),i=1,nptd)
 
      IPAS=1
      RETURN
 
 1002 FORMAT(10(1X,1PE11.4))
      END