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    GOUNAND   25/08/04    21:15:09     12340          
  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(4),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','ELEM','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(4),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,3,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.          if (IMSLU.NE.3) THEN
  572.             ITYP1=IPT1.ITYPEL
  573.             IF(ITYP1.NE.1) CALL CHANGE(IPT1,1)
  574.          endif
  575.       ENDIF
  576.       NOVER=0
  577.       CALL LIRMOT(MSCLE(4),1,NOVER,0)
  578.  
  579. C  ON A LU TOUS LES OBJETS DONT ON A BESOIN
  580. C  ON APPELLE ELEMAP POUR FAIRE LE TRAVAIL
  581.       ipt3 = 0
  582. *      write(ioimp,*) 'imslu=',imslu
  583.       if (imslu.ne.3) then
  584.          call elemap(meleme, ipt1, imslu, ipt3, nltot)
  585.       else
  586.          call elemel(meleme, ipt1, ipt3, nltot)
  587. c         write(ioimp,*) 'ipt3,nltot,ierr=',ipt3,nltot,ierr
  588.       endif
  589.  
  590. C  ON VERIFIE QUE TOUT S'EST BIEN PASSE
  591.       if(ierr.eq.0.and.ipt3.ne.0) then
  592.          if(nltot.eq.0.and.nover.eq.0) then
  593.             irr = 1
  594.          else
  595. C  ON ECRIT LE MAILLAGE RESULTAT
  596.             call actobj('MAILLAGE', ipt3,1)
  597.             call ecrobj('MAILLAGE', ipt3)
  598.          endif
  599.       endif
  600.       return
  601.  
  602. C ********************************************************************
  603. C ********************************************************************
  604.  
  605.  330  CONTINUE
  606.       IF(IMLU.NE.3) GOTO 340
  607.  
  608.  
  609. C ********************************************************************
  610. C SYNTAXE 'TYPE'
  611. C ********************************************************************
  612.  
  613.       I1 = meleme.LISOUS(/1)
  614.       JGN=4
  615.       JGM=MAX(1,I1)
  616.       SEGINI MLMOTS
  617.       IF (I1.EQ.0) THEN
  618.         MOTS(1)=NOMS(ITYPEL)
  619.       ELSE
  620.         DO 33 I=1,I1
  621.           IPT2=LISOUS(I)
  622.           SEGACT IPT2
  623.           IDES=IPT2.ITYPEL
  624.           MOTS(I)=NOMS(IDES)
  625.           SEGACT IPT2
  626.  33     CONTINUE
  627.       ENDIF
  628.       SEGACT MLMOTS
  629.       SEGACT,MELEME
  630.       CALL ECROBJ('LISTMOTS',MLMOTS)
  631.       RETURN
  632.  
  633. C ********************************************************************
  634. C ********************************************************************
  635.  
  636.  340  CONTINUE
  637. C
  638. C---- LISTMOTS des COULeurs
  639.       IF(IMLU.NE.4) GOTO 350
  640.  
  641.  
  642. C ********************************************************************
  643. C SYNTAXE 'COUL'
  644. C ********************************************************************
  645.  
  646.       CALL LIRENT(ICOUL,0,IRETOU)
  647.       IF (IERR.NE.0) RETURN
  648.       IF (IRETOU.EQ.1) THEN
  649.         ICOUL = ICOUL-1
  650.         ICOUL = MOD(ICOUL,NBCOUL)
  651.         IF (ICOUL.LT.0) ICOUL = ICOUL+NBCOUL
  652.         ICOUL = ICOUL+1
  653.         GOTO 11
  654.       ENDIF
  655. C
  656.       JG=NBCOUL+1
  657.       SEGINI,MLENTI
  658.       DO IE1=1,NBCOUL+1
  659.          LECT(IE1)=0
  660.       ENDDO
  661.       I1=LISOUS(/1)
  662.       DO IE1=1,MAX(I1,1)
  663.          IF (I1.EQ.0)THEN
  664.             IPT2=MELEME
  665.          ELSE
  666.             IPT2=LISOUS(IE1)
  667.             SEGACT,IPT2
  668.          ENDIF
  669.          DO IE2=1,IPT2.ICOLOR(/1)
  670.             LECT(IPT2.ICOLOR(IE2)+1)=1
  671.          ENDDO
  672. C        SEGACT,IPT2
  673.       ENDDO
  674. C     SEGACT,MELEME
  675. C
  676.       JGN=4
  677.       JGM=0
  678.       DO IE1=1,NBCOUL
  679.          JGM=JGM+LECT(IE1)
  680.       ENDDO
  681.       SEGINI MLMOTS
  682.       JGM=0
  683.       IF (LECT(1).NE.0)THEN
  684.         JGM=JGM+1
  685.         MOTS(JGM)='DEFA'
  686.       ENDIF
  687. C
  688.       DO IE1=2,NBCOUL+1
  689.          IF (LECT(IE1).NE.0)THEN
  690.             JGM=JGM+1
  691.             MOTS(JGM)=NCOUL(IE1-1)
  692.          ENDIF
  693.       ENDDO
  694.       SEGSUP,MLENTI
  695.       SEGACT,MLMOTS
  696.       CALL ECROBJ('LISTMOTS',MLMOTS)
  697.       RETURN
  698.  
  699. C ********************************************************************
  700. C ********************************************************************
  701.  
  702.  350     CONTINUE
  703.  
  704.       IF(IMLU.NE.5) GOTO 360
  705.  
  706.  
  707. C ********************************************************************
  708. C SYNTAXE 'COMPRIS'
  709. C ********************************************************************
  710.  
  711. * on recycle l operateur COMPRIS 01/2000 kich
  712.       CALL ECROBJ('MAILLAGE',MELEME)
  713.       CALL COMPRI
  714.       RETURN
  715.  
  716. C ********************************************************************
  717. C ********************************************************************
  718.  
  719.  
  720. C ********************************************************************
  721. C SYNTAXE 'ZONE'
  722. C ********************************************************************
  723.  
  724.  360     CONTINUE
  725.       SEGACT,MELEME
  726.       NBSOUS=LISOUS(/1)
  727.       CALL LIRENT(IZONE,0,IRETOU)
  728.       IF (IRETOU.NE.0)THEN
  729. *
  730. *         EXTRACTION D'UNE ZONE
  731. *
  732.         IF (NBSOUS.EQ.0.AND.IZONE.EQ.1)THEN
  733.           CALL ECROBJ('MAILLAGE',MELEME)
  734.         ELSEIF(IZONE.LE.NBSOUS)THEN
  735.           CALL ECROBJ('MAILLAGE',LISOUS(IZONE))
  736.         ELSE
  737.           CALL ERREUR(279)
  738.         ENDIF
  739.       ELSE
  740. *
  741. *         NB DE ZONE
  742. *
  743.       IF(NBSOUS.EQ.0)NBSOUS=NBSOUS+1
  744.         CALL ECRENT(NBSOUS)
  745.       ENDIF
  746.       SEGACT,MELEME
  747.       RETURN
  748.  
  749. C ********************************************************************
  750. C ********************************************************************
  751.  
  752.  
  753. C ********************************************************************
  754. C SYNTAXE CHAMP PAR ELEMENT
  755. C ********************************************************************
  756.  
  757.  5000 CONTINUE
  758.       IPCHE  = 0
  759.       IMM    = 0
  760.       IAB    = 0
  761.       IAV    = 0
  762.       ILAST  = 0
  763.       IPLIS  = 0
  764.       VALREF = XZERO
  765.       VALRE2 = XZERO
  766.       IPMAIL = 0
  767.  
  768.       CALL LIROBJ('MCHAML',IPCHE,1,IRET)
  769.       IF (IERR.NE.0) RETURN
  770.       CALL LIRMOT(MOTM,9,IMM,1)
  771.       IF (IERR.NE.0) RETURN
  772.       IF (IMM.GT.2) THEN
  773.         CALL LIRREE(VALREF,1,IRET)
  774.         IF (IERR.NE.0) RETURN
  775.         IF (IMM.EQ.9) THEN
  776.           CALL LIRREE(VALRE2,1,IRET)
  777.           IF (IERR.NE.0) RETURN
  778.         ENDIF
  779.       ENDIF
  780.       CALL LIRMOT(MOABS,1,IAB,0)
  781.       IF (IERR.NE.0) RETURN
  782.       CALL LIRMOT(MOTAV,2,IAV,0)
  783.       IF (IERR.NE.0) RETURN
  784.       IF (IAV.EQ.0) IAV=1
  785. C Lecture de 'STRI' ou 'LARG'  ==> Par defaut c'est LARG (Comme avant)
  786.       CALL LIRMOT(MSCLE,2,ILAST,0)
  787.       IF (IERR.NE.0) RETURN
  788.       IF (ILAST.EQ.0) ILAST=2
  789.       CALL LIROBJ('LISTMOTS',IPLIS,0,IRET)
  790.       IF (IERR.NE.0) RETURN
  791.  
  792.       CALL EXELCH(IPCHE,IMM,IAB,IAV,ILAST,IPLIS,VALREF,VALRE2,IPMAIL)
  793.       IF (IERR.NE.0 .OR. IPMAIL.EQ.0) RETURN
  794.  
  795.       CALL ECROBJ('MAILLAGE',IPMAIL)
  796.  
  797.       RETURN
  798.  
  799. C ********************************************************************
  800. C ********************************************************************
  801.  
  802.       END
  803.  
  804.  

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