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    CB215821  26/08/24    21:17:21     12622          
  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 821 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.   821 CONTINUE
  66.   40  CONTINUE
  67.   30  CONTINUE
  68.       ENDIF
  69.       NBELEM=0
  70.       NBSOUS=0
  71.       NBREF=0
  72.       NBNN=NBNNE(ICLE)
  73.       SEGINI IPT8
  74.       IPT8.ITYPEL=ICLE
  75.  100  CONTINUE
  76.       CALL TRMESS('Pointez les points de l''element')
  77.       NBELEM=NBELEM+1
  78.       SEGADJ IPT8
  79.       CALL CHCOUL(5)
  80.       DO 110 I=1,NBNN
  81.       CALL TRDIG(X,Y,INCLE)
  82.       IF (INCLE.EQ.3) GOTO 141
  83.        DO 120 IP=1,ITE
  84.         IF (IVU(IP).NE.1) GOTO 120
  85.         IF((X-XPROJ(1,IP))**2+(Y-XPROJ(2,IP))**2.LT.XPR) GOTO 130
  86.  120   CONTINUE
  87.        ITE=ITE+1
  88.        SEGADJ XPROJ
  89.        XPROJ(1,ITE)=X
  90.        XPROJ(2,ITE)=Y
  91.        XPROJ(3,ITE)=TTEMP
  92.        XCOOR(**)=X
  93.        XCOOR(**)=Y
  94.        IF (IDIM.EQ.3) XCOOR(**)=TTEMP
  95.        XCOOR(**)=DENSIT
  96.        nbpts=nbpts+1
  97.        IP=ITE
  98.        ICPR(**)=ITE
  99.        III=ICPR(/1)
  100.        IDCP(**)=III
  101.        IVU(**)=1
  102.        IMILL(**)=0
  103.        CALL PROMOD(ICPR,XPROJ,III,4,IBOUJ)
  104.  130   CONTINUE
  105.       call insegt(3,iresu)
  106.       TTEMP=XPROJ(3,IP)
  107.        XTR(I)=XPROJ(1,IP)
  108.        YTR(I)=XPROJ(2,IP)
  109.        IF (I.NE.1) CALL POLRL(2,XTR(I-1),YTR(I-1),ZTR)
  110.       IF (I.EQ.NBNN.AND.IPT8.ITYPEL.GT.3) THEN
  111.        XTR(2)=XTR(I)
  112.        YTR(2)=YTR(I)
  113.        CALL POLRL(2,XTR,YTR,ZTR)
  114.       ENDIF
  115.       IPT8.NUM(I,NBELEM)=IDCP(IP)
  116.  110  CONTINUE
  117.       IPT8.ICOLOR(NBELEM)=IDCOUL
  118.       CALL CHCOUL(IDNOIR)
  119.       DO 140 I=1,NBNN
  120.        IPR=ICPR(IPT8.NUM(I,NBELEM))
  121.        XTR(1)=XPROJ(1,IPR)
  122.        YTR(1)=XPROJ(2,IPR)
  123.        XTR(2)=XPROJ(1,IPR)
  124.        YTR(2)=XPROJ(2,IPR)
  125.        CALL POLRL(2,XTR,YTR,ZTR)
  126.        IMILL(IPR)=1
  127.  140  CONTINUE
  128.  141  CONTINUE
  129.       LEGEND(1)=' '
  130.       LEGEND(2)='Fin'
  131.       LEGEND(3)='Cont'
  132.       CALL MENU(LEGEND,3,4)
  133.       CALL TRMESS('Fin pour arreter la definition d''elements')
  134.       CALL TRAFF(IREP)
  135.       IF (IREP.NE.1) GOTO 100
  136.       CALL TRGET
  137.      * ('Donnez si necessaire un nom aux elements crees :',ZONE)
  138.       IF (ZONE(1:1).NE.' ') THEN
  139.        CALL NOMOBJ('MAILLAGE',ZONE,IPT8)
  140.       ENDIF
  141.       LEGEND(1)=' '
  142.       LEGEND(2)='Ajou'
  143.       LEGEND(3)='Cont'
  144.       CALL MENU(LEGEND,3,4)
  145.       CALL TRMESS('Ajou pour ajouter le maillage au maillage courant')
  146.       CALL TRAFF(IREP)
  147.       IF (IREP.NE.1) THEN
  148.         SEGDES IPT8
  149.         RETURN
  150.       ENDIF
  151.       IF (LISOUS(/1).EQ.0) THEN
  152.        IF (ITYPEL.EQ.IPT8.ITYPEL) THEN
  153.         NBELE0=NUM(/2)
  154.         NBELE8=IPT8.NUM(/2)
  155.         NBELEM=NBELE0+NBELE8
  156.         NBNN=NUM(/1)
  157.         NBREF=0
  158.         NBSOUS=0
  159.         SEGADJ MELEME
  160.         DO 822 I=NBELE0+1,NBELEM
  161.         ICOLOR(I)=IPT8.ICOLOR(I-NBELE0)
  162.         DO 800 J=1,NBNN
  163.         NUM(J,I)=IPT8.NUM(J,I-NBELE0)
  164.  800    CONTINUE
  165.   822   CONTINUE
  166.         SEGDES IPT8
  167.         RETURN
  168.        ENDIF
  169.        SEGINI,IPT2=MELEME
  170.        NBSOUS=2
  171.        NBREF=0
  172.        NBNN=0
  173.        NBELEM=0
  174.        SEGADJ MELEME
  175.        ITYPEL=0
  176.        LISOUS(1)=IPT2
  177.        LISOUS(2)=IPT8
  178.        RETURN
  179.       ENDIF
  180.       DO 810 IO=1,LISOUS(/1)
  181.       IPT1=LISOUS(IO)
  182.       IF (IPT1.ITYPEL.NE.IPT8.ITYPEL) GOTO 810
  183.         NBELE1=IPT1.NUM(/2)
  184.         NBELE8=IPT8.NUM(/2)
  185.         NBELEM=NBELE1+NBELE8
  186.         NBNN=IPT1.NUM(/1)
  187.         NBREF=0
  188.         NBSOUS=0
  189.         SEGADJ IPT1
  190.         DO 823 I=NBELE1+1,NBELEM
  191.         IPT1.ICOLOR(I)=IPT8.ICOLOR(I-NBELE1)
  192.         DO 820 J=1,NBNN
  193.         IPT1.NUM(J,I)=IPT8.NUM(J,I-NBELE1)
  194.  820    CONTINUE
  195.   823   CONTINUE
  196.         SEGDES IPT8
  197.         RETURN
  198.  810  CONTINUE
  199.       NBELEM=0
  200.       NBREF=0
  201.       NBSOUS=LISOUS(/1)+1
  202.       NBNN=0
  203.       SEGADJ MELEME
  204.       LISOUS(NBSOUS)=IPT8
  205.       END
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  

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