Télécharger la plaquette Cast3M


fr en

Télécharger mocr.eso

Retour à la liste

Numérotation des lignes : 

mocr

  1. C MOCR      SOURCE    PV        20/03/25    08:13:59     10554          
  2. C   MODI CREATION D'ELEMENT
  3. C
  4.       SUBROUTINE MOCR(XPROJ,IVU,IDCP,MELEME,ICPR,ITE,IMILL,TMIN,IBOUJ)
  5.       IMPLICIT INTEGER(I-N)
  6.       COMMON/CMODI/LIGMAX,XDEC,YDEC
  7. -INC SMELEME
  8.  
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC CCGEOME
  12. -INC SMCOORD
  13.       DIMENSION XTR(10),YTR(10),ZTR(10)
  14.       SEGMENT XPROJ(3,ITE)
  15.       SEGMENT IVU(ITE)
  16.       SEGMENT IDCP(ITE)
  17.       SEGMENT ICPR(0)
  18.       SEGMENT IMILL(ITE)
  19.       SEGMENT IBOUJ(0)
  20.       CHARACTER*4 LEGEND(11)
  21.       CHARACTER*8 ZONE
  22.       do i=1,10
  23.        ztr(i)=0
  24.       enddo
  25.       XPR=XDEC**2
  26.       TTEMP=TMIN
  27.   10  CONTINUE
  28.       CALL TRMESS('Choisissez le type d''element')
  29.       LEGEND(1)=' '
  30.       LEGEND(2)='POI1'
  31.       LEGEND(3)='SEG2'
  32.       LEGEND(4)='SEG3'
  33.       LEGEND(5)='TRI3'
  34.       LEGEND(6)=' '
  35.       LEGEND(7)='TRI6'
  36.       LEGEND(8)=' '
  37.       LEGEND(9)='QUA4'
  38.       LEGEND(10)=' '
  39.       LEGEND(11)='QUA8'
  40.       CALL MENU(LEGEND,11,4)
  41.       CALL TRAFF(ICLE)
  42.       IF (ICLE.NE.2.AND.ICLE.NE.3.AND.ICLE.NE.4.AND.ICLE.NE.6
  43.      # .AND.ICLE.NE.8.AND.ICLE.NE.10.AND.ICLE.NE.1) THEN
  44.       GOTO 10
  45.       ENDIF
  46.       IF (KDEGRE(ICLE).EQ.3) THEN
  47. *  IL FAUT INDIQUER OU SONT LES POINTS MILIEUX
  48.       call insegt(3,iresu)
  49.       CALL CHCOUL(IDNOIR)
  50.       IPT1=MELEME
  51.       DO 30 IO=1,MAX(1,LISOUS(/1))
  52.       IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  53.       IF (KDEGRE(IPT1.ITYPEL).NE.3) GOTO 40
  54.       DO 50 I=1,IPT1.NUM(/1)
  55.       DO 50 J=1,IPT1.NUM(/2)
  56.       IP=ICPR(IPT1.NUM(I,J))
  57.       IF (IMILL(IP).NE.0) GOTO 50
  58.       XTR(1)=XPROJ(1,IP)
  59.       YTR(1)=XPROJ(2,IP)
  60.       XTR(2)=XPROJ(1,IP)
  61.       YTR(2)=XPROJ(2,IP)
  62.       CALL POLRL(2,XTR,YTR,ZTR)
  63.       IMILL(IP)=1
  64.   50  CONTINUE
  65.   40  CONTINUE
  66.   30  CONTINUE
  67.       ENDIF
  68.       NBELEM=0
  69.       NBSOUS=0
  70.       NBREF=0
  71.       NBNN=NBNNE(ICLE)
  72.       SEGINI IPT8
  73.       IPT8.ITYPEL=ICLE
  74.  100  CONTINUE
  75.       CALL TRMESS('Pointez les points de l''element')
  76.       NBELEM=NBELEM+1
  77.       SEGADJ IPT8
  78.       CALL CHCOUL(5)
  79.       DO 110 I=1,NBNN
  80.       CALL TRDIG(X,Y,INCLE)
  81.       IF (INCLE.EQ.3) GOTO 141
  82.        DO 120 IP=1,ITE
  83.         IF (IVU(IP).NE.1) GOTO 120
  84.         IF((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LT.XPR) GOTO 130
  85.  120   CONTINUE
  86.        ITE=ITE+1
  87.        SEGADJ XPROJ
  88.        XPROJ(1,ITE)=X
  89.        XPROJ(2,ITE)=Y
  90.        XPROJ(3,ITE)=TTEMP
  91.        XCOOR(**)=X
  92.        XCOOR(**)=Y
  93.        IF (IDIM.EQ.3) XCOOR(**)=TTEMP
  94.        XCOOR(**)=DENSIT
  95.        nbpts=nbpts+1
  96.        IP=ITE
  97.        ICPR(**)=ITE
  98.        III=ICPR(/1)
  99.        IDCP(**)=III
  100.        IVU(**)=1
  101.        IMILL(**)=0
  102.        CALL PROMOD(ICPR,XPROJ,III,4,IBOUJ)
  103.  130   CONTINUE
  104.       call insegt(3,iresu)
  105.       TTEMP=XPROJ(3,IP)
  106.        XTR(I)=XPROJ(1,IP)
  107.        YTR(I)=XPROJ(2,IP)
  108.        IF (I.NE.1) CALL POLRL(2,XTR(I-1),YTR(I-1),ZTR)
  109.       IF (I.EQ.NBNN.AND.IPT8.ITYPEL.GT.3) THEN
  110.        XTR(2)=XTR(I)
  111.        YTR(2)=YTR(I)
  112.        CALL POLRL(2,XTR,YTR,ZTR)
  113.       ENDIF
  114.       IPT8.NUM(I,NBELEM)=IDCP(IP)
  115.  110  CONTINUE
  116.       IPT8.ICOLOR(NBELEM)=IDCOUL
  117.       CALL CHCOUL(IDNOIR)
  118.       DO 140 I=1,NBNN
  119.        IPR=ICPR(IPT8.NUM(I,NBELEM))
  120.        XTR(1)=XPROJ(1,IPR)
  121.        YTR(1)=XPROJ(2,IPR)
  122.        XTR(2)=XPROJ(1,IPR)
  123.        YTR(2)=XPROJ(2,IPR)
  124.        CALL POLRL(2,XTR,YTR,ZTR)
  125.        IMILL(IPR)=1
  126.  140  CONTINUE
  127.  141  CONTINUE
  128.       LEGEND(1)=' '
  129.       LEGEND(2)='Fin'
  130.       LEGEND(3)='Cont'
  131.       CALL MENU(LEGEND,3,4)
  132.       CALL TRMESS('Fin pour arreter la definition d''elements')
  133.       CALL TRAFF(IREP)
  134.       IF (IREP.NE.1) GOTO 100
  135.       CALL TRGET
  136.      * ('Donnez si necessaire un nom aux elements crees :',ZONE)
  137.       IF (ZONE(1:1).NE.' ') THEN
  138.        CALL NOMOBJ('MAILLAGE',ZONE,IPT8)
  139.       ENDIF
  140.       LEGEND(1)=' '
  141.       LEGEND(2)='Ajou'
  142.       LEGEND(3)='Cont'
  143.       CALL MENU(LEGEND,3,4)
  144.       CALL TRMESS('Ajou pour ajouter le maillage au maillage courant')
  145.       CALL TRAFF(IREP)
  146.       IF (IREP.NE.1) THEN
  147.         SEGDES IPT8
  148.         RETURN
  149.       ENDIF
  150.       IF (LISOUS(/1).EQ.0) THEN
  151.        IF (ITYPEL.EQ.IPT8.ITYPEL) THEN
  152.         NBELE0=NUM(/2)
  153.         NBELE8=IPT8.NUM(/2)
  154.         NBELEM=NBELE0+NBELE8
  155.         NBNN=NUM(/1)
  156.         NBREF=0
  157.         NBSOUS=0
  158.         SEGADJ MELEME
  159.         DO 800 I=NBELE0+1,NBELEM
  160.         ICOLOR(I)=IPT8.ICOLOR(I-NBELE0)
  161.         DO 800 J=1,NBNN
  162.         NUM(J,I)=IPT8.NUM(J,I-NBELE0)
  163.  800    CONTINUE
  164.         SEGDES IPT8
  165.         RETURN
  166.        ENDIF
  167.        SEGINI,IPT2=MELEME
  168.        NBSOUS=2
  169.        NBREF=0
  170.        NBNN=0
  171.        NBELEM=0
  172.        SEGADJ MELEME
  173.        ITYPEL=0
  174.        LISOUS(1)=IPT2
  175.        LISOUS(2)=IPT8
  176.        RETURN
  177.       ENDIF
  178.       DO 810 IO=1,LISOUS(/1)
  179.       IPT1=LISOUS(IO)
  180.       IF (IPT1.ITYPEL.NE.IPT8.ITYPEL) GOTO 810
  181.         NBELE1=IPT1.NUM(/2)
  182.         NBELE8=IPT8.NUM(/2)
  183.         NBELEM=NBELE1+NBELE8
  184.         NBNN=IPT1.NUM(/1)
  185.         NBREF=0
  186.         NBSOUS=0
  187.         SEGADJ IPT1
  188.         DO 820 I=NBELE1+1,NBELEM
  189.         IPT1.ICOLOR(I)=IPT8.ICOLOR(I-NBELE1)
  190.         DO 820 J=1,NBNN
  191.         IPT1.NUM(J,I)=IPT8.NUM(J,I-NBELE1)
  192.  820    CONTINUE
  193.         SEGDES IPT8
  194.         RETURN
  195.  810  CONTINUE
  196.       NBELEM=0
  197.       NBREF=0
  198.       NBSOUS=LISOUS(/1)+1
  199.       NBNN=0
  200.       SEGADJ MELEME
  201.       LISOUS(NBSOUS)=IPT8
  202.       END
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  

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