C ZTSCAL    SOURCE    MAGN      10/05/18    21:18:05     6675           
      SUBROUTINE ZTSCAL(MTABX,MTAB1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
C***********************************************************************
C
C  CET OPERATEUR DISCRETISE UNE EQUATION DE TRANSPORT
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  SYNTAXE :
C  ---------
C    1/ Cas incompréssible
C
C de/dt + u Grad e = alpha Lapl e  < + S >
C
C   'OPER' 'TSCAL' al 'UN' s          'INCO' EN :
C   'OPER' 'TSCAL' al 'UN' s alt sgt  'INCO' EN :
C
C    2/ Cas compréssible
C
C dh/dt + u Grad h + h Div u = alpha Lapl(tn) < + S >
C
C   'OPER' 'TSCAL' lb 'UN' s tn         'INCO' HN :
C   'OPER' 'TSCAL' lb 'UN' s tn lbt sgt 'INCO' HN :
C
C
C    al,alt Diffusivité thermique moléculaire ou turbulente
C         FLOTTANT où CHPOINT SCAL CENTRE
C    lb,lbt Conductivité thermiquemoléculaire ou turbulente
C         FLOTTANT où CHPOINT SCAL CENTRE
C    sgt  Prandtl turbulent
C    s    source volumique
C         POINT où CHPOINT SCAL CENTRE
C
C    un   Champ de vitesse transportant
C         CHPOINT VECT SOMMET
C    tn   Champ de température
C         CHPOINT SCAL SOMMET
C
C***********************************************************************

-INC CCVQUA4
-INC CCOPTIO
-INC CCGEOME
-INC SIZFFB
      POINTEUR IZF1.IZFFM
-INC SMCHAML
-INC SMCOORD
-INC SMLENTI
      POINTEUR IPADI.MLENTI,IPADS.MLENTI
      POINTEUR IPADU.MLENTI,IPADD.MLENTI
      POINTEUR IPADQ.MLENTI,MELEMI.MELEME,MELEP1.MELEME
-INC SMELEME
      POINTEUR MELEM1.MELEME,MELEMC.MELEME,MELEMS.MELEME
      POINTEUR MELEMQ.MELEME
-INC SMCHPOI
      POINTEUR IZGG1.MPOVAL
      POINTEUR IZTU1.MPOVAL
      POINTEUR VISCO.MPOVAL
      POINTEUR IZTGG3.MPOVAL,IZTGG4.MPOVAL
      POINTEUR IZTGG6.MPOVAL
      POINTEUR MZALT.MPOVAL,MZST.MPOVAL
      POINTEUR IZVOL.MPOVAL,IZTCO.MPOVAL
      POINTEUR VITESS.MPOVAL,UTRANS.MPOVAL
-INC SMMATRIK
      POINTEUR IPM.IZAFM
      SEGMENT IMATRS
      INTEGER LIZAFS(NBSOUS,NBME)
      ENDSEGMENT
      POINTEUR IPMS.IZAFM,IPS1.IZAFM,IPS2.IZAFM,IPS3.IZAFM
-INC SMLMOTS
      POINTEUR LINCO.MLMOTS
      CHARACTER*8 NOMZ,NOMI,NOM0,TYPE,TYPC,NOM,NOMA
      PARAMETER (NTB=1)
      CHARACTER*8 LTAB(NTB)
      DIMENSION KTAB(NTB),IXV(3),RO(1)
      SAVE IPAS
      DATA LTAB/'KIZX    '/,IPAS/0/,RO/1.D0/
C*****************************************************************************
CTSCAL
C     write(6,*)' Debut TSCAL'

C
C- Récupération de la table DOMAINE associée au domaine local
C
      CALL ACMM(MTABX,'NOMZONE',NOMZ)
      CALL LEKTAB(MTABX,'DOMZ',MTABZ)
      IF(MTABZ.EQ.0)THEN
C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
         MOTERR( 1: 8) = '  DOMZ  '
         MOTERR( 9:16) = '  DOMZ  '
         MOTERR(17:24) = '  KIZX  '
         CALL ERREUR(786)
         RETURN
      ENDIF
C
C- Récupération de la table INCO (pointeur KINC)
C
      CALL LEKTAB(MTAB1,'INCO',KINC)
      IF(KINC.EQ.0)THEN
C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
         MOTERR( 1: 8) = '  INCO  '
         MOTERR( 9:16) = '  INCO  '
         MOTERR(17:24) = '  EQEX  '
         CALL ERREUR(786)
      RETURN
      ENDIF

C*****************************************************************************
C OPTIONS

C
C- Récupération de la table des options KOPT (pointeur KOPTI)
C
      CALL LEKTAB(MTABX,'KOPT',KOPTI)
      IF (KOPTI.EQ.0) THEN
C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
         MOTERR( 1: 8) = '  KOPT  '
         MOTERR( 9:16) = '  KOPT  '
         MOTERR(17:24) = '  KIZX  '
         CALL ERREUR(786)
         RETURN
      ENDIF

      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2

      CALL ACME(KOPTI,'MTRMASS ',MMPG)
      IPG=0
      IF(MMPG.EQ.3)IPG=1
      CALL ACME(KOPTI,'IDCEN',IDCEN)
      CALL ACME(KOPTI,'IKOMP',IKOMP)
      CALL ACME(KOPTI,'KIMPL',KIMPL)
      CALL ACMF(KOPTI,'AIMPL',AIMPL)
      CALL ACME(KOPTI,'KFORM',KFORM)
      CALL ACME(KOPTI,'KPOIN',KPRE)
      CALL ACME(KOPTI,'KMACO',KMACO)
         IF (IERR.NE.0) RETURN

C*****************************************************************************

      CALL LEKTAB(MTABZ,'MAILLAGE',MELEME)
      CALL LEKTAB(MTABZ,'SOMMET',MELEMS)
      CALL LEKTAB(MTABZ,'CENTRE',MELEMC)
      CALL LEKTAB(MTABZ,'MACRO',MACRO)
      CALL LEKTAB(MTABZ,'MACRO1',MELEMI)
      CALL LEKTAB(MTABZ,'QUADRATI',MQUAD)
         IF (IERR.NE.0) RETURN

      MELEMQ=MELEMC
      MELEP1=MELEMC
C     write(6,*)' KPRE=',kpre,' MACRO=',macro,' QUADR=',MQUAD
      IF(KPRE.LE.3.AND.MACRO.EQ.0.AND.MQUAD.EQ.0.AND.KFORM.NE.0)THEN
      WRITE(6,*)' Operateur TSCA '
      WRITE(6,*)' Incompatibilité du terme source et des éléments'
      WRITE(6,*)' MACRO ou QUADRATIQUE attendu '
      WRITE(6,*)' Interuption anormale de TSCA'
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = '  EF    '
      CALL ERREUR(803)
      RETURN
      ELSEIF(KPRE.EQ.3)THEN
      CALL LEKTAB(MTABZ,'CENTREP0',MELEMQ)
      MELEP1=MELEMQ
      ELSEIF(KPRE.EQ.4)THEN
      CALL LEKTAB(MTABZ,'CENTREP1',MELEMQ)
      CALL LEKTAB(MTABZ,'ELTP1NC ',MELEP1)
      ENDIF

      CALL LEKTAB(MTABZ,'XXPSOML',MCHELM)
      CALL LEKTAB(MTABZ,'XXDXDY',MCHPDX)
      CALL LEKTAB(MTABZ,'XXVOLUM',MCHPVO)
         IF (IERR.NE.0) RETURN

      SEGACT MCHELM
      CALL LICHT(MCHPDX,IZTCO,TYPC,IGEOM)
      NELZ=IZTCO.VPOCHA(/1)
      CALL LICHT(MCHPVO,IZVOL,TYPC,IGEOM)
C***


C*************************************************************************
C VERIFICATIONS SUR LES INCONNUES
C
C- Récupération du nombre d'inconnues et du nom de l'inconnue NOMI
C
      TYPE='LISTMOTS'
      CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO)
      IF (IERR.NE.0) RETURN
      SEGACT LINCO
      NBINC=LINCO.MOTS(/2)
      IF(NBINC.NE.1)THEN
C        Indice %m1:8 : contient plus de %i1 %m9:16
         MOTERR( 1:8) = 'LISTINCO'
         INTERR(1) = 1
         MOTERR(9:16) = ' MOTS   '
         CALL ERREUR(799)
         RETURN
      ENDIF

      NOMI=LINCO.MOTS(1)
      NOMA=NOMI
C
C- Récupération de l'inconnue
C
      TYPE=' '
      CALL ACMO(KINC,NOMI,TYPE,MCHPOI)
      IF(TYPE.NE.'CHPOINT ')THEN
C        Indice %m1:8 : ne contient pas un objet de type %m9:16
         MOTERR( 1: 8) = 'INC '//NOMI
         MOTERR( 9:16) = 'CHPOINT '
         CALL ERREUR(800)
         RETURN
      ELSE
      CALL LICHT(MCHPOI,IZTU1,TYPC,MELEM1)
         NINKO = IZTU1.VPOCHA(/2)
         IF (NINKO.NE.1) THEN
C        Indice %m1:8 : Le %m9:16 n'a pas le bon nombre de composantes
            MOTERR( 1: 8) = 'INC '//NOMI
            MOTERR( 9:16) = 'CHPOINT '
            CALL ERREUR(784)
            RETURN
         ENDIF
      ENDIF

C*****************************************************************************
C Le domaine de definition est donne par le SPG  de la premiere inconnue
C Les inconnues suivantes devront posseder ce meme pointeur
C On verifie que les points de la zone sont tous inclus dans ce SPG

      CALL KRIPAD(MELEM1,IPADI)
      IPADS=IPADI
      IPADD=IPADI
      IF(MELEM1.NE.MELEMS)CALL KRIPAD(MELEMS,IPADS)
      IPADU=IPADS

      IF(IPAS.EQ.0)THEN
      CALL VERPAD(IPADI,MELEME,IRET)
      IF(IRET.NE.0)THEN
C     Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
         MOTERR(1: 8) = 'INC '//NOMI
         MOTERR(9:16) = 'CHPOINT '
         CALL ERREUR(788)
         RETURN
      ENDIF
      ENDIF

C*****************************************************************************
C Lecture des coefficient
C Type du coefficient :
C IK1=0 CHPOINT IK1=1 scalaire  IK1=2 vecteur

C     write(6,*)' Opérateur TSCAL lecture des coefficients'
      CALL ACME(MTABX,'IARG',IARG)
      IF(IKOMP.EQ.0)THEN
      IF(IARG.NE.3.AND.IARG.NE.5)THEN
      WRITE(6,*)' Opérateur TSCAL : option incompréssible '
      WRITE(6,*)' Nombre d''arguments incorrect : ',IARG
      WRITE(6,*)' On attend 3 ou 5 '
C           Indice %m1:8 : nombre d'arguments incorrect
            MOTERR(1:8) = 'IARG    '
            CALL ERREUR(804)
            RETURN
         ENDIF
      ELSEIF(IKOMP.EQ.1)THEN
      IF(IARG.NE.4.AND.IARG.NE.6)THEN
      WRITE(6,*)' Opérateur TSCAL : option compréssible '
      WRITE(6,*)' Nombre d''arguments incorrect : ',IARG
      WRITE(6,*)' On attend 4 ou 6 '
C           Indice %m1:8 : nombre d'arguments incorrect
            MOTERR(1:8) = 'IARG    '
            CALL ERREUR(804)
            RETURN
         ENDIF
      ENDIF

C--Cas incompréssible
      IF(IKOMP.EQ.0)THEN
C 1er coefficient  Alpha
      IXV(1)=MELEMC
      IXV(2)=1
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,1,IXV,MCOF,VISCO,NPT1,NC1,IKL,IRET)
      IF(IRET.EQ.0)RETURN

      IK2=-1
      IKG=-1
      IK3=-1
      IK4=-1
      IZTGG4=IZTU1
      MZALT=VISCO
      MZST=VISCO

C 2ème coefficient  UN
      IXV(1)=-MELEMS
      IXV(2)=0
      IXV(3)=1
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,2,IXV,MUTR,UTRANS,NPTU,NC2,IKU,IRET)
      IF(IRET.EQ.0)RETURN
      IF(IKU.EQ.2)IKU=1

C 3ème coefficient  source
      IXV(1)=MELEMC
      IXV(2)=1
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,3,IXV,IZTG3,IZTGG3,NPT3,NC3,IKS,IRET)
      IF(IRET.EQ.0)RETURN

      IF(IARG.EQ.5)THEN
C alpha turbulent
      IXV(1)=MELEMC
      IXV(2)=0
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,4,IXV,MALT,MZALT,NPT4,NC4,IK4,IRET)
      IF(IRET.EQ.0)RETURN

C sigma turbulent
      IXV(1)=0
      IXV(2)=1
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,5,IXV,MST,MZST,NPT5,NC5,IK5,IRET)
      IF(IRET.EQ.0)RETURN
      IF(MZST.VPOCHA(1,1).LE.0.D0)THEN
      WRITE(6,*)' Opérateur TSCAL :'
      WRITE(6,*)'Valeur du Prandtl turbulent érronée'
      RETURN
      ENDIF
      ENDIF

C--Cas compréssible
      ELSEIF(IKOMP.EQ.1)THEN
C 1er coefficient  Lambda
      IXV(1)=MELEMC
      IXV(2)=1
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,1,IXV,MCOF,VISCO,NPT1,NC1,IKL,IRET)
      IF(IRET.EQ.0)RETURN

      IK2=-1
      IKG=-1
      IK3=-1
      IK4=-1
      MZALT=VISCO
      MZST=VISCO

C 2ème coefficient  UN
      IXV(1)=-MELEMS
      IXV(2)=0
      IXV(3)=1
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,2,IXV,MUTR,UTRANS,NPTU,NC2,IKU,IRET)
      IF(IRET.EQ.0)RETURN
      IF(IKU.EQ.2)IKU=1

C 3ème coefficient  source
      IXV(1)=MELEMC
      IXV(2)=1
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,3,IXV,IZTG3,IZTGG3,NPT3,NC3,IKS,IRET)
      IF(IRET.EQ.0)RETURN

C 4ème coefficient  tn
      IXV(1)=MELEMS
      IXV(2)=0
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,4,IXV,IZTG4,IZTGG4,NPT4,NC4,IK4,IRET)
      IPADD=IPADS
      IF(IRET.EQ.0)RETURN

      IF(IARG.EQ.6)THEN
C lambda turbulent
      IXV(1)=MELEMC
      IXV(2)=0
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,5,IXV,MALT,MZALT,NPT5,NC5,IK5,IRET)
      IF(IRET.EQ.0)RETURN

C sigma turbulent
      IXV(1)=0
      IXV(2)=1
      IXV(3)=0
      CALL LEKCOF('Opérateur TSCAL :',
     & MTABX,KINC,6,IXV,MST,MZST,NPT6,NC6,IK6,IRET)
      IF(IRET.EQ.0)RETURN
      IF(MZST.VPOCHA(1,1).LE.0.D0)THEN
       call erreur(992)
      RETURN
      ENDIF
      ENDIF

      ENDIF

C     write(6,*)' Opérateur TSCAL : Fin lecture Arguments '
C Fin lecture Arguments ************************************************


      CALL LEKTAB(MTAB1,'PASDETPS',MTABT)
      IF(MTABT.EQ.0)THEN
      CALL CRTABL(MTABT)
      CALL ECMM(MTABT,'SOUSTYPE','PASDETPS')
      CALL ECMO(MTAB1,'PASDETPS','TABLE   ',MTABT)
      DT=1.D30
      DTP=1.D30+DT
      IPAT=1
      CALL ECME(MTABT,'NUPASDT',IPAT)
      DTM1=1.D-20
      CALL ECMF(MTABT,'DELTAT-1',DTM1)
      ELSE
      CALL ACMF(MTABT,'DELTAT',DTP)
      CALL ACMF(MTABT,'DELTAT-1',DTM1)
      ENDIF

C*********** FORMULATIONS **********
C*********** FORMULATIONS **********
C*********** FORMULATIONS **********



C************************** FORMULATION EFM1 ***************************
      IF(KFORM.EQ.0)THEN
C Formulation EFM1
C Vérification des options

      IF(KIMPL.NE.0)THEN
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = ' EFM1   '
            WRITE(6,*)' Options incompatibles : EFM1 et (IMPL ou SEMI) '
            CALL ERREUR(803)
            RETURN
        ENDIF

      IF(IKOMP.EQ.1.AND.(IDCEN.EQ.6.OR.IDCEN.EQ.7))THEN
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = ' EFM1   '
            WRITE(6,*)' Option de décentrement non prévue en',
     &                ' formulation conservative '
            CALL ERREUR(803)
            RETURN
        ENDIF

      IF(IDCEN.GE.4.AND.(IDCEN.NE.6.AND.IDCEN.NE.7))THEN
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = ' EFM1   '
            WRITE(6,*)' Option de décentrement non prévue en',
     &                ' formulation EFM1 '
            CALL ERREUR(803)
            RETURN
        ENDIF

      IF(IDIM.EQ.3.AND.(IDCEN.EQ.6.OR.IDCEN.EQ.7))THEN
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = ' EFM1   '
            WRITE(6,*)' Option de décentrement non prévue en 3D'
            CALL ERREUR(803)
            RETURN
        ENDIF

      CALL LEKTAB(MTAB1,'KIZG',KIZG)
      IF(KIZG.EQ.0)THEN
      CALL CRTABL(KIZG)
      CALL ECMM(KIZG,'SOUSTYPE','KIZG')
      CALL ECMO(MTAB1,'KIZG','TABLE   ',KIZG)
      ENDIF

      TYPE=' '
      CALL ACMO(KIZG,NOMI,TYPE,IZG1)
      IF(TYPE.NE.'CHPOINT ')THEN
      NC=IZTU1.VPOCHA(/2)
      TYPE='SOMMET'
      CALL CRCHPT(TYPE,MELEM1,NC,IZG1)
      CALL ECMO(KIZG,NOMI,'CHPOINT ',IZG1)
      ENDIF

      CALL LICHT(IZG1,IZGG1,TYPC,IGEOM)

      IF(IGEOM.NE.MELEM1)THEN
      WRITE(6,*)' Opérateur TSCAL'
      WRITE(6,*)'Incompatibilite de SPG entre 1eres inconnues'
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = '  EFM1  '
            CALL ERREUR(803)
      RETURN 
      ENDIF 

      CALL LEKTAB(MTABZ,'MATESI',MATRIK)
      IF (IERR.NE.0) RETURN
      SEGACT MATRIK

      IMATRI=IRIGEL(4,1)
      SEGACT IMATRI
C---

      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
      NUTOEL=0
      DT=1.E30

      DO 1 L=1,NBSOUS
      IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1

      NOM0=NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(NOM0,'FONFORM0',IZFFM)
      SEGACT IZFFM*MOD

      MCHAML=ICHAML(L)
      SEGACT MCHAML
      MELVAL=IELVAL(1)
      SEGACT MELVAL

      IF(IMACHE(L).NE.IPT1)THEN
       write(*,*)'IPT1,IMACHE ',IPT1,IMACHE(L)
       goto 90
      ENDIF

      IZAFM=LIZAFM(L,1)
      IPM1=IZAFM
      SEGACT IZAFM
      IF(IAXI.NE.0)THEN
      IPM1=LIZAFM(L,2)
      SEGACT IPM1
      ENDIF

      NP  =IPT1.NUM(/1)
      NBEL=IPT1.NUM(/2)
      IES=IDIM

      NPTU=UTRANS.VPOCHA(/1)
      NPTT=IZTGG4.VPOCHA(/1)
      NPTI=IZTGG4.VPOCHA(/1)

      IF(IDCEN.GE.1.AND.IDCEN.LE.3)THEN

      IF(IKOMP.EQ.0)THEN

      CALL ZCTSCL(AM,IPM1.AM,VELCHE,IPT1.NUM,NBEL,NUTOEL,IES,NP,
     & IAXI,IPADI.LECT,IPADU.LECT,IPADD.LECT,IKOMP,IARG,
     & VISCO.VPOCHA,IKL,UTRANS.VPOCHA,IKU,NPTU,IZTGG4.VPOCHA,NPTT,
     & IZTGG3.VPOCHA,IKS,
     & IZTU1.VPOCHA,IZGG1.VPOCHA,NPTI,
     & MZALT.VPOCHA,MZST.VPOCHA,
     & IZVOL.VPOCHA,IZTCO.VPOCHA,NELZ,IDCEN,IPG,
     & DTM1,DT,DTT1,DTT2,NUEL,DIAEL,IZFFM.FN)

      ELSEIF(IKOMP.EQ.1)THEN

      NPT=IZGG1.VPOCHA(/1)
      CALL ZCTSCA(AM,IPM1.AM,VELCHE,IPT1.NUM,NBEL,NUTOEL,NPT,IES,NP,
     & IAXI,IPADI.LECT,IKOMP,IARG,IPADU.LECT,IPADD.LECT,
     & VISCO.VPOCHA,IKL,UTRANS.VPOCHA,IKU,NPTU,IZTGG4.VPOCHA,
     & IZTGG3.VPOCHA,IKS,IZTU1.VPOCHA,
     & IZGG1.VPOCHA,MZALT.VPOCHA,MZST.VPOCHA,
     & IZVOL.VPOCHA,IZTCO.VPOCHA,NELZ,IDCEN,
     & DTM1,DT,DTT1,DTT2,NUEL,DIAEL)

      ENDIF

      ELSEIF(IDCEN.EQ.6)THEN


      N=NPTU
      NC=1
      SEGINI MPOVA6

      CALL ZPSI(AM,IPM1.AM,VELCHE,IPT1.NUM,NBEL,NUTOEL,NPT,IES,NP,
     & IAXI,IPADI.LECT,IKOMP,IARG,
     & VISCO.VPOCHA,IKL,UTRANS.VPOCHA,IKU,NPTU,IPADU.LECT,
     & IZTGG4.VPOCHA,IZTGG3.VPOCHA,IKS,IZTU1.VPOCHA,
     & IZGG1.VPOCHA,MZALT.VPOCHA,MZST.VPOCHA,
     & IZVOL.VPOCHA,IZTCO.VPOCHA,NELZ,MPOVA6.VPOCHA,
     & DTM1,DT,DTT1,DTT2,NUEL,DIAEL)

      SEGSUP MPOVA6



      ELSEIF(IDCEN.EQ.7)THEN

      CALL ZJOHNS(AM,IPM1.AM,VELCHE,IPT1.NUM,NBEL,NUTOEL,NPT,IES,NP,
     & IAXI,IPADI.LECT,IKOMP,IARG,
     & VISCO.VPOCHA,IKL,UTRANS.VPOCHA,IKU,NPTU,IPADU.LECT,
     & IZTGG4.VPOCHA,IZTGG3.VPOCHA,IKS,IZTU1.VPOCHA,
     & IZGG1.VPOCHA,MZALT.VPOCHA,MZST.VPOCHA,
     & IZVOL.VPOCHA,IZTCO.VPOCHA,NELZ,
     & DTM1,DT,DTT1,DTT2,NUEL,DIAEL)

      ENDIF


      SEGDES IZAFM*NOMOD,IPT1*NOMOD,MCHAML*NOMOD,MELVAL*NOMOD
      IF(IAXI.NE.0)SEGDES IPM1*NOMOD
      NUTOEL=NUTOEL+NBEL

 1    CONTINUE
      SEGDES MATRIK*NOMOD,MCHELM*NOMOD
      SEGDES IMATRI

      IF(DT.LT.DTP)THEN
      CALL ECMF(MTABT,'DELTAT',DT)
      CALL ECMM(MTABT,'OPER','TSCAL')
      CALL ECMM(MTABT,'ZONE',NOMZ)
      CALL ECMF(MTABT,'DTCONV',DTT1)
      CALL ECMF(MTABT,'DTDIFU',DTT2)
      CALL ECMF(MTABT,'DIAEL',DIAEL)
      CALL ECME(MTABT,'NUEL',NUEL)
      ENDIF
      SEGDES VISCO,UTRANS
      IF(IKOMP.EQ.0.AND.IARG.EQ.3)SEGDES IZTGG3*NOMOD
      IF(IKOMP.EQ.1.AND.IARG.EQ.4)SEGDES IZTGG3*NOMOD,IZTGG4*NOMOD
      IF(IKOMP.EQ.1.AND.IARG.EQ.6)SEGDES IZTGG3*NOMOD,IZTGG4*NOMOD
     & ,MZALT*NOMOD,MZST*NOMOD
      SEGDES IZTU1*NOMOD
      SEGDES IZGG1
      SEGDES IZVOL*NOMOD,IZTCO*NOMOD
      SEGDES LINCO

C*************************************************************************
      ELSE IF(KFORM.EQ.1)THEN
C CAS FORMULATION EF

      DT=0.D0
      IF(IDCEN.EQ.4)THEN
      TYPE=' '
      CALL ACMO(MTABT,'DELTAT',TYPE,IENT)
      IF(TYPE.NE.'ENTIER')THEN
      WRITE(6,*)' Opérateur TSCA'
      WRITE(6,*)' On reclame un pas de temps'
C        Option %m1:8 incompatible avec les données 
            MOTERR( 1: 8) = '  EF    '
            CALL ERREUR(803)
      RETURN
      ELSE
      CALL ACMF(MTABT,'DELTAT',DT)
      ENDIF
      ENDIF

      IHV=0
      NUTOEL=0
      NINKO=IZTU1.VPOCHA(/2)
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1

      TYPE=' '
      CALL ACMO(MTABX,'MATELM',TYPE,MATRIK)
      IF(TYPE.EQ.'MATRIK'.AND.KMACO.NE.0)THEN
      SEGACT MATRIK
      NMATRI=IRIGEL(/2)
      MELEME=IRIGEL(1,1)
      SEGACT MELEME
      IMATRI=IRIGEL(4,1)
      SEGACT IMATRI
      NBME=LIZAFM(/2)
      NINKO=NBME
      MELEMS=KSPGP


      ELSE

      NRIGE=7
      NKID =9
      NKMT =7
      NMATRI=1
      SEGINI MATRIK
      IRIGEL(1,1)=MELEME
      IRIGEL(2,1)=MELEME
      IRIGEL(7,1)=2
      NBOP=0
      NBME=NINKO
      NBELC=0
      CALL LEKTAB(MTABZ,'SOMMET',MELEMS)
      SEGINI IMATRI,IMATRS
      IRIGEL(4,1)=IMATRI
      KSPGP=MELEMS
      KSPGD=MELEMS

      IF(NBME.EQ.1)THEN
      LISPRI(1)=NOMI(1:4)//'    '
      LISDUA(1)=NOMA(1:4)//'    '
      ELSE
      DO 102 I=1,NBME
      WRITE(NOM,FMT='(I1,A7)')I,NOMI(1:7)
      LISPRI(I)=NOM(1:4)//'    '
      WRITE(NOM,FMT='(I1,A7)')I,NOMA(1:7)
      LISDUA(I)=NOM(1:4)//'    '
 102  CONTINUE
      ENDIF

      NUTOEL=0
      DO 101 L=1,NBSOUS
      IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NOM0=NOMS(IPT1.ITYPEL)//'    '
      CALL KALPBG(NOM0,'FONFORM ',IZFFM)
      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      NES=GR(/1)
      NPG=GR(/3)

      NP = IPT1.NUM(/1)
      MP = NP
      NBEL=IPT1.NUM(/2)
      SEGINI IPM1,IPS1
      LIZAFM(L,1)=IPM1
      LIZAFS(L,1)=IPS1
      IPM2=IPM1
      IPM3=IPM1
      IPS2=IPS1
      IPS3=IPS1
      IF(NBME.GE.2)THEN
      SEGINI IPM2,IPS2
      LIZAFM(L,2)=IPM2
      LIZAFS(L,2)=IPS2
      ENDIF
      IF(NBME.GE.3)THEN
      SEGINI IPM3,IPS3
      LIZAFM(L,3)=IPM3
      LIZAFS(L,3)=IPS3
      ENDIF


      KITT=2
      KJTT=IKL
      NPT=UTRANS.VPOCHA(/1)
      NPTG=IZTU1.VPOCHA(/1)

      CALL ZCONV(FN,GR,PG,XYZ,HR,PGSQ,RPG,
     & NES,IDIM,NP,NPG,IAXI,AIMPL,IKOMP,
     & RO,1,UTRANS.VPOCHA,IKU,NPT,IPADU.LECT,VISCO.VPOCHA,IKL,
     & IPT1.NUM,NBEL,NUTOEL,XCOOR,
     & IPM1.AM,IPM2.AM,IPM3.AM,
     & IPS1.AM,IPS2.AM,IPS3.AM,
     & NINKO,IDCEN,DT,
     & IZTU1.VPOCHA,0,NPTG,IPADI.LECT,IZTCO.VPOCHA,NELZ)

      CALL XLAPL(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,
     & VISCO.VPOCHA,VISCO.VPOCHA,VISCO.VPOCHA,KITT,KJTT,IKL,
     & IPT1.NUM,NBEL,NUTOEL,XCOOR,AIMPL,IKOMP,
     & IPM1.AM,IPM2.AM,IPM3.AM,
     & IPS1.AM,IPS2.AM,IPS3.AM,
     & NINKO,IHV,IARG,VISCO.VPOCHA)

      NUTOEL=NUTOEL+NBEL
 101  CONTINUE

      ENDIF

C On cree le CHPOINT pour les sources et eventuellement le semi
C
      NAT=2
      NSOUPO=1
      SEGACT MELEMS
      N=MELEMS.NUM(/2)
      NC=NINKO
      SEGINI MCHPO1,MSOUP1,MPOVA1
      MCHPO1.IFOPOI=IFOMOD
      MCHPO1.MOCHDE=TITREE
      MCHPO1.MTYPOI='SMBR'
      MCHPO1.JATTRI(1)=2
      MCHPO1.IPCHP(1)=MSOUP1
      DO 177 N=1,NINKO
      MSOUP1.NOCOMP(N)=LISDUA(N)(1:4)
 177  CONTINUE
      MSOUP1.IGEOC=MELEMS
      MSOUP1.IPOVAL=MPOVA1

      CALL KRIPAD(MELEMQ,IPADQ)

      SEGACT MELEMI
      NBSOUS=MELEMI.LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1

      NUTOEL=0
      DO 1102 L=1,NBSOUS
      IPT1=MELEMI
      IF(NBSOUS.NE.1)IPT1=MELEMI.LISOUS(L)
      SEGACT IPT1

       IF(MQUAD.NE.0)THEN
       IF(KPRE.EQ.2)NOM0=NOMS(IPT1.ITYPEL)//'PRP0'
       IF(KPRE.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'PRP0'
       IF(KPRE.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'PRP1'
       ELSEIF(MACRO.NE.0)THEN
       IF(KPRE.EQ.2)NOM0=NOMS(IPT1.ITYPEL)//'    '
       IF(KPRE.EQ.3)NOM0=NOMS(IPT1.ITYPEL)//'MCP0'
       IF(KPRE.EQ.4)NOM0=NOMS(IPT1.ITYPEL)//'MCP1'
       ELSE
       IF(KPRE.EQ.2)NOM0=NOMS(IPT1.ITYPEL)//'    '
       ENDIF

       CALL KALPBG(NOM0,'FONFORM ',IZFFM)


      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
      NES=GR(/1)
      NPG=GR(/3)
      IZF1=KTP(1)
      SEGACT IZF1*MOD
      MP1=IZF1.FN(/1)
      NP = IPT1.NUM(/1)
      MP = NP
      NBEL=IPT1.NUM(/2)
      NELG=IZTGG3.VPOCHA(/1)
      NPT =MPOVA1.VPOCHA(/1)
      SEGACT MELEP1

      IKAS=1
      CALL XSOUR(FN,IZF1.FN,GR,PG,XYZ,HR,PGSQ,RPG,
     & NES,IDIM,NP,MP1,NPG,IAXI,IPT1.NUM,IKAS,KPRE,
     & IZTGG3.VPOCHA,IKS,NELG,IPADQ.LECT,MELEP1.NUM,
     & IZTGG3.VPOCHA,IKS,IZTGG3.VPOCHA,IKS,IPADS.LECT,
     & NBEL,NUTOEL,XCOOR,MPOVA1.VPOCHA,NPT)

      NUTOEL=NUTOEL+NBEL
 1102 CONTINUE
      SEGSUP IPADQ


      IF(KIMPL.EQ.0.OR.KIMPL.EQ.2)THEN

      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1

      DO 1533 L=1,NBSOUS
      IPT1=MELEME
      IF(NBSOUS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      NP=IPT1.NUM(/1)
      NBEL=IPT1.NUM(/2)
      DO 2 N=1,NINKO
      IPMS=LIZAFS(L,N)
      SEGACT IPMS
      DO 12 K=1,NBEL
      DO 13 J=1,NP
      UU=0.D0
      IU=IPADS.LECT(IPT1.NUM(J,K))
      DO 14 I=1,NP
      IK=IPADI.LECT(IPT1.NUM(I,K))
      UU=UU+IPMS.AM(K,I,J)*IZTU1.VPOCHA(IK,N)
 14   CONTINUE
      MPOVA1.VPOCHA(IU,N)=MPOVA1.VPOCHA(IU,N)+UU
 13   CONTINUE
 12   CONTINUE

 2    CONTINUE

 1533 CONTINUE

      SEGDES IPM1,IPM2,IPM3
      IPS=IPS1
      SEGSUP IPS1
      IF(IPS2.NE.IPS)SEGSUP IPS2
      IF(IPS3.NE.IPS)SEGSUP IPS3
      SEGDES IZTCO
      ENDIF

      TYPE=' '
      CALL ACMO(MTAB1,'SMBR',TYPE,MCHPO2)
      IF(TYPE.NE.'CHPOINT')THEN
      CALL ECMO(MTAB1,'SMBR','CHPOINT',MCHPO1)
      ELSE
      CALL ECROBJ('CHPOINT',MCHPO2)
      CALL ECROBJ('CHPOINT',MCHPO1)
      CALL OPERAD
      CALL LIROBJ('CHPOINT',MCHPOI,1,IRET)
      CALL ECMO(MTAB1,'SMBR','CHPOINT',MCHPOI)
      ENDIF

      SEGDES IMATRI
      SEGDES MELEME,MATRIK
      IF(IKL.EQ.0)THEN
      SEGDES VISCO
      ENDIF
      CALL ECMO(MTABX,'MATELM','MATRIK',MATRIK)

C*************************************************************************
      ELSE IF(KFORM.EQ.2)THEN
C CAS FORMULATION VF
      WRITE(6,*)' FORMULATION VF NON DISPONIBLE '
C        Option %m1:8 incompatible avec les données 
            MOTERR( 1: 8) = '  EF    '
            CALL ERREUR(803)
            RETURN

      ENDIF

C     write(6,*)' RETOUR DE TSCA '
      IPDI=IPADI
      SEGSUP IPADI
      IF(IPADS.NE.IPDI)SEGSUP IPADS
      IPAS=1
      RETURN


 90   CONTINUE
      WRITE(6,*)' Interuption anormale de TSCAL '
C        Option %m1:8 incompatible avec les données
            CALL ERREUR(803)
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
 1001 FORMAT(20(1X,I5))
      END