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   26/06/09    21:15:10     12566          
  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.       CHARACTER*40 CFORM
  91. * Noms de composantes pour la métrique
  92. *
  93. * Executable statements
  94. *
  95. *      IF (IMPR.GE.5) WRITE(IOIMP,*) 'Entrée dans opto1.eso'
  96.       IDIMP=IDIM+1
  97.       ICOORD=MCOORD
  98.       SEGACT MCOORD
  99. *      write(ioimp,*) 'opto1 debut : nbpts, xcoor=',nbpts,xcoor(/1)/(idim
  100. *     $     +1)
  101.       IBPTS=NBPTS
  102. *     On se simplifie la vie en ne considérant que des maillages simples
  103. *      call ecmai1(itopo,0)
  104.       SEGACT ITOPO
  105.       NBSOUS=ITOPO.LISOUS(/1)
  106.       NBNN=ITOPO.NUM(/1)
  107.       IF (NBSOUS.NE.0.OR.NBNN.NE.IDIMP) THEN
  108.          WRITE(IOIMP,*)
  109.      $        'Topologie : pas un maillage de simplex volumiques'
  110.          GOTO 9999
  111.       ENDIF
  112.       SEGACT IELEM
  113.       NBSOUS=IELEM.LISOUS(/1)
  114.       NBELEM=IELEM.NUM(/2)
  115.       IF (NBSOUS.NE.0) THEN
  116.          WRITE(IOIMP,*) 'Deuxieme maillage : pas un maillage simple'
  117.          GOTO 9999
  118.       ENDIF
  119.       SEGACT IPVIRT
  120.       NBSOUS=IPVIRT.LISOUS(/1)
  121.       NBNN=IPVIRT.NUM(/1)
  122.       IF (NBSOUS.NE.0.OR.NBNN.NE.1) THEN
  123.          WRITE(IOIMP,*)
  124.      $        'VIRT : pas un maillage de points'
  125.          GOTO 9999
  126.       ENDIF
  127. * Correspondances de numérotation
  128.       SEGINI ICPR
  129. * Mettre le noeuds virtuels en premier et les compter
  130.       IK=0
  131.       DO 13 IEL=1,IPVIRT.NUM(/2)
  132.          IP=IPVIRT.NUM(1,IEL)
  133.          IF (ICPR(IP).EQ.0) THEN
  134.             IK=IK+1
  135.             ICPR(IP)=IK
  136.          ENDIF
  137.  13   CONTINUE
  138.       NIPVIR=IK
  139.       DO 23 IEL=1,ITOPO.NUM(/2)
  140.          DO 230 INO=1,ITOPO.NUM(/1)
  141.             IP=ITOPO.NUM(INO,IEL)
  142.             IF (ICPR(IP).EQ.0) THEN
  143.                IK=IK+1
  144.                ICPR(IP)=IK
  145.             ENDIF
  146.  230     CONTINUE
  147.  23   CONTINUE
  148.       NBLINI=ITOPO.NUM(/2)
  149.       NPTINI=IK
  150.       SEGINI IDCP
  151.       NPTBAS=XCOOR(/1)/IDIMP
  152. * On pourrait ameliorer...
  153.       DO 500 I=1,NPTBAS
  154.          if (icpr(i).ne.0) IDCP(ICPR(I))=I
  155.  500  CONTINUE
  156.       if (IMPR.GE.2) then
  157.          write(ioimp,'(A,3I5)')
  158.      $        'opto1 : nb noeuds globaux,locaux,virtuels=',NPTBAS,IK
  159.      $        ,NIPVIR
  160. *         write(ioimp,*) 'ICPR'
  161. *         write(ioimp,187) (ICPR(I),I=1,ICPR(/1))
  162.          if (IMPR.GE.12) then
  163.             write(ioimp,*) 'IDCP'
  164.             write(ioimp,187) (IDCP(I),I=1,IDCP(/1))
  165.          endif
  166.       endif
  167.  125  format ('(A,2(1X,I3),20(2X,''[''',I1,'I3,'']''))')
  168.       IF (IMPR.GE.4) THEN
  169.          nnod=itopo.num(/1)
  170.          nel=itopo.num(/2)
  171.          write(cform,125) nnod
  172.          write(ioimp,cform)
  173.      $        'opto1 : topologie en coord globales nnod,nel=',nnod,nel
  174.      $        ,((itopo.num(ino,iel),ino=1,nnod),iel=1,nel)
  175. *         call ecmai1(itopo,0)
  176. *         segact itopo*mod
  177.       ENDIF
  178. *
  179.       IF (IDIM.EQ.2) THEN
  180.          NELMOY=15
  181.          NPOMOY=10
  182.       ELSEIF (IDIM.EQ.3) THEN
  183.          NELMOY=40
  184.          NPOMOY=20
  185.       ELSE
  186.          write(ioimp,*) 'idim=',idim
  187.          goto 9999
  188.       ENDIF
  189.  
  190.       SEGINI TRAVJ
  191.       NVINI=NBLINI
  192.       NVCOU=NBLINI
  193.       NVMAX=NBLINI+MAX(NELMOY,NBLINI)
  194.       NPINI=NPTINI
  195.       NPCOU=NPTINI
  196.       NPMAX=NPTINI
  197.       IF (IAJNO.NE.0) NPMAX=NPMAX+MAX(NPOMOY,NPTINI)
  198. *
  199. * Melemes en coordonnées locales
  200. *     Topologie
  201.       NBELEM=travj.NVMAX
  202.       NBNN=IDIMP
  203.       NBSOUS=0
  204.       NBREF=0
  205.       SEGINI,JTOPO
  206.       JTOPO.ITYPEL=ITOPO.ITYPEL
  207.       TRAVJ.TOPO=JTOPO
  208.       DO 33 IEL=1,travj.nvcou
  209.          DO 330 INO=1,IDIMP
  210.             IP=ITOPO.NUM(INO,IEL)
  211.             JP=ICPR(IP)
  212.             IF (JP.NE.0) THEN
  213.                JTOPO.NUM(INO,IEL)=JP
  214.             ELSE
  215.                WRITE(IOIMP,*) 'Erreur de programmation'
  216.                GOTO 9999
  217.             ENDIF
  218.  330     CONTINUE
  219.  33   CONTINUE
  220. * Eventuellement, IELEM=ITOP donc à désactiver ici
  221.       SEGDES IELEM
  222.       SEGDES ITOPO
  223.       IF (IMPR.GE.4) THEN
  224.          nnod=jtopo.num(/1)
  225.          nel=travj.nvcou
  226.          write(cform,125) nnod
  227.          write(ioimp,cform)
  228.      $        'opto1 : topologie en coord locales nnod,nel=',nnod,nel
  229.      $        ,((jtopo.num(ino,iel),ino=1,nnod),iel=1,nel)
  230. *         write(ioimp,*) 'opto1.eso : topologie en coord locales : '
  231. *         call ecmai1(jtopo,0)
  232. *         segact jtopo*mod
  233.       ENDIF
  234.  
  235. *     Noeuds virtuels en coordonnées locales
  236.       IF (IPVIRT.NE.0) THEN
  237.          NBELEM=IPVIRT.NUM(/2)
  238.          NBNN=1
  239.          NBSOUS=0
  240.          NBREF=0
  241.          SEGINI,JPVIRT
  242.          JPVIRT.ITYPEL=IPVIRT.ITYPEL
  243.          DO 34 IEL=1,NBELEM
  244.             IP=IPVIRT.NUM(1,IEL)
  245.             JP=ICPR(IP)
  246.             IF (JP.GT.0.OR.JP.LE.NIPVIR) THEN
  247.                JPVIRT.NUM(1,IEL)=JP
  248.             ELSE
  249.                WRITE(IOIMP,*) 'Erreur de programmation JP,NIPVIR=',JP
  250.      $              ,NIPVIR
  251.                GOTO 9999
  252.             ENDIF
  253.  34      CONTINUE
  254.       ELSE
  255.          JPVIRT=0
  256.       ENDIF
  257.       TRAVJ.PVIRT=JPVIRT
  258.       IF (IMPR.GE.4) THEN
  259.          if (jpvirt.ne.0) then
  260.             nnod=jpvirt.num(/1)
  261.             nel=jpvirt.num(/2)
  262.             write(cform,125) nnod
  263.             write(ioimp,cform)
  264.      $           'opto1 : noeuds virtuels en coord locales nnod,nel='
  265.      $           ,nnod,nel,((jpvirt.num(ino,iel),ino=1,nnod),iel=1,nel)
  266. *            write(ioimp,*)
  267. *     $           'opto1 : noeuds virtuels en coord locales :'
  268. *         call ecmai1(jpvirt,0)
  269. *     segact jpvirt*mod
  270.          else
  271.             write(ioimp,*)
  272.      $           'opto1 : pas de noeuds virtuels'
  273.          endif
  274.       ENDIF
  275. *     Element autour duquel on extrait
  276. *         write(ioimp,*) 'opto1.eso : element en coord globales : '
  277. *         call ecmai1(ielem,0)
  278. *         segact ielem*mod
  279.       SEGINI,JELEM=IELEM
  280.       DO 43 IEL=1,JELEM.NUM(/2)
  281.          DO 430 INO=1,JELEM.NUM(/1)
  282.             IP=JELEM.NUM(INO,IEL)
  283.             JP=ICPR(IP)
  284. *     Il faudra gérer le cas où certains noeuds de JELEM sont nuls. Voir
  285. *     dans EXTO3.
  286. *            IF (JP.NE.0) THEN
  287.                JELEM.NUM(INO,IEL)=JP
  288. *            ELSE
  289.              IF (JP.EQ.0) THEN
  290.                 WRITE(IOIMP,*)
  291.      $               'Element fourni non inclus dans la topologie'
  292. *     Pour avoir un comportement identique à la version Gibiane de
  293. *     EXTOPLOC, on annule l'élément. La gestion des éléments nuls est
  294. *     faite dans exto3.eso
  295.                 DO INOO=1,JELEM.NUM(/1)
  296.                    JELEM.NUM(INOO,IEL)=0
  297.                 ENDDO
  298.                 GOTO 43
  299.              ENDIF
  300. *               GOTO 9999
  301. *            ENDIF
  302.  430     CONTINUE
  303.  43   CONTINUE
  304.       IF (IMPR.GE.4) THEN
  305.          nnod=jelem.num(/1)
  306.          nel=jelem.num(/2)
  307.          write(cform,125) nnod
  308.          write(ioimp,cform)
  309.      $        'opto1 : elements en coord locales nnod,nel=',nnod,nel
  310.      $        ,((jelem.num(ino,iel),ino=1,nnod),iel=1,nel)
  311. *         write(ioimp,*) 'opto1.eso : element en coord locales : '
  312. *         call ecmai1(jelem,0)
  313. *         segact jelem*mod
  314.       ENDIF
  315. * Passage des coordonnées en locale
  316. *      NBPTS=NPTINI
  317.       NBPTS=travj.NPMAX
  318.       SEGINI,JCOORD
  319.       TRAVJ.COORD=JCOORD
  320.       DO 53 IPL=1,travj.npcou
  321.          IREFL=IDIMP*(IPL-1)
  322.          IP=IDCP(IPL)
  323.          IREF=IDIMP*(IP-1)
  324.          DO 530 IC=1,IDIMP
  325.             JCOORD.XCOOR(IREFL+IC)=XCOOR(IREF+IC)
  326.  530     CONTINUE
  327.  53   CONTINUE
  328. * Passage de la métrique en local
  329. *
  330.       IF (ICMETR.NE.0) THEN
  331. *     Définition des noms de composantes
  332.          JGN=4
  333.          JGM=0
  334.          IF (IMET.EQ.3) JGM=1
  335.          IF (IMET.EQ.4) JGM=IDIM*(IDIM+1)/2
  336.          SEGINI JNMETR
  337.          DO I=1,JGM
  338.             JNMETR.MOTS(I)='G    '
  339.          ENDDO
  340.          IF (IMET.EQ.4) THEN
  341.             idx=0
  342.             DO I=1,IDIM
  343.                DO J=1,I
  344.                   idx=idx+1
  345.                   WRITE(JNMETR.MOTS(idx)(2:2),FMT='(I1)') I
  346.                   WRITE(JNMETR.MOTS(idx)(3:3),FMT='(I1)') J
  347.                ENDDO
  348.             ENDDO
  349.          ENDIF
  350. *dbg         WRITE (IOIMP,2019) (JNMETR.MOTS(I),I=1,JNMETR.MOTS(/2))
  351. *dbg 2019    FORMAT (20(2X,A4) )
  352.          NNIN=JNMETR.MOTS(/2)
  353.          NNNOE=travj.NPCOU
  354.          if (iveri.ge.1) SEGINI MISDEF
  355.          NNNOE=travj.NPMAX
  356.          SEGINI JCMETR
  357.          MCHPOI=ICMETR
  358.          SEGACT MCHPOI
  359.          NSOUPO=IPCHP(/1)
  360.          DO ISOUPO=1,NSOUPO
  361.             MSOUPO=IPCHP(ISOUPO)
  362.             SEGACT MSOUPO
  363.             NC=NOCOMP(/2)
  364.             MELEME=IGEOC
  365.             MPOVAL=IPOVAL
  366.             SEGACT MELEME
  367.             SEGACT MPOVAL
  368.             N=VPOCHA(/1)
  369.             DO IC=1,NC
  370.                ININ=0
  371.                DO JNIN=1,NNIN
  372.                   IF (NOCOMP(IC).EQ.JNMETR.MOTS(JNIN)) THEN
  373.                      ININ=JNIN
  374.                      GOTO 11
  375.                   ENDIF
  376.                ENDDO
  377.  11            CONTINUE
  378.                IF (ININ.NE.0) THEN
  379.                   DO I=1,N
  380.                      INNOE=ICPR(NUM(1,I))
  381.                      IF (INNOE.NE.0) THEN
  382.                         if (iveri.ge.1) ISDEF(ININ,INNOE)=1
  383.                         JCMETR.XIN(ININ,INNOE)=VPOCHA(I,IC)
  384.                      ENDIF
  385.                   ENDDO
  386.                ENDIF
  387.             ENDDO
  388.             SEGDES MPOVAL
  389.             SEGDES MELEME
  390.             SEGDES MSOUPO
  391.          ENDDO
  392.          SEGDES MCHPOI
  393.          if (iveri.ge.1) then
  394. *     Vérification que la métrique a été définie sur tous les noeuds et
  395. *     toutes les composantes sauf les noeuds virtuels.
  396.             DO 21 J=1,ISDEF(/2)
  397.                IF (JPVIRT.NE.0) THEN
  398.                   DO IEL=1,NBELEM
  399.                      JP=JPVIRT.NUM(1,IEL)
  400.                      if (J.EQ.JP) GOTO 21
  401.                   ENDDO
  402.                ENDIF
  403.                DO I=1,ISDEF(/1)
  404.                   IF (ISDEF(I,J).NE.1) THEN
  405.                      MOT=JNMETR.MOTS(I)
  406.                      INOD=IDCP(J)
  407.                      write(ioimp,*)
  408.      $                    'Metrique non definie pour la composante '
  409.      $                    ,MOT,' au noeud ',INOD
  410.                      GOTO 9999
  411.                   ENDIF
  412.                ENDDO
  413.  21         CONTINUE
  414.             SEGSUP MISDEF
  415.          endif
  416.       ELSE
  417.          JNMETR=0
  418.          JCMETR=0
  419.       ENDIF
  420.       TRAVJ.NMETR=JNMETR
  421.       TRAVJ.CMETR=JCMETR
  422. *tst      WRITE(IOIMP,185) 'SEGMENT JCOORD ',JCOORD
  423. *tst         WRITE(FORMA,FMT='("(1(",I1,"(1PG12.5,2X)))")') IDIMP
  424. *tst         write(ioimp,*) 'forma=',forma
  425. *tst         write(ioimp,*) 'XCOOR'
  426. *tst         write(ioimp,forma)  (jcoord.xcoor(I),I=1,jcoord.xcoor(/1))
  427.       SEGSUP ICPR
  428. * La numérotation globale devient la locale dans ce bloc  !!!
  429.       MCOORD=JCOORD
  430. * Tous les arguments sont potentiellement des entrées-sorties
  431. *     in EXTO2 SEGINI JTOPA
  432. *      write(ioimp,*) ' opto1  : avant opto2 =',OOOVAL(2,1)
  433.       CALL OPTO2(TRAVJ,JELEM,LTOPA)
  434. *      if (iveri.ge.2) call vetopi(travj,'opto1.eso : Apres opto2')
  435. *     if (ierr.ne.0) return
  436. *      write(ioimp,*) 'opto1.eso : Apres opto2'
  437. *      TOPINV=TRAVJ.TOPI
  438. *      segsup topinv
  439.  
  440.       SEGSUP JELEM
  441. *     write(ioimp,*) ' opto1  : apres opto2 =',OOOVAL(2,1)
  442.       IF (IERR.NE.0) GOTO 555
  443. *
  444. *     NPTFIN=JCOORD.XCOOR(/1)/IDIMP
  445.       NPTFIN=travj.npcou
  446.       if (jchang.eq.0) then
  447.          ITOPA=ITOPO
  448.          ICMETA=ICMETR
  449.          if (iseqm.eq.0) then
  450.             IF (NPTINI.NE.NPTFIN) THEN
  451.                write(ioimp,*) nptfin-nptini,' nouveaux noeuds crees'
  452.                write(ioimp,*) 'pas normal car topologie inchangee'
  453.             ENDIF
  454.          endif
  455. *     On rétablit la numérotation globale originelle et on rajoute les
  456. *     noeuds nouvellement créés
  457. *     ! Attention, il faut aussi rétablir le NBPTS suite aux changements
  458. *     !  de Pierre dans SMCOORD
  459.          NBPTS=IBPTS
  460.          MCOORD=ICOORD
  461.       else
  462. *     Mise à jour de la topologie en rétablissant la numérotation
  463. *     globale et en notant les numéros de noeuds utilisés dans ICPR car
  464. *     on va restreindre la métrique interpolée à ces nouveaux noeuds
  465.          IF (JCMETR.NE.0) THEN
  466.             SEGINI ICPR
  467.             IK=0
  468.          ENDIF
  469. *     On ne serait pas obligé de faire ceci mais alors, il faut faire
  470. *     attention au cas où JTOPA=JTOPO
  471. *     SEGINI,ITOPA=JTOPA
  472. *      write(ioimp,*) 'opto1.eso : on a genere la topologie : '
  473. *      call ecmai1(jtopo,0)
  474. *      segact jtopo*mod
  475. *     En place
  476.          JTOPO=TRAVJ.TOPO
  477.          ITOPA =JTOPO
  478. * Pour éviter une suppression dans topsup
  479.          travj.topo=0
  480.          if (nvcou.ne.nvmax) then
  481.             nbnn=idimp
  482.             nbelem=nvcou
  483.             nbsous=0
  484.             nbref=0
  485.             segadj,itopa
  486.          endif
  487. *      write(ioimp,*) 'itopa'
  488. *      call ecmail(itopa,0)
  489. *      segact itopa*mod
  490. * On ajuste le nombre d'éléments
  491.          DO 63 IEL=1,ITOPA.NUM(/2)
  492.             DO 630 INO=1,ITOPA.NUM(/1)
  493.                IPL=ITOPA.NUM(INO,IEL)
  494.                IF (JCMETR.NE.0) THEN
  495.                   IF (ICPR(IPL).EQ.0) THEN
  496.                      IK=IK+1
  497.                      ICPR(IPL)=IK
  498.                   ENDIF
  499.                ENDIF
  500. *
  501.                IF (IPL.LE.NPTINI) THEN
  502.                   IP=IDCP(IPL)
  503.                ELSE
  504.                   IP=IPL-NPTINI+NPTBAS
  505.                ENDIF
  506.                ITOPA.NUM(INO,IEL)=IP
  507.  630        CONTINUE
  508.  63      CONTINUE
  509. *         IF (IMPR.GE.3) THEN
  510. *            write(ioimp,*) 'opto1.eso : topologie amelioree totale : '
  511. *            call ecmai1(itopa,0)
  512. *         ENDIF
  513.          if (iseqm.ne.0) then
  514.             NOBJ=LTOPA.LISOBJ(/1)
  515.             DO IOBJ=1,NOBJ
  516.                MELEME=LTOPA.LISOBJ(IOBJ)
  517.                segact meleme*mod
  518.                DO IEL=1,NUM(/2)
  519.                   DO INO=1,NUM(/1)
  520.                      IPL=NUM(INO,IEL)
  521.                      IF (IPL.LE.NPTINI) THEN
  522.                         IP=IDCP(IPL)
  523.                      ELSE
  524.                         IP=IPL-NPTINI+NPTBAS
  525.                      ENDIF
  526.                      NUM(INO,IEL)=IP
  527.                   ENDDO
  528.                ENDDO
  529. *               write(ioimp,*) 'IOBJ=',IOBJ
  530. *               call ecmai1(meleme,0)
  531.             ENDDO
  532.          endif
  533.          IF (JCMETR.NE.0) THEN
  534. *     La nouvelle métrique
  535.             NNIN=JCMETR.XIN(/1)
  536.             NNNOE=TRAVJ.NPCOU
  537. *dbg               npmax=jcmetr.xin(/2)
  538. *dbg               write(ioimp,*) 'nnin,nnnoe,npmax=',nnin,nnnoe,npmax
  539. *
  540.             NSOUPO=1
  541.             NAT=1
  542.             SEGINI,MCHPOI
  543.             IFOPOI=IFOUR
  544.             JATTRI(1)=1
  545.             MTYPOI='        '
  546.             MOCHDE='            CHPOINT CREE PAR OPTO  '
  547.             NC=NNIN
  548.             SEGINI,MSOUPO
  549.             IPCHP(1)=MSOUPO
  550.             DO ININ=1,NNIN
  551.                NOCOMP(ININ)=JNMETR.MOTS(ININ)
  552.             ENDDO
  553.             NBSOUS=0
  554.             NBREF=0
  555.             NBNN=1
  556.             NBELEM=IK
  557.             N=NBELEM
  558.             SEGINI,MPOVAL
  559.             SEGINI,MELEME
  560.             ITYPEL=1
  561.             DO INNOE=1,NNNOE
  562.                JK=ICPR(INNOE)
  563.                IF (JK.NE.0) THEN
  564.                   IF (INNOE.LE.NPTINI) THEN
  565.                      NUM(1,JK)=IDCP(INNOE)
  566.                   ELSE
  567.                      NUM(1,JK)=INNOE-NPTINI+NPTBAS
  568.                   ENDIF
  569.                   DO ININ=1,NNIN
  570.                      VPOCHA(JK,ININ)=JCMETR.XIN(ININ,INNOE)
  571.                   ENDDO
  572.                ENDIF
  573.             ENDDO
  574.             IGEOC=MELEME
  575.             IPOVAL=MPOVAL
  576.             SEGSUP ICPR
  577. *            SEGDES,MPOVAL
  578. *            SEGDES,MSOUPO
  579. *            SEGDES,MELEME
  580. *            SEGDES,MCHPOI
  581.             ICMETA=MCHPOI
  582.          ELSE
  583.             ICMETA=0
  584.          ENDIF
  585.          SEGSUP IDCP
  586. *     On rétablit la numérotation globale originelle et on rajoute les
  587. *     noeuds nouvellement créés
  588. *     ! Attention, il faut aussi rétablir le NBPTS suite aux changements
  589. *     !  de Pierre dans SMCOORD
  590.          NBPTS=IBPTS
  591.          MCOORD=ICOORD
  592.          IF (NPTINI.NE.NPTFIN) THEN
  593.             SEGACT MCOORD*MOD
  594.             if (impr.ge.4)
  595.      $           write(ioimp,'(A,I6,1X,A)') 'opto1 :',nptfin-nptini
  596.      $           ,'nouveaux noeuds crees'
  597.             NBPTA=NPTBAS
  598.             NBPTS=NBPTA+NPTFIN-NPTINI
  599.             SEGADJ MCOORD
  600.             DO 5000 I=NPTINI+1,NPTFIN
  601.                DO 5010 J=1,IDIM
  602.                   XCOOR(NBPTA*IDIMP+J)=JCOORD.XCOOR((I-1)*IDIMP+J)
  603.  5010          CONTINUE
  604.                NBPTA=NBPTA+1
  605.  5000       CONTINUE
  606.             SEGACT MCOORD
  607.          ENDIF
  608.       ENDIF
  609. *      if (iveri.ge.2) call vetopi(travj,'opto1.eso : Avant topsup')
  610. *      if (ierr.ne.0) return
  611. *      write(ioimp,*) 'opto1 fin : nbpts, xcoor=',nbpts,xcoor(/1)/(idim
  612. *     $     +1)
  613. *      SEGDES MCOORD
  614. *     write(ioimp,*) ' opto1  : avant segsup=',OOOVAL(2,1)
  615. *     if (icmeta.ne.0) SEGDES ICMETA
  616. *     Ici Jcoors
  617. *      write(ioimp,*) 'av topsup travj'
  618.       CALL TOPSUP(TRAVJ)
  619. *      write(ioimp,*) ' opto1  : apres segsup=',OOOVAL(2,1)
  620. *
  621. * Normal termination
  622. *
  623.       RETURN
  624. *
  625. * Format handling
  626. *
  627.  185  FORMAT (/2X,10(A16,'=',I8,2X)/)
  628.  187  FORMAT (5X,10I8)
  629. *
  630. * Error handling
  631. *
  632. *     Point de branchement si erreur pendant le bloc en numérotation
  633. *     locale
  634. *     Il faut rétablir la numérotation globale
  635.  555  CONTINUE
  636.       NBPTS=IBPTS
  637.       MCOORD=ICOORD
  638.       RETURN
  639. *
  640.  9999 CONTINUE
  641.       MOTERR(1:8)='OPTO1   '
  642. * 349 2
  643. *Problème non prévu dans le s.p. %m1:8 contactez votre assistance
  644.       CALL ERREUR(349)
  645.       RETURN
  646. *
  647. * End of subroutine OPTO1
  648. *
  649.       END
  650.  
  651.  

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