Télécharger la plaquette Cast3M


fr en

Télécharger indi2.eso

Retour à la liste

Numérotation des lignes : 

indi2

  1. C INDI2     SOURCE    GOUNAND   26/06/09    21:15:07     12566          
  2.       SUBROUTINE INDI2(IMAIL,MLMOTS)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : INDI2
  7. C DESCRIPTION : Indicateur de qualite du mailleur topologique
  8. C
  9. C
  10. C
  11. C LANGAGE     : ESOPE
  12. C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
  13. C               mel : gounand@semt2.smts.cea.fr
  14. C***********************************************************************
  15. C APPELES          :
  16. C APPELES (E/S)    :
  17. C APPELES (BLAS)   :
  18. C APPELES (CALCUL) :
  19. C APPELE PAR       :
  20. C***********************************************************************
  21. C SYNTAXE GIBIANE    :
  22. C ENTREES            : IMAIL
  23. C ENTREES/SORTIES    :
  24. C SORTIES            : ICHA
  25. C***********************************************************************
  26. C VERSION    : v1, 31/03/2021, version initiale
  27. C HISTORIQUE : v1, 31/03/2021, creation
  28. C HISTORIQUE :
  29. C HISTORIQUE :
  30. C***********************************************************************
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC SMCOORD
  34. -INC SMLREEL
  35. -INC SMLMOTS
  36. -INC SMELEME
  37. -INC SMCHAML
  38. -INC SMTEXTE
  39. -INC SMCHPOI
  40.       POINTEUR ICMETR.MCHPOI,ICMTR2.MCHPOI
  41. *
  42.       parameter(ncle=3)
  43.       character*8 mtyp
  44.       character*1 chifr
  45.       character*8 mcle(ncle)
  46.       logical lmet
  47.       parameter (ntmet=4)
  48.       character*8 typmet(ntmet)
  49.       character*4 moindi
  50. *
  51.       DATA MCLE/'ARIT    ','GEOM    ','LISTREEL'/
  52.       DATA typmet/'FLOTTANT','ENTIER  ','CHPOINT ','MCHAML  '/
  53. *
  54. * Executable statements
  55. *
  56.       MELEME=IMAIL
  57.       JGM=MOTS(/2)
  58.       call place(MLMOTS.MOTS,JGM,IMOT,'TOP2')
  59.       IF (IMOT.EQ.0) THEN
  60.          CALL QUETYP(mtyp,0,iretou)
  61.          if (iretou.eq.1) then
  62.             CALL PLACE(typmet,ntmet,imet,mtyp)
  63.             if (imet.ne.0) then
  64. * Ecrire le mot-cle 'METR' pour la procedure
  65.                CALL ECRCHA('METR')
  66.             endif
  67.          endif
  68.          CALL ECROBJ('MAILLAGE',MELEME)
  69. *! Ecrire les chaines plutot que le LISTMOTS
  70. *! car il peut se faire menager avant l'appel a DEADUTIL
  71.          DO IGM=1,JGM
  72.             MOINDI=MOTS(IGM)
  73.             CALL ECRCHA(MOINDI)
  74.          ENDDO
  75. *!         CALL ECROBJ('LISTMOTS',MLMOTS)
  76.          CALL ECRCHA('INDI')
  77.          SEGINI MTEXTE
  78.          LTT=8
  79.          MTEXT(1:LTT) ='DEADUTIL'
  80.          NCART=LTT
  81.          SEGDES MTEXTE
  82.          CALL ECROBJ('TEXTE',MTEXTE)
  83.          RETURN
  84.       ENDIF
  85.       IF (JGM.NE.1) THEN
  86.          CALL ERREUR(5)
  87.          RETURN
  88.       ENDIF
  89. *     Initialisation des données dans le common CCMATOP
  90. *     Attention, il faut mettre les mêmes valeurs par défaut
  91. *     que dans proptt et prtopv
  92.       xvtol=1.D-11
  93.       imet=0
  94.       xdens=0.d0
  95.       icmetr=0
  96.       icmtr2=0
  97.       imomet=0
  98.       impr=0
  99.       iveri=2
  100.       ilistr=0
  101. *
  102.  10   continue
  103.       call lirmot(mcle,ncle,icle,0)
  104.       if (icle.ne.0) then
  105.          if (icle.eq.1.or.icle.eq.2) then
  106.             imomet=icle-1
  107.          elseif (icle.eq.3) then
  108.             ilistr=1
  109.          else
  110.             call erreur(5)
  111.             return
  112.          endif
  113.          goto 10
  114.       endif
  115. * 2020/04/29 SG
  116. *     Pas de gestion du noeud virtuel car cela n'est pas compatible
  117. *     avec la transformation du MLREEL en CHAMELEM
  118. *
  119. *     Lecture de la métrique voulue :
  120. c     LOG1  : pas de métrique,
  121. c     FLOT1 : taille de maille ;
  122. C     CHPO1 : inverse de la métrique isotrope, nom de composante G ou
  123. C     anisotrope, noms de composante G11, G21, G22, (G31, G32, G33 en
  124. C     3D)
  125. *
  126.       imet=0
  127.       call lirlog(lmet,0,IRET)
  128.       IF (IERR.NE.0) RETURN
  129.       if (iret.eq.0) then
  130.          call lirree(XDENS,0,IRET)
  131.          IF (IERR.NE.0) RETURN
  132.          if (iret.eq.1) then
  133.             imet=2
  134.          else
  135.             CALL LIROBJ('CHPOINT',ICMETR,0,IRET)
  136.             IF (IERR.NE.0) RETURN
  137.             if (iret.eq.1) then
  138.                call extr11(icmetr,mlmots)
  139.                if (ierr.ne.0) return
  140.                segact mlmots
  141.                CALL PLACE(MOTS,MOTS(/2),iplac,'G   ')
  142.                if (iplac.ne.0) then
  143.                   imet=3
  144.                else
  145.                   imet=4
  146.                endif
  147.                segsup mlmots
  148.             endif
  149.          endif
  150.          if (imomet.eq.1.and.icmetr.ne.0) then
  151.             call ecrcha('LOG')
  152.             call ecrobj('CHPOINT',ICMETR)
  153.             call prtens
  154.             if (ierr.ne.0) return
  155.             call lirobj('CHPOINT',ICMTR2,1,IRET)
  156.             if (ierr.ne.0) return
  157.          else
  158.             ICMTR2=ICMETR
  159.          endif
  160.       else
  161.         if(lmet) imet=1
  162.       endif
  163.       CALL LIROBJ('LISTREEL',MLREEL,0,IRET)
  164.       IF (IERR.NE.0) RETURN
  165.       if (iret.eq.1) then
  166.          SEGACT MLREEL
  167.          NR=PROG(/1)
  168.          if (NR.NE.3) THEN
  169.             write(ioimp,*) 'indi2.eso : NR.NE.3'
  170.             call erreur(5)
  171.             return
  172.          endif
  173.          jcritq=nint(prog(1))
  174.          pcritq=prog(2)
  175.          qcritq=prog(3)
  176.       else
  177.          jcritq=2
  178.          pcritq=10.d0
  179.          qcritq=1.d0
  180.       endif
  181. *      write(ioimp,*) 'imet=',imet
  182.       CALL QUALI7(MELEME,IMET,IMOMET,XDENS,ICMTR2,XVTOL,MLREEL
  183.      $     ,IMPR,IVERI,jcritq,pcritq,qcritq)
  184.       IF (IERR.NE.0) RETURN
  185.       if (imomet.eq.1.and.icmetr.ne.0) then
  186.          segsup,icmtr2
  187.       endif
  188. *
  189.       if (ilistr.eq.1) then
  190.          CALL ECROBJ('LISTREEL',MLREEL)
  191.       else
  192. *
  193. *     Transformation du MLREEL en MCHAML
  194. *
  195.          SEGACT MELEME
  196.          NBSOUS=LISOUS(/1)
  197.          IF (NBSOUS.NE.0) THEN
  198.             CALL ERREUR(25)
  199.             RETURN
  200.          ENDIF
  201.          NBELEM=NUM(/2)
  202.          SEGACT MLREEL
  203.          JG=PROG(/1)
  204.          IF (JG.NE.NBELEM) THEN
  205.             write(ioimp,*) 'JG,NBELEM=',JG,NBELEM
  206.             CALL ERREUR(5)
  207.             RETURN
  208.          ENDIF
  209. *     Création du CHAMELEM
  210.          L1=7
  211.          N1=1
  212.          N3=6
  213.          SEGINI,MCHELM
  214.          TITCHE='QUALITE'
  215.          CONCHE(1)='                '
  216.          INFCHE(1,1)=0
  217.          INFCHE(1,2)=0
  218.          INFCHE(1,3)=NIFOUR
  219.          INFCHE(1,4)=0
  220.          INFCHE(1,5)=0
  221.          INFCHE(1,6)=1
  222.          IFOCHE=IFOUR
  223. *
  224.          N2=1
  225.          SEGINI,MCHAML
  226.          NOMCHE(1)='TOP2'
  227.          TYPCHE(1)='REAL*8'
  228. *
  229.          N1PTEL=1
  230.          N1EL=NBELEM
  231.          N2PTEL=0
  232.          N2EL=0
  233.          SEGINI,MELVAL
  234.          DO IELEM=1,NBELEM
  235.             VELCHE(1,IELEM)=PROG(IELEM)
  236.          ENDDO
  237. *
  238.          IELVAL(1)=MELVAL
  239. *
  240.          IMACHE(1)=MELEME
  241.          ICHAML(1)=MCHAML
  242. * Sortie
  243.          SEGSUP MLREEL
  244.          CALL ACTOBJ('MCHAML',MCHELM,1)
  245.          CALL ECROBJ('MCHAML',MCHELM)
  246.       ENDIF
  247. *
  248. * Normal termination
  249. *
  250.       RETURN
  251. *
  252. * End of subroutine INDI2
  253. *
  254.       END
  255.  
  256.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales