Télécharger la plaquette Cast3M


fr en

Télécharger monl.eso

Retour à la liste

Numérotation des lignes : 

monl

  1. C MONL      SOURCE    BP208322  16/11/18    21:19:28     9177           
  2. C  MODI NOMMER UN ELEMENT
  3. C
  4.       SUBROUTINE MONL(XPROJ,IVU,ICPR,IPTZ)
  5.       IMPLICIT INTEGER(I-N)
  6. -INC CCREEL
  7. -INC SMELEME
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCGEOME
  12.       DIMENSION XTR(40),YTR(40),ztr(40)
  13.       CHARACTER*8 ZONE
  14.       CHARACTER*19 LEGEND(3)
  15.       COMMON/CMODI/LIGMAX,XDEC,YDEC
  16.       SEGMENT IVU(0)
  17.       SEGMENT XPROJ(3,0)
  18.       SEGMENT ICPR(0)
  19.       SEGMENT ISOM(NBSO)
  20.       do i=1,40
  21.         ztr(i)=0
  22.       enddo
  23.       IPT1=IPTZ
  24.       XDPR=XDEC**2
  25.  11   CONTINUE
  26.       LEGEND(1)=' '
  27.       LEGEND(2)='Element du maillage'
  28.       LEGEND(3)='Element du contour'
  29.       CALL MENU(LEGEND,3,19)
  30.       CALL TRAFF(ICLE)
  31.       IF (ICLE.NE.1.AND.ICLE.NE.2) GOTO 11
  32.       IF (ICLE.EQ.2) THEN
  33.          CALL ECROBJ('MAILLAGE',IPT1)
  34.          CALL PRCONT
  35.          CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  36.          IF (IERR.NE.0) RETURN
  37. *  REACTIVONS LE  MAILLAGE A TOUT HASARD
  38.          SEGACT IPT1
  39.          DO 101 I=1,IPT1.LISOUS(/1)
  40.             IPT2=IPT1.LISOUS(I)
  41.             SEGACT IPT2
  42.  101     CONTINUE
  43.          SEGACT MELEME
  44.          NBELEM=NUM(/2)
  45.          NBNN=NUM(/1)
  46.          CALL CHCOUL(1)
  47.          ICOUR=0
  48.          ITR=1
  49.          DO 10 J=1,NBELEM
  50.             DO 20 I=1,NBNN-1
  51.                IP=ICPR(NUM(I,J))
  52.                IP1=ICPR(NUM(I+1,J))
  53.                IF (IVU(IP).NE.1) GOTO 20
  54.                IF (IVU(IP1).NE.1) GOTO 20
  55.                IF (ICOUR.NE.IP) THEN
  56.                   IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  57.                   ITR=1
  58.                   XTR(1)=XPROJ(1,IP)
  59.                   YTR(1)=XPROJ(2,IP)
  60.                ENDIF
  61.                ITR=ITR+1
  62.                XTR(ITR)=XPROJ(1,IP1)
  63.                YTR(ITR)=XPROJ(2,IP1)
  64.                IF (ITR.EQ.40) THEN
  65.                   CALL POLRL(ITR,XTR,YTR,ZTR)
  66.                   XTR(1)=XTR(ITR)
  67.                   YTR(1)=YTR(ITR)
  68.                   ITR=1
  69.                ENDIF
  70.                ICOUR=IP1
  71.  20         CONTINUE
  72.  10      CONTINUE
  73.          CALL POLRL(ITR,XTR,YTR,ZTR)
  74.          ITR=1
  75.  40      CONTINUE
  76.          CALL TRMESS('Pointez la premiere extremite')
  77.          CALL MOPF3
  78.          CALL TRDIG(X,Y,INCLE)
  79.          IF (INCLE.EQ.3) RETURN
  80.          DO 80 IL=1,NUM(/2)
  81.             IPT=NUM(1,IL)
  82.             IP=ICPR(IPT)
  83.             IF (IVU(IP).NE.1) GOTO 80
  84.             IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 30
  85.  80      CONTINUE
  86.          GOTO 40
  87.  30      IP1 = IPT
  88.  70      CONTINUE
  89.          CALL TRMESS('Pointez la deuxieme extremite')
  90.          CALL MOPF3
  91.          CALL TRDIG(X,Y,INCLE)
  92.          IF (INCLE.EQ.3) RETURN
  93.          DO 50 IL=1,NUM(/2)
  94.             IPT=NUM(1,IL)
  95.             IP=ICPR(IPT)
  96.             IF (IVU(IP).NE.1) GOTO 50
  97.             IF ((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LE.XDPR) GOTO 60
  98.  50      CONTINUE
  99.          GOTO 70
  100.  60      IP2=IPT
  101.          CALL ECROBJ ('POINT   ',IP2)
  102.          CALL ECROBJ ('POINT   ',IP1)
  103.          CALL ECROBJ ('MAILLAGE',MELEME)
  104.          CALL COMPRI
  105.          CALL LIROBJ ( 'MAILLAGE',IPT2,1,IRETOU)
  106.          IF(IERR.NE.0) RETURN
  107.          SEGDES MELEME
  108.          MELEME=IPT2
  109.          SEGACT MELEME
  110.          NBELEM=NUM(/2)
  111.          NBNN=NUM(/1)
  112.          CALL CHCOUL(6)
  113.          ICOUR=0
  114.          ITR=1
  115.          DO 100 J=1,NBELEM
  116.             DO 110 I=1,NBNN-1
  117.                IP=ICPR(NUM(I,J))
  118.                IP1=ICPR(NUM(I+1,J))
  119.                IF (IVU(IP).NE.1) GOTO 110
  120.                IF (IVU(IP1).NE.1) GOTO 110
  121.                IF (ICOUR.NE.IP) THEN
  122.                   IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  123.                   ITR=1
  124.                   XTR(1)=XPROJ(1,IP)
  125.                   YTR(1)=XPROJ(2,IP)
  126.                ENDIF
  127.                ITR=ITR+1
  128.                XTR(ITR)=XPROJ(1,IP1)
  129.                YTR(ITR)=XPROJ(2,IP1)
  130.                IF (ITR.EQ.40) THEN
  131.                   CALL POLRL(ITR,XTR,YTR,ZTR)
  132.                   XTR(1)=XTR(ITR)
  133.                   YTR(1)=YTR(ITR)
  134.                   ITR=1
  135.                ENDIF
  136.                ICOUR=IP1
  137.  110        CONTINUE
  138.  100     CONTINUE
  139.          CALL POLRL(ITR,XTR,YTR,ZTR)
  140.          ITR=1
  141.          CALL TRGET('Donnez un nom si necessaire :',ZONE)
  142.          IF (ZONE(1:1).EQ.' ') THEN
  143.             SEGSUP MELEME
  144.             RETURN
  145.          ENDIF
  146.          CALL NOMOBJ('MAILLAGE',ZONE,MELEME)
  147.          RETURN
  148.       ENDIF
  149. *  RECHERCHE D'ELEMENT
  150.       IPPT=0
  151.       IEEL=0
  152. *  ON CREE UN RESULTAT VIDE POUR RECEUILLIR LES ELEMENTS DESIGNES
  153.       NBNN=0
  154.       NBELEM=0
  155.       NBSOUS=0
  156.       NBREF=0
  157.       SEGINI IPT8
  158.       MELEME=IPT1
  159.       CALL TRMESS('Pointez les elements a nommer. Pointez 2 fois le '
  160.      #     //'meme pour terminer')
  161.  400  CONTINUE
  162.       CALL TRDIG(XP,YP,INCLE)
  163.       IF (INCLE.EQ.3) GOTO 650
  164.       IPT1=MELEME
  165.       SEGACT IPT1
  166.       DO 220 IO=1,MAX(1,LISOUS(/1))
  167.          IF (LISOUS(/1).NE.0) THEN
  168.             IPT1=LISOUS(IO)
  169.             SEGACT IPT1
  170.          ENDIF
  171.          NBNN=IPT1.NUM(/1)
  172.          IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 260
  173. *  C'EST UNE LIGNE
  174.          DO 240 J=1,IPT1.NUM(/2)
  175.             IA=ICPR(IPT1.NUM(1,J))
  176.             IB=ICPR(IPT1.NUM(NBNN,J))
  177.             IF (IVU(IA).NE.1) GOTO 240
  178.             IF (IVU(IB).NE.1) GOTO 240
  179.             XA=XPROJ(1,IA)
  180.             YA=XPROJ(2,IA)
  181.             XB=XPROJ(1,IB)
  182.             YB=XPROJ(2,IB)
  183.             SCA=(XP-XA)*(XP-XB)+(YP-YA)*(YP-YB)
  184.             IF (SCA.LE.0.) GOTO 500
  185.  240     CONTINUE
  186.          GOTO 1000
  187.  260     IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 1000
  188. *  C'EST UNE SURFACE
  189.          NBSO = NBSOM(IPT1.ITYPEL)
  190.          IF (NBSO.EQ.0) THEN
  191. C       Polygone a N cotes
  192.             NBSO = IPT1.NUM(/1)
  193.          ENDIF
  194.          SEGINI ISOM
  195.          DO 261 I=1,ISOM(/1)
  196.             ISOM(I)=IBSOM(NSPOS(IPT1.ITYPEL)-1+I)
  197.  261     CONTINUE
  198.          DO 262 J=1,IPT1.NUM(/2)
  199.             I1=ICPR(IPT1.NUM(ISOM(1),J))
  200.             I2=ICPR(IPT1.NUM(ISOM(2),J))
  201.             I3=ICPR(IPT1.NUM(ISOM(3),J))
  202.             IF (IVU(I1).NE.1) GOTO 262
  203.             IF (IVU(I2).NE.1) GOTO 262
  204.             IF (IVU(I3).NE.1) GOTO 262
  205.             X1=XPROJ(1,I1)
  206.             X2=XPROJ(1,I2)
  207.             X3=XPROJ(1,I3)
  208.             Y1=XPROJ(2,I1)
  209.             Y2=XPROJ(2,I2)
  210.             Y3=XPROJ(2,I3)
  211.             Z1=0.
  212.             Z2=0.
  213.             Z3=0.
  214.             XNORM=(Y2-Y1)*(Z2-Z3)-(Z2-Z1)*(Y2-Y3)
  215.             YNORM=(Z2-Z1)*(X2-X3)-(X2-X1)*(Z2-Z3)
  216.             ZNORM=(X2-X1)*(Y2-Y3)-(Y2-Y1)*(X2-X3)
  217.             DNORM=SQRT(XNORM**2+YNORM**2+ZNORM**2)
  218.             XNORM=XNORM/DNORM
  219.             YNORM=YNORM/DNORM
  220.             ZNORM=ZNORM/DNORM
  221.             ANG=0.
  222.             I1=ICPR(IPT1.NUM(ISOM(ISOM(/1)),J))
  223.             XV1=XPROJ(1,I1)-XP
  224.             YV1=XPROJ(2,I1)-YP
  225.             ZV1=0.
  226.             DO 263 IS=1,ISOM(/1)
  227.                I2=ICPR(IPT1.NUM(ISOM(IS),J))
  228.                XV2=XPROJ(1,I2)-XP
  229.                YV2=XPROJ(2,I2)-YP
  230.                ZV2=0.
  231.                XATA=XNORM*(YV1*ZV2-ZV1*YV2)+YNORM*(ZV1*XV2-XV1*ZV2)+
  232.      #              ZNORM*(XV1*YV2-YV1*XV2)
  233.                YATA=XV1*XV2+YV1*YV2+ZV1*ZV2
  234.                IF (XATA.EQ.0..AND.YATA.EQ.0.) GOTO 500
  235.                ANG=ANG+ATAN2(XATA,YATA)
  236.                XV1=XV2
  237.                YV1=YV2
  238.                ZV1=ZV2
  239.  263        CONTINUE
  240.             IF (ABS(ANG).GT.XPI) GOTO 500
  241.  262     CONTINUE
  242.          SEGSUP ISOM
  243.  1000    CONTINUE
  244.  220  CONTINUE
  245. * ON N'A PAS TROUVE ON RECOMMENCE
  246.       GOTO 400
  247. * ON A TROUVE ON DESSINE L'ELEMENT EN REDUIT ET EN ROSE
  248.  500  CONTINUE
  249.       IEL=J
  250.       IF (IPT1.EQ.IPPT.AND.IEL.EQ.IEEL) GOTO 650
  251.       IPPT=IPT1
  252.       IEEL=IEL
  253.       XECLAT=0.8
  254.       CALL CHCOUL(1)
  255.       K=IPT1.ITYPEL
  256.       IDEP=LPT(K)
  257.       IFIN=IDEP+2*LPL(K)-2
  258.       IFIN2=IFIN
  259.       IF (LPL(K).EQ.0.AND.LPT(K).NE.0)THEN
  260. C       Polygone
  261.          IFIN =IDEP+2*IPT1.NUM(/1)-2
  262.          IFIN2=IFIN -2
  263.       ENDIF
  264.       I=IEL
  265.       XG=0.
  266.       YG=0.
  267.       N=IPT1.NUM(/1)
  268.       DO 510 J=1,N
  269.          XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I)))
  270.          YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I)))
  271.  510  CONTINUE
  272.       XG=XG/N
  273.       YG=YG/N
  274.       I3=0
  275.       ITR=1
  276.       DO 520 J=IDEP,IFIN,2
  277.          IF (J.LE.IFIN2) THEN
  278.             I1=ICPR(IPT1.NUM(KSEGM(J),I))
  279.             I2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  280.          ELSE
  281.             I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  282.             I2=ICPR(IPT1.NUM(KSEGM(1),I))
  283.          ENDIF
  284.          XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  285.          YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  286.          IF (I1.NE.I3) THEN
  287.             IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  288.             ITR=1
  289.             XTR(ITR)=XR
  290.             YTR(ITR)=YR
  291.          ENDIF
  292.          XR=XG+(XPROJ(1,I2)-XG)*XECLAT
  293.          YR=YG+(XPROJ(2,I2)-YG)*XECLAT
  294.          ITR=ITR+1
  295.          XTR(ITR)=XR
  296.          YTR(ITR)=YR
  297.          I3=I2
  298.  520  CONTINUE
  299.       IF (ITR.GT.1)  CALL POLRL(ITR,XTR,YTR,ZTR)
  300.       ITR=1
  301. *  ON MET DANS LE RESULTAT
  302.       ITYP=IPT1.ITYPEL
  303.  630  CONTINUE
  304.       DO 600 IO=1,IPT8.LISOUS(/1)
  305.          IPT2=IPT8.LISOUS(IO)
  306.          IF (ITYP.NE.IPT2.ITYPEL) GOTO 600
  307.          NBNN=IPT2.NUM(/1)
  308.          NBSOUS=0
  309.          NBREF=0
  310.          NBELEM=IPT2.NUM(/2)+1
  311.          SEGADJ IPT2
  312.          DO 610 I=1,NBNN
  313.             IPT2.NUM(I,NBELEM)=IPT1.NUM(I,IEL)
  314.  610     CONTINUE
  315.          IPT2.ICOLOR(NBELEM)=IPT1.ICOLOR(NBELEM)
  316.          GOTO 620
  317.  600  CONTINUE
  318.       NBNN=IPT1.NUM(/1)
  319.       NBELEM=0
  320.       NBREF=0
  321.       NBSOUS=0
  322.       SEGINI IPT2
  323.       IPT2.ITYPEL=IPT1.ITYPEL
  324.       NBNN=0
  325.       NBELEM=0
  326.       NBREF=0
  327.       NBSOUS=IPT8.LISOUS(/1)+1
  328.       SEGADJ IPT8
  329.       IPT8.LISOUS(NBSOUS)=IPT2
  330.       GOTO 630
  331. *  OK ON PEUT CONTINUER
  332.  620  CONTINUE
  333.       GOTO 400
  334.  650  CONTINUE
  335. *  SI UN SEUL SOUS-OBJET ON SIMPLIFIE LA STRUCTURE
  336.       IF (IPT8.LISOUS(/1).EQ.1) THEN
  337.          IPT7=IPT8
  338.          IPT8=IPT7.LISOUS(1)
  339.          SEGSUP IPT7
  340.       ENDIF
  341.       IF (IPT8.NUM(/2).EQ.0) THEN
  342.          SEGSUP IPT8
  343.          RETURN
  344.       ENDIF
  345. *  ON DEMANDE LE NOM
  346.       CALL TRGET('Donnez un nom si necessaire:',ZONE)
  347.       IF (ZONE(1:1).EQ.' ') THEN
  348.          SEGSUP IPT8
  349.          RETURN
  350.       ENDIF
  351.       CALL NOMOBJ('MAILLAGE',ZONE,IPT8)
  352.       RETURN
  353.       END
  354.  
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  
  367.  
  368.  
  369.  
  370.  
  371.  

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