Télécharger la plaquette Cast3M


fr en

Télécharger opto1.eso

Retour à la liste

Numérotation des lignes : 

opto1

  1. C OPTO1     SOURCE    GOUNAND   25/11/24    21:15:10     12406          
  2.       SUBROUTINE OPTO1(ITOPO,IELEM,IPVIRT,ICMETR,
  3.      $     ITOPA,ICMETA,LTOPA)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C NOM         : OPTO1
  8. C DESCRIPTION : Une implémentation de l'amélioration d'une topologie
  9. C               autour d'un élément. On reprend OPTITOPO pour le corps
  10. C     du programme. On reprend l'extraction et la topologie inverse de
  11. C     EXTO. Le point crucial sera d'implémenter la modification de la
  12. C     topologie : enlever les anciens éléments et mettre les nouveaux.
  13. C
  14. C
  15. C     Ici, on fait quelques tests, on passe les entrées en numérotation
  16. C     locale basée sur celle de ITOPO, on crée également un MCOORD local
  17. C     avant de passer à OPTO2. En effet, OPTO2 sera suceptible de créer
  18. C     des noeuds
  19. C
  20. C     En sortie, on repasse en numérotation globale, on inclue les
  21. C     éventuels nouveaux noeuds créés dans OPTO2 dans le MCOORD global.
  22. C
  23. C     La programmation est inspirée de demete.eso et reprise de
  24. C     exto1.eso
  25. C
  26. C
  27. C LANGAGE     : ESOPE
  28. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
  29. C               mél : gounand@semt2.smts.cea.fr
  30. C***********************************************************************
  31. C APPELES          : OPTO2
  32. C APPELES (E/S)    :
  33. C APPELES (BLAS)   :
  34. C APPELES (CALCUL) :
  35. C APPELE PAR       : PROPTO
  36. C***********************************************************************
  37. C SYNTAXE GIBIANE    :
  38. C ENTREES            :
  39. C ENTREES/SORTIES    :
  40. C SORTIES            :
  41. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  42. C***********************************************************************
  43. C VERSION    : v1, 06/10/2017, version initiale
  44. C HISTORIQUE : v1, 06/10/2017, création
  45. C HISTORIQUE :
  46. C HISTORIQUE :
  47. C***********************************************************************
  48. -INC PPARAM
  49. -INC CCOPTIO
  50. -INC TMATOP2
  51. -INC SMELEME
  52. * Numerotation globale
  53.       POINTEUR ITOPO.MELEME,IELEM.MELEME
  54.       POINTEUR ITOPA.MELEME
  55.       POINTEUR IPVIRT.MELEME
  56. ** Numerotation locale
  57.       POINTEUR JTOPO.MELEME
  58.       POINTEUR JELEM.MELEME
  59.       POINTEUR JPVIRT.MELEME
  60. -INC SMLOBJE
  61.       POINTEUR LTOPA.MLOBJE
  62. -INC SMCHPOI
  63.       POINTEUR ICMETR.MCHPOI
  64.       POINTEUR ICMETA.MCHPOI
  65. -INC SMCOORD
  66. * Numerotation globale
  67.       POINTEUR ICOORD.MCOORD
  68. ** Numerotation locale
  69.       POINTEUR JCOORD.MCOORD
  70. -INC TMATOP1
  71. *-INC STOPINV
  72. *-INC STRAVJ
  73. *-INC SMETRIQ
  74.       POINTEUR JCMETR.METRIQ
  75. -INC TMTRAV
  76.       SEGMENT MISDEF
  77.       INTEGER ISDEF(NNIN,NNNOE)
  78.       ENDSEGMENT
  79. -INC SMLMOTS
  80.       POINTEUR JNMETR.MLMOTS
  81. *
  82. * Passage de numerotation globale -> locale
  83. *   et locale -> globale
  84.       SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  85.       SEGMENT IDCP(NPTINI)
  86. *     integer oooval
  87.       logical lnul
  88.       CHARACTER*24 FORMA
  89.       CHARACTER*4 MOT
  90. * Noms de composantes pour la métrique
  91. *
  92. * Executable statements
  93. *
  94.       IF (IMPR.GE.5) WRITE(IOIMP,*) 'Entrée dans opto1.eso'
  95.       IDIMP=IDIM+1
  96.       ICOORD=MCOORD
  97.       SEGACT MCOORD
  98. *      write(ioimp,*) 'opto1 debut : nbpts, xcoor=',nbpts,xcoor(/1)/(idim
  99. *     $     +1)
  100.       IBPTS=NBPTS
  101. *     On se simplifie la vie en ne considérant que des maillages simples
  102. *      call ecmai1(itopo,0)
  103.       SEGACT ITOPO
  104.       NBSOUS=ITOPO.LISOUS(/1)
  105.       NBNN=ITOPO.NUM(/1)
  106.       IF (NBSOUS.NE.0.OR.NBNN.NE.IDIMP) THEN
  107.          WRITE(IOIMP,*)
  108.      $        'Topologie : pas un maillage de simplex volumiques'
  109.          GOTO 9999
  110.       ENDIF
  111.       SEGACT IELEM
  112.       NBSOUS=IELEM.LISOUS(/1)
  113.       NBELEM=IELEM.NUM(/2)
  114.       IF (NBSOUS.NE.0) THEN
  115.          WRITE(IOIMP,*) 'Deuxieme maillage : pas un maillage simple'
  116.          GOTO 9999
  117.       ENDIF
  118.       SEGACT IPVIRT
  119.       NBSOUS=IPVIRT.LISOUS(/1)
  120.       NBNN=IPVIRT.NUM(/1)
  121.       IF (NBSOUS.NE.0.OR.NBNN.NE.1) THEN
  122.          WRITE(IOIMP,*)
  123.      $        'VIRT : pas un maillage de points'
  124.          GOTO 9999
  125.       ENDIF
  126. * Correspondances de numérotation
  127.       SEGINI ICPR
  128. * Mettre le noeuds virtuels en premier et les compter
  129.       IK=0
  130.       DO 13 IEL=1,IPVIRT.NUM(/2)
  131.          IP=IPVIRT.NUM(1,IEL)
  132.          IF (ICPR(IP).EQ.0) THEN
  133.             IK=IK+1
  134.             ICPR(IP)=IK
  135.          ENDIF
  136.  13   CONTINUE
  137.       NIPVIR=IK
  138.       DO 23 IEL=1,ITOPO.NUM(/2)
  139.          DO 230 INO=1,ITOPO.NUM(/1)
  140.             IP=ITOPO.NUM(INO,IEL)
  141.             IF (ICPR(IP).EQ.0) THEN
  142.                IK=IK+1
  143.                ICPR(IP)=IK
  144.             ENDIF
  145.  230     CONTINUE
  146.  23   CONTINUE
  147.       NBLINI=ITOPO.NUM(/2)
  148.       NPTINI=IK
  149.       SEGINI IDCP
  150.       NPTBAS=XCOOR(/1)/IDIMP
  151. * On pourrait ameliorer...
  152.       DO 500 I=1,NPTBAS
  153.          if (icpr(i).ne.0) IDCP(ICPR(I))=I
  154.  500  CONTINUE
  155.       if (IMPR.GE.2) then
  156.          write(ioimp,*) 'Nb noeud globaux,locaux,virtuels=',NPTBAS,IK
  157.      $        ,NIPVIR
  158. *         write(ioimp,*) 'ICPR'
  159. *         write(ioimp,187) (ICPR(I),I=1,ICPR(/1))
  160.          if (IMPR.GE.6) then
  161.             write(ioimp,*) 'IDCP'
  162.             write(ioimp,187) (IDCP(I),I=1,IDCP(/1))
  163.          endif
  164.       endif
  165.       IF (IMPR.GE.3) THEN
  166.          write(ioimp,*) 'opto1.eso : topologie en coord globales : '
  167.          call ecmai1(itopo,0)
  168.          segact itopo*mod
  169.       ENDIF
  170. *
  171.       IF (IDIM.EQ.2) THEN
  172.          NELMOY=15
  173.          NPOMOY=10
  174.       ELSEIF (IDIM.EQ.3) THEN
  175.          NELMOY=40
  176.          NPOMOY=20
  177.       ELSE
  178.          write(ioimp,*) 'idim=',idim
  179.          goto 9999
  180.       ENDIF
  181.  
  182.       SEGINI TRAVJ
  183.       NVINI=NBLINI
  184.       NVCOU=NBLINI
  185.       NVMAX=NBLINI+MAX(NELMOY,NBLINI)
  186.       NPINI=NPTINI
  187.       NPCOU=NPTINI
  188.       NPMAX=NPTINI
  189.       IF (IAJNO.NE.0) NPMAX=NPMAX+MAX(NPOMOY,NPTINI)
  190. *
  191. * Melemes en coordonnées locales
  192. *     Topologie
  193.       NBELEM=travj.NVMAX
  194.       NBNN=IDIMP
  195.       NBSOUS=0
  196.       NBREF=0
  197.       SEGINI,JTOPO
  198.       JTOPO.ITYPEL=ITOPO.ITYPEL
  199.       TRAVJ.TOPO=JTOPO
  200.       DO 33 IEL=1,travj.nvcou
  201.          DO 330 INO=1,IDIMP
  202.             IP=ITOPO.NUM(INO,IEL)
  203.             JP=ICPR(IP)
  204.             IF (JP.NE.0) THEN
  205.                JTOPO.NUM(INO,IEL)=JP
  206.             ELSE
  207.                WRITE(IOIMP,*) 'Erreur de programmation'
  208.                GOTO 9999
  209.             ENDIF
  210.  330     CONTINUE
  211.  33   CONTINUE
  212. * Eventuellement, IELEM=ITOP donc à désactiver ici
  213.       SEGDES IELEM
  214.       SEGDES ITOPO
  215.       IF (IMPR.GE.4) THEN
  216.          write(ioimp,*) 'opto1.eso : topologie en coord locales : '
  217.          call ecmai1(jtopo,0)
  218.          segact jtopo*mod
  219.       ENDIF
  220.  
  221. *     Noeuds virtuels en coordonnées locales
  222.       IF (IPVIRT.NE.0) THEN
  223.          NBELEM=IPVIRT.NUM(/2)
  224.          NBNN=1
  225.          NBSOUS=0
  226.          NBREF=0
  227.          SEGINI,JPVIRT
  228.          JPVIRT.ITYPEL=IPVIRT.ITYPEL
  229.          DO 34 IEL=1,NBELEM
  230.             IP=IPVIRT.NUM(1,IEL)
  231.             JP=ICPR(IP)
  232.             IF (JP.GT.0.OR.JP.LE.NIPVIR) THEN
  233.                JPVIRT.NUM(1,IEL)=JP
  234.             ELSE
  235.                WRITE(IOIMP,*) 'Erreur de programmation JP,NIPVIR=',JP
  236.      $              ,NIPVIR
  237.                GOTO 9999
  238.             ENDIF
  239.  34      CONTINUE
  240.       ELSE
  241.          JPVIRT=0
  242.       ENDIF
  243.       TRAVJ.PVIRT=JPVIRT
  244.       IF (IMPR.GE.4) THEN
  245.          write(ioimp,*) 'opto1.eso : noeuds virtuels en coord locales :'
  246.          call ecmai1(jpvirt,0)
  247.          segact jpvirt*mod
  248.       ENDIF
  249. *     Element autour duquel on extrait
  250. *         write(ioimp,*) 'opto1.eso : element en coord globales : '
  251. *         call ecmai1(ielem,0)
  252. *         segact ielem*mod
  253.       SEGINI,JELEM=IELEM
  254.       DO 43 IEL=1,JELEM.NUM(/2)
  255.          DO 430 INO=1,JELEM.NUM(/1)
  256.             IP=JELEM.NUM(INO,IEL)
  257.             JP=ICPR(IP)
  258. *     Il faudra gérer le cas où certains noeuds de JELEM sont nuls. Voir
  259. *     dans EXTO3.
  260. *            IF (JP.NE.0) THEN
  261.                JELEM.NUM(INO,IEL)=JP
  262. *            ELSE
  263.              IF (JP.EQ.0) THEN
  264.                 WRITE(IOIMP,*)
  265.      $               'Element fourni non inclus dans la topologie'
  266. *     Pour avoir un comportement identique à la version Gibiane de
  267. *     EXTOPLOC, on annule l'élément. La gestion des éléments nuls est
  268. *     faite dans exto3.eso
  269.                 DO INOO=1,JELEM.NUM(/1)
  270.                    JELEM.NUM(INOO,IEL)=0
  271.                 ENDDO
  272.                 GOTO 43
  273.              ENDIF
  274. *               GOTO 9999
  275. *            ENDIF
  276.  430     CONTINUE
  277.  43   CONTINUE
  278.       IF (IMPR.GE.6) THEN
  279.          write(ioimp,*) 'opto1.eso : element en coord locales : '
  280.          call ecmai1(jelem,0)
  281.          segact jelem*mod
  282.       ENDIF
  283. * Passage des coordonnées en locale
  284. *      NBPTS=NPTINI
  285.       NBPTS=travj.NPMAX
  286.       SEGINI,JCOORD
  287.       TRAVJ.COORD=JCOORD
  288.       DO 53 IPL=1,travj.npcou
  289.          IREFL=IDIMP*(IPL-1)
  290.          IP=IDCP(IPL)
  291.          IREF=IDIMP*(IP-1)
  292.          DO 530 IC=1,IDIMP
  293.             JCOORD.XCOOR(IREFL+IC)=XCOOR(IREF+IC)
  294.  530     CONTINUE
  295.  53   CONTINUE
  296. * Passage de la métrique en local
  297. *
  298.       IF (ICMETR.NE.0) THEN
  299. *     Définition des noms de composantes
  300.          JGN=4
  301.          JGM=0
  302.          IF (IMET.EQ.3) JGM=1
  303.          IF (IMET.EQ.4) JGM=IDIM*(IDIM+1)/2
  304.          SEGINI JNMETR
  305.          DO I=1,JGM
  306.             JNMETR.MOTS(I)='G    '
  307.          ENDDO
  308.          IF (IMET.EQ.4) THEN
  309.             idx=0
  310.             DO I=1,IDIM
  311.                DO J=1,I
  312.                   idx=idx+1
  313.                   WRITE(JNMETR.MOTS(idx)(2:2),FMT='(I1)') I
  314.                   WRITE(JNMETR.MOTS(idx)(3:3),FMT='(I1)') J
  315.                ENDDO
  316.             ENDDO
  317.          ENDIF
  318. *dbg         WRITE (IOIMP,2019) (JNMETR.MOTS(I),I=1,JNMETR.MOTS(/2))
  319. *dbg 2019    FORMAT (20(2X,A4) )
  320.          NNIN=JNMETR.MOTS(/2)
  321.          NNNOE=travj.NPCOU
  322.          if (iveri.ge.1) SEGINI MISDEF
  323.          NNNOE=travj.NPMAX
  324.          SEGINI JCMETR
  325.          MCHPOI=ICMETR
  326.          SEGACT MCHPOI
  327.          NSOUPO=IPCHP(/1)
  328.          DO ISOUPO=1,NSOUPO
  329.             MSOUPO=IPCHP(ISOUPO)
  330.             SEGACT MSOUPO
  331.             NC=NOCOMP(/2)
  332.             MELEME=IGEOC
  333.             MPOVAL=IPOVAL
  334.             SEGACT MELEME
  335.             SEGACT MPOVAL
  336.             N=VPOCHA(/1)
  337.             DO IC=1,NC
  338.                ININ=0
  339.                DO JNIN=1,NNIN
  340.                   IF (NOCOMP(IC).EQ.JNMETR.MOTS(JNIN)) THEN
  341.                      ININ=JNIN
  342.                      GOTO 11
  343.                   ENDIF
  344.                ENDDO
  345.  11            CONTINUE
  346.                IF (ININ.NE.0) THEN
  347.                   DO I=1,N
  348.                      INNOE=ICPR(NUM(1,I))
  349.                      IF (INNOE.NE.0) THEN
  350.                         if (iveri.ge.1) ISDEF(ININ,INNOE)=1
  351.                         JCMETR.XIN(ININ,INNOE)=VPOCHA(I,IC)
  352.                      ENDIF
  353.                   ENDDO
  354.                ENDIF
  355.             ENDDO
  356.             SEGDES MPOVAL
  357.             SEGDES MELEME
  358.             SEGDES MSOUPO
  359.          ENDDO
  360.          SEGDES MCHPOI
  361.          if (iveri.ge.1) then
  362. *     Vérification que la métrique a été définie sur tous les noeuds et
  363. *     toutes les composantes sauf les noeuds virtuels.
  364.             DO 21 J=1,ISDEF(/2)
  365.                IF (JPVIRT.NE.0) THEN
  366.                   DO IEL=1,NBELEM
  367.                      JP=JPVIRT.NUM(1,IEL)
  368.                      if (J.EQ.JP) GOTO 21
  369.                   ENDDO
  370.                ENDIF
  371.                DO I=1,ISDEF(/1)
  372.                   IF (ISDEF(I,J).NE.1) THEN
  373.                      MOT=JNMETR.MOTS(I)
  374.                      INOD=IDCP(J)
  375.                      write(ioimp,*)
  376.      $                    'Metrique non definie pour la composante '
  377.      $                    ,MOT,' au noeud ',INOD
  378.                      GOTO 9999
  379.                   ENDIF
  380.                ENDDO
  381.  21         CONTINUE
  382.             SEGSUP MISDEF
  383.          endif
  384.       ELSE
  385.          JNMETR=0
  386.          JCMETR=0
  387.       ENDIF
  388.       TRAVJ.NMETR=JNMETR
  389.       TRAVJ.CMETR=JCMETR
  390. *tst      WRITE(IOIMP,185) 'SEGMENT JCOORD ',JCOORD
  391. *tst         WRITE(FORMA,FMT='("(1(",I1,"(1PG12.5,2X)))")') IDIMP
  392. *tst         write(ioimp,*) 'forma=',forma
  393. *tst         write(ioimp,*) 'XCOOR'
  394. *tst         write(ioimp,forma)  (jcoord.xcoor(I),I=1,jcoord.xcoor(/1))
  395.       SEGSUP ICPR
  396. * La numérotation globale devient la locale dans ce bloc  !!!
  397.       MCOORD=JCOORD
  398. * Tous les arguments sont potentiellement des entrées-sorties
  399. *     in EXTO2 SEGINI JTOPA
  400. *      write(ioimp,*) ' opto1  : avant opto2 =',OOOVAL(2,1)
  401.       CALL OPTO2(TRAVJ,JELEM,LTOPA)
  402.       SEGSUP JELEM
  403. *     write(ioimp,*) ' opto1  : apres opto2 =',OOOVAL(2,1)
  404.       IF (IERR.NE.0) GOTO 555
  405. *
  406. *     NPTFIN=JCOORD.XCOOR(/1)/IDIMP
  407.       NPTFIN=travj.npcou
  408.       if (jchang.eq.0) then
  409.          ITOPA=ITOPO
  410.          ICMETA=ICMETR
  411.          if (iseqm.eq.0) then
  412.             IF (NPTINI.NE.NPTFIN) THEN
  413.                write(ioimp,*) nptfin-nptini,' nouveaux noeuds crees'
  414.                write(ioimp,*) 'pas normal car topologie inchangee'
  415.             ENDIF
  416.          endif
  417. *     On rétablit la numérotation globale originelle et on rajoute les
  418. *     noeuds nouvellement créés
  419. *     ! Attention, il faut aussi rétablir le NBPTS suite aux changements
  420. *     !  de Pierre dans SMCOORD
  421.          NBPTS=IBPTS
  422.          MCOORD=ICOORD
  423.       else
  424. *     Mise à jour de la topologie en rétablissant la numérotation
  425. *     globale et en notant les numéros de noeuds utilisés dans ICPR car
  426. *     on va restreindre la métrique interpolée à ces nouveaux noeuds
  427.          IF (JCMETR.NE.0) THEN
  428.             SEGINI ICPR
  429.             IK=0
  430.          ENDIF
  431. *     On ne serait pas obligé de faire ceci mais alors, il faut faire
  432. *     attention au cas où JTOPA=JTOPO
  433. *     SEGINI,ITOPA=JTOPA
  434. *      write(ioimp,*) 'opto1.eso : on a genere la topologie : '
  435. *      call ecmai1(jtopo,0)
  436. *      segact jtopo*mod
  437. *     En place
  438.          JTOPO=TRAVJ.TOPO
  439.          ITOPA =JTOPO
  440. * Pour éviter une suppression dans topsup
  441.          travj.topo=0
  442.          if (nvcou.ne.nvmax) then
  443.             nbnn=idimp
  444.             nbelem=nvcou
  445.             nbsous=0
  446.             nbref=0
  447.             segadj,itopa
  448.          endif
  449. *      write(ioimp,*) 'itopa'
  450. *      call ecmail(itopa,0)
  451. *      segact itopa*mod
  452. * On ajuste le nombre d'éléments
  453.          DO 63 IEL=1,ITOPA.NUM(/2)
  454.             DO 630 INO=1,ITOPA.NUM(/1)
  455.                IPL=ITOPA.NUM(INO,IEL)
  456.                IF (JCMETR.NE.0) THEN
  457.                   IF (ICPR(IPL).EQ.0) THEN
  458.                      IK=IK+1
  459.                      ICPR(IPL)=IK
  460.                   ENDIF
  461.                ENDIF
  462. *
  463.                IF (IPL.LE.NPTINI) THEN
  464.                   IP=IDCP(IPL)
  465.                ELSE
  466.                   IP=IPL-NPTINI+NPTBAS
  467.                ENDIF
  468.                ITOPA.NUM(INO,IEL)=IP
  469.  630        CONTINUE
  470.  63      CONTINUE
  471. *         IF (IMPR.GE.3) THEN
  472. *            write(ioimp,*) 'opto1.eso : topologie amelioree totale : '
  473. *            call ecmai1(itopa,0)
  474. *         ENDIF
  475.          if (iseqm.ne.0) then
  476.             NOBJ=LTOPA.LISOBJ(/1)
  477.             DO IOBJ=1,NOBJ
  478.                MELEME=LTOPA.LISOBJ(IOBJ)
  479.                segact meleme*mod
  480.                DO IEL=1,NUM(/2)
  481.                   DO INO=1,NUM(/1)
  482.                      IPL=NUM(INO,IEL)
  483.                      IF (IPL.LE.NPTINI) THEN
  484.                         IP=IDCP(IPL)
  485.                      ELSE
  486.                         IP=IPL-NPTINI+NPTBAS
  487.                      ENDIF
  488.                      NUM(INO,IEL)=IP
  489.                   ENDDO
  490.                ENDDO
  491. *               write(ioimp,*) 'IOBJ=',IOBJ
  492. *               call ecmai1(meleme,0)
  493.             ENDDO
  494.          endif
  495.          IF (JCMETR.NE.0) THEN
  496. *     La nouvelle métrique
  497.             NNIN=JCMETR.XIN(/1)
  498.             NNNOE=TRAVJ.NPCOU
  499. *dbg               npmax=jcmetr.xin(/2)
  500. *dbg               write(ioimp,*) 'nnin,nnnoe,npmax=',nnin,nnnoe,npmax
  501. *
  502.             NSOUPO=1
  503.             NAT=1
  504.             SEGINI,MCHPOI
  505.             IFOPOI=IFOUR
  506.             JATTRI(1)=1
  507.             MTYPOI='        '
  508.             MOCHDE='            CHPOINT CREE PAR OPTO  '
  509.             NC=NNIN
  510.             SEGINI,MSOUPO
  511.             IPCHP(1)=MSOUPO
  512.             DO ININ=1,NNIN
  513.                NOCOMP(ININ)=JNMETR.MOTS(ININ)
  514.             ENDDO
  515.             NBSOUS=0
  516.             NBREF=0
  517.             NBNN=1
  518.             NBELEM=IK
  519.             N=NBELEM
  520.             SEGINI,MPOVAL
  521.             SEGINI,MELEME
  522.             ITYPEL=1
  523.             DO INNOE=1,NNNOE
  524.                JK=ICPR(INNOE)
  525.                IF (JK.NE.0) THEN
  526.                   IF (INNOE.LE.NPTINI) THEN
  527.                      NUM(1,JK)=IDCP(INNOE)
  528.                   ELSE
  529.                      NUM(1,JK)=INNOE-NPTINI+NPTBAS
  530.                   ENDIF
  531.                   DO ININ=1,NNIN
  532.                      VPOCHA(JK,ININ)=JCMETR.XIN(ININ,INNOE)
  533.                   ENDDO
  534.                ENDIF
  535.             ENDDO
  536.             IGEOC=MELEME
  537.             IPOVAL=MPOVAL
  538.             SEGSUP ICPR
  539. *            SEGDES,MPOVAL
  540. *            SEGDES,MSOUPO
  541. *            SEGDES,MELEME
  542. *            SEGDES,MCHPOI
  543.             ICMETA=MCHPOI
  544.          ELSE
  545.             ICMETA=0
  546.          ENDIF
  547.          SEGSUP IDCP
  548. *     On rétablit la numérotation globale originelle et on rajoute les
  549. *     noeuds nouvellement créés
  550. *     ! Attention, il faut aussi rétablir le NBPTS suite aux changements
  551. *     !  de Pierre dans SMCOORD
  552.          NBPTS=IBPTS
  553.          MCOORD=ICOORD
  554.          IF (NPTINI.NE.NPTFIN) THEN
  555.             SEGACT MCOORD*MOD
  556.             if (impr.ge.4)
  557.      $           write(ioimp,*) nptfin-nptini,' nouveaux noeuds crees'
  558.             NBPTA=NPTBAS
  559.             NBPTS=NBPTA+NPTFIN-NPTINI
  560.             SEGADJ MCOORD
  561.             nnonul=0
  562.             DO 5000 I=NPTINI+1,NPTFIN
  563.                lnul=.true.
  564.                DO 5010 J=1,IDIM
  565.                   XCOOR(NBPTA*IDIMP+J)=JCOORD.XCOOR((I-1)*IDIMP+J)
  566.                   lnul=lnul.and.(XCOOR(NBPTA*IDIMP+J).EQ.0.D0)
  567.  5010          CONTINUE
  568.                NBPTA=NBPTA+1
  569.                if (lnul) nnonul=nnonul+1
  570.  5000       CONTINUE
  571.             if (iveri.ge.1.and.nnonul.ne.0) then
  572.                write(ioimp,*) '!!! ',nnonul
  573.      $              ,' nouveaux noeuds nuls crees'
  574.                goto 9999
  575.             endif
  576.             SEGACT MCOORD
  577.          ENDIF
  578.       ENDIF
  579. *      write(ioimp,*) 'opto1 fin : nbpts, xcoor=',nbpts,xcoor(/1)/(idim
  580. *     $     +1)
  581. *      SEGDES MCOORD
  582. *     write(ioimp,*) ' opto1  : avant segsup=',OOOVAL(2,1)
  583. *     if (icmeta.ne.0) SEGDES ICMETA
  584. *      Ici Jcoors
  585.       CALL TOPSUP(TRAVJ)
  586. *      write(ioimp,*) ' opto1  : apres segsup=',OOOVAL(2,1)
  587. *
  588. * Normal termination
  589. *
  590.       RETURN
  591. *
  592. * Format handling
  593. *
  594.  185  FORMAT (/2X,10(A16,'=',I8,2X)/)
  595.  187  FORMAT (5X,10I8)
  596. *
  597. * Error handling
  598. *
  599. *     Point de branchement si erreur pendant le bloc en numérotation
  600. *     locale
  601. *     Il faut rétablir la numérotation globale
  602.  555  CONTINUE
  603.       NBPTS=IBPTS
  604.       MCOORD=ICOORD
  605.       RETURN
  606. *
  607.  9999 CONTINUE
  608.       MOTERR(1:8)='OPTO1   '
  609. * 349 2
  610. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  611.       CALL ERREUR(349)
  612.       RETURN
  613. *
  614. * End of subroutine OPTO1
  615. *
  616.       END
  617.  
  618.  

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