Sources Esope | Cast3M

indi2
C INDI2     SOURCE    GOUNAND   25/07/24    21:15:01     12334          
      SUBROUTINE INDI2(IMAIL)
      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 SMCHPOI
      POINTEUR ICMETR.MCHPOI,ICMTR2.MCHPOI
*
      parameter(ncle=3)
      character*8 mtyp
      character*8 mcle(ncle)
      logical lmet
*
      DATA MCLE/'ARIT    ','GEOM    ','LISTREEL'/
*
* Executable statements
*
      MELEME=IMAIL
*     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
      ipvirt=0
      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
c$$$* Mot-clé VIRT pour gérer le noeud virtuel
c$$$         call lirmot(mcle,ncle,imot,0)
c$$$         IF (IERR.NE.0) RETURN
c$$$         if (imot.eq.1) then
c$$$            CALL LIROBJ('POINT',IPVIRT,0,IRET)
c$$$            IF (IERR.NE.0) RETURN
c$$$            IF (IRET.EQ.0) THEN
c$$$               CALL LIRENT(IPVIRT,1,IRET)
c$$$               IF (IERR.NE.0) RETURN
c$$$               IF (IPVIRT.NE.0) THEN
c$$$                  write(ioimp,*)
c$$$     $                 'On voulait lire un point ou un entier nul'
c$$$                  goto 9999
c$$$               ENDIF
c$$$            ENDIF
c$$$         endif
*
*     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,IPVIRT,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