C YLAP22    SOURCE    MAGN      09/07/30    21:22:26     6458           
C YLAP11    SOURCE    LEPOTIER  03/02/13    21:24:03     4578           
      SUBROUTINE YLAP22()
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,XKT
      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.
      LOGRES =.TRUE.
C
C******* Flux ou residu?
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
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT1=',XKT
      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      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT2=',XKT
C
C**** Centre, FACE et FACEL
C
      CALL LEKTAB(IDOMA,'CENTRE',MELEMC)
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT3=',XKT
      IF(IERR .NE. 0) GOTO 9999
C
      CALL LEKTAB(IDOMA,'FACE',MELEMF)
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT4=',XKT
      IF(IERR .NE. 0) GOTO 9999
C      
      CALL LEKTAB(IDOMA,'FACEL',MELEFL)
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT5=',XKT
      IF(IERR .NE. 0) GOTO 9999
C
C**** Lecture du CHPOINT contenant les surfaces des faces.
C
      CALL LEKTAB(IDOMA,'XXSURFAC',ICHPSU)
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT6=',XKT
      IF(IERR .NE. 0) GOTO 9999
C  
C**** Lecture du CHPOINT contenant les diametres minimums.
C
      CALL LEKTAB(IDOMA,'XXDIEMIN',ICHPDI)
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT7=',XKT
      IF(IERR .NE. 0) GOTO 9999
C     
C**** Lecture du CHPOINT contenant les volumes
C
      CALL LEKTAB(IDOMA,'XXVOLUM',ICHPVO)
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT8=',XKT
      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
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
C
C**** Gradient de la temperature
C
      TYPE='CHPOINT '
      CALL LIROBJ(TYPE,IGRTN,1,IRET)
      IF(IERR .NE. 0) GOTO 9999
      JGN = 4
      JGM=1
      SEGINI MLMNOM
      MLMNOM.MOTS(1) = 'FLUX'
      CALL QUEPO1(IGRTN, MELEMF, MLMNOM)
      IF(IERR .NE. 0) GOTO 9999
      SEGSUP MLMNOM

C
      IF (LOGIMP) THEN
         CALL LIROBJ('MCHAML  ',ICOGRT,1,IRET)
         IF(IERR .NE. 0) GOTO 9999
      ENDIF

      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 =1
               SEGINI MLMNOM
               MLMNOM.MOTS(1) = 'FLUX'
               CALL QUEPO1(IQIMP, 0, MLMNOM)
               IF(IERR .NE. 0) GOTO 9999
               SEGSUP MLMNOM
            ELSE
               IQIMP=0
            ENDIF
         ELSE
            IQIMP=0
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
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      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT1=',XKT
      IF (LOGIMP) THEN
c         IF (IDIM.EQ.2) THEN
            CALL YLAP1T(ITN,ICOGRT,
     $           ITIMP,IQIMP,IMIXT,
     $           MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPVO,IJACO)
c          ELSEIF (IDIM.EQ.3) THEN
c            CALL YLAP2T(MU,KAPPA,CV,IRN,IVN,ITN,
c     $           IGRVN,ICOGRV,ICOGRT,
c     $           IVNIMP,ITAUIM,ITIMP,IQIMP,IMIXT,
c     $           MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPVO,MLMOTS,
c     $           IJACO)
c          ELSE
c             WRITE(IOIMP,*) 'IDIM=',IDIM,' ILLICITE.'
c             CALL ERREUR(5)
c             GOTO 9999
c          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=1
      SEGINI MLDEFO
      DO ICELL=1,1,1
         MLDEFO.MOTS(ICELL)='RETN'
      ENDDO
      TYPE = 'CHPOINT '
      CALL KRCHP1(TYPE, MELEMF, ICHFLU, MLDEFO)
      CALL GIBTEM(XKT)
C     
C**** Calcul des flux et du pas du temps.
C
c      IF(IDIM.EQ.2)THEN
         CALL YLA12T(IGRTN,IQIMP,MELEMC,MELEMF,MELEFL,
     &                   ICHPSU,INORM,ICHPDI,ICHFLU,DELTAT)
      CALL GIBTEM(XKT)
c      ELSE
c         CALL YLAP13T(MU,KAPPA,CV,IRN,IVN,IGRVN,IGRTN,
c     &        IVNIMP,ITAUIM,IQIMP,
c     &        MELEMC,MELEMF,MELEFL,ICHPSU,INORM,ICHPDI,ICHFLU,DELTAT)
c      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
c      CALL GIBTEM(XKT)
c      WRITE(6,*) 'XKT3=',XKT
         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