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    CB215821  26/08/24    21:16:51     12622          
  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 1000 J=1,NUM(/2)
  126.             DO 38 K=1,NUM(/1)
  127.               IPT3.NUM(K,J+IA) = NUM(K,J)
  128.   38      CONTINUE
  129.  1000     CONTINUE
  130.           IA=IA+NUM(/2)
  131.           SEGDES MELEME
  132.    37   CONTINUE
  133.         IPT3.ITYPEL=23
  134.         IPT2=IPT3
  135.       ELSE
  136.         IF (IPT2.ITYPEL.NE.23) THEN
  137.           CALL CHANGE (IPT2,23)
  138. *      write(6,*) ' inclu3 conv faite'
  139.         ENDIF
  140.       ENDIF
  141.  
  142.       CALL INCLU4(IPT1,IPT2,ICPR,XCRITT)
  143. *     write(6,FMT='(10i6)') (ICPR(IU),IU=1,ICPR(/1))
  144.       IF (IERR.NE.0) GOTO 999
  145.  
  146. C     TEST ET CREATION DU SEGMENT RESULTAT
  147.       NBREF=0
  148.       MELEME=IPT1IN
  149.       SEGACT MELEME
  150.       IPT2=MELEME
  151.       NBSOU=LISOUS(/1)
  152.       IF (NBSOU.NE.0) THEN
  153.         NBNN=0
  154.         NBELEM=0
  155.         NBSOUS=NBSOU
  156.         SEGINI IPT8
  157.         ISO=0
  158.       ENDIF
  159.       IF (IMSLU.EQ.3) THEN
  160.         NBELE5=0
  161.         SEGACT,IPT5
  162.       ENDIF
  163.       DO 270 ISOUS=1,MAX(1,NBSOU)
  164.         IF (NBSOU.NE.0) THEN
  165.           IPT2=LISOUS(ISOUS)
  166.           SEGACT IPT2
  167.         ENDIF
  168.         NBNN=IPT2.NUM(/1)
  169.         NBELEM=IPT2.NUM(/2)
  170.         ICOUNT=0
  171.         DO 250 IEL=1,NBELEM
  172.           IF (IMSLU.EQ.1) THEN
  173.             DO 251 INOEU=1,NBNN
  174.               IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250
  175.  251        CONTINUE
  176.             ICOUNT=ICOUNT+1
  177.           ELSE IF (IMSLU.EQ.2) THEN
  178.             DO 252 INOEU=1,NBNN
  179.               IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253
  180.  252        CONTINUE
  181.             GOTO 250
  182.  253        CONTINUE
  183.             ICOUNT=ICOUNT+1
  184. C*        ELSE IF (IMSLU.EQ.3) THEN
  185.           ELSE
  186.             IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) ICOUNT=ICOUNT+1
  187.           ENDIF
  188.  250    CONTINUE
  189.         NBSOUS=0
  190.         NBREF=0
  191.         NBEL=NBELEM
  192.         NBELEM=ICOUNT
  193.         ICOUNT=1
  194.         IF (NBELEM.EQ.0) GOTO 260
  195.         SEGINI IPT3
  196.         IPT3.ITYPEL=IPT2.ITYPEL
  197.         DO 255 IEL=1,NBEL
  198.           IF (IMSLU.EQ.1) THEN
  199.             DO 256 INOEU=1,NBNN
  200.               IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255
  201.               IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  202.  256        CONTINUE
  203.             IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  204.             ICOUNT=ICOUNT+1
  205.             IF (ICOUNT.GT.NBELEM) GOTO 260
  206.           ELSE IF (IMSLU.EQ.2) THEN
  207.             IOOK=0
  208.             DO 257 INOEU=1,NBNN
  209.               IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1
  210.               IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  211.  257        CONTINUE
  212.             IF (IOOK.EQ.0) GOTO 255
  213.             IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  214.             ICOUNT=ICOUNT+1
  215.             IF (ICOUNT.GT.NBELEM) GOTO 260
  216. C*        ELSE IF (IMSLU.EQ.3) THEN
  217.           ELSE
  218.             IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) THEN
  219.               DO INOEU=1,NBNN
  220.                 IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
  221.               ENDDO
  222.               IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
  223.               ICOUNT=ICOUNT+1
  224.               IF (ICOUNT.GT.NBELEM) GOTO 260
  225.             ENDIF
  226.           ENDIF
  227.  255    CONTINUE
  228.  
  229. *       Bilan et sauvegarde
  230.  
  231.  260    CONTINUE
  232.         IF (NBSOU.EQ.0) THEN
  233.           IF (NBELEM.EQ.0) THEN
  234.              IF (IVERI.EQ.1) THEN
  235. *               Ecriture d'un maillage vide
  236.                 NBSOUS=0
  237.                 NBREF=0
  238.                 NBNN=0
  239.                 NBELEM=0
  240.                 SEGINI IPT4
  241.                 CALL ECROBJ('MAILLAGE',IPT4)
  242.                 GOTO 999
  243.              ELSE
  244. *              Tache impossible. Probablement données erronées
  245.                CALL ERREUR(26)
  246.                RETURN
  247.              ENDIF
  248.           ENDIF
  249.           GOTO 280
  250.         ENDIF
  251.         IF (IMSLU.EQ.3) NBELE5=NBELE5+NBEL
  252.         IF (NBELEM.NE.0) THEN
  253.           IPT8.LISOUS(ISOUS)=IPT3
  254.           ISO=ISO+1
  255.           SEGDES IPT3
  256.         ENDIF
  257.  270  CONTINUE
  258.  
  259.       IF (ISO.EQ.1) THEN
  260.          SEGSUP IPT8
  261.          GOTO 280
  262.       ENDIF
  263.       IF (ISO.EQ.0) THEN
  264.          SEGSUP IPT8
  265.          IF (IVERI.EQ.1) THEN
  266. *           Ecriture d'un maillage vide
  267.             NBSOUS=0
  268.             NBREF=0
  269.             NBNN=0
  270.             NBELEM=0
  271.             SEGINI IPT4
  272.             CALL ECROBJ('MAILLAGE',IPT4)
  273.             GOTO 999
  274.          ELSE
  275. *          Tache impossible. Probablement données erronées
  276.            CALL ERREUR(26)
  277.            RETURN
  278.          ENDIF
  279.       ENDIF
  280.       IPT3=IPT8
  281.       IF (ISO.EQ.NBSOU) GOTO 280
  282.       NBSOUS=ISO
  283.       NBREF=0
  284.       NBNN=0
  285.       NBELEM=0
  286.       SEGINI IPT4
  287.       ISO=0
  288.       DO 275 IS=1,NBSOU
  289.         IF (IPT3.LISOUS(IS).EQ.0) GOTO 275
  290.         ISO=ISO+1
  291.         IPT4.LISOUS(ISO)=IPT3.LISOUS(IS)
  292.  275  CONTINUE
  293.       IF (ISO.EQ.0) THEN
  294.         NBSOUS=0
  295.         NBREF=0
  296.         NBNN=0
  297.         NBELEM=0
  298.         SEGINI IPT4
  299.         CALL ECROBJ('MAILLAGE',IPT4)
  300.         GOTO 999
  301.       ENDIF
  302.       SEGSUP IPT3
  303.       IPT3=IPT4
  304.  280  CONTINUE
  305.       SEGDES IPT3
  306.       CALL ECROBJ('MAILLAGE',IPT3)
  307.  
  308.  999  CONTINUE
  309. ***   IF (IPT1IN.NE.IPT1) SEGSUP,IPT1
  310.       SEGSUP,ICPR
  311.       IPT1=IPT1IN
  312.       IPT2=IPT2IN
  313.       SEGDES,IPT1,IPT2
  314.       IF (IMSLU.EQ.3) THEN
  315.         NBPTS=NBPTSI
  316.         SEGADJ,MCOORD
  317.       ENDIF
  318.  
  319.       RETURN
  320.       END
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  

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