Télécharger la plaquette Cast3M


fr en

Télécharger topv3.eso

Retour à la liste

Numérotation des lignes : 

topv3

  1. C TOPV3     SOURCE    GOUNAND   25/11/24    21:15:21     12406          
  2. * On préférerait KEXTO à la place de TRAVK mais KEXTO n'est pas autoporteur.
  3.       SUBROUTINE TOPV3(TRAVK,KELEMX,IAJNO,TRAVL,INCMA,ISTMA,
  4.      $     JNASCM,ICBES,IPOPL2,iveri,impr)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.       IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM         : TOPV3
  9. C DESCRIPTION :
  10. *
  11. *     Génération des topologies candidates (stockage dans LMCANS indexé
  12. *     par LIDXCA) Issu de topv2_nettoie_final.eso
  13. *
  14. C
  15. C
  16. C LANGAGE     : ESOPE
  17. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  18. C               mél : gounand@semt2.smts.cea.fr
  19. C***********************************************************************
  20. C VERSION    : v1, 09/11/2017, version initiale
  21. C HISTORIQUE : v1, 09/11/2017, création
  22. C HISTORIQUE :
  23. C HISTORIQUE :
  24. C***********************************************************************
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC TMATOP1
  28. *-INC TMATOP2
  29. -INC CCREEL
  30. -INC SMELEME
  31.       POINTEUR KEXTO.MELEME
  32.       POINTEUR IBTLOC.MELEME
  33.       POINTEUR IPBTL2.MELEME
  34.       POINTEUR LMCANS.MELEMX
  35.       POINTEUR IPBTL.MELEMX
  36.       POINTEUR KELEMX.MELEMX
  37. -INC SMLENTI
  38.       POINTEUR KNNO.MLENTI
  39.       POINTEUR LIDXCA.MLENTI
  40. -INC SMLREEL
  41. -INC SMCOORD
  42.       POINTEUR TRAVK.TRAVJ
  43. *
  44.       LOGICAL LTOIBO
  45.       LOGICAL LTOIBA
  46.       LOGICAL LLIMCA
  47.       LOGICAL LCHANG
  48.       LOGICAL LCHTOP
  49. *
  50. * Executable statements
  51. *
  52. *      WRITE(IOIMP,*) 'coucou topv3'
  53.       KEXTO=TRAVK.TOPO
  54.       NKPVIR=TRAVK.PVIRT
  55. *
  56.       LMCANS=TRAVL.MCANS
  57.       LIDXCA=TRAVL.IDXCA
  58.       IPBTL=TRAVL.PBTL
  59. *     Les noeud S et S' de Gruau p.42
  60.       IARET=KELEMX.NNCOU
  61. *
  62.       IS=KELEMX.NUMX(1,1)
  63.       ISP=0
  64.       IS3=0
  65.       IS4=0
  66.       IF (IARET.EQ.2) ISP=KELEMX.NUMX(2,1)
  67.       IF (IARET.EQ.3) IS3=KELEMX.NUMX(3,1)
  68.       IF (IARET.EQ.4) IS4=KELEMX.NUMX(4,1)
  69. *
  70. * Le premier candidat est toujours l'original qui n'est pas forcément un étoilement
  71. *
  72.       NCCOUO=TRAVL.NCCOU
  73.       NLCOUO=LMCANS.NLCOU
  74.       NNC=NCCOUO+1
  75.       NNL=NLCOUO+TRAVK.NVCOU
  76.       CALL TRLADJ(TRAVL,NNC,NNL,lchang,'topv3 : TRAVL')
  77.       if (ierr.ne.0) return
  78.       IDX=LIDXCA.LECT(NNC)
  79.       DO IEL=1,TRAVK.NVCOU
  80.          DO INO=1,KEXTO.NUM(/1)
  81.             LMCANS.NUMX(INO,IDX)=KEXTO.NUM(INO,IEL)
  82.          ENDDO
  83.          IDX=IDX+1
  84.       ENDDO
  85.       LIDXCA.LECT(NNC+1)=IDX
  86.       ICBES=1
  87.       if (iveri.ge.2) then
  88.          call trlver(travl,'topv3 : Apres initialisation KEXTO')
  89.          if (ierr.ne.0) return
  90.       endif
  91. * Extraction du bord (contour ou enveloppe)
  92. *      write(ioimp,*) 'Avant extraction bord'
  93.       IF (IDIM.EQ.2) THEN
  94.          IELDEB=1
  95.          IELFIN=TRAVK.NVCOU
  96.          ICPR=0
  97.          IDCP=0
  98.          NPLOC=TRAVK.NPCOU
  99. *         ITYCON=1
  100.          ITYCON=3
  101.          INOID=1
  102.          CALL CONTOU(KEXTO,IELDEB,IELFIN,ICPR,IDCP,NPLOC,ITYCON,INOID
  103.      $        ,IBTLOC)
  104.          IF (IERR.NE.0) RETURN
  105.          SEGACT IBTLOC
  106.       ELSEIF (IDIM.EQ.3) THEN
  107. *
  108.          IELDEB=1
  109.          IELFIN=TRAVK.NVCOU
  110.          ICLE=0
  111.          INOID=1
  112.          CALL ENVVO3(KEXTO,IELDEB,IELFIN,ICLE,INOID,IBTLOC)
  113.          IF (IERR.NE.0) RETURN
  114.       ELSE
  115. * 709 2
  116. *Fonction indisponible en dimension %i1.
  117.          INTERR(1)=IDIM
  118.          CALL ERREUR(709)
  119.       ENDIF
  120.       IF (IERR.NE.0) RETURN
  121.       if (impr.ge.4) then
  122.          write(ioimp,*) 'NKPVIR=',NKPVIR
  123.          write(ioimp,*) 'Apres extraction bord IBTLOC=',IBTLOC
  124.          WRITE(IOIMP,*) 'IBTLOC'
  125.          CALL ECMAI1(ibtloc,0)
  126.          SEGACT IBTLOC
  127.       endif
  128. *
  129.       NLBTL=IBTLOC.NUM(/2)
  130. * Il arrive quelquefois que la topologie locale n'ait pas de bord
  131.       IF (NLBTL.GT.0) THEN
  132. * Si la topologie locale n'a qu'un seul élément, il n'est pas nécessaire
  133. * de l'étoiler
  134.          NLTLOC=TRAVK.NVCOU
  135. *
  136.          LTOIBO=(NLTLOC.GT.1)
  137.          LTOIBA=(IAJNO.NE.0)
  138. * Si on doit etoiler, on contruit le maillage des points du bord
  139. * = chan IBTLOC 'POI1'
  140. * on applique ici une méthode locale en O(n^2) ce qui suppose que IBTLOC
  141. * n'a pas trop de points...
  142.          IF (LTOIBO.OR.LTOIBA) THEN
  143.             KNNO=TRAVK.NNO
  144.             NBELEM=IBTLOC.NUM(/2)
  145.             NBNN=IBTLOC.NUM(/1)
  146.             IK=0
  147.             DO IBELEM=1,NBELEM
  148.                DO IBNN=1,NBNN
  149.                   INO=IBTLOC.NUM(IBNN,IBELEM)
  150.                   if (ino.eq.0) then
  151.                      write(ioimp,*) 'Noeud nul détecté !!!!'
  152.                      WRITE(IOIMP,*) 'KEXTO'
  153.                      call ecmai1(kexto,0)
  154.                      WRITE(IOIMP,*) 'IBTLOC'
  155.                      CALL ECMAI1(ibtloc,0)
  156.                      goto 9999
  157.                   endif
  158.                   IF (KNNO.LECT(INO).EQ.0) THEN
  159.                      IK=IK+1
  160.                      KNNO.LECT(INO)=IK
  161.                   ENDIF
  162.                ENDDO
  163.             ENDDO
  164.             CALL mlxadl(IPBTL,IK,lchang,'topv3 : IPBTL_IK')
  165.             if (ierr.ne.0) return
  166.             if (iveri.ge.2) then
  167.                call vemelx(ipbtl,'topv3 : Apres requisition ipbtl')
  168.                if (ierr.ne.0) return
  169.             endif
  170. * On regarde également si IS ou ISP font partie du bord
  171.             IS2=IS
  172.             ISP2=ISP
  173.             IS32=IS3
  174.             IS42=IS4
  175.             DO IIPO=1,TRAVK.NPCOU
  176.                INLOC=KNNO.LECT(IIPO)
  177.                IF (INLOC.NE.0) THEN
  178.                   IPBTL.NUMX(1,INLOC)=IIPO
  179.                   IF (IS2.EQ.IIPO) IS2=0
  180.                   IF (ISP2.EQ.IIPO) ISP2=0
  181.                   IF (IS32.EQ.IIPO) IS32=0
  182.                   IF (IS42.EQ.IIPO) IS42=0
  183. *     Nettoyage de KNNO
  184.                   KNNO.LECT(IIPO)=0
  185.                ENDIF
  186.             ENDDO
  187. * Vérification du nettoyage de KNNO
  188.             if (iveri.ge.2) then
  189.                call vetopi(travk,
  190.      $              'topv3 : Apres creation points du bord')
  191.                if (ierr.ne.0) return
  192.             endif
  193.             IF (IVERI.GE.2.and..false.) THEN
  194. * à corriger pour le nouveau ipbtl en melemx
  195.                IPBTL2=IBTLOC
  196.                CALL CHANGE(IPBTL2,1)
  197.                SEGACT IBTLOC
  198.                CALL OUEXCL(IPBTL,IPBTL2,IPT3)
  199.                IF (IERR.NE.0) RETURN
  200.                SEGACT IPBTL
  201.                SEGACT MCOORD*MOD
  202.                IF (IPT3.NE.0) THEN
  203.                   WRITE(IOIMP,*) 'IPT3 pour IPBTL'
  204.                   CALL ECMAI1(IPT3,0)
  205.                   IF (IERR.NE.0) RETURN
  206.                   WRITE(IOIMP,*) 'NEL1=',IPBTL.NLCOU
  207.                   CALL ECMELX(IPBTL,0)
  208.                   SEGACT IPBTL2
  209.                   WRITE(IOIMP,*) 'NEL2=',IPBTL2.NUM(/2)
  210.                   CALL ECMAI1(IPBTL2,0)
  211.                   CALL ERREUR(5)
  212.                   RETURN
  213.                ENDIF
  214.             ENDIF
  215. * On étoile à partir des éléments du bord
  216.             IF (LTOIBO) THEN
  217. * On étoile à partir de S ou S' s'ils ne font pas partie du bord
  218.                DO IBIS=1,4
  219.                   IF (IBIS.EQ.1) THEN
  220.                      NODE=IS2
  221.                      MOTERR(1:4)='IS2 '
  222.                   ELSEIF (IBIS.EQ.2) THEN
  223.                      NODE=ISP2
  224.                      MOTERR(1:4)='ISP2'
  225.                   ELSEIF (IBIS.EQ.3) THEN
  226.                      NODE=IS32
  227.                      MOTERR(1:4)='IS32'
  228.                   ELSEIF (IBIS.EQ.4) THEN
  229.                      NODE=IS42
  230.                      MOTERR(1:4)='IS42'
  231.                   ELSE
  232.                      write(ioimp,*) 'pb boucle ibis'
  233.                      goto 9999
  234.                   ENDIF
  235.                   IF (NODE.NE.0) THEN
  236. *
  237.                      CALL ETOIL2(NODE,IBTLOC,TRAVL)
  238.                      IF (IERR.NE.0) RETURN
  239.                      if (iveri.ge.2) then
  240.                         call trlver(travl
  241.      $                       ,'topv3 : Apres etoil2, IBIS')
  242.                         if (ierr.ne.0) return
  243.                      endif
  244.                      ncc=travl.nccou
  245.                      if (lidxca.lect(ncc+1).eq.lidxca.lect(ncc)) goto
  246.      $                    666
  247.                   ENDIF
  248.                ENDDO
  249.                NPBTL=IPBTL.NLCOU
  250. *     WRITE(IOIMP,*) 'NPBTL=',NPBTL
  251.                IF (NPBTL.GT.INCMA) THEN
  252.                   LLIMCA=.TRUE.
  253.                   JNASCM=JNASCM+1
  254.                   IF (ISTMA.EQ.0) THEN
  255.                      NPBTLR=0
  256.                      LTOIBA=.FALSE.
  257.                   ELSEIF (ISTMA.EQ.1) THEN
  258.                      NPBTLR=1
  259.                      JNPBTL=(NPBTL+1)/2
  260.                   ELSEIF (ISTMA.EQ.2) THEN
  261. * Attention overflow potentiel...
  262.                      NPBTLR=MAX(1,NINT(INCMA*(DBLE(INCMA)/DBLE(NPBTL))))
  263.                      JNPBTL=(NPBTL+1)/2
  264.                   ELSE
  265.                      WRITE(IOIMP,*) 'ISTMA=',ISTMA,' non prevu'
  266.                      GOTO 9999
  267.                   ENDIF
  268.                   if (impr.ge.2) then
  269.                      write(ioimp,*) 'topv3 : reduction nb cand de '
  270.      $                    ,NPBTL,' a ',NPBTLR
  271.                   endif
  272.                ELSE
  273.                   LLIMCA=.FALSE.
  274.                   NPBTLR=NPBTL
  275.                ENDIF
  276.  
  277.                DO INPBTL=1,NPBTLR
  278.                   IF (.NOT.LLIMCA) THEN
  279.                      NODE=IPBTL.NUMX(1,INPBTL)
  280.                   ELSE
  281.                      IF (ISTMA.EQ.1) THEN
  282.                         NODE=IPBTL.NUMX(1,JNPBTL)
  283.                      ELSEIF (ISTMA.EQ.2) THEN
  284.                         IF (NPBTLR.NE.1) JNPBTL=1+NINT((NPBTLR-1)
  285.      $                       *(DBLE(INPBTL-1)/DBLE(NPBTLR-1)))
  286.                         NODE=IPBTL.NUMX(1,JNPBTL)
  287.                      ELSE
  288.                         WRITE(IOIMP,*) 'ISTMA=',ISTMA,' non prevu 2'
  289.                         GOTO 9999
  290.                      ENDIF
  291.                   ENDIF
  292.  
  293. *            WRITE(IOIMP,*) 'INPBTL=',INPBTL,' NODE=',NODE
  294.                   MOTERR(1:4)='NBOR'
  295. *
  296. *                  write(ioimp,*) 'lmcans avant'
  297. *                  call ecmelx(lmcans,0)
  298.                   CALL ETOIL2(NODE,IBTLOC,TRAVL)
  299.                   IF (IERR.NE.0) RETURN
  300. *                  write(ioimp,*) 'lmcans apres'
  301. *                  call ecmelx(lmcans,0)
  302.                   if (iveri.ge.2) then
  303.                      call trlver(travl
  304.      $                    ,'topv3 : Apres etoil2, INPBTL')
  305.                      if (ierr.ne.0) return
  306.                   endif
  307.                   ncc=travl.nccou
  308.                   if (lidxca.lect(ncc+1).eq.lidxca.lect(ncc)) goto
  309.      $                 666
  310.                ENDDO
  311.             ENDIF
  312.             IF (LTOIBA) THEN
  313. * Cas 1 : on étoile avec l'isobarycentre du contour
  314.                IF (IARET.EQ.1) THEN
  315. *! NO    !              CALL BARYC5(IPBTL,KPVIRT,TRAVK,NODE)
  316. *                  CALL BARYC5(IPBTL,0,TRAVK,NODE)
  317.                   CALL BARYC5(IPBTL,NKPVIR,TRAVK,NODE)
  318.                   MOTERR(1:4)='BARC'
  319. * Cas 2 : on étoile avec l'isobarycentre de S et S'
  320.                ELSEIF (IARET.EQ.2) THEN
  321. * !NO :)                  CALL BARYC5(KELEMX,0,TRAVK,NODE)
  322.                   CALL BARYC5(KELEMX,NKPVIR,TRAVK,NODE)
  323.                   MOTERR(1:4)='BARS'
  324. * Cas 3 ajout 2017/08/22
  325.                ELSEIF (IARET.EQ.3) THEN
  326.                   CALL BARYC5(KELEMX,NKPVIR,TRAVK,NODE)
  327.                   MOTERR(1:4)='BAR3'
  328. * Cas 4 ajout 2017/08/22
  329.                ELSEIF (IARET.EQ.4) THEN
  330.                   CALL BARYC5(KELEMX,NKPVIR,TRAVK,NODE)
  331.                   MOTERR(1:4)='BAR4'
  332.                ELSE
  333.                   Write(ioimp,*) 'iaret=',iaret
  334.                   call erreur(5)
  335.                   return
  336.                ENDIF
  337.                IF (IERR.NE.0) RETURN
  338. *
  339.                if (impr.ge.3) then
  340.                   write(ioimp,*) 'Etoilement avec :',moterr(1:4)
  341.      $                 ,' NODE=',NODE
  342.                endif
  343.                CALL ETOIL2(NODE,IBTLOC,TRAVL)
  344.                IF (IERR.NE.0) RETURN
  345.                if (iveri.ge.2) then
  346.                   call trlver(travl
  347.      $                 ,'topv3 : Apres etoil2, BARYC')
  348.                   if (ierr.ne.0) return
  349.                endif
  350.                ipopl2=travl.nccou
  351.                ncc=travl.nccou
  352.                if (lidxca.lect(ncc+1).eq.lidxca.lect(ncc)) goto
  353.      $              666
  354.             ENDIF
  355. *     SEGSUP IPBTL
  356. * Ne le faire que si iveri=1 ?
  357.             if (iveri.ge.1) then
  358.                DO IZER=1,IPBTL.NLCOU
  359.                   IPBTL.NUMX(1,IZER)=0
  360.                ENDDO
  361.             endif
  362.             CALL mlxadl(IPBTL,0,lchang,'topv3 : IPBTL_0')
  363.             if (ierr.ne.0) return
  364.             if (iveri.ge.2) then
  365.                call vemelx(ipbtl,'topv3 : Apres nettoyage ipbtl')
  366.                if (ierr.ne.0) return
  367.             endif
  368.          ENDIF
  369.       ENDIF
  370.       SEGSUP IBTLOC
  371.       RETURN
  372. *
  373. *
  374. *
  375.  9999 CONTINUE
  376.       MOTERR(1:8)='TOPV3   '
  377. * 349 2
  378. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  379.       CALL ERREUR(349)
  380.       RETURN
  381.  666  CONTINUE
  382.       WRITE(IOIMP,*) 'topv3 : Pb candidat ',MOTERR(1:4)
  383. *a upgrader      CALL ECMAI1(IMCAND,0)
  384.       WRITE(IOIMP,*) 'KEXTO'
  385.       CALL ECMAI1(KEXTO,0)
  386.       WRITE(IOIMP,*) 'IBTLOC'
  387.       CALL ECMAI1(IBTLOC,0)
  388.       WRITE(IOIMP,*) 'IPBTL'
  389.       CALL ECMELX(IPBTL,0)
  390.       WRITE(IOIMP,*) 'NODE=',NODE
  391.       CALL ERREUR(5)
  392.       RETURN
  393. *
  394. * End of subroutine TOPV3
  395. *
  396.       END
  397.  
  398.  

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