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/01/11    21:15:02     12447          
  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.  10   continue
  102.       call lirmot(mcle,ncle,icle,0)
  103.       if (icle.ne.0) then
  104.          if (icle.eq.1.or.icle.eq.2) then
  105.             imomet=icle-1
  106.          elseif (icle.eq.3) then
  107.             ilistr=1
  108.          else
  109.             call erreur(5)
  110.             return
  111.          endif
  112.          goto 10
  113.       endif
  114. * 2020/04/29 SG
  115. *     Pas de gestion du noeud virtuel car cela n'est pas compatible
  116. *     avec la transformation du MLREEL en CHAMELEM
  117. *
  118. *     Lecture de la métrique voulue :
  119. c     LOG1  : pas de métrique,
  120. c     FLOT1 : taille de maille ;
  121. C     CHPO1 : inverse de la métrique isotrope, nom de composante G ou
  122. C     anisotrope, noms de composante G11, G21, G22, (G31, G32, G33 en
  123. C     3D)
  124. *
  125.       imet=0
  126.       call lirlog(lmet,0,IRET)
  127.       IF (IERR.NE.0) RETURN
  128.       if (iret.eq.0) then
  129.          call lirree(XDENS,0,IRET)
  130.          IF (IERR.NE.0) RETURN
  131.          if (iret.eq.1) then
  132.             imet=2
  133.          else
  134.             CALL LIROBJ('CHPOINT',ICMETR,0,IRET)
  135.             IF (IERR.NE.0) RETURN
  136.             if (iret.eq.1) then
  137.                call extr11(icmetr,mlmots)
  138.                if (ierr.ne.0) return
  139.                segact mlmots
  140.                CALL PLACE(MOTS,MOTS(/2),iplac,'G   ')
  141.                if (iplac.ne.0) then
  142.                   imet=3
  143.                else
  144.                   imet=4
  145.                endif
  146.                segsup mlmots
  147.             endif
  148.          endif
  149.          if (imomet.eq.1.and.icmetr.ne.0) then
  150.             call ecrcha('LOG')
  151.             call ecrobj('CHPOINT',ICMETR)
  152.             call prtens
  153.             if (ierr.ne.0) return
  154.             call lirobj('CHPOINT',ICMTR2,1,IRET)
  155.             if (ierr.ne.0) return
  156.          else
  157.             ICMTR2=ICMETR
  158.          endif
  159.       else
  160.         if(lmet) imet=1
  161.       endif
  162. *      write(ioimp,*) 'imet=',imet
  163.       CALL QUALI7(MELEME,IMET,IMOMET,XDENS,ICMTR2,XVTOL,MLREEL,ISTRID
  164.      $     ,IMPR,IVERI)
  165.       IF (IERR.NE.0) RETURN
  166.       if (imomet.eq.1.and.icmetr.ne.0) then
  167.          segsup,icmtr2
  168.       endif
  169. *
  170.       if (ilistr.eq.1) then
  171.          IF (ISTRID.NE.1) THEN
  172.             JG=PROG(/1)/ISTRID
  173.             SEGINI MLREE2
  174.             DO IG=1,JG
  175.                KG=(IG-1)*ISTRID+1
  176.                MLREE2.PROG(IG)=PROG(KG)
  177.             ENDDO
  178.             SEGSUP MLREEL
  179.             MLREEL=MLREE2
  180.          ENDIF
  181.          CALL ECROBJ('LISTREEL',MLREEL)
  182.       else
  183. *
  184. *     Transformation du MLREEL en MCHAML
  185. *
  186.          SEGACT MELEME
  187.          NBSOUS=LISOUS(/1)
  188.          IF (NBSOUS.NE.0) THEN
  189.             CALL ERREUR(25)
  190.             RETURN
  191.          ENDIF
  192.          NBELEM=NUM(/2)
  193.          SEGACT MLREEL
  194.          JG=PROG(/1)
  195.          IF (JG.NE.NBELEM*ISTRID) THEN
  196.             write(ioimp,*) 'JG,NBELEM,ISTRID=',JG,NBELEM,ISTRID
  197.             CALL ERREUR(5)
  198.             RETURN
  199.          ENDIF
  200. *     Création du CHAMELEM
  201.          L1=7
  202.          N1=1
  203.          N3=6
  204.          SEGINI,MCHELM
  205.          TITCHE='QUALITE'
  206.          CONCHE(1)='                '
  207.          INFCHE(1,1)=0
  208.          INFCHE(1,2)=0
  209.          INFCHE(1,3)=NIFOUR
  210.          INFCHE(1,4)=0
  211.          INFCHE(1,5)=0
  212.          INFCHE(1,6)=1
  213.          IFOCHE=IFOUR
  214. *
  215.          IF (ISTRID.GT.9) THEN
  216.             write(ioimp,*) 'ISTRID=',ISTRID,'.GT.9'
  217.             CALL ERREUR(5)
  218.             RETURN
  219.          ENDIF
  220.          N2=ISTRID
  221.          SEGINI,MCHAML
  222.          DO K=1,ISTRID
  223.             IF (K.EQ.1) THEN
  224.                NOMCHE(K)='TOP2'
  225.             ELSE
  226.                WRITE(CHIFR,'(I1)') K
  227.                NOMCHE(K)='TOP2'//CHIFR
  228.             ENDIF
  229.             TYPCHE(K)='REAL*8'
  230. *
  231.             N1PTEL=1
  232.             N1EL=NBELEM
  233.             N2PTEL=0
  234.             N2EL=0
  235.             SEGINI,MELVAL
  236.             DO IELEM=1,NBELEM
  237.                JELEM=(IELEM-1)*ISTRID
  238.                VELCHE(1,IELEM)=PROG(JELEM+K)
  239.             ENDDO
  240. *
  241.             IELVAL(K)=MELVAL
  242.          ENDDO
  243. *
  244.          IMACHE(1)=MELEME
  245.          ICHAML(1)=MCHAML
  246. * Sortie
  247.          SEGSUP MLREEL
  248.          CALL ACTOBJ('MCHAML',MCHELM,1)
  249.          CALL ECROBJ('MCHAML',MCHELM)
  250.       ENDIF
  251. *
  252. * Normal termination
  253. *
  254.       RETURN
  255. *
  256. * End of subroutine INDI2
  257. *
  258.       END
  259.  
  260.  

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