Télécharger la plaquette Cast3M


fr en

Télécharger mosu.eso

Retour à la liste

Numérotation des lignes : 

mosu

  1. C MOSU      SOURCE    BP208322  16/11/18    21:19:29     9177           
  2. C  MODI SUPPRESSION D'UN ELEMENT
  3. C
  4.       SUBROUTINE MOSU(XPROJ,IVU,ICPR,MELEME)
  5.       IMPLICIT INTEGER(I-N)
  6. -INC CCREEL
  7. -INC SMELEME
  8. -INC CCGEOME
  9.       COMMON/CMODI/LIGMAX,XDEC,YDEC
  10.       DIMENSION XTR(10),YTR(10),ZTR(10)
  11.       SEGMENT IVU(0)
  12.       SEGMENT XPROJ(3,0)
  13.       SEGMENT ICPR(0)
  14.       SEGMENT ISOM(NBSO)
  15.       do i=1,10
  16.        ztr(i)=0
  17.       enddo
  18.  5    CONTINUE
  19.       CALL TRMESS('POINTEZ L''ELEMENT A SUPPRIMER')
  20.       CALL MOPF3
  21.       CALL TRDIG(XP,YP,INCLE)
  22.       CALL TRMESS(' ')
  23.       IF (INCLE.EQ.3) RETURN
  24.       IPT1=MELEME
  25.       SEGACT IPT1*MOD
  26.       DO 20 IO=1,MAX(1,LISOUS(/1))
  27.          IF (LISOUS(/1).NE.0) THEN
  28.             IPT1=LISOUS(IO)
  29.             SEGACT IPT1*MOD
  30.          ENDIF
  31.          NBNN=IPT1.NUM(/1)
  32.          IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 60
  33. C  C'EST UNE LIGNE
  34.          DO 40 J=1,IPT1.NUM(/2)
  35.             IA=ICPR(IPT1.NUM(1,J))
  36.             IB=ICPR(IPT1.NUM(NBNN,J))
  37.             IF (IVU(IA).NE.1) GOTO 40
  38.             IF (IVU(IB).NE.1) GOTO 40
  39.             XA=XPROJ(1,IA)
  40.             YA=XPROJ(2,IA)
  41.             XB=XPROJ(1,IB)
  42.             YB=XPROJ(2,IB)
  43.             SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB)
  44.             IF (SCA.LE.0.) GOTO 500
  45.  40      CONTINUE
  46.          GOTO 100
  47.  60      IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 100
  48. C  C'EST UNE SURFACE
  49.          NBSO = NBSOM(IPT1.ITYPEL)
  50.          IF (NBSO.EQ.0) THEN
  51. C       Polygone a N cotes
  52.             NBSO = IPT1.NUM(/1)
  53.          ENDIF
  54.          SEGINI ISOM
  55.          DO 61 I=1,ISOM(/1)
  56.             ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I)
  57.  61      CONTINUE
  58.          DO 62 J=1,IPT1.NUM(/2)
  59.             I1=ICPR(IPT1.NUM(ISOM(1),J))
  60.             I2=ICPR(IPT1.NUM(ISOM(2),J))
  61.             I3=ICPR(IPT1.NUM(ISOM(3),J))
  62.             IF (IVU(I1).NE.1) GOTO 62
  63.             IF (IVU(I2).NE.1) GOTO 62
  64.             IF (IVU(I3).NE.1) GOTO 62
  65.             X1=XPROJ(1,I1)
  66.             X2=XPROJ(1,I2)
  67.             X3=XPROJ(1,I3)
  68.             Y1=XPROJ(2,I1)
  69.             Y2=XPROJ(2,I2)
  70.             Y3=XPROJ(2,I3)
  71.             Z1=0.
  72.             Z2=0.
  73.             Z3=0.
  74.             XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3)
  75.             YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3)
  76.             ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3)
  77.             DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2)
  78.             XNORM=XNORM/DNORM
  79.             YNORM=YNORM/DNORM
  80.             ZNORM=ZNORM/DNORM
  81.             ANG=0.
  82.             I1=ICPR(IPT1.NUM(ISOM(ISOM(/1)),J))
  83.             XV1=XPROJ(1,I1)-XP
  84.             YV1=XPROJ(2,I1)-YP
  85.             ZV1=0.
  86.             DO 63 IS=1,ISOM(/1)
  87.                I2=ICPR(IPT1.NUM(ISOM(IS),J))
  88.                XV2=XPROJ(1,I2)-XP
  89.                YV2=XPROJ(2,I2)-YP
  90.                ZV2=0.
  91.                XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+
  92.      #              ZNORM*(XV1*YV2-YV1*XV2)
  93.                YATA=XV1*XV2+YV1*YV2+ZV1*ZV2
  94.                IF (XATA.EQ.0..AND.YATA.EQ.0.) GOTO 500
  95.                ANG=ANG+ATAN2(XATA,YATA)
  96.                XV1=XV2
  97.                YV1=YV2
  98.                ZV1=ZV2
  99.  63         CONTINUE
  100.             IF (ABS(ANG).GT.XPI) GOTO 500
  101.  62      CONTINUE
  102.          SEGSUP ISOM
  103.  100     CONTINUE
  104.  20   CONTINUE
  105. * ON N'A PAS TROUVE ON RECOMMENCE
  106.       GOTO 5
  107. * ON A TROUVE ON DESSINE L'ELEMENT EN REDUIT ET EN ROSE
  108.  500  CONTINUE
  109.       call insegt(3,iresu)
  110.       ITR=1
  111.       XECLAT=0.8
  112.       IEL=J
  113.       CALL CHCOUL(3)
  114.       K=IPT1.ITYPEL
  115.       IDEP=LPT(K)
  116.       IFIN=IDEP+2*LPL(K)-2
  117.       IFIN2=IFIN
  118.       IF (LPL(K).EQ.0.AND.LPT(K).NE.0)THEN
  119. C       Polygone
  120.          IFIN =IDEP+2*IPT1.NUM(/1)-2
  121.          IFIN2=IFIN -2
  122.       ENDIF
  123.       I=IEL
  124.       XG=0.
  125.       YG=0.
  126.       N=IPT1.NUM(/1)
  127.       DO 510 J=1,N
  128.          XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I)))
  129.          YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I)))
  130.  510  CONTINUE
  131.       XG=XG/N
  132.       YG=YG/N
  133.       I3=0
  134.       DO 520 J=IDEP,IFIN,2
  135.          IF (J.LE.IFIN2) THEN
  136.             I1=ICPR(IPT1.NUM(KSEGM(J),I))
  137.             I2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  138.          ELSE
  139.             I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  140.             I2=ICPR(IPT1.NUM(KSEGM(1),I))
  141.          ENDIF
  142.          XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  143.          YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  144.          IF (I1.NE.I3) THEN
  145.             IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  146.             ITR=1
  147.             XTR(ITR)=XR
  148.             YTR(ITR)=YR
  149.          ENDIF
  150.          XR=XG+(XPROJ(1,I2)-XG)*XECLAT
  151.          YR=YG+(XPROJ(2,I2)-YG)*XECLAT
  152.          ITR=ITR+1
  153.          XTR(ITR)=XR
  154.          YTR(ITR)=YR
  155.          I3=I2
  156.  520  CONTINUE
  157.       IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  158. *  DEFINITIF
  159.       IPTSUP=IPT1
  160.       IPT1=MELEME
  161.       DO 610 IO=1,MAX(1,LISOUS(/1))
  162.          IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  163.          IF (IPT1.NE.IPTSUP) GOTO 620
  164.          DO 630 IL=IEL,IPT1.NUM(/2)-1
  165.             DO 640 IN=1,IPT1.NUM(/1)
  166.                IPT1.NUM(IN,IL)=IPT1.NUM(IN,IL+1)
  167.  640        CONTINUE
  168.             IPT1.ICOLOR(IL)=IPT1.ICOLOR(IL+1)
  169.  630     CONTINUE
  170.          NBNN=IPT1.NUM(/1)
  171.          NBELEM=IPT1.NUM(/2)-1
  172.          NBREF=0
  173.          NBSOUS=0
  174.          SEGADJ IPT1
  175.  620     CONTINUE
  176.  610  CONTINUE
  177. *  SUPPRIMER LES SOUS-OBJETS VIDES
  178.       IF (LISOUS(/1).EQ.0) RETURN
  179.       IO1=0
  180.       DO 700 IO=1,LISOUS(/1)
  181.          IPT1=LISOUS(IO)
  182.          IF (IPT1.NUM(/2).EQ.0) THEN
  183.             SEGSUP IPT1
  184.             GOTO 700
  185.          ENDIF
  186.          IO1=IO1+1
  187.          LISOUS(IO1)=LISOUS(IO)
  188.  700  CONTINUE
  189.       NBELEM=0
  190.       NBNN=0
  191.       NBREF=0
  192.       NBSOUS=IO1
  193.       IF (NBSOUS.NE.LISOUS(/1)) SEGADJ MELEME
  194. *  SI UNE SEULE REFERENCE SUPPRIMER LE CHAPEAU
  195.       IF (LISOUS(/1).EQ.1) THEN
  196.          IPT1=LISOUS(1)
  197.          NBELEM=IPT1.NUM(/2)
  198.          NBNN=IPT1.NUM(/1)
  199.          NBSOUS=0
  200.          NBREF=0
  201.          SEGADJ MELEME
  202.          ITYPEL=IPT1.ITYPEL
  203.          DO 731 J=1,NBELEM
  204.             DO 730 I=1,NBNN
  205.                NUM(I,J)=IPT1.NUM(I,J)
  206.  730        CONTINUE
  207.             ICOLOR(J)=IPT1.ICOLOR(J)
  208.  731     CONTINUE
  209.          SEGSUP IPT1
  210.       ENDIF
  211.       END
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  

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