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

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