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   25/07/24    21:15:04     12334          
  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. -INC SMLMOTS
  47. -INC SMCHPOI
  48.       POINTEUR ICMETR.MCHPOI,ICMTR2.MCHPOI
  49. * METrique sur la topologie Améliorée
  50.       POINTEUR ICMETA.MCHPOI,ICMTA2.MCHPOI
  51.       INTEGER IMPR,IRET
  52.       integer oooval
  53.       parameter(ncle=11)
  54.       character*8 mtyp
  55.       character*4 mcle(ncle)
  56.       logical lmet
  57.  
  58.       data mcle /'IMPR','VERI','VTOL','QTOL','VIRT','SGAJ','ALGO'
  59.      $     ,'AJNO','NCMA','STMA','MOYE'/
  60. *      data mmet /'SANS','DENS','CSTE','ISOT','ANIS'/
  61. *
  62. * Executable statements
  63. *
  64.       impr=0
  65.       IF (IMPR.Ge.5) WRITE(IOIMP,*) 'Entrée dans propto.eso'
  66. *
  67. *     Initialisation des données dans le common TMATOP2
  68. *     Attention, il faut mettre les mêmes valeurs par défaut
  69. *     que dans ryo2v et prtopv
  70. *
  71.       impr=0
  72.       iveri=0
  73.       isgadj=0
  74.       xvtol=1.d-11
  75.       qtol=1.d-2
  76.       ipvirt=0
  77.       imet=0
  78.       imomet=0
  79.       xdens=0.d0
  80.       icmetr=0
  81.       ialgo=0
  82.       iajno=0
  83.       incma=1000
  84.       istma=0
  85. *      write(ioimp,*) 'propto : entree      =',OOOVAL(2,1)
  86. * Entrees
  87.       CALL LIROBJ('MAILLAGE',ITOPO,1,IRETOU)
  88.       IF (IERR.NE.0) RETURN
  89.       CALL LIROBJ('MAILLAGE',IELEM,1,IRETOU)
  90.       IF (IERR.NE.0) RETURN
  91.       CALL QUETYP(MTYP,0,IRET)
  92.       if (iret.EQ.1) then
  93.          if (MTYP.NE.'MOT     ') THEN
  94. *
  95. *     Lecture de la métrique voulue :
  96. c     LOG1  : pas de métrique,
  97. c     FLOT1 : taille de maille ;
  98. C     CHPO1 : inverse de la métrique isotrope, nom de composante G ou
  99. C     anisotrope, noms de composante G11, G21, G22, (G31, G32, G33 en
  100. C     3D)
  101. *
  102.             IF (MTYP.EQ.'LOGIQUE ') THEN
  103.                call lirlog(lmet,1,IRLOG)
  104.                IF (IERR.NE.0) RETURN
  105.             ELSEIF (MTYP.EQ.'CHPOINT ') THEN
  106.                CALL LIROBJ('CHPOINT',ICMETR,1,IRET)
  107.                IF (IERR.NE.0) RETURN
  108.                call extr11(icmetr,mlmots)
  109.                if (ierr.ne.0) return
  110.                segact mlmots
  111.                CALL PLACE(MOTS,MOTS(/2),iplac,'G   ')
  112.                if (iplac.ne.0) then
  113.                   imet=3
  114.                else
  115.                   imet=4
  116.                endif
  117.                segsup mlmots
  118.             elseif (MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER') then
  119.                call lirree(XDENS,1,IRET)
  120.                IF (IERR.NE.0) RETURN
  121.                imet=2
  122.             else
  123. *  39 2
  124. * On ne veut pas d'objet de type %m1:8
  125.                MOTERR(1:8)=MTYP
  126.                CALL ERREUR(39)
  127.                RETURN
  128.             endif
  129.          endif
  130.       endif
  131. *
  132. *     Mots-Clefs
  133. *
  134.  10   continue
  135.       call lirmot(mcle,ncle,imot,0)
  136.       if (imot.eq.1) then
  137. *     call lirree(xval,1,iret)
  138. *         impr=3
  139.          CALL LIRENT(impr,1,IRET)
  140.          IF (IERR.NE.0) RETURN
  141.       elseif (imot.eq.2) then
  142. *         iveri=2
  143.          CALL LIRENT(iveri,1,IRET)
  144.          IF (IERR.NE.0) RETURN
  145.       elseif (imot.eq.3) then
  146.          CALL LIRREE(XVTOL,1,IRET)
  147.          IF (IERR.NE.0) RETURN
  148.       elseif (imot.eq.4) then
  149.          CALL LIRREE(QTOL,1,IRET)
  150.          IF (IERR.NE.0) RETURN
  151.       elseif (imot.eq.5) then
  152.          CALL LIROBJ('POINT',IPVIRT,0,IRET)
  153.          IF (IERR.NE.0) RETURN
  154.          IF (IRET.EQ.0) THEN
  155.             CALL LIRENT(IPVIRT,1,IRET)
  156.             IF (IERR.NE.0) RETURN
  157.             IF (IPVIRT.NE.0) THEN
  158.                write(ioimp,*)
  159.      $              'On voulait lire un point ou un entier nul'
  160.                goto 9999
  161.             ENDIF
  162.          ENDIF
  163.       elseif (imot.eq.6) then
  164. *         isgadj=1
  165.          CALL LIRENT(isgadj,1,IRET)
  166.          IF (IERR.NE.0) RETURN
  167.       elseif (imot.eq.7) then
  168.          CALL LIRENT(ialgo,1,IRET)
  169.          IF (IERR.NE.0) RETURN
  170.       elseif (imot.eq.8) then
  171.          CALL LIRENT(iajno,1,IRET)
  172.          IF (IERR.NE.0) RETURN
  173.       elseif (imot.eq.9) then
  174.          CALL LIRENT(incma,1,IRET)
  175.          IF (IERR.NE.0) RETURN
  176.       elseif (imot.eq.10) then
  177.          CALL LIRENT(istma,1,IRET)
  178.          IF (IERR.NE.0) RETURN
  179.       elseif (imot.eq.11) then
  180.          CALL LIRENT(imomet,1,IRET)
  181.          IF (IERR.NE.0) RETURN
  182.       elseif (imot.ne.0) then
  183.          MOTERR(1:8)=MCLE(imot)
  184.          Write(ioimp,*) MOTERR(1:8)
  185. * Option indisponible
  186.          CALL ERREUR(19)
  187.          RETURN
  188.       endif
  189.       if (imot.ne.0) goto 10
  190. *      write(ioimp,*) 'imet=',imet
  191. *
  192. * Test des paramètres
  193. *
  194. *!debug      if (impr.ge.3) then
  195.       if (impr.ge.2) then
  196.          write(ioimp,*) 'Opto parameters :'
  197.          write(ioimp,186) 'impr',impr,'iveri',iveri,'ipvirt',ipvirt
  198.      $        ,'imet',imet,'isgadj',isgadj,'ialgo',ialgo,'iajno',iajno
  199.      $        ,'incma',incma,'istma',istma,'imomet',imomet
  200.          write(ioimp,188) 'xvtol',xvtol,'qtol',qtol
  201.       endif
  202. *
  203. *     Initialisation des sorties du common
  204. *
  205.       jparco=0
  206.       jexplo=0
  207.       jchang=0
  208.       jnascm=0
  209. * Traitement
  210. *      write(ioimp,*) 'coucou propto, iveri=',iveri
  211. *     write(ioimp,*) 'propto : avant opto1 =',OOOVAL(2,1)
  212. * En moyenne géométrique, on passe en LOG avant OPTO1
  213.       if (imomet.eq.1.and.icmetr.ne.0) then
  214.          call ecrcha('LOG')
  215.          call ecrobj('CHPOINT',ICMETR)
  216.          call prtens
  217.          if (ierr.ne.0) return
  218.          call lirobj('CHPOINT',ICMTR2,1,IRET)
  219.          if (ierr.ne.0) return
  220.       else
  221.          ICMTR2=ICMETR
  222.       endif
  223. * Restituer le CHPOINT sur tous les noeuds ??
  224.       CALL OPTO1(ITOPO,IELEM,IPVIRT,ICMTR2,
  225.      $     ITOPA,ICMTA2)
  226. *      write(ioimp,*) 'propto : apres opto1 =',OOOVAL(2,1)
  227.       IF (IERR.NE.0) RETURN
  228.       if (imomet.eq.1.and.icmta2.ne.0) then
  229.          call ecrcha('EXP')
  230.          call ecrobj('CHPOINT',ICMTA2)
  231.          call prtens
  232.          if (ierr.ne.0) return
  233.          call lirobj('CHPOINT',ICMETA,1,IRET)
  234.          if (ierr.ne.0) return
  235.          if (icmta2.ne.icmtr2) segsup,icmta2
  236.          segsup,icmtr2
  237.       else
  238.          ICMETA=ICMTA2
  239.       endif
  240. *     Sorties
  241.       CALL ECRENT(JNASCM)
  242.       CALL ECRENT(JPARCO)
  243.       CALL ECRENT(JCHANG)
  244.       CALL ECRENT(JEXPLO)
  245. *del      if (imet.gt.1) then
  246.       if (imet.le.2) then
  247.          if (irlog.eq.1) then
  248.             call ecrlog(lmet)
  249.          else
  250.             CALL ECRREE(XDENS)
  251.          endif
  252.       else
  253.          CALL ACTOBJ('CHPOINT',ICMETA,1)
  254.          CALL ECROBJ('CHPOINT',ICMETA)
  255.       endif
  256. *del      endif
  257.       CALL ACTOBJ('MAILLAGE',ITOPA,1)
  258.       CALL ECROBJ('MAILLAGE',ITOPA)
  259. *
  260. * Normal termination
  261. *
  262. *      write(ioimp,*) 'propto : sortie      =',OOOVAL(2,1)
  263.       RETURN
  264. *
  265. * Format handling
  266. *
  267.  186  FORMAT (2X,12(A6,'=',I6,2X))
  268.  188  FORMAT (2X,12(A6,'=',1PG12.5,2X))
  269. *
  270. * Error handling
  271. *
  272.  9999 CONTINUE
  273.       MOTERR(1:8)='PROPTO  '
  274. * 349 2
  275. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  276.       CALL ERREUR(349)
  277.       RETURN
  278. *
  279. * End of subroutine PROPTO
  280. *
  281.       END
  282.  
  283.  

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