Télécharger la plaquette Cast3M


fr en

Télécharger inclu3.eso

Retour à la liste

Numérotation des lignes : 

inclu3

  1. C INCLU3    SOURCE    PV        20/03/24    21:18:09     10554          
  2.  
  3.       SUBROUTINE INCLU3(IPT1,IPT2)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMELEME
  11. -INC SMCOORD
  12.  
  13.       SEGMENT ICPR(NNNOE)
  14.       SEGMENT IELOP(IN)
  15.  
  16.       CHARACTER*4 LEMOT(3),LEMO2(1)
  17.       DATA LEMOT / 'STRI','LARG','BARY' /
  18.       DATA LEMO2 / 'NOID' /
  19.  
  20. C*    IF (IDIM.NE.3) THEN
  21. C*      INTERR(1)=IDIM
  22. C*      CALL ERREUR(709)
  23. C*      RETURN
  24. C*    ENDIF
  25.       IDIMP1=IDIM+1
  26.  
  27.       CALL LIRMOT(LEMOT,3,IMSLU,0)
  28.       IF (IMSLU.EQ.0) IMSLU=1
  29.  
  30.       IVERI=0
  31.       CALL LIRMOT(LEMO2,1,IRE2,0)
  32.       IF (IRE2.EQ.1) IVERI=1
  33.  
  34. C CRITERE D'INCLUSION :
  35.       CALL LIRREE(XCRITT,0,IRET)
  36.       IF (IRET.EQ.0) XCRITT=1.E-2
  37.  
  38.       SEGACT,IPT1,IPT2
  39.       IPT1IN=IPT1
  40.       IPT2IN=IPT2
  41.  
  42. *  Conversion de IPT1 en maillage de type POI1
  43. * ---------------------------------------------
  44.       segact mcoord*mod
  45.       NBPTSI=nbpts
  46.       IF (IPT1.ITYPEL .EQ. 1) THEN
  47.         IF (IMSLU.EQ.3) IPT5=IPT1
  48.       ELSE
  49. C* Traitement de l'option 'BARY' :
  50. C* IPT1 contiendra les centres de gravite de IPT1 (dans le meme ordre)
  51.         IF (IMSLU.EQ.3) THEN
  52.           NBPTS=NBPTSI
  53.           NBNN=1
  54.           NBELEM=0
  55.           NBREF=0
  56.           NBSOUS=0
  57.           SEGINI,IPT5
  58.           IPT5.ITYPEL=1
  59.           IGRAV=NBPTSI
  60.           IPT6=IPT1
  61.           NSOU1=IPT6.LISOUS(/1)
  62.           DO i=1,MAX(1,NSOU1)
  63.             IF (NSOU1.NE.0) THEN
  64.               IPT6=IPT1.LISOUS(i)
  65.               SEGACT,IPT6
  66.             ENDIF
  67.             NBELE5=NBELEM
  68.             NBELE1=IPT6.NUM(/2)
  69.             NBELEM=NBELEM+NBELE1
  70.             SEGADJ,IPT5
  71.             NBPTS=NBPTS+NBELE1
  72.             SEGADJ,MCOORD
  73.             NBN1=IPT6.NUM(/1)
  74.             DO j=1,NBELE1
  75.               IGRAV=IGRAV+1
  76.               IPT5.NUM(1,NBELE5+j)=IGRAV
  77.               XP=0.D0
  78.               YP=0.D0
  79.               ZP=0.D0
  80.               DO k=1,NBN1
  81.                 IREF=IPT6.NUM(k,j)*IDIMP1-IDIM
  82.                 XP=XCOOR(IREF)  +XP
  83.                 YP=XCOOR(IREF+1)+YP
  84.                 ZP=XCOOR(IREF+2)+ZP
  85.               ENDDO
  86.               IREF=IGRAV*IDIMP1-IDIM
  87.               XCOOR(IREF  )=XP/FLOAT(NBN1)
  88.               XCOOR(IREF+1)=YP/FLOAT(NBN1)
  89.               XCOOR(IREF+2)=ZP/FLOAT(NBN1)
  90.             ENDDO
  91.             IF (NSOU1.NE.0) SEGDES,IPT6
  92.           ENDDO
  93.           SEGDES,IPT1
  94.           IPT1=IPT5
  95. C* Traitement des options 'STRI' et 'LARG'
  96.         ELSE
  97.           CALL CHANGE(IPT1,1)
  98.         ENDIF
  99.       ENDIF
  100.       NNNOE=IPT1.NUM(/2)
  101. *
  102. *     Conversion de ipt2 en elements de type TET4
  103. *
  104.       IF (IPT2.LISOUS(/1).NE.0) THEN
  105.         IN=IPT2.LISOUS(/1)
  106.         SEGINI IELOP
  107.         NBELEM=0
  108.         DO 36 I=1,IPT2.LISOUS(/1)
  109.           MELEME=IPT2.LISOUS(I)
  110.           SEGACT MELEME
  111.           IF (MELEME.ITYPEL.NE.23) THEN
  112.             CALL CHANGE(MELEME,23)
  113. *      write(6,*) ' inclu3 conv faite'
  114.           ENDIF
  115.           NBELEM=NBELEM+NUM(/2)
  116.           IELOP(I)=MELEME
  117.    36   CONTINUE
  118.         NBNN=4
  119.         NBREF=0
  120.         NBSOUS=0
  121.         SEGINI IPT3
  122.         IA=0
  123.         DO 37 I=1,IPT2.LISOUS(/1)
  124.           MELEME=IELOP(I)
  125.           DO 38 J=1,NUM(/2)
  126.             DO 38 K=1,NUM(/1)
  127.               IPT3.NUM(K,J+IA) = NUM(K,J)
  128.   38      CONTINUE
  129.           IA=IA+NUM(/2)
  130.           SEGDES MELEME
  131.    37   CONTINUE
  132.         IPT3.ITYPEL=23
  133.         IPT2=IPT3
  134.       ELSE
  135.         IF (IPT2.ITYPEL.NE.23) THEN
  136.           CALL CHANGE (IPT2,23)
  137. *      write(6,*) ' inclu3 conv faite'
  138.         ENDIF
  139.       ENDIF
  140.  
  141.       CALL INCLU4(IPT1,IPT2,ICPR,XCRITT)
  142. *     write(6,FMT='(10i6)') (ICPR(IU),IU=1,ICPR(/1))
  143.       IF (IERR.NE.0) GOTO 999
  144.  
  145. C     TEST ET CREATION DU SEGMENT RESULTAT
  146.       NBREF=0
  147.       MELEME=IPT1IN
  148.       SEGACT MELEME
  149.       IPT2=MELEME
  150.       NBSOU=LISOUS(/1)
  151.       IF (NBSOU.NE.0) THEN
  152.         NBNN=0
  153.         NBELEM=0
  154.         NBSOUS=NBSOU
  155.         SEGINI IPT8
  156.         ISO=0
  157.       ENDIF
  158.       IF (IMSLU.EQ.3) THEN
  159.         NBELE5=0
  160.         SEGACT,IPT5
  161.       ENDIF
  162.       DO 270 ISOUS=1,MAX(1,NBSOU)
  163.         IF (NBSOU.NE.0) THEN
  164.           IPT2=LISOUS(ISOUS)
  165.           SEGACT IPT2
  166.         ENDIF
  167.         NBNN=IPT2.NUM(/1)
  168.         NBELEM=IPT2.NUM(/2)
  169.         ICOUNT=0
  170.         DO 250 IEL=1,NBELEM
  171.           IF (IMSLU.EQ.1) THEN
  172.             DO 251 INOEU=1,NBNN
  173.               IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250
  174.  251        CONTINUE
  175.             ICOUNT=ICOUNT+1
  176.           ELSE IF (IMSLU.EQ.2) THEN
  177.             DO 252 INOEU=1,NBNN
  178.               IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253
  179.  252        CONTINUE
  180.             GOTO 250
  181.  253        CONTINUE
  182.             ICOUNT=ICOUNT+1
  183. C*        ELSE IF (IMSLU.EQ.3) THEN
  184.           ELSE
  185.             IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) ICOUNT=ICOUNT+1
  186.           ENDIF
  187.  250    CONTINUE
  188.         NBSOUS=0
  189.         NBREF=0
  190.         NBEL=NBELEM
  191.         NBELEM=ICOUNT
  192.         ICOUNT=1
  193.         IF (NBELEM.EQ.0) GOTO 260
  194.         SEGINI IPT3
  195.         IPT3.ITYPEL=IPT2.ITYPEL
  196.         DO 255 IEL=1,NBEL
  197.           IF (IMSLU.EQ.1) THEN
  198.             DO 256 INOEU=1,NBNN
  199.               IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255
  200.               IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  201.  256        CONTINUE
  202.             IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  203.             ICOUNT=ICOUNT+1
  204.             IF (ICOUNT.GT.NBELEM) GOTO 260
  205.           ELSE IF (IMSLU.EQ.2) THEN
  206.             IOOK=0
  207.             DO 257 INOEU=1,NBNN
  208.               IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1
  209.               IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  210.  257        CONTINUE
  211.             IF (IOOK.EQ.0) GOTO 255
  212.             IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  213.             ICOUNT=ICOUNT+1
  214.             IF (ICOUNT.GT.NBELEM) GOTO 260
  215. C*        ELSE IF (IMSLU.EQ.3) THEN
  216.           ELSE
  217.             IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) THEN
  218.               DO INOEU=1,NBNN
  219.                 IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  220.               ENDDO
  221.               IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  222.               ICOUNT=ICOUNT+1
  223.               IF (ICOUNT.GT.NBELEM) GOTO 260
  224.             ENDIF
  225.           ENDIF
  226.  255    CONTINUE
  227.  
  228. *       Bilan et sauvegarde
  229.  
  230.  260    CONTINUE
  231.         IF (NBSOU.EQ.0) THEN
  232.           IF (NBELEM.EQ.0) THEN
  233.              IF (IVERI.EQ.1) THEN
  234. *               Ecriture d'un maillage vide
  235.                 NBSOUS=0
  236.                 NBREF=0
  237.                 NBNN=0
  238.                 NBELEM=0
  239.                 SEGINI IPT4
  240.                 CALL ECROBJ('MAILLAGE',IPT4)
  241.                 GOTO 999
  242.              ELSE
  243. *              Tache impossible. Probablement données erronées
  244.                CALL ERREUR(26)
  245.                RETURN
  246.              ENDIF
  247.           ENDIF
  248.           GOTO 280
  249.         ENDIF
  250.         IF (IMSLU.EQ.3) NBELE5=NBELE5+NBEL
  251.         IF (NBELEM.NE.0) THEN
  252.           IPT8.LISOUS(ISOUS)=IPT3
  253.           ISO=ISO+1
  254.           SEGDES IPT3
  255.         ENDIF
  256.  270  CONTINUE
  257.  
  258.       IF (ISO.EQ.1) THEN
  259.          SEGSUP IPT8
  260.          GOTO 280
  261.       ENDIF
  262.       IF (ISO.EQ.0) THEN
  263.          SEGSUP IPT8
  264.          IF (IVERI.EQ.1) THEN
  265. *           Ecriture d'un maillage vide
  266.             NBSOUS=0
  267.             NBREF=0
  268.             NBNN=0
  269.             NBELEM=0
  270.             SEGINI IPT4
  271.             CALL ECROBJ('MAILLAGE',IPT4)
  272.             GOTO 999
  273.          ELSE
  274. *          Tache impossible. Probablement données erronées
  275.            CALL ERREUR(26)
  276.            RETURN
  277.          ENDIF
  278.       ENDIF
  279.       IPT3=IPT8
  280.       IF (ISO.EQ.NBSOU) GOTO 280
  281.       NBSOUS=ISO
  282.       NBREF=0
  283.       NBNN=0
  284.       NBELEM=0
  285.       SEGINI IPT4
  286.       ISO=0
  287.       DO 275 IS=1,NBSOU
  288.         IF (IPT3.LISOUS(IS).EQ.0) GOTO 275
  289.         ISO=ISO+1
  290.         IPT4.LISOUS(ISO)=IPT3.LISOUS(IS)
  291.  275  CONTINUE
  292.       IF (ISO.EQ.0) THEN
  293.         NBSOUS=0
  294.         NBREF=0
  295.         NBNN=0
  296.         NBELEM=0
  297.         SEGINI IPT4
  298.         CALL ECROBJ('MAILLAGE',IPT4)
  299.         GOTO 999
  300.       ENDIF
  301.       SEGSUP IPT3
  302.       IPT3=IPT4
  303.  280  CONTINUE
  304.       SEGDES IPT3
  305.       CALL ECROBJ('MAILLAGE',IPT3)
  306.  
  307.  999  CONTINUE
  308. ***   IF (IPT1IN.NE.IPT1) SEGSUP,IPT1
  309.       SEGSUP,ICPR
  310.       IPT1=IPT1IN
  311.       IPT2=IPT2IN
  312.       SEGDES,IPT1,IPT2
  313.       IF (IMSLU.EQ.3) THEN
  314.         NBPTS=NBPTSI
  315.         SEGADJ,MCOORD
  316.       ENDIF
  317.  
  318.       RETURN
  319.       END
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329.  

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