Télécharger la plaquette Cast3M


fr en

Télécharger propto.eso

Retour à la liste

Numérotation des lignes : 

propto

  1. C PROPTO    SOURCE    GOUNAND   26/06/09    21:15:12     12566          
  2.       SUBROUTINE PROPTO
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : PROPTO
  7. C DESCRIPTION : Une implémentation de l'amélioration d'une topologie
  8. C               autour d'un élément. On reprend OPTITOPO pour le corps
  9. C     du programme. On reprend l'extraction et la topologie inverse de
  10. C     EXTO. Le point crucial sera d'implémenter la modification de la
  11. C     topologie : enlever les anciens éléments et mettre les nouveaux.
  12. C
  13. C     Ici, on fait les entrées-sorties et on initialise le common avec
  14. C     les options globales.
  15. C
  16. C
  17. C LANGAGE     : ESOPE
  18. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
  19. C               mél : gounand@semt2.smts.cea.fr
  20. C***********************************************************************
  21. C APPELES          :
  22. C APPELES (E/S)    :
  23. C APPELES (BLAS)   :
  24. C APPELES (CALCUL) :
  25. C APPELE PAR       :
  26. C***********************************************************************
  27. C SYNTAXE GIBIANE    :
  28. C ENTREES            :
  29. C ENTREES/SORTIES    :
  30. C SORTIES            :
  31. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  32. C***********************************************************************
  33. C VERSION    : v1, 04/10/2017, version initiale
  34. C HISTORIQUE : v1, 04/10/2017, création
  35. C HISTORIQUE :
  36. C HISTORIQUE :
  37. C***********************************************************************
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC TMATOP2
  41. -INC SMELEME
  42.       POINTEUR ITOPO.MELEME
  43.       POINTEUR IELEM.MELEME
  44. * TOPologie Améliorée
  45.       POINTEUR ITOPA.MELEME
  46.       POINTEUR IPVIRT.MELEME
  47. -INC SMLOBJE
  48.       POINTEUR LTOPA.MLOBJE
  49. -INC SMLMOTS
  50. -INC SMLREEL
  51.       POINTEUR ICRITQ.MLREEL
  52. -INC SMCHPOI
  53.       POINTEUR ICMETR.MCHPOI,ICMTR2.MCHPOI
  54. * METrique sur la topologie Améliorée
  55.       POINTEUR ICMETA.MCHPOI,ICMTA2.MCHPOI
  56.       integer oooval
  57.       parameter(ncle=14)
  58.       character*8 mtyp
  59.       character*4 mcle(ncle)
  60.       logical lmet
  61.  
  62.       data mcle /'IMPR','VERI','VTOL','QTOL','VIRT','SGAJ','ALGO'
  63.      $     ,'AJNO','NCMA','STMA','MOYE','BARY','SEQM',
  64.      $     'CRIQ'/
  65. *
  66. * Executable statements
  67. *
  68.       impr=0
  69.       IF (IMPR.Ge.5) WRITE(IOIMP,*) 'Entrée dans propto.eso'
  70. *
  71. *     Initialisation des données dans le common TMATOP2
  72. *     Attention, il faut mettre les mêmes valeurs par défaut
  73. *     que dans ryo2v et prtopv
  74. *
  75.       impr=0
  76.       iveri=0
  77.       isgadj=0
  78.       xvtol=1.d-11
  79.       qtol=1.d-2
  80.       ipvirt=0
  81.       imet=0
  82.       imomet=0
  83.       xdens=0.d0
  84.       icmetr=0
  85.       ialgo=0
  86.       iajno=0
  87.       incma=1000
  88.       istma=0
  89.       imobar=0
  90.       iseqm=0
  91.       icritq=0
  92.       jcritq=2
  93.       pcritq=10.d0
  94.       qcritq=1.d0
  95. *      write(ioimp,*) 'propto : entree      =',OOOVAL(2,1)
  96. * Entrees
  97.       CALL LIROBJ('MAILLAGE',ITOPO,1,IRETOU)
  98.       IF (IERR.NE.0) RETURN
  99.       CALL LIROBJ('MAILLAGE',IELEM,1,IRETOU)
  100.       IF (IERR.NE.0) RETURN
  101.       CALL QUETYP(MTYP,0,IRET)
  102.       if (iret.EQ.1) then
  103.          if (MTYP.NE.'MOT     ') THEN
  104. *
  105. *     Lecture de la métrique voulue :
  106. c     FLOT1 : taille de maille ;
  107. C     CHPO1 : inverse de la métrique isotrope, nom de composante G ou
  108. C     anisotrope, noms de composante G11, G21, G22, (G31, G32, G33 en
  109. C     3D)
  110. *
  111.             IF (MTYP.EQ.'LOGIQUE ') THEN
  112.                call lirlog(lmet,1,IRLOG)
  113.                IF (IERR.NE.0) RETURN
  114.             ELSEIF (MTYP.EQ.'CHPOINT ') THEN
  115.                CALL LIROBJ('CHPOINT',ICMETR,1,IRET)
  116.                IF (IERR.NE.0) RETURN
  117.                call extr11(icmetr,mlmots)
  118.                if (ierr.ne.0) return
  119.                segact mlmots
  120.                CALL PLACE(MOTS,MOTS(/2),iplac,'G   ')
  121.                if (iplac.ne.0) then
  122.                   imet=3
  123.                else
  124.                   imet=4
  125.                endif
  126.                segsup mlmots
  127.             elseif (MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER') then
  128.                call lirree(XDENS,1,IRET)
  129.                IF (IERR.NE.0) RETURN
  130.                imet=2
  131.             else
  132. *  39 2
  133. * On ne veut pas d'objet de type %m1:8
  134.                MOTERR(1:8)=MTYP
  135.                CALL ERREUR(39)
  136.                RETURN
  137.             endif
  138.          endif
  139.       endif
  140. *
  141. *     Mots-Clefs
  142. *
  143.  10   continue
  144.       call lirmot(mcle,ncle,imot,0)
  145.       if (imot.eq.1) then
  146.          CALL LIRENT(impr,1,IRET)
  147.       elseif (imot.eq.2) then
  148.          CALL LIRENT(iveri,1,IRET)
  149.       elseif (imot.eq.3) then
  150.          CALL LIRREE(XVTOL,1,IRET)
  151.       elseif (imot.eq.4) then
  152.          CALL LIRREE(QTOL,1,IRET)
  153.       elseif (imot.eq.5) then
  154.          CALL LIROBJ('MAILLAGE',IPVIRT,1,IRET)
  155.       elseif (imot.eq.6) then
  156.          CALL LIRENT(isgadj,1,IRET)
  157.       elseif (imot.eq.7) then
  158.          CALL LIRENT(ialgo,1,IRET)
  159.       elseif (imot.eq.8) then
  160.          CALL LIRENT(iajno,1,IRET)
  161.       elseif (imot.eq.9) then
  162.          CALL LIRENT(incma,1,IRET)
  163.       elseif (imot.eq.10) then
  164.          CALL LIRENT(istma,1,IRET)
  165.       elseif (imot.eq.11) then
  166.          CALL LIRENT(imomet,1,IRET)
  167.       elseif (imot.eq.12) then
  168.          CALL LIRENT(imobar,1,IRET)
  169.       elseif (imot.eq.13) then
  170.          CALL LIRENT(iseqm,1,IRET)
  171.       elseif (imot.eq.14) then
  172.          CALL LIROBJ('LISTREEL',ICRITQ,1,IRET)
  173.       elseif (imot.eq.15) then
  174.          CALL LIRREE(PCRITQ,1,IRET)
  175.       elseif (imot.eq.16) then
  176.          CALL LIRREE(QCRITQ,1,IRET)
  177.       elseif (imot.ne.0) then
  178.          MOTERR(1:8)=MCLE(imot)
  179.          Write(ioimp,*) MOTERR(1:8)
  180. * Option indisponible
  181.          CALL ERREUR(19)
  182.          RETURN
  183.       endif
  184.       IF (IERR.NE.0) RETURN
  185.       if (imot.ne.0) goto 10
  186. *
  187. * Test des paramètres
  188. *
  189.       IF (icritq.ne.0) then
  190.          segact icritq
  191.          npar=icritq.prog(/1)
  192.          if (npar.ne.1.and.npar.ne.3) then
  193.             write(ioimp,*) 'CRIQ keyword:'
  194.             INTERR(1)=3
  195. * 1158 2
  196. *On attend un LISTREEL de dimension %i1
  197.             CALL ERREUR(1158)
  198.             RETURN
  199.          endif
  200.          jcritq=NINT(icritq.prog(1))
  201.          if (npar.gt.1) then
  202.             pcritq=icritq.prog(2)
  203.             qcritq=icritq.prog(3)
  204.          endif
  205.       ENDIF
  206. *!debug      if (impr.ge.3) then
  207.       if (impr.ge.2) then
  208.          write(ioimp,*) 'Opto parameters :'
  209.          write(ioimp,186) 'impr',impr,'iveri',iveri,'ipvirt',ipvirt
  210.      $        ,'imet',imet,'isgadj',isgadj,'ialgo',ialgo,'iajno',iajno
  211.      $        ,'incma',incma,'istma',istma,'imomet',imomet,'imobar'
  212.      $        ,imobar,'iseqm',iseqm,'jcritq',jcritq
  213.          write(ioimp,188) 'xvtol',xvtol,'qtol',qtol,'pcritq',pcritq
  214.      $        ,'qcritq',qcritq
  215.       endif
  216. *
  217. *     Initialisation des sorties du common
  218. *
  219.       jparco=0
  220.       jexplo=0
  221.       jchang=0
  222.       jnascm=0
  223. * Traitement
  224. * En moyenne géométrique, on passe en LOG avant OPTO1
  225.       if (imomet.eq.1.and.icmetr.ne.0) then
  226.          call ecrcha('LOG')
  227.          call ecrobj('CHPOINT',ICMETR)
  228.          call prtens
  229.          if (ierr.ne.0) return
  230.          call lirobj('CHPOINT',ICMTR2,1,IRET)
  231.          if (ierr.ne.0) return
  232.       else
  233.          ICMTR2=ICMETR
  234.       endif
  235. * Restituer le CHPOINT sur tous les noeuds ??
  236.       CALL OPTO1(ITOPO,IELEM,IPVIRT,ICMTR2,
  237.      $     ITOPA,ICMTA2,LTOPA)
  238.       IF (IERR.NE.0) RETURN
  239.       if (imomet.eq.1.and.icmta2.ne.0) then
  240.          call ecrcha('EXP')
  241.          call ecrobj('CHPOINT',ICMTA2)
  242.          call prtens
  243.          if (ierr.ne.0) return
  244.          call lirobj('CHPOINT',ICMETA,1,IRET)
  245.          if (ierr.ne.0) return
  246.          if (icmta2.ne.icmtr2) segsup,icmta2
  247.          segsup,icmtr2
  248.       else
  249.          ICMETA=ICMTA2
  250.       endif
  251. *     Sorties
  252.       CALL ECRENT(JNASCM)
  253.       CALL ECRENT(JPARCO)
  254.       CALL ECRENT(JCHANG)
  255.       CALL ECRENT(JEXPLO)
  256.       if (imet.le.2) then
  257.          if (irlog.eq.1) then
  258.             call ecrlog(lmet)
  259.          else
  260.             CALL ECRREE(XDENS)
  261.          endif
  262.       else
  263.          CALL ACTOBJ('CHPOINT',ICMETA,1)
  264.          CALL ECROBJ('CHPOINT',ICMETA)
  265.       endif
  266. * del      endif
  267.       CALL ACTOBJ('MAILLAGE',ITOPA,1)
  268.       CALL ECROBJ('MAILLAGE',ITOPA)
  269.       SEGACT LTOPA
  270.       NOBJ=LTOPA.LISOBJ(/1)
  271.       DO IOBJ=1,NOBJ
  272.          MELEME=LTOPA.LISOBJ(IOBJ)
  273.          CALL ACTOBJ('MAILLAGE',MELEME,1)
  274.       ENDDO
  275.       CALL ECROBJ('LISTOBJE',LTOPA)
  276. *
  277. * Normal termination
  278. *
  279.       RETURN
  280. *
  281. * Format handling
  282. *
  283.  186  FORMAT (2X,12(A6,'=',I6,2X))
  284.  188  FORMAT (2X,12(A6,'=',1PG12.5,2X))
  285. *
  286. * Error handling
  287. *
  288.  9999 CONTINUE
  289.       MOTERR(1:8)='PROPTO  '
  290. * 349 2
  291. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  292.       CALL ERREUR(349)
  293.       RETURN
  294. *
  295. * End of subroutine PROPTO
  296. *
  297.       END
  298.  
  299.  

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