Télécharger la plaquette Cast3M


fr en

Télécharger extrel.eso

Retour à la liste

Numérotation des lignes : 

extrel

  1. C EXTREL    SOURCE    JB251061  22/01/03    21:15:16     11236          
  2. C
  3. C    CE SOUS PROGRAMME A POUR OBJET D'EXTRAIRE D'UN OBJET COMPLEXE
  4. C    LE SOUS OBJET FORME DES ELEMENTS DEMANDES
  5. C    LA SYNTAXE EN EST :
  6. C     ELEM  |  (TYPE SI PLUSIEURS) | (IEL)
  7. C                                  | (LISTE ENTIERS)
  8. C           |  CONTENANT   POINT (TOUS)
  9. C           |  APPUYES   | (LARGE) OBJ
  10. C                        |  STRICT
  11. C
  12.       SUBROUTINE EXTREL(IRR,IFLAG,LIEL)
  13.  
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8 (A-H,O-Z)
  16.  
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC CCGEOME
  21. -INC CCREEL
  22.  
  23. -INC SMLENTI
  24. -INC SMLMOTS
  25. -INC SMELEME
  26. -INC SMCOORD
  27.  
  28.       SEGMENT ISOM(NBS)
  29.  
  30.       PARAMETER (NCLE=6)
  31.       CHARACTER*4 MCLE(NCLE),MOTM(9),MOABS(1),MOTAV(2)
  32.       CHARACTER*4 MSCLE(3),MCLE2(1)
  33.       DIMENSION INBC(10)
  34.       DATA MOTAV/'AVEC','SANS'/
  35.       DATA MOTM/'MAXI','MINI','SUPE','EGSU',
  36.      .     'EGAL','EGIN','INFE','DIFF','COMP'/
  37.       DATA MOABS/'ABS '/
  38.       DATA MCLE/'CONT','APPU','TYPE','COUL','COMP','ZONE'/
  39.       DATA MSCLE/'STRI','LARG','NOVE'/
  40.       DATA MCLE2/'TOUS'/
  41.  
  42. C     INITIALISATIONS
  43.       IRR =0
  44.       LIEL=0
  45.       IOB =0
  46.  
  47. c     LECTURE DU MAILLAGE
  48.       CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  49.       IF (IERR.NE.0) RETURN
  50.       IF (IRETOU.EQ.0) GOTO 5000
  51. *
  52. *     EXTRACTION DES ELEMENTS D'UN MAILLAGE
  53. *
  54.       SEGACT MELEME
  55.  
  56.       NIEL=0
  57.       ISOM=0
  58. c  icle2 relatif a l option TOUS, NIEL= nbre d EF trouves
  59.       ICLE2=0
  60. c  LECTURE DES MOTS-CLE
  61.       CALL LIRMOT(NOMS,NOMBR,IDES,0)
  62.       IF (IERR.NE.0) RETURN
  63.       IF (IDES.NE.0) GOTO 2
  64.       CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  65.       IF (IERR.NE.0) RETURN
  66.       IF (ICOUL.NE.0) GOTO 11
  67.       CALL LIRMOT(MCLE,NCLE,IMLU,0)
  68.       IF (IERR.NE.0) RETURN
  69.       IF (IMLU.NE.0) GOTO 20
  70.  
  71.  
  72. C ********************************************************************
  73. C SYNTAXE SANS MOT-CLE
  74. C ********************************************************************
  75.  
  76. C  ON N'A PAS LU DE MOT-CLE ON PEUT CONTINUER SI L'OBJET CONTIENT UN
  77. C  SEUL TYPE D'ELEMENT
  78.       IF (LISOUS(/1).NE.0) THEN
  79.         CALL ERREUR(25)
  80.         RETURN
  81.       ENDIF
  82.       IDES = meleme.ITYPEL
  83.  2    CONTINUE
  84.       IF (LISOUS(/1).NE.0) GOTO 3
  85.       IF (ITYPEL.NE.IDES) THEN
  86.         CALL ERREUR(26)
  87.         RETURN
  88.       ENDIF
  89.       GOTO 4
  90.  3    CONTINUE
  91.       if (ides.ne.22.and.ides.ne.48) then
  92.         DO 5 I=1,LISOUS(/1)
  93.          IPT2=LISOUS(I)
  94.          SEGACT IPT2
  95.          IF(IPT2.ITYPEL.EQ.IDES)GOTO 6
  96.          SEGACT IPT2
  97.  5         CONTINUE
  98.         CALL ERREUR(26)
  99.         SEGACT MELEME
  100.         RETURN
  101.       else
  102.         nbso=0
  103.         do 555 I=1,LISOUS(/1)
  104.         IPT2=LISOUS(I)
  105.         SEGACT IPT2
  106.         if (IPT2.ITYPEL.EQ.IDES) then
  107.           nbso=nbso+1
  108.           if (nbso.gt.10) then
  109.             call erreur(279)
  110.             return
  111.           endif
  112.           inbc(nbso)=ipt2
  113.           SEGACT ipt2
  114.         endif
  115.  555    continue
  116.         if (nbso.eq.0) then
  117.           call erreur(26)
  118.           SEGACT meleme
  119.           return
  120.         elseif(nbso.eq.1) then
  121.           ipt2=inbc(1)
  122.           goto 1000
  123.         else
  124.           nbnn=0
  125.           nbelem=0
  126.           nbsous=nbso
  127.           nbref=0
  128.           segini ipt2
  129.           do jo =1,nbso
  130.             ipt2.lisous(jo)=inbc(jo)
  131.           enddo
  132.           goto 1000
  133.         endif
  134.       endif
  135.  6    CONTINUE
  136.       SEGACT MELEME
  137.       MELEME=IPT2
  138.       CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  139.       IF (IERR.NE.0) RETURN
  140.       IF (ICOUL.NE.0) GOTO 11
  141.  4    CONTINUE
  142.       CALL LIRENT(IEL,0,IRETOU)
  143.       IF (IERR.NE.0) RETURN
  144.       IF (IRETOU.EQ.0) GOTO 50
  145.  
  146. C  ECRITURE DU MAILLAGE RESULTATS
  147.  7    CONTINUE
  148.       SEGACT MELEME
  149. C     qq verif
  150.       IF (IEL.LE.0.OR.IEL.GT.NUM(/2)) THEN
  151.         CALL ERREUR(262)
  152.         RETURN
  153.       ENDIF
  154. C     creation (ou ajustement du meleme resultat)
  155.       NBSOUS =0
  156.       NBREF  =0
  157.       NBNN   =NUM(/1)
  158.       IF ((ICLE2.EQ.0).OR.(NIEL.EQ.0)) THEN
  159.         NBELEM=1
  160.         SEGINI,IPT2
  161.       ELSE
  162. C        BP: pour l instant on suppose qu on a qu 1 seul type d element
  163.         NBELEM=NIEL+1
  164.         SEGADJ,IPT2
  165.       ENDIF
  166.       IPT2.ITYPEL=ITYPEL
  167.       IPT2.ICOLOR(NBELEM)=ICOLOR(IEL)
  168.       DO 8 I=1,NBNN
  169.         IPT2.NUM(I,NBELEM)=NUM(I,IEL)
  170.  8    CONTINUE
  171.       NIEL=NBELEM
  172.       LIEL=IEL
  173.       IF (ISOM.NE.0) SEGACT,ISOM
  174. C   OPTION 'TOUS' : ON RECOMMENCE
  175.       IF (ICLE2.NE.0) THEN
  176.         IOB1=IOB
  177.         JDEB1=IEL+1
  178.         IF(JDEB1.LE.NUM(/2)) GOTO 25
  179.         JDEB1=1
  180.         IOB1=IOB1+1
  181.         IF(IOB1.LE.MAX(1,LISOUS(/1))) GOTO 25
  182.       ENDIF
  183.       GOTO 1000
  184. C  CAR C'EST FINI
  185.  11   CONTINUE
  186.       ICOUL=ICOUL-1
  187. C     DETERMINATION DES ELEMENTS D'UNE COULEUR DONNEE:ICOUL
  188. C     REMPLIR LE TABLEAU DU NOMBRE DES ELEMENTS
  189.       DO 12 I=1,10
  190.         INBC(I)=0
  191.  12   CONTINUE
  192.       ICPT=0
  193.       IPT1=MELEME
  194.       DO 13 I=1,MAX(1,LISOUS(/1))
  195.         IF (LISOUS(/1).NE.0) THEN
  196.           IPT1=LISOUS(I)
  197.           SEGACT IPT1
  198.         ENDIF
  199.         ICPT=ICPT+1
  200.         DO 15 J=1,IPT1.NUM(/2)
  201.           IF(IPT1.ICOLOR(J).EQ.ICOUL) INBC(ICPT)=INBC(ICPT)+1
  202.  15     CONTINUE
  203.         IF(LISOUS(/1).NE.0) SEGACT IPT1
  204.  13   CONTINUE
  205.       NB=0
  206.       DO 17 I=1,10
  207.         IF(INBC(I).NE.0) NB=NB+1
  208.  17   CONTINUE
  209.       IF (NB.EQ.0) CALL ERREUR(222)
  210.       IF (NB.EQ.1) THEN
  211.         NBSOUS=0
  212.         NBREF=0
  213.         IF (LISOUS(/1).NE.0) THEN
  214.           DO 18 I=1,10
  215.             IF(INBC(I).NE.0) IREP=I
  216.  18       CONTINUE
  217.           IPT1=LISOUS(IREP)
  218.           SEGACT IPT1
  219.           NBNN=IPT1.NUM(/1)
  220.           NBELEM=INBC(IREP)
  221.         ELSE
  222.           NBNN=NUM(/1)
  223.           NBELEM=INBC(1)
  224.           IPT1=MELEME
  225.         ENDIF
  226.         SEGINI IPT2
  227.         II=0
  228.         IPT2.ITYPEL=IPT1.ITYPEL
  229.         DO 19 J=1,IPT1.NUM(/2)
  230.           IF(IPT1.ICOLOR(J).NE.ICOUL) GOTO 19
  231.           II=II+1
  232.           IPT2.ICOLOR(II)=ICOUL
  233.           DO 93 I=1,NBNN
  234.             IPT2.NUM(I,II)=IPT1.NUM(I,J)
  235.  93       CONTINUE
  236.  19     CONTINUE
  237.         IF(LISOUS(/1).NE.0) SEGACT IPT1
  238.       ELSE
  239.         NBSOUS=NB
  240.         NBREF=0
  241.         NBNN=0
  242.         NBELEM=0
  243.         SEGINI IPT2
  244.         IB=0
  245.         DO 90 I=1,10
  246.           IF(INBC(I).EQ.0) GOTO 90
  247.           IB=IB+1
  248.           IPT3=LISOUS(I)
  249.           SEGACT IPT3
  250.           NBSOUS=0
  251.           NBREF=0
  252.           NBNN=IPT3.NUM(/1)
  253.           NBELEM=INBC(I)
  254.           SEGINI IPT4
  255.           IPT4.ITYPEL=IPT3.ITYPEL
  256.           II=0
  257.           DO 91 J=1,IPT3.NUM(/2)
  258.             IF(IPT3.ICOLOR(J).NE.ICOUL) GOTO 91
  259.             II=II+1
  260.             IPT4.ICOLOR(II)=ICOUL
  261.             DO 94 K=1,NBNN
  262.               IPT4.NUM(K,II)=IPT3.NUM(K,J)
  263.  94         CONTINUE
  264.  91       CONTINUE
  265.           SEGACT IPT3
  266.           IPT2.LISOUS(IB)=IPT4
  267.           SEGACT IPT4
  268.  90     CONTINUE
  269.         SEGACT IPT2
  270.       ENDIF
  271.       SEGACT MELEME
  272.       MELEME=IPT2
  273.       CALL LIRMOT (NOMS,NOMBR,IDES,0)
  274.       IF(IDES.NE.0) GOTO 2
  275.       GOTO 4
  276.  
  277. C ********************************************************************
  278. C ********************************************************************
  279.  
  280.  20   CONTINUE
  281.  
  282. c  ON A LU  'CONT', 'APPU', 'TYPE', 'COUL', 'COMP', ou 'ZONE'
  283.       IF(IMLU.NE.1) GOTO 30
  284.  
  285.  
  286. C ********************************************************************
  287. C SYNTAXE 'CONTENANT'
  288. C ********************************************************************
  289.  
  290. C  ON VEUT LIROBJ UN POINT
  291.       CALL LIROBJ('POINT   ',IP,1,IRETOU)
  292.       IF(IERR.NE.0) RETURN
  293.       SEGACT MCOORD
  294.       IREFP=(IP-1)*(IDIM+1)+1
  295.       XP=XCOOR(IREFP)
  296.       YP=XCOOR(IREFP+1)
  297.       ZP=XCOOR(IREFP+2)
  298.       IF(IDIM.EQ.2) ZP=0.D0
  299. C BP: cherche t on 'TOUS' les elements qui contiennent ce point ?
  300.       ICLE2=0
  301.       CALL LIRMOT(MCLE2,1,ICLE2,0)
  302. C sg option noverif
  303.       NOVER=0
  304.       CALL LIRMOT(MSCLE(3),1,NOVER,0)
  305. C        NIEL = nbre d'EF trouvés, IOB1 et JDEB1 = debut de boucles
  306.       NIEL =0
  307.       IOB1 =1
  308.       JDEB1=1
  309.  25   CONTINUE
  310.       IPT1=MELEME
  311. C     BOUCLE SUR LES EVENTUELS SOUS-OBJETS
  312.       DO 22 IOB=IOB1,MAX(1,LISOUS(/1))
  313.         IF (LISOUS(/1).NE.0) THEN
  314.           IPT1=LISOUS(IOB)
  315.           SEGACT IPT1
  316.         ENDIF
  317. C 21    CONTINUE
  318. C
  319. cbp2016 : tous les elements doivent avoir toutes leurs faces orientees
  320. cbp2016   dans la meme direction (vers l'interieur)
  321. cbp2016            IA1 = 0
  322. cbp2016            IF(IPT1.ITYPEL.EQ.14.OR.IPT1.ITYPEL.EQ.15)IA1 = 1
  323. cbp2016            IF(IPT1.ITYPEL.EQ.16.OR.IPT1.ITYPEL.EQ.17)IA1 = 7
  324. C
  325.       NBNN=IPT1.NUM(/1)
  326.       IF(KSURF(IPT1.ITYPEL).NE.0) GOTO 60
  327. C  C'EST UNE LIGNE
  328. C  Recherche du point le plus proche + élément contenant ce point
  329.       IPT5 = IPT1
  330.       CALL CHANGE(IPT5,1)
  331.       IF (IERR.NE.0) RETURN
  332.       CALL ECROBJ('POINT   ',IP)
  333.       CALL ECRCHA('PROC')
  334.       CALL ECROBJ('MAILLAGE',IPT5)
  335.       CALL POIEXT
  336.       CALL LIROBJ('POINT   ',IP1,1,IRETOU)
  337.       IF (IERR.NE.0) RETURN
  338.       SEGACT IPT1
  339.       DO 40 J=JDEB1,IPT1.NUM(/2)
  340.          DO 41 K=1,NBNN
  341.             IF (IPT1.NUM(K,J).EQ.IP1) THEN
  342.               GOTO 100
  343.             ENDIF
  344.  41      CONTINUE
  345.  40   CONTINUE
  346.       GOTO 23
  347.  
  348.  60   IF(KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 70
  349. C  C'EST UNE SURFACE
  350.       NBS = NBSOM(IPT1.ITYPEL)
  351.       IF (NBS.EQ.0) THEN
  352. C        Polygone a N cotes
  353.          NBS = IPT1.NUM(/1)
  354.       ENDIF
  355.       SEGINI ISOM
  356.       DO 61 I=1,ISOM(/1)
  357.          ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I)
  358.  61   CONTINUE
  359.       DO 62 J=JDEB1,IPT1.NUM(/2)
  360.          I1=IPT1.NUM(ISOM(1),J)
  361.          I2=IPT1.NUM(ISOM(2),J)
  362.          I3=IPT1.NUM(ISOM(3),J)
  363.          IREF1=(I1-1)*(IDIM+1)
  364.          IREF2=(I2-1)*(IDIM+1)
  365.          IREF3=(I3-1)*(IDIM+1)
  366.          X1=XCOOR(IREF1+1)
  367.          X2=XCOOR(IREF2+1)
  368.          X3=XCOOR(IREF3+1)
  369.          Y1=XCOOR(IREF1+2)
  370.          Y2=XCOOR(IREF2+2)
  371.          Y3=XCOOR(IREF3+2)
  372.          Z1=XCOOR(IREF1+3)
  373.          Z2=XCOOR(IREF2+3)
  374.          Z3=XCOOR(IREF3+3)
  375.          XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3)
  376.          YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3)
  377.          ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3)
  378.          IF (IDIM.EQ.2) THEN
  379.             XNORM=0.D0
  380.             YNORM=0.D0
  381.          ENDIF
  382.          DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2)
  383.          XNORM=XNORM/DNORM
  384.          YNORM=YNORM/DNORM
  385.          ZNORM=ZNORM/DNORM
  386.          ANG=0.D0
  387.          I1=IPT1.NUM(ISOM(ISOM(/1)),J)
  388.          IREF1=(I1-1)*(IDIM+1)
  389.          XV1=XCOOR(IREF1+1)-XP
  390.          YV1=XCOOR(IREF1+2)-YP
  391.          ZV1=XCOOR(IREF1+3)-ZP
  392.          IF(IDIM.EQ.2) ZV1=0.D0
  393.          DO 63 IS=1,ISOM(/1)
  394.             I2=IPT1.NUM(ISOM(IS),J)
  395.             IREF2=(I2-1)*(IDIM+1)
  396.             XV2=XCOOR(IREF2+1)-XP
  397.             YV2=XCOOR(IREF2+2)-YP
  398.             ZV2=XCOOR(IREF2+3)-ZP
  399.             IF(IDIM.EQ.2) ZV2=0.D0
  400.             XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+
  401.      #           ZNORM*(XV1*YV2-YV1*XV2)
  402.             YATA=XV1*XV2+YV1*YV2+ZV1*ZV2
  403.             IF(XATA.EQ.0.D0.AND.YATA.EQ.0.D0) GOTO 100
  404.             IF (IFLAG.EQ.1) THEN
  405.                IF(ABS(ABS(ATAN2(XATA,YATA))-XPI).LT.0.0001D0) GOTO 100
  406.             ENDIF
  407.             ANG=ANG+ATAN2(XATA,YATA)
  408.             XV1=XV2
  409.             YV1=YV2
  410.             ZV1=ZV2
  411.  63      CONTINUE
  412.          IF (IFLAG.EQ.1) THEN
  413.             IF(ABS(ABS(ANG)-XPI).LT.0.0001D0) GOTO 100
  414.          ENDIF
  415.          IF(ABS(ANG).GT.XPI) GOTO 100
  416.  62   CONTINUE
  417.       SEGSUP ISOM
  418.       ISOM=0
  419.       GOTO 23
  420.  
  421.  70   CONTINUE
  422. C  C'EST UN VOLUME
  423.       NBFAC=LTEL(1,IPT1.ITYPEL)
  424.       IAD=LTEL(2,IPT1.ITYPEL)-1
  425.       IF(NBFAC.EQ.0) GOTO 23
  426.       DO 71 J=JDEB1,IPT1.NUM(/2)
  427.          XMI=XGRAND
  428.          XMA=-XGRAND
  429.          YMI=XGRAND
  430.          YMA=-XGRAND
  431.          ZMI=XGRAND
  432.          ZMA=-XGRAND
  433.          DO 710 KKI=1,IPT1.NUM(/1)
  434.             IA=(IPT1.NUM(KKI,J)-1)*( IDIM+1)
  435.             XMI=MIN(XMI,XCOOR(IA+1))
  436.             XMA=MAX(XMA,XCOOR(IA+1))
  437.             YMI=MIN(YMI,XCOOR(IA+2))
  438.             YMA=MAX(YMA,XCOOR(IA+2))
  439.             ZMI=MIN(ZMI,XCOOR(IA+3))
  440.             ZMA=MAX(ZMA,XCOOR(IA+3))
  441.  710     CONTINUE
  442.          XXM=XMA-XMI
  443.          YYM=YMA-YMI
  444.          ZZM=ZMA-ZMI
  445.          IF( XXM.EQ.0.D0.OR.YYM.EQ.0.D0.OR.ZZM.EQ.0.D0) THEN
  446.             CALL ERREUR(26)
  447.             RETURN
  448.          ENDIF
  449.          XDE=((XMI-XP)*(XP-XMA))/XXM/XXM
  450.          YDE=((YMI-YP)*(YP-YMA))/YYM/YYM
  451.          ZDE=((ZMI-ZP)*(ZP-ZMA))/ZZM/ZZM
  452.          IF(XDE.LT.-0.001D0.OR.YDE.LT.-0.001D0.OR.ZDE.LT.-0.001D0)
  453.      $     GOTO 71
  454.          ANG=0.D0
  455. cbp2016         IMULT = 1
  456.          DO 72 IFAC=1,NBFAC
  457. cbp2016            IF(IA1.NE.0) IMULT = KSIF(IA1+IFAC-1)
  458.             ITYP=LDEL(1,IAD+IFAC)
  459.             NPFAC=KDFAC(1,ITYP)
  460.             IF (NPFAC.EQ.0) THEN
  461. C              Polygone a n cotes
  462.                NPFAC = IPT1.NUM(/1)
  463.             ENDIF
  464.             JAD=LDEL(2,IAD+IFAC)-1
  465.             IA=IPT1.NUM(LFAC(JAD+1),J)
  466.             IREFA=(IA-1)*(IDIM+1)+1
  467.             DO 73 MAUX=3,NPFAC
  468.                IB=IPT1.NUM(LFAC(JAD+MAUX-1),J)
  469.                IC=IPT1.NUM(LFAC(JAD+MAUX),J)
  470.                IREFB=(IB-1)*(IDIM+1)+1
  471.                IREFC=(IC-1)*(IDIM+1)+1
  472.                CALL ANGSOL(XCOOR(IREFP),XCOOR(IREFA),XCOOR(IREFB)
  473.      $                    ,XCOOR(IREFC),AN,IFLAG,IFLIG)
  474.                IF(IERR .NE. 0) RETURN
  475.                IF (IFLAG.EQ.1) THEN
  476.                   IF(ABS(ABS(AN)-(2.D0*XPI)) .LT. 1D-4) GOTO 100
  477.                   IF(IFLIG.EQ.1) GOTO 100
  478.                ENDIF
  479. cbp2016               ANG=ANG+AN*IMULT
  480.                ANG=ANG+AN
  481.  73         CONTINUE
  482.  72      CONTINUE
  483.          IF(ABS(ANG) .GT. XPI) GOTO 100
  484.  71   CONTINUE
  485.  23   CONTINUE
  486.       IF(LISOUS(/1).NE.0) SEGACT IPT1
  487.       JDEB1=1
  488.  22   CONTINUE
  489. C     FIN DE BOUCLE SUR LES SOUS-OBJETS MAILLAGE
  490. c     Option 'TOUS' + on a trouve au moins 1 element => fin heureuse
  491.       IF((ICLE2.NE.0).AND.(NIEL.GE.1)) GOTO 1000
  492. c     Sinon c est qu on rien trouve => erreur si nover=0
  493.       IF (NOVER.EQ.1) THEN
  494.          CALL MELVID(ilcour,ipt2)
  495.          GOTO 1000
  496.       ENDIF
  497.       SEGACT MELEME
  498.       IRR=1
  499.       RETURN
  500.  
  501.  100  IF (LISOUS.NE.0) SEGACT MELEME
  502.       MELEME=IPT1
  503.       IEL=J
  504.       GOTO 7
  505.  
  506.  50   CONTINUE
  507. C  ON LIT UN OBJET MLENTI
  508.       CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
  509.       IF(IRETOU.EQ.0) GOTO 58
  510.       SEGACT MLENTI
  511.       NBNN=NUM(/1)
  512.       NBELEM=LECT(/1)
  513.       NBSOUS=0
  514.       NBREF=0
  515.       IF(NBELEM.EQ.0) CALL ERREUR(25)
  516.       SEGINI IPT2
  517.       IPT2.ITYPEL=ITYPEL
  518.       DO 51 JJ=1,NBELEM
  519.          J=LECT(JJ)
  520.          IF(J.LE.0.OR.J.GT.NUM(/2)) CALL ERREUR(36)
  521.          IF(IERR.NE.0) GOTO 55
  522.          IPT2.ICOLOR(JJ)=ICOLOR(J)
  523.          DO 52 I=1,NBNN
  524.             IPT2.NUM(I,JJ)=NUM(I,J)
  525.  52      CONTINUE
  526.  51   CONTINUE
  527.       SEGACT MLENTI
  528.       GOTO 1000
  529.  58   CONTINUE
  530.       IPT2=MELEME
  531.       GOTO 1001
  532.  55   SEGSUP IPT2
  533.       SEGACT MELEME
  534.       RETURN
  535.  1000 CONTINUE
  536.       SEGACT MELEME
  537.  1001 SEGACT IPT2
  538.       CALL ECROBJ('MAILLAGE',IPT2)
  539.       RETURN
  540.  
  541. C ********************************************************************
  542. C ********************************************************************
  543.  
  544.  30   CONTINUE
  545.       IF(IMLU.NE.2) GOTO 330
  546.  
  547.  
  548. C ********************************************************************
  549. C SYNTAXE 'APPUYE'
  550. C ********************************************************************
  551.  
  552. C  ON A LU APPUYE ON LIT UN DEUXIEME OBJET ET ON FAIT EN SORTE QUE
  553. C  CE SOIT DES POINTS
  554. C  MODIF MAI 1986 ON AUTORISE A LIROBJ UN SEUL POINT
  555. C  NOUVELLE OPTION STRICT LARGE
  556.       CALL LIRMOT(MSCLE,2,IMSLU,0)
  557.       IF(IMSLU.EQ.0) IMSLU=1
  558.       CALL LIROBJ('MAILLAGE',IPT1,0,IPLU)
  559.       IF (IPLU.EQ.0) THEN
  560.          CALL LIROBJ('POINT   ',IPT1,1,IRETOU)
  561.          IF(IERR.NE.0) RETURN
  562.          CALL CRELEM(IPT1)
  563.       ELSE
  564.          SEGACT IPT1
  565.          IPLU=IPT1.ITYPEL
  566.          IF(IPLU.NE.1) CALL CHANGE(IPT1,1)
  567.       ENDIF
  568.       NOVER=0
  569.       CALL LIRMOT(MSCLE(3),1,NOVER,0)
  570.  
  571. C  ON A LU TOUS LES OBJETS DONT ON A BESOIN
  572. C  ON APPELLE ELEMAP POUR FAIRE LE TRAVAIL
  573.       ipt3 = 0
  574.       call elemap(meleme, ipt1, imslu, ipt3, nltot)
  575.  
  576. C  ON VERIFIE QUE TOUT S'EST BIEN PASSE
  577.       if(ierr.eq.0.and.ipt3.ne.0) then
  578.         if(nltot.eq.0.and.nover.eq.0) then
  579.           irr = 1
  580.         else
  581. C  ON ECRIT LE MAILLAGE RESULTAT
  582.           segact ipt3
  583.           call ecrobj('MAILLAGE', ipt3)
  584.         endif
  585.       endif
  586.       return
  587.  
  588. C ********************************************************************
  589. C ********************************************************************
  590.  
  591.  330  CONTINUE
  592.       IF(IMLU.NE.3) GOTO 340
  593.  
  594.  
  595. C ********************************************************************
  596. C SYNTAXE 'TYPE'
  597. C ********************************************************************
  598.  
  599.       I1 = meleme.LISOUS(/1)
  600.       JGN=4
  601.       JGM=MAX(1,I1)
  602.       SEGINI MLMOTS
  603.       IF (I1.EQ.0) THEN
  604.         MOTS(1)=NOMS(ITYPEL)
  605.       ELSE
  606.         DO 33 I=1,I1
  607.           IPT2=LISOUS(I)
  608.           SEGACT IPT2
  609.           IDES=IPT2.ITYPEL
  610.           MOTS(I)=NOMS(IDES)
  611.           SEGACT IPT2
  612.  33     CONTINUE
  613.       ENDIF
  614.       SEGACT MLMOTS
  615.       SEGACT,MELEME
  616.       CALL ECROBJ('LISTMOTS',MLMOTS)
  617.       RETURN
  618.  
  619. C ********************************************************************
  620. C ********************************************************************
  621.  
  622.  340  CONTINUE
  623. C
  624. C---- LISTMOTS des COULeurs
  625.       IF(IMLU.NE.4) GOTO 350
  626.  
  627.  
  628. C ********************************************************************
  629. C SYNTAXE 'COUL'
  630. C ********************************************************************
  631.  
  632.       CALL LIRENT(ICOUL,0,IRETOU)
  633.       IF (IERR.NE.0) RETURN
  634.       IF (IRETOU.EQ.1) GOTO 11
  635. C
  636.       JG=NBCOUL+1
  637.       SEGINI,MLENTI
  638.       DO IE1=1,NBCOUL+1
  639.          LECT(IE1)=0
  640.       ENDDO
  641.       I1=LISOUS(/1)
  642.       DO IE1=1,MAX(I1,1)
  643.          IF (I1.EQ.0)THEN
  644.             IPT2=MELEME
  645.          ELSE
  646.             IPT2=LISOUS(IE1)
  647.             SEGACT,IPT2
  648.          ENDIF
  649.          DO IE2=1,IPT2.ICOLOR(/1)
  650.             LECT(IPT2.ICOLOR(IE2)+1)=1
  651.          ENDDO
  652. C        SEGACT,IPT2
  653.       ENDDO
  654. C     SEGACT,MELEME
  655. C
  656.       JGN=4
  657.       JGM=0
  658.       DO IE1=1,NBCOUL
  659.          JGM=JGM+LECT(IE1)
  660.       ENDDO
  661.       SEGINI MLMOTS
  662.       JGM=0
  663.       IF (LECT(1).NE.0)THEN
  664.         JGM=JGM+1
  665.         MOTS(JGM)='DEFA'
  666.       ENDIF
  667. C
  668.       DO IE1=2,NBCOUL+1
  669.          IF (LECT(IE1).NE.0)THEN
  670.             JGM=JGM+1
  671.             MOTS(JGM)=NCOUL(IE1-1)
  672.          ENDIF
  673.       ENDDO
  674.       SEGSUP,MLENTI
  675.       SEGACT,MLMOTS
  676.       CALL ECROBJ('LISTMOTS',MLMOTS)
  677.       RETURN
  678.  
  679. C ********************************************************************
  680. C ********************************************************************
  681.  
  682.  350     CONTINUE
  683.  
  684.       IF(IMLU.NE.5) GOTO 360
  685.  
  686.  
  687. C ********************************************************************
  688. C SYNTAXE 'COMPRIS'
  689. C ********************************************************************
  690.  
  691. * on recycle l operateur COMPRIS 01/2000 kich
  692.       CALL ECROBJ('MAILLAGE',MELEME)
  693.       CALL COMPRI
  694.       RETURN
  695.  
  696. C ********************************************************************
  697. C ********************************************************************
  698.  
  699.  
  700. C ********************************************************************
  701. C SYNTAXE 'ZONE'
  702. C ********************************************************************
  703.  
  704.  360     CONTINUE
  705.       SEGACT,MELEME
  706.       NBSOUS=LISOUS(/1)
  707.       CALL LIRENT(IZONE,0,IRETOU)
  708.       IF (IRETOU.NE.0)THEN
  709. *
  710. *         EXTRACTION D'UNE ZONE
  711. *
  712.         IF (NBSOUS.EQ.0.AND.IZONE.EQ.1)THEN
  713.           CALL ECROBJ('MAILLAGE',MELEME)
  714.         ELSEIF(IZONE.LE.NBSOUS)THEN
  715.           CALL ECROBJ('MAILLAGE',LISOUS(IZONE))
  716.         ELSE
  717.           CALL ERREUR(279)
  718.         ENDIF
  719.       ELSE
  720. *
  721. *         NB DE ZONE
  722. *
  723.       IF(NBSOUS.EQ.0)NBSOUS=NBSOUS+1
  724.         CALL ECRENT(NBSOUS)
  725.       ENDIF
  726.       SEGACT,MELEME
  727.       RETURN
  728.  
  729. C ********************************************************************
  730. C ********************************************************************
  731.  
  732.  
  733. C ********************************************************************
  734. C SYNTAXE CHAMP PAR ELEMENT
  735. C ********************************************************************
  736.  
  737.  5000 CONTINUE
  738.       IPCHE  = 0
  739.       IMM    = 0
  740.       IAB    = 0
  741.       IAV    = 0
  742.       ILAST  = 0
  743.       IPLIS  = 0
  744.       VALREF = XZERO
  745.       VALRE2 = XZERO
  746.       IPMAIL = 0
  747.  
  748.       CALL LIROBJ('MCHAML',IPCHE,1,IRET)
  749.       IF (IERR.NE.0) RETURN
  750.       CALL LIRMOT(MOTM,9,IMM,1)
  751.       IF (IERR.NE.0) RETURN
  752.       IF (IMM.GT.2) THEN
  753.         CALL LIRREE(VALREF,1,IRET)
  754.         IF (IERR.NE.0) RETURN
  755.         IF (IMM.EQ.9) THEN
  756.           CALL LIRREE(VALRE2,1,IRET)
  757.           IF (IERR.NE.0) RETURN
  758.         ENDIF
  759.       ENDIF
  760.       CALL LIRMOT(MOABS,1,IAB,0)
  761.       IF (IERR.NE.0) RETURN
  762.       CALL LIRMOT(MOTAV,2,IAV,0)
  763.       IF (IERR.NE.0) RETURN
  764.       IF (IAV.EQ.0) IAV=1
  765. C Lecture de 'STRI' ou 'LARG'  ==> Par defaut c'est LARG (Comme avant)
  766.       CALL LIRMOT(MSCLE,2,ILAST,0)
  767.       IF (IERR.NE.0) RETURN
  768.       IF (ILAST.EQ.0) ILAST=2
  769.       CALL LIROBJ('LISTMOTS',IPLIS,0,IRET)
  770.       IF (IERR.NE.0) RETURN
  771.  
  772.       CALL EXELCH(IPCHE,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,IPMAIL)
  773.       IF (IERR.NE.0 .OR. IPMAIL.EQ.0) RETURN
  774.  
  775.       CALL ECROBJ('MAILLAGE',IPMAIL)
  776.  
  777.       RETURN
  778.  
  779. C ********************************************************************
  780. C ********************************************************************
  781.  
  782.       END
  783.  
  784.  
  785.  
  786.  
  787.  

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