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    PV        22/07/28    21:15:06     11419          
  2.       SUBROUTINE OPTO2(TRAVJ,JELEM)
  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 SMCOORD
  74. * Numerotation locale (de 1 à NBPTS)
  75. *      INTEGER NPCOU,NPMAX
  76. *del      POINTEUR JCOORD.MCOORD
  77.       POINTEUR KCOORD.MCOORD
  78. -INC TMATOP1      
  79. *-INC STOPINV
  80. *-INC SMETRIQ
  81.       POINTEUR JCMETR.METRIQ
  82.       POINTEUR KCMETR.METRIQ
  83. *-INC STRAVJ
  84.       POINTEUR TRAVK.TRAVJ
  85. *-INC STRAVL
  86. -INC SMLMOTS
  87.       POINTEUR JNMETR.MLMOTS
  88.       POINTEUR KNMETR.MLMOTS
  89. *     
  90.       POINTEUR TRAVX.TRAVJ
  91. *
  92. *-INC SMLENTX
  93.       POINTEUR ICPRX.MLENTX
  94.       POINTEUR IDCPX.MLENTX
  95. *-INC SMELEMX
  96.       POINTEUR KELEMX.MELEMX
  97. *
  98.       logical lchang
  99. *     
  100. * Executable statements
  101. *
  102.       if (impr.ge.4) WRITE(IOIMP,*) 'Entrée dans opto2.eso'
  103. *
  104. * Initialisation et extension des segments JTOPO et JCOORD
  105. *
  106.       IDIMP=IDIM+1
  107.  
  108.       JTOPO=TRAVJ.TOPO
  109. *
  110. * Initialisation de la topologie inverse
  111. *
  112. *      CALL INTOPI(NVMAX,NPMAX,TOPINV,IMPR)
  113.       CALL INTOP2(TRAVJ,IMPR)
  114.       IF (IERR.NE.0) RETURN
  115. *
  116. * Remplissage de la topologie inverse avec JTOPO
  117. *
  118. *      CALL RETOPI(JTOPO,NVCOU,TOPINV,IMPR)
  119.       CALL RETOP2(TRAVJ,IMPR)
  120.       IF (IERR.NE.0) RETURN
  121. *      
  122.       if (.false.) then
  123.          TOPINV=TRAVJ.TOPI
  124.          call ectopi(TOPINV,1)
  125.          call ectopi(TOPINV,2)
  126.       endif
  127. *
  128. * Segment de travail pour l'extraction des éléments
  129. *
  130.       JG=NVMAX
  131.       SEGINI JNBL
  132.       TRAVJ.NBL=JNBL
  133.       JG=NPMAX-NPINI
  134.       SEGINI JNNO
  135.       TRAVJ.NNO=JNNO
  136. *
  137. * Extraction de la topologie à optimiser
  138. *
  139. *     NELMOY=40
  140.       IF (IDIM.EQ.2) THEN
  141.          NELMOY=15
  142.          NPOMOY=10
  143.       ELSEIF (IDIM.EQ.3) THEN
  144.          NELMOY=40
  145.          NPOMOY=12
  146. *         NELMOY=40
  147. *         NPOMOY=25
  148.       ELSE
  149.          write(ioimp,*) 'idim=',idim
  150.          goto 9999
  151.       ENDIF
  152. *
  153. *!!!   A changer plus tard
  154. * 
  155. *      NVXMAX=0
  156.       SEGINI TRAVX
  157. *old      if (isgadj.gt.0) write(ioimp,185) 'TRAVJ,TRAVX=',TRAVJ,TRAVX
  158.       TRAVX.NVINI=0
  159.       TRAVX.NVCOU=0
  160.       TRAVX.NVMAX=NELMOY
  161. *      TRAVX.NVMAX=0
  162.       JG=TRAVX.NVMAX
  163.       SEGINI NEXTO
  164.       TRAVX.NBL=NEXTO
  165. *
  166.  
  167.       NBNN=IDIMP
  168.       NBELEM=TRAVX.NVMAX
  169.       NBSOUS=0
  170.       NBREF=0
  171.       SEGINI JEXTO
  172.       JEXTO.ITYPEL=JTOPO.ITYPEL
  173.       TRAVX.TOPO=JEXTO
  174. *     Boucle sur les éléments
  175. *      write(ioimp,*) 'opto2 jelem(nno,nbnn=)',jelem.num(/1)
  176. *     $     ,jelem.num(/2)
  177.       NBNN1=JELEM.NUM(/1)
  178.       NBNN=NBNN1
  179.       NBELEM=1
  180.       NBSOUS=0
  181.       NBREF=0
  182.       SEGINI JELEM1
  183.       JELEM1.ITYPEL=JELEM.ITYPEL
  184.  
  185. *     Segment de travail TRAVK pour opto3 numérotation locale à
  186. *     l'élément extrait.
  187.       SEGINI TRAVK
  188.       TRAVK.NVINI=0
  189.       TRAVK.NVCOU=0
  190.       TRAVK.NVMAX=NELMOY
  191. * Important pour le segment NNO après      
  192.       TRAVK.NPINI=0
  193.       TRAVK.NPCOU=0
  194.       TRAVK.NPMAX=NPOMOY
  195. *      IF (IJOB.NE.0) TRAVK.NPMAX=TRAVK.NPMAX+MAX(10,NPTINI)
  196. *A changer !!!      IF (IJOB.NE.0) TRAVK.NPMAX=TRAVK.NPMAX+1
  197. *         IF (IJOB.NE.0) TRAVK.NPMAX=TRAVK.NPMAX+1
  198. * Topologie de TRAVK (KEXTO)
  199.       NBELEM=TRAVK.NVMAX
  200.       NBNN=IDIMP
  201.       NBSOUS=0
  202.       NBREF=0
  203.       SEGINI,KEXTO
  204.       KEXTO.ITYPEL=JEXTO.ITYPEL
  205.       TRAVK.TOPO=KEXTO
  206. *     Coordonnées de TRAVK (KCOORD)
  207.       NBPTS=TRAVK.NPMAX
  208.       SEGINI,KCOORD
  209.       TRAVK.COORD=KCOORD
  210.       JNMETR=TRAVJ.NMETR
  211.       IF (JNMETR.NE.0) THEN
  212.          SEGINI,KNMETR=JNMETR
  213.          TRAVK.NMETR=KNMETR
  214.       ENDIF
  215.       JCMETR=TRAVJ.CMETR
  216.       IF (JCMETR.NE.0) THEN
  217.          NNIN=JCMETR.XIN(/1)
  218.          NNNOE=TRAVK.NPMAX
  219.          SEGINI,KCMETR
  220.          TRAVK.CMETR=KCMETR
  221.       ENDIF
  222. *
  223. *     Segment de travail pour trouver les noeuds du contour ou de
  224. *     l'enveloppe pour étoiler dans topv2 
  225. *
  226.       JG=TRAVK.NPMAX-TRAVK.NPINI
  227.       SEGINI KNNO
  228.       TRAVK.NNO=KNNO
  229. *     Segment de travail TRAVL pour topv2
  230.       NNM=JEXTO.NUM(/1)
  231.       ITYP=JEXTO.ITYPEL
  232. *del         CALL TRLINI(NELMOY,JEXTO.NUM(/1),JEXTO.ITYPEL,TRAVL)
  233.       CALL TRLINI(NELMOY,NNM,ITYP,TRAVL)
  234.       if (iveri.ge.2) then
  235.          call trlver(travl,'opto2 : Apres initialisation TRAVL')
  236.          if (ierr.ne.0) return
  237.       endif
  238. *
  239. *     Segment de travail pour le changement de numérotation dans opto3
  240. *
  241.       JGMAX=NPOMOY
  242.       SEGINI ICPRX
  243.       CALL mtxadj(ICPRX,0,lchang,'opto2 : ICPRX_INI')
  244.       if (ierr.ne.0) return
  245.       SEGINI IDCPX
  246.       CALL mtxadj(IDCPX,0,lchang,'opto2 : IDCPX_INI')
  247.       if (ierr.ne.0) return
  248. *
  249. *     Segment de travail pour jelem en numérotation très locale dans
  250. *     opto3. Ce segment a un élément et peut-être moins de noeuds que JELEM1
  251. *     
  252.       NNMAX=JELEM.NUM(/1)
  253.       NLMAX=1
  254.       SEGINI KELEMX
  255.       KELEMX.ITYPEX=JELEM.ITYPEL
  256.       KELEMX.NLCOU=1
  257.  
  258.  
  259.       DO IAPARC=1,JELEM.NUM(/2)
  260.          DO IBNN=1,NBNN1
  261.             JELEM1.NUM(IBNN,1)=JELEM.NUM(IBNN,IAPARC)
  262.          ENDDO
  263.          JPARCO=JPARCO+1
  264.          IF (IMPR.GE.4) THEN
  265.             write(ioimp,*) '  opto2 : Autour de l''element ',iaparc
  266.             call ecmai1(jelem1,0)
  267.             segact jelem1*mod
  268.          ENDIF
  269. *      
  270.          if (iveri.ge.2) call vetopi(travj,'Avant exto4')
  271.          if (ierr.ne.0) return
  272. *
  273.          CALL EXTO4c(JELEM1,TRAVJ,
  274.      $        TRAVX)
  275. *     verif que NBL est bien nettoyé
  276.          if (iveri.ge.2) call vetopi(travj,'Apres exto4')
  277.          if (ierr.ne.0) return
  278. *tst      write(ioimp,*) 'Elements de la topologie extraits :'
  279. *tst      write(ioimp,187) (nexto(I),I=1,travx.nvcou)
  280.  
  281.  
  282. *     Mise à jour de jexto
  283.          nexto=travx.nbl
  284.          jexto=travx.topo
  285.          do iel=1,travx.nvcou
  286.             do ino=1,IDIMP
  287.                JEXTO.NUM(ino,iel)=JTOPO.NUM(INO,nexto.lect(iel))
  288.             enddo
  289.          enddo
  290. *
  291. * Optimisation de la topologie extraite
  292. *
  293.          IF (IMPR.GE.4) THEN
  294.             write(ioimp,*) 'opto2.eso : on a extrait la topologie : '
  295.             call ecmai1(jexto,0)
  296.             segact jexto
  297.          ENDIF
  298. *
  299. *     Init
  300.  
  301.          CALL OPTO3(TRAVJ,TRAVX,JELEM1,TRAVK,TRAVL,ICPRX,IDCPX,
  302.      $        KELEMX,
  303.      $        JTBES,JCAND)
  304.          IF (IERR.NE.0) RETURN
  305.          if (iveri.ge.2) call vetopi(travj,'Apres opto3')
  306.          IF (IERR.NE.0) RETURN
  307.  
  308.          JEXPLO=JEXPLO+ABS(JCAND)
  309.          IF (IMPR.GE.4) THEN
  310.             IF (JEXTO.EQ.JTBES) THEN
  311.                WRITE(IOIMP,*) 'Pas damelioration JTBES=',JTBES
  312.             ELSE
  313.                WRITE(IOIMP,*) 'Topologie amelioree JTBES=',JTBES
  314.                CALL ECMAI1(JTBES,0)
  315.                segact jtbes
  316.             ENDIF
  317.          ENDIF
  318. *
  319. *     Si la topologie locale a été améliorée, on change la topologie
  320. *     globale en conséquence
  321. *      
  322.          IF (JEXTO.NE.JTBES) THEN
  323.             JCHANG=JCHANG+1
  324. *            CALL TOPDIF(TRAVJ,TRAVX)
  325.             CALL TOPDI2(TRAVJ,TRAVX)
  326.             if (ierr.ne.0) return
  327.             if (iveri.ge.2) call vetopi(travj,'Apres DIFF')
  328.             if (ierr.ne.0) return
  329. *     
  330. *     On ajoute les éléments de JTBES dans JTOPO
  331. *
  332.             CALL TOPFUS(TRAVJ,JTBES)
  333.             if (ierr.ne.0) return
  334.             if (iveri.ge.2) call vetopi(travj,'Apres ET')
  335.             if (ierr.ne.0) return
  336.          ENDIF
  337. *
  338. *     Nettoyage de NEXTO et JEXTO (normalement inutile mais utilisé pour
  339. *     vetopi)
  340. *
  341.          if (iveri.ge.1) then
  342.             nexto=travx.nbl
  343.             jexto=travx.topo
  344.             do iel=1,travx.nvcou
  345.                do ino=1,IDIMP
  346.                   JEXTO.NUM(ino,iel)=0
  347.                   nexto.lect(iel)=0
  348.                enddo
  349.             enddo
  350.             travx.nvcou=0
  351.          endif
  352.  
  353. * Fin boucle sur les éléments         
  354.       ENDDO
  355. *
  356. * Il faut appeler le nettoyage avant de sortir
  357. *
  358.       SEGSUP KELEMX
  359.       SEGSUP ICPRX
  360.       SEGSUP IDCPX
  361.       CALL TRLSUP(TRAVL)
  362. *      SEGSUP IPBTL
  363.       CALL TOPSUP(TRAVK)
  364. *tst      topinv=travj.topi
  365. *tst         write(ioimp,*) 'TOPINV Avant nettoyage elem TOPINV'
  366. *tst         call ectopi(topinv,1)
  367. *tst         call ectopi(topinv,2)
  368.       segsup jelem1
  369.       if (jtbes.ne.travx.topo) segsup jtbes
  370.       call topsup(travx)
  371.  
  372. *     Nettoyage des éléments vides
  373. *      impr=8
  374.       call topclv(travj,lchang)
  375.       if (ierr.ne.0) return
  376.       if (iveri.ge.2.and.lchang) call vetopi(travj
  377.      $     ,'Apres nettoyage elem')
  378.       if (ierr.ne.0) return
  379. *
  380. *     Nettoyage des noeuds non référencés dans la topologie mais
  381. *     seulement ceux ajoutés par nous, pas les autres !
  382. *
  383.       call topclp(travj,lchang)
  384. * verif          
  385.       if (iveri.ge.2.and.lchang) call vetopi(travj
  386.      $     ,'Apres nettoyage noeuds')
  387.       if (ierr.ne.0) return
  388.  
  389. *
  390. * Normal termination
  391. *
  392.       RETURN
  393. *
  394. * Format handling
  395. *
  396.  185  FORMAT (5X,A32,6I8)
  397.  186  FORMAT ('Segment ',A6,' ',A6,' ajusté de ',I6,' à ',I6)
  398.  187  FORMAT (5X,10I8)
  399.  188  FORMAT ('Apres point IELEM(',I2,',1)=',I6,' ; NBL=')
  400.  189  FORMAT ('Le noeud ',I2,'/',I2,' de IELEM de numero',I6
  401.      $     ,' a le plus petit nb de voisins :',I3)
  402. *     
  403. * Error handling     
  404. *     
  405.  9999 CONTINUE
  406.       MOTERR(1:8)='OPTO2   '
  407. * 349 2
  408. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  409.       CALL ERREUR(349)
  410.       RETURN
  411. *
  412. * End of subroutine OPTO2
  413. *
  414.       END
  415.  
  416.  
  417.  
  418.  

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