Sources Esope | Cast3M

indi2
C INDI2     SOURCE    GOUNAND   25/11/21    21:15:02     12404          
      SUBROUTINE INDI2(IMAIL,ITOPO)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : INDI2
C DESCRIPTION : Indicateur de qualite du mailleur topologique
C
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
C               mel : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          :
C APPELES (E/S)    :
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            : IMAIL
C ENTREES/SORTIES    :
C SORTIES            : ICHA
C***********************************************************************
C VERSION    : v1, 31/03/2021, version initiale
C HISTORIQUE : v1, 31/03/2021, creation
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMLREEL
-INC SMLMOTS
-INC SMELEME
-INC SMCHAML
-INC SMTEXTE
-INC SMCHPOI
      POINTEUR ICMETR.MCHPOI,ICMTR2.MCHPOI
*
      parameter(ncle=3)
      character*8 mtyp
      character*8 mcle(ncle)
      logical lmet
      parameter (ntmet=4)
      character*8 typmet(ntmet)
*
      DATA MCLE/'ARIT    ','GEOM    ','LISTREEL'/
      DATA typmet/'FLOTTANT','ENTIER  ','CHPOINT ','MCHAML  '/
*
* Executable statements
*
      MELEME=IMAIL
      IF (ITOPO.EQ.2.OR.ITOPO.EQ.3) THEN
         CALL QUETYP(mtyp,0,iretou)
         if (iretou.eq.1) then
            CALL PLACE(typmet,ntmet,imet,mtyp)
            if (imet.ne.0) then
* Ecrire le mot-cle 'METR' pour la procedure
               CALL ECRCHA('METR')
            endif
         endif
         CALL ECROBJ('MAILLAGE',MELEME)
         SEGINI MTEXTE
         IF (ITOPO.EQ.2) THEN
            LTT=14
            MTEXT(1:LTT) ='DEADUTIL QALI2'
         ELSE
            LTT=14
            MTEXT(1:LTT) ='DEADUTIL QEQU2'
         ENDIF
         NCART=LTT
         SEGDES MTEXTE
         CALL ECROBJ('TEXTE',MTEXTE)
         RETURN
      ENDIF
*     Initialisation des données dans le common CCMATOP
*     Attention, il faut mettre les mêmes valeurs par défaut
*     que dans proptt et prtopv
      xvtol=1.D-11
      imet=0
      xdens=0.d0
      icmetr=0
      icmtr2=0
      imomet=0
      impr=0
      iveri=2
      ilistr=0
 10   continue
      call lirmot(mcle,ncle,icle,0)
      if (icle.ne.0) then
         if (icle.eq.1.or.icle.eq.2) then
            imomet=icle-1
         elseif (icle.eq.3) then
            ilistr=1
         else
            call erreur(5)
            return
         endif
         goto 10
      endif
* 2020/04/29 SG
*     Pas de gestion du noeud virtuel car cela n'est pas compatible
*     avec la transformation du MLREEL en CHAMELEM
*
*     Lecture de la métrique voulue :
c     LOG1  : pas de métrique,
c     FLOT1 : taille de maille ;
C     CHPO1 : inverse de la métrique isotrope, nom de composante G ou
C     anisotrope, noms de composante G11, G21, G22, (G31, G32, G33 en
C     3D)
*
      imet=0
      call lirlog(lmet,0,IRET)
      IF (IERR.NE.0) RETURN
      if (iret.eq.0) then
         call lirree(XDENS,0,IRET)
         IF (IERR.NE.0) RETURN
         if (iret.eq.1) then
            imet=2
         else
            CALL LIROBJ('CHPOINT',ICMETR,0,IRET)
            IF (IERR.NE.0) RETURN
            if (iret.eq.1) then
               call extr11(icmetr,mlmots)
               if (ierr.ne.0) return
               segact mlmots
               CALL PLACE(MOTS,MOTS(/2),iplac,'G   ')
               if (iplac.ne.0) then
                  imet=3
               else
                  imet=4
               endif
               segsup mlmots
            endif
         endif
         if (imomet.eq.1.and.icmetr.ne.0) then
            call ecrcha('LOG')
            call ecrobj('CHPOINT',ICMETR)
            call prtens
            if (ierr.ne.0) return
            call lirobj('CHPOINT',ICMTR2,1,IRET)
            if (ierr.ne.0) return
         else
            ICMTR2=ICMETR
         endif
      else
        if(lmet) imet=1
      endif
*      write(ioimp,*) 'imet=',imet
      CALL QUALI7(MELEME,IMET,IMOMET,XDENS,ICMTR2,XVTOL,MLREEL
     $     ,IMPR,IVERI)
      IF (IERR.NE.0) RETURN
      if (imomet.eq.1.and.icmetr.ne.0) then
         segsup,icmtr2
      endif
*
      if (ilistr.eq.1) then
         CALL ECROBJ('LISTREEL',MLREEL)
      else
*
*     Transformation du MLREEL en MCHAML
*
         SEGACT MELEME
         NBSOUS=LISOUS(/1)
         IF (NBSOUS.NE.0) THEN
            CALL ERREUR(25)
            RETURN
         ENDIF
         NBELEM=NUM(/2)
         SEGACT MLREEL
         JG=PROG(/1)
         IF (JG.NE.NBELEM) THEN
            CALL ERREUR(5)
            RETURN
         ENDIF
*     Création du CHAMELEM
         N1PTEL=1
         N1EL=NBELEM
         N2PTEL=0
         N2EL=0
         SEGINI,MELVAL
         DO IELEM=1,NBELEM
            VELCHE(1,IELEM)=PROG(IELEM)
         ENDDO
*
         N2=1
         SEGINI,MCHAML
*     NOMCHE(1)='QUALTOPO'
*     Eviter les problèmes dans certains opérateurs avec les noms de 4
*     lettres ?
         NOMCHE(1)='TOPO'
         TYPCHE(1)='REAL*8'
*
         IELVAL(1)=MELVAL
*
         L1=7
         N1=1
         N3=6
         SEGINI,MCHELM
         TITCHE='QUALITE'
         CONCHE(1)='                '
         INFCHE(1,1)=0
         INFCHE(1,2)=0
         INFCHE(1,3)=NIFOUR
         INFCHE(1,4)=0
         INFCHE(1,5)=0
         INFCHE(1,6)=1
         IFOCHE=IFOUR
*
         IMACHE(1)=MELEME
         ICHAML(1)=MCHAML
* Sortie
         SEGSUP MLREEL
         CALL ACTOBJ('MCHAML',MCHELM,1)
         CALL ECROBJ('MCHAML',MCHELM)
      ENDIF
*
* Normal termination
*
      RETURN
*
* End of subroutine INDI2
*
      END