Télécharger la plaquette Cast3M


fr en

Télécharger opto2.eso

Retour à la liste

Numérotation des lignes : 

opto2

  1. C OPTO2     SOURCE    GOUNAND   26/06/09    21:15:10     12566          
  2.       SUBROUTINE OPTO2(TRAVJ,JELEM,LTOPA)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : OPTO2 (anciennement optt2c)
  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
  14. C     Ici, on est en numérotation locale et on fait l'extraction de la
  15. C     topologie proprement dite, son optimisation puis sa mise à jour.
  16. C     Les segments transmis sont supposés activés en *MOD
  17. C
  18. C     Le point important est de construire la topologie inverse.
  19. C
  20. C     Le début est identique à exto2.eso
  21. C
  22. C     Repris de optt2b : on raccourcit la subroutine en externalisant
  23. C     des opérations en subroutines.
  24. C
  25. C LANGAGE     : ESOPE
  26. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
  27. C               mél : gounand@semt2.smts.cea.fr
  28. C***********************************************************************
  29. C APPELES          : EXTO4C, OPTO3
  30. C APPELES (E/S)    :
  31. C APPELES (BLAS)   :
  32. C APPELES (CALCUL) :
  33. C APPELE PAR       : OPTO1
  34. C***********************************************************************
  35. C SYNTAXE GIBIANE    :
  36. C ENTREES            : JELEM
  37. C ENTREES/SORTIES    : JCOORD, JTOPO
  38. C SORTIES            :
  39. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  40. C***********************************************************************
  41. C VERSION    : v1, 17/10/2017, version initiale
  42. C HISTORIQUE : v1, 17/10/2017, création
  43. C HISTORIQUE :
  44. C HISTORIQUE :
  45. C***********************************************************************
  46. -INC PPARAM
  47. -INC CCOPTIO
  48. -INC TMATOP2
  49. -INC SMLENTI
  50.       POINTEUR JNBL.MLENTI
  51.       POINTEUR JNNO.MLENTI,KNNO.MLENTI
  52.       POINTEUR NEXTO.MLENTI
  53. -INC SMELEME
  54. *
  55. *     Le nombre d'éléments de JTOPO et le nombre de points de JCOORD
  56. *     vont être variables. Pour ne pas avoir à ajuster ces segments en
  57. *     permanence, on va dimensionner plus large, mais du coup, il faut
  58. *     aussi maintenir à la main le nombre de noeuds et d'éléments
  59. *     courants.
  60. *
  61. *     Le nombre d'éléments courants est NVCOU et le nombre d'éléments
  62. *     max est NVMAX. Idem pour le nombre de noeuds courants et max :
  63. *     NPCOU et NPMAX.
  64. *
  65. * Numerotation locale des éléments JTOPO.NUM(NBNN,NBELEM)
  66. *      INTEGER NVCOU,NVMAX
  67.       POINTEUR JTOPO.MELEME
  68. *del      POINTEUR KTOPO.MELEME
  69.       POINTEUR JELEM.MELEME
  70.       POINTEUR JELEM1.MELEME
  71.       POINTEUR JEXTO.MELEME,KEXTO.MELEME
  72.       POINTEUR JTBES.MELEME
  73. -INC SMLOBJE
  74.       POINTEUR LTOPA.MLOBJE
  75. -INC SMCOORD
  76. * Numerotation locale (de 1 à NBPTS)
  77. *      INTEGER NPCOU,NPMAX
  78. *del      POINTEUR JCOORD.MCOORD
  79.       POINTEUR KCOORD.MCOORD
  80. -INC TMATOP1
  81. *-INC STOPINV
  82. *-INC SMETRIQ
  83.       POINTEUR JCMETR.METRIQ
  84.       POINTEUR KCMETR.METRIQ
  85. *-INC STRAVJ
  86.       POINTEUR TRAVK.TRAVJ
  87. *-INC STRAVL
  88. -INC SMLMOTS
  89.       POINTEUR JNMETR.MLMOTS
  90.       POINTEUR KNMETR.MLMOTS
  91. *
  92.       POINTEUR TRAVX.TRAVJ
  93. *
  94. *-INC SMLENTX
  95.       POINTEUR ICPRX.MLENTX
  96.       POINTEUR IDCPX.MLENTX
  97.       POINTEUR ICPR2.MLENTX
  98.       POINTEUR IDCP2.MLENTX
  99. *-INC SMELEMX
  100.       POINTEUR KELEMX.MELEMX
  101.       POINTEUR JELEM2.MELEMX
  102. *
  103.       logical lchang
  104.       CHARACTER*60 CFORM
  105.       character*6 SUBRN
  106. *
  107. * Executable statements
  108. *
  109. *      if (impr.ge.5) WRITE(IOIMP,*) 'Entrée dans opto2.eso'
  110. *
  111. * Initialisation et extension des segments JTOPO et JCOORD
  112. *
  113.       IDIMP=IDIM+1
  114.  
  115.       JTOPO=TRAVJ.TOPO
  116. *
  117. * Initialisation de la topologie inverse
  118. *
  119. *      CALL INTOPI(NVMAX,NPMAX,TOPINV,IMPR)
  120.       CALL INTOP2(TRAVJ,IMPR)
  121.       IF (IERR.NE.0) RETURN
  122. *
  123. * Remplissage de la topologie inverse avec JTOPO
  124. *
  125. *      CALL RETOPI(JTOPO,NVCOU,TOPINV,IMPR)
  126.       CALL RETOP2(TRAVJ,IMPR)
  127.       IF (IERR.NE.0) RETURN
  128. *
  129.       if (.false.) then
  130.          TOPINV=TRAVJ.TOPI
  131.          call ectopi(TOPINV,1)
  132. *         call ectopi(TOPINV,2)
  133.       endif
  134. *
  135. * Initialisation LTOPA
  136. *
  137.       NOBJ=0
  138.       NREE=0
  139.       SEGINI LTOPA
  140.       LTOPA.TYPOBJ='MAILLAGE'
  141. *
  142. * Segment de travail pour l'extraction des éléments
  143. *
  144.       JG=NVMAX
  145.       SEGINI JNBL
  146.       TRAVJ.NBL=JNBL
  147.       JG=NPMAX-NPINI
  148.       SEGINI JNNO
  149.       TRAVJ.NNO=JNNO
  150. *
  151. * Extraction de la topologie à optimiser
  152. *
  153. *     NELMOY=40
  154.       IF (IDIM.EQ.2) THEN
  155.          NELMOY=15
  156.          NPOMOY=10
  157.       ELSEIF (IDIM.EQ.3) THEN
  158.          NELMOY=40
  159.          NPOMOY=12
  160. *         NELMOY=40
  161. *         NPOMOY=25
  162.       ELSE
  163.          write(ioimp,*) 'idim=',idim
  164.          goto 9999
  165.       ENDIF
  166. *
  167. *!!!   A changer plus tard
  168. *
  169. *      NVXMAX=0
  170.       SEGINI TRAVX
  171. *old      if (isgadj.gt.0) write(ioimp,185) 'TRAVJ,TRAVX=',TRAVJ,TRAVX
  172.       TRAVX.NVINI=0
  173.       TRAVX.NVCOU=0
  174.       TRAVX.NVMAX=NELMOY
  175. *      TRAVX.NVMAX=0
  176.       JG=TRAVX.NVMAX
  177.       SEGINI NEXTO
  178.       TRAVX.NBL=NEXTO
  179. *
  180.  
  181.       NBNN=IDIMP
  182.       NBELEM=TRAVX.NVMAX
  183.       NBSOUS=0
  184.       NBREF=0
  185.       SEGINI JEXTO
  186.       JEXTO.ITYPEL=JTOPO.ITYPEL
  187.       TRAVX.TOPO=JEXTO
  188. *     Boucle sur les éléments
  189. *      write(ioimp,*) 'opto2 jelem(nno,nbnn=)',jelem.num(/1)
  190. *     $     ,jelem.num(/2)
  191.       NBNN1=JELEM.NUM(/1)
  192.       NBNN=NBNN1
  193.       NBELEM=1
  194.       NBSOUS=0
  195.       NBREF=0
  196.       SEGINI JELEM1
  197.       JELEM1.ITYPEL=JELEM.ITYPEL
  198.  
  199. *     Segment de travail TRAVK pour opto3 numérotation locale à
  200. *     l'élément extrait.
  201.       SEGINI TRAVK
  202.       TRAVK.NVINI=0
  203.       TRAVK.NVCOU=0
  204.       TRAVK.NVMAX=NELMOY
  205. * Important pour le segment NNO après
  206.       TRAVK.NPINI=0
  207.       TRAVK.NPCOU=0
  208.       TRAVK.NPMAX=NPOMOY
  209. * Topologie de TRAVK (KEXTO)
  210.       NBELEM=TRAVK.NVMAX
  211.       NBNN=IDIMP
  212.       NBSOUS=0
  213.       NBREF=0
  214.       SEGINI,KEXTO
  215.       KEXTO.ITYPEL=JEXTO.ITYPEL
  216.       TRAVK.TOPO=KEXTO
  217. *     Coordonnées de TRAVK (KCOORD)
  218.       NBPTS=TRAVK.NPMAX
  219.       SEGINI,KCOORD
  220.       TRAVK.COORD=KCOORD
  221.       JNMETR=TRAVJ.NMETR
  222.       IF (JNMETR.NE.0) THEN
  223.          SEGINI,KNMETR=JNMETR
  224.          TRAVK.NMETR=KNMETR
  225.       ENDIF
  226.       JCMETR=TRAVJ.CMETR
  227.       IF (JCMETR.NE.0) THEN
  228.          NNIN=JCMETR.XIN(/1)
  229.          NNNOE=TRAVK.NPMAX
  230.          SEGINI,KCMETR
  231.          TRAVK.CMETR=KCMETR
  232.       ENDIF
  233. *
  234. *     Segment de travail pour trouver les noeuds du contour ou de
  235. *     l'enveloppe pour étoiler dans topv2
  236. *
  237.       JG=TRAVK.NPMAX-TRAVK.NPINI
  238.       SEGINI KNNO
  239.       TRAVK.NNO=KNNO
  240. *     Segment de travail TRAVL pour topv2
  241.       NNM=JEXTO.NUM(/1)
  242.       ITYP=JEXTO.ITYPEL
  243. *del         CALL TRLINI(NELMOY,JEXTO.NUM(/1),JEXTO.ITYPEL,TRAVL)
  244.       CALL TRLINI(NELMOY,NNM,ITYP,TRAVL)
  245.       if (iveri.ge.2) then
  246.          call trlver(travl,'opto2 : Apres initialisation TRAVL')
  247.          if (ierr.ne.0) return
  248.       endif
  249. *
  250. *     Segment de travail pour le changement de numérotation dans opto3
  251. *
  252.       JGMAX=NPOMOY
  253.       SEGINI ICPRX
  254.       CALL mtxadj(ICPRX,0,lchang,'opto2 : ICPRX_INI')
  255.       if (ierr.ne.0) return
  256.       SEGINI IDCPX
  257.       CALL mtxadj(IDCPX,0,lchang,'opto2 : IDCPX_INI')
  258.       if (ierr.ne.0) return
  259. *
  260. *     Segment de travail pour jelem en numérotation très locale dans
  261. *     opto3. Ce segment a un élément et peut-être moins de noeuds que JELEM1
  262. *
  263.       NNMAX=JELEM.NUM(/1)
  264.       NLMAX=1
  265.       SEGINI KELEMX
  266.       KELEMX.ITYPEX=JELEM.ITYPEL
  267.       KELEMX.NLCOU=1
  268. *
  269. *   Segments de travail pour le voisinage des elements
  270. *
  271.       JGMAX=NPOMOY
  272.       SEGINI ICPR2
  273.       CALL mtxadj(ICPR2,0,lchang,'opto2 : ICPR2_INI')
  274.       if (ierr.ne.0) return
  275.       SEGINI IDCP2
  276.       CALL mtxadj(IDCP2,0,lchang,'opto2 : IDCP2_INI')
  277.       if (ierr.ne.0) return
  278.       NNMAX=1
  279.       NLMAX=NPOMOY
  280.       SEGINI JELEM2
  281.       JELEM2.ITYPEX=JELEM.ITYPEL
  282.       CALL mlxadl(JELEM2,0,lchang,'opto2 : JELEM2_INI')
  283.       if (ierr.ne.0) return
  284.  
  285.       NBNNT=JTOPO.NUM(/1)
  286.       TOPINV=TRAVJ.TOPI
  287. *
  288.  125  format ('(A,1X,I3,1X,A,2(1X,I3),20(2X,''[''',I1,'I3,'']''))')
  289.       DO IAPARC=1,JELEM.NUM(/2)
  290.          DO IBNN=1,NBNN1
  291.             JELEM1.NUM(IBNN,1)=JELEM.NUM(IBNN,IAPARC)
  292.          ENDDO
  293.          JPARCO=JPARCO+1
  294.          IF (IMPR.GE.4) THEN
  295.             nnod=jelem1.num(/1)
  296.             nel=1
  297.             write(cform,125) nnod
  298.             write(ioimp,cform)
  299.      $        'opto2 : autour de l''element',iaparc,'nnod,nel=',nnod
  300.      $        ,nel,((jelem1.num(ino,iel),ino=1,nnod),iel=1,nel)
  301. *            write(ioimp,*) '  opto2 : Autour de l''element ',iaparc
  302. *            call ecmai1(jelem1,0)
  303. *            segact jelem1*mod
  304.          ENDIF
  305. * On fait le voisinage de Gruau uniquement pour les noeuds en 2D
  306. * et les noeuds et les aretes un 3D.
  307. * Sinon, on fait l'ancienne manière. C'est un test parce que la
  308. * méthode Gruau n'est pas terrible dans les coins.
  309.  
  310.          IF (IALGO.EQ.0) THEN
  311. *     $        (IALGO.EQ.1.AND.IDIM.EQ.2.AND.NBNN1.LT.1).OR.
  312. *     $        (IALGO.EQ.1.AND.IDIM.EQ.3.AND.NBNN1.LT.1)
  313. *     $        ) THEN
  314. *         IF (IALGO.EQ.0.OR.(IALGO.EQ.1.AND.NBNN1.LT.IDIM)) THEN
  315. *         IF (NBNN1.LT.IDIM+1) THEN
  316. *         IF (.false.) THEN
  317.             subrn='exto5c'
  318. *     Voisinages des noeuds de JELEM1
  319.             NCOU=TRAVJ.NPCOU
  320.             CALL mtxadj(ICPR2,NCOU,lchang,'opto2 : ICPR2_dim')
  321.             if (ierr.ne.0) return
  322.             IIDCP2=0
  323. *     Voisinage pour chaque noeud
  324.             DO IBNN=1,NBNN1
  325.                INOD=JELEM1.NUM(IBNN,1)
  326.                IVAL=2**(IBNN-1)
  327. *       Parcours de la topologie inverse et cochage dans ICPR2
  328.                LAST=TIC(INOD)
  329.                LDG=TDC(INOD)
  330.                DO IDG=1,LDG
  331.                   IL=((LAST-1)/IDIMP)+1
  332.                   DO IBNNT=1,NBNNT
  333.                      IN=JTOPO.NUM(IBNNT,IL)
  334.                      IF (IN.NE.INOD) THEN
  335.                         ITOUCH=ICPR2.LECTX(IN)
  336.                         IF (ITOUCH.LT.IVAL) THEN
  337.                            ICPR2.LECTX(IN)=ITOUCH+IVAL
  338.                            IF (ITOUCH.EQ.0) THEN
  339.                               IIDCP2=IIDCP2+1
  340.                               CALL mtxadj(IDCP2,IIDCP2,lchang,'opto2 :
  341.      $                             IDCP2_dim')
  342.                               if (ierr.ne.0) return
  343.                               IDCP2.LECTX(IIDCP2)=IN
  344.                            ENDIF
  345.                         ENDIF
  346.                      ENDIF
  347.                   ENDDO
  348.                   LAST=TLC(LAST)
  349.                ENDDO
  350.             ENDDO
  351.             NIDCP2=IIDCP2
  352. *     JELEM2 a au moins les noeuds de JELEM1
  353.             NBNN=NBNN1
  354. *     segprt,icpr2
  355. *     Intersection des voisinages
  356.             IVAL=(2**NBNN1)-1
  357.             NIDCP2=IIDCP2
  358.             DO IIDCP2=1,NIDCP2
  359.                IN=IDCP2.LECTX(IIDCP2)
  360.                IF (ICPR2.LECTX(IN).eq.IVAL) THEN
  361.                   NBNN=NBNN+1
  362.                ENDIF
  363.             ENDDO
  364. *
  365.             call mlxadl(JELEM2,NBNN,lchang,'opto2 : JELEM2_NBNN')
  366.             if (ierr.ne.0) return
  367.             if (iveri.ge.2) then
  368.                call vemelx(jelem2,'opto2 : Apres requisition jelem2')
  369.                if (ierr.ne.0) return
  370.             endif
  371.  
  372.             ibnn=0
  373.             do i=1,nbnn1
  374.                ibnn=ibnn+1
  375.                jelem2.numx(1,ibnn)=jelem1.num(ibnn,1)
  376.             enddo
  377.             DO IIDCP2=1,NIDCP2
  378.                IN=IDCP2.LECTX(IIDCP2)
  379.                IF (ICPR2.LECTX(IN).eq.IVAL) THEN
  380.                   ibnn=ibnn+1
  381.                   jelem2.numx(1,ibnn)=IN
  382.                ENDIF
  383.                icpr2.lectx(IN)=0
  384.             ENDDO
  385.             IF (IMPR.GE.6) THEN
  386.                write(ioimp,*)
  387.      $              '  opto2 : Noeuds du voisinage de l''element '
  388.      $              ,iaparc
  389.                call ecmelx(jelem2,0)
  390.             ENDIF
  391. *
  392.             if (iveri.ge.2) call vetopi(travj,'Avant exto5c')
  393.             if (ierr.ne.0) return
  394. *
  395.             CALL EXTO5c(JELEM2,TRAVJ,
  396.      $           TRAVX)
  397. * Menage JELEM2
  398.             if (iveri.ge.2) then
  399.                DO IZER=1,JELEM2.NLCOU
  400.                   JELEM2.NUMX(1,IZER)=0
  401.                ENDDO
  402.             endif
  403.             CALL mlxadl(JELEM2,0,lchang,'opto2 : JELEM2_0')
  404.             if (ierr.ne.0) return
  405.             if (iveri.ge.2) then
  406.                call vemelx(jelem2,'opto2 : Apres nettoyage jelem2')
  407.                if (ierr.ne.0) return
  408.             endif
  409. *     verif que NBL est bien nettoyé
  410.             if (iveri.ge.2) call vetopi(travj,'Apres exto5c')
  411.             if (ierr.ne.0) return
  412.          ELSE
  413.             subrn='exto4c'
  414.             if (iveri.ge.2) call vetopi(travj,'Avant exto4')
  415.             if (ierr.ne.0) return
  416. *
  417.             CALL EXTO4c(JELEM1,TRAVJ,
  418.      $           TRAVX)
  419. *     verif que NBL est bien nettoyé
  420.             if (iveri.ge.2) call vetopi(travj,'Apres exto4')
  421.             if (ierr.ne.0) return
  422.          ENDIF
  423. *tst      write(ioimp,*) 'Elements de la topologie extraits :'
  424. *tst      write(ioimp,187) (nexto(I),I=1,travx.nvcou)
  425. *     Mise à jour de jexto
  426.          nexto=travx.nbl
  427.          jexto=travx.topo
  428.          nel=travx.nvcou
  429.          if (impr.ge.4) then
  430.             write(ioimp,'(A,I5,1X,A,1X,A,1X,A,1X,20(1X,I3))')
  431.      $           'opto2 :',nel
  432.      $           ,'element(s) de la topologie extraits avec',subrn,':'
  433.      $           ,(nexto.lect(iel),iel=1,nel)
  434.          endif
  435. *
  436. *!         segact,jexto*mod
  437.          do iel=1,travx.nvcou
  438.             do ino=1,IDIMP
  439. *               write(ioimp,*) 'iel,ino,nexto=',iel,ino,nexto.lect(iel)
  440.                JEXTO.NUM(ino,iel)=JTOPO.NUM(INO,nexto.lect(iel))
  441.             enddo
  442.          enddo
  443. *
  444. * Optimisation de la topologie extraite
  445. *
  446.  126     format ('(A,1X,2(1X,I3),20(2X,''[''',I1,'I3,'']''))')
  447.          IF (IMPR.GE.4) THEN
  448.             nnod=jexto.num(/1)
  449.             nel=travx.nvcou
  450.             write(cform,126) nnod
  451.             write(ioimp,cform)
  452.      $        'opto2 : on a extrait la topologie nnod,nel=',nnod
  453.      $        ,nel,((jexto.num(ino,iel),ino=1,nnod),iel=1,nel)
  454. *            write(ioimp,*) 'opto2.eso : on a extrait la topologie : '
  455. *            call ecmai1(jexto,0)
  456. *            segact jexto
  457.          ENDIF
  458. *
  459. *     Init
  460. *
  461.          CALL OPTO3(TRAVJ,TRAVX,JELEM1,TRAVK,TRAVL,ICPRX,IDCPX,
  462.      $        KELEMX,
  463.      $        JTBES,JCAND)
  464.          IF (IERR.NE.0) RETURN
  465.          if (iveri.ge.2) call vetopi(travj,'Apres opto3')
  466.          IF (IERR.NE.0) RETURN
  467.  
  468.          JEXPLO=JEXPLO+ABS(JCAND)
  469.          IF (IMPR.GE.4) THEN
  470.             IF (JEXTO.EQ.JTBES) THEN
  471.                WRITE(IOIMP,'(A,I7)') 'opto2 : pas damelioration JTBES='
  472.      $              ,JTBES
  473.             ELSE
  474.  127           format ('(A,1X,2(1X,I3),20(2X,''[''',I1,'I3,'']''))')
  475.                nnod=jtbes.num(/1)
  476.                nel=jtbes.num(/2)
  477.                write(cform,127) nnod
  478.                write(ioimp,cform)
  479.      $              'opto2 : topologie amelioree nnod,nel=',nnod
  480.      $        ,nel,((jtbes.num(ino,iel),ino=1,nnod),iel=1,nel)
  481. *               WRITE(IOIMP,*) 'Topologie amelioree JTBES=',JTBES
  482. *               CALL ECMAI1(JTBES,0)
  483. *               segact jtbes
  484.             ENDIF
  485.          ENDIF
  486. *
  487. *     Si la topologie locale a été améliorée, on change la topologie
  488. *     globale en conséquence
  489. *
  490.          IF (JEXTO.NE.JTBES) THEN
  491.             JCHANG=JCHANG+1
  492. *            CALL TOPDIF(TRAVJ,TRAVX)
  493.             CALL TOPDI2(TRAVJ,TRAVX)
  494.             if (ierr.ne.0) return
  495.             if (iveri.ge.2) call vetopi(travj,'Apres DIFF')
  496.             if (ierr.ne.0) return
  497. *
  498. *     On ajoute les éléments de JTBES dans JTOPO
  499. *
  500.             CALL TOPFUS(TRAVJ,JTBES)
  501.             if (ierr.ne.0) return
  502.             if (iveri.ge.2) call vetopi(travj,'Apres ET')
  503.             if (ierr.ne.0) return
  504.             if (iseqm.ne.0) then
  505.                NOBJ=NOBJ+3
  506.                NREE=0
  507.                SEGADJ LTOPA
  508. *               WRITE(IOIMP,*) 'NOBJ=',NOBJ
  509. * Ajouter JELEM1
  510.                NBNN=JELEM1.NUM(/1)
  511.                NBELEM=1
  512.                NBSOUS=0
  513.                NBREF=0
  514.                SEGINI MELEME
  515.                ITYPEL=JELEM1.ITYPEL
  516.                DO IBNN=1,NBNN
  517.                   NUM(IBNN,1)=JELEM1.NUM(IBNN,1)
  518.                ENDDO
  519.                LTOPA.LISOBJ(NOBJ-2)=MELEME
  520. *               write(ioimp,*) 'jelem1'
  521. *               call ecmai1(meleme,0)
  522. *               segact meleme*mod
  523. *
  524. * Ajouter JEXTO reduit
  525.                NBNN=JEXTO.NUM(/1)
  526.                NBELEM=TRAVX.NVCOU
  527.                NBSOUS=0
  528.                NBREF=0
  529.                SEGINI MELEME
  530.                ITYPEL=JEXTO.ITYPEL
  531.                DO IBELEM=1,NBELEM
  532.                   DO IBNN=1,NBNN
  533.                      NUM(IBNN,IBELEM)=JEXTO.NUM(IBNN,IBELEM)
  534.                   ENDDO
  535.                ENDDO
  536.                LTOPA.LISOBJ(NOBJ-1)=MELEME
  537. *               write(ioimp,*) 'jexto'
  538. *               call ecmai1(meleme,0)
  539. *               segact meleme*mod
  540. * Ajouter JTBES
  541.                LTOPA.LISOBJ(NOBJ)=JTBES
  542. *               write(ioimp,*) 'jtbes'
  543. *               call ecmai1(jtbes,0)
  544. *               segact jtbes*mod
  545.             endif
  546.          ENDIF
  547. *
  548. *     Nettoyage de NEXTO et JEXTO (normalement inutile mais utilisé pour
  549. *     vetopi)
  550. *
  551.          if (iveri.ge.1) then
  552.             nexto=travx.nbl
  553.             jexto=travx.topo
  554.             do iel=1,travx.nvcou
  555.                do ino=1,IDIMP
  556.                   JEXTO.NUM(ino,iel)=0
  557.                   nexto.lect(iel)=0
  558.                enddo
  559.             enddo
  560.             travx.nvcou=0
  561.          endif
  562.  
  563. * Fin boucle sur les éléments
  564.       ENDDO
  565. *
  566. * Il faut appeler le nettoyage avant de sortir
  567. *
  568.       SEGSUP JELEM2
  569.       SEGSUP IDCP2
  570.       SEGSUP ICPR2
  571.       SEGSUP KELEMX
  572.       SEGSUP ICPRX
  573.       SEGSUP IDCPX
  574.       CALL TRLSUP(TRAVL)
  575. *     SEGSUP IPBTL
  576.       CALL TOPSUP(TRAVK)
  577. *tst      topinv=travj.topi
  578. *tst         write(ioimp,*) 'TOPINV Avant nettoyage elem TOPINV'
  579. *tst         call ectopi(topinv,1)
  580. *tst         call ectopi(topinv,2)
  581.       segsup jelem1
  582.       if (jtbes.ne.travx.topo.and.iseqm.eq.0) segsup jtbes
  583.       call topsup(travx)
  584.  
  585. *     Nettoyage des éléments vides
  586. *      impr=8
  587.       call topclv(travj,lchang)
  588.       if (ierr.ne.0) return
  589.       if (iveri.ge.2.and.lchang) call vetopi(travj
  590.      $     ,'Apres nettoyage elem')
  591.       if (ierr.ne.0) return
  592. *
  593. *     Nettoyage des noeuds non référencés dans la topologie mais
  594. *     seulement ceux ajoutés par nous, pas les autres !
  595. *
  596.       IF (iseqm.eq.0) call topclp(travj,lchang)
  597. * verif
  598.       if (iveri.ge.2.and.lchang) call vetopi(travj
  599.      $     ,'Apres nettoyage noeuds')
  600.       if (ierr.ne.0) return
  601.  
  602. *
  603. * Normal termination
  604. *
  605.       RETURN
  606. *
  607. * Error handling
  608. *
  609.  9999 CONTINUE
  610.       MOTERR(1:8)='OPTO2   '
  611. * 349 2
  612. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  613.       CALL ERREUR(349)
  614.       RETURN
  615. *
  616. * End of subroutine OPTO2
  617. *
  618.       END
  619.  
  620.  

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