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

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