Sources Esope | Cast3M

propto
C PROPTO    SOURCE    SP204843  26/02/03    21:15:35     12461          
      SUBROUTINE PROPTO
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : PROPTO
C DESCRIPTION : Une implémentation de l'amélioration d'une topologie
C               autour d'un élément. On reprend OPTITOPO pour le corps
C     du programme. On reprend l'extraction et la topologie inverse de
C     EXTO. Le point crucial sera d'implémenter la modification de la
C     topologie : enlever les anciens éléments et mettre les nouveaux.
C
C     Ici, on fait les entrées-sorties et on initialise le common avec
C     les options globales.
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
C               mél : 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            :
C ENTREES/SORTIES    :
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 04/10/2017, version initiale
C HISTORIQUE : v1, 04/10/2017, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
-INC PPARAM
-INC CCOPTIO
-INC TMATOP2
-INC SMELEME
      POINTEUR ITOPO.MELEME
      POINTEUR IELEM.MELEME
* TOPologie Améliorée
      POINTEUR ITOPA.MELEME
      POINTEUR IPVIRT.MELEME
-INC SMLOBJE
      POINTEUR LTOPA.MLOBJE
-INC SMLMOTS
-INC SMCHPOI
      POINTEUR ICMETR.MCHPOI,ICMTR2.MCHPOI
* METrique sur la topologie Améliorée
      POINTEUR ICMETA.MCHPOI,ICMTA2.MCHPOI
      integer oooval
      parameter(ncle=13)
      character*8 mtyp
      character*4 mcle(ncle)
      logical lmet
 
      data mcle /'IMPR','VERI','VTOL','QTOL','VIRT','SGAJ','ALGO'
     $     ,'AJNO','NCMA','STMA','MOYE','BARY','SEQM'/
*
* Executable statements
*
      impr=0
      IF (IMPR.Ge.5) WRITE(IOIMP,*) 'Entrée dans propto.eso'
*
*     Initialisation des données dans le common TMATOP2
*     Attention, il faut mettre les mêmes valeurs par défaut
*     que dans ryo2v et prtopv
*
      impr=0
      iveri=0
      isgadj=0
      xvtol=1.d-11
      qtol=1.d-2
      ipvirt=0
      imet=0
      imomet=0
      xdens=0.d0
      icmetr=0
      ialgo=0
      iajno=0
      incma=1000
      istma=0
      imobar=0
      iseqm=0
*      write(ioimp,*) 'propto : entree      =',OOOVAL(2,1)
* Entrees
      CALL LIROBJ('MAILLAGE',ITOPO,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',IELEM,1,IRETOU)
      IF (IERR.NE.0) RETURN
      CALL QUETYP(MTYP,0,IRET)
      if (iret.EQ.1) then
         if (MTYP.NE.'MOT     ') THEN
*
*     Lecture de la métrique voulue :
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)
*
            IF (MTYP.EQ.'LOGIQUE ') THEN
               call lirlog(lmet,1,IRLOG)
               IF (IERR.NE.0) RETURN
            ELSEIF (MTYP.EQ.'CHPOINT ') THEN
               CALL LIROBJ('CHPOINT',ICMETR,1,IRET)
               IF (IERR.NE.0) RETURN
               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
            elseif (MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER') then
               call lirree(XDENS,1,IRET)
               IF (IERR.NE.0) RETURN
               imet=2
            else
*  39 2
* On ne veut pas d'objet de type %m1:8
               MOTERR(1:8)=MTYP
               CALL ERREUR(39)
               RETURN
            endif
         endif
      endif
*
*     Mots-Clefs
*
 10   continue
      call lirmot(mcle,ncle,imot,0)
      if (imot.eq.1) then
         CALL LIRENT(impr,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.2) then
         CALL LIRENT(iveri,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.3) then
         CALL LIRREE(XVTOL,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.4) then
         CALL LIRREE(QTOL,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.5) then
         CALL LIROBJ('MAILLAGE',IPVIRT,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.6) then
         CALL LIRENT(isgadj,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.7) then
         CALL LIRENT(ialgo,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.8) then
         CALL LIRENT(iajno,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.9) then
         CALL LIRENT(incma,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.10) then
         CALL LIRENT(istma,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.11) then
         CALL LIRENT(imomet,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.12) then
         CALL LIRENT(imobar,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.eq.13) then
         CALL LIRENT(iseqm,1,IRET)
         IF (IERR.NE.0) RETURN
      elseif (imot.ne.0) then
         MOTERR(1:8)=MCLE(imot)
         Write(ioimp,*) MOTERR(1:8)
* Option indisponible
         CALL ERREUR(19)
         RETURN
      endif
      if (imot.ne.0) goto 10
*
* Test des paramètres
*
*!debug      if (impr.ge.3) then
      if (impr.ge.2) then
         write(ioimp,*) 'Opto parameters :'
         write(ioimp,186) 'impr',impr,'iveri',iveri,'ipvirt',ipvirt
     $        ,'imet',imet,'isgadj',isgadj,'ialgo',ialgo,'iajno',iajno
     $        ,'incma',incma,'istma',istma,'imomet',imomet,'imobar'
     $        ,imobar,'iseqm',iseqm
         write(ioimp,188) 'xvtol',xvtol,'qtol',qtol
      endif
*
*     Initialisation des sorties du common
*
      jparco=0
      jexplo=0
      jchang=0
      jnascm=0
* Traitement
* En moyenne géométrique, on passe en LOG avant OPTO1
      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
* Restituer le CHPOINT sur tous les noeuds ??
      CALL OPTO1(ITOPO,IELEM,IPVIRT,ICMTR2,
     $     ITOPA,ICMTA2,LTOPA)
      IF (IERR.NE.0) RETURN
      if (imomet.eq.1.and.icmta2.ne.0) then
         call ecrcha('EXP')
         call ecrobj('CHPOINT',ICMTA2)
         call prtens
         if (ierr.ne.0) return
         call lirobj('CHPOINT',ICMETA,1,IRET)
         if (ierr.ne.0) return
         if (icmta2.ne.icmtr2) segsup,icmta2
         segsup,icmtr2
      else
         ICMETA=ICMTA2
      endif
*     Sorties
      CALL ECRENT(JNASCM)
      CALL ECRENT(JPARCO)
      CALL ECRENT(JCHANG)
      CALL ECRENT(JEXPLO)
      if (imet.le.2) then
         if (irlog.eq.1) then
            call ecrlog(lmet)
         else
            CALL ECRREE(XDENS)
         endif
      else
         CALL ACTOBJ('CHPOINT',ICMETA,1)
         CALL ECROBJ('CHPOINT',ICMETA)
      endif
* del      endif
      CALL ACTOBJ('MAILLAGE',ITOPA,1)
      CALL ECROBJ('MAILLAGE',ITOPA)
      SEGACT LTOPA
      NOBJ=LTOPA.LISOBJ(/1)
      DO IOBJ=1,NOBJ
         MELEME=LTOPA.LISOBJ(IOBJ)
         CALL ACTOBJ('MAILLAGE',MELEME,1)
      ENDDO
      CALL ECROBJ('LISTOBJE',LTOPA)
*
* Normal termination
*
      RETURN
*
* Format handling
*
 186  FORMAT (2X,12(A6,'=',I6,2X))
 188  FORMAT (2X,12(A6,'=',1PG12.5,2X))
*
* Error handling
*
 9999 CONTINUE
      MOTERR(1:8)='PROPTO  '
* 349 2
*Problème non prévu dans le s.p. %m1:8 contactez votre assistance
      CALL ERREUR(349)
      RETURN
*
* End of subroutine PROPTO
*
      END