C CFL1      SOURCE    OF166741  25/02/21    21:15:27     12166          
      SUBROUTINE CFL1(IPMODL,IPCHA1,IPCHA2,IPCHA3,IPCHA4,ICAS)
*
*-----------------------------------------------------------------------
*
*    calcul du pas de temps de stabilité operateur CFL
*           de la vitesse du son  operateur CSON
*           de la taille de propagation de l'information opérateur TAILLE
*
* en entrée
*  ipmodl objet model
*  ipcha1 champ de caractéristiques
*  ipcha2 champ de vitesse du son composante 'CSON'
*  ipcha3 champ de taille du maillage composante 'L' ( et 'L2H' facultatif)
*  icas décrit le cas de figure
*            entree            ------->                   sortie
*        = 1 ipcha1                                pas de temps cfl
*        = 2 ipcha2 ( et ipcha1 si cara geom )      "       "      "
*        = 3 ipcha3 et ipcha1                       "       "      "
*        = 4 ipcha1                                vitesse du son
*        = 5 ( et ipcha1 si cara geom )            parametre de taille
* en sortie
*        ipcha4 le champ par element demandé
*
*-----------------------------------------------------------------------
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC CCGEOME
-INC CCREEL

-INC SMCHAML
-INC SMINTE
-INC SMELEME
-INC SMRIGID
-INC SMMODEL
-INC SMCOORD
-INC SMLREEL

-INC TMPTVAL

      SEGMENT NOTYPE
        CHARACTER*16 TYPE(NBTYPE)
      ENDSEGMENT

      CHARACTER*(NCONCH) CONM
      CHARACTER*8 CMATE
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      CHARACTER*4 CMOT
      LOGICAL DEUCMP,lsupma

*--------------------------------------------------------------------*
*     call tcloc2(' ',-1,it)
      deucmp=.FALSE.
      IF ( ICAS .EQ. 1) THEN
        IPCHE1 =  IPCHA1
        IPCHE2 = 0
      ELSE IF ( ICAS .EQ. 2 ) THEN
        IPCHE1 = IPCHA1
        IPCHE2 = IPCHA2
      ELSE IF ( ICAS .EQ. 3 ) THEN
         IPCHE1 = IPCHA1
         IPCHE2 = IPCHA3
      ELSE IF ( ICAS .EQ. 4 ) THEN
         IPCHE1 = IPCHA1
         IPCHE2 = 0
      ELSE IF ( ICAS .EQ. 5 ) THEN
         IPCHE1 = IPCHA1
         IPCHE2 = 0
      ENDIF

      MMODEL = IPMODL
      SEGACT MMODEL
      NSOUS = KMODEL(/1)
*
*  initialisation de l'objet résultat
*
      N1 = NSOUS
      N3 = 6
      L1 = 16
      SEGINI MCHELM
      IF ( ICAS .LE. 3 .OR. ICAS .GE. 1 ) THEN
         TITCHE = 'PAS DE TEMPS CFL'
      ELSE IF ( ICAS .EQ. 4 ) THEN
         TITCHE = 'VITESSE DU SON'
      ELSE IF ( ICAS .EQ. 5 ) THEN
         TITCHE = 'TAILLE CFL'
      ENDIF

      IFOCHE = IFOUR
*--------------------------------------------------------------------*
*
*       BOUCLE SUR LES ZONES ELEMENTAIRES ( MEME TYPE D'EF )
*
*--------------------------------------------------------------------*
*
      DO 500 ISOUS=1,NSOUS
        IMODEL=KMODEL(ISOUS)
        SEGACT IMODEL
        lsupma=.true.
*
*    INITIALISATIONS
*
        IVAM1 = 0
        IVAM2 = 0
*
        MELE  = NEFMOD
        IPMAIL= IMAMOD
        CONM  = CONMOD
        NFOR  = FORMOD(/2)
        NMAT  = MATMOD(/2)
*
        IVAMAT=0
        IVACAR=0
        NMATR=0
        NMATF=0
        NCARA=0
        NCARF=0
        MOCARA=0
        MOMATR=0
        DESCR=0
        IMATRI=0
C
C   COQUE INTEGREE OU PAS ?
        NPINT = imodel.INFMOD(1)
*
*    formulation et matériau ( ca peut servir par la suite )
*
        CMATE = imodel.CMATEE
        MATE  = imodel.IMATEE
        INAT  = imodel.INATUU
*
*    information sur l'élément finis : nécessaire pour les tests
*                                      qui donnent les noms de composantes
*
         INTTYP = 2
*
         MFR   = INFELE(13)
         IELE  = INFELE(14)
*         IPINT = INFELE(11)
         ipint=infmod(4)
*
*    Verification de compatibilite de MCHAML du point de vue des
*
*    tableaux INFCHE et creation du tableau INFOS pour COMCHA
*
         CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
         IF (IRTD.EQ.0) THEN
*                    incompatibilité entre le modele et le chamelem
           SEGSUP MCHELM
           RETURN
         ENDIF

*         call tcloc2('Apres ident',6,it)
*
*--------------------------------------------------------------------*
*       determination des noms de composantes dans les champs
*
* on commence par le champ  2  qui n'existe que dans le cas 2 et 3
        NOTYPE = MOTYR8
        IF (ICAS.EQ.2 .OR.ICAS.EQ.3) THEN
             IF (ICAS.EQ.2) THEN
*             le champ 2 contient la vitesse du son
               NBROBL=1
               NBRFAC=0
               SEGINI NOMID
               LESOBL(1)='CSON'
             ELSE IF(ICAS.EQ.3) THEN
*             le champ 2 contient le parametre de taille
               NBROBL=1
               NBRFAC=1
               SEGINI NOMID
               LESOBL(1)='L'
               LESFAC(1) = 'L2H'
              ENDIF
              MOTYPE = NOTYPE
              MOMATR = NOMID
* ===>
*       write(6,*) 'Sous zone' ,isous,' Composante obligatoire ipche2'
*       write(6,7001) (lesobl(i),i=1,nbrobl)
*       write(6,*) 'facultatives'
*       write(6,7001) (lesfac(i),i=1,nbrfac)
* 7001  format(4(A4,2X))
*           Recherche des valeurs des composantes dans les MELVAL d'un
*           CHAMELEM. On distingue les composantes obligatoires des
*            composantes facultatives.

          CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAM2)
          SEGSUP,NOMID
          IF (NOTYPE.NE.MOTYR8) SEGSUP,NOTYPE
          IF (IERR.NE.0) THEN
            SEGSUP MCHELM
            RETURN
          ENDIF
        ENDIF
*        call tcloc2('Apres komcha1',6,it)
*
*     dans les cas 1,2 ou 5 il peut y avoir des caractéristiques geometriques
*     dans les cas  1,3 ou 4  il y a des caractéristiques matériau
*       on commence par traiter les caractéristiques matériau
        IF (ICAS .EQ. 1 .OR. ICAS .EQ. 3 .OR. ICAS .EQ. 4) THEN
            IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
               NBROBL=3
               NBRFAC=0
               SEGINI NOMID
               MOMATR=NOMID
               LESOBL(1)='YOUN'
               LESOBL(2)='NU'
               LESOBL(3)='RHO'
               NMATR=NBROBL
               NMATF=NBRFAC
            ELSE
     $      IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN
*               indisponible! pour les volontaies voir voir rigi1.eso
*              SEGSUP MCHELM
               CALL ERREUR(251)
               RETURN
            ELSE
     $      IF (FORMOD(1).EQ.'POREUX   '.AND.CMATE.EQ.'ISOTROPE') THEN
*               indisponible! pour les volontaies voir rigi1.eso
               CALL ERREUR(251)
               SEGSUP MCHELM
               RETURN
*
            ELSEIF(INAT.EQ.67.AND.CMATE.EQ.'ORTHOTRO') THEN
*               indisponible! pour les volontaies voir rigi1.eso
               SEGSUP MCHELM
               CALL ERREUR(251)
               RETURN
*
            ELSE
              if(lnomid(6).ne.0) then
               nomid=lnomid(6)
               momatr=nomid
               nmatr=lesobl(/2)
               nmatf=lesfac(/2)
               lsupma=.false.
              else
               lsupma=.true.
               CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF)
              endif
            ENDIF
*
*   type des composantes
*
            IF (CMATE.EQ.'SECTION') THEN
               SEGSUP MCHELM
               SEGDES MMODEL,IMODEL
               CALL ERREUR(251)
               RETURN
            ELSE
              MOTYPE=MOTYR8
            ENDIF
*
*  dans le cas ou il y des caractéristiques géometriques on augmente
*  motype
*
          ELSE IF((ICAS.EQ.2 .OR. ICAS.EQ.5).AND.IPCHE1.NE.0)THEN
*  dans ces cas il faut eventuellement récuperer les caractéristiques
*  geométriques et avoir initialiser  notype avant
               NBROBL=0
               NBRFAC=0
               SEGINI NOMID
               MOMATR=NOMID
               MOTYPE=MOTYR8
               NMATR=NBROBL
               NMATF=NBRFAC
         ENDIF
*
         IF((IPCHE1.NE.0).AND.(ICAS.NE.4).AND.(ICAS.NE.3))THEN
*
*
* EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
*
         IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
             NBROBL=NBROBL+1
             IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
               NBRFAC=NBRFAC+2
             ELSE
               NBRFAC=NBRFAC+1
             ENDIF
             SEGADJ NOMID
             MOCARA=NOMID
             LESOBL(NBROBL)='EPAI'
             LESFAC(NBRFAC)='EXCE'
             IF(MFR.EQ.3.AND.IFOUR.EQ.-2)  THEN
                 LESFAC(NBRFAC-1)='EXCE'
                 LESFAC(NBRFAC)='DIM3'
             ELSE
                 LESFAC(NBRFAC)='EXCE'
             ENDIF
*
* SECTION POUR LES BARRES ET LES CERCES
*
          ELSE IF (MFR.EQ.27) THEN
             NBROBL=NBROBL+1
             SEGADJ NOMID
             LESOBL(NBROBL)='SECT'
*
* section, excentrements et orientation pour les barres excentrees
*
          ELSE IF (MFR.EQ.49) THEN
             NBROBL=NBROBL+6
             SEGADJ NOMID
             LESOBL(NBROBL-5)='SECT'
             LESOBL(NBROBL-4)='EXCZ'
             LESOBL(NBROBL-3)='EXCY'
             LESOBL(NBROBL-2)='VX  '
             LESOBL(NBROBL-1)='VY  '
             LESOBL(NBROBL)='VZ  '
*
* CARACTERISTIQUES POUR LES POUTRES
*
          ELSE IF (MFR.EQ.7 ) THEN
               NBROBL=NBROBL+4
               NBRFAC=NBRFAC+2
               SEGADJ NOMID
               LESOBL(NBROBL-3)='TORS'
               LESOBL(NBROBL-2)='INRY'
               LESOBL(NBROBL-1)='INRZ'
               LESOBL(NBROBL)='SECT'
               LESFAC(NBRFAC-1)='SECY'
               LESFAC(NBRFAC)='SECZ'
*
* CARACTERISTIQUES POUR LES TUYAUX
*
          ELSE IF (MFR.EQ.13) THEN
*            pour les autres on ne ient pas compte des modification
*            qui assouplissent le tuyau donc omega max diminue
             NBROBL=NBROBL+2
             SEGADJ NOMID
             LESOBL(NBROBL-1)='EPAI'
             LESOBL(NBROBL)='RAYO'
          ELSE IF (MFR.EQ.39) THEN
             NBROBL=NBROBL+2
             NBRFAC=NBRFAC+2
             SEGADJ NOMID
             LESOBL(NBROBL-1)='EPAI'
             LESOBL(NBROBL)='RAYO'
             LESFAC(NBRFAC-1)='RACO'
             LESFAC(NBRFAC)='PRES'
          ENDIF
*
          MOMATR=NOMID
          NMATR=NBROBL
          NMATF=NBRFAC
*
* ===>
*       write(6,*) 'Sous zone' ,isous,' Composante obligatoire ipche1'
*       write(6,7001) (lesobl(i),i=1,nbrobl)
*       write(6,*) 'facultatives'
*       write(6,7001) (lesfac(i),i=1,nbrfac)
*
      ENDIF
*
      IF (NMATR.NE.0) THEN
        CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAM1)
        IF (MOTYPE.NE.MOTYR8) SEGSUP NOTYPE
        nomid=momatr
        if(lsupma)segsup NOMID
        IF (IERR.NE.0) THEN
            SEGSUP MCHELM
            RETURN
        ENDIF
*           call tcloc2('Apres komcha2',6,it)
      ENDIF
*
*--------------------------------------------------------------------*
*       remplissage de la description du sous champ résultat
*
* dimension
*    = 2 si taille et coque ou poutre
*        mfr obtenu par elquoi nous renseigne
*
       IF ((ICAS.EQ.5).AND.
     &    (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.7.OR.MFR.EQ.9.OR.MFR.EQ.13))
     &    THEN
          DEUCMP = .TRUE.
          N2 = 2
          SEGINI MCHAML
          NOMCHE(1) = 'L'
          NOMCHE(2) = 'L2H'
          TYPCHE(1) = 'REAL*8'
          TYPCHE(2) = 'REAL*8'
       ELSE IF (ICAS.EQ.5) THEN
          N2 = 1
          SEGINI MCHAML
          NOMCHE(1) = 'L'
          TYPCHE(1) = 'REAL*8'
       ELSE IF (ICAS.EQ.4) THEN
          N2 = 1
          SEGINI MCHAML
          NOMCHE(1) = 'CSON'
          TYPCHE(1) = 'REAL*8'
       ELSE IF (ICAS.EQ.1.OR.ICAS.EQ.2.OR.ICAS.EQ.3) THEN
          N2 = 1
          SEGINI MCHAML
          NOMCHE(1) = 'TCFL'
          TYPCHE(1) = 'REAL*8'
       ENDIF
       ICHAML(ISOUS) = MCHAML
*
* le chamelem est defini au centre de gravité
*
        INFCHE(ISOUS,6) = 2
* il faut brancher sur le segment d'intégration
        INFCHE(ISOUS,4)=IPINT
* nom du constituant
        CONCHE(ISOUS) = CONMOD
* maillage
        IMACHE(ISOUS) = IPMAIL
* a priori info ne set plus
*        SEGSUP INFO
*
*--------------------------------------------------------------------*
*       appel au sous routine spécifiques
*
*     NUMERO DES ETIQUETTES      :
*     Les elements sont groupes comme suit :
*      - massif,liquide 'surface libre' poreux ----------------------> 4
*      - coq3,dkt,coq4,coq8,coq2,dst --------------------------------> 12
*      - poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,jot3> 27
*      - joi4,joi2,poutre de timoschenko,joi3                          29
*
*           1            5              0              5             0
      GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,12,99, 4, 4, 4, 4,99,99,99,
     2      99,99, 4, 4, 4, 4,27,27,29,99,99,99,99,99,99,99,99,99,99,99,
     4      27,29,99,27,99,29,12,99,27,99,99,99,99,99,12,27,99,99,99,99,
     6      99,99,99,99,99,99,99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,
     8      99,99,99,29,99,99,99,99,99,99,99,99,27,12,99,99,99,99,99,99,
     1      99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
     2      99,99,99,99,99,99,99),MELE
 99   CONTINUE
      MOTERR(1:4)=NOMTP(MELE)
      MOTERR(9:12)='CFL1'
      CALL ERREUR(86)
      SEGSUP MCHELM,MCHAML
      RETURN
C
C_______________________________________________________________________
C
C     massif
C_______________________________________________________________________
C
   4  CONTINUE
*      write(6,*) 'Appel a cfl2'
      CALL CFL2(ICAS,IPMAIL,MELE,IVAM1,IVAM2,MELV1,MELV2,N2)
      IF (IERR.NE.0) RETURN
      GOTO 400

C_______________________________________________________________________
C
C     ELTS DE RACCORD LIQUIDE SOLIDE  RAC2 RACO LIA3 LIA4 LICO LIC4
C          PAS DE RIGIDITE
C_______________________________________________________________________
C
  12  CONTINUE
*      write(6,*) 'Appel a cfl3'
      CALL CFL5(ICAS,IPMAIL,MELE,IVAM1,IVAM2,MELV1,MELV2,N2)
      IF (IERR.NE.0) RETURN
      GOTO 400
C_______________________________________________________________________
C
C     coq3,dkt,coq4,coq8,coq2,dst
C_______________________________________________________________________
C
  27  CONTINUE
*      write(6,*) 'Appel a cfl4'
      CALL CFL5(ICAS,IPMAIL,MELE,IVAM1,IVAM2,MELV1,MELV2,N2)
      IF (IERR.NE.0) RETURN
      GOTO 400
C_______________________________________________________________________
C
C poutre,barre,homogeneise
C poutre de Timoschenko
C_______________________________________________________________________
C
  29  CONTINUE
*      write(6,*) 'Appel a cfl5'
*  ivam1 et 2 sont actifs , ipmail descativé
      CALL CFL5(ICAS,IPMAIL,MELE,IVAM1,IVAM2,MELV1,MELV2,N2)
*  en sortie melv1 et melv2 sont inactifs
      IF (IERR.NE.0) RETURN
      GOTO 400
*
 400  CONTINUE
*  on raccroche le résultat
      IELVAL(1) = MELV1
      IF (DEUCMP)  IELVAL(2) = MELV2
      SEGDES MCHAML
      SEGDES IMODEL
      IF (IVAM1.NE.0) THEN
         MPTVAL = IVAM1
         SEGSUP MPTVAL
      ENDIF
      IF (IVAM2.NE.0) THEN
         MPTVAL = IVAM2
         SEGSUP MPTVAL
      ENDIF
* fin boucle sur les sous zone des champs
 500  CONTINUE
*
       IPCHA4 = MCHELM
       SEGDES MCHELM,MMODEL

       RETURN
       END