C YLAP11    SOURCE    MAGN      09/07/30    21:22:11     6458           
      SUBROUTINE YLAP11()
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  YLAPL11
C
C DESCRIPTION       :  Voir YLAPL1
C
C     
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
C      
C AUTEUR            :  A. BECCANTINI, DRN/DMT/SEMT/LTMF                        
C
C************************************************************************
C
C
C APPELES (E/S)     :  LIRMOT, ERREUR
C 
C      
C APPELES           :  YLAPL12
C
C************************************************************************
C
C*** ENTREE / SORTIE (voir Phrase d'appel GIBIANE)
C
C***********************************************************************
C
C HISTORIQUE (Anomalies et modifications éventuelles)
C
C HISTORIQUE : 11/02/2003 Ajout de l'option MIXT pour la température
C      
C************************************************************************
C
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMMATRIK
-INC SMCHPOI
-INC SMLMOTS
      POINTEUR MLMNOM.MLMOTS
      POINTEUR MLDEFO.MLMOTS
-INC SMCHAML
      POINTEUR ICOGRV.MCHELM
      POINTEUR ICOGRT.MCHELM
C
C**** Variables de COOPTIO
C
C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
C     &        ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
C     &        ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
C     &        ,IECHO,   IIMPI,  IOSPI
C     &        ,IDIM
C     &        ,MCOORD
C     &        ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &        ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &        ,NORINC,NORVAL,NORIND,NORVAD
C     &        ,NUCROU, IPSAUV
C
C**** Variables de SMLMOTS
C
      INTEGER  JGM, JGN
C
C**** Variables de SMMATRIK
C
      INTEGER   NKID, NKMT, NMATRI, NRIGE         
C
C**** Variables du programme
C
      INTEGER ICELL, IRET, INDIC, NBCOMP
     &      , IDOMA, MELEMC, MELEMF, MELEFL, ICHPSU, ICHPDI, ICHPVO
     &      , INORM
     &      , IRN, IVN, ITN, IGRVN, IGRTN
     &      , IVNIMP, ITAUIM, ITIMP,IQIMP,IMIXT
     &      , ILIINC, NC, INEFMD, ICOND
     &      , IJACO, ICHFLU, ICHRES, NSOUPO,ICLAU
      REAL*8 MU,KAPPA,CV,DELTAT
      CHARACTER*(40) MESERR
      CHARACTER*4 MOT,LFLUX(2), LIMPL(2)
      CHARACTER*8 MOT2
      CHARACTER*8 TYPE
      LOGICAL LOGRES,LOGIMP,LOGAN
C
      DATA LFLUX/'FLUX','RESI'/
      DATA LIMPL/'EXPL','IMPL'/
C
C**** Initialisation des variables pour la gestion des erreurs.
C
      MESERR  = '                                        '
      LOGAN = .FALSE.
C
C******* Flux ou residu?
C
      CALL LIRMOT(LFLUX,2,ICELL,1)
      IF(IERR .NE. 0)GOTO 9999
      IF(ICELL .EQ. 1)THEN
         LOGRES = .FALSE.
      ELSEIF(ICELL .EQ. 2)THEN
         LOGRES = .TRUE.
      ELSE
C
C******** Message d'erreur standard
C         251 2
C         Tentative d'utilisation d'une option non implémentée
C
         CALL ERREUR(251)
      ENDIF
C
C
      CALL LIRMOT(LIMPL,2,ICELL,1)
      IF(IERR .NE. 0)GOTO 9999
      IF(ICELL .EQ. 1)THEN
         LOGIMP=.FALSE.
      ELSEIF(ICELL .EQ. 2)THEN
         LOGIMP=.TRUE.
      ELSE
         WRITE(IOIMP,*) 'Erreur de programmation'
         CALL ERREUR(5)
         GOTO 9999
      ENDIF

C
C**********************************
C**** Lecture de l'objet MODELE ***
C**********************************
C
      ICOND = 1
      CALL QUETYP(TYPE,ICOND,IRET)

      IF(IRET.EQ.0.AND.TYPE.NE.'MMODEL')THEN
        WRITE(6,*)' On attend un objet MMODEL'
        RETURN
      ENDIF
      CALL LIROBJ('MMODEL',MMODEL,ICOND,IRET)
      IF(IERR.NE.0)GOTO 9999
      CALL LEKMOD(MMODEL,IDOMA,INEFMD)
      IF(IERR.NE.0)GOTO 9999
C
C**** Centre, FACE et FACEL
C
      CALL LEKTAB(IDOMA,'CENTRE',MELEMC)
      IF(IERR .NE. 0) GOTO 9999
C
      CALL LEKTAB(IDOMA,'FACE',MELEMF)
      IF(IERR .NE. 0) GOTO 9999
C      
      CALL LEKTAB(IDOMA,'FACEL',MELEFL)
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du CHPOINT contenant les surfaces des faces.
C
      CALL LEKTAB(IDOMA,'XXSURFAC',ICHPSU)
      IF(IERR .NE. 0) GOTO 9999
C  
C**** Lecture du CHPOINT contenant les diametres minimums.
C
      CALL LEKTAB(IDOMA,'XXDIEMIN',ICHPDI)
      IF(IERR .NE. 0) GOTO 9999
C     
C**** Lecture du CHPOINT contenant les volumes
C
      CALL LEKTAB(IDOMA,'XXVOLUM',ICHPVO)
      IF(IERR .NE. 0) GOTO 9999
C
C********** Les normales aux faces
C
      CALL LEKTAB(IDOMA,'XXNORMAF',INORM)
      IF(IERR .NE. 0) GOTO 9999
C
C********************************
C**** Fin table domaine *********
C********************************
C
C**** Viscosité dynamique (kg/m/sec)
C
      CALL LIRREE(MU,1,IRET)
      IF(IERR.NE.0)GOTO 9999
C
C**** Conductivité thermique (J/sec/m/K)
C
      CALL LIRREE(KAPPA,1,IRET)
      IF(IERR.NE.0)GOTO 9999
C
C**** Chaleur specifique (J/kg/K)
C
      CALL LIRREE(CV,1,IRET)
      IF(IERR.NE.0)GOTO 9999
C
C**** Densité
C
      TYPE = 'CHPOINT '
      CALL LIROBJ(TYPE,IRN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      INDIC = 1
      NBCOMP = 1
      MOT = 'SCAL'
      CALL QUEPOI(IRN, MELEMC, INDIC, NBCOMP, MOT)
C
C**** Vitesse
C
      TYPE='CHPOINT '
      CALL LIROBJ(TYPE,IVN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      JGN = 4
      JGM = IDIM
      SEGINI MLMNOM
      MLMNOM.MOTS(1) = 'UX  '
      MLMNOM.MOTS(2) = 'UY  '
      IF(IDIM.EQ.3) MLMNOM.MOTS(3) = 'UZ  '
      CALL QUEPO1(IVN, MELEMC, MLMNOM)
      IF(IERR .NE. 0) GOTO 9999
      SEGSUP MLMNOM
C
C**** Température
C
      TYPE='CHPOINT '
      CALL LIROBJ(TYPE,ITN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      JGN = 4
      JGM = 1
      SEGINI MLMNOM
      MLMNOM.MOTS(1) = 'SCAL'
      CALL QUEPO1(ITN, MELEMC, MLMNOM)
      IF(IERR .NE. 0) GOTO 9999
      SEGSUP MLMNOM
C
C**** Gradient de la vitesse
C
      TYPE='CHPOINT '
      CALL LIROBJ(TYPE,IGRVN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      JGN = 4
      JGM =IDIM*IDIM
      SEGINI MLMNOM
      IF(IDIM.EQ.2)THEN
         MLMNOM.MOTS(1) = 'P1DX'
         MLMNOM.MOTS(2) = 'P1DY'
         MLMNOM.MOTS(3) = 'P2DX'
         MLMNOM.MOTS(4) = 'P2DY'
      ELSE
         MLMNOM.MOTS(1) = 'P1DX'
         MLMNOM.MOTS(2) = 'P1DY'
         MLMNOM.MOTS(3) = 'P1DZ'
         MLMNOM.MOTS(4) = 'P2DX'
         MLMNOM.MOTS(5) = 'P2DY'
         MLMNOM.MOTS(6) = 'P2DZ'
         MLMNOM.MOTS(7) = 'P3DX'
         MLMNOM.MOTS(8) = 'P3DY'
         MLMNOM.MOTS(9) = 'P3DZ'
      ENDIF
      CALL QUEPO1(IGRVN, MELEMF, MLMNOM)
      IF(IERR .NE. 0) GOTO 9999
      SEGSUP MLMNOM
C
C**** Gradient de la temperature
C
      TYPE='CHPOINT '
      CALL LIROBJ(TYPE,IGRTN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      JGN = 4
      JGM=IDIM
      SEGINI MLMNOM
      MLMNOM.MOTS(1) = 'P1DX'
      MLMNOM.MOTS(2) = 'P1DY'
      IF(IDIM.EQ.3) MLMNOM.MOTS(3) = 'P1DZ  '
      CALL QUEPO1(IGRTN, MELEMF, MLMNOM)
      IF(IERR .NE. 0) GOTO 9999
      SEGSUP MLMNOM
C
C
      IF (LOGIMP) THEN
         CALL LIROBJ('MCHAML  ',ICOGRV,1,IRET)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF
C
C
      IF (LOGIMP) THEN
         CALL LIROBJ('MCHAML  ',ICOGRT,1,IRET)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF
C
C
C**** Conditions limites 
C
C     Vitesse imposée à la paroi
C
      CALL LIRCHA(MOT,0,IRET)
      IF(IRET .NE. 0)THEN
         IF(MOT .EQ. 'VIMP')THEN
            TYPE='CHPOINT '
            CALL LIROBJ(TYPE,IVNIMP,1,IRET)
            IF(IERR .NE. 0) GOTO 9999
            MCHPOI = IVNIMP
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            SEGDES MCHPOI
            IF(NSOUPO .GT. 0)THEN
               JGN = 4
               JGM = IDIM
               SEGINI MLMNOM
               MLMNOM.MOTS(1) = 'UX  '
               MLMNOM.MOTS(2) = 'UY  '
               IF(IDIM.EQ.3) MLMNOM.MOTS(3) = 'UZ  '
               CALL QUEPO1(IVNIMP, 0, MLMNOM)
               IF(IERR .NE. 0) GOTO 9999
               SEGSUP MLMNOM
            ELSE
               IVNIMP=0
            ENDIF
         ELSE
            IVNIMP=0
C
C********** Je m'excuse et je le remets dans la pile
C
            CALL REFUS
         ENDIF
      ELSE
         IVNIMP=0
      ENDIF
C
C     Tenseur des contraintes visqueux
C
      CALL LIRCHA(MOT,0,IRET)
      IF(IRET .NE. 0)THEN
         IF(MOT .EQ. 'TAUI')THEN
            TYPE='CHPOINT '
            CALL LIROBJ(TYPE,ITAUIM,1,IRET)
            IF(IERR .NE. 0) GOTO 9999
            MCHPOI = ITAUIM
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            SEGDES MCHPOI
            IF(NSOUPO .GT. 0)THEN
               JGN = 4
C           2D only
               JGM = 3*(IDIM-1)
               SEGINI MLMNOM
               IF(IDIM .EQ.2)THEN
                  MLMNOM.MOTS(1) = 'TXX'
                  MLMNOM.MOTS(2) = 'TYY'
                  MLMNOM.MOTS(3) = 'TXY'
               ELSE
                  MLMNOM.MOTS(1) = 'TXX'
                  MLMNOM.MOTS(2) = 'TYY'
                  MLMNOM.MOTS(3) = 'TZZ'
                  MLMNOM.MOTS(4) = 'TXY'
                  MLMNOM.MOTS(5) = 'TXZ'
                  MLMNOM.MOTS(6) = 'TYZ'
               ENDIF
               CALL QUEPO1(ITAUIM, 0, MLMNOM)
               IF(IERR .NE. 0) GOTO 9999
               SEGSUP MLMNOM
            ELSE
               ITAUIM=0
            ENDIF
         ELSE
            ITAUIM=0
C
C********** Je m'excuse et je le remets dans la pile
C
            CALL REFUS
         ENDIF
      ELSE
         ITAUIM=0
      ENDIF
C
C     Flux thermique 
C
      CALL LIRCHA(MOT,0,IRET)
      IF(IRET .NE. 0)THEN
         IF(MOT .EQ. 'QIMP')THEN
            TYPE='CHPOINT '
            CALL LIROBJ(TYPE,IQIMP,1,IRET)
            IF(IERR .NE. 0) GOTO 9999
            MCHPOI = IQIMP
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            SEGDES MCHPOI
            IF(NSOUPO .GT.0)THEN
               JGN = 4
               JGM = IDIM
               SEGINI MLMNOM
               MLMNOM.MOTS(1) = 'UX  '
               MLMNOM.MOTS(2) = 'UY  '
               IF(IDIM .EQ. 3) MLMNOM.MOTS(3) = 'UZ  '
               CALL QUEPO1(IQIMP, 0, MLMNOM)
               IF(IERR .NE. 0) GOTO 9999
               SEGSUP MLMNOM
            ELSE
               IQIMP=0
            ENDIF
         ELSE
            IQIMP=0
C
C********** Je m'excuse et je le remets dans la pile
C
            CALL REFUS
         ENDIF
      ELSE
         IQIMP=0
      ENDIF
C
C      Conditions aux limites mixtes 
C
      CALL LIRCHA(MOT,0,IRET)
      IF(IRET .NE. 0)THEN
         IF(MOT .EQ. 'MIXT')THEN
            TYPE='CHPOINT '
            CALL LIROBJ(TYPE,IMIXT,1,IRET)
            IF(IERR .NE. 0) GOTO 9999
            MCHPOI = IMIXT
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            SEGDES MCHPOI
            IF(NSOUPO .GT.0)THEN
            ELSE
               IMIXT=0
            ENDIF
         ELSE
            IMIXT=0
C
C********** Je m'excuse et je le remets dans la pile
C
            CALL REFUS
         ENDIF
      ELSE
         IMIXT=0
      ENDIF
C
C     Température imposée
C
      CALL LIRCHA(MOT,0,IRET)
      IF(IRET .NE. 0)THEN
         IF(MOT .EQ. 'TIMP')THEN
            TYPE='CHPOINT '
            CALL LIROBJ(TYPE,ITIMP,1,IRET)
            IF(IERR .NE. 0) GOTO 9999
            MCHPOI = ITIMP
            SEGACT MCHPOI
            NSOUPO = MCHPOI.IPCHP(/1)
            SEGDES MCHPOI
            IF(NSOUPO .GT.0)THEN
               JGN = 4
               JGM = 1
               SEGINI MLMNOM
               MLMNOM.MOTS(1) = 'SCAL'
               CALL QUEPO1(ITIMP, 0, MLMNOM)
               IF(IERR .NE. 0) GOTO 9999
               SEGSUP MLMNOM
            ELSE
               ITIMP=0
            ENDIF
         ELSE
            ITIMP=0
C
C********** Je m'excuse et je le remets dans la pile
C
            CALL REFUS
         ENDIF
      ELSE
         ITIMP=0
      ENDIF
C
C**** Les noms des inconnues
C
      TYPE='LISTMOTS'
      CALL LIROBJ(TYPE,ILIINC,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      MLMOTS = ILIINC
      SEGACT MLMOTS
      NC = MLMOTS.MOTS(/2)
      SEGDES MLMOTS
      IF(NC .NE. (IDIM+2))THEN
         MESERR='LMOT1 = ???                         '
         WRITE(IOIMP,*) MESERR
C
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C
         CALL ERREUR(21)
         GOTO 9999
      ENDIF
C
C    OPTION POUR NE CALCULER QUE LA THERMIQUE  
C
      IRET = 0
      CALL LIRCHA(MOT2,0,IRET)
      IF(IERR .NE. 0) GOTO 9999
      IF(IRET .NE. 0)THEN
         IF(MOT2 .EQ. 'CLAUDEIS')THEN
            ICLAU = 1
         ELSE
C
C******* Je la remets dans la pile
C
            CALL ECRCHA(MOT2)
            ICLAU = 0
         ENDIF
      ELSE
         ICLAU=0
      ENDIF

C
C Fin de la lecture des données
C
C
C Test des données
C
      IF (.NOT.LOGIMP.AND.(ITIMP.NE.0)) THEN
C**** La temperature imposéé à la paroi ne serve pas dans le
C     cas de proprietés physiques constantes en explicite
         MESERR='TIMP = ???                          '
         WRITE(IOIMP,*) MESERR
C********** Message d'erreur standard
C           21 2
C           Données incompatibles
C     
         CALL ERREUR(21)
         GOTO 9999
      ENDIF
C
C Création de la matrice jacobienne du résidu du laplacien VF
C
      IF (LOGIMP) THEN
         IF (IDIM.EQ.2) THEN
            CALL YLAP1A(MU,KAPPA,CV,IRN,IVN,ITN,
     $           IGRVN,ICOGRV,ICOGRT,
     $           IVNIMP,ITAUIM,ITIMP,IQIMP,IMIXT,ICLAU,
     $           MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPVO,MLMOTS,
     $           IJACO)
          ELSEIF (IDIM.EQ.3) THEN
            CALL YLAP2A(MU,KAPPA,CV,IRN,IVN,ITN,
     $           IGRVN,ICOGRV,ICOGRT,
     $           IVNIMP,ITAUIM,ITIMP,IQIMP,
     $           MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPVO,MLMOTS,
     $           IJACO)
          ELSE
             WRITE(IOIMP,*) 'IDIM=',IDIM,' ILLICITE.'
             CALL ERREUR(5)
             GOTO 9999
          ENDIF
       ELSE
C
C******* Objet MATRIK vide en explicite
C
         NRIGE=7
         NMATRI=0
         NKID =9
         NKMT =7
         SEGINI MATRIK
         SEGDES MATRIK
         IJACO = MATRIK
       ENDIF
C
C**** Creation des flux aux interfaces
C
      JGN=4
      JGM=IDIM+1
      SEGINI MLDEFO
      SEGACT MLMOTS
      DO ICELL=1,JGM,1
         MLDEFO.MOTS(ICELL)=MLMOTS.MOTS(ICELL+1)
      ENDDO
      SEGDES MLMOTS
      TYPE = 'CHPOINT '
      CALL KRCHP1(TYPE, MELEMF, ICHFLU, MLDEFO)
C     
C**** Calcul des flux et du pas du temps.
C
      IF(IDIM.EQ.2)THEN
         CALL YLAP12(MU,KAPPA,CV,IRN,IVN,IGRVN,IGRTN,
     &        IVNIMP,ITAUIM,IQIMP,
     &        MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPDI,ICHFLU,DELTAT)
      ELSE
         CALL YLAP13(MU,KAPPA,CV,IRN,IVN,IGRVN,IGRTN,
     &        IVNIMP,ITAUIM,IQIMP,
     &        MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPDI,ICHFLU,DELTAT)
      ENDIF
      IF(IERR .NE. 0)GOTO 9999
C
C**** Calcul de residu (si LOGRES = .TRUE.)         
C
      IF(LOGRES)THEN
         TYPE = 'CHPOINT '
         CALL KRCHP1(TYPE, MELEMC, ICHRES, MLDEFO)
         IF(IERR.NE.0) GOTO 9999
C
         CALL KONRE1(MELEMC,MELEMF,MELEFL,ICHPVO,
     &        ICHFLU, ICHRES,
     &        LOGAN,MESERR)
         IF(LOGAN)THEN
C
C******* Anomalie detectée
C
C
C******* Message d'erreur standard
C        -301 0
C        %m1:40
C
            MOTERR(1:40) =  MESERR(1:40)
            WRITE(IOIMP,*) MOTERR(1:40)
C
C******* Message d'erreur standard
C        5 3
C        Erreur anormale.contactez votre support
C         
            CALL ERREUR(5)
            GOTO 9999
         ENDIF
      ELSE
         SEGSUP MLDEFO
         ICHRES = 0
      ENDIF
C
C**** Sortie     
C     
      CALL ECRREE(DELTAT)
      TYPE = 'CHPOINT '
      IF(ICHRES .NE. 0) CALL ECROBJ(TYPE,ICHRES)
      IF(ICHFLU .NE. 0) CALL ECROBJ(TYPE,ICHFLU)
      TYPE='MATRIK '
      CALL ECROBJ(TYPE,IJACO)
C
 9999 RETURN
      END