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

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